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