269 SUBROUTINE cgges( JOBVSL, JOBVSR, SORT, SELCTG, N, A, LDA, B, LDB,
270 $ sdim, alpha, beta, vsl, ldvsl, vsr, ldvsr, work,
271 $ lwork, rwork, bwork, info )
279 CHARACTER JOBVSL, JOBVSR, SORT
280 INTEGER INFO, LDA, LDB, LDVSL, LDVSR, LWORK, N, SDIM
285 COMPLEX A( lda, * ), ALPHA( * ), B( ldb, * ),
286 $ beta( * ), vsl( ldvsl, * ), vsr( ldvsr, * ),
298 parameter ( zero = 0.0e0, one = 1.0e0 )
300 parameter ( czero = ( 0.0e0, 0.0e0 ),
301 $ cone = ( 1.0e0, 0.0e0 ) )
304 LOGICAL CURSL, ILASCL, ILBSCL, ILVSL, ILVSR, LASTSL,
306 INTEGER I, ICOLS, IERR, IHI, IJOBVL, IJOBVR, ILEFT,
307 $ ilo, iright, irows, irwrk, itau, iwrk, lwkmin,
309 REAL ANRM, ANRMTO, BIGNUM, BNRM, BNRMTO, EPS, PVSL,
325 EXTERNAL lsame, ilaenv, clange, slamch
334 IF( lsame( jobvsl,
'N' ) )
THEN
337 ELSE IF( lsame( jobvsl,
'V' ) )
THEN
345 IF( lsame( jobvsr,
'N' ) )
THEN
348 ELSE IF( lsame( jobvsr,
'V' ) )
THEN
356 wantst = lsame( sort,
'S' )
361 lquery = ( lwork.EQ.-1 )
362 IF( ijobvl.LE.0 )
THEN
364 ELSE IF( ijobvr.LE.0 )
THEN
366 ELSE IF( ( .NOT.wantst ) .AND. ( .NOT.lsame( sort,
'N' ) ) )
THEN
368 ELSE IF( n.LT.0 )
THEN
370 ELSE IF( lda.LT.max( 1, n ) )
THEN
372 ELSE IF( ldb.LT.max( 1, n ) )
THEN
374 ELSE IF( ldvsl.LT.1 .OR. ( ilvsl .AND. ldvsl.LT.n ) )
THEN
376 ELSE IF( ldvsr.LT.1 .OR. ( ilvsr .AND. ldvsr.LT.n ) )
THEN
388 lwkmin = max( 1, 2*n )
389 lwkopt = max( 1, n + n*ilaenv( 1,
'CGEQRF',
' ', n, 1, n, 0 ) )
390 lwkopt = max( lwkopt, n +
391 $ n*ilaenv( 1,
'CUNMQR',
' ', n, 1, n, -1 ) )
393 lwkopt = max( lwkopt, n +
394 $ n*ilaenv( 1,
'CUNGQR',
' ', n, 1, n, -1 ) )
398 IF( lwork.LT.lwkmin .AND. .NOT.lquery )
403 CALL xerbla(
'CGGES ', -info )
405 ELSE IF( lquery )
THEN
419 smlnum = slamch(
'S' )
420 bignum = one / smlnum
421 CALL slabad( smlnum, bignum )
422 smlnum = sqrt( smlnum ) / eps
423 bignum = one / smlnum
427 anrm = clange(
'M', n, n, a, lda, rwork )
429 IF( anrm.GT.zero .AND. anrm.LT.smlnum )
THEN
432 ELSE IF( anrm.GT.bignum )
THEN
438 $
CALL clascl(
'G', 0, 0, anrm, anrmto, n, n, a, lda, ierr )
442 bnrm = clange(
'M', n, n, b, ldb, rwork )
444 IF( bnrm.GT.zero .AND. bnrm.LT.smlnum )
THEN
447 ELSE IF( bnrm.GT.bignum )
THEN
453 $
CALL clascl(
'G', 0, 0, bnrm, bnrmto, n, n, b, ldb, ierr )
461 CALL cggbal(
'P', n, a, lda, b, ldb, ilo, ihi, rwork( ileft ),
462 $ rwork( iright ), rwork( irwrk ), ierr )
467 irows = ihi + 1 - ilo
471 CALL cgeqrf( irows, icols, b( ilo, ilo ), ldb, work( itau ),
472 $ work( iwrk ), lwork+1-iwrk, ierr )
477 CALL cunmqr(
'L',
'C', irows, icols, irows, b( ilo, ilo ), ldb,
478 $ work( itau ), a( ilo, ilo ), lda, work( iwrk ),
479 $ lwork+1-iwrk, ierr )
485 CALL claset(
'Full', n, n, czero, cone, vsl, ldvsl )
486 IF( irows.GT.1 )
THEN
487 CALL clacpy(
'L', irows-1, irows-1, b( ilo+1, ilo ), ldb,
488 $ vsl( ilo+1, ilo ), ldvsl )
490 CALL cungqr( irows, irows, irows, vsl( ilo, ilo ), ldvsl,
491 $ work( itau ), work( iwrk ), lwork+1-iwrk, ierr )
497 $
CALL claset(
'Full', n, n, czero, cone, vsr, ldvsr )
502 CALL cgghrd( jobvsl, jobvsr, n, ilo, ihi, a, lda, b, ldb, vsl,
503 $ ldvsl, vsr, ldvsr, ierr )
512 CALL chgeqz(
'S', jobvsl, jobvsr, n, ilo, ihi, a, lda, b, ldb,
513 $ alpha, beta, vsl, ldvsl, vsr, ldvsr, work( iwrk ),
514 $ lwork+1-iwrk, rwork( irwrk ), ierr )
516 IF( ierr.GT.0 .AND. ierr.LE.n )
THEN
518 ELSE IF( ierr.GT.n .AND. ierr.LE.2*n )
THEN
534 $
CALL clascl(
'G', 0, 0, anrm, anrmto, n, 1, alpha, n, ierr )
536 $
CALL clascl(
'G', 0, 0, bnrm, bnrmto, n, 1, beta, n, ierr )
541 bwork( i ) = selctg( alpha( i ), beta( i ) )
544 CALL ctgsen( 0, ilvsl, ilvsr, bwork, n, a, lda, b, ldb, alpha,
545 $ beta, vsl, ldvsl, vsr, ldvsr, sdim, pvsl, pvsr,
546 $ dif, work( iwrk ), lwork-iwrk+1, idum, 1, ierr )
556 $
CALL cggbak(
'P',
'L', n, ilo, ihi, rwork( ileft ),
557 $ rwork( iright ), n, vsl, ldvsl, ierr )
559 $
CALL cggbak(
'P',
'R', n, ilo, ihi, rwork( ileft ),
560 $ rwork( iright ), n, vsr, ldvsr, ierr )
565 CALL clascl(
'U', 0, 0, anrmto, anrm, n, n, a, lda, ierr )
566 CALL clascl(
'G', 0, 0, anrmto, anrm, n, 1, alpha, n, ierr )
570 CALL clascl(
'U', 0, 0, bnrmto, bnrm, n, n, b, ldb, ierr )
571 CALL clascl(
'G', 0, 0, bnrmto, bnrm, n, 1, beta, n, ierr )
581 cursl = selctg( alpha( i ), beta( i ) )
584 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 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 cgges(JOBVSL, JOBVSR, SORT, SELCTG, N, A, LDA, B, LDB, SDIM, ALPHA, BETA, VSL, LDVSL, VSR, LDVSR, WORK, LWORK, RWORK, BWORK, INFO)
CGGES computes the eigenvalues, the Schur form, and, optionally, the matrix of Schur vectors for GE ...
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