LAPACK  3.4.2
LAPACK: Linear Algebra PACKage
 All Files Functions Groups
zla_syamv.f
Go to the documentation of this file.
1 *> \brief \b ZLA_SYAMV computes a matrix-vector product using a symmetric indefinite matrix to calculate error bounds.
2 *
3 * =========== DOCUMENTATION ===========
4 *
5 * Online html documentation available at
6 * http://www.netlib.org/lapack/explore-html/
7 *
8 *> \htmlonly
9 *> Download ZLA_SYAMV + dependencies
10 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zla_syamv.f">
11 *> [TGZ]</a>
12 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zla_syamv.f">
13 *> [ZIP]</a>
14 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zla_syamv.f">
15 *> [TXT]</a>
16 *> \endhtmlonly
17 *
18 * Definition:
19 * ===========
20 *
21 * SUBROUTINE ZLA_SYAMV( UPLO, N, ALPHA, A, LDA, X, INCX, BETA, Y,
22 * INCY )
23 *
24 * .. Scalar Arguments ..
25 * DOUBLE PRECISION ALPHA, BETA
26 * INTEGER INCX, INCY, LDA, N
27 * INTEGER UPLO
28 * ..
29 * .. Array Arguments ..
30 * COMPLEX*16 A( LDA, * ), X( * )
31 * DOUBLE PRECISION Y( * )
32 * ..
33 *
34 *
35 *> \par Purpose:
36 * =============
37 *>
38 *> \verbatim
39 *>
40 *> ZLA_SYAMV performs the matrix-vector operation
41 *>
42 *> y := alpha*abs(A)*abs(x) + beta*abs(y),
43 *>
44 *> where alpha and beta are scalars, x and y are vectors and A is an
45 *> n by n symmetric matrix.
46 *>
47 *> This function is primarily used in calculating error bounds.
48 *> To protect against underflow during evaluation, components in
49 *> the resulting vector are perturbed away from zero by (N+1)
50 *> times the underflow threshold. To prevent unnecessarily large
51 *> errors for block-structure embedded in general matrices,
52 *> "symbolically" zero components are not perturbed. A zero
53 *> entry is considered "symbolic" if all multiplications involved
54 *> in computing that entry have at least one zero multiplicand.
55 *> \endverbatim
56 *
57 * Arguments:
58 * ==========
59 *
60 *> \param[in] UPLO
61 *> \verbatim
62 *> UPLO is INTEGER
63 *> On entry, UPLO specifies whether the upper or lower
64 *> triangular part of the array A is to be referenced as
65 *> follows:
66 *>
67 *> UPLO = BLAS_UPPER Only the upper triangular part of A
68 *> is to be referenced.
69 *>
70 *> UPLO = BLAS_LOWER Only the lower triangular part of A
71 *> is to be referenced.
72 *>
73 *> Unchanged on exit.
74 *> \endverbatim
75 *>
76 *> \param[in] N
77 *> \verbatim
78 *> N is INTEGER
79 *> On entry, N specifies the number of columns of the matrix A.
80 *> N must be at least zero.
81 *> Unchanged on exit.
82 *> \endverbatim
83 *>
84 *> \param[in] ALPHA
85 *> \verbatim
86 *> ALPHA is DOUBLE PRECISION .
87 *> On entry, ALPHA specifies the scalar alpha.
88 *> Unchanged on exit.
89 *> \endverbatim
90 *>
91 *> \param[in] A
92 *> \verbatim
93 *> A is COMPLEX*16 array, DIMENSION ( LDA, n ).
94 *> Before entry, the leading m by n part of the array A must
95 *> contain the matrix of coefficients.
96 *> Unchanged on exit.
97 *> \endverbatim
98 *>
99 *> \param[in] LDA
100 *> \verbatim
101 *> LDA is INTEGER
102 *> On entry, LDA specifies the first dimension of A as declared
103 *> in the calling (sub) program. LDA must be at least
104 *> max( 1, n ).
105 *> Unchanged on exit.
106 *> \endverbatim
107 *>
108 *> \param[in] X
109 *> \verbatim
110 *> X is COMPLEX*16 array, DIMENSION at least
111 *> ( 1 + ( n - 1 )*abs( INCX ) )
112 *> Before entry, the incremented array X must contain the
113 *> vector x.
114 *> Unchanged on exit.
115 *> \endverbatim
116 *>
117 *> \param[in] INCX
118 *> \verbatim
119 *> INCX is INTEGER
120 *> On entry, INCX specifies the increment for the elements of
121 *> X. INCX must not be zero.
122 *> Unchanged on exit.
123 *> \endverbatim
124 *>
125 *> \param[in] BETA
126 *> \verbatim
127 *> BETA is DOUBLE PRECISION .
128 *> On entry, BETA specifies the scalar beta. When BETA is
129 *> supplied as zero then Y need not be set on input.
130 *> Unchanged on exit.
131 *> \endverbatim
132 *>
133 *> \param[in,out] Y
134 *> \verbatim
135 *> Y is DOUBLE PRECISION array, dimension
136 *> ( 1 + ( n - 1 )*abs( INCY ) )
137 *> Before entry with BETA non-zero, the incremented array Y
138 *> must contain the vector y. On exit, Y is overwritten by the
139 *> updated vector y.
140 *> \endverbatim
141 *>
142 *> \param[in] INCY
143 *> \verbatim
144 *> INCY is INTEGER
145 *> On entry, INCY specifies the increment for the elements of
146 *> Y. INCY must not be zero.
147 *> Unchanged on exit.
148 *> \endverbatim
149 *
150 * Authors:
151 * ========
152 *
153 *> \author Univ. of Tennessee
154 *> \author Univ. of California Berkeley
155 *> \author Univ. of Colorado Denver
156 *> \author NAG Ltd.
157 *
158 *> \date September 2012
159 *
160 *> \ingroup complex16SYcomputational
161 *
162 *> \par Further Details:
163 * =====================
164 *>
165 *> \verbatim
166 *>
167 *> Level 2 Blas routine.
168 *>
169 *> -- Written on 22-October-1986.
170 *> Jack Dongarra, Argonne National Lab.
171 *> Jeremy Du Croz, Nag Central Office.
172 *> Sven Hammarling, Nag Central Office.
173 *> Richard Hanson, Sandia National Labs.
174 *> -- Modified for the absolute-value product, April 2006
175 *> Jason Riedy, UC Berkeley
176 *> \endverbatim
177 *>
178 * =====================================================================
179  SUBROUTINE zla_syamv( UPLO, N, ALPHA, A, LDA, X, INCX, BETA, Y,
180  $ incy )
181 *
182 * -- LAPACK computational routine (version 3.4.2) --
183 * -- LAPACK is a software package provided by Univ. of Tennessee, --
184 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
185 * September 2012
186 *
187 * .. Scalar Arguments ..
188  DOUBLE PRECISION alpha, beta
189  INTEGER incx, incy, lda, n
190  INTEGER uplo
191 * ..
192 * .. Array Arguments ..
193  COMPLEX*16 a( lda, * ), x( * )
194  DOUBLE PRECISION y( * )
195 * ..
196 *
197 * =====================================================================
198 *
199 * .. Parameters ..
200  DOUBLE PRECISION one, zero
201  parameter( one = 1.0d+0, zero = 0.0d+0 )
202 * ..
203 * .. Local Scalars ..
204  LOGICAL symb_zero
205  DOUBLE PRECISION temp, safe1
206  INTEGER i, info, iy, j, jx, kx, ky
207  COMPLEX*16 zdum
208 * ..
209 * .. External Subroutines ..
210  EXTERNAL xerbla, dlamch
211  DOUBLE PRECISION dlamch
212 * ..
213 * .. External Functions ..
214  EXTERNAL ilauplo
215  INTEGER ilauplo
216 * ..
217 * .. Intrinsic Functions ..
218  INTRINSIC max, abs, sign, REAL, dimag
219 * ..
220 * .. Statement Functions ..
221  DOUBLE PRECISION cabs1
222 * ..
223 * .. Statement Function Definitions ..
224  cabs1( zdum ) = abs( dble( zdum ) ) + abs( dimag( zdum ) )
225 * ..
226 * .. Executable Statements ..
227 *
228 * Test the input parameters.
229 *
230  info = 0
231  IF ( uplo.NE.ilauplo( 'U' ) .AND.
232  $ uplo.NE.ilauplo( 'L' ) )THEN
233  info = 1
234  ELSE IF( n.LT.0 )THEN
235  info = 2
236  ELSE IF( lda.LT.max( 1, n ) )THEN
237  info = 5
238  ELSE IF( incx.EQ.0 )THEN
239  info = 7
240  ELSE IF( incy.EQ.0 )THEN
241  info = 10
242  END IF
243  IF( info.NE.0 )THEN
244  CALL xerbla( 'DSYMV ', info )
245  return
246  END IF
247 *
248 * Quick return if possible.
249 *
250  IF( ( n.EQ.0 ).OR.( ( alpha.EQ.zero ).AND.( beta.EQ.one ) ) )
251  $ return
252 *
253 * Set up the start points in X and Y.
254 *
255  IF( incx.GT.0 )THEN
256  kx = 1
257  ELSE
258  kx = 1 - ( n - 1 )*incx
259  END IF
260  IF( incy.GT.0 )THEN
261  ky = 1
262  ELSE
263  ky = 1 - ( n - 1 )*incy
264  END IF
265 *
266 * Set SAFE1 essentially to be the underflow threshold times the
267 * number of additions in each row.
268 *
269  safe1 = dlamch( 'Safe minimum' )
270  safe1 = (n+1)*safe1
271 *
272 * Form y := alpha*abs(A)*abs(x) + beta*abs(y).
273 *
274 * The O(N^2) SYMB_ZERO tests could be replaced by O(N) queries to
275 * the inexact flag. Still doesn't help change the iteration order
276 * to per-column.
277 *
278  iy = ky
279  IF ( incx.EQ.1 ) THEN
280  IF ( uplo .EQ. ilauplo( 'U' ) ) THEN
281  DO i = 1, n
282  IF ( beta .EQ. zero ) THEN
283  symb_zero = .true.
284  y( iy ) = 0.0d+0
285  ELSE IF ( y( iy ) .EQ. zero ) THEN
286  symb_zero = .true.
287  ELSE
288  symb_zero = .false.
289  y( iy ) = beta * abs( y( iy ) )
290  END IF
291  IF ( alpha .NE. zero ) THEN
292  DO j = 1, i
293  temp = cabs1( a( j, i ) )
294  symb_zero = symb_zero .AND.
295  $ ( x( j ) .EQ. zero .OR. temp .EQ. zero )
296 
297  y( iy ) = y( iy ) + alpha*cabs1( x( j ) )*temp
298  END DO
299  DO j = i+1, n
300  temp = cabs1( a( i, j ) )
301  symb_zero = symb_zero .AND.
302  $ ( x( j ) .EQ. zero .OR. temp .EQ. zero )
303 
304  y( iy ) = y( iy ) + alpha*cabs1( x( j ) )*temp
305  END DO
306  END IF
307 
308  IF ( .NOT.symb_zero )
309  $ y( iy ) = y( iy ) + sign( safe1, y( iy ) )
310 
311  iy = iy + incy
312  END DO
313  ELSE
314  DO i = 1, n
315  IF ( beta .EQ. zero ) THEN
316  symb_zero = .true.
317  y( iy ) = 0.0d+0
318  ELSE IF ( y( iy ) .EQ. zero ) THEN
319  symb_zero = .true.
320  ELSE
321  symb_zero = .false.
322  y( iy ) = beta * abs( y( iy ) )
323  END IF
324  IF ( alpha .NE. zero ) THEN
325  DO j = 1, i
326  temp = cabs1( a( i, j ) )
327  symb_zero = symb_zero .AND.
328  $ ( x( j ) .EQ. zero .OR. temp .EQ. zero )
329 
330  y( iy ) = y( iy ) + alpha*cabs1( x( j ) )*temp
331  END DO
332  DO j = i+1, n
333  temp = cabs1( a( j, i ) )
334  symb_zero = symb_zero .AND.
335  $ ( x( j ) .EQ. zero .OR. temp .EQ. zero )
336 
337  y( iy ) = y( iy ) + alpha*cabs1( x( j ) )*temp
338  END DO
339  END IF
340 
341  IF ( .NOT.symb_zero )
342  $ y( iy ) = y( iy ) + sign( safe1, y( iy ) )
343 
344  iy = iy + incy
345  END DO
346  END IF
347  ELSE
348  IF ( uplo .EQ. ilauplo( 'U' ) ) THEN
349  DO i = 1, n
350  IF ( beta .EQ. zero ) THEN
351  symb_zero = .true.
352  y( iy ) = 0.0d+0
353  ELSE IF ( y( iy ) .EQ. zero ) THEN
354  symb_zero = .true.
355  ELSE
356  symb_zero = .false.
357  y( iy ) = beta * abs( y( iy ) )
358  END IF
359  jx = kx
360  IF ( alpha .NE. zero ) THEN
361  DO j = 1, i
362  temp = cabs1( a( j, i ) )
363  symb_zero = symb_zero .AND.
364  $ ( x( j ) .EQ. zero .OR. temp .EQ. zero )
365 
366  y( iy ) = y( iy ) + alpha*cabs1( x( jx ) )*temp
367  jx = jx + incx
368  END DO
369  DO j = i+1, n
370  temp = cabs1( a( i, j ) )
371  symb_zero = symb_zero .AND.
372  $ ( x( j ) .EQ. zero .OR. temp .EQ. zero )
373 
374  y( iy ) = y( iy ) + alpha*cabs1( x( jx ) )*temp
375  jx = jx + incx
376  END DO
377  END IF
378 
379  IF ( .NOT.symb_zero )
380  $ y( iy ) = y( iy ) + sign( safe1, y( iy ) )
381 
382  iy = iy + incy
383  END DO
384  ELSE
385  DO i = 1, n
386  IF ( beta .EQ. zero ) THEN
387  symb_zero = .true.
388  y( iy ) = 0.0d+0
389  ELSE IF ( y( iy ) .EQ. zero ) THEN
390  symb_zero = .true.
391  ELSE
392  symb_zero = .false.
393  y( iy ) = beta * abs( y( iy ) )
394  END IF
395  jx = kx
396  IF ( alpha .NE. zero ) THEN
397  DO j = 1, i
398  temp = cabs1( a( i, j ) )
399  symb_zero = symb_zero .AND.
400  $ ( x( j ) .EQ. zero .OR. temp .EQ. zero )
401 
402  y( iy ) = y( iy ) + alpha*cabs1( x( jx ) )*temp
403  jx = jx + incx
404  END DO
405  DO j = i+1, n
406  temp = cabs1( a( j, i ) )
407  symb_zero = symb_zero .AND.
408  $ ( x( j ) .EQ. zero .OR. temp .EQ. zero )
409 
410  y( iy ) = y( iy ) + alpha*cabs1( x( jx ) )*temp
411  jx = jx + incx
412  END DO
413  END IF
414 
415  IF ( .NOT.symb_zero )
416  $ y( iy ) = y( iy ) + sign( safe1, y( iy ) )
417 
418  iy = iy + incy
419  END DO
420  END IF
421 
422  END IF
423 *
424  return
425 *
426 * End of ZLA_SYAMV
427 *
428  END