cstein()

subroutine cstein	(	integer	n,
		real, dimension( * )	d,
		real, dimension( * )	e,
		integer	m,
		real, dimension( * )	w,
		integer, dimension( * )	iblock,
		integer, dimension( * )	isplit,
		complex, dimension( ldz, * )	z,
		integer	ldz,
		real, dimension( * )	work,
		integer, dimension( * )	iwork,
		integer, dimension( * )	ifail,
		integer	info )

CSTEIN

Download CSTEIN + dependencies [TGZ] [ZIP] [TXT]

Purpose:

!>
!> CSTEIN computes the eigenvectors of a real symmetric tridiagonal
!> matrix T corresponding to specified eigenvalues, using inverse
!> iteration.
!>
!> The maximum number of iterations allowed for each eigenvector is
!> specified by an internal parameter MAXITS (currently set to 5).
!>
!> Although the eigenvectors are real, they are stored in a complex
!> array, which may be passed to CUNMTR or CUPMTR for back
!> transformation to the eigenvectors of a complex Hermitian matrix
!> which was reduced to tridiagonal form.
!>
!> 

Parameters

[in]	N	!> N is INTEGER !> The order of the matrix. N >= 0. !>
[in]	D	!> D is REAL array, dimension (N) !> The n diagonal elements of the tridiagonal matrix T. !>
[in]	E	!> E is REAL array, dimension (N-1) !> The (n-1) subdiagonal elements of the tridiagonal matrix !> T, stored in elements 1 to N-1. !>
[in]	M	!> M is INTEGER !> The number of eigenvectors to be found. 0 <= M <= N. !>
[in]	W	!> W is REAL array, dimension (N) !> The first M elements of W contain the eigenvalues for !> which eigenvectors are to be computed. The eigenvalues !> should be grouped by split-off block and ordered from !> smallest to largest within the block. ( The output array !> W from SSTEBZ with ORDER = 'B' is expected here. ) !>
[in]	IBLOCK	!> IBLOCK is INTEGER array, dimension (N) !> The submatrix indices associated with the corresponding !> eigenvalues in W; IBLOCK(i)=1 if eigenvalue W(i) belongs to !> the first submatrix from the top, =2 if W(i) belongs to !> the second submatrix, etc. ( The output array IBLOCK !> from SSTEBZ is expected here. ) !>
[in]	ISPLIT	!> ISPLIT is INTEGER array, dimension (N) !> The splitting points, at which T breaks up into submatrices. !> The first submatrix consists of rows/columns 1 to !> ISPLIT( 1 ), the second of rows/columns ISPLIT( 1 )+1 !> through ISPLIT( 2 ), etc. !> ( The output array ISPLIT from SSTEBZ is expected here. ) !>
[out]	Z	!> Z is COMPLEX array, dimension (LDZ, M) !> The computed eigenvectors. The eigenvector associated !> with the eigenvalue W(i) is stored in the i-th column of !> Z. Any vector which fails to converge is set to its current !> iterate after MAXITS iterations. !> The imaginary parts of the eigenvectors are set to zero. !>
[in]	LDZ	!> LDZ is INTEGER !> The leading dimension of the array Z. LDZ >= max(1,N). !>
[out]	WORK	!> WORK is REAL array, dimension (5*N) !>
[out]	IWORK	!> IWORK is INTEGER array, dimension (N) !>
[out]	IFAIL	!> IFAIL is INTEGER array, dimension (M) !> On normal exit, all elements of IFAIL are zero. !> If one or more eigenvectors fail to converge after !> MAXITS iterations, then their indices are stored in !> array IFAIL. !>
[out]	INFO	!> INFO is INTEGER !> = 0: successful exit !> < 0: if INFO = -i, the i-th argument had an illegal value !> > 0: if INFO = i, then i eigenvectors failed to converge !> in MAXITS iterations. Their indices are stored in !> array IFAIL. !>

Internal Parameters:

!>  MAXITS  INTEGER, default = 5
!>          The maximum number of iterations performed.
!>
!>  EXTRA   INTEGER, default = 2
!>          The number of iterations performed after norm growth
!>          criterion is satisfied, should be at least 1.
!> 

Author

Univ. of Tennessee

Univ. of California Berkeley

Univ. of Colorado Denver

NAG Ltd.

Definition at line 178 of file cstein.f.

*
*  -- LAPACK computational routine --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
*     .. Scalar Arguments ..
      INTEGER            INFO, LDZ, M, N
*     ..
*     .. Array Arguments ..
      INTEGER            IBLOCK( * ), IFAIL( * ), ISPLIT( * ),
     $                   IWORK( * )
      REAL               D( * ), E( * ), W( * ), WORK( * )
      COMPLEX            Z( LDZ, * )
*     ..
*
* =====================================================================
*
*     .. Parameters ..
      COMPLEX            CZERO, CONE
      parameter( czero = ( 0.0e+0, 0.0e+0 ),
     $                   cone = ( 1.0e+0, 0.0e+0 ) )
      REAL               ZERO, ONE, TEN, ODM3, ODM1
      parameter( zero = 0.0e+0, one = 1.0e+0, ten = 1.0e+1,
     $                   odm3 = 1.0e-3, odm1 = 1.0e-1 )
      INTEGER            MAXITS, EXTRA
      parameter( maxits = 5, extra = 2 )
*     ..
*     .. Local Scalars ..
      INTEGER            B1, BLKSIZ, BN, GPIND, I, IINFO, INDRV1,
     $                   INDRV2, INDRV3, INDRV4, INDRV5, ITS, J, J1,
     $                   JBLK, JMAX, JR, NBLK, NRMCHK
      REAL               CTR, EPS, EPS1, NRM, ONENRM, ORTOL, PERTOL,
     $                   SCL, SEP, STPCRT, TOL, XJ, XJM
*     ..
*     .. Local Arrays ..
      INTEGER            ISEED( 4 )
*     ..
*     .. External Functions ..
      INTEGER            ISAMAX
      REAL               SLAMCH, SNRM2
      EXTERNAL           isamax, slamch, snrm2
*     ..
*     .. External Subroutines ..
      EXTERNAL           scopy, slagtf, slagts, slarnv, sscal,
     $                   xerbla
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          abs, cmplx, max, real, sqrt
*     ..
*     .. Executable Statements ..
*
*     Test the input parameters.
*
      info = 0
      DO 10 i = 1, m
         ifail( i ) = 0
   10 CONTINUE
*
      IF( n.LT.0 ) THEN
         info = -1
      ELSE IF( m.LT.0 .OR. m.GT.n ) THEN
         info = -4
      ELSE IF( ldz.LT.max( 1, n ) ) THEN
         info = -9
      ELSE
         DO 20 j = 2, m
            IF( iblock( j ).LT.iblock( j-1 ) ) THEN
               info = -6
               GO TO 30
            END IF
            IF( iblock( j ).EQ.iblock( j-1 ) .AND. w( j ).LT.w( j-1 ) )
     $           THEN
               info = -5
               GO TO 30
            END IF
   20    CONTINUE
   30    CONTINUE
      END IF
*
      IF( info.NE.0 ) THEN
         CALL xerbla( 'CSTEIN', -info )
         RETURN
      END IF
*
*     Quick return if possible
*
      IF( n.EQ.0 .OR. m.EQ.0 ) THEN
         RETURN
      ELSE IF( n.EQ.1 ) THEN
         z( 1, 1 ) = cone
         RETURN
      END IF
*
*     Get machine constants.
*
      eps = slamch( 'Precision' )
*
*     Initialize seed for random number generator SLARNV.
*
      DO 40 i = 1, 4
         iseed( i ) = 1
   40 CONTINUE
*
*     Initialize pointers.
*
      indrv1 = 0
      indrv2 = indrv1 + n
      indrv3 = indrv2 + n
      indrv4 = indrv3 + n
      indrv5 = indrv4 + n
*
*     Compute eigenvectors of matrix blocks.
*
      j1 = 1
      DO 180 nblk = 1, iblock( m )
*
*        Find starting and ending indices of block nblk.
*
         IF( nblk.EQ.1 ) THEN
            b1 = 1
         ELSE
            b1 = isplit( nblk-1 ) + 1
         END IF
         bn = isplit( nblk )
         blksiz = bn - b1 + 1
         IF( blksiz.EQ.1 )
     $      GO TO 60
         gpind = j1
*
*        Compute reorthogonalization criterion and stopping criterion.
*
         onenrm = abs( d( b1 ) ) + abs( e( b1 ) )
         onenrm = max( onenrm, abs( d( bn ) )+abs( e( bn-1 ) ) )
         DO 50 i = b1 + 1, bn - 1
            onenrm = max( onenrm, abs( d( i ) )+abs( e( i-1 ) )+
     $               abs( e( i ) ) )
   50    CONTINUE
         ortol = odm3*onenrm
*
         stpcrt = sqrt( odm1 / real( blksiz ) )
*
*        Loop through eigenvalues of block nblk.
*
   60    CONTINUE
         jblk = 0
         DO 170 j = j1, m
            IF( iblock( j ).NE.nblk ) THEN
               j1 = j
               GO TO 180
            END IF
            jblk = jblk + 1
            xj = w( j )
*
*           Skip all the work if the block size is one.
*
            IF( blksiz.EQ.1 ) THEN
               work( indrv1+1 ) = one
               GO TO 140
            END IF
*
*           If eigenvalues j and j-1 are too close, add a relatively
*           small perturbation.
*
            IF( jblk.GT.1 ) THEN
               eps1 = abs( eps*xj )
               pertol = ten*eps1
               sep = xj - xjm
               IF( sep.LT.pertol )
     $            xj = xjm + pertol
            END IF
*
            its = 0
            nrmchk = 0
*
*           Get random starting vector.
*
            CALL slarnv( 2, iseed, blksiz, work( indrv1+1 ) )
*
*           Copy the matrix T so it won't be destroyed in factorization.
*
            CALL scopy( blksiz, d( b1 ), 1, work( indrv4+1 ), 1 )
            CALL scopy( blksiz-1, e( b1 ), 1, work( indrv2+2 ), 1 )
            CALL scopy( blksiz-1, e( b1 ), 1, work( indrv3+1 ), 1 )
*
*           Compute LU factors with partial pivoting  ( PT = LU )
*
            tol = zero
            CALL slagtf( blksiz, work( indrv4+1 ), xj,
     $                   work( indrv2+2 ),
     $                   work( indrv3+1 ), tol, work( indrv5+1 ), iwork,
     $                   iinfo )
*
*           Update iteration count.
*
   70       CONTINUE
            its = its + 1
            IF( its.GT.maxits )
     $         GO TO 120
*
*           Normalize and scale the righthand side vector Pb.
*
            jmax = isamax( blksiz, work( indrv1+1 ), 1 )
            scl = real( blksiz )*onenrm*max( eps,
     $            abs( work( indrv4+blksiz ) ) ) /
     $            abs( work( indrv1+jmax ) )
            CALL sscal( blksiz, scl, work( indrv1+1 ), 1 )
*
*           Solve the system LU = Pb.
*
            CALL slagts( -1, blksiz, work( indrv4+1 ),
     $                   work( indrv2+2 ),
     $                   work( indrv3+1 ), work( indrv5+1 ), iwork,
     $                   work( indrv1+1 ), tol, iinfo )
*
*           Reorthogonalize by modified Gram-Schmidt if eigenvalues are
*           close enough.
*
            IF( jblk.EQ.1 )
     $         GO TO 110
            IF( abs( xj-xjm ).GT.ortol )
     $         gpind = j
            IF( gpind.NE.j ) THEN
               DO 100 i = gpind, j - 1
                  ctr = zero
                  DO 80 jr = 1, blksiz
                     ctr = ctr + work( indrv1+jr )*
     $                     real( z( b1-1+jr, i ) )
   80             CONTINUE
                  DO 90 jr = 1, blksiz
                     work( indrv1+jr ) = work( indrv1+jr ) -
     $                                   ctr*real( z( b1-1+jr, i ) )
   90             CONTINUE
  100          CONTINUE
            END IF
*
*           Check the infinity norm of the iterate.
*
  110       CONTINUE
            jmax = isamax( blksiz, work( indrv1+1 ), 1 )
            nrm = abs( work( indrv1+jmax ) )
*
*           Continue for additional iterations after norm reaches
*           stopping criterion.
*
            IF( nrm.LT.stpcrt )
     $         GO TO 70
            nrmchk = nrmchk + 1
            IF( nrmchk.LT.extra+1 )
     $         GO TO 70
*
            GO TO 130
*
*           If stopping criterion was not satisfied, update info and
*           store eigenvector number in array ifail.
*
  120       CONTINUE
            info = info + 1
            ifail( info ) = j
*
*           Accept iterate as jth eigenvector.
*
  130       CONTINUE
            scl = one / snrm2( blksiz, work( indrv1+1 ), 1 )
            jmax = isamax( blksiz, work( indrv1+1 ), 1 )
            IF( work( indrv1+jmax ).LT.zero )
     $         scl = -scl
            CALL sscal( blksiz, scl, work( indrv1+1 ), 1 )
  140       CONTINUE
            DO 150 i = 1, n
               z( i, j ) = czero
  150       CONTINUE
            DO 160 i = 1, blksiz
               z( b1+i-1, j ) = cmplx( work( indrv1+i ), zero )
  160       CONTINUE
*
*           Save the shift to check eigenvalue spacing at next
*           iteration.
*
            xjm = xj
*
  170    CONTINUE
  180 CONTINUE
*
      RETURN
*
*     End of CSTEIN
*

Here is the call graph for this function:

Here is the caller graph for this function: