1: SUBROUTINE DLA_GBAMV( TRANS, M, N, KL, KU, ALPHA, AB, LDAB, X,
2: $ INCX, BETA, Y, 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, LDAB, M, N, KL, KU, TRANS
17: * ..
18: * .. Array Arguments ..
19: DOUBLE PRECISION AB( LDAB, * ), X( * ), Y( * )
20: * ..
21: *
22: * Purpose
23: * =======
24: *
25: * DLA_GBAMV performs one of the matrix-vector operations
26: *
27: * y := alpha*abs(A)*abs(x) + beta*abs(y),
28: * or 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: * m by n 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: * TRANS (input) INTEGER
46: * On entry, TRANS specifies the operation to be performed as
47: * follows:
48: *
49: * BLAS_NO_TRANS y := alpha*abs(A)*abs(x) + beta*abs(y)
50: * BLAS_TRANS y := alpha*abs(A')*abs(x) + beta*abs(y)
51: * BLAS_CONJ_TRANS y := alpha*abs(A')*abs(x) + beta*abs(y)
52: *
53: * Unchanged on exit.
54: *
55: * M (input) INTEGER
56: * On entry, M specifies the number of rows of the matrix A.
57: * M must be at least zero.
58: * Unchanged on exit.
59: *
60: * N (input) INTEGER
61: * On entry, N specifies the number of columns of the matrix A.
62: * N must be at least zero.
63: * Unchanged on exit.
64: *
65: * KL (input) INTEGER
66: * The number of subdiagonals within the band of A. KL >= 0.
67: *
68: * KU (input) INTEGER
69: * The number of superdiagonals within the band of A. KU >= 0.
70: *
71: * ALPHA - DOUBLE PRECISION
72: * On entry, ALPHA specifies the scalar alpha.
73: * Unchanged on exit.
74: *
75: * A - DOUBLE PRECISION array of DIMENSION ( LDA, n )
76: * Before entry, the leading m by n part of the array A must
77: * contain the matrix of coefficients.
78: * Unchanged on exit.
79: *
80: * LDA (input) INTEGER
81: * On entry, LDA specifies the first dimension of A as declared
82: * in the calling (sub) program. LDA must be at least
83: * max( 1, m ).
84: * Unchanged on exit.
85: *
86: * X (input) DOUBLE PRECISION array, dimension
87: * ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n'
88: * and at least
89: * ( 1 + ( m - 1 )*abs( INCX ) ) otherwise.
90: * Before entry, the incremented array X must contain the
91: * vector x.
92: * Unchanged on exit.
93: *
94: * INCX (input) INTEGER
95: * On entry, INCX specifies the increment for the elements of
96: * X. INCX must not be zero.
97: * Unchanged on exit.
98: *
99: * BETA - DOUBLE PRECISION
100: * On entry, BETA specifies the scalar beta. When BETA is
101: * supplied as zero then Y need not be set on input.
102: * Unchanged on exit.
103: *
104: * Y (input/output) DOUBLE PRECISION array, dimension
105: * ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n'
106: * and at least
107: * ( 1 + ( n - 1 )*abs( INCY ) ) otherwise.
108: * Before entry with BETA non-zero, the incremented array Y
109: * must contain the vector y. On exit, Y is overwritten by the
110: * updated vector y.
111: *
112: * INCY (input) INTEGER
113: * On entry, INCY specifies the increment for the elements of
114: * Y. INCY must not be zero.
115: * Unchanged on exit.
116: *
117: *
118: * Level 2 Blas routine.
119: *
120: * =====================================================================
121:
122: * .. Parameters ..
123: DOUBLE PRECISION ONE, ZERO
124: PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
125: * ..
126: * .. Local Scalars ..
127: LOGICAL SYMB_ZERO
128: DOUBLE PRECISION TEMP, SAFE1
129: INTEGER I, INFO, IY, J, JX, KX, KY, LENX, LENY, KD, KE
130: * ..
131: * .. External Subroutines ..
132: EXTERNAL XERBLA, DLAMCH
133: DOUBLE PRECISION DLAMCH
134: * ..
135: * .. External Functions ..
136: EXTERNAL ILATRANS
137: INTEGER ILATRANS
138: * ..
139: * .. Intrinsic Functions ..
140: INTRINSIC MAX, ABS, SIGN
141: * ..
142: * .. Executable Statements ..
143: *
144: * Test the input parameters.
145: *
146: INFO = 0
147: IF ( .NOT.( ( TRANS.EQ.ILATRANS( 'N' ) )
148: $ .OR. ( TRANS.EQ.ILATRANS( 'T' ) )
149: $ .OR. ( TRANS.EQ.ILATRANS( 'C' ) ) ) ) THEN
150: INFO = 1
151: ELSE IF( M.LT.0 )THEN
152: INFO = 2
153: ELSE IF( N.LT.0 )THEN
154: INFO = 3
155: ELSE IF( KL.LT.0 .OR. KL.GT.M-1 ) THEN
156: INFO = 4
157: ELSE IF( KU.LT.0 .OR. KU.GT.N-1 ) THEN
158: INFO = 5
159: ELSE IF( LDAB.LT.KL+KU+1 )THEN
160: INFO = 6
161: ELSE IF( INCX.EQ.0 )THEN
162: INFO = 8
163: ELSE IF( INCY.EQ.0 )THEN
164: INFO = 11
165: END IF
166: IF( INFO.NE.0 )THEN
167: CALL XERBLA( 'DLA_GBAMV ', INFO )
168: RETURN
169: END IF
170: *
171: * Quick return if possible.
172: *
173: IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR.
174: $ ( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) )
175: $ RETURN
176: *
177: * Set LENX and LENY, the lengths of the vectors x and y, and set
178: * up the start points in X and Y.
179: *
180: IF( TRANS.EQ.ILATRANS( 'N' ) )THEN
181: LENX = N
182: LENY = M
183: ELSE
184: LENX = M
185: LENY = N
186: END IF
187: IF( INCX.GT.0 )THEN
188: KX = 1
189: ELSE
190: KX = 1 - ( LENX - 1 )*INCX
191: END IF
192: IF( INCY.GT.0 )THEN
193: KY = 1
194: ELSE
195: KY = 1 - ( LENY - 1 )*INCY
196: END IF
197: *
198: * Set SAFE1 essentially to be the underflow threshold times the
199: * number of additions in each row.
200: *
201: SAFE1 = DLAMCH( 'Safe minimum' )
202: SAFE1 = (N+1)*SAFE1
203: *
204: * Form y := alpha*abs(A)*abs(x) + beta*abs(y).
205: *
206: * The O(M*N) SYMB_ZERO tests could be replaced by O(N) queries to
207: * the inexact flag. Still doesn't help change the iteration order
208: * to per-column.
209: *
210: KD = KU + 1
211: KE = KL + 1
212: IY = KY
213: IF ( INCX.EQ.1 ) THEN
214: IF( TRANS.EQ.ILATRANS( 'N' ) )THEN
215: DO I = 1, LENY
216: IF ( BETA .EQ. ZERO ) THEN
217: SYMB_ZERO = .TRUE.
218: Y( IY ) = 0.0D+0
219: ELSE IF ( Y( IY ) .EQ. ZERO ) THEN
220: SYMB_ZERO = .TRUE.
221: ELSE
222: SYMB_ZERO = .FALSE.
223: Y( IY ) = BETA * ABS( Y( IY ) )
224: END IF
225: IF ( ALPHA .NE. ZERO ) THEN
226: DO J = MAX( I-KL, 1 ), MIN( I+KU, LENX )
227: TEMP = ABS( AB( KD+I-J, J ) )
228: SYMB_ZERO = SYMB_ZERO .AND.
229: $ ( X( J ) .EQ. ZERO .OR. TEMP .EQ. ZERO )
230:
231: Y( IY ) = Y( IY ) + ALPHA*ABS( X( J ) )*TEMP
232: END DO
233: END IF
234:
235: IF ( .NOT.SYMB_ZERO )
236: $ Y( IY ) = Y( IY ) + SIGN( SAFE1, Y( IY ) )
237: IY = IY + INCY
238: END DO
239: ELSE
240: DO I = 1, LENY
241: IF ( BETA .EQ. ZERO ) THEN
242: SYMB_ZERO = .TRUE.
243: Y( IY ) = 0.0D+0
244: ELSE IF ( Y( IY ) .EQ. ZERO ) THEN
245: SYMB_ZERO = .TRUE.
246: ELSE
247: SYMB_ZERO = .FALSE.
248: Y( IY ) = BETA * ABS( Y( IY ) )
249: END IF
250: IF ( ALPHA .NE. ZERO ) THEN
251: DO J = MAX( I-KL, 1 ), MIN( I+KU, LENX )
252: TEMP = ABS( AB( KE-I+J, I ) )
253: SYMB_ZERO = SYMB_ZERO .AND.
254: $ ( X( J ) .EQ. ZERO .OR. TEMP .EQ. ZERO )
255:
256: Y( IY ) = Y( IY ) + ALPHA*ABS( X( J ) )*TEMP
257: END DO
258: END IF
259:
260: IF ( .NOT.SYMB_ZERO )
261: $ Y( IY ) = Y( IY ) + SIGN( SAFE1, Y( IY ) )
262: IY = IY + INCY
263: END DO
264: END IF
265: ELSE
266: IF( TRANS.EQ.ILATRANS( 'N' ) )THEN
267: DO I = 1, LENY
268: IF ( BETA .EQ. ZERO ) THEN
269: SYMB_ZERO = .TRUE.
270: Y( IY ) = 0.0D+0
271: ELSE IF ( Y( IY ) .EQ. ZERO ) THEN
272: SYMB_ZERO = .TRUE.
273: ELSE
274: SYMB_ZERO = .FALSE.
275: Y( IY ) = BETA * ABS( Y( IY ) )
276: END IF
277: IF ( ALPHA .NE. ZERO ) THEN
278: JX = KX
279: DO J = MAX( I-KL, 1 ), MIN( I+KU, LENX )
280: TEMP = ABS( AB( KD+I-J, J ) )
281: SYMB_ZERO = SYMB_ZERO .AND.
282: $ ( X( JX ) .EQ. ZERO .OR. TEMP .EQ. ZERO )
283:
284: Y( IY ) = Y( IY ) + ALPHA*ABS( X( JX ) )*TEMP
285: JX = JX + INCX
286: END DO
287: END IF
288:
289: IF ( .NOT.SYMB_ZERO )
290: $ Y( IY ) = Y( IY ) + SIGN( SAFE1, Y( IY ) )
291:
292: IY = IY + INCY
293: END DO
294: ELSE
295: DO I = 1, LENY
296: IF ( BETA .EQ. ZERO ) THEN
297: SYMB_ZERO = .TRUE.
298: Y( IY ) = 0.0D+0
299: ELSE IF ( Y( IY ) .EQ. ZERO ) THEN
300: SYMB_ZERO = .TRUE.
301: ELSE
302: SYMB_ZERO = .FALSE.
303: Y( IY ) = BETA * ABS( Y( IY ) )
304: END IF
305: IF ( ALPHA .NE. ZERO ) THEN
306: JX = KX
307: DO J = MAX( I-KL, 1 ), MIN( I+KU, LENX )
308: TEMP = ABS( AB( KE-I+J, I ) )
309: SYMB_ZERO = SYMB_ZERO .AND.
310: $ ( X( JX ) .EQ. ZERO .OR. TEMP .EQ. ZERO )
311:
312: Y( IY ) = Y( IY ) + ALPHA*ABS( X( JX ) )*TEMP
313: JX = JX + INCX
314: END DO
315: END IF
316:
317: IF ( .NOT.SYMB_ZERO )
318: $ Y( IY ) = Y( IY ) + SIGN( SAFE1, Y( IY ) )
319:
320: IY = IY + INCY
321: END DO
322: END IF
323:
324: END IF
325: *
326: RETURN
327: *
328: * End of DLA_GBAMV
329: *
330: END
CVSweb interface <joel.bertrand@systella.fr>
![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to dla_gbamv.f CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [local] / rpl / lapack / lapack