LAPACK  3.10.0
LAPACK: Linear Algebra PACKage

◆ dsyequb()

subroutine dsyequb ( character  UPLO,
integer  N,
double precision, dimension( lda, * )  A,
integer  LDA,
double precision, dimension( * )  S,
double precision  SCOND,
double precision  AMAX,
double precision, dimension( * )  WORK,
integer  INFO 
)

DSYEQUB

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

Purpose:
 DSYEQUB computes row and column scalings intended to equilibrate a
 symmetric matrix A (with respect to the Euclidean norm) and reduce
 its condition number. The scale factors S are computed by the BIN
 algorithm (see references) so that the scaled matrix B with elements
 B(i,j) = S(i)*A(i,j)*S(j) has a condition number within a factor N of
 the smallest possible condition number over all possible diagonal
 scalings.
Parameters
[in]UPLO
          UPLO is CHARACTER*1
          = 'U':  Upper triangle of A is stored;
          = 'L':  Lower triangle of A is stored.
[in]N
          N is INTEGER
          The order of the matrix A. N >= 0.
[in]A
          A is DOUBLE PRECISION array, dimension (LDA,N)
          The N-by-N symmetric matrix whose scaling factors are to be
          computed.
[in]LDA
          LDA is INTEGER
          The leading dimension of the array A. LDA >= max(1,N).
[out]S
          S is DOUBLE PRECISION array, dimension (N)
          If INFO = 0, S contains the scale factors for A.
[out]SCOND
          SCOND is DOUBLE PRECISION
          If INFO = 0, S contains the ratio of the smallest S(i) to
          the largest S(i). If SCOND >= 0.1 and AMAX is neither too
          large nor too small, it is not worth scaling by S.
[out]AMAX
          AMAX is DOUBLE PRECISION
          Largest absolute value of any matrix element. If AMAX is
          very close to overflow or very close to underflow, the
          matrix should be scaled.
[out]WORK
          WORK is DOUBLE PRECISION array, dimension (2*N)
[out]INFO
          INFO is INTEGER
          = 0:  successful exit
          < 0:  if INFO = -i, the i-th argument had an illegal value
          > 0:  if INFO = i, the i-th diagonal element is nonpositive.
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.
References:
Livne, O.E. and Golub, G.H., "Scaling by Binormalization",
Numerical Algorithms, vol. 35, no. 1, pp. 97-120, January 2004.
DOI 10.1023/B:NUMA.0000016606.32820.69
Tech report version: http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.3.1679

Definition at line 130 of file dsyequb.f.

131 *
132 * -- LAPACK computational routine --
133 * -- LAPACK is a software package provided by Univ. of Tennessee, --
134 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
135 *
136 * .. Scalar Arguments ..
137  INTEGER INFO, LDA, N
138  DOUBLE PRECISION AMAX, SCOND
139  CHARACTER UPLO
140 * ..
141 * .. Array Arguments ..
142  DOUBLE PRECISION A( LDA, * ), S( * ), WORK( * )
143 * ..
144 *
145 * =====================================================================
146 *
147 * .. Parameters ..
148  DOUBLE PRECISION ONE, ZERO
149  parameter( one = 1.0d0, zero = 0.0d0 )
150  INTEGER MAX_ITER
151  parameter( max_iter = 100 )
152 * ..
153 * .. Local Scalars ..
154  INTEGER I, J, ITER
155  DOUBLE PRECISION AVG, STD, TOL, C0, C1, C2, T, U, SI, D, BASE,
156  $ SMIN, SMAX, SMLNUM, BIGNUM, SCALE, SUMSQ
157  LOGICAL UP
158 * ..
159 * .. External Functions ..
160  DOUBLE PRECISION DLAMCH
161  LOGICAL LSAME
162  EXTERNAL dlamch, lsame
163 * ..
164 * .. External Subroutines ..
165  EXTERNAL dlassq, xerbla
166 * ..
167 * .. Intrinsic Functions ..
168  INTRINSIC abs, int, log, max, min, sqrt
169 * ..
170 * .. Executable Statements ..
171 *
172 * Test the input parameters.
173 *
174  info = 0
175  IF ( .NOT. ( lsame( uplo, 'U' ) .OR. lsame( uplo, 'L' ) ) ) THEN
176  info = -1
177  ELSE IF ( n .LT. 0 ) THEN
178  info = -2
179  ELSE IF ( lda .LT. max( 1, n ) ) THEN
180  info = -4
181  END IF
182  IF ( info .NE. 0 ) THEN
183  CALL xerbla( 'DSYEQUB', -info )
184  RETURN
185  END IF
186 
187  up = lsame( uplo, 'U' )
188  amax = zero
189 *
190 * Quick return if possible.
191 *
192  IF ( n .EQ. 0 ) THEN
193  scond = one
194  RETURN
195  END IF
196 
197  DO i = 1, n
198  s( i ) = zero
199  END DO
200 
201  amax = zero
202  IF ( up ) THEN
203  DO j = 1, n
204  DO i = 1, j-1
205  s( i ) = max( s( i ), abs( a( i, j ) ) )
206  s( j ) = max( s( j ), abs( a( i, j ) ) )
207  amax = max( amax, abs( a( i, j ) ) )
208  END DO
209  s( j ) = max( s( j ), abs( a( j, j ) ) )
210  amax = max( amax, abs( a( j, j ) ) )
211  END DO
212  ELSE
213  DO j = 1, n
214  s( j ) = max( s( j ), abs( a( j, j ) ) )
215  amax = max( amax, abs( a( j, j ) ) )
216  DO i = j+1, n
217  s( i ) = max( s( i ), abs( a( i, j ) ) )
218  s( j ) = max( s( j ), abs( a( i, j ) ) )
219  amax = max( amax, abs( a( i, j ) ) )
220  END DO
221  END DO
222  END IF
223  DO j = 1, n
224  s( j ) = 1.0d0 / s( j )
225  END DO
226 
227  tol = one / sqrt( 2.0d0 * n )
228 
229  DO iter = 1, max_iter
230  scale = 0.0d0
231  sumsq = 0.0d0
232 * beta = |A|s
233  DO i = 1, n
234  work( i ) = zero
235  END DO
236  IF ( up ) THEN
237  DO j = 1, n
238  DO i = 1, j-1
239  work( i ) = work( i ) + abs( a( i, j ) ) * s( j )
240  work( j ) = work( j ) + abs( a( i, j ) ) * s( i )
241  END DO
242  work( j ) = work( j ) + abs( a( j, j ) ) * s( j )
243  END DO
244  ELSE
245  DO j = 1, n
246  work( j ) = work( j ) + abs( a( j, j ) ) * s( j )
247  DO i = j+1, n
248  work( i ) = work( i ) + abs( a( i, j ) ) * s( j )
249  work( j ) = work( j ) + abs( a( i, j ) ) * s( i )
250  END DO
251  END DO
252  END IF
253 
254 * avg = s^T beta / n
255  avg = 0.0d0
256  DO i = 1, n
257  avg = avg + s( i )*work( i )
258  END DO
259  avg = avg / n
260 
261  std = 0.0d0
262  DO i = n+1, 2*n
263  work( i ) = s( i-n ) * work( i-n ) - avg
264  END DO
265  CALL dlassq( n, work( n+1 ), 1, scale, sumsq )
266  std = scale * sqrt( sumsq / n )
267 
268  IF ( std .LT. tol * avg ) GOTO 999
269 
270  DO i = 1, n
271  t = abs( a( i, i ) )
272  si = s( i )
273  c2 = ( n-1 ) * t
274  c1 = ( n-2 ) * ( work( i ) - t*si )
275  c0 = -(t*si)*si + 2*work( i )*si - n*avg
276  d = c1*c1 - 4*c0*c2
277 
278  IF ( d .LE. 0 ) THEN
279  info = -1
280  RETURN
281  END IF
282  si = -2*c0 / ( c1 + sqrt( d ) )
283 
284  d = si - s( i )
285  u = zero
286  IF ( up ) THEN
287  DO j = 1, i
288  t = abs( a( j, i ) )
289  u = u + s( j )*t
290  work( j ) = work( j ) + d*t
291  END DO
292  DO j = i+1,n
293  t = abs( a( i, j ) )
294  u = u + s( j )*t
295  work( j ) = work( j ) + d*t
296  END DO
297  ELSE
298  DO j = 1, i
299  t = abs( a( i, j ) )
300  u = u + s( j )*t
301  work( j ) = work( j ) + d*t
302  END DO
303  DO j = i+1,n
304  t = abs( a( j, i ) )
305  u = u + s( j )*t
306  work( j ) = work( j ) + d*t
307  END DO
308  END IF
309 
310  avg = avg + ( u + work( i ) ) * d / n
311  s( i ) = si
312  END DO
313  END DO
314 
315  999 CONTINUE
316 
317  smlnum = dlamch( 'SAFEMIN' )
318  bignum = one / smlnum
319  smin = bignum
320  smax = zero
321  t = one / sqrt( avg )
322  base = dlamch( 'B' )
323  u = one / log( base )
324  DO i = 1, n
325  s( i ) = base ** int( u * log( s( i ) * t ) )
326  smin = min( smin, s( i ) )
327  smax = max( smax, s( i ) )
328  END DO
329  scond = max( smin, smlnum ) / min( smax, bignum )
330 *
double precision function dlamch(CMACH)
DLAMCH
Definition: dlamch.f:69
subroutine dlassq(n, x, incx, scl, sumsq)
DLASSQ updates a sum of squares represented in scaled form.
Definition: dlassq.f90:126
subroutine xerbla(SRNAME, INFO)
XERBLA
Definition: xerbla.f:60
logical function lsame(CA, CB)
LSAME
Definition: lsame.f:53
Here is the call graph for this function:
Here is the caller graph for this function: