282 SUBROUTINE cgegv( JOBVL, JOBVR, N, A, LDA, B, LDB, ALPHA, BETA,
283 $ vl, ldvl, vr, ldvr, work, lwork, rwork, info )
291 CHARACTER jobvl, jobvr
292 INTEGER info, lda, ldb, ldvl, ldvr, lwork, n
296 COMPLEX a( lda, * ), alpha( * ),
b( ldb, * ),
297 $ beta( * ), vl( ldvl, * ), vr( ldvr, * ),
305 parameter( zero = 0.0e0, one = 1.0e0 )
307 parameter( czero = ( 0.0e0, 0.0e0 ),
308 $ cone = ( 1.0e0, 0.0e0 ) )
311 LOGICAL ilimit, ilv, ilvl, ilvr, lquery
313 INTEGER icols, ihi, iinfo, ijobvl, ijobvr, ileft, ilo,
314 $ in, iright, irows, irwork, itau, iwork, jc, jr,
315 $ lopt, lwkmin, lwkopt, nb, nb1, nb2, nb3
316 REAL absai, absar, absb, anrm, anrm1, anrm2, bnrm,
317 $ bnrm1, bnrm2, eps, safmax, safmin, salfai,
318 $ salfar, sbeta, scale, temp
335 INTRINSIC abs, aimag, cmplx, int, max, real
341 abs1( x ) = abs(
REAL( X ) ) + abs( aimag( x ) )
347 IF(
lsame( jobvl,
'N' ) )
THEN
350 ELSE IF(
lsame( jobvl,
'V' ) )
THEN
358 IF(
lsame( jobvr,
'N' ) )
THEN
361 ELSE IF(
lsame( jobvr,
'V' ) )
THEN
372 lwkmin = max( 2*n, 1 )
375 lquery = ( lwork.EQ.-1 )
377 IF( ijobvl.LE.0 )
THEN
379 ELSE IF( ijobvr.LE.0 )
THEN
381 ELSE IF( n.LT.0 )
THEN
383 ELSE IF( lda.LT.max( 1, n ) )
THEN
385 ELSE IF( ldb.LT.max( 1, n ) )
THEN
387 ELSE IF( ldvl.LT.1 .OR. ( ilvl .AND. ldvl.LT.n ) )
THEN
389 ELSE IF( ldvr.LT.1 .OR. ( ilvr .AND. ldvr.LT.n ) )
THEN
391 ELSE IF( lwork.LT.lwkmin .AND. .NOT.lquery )
THEN
396 nb1 =
ilaenv( 1,
'CGEQRF',
' ', n, n, -1, -1 )
397 nb2 =
ilaenv( 1,
'CUNMQR',
' ', n, n, n, -1 )
398 nb3 =
ilaenv( 1,
'CUNGQR',
' ', n, n, n, -1 )
399 nb = max( nb1, nb2, nb3 )
400 lopt = max( 2*n, n*(nb+1) )
405 CALL
xerbla(
'CGEGV ', -info )
407 ELSE IF( lquery )
THEN
420 safmin = safmin + safmin
421 safmax = one / safmin
425 anrm =
clange(
'M', n, n, a, lda, rwork )
428 IF( anrm.LT.one )
THEN
429 IF( safmax*anrm.LT.one )
THEN
435 IF( anrm.GT.zero )
THEN
436 CALL
clascl(
'G', -1, -1, anrm, one, n, n, a, lda, iinfo )
437 IF( iinfo.NE.0 )
THEN
445 bnrm =
clange(
'M', n, n,
b, ldb, rwork )
448 IF( bnrm.LT.one )
THEN
449 IF( safmax*bnrm.LT.one )
THEN
455 IF( bnrm.GT.zero )
THEN
456 CALL
clascl(
'G', -1, -1, bnrm, one, n, n,
b, ldb, iinfo )
457 IF( iinfo.NE.0 )
THEN
469 CALL
cggbal(
'P', n, a, lda,
b, ldb, ilo, ihi, rwork( ileft ),
470 $ rwork( iright ), rwork( irwork ), iinfo )
471 IF( iinfo.NE.0 )
THEN
478 irows = ihi + 1 - ilo
486 CALL
cgeqrf( irows, icols,
b( ilo, ilo ), ldb, work( itau ),
487 $ work( iwork ), lwork+1-iwork, iinfo )
489 $ lwkopt = max( lwkopt, int( work( iwork ) )+iwork-1 )
490 IF( iinfo.NE.0 )
THEN
495 CALL
cunmqr(
'L',
'C', irows, icols, irows,
b( ilo, ilo ), ldb,
496 $ work( itau ), a( ilo, ilo ), lda, work( iwork ),
497 $ lwork+1-iwork, iinfo )
499 $ lwkopt = max( lwkopt, int( work( iwork ) )+iwork-1 )
500 IF( iinfo.NE.0 )
THEN
506 CALL
claset(
'Full', n, n, czero, cone, vl, ldvl )
507 CALL
clacpy(
'L', irows-1, irows-1,
b( ilo+1, ilo ), ldb,
508 $ vl( ilo+1, ilo ), ldvl )
509 CALL
cungqr( irows, irows, irows, vl( ilo, ilo ), ldvl,
510 $ work( itau ), work( iwork ), lwork+1-iwork,
513 $ lwkopt = max( lwkopt, int( work( iwork ) )+iwork-1 )
514 IF( iinfo.NE.0 )
THEN
521 $ CALL
claset(
'Full', n, n, czero, cone, vr, ldvr )
529 CALL
cgghrd( jobvl, jobvr, n, ilo, ihi, a, lda,
b, ldb, vl,
530 $ ldvl, vr, ldvr, iinfo )
532 CALL
cgghrd(
'N',
'N', irows, 1, irows, a( ilo, ilo ), lda,
533 $
b( ilo, ilo ), ldb, vl, ldvl, vr, ldvr, iinfo )
535 IF( iinfo.NE.0 )
THEN
548 CALL
chgeqz( chtemp, jobvl, jobvr, n, ilo, ihi, a, lda,
b, ldb,
549 $ alpha, beta, vl, ldvl, vr, ldvr, work( iwork ),
550 $ lwork+1-iwork, rwork( irwork ), iinfo )
552 $ lwkopt = max( lwkopt, int( work( iwork ) )+iwork-1 )
553 IF( iinfo.NE.0 )
THEN
554 IF( iinfo.GT.0 .AND. iinfo.LE.n )
THEN
556 ELSE IF( iinfo.GT.n .AND. iinfo.LE.2*n )
THEN
578 CALL
ctgevc( chtemp,
'B', ldumma, n, a, lda,
b, ldb, vl, ldvl,
579 $ vr, ldvr, n, in, work( iwork ), rwork( irwork ),
581 IF( iinfo.NE.0 )
THEN
589 CALL
cggbak(
'P',
'L', n, ilo, ihi, rwork( ileft ),
590 $ rwork( iright ), n, vl, ldvl, iinfo )
591 IF( iinfo.NE.0 )
THEN
598 temp = max( temp, abs1( vl( jr, jc ) ) )
604 vl( jr, jc ) = vl( jr, jc )*temp
609 CALL
cggbak(
'P',
'R', n, ilo, ihi, rwork( ileft ),
610 $ rwork( iright ), n, vr, ldvr, iinfo )
611 IF( iinfo.NE.0 )
THEN
618 temp = max( temp, abs1( vr( jr, jc ) ) )
624 vr( jr, jc ) = vr( jr, jc )*temp
642 absar = abs(
REAL( ALPHA( JC ) ) )
643 absai = abs( aimag( alpha( jc ) ) )
644 absb = abs(
REAL( BETA( JC ) ) )
645 salfar = anrm*
REAL( ALPHA( JC ) )
646 salfai = anrm*aimag( alpha( jc ) )
647 sbeta = bnrm*
REAL( BETA( JC ) )
653 IF( abs( salfai ).LT.safmin .AND. absai.GE.
654 $ max( safmin, eps*absar, eps*absb ) )
THEN
656 scale = ( safmin / anrm1 ) / max( safmin, anrm2*absai )
661 IF( abs( salfar ).LT.safmin .AND. absar.GE.
662 $ max( safmin, eps*absai, eps*absb ) )
THEN
664 scale = max( scale, ( safmin / anrm1 ) /
665 $ max( safmin, anrm2*absar ) )
670 IF( abs( sbeta ).LT.safmin .AND. absb.GE.
671 $ max( safmin, eps*absar, eps*absai ) )
THEN
673 scale = max( scale, ( safmin / bnrm1 ) /
674 $ max( safmin, bnrm2*absb ) )
680 temp = ( scale*safmin )*max( abs( salfar ), abs( salfai ),
683 $ scale = scale / temp
691 salfar = ( scale*
REAL( ALPHA( JC ) ) )*anrm
692 salfai = ( scale*aimag( alpha( jc ) ) )*anrm
693 sbeta = ( scale*beta( jc ) )*bnrm
695 alpha( jc ) = cmplx( salfar, salfai )
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...
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 ...
subroutine ctgevc(SIDE, HOWMNY, SELECT, N, S, LDS, P, LDP, VL, LDVL, VR, LDVR, MM, M, WORK, RWORK, INFO)
CTGEVC
subroutine cggbal(JOB, N, A, LDA, B, LDB, ILO, IHI, LSCALE, RSCALE, WORK, INFO)
CGGBAL
subroutine xerbla(SRNAME, INFO)
XERBLA
subroutine cunmqr(SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, LWORK, INFO)
CUNMQR
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real b(3) integer i
logical function lsame(CA, CB)
LSAME
subroutine cggbak(JOB, SIDE, N, ILO, IHI, LSCALE, RSCALE, M, V, LDV, INFO)
CGGBAK
subroutine clacpy(UPLO, M, N, A, LDA, B, LDB)
CLACPY copies all or part of one two-dimensional array to another.
real function slamch(CMACH)
SLAMCH
subroutine cgghrd(COMPQ, COMPZ, N, ILO, IHI, A, LDA, B, LDB, Q, LDQ, Z, LDZ, INFO)
CGGHRD
subroutine cgeqrf(M, N, A, LDA, TAU, WORK, LWORK, INFO)
CGEQRF
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.
integer function ilaenv(ISPEC, NAME, OPTS, N1, N2, N3, N4)
subroutine cgegv(JOBVL, JOBVR, N, A, LDA, B, LDB, ALPHA, BETA, VL, LDVL, VR, LDVR, WORK, LWORK, RWORK, INFO)
CGEEVX computes the eigenvalues and, optionally, the left and/or right eigenvectors for GE matrices ...
subroutine chgeqz(JOB, COMPQ, COMPZ, N, ILO, IHI, H, LDH, T, LDT, ALPHA, BETA, Q, LDQ, Z, LDZ, WORK, LWORK, RWORK, INFO)
CHGEQZ
subroutine cungqr(M, N, K, A, LDA, TAU, WORK, LWORK, INFO)
CUNGQR