269 SUBROUTINE zgges( 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
284 DOUBLE PRECISION rwork( * )
285 COMPLEX*16 a( lda, * ), alpha( * ),
b( ldb, * ),
286 $ beta( * ), vsl( ldvsl, * ), vsr( ldvsr, * ),
297 DOUBLE PRECISION zero, one
298 parameter( zero = 0.0d0, one = 1.0d0 )
299 COMPLEX*16 czero, cone
300 parameter( czero = ( 0.0d0, 0.0d0 ),
301 $ cone = ( 1.0d0, 0.0d0 ) )
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 DOUBLE PRECISION anrm, anrmto, bignum, bnrm, bnrmto, eps, pvsl,
314 DOUBLE PRECISION dif( 2 )
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,
'ZGEQRF',
' ', n, 1, n, 0 ) )
390 lwkopt = max( lwkopt, n +
391 $ n*
ilaenv( 1,
'ZUNMQR',
' ', n, 1, n, -1 ) )
393 lwkopt = max( lwkopt, n +
394 $ n*
ilaenv( 1,
'ZUNGQR',
' ', n, 1, n, -1 ) )
398 IF( lwork.LT.lwkmin .AND. .NOT.lquery )
403 CALL
xerbla(
'ZGGES ', -info )
405 ELSE IF( lquery )
THEN
420 bignum = one / smlnum
421 CALL
dlabad( smlnum, bignum )
422 smlnum = sqrt( smlnum ) / eps
423 bignum = one / smlnum
427 anrm =
zlange(
'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
zlascl(
'G', 0, 0, anrm, anrmto, n, n, a, lda, ierr )
442 bnrm =
zlange(
'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
zlascl(
'G', 0, 0, bnrm, bnrmto, n, n,
b, ldb, ierr )
461 CALL
zggbal(
'P', n, a, lda,
b, ldb, ilo, ihi, rwork( ileft ),
462 $ rwork( iright ), rwork( irwrk ), ierr )
467 irows = ihi + 1 - ilo
471 CALL
zgeqrf( irows, icols,
b( ilo, ilo ), ldb, work( itau ),
472 $ work( iwrk ), lwork+1-iwrk, ierr )
477 CALL
zunmqr(
'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
zlaset(
'Full', n, n, czero, cone, vsl, ldvsl )
486 IF( irows.GT.1 )
THEN
487 CALL
zlacpy(
'L', irows-1, irows-1,
b( ilo+1, ilo ), ldb,
488 $ vsl( ilo+1, ilo ), ldvsl )
490 CALL
zungqr( irows, irows, irows, vsl( ilo, ilo ), ldvsl,
491 $ work( itau ), work( iwrk ), lwork+1-iwrk, ierr )
497 $ CALL
zlaset(
'Full', n, n, czero, cone, vsr, ldvsr )
502 CALL
zgghrd( jobvsl, jobvsr, n, ilo, ihi, a, lda,
b, ldb, vsl,
503 $ ldvsl, vsr, ldvsr, ierr )
512 CALL
zhgeqz(
'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
zlascl(
'G', 0, 0, anrm, anrmto, n, 1, alpha, n, ierr )
536 $ CALL
zlascl(
'G', 0, 0, bnrm, bnrmto, n, 1, beta, n, ierr )
541 bwork( i ) = selctg( alpha( i ), beta( i ) )
544 CALL
ztgsen( 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
zggbak(
'P',
'L', n, ilo, ihi, rwork( ileft ),
557 $ rwork( iright ), n, vsl, ldvsl, ierr )
559 $ CALL
zggbak(
'P',
'R', n, ilo, ihi, rwork( ileft ),
560 $ rwork( iright ), n, vsr, ldvsr, ierr )
565 CALL
zlascl(
'U', 0, 0, anrmto, anrm, n, n, a, lda, ierr )
566 CALL
zlascl(
'G', 0, 0, anrmto, anrm, n, 1, alpha, n, ierr )
570 CALL
zlascl(
'U', 0, 0, bnrmto, bnrm, n, n,
b, ldb, ierr )
571 CALL
zlascl(
'G', 0, 0, bnrmto, bnrm, n, 1, beta, n, ierr )
581 cursl = selctg( alpha( i ), beta( i ) )
584 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
LOGICAL function lsame(CA, CB)
LSAME
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
DOUBLE PRECISION function zlange(NORM, M, N, A, LDA, WORK)
ZLANGE returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute value ...
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
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real b(3) integer i
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...
INTEGER function ilaenv(ISPEC, NAME, OPTS, N1, N2, N3, N4)
subroutine zgeqrf(M, N, A, LDA, TAU, WORK, LWORK, INFO)
ZGEQRF VARIANT: left-looking Level 3 BLAS of the algorithm.
DOUBLE PRECISION function dlamch(CMACH)
DLAMCH
subroutine zunmqr(SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, LWORK, INFO)
ZUNMQR
subroutine zggbal(JOB, N, A, LDA, B, LDB, ILO, IHI, LSCALE, RSCALE, WORK, INFO)
ZGGBAL
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 ...