189 SUBROUTINE sgeev( JOBVL, JOBVR, N, A, LDA, WR, WI, VL, LDVL, VR,
190 $ ldvr, work, lwork, info )
198 CHARACTER jobvl, jobvr
199 INTEGER info, lda, ldvl, ldvr, lwork, n
202 REAL a( lda, * ), vl( ldvl, * ), vr( ldvr, * ),
203 $ wi( * ), work( * ), wr( * )
210 parameter( zero = 0.0e0, one = 1.0e0 )
213 LOGICAL lquery, scalea, wantvl, wantvr
215 INTEGER hswork, i, ibal, ierr, ihi, ilo, itau, iwrk, k,
216 $ maxwrk, minwrk, nout
217 REAL anrm, bignum, cs, cscale, eps, r, scl, smlnum,
244 lquery = ( lwork.EQ.-1 )
245 wantvl =
lsame( jobvl,
'V' )
246 wantvr =
lsame( jobvr,
'V' )
247 IF( ( .NOT.wantvl ) .AND. ( .NOT.
lsame( jobvl,
'N' ) ) )
THEN
249 ELSE IF( ( .NOT.wantvr ) .AND. ( .NOT.
lsame( jobvr,
'N' ) ) )
THEN
251 ELSE IF( n.LT.0 )
THEN
253 ELSE IF( lda.LT.max( 1, n ) )
THEN
255 ELSE IF( ldvl.LT.1 .OR. ( wantvl .AND. ldvl.LT.n ) )
THEN
257 ELSE IF( ldvr.LT.1 .OR. ( wantvr .AND. ldvr.LT.n ) )
THEN
276 maxwrk = 2*n + n*
ilaenv( 1,
'SGEHRD',
' ', n, 1, n, 0 )
279 maxwrk = max( maxwrk, 2*n + ( n - 1 )*
ilaenv( 1,
280 $
'SORGHR',
' ', n, 1, n, -1 ) )
281 CALL
shseqr(
'S',
'V', n, 1, n, a, lda, wr, wi, vl, ldvl,
284 maxwrk = max( maxwrk, n + 1, n + hswork )
285 maxwrk = max( maxwrk, 4*n )
286 ELSE IF( wantvr )
THEN
288 maxwrk = max( maxwrk, 2*n + ( n - 1 )*
ilaenv( 1,
289 $
'SORGHR',
' ', n, 1, n, -1 ) )
290 CALL
shseqr(
'S',
'V', n, 1, n, a, lda, wr, wi, vr, ldvr,
293 maxwrk = max( maxwrk, n + 1, n + hswork )
294 maxwrk = max( maxwrk, 4*n )
297 CALL
shseqr(
'E',
'N', n, 1, n, a, lda, wr, wi, vr, ldvr,
300 maxwrk = max( maxwrk, n + 1, n + hswork )
302 maxwrk = max( maxwrk, minwrk )
306 IF( lwork.LT.minwrk .AND. .NOT.lquery )
THEN
312 CALL
xerbla(
'SGEEV ', -info )
314 ELSE IF( lquery )
THEN
327 bignum = one / smlnum
328 CALL
slabad( smlnum, bignum )
329 smlnum = sqrt( smlnum ) / eps
330 bignum = one / smlnum
334 anrm =
slange(
'M', n, n, a, lda, dum )
336 IF( anrm.GT.zero .AND. anrm.LT.smlnum )
THEN
339 ELSE IF( anrm.GT.bignum )
THEN
344 $ CALL
slascl(
'G', 0, 0, anrm, cscale, n, n, a, lda, ierr )
350 CALL
sgebal(
'B', n, a, lda, ilo, ihi, work( ibal ), ierr )
357 CALL
sgehrd( n, ilo, ihi, a, lda, work( itau ), work( iwrk ),
358 $ lwork-iwrk+1, ierr )
366 CALL
slacpy(
'L', n, n, a, lda, vl, ldvl )
371 CALL
sorghr( n, ilo, ihi, vl, ldvl, work( itau ), work( iwrk ),
372 $ lwork-iwrk+1, ierr )
378 CALL
shseqr(
'S',
'V', n, ilo, ihi, a, lda, wr, wi, vl, ldvl,
379 $ work( iwrk ), lwork-iwrk+1, info )
387 CALL
slacpy(
'F', n, n, vl, ldvl, vr, ldvr )
390 ELSE IF( wantvr )
THEN
396 CALL
slacpy(
'L', n, n, a, lda, vr, ldvr )
401 CALL
sorghr( n, ilo, ihi, vr, ldvr, work( itau ), work( iwrk ),
402 $ lwork-iwrk+1, ierr )
408 CALL
shseqr(
'S',
'V', n, ilo, ihi, a, lda, wr, wi, vr, ldvr,
409 $ work( iwrk ), lwork-iwrk+1, info )
417 CALL
shseqr(
'E',
'N', n, ilo, ihi, a, lda, wr, wi, vr, ldvr,
418 $ work( iwrk ), lwork-iwrk+1, info )
426 IF( wantvl .OR. wantvr )
THEN
431 CALL
strevc( side,
'B',
SELECT, n, a, lda, vl, ldvl, vr, ldvr,
432 $ n, nout, work( iwrk ), ierr )
440 CALL
sgebak(
'B',
'L', n, ilo, ihi, work( ibal ), n, vl, ldvl,
446 IF( wi( i ).EQ.zero )
THEN
447 scl = one /
snrm2( n, vl( 1, i ), 1 )
448 CALL
sscal( n, scl, vl( 1, i ), 1 )
449 ELSE IF( wi( i ).GT.zero )
THEN
451 $
snrm2( n, vl( 1, i+1 ), 1 ) )
452 CALL
sscal( n, scl, vl( 1, i ), 1 )
453 CALL
sscal( n, scl, vl( 1, i+1 ), 1 )
455 work( iwrk+k-1 ) = vl( k, i )**2 + vl( k, i+1 )**2
457 k =
isamax( n, work( iwrk ), 1 )
458 CALL
slartg( vl( k, i ), vl( k, i+1 ), cs, sn, r )
459 CALL
srot( n, vl( 1, i ), 1, vl( 1, i+1 ), 1, cs, sn )
470 CALL
sgebak(
'B',
'R', n, ilo, ihi, work( ibal ), n, vr, ldvr,
476 IF( wi( i ).EQ.zero )
THEN
477 scl = one /
snrm2( n, vr( 1, i ), 1 )
478 CALL
sscal( n, scl, vr( 1, i ), 1 )
479 ELSE IF( wi( i ).GT.zero )
THEN
481 $
snrm2( n, vr( 1, i+1 ), 1 ) )
482 CALL
sscal( n, scl, vr( 1, i ), 1 )
483 CALL
sscal( n, scl, vr( 1, i+1 ), 1 )
485 work( iwrk+k-1 ) = vr( k, i )**2 + vr( k, i+1 )**2
487 k =
isamax( n, work( iwrk ), 1 )
488 CALL
slartg( vr( k, i ), vr( k, i+1 ), cs, sn, r )
489 CALL
srot( n, vr( 1, i ), 1, vr( 1, i+1 ), 1, cs, sn )
499 CALL
slascl(
'G', 0, 0, cscale, anrm, n-info, 1, wr( info+1 ),
500 $ max( n-info, 1 ), ierr )
501 CALL
slascl(
'G', 0, 0, cscale, anrm, n-info, 1, wi( info+1 ),
502 $ max( n-info, 1 ), ierr )
504 CALL
slascl(
'G', 0, 0, cscale, anrm, ilo-1, 1, wr, n,
506 CALL
slascl(
'G', 0, 0, cscale, anrm, ilo-1, 1, wi, n,
LOGICAL function lsame(CA, CB)
LSAME
INTEGER function isamax(N, SX, INCX)
ISAMAX
REAL function slamch(CMACH)
SLAMCH
REAL function slapy2(X, Y)
SLAPY2 returns sqrt(x2+y2).
subroutine xerbla(SRNAME, INFO)
XERBLA
subroutine sgebak(JOB, SIDE, N, ILO, IHI, SCALE, M, V, LDV, INFO)
SGEBAK
subroutine shseqr(JOB, COMPZ, N, ILO, IHI, H, LDH, WR, WI, Z, LDZ, WORK, LWORK, INFO)
SHSEQR
subroutine sgebal(JOB, N, A, LDA, ILO, IHI, SCALE, INFO)
SGEBAL
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.
INTEGER function ilaenv(ISPEC, NAME, OPTS, N1, N2, N3, N4)
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 sgeev(JOBVL, JOBVR, N, A, LDA, WR, WI, VL, LDVL, VR, LDVR, WORK, LWORK, INFO)
SGEEV computes the eigenvalues and, optionally, the left and/or right eigenvectors for GE matrices ...
subroutine slabad(SMALL, LARGE)
SLABAD
subroutine sorghr(N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO)
SORGHR
subroutine strevc(SIDE, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR, LDVR, MM, M, WORK, INFO)
STREVC
subroutine sgehrd(N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO)
SGEHRD
subroutine slartg(F, G, CS, SN, R)
SLARTG generates a plane rotation with real cosine and real sine.
REAL function snrm2(N, X, INCX)
SNRM2
subroutine sscal(N, SA, SX, INCX)
SSCAL
subroutine srot(N, SX, INCX, SY, INCY, C, S)
SROT