LAPACK  3.10.0
LAPACK: Linear Algebra PACKage
sstect.f
Go to the documentation of this file.
1 *> \brief \b SSTECT
2 *
3 * =========== DOCUMENTATION ===========
4 *
5 * Online html documentation available at
6 * http://www.netlib.org/lapack/explore-html/
7 *
8 * Definition:
9 * ===========
10 *
11 * SUBROUTINE SSTECT( N, A, B, SHIFT, NUM )
12 *
13 * .. Scalar Arguments ..
14 * INTEGER N, NUM
15 * REAL SHIFT
16 * ..
17 * .. Array Arguments ..
18 * REAL A( * ), B( * )
19 * ..
20 *
21 *
22 *> \par Purpose:
23 * =============
24 *>
25 *> \verbatim
26 *>
27 *> SSTECT counts the number NUM of eigenvalues of a tridiagonal
28 *> matrix T which are less than or equal to SHIFT. T has
29 *> diagonal entries A(1), ... , A(N), and offdiagonal entries
30 *> B(1), ..., B(N-1).
31 *> See W. Kahan "Accurate Eigenvalues of a Symmetric Tridiagonal
32 *> Matrix", Report CS41, Computer Science Dept., Stanford
33 *> University, July 21, 1966
34 *> \endverbatim
35 *
36 * Arguments:
37 * ==========
38 *
39 *> \param[in] N
40 *> \verbatim
41 *> N is INTEGER
42 *> The dimension of the tridiagonal matrix T.
43 *> \endverbatim
44 *>
45 *> \param[in] A
46 *> \verbatim
47 *> A is REAL array, dimension (N)
48 *> The diagonal entries of the tridiagonal matrix T.
49 *> \endverbatim
50 *>
51 *> \param[in] B
52 *> \verbatim
53 *> B is REAL array, dimension (N-1)
54 *> The offdiagonal entries of the tridiagonal matrix T.
55 *> \endverbatim
56 *>
57 *> \param[in] SHIFT
58 *> \verbatim
59 *> SHIFT is REAL
60 *> The shift, used as described under Purpose.
61 *> \endverbatim
62 *>
63 *> \param[out] NUM
64 *> \verbatim
65 *> NUM is INTEGER
66 *> The number of eigenvalues of T less than or equal
67 *> to SHIFT.
68 *> \endverbatim
69 *
70 * Authors:
71 * ========
72 *
73 *> \author Univ. of Tennessee
74 *> \author Univ. of California Berkeley
75 *> \author Univ. of Colorado Denver
76 *> \author NAG Ltd.
77 *
78 *> \ingroup single_eig
79 *
80 * =====================================================================
81  SUBROUTINE sstect( N, A, B, SHIFT, NUM )
82 *
83 * -- LAPACK test routine --
84 * -- LAPACK is a software package provided by Univ. of Tennessee, --
85 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
86 *
87 * .. Scalar Arguments ..
88  INTEGER N, NUM
89  REAL SHIFT
90 * ..
91 * .. Array Arguments ..
92  REAL A( * ), B( * )
93 * ..
94 *
95 * =====================================================================
96 *
97 * .. Parameters ..
98  REAL ZERO, ONE, THREE
99  parameter( zero = 0.0e0, one = 1.0e0, three = 3.0e0 )
100 * ..
101 * .. Local Scalars ..
102  INTEGER I
103  REAL M1, M2, MX, OVFL, SOV, SSHIFT, SSUN, SUN, TMP,
104  $ TOM, U, UNFL
105 * ..
106 * .. External Functions ..
107  REAL SLAMCH
108  EXTERNAL slamch
109 * ..
110 * .. Intrinsic Functions ..
111  INTRINSIC abs, max, sqrt
112 * ..
113 * .. Executable Statements ..
114 *
115 * Get machine constants
116 *
117  unfl = slamch( 'Safe minimum' )
118  ovfl = slamch( 'Overflow' )
119 *
120 * Find largest entry
121 *
122  mx = abs( a( 1 ) )
123  DO 10 i = 1, n - 1
124  mx = max( mx, abs( a( i+1 ) ), abs( b( i ) ) )
125  10 CONTINUE
126 *
127 * Handle easy cases, including zero matrix
128 *
129  IF( shift.GE.three*mx ) THEN
130  num = n
131  RETURN
132  END IF
133  IF( shift.LT.-three*mx ) THEN
134  num = 0
135  RETURN
136  END IF
137 *
138 * Compute scale factors as in Kahan's report
139 * At this point, MX .NE. 0 so we can divide by it
140 *
141  sun = sqrt( unfl )
142  ssun = sqrt( sun )
143  sov = sqrt( ovfl )
144  tom = ssun*sov
145  IF( mx.LE.one ) THEN
146  m1 = one / mx
147  m2 = tom
148  ELSE
149  m1 = one
150  m2 = tom / mx
151  END IF
152 *
153 * Begin counting
154 *
155  num = 0
156  sshift = ( shift*m1 )*m2
157  u = ( a( 1 )*m1 )*m2 - sshift
158  IF( u.LE.sun ) THEN
159  IF( u.LE.zero ) THEN
160  num = num + 1
161  IF( u.GT.-sun )
162  $ u = -sun
163  ELSE
164  u = sun
165  END IF
166  END IF
167  DO 20 i = 2, n
168  tmp = ( b( i-1 )*m1 )*m2
169  u = ( ( a( i )*m1 )*m2-tmp*( tmp / u ) ) - sshift
170  IF( u.LE.sun ) THEN
171  IF( u.LE.zero ) THEN
172  num = num + 1
173  IF( u.GT.-sun )
174  $ u = -sun
175  ELSE
176  u = sun
177  END IF
178  END IF
179  20 CONTINUE
180  RETURN
181 *
182 * End of SSTECT
183 *
184  END
subroutine sstect(N, A, B, SHIFT, NUM)
SSTECT
Definition: sstect.f:82