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