1: SUBROUTINE DLA_SYAMV( UPLO, N, ALPHA, A, LDA, X, INCX, BETA, Y,
2: $ INCY )
3: *
4: * -- LAPACK routine (version 3.2.2) --
5: * -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and --
6: * -- Jason Riedy of Univ. of California Berkeley. --
7: * -- June 2010 --
8: *
9: * -- LAPACK is a software package provided by Univ. of Tennessee, --
10: * -- Univ. of California Berkeley and NAG Ltd. --
11: *
12: IMPLICIT NONE
13: * ..
14: * .. Scalar Arguments ..
15: DOUBLE PRECISION ALPHA, BETA
16: INTEGER INCX, INCY, LDA, N, UPLO
17: * ..
18: * .. Array Arguments ..
19: DOUBLE PRECISION A( LDA, * ), X( * ), Y( * )
20: * ..
21: *
22: * Purpose
23: * =======
24: *
25: * DLA_SYAMV performs the matrix-vector operation
26: *
27: * y := alpha*abs(A)*abs(x) + beta*abs(y),
28: *
29: * where alpha and beta are scalars, x and y are vectors and A is an
30: * n by n symmetric matrix.
31: *
32: * This function is primarily used in calculating error bounds.
33: * To protect against underflow during evaluation, components in
34: * the resulting vector are perturbed away from zero by (N+1)
35: * times the underflow threshold. To prevent unnecessarily large
36: * errors for block-structure embedded in general matrices,
37: * "symbolically" zero components are not perturbed. A zero
38: * entry is considered "symbolic" if all multiplications involved
39: * in computing that entry have at least one zero multiplicand.
40: *
41: * Arguments
42: * ==========
43: *
44: * UPLO (input) INTEGER
45: * On entry, UPLO specifies whether the upper or lower
46: * triangular part of the array A is to be referenced as
47: * follows:
48: *
49: * UPLO = BLAS_UPPER Only the upper triangular part of A
50: * is to be referenced.
51: *
52: * UPLO = BLAS_LOWER Only the lower triangular part of A
53: * is to be referenced.
54: *
55: * Unchanged on exit.
56: *
57: * N (input) INTEGER
58: * On entry, N specifies the number of columns of the matrix A.
59: * N must be at least zero.
60: * Unchanged on exit.
61: *
62: * ALPHA - DOUBLE PRECISION .
63: * On entry, ALPHA specifies the scalar alpha.
64: * Unchanged on exit.
65: *
66: * A - DOUBLE PRECISION array of DIMENSION ( LDA, n ).
67: * Before entry, the leading m by n part of the array A must
68: * contain the matrix of coefficients.
69: * Unchanged on exit.
70: *
71: * LDA (input) INTEGER
72: * On entry, LDA specifies the first dimension of A as declared
73: * in the calling (sub) program. LDA must be at least
74: * max( 1, n ).
75: * Unchanged on exit.
76: *
77: * X (input) DOUBLE PRECISION array, dimension
78: * ( 1 + ( n - 1 )*abs( INCX ) )
79: * Before entry, the incremented array X must contain the
80: * vector x.
81: * Unchanged on exit.
82: *
83: * INCX (input) INTEGER
84: * On entry, INCX specifies the increment for the elements of
85: * X. INCX must not be zero.
86: * Unchanged on exit.
87: *
88: * BETA - DOUBLE PRECISION .
89: * On entry, BETA specifies the scalar beta. When BETA is
90: * supplied as zero then Y need not be set on input.
91: * Unchanged on exit.
92: *
93: * Y (input/output) DOUBLE PRECISION array, dimension
94: * ( 1 + ( n - 1 )*abs( INCY ) )
95: * Before entry with BETA non-zero, the incremented array Y
96: * must contain the vector y. On exit, Y is overwritten by the
97: * updated vector y.
98: *
99: * INCY (input) INTEGER
100: * On entry, INCY specifies the increment for the elements of
101: * Y. INCY must not be zero.
102: * Unchanged on exit.
103: *
104: * Further Details
105: * ===============
106: *
107: * Level 2 Blas routine.
108: *
109: * -- Written on 22-October-1986.
110: * Jack Dongarra, Argonne National Lab.
111: * Jeremy Du Croz, Nag Central Office.
112: * Sven Hammarling, Nag Central Office.
113: * Richard Hanson, Sandia National Labs.
114: * -- Modified for the absolute-value product, April 2006
115: * Jason Riedy, UC Berkeley
116: *
117: * =====================================================================
118: *
119: * .. Parameters ..
120: DOUBLE PRECISION ONE, ZERO
121: PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
122: * ..
123: * .. Local Scalars ..
124: LOGICAL SYMB_ZERO
125: DOUBLE PRECISION TEMP, SAFE1
126: INTEGER I, INFO, IY, J, JX, KX, KY
127: * ..
128: * .. External Subroutines ..
129: EXTERNAL XERBLA, DLAMCH
130: DOUBLE PRECISION DLAMCH
131: * ..
132: * .. External Functions ..
133: EXTERNAL ILAUPLO
134: INTEGER ILAUPLO
135: * ..
136: * .. Intrinsic Functions ..
137: INTRINSIC MAX, ABS, SIGN
138: * ..
139: * .. Executable Statements ..
140: *
141: * Test the input parameters.
142: *
143: INFO = 0
144: IF ( UPLO.NE.ILAUPLO( 'U' ) .AND.
145: $ UPLO.NE.ILAUPLO( 'L' ) ) THEN
146: INFO = 1
147: ELSE IF( N.LT.0 )THEN
148: INFO = 2
149: ELSE IF( LDA.LT.MAX( 1, N ) )THEN
150: INFO = 5
151: ELSE IF( INCX.EQ.0 )THEN
152: INFO = 7
153: ELSE IF( INCY.EQ.0 )THEN
154: INFO = 10
155: END IF
156: IF( INFO.NE.0 )THEN
157: CALL XERBLA( 'DSYMV ', INFO )
158: RETURN
159: END IF
160: *
161: * Quick return if possible.
162: *
163: IF( ( N.EQ.0 ).OR.( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) )
164: $ RETURN
165: *
166: * Set up the start points in X and Y.
167: *
168: IF( INCX.GT.0 )THEN
169: KX = 1
170: ELSE
171: KX = 1 - ( N - 1 )*INCX
172: END IF
173: IF( INCY.GT.0 )THEN
174: KY = 1
175: ELSE
176: KY = 1 - ( N - 1 )*INCY
177: END IF
178: *
179: * Set SAFE1 essentially to be the underflow threshold times the
180: * number of additions in each row.
181: *
182: SAFE1 = DLAMCH( 'Safe minimum' )
183: SAFE1 = (N+1)*SAFE1
184: *
185: * Form y := alpha*abs(A)*abs(x) + beta*abs(y).
186: *
187: * The O(N^2) SYMB_ZERO tests could be replaced by O(N) queries to
188: * the inexact flag. Still doesn't help change the iteration order
189: * to per-column.
190: *
191: IY = KY
192: IF ( INCX.EQ.1 ) THEN
193: IF ( UPLO .EQ. ILAUPLO( 'U' ) ) THEN
194: DO I = 1, N
195: IF ( BETA .EQ. ZERO ) THEN
196: SYMB_ZERO = .TRUE.
197: Y( IY ) = 0.0D+0
198: ELSE IF ( Y( IY ) .EQ. ZERO ) THEN
199: SYMB_ZERO = .TRUE.
200: ELSE
201: SYMB_ZERO = .FALSE.
202: Y( IY ) = BETA * ABS( Y( IY ) )
203: END IF
204: IF ( ALPHA .NE. ZERO ) THEN
205: DO J = 1, I
206: TEMP = ABS( A( J, I ) )
207: SYMB_ZERO = SYMB_ZERO .AND.
208: $ ( X( J ) .EQ. ZERO .OR. TEMP .EQ. ZERO )
209:
210: Y( IY ) = Y( IY ) + ALPHA*ABS( X( J ) )*TEMP
211: END DO
212: DO J = I+1, N
213: TEMP = ABS( A( I, J ) )
214: SYMB_ZERO = SYMB_ZERO .AND.
215: $ ( X( J ) .EQ. ZERO .OR. TEMP .EQ. ZERO )
216:
217: Y( IY ) = Y( IY ) + ALPHA*ABS( X( J ) )*TEMP
218: END DO
219: END IF
220:
221: IF ( .NOT.SYMB_ZERO )
222: $ Y( IY ) = Y( IY ) + SIGN( SAFE1, Y( IY ) )
223:
224: IY = IY + INCY
225: END DO
226: ELSE
227: DO I = 1, N
228: IF ( BETA .EQ. ZERO ) THEN
229: SYMB_ZERO = .TRUE.
230: Y( IY ) = 0.0D+0
231: ELSE IF ( Y( IY ) .EQ. ZERO ) THEN
232: SYMB_ZERO = .TRUE.
233: ELSE
234: SYMB_ZERO = .FALSE.
235: Y( IY ) = BETA * ABS( Y( IY ) )
236: END IF
237: IF ( ALPHA .NE. ZERO ) THEN
238: DO J = 1, I
239: TEMP = ABS( A( I, J ) )
240: SYMB_ZERO = SYMB_ZERO .AND.
241: $ ( X( J ) .EQ. ZERO .OR. TEMP .EQ. ZERO )
242:
243: Y( IY ) = Y( IY ) + ALPHA*ABS( X( J ) )*TEMP
244: END DO
245: DO J = I+1, N
246: TEMP = ABS( A( J, I ) )
247: SYMB_ZERO = SYMB_ZERO .AND.
248: $ ( X( J ) .EQ. ZERO .OR. TEMP .EQ. ZERO )
249:
250: Y( IY ) = Y( IY ) + ALPHA*ABS( X( J ) )*TEMP
251: END DO
252: END IF
253:
254: IF ( .NOT.SYMB_ZERO )
255: $ Y( IY ) = Y( IY ) + SIGN( SAFE1, Y( IY ) )
256:
257: IY = IY + INCY
258: END DO
259: END IF
260: ELSE
261: IF ( UPLO .EQ. ILAUPLO( 'U' ) ) THEN
262: DO I = 1, N
263: IF ( BETA .EQ. ZERO ) THEN
264: SYMB_ZERO = .TRUE.
265: Y( IY ) = 0.0D+0
266: ELSE IF ( Y( IY ) .EQ. ZERO ) THEN
267: SYMB_ZERO = .TRUE.
268: ELSE
269: SYMB_ZERO = .FALSE.
270: Y( IY ) = BETA * ABS( Y( IY ) )
271: END IF
272: JX = KX
273: IF ( ALPHA .NE. ZERO ) THEN
274: DO J = 1, I
275: TEMP = ABS( A( J, I ) )
276: SYMB_ZERO = SYMB_ZERO .AND.
277: $ ( X( J ) .EQ. ZERO .OR. TEMP .EQ. ZERO )
278:
279: Y( IY ) = Y( IY ) + ALPHA*ABS( X( JX ) )*TEMP
280: JX = JX + INCX
281: END DO
282: DO J = I+1, N
283: TEMP = ABS( A( I, J ) )
284: SYMB_ZERO = SYMB_ZERO .AND.
285: $ ( X( J ) .EQ. ZERO .OR. TEMP .EQ. ZERO )
286:
287: Y( IY ) = Y( IY ) + ALPHA*ABS( X( JX ) )*TEMP
288: JX = JX + INCX
289: END DO
290: END IF
291:
292: IF ( .NOT.SYMB_ZERO )
293: $ Y( IY ) = Y( IY ) + SIGN( SAFE1, Y( IY ) )
294:
295: IY = IY + INCY
296: END DO
297: ELSE
298: DO I = 1, N
299: IF ( BETA .EQ. ZERO ) THEN
300: SYMB_ZERO = .TRUE.
301: Y( IY ) = 0.0D+0
302: ELSE IF ( Y( IY ) .EQ. ZERO ) THEN
303: SYMB_ZERO = .TRUE.
304: ELSE
305: SYMB_ZERO = .FALSE.
306: Y( IY ) = BETA * ABS( Y( IY ) )
307: END IF
308: JX = KX
309: IF ( ALPHA .NE. ZERO ) THEN
310: DO J = 1, I
311: TEMP = ABS( A( I, J ) )
312: SYMB_ZERO = SYMB_ZERO .AND.
313: $ ( X( J ) .EQ. ZERO .OR. TEMP .EQ. ZERO )
314:
315: Y( IY ) = Y( IY ) + ALPHA*ABS( X( JX ) )*TEMP
316: JX = JX + INCX
317: END DO
318: DO J = I+1, N
319: TEMP = ABS( A( J, I ) )
320: SYMB_ZERO = SYMB_ZERO .AND.
321: $ ( X( J ) .EQ. ZERO .OR. TEMP .EQ. ZERO )
322:
323: Y( IY ) = Y( IY ) + ALPHA*ABS( X( JX ) )*TEMP
324: JX = JX + INCX
325: END DO
326: END IF
327:
328: IF ( .NOT.SYMB_ZERO )
329: $ Y( IY ) = Y( IY ) + SIGN( SAFE1, Y( IY ) )
330:
331: IY = IY + INCY
332: END DO
333: END IF
334:
335: END IF
336: *
337: RETURN
338: *
339: * End of DLA_SYAMV
340: *
341: END
CVSweb interface <joel.bertrand@systella.fr>
![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to dla_syamv.f CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [local] / rpl / lapack / lapack