```001:       SUBROUTINE DSYEQUB( UPLO, N, A, LDA, S, SCOND, AMAX, WORK, INFO )
002: *
003: *     -- LAPACK routine (version 3.2)                                 --
004: *     -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and --
005: *     -- Jason Riedy of Univ. of California Berkeley.                 --
006: *     -- November 2008                                                --
007: *
008: *     -- LAPACK is a software package provided by Univ. of Tennessee, --
009: *     -- Univ. of California Berkeley and NAG Ltd.                    --
010: *
011:       IMPLICIT NONE
012: *     ..
013: *     .. Scalar Arguments ..
014:       INTEGER            INFO, LDA, N
015:       DOUBLE PRECISION   AMAX, SCOND
016:       CHARACTER          UPLO
017: *     ..
018: *     .. Array Arguments ..
019:       DOUBLE PRECISION   A( LDA, * ), S( * ), WORK( * )
020: *     ..
021: *
022: *  Purpose
023: *  =======
024: *
025: *  DSYEQUB computes row and column scalings intended to equilibrate a
026: *  symmetric matrix A and reduce its condition number
027: *  (with respect to the two-norm).  S contains the scale factors,
028: *  S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with
029: *  elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal.  This
030: *  choice of S puts the condition number of B within a factor N of the
031: *  smallest possible condition number over all possible diagonal
032: *  scalings.
033: *
034: *  Arguments
035: *  =========
036: *
037: *  N       (input) INTEGER
038: *          The order of the matrix A.  N >= 0.
039: *
040: *  A       (input) DOUBLE PRECISION array, dimension (LDA,N)
041: *          The N-by-N symmetric matrix whose scaling
042: *          factors are to be computed.  Only the diagonal elements of A
043: *          are referenced.
044: *
045: *  LDA     (input) INTEGER
046: *          The leading dimension of the array A.  LDA >= max(1,N).
047: *
048: *  S       (output) DOUBLE PRECISION array, dimension (N)
049: *          If INFO = 0, S contains the scale factors for A.
050: *
051: *  SCOND   (output) DOUBLE PRECISION
052: *          If INFO = 0, S contains the ratio of the smallest S(i) to
053: *          the largest S(i).  If SCOND >= 0.1 and AMAX is neither too
054: *          large nor too small, it is not worth scaling by S.
055: *
056: *  AMAX    (output) DOUBLE PRECISION
057: *          Absolute value of largest matrix element.  If AMAX is very
058: *          close to overflow or very close to underflow, the matrix
059: *          should be scaled.
060: *  INFO    (output) INTEGER
061: *          = 0:  successful exit
062: *          < 0:  if INFO = -i, the i-th argument had an illegal value
063: *          > 0:  if INFO = i, the i-th diagonal element is nonpositive.
064: *
065: *  =====================================================================
066: *
067: *     .. Parameters ..
068:       DOUBLE PRECISION   ONE, ZERO
069:       PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
070:       INTEGER            MAX_ITER
071:       PARAMETER          ( MAX_ITER = 100 )
072: *     ..
073: *     .. Local Scalars ..
074:       INTEGER            I, J, ITER
075:       DOUBLE PRECISION   AVG, STD, TOL, C0, C1, C2, T, U, SI, D, BASE,
076:      \$                   SMIN, SMAX, SMLNUM, BIGNUM, SCALE, SUMSQ
077:       LOGICAL            UP
078: *     ..
079: *     .. External Functions ..
080:       DOUBLE PRECISION   DLAMCH
081:       LOGICAL            LSAME
082: *     ..
083: *     .. External Subroutines ..
084:       EXTERNAL           DLASSQ
085: *     ..
086: *     .. Executable Statements ..
087: *
088: *     Test input parameters.
089: *
090:       INFO = 0
091:       IF ( .NOT. ( LSAME( UPLO, 'U' ) .OR. LSAME( UPLO, 'L' ) ) ) THEN
092:         INFO = -1
093:       ELSE IF ( N .LT. 0 ) THEN
094:         INFO = -2
095:       ELSE IF ( LDA .LT. MAX( 1, N ) ) THEN
096:         INFO = -4
097:       END IF
098:       IF ( INFO .NE. 0 ) THEN
099:         CALL XERBLA( 'DSYEQUB', -INFO )
100:         RETURN
101:       END IF
102:
103:       UP = LSAME( UPLO, 'U' )
104:       AMAX = ZERO
105: *
106: *     Quick return if possible.
107: *
108:       IF ( N .EQ. 0 ) THEN
109:         SCOND = ONE
110:         RETURN
111:       END IF
112:
113:       DO I = 1, N
114:         S( I ) = ZERO
115:       END DO
116:
117:       AMAX = ZERO
118:       IF ( UP ) THEN
119:          DO J = 1, N
120:             DO I = 1, J-1
121:                S( I ) = MAX( S( I ), ABS( A( I, J ) ) )
122:                S( J ) = MAX( S( J ), ABS( A( I, J ) ) )
123:                AMAX = MAX( AMAX, ABS( A(I, J) ) )
124:             END DO
125:             S( J ) = MAX( S( J ), ABS( A( J, J ) ) )
126:             AMAX = MAX( AMAX, ABS( A( J, J ) ) )
127:          END DO
128:       ELSE
129:          DO J = 1, N
130:             S( J ) = MAX( S( J ), ABS( A( J, J ) ) )
131:             AMAX = MAX( AMAX, ABS( A( J, J ) ) )
132:             DO I = J+1, N
133:                S( I ) = MAX( S( I ), ABS( A( I, J ) ) )
134:                S( J ) = MAX( S( J ), ABS( A( I, J ) ) )
135:                AMAX = MAX( AMAX, ABS( A( I, J ) ) )
136:             END DO
137:          END DO
138:       END IF
139:       DO J = 1, N
140:          S( J ) = 1.0D+0 / S( J )
141:       END DO
142:
143:       TOL = ONE / SQRT(2.0D0 * N)
144:
145:       DO ITER = 1, MAX_ITER
146:          SCALE = 0.0D+0
147:          SUMSQ = 0.0D+0
148: *       BETA = |A|S
149:         DO I = 1, N
150:            WORK(I) = ZERO
151:         END DO
152:         IF ( UP ) THEN
153:            DO J = 1, N
154:               DO I = 1, J-1
155:                  T = ABS( A( I, J ) )
156:                  WORK( I ) = WORK( I ) + ABS( A( I, J ) ) * S( J )
157:                  WORK( J ) = WORK( J ) + ABS( A( I, J ) ) * S( I )
158:               END DO
159:               WORK( J ) = WORK( J ) + ABS( A( J, J ) ) * S( J )
160:            END DO
161:         ELSE
162:            DO J = 1, N
163:               WORK( J ) = WORK( J ) + ABS( A( J, J ) ) * S( J )
164:               DO I = J+1, N
165:                  T = ABS( A( I, J ) )
166:                  WORK( I ) = WORK( I ) + ABS( A( I, J ) ) * S( J )
167:                  WORK( J ) = WORK( J ) + ABS( A( I, J ) ) * S( I )
168:               END DO
169:            END DO
170:         END IF
171:
172: *       avg = s^T beta / n
173:         AVG = 0.0D+0
174:         DO I = 1, N
175:           AVG = AVG + S( I )*WORK( I )
176:         END DO
177:         AVG = AVG / N
178:
179:         STD = 0.0D+0
180:         DO I = 2*N+1, 3*N
181:            WORK( I ) = S( I-2*N ) * WORK( I-2*N ) - AVG
182:         END DO
183:         CALL DLASSQ( N, WORK( 2*N+1 ), 1, SCALE, SUMSQ )
184:         STD = SCALE * SQRT( SUMSQ / N )
185:
186:         IF ( STD .LT. TOL * AVG ) GOTO 999
187:
188:         DO I = 1, N
189:           T = ABS( A( I, I ) )
190:           SI = S( I )
191:           C2 = ( N-1 ) * T
192:           C1 = ( N-2 ) * ( WORK( I ) - T*SI )
193:           C0 = -(T*SI)*SI + 2*WORK( I )*SI - N*AVG
194:           D = C1*C1 - 4*C0*C2
195:
196:           IF ( D .LE. 0 ) THEN
197:             INFO = -1
198:             RETURN
199:           END IF
200:           SI = -2*C0 / ( C1 + SQRT( D ) )
201:
202:           D = SI - S( I )
203:           U = ZERO
204:           IF ( UP ) THEN
205:             DO J = 1, I
206:               T = ABS( A( J, I ) )
207:               U = U + S( J )*T
208:               WORK( J ) = WORK( J ) + D*T
209:             END DO
210:             DO J = I+1,N
211:               T = ABS( A( I, J ) )
212:               U = U + S( J )*T
213:               WORK( J ) = WORK( J ) + D*T
214:             END DO
215:           ELSE
216:             DO J = 1, I
217:               T = ABS( A( I, J ) )
218:               U = U + S( J )*T
219:               WORK( J ) = WORK( J ) + D*T
220:             END DO
221:             DO J = I+1,N
222:               T = ABS( A( J, I ) )
223:               U = U + S( J )*T
224:               WORK( J ) = WORK( J ) + D*T
225:             END DO
226:           END IF
227:
228:           AVG = AVG + ( U + WORK( I ) ) * D / N
229:           S( I ) = SI
230:
231:         END DO
232:
233:       END DO
234:
235:  999  CONTINUE
236:
237:       SMLNUM = DLAMCH( 'SAFEMIN' )
238:       BIGNUM = ONE / SMLNUM
239:       SMIN = BIGNUM
240:       SMAX = ZERO
241:       T = ONE / SQRT(AVG)
242:       BASE = DLAMCH( 'B' )
243:       U = ONE / LOG( BASE )
244:       DO I = 1, N
245:         S( I ) = BASE ** INT( U * LOG( S( I ) * T ) )
246:         SMIN = MIN( SMIN, S( I ) )
247:         SMAX = MAX( SMAX, S( I ) )
248:       END DO
249:       SCOND = MAX( SMIN, SMLNUM ) / MIN( SMAX, BIGNUM )
250: *
251:       END
252: ```