LAPACK 3.12.1
LAPACK: Linear Algebra PACKage
•All Classes Namespaces Files Functions Variables Typedefs Enumerations Enumerator Macros Modules Pages

◆ sla_syamv()

subroutine sla_syamv ( integer uplo,
integer n,
real alpha,
real, dimension( lda, * ) a,
integer lda,
real, dimension( * ) x,
integer incx,
real beta,
real, dimension( * ) y,
integer incy )

SLA_SYAMV computes a matrix-vector product using a symmetric indefinite matrix to calculate error bounds.

Download SLA_SYAMV + dependencies [TGZ] [ZIP] [TXT]

Purpose:
!>
!> SLA_SYAMV  performs the matrix-vector operation
!>
!>         y := alpha*abs(A)*abs(x) + beta*abs(y),
!>
!> where alpha and beta are scalars, x and y are vectors and A is an
!> n by n symmetric matrix.
!>
!> This function is primarily used in calculating error bounds.
!> To protect against underflow during evaluation, components in
!> the resulting vector are perturbed away from zero by (N+1)
!> times the underflow threshold.  To prevent unnecessarily large
!> errors for block-structure embedded in general matrices,
!>  zero components are not perturbed.  A zero
!> entry is considered  if all multiplications involved
!> in computing that entry have at least one zero multiplicand.
!>
Parameters
[in]UPLO
!>          UPLO is INTEGER
!>           On entry, UPLO specifies whether the upper or lower
!>           triangular part of the array A is to be referenced as
!>           follows:
!>
!>              UPLO = BLAS_UPPER   Only the upper triangular part of A
!>                                  is to be referenced.
!>
!>              UPLO = BLAS_LOWER   Only the lower triangular part of A
!>                                  is to be referenced.
!>
!>           Unchanged on exit.
!>
[in]N
!>          N is INTEGER
!>           On entry, N specifies the number of columns of the matrix A.
!>           N must be at least zero.
!>           Unchanged on exit.
!>
[in]ALPHA
!>          ALPHA is REAL .
!>           On entry, ALPHA specifies the scalar alpha.
!>           Unchanged on exit.
!>
[in]A
!>          A is REAL array, dimension ( LDA, n ).
!>           Before entry, the leading m by n part of the array A must
!>           contain the matrix of coefficients.
!>           Unchanged on exit.
!>
[in]LDA
!>          LDA is INTEGER
!>           On entry, LDA specifies the first dimension of A as declared
!>           in the calling (sub) program. LDA must be at least
!>           max( 1, n ).
!>           Unchanged on exit.
!>
[in]X
!>          X is REAL array, dimension
!>           ( 1 + ( n - 1 )*abs( INCX ) )
!>           Before entry, the incremented array X must contain the
!>           vector x.
!>           Unchanged on exit.
!>
[in]INCX
!>          INCX is INTEGER
!>           On entry, INCX specifies the increment for the elements of
!>           X. INCX must not be zero.
!>           Unchanged on exit.
!>
[in]BETA
!>          BETA is REAL .
!>           On entry, BETA specifies the scalar beta. When BETA is
!>           supplied as zero then Y need not be set on input.
!>           Unchanged on exit.
!>
[in,out]Y
!>          Y is REAL array, dimension
!>           ( 1 + ( n - 1 )*abs( INCY ) )
!>           Before entry with BETA non-zero, the incremented array Y
!>           must contain the vector y. On exit, Y is overwritten by the
!>           updated vector y.
!>
[in]INCY
!>          INCY is INTEGER
!>           On entry, INCY specifies the increment for the elements of
!>           Y. INCY must not be zero.
!>           Unchanged on exit.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.
Further Details:
!>
!>  Level 2 Blas routine.
!>
!>  -- Written on 22-October-1986.
!>     Jack Dongarra, Argonne National Lab.
!>     Jeremy Du Croz, Nag Central Office.
!>     Sven Hammarling, Nag Central Office.
!>     Richard Hanson, Sandia National Labs.
!>  -- Modified for the absolute-value product, April 2006
!>     Jason Riedy, UC Berkeley
!>

Definition at line 173 of file sla_syamv.f.

175*
176* -- LAPACK computational routine --
177* -- LAPACK is a software package provided by Univ. of Tennessee, --
178* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
179*
180* .. Scalar Arguments ..
181 REAL ALPHA, BETA
182 INTEGER INCX, INCY, LDA, N, UPLO
183* ..
184* .. Array Arguments ..
185 REAL A( LDA, * ), X( * ), Y( * )
186* ..
187*
188* =====================================================================
189*
190* .. Parameters ..
191 REAL ONE, ZERO
192 parameter( one = 1.0e+0, zero = 0.0e+0 )
193* ..
194* .. Local Scalars ..
195 LOGICAL SYMB_ZERO
196 REAL TEMP, SAFE1
197 INTEGER I, INFO, IY, J, JX, KX, KY
198* ..
199* .. External Subroutines ..
200 EXTERNAL xerbla, slamch
201 REAL SLAMCH
202* ..
203* .. External Functions ..
204 EXTERNAL ilauplo
205 INTEGER ILAUPLO
206* ..
207* .. Intrinsic Functions ..
208 INTRINSIC max, abs, sign
209* ..
210* .. Executable Statements ..
211*
212* Test the input parameters.
213*
214 info = 0
215 IF ( uplo.NE.ilauplo( 'U' ) .AND.
216 $ uplo.NE.ilauplo( 'L' ) ) THEN
217 info = 1
218 ELSE IF( n.LT.0 )THEN
219 info = 2
220 ELSE IF( lda.LT.max( 1, n ) )THEN
221 info = 5
222 ELSE IF( incx.EQ.0 )THEN
223 info = 7
224 ELSE IF( incy.EQ.0 )THEN
225 info = 10
226 END IF
227 IF( info.NE.0 )THEN
228 CALL xerbla( 'SLA_SYAMV', info )
229 RETURN
230 END IF
231*
232* Quick return if possible.
233*
234 IF( ( n.EQ.0 ).OR.( ( alpha.EQ.zero ).AND.( beta.EQ.one ) ) )
235 $ RETURN
236*
237* Set up the start points in X and Y.
238*
239 IF( incx.GT.0 )THEN
240 kx = 1
241 ELSE
242 kx = 1 - ( n - 1 )*incx
243 END IF
244 IF( incy.GT.0 )THEN
245 ky = 1
246 ELSE
247 ky = 1 - ( n - 1 )*incy
248 END IF
249*
250* Set SAFE1 essentially to be the underflow threshold times the
251* number of additions in each row.
252*
253 safe1 = slamch( 'Safe minimum' )
254 safe1 = (n+1)*safe1
255*
256* Form y := alpha*abs(A)*abs(x) + beta*abs(y).
257*
258* The O(N^2) SYMB_ZERO tests could be replaced by O(N) queries to
259* the inexact flag. Still doesn't help change the iteration order
260* to per-column.
261*
262 iy = ky
263 IF ( incx.EQ.1 ) THEN
264 IF ( uplo .EQ. ilauplo( 'U' ) ) THEN
265 DO i = 1, n
266 IF ( beta .EQ. zero ) THEN
267 symb_zero = .true.
268 y( iy ) = 0.0
269 ELSE IF ( y( iy ) .EQ. zero ) THEN
270 symb_zero = .true.
271 ELSE
272 symb_zero = .false.
273 y( iy ) = beta * abs( y( iy ) )
274 END IF
275 IF ( alpha .NE. zero ) THEN
276 DO j = 1, i
277 temp = abs( a( j, i ) )
278 symb_zero = symb_zero .AND.
279 $ ( x( j ) .EQ. zero .OR. temp .EQ. zero )
280
281 y( iy ) = y( iy ) + alpha*abs( x( j ) )*temp
282 END DO
283 DO j = i+1, n
284 temp = abs( a( i, j ) )
285 symb_zero = symb_zero .AND.
286 $ ( x( j ) .EQ. zero .OR. temp .EQ. zero )
287
288 y( iy ) = y( iy ) + alpha*abs( x( j ) )*temp
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.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 IF ( alpha .NE. zero ) THEN
309 DO j = 1, i
310 temp = abs( a( i, j ) )
311 symb_zero = symb_zero .AND.
312 $ ( x( j ) .EQ. zero .OR. temp .EQ. zero )
313
314 y( iy ) = y( iy ) + alpha*abs( x( j ) )*temp
315 END DO
316 DO j = i+1, n
317 temp = abs( a( j, i ) )
318 symb_zero = symb_zero .AND.
319 $ ( x( j ) .EQ. zero .OR. temp .EQ. zero )
320
321 y( iy ) = y( iy ) + alpha*abs( x( j ) )*temp
322 END DO
323 END IF
324
325 IF ( .NOT.symb_zero )
326 $ y( iy ) = y( iy ) + sign( safe1, y( iy ) )
327
328 iy = iy + incy
329 END DO
330 END IF
331 ELSE
332 IF ( uplo .EQ. ilauplo( 'U' ) ) THEN
333 DO i = 1, n
334 IF ( beta .EQ. zero ) THEN
335 symb_zero = .true.
336 y( iy ) = 0.0
337 ELSE IF ( y( iy ) .EQ. zero ) THEN
338 symb_zero = .true.
339 ELSE
340 symb_zero = .false.
341 y( iy ) = beta * abs( y( iy ) )
342 END IF
343 jx = kx
344 IF ( alpha .NE. zero ) THEN
345 DO j = 1, i
346 temp = abs( a( j, i ) )
347 symb_zero = symb_zero .AND.
348 $ ( x( j ) .EQ. zero .OR. temp .EQ. zero )
349
350 y( iy ) = y( iy ) + alpha*abs( x( jx ) )*temp
351 jx = jx + incx
352 END DO
353 DO j = i+1, n
354 temp = abs( a( i, j ) )
355 symb_zero = symb_zero .AND.
356 $ ( x( j ) .EQ. zero .OR. temp .EQ. zero )
357
358 y( iy ) = y( iy ) + alpha*abs( x( jx ) )*temp
359 jx = jx + incx
360 END DO
361 END IF
362
363 IF ( .NOT.symb_zero )
364 $ y( iy ) = y( iy ) + sign( safe1, y( iy ) )
365
366 iy = iy + incy
367 END DO
368 ELSE
369 DO i = 1, n
370 IF ( beta .EQ. zero ) THEN
371 symb_zero = .true.
372 y( iy ) = 0.0
373 ELSE IF ( y( iy ) .EQ. zero ) THEN
374 symb_zero = .true.
375 ELSE
376 symb_zero = .false.
377 y( iy ) = beta * abs( y( iy ) )
378 END IF
379 jx = kx
380 IF ( alpha .NE. zero ) THEN
381 DO j = 1, i
382 temp = abs( a( i, j ) )
383 symb_zero = symb_zero .AND.
384 $ ( x( j ) .EQ. zero .OR. temp .EQ. zero )
385
386 y( iy ) = y( iy ) + alpha*abs( x( jx ) )*temp
387 jx = jx + incx
388 END DO
389 DO j = i+1, n
390 temp = abs( a( j, i ) )
391 symb_zero = symb_zero .AND.
392 $ ( x( j ) .EQ. zero .OR. temp .EQ. zero )
393
394 y( iy ) = y( iy ) + alpha*abs( x( jx ) )*temp
395 jx = jx + incx
396 END DO
397 END IF
398
399 IF ( .NOT.symb_zero )
400 $ y( iy ) = y( iy ) + sign( safe1, y( iy ) )
401
402 iy = iy + incy
403 END DO
404 END IF
405
406 END IF
407*
408 RETURN
409*
410* End of SLA_SYAMV
411*
xerbla
subroutine xerbla(srname, info)
Definition cblat2.f:3285
ilauplo
integer function ilauplo(uplo)
ILAUPLO
Definition ilauplo.f:56
slamch
real function slamch(cmach)
SLAMCH
Definition slamch.f:68
Here is the call graph for this function:
Here is the caller graph for this function: