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,
231 INTEGER ILAENV, ISAMAX
232 REAL SLAMCH, SLANGE, SLAPY2, SNRM2
233 EXTERNAL lsame, ilaenv, isamax, slamch, slange, slapy2,
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
326 smlnum = slamch(
'S' )
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
450 scl = one / slapy2( snrm2( n, vl( 1, i ), 1 ),
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
480 scl = one / slapy2( snrm2( n, vr( 1, i ), 1 ),
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,
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.
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.
subroutine sscal(N, SA, SX, INCX)
SSCAL
subroutine srot(N, SX, INCX, SY, INCY, C, S)
SROT