267 SUBROUTINE zgges( JOBVSL, JOBVSR, SORT, SELCTG, N, A, LDA, B, LDB,
268 $ SDIM, ALPHA, BETA, VSL, LDVSL, VSR, LDVSR, WORK,
269 $ LWORK, RWORK, BWORK, INFO )
276 CHARACTER JOBVSL, JOBVSR, SORT
277 INTEGER INFO, LDA, LDB, LDVSL, LDVSR, LWORK, N, SDIM
281 DOUBLE PRECISION RWORK( * )
282 COMPLEX*16 A( LDA, * ), ALPHA( * ), B( LDB, * ),
283 $ beta( * ), vsl( ldvsl, * ), vsr( ldvsr, * ),
294 DOUBLE PRECISION ZERO, ONE
295 PARAMETER ( ZERO = 0.0d0, one = 1.0d0 )
296 COMPLEX*16 CZERO, CONE
297 parameter( czero = ( 0.0d0, 0.0d0 ),
298 $ cone = ( 1.0d0, 0.0d0 ) )
301 LOGICAL CURSL, ILASCL, ILBSCL, ILVSL, ILVSR, LASTSL,
303 INTEGER I, ICOLS, IERR, IHI, IJOBVL, IJOBVR, ILEFT,
304 $ ILO, IRIGHT, IROWS, IRWRK, ITAU, IWRK, LWKMIN,
306 DOUBLE PRECISION ANRM, ANRMTO, BIGNUM, BNRM, BNRMTO, EPS, PVSL,
311 DOUBLE PRECISION DIF( 2 )
321 DOUBLE PRECISION DLAMCH, ZLANGE
322 EXTERNAL lsame, ilaenv, dlamch, zlange
331 IF( lsame( jobvsl,
'N' ) )
THEN
334 ELSE IF( lsame( jobvsl,
'V' ) )
THEN
342 IF( lsame( jobvsr,
'N' ) )
THEN
345 ELSE IF( lsame( jobvsr,
'V' ) )
THEN
353 wantst = lsame( sort,
'S' )
358 lquery = ( lwork.EQ.-1 )
359 IF( ijobvl.LE.0 )
THEN
361 ELSE IF( ijobvr.LE.0 )
THEN
363 ELSE IF( ( .NOT.wantst ) .AND. ( .NOT.lsame( sort,
'N' ) ) )
THEN
365 ELSE IF( n.LT.0 )
THEN
367 ELSE IF( lda.LT.max( 1, n ) )
THEN
369 ELSE IF( ldb.LT.max( 1, n ) )
THEN
371 ELSE IF( ldvsl.LT.1 .OR. ( ilvsl .AND. ldvsl.LT.n ) )
THEN
373 ELSE IF( ldvsr.LT.1 .OR. ( ilvsr .AND. ldvsr.LT.n ) )
THEN
385 lwkmin = max( 1, 2*n )
386 lwkopt = max( 1, n + n*ilaenv( 1,
'ZGEQRF',
' ', n, 1, n, 0 ) )
387 lwkopt = max( lwkopt, n +
388 $ n*ilaenv( 1,
'ZUNMQR',
' ', n, 1, n, -1 ) )
390 lwkopt = max( lwkopt, n +
391 $ n*ilaenv( 1,
'ZUNGQR',
' ', n, 1, n, -1 ) )
395 IF( lwork.LT.lwkmin .AND. .NOT.lquery )
400 CALL xerbla(
'ZGGES ', -info )
402 ELSE IF( lquery )
THEN
416 smlnum = dlamch(
'S' )
417 bignum = one / smlnum
418 CALL dlabad( smlnum, bignum )
419 smlnum = sqrt( smlnum ) / eps
420 bignum = one / smlnum
424 anrm = zlange(
'M', n, n, a, lda, rwork )
426 IF( anrm.GT.zero .AND. anrm.LT.smlnum )
THEN
429 ELSE IF( anrm.GT.bignum )
THEN
435 $
CALL zlascl(
'G', 0, 0, anrm, anrmto, n, n, a, lda, ierr )
439 bnrm = zlange(
'M', n, n, b, ldb, rwork )
441 IF( bnrm.GT.zero .AND. bnrm.LT.smlnum )
THEN
444 ELSE IF( bnrm.GT.bignum )
THEN
450 $
CALL zlascl(
'G', 0, 0, bnrm, bnrmto, n, n, b, ldb, ierr )
458 CALL zggbal(
'P', n, a, lda, b, ldb, ilo, ihi, rwork( ileft ),
459 $ rwork( iright ), rwork( irwrk ), ierr )
464 irows = ihi + 1 - ilo
468 CALL zgeqrf( irows, icols, b( ilo, ilo ), ldb, work( itau ),
469 $ work( iwrk ), lwork+1-iwrk, ierr )
474 CALL zunmqr(
'L',
'C', irows, icols, irows, b( ilo, ilo ), ldb,
475 $ work( itau ), a( ilo, ilo ), lda, work( iwrk ),
476 $ lwork+1-iwrk, ierr )
482 CALL zlaset(
'Full', n, n, czero, cone, vsl, ldvsl )
483 IF( irows.GT.1 )
THEN
484 CALL zlacpy(
'L', irows-1, irows-1, b( ilo+1, ilo ), ldb,
485 $ vsl( ilo+1, ilo ), ldvsl )
487 CALL zungqr( irows, irows, irows, vsl( ilo, ilo ), ldvsl,
488 $ work( itau ), work( iwrk ), lwork+1-iwrk, ierr )
494 $
CALL zlaset(
'Full', n, n, czero, cone, vsr, ldvsr )
499 CALL zgghrd( jobvsl, jobvsr, n, ilo, ihi, a, lda, b, ldb, vsl,
500 $ ldvsl, vsr, ldvsr, ierr )
509 CALL zhgeqz(
'S', jobvsl, jobvsr, n, ilo, ihi, a, lda, b, ldb,
510 $ alpha, beta, vsl, ldvsl, vsr, ldvsr, work( iwrk ),
511 $ lwork+1-iwrk, rwork( irwrk ), ierr )
513 IF( ierr.GT.0 .AND. ierr.LE.n )
THEN
515 ELSE IF( ierr.GT.n .AND. ierr.LE.2*n )
THEN
531 $
CALL zlascl(
'G', 0, 0, anrm, anrmto, n, 1, alpha, n, ierr )
533 $
CALL zlascl(
'G', 0, 0, bnrm, bnrmto, n, 1, beta, n, ierr )
538 bwork( i ) = selctg( alpha( i ), beta( i ) )
541 CALL ztgsen( 0, ilvsl, ilvsr, bwork, n, a, lda, b, ldb, alpha,
542 $ beta, vsl, ldvsl, vsr, ldvsr, sdim, pvsl, pvsr,
543 $ dif, work( iwrk ), lwork-iwrk+1, idum, 1, ierr )
553 $
CALL zggbak(
'P',
'L', n, ilo, ihi, rwork( ileft ),
554 $ rwork( iright ), n, vsl, ldvsl, ierr )
556 $
CALL zggbak(
'P',
'R', n, ilo, ihi, rwork( ileft ),
557 $ rwork( iright ), n, vsr, ldvsr, ierr )
562 CALL zlascl(
'U', 0, 0, anrmto, anrm, n, n, a, lda, ierr )
563 CALL zlascl(
'G', 0, 0, anrmto, anrm, n, 1, alpha, n, ierr )
567 CALL zlascl(
'U', 0, 0, bnrmto, bnrm, n, n, b, ldb, ierr )
568 CALL zlascl(
'G', 0, 0, bnrmto, bnrm, n, 1, beta, n, ierr )
578 cursl = selctg( alpha( i ), beta( i ) )
581 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 zgges(JOBVSL, JOBVSR, SORT, SELCTG, N, A, LDA, B, LDB, SDIM, ALPHA, BETA, VSL, LDVSL, VSR, LDVSR, WORK, LWORK, RWORK, BWORK, INFO)
ZGGES computes the eigenvalues, the Schur form, and, optionally, the matrix of Schur vectors for GE m...
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.