OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
catrmv.f
Go to the documentation of this file.
1 SUBROUTINE catrmv( UPLO, TRANS, DIAG, N, ALPHA, A, LDA, X, INCX,
2 $ BETA, Y, INCY )
3*
4* -- PBLAS auxiliary routine (version 2.0) --
5* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
6* and University of California, Berkeley.
7* April 1, 1998
8*
9* .. Scalar Arguments ..
10 CHARACTER*1 DIAG, TRANS, UPLO
11 INTEGER INCX, INCY, LDA, N
12 REAL ALPHA, BETA
13* ..
14* .. Array Arguments ..
15 REAL Y( * )
16 COMPLEX A( LDA, * ), X( * )
17* ..
18*
19* Purpose
20* =======
21*
22* CATRMV performs one of the matrix-vector operations
23*
24* y := abs( alpha )*abs( A )*abs( x )+ abs( beta*y ),
25*
26* or
27*
28* y := abs( alpha )*abs( A' )*abs( x ) + abs( beta*y ),
29*
30* or
31*
32* y := abs( alpha )*abs( conjg( A' ) )*abs( x ) + abs( beta*y ),
33*
34* where alpha and beta are real scalars, y is a real vector, x is a
35* vector and A is an n by n unit or non-unit, upper or lower triangular
36* matrix.
37*
38* Arguments
39* =========
40*
41* UPLO (input) CHARACTER*1
42* On entry, UPLO specifies whether the matrix is an upper or
43* lower triangular matrix as follows:
44*
45* UPLO = 'U' or 'u' A is an upper triangular matrix.
46*
47* UPLO = 'L' or 'l' A is a lower triangular matrix.
48*
49* TRANS (input) CHARACTER*1
50* On entry, TRANS specifies the operation to be performed as
51* follows:
52*
53* TRANS = 'N' or 'n':
54* y := abs( alpha )*abs( A )*abs( x )+ abs( beta*y )
55*
56* TRANS = 'T' or 't':
57* y := abs( alpha )*abs( A' )*abs( x ) + abs( beta*y )
58*
59* TRANS = 'C' or 'c':
60* y := abs( alpha )*abs( conjg( A' ) )*abs( x ) +
61* abs( beta*y )
62*
63* DIAG (input) CHARACTER*1
64* On entry, DIAG specifies whether or not A is unit triangular
65* as follows:
66*
67* DIAG = 'U' or 'u' A is assumed to be unit triangular.
68*
69* DIAG = 'N' or 'n' A is not assumed to be unit triangular.
70*
71* N (input) INTEGER
72* On entry, N specifies the order of the matrix A. N must be at
73* least zero.
74*
75* ALPHA (input) REAL
76* On entry, ALPHA specifies the real scalar alpha.
77*
78* A (input) COMPLEX array
79* On entry, A is an array of dimension (LDA,N). Before entry
80* with UPLO = 'U' or 'u', the leading n by n part of the array
81* A must contain the upper triangular part of the matrix A and
82* the strictly lower triangular part of A is not referenced.
83* When UPLO = 'L' or 'l', the leading n by n part of the array
84* A must contain the lower triangular part of the matrix A and
85* the strictly upper trapezoidal part of A is not referenced.
86* Note that when DIAG = 'U' or 'u', the diagonal elements of A
87* are not referenced either, but are assumed to be unity.
88*
89* LDA (input) INTEGER
90* On entry, LDA specifies the leading dimension of the array A.
91* LDA must be at least max( 1, N ).
92*
93* X (input) COMPLEX array of dimension at least
94* ( 1 + ( n - 1 )*abs( INCX ) ). Before entry, the incremented
95* array X must contain the vector x.
96*
97* INCX (input) INTEGER
98* On entry, INCX specifies the increment for the elements of X.
99* INCX must not be zero.
100*
101* BETA (input) REAL
102* On entry, BETA specifies the real scalar beta. When BETA is
103* supplied as zero then Y need not be set on input.
104*
105* Y (input/output) REAL array of dimension at least
106* ( 1 + ( n - 1 )*abs( INCY ) ). Before entry with BETA non-
107* zero, the incremented array Y must contain the vector y. On
108* exit, the incremented array Y is overwritten by the updated
109* vector y.
110*
111* INCY (input) INTEGER
112* On entry, INCY specifies the increment for the elements of Y.
113* INCY must not be zero.
114*
115* -- Written on April 1, 1998 by
116* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
117*
118* =====================================================================
119*
120* .. Parameters ..
121 REAL ONE, ZERO
122 parameter( one = 1.0e+0, zero = 0.0e+0 )
123* ..
124* .. Local Scalars ..
125 INTEGER I, INFO, IX, IY, J, JX, JY, KX, KY
126 LOGICAL NOUNIT
127 REAL ABSX, TALPHA, TEMP
128 COMPLEX ZDUM
129* ..
130* .. External Functions ..
131 LOGICAL LSAME
132 EXTERNAL lsame
133* ..
134* .. External Subroutines ..
135 EXTERNAL xerbla
136* ..
137* .. Intrinsic Functions ..
138 INTRINSIC abs, aimag, max, real
139* ..
140* .. Statement Functions ..
141 REAL CABS1
142 cabs1( zdum ) = abs( real( zdum ) ) + abs( aimag( zdum ) )
143* ..
144* .. Executable Statements ..
145*
146* Test the input parameters.
147*
148 info = 0
149 IF ( .NOT.lsame( uplo , 'U' ).AND.
150 $ .NOT.lsame( uplo , 'L' ) )THEN
151 info = 1
152 ELSE IF( .NOT.lsame( trans, 'N' ).AND.
153 $ .NOT.lsame( trans, 'T' ).AND.
154 $ .NOT.lsame( trans, 'C' ) )THEN
155 info = 2
156 ELSE IF( .NOT.lsame( diag , 'u.AND.' )
157.NOT. $ LSAME( DIAG , 'n' ) )THEN
158 INFO = 3
159.LT. ELSE IF( N0 )THEN
160 INFO = 4
161.LT. ELSE IF( LDAMAX( 1, N ) )THEN
162 INFO = 7
163.EQ. ELSE IF( INCX0 )THEN
164 INFO = 9
165.EQ. ELSE IF( INCY0 ) THEN
166 INFO = 12
167 END IF
168.NE. IF( INFO0 )THEN
169 CALL XERBLA( 'catrmv', INFO )
170 RETURN
171 END IF
172*
173* Quick return if possible.
174*
175.EQ..OR. IF( ( N0 )
176.EQ..AND..EQ. $ ( ( ALPHAZERO )( BETAONE ) ) )
177 $ RETURN
178*
179 NOUNIT = LSAME( DIAG , 'n' )
180*
181* Set up the start points in X and Y.
182*
183.GT. IF( INCX0 ) THEN
184 KX = 1
185 ELSE
186 KX = 1 - ( N - 1 ) * INCX
187 END IF
188.GT. IF( INCY0 ) THEN
189 KY = 1
190 ELSE
191 KY = 1 - ( N - 1 ) * INCY
192 END IF
193*
194* Start the operations. In this version the elements of A are
195* accessed sequentially with one pass through A.
196*
197* First form y := abs( beta*y ).
198*
199.EQ. IF( INCY1 ) THEN
200.EQ. IF( BETAZERO ) THEN
201 DO 10, I = 1, N
202 Y( I ) = ZERO
203 10 CONTINUE
204.EQ. ELSE IF( BETAONE ) THEN
205 DO 20, I = 1, N
206 Y( I ) = ABS( Y( I ) )
207 20 CONTINUE
208 ELSE
209 DO 30, I = 1, N
210 Y( I ) = ABS( BETA * Y( I ) )
211 30 CONTINUE
212 END IF
213 ELSE
214 IY = KY
215.EQ. IF( BETAZERO ) THEN
216 DO 40, I = 1, N
217 Y( IY ) = ZERO
218 IY = IY + INCY
219 40 CONTINUE
220.EQ. ELSE IF( BETAONE ) THEN
221 DO 50, I = 1, N
222 Y( IY ) = ABS( Y( IY ) )
223 IY = IY + INCY
224 50 CONTINUE
225 ELSE
226 DO 60, I = 1, N
227 Y( IY ) = ABS( BETA * Y( IY ) )
228 IY = IY + INCY
229 60 CONTINUE
230 END IF
231 END IF
232*
233.EQ. IF( ALPHAZERO )
234 $ RETURN
235*
236 TALPHA = ABS( ALPHA )
237*
238 IF( LSAME( TRANS, 'n' ) )THEN
239*
240* Form y := abs( alpha ) * abs( A ) * abs( x ) + y.
241*
242 IF( LSAME( UPLO, 'u' ) )THEN
243 JX = KX
244.EQ. IF( INCY1 ) THEN
245 DO 80, J = 1, N
246 ABSX = CABS1( X( JX ) )
247.NE. IF( ABSXZERO ) THEN
248 TEMP = TALPHA * ABSX
249 DO 70, I = 1, J - 1
250 Y( I ) = Y( I ) + TEMP * CABS1( A( I, J ) )
251 70 CONTINUE
252*
253 IF( NOUNIT ) THEN
254 Y( J ) = Y( J ) + TEMP * CABS1( A( J, J ) )
255 ELSE
256 Y( J ) = Y( J ) + TEMP
257 END IF
258 END IF
259 JX = JX + INCX
260 80 CONTINUE
261*
262 ELSE
263*
264 DO 100, J = 1, N
265 ABSX = CABS1( X( JX ) )
266.NE. IF( ABSXZERO ) THEN
267 TEMP = TALPHA * ABSX
268 IY = KY
269 DO 90, I = 1, J - 1
270 Y( IY ) = Y( IY ) + TEMP * CABS1( A( I, J ) )
271 IY = IY + INCY
272 90 CONTINUE
273*
274 IF( NOUNIT ) THEN
275 Y( IY ) = Y( IY ) + TEMP * CABS1( A( J, J ) )
276 ELSE
277 Y( IY ) = Y( IY ) + TEMP
278 END IF
279 END IF
280 JX = JX + INCX
281 100 CONTINUE
282*
283 END IF
284*
285 ELSE
286*
287 JX = KX
288.EQ. IF( INCY1 ) THEN
289 DO 120, J = 1, N
290 ABSX = CABS1( X( JX ) )
291.NE. IF( ABSXZERO ) THEN
292*
293 TEMP = TALPHA * ABSX
294*
295 IF( NOUNIT ) THEN
296 Y( J ) = Y( J ) + TEMP * CABS1( A( J, J ) )
297 ELSE
298 Y( J ) = Y( J ) + TEMP
299 END IF
300*
301 DO 110, I = J + 1, N
302 Y( I ) = Y( I ) + TEMP * CABS1( A( I, J ) )
303 110 CONTINUE
304 END IF
305 JX = JX + INCX
306 120 CONTINUE
307*
308 ELSE
309*
310 DO 140, J = 1, N
311 ABSX = CABS1( X( JX ) )
312.NE. IF( ABSXZERO ) THEN
313 TEMP = TALPHA * ABSX
314 IY = KY + ( J - 1 ) * INCY
315*
316 IF( NOUNIT ) THEN
317 Y( IY ) = Y( IY ) + TEMP * CABS1( A( J, J ) )
318 ELSE
319 Y( IY ) = Y( IY ) + TEMP
320 END IF
321*
322 DO 130, I = J + 1, N
323 IY = IY + INCY
324 Y( IY ) = Y( IY ) + TEMP * CABS1( A( I, J ) )
325 130 CONTINUE
326 END IF
327 JX = JX + INCX
328 140 CONTINUE
329*
330 END IF
331*
332 END IF
333*
334 ELSE
335*
336* Form y := abs( alpha ) * abs( A' ) * abs( x ) + y.
337*
338 IF( LSAME( UPLO, 'u' ) )THEN
339 JY = KY
340.EQ. IF( INCX1 ) THEN
341 DO 160, J = 1, N
342*
343 TEMP = ZERO
344*
345 DO 150, I = 1, J - 1
346 TEMP = TEMP + CABS1( A( I, J ) ) * CABS1( X( I ) )
347 150 CONTINUE
348*
349 IF( NOUNIT ) THEN
350 TEMP = TEMP + CABS1( A( J, J ) ) * CABS1( X( J ) )
351 ELSE
352 TEMP = TEMP + CABS1( X( J ) )
353 END IF
354*
355 Y( JY ) = Y( JY ) + TALPHA * TEMP
356 JY = JY + INCY
357*
358 160 CONTINUE
359*
360 ELSE
361*
362 DO 180, J = 1, N
363 TEMP = ZERO
364 IX = KX
365 DO 170, I = 1, J - 1
366 TEMP = TEMP + CABS1( A( I, J ) ) * CABS1( X( IX ) )
367 IX = IX + INCX
368 170 CONTINUE
369*
370 IF( NOUNIT ) THEN
371 TEMP = TEMP + CABS1( A( J, J ) ) * CABS1( X( IX ) )
372 ELSE
373 TEMP = TEMP + CABS1( X( IX ) )
374 END IF
375*
376 Y( JY ) = Y( JY ) + TALPHA * TEMP
377 JY = JY + INCY
378*
379 180 CONTINUE
380*
381 END IF
382*
383 ELSE
384*
385 JY = KY
386.EQ. IF( INCX1 ) THEN
387*
388 DO 200, J = 1, N
389*
390 IF( NOUNIT ) THEN
391 TEMP = CABS1( A( J, J ) ) * CABS1( X( J ) )
392 ELSE
393 TEMP = CABS1( X( J ) )
394 END IF
395*
396 DO 190, I = J + 1, N
397 TEMP = TEMP + CABS1( A( I, J ) ) * CABS1( X( I ) )
398 190 CONTINUE
399*
400 Y( JY ) = Y( JY ) + TALPHA * TEMP
401 JY = JY + INCY
402*
403 200 CONTINUE
404*
405 ELSE
406*
407 DO 220, J = 1, N
408*
409 IX = KX + ( J - 1 ) * INCX
410*
411 IF( NOUNIT ) THEN
412 TEMP = CABS1( A( J, J ) ) * CABS1( X( IX ) )
413 ELSE
414 TEMP = CABS1( X( IX ) )
415 END IF
416*
417 DO 210, I = J + 1, N
418 IX = IX + INCX
419 TEMP = TEMP + CABS1( A( I, J ) ) * CABS1( X( IX ) )
420 210 CONTINUE
421 Y( JY ) = Y( JY ) + TALPHA * TEMP
422 JY = JY + INCY
423 220 CONTINUE
424 END IF
425 END IF
426*
427 END IF
428*
429 RETURN
430*
431* End of CATRMV
432*
433 END
catrmv
subroutine catrmv(uplo, trans, diag, n, alpha, a, lda, x, incx, beta, y, incy)
Definition catrmv.f:3
xerbla
subroutine xerbla(srname, info)
XERBLA
Definition xerbla.f:60
max
#define max(a, b)
Definition macros.h:21