LAPACK  3.4.2
LAPACK: Linear Algebra PACKage
 All Files Functions Groups
cheequb.f
Go to the documentation of this file.
1 *> \brief \b CHEEQUB
2 *
3 * =========== DOCUMENTATION ===========
4 *
5 * Online html documentation available at
6 * http://www.netlib.org/lapack/explore-html/
7 *
8 *> \htmlonly
9 *> Download CHEEQUB + dependencies
10 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/cheequb.f">
11 *> [TGZ]</a>
12 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/cheequb.f">
13 *> [ZIP]</a>
14 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/cheequb.f">
15 *> [TXT]</a>
16 *> \endhtmlonly
17 *
18 * Definition:
19 * ===========
20 *
21 * SUBROUTINE CHEEQUB( UPLO, N, A, LDA, S, SCOND, AMAX, WORK, INFO )
22 *
23 * .. Scalar Arguments ..
24 * INTEGER INFO, LDA, N
25 * REAL AMAX, SCOND
26 * CHARACTER UPLO
27 * ..
28 * .. Array Arguments ..
29 * COMPLEX A( LDA, * ), WORK( * )
30 * REAL S( * )
31 * ..
32 *
33 *
34 *> \par Purpose:
35 * =============
36 *>
37 *> \verbatim
38 *>
39 *> CHEEQUB computes row and column scalings intended to equilibrate a
40 *> Hermitian matrix A and reduce its condition number
41 *> (with respect to the two-norm). S contains the scale factors,
42 *> S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with
43 *> elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal. This
44 *> choice of S puts the condition number of B within a factor N of the
45 *> smallest possible condition number over all possible diagonal
46 *> scalings.
47 *> \endverbatim
48 *
49 * Arguments:
50 * ==========
51 *
52 *> \param[in] UPLO
53 *> \verbatim
54 *> UPLO is CHARACTER*1
55 *> = 'U': Upper triangles of A and B are stored;
56 *> = 'L': Lower triangles of A and B are stored.
57 *> \endverbatim
58 *>
59 *> \param[in] N
60 *> \verbatim
61 *> N is INTEGER
62 *> The order of the matrix A. N >= 0.
63 *> \endverbatim
64 *>
65 *> \param[in] A
66 *> \verbatim
67 *> A is COMPLEX array, dimension (LDA,N)
68 *> The N-by-N Hermitian matrix whose scaling
69 *> factors are to be computed. Only the diagonal elements of A
70 *> are referenced.
71 *> \endverbatim
72 *>
73 *> \param[in] LDA
74 *> \verbatim
75 *> LDA is INTEGER
76 *> The leading dimension of the array A. LDA >= max(1,N).
77 *> \endverbatim
78 *>
79 *> \param[out] S
80 *> \verbatim
81 *> S is REAL array, dimension (N)
82 *> If INFO = 0, S contains the scale factors for A.
83 *> \endverbatim
84 *>
85 *> \param[out] SCOND
86 *> \verbatim
87 *> SCOND is REAL
88 *> If INFO = 0, S contains the ratio of the smallest S(i) to
89 *> the largest S(i). If SCOND >= 0.1 and AMAX is neither too
90 *> large nor too small, it is not worth scaling by S.
91 *> \endverbatim
92 *>
93 *> \param[out] AMAX
94 *> \verbatim
95 *> AMAX is REAL
96 *> Absolute value of largest matrix element. If AMAX is very
97 *> close to overflow or very close to underflow, the matrix
98 *> should be scaled.
99 *> \endverbatim
100 *>
101 *> \param[out] WORK
102 *> \verbatim
103 *> WORK is COMPLEX array, dimension (3*N)
104 *> \endverbatim
105 *>
106 *> \param[out] INFO
107 *> \verbatim
108 *> INFO is INTEGER
109 *> = 0: successful exit
110 *> < 0: if INFO = -i, the i-th argument had an illegal value
111 *> > 0: if INFO = i, the i-th diagonal element is nonpositive.
112 *> \endverbatim
113 *
114 * Authors:
115 * ========
116 *
117 *> \author Univ. of Tennessee
118 *> \author Univ. of California Berkeley
119 *> \author Univ. of Colorado Denver
120 *> \author NAG Ltd.
121 *
122 *> \date April 2012
123 *
124 *> \ingroup complexHEcomputational
125 *
126 * =====================================================================
127  SUBROUTINE cheequb( UPLO, N, A, LDA, S, SCOND, AMAX, WORK, INFO )
128 *
129 * -- LAPACK computational routine (version 3.4.1) --
130 * -- LAPACK is a software package provided by Univ. of Tennessee, --
131 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
132 * April 2012
133 *
134 * .. Scalar Arguments ..
135  INTEGER info, lda, n
136  REAL amax, scond
137  CHARACTER uplo
138 * ..
139 * .. Array Arguments ..
140  COMPLEX a( lda, * ), work( * )
141  REAL s( * )
142 * ..
143 *
144 * =====================================================================
145 *
146 * .. Parameters ..
147  REAL one, zero
148  parameter( one = 1.0e+0, zero = 0.0e+0 )
149  INTEGER max_iter
150  parameter( max_iter = 100 )
151 * ..
152 * .. Local Scalars ..
153  INTEGER i, j, iter
154  REAL avg, std, tol, c0, c1, c2, t, u, si, d,
155  $ base, smin, smax, smlnum, bignum, scale, sumsq
156  LOGICAL up
157  COMPLEX zdum
158 * ..
159 * .. External Functions ..
160  REAL slamch
161  LOGICAL lsame
162  EXTERNAL lsame, slamch
163 * ..
164 * .. External Subroutines ..
165  EXTERNAL classq
166 * ..
167 * .. Intrinsic Functions ..
168  INTRINSIC abs, aimag, int, log, max, min, REAL, sqrt
169 * ..
170 * .. Statement Functions ..
171  REAL cabs1
172 * ..
173 * .. Statement Function Definitions ..
174  cabs1( zdum ) = abs( REAL( ZDUM ) ) + abs( aimag( zdum ) )
175 *
176 * Test input parameters.
177 *
178  info = 0
179  IF (.NOT. ( lsame( uplo, 'U' ) .OR. lsame( uplo, 'L' ) ) ) THEN
180  info = -1
181  ELSE IF ( n .LT. 0 ) THEN
182  info = -2
183  ELSE IF ( lda .LT. max( 1, n ) ) THEN
184  info = -4
185  END IF
186  IF ( info .NE. 0 ) THEN
187  CALL xerbla( 'CHEEQUB', -info )
188  return
189  END IF
190 
191  up = lsame( uplo, 'U' )
192  amax = zero
193 *
194 * Quick return if possible.
195 *
196  IF ( n .EQ. 0 ) THEN
197  scond = one
198  return
199  END IF
200 
201  DO i = 1, n
202  s( i ) = zero
203  END DO
204 
205  amax = zero
206  IF ( up ) THEN
207  DO j = 1, n
208  DO i = 1, j-1
209  s( i ) = max( s( i ), cabs1( a( i, j ) ) )
210  s( j ) = max( s( j ), cabs1( a( i, j ) ) )
211  amax = max( amax, cabs1( a( i, j ) ) )
212  END DO
213  s( j ) = max( s( j ), cabs1( a( j, j ) ) )
214  amax = max( amax, cabs1( a( j, j ) ) )
215  END DO
216  ELSE
217  DO j = 1, n
218  s( j ) = max( s( j ), cabs1( a( j, j ) ) )
219  amax = max( amax, cabs1( a( j, j ) ) )
220  DO i = j+1, n
221  s( i ) = max( s( i ), cabs1( a( i, j ) ) )
222  s( j ) = max( s( j ), cabs1( a( i, j ) ) )
223  amax = max( amax, cabs1( a(i, j ) ) )
224  END DO
225  END DO
226  END IF
227  DO j = 1, n
228  s( j ) = 1.0 / s( j )
229  END DO
230 
231  tol = one / sqrt( 2.0e0 * n )
232 
233  DO iter = 1, max_iter
234  scale = 0.0
235  sumsq = 0.0
236 * beta = |A|s
237  DO i = 1, n
238  work( i ) = zero
239  END DO
240  IF ( up ) THEN
241  DO j = 1, n
242  DO i = 1, j-1
243  t = cabs1( a( i, j ) )
244  work( i ) = work( i ) + cabs1( a( i, j ) ) * s( j )
245  work( j ) = work( j ) + cabs1( a( i, j ) ) * s( i )
246  END DO
247  work( j ) = work( j ) + cabs1( a( j, j ) ) * s( j )
248  END DO
249  ELSE
250  DO j = 1, n
251  work( j ) = work( j ) + cabs1( a( j, j ) ) * s( j )
252  DO i = j+1, n
253  t = cabs1( a( i, j ) )
254  work( i ) = work( i ) + cabs1( a( i, j ) ) * s( j )
255  work( j ) = work( j ) + cabs1( a( i, j ) ) * s( i )
256  END DO
257  END DO
258  END IF
259 
260 * avg = s^T beta / n
261  avg = 0.0
262  DO i = 1, n
263  avg = avg + s( i )*work( i )
264  END DO
265  avg = avg / n
266 
267  std = 0.0
268  DO i = 2*n+1, 3*n
269  work( i ) = s( i-2*n ) * work( i-2*n ) - avg
270  END DO
271  CALL classq( n, work( 2*n+1 ), 1, scale, sumsq )
272  std = scale * sqrt( sumsq / n )
273 
274  IF ( std .LT. tol * avg ) goto 999
275 
276  DO i = 1, n
277  t = cabs1( a( i, i ) )
278  si = s( i )
279  c2 = ( n-1 ) * t
280  c1 = ( n-2 ) * ( work( i ) - t*si )
281  c0 = -(t*si)*si + 2*work( i )*si - n*avg
282 
283  d = c1*c1 - 4*c0*c2
284  IF ( d .LE. 0 ) THEN
285  info = -1
286  return
287  END IF
288  si = -2*c0 / ( c1 + sqrt( d ) )
289 
290  d = si - s(i)
291  u = zero
292  IF ( up ) THEN
293  DO j = 1, i
294  t = cabs1( a( j, i ) )
295  u = u + s( j )*t
296  work( j ) = work( j ) + d*t
297  END DO
298  DO j = i+1,n
299  t = cabs1( a( i, j ) )
300  u = u + s( j )*t
301  work( j ) = work( j ) + d*t
302  END DO
303  ELSE
304  DO j = 1, i
305  t = cabs1( a( i, j ) )
306  u = u + s( j )*t
307  work( j ) = work( j ) + d*t
308  END DO
309  DO j = i+1,n
310  t = cabs1( a( j, i ) )
311  u = u + s( j )*t
312  work( j ) = work( j ) + d*t
313  END DO
314  END IF
315  avg = avg + ( u + work( i ) ) * d / n
316  s( i ) = si
317  END DO
318 
319  END DO
320 
321  999 continue
322 
323  smlnum = slamch( 'SAFEMIN' )
324  bignum = one / smlnum
325  smin = bignum
326  smax = zero
327  t = one / sqrt( avg )
328  base = slamch( 'B' )
329  u = one / log( base )
330  DO i = 1, n
331  s( i ) = base ** int( u * log( s( i ) * t ) )
332  smin = min( smin, s( i ) )
333  smax = max( smax, s( i ) )
334  END DO
335  scond = max( smin, smlnum ) / min( smax, bignum )
336 
337  END