328 SUBROUTINE zggesx( 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 DOUBLE PRECISION RCONDE( 2 ), RCONDV( 2 ), RWORK( * )
347 COMPLEX*16 A( lda, * ), ALPHA( * ), B( ldb, * ),
348 $ beta( * ), vsl( ldvsl, * ), vsr( ldvsr, * ),
359 DOUBLE PRECISION ZERO, ONE
360 parameter ( zero = 0.0d+0, one = 1.0d+0 )
361 COMPLEX*16 CZERO, CONE
362 parameter ( czero = ( 0.0d+0, 0.0d+0 ),
363 $ cone = ( 1.0d+0, 0.0d+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 DOUBLE PRECISION ANRM, ANRMTO, BIGNUM, BNRM, BNRMTO, EPS, PL,
375 DOUBLE PRECISION DIF( 2 )
385 DOUBLE PRECISION DLAMCH, ZLANGE
386 EXTERNAL lsame, ilaenv, dlamch, zlange
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,
'ZGEQRF',
' ', n, 1, n, 0 ) )
468 maxwrk = max( maxwrk, n*( 1 +
469 $ ilaenv( 1,
'ZUNMQR',
' ', n, 1, n, -1 ) ) )
471 maxwrk = max( maxwrk, n*( 1 +
472 $ ilaenv( 1,
'ZUNGQR',
' ', 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(
'ZGGESX', -info )
500 ELSE IF (lquery)
THEN
514 smlnum = dlamch(
'S' )
515 bignum = one / smlnum
516 CALL dlabad( smlnum, bignum )
517 smlnum = sqrt( smlnum ) / eps
518 bignum = one / smlnum
522 anrm = zlange(
'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 zlascl(
'G', 0, 0, anrm, anrmto, n, n, a, lda, ierr )
536 bnrm = zlange(
'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 zlascl(
'G', 0, 0, bnrm, bnrmto, n, n, b, ldb, ierr )
554 CALL zggbal(
'P', n, a, lda, b, ldb, ilo, ihi, rwork( ileft ),
555 $ rwork( iright ), rwork( irwrk ), ierr )
560 irows = ihi + 1 - ilo
564 CALL zgeqrf( irows, icols, b( ilo, ilo ), ldb, work( itau ),
565 $ work( iwrk ), lwork+1-iwrk, ierr )
570 CALL zunmqr(
'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 zlaset(
'Full', n, n, czero, cone, vsl, ldvsl )
579 IF( irows.GT.1 )
THEN
580 CALL zlacpy(
'L', irows-1, irows-1, b( ilo+1, ilo ), ldb,
581 $ vsl( ilo+1, ilo ), ldvsl )
583 CALL zungqr( irows, irows, irows, vsl( ilo, ilo ), ldvsl,
584 $ work( itau ), work( iwrk ), lwork+1-iwrk, ierr )
590 $
CALL zlaset(
'Full', n, n, czero, cone, vsr, ldvsr )
595 CALL zgghrd( jobvsl, jobvsr, n, ilo, ihi, a, lda, b, ldb, vsl,
596 $ ldvsl, vsr, ldvsr, ierr )
605 CALL zhgeqz(
'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 zlascl(
'G', 0, 0, anrmto, anrm, n, 1, alpha, n, ierr )
629 $
CALL zlascl(
'G', 0, 0, bnrmto, bnrm, n, 1, beta, n, ierr )
634 bwork( i ) = selctg( alpha( i ), beta( i ) )
642 CALL ztgsen( 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 zggbak(
'P',
'L', n, ilo, ihi, rwork( ileft ),
674 $ rwork( iright ), n, vsl, ldvsl, ierr )
677 $
CALL zggbak(
'P',
'R', n, ilo, ihi, rwork( ileft ),
678 $ rwork( iright ), n, vsr, ldvsr, ierr )
683 CALL zlascl(
'U', 0, 0, anrmto, anrm, n, n, a, lda, ierr )
684 CALL zlascl(
'G', 0, 0, anrmto, anrm, n, 1, alpha, n, ierr )
688 CALL zlascl(
'U', 0, 0, bnrmto, bnrm, n, n, b, ldb, ierr )
689 CALL zlascl(
'G', 0, 0, bnrmto, bnrm, n, 1, beta, n, ierr )
699 cursl = selctg( alpha( i ), beta( i ) )
702 IF( cursl .AND. .NOT.lastsl )
subroutine zgghrd(COMPQ, COMPZ, N, ILO, IHI, A, LDA, B, LDB, Q, LDQ, Z, LDZ, INFO)
ZGGHRD
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 zggbak(JOB, SIDE, N, ILO, IHI, LSCALE, RSCALE, M, V, LDV, INFO)
ZGGBAK
subroutine zungqr(M, N, K, A, LDA, TAU, WORK, LWORK, INFO)
ZUNGQR
subroutine zggbal(JOB, N, A, LDA, B, LDB, ILO, IHI, LSCALE, RSCALE, WORK, INFO)
ZGGBAL
subroutine zgeqrf(M, N, A, LDA, TAU, WORK, LWORK, INFO)
ZGEQRF VARIANT: left-looking Level 3 BLAS of the algorithm.
subroutine zunmqr(SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, LWORK, INFO)
ZUNMQR
subroutine xerbla(SRNAME, INFO)
XERBLA
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 dlabad(SMALL, LARGE)
DLABAD
subroutine zhgeqz(JOB, COMPQ, COMPZ, N, ILO, IHI, H, LDH, T, LDT, ALPHA, BETA, Q, LDQ, Z, LDZ, WORK, LWORK, RWORK, INFO)
ZHGEQZ
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 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...