214 SUBROUTINE zggev3( JOBVL, JOBVR, N, A, LDA, B, LDB, ALPHA, BETA,
215 $ VL, LDVL, VR, LDVR, WORK, LWORK, RWORK, INFO )
222 CHARACTER JOBVL, JOBVR
223 INTEGER INFO, LDA, LDB, LDVL, LDVR, LWORK, N
226 DOUBLE PRECISION RWORK( * )
227 COMPLEX*16 A( LDA, * ), ALPHA( * ), B( LDB, * ),
228 $ beta( * ), vl( ldvl, * ), vr( ldvr, * ),
235 DOUBLE PRECISION ZERO, ONE
236 parameter( zero = 0.0d0, one = 1.0d0 )
237 COMPLEX*16 CZERO, CONE
238 parameter( czero = ( 0.0d0, 0.0d0 ),
239 $ cone = ( 1.0d0, 0.0d0 ) )
242 LOGICAL ILASCL, ILBSCL, ILV, ILVL, ILVR, LQUERY
244 INTEGER ICOLS, IERR, IHI, IJOBVL, IJOBVR, ILEFT, ILO,
245 $ in, iright, irows, irwrk, itau, iwrk, jc, jr,
247 DOUBLE PRECISION ANRM, ANRMTO, BIGNUM, BNRM, BNRMTO, EPS,
260 DOUBLE PRECISION DLAMCH, ZLANGE
261 EXTERNAL lsame, dlamch, zlange
264 INTRINSIC abs, dble, dimag, max, sqrt
267 DOUBLE PRECISION ABS1
270 abs1( x ) = abs( dble( x ) ) + abs( dimag( x ) )
276 IF( lsame( jobvl,
'N' ) )
THEN
279 ELSE IF( lsame( jobvl,
'V' ) )
THEN
287 IF( lsame( jobvr,
'N' ) )
THEN
290 ELSE IF( lsame( jobvr,
'V' ) )
THEN
302 lquery = ( lwork.EQ.-1 )
303 IF( ijobvl.LE.0 )
THEN
305 ELSE IF( ijobvr.LE.0 )
THEN
307 ELSE IF( n.LT.0 )
THEN
309 ELSE IF( lda.LT.max( 1, n ) )
THEN
311 ELSE IF( ldb.LT.max( 1, n ) )
THEN
313 ELSE IF( ldvl.LT.1 .OR. ( ilvl .AND. ldvl.LT.n ) )
THEN
315 ELSE IF( ldvr.LT.1 .OR. ( ilvr .AND. ldvr.LT.n ) )
THEN
317 ELSE IF( lwork.LT.max( 1, 2*n ) .AND. .NOT.lquery )
THEN
324 CALL zgeqrf( n, n, b, ldb, work, work, -1, ierr )
325 lwkopt = max( 1, n+int( work( 1 ) ) )
326 CALL zunmqr(
'L',
'C', n, n, n, b, ldb, work, a, lda, work,
328 lwkopt = max( lwkopt, n+int( work( 1 ) ) )
330 CALL zungqr( n, n, n, vl, ldvl, work, work, -1, ierr )
331 lwkopt = max( lwkopt, n+int( work( 1 ) ) )
334 CALL zgghd3( jobvl, jobvr, n, 1, n, a, lda, b, ldb, vl,
335 $ ldvl, vr, ldvr, work, -1, ierr )
336 lwkopt = max( lwkopt, n+int( work( 1 ) ) )
337 CALL zlaqz0(
'S', jobvl, jobvr, n, 1, n, a, lda, b, ldb,
338 $ alpha, beta, vl, ldvl, vr, ldvr, work, -1,
340 lwkopt = max( lwkopt, n+int( work( 1 ) ) )
342 CALL zgghd3( jobvl, jobvr, n, 1, n, a, lda, b, ldb, vl,
343 $ ldvl, vr, ldvr, work, -1, ierr )
344 lwkopt = max( lwkopt, n+int( work( 1 ) ) )
345 CALL zlaqz0(
'E', jobvl, jobvr, n, 1, n, a, lda, b, ldb,
346 $ alpha, beta, vl, ldvl, vr, ldvr, work, -1,
348 lwkopt = max( lwkopt, n+int( work( 1 ) ) )
350 work( 1 ) = dcmplx( lwkopt )
354 CALL xerbla(
'ZGGEV3 ', -info )
356 ELSE IF( lquery )
THEN
367 eps = dlamch(
'E' )*dlamch(
'B' )
368 smlnum = dlamch(
'S' )
369 bignum = one / smlnum
370 smlnum = sqrt( smlnum ) / eps
371 bignum = one / smlnum
375 anrm = zlange(
'M', n, n, a, lda, rwork )
377 IF( anrm.GT.zero .AND. anrm.LT.smlnum )
THEN
380 ELSE IF( anrm.GT.bignum )
THEN
385 $
CALL zlascl(
'G', 0, 0, anrm, anrmto, n, n, a, lda, ierr )
389 bnrm = zlange(
'M', n, n, b, ldb, rwork )
391 IF( bnrm.GT.zero .AND. bnrm.LT.smlnum )
THEN
394 ELSE IF( bnrm.GT.bignum )
THEN
399 $
CALL zlascl(
'G', 0, 0, bnrm, bnrmto, n, n, b, ldb, ierr )
406 CALL zggbal(
'P', n, a, lda, b, ldb, ilo, ihi, rwork( ileft ),
407 $ rwork( iright ), rwork( irwrk ), ierr )
411 irows = ihi + 1 - ilo
419 CALL zgeqrf( irows, icols, b( ilo, ilo ), ldb, work( itau ),
420 $ work( iwrk ), lwork+1-iwrk, ierr )
424 CALL zunmqr(
'L',
'C', irows, icols, irows, b( ilo, ilo ), ldb,
425 $ work( itau ), a( ilo, ilo ), lda, work( iwrk ),
426 $ lwork+1-iwrk, ierr )
431 CALL zlaset(
'Full', n, n, czero, cone, vl, ldvl )
432 IF( irows.GT.1 )
THEN
433 CALL zlacpy(
'L', irows-1, irows-1, b( ilo+1, ilo ), ldb,
434 $ vl( ilo+1, ilo ), ldvl )
436 CALL zungqr( irows, irows, irows, vl( ilo, ilo ), ldvl,
437 $ work( itau ), work( iwrk ), lwork+1-iwrk, ierr )
443 $
CALL zlaset(
'Full', n, n, czero, cone, vr, ldvr )
451 CALL zgghd3( jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb, vl,
452 $ ldvl, vr, ldvr, work( iwrk ), lwork+1-iwrk, ierr )
454 CALL zgghd3(
'N',
'N', irows, 1, irows, a( ilo, ilo ), lda,
455 $ b( ilo, ilo ), ldb, vl, ldvl, vr, ldvr,
456 $ work( iwrk ), lwork+1-iwrk, ierr )
468 CALL zlaqz0( chtemp, jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb,
469 $ alpha, beta, vl, ldvl, vr, ldvr, work( iwrk ),
470 $ lwork+1-iwrk, rwork( irwrk ), 0, ierr )
472 IF( ierr.GT.0 .AND. ierr.LE.n )
THEN
474 ELSE IF( ierr.GT.n .AND. ierr.LE.2*n )
THEN
495 CALL ztgevc( chtemp,
'B', ldumma, n, a, lda, b, ldb, vl, ldvl,
496 $ vr, ldvr, n, in, work( iwrk ), rwork( irwrk ),
506 CALL zggbak(
'P',
'L', n, ilo, ihi, rwork( ileft ),
507 $ rwork( iright ), n, vl, ldvl, ierr )
511 temp = max( temp, abs1( vl( jr, jc ) ) )
517 vl( jr, jc ) = vl( jr, jc )*temp
522 CALL zggbak(
'P',
'R', n, ilo, ihi, rwork( ileft ),
523 $ rwork( iright ), n, vr, ldvr, ierr )
527 temp = max( temp, abs1( vr( jr, jc ) ) )
533 vr( jr, jc ) = vr( jr, jc )*temp
544 $
CALL zlascl(
'G', 0, 0, anrmto, anrm, n, 1, alpha, n, ierr )
547 $
CALL zlascl(
'G', 0, 0, bnrmto, bnrm, n, 1, beta, n, ierr )
549 work( 1 ) = dcmplx( lwkopt )
subroutine xerbla(srname, info)
subroutine zgeqrf(m, n, a, lda, tau, work, lwork, info)
ZGEQRF
subroutine zggbak(job, side, n, ilo, ihi, lscale, rscale, m, v, ldv, info)
ZGGBAK
subroutine zggbal(job, n, a, lda, b, ldb, ilo, ihi, lscale, rscale, work, info)
ZGGBAL
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 zgghd3(compq, compz, n, ilo, ihi, a, lda, b, ldb, q, ldq, z, ldz, work, lwork, info)
ZGGHD3
subroutine zlacpy(uplo, m, n, a, lda, b, ldb)
ZLACPY copies all or part of one two-dimensional array to another.
recursive subroutine zlaqz0(wants, wantq, wantz, n, ilo, ihi, a, lda, b, ldb, alpha, beta, q, ldq, z, ldz, work, lwork, rwork, rec, info)
ZLAQZ0
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.
subroutine ztgevc(side, howmny, select, n, s, lds, p, ldp, vl, ldvl, vr, ldvr, mm, m, work, rwork, info)
ZTGEVC
subroutine zungqr(m, n, k, a, lda, tau, work, lwork, info)
ZUNGQR
subroutine zunmqr(side, trans, m, n, k, a, lda, tau, c, ldc, work, lwork, info)
ZUNMQR