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