328 SUBROUTINE cggesx( JOBVSL, JOBVSR, SORT, SELCTG, SENSE, N, A, LDA,
329 $ b, ldb, sdim, alpha, beta, vsl, ldvsl, vsr,
330 $ ldvsr, rconde, rcondv, work, lwork, rwork,
331 $ iwork, liwork, bwork, info )
339 CHARACTER JOBVSL, JOBVSR, SENSE, SORT
340 INTEGER INFO, LDA, LDB, LDVSL, LDVSR, LIWORK, LWORK, N,
346 REAL RCONDE( 2 ), RCONDV( 2 ), RWORK( * )
347 COMPLEX A( lda, * ), ALPHA( * ), B( ldb, * ),
348 $ beta( * ), vsl( ldvsl, * ), vsr( ldvsr, * ),
360 parameter ( zero = 0.0e+0, one = 1.0e+0 )
362 parameter ( czero = ( 0.0e+0, 0.0e+0 ),
363 $ cone = ( 1.0e+0, 0.0e+0 ) )
366 LOGICAL CURSL, ILASCL, ILBSCL, ILVSL, ILVSR, LASTSL,
367 $ lquery, wantsb, wantse, wantsn, wantst, wantsv
368 INTEGER I, ICOLS, IERR, IHI, IJOB, IJOBVL, IJOBVR,
369 $ ileft, ilo, iright, irows, irwrk, itau, iwrk,
370 $ liwmin, lwrk, maxwrk, minwrk
371 REAL ANRM, ANRMTO, BIGNUM, BNRM, BNRMTO, EPS, PL,
386 EXTERNAL lsame, ilaenv, clange, slamch
395 IF( lsame( jobvsl,
'N' ) )
THEN
398 ELSE IF( lsame( jobvsl,
'V' ) )
THEN
406 IF( lsame( jobvsr,
'N' ) )
THEN
409 ELSE IF( lsame( jobvsr,
'V' ) )
THEN
417 wantst = lsame( sort,
'S' )
418 wantsn = lsame( sense,
'N' )
419 wantse = lsame( sense,
'E' )
420 wantsv = lsame( sense,
'V' )
421 wantsb = lsame( sense,
'B' )
422 lquery = ( lwork.EQ.-1 .OR. liwork.EQ.-1 )
425 ELSE IF( wantse )
THEN
427 ELSE IF( wantsv )
THEN
429 ELSE IF( wantsb )
THEN
436 IF( ijobvl.LE.0 )
THEN
438 ELSE IF( ijobvr.LE.0 )
THEN
440 ELSE IF( ( .NOT.wantst ) .AND. ( .NOT.lsame( sort,
'N' ) ) )
THEN
442 ELSE IF( .NOT.( wantsn .OR. wantse .OR. wantsv .OR. wantsb ) .OR.
443 $ ( .NOT.wantst .AND. .NOT.wantsn ) )
THEN
445 ELSE IF( n.LT.0 )
THEN
447 ELSE IF( lda.LT.max( 1, n ) )
THEN
449 ELSE IF( ldb.LT.max( 1, n ) )
THEN
451 ELSE IF( ldvsl.LT.1 .OR. ( ilvsl .AND. ldvsl.LT.n ) )
THEN
453 ELSE IF( ldvsr.LT.1 .OR. ( ilvsr .AND. ldvsr.LT.n ) )
THEN
467 maxwrk = n*(1 + ilaenv( 1,
'CGEQRF',
' ', n, 1, n, 0 ) )
468 maxwrk = max( maxwrk, n*( 1 +
469 $ ilaenv( 1,
'CUNMQR',
' ', n, 1, n, -1 ) ) )
471 maxwrk = max( maxwrk, n*( 1 +
472 $ ilaenv( 1,
'CUNGQR',
' ', n, 1, n, -1 ) ) )
476 $ lwrk = max( lwrk, n*n/2 )
483 IF( wantsn .OR. n.EQ.0 )
THEN
490 IF( lwork.LT.minwrk .AND. .NOT.lquery )
THEN
492 ELSE IF( liwork.LT.liwmin .AND. .NOT.lquery)
THEN
498 CALL xerbla(
'CGGESX', -info )
500 ELSE IF (lquery)
THEN
514 smlnum = slamch(
'S' )
515 bignum = one / smlnum
516 CALL slabad( smlnum, bignum )
517 smlnum = sqrt( smlnum ) / eps
518 bignum = one / smlnum
522 anrm = clange(
'M', n, n, a, lda, rwork )
524 IF( anrm.GT.zero .AND. anrm.LT.smlnum )
THEN
527 ELSE IF( anrm.GT.bignum )
THEN
532 $
CALL clascl(
'G', 0, 0, anrm, anrmto, n, n, a, lda, ierr )
536 bnrm = clange(
'M', n, n, b, ldb, rwork )
538 IF( bnrm.GT.zero .AND. bnrm.LT.smlnum )
THEN
541 ELSE IF( bnrm.GT.bignum )
THEN
546 $
CALL clascl(
'G', 0, 0, bnrm, bnrmto, n, n, b, ldb, ierr )
554 CALL cggbal(
'P', n, a, lda, b, ldb, ilo, ihi, rwork( ileft ),
555 $ rwork( iright ), rwork( irwrk ), ierr )
560 irows = ihi + 1 - ilo
564 CALL cgeqrf( irows, icols, b( ilo, ilo ), ldb, work( itau ),
565 $ work( iwrk ), lwork+1-iwrk, ierr )
570 CALL cunmqr(
'L',
'C', irows, icols, irows, b( ilo, ilo ), ldb,
571 $ work( itau ), a( ilo, ilo ), lda, work( iwrk ),
572 $ lwork+1-iwrk, ierr )
578 CALL claset(
'Full', n, n, czero, cone, vsl, ldvsl )
579 IF( irows.GT.1 )
THEN
580 CALL clacpy(
'L', irows-1, irows-1, b( ilo+1, ilo ), ldb,
581 $ vsl( ilo+1, ilo ), ldvsl )
583 CALL cungqr( irows, irows, irows, vsl( ilo, ilo ), ldvsl,
584 $ work( itau ), work( iwrk ), lwork+1-iwrk, ierr )
590 $
CALL claset(
'Full', n, n, czero, cone, vsr, ldvsr )
595 CALL cgghrd( jobvsl, jobvsr, n, ilo, ihi, a, lda, b, ldb, vsl,
596 $ ldvsl, vsr, ldvsr, ierr )
605 CALL chgeqz(
'S', jobvsl, jobvsr, n, ilo, ihi, a, lda, b, ldb,
606 $ alpha, beta, vsl, ldvsl, vsr, ldvsr, work( iwrk ),
607 $ lwork+1-iwrk, rwork( irwrk ), ierr )
609 IF( ierr.GT.0 .AND. ierr.LE.n )
THEN
611 ELSE IF( ierr.GT.n .AND. ierr.LE.2*n )
THEN
627 $
CALL clascl(
'G', 0, 0, anrmto, anrm, n, 1, alpha, n, ierr )
629 $
CALL clascl(
'G', 0, 0, bnrmto, bnrm, n, 1, beta, n, ierr )
634 bwork( i ) = selctg( alpha( i ), beta( i ) )
642 CALL ctgsen( ijob, ilvsl, ilvsr, bwork, n, a, lda, b, ldb,
643 $ alpha, beta, vsl, ldvsl, vsr, ldvsr, sdim, pl, pr,
644 $ dif, work( iwrk ), lwork-iwrk+1, iwork, liwork,
648 $ maxwrk = max( maxwrk, 2*sdim*( n-sdim ) )
649 IF( ierr.EQ.-21 )
THEN
655 IF( ijob.EQ.1 .OR. ijob.EQ.4 )
THEN
659 IF( ijob.EQ.2 .OR. ijob.EQ.4 )
THEN
660 rcondv( 1 ) = dif( 1 )
661 rcondv( 2 ) = dif( 2 )
673 $
CALL cggbak(
'P',
'L', n, ilo, ihi, rwork( ileft ),
674 $ rwork( iright ), n, vsl, ldvsl, ierr )
677 $
CALL cggbak(
'P',
'R', n, ilo, ihi, rwork( ileft ),
678 $ rwork( iright ), n, vsr, ldvsr, ierr )
683 CALL clascl(
'U', 0, 0, anrmto, anrm, n, n, a, lda, ierr )
684 CALL clascl(
'G', 0, 0, anrmto, anrm, n, 1, alpha, n, ierr )
688 CALL clascl(
'U', 0, 0, bnrmto, bnrm, n, n, b, ldb, ierr )
689 CALL clascl(
'G', 0, 0, bnrmto, bnrm, n, 1, beta, n, ierr )
699 cursl = selctg( alpha( i ), beta( i ) )
702 IF( cursl .AND. .NOT.lastsl )
subroutine clascl(TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO)
CLASCL multiplies a general rectangular matrix by a real scalar defined as cto/cfrom.
subroutine cggbal(JOB, N, A, LDA, B, LDB, ILO, IHI, LSCALE, RSCALE, WORK, INFO)
CGGBAL
subroutine slabad(SMALL, LARGE)
SLABAD
subroutine xerbla(SRNAME, INFO)
XERBLA
subroutine cggesx(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)
CGGESX computes the eigenvalues, the Schur form, and, optionally, the matrix of Schur vectors for GE...
subroutine cunmqr(SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, LWORK, INFO)
CUNMQR
subroutine cgghrd(COMPQ, COMPZ, N, ILO, IHI, A, LDA, B, LDB, Q, LDQ, Z, LDZ, INFO)
CGGHRD
subroutine claset(UPLO, M, N, ALPHA, BETA, A, LDA)
CLASET initializes the off-diagonal elements and the diagonal elements of a matrix to given values...
subroutine cgeqrf(M, N, A, LDA, TAU, WORK, LWORK, INFO)
CGEQRF
subroutine cggbak(JOB, SIDE, N, ILO, IHI, LSCALE, RSCALE, M, V, LDV, INFO)
CGGBAK
subroutine chgeqz(JOB, COMPQ, COMPZ, N, ILO, IHI, H, LDH, T, LDT, ALPHA, BETA, Q, LDQ, Z, LDZ, WORK, LWORK, RWORK, INFO)
CHGEQZ
subroutine ctgsen(IJOB, WANTQ, WANTZ, SELECT, N, A, LDA, B, LDB, ALPHA, BETA, Q, LDQ, Z, LDZ, M, PL, PR, DIF, WORK, LWORK, IWORK, LIWORK, INFO)
CTGSEN
subroutine clacpy(UPLO, M, N, A, LDA, B, LDB)
CLACPY copies all or part of one two-dimensional array to another.
subroutine cungqr(M, N, K, A, LDA, TAU, WORK, LWORK, INFO)
CUNGQR