280 SUBROUTINE cgegv( JOBVL, JOBVR, N, A, LDA, B, LDB, ALPHA, BETA,
281 $ VL, LDVL, VR, LDVR, WORK, LWORK, RWORK, INFO )
288 CHARACTER jobvl, jobvr
289 INTEGER info, lda, ldb, ldvl, ldvr, lwork, n
293 COMPLEX a( lda, * ), alpha( * ), b( ldb, * ),
294 $ beta( * ), vl( ldvl, * ), vr( ldvr, * ),
302 parameter( zero = 0.0e0, one = 1.0e0 )
304 parameter( czero = ( 0.0e0, 0.0e0 ),
305 $ cone = ( 1.0e0, 0.0e0 ) )
308 LOGICAL ilimit, ilv, ilvl, ilvr, lquery
310 INTEGER icols, ihi, iinfo, ijobvl, ijobvr, ileft, ilo,
311 $ in, iright, irows, irwork, itau, iwork, jc, jr,
312 $ lopt, lwkmin, lwkopt, nb, nb1, nb2, nb3
313 REAL absai, absar, absb, anrm, anrm1, anrm2, bnrm,
314 $ bnrm1, bnrm2, eps, safmax, safmin, salfai,
315 $ salfar, sbeta, scale, temp
332 INTRINSIC abs, aimag, cmplx, int, max, real
338 abs1( x ) = abs(
REAL( X ) ) + abs( aimag( x ) )
344 IF(
lsame( jobvl,
'N' ) )
THEN 347 ELSE IF(
lsame( jobvl,
'V' ) )
THEN 355 IF(
lsame( jobvr,
'N' ) )
THEN 358 ELSE IF(
lsame( jobvr,
'V' ) )
THEN 369 lwkmin = max( 2*n, 1 )
372 lquery = ( lwork.EQ.-1 )
374 IF( ijobvl.LE.0 )
THEN 376 ELSE IF( ijobvr.LE.0 )
THEN 378 ELSE IF( n.LT.0 )
THEN 380 ELSE IF( lda.LT.max( 1, n ) )
THEN 382 ELSE IF( ldb.LT.max( 1, n ) )
THEN 384 ELSE IF( ldvl.LT.1 .OR. ( ilvl .AND. ldvl.LT.n ) )
THEN 386 ELSE IF( ldvr.LT.1 .OR. ( ilvr .AND. ldvr.LT.n ) )
THEN 388 ELSE IF( lwork.LT.lwkmin .AND. .NOT.lquery )
THEN 393 nb1 =
ilaenv( 1,
'CGEQRF',
' ', n, n, -1, -1 )
394 nb2 =
ilaenv( 1,
'CUNMQR',
' ', n, n, n, -1 )
395 nb3 =
ilaenv( 1,
'CUNGQR',
' ', n, n, n, -1 )
396 nb = max( nb1, nb2, nb3 )
397 lopt = max( 2*n, n*(nb+1) )
402 CALL xerbla(
'CGEGV ', -info )
404 ELSE IF( lquery )
THEN 417 safmin = safmin + safmin
418 safmax = one / safmin
422 anrm =
clange(
'M', n, n, a, lda, rwork )
425 IF( anrm.LT.one )
THEN 426 IF( safmax*anrm.LT.one )
THEN 432 IF( anrm.GT.zero )
THEN 433 CALL clascl(
'G', -1, -1, anrm, one, n, n, a, lda, iinfo )
434 IF( iinfo.NE.0 )
THEN 442 bnrm =
clange(
'M', n, n, b, ldb, rwork )
445 IF( bnrm.LT.one )
THEN 446 IF( safmax*bnrm.LT.one )
THEN 452 IF( bnrm.GT.zero )
THEN 453 CALL clascl(
'G', -1, -1, bnrm, one, n, n, b, ldb, iinfo )
454 IF( iinfo.NE.0 )
THEN 466 CALL cggbal(
'P', n, a, lda, b, ldb, ilo, ihi, rwork( ileft ),
467 $ rwork( iright ), rwork( irwork ), iinfo )
468 IF( iinfo.NE.0 )
THEN 475 irows = ihi + 1 - ilo
483 CALL cgeqrf( irows, icols, b( ilo, ilo ), ldb, work( itau ),
484 $ work( iwork ), lwork+1-iwork, iinfo )
486 $ lwkopt = max( lwkopt, int( work( iwork ) )+iwork-1 )
487 IF( iinfo.NE.0 )
THEN 492 CALL cunmqr(
'L',
'C', irows, icols, irows, b( ilo, ilo ), ldb,
493 $ work( itau ), a( ilo, ilo ), lda, work( iwork ),
494 $ lwork+1-iwork, iinfo )
496 $ lwkopt = max( lwkopt, int( work( iwork ) )+iwork-1 )
497 IF( iinfo.NE.0 )
THEN 503 CALL claset(
'Full', n, n, czero, cone, vl, ldvl )
504 CALL clacpy(
'L', irows-1, irows-1, b( ilo+1, ilo ), ldb,
505 $ vl( ilo+1, ilo ), ldvl )
506 CALL cungqr( irows, irows, irows, vl( ilo, ilo ), ldvl,
507 $ work( itau ), work( iwork ), lwork+1-iwork,
510 $ lwkopt = max( lwkopt, int( work( iwork ) )+iwork-1 )
511 IF( iinfo.NE.0 )
THEN 518 $
CALL claset(
'Full', n, n, czero, cone, vr, ldvr )
526 CALL cgghrd( jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb, vl,
527 $ ldvl, vr, ldvr, iinfo )
529 CALL cgghrd(
'N',
'N', irows, 1, irows, a( ilo, ilo ), lda,
530 $ b( ilo, ilo ), ldb, vl, ldvl, vr, ldvr, iinfo )
532 IF( iinfo.NE.0 )
THEN 545 CALL chgeqz( chtemp, jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb,
546 $ alpha, beta, vl, ldvl, vr, ldvr, work( iwork ),
547 $ lwork+1-iwork, rwork( irwork ), iinfo )
549 $ lwkopt = max( lwkopt, int( work( iwork ) )+iwork-1 )
550 IF( iinfo.NE.0 )
THEN 551 IF( iinfo.GT.0 .AND. iinfo.LE.n )
THEN 553 ELSE IF( iinfo.GT.n .AND. iinfo.LE.2*n )
THEN 575 CALL ctgevc( chtemp,
'B', ldumma, n, a, lda, b, ldb, vl, ldvl,
576 $ vr, ldvr, n, in, work( iwork ), rwork( irwork ),
578 IF( iinfo.NE.0 )
THEN 586 CALL cggbak(
'P',
'L', n, ilo, ihi, rwork( ileft ),
587 $ rwork( iright ), n, vl, ldvl, iinfo )
588 IF( iinfo.NE.0 )
THEN 595 temp = max( temp, abs1( vl( jr, jc ) ) )
601 vl( jr, jc ) = vl( jr, jc )*temp
606 CALL cggbak(
'P',
'R', n, ilo, ihi, rwork( ileft ),
607 $ rwork( iright ), n, vr, ldvr, iinfo )
608 IF( iinfo.NE.0 )
THEN 615 temp = max( temp, abs1( vr( jr, jc ) ) )
621 vr( jr, jc ) = vr( jr, jc )*temp
639 absar = abs(
REAL( ALPHA( JC ) ) )
640 absai = abs( aimag( alpha( jc ) ) )
641 absb = abs(
REAL( BETA( JC ) ) )
642 salfar = anrm*
REAL( ALPHA( JC ) )
643 salfai = anrm*aimag( alpha( jc ) )
644 sbeta = bnrm*
REAL( BETA( JC ) )
650 IF( abs( salfai ).LT.safmin .AND. absai.GE.
651 $ max( safmin, eps*absar, eps*absb ) )
THEN 653 scale = ( safmin / anrm1 ) / max( safmin, anrm2*absai )
658 IF( abs( salfar ).LT.safmin .AND. absar.GE.
659 $ max( safmin, eps*absai, eps*absb ) )
THEN 661 scale = max( scale, ( safmin / anrm1 ) /
662 $ max( safmin, anrm2*absar ) )
667 IF( abs( sbeta ).LT.safmin .AND. absb.GE.
668 $ max( safmin, eps*absar, eps*absai ) )
THEN 670 scale = max( scale, ( safmin / bnrm1 ) /
671 $ max( safmin, bnrm2*absb ) )
677 temp = ( scale*safmin )*max( abs( salfar ), abs( salfai ),
680 $ scale = scale / temp
688 salfar = ( scale*
REAL( ALPHA( JC ) ) )*anrm
689 salfai = ( scale*aimag( alpha( jc ) ) )*anrm
690 sbeta = ( scale*beta( jc ) )*bnrm
692 alpha( jc ) = cmplx( salfar, salfai )
subroutine cggbal(JOB, N, A, LDA, B, LDB, ILO, IHI, LSCALE, RSCALE, WORK, INFO)
CGGBAL
integer function ilaenv(ISPEC, NAME, OPTS, N1, N2, N3, N4)
ILAENV
subroutine clacpy(UPLO, M, N, A, LDA, B, LDB)
CLACPY copies all or part of one two-dimensional array to another.
logical function lsame(CA, CB)
LSAME
subroutine chgeqz(JOB, COMPQ, COMPZ, N, ILO, IHI, H, LDH, T, LDT, ALPHA, BETA, Q, LDQ, Z, LDZ, WORK, LWORK, RWORK, INFO)
CHGEQZ
subroutine xerbla(SRNAME, INFO)
XERBLA
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 cgghrd(COMPQ, COMPZ, N, ILO, IHI, A, LDA, B, LDB, Q, LDQ, Z, LDZ, INFO)
CGGHRD
subroutine ctgevc(SIDE, HOWMNY, SELECT, N, S, LDS, P, LDP, VL, LDVL, VR, LDVR, MM, M, WORK, RWORK, INFO)
CTGEVC
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 cggbak(JOB, SIDE, N, ILO, IHI, LSCALE, RSCALE, M, V, LDV, INFO)
CGGBAK
subroutine cungqr(M, N, K, A, LDA, TAU, WORK, LWORK, INFO)
CUNGQR
subroutine cunmqr(SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, LWORK, INFO)
CUNMQR
real function slamch(CMACH)
SLAMCH
subroutine cgeqrf(M, N, A, LDA, TAU, WORK, LWORK, INFO)
CGEQRF
real function clange(NORM, M, N, A, LDA, WORK)
CLANGE returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute value ...