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 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 zlacpy(UPLO, M, N, A, LDA, B, LDB)
ZLACPY copies all or part of one two-dimensional array to another.
subroutine zhgeqz(JOB, COMPQ, COMPZ, N, ILO, IHI, H, LDH, T, LDT, ALPHA, BETA, Q, LDQ, Z, LDZ, WORK, LWORK, RWORK, INFO)
ZHGEQZ
subroutine zungqr(M, N, K, A, LDA, TAU, WORK, LWORK, INFO)
ZUNGQR
subroutine xerbla(SRNAME, INFO)
XERBLA
subroutine zggbak(JOB, SIDE, N, ILO, IHI, LSCALE, RSCALE, M, V, LDV, INFO)
ZGGBAK
subroutine dlabad(SMALL, LARGE)
DLABAD
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 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 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 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...
subroutine zggbal(JOB, N, A, LDA, B, LDB, ILO, IHI, LSCALE, RSCALE, WORK, INFO)
ZGGBAL