322 $ Q, LDQ, VL, VU, IL, IU, ABSTOL, M, W,
323 $ Z, LDZ, WORK, LWORK, RWORK, IWORK,
333 CHARACTER JOBZ, RANGE, UPLO
334 INTEGER IL, INFO, IU, KD, LDAB, LDQ, LDZ, M, N, LWORK
338 INTEGER IFAIL( * ), IWORK( * )
339 REAL RWORK( * ), W( * )
340 COMPLEX AB( LDAB, * ), Q( LDQ, * ), WORK( * ),
348 PARAMETER ( ZERO = 0.0e0, one = 1.0e0 )
350 parameter( czero = ( 0.0e0, 0.0e0 ),
351 $ cone = ( 1.0e0, 0.0e0 ) )
354 LOGICAL ALLEIG, INDEIG, LOWER, TEST, VALEIG, WANTZ,
357 INTEGER I, IINFO, IMAX, INDD, INDE, INDEE, INDIBL,
358 $ INDISP, INDIWK, INDRWK, INDWRK, ISCALE, ITMP1,
359 $ llwork, lwmin, lhtrd, lwtrd, ib, indhous,
361 REAL ABSTLL, ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN,
362 $ SIGMA, SMLNUM, TMP1, VLL, VUU
368 REAL SLAMCH, CLANHB, SROUNDUP_LWORK
369 EXTERNAL lsame, slamch, clanhb, ilaenv2stage,
379 INTRINSIC real, max, min, sqrt
385 wantz = lsame( jobz,
'V' )
386 alleig = lsame( range,
'A' )
387 valeig = lsame( range,
'V' )
388 indeig = lsame( range,
'I' )
389 lower = lsame( uplo,
'L' )
390 lquery = ( lwork.EQ.-1 )
393 IF( .NOT.( lsame( jobz,
'N' ) ) )
THEN
395 ELSE IF( .NOT.( alleig .OR. valeig .OR. indeig ) )
THEN
397 ELSE IF( .NOT.( lower .OR. lsame( uplo,
'U' ) ) )
THEN
399 ELSE IF( n.LT.0 )
THEN
401 ELSE IF( kd.LT.0 )
THEN
403 ELSE IF( ldab.LT.kd+1 )
THEN
405 ELSE IF( wantz .AND. ldq.LT.max( 1, n ) )
THEN
409 IF( n.GT.0 .AND. vu.LE.vl )
411 ELSE IF( indeig )
THEN
412 IF( il.LT.1 .OR. il.GT.max( 1, n ) )
THEN
414 ELSE IF( iu.LT.min( n, il ) .OR. iu.GT.n )
THEN
420 IF( ldz.LT.1 .OR. ( wantz .AND. ldz.LT.n ) )
427 work( 1 ) = sroundup_lwork(lwmin)
429 ib = ilaenv2stage( 2,
'CHETRD_HB2ST', jobz,
431 lhtrd = ilaenv2stage( 3,
'CHETRD_HB2ST', jobz,
433 lwtrd = ilaenv2stage( 4,
'CHETRD_HB2ST', jobz,
435 lwmin = lhtrd + lwtrd
436 work( 1 ) = sroundup_lwork(lwmin)
439 IF( lwork.LT.lwmin .AND. .NOT.lquery )
444 CALL xerbla(
'CHBEVX_2STAGE', -info )
446 ELSE IF( lquery )
THEN
461 ctmp1 = ab( kd+1, 1 )
465 IF( .NOT.( vl.LT.tmp1 .AND. vu.GE.tmp1 ) )
469 w( 1 ) = real( ctmp1 )
478 safmin = slamch(
'Safe minimum' )
479 eps = slamch(
'Precision' )
480 smlnum = safmin / eps
481 bignum = one / smlnum
482 rmin = sqrt( smlnum )
483 rmax = min( sqrt( bignum ), one / sqrt( sqrt( safmin ) ) )
496 anrm = clanhb(
'M', uplo, n, kd, ab, ldab, rwork )
497 IF( anrm.GT.zero .AND. anrm.LT.rmin )
THEN
500 ELSE IF( anrm.GT.rmax )
THEN
504 IF( iscale.EQ.1 )
THEN
506 CALL clascl(
'B', kd, kd, one, sigma, n, n, ab, ldab,
509 CALL clascl(
'Q', kd, kd, one, sigma, n, n, ab, ldab,
513 $ abstll = abstol*sigma
527 indwrk = indhous + lhtrd
528 llwork = lwork - indwrk + 1
531 $ rwork( indd ), rwork( inde ), work( indhous ),
532 $ lhtrd, work( indwrk ), llwork, iinfo )
540 IF (il.EQ.1 .AND. iu.EQ.n)
THEN
544 IF ((alleig .OR. test) .AND. (abstol.LE.zero))
THEN
545 CALL scopy( n, rwork( indd ), 1, w, 1 )
547 IF( .NOT.wantz )
THEN
548 CALL scopy( n-1, rwork( inde ), 1, rwork( indee ), 1 )
549 CALL ssterf( n, w, rwork( indee ), info )
551 CALL clacpy(
'A', n, n, q, ldq, z, ldz )
552 CALL scopy( n-1, rwork( inde ), 1, rwork( indee ), 1 )
553 CALL csteqr( jobz, n, w, rwork( indee ), z, ldz,
554 $ rwork( indrwk ), info )
578 CALL sstebz( range, order, n, vll, vuu, il, iu, abstll,
579 $ rwork( indd ), rwork( inde ), m, nsplit, w,
580 $ iwork( indibl ), iwork( indisp ), rwork( indrwk ),
581 $ iwork( indiwk ), info )
584 CALL cstein( n, rwork( indd ), rwork( inde ), m, w,
585 $ iwork( indibl ), iwork( indisp ), z, ldz,
586 $ rwork( indrwk ), iwork( indiwk ), ifail, info )
592 CALL ccopy( n, z( 1, j ), 1, work( 1 ), 1 )
593 CALL cgemv(
'N', n, n, cone, q, ldq, work, 1, czero,
601 IF( iscale.EQ.1 )
THEN
607 CALL sscal( imax, one / sigma, w, 1 )
618 IF( w( jj ).LT.tmp1 )
THEN
625 itmp1 = iwork( indibl+i-1 )
627 iwork( indibl+i-1 ) = iwork( indibl+j-1 )
629 iwork( indibl+j-1 ) = itmp1
630 CALL cswap( n, z( 1, i ), 1, z( 1, j ), 1 )
633 ifail( i ) = ifail( j )
642 work( 1 ) = sroundup_lwork(lwmin)