311 SUBROUTINE sstemr( JOBZ, RANGE, N, D, E, VL, VU, IL, IU,
312 $ m, w, z, ldz, nzc, isuppz, tryrac, work, lwork,
313 $ iwork, liwork, info )
321 CHARACTER jobz, range
323 INTEGER il, info, iu, ldz, nzc, liwork, lwork, m, n
327 INTEGER isuppz( * ), iwork( * )
328 REAL d( * ), e( * ), w( * ), work( * )
335 REAL zero, one, four, minrgp
336 parameter( zero = 0.0e0, one = 1.0e0,
341 LOGICAL alleig, indeig, lquery, valeig, wantz, zquery
342 INTEGER i, ibegin, iend, ifirst, iil, iindbl, iindw,
343 $ iindwk, iinfo, iinspl, iiu, ilast, in, indd,
344 $ inde2, inderr, indgp, indgrs, indwrk, itmp,
345 $ itmp2,
j, jblk, jj, liwmin, lwmin, nsplit,
346 $ nzcmin, offset, wbegin, wend
347 REAL bignum, cs, eps, pivmin, r1, r2, rmax, rmin,
348 $ rtol1, rtol2, safmin, scale, smlnum, sn,
349 $ thresh, tmp, tnrm, wl, wu
362 INTRINSIC max, min, sqrt
368 wantz =
lsame( jobz,
'V' )
369 alleig =
lsame( range,
'A' )
370 valeig =
lsame( range,
'V' )
371 indeig =
lsame( range,
'I' )
373 lquery = ( ( lwork.EQ.-1 ).OR.( liwork.EQ.-1 ) )
374 zquery = ( nzc.EQ.-1 )
400 ELSEIF( indeig )
THEN
407 IF( .NOT.( wantz .OR.
lsame( jobz,
'N' ) ) )
THEN
409 ELSE IF( .NOT.( alleig .OR. valeig .OR. indeig ) )
THEN
411 ELSE IF( n.LT.0 )
THEN
413 ELSE IF( valeig .AND. n.GT.0 .AND. wu.LE.wl )
THEN
415 ELSE IF( indeig .AND. ( iil.LT.1 .OR. iil.GT.n ) )
THEN
417 ELSE IF( indeig .AND. ( iiu.LT.iil .OR. iiu.GT.n ) )
THEN
419 ELSE IF( ldz.LT.1 .OR. ( wantz .AND. ldz.LT.n ) )
THEN
421 ELSE IF( lwork.LT.lwmin .AND. .NOT.lquery )
THEN
423 ELSE IF( liwork.LT.liwmin .AND. .NOT.lquery )
THEN
429 safmin =
slamch(
'Safe minimum' )
430 eps =
slamch(
'Precision' )
431 smlnum = safmin / eps
432 bignum = one / smlnum
433 rmin = sqrt( smlnum )
434 rmax = min( sqrt( bignum ), one / sqrt( sqrt( safmin ) ) )
440 IF( wantz .AND. alleig )
THEN
442 ELSE IF( wantz .AND. valeig )
THEN
443 CALL
slarrc(
'T', n, vl, vu, d, e, safmin,
444 $ nzcmin, itmp, itmp2, info )
445 ELSE IF( wantz .AND. indeig )
THEN
451 IF( zquery .AND. info.EQ.0 )
THEN
453 ELSE IF( nzc.LT.nzcmin .AND. .NOT.zquery )
THEN
460 CALL
xerbla(
'SSTEMR', -info )
463 ELSE IF( lquery .OR. zquery )
THEN
474 IF( alleig .OR. indeig )
THEN
478 IF( wl.LT.d( 1 ) .AND. wu.GE.d( 1 ) )
THEN
483 IF( wantz.AND.(.NOT.zquery) )
THEN
492 IF( .NOT.wantz )
THEN
493 CALL
slae2( d(1), e(1), d(2), r1, r2 )
494 ELSE IF( wantz.AND.(.NOT.zquery) )
THEN
495 CALL
slaev2( d(1), e(1), d(2), r1, r2, cs, sn )
498 $ (valeig.AND.(r2.GT.wl).AND.
500 $ (indeig.AND.(iil.EQ.1)) )
THEN
503 IF( wantz.AND.(.NOT.zquery) )
THEN
522 $ (valeig.AND.(r1.GT.wl).AND.
524 $ (indeig.AND.(iiu.EQ.2)) )
THEN
527 IF( wantz.AND.(.NOT.zquery) )
THEN
568 tnrm =
slanst(
'M', n, d, e )
569 IF( tnrm.GT.zero .AND. tnrm.LT.rmin )
THEN
571 ELSE IF( tnrm.GT.rmax )
THEN
574 IF( scale.NE.one )
THEN
575 CALL
sscal( n, scale, d, 1 )
576 CALL
sscal( n-1, scale, e, 1 )
596 CALL
slarrr( n, d, e, iinfo )
612 CALL
scopy(n,d,1,work(indd),1)
616 work( inde2+
j-1 ) = e(
j)**2
620 IF( .NOT.wantz )
THEN
629 rtol1 = max( sqrt(eps)*5.0e-2, four * eps )
630 rtol2 = max( sqrt(eps)*5.0e-3, four * eps )
632 CALL
slarre( range, n, wl, wu, iil, iiu, d, e,
633 $ work(inde2), rtol1, rtol2, thresh, nsplit,
634 $ iwork( iinspl ), m, w, work( inderr ),
635 $ work( indgp ), iwork( iindbl ),
636 $ iwork( iindw ), work( indgrs ), pivmin,
637 $ work( indwrk ), iwork( iindwk ), iinfo )
638 IF( iinfo.NE.0 )
THEN
639 info = 10 + abs( iinfo )
652 CALL
slarrv( n, wl, wu, d, e,
653 $ pivmin, iwork( iinspl ), m,
654 $ 1, m, minrgp, rtol1, rtol2,
655 $ w, work( inderr ), work( indgp ), iwork( iindbl ),
656 $ iwork( iindw ), work( indgrs ), z, ldz,
657 $ isuppz, work( indwrk ), iwork( iindwk ), iinfo )
658 IF( iinfo.NE.0 )
THEN
659 info = 20 + abs( iinfo )
669 itmp = iwork( iindbl+
j-1 )
670 w(
j ) = w(
j ) + e( iwork( iinspl+itmp-1 ) )
680 DO 39 jblk = 1, iwork( iindbl+m-1 )
681 iend = iwork( iinspl+jblk-1 )
682 in = iend - ibegin + 1
687 IF( iwork( iindbl+wend ).EQ.jblk )
THEN
692 IF( wend.LT.wbegin )
THEN
697 offset = iwork(iindw+wbegin-1)-1
698 ifirst = iwork(iindw+wbegin-1)
699 ilast = iwork(iindw+wend-1)
702 $ work(indd+ibegin-1), work(inde2+ibegin-1),
703 $ ifirst, ilast, rtol2, offset, w(wbegin),
704 $ work( inderr+wbegin-1 ),
705 $ work( indwrk ), iwork( iindwk ), pivmin,
714 IF( scale.NE.one )
THEN
715 CALL
sscal( m, one / scale, w, 1 )
722 IF( nsplit.GT.1 .OR. n.EQ.2 )
THEN
723 IF( .NOT. wantz )
THEN
724 CALL
slasrt(
'I', m, w, iinfo )
725 IF( iinfo.NE.0 )
THEN
734 IF( w( jj ).LT.tmp )
THEN
743 CALL
sswap( n, z( 1, i ), 1, z( 1,
j ), 1 )
744 itmp = isuppz( 2*i-1 )
745 isuppz( 2*i-1 ) = isuppz( 2*
j-1 )
746 isuppz( 2*
j-1 ) = itmp
748 isuppz( 2*i ) = isuppz( 2*
j )