SCALAPACK 2.2.2
LAPACK: Linear Algebra PACKage
Loading...
Searching...
No Matches

◆ catrmv()

subroutine catrmv ( character*1  uplo,
character*1  trans,
character*1  diag,
integer  n,
real  alpha,
complex, dimension( lda, * )  a,
integer  lda,
complex, dimension( * )  x,
integer  incx,
real  beta,
real, dimension( * )  y,
integer  incy 
)

Definition at line 1 of file catrmv.f.

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 ELSE IF( n.LT.0 )THEN
160 info = 4
161 ELSE IF( lda.LT.max( 1, n ) )THEN
162 info = 7
163 ELSE IF( incx.EQ.0 )THEN
164 info = 9
165 ELSE IF( incy.EQ.0 ) THEN
166 info = 12
167 END IF
168 IF( info.NE.0 )THEN
169 CALL xerbla( 'CATRMV', info )
170 RETURN
171 END IF
172*
173* Quick return if possible.
174*
175 IF( ( n.EQ.0 ).OR.
176 $ ( ( alpha.EQ.zero ).AND.( beta.EQ.one ) ) )
177 $ RETURN
178*
179 nounit = lsame( diag , 'N' )
180*
181* Set up the start points in X and Y.
182*
183 IF( incx.GT.0 ) THEN
184 kx = 1
185 ELSE
186 kx = 1 - ( n - 1 ) * incx
187 END IF
188 IF( incy.GT.0 ) 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 IF( incy.EQ.1 ) THEN
200 IF( beta.EQ.zero ) THEN
201 DO 10, i = 1, n
202 y( i ) = zero
203 10 CONTINUE
204 ELSE IF( beta.EQ.one ) 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 IF( beta.EQ.zero ) THEN
216 DO 40, i = 1, n
217 y( iy ) = zero
218 iy = iy + incy
219 40 CONTINUE
220 ELSE IF( beta.EQ.one ) 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 IF( alpha.EQ.zero )
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 IF( incy.EQ.1 ) THEN
245 DO 80, j = 1, n
246 absx = cabs1( x( jx ) )
247 IF( absx.NE.zero ) 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 IF( absx.NE.zero ) 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 IF( incy.EQ.1 ) THEN
289 DO 120, j = 1, n
290 absx = cabs1( x( jx ) )
291 IF( absx.NE.zero ) 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 IF( absx.NE.zero ) 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 IF( incx.EQ.1 ) 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 IF( incx.EQ.1 ) 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*
max
#define max(A, B)
Definition pcgemr.c:180
lsame
logical function lsame(ca, cb)
Definition tools.f:1724