216 SUBROUTINE zggev3( JOBVL, JOBVR, N, A, LDA, B, LDB, ALPHA, BETA,
217 $ vl, ldvl, vr, ldvr, work, lwork, rwork, info )
225 CHARACTER JOBVL, JOBVR
226 INTEGER INFO, LDA, LDB, LDVL, LDVR, LWORK, N
229 DOUBLE PRECISION RWORK( * )
230 COMPLEX*16 A( lda, * ), ALPHA( * ), B( ldb, * ),
231 $ beta( * ), vl( ldvl, * ), vr( ldvr, * ),
238 DOUBLE PRECISION ZERO, ONE
239 parameter ( zero = 0.0d0, one = 1.0d0 )
240 COMPLEX*16 CZERO, CONE
241 parameter ( czero = ( 0.0d0, 0.0d0 ),
242 $ cone = ( 1.0d0, 0.0d0 ) )
245 LOGICAL ILASCL, ILBSCL, ILV, ILVL, ILVR, LQUERY
247 INTEGER ICOLS, IERR, IHI, IJOBVL, IJOBVR, ILEFT, ILO,
248 $ in, iright, irows, irwrk, itau, iwrk, jc, jr,
250 DOUBLE PRECISION ANRM, ANRMTO, BIGNUM, BNRM, BNRMTO, EPS,
264 DOUBLE PRECISION DLAMCH, ZLANGE
265 EXTERNAL lsame, dlamch, zlange
268 INTRINSIC abs, dble, dimag, max, sqrt
271 DOUBLE PRECISION ABS1
274 abs1( x ) = abs( dble( x ) ) + abs( dimag( x ) )
280 IF( lsame( jobvl,
'N' ) )
THEN
283 ELSE IF( lsame( jobvl,
'V' ) )
THEN
291 IF( lsame( jobvr,
'N' ) )
THEN
294 ELSE IF( lsame( jobvr,
'V' ) )
THEN
306 lquery = ( lwork.EQ.-1 )
307 IF( ijobvl.LE.0 )
THEN
309 ELSE IF( ijobvr.LE.0 )
THEN
311 ELSE IF( n.LT.0 )
THEN
313 ELSE IF( lda.LT.max( 1, n ) )
THEN
315 ELSE IF( ldb.LT.max( 1, n ) )
THEN
317 ELSE IF( ldvl.LT.1 .OR. ( ilvl .AND. ldvl.LT.n ) )
THEN
319 ELSE IF( ldvr.LT.1 .OR. ( ilvr .AND. ldvr.LT.n ) )
THEN
321 ELSE IF( lwork.LT.max( 1, 2*n ) .AND. .NOT.lquery )
THEN
328 CALL zgeqrf( n, n, b, ldb, work, work, -1, ierr )
329 lwkopt = max( 1, n+int( work( 1 ) ) )
330 CALL zunmqr(
'L',
'C', n, n, n, b, ldb, work, a, lda, work,
332 lwkopt = max( lwkopt, n+int( work( 1 ) ) )
334 CALL zungqr( n, n, n, vl, ldvl, work, work, -1, ierr )
335 lwkopt = max( lwkopt, n+int( work( 1 ) ) )
338 CALL zgghd3( jobvl, jobvr, n, 1, n, a, lda, b, ldb, vl,
339 $ ldvl, vr, ldvr, work, -1, ierr )
340 lwkopt = max( lwkopt, n+int( work( 1 ) ) )
341 CALL zhgeqz(
'S', jobvl, jobvr, n, 1, n, a, lda, b, ldb,
342 $ alpha, beta, vl, ldvl, vr, ldvr, work, -1,
344 lwkopt = max( lwkopt, n+int( work( 1 ) ) )
346 CALL zgghd3( jobvl, jobvr, n, 1, n, a, lda, b, ldb, vl,
347 $ ldvl, vr, ldvr, work, -1, ierr )
348 lwkopt = max( lwkopt, n+int( work( 1 ) ) )
349 CALL zhgeqz(
'E', jobvl, jobvr, n, 1, n, a, lda, b, ldb,
350 $ alpha, beta, vl, ldvl, vr, ldvr, work, -1,
352 lwkopt = max( lwkopt, n+int( work( 1 ) ) )
354 work( 1 ) = dcmplx( lwkopt )
358 CALL xerbla(
'ZGGEV3 ', -info )
360 ELSE IF( lquery )
THEN
371 eps = dlamch(
'E' )*dlamch(
'B' )
372 smlnum = dlamch(
'S' )
373 bignum = one / smlnum
374 CALL dlabad( smlnum, bignum )
375 smlnum = sqrt( smlnum ) / eps
376 bignum = one / smlnum
380 anrm = zlange(
'M', n, n, a, lda, rwork )
382 IF( anrm.GT.zero .AND. anrm.LT.smlnum )
THEN
385 ELSE IF( anrm.GT.bignum )
THEN
390 $
CALL zlascl(
'G', 0, 0, anrm, anrmto, n, n, a, lda, ierr )
394 bnrm = zlange(
'M', n, n, b, ldb, rwork )
396 IF( bnrm.GT.zero .AND. bnrm.LT.smlnum )
THEN
399 ELSE IF( bnrm.GT.bignum )
THEN
404 $
CALL zlascl(
'G', 0, 0, bnrm, bnrmto, n, n, b, ldb, ierr )
411 CALL zggbal(
'P', n, a, lda, b, ldb, ilo, ihi, rwork( ileft ),
412 $ rwork( iright ), rwork( irwrk ), ierr )
416 irows = ihi + 1 - ilo
424 CALL zgeqrf( irows, icols, b( ilo, ilo ), ldb, work( itau ),
425 $ work( iwrk ), lwork+1-iwrk, ierr )
429 CALL zunmqr(
'L',
'C', irows, icols, irows, b( ilo, ilo ), ldb,
430 $ work( itau ), a( ilo, ilo ), lda, work( iwrk ),
431 $ lwork+1-iwrk, ierr )
436 CALL zlaset(
'Full', n, n, czero, cone, vl, ldvl )
437 IF( irows.GT.1 )
THEN
438 CALL zlacpy(
'L', irows-1, irows-1, b( ilo+1, ilo ), ldb,
439 $ vl( ilo+1, ilo ), ldvl )
441 CALL zungqr( irows, irows, irows, vl( ilo, ilo ), ldvl,
442 $ work( itau ), work( iwrk ), lwork+1-iwrk, ierr )
448 $
CALL zlaset(
'Full', n, n, czero, cone, vr, ldvr )
456 CALL zgghd3( jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb, vl,
457 $ ldvl, vr, ldvr, work( iwrk ), lwork+1-iwrk, ierr )
459 CALL zgghd3(
'N',
'N', irows, 1, irows, a( ilo, ilo ), lda,
460 $ b( ilo, ilo ), ldb, vl, ldvl, vr, ldvr,
461 $ work( iwrk ), lwork+1-iwrk, ierr )
473 CALL zhgeqz( chtemp, jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb,
474 $ alpha, beta, vl, ldvl, vr, ldvr, work( iwrk ),
475 $ lwork+1-iwrk, rwork( irwrk ), ierr )
477 IF( ierr.GT.0 .AND. ierr.LE.n )
THEN
479 ELSE IF( ierr.GT.n .AND. ierr.LE.2*n )
THEN
500 CALL ztgevc( chtemp,
'B', ldumma, n, a, lda, b, ldb, vl, ldvl,
501 $ vr, ldvr, n, in, work( iwrk ), rwork( irwrk ),
511 CALL zggbak(
'P',
'L', n, ilo, ihi, rwork( ileft ),
512 $ rwork( iright ), n, vl, ldvl, ierr )
516 temp = max( temp, abs1( vl( jr, jc ) ) )
522 vl( jr, jc ) = vl( jr, jc )*temp
527 CALL zggbak(
'P',
'R', n, ilo, ihi, rwork( ileft ),
528 $ rwork( iright ), n, vr, ldvr, ierr )
532 temp = max( temp, abs1( vr( jr, jc ) ) )
538 vr( jr, jc ) = vr( jr, jc )*temp
549 $
CALL zlascl(
'G', 0, 0, anrmto, anrm, n, 1, alpha, n, ierr )
552 $
CALL zlascl(
'G', 0, 0, bnrmto, bnrm, n, 1, beta, n, ierr )
554 work( 1 ) = dcmplx( lwkopt )
subroutine zlacpy(UPLO, M, N, A, LDA, B, LDB)
ZLACPY copies all or part of one two-dimensional array to another.
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 dlabad(SMALL, LARGE)
DLABAD
subroutine zunmqr(SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, LWORK, INFO)
ZUNMQR
subroutine zgghd3(COMPQ, COMPZ, N, ILO, IHI, A, LDA, B, LDB, Q, LDQ, Z, LDZ, WORK, LWORK, INFO)
ZGGHD3
subroutine zggev3(JOBVL, JOBVR, N, A, LDA, B, LDB, ALPHA, BETA, VL, LDVL, VR, LDVR, WORK, LWORK, RWORK, INFO)
ZGGEV3 computes the eigenvalues and, optionally, the left and/or right eigenvectors for GE matrices ...
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.