Annotation of rpl/lapack/lapack/zsyequb.f, revision 1.7
1.5 bertrand 1: *> \brief \b ZSYEQUB
2: *
3: * =========== DOCUMENTATION ===========
4: *
5: * Online html documentation available at
6: * http://www.netlib.org/lapack/explore-html/
7: *
8: *> \htmlonly
9: *> Download ZSYEQUB + dependencies
10: *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zsyequb.f">
11: *> [TGZ]</a>
12: *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zsyequb.f">
13: *> [ZIP]</a>
14: *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zsyequb.f">
15: *> [TXT]</a>
16: *> \endhtmlonly
17: *
18: * Definition:
19: * ===========
20: *
21: * SUBROUTINE ZSYEQUB( UPLO, N, A, LDA, S, SCOND, AMAX, WORK, INFO )
22: *
23: * .. Scalar Arguments ..
24: * INTEGER INFO, LDA, N
25: * DOUBLE PRECISION AMAX, SCOND
26: * CHARACTER UPLO
27: * ..
28: * .. Array Arguments ..
29: * COMPLEX*16 A( LDA, * ), WORK( * )
30: * DOUBLE PRECISION S( * )
31: * ..
32: *
33: *
34: *> \par Purpose:
35: * =============
36: *>
37: *> \verbatim
38: *>
39: *> ZSYEQUB computes row and column scalings intended to equilibrate a
40: *> symmetric 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: *> Specifies whether the details of the factorization are stored
56: *> as an upper or lower triangular matrix.
57: *> = 'U': Upper triangular, form is A = U*D*U**T;
58: *> = 'L': Lower triangular, form is A = L*D*L**T.
59: *> \endverbatim
60: *>
61: *> \param[in] N
62: *> \verbatim
63: *> N is INTEGER
64: *> The order of the matrix A. N >= 0.
65: *> \endverbatim
66: *>
67: *> \param[in] A
68: *> \verbatim
69: *> A is COMPLEX*16 array, dimension (LDA,N)
70: *> The N-by-N symmetric matrix whose scaling
71: *> factors are to be computed. Only the diagonal elements of A
72: *> are referenced.
73: *> \endverbatim
74: *>
75: *> \param[in] LDA
76: *> \verbatim
77: *> LDA is INTEGER
78: *> The leading dimension of the array A. LDA >= max(1,N).
79: *> \endverbatim
80: *>
81: *> \param[out] S
82: *> \verbatim
83: *> S is DOUBLE PRECISION array, dimension (N)
84: *> If INFO = 0, S contains the scale factors for A.
85: *> \endverbatim
86: *>
87: *> \param[out] SCOND
88: *> \verbatim
89: *> SCOND is DOUBLE PRECISION
90: *> If INFO = 0, S contains the ratio of the smallest S(i) to
91: *> the largest S(i). If SCOND >= 0.1 and AMAX is neither too
92: *> large nor too small, it is not worth scaling by S.
93: *> \endverbatim
94: *>
95: *> \param[out] AMAX
96: *> \verbatim
97: *> AMAX is DOUBLE PRECISION
98: *> Absolute value of largest matrix element. If AMAX is very
99: *> close to overflow or very close to underflow, the matrix
100: *> should be scaled.
101: *> \endverbatim
102: *>
103: *> \param[out] WORK
104: *> \verbatim
105: *> WORK is COMPLEX*16 array, dimension (3*N)
106: *> \endverbatim
107: *>
108: *> \param[out] INFO
109: *> \verbatim
110: *> INFO is INTEGER
111: *> = 0: successful exit
112: *> < 0: if INFO = -i, the i-th argument had an illegal value
113: *> > 0: if INFO = i, the i-th diagonal element is nonpositive.
114: *> \endverbatim
115: *
116: * Authors:
117: * ========
118: *
119: *> \author Univ. of Tennessee
120: *> \author Univ. of California Berkeley
121: *> \author Univ. of Colorado Denver
122: *> \author NAG Ltd.
123: *
124: *> \date November 2011
125: *
126: *> \ingroup complex16SYcomputational
127: *
128: *> \par References:
129: * ================
130: *>
131: *> Livne, O.E. and Golub, G.H., "Scaling by Binormalization", \n
132: *> Numerical Algorithms, vol. 35, no. 1, pp. 97-120, January 2004. \n
133: *> DOI 10.1023/B:NUMA.0000016606.32820.69 \n
134: *> Tech report version: http://ruready.utah.edu/archive/papers/bin.pdf
135: *>
136: * =====================================================================
1.1 bertrand 137: SUBROUTINE ZSYEQUB( UPLO, N, A, LDA, S, SCOND, AMAX, WORK, INFO )
138: *
1.5 bertrand 139: * -- LAPACK computational routine (version 3.4.0) --
140: * -- LAPACK is a software package provided by Univ. of Tennessee, --
141: * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
142: * November 2011
1.1 bertrand 143: *
144: * .. Scalar Arguments ..
145: INTEGER INFO, LDA, N
146: DOUBLE PRECISION AMAX, SCOND
147: CHARACTER UPLO
148: * ..
149: * .. Array Arguments ..
150: COMPLEX*16 A( LDA, * ), WORK( * )
151: DOUBLE PRECISION S( * )
152: * ..
153: *
154: * =====================================================================
155: *
156: * .. Parameters ..
157: DOUBLE PRECISION ONE, ZERO
158: PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 )
159: INTEGER MAX_ITER
160: PARAMETER ( MAX_ITER = 100 )
161: * ..
162: * .. Local Scalars ..
163: INTEGER I, J, ITER
164: DOUBLE PRECISION AVG, STD, TOL, C0, C1, C2, T, U, SI, D, BASE,
165: $ SMIN, SMAX, SMLNUM, BIGNUM, SCALE, SUMSQ
166: LOGICAL UP
167: COMPLEX*16 ZDUM
168: * ..
169: * .. External Functions ..
170: DOUBLE PRECISION DLAMCH
171: LOGICAL LSAME
172: EXTERNAL DLAMCH, LSAME
173: * ..
174: * .. External Subroutines ..
175: EXTERNAL ZLASSQ
176: * ..
177: * .. Intrinsic Functions ..
178: INTRINSIC ABS, DBLE, DIMAG, INT, LOG, MAX, MIN, SQRT
179: * ..
180: * .. Statement Functions ..
181: DOUBLE PRECISION CABS1
182: * ..
183: * Statement Function Definitions
184: CABS1( ZDUM ) = ABS( DBLE( ZDUM ) ) + ABS( DIMAG( ZDUM ) )
185: * ..
186: * .. Executable Statements ..
187: *
188: * Test the input parameters.
189: *
190: INFO = 0
191: IF ( .NOT. ( LSAME( UPLO, 'U' ) .OR. LSAME( UPLO, 'L' ) ) ) THEN
192: INFO = -1
193: ELSE IF ( N .LT. 0 ) THEN
194: INFO = -2
195: ELSE IF ( LDA .LT. MAX( 1, N ) ) THEN
196: INFO = -4
197: END IF
198: IF ( INFO .NE. 0 ) THEN
199: CALL XERBLA( 'ZSYEQUB', -INFO )
200: RETURN
201: END IF
202:
203: UP = LSAME( UPLO, 'U' )
204: AMAX = ZERO
205: *
206: * Quick return if possible.
207: *
208: IF ( N .EQ. 0 ) THEN
209: SCOND = ONE
210: RETURN
211: END IF
212:
213: DO I = 1, N
214: S( I ) = ZERO
215: END DO
216:
217: AMAX = ZERO
218: IF ( UP ) THEN
219: DO J = 1, N
220: DO I = 1, J-1
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: S( J ) = MAX( S( J ), CABS1( A( J, J) ) )
226: AMAX = MAX( AMAX, CABS1( A( J, J ) ) )
227: END DO
228: ELSE
229: DO J = 1, N
230: S( J ) = MAX( S( J ), CABS1( A( J, J ) ) )
231: AMAX = MAX( AMAX, CABS1( A( J, J ) ) )
232: DO I = J+1, N
233: S( I ) = MAX( S( I ), CABS1( A( I, J ) ) )
234: S( J ) = MAX( S( J ), CABS1 (A( I, J ) ) )
235: AMAX = MAX( AMAX, CABS1( A( I, J ) ) )
236: END DO
237: END DO
238: END IF
239: DO J = 1, N
240: S( J ) = 1.0D+0 / S( J )
241: END DO
242:
243: TOL = ONE / SQRT( 2.0D0 * N )
244:
245: DO ITER = 1, MAX_ITER
246: SCALE = 0.0D+0
247: SUMSQ = 0.0D+0
248: * beta = |A|s
249: DO I = 1, N
250: WORK( I ) = ZERO
251: END DO
252: IF ( UP ) THEN
253: DO J = 1, N
254: DO I = 1, J-1
255: T = CABS1( A( I, J ) )
256: WORK( I ) = WORK( I ) + CABS1( A( I, J ) ) * S( J )
257: WORK( J ) = WORK( J ) + CABS1( A( I, J ) ) * S( I )
258: END DO
259: WORK( J ) = WORK( J ) + CABS1( A( J, J ) ) * S( J )
260: END DO
261: ELSE
262: DO J = 1, N
263: WORK( J ) = WORK( J ) + CABS1( A( J, J ) ) * S( J )
264: DO I = J+1, N
265: T = CABS1( A( I, J ) )
266: WORK( I ) = WORK( I ) + CABS1( A( I, J ) ) * S( J )
267: WORK( J ) = WORK( J ) + CABS1( A( I, J ) ) * S( I )
268: END DO
269: END DO
270: END IF
271:
272: * avg = s^T beta / n
273: AVG = 0.0D+0
274: DO I = 1, N
275: AVG = AVG + S( I )*WORK( I )
276: END DO
277: AVG = AVG / N
278:
279: STD = 0.0D+0
280: DO I = N+1, 2*N
281: WORK( I ) = S( I-N ) * WORK( I-N ) - AVG
282: END DO
283: CALL ZLASSQ( N, WORK( N+1 ), 1, SCALE, SUMSQ )
284: STD = SCALE * SQRT( SUMSQ / N )
285:
286: IF ( STD .LT. TOL * AVG ) GOTO 999
287:
288: DO I = 1, N
289: T = CABS1( A( I, I ) )
290: SI = S( I )
291: C2 = ( N-1 ) * T
292: C1 = ( N-2 ) * ( WORK( I ) - T*SI )
293: C0 = -(T*SI)*SI + 2*WORK( I )*SI - N*AVG
294: D = C1*C1 - 4*C0*C2
295:
296: IF ( D .LE. 0 ) THEN
297: INFO = -1
298: RETURN
299: END IF
300: SI = -2*C0 / ( C1 + SQRT( D ) )
301:
302: D = SI - S( I )
303: U = ZERO
304: IF ( UP ) THEN
305: DO J = 1, I
306: T = CABS1( A( J, I ) )
307: U = U + S( J )*T
308: WORK( J ) = WORK( J ) + D*T
309: END DO
310: DO J = I+1,N
311: T = CABS1( A( I, J ) )
312: U = U + S( J )*T
313: WORK( J ) = WORK( J ) + D*T
314: END DO
315: ELSE
316: DO J = 1, I
317: T = CABS1( A( I, J ) )
318: U = U + S( J )*T
319: WORK( J ) = WORK( J ) + D*T
320: END DO
321: DO J = I+1,N
322: T = CABS1( A( J, I ) )
323: U = U + S( J )*T
324: WORK( J ) = WORK( J ) + D*T
325: END DO
326: END IF
327: AVG = AVG + ( U + WORK( I ) ) * D / N
328: S( I ) = SI
329: END DO
330: END DO
331:
332: 999 CONTINUE
333:
334: SMLNUM = DLAMCH( 'SAFEMIN' )
335: BIGNUM = ONE / SMLNUM
336: SMIN = BIGNUM
337: SMAX = ZERO
338: T = ONE / SQRT( AVG )
339: BASE = DLAMCH( 'B' )
340: U = ONE / LOG( BASE )
341: DO I = 1, N
342: S( I ) = BASE ** INT( U * LOG( S( I ) * T ) )
343: SMIN = MIN( SMIN, S( I ) )
344: SMAX = MAX( SMAX, S( I ) )
345: END DO
346: SCOND = MAX( SMIN, SMLNUM ) / MIN( SMAX, BIGNUM )
347: *
348: END
CVSweb interface <joel.bertrand@systella.fr>
![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to zsyequb.f CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [local] / rpl / lapack / lapack