![]() |
LAPACK
3.4.1
LAPACK: Linear Algebra PACKage
|
00001 *> \brief \b CLA_HEAMV 00002 * 00003 * =========== DOCUMENTATION =========== 00004 * 00005 * Online html documentation available at 00006 * http://www.netlib.org/lapack/explore-html/ 00007 * 00008 *> \htmlonly 00009 *> Download CLA_HEAMV + dependencies 00010 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/cla_heamv.f"> 00011 *> [TGZ]</a> 00012 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/cla_heamv.f"> 00013 *> [ZIP]</a> 00014 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/cla_heamv.f"> 00015 *> [TXT]</a> 00016 *> \endhtmlonly 00017 * 00018 * Definition: 00019 * =========== 00020 * 00021 * SUBROUTINE CLA_HEAMV( UPLO, N, ALPHA, A, LDA, X, INCX, BETA, Y, 00022 * INCY ) 00023 * 00024 * .. Scalar Arguments .. 00025 * REAL ALPHA, BETA 00026 * INTEGER INCX, INCY, LDA, N, UPLO 00027 * .. 00028 * .. Array Arguments .. 00029 * COMPLEX A( LDA, * ), X( * ) 00030 * REAL Y( * ) 00031 * .. 00032 * 00033 * 00034 *> \par Purpose: 00035 * ============= 00036 *> 00037 *> \verbatim 00038 *> 00039 *> CLA_SYAMV performs the matrix-vector operation 00040 *> 00041 *> y := alpha*abs(A)*abs(x) + beta*abs(y), 00042 *> 00043 *> where alpha and beta are scalars, x and y are vectors and A is an 00044 *> n by n symmetric matrix. 00045 *> 00046 *> This function is primarily used in calculating error bounds. 00047 *> To protect against underflow during evaluation, components in 00048 *> the resulting vector are perturbed away from zero by (N+1) 00049 *> times the underflow threshold. To prevent unnecessarily large 00050 *> errors for block-structure embedded in general matrices, 00051 *> "symbolically" zero components are not perturbed. A zero 00052 *> entry is considered "symbolic" if all multiplications involved 00053 *> in computing that entry have at least one zero multiplicand. 00054 *> \endverbatim 00055 * 00056 * Arguments: 00057 * ========== 00058 * 00059 *> \param[in] UPLO 00060 *> \verbatim 00061 *> UPLO is INTEGER 00062 *> On entry, UPLO specifies whether the upper or lower 00063 *> triangular part of the array A is to be referenced as 00064 *> follows: 00065 *> 00066 *> UPLO = BLAS_UPPER Only the upper triangular part of A 00067 *> is to be referenced. 00068 *> 00069 *> UPLO = BLAS_LOWER Only the lower triangular part of A 00070 *> is to be referenced. 00071 *> 00072 *> Unchanged on exit. 00073 *> \endverbatim 00074 *> 00075 *> \param[in] N 00076 *> \verbatim 00077 *> N is INTEGER 00078 *> On entry, N specifies the number of columns of the matrix A. 00079 *> N must be at least zero. 00080 *> Unchanged on exit. 00081 *> \endverbatim 00082 *> 00083 *> \param[in] ALPHA 00084 *> \verbatim 00085 *> ALPHA is REAL . 00086 *> On entry, ALPHA specifies the scalar alpha. 00087 *> Unchanged on exit. 00088 *> \endverbatim 00089 *> 00090 *> \param[in] A 00091 *> \verbatim 00092 *> A is COMPLEX array of DIMENSION ( LDA, n ). 00093 *> Before entry, the leading m by n part of the array A must 00094 *> contain the matrix of coefficients. 00095 *> Unchanged on exit. 00096 *> \endverbatim 00097 *> 00098 *> \param[in] LDA 00099 *> \verbatim 00100 *> LDA is INTEGER 00101 *> On entry, LDA specifies the first dimension of A as declared 00102 *> in the calling (sub) program. LDA must be at least 00103 *> max( 1, n ). 00104 *> Unchanged on exit. 00105 *> \endverbatim 00106 *> 00107 *> \param[in] X 00108 *> \verbatim 00109 *> X is COMPLEX array, dimension 00110 *> ( 1 + ( n - 1 )*abs( INCX ) ) 00111 *> Before entry, the incremented array X must contain the 00112 *> vector x. 00113 *> Unchanged on exit. 00114 *> \endverbatim 00115 *> 00116 *> \param[in] INCX 00117 *> \verbatim 00118 *> INCX is INTEGER 00119 *> On entry, INCX specifies the increment for the elements of 00120 *> X. INCX must not be zero. 00121 *> Unchanged on exit. 00122 *> \endverbatim 00123 *> 00124 *> \param[in] BETA 00125 *> \verbatim 00126 *> BETA is REAL . 00127 *> On entry, BETA specifies the scalar beta. When BETA is 00128 *> supplied as zero then Y need not be set on input. 00129 *> Unchanged on exit. 00130 *> \endverbatim 00131 *> 00132 *> \param[in,out] Y 00133 *> \verbatim 00134 *> Y is REAL array, dimension 00135 *> ( 1 + ( n - 1 )*abs( INCY ) ) 00136 *> Before entry with BETA non-zero, the incremented array Y 00137 *> must contain the vector y. On exit, Y is overwritten by the 00138 *> updated vector y. 00139 *> \endverbatim 00140 *> 00141 *> \param[in] INCY 00142 *> \verbatim 00143 *> INCY is INTEGER 00144 *> On entry, INCY specifies the increment for the elements of 00145 *> Y. INCY must not be zero. 00146 *> Unchanged on exit. 00147 *> \endverbatim 00148 * 00149 * Authors: 00150 * ======== 00151 * 00152 *> \author Univ. of Tennessee 00153 *> \author Univ. of California Berkeley 00154 *> \author Univ. of Colorado Denver 00155 *> \author NAG Ltd. 00156 * 00157 *> \date November 2011 00158 * 00159 *> \ingroup complexHEcomputational 00160 * 00161 *> \par Further Details: 00162 * ===================== 00163 *> 00164 *> \verbatim 00165 *> 00166 *> Level 2 Blas routine. 00167 *> 00168 *> -- Written on 22-October-1986. 00169 *> Jack Dongarra, Argonne National Lab. 00170 *> Jeremy Du Croz, Nag Central Office. 00171 *> Sven Hammarling, Nag Central Office. 00172 *> Richard Hanson, Sandia National Labs. 00173 *> -- Modified for the absolute-value product, April 2006 00174 *> Jason Riedy, UC Berkeley 00175 *> \endverbatim 00176 *> 00177 * ===================================================================== 00178 SUBROUTINE CLA_HEAMV( UPLO, N, ALPHA, A, LDA, X, INCX, BETA, Y, 00179 $ INCY ) 00180 * 00181 * -- LAPACK computational routine (version 3.4.0) -- 00182 * -- LAPACK is a software package provided by Univ. of Tennessee, -- 00183 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- 00184 * November 2011 00185 * 00186 * .. Scalar Arguments .. 00187 REAL ALPHA, BETA 00188 INTEGER INCX, INCY, LDA, N, UPLO 00189 * .. 00190 * .. Array Arguments .. 00191 COMPLEX A( LDA, * ), X( * ) 00192 REAL Y( * ) 00193 * .. 00194 * 00195 * ===================================================================== 00196 * 00197 * .. Parameters .. 00198 REAL ONE, ZERO 00199 PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) 00200 * .. 00201 * .. Local Scalars .. 00202 LOGICAL SYMB_ZERO 00203 REAL TEMP, SAFE1 00204 INTEGER I, INFO, IY, J, JX, KX, KY 00205 COMPLEX ZDUM 00206 * .. 00207 * .. External Subroutines .. 00208 EXTERNAL XERBLA, SLAMCH 00209 REAL SLAMCH 00210 * .. 00211 * .. External Functions .. 00212 EXTERNAL ILAUPLO 00213 INTEGER ILAUPLO 00214 * .. 00215 * .. Intrinsic Functions .. 00216 INTRINSIC MAX, ABS, SIGN, REAL, AIMAG 00217 * .. 00218 * .. Statement Functions .. 00219 REAL CABS1 00220 * .. 00221 * .. Statement Function Definitions .. 00222 CABS1( ZDUM ) = ABS( REAL ( ZDUM ) ) + ABS( AIMAG ( ZDUM ) ) 00223 * .. 00224 * .. Executable Statements .. 00225 * 00226 * Test the input parameters. 00227 * 00228 INFO = 0 00229 IF ( UPLO.NE.ILAUPLO( 'U' ) .AND. 00230 $ UPLO.NE.ILAUPLO( 'L' ) )THEN 00231 INFO = 1 00232 ELSE IF( N.LT.0 )THEN 00233 INFO = 2 00234 ELSE IF( LDA.LT.MAX( 1, N ) )THEN 00235 INFO = 5 00236 ELSE IF( INCX.EQ.0 )THEN 00237 INFO = 7 00238 ELSE IF( INCY.EQ.0 )THEN 00239 INFO = 10 00240 END IF 00241 IF( INFO.NE.0 )THEN 00242 CALL XERBLA( 'CHEMV ', INFO ) 00243 RETURN 00244 END IF 00245 * 00246 * Quick return if possible. 00247 * 00248 IF( ( N.EQ.0 ).OR.( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) ) 00249 $ RETURN 00250 * 00251 * Set up the start points in X and Y. 00252 * 00253 IF( INCX.GT.0 )THEN 00254 KX = 1 00255 ELSE 00256 KX = 1 - ( N - 1 )*INCX 00257 END IF 00258 IF( INCY.GT.0 )THEN 00259 KY = 1 00260 ELSE 00261 KY = 1 - ( N - 1 )*INCY 00262 END IF 00263 * 00264 * Set SAFE1 essentially to be the underflow threshold times the 00265 * number of additions in each row. 00266 * 00267 SAFE1 = SLAMCH( 'Safe minimum' ) 00268 SAFE1 = (N+1)*SAFE1 00269 * 00270 * Form y := alpha*abs(A)*abs(x) + beta*abs(y). 00271 * 00272 * The O(N^2) SYMB_ZERO tests could be replaced by O(N) queries to 00273 * the inexact flag. Still doesn't help change the iteration order 00274 * to per-column. 00275 * 00276 IY = KY 00277 IF ( INCX.EQ.1 ) THEN 00278 IF ( UPLO .EQ. ILAUPLO( 'U' ) ) THEN 00279 DO I = 1, N 00280 IF ( BETA .EQ. ZERO ) THEN 00281 SYMB_ZERO = .TRUE. 00282 Y( IY ) = 0.0 00283 ELSE IF ( Y( IY ) .EQ. ZERO ) THEN 00284 SYMB_ZERO = .TRUE. 00285 ELSE 00286 SYMB_ZERO = .FALSE. 00287 Y( IY ) = BETA * ABS( Y( IY ) ) 00288 END IF 00289 IF ( ALPHA .NE. ZERO ) THEN 00290 DO J = 1, I 00291 TEMP = CABS1( A( J, I ) ) 00292 SYMB_ZERO = SYMB_ZERO .AND. 00293 $ ( X( J ) .EQ. ZERO .OR. TEMP .EQ. ZERO ) 00294 00295 Y( IY ) = Y( IY ) + ALPHA*CABS1( X( J ) )*TEMP 00296 END DO 00297 DO J = I+1, N 00298 TEMP = CABS1( A( I, J ) ) 00299 SYMB_ZERO = SYMB_ZERO .AND. 00300 $ ( X( J ) .EQ. ZERO .OR. TEMP .EQ. ZERO ) 00301 00302 Y( IY ) = Y( IY ) + ALPHA*CABS1( X( J ) )*TEMP 00303 END DO 00304 END IF 00305 00306 IF (.NOT.SYMB_ZERO) 00307 $ Y( IY ) = Y( IY ) + SIGN( SAFE1, Y( IY ) ) 00308 00309 IY = IY + INCY 00310 END DO 00311 ELSE 00312 DO I = 1, N 00313 IF ( BETA .EQ. ZERO ) THEN 00314 SYMB_ZERO = .TRUE. 00315 Y( IY ) = 0.0 00316 ELSE IF ( Y( IY ) .EQ. ZERO ) THEN 00317 SYMB_ZERO = .TRUE. 00318 ELSE 00319 SYMB_ZERO = .FALSE. 00320 Y( IY ) = BETA * ABS( Y( IY ) ) 00321 END IF 00322 IF ( ALPHA .NE. ZERO ) THEN 00323 DO J = 1, I 00324 TEMP = CABS1( A( I, J ) ) 00325 SYMB_ZERO = SYMB_ZERO .AND. 00326 $ ( X( J ) .EQ. ZERO .OR. TEMP .EQ. ZERO ) 00327 00328 Y( IY ) = Y( IY ) + ALPHA*CABS1( X( J ) )*TEMP 00329 END DO 00330 DO J = I+1, N 00331 TEMP = CABS1( A( J, I ) ) 00332 SYMB_ZERO = SYMB_ZERO .AND. 00333 $ ( X( J ) .EQ. ZERO .OR. TEMP .EQ. ZERO ) 00334 00335 Y( IY ) = Y( IY ) + ALPHA*CABS1( X( J ) )*TEMP 00336 END DO 00337 END IF 00338 00339 IF (.NOT.SYMB_ZERO) 00340 $ Y( IY ) = Y( IY ) + SIGN( SAFE1, Y( IY ) ) 00341 00342 IY = IY + INCY 00343 END DO 00344 END IF 00345 ELSE 00346 IF ( UPLO .EQ. ILAUPLO( 'U' ) ) THEN 00347 DO I = 1, N 00348 IF ( BETA .EQ. ZERO ) THEN 00349 SYMB_ZERO = .TRUE. 00350 Y( IY ) = 0.0 00351 ELSE IF ( Y( IY ) .EQ. ZERO ) THEN 00352 SYMB_ZERO = .TRUE. 00353 ELSE 00354 SYMB_ZERO = .FALSE. 00355 Y( IY ) = BETA * ABS( Y( IY ) ) 00356 END IF 00357 JX = KX 00358 IF ( ALPHA .NE. ZERO ) THEN 00359 DO J = 1, I 00360 TEMP = CABS1( A( J, I ) ) 00361 SYMB_ZERO = SYMB_ZERO .AND. 00362 $ ( X( J ) .EQ. ZERO .OR. TEMP .EQ. ZERO ) 00363 00364 Y( IY ) = Y( IY ) + ALPHA*CABS1( X( JX ) )*TEMP 00365 JX = JX + INCX 00366 END DO 00367 DO J = I+1, N 00368 TEMP = CABS1( A( I, J ) ) 00369 SYMB_ZERO = SYMB_ZERO .AND. 00370 $ ( X( J ) .EQ. ZERO .OR. TEMP .EQ. ZERO ) 00371 00372 Y( IY ) = Y( IY ) + ALPHA*CABS1( X( JX ) )*TEMP 00373 JX = JX + INCX 00374 END DO 00375 END IF 00376 00377 IF ( .NOT.SYMB_ZERO ) 00378 $ Y( IY ) = Y( IY ) + SIGN( SAFE1, Y( IY ) ) 00379 00380 IY = IY + INCY 00381 END DO 00382 ELSE 00383 DO I = 1, N 00384 IF ( BETA .EQ. ZERO ) THEN 00385 SYMB_ZERO = .TRUE. 00386 Y( IY ) = 0.0 00387 ELSE IF ( Y( IY ) .EQ. ZERO ) THEN 00388 SYMB_ZERO = .TRUE. 00389 ELSE 00390 SYMB_ZERO = .FALSE. 00391 Y( IY ) = BETA * ABS( Y( IY ) ) 00392 END IF 00393 JX = KX 00394 IF ( ALPHA .NE. ZERO ) THEN 00395 DO J = 1, I 00396 TEMP = CABS1( A( I, J ) ) 00397 SYMB_ZERO = SYMB_ZERO .AND. 00398 $ ( X( J ) .EQ. ZERO .OR. TEMP .EQ. ZERO ) 00399 00400 Y( IY ) = Y( IY ) + ALPHA*CABS1( X( JX ) )*TEMP 00401 JX = JX + INCX 00402 END DO 00403 DO J = I+1, N 00404 TEMP = CABS1( A( J, I ) ) 00405 SYMB_ZERO = SYMB_ZERO .AND. 00406 $ ( X( J ) .EQ. ZERO .OR. TEMP .EQ. ZERO ) 00407 00408 Y( IY ) = Y( IY ) + ALPHA*CABS1( X( JX ) )*TEMP 00409 JX = JX + INCX 00410 END DO 00411 END IF 00412 00413 IF ( .NOT.SYMB_ZERO ) 00414 $ Y( IY ) = Y( IY ) + SIGN( SAFE1, Y( IY ) ) 00415 00416 IY = IY + INCY 00417 END DO 00418 END IF 00419 00420 END IF 00421 * 00422 RETURN 00423 * 00424 * End of CLA_HEAMV 00425 * 00426 END