226 SUBROUTINE sggev( JOBVL, JOBVR, N, A, LDA, B, LDB, ALPHAR, ALPHAI,
227 $ beta, vl, ldvl, vr, ldvr, work, lwork, info )
235 CHARACTER jobvl, jobvr
236 INTEGER info, lda, ldb, ldvl, ldvr, lwork, n
239 REAL a( lda, * ), alphai( * ), alphar( * ),
240 $
b( ldb, * ), beta( * ), vl( ldvl, * ),
241 $ vr( ldvr, * ), work( * )
248 parameter( zero = 0.0e+0, one = 1.0e+0 )
251 LOGICAL ilascl, ilbscl, ilv, ilvl, ilvr, lquery
253 INTEGER icols, ierr, ihi, ijobvl, ijobvr, ileft, ilo,
254 $ in, iright, irows, itau, iwrk, jc, jr, maxwrk,
256 REAL anrm, anrmto, bignum, bnrm, bnrmto, eps,
274 INTRINSIC abs, max, sqrt
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
332 minwrk = max( 1, 8*n )
333 maxwrk = max( 1, n*( 7 +
334 $
ilaenv( 1,
'SGEQRF',
' ', n, 1, n, 0 ) ) )
335 maxwrk = max( maxwrk, n*( 7 +
336 $
ilaenv( 1,
'SORMQR',
' ', n, 1, n, 0 ) ) )
338 maxwrk = max( maxwrk, n*( 7 +
339 $
ilaenv( 1,
'SORGQR',
' ', n, 1, n, -1 ) ) )
343 IF( lwork.LT.minwrk .AND. .NOT.lquery )
348 CALL
xerbla(
'SGGEV ', -info )
350 ELSE IF( lquery )
THEN
363 bignum = one / smlnum
364 CALL
slabad( smlnum, bignum )
365 smlnum = sqrt( smlnum ) / eps
366 bignum = one / smlnum
370 anrm =
slange(
'M', n, n, a, lda, work )
372 IF( anrm.GT.zero .AND. anrm.LT.smlnum )
THEN
375 ELSE IF( anrm.GT.bignum )
THEN
380 $ CALL
slascl(
'G', 0, 0, anrm, anrmto, n, n, a, lda, ierr )
384 bnrm =
slange(
'M', n, n,
b, ldb, work )
386 IF( bnrm.GT.zero .AND. bnrm.LT.smlnum )
THEN
389 ELSE IF( bnrm.GT.bignum )
THEN
394 $ CALL
slascl(
'G', 0, 0, bnrm, bnrmto, n, n,
b, ldb, ierr )
402 CALL
sggbal(
'P', n, a, lda,
b, ldb, ilo, ihi, work( ileft ),
403 $ work( iright ), work( iwrk ), ierr )
408 irows = ihi + 1 - ilo
416 CALL
sgeqrf( irows, icols,
b( ilo, ilo ), ldb, work( itau ),
417 $ work( iwrk ), lwork+1-iwrk, ierr )
422 CALL
sormqr(
'L',
'T', irows, icols, irows,
b( ilo, ilo ), ldb,
423 $ work( itau ), a( ilo, ilo ), lda, work( iwrk ),
424 $ lwork+1-iwrk, ierr )
430 CALL
slaset(
'Full', n, n, zero, one, vl, ldvl )
431 IF( irows.GT.1 )
THEN
432 CALL
slacpy(
'L', irows-1, irows-1,
b( ilo+1, ilo ), ldb,
433 $ vl( ilo+1, ilo ), ldvl )
435 CALL
sorgqr( irows, irows, irows, vl( ilo, ilo ), ldvl,
436 $ work( itau ), work( iwrk ), lwork+1-iwrk, ierr )
442 $ CALL
slaset(
'Full', n, n, zero, one, vr, ldvr )
451 CALL
sgghrd( jobvl, jobvr, n, ilo, ihi, a, lda,
b, ldb, vl,
452 $ ldvl, vr, ldvr, ierr )
454 CALL
sgghrd(
'N',
'N', irows, 1, irows, a( ilo, ilo ), lda,
455 $
b( ilo, ilo ), ldb, vl, ldvl, vr, ldvr, ierr )
468 CALL
shgeqz( chtemp, jobvl, jobvr, n, ilo, ihi, a, lda,
b, ldb,
469 $ alphar, alphai, beta, vl, ldvl, vr, ldvr,
470 $ work( iwrk ), lwork+1-iwrk, 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
stgevc( chtemp,
'B', ldumma, n, a, lda,
b, ldb, vl, ldvl,
496 $ vr, ldvr, n, in, work( iwrk ), ierr )
506 CALL
sggbak(
'P',
'L', n, ilo, ihi, work( ileft ),
507 $ work( iright ), n, vl, ldvl, ierr )
509 IF( alphai( jc ).LT.zero )
512 IF( alphai( jc ).EQ.zero )
THEN
514 temp = max( temp, abs( vl( jr, jc ) ) )
518 temp = max( temp, abs( vl( jr, jc ) )+
519 $ abs( vl( jr, jc+1 ) ) )
525 IF( alphai( jc ).EQ.zero )
THEN
527 vl( jr, jc ) = vl( jr, jc )*temp
531 vl( jr, jc ) = vl( jr, jc )*temp
532 vl( jr, jc+1 ) = vl( jr, jc+1 )*temp
538 CALL
sggbak(
'P',
'R', n, ilo, ihi, work( ileft ),
539 $ work( iright ), n, vr, ldvr, ierr )
541 IF( alphai( jc ).LT.zero )
544 IF( alphai( jc ).EQ.zero )
THEN
546 temp = max( temp, abs( vr( jr, jc ) ) )
550 temp = max( temp, abs( vr( jr, jc ) )+
551 $ abs( vr( jr, jc+1 ) ) )
557 IF( alphai( jc ).EQ.zero )
THEN
559 vr( jr, jc ) = vr( jr, jc )*temp
563 vr( jr, jc ) = vr( jr, jc )*temp
564 vr( jr, jc+1 ) = vr( jr, jc+1 )*temp
579 CALL
slascl(
'G', 0, 0, anrmto, anrm, n, 1, alphar, n, ierr )
580 CALL
slascl(
'G', 0, 0, anrmto, anrm, n, 1, alphai, n, ierr )
584 CALL
slascl(
'G', 0, 0, bnrmto, bnrm, n, 1, beta, n, ierr )
subroutine slaset(UPLO, M, N, ALPHA, BETA, A, LDA)
SLASET initializes the off-diagonal elements and the diagonal elements of a matrix to given values...
subroutine sggbal(JOB, N, A, LDA, B, LDB, ILO, IHI, LSCALE, RSCALE, WORK, INFO)
SGGBAL
real function slange(NORM, M, N, A, LDA, WORK)
SLANGE returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute value ...
subroutine sormqr(SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, LWORK, INFO)
SORMQR
subroutine sgghrd(COMPQ, COMPZ, N, ILO, IHI, A, LDA, B, LDB, Q, LDQ, Z, LDZ, INFO)
SGGHRD
subroutine stgevc(SIDE, HOWMNY, SELECT, N, S, LDS, P, LDP, VL, LDVL, VR, LDVR, MM, M, WORK, INFO)
STGEVC
subroutine xerbla(SRNAME, INFO)
XERBLA
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real b(3) integer i
logical function lsame(CA, CB)
LSAME
subroutine shgeqz(JOB, COMPQ, COMPZ, N, ILO, IHI, H, LDH, T, LDT, ALPHAR, ALPHAI, BETA, Q, LDQ, Z, LDZ, WORK, LWORK, INFO)
SHGEQZ
subroutine slascl(TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO)
SLASCL multiplies a general rectangular matrix by a real scalar defined as cto/cfrom.
subroutine slacpy(UPLO, M, N, A, LDA, B, LDB)
SLACPY copies all or part of one two-dimensional array to another.
real function slamch(CMACH)
SLAMCH
subroutine sgeqrf(M, N, A, LDA, TAU, WORK, LWORK, INFO)
SGEQRF
subroutine slabad(SMALL, LARGE)
SLABAD
integer function ilaenv(ISPEC, NAME, OPTS, N1, N2, N3, N4)
subroutine sggev(JOBVL, JOBVR, N, A, LDA, B, LDB, ALPHAR, ALPHAI, BETA, VL, LDVL, VR, LDVR, WORK, LWORK, INFO)
SGGEV computes the eigenvalues and, optionally, the left and/or right eigenvectors for GE matrices ...
subroutine sorgqr(M, N, K, A, LDA, TAU, WORK, LWORK, INFO)
SORGQR
subroutine sggbak(JOB, SIDE, N, ILO, IHI, LSCALE, RSCALE, M, V, LDV, INFO)
SGGBAK