LAPACK 3.12.0
LAPACK: Linear Algebra PACKage
Loading...
Searching...
No Matches

◆ cla_heamv()

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

CLA_HEAMV computes a matrix-vector product using a Hermitian indefinite matrix to calculate error bounds.

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

Purpose:
 CLA_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,
 "symbolically" zero components are not perturbed.  A zero
 entry is considered "symbolic" 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 COMPLEX 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 COMPLEX 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 176 of file cla_heamv.f.

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