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 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 cggbal(JOB, N, A, LDA, B, LDB, ILO, IHI, LSCALE, RSCALE, WORK, INFO)
CGGBAL
subroutine xerbla(SRNAME, INFO)
XERBLA
subroutine cunmqr(SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, LWORK, INFO)
CUNMQR
subroutine cggbak(JOB, SIDE, N, ILO, IHI, LSCALE, RSCALE, M, V, LDV, INFO)
CGGBAK
subroutine clacpy(UPLO, M, N, A, LDA, B, LDB)
CLACPY copies all or part of one two-dimensional array to another.
subroutine cgghrd(COMPQ, COMPZ, N, ILO, IHI, A, LDA, B, LDB, Q, LDQ, Z, LDZ, INFO)
CGGHRD
subroutine cgeqrf(M, N, A, LDA, TAU, WORK, LWORK, INFO)
CGEQRF
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 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 slabad(SMALL, LARGE)
SLABAD
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 chgeqz(JOB, COMPQ, COMPZ, N, ILO, IHI, H, LDH, T, LDT, ALPHA, BETA, Q, LDQ, Z, LDZ, WORK, LWORK, RWORK, INFO)
CHGEQZ
subroutine cungqr(M, N, K, A, LDA, TAU, WORK, LWORK, INFO)
CUNGQR