282 SUBROUTINE zgegv( 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
295 DOUBLE PRECISION RWORK( * )
296 COMPLEX*16 A( lda, * ), ALPHA( * ), B( ldb, * ),
297 $ beta( * ), vl( ldvl, * ), vr( ldvr, * ),
304 DOUBLE PRECISION ZERO, ONE
305 parameter ( zero = 0.0d0, one = 1.0d0 )
306 COMPLEX*16 CZERO, CONE
307 parameter ( czero = ( 0.0d0, 0.0d0 ),
308 $ cone = ( 1.0d0, 0.0d0 ) )
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 DOUBLE PRECISION ABSAI, ABSAR, ABSB, ANRM, ANRM1, ANRM2, BNRM,
317 $ bnrm1, bnrm2, eps, safmax, safmin, salfai,
318 $ salfar, sbeta, scale, temp
331 DOUBLE PRECISION DLAMCH, ZLANGE
332 EXTERNAL lsame, ilaenv, dlamch, zlange
335 INTRINSIC abs, dble, dcmplx, dimag, int, max
338 DOUBLE PRECISION ABS1
341 abs1( x ) = abs( dble( x ) ) + abs( dimag( 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,
'ZGEQRF',
' ', n, n, -1, -1 )
397 nb2 = ilaenv( 1,
'ZUNMQR',
' ', n, n, n, -1 )
398 nb3 = ilaenv( 1,
'ZUNGQR',
' ', n, n, n, -1 )
399 nb = max( nb1, nb2, nb3 )
400 lopt = max( 2*n, n*( nb+1 ) )
405 CALL xerbla(
'ZGEGV ', -info )
407 ELSE IF( lquery )
THEN
418 eps = dlamch(
'E' )*dlamch(
'B' )
419 safmin = dlamch(
'S' )
420 safmin = safmin + safmin
421 safmax = one / safmin
425 anrm = zlange(
'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 zlascl(
'G', -1, -1, anrm, one, n, n, a, lda, iinfo )
437 IF( iinfo.NE.0 )
THEN
445 bnrm = zlange(
'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 zlascl(
'G', -1, -1, bnrm, one, n, n, b, ldb, iinfo )
457 IF( iinfo.NE.0 )
THEN
469 CALL zggbal(
'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 zgeqrf( 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 zunmqr(
'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 zlaset(
'Full', n, n, czero, cone, vl, ldvl )
507 CALL zlacpy(
'L', irows-1, irows-1, b( ilo+1, ilo ), ldb,
508 $ vl( ilo+1, ilo ), ldvl )
509 CALL zungqr( 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 zlaset(
'Full', n, n, czero, cone, vr, ldvr )
529 CALL zgghrd( jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb, vl,
530 $ ldvl, vr, ldvr, iinfo )
532 CALL zgghrd(
'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 zhgeqz( 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 ztgevc( 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 zggbak(
'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 zggbak(
'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( dble( alpha( jc ) ) )
643 absai = abs( dimag( alpha( jc ) ) )
644 absb = abs( dble( beta( jc ) ) )
645 salfar = anrm*dble( alpha( jc ) )
646 salfai = anrm*dimag( alpha( jc ) )
647 sbeta = bnrm*dble( 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*dble( alpha( jc ) ) )*anrm
692 salfai = ( scale*dimag( alpha( jc ) ) )*anrm
693 sbeta = ( scale*beta( jc ) )*bnrm
695 alpha( jc ) = dcmplx( salfar, salfai )
subroutine zlacpy(UPLO, M, N, A, LDA, B, LDB)
ZLACPY copies all or part of one two-dimensional array to another.
subroutine zgghrd(COMPQ, COMPZ, N, ILO, IHI, A, LDA, B, LDB, Q, LDQ, Z, LDZ, INFO)
ZGGHRD
subroutine zgeqrf(M, N, A, LDA, TAU, WORK, LWORK, INFO)
ZGEQRF VARIANT: left-looking Level 3 BLAS of the algorithm.
subroutine zggbak(JOB, SIDE, N, ILO, IHI, LSCALE, RSCALE, M, V, LDV, INFO)
ZGGBAK
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 zggbal(JOB, N, A, LDA, B, LDB, ILO, IHI, LSCALE, RSCALE, WORK, INFO)
ZGGBAL
subroutine xerbla(SRNAME, INFO)
XERBLA
subroutine zunmqr(SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, LWORK, INFO)
ZUNMQR
subroutine zungqr(M, N, K, A, LDA, TAU, WORK, LWORK, INFO)
ZUNGQR
subroutine ztgevc(SIDE, HOWMNY, SELECT, N, S, LDS, P, LDP, VL, LDVL, VR, LDVR, MM, M, WORK, RWORK, INFO)
ZTGEVC
subroutine zhgeqz(JOB, COMPQ, COMPZ, N, ILO, IHI, H, LDH, T, LDT, ALPHA, BETA, Q, LDQ, Z, LDZ, WORK, LWORK, RWORK, INFO)
ZHGEQZ
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 zgegv(JOBVL, JOBVR, N, A, LDA, B, LDB, ALPHA, BETA, VL, LDVL, VR, LDVR, WORK, LWORK, RWORK, INFO)
ZGEEVX computes the eigenvalues and, optionally, the left and/or right eigenvectors for GE matrices ...