191 SUBROUTINE sgeev( JOBVL, JOBVR, N, A, LDA, WR, WI, VL, LDVL, VR,
192 $ ldvr, work, lwork, info )
201 CHARACTER JOBVL, JOBVR
202 INTEGER INFO, LDA, LDVL, LDVR, LWORK, N
205 REAL A( lda, * ), VL( ldvl, * ), VR( ldvr, * ),
206 $ wi( * ), work( * ), wr( * )
213 parameter ( zero = 0.0e0, one = 1.0e0 )
216 LOGICAL LQUERY, SCALEA, WANTVL, WANTVR
218 INTEGER HSWORK, I, IBAL, IERR, IHI, ILO, ITAU, IWRK, K,
219 $ lwork_trevc, maxwrk, minwrk, nout
220 REAL ANRM, BIGNUM, CS, CSCALE, EPS, R, SCL, SMLNUM,
234 INTEGER ISAMAX, ILAENV
235 REAL SLAMCH, SLANGE, SLAPY2, SNRM2
236 EXTERNAL lsame, isamax, ilaenv, slamch, slange, slapy2,
247 lquery = ( lwork.EQ.-1 )
248 wantvl = lsame( jobvl,
'V' )
249 wantvr = lsame( jobvr,
'V' )
250 IF( ( .NOT.wantvl ) .AND. ( .NOT.lsame( jobvl,
'N' ) ) )
THEN
252 ELSE IF( ( .NOT.wantvr ) .AND. ( .NOT.lsame( jobvr,
'N' ) ) )
THEN
254 ELSE IF( n.LT.0 )
THEN
256 ELSE IF( lda.LT.max( 1, n ) )
THEN
258 ELSE IF( ldvl.LT.1 .OR. ( wantvl .AND. ldvl.LT.n ) )
THEN
260 ELSE IF( ldvr.LT.1 .OR. ( wantvr .AND. ldvr.LT.n ) )
THEN
279 maxwrk = 2*n + n*ilaenv( 1,
'SGEHRD',
' ', n, 1, n, 0 )
282 maxwrk = max( maxwrk, 2*n + ( n - 1 )*ilaenv( 1,
283 $
'SORGHR',
' ', n, 1, n, -1 ) )
284 CALL shseqr(
'S',
'V', n, 1, n, a, lda, wr, wi, vl, ldvl,
286 hswork = int( work(1) )
287 maxwrk = max( maxwrk, n + 1, n + hswork )
288 CALL strevc3(
'L',
'B',
SELECT, n, a, lda,
289 $ vl, ldvl, vr, ldvr, n, nout,
291 lwork_trevc = int( work(1) )
292 maxwrk = max( maxwrk, n + lwork_trevc )
293 maxwrk = max( maxwrk, 4*n )
294 ELSE IF( wantvr )
THEN
296 maxwrk = max( maxwrk, 2*n + ( n - 1 )*ilaenv( 1,
297 $
'SORGHR',
' ', n, 1, n, -1 ) )
298 CALL shseqr(
'S',
'V', n, 1, n, a, lda, wr, wi, vr, ldvr,
300 hswork = int( work(1) )
301 maxwrk = max( maxwrk, n + 1, n + hswork )
302 CALL strevc3(
'R',
'B',
SELECT, n, a, lda,
303 $ vl, ldvl, vr, ldvr, n, nout,
305 lwork_trevc = int( work(1) )
306 maxwrk = max( maxwrk, n + lwork_trevc )
307 maxwrk = max( maxwrk, 4*n )
310 CALL shseqr(
'E',
'N', n, 1, n, a, lda, wr, wi, vr, ldvr,
312 hswork = int( work(1) )
313 maxwrk = max( maxwrk, n + 1, n + hswork )
315 maxwrk = max( maxwrk, minwrk )
319 IF( lwork.LT.minwrk .AND. .NOT.lquery )
THEN
325 CALL xerbla(
'SGEEV ', -info )
327 ELSE IF( lquery )
THEN
339 smlnum = slamch(
'S' )
340 bignum = one / smlnum
341 CALL slabad( smlnum, bignum )
342 smlnum = sqrt( smlnum ) / eps
343 bignum = one / smlnum
347 anrm = slange(
'M', n, n, a, lda, dum )
349 IF( anrm.GT.zero .AND. anrm.LT.smlnum )
THEN
352 ELSE IF( anrm.GT.bignum )
THEN
357 $
CALL slascl(
'G', 0, 0, anrm, cscale, n, n, a, lda, ierr )
363 CALL sgebal(
'B', n, a, lda, ilo, ihi, work( ibal ), ierr )
370 CALL sgehrd( n, ilo, ihi, a, lda, work( itau ), work( iwrk ),
371 $ lwork-iwrk+1, ierr )
379 CALL slacpy(
'L', n, n, a, lda, vl, ldvl )
384 CALL sorghr( n, ilo, ihi, vl, ldvl, work( itau ), work( iwrk ),
385 $ lwork-iwrk+1, ierr )
391 CALL shseqr(
'S',
'V', n, ilo, ihi, a, lda, wr, wi, vl, ldvl,
392 $ work( iwrk ), lwork-iwrk+1, info )
400 CALL slacpy(
'F', n, n, vl, ldvl, vr, ldvr )
403 ELSE IF( wantvr )
THEN
409 CALL slacpy(
'L', n, n, a, lda, vr, ldvr )
414 CALL sorghr( n, ilo, ihi, vr, ldvr, work( itau ), work( iwrk ),
415 $ lwork-iwrk+1, ierr )
421 CALL shseqr(
'S',
'V', n, ilo, ihi, a, lda, wr, wi, vr, ldvr,
422 $ work( iwrk ), lwork-iwrk+1, info )
430 CALL shseqr(
'E',
'N', n, ilo, ihi, a, lda, wr, wi, vr, ldvr,
431 $ work( iwrk ), lwork-iwrk+1, info )
439 IF( wantvl .OR. wantvr )
THEN
444 CALL strevc3( side,
'B',
SELECT, n, a, lda, vl, ldvl, vr, ldvr,
445 $ n, nout, work( iwrk ), lwork-iwrk+1, ierr )
453 CALL sgebak(
'B',
'L', n, ilo, ihi, work( ibal ), n, vl, ldvl,
459 IF( wi( i ).EQ.zero )
THEN
460 scl = one / snrm2( n, vl( 1, i ), 1 )
461 CALL sscal( n, scl, vl( 1, i ), 1 )
462 ELSE IF( wi( i ).GT.zero )
THEN
463 scl = one / slapy2( snrm2( n, vl( 1, i ), 1 ),
464 $ snrm2( n, vl( 1, i+1 ), 1 ) )
465 CALL sscal( n, scl, vl( 1, i ), 1 )
466 CALL sscal( n, scl, vl( 1, i+1 ), 1 )
468 work( iwrk+k-1 ) = vl( k, i )**2 + vl( k, i+1 )**2
470 k = isamax( n, work( iwrk ), 1 )
471 CALL slartg( vl( k, i ), vl( k, i+1 ), cs, sn, r )
472 CALL srot( n, vl( 1, i ), 1, vl( 1, i+1 ), 1, cs, sn )
483 CALL sgebak(
'B',
'R', n, ilo, ihi, work( ibal ), n, vr, ldvr,
489 IF( wi( i ).EQ.zero )
THEN
490 scl = one / snrm2( n, vr( 1, i ), 1 )
491 CALL sscal( n, scl, vr( 1, i ), 1 )
492 ELSE IF( wi( i ).GT.zero )
THEN
493 scl = one / slapy2( snrm2( n, vr( 1, i ), 1 ),
494 $ snrm2( n, vr( 1, i+1 ), 1 ) )
495 CALL sscal( n, scl, vr( 1, i ), 1 )
496 CALL sscal( n, scl, vr( 1, i+1 ), 1 )
498 work( iwrk+k-1 ) = vr( k, i )**2 + vr( k, i+1 )**2
500 k = isamax( n, work( iwrk ), 1 )
501 CALL slartg( vr( k, i ), vr( k, i+1 ), cs, sn, r )
502 CALL srot( n, vr( 1, i ), 1, vr( 1, i+1 ), 1, cs, sn )
512 CALL slascl(
'G', 0, 0, cscale, anrm, n-info, 1, wr( info+1 ),
513 $ max( n-info, 1 ), ierr )
514 CALL slascl(
'G', 0, 0, cscale, anrm, n-info, 1, wi( info+1 ),
515 $ max( n-info, 1 ), ierr )
517 CALL slascl(
'G', 0, 0, cscale, anrm, ilo-1, 1, wr, n,
519 CALL slascl(
'G', 0, 0, cscale, anrm, ilo-1, 1, wi, n,
subroutine slartg(F, G, CS, SN, R)
SLARTG generates a plane rotation with real cosine and real sine.
subroutine sgehrd(N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO)
SGEHRD
subroutine sgebak(JOB, SIDE, N, ILO, IHI, SCALE, M, V, LDV, INFO)
SGEBAK
subroutine sorghr(N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO)
SORGHR
subroutine srot(N, SX, INCX, SY, INCY, C, S)
SROT
subroutine sgebal(JOB, N, A, LDA, ILO, IHI, SCALE, INFO)
SGEBAL
subroutine xerbla(SRNAME, INFO)
XERBLA
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 strevc3(SIDE, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR, LDVR, MM, M, WORK, LWORK, INFO)
STREVC3
subroutine slabad(SMALL, LARGE)
SLABAD
subroutine sscal(N, SA, SX, INCX)
SSCAL
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 slacpy(UPLO, M, N, A, LDA, B, LDB)
SLACPY copies all or part of one two-dimensional array to another.
subroutine shseqr(JOB, COMPZ, N, ILO, IHI, H, LDH, WR, WI, Z, LDZ, WORK, LWORK, INFO)
SHSEQR