PLASMA  2.4.5
PLASMA - Parallel Linear Algebra for Scalable Multi-core Architectures
 All Data Structures Namespaces Files Functions Variables Typedefs Enumerations Enumerator Macros Groups
slarhs.f
Go to the documentation of this file.
1  SUBROUTINE slarhs( PATH, XTYPE, UPLO, TRANS, M, N, KL, KU, NRHS,
2  $ a, lda, x, ldx, b, ldb, iseed, info )
3 *
4 * -- LAPACK test routine (version 3.1) --
5 * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
6 * November 2006
7 *
8 * .. Scalar Arguments ..
9  CHARACTER trans, uplo, xtype
10  CHARACTER*3 path
11  INTEGER info, kl, ku, lda, ldb, ldx, m, n, nrhs
12 * ..
13 * .. Array Arguments ..
14  INTEGER iseed( 4 )
15  REAL a( lda, * ), b( ldb, * ), x( ldx, * )
16 * ..
17 *
18 * Purpose
19 * =======
20 *
21 * SLARHS chooses a set of NRHS random solution vectors and sets
22 * up the right hand sides for the linear system
23 * op( A ) * X = B,
24 * where op( A ) may be A or A' (transpose of A).
25 *
26 * Arguments
27 * =========
28 *
29 * PATH (input) CHARACTER*3
30 * The type of the real matrix A. PATH may be given in any
31 * combination of upper and lower case. Valid types include
32 * xGE: General m x n matrix
33 * xGB: General banded matrix
34 * xPO: Symmetric positive definite, 2-D storage
35 * xPP: Symmetric positive definite packed
36 * xPB: Symmetric positive definite banded
37 * xSY: Symmetric indefinite, 2-D storage
38 * xSP: Symmetric indefinite packed
39 * xSB: Symmetric indefinite banded
40 * xTR: Triangular
41 * xTP: Triangular packed
42 * xTB: Triangular banded
43 * xQR: General m x n matrix
44 * xLQ: General m x n matrix
45 * xQL: General m x n matrix
46 * xRQ: General m x n matrix
47 * where the leading character indicates the precision.
48 *
49 * XTYPE (input) CHARACTER*1
50 * Specifies how the exact solution X will be determined:
51 * = 'N': New solution; generate a random X.
52 * = 'C': Computed; use value of X on entry.
53 *
54 * UPLO (input) CHARACTER*1
55 * Specifies whether the upper or lower triangular part of the
56 * matrix A is stored, if A is symmetric.
57 * = 'U': Upper triangular
58 * = 'L': Lower triangular
59 *
60 * TRANS (input) CHARACTER*1
61 * Specifies the operation applied to the matrix A.
62 * = 'N': System is A * x = b
63 * = 'T': System is A'* x = b
64 * = 'C': System is A'* x = b
65 *
66 * M (input) INTEGER
67 * The number or rows of the matrix A. M >= 0.
68 *
69 * N (input) INTEGER
70 * The number of columns of the matrix A. N >= 0.
71 *
72 * KL (input) INTEGER
73 * Used only if A is a band matrix; specifies the number of
74 * subdiagonals of A if A is a general band matrix or if A is
75 * symmetric or triangular and UPLO = 'L'; specifies the number
76 * of superdiagonals of A if A is symmetric or triangular and
77 * UPLO = 'U'. 0 <= KL <= M-1.
78 *
79 * KU (input) INTEGER
80 * Used only if A is a general band matrix or if A is
81 * triangular.
82 *
83 * If PATH = xGB, specifies the number of superdiagonals of A,
84 * and 0 <= KU <= N-1.
85 *
86 * If PATH = xTR, xTP, or xTB, specifies whether or not the
87 * matrix has unit diagonal:
88 * = 1: matrix has non-unit diagonal (default)
89 * = 2: matrix has unit diagonal
90 *
91 * NRHS (input) INTEGER
92 * The number of right hand side vectors in the system A*X = B.
93 *
94 * A (input) REAL array, dimension (LDA,N)
95 * The test matrix whose type is given by PATH.
96 *
97 * LDA (input) INTEGER
98 * The leading dimension of the array A.
99 * If PATH = xGB, LDA >= KL+KU+1.
100 * If PATH = xPB, xSB, xHB, or xTB, LDA >= KL+1.
101 * Otherwise, LDA >= max(1,M).
102 *
103 * X (input or output) REAL array, dimension(LDX,NRHS)
104 * On entry, if XTYPE = 'C' (for 'Computed'), then X contains
105 * the exact solution to the system of linear equations.
106 * On exit, if XTYPE = 'N' (for 'New'), then X is initialized
107 * with random values.
108 *
109 * LDX (input) INTEGER
110 * The leading dimension of the array X. If TRANS = 'N',
111 * LDX >= max(1,N); if TRANS = 'T', LDX >= max(1,M).
112 *
113 * B (output) REAL array, dimension (LDB,NRHS)
114 * The right hand side vector(s) for the system of equations,
115 * computed from B = op(A) * X, where op(A) is determined by
116 * TRANS.
117 *
118 * LDB (input) INTEGER
119 * The leading dimension of the array B. If TRANS = 'N',
120 * LDB >= max(1,M); if TRANS = 'T', LDB >= max(1,N).
121 *
122 * ISEED (input/output) INTEGER array, dimension (4)
123 * The seed vector for the random number generator (used in
124 * SLATMS). Modified on exit.
125 *
126 * INFO (output) INTEGER
127 * = 0: successful exit
128 * < 0: if INFO = -i, the i-th argument had an illegal value
129 *
130 * =====================================================================
131 *
132 * .. Parameters ..
133  REAL one, zero
134  parameter( one = 1.0e+0, zero = 0.0e+0 )
135 * ..
136 * .. Local Scalars ..
137  LOGICAL band, gen, notran, qrs, sym, tran, tri
138  CHARACTER c1, diag
139  CHARACTER*2 c2
140  INTEGER j, mb, nx
141 * ..
142 * .. External Functions ..
143  LOGICAL lsame, lsamen
144  EXTERNAL lsame, lsamen
145 * ..
146 * .. External Subroutines ..
147  EXTERNAL sgbmv, sgemm, slacpy, slarnv, ssbmv, sspmv,
148  $ ssymm, stbmv, stpmv, strmm, xerbla
149 * ..
150 * .. Intrinsic Functions ..
151  INTRINSIC max
152 * ..
153 * .. Executable Statements ..
154 *
155 * Test the input parameters.
156 *
157  info = 0
158  c1 = path( 1: 1 )
159  c2 = path( 2: 3 )
160  tran = lsame( trans, 'T' ) .OR. lsame( trans, 'C' )
161  notran = .NOT.tran
162  gen = lsame( path( 2: 2 ), 'G' )
163  qrs = lsame( path( 2: 2 ), 'Q' ) .OR. lsame( path( 3: 3 ), 'Q' )
164  sym = lsame( path( 2: 2 ), 'P' ) .OR. lsame( path( 2: 2 ), 'S' )
165  tri = lsame( path( 2: 2 ), 'T' )
166  band = lsame( path( 3: 3 ), 'B' )
167  IF( .NOT.lsame( c1, 'Single precision' ) ) THEN
168  info = -1
169  ELSE IF( .NOT.( lsame( xtype, 'N' ) .OR. lsame( xtype, 'C' ) ) )
170  $ THEN
171  info = -2
172  ELSE IF( ( sym .OR. tri ) .AND. .NOT.
173  $ ( lsame( uplo, 'U' ) .OR. lsame( uplo, 'L' ) ) ) THEN
174  info = -3
175  ELSE IF( ( gen .OR. qrs ) .AND. .NOT.
176  $ ( tran .OR. lsame( trans, 'N' ) ) ) THEN
177  info = -4
178  ELSE IF( m.LT.0 ) THEN
179  info = -5
180  ELSE IF( n.LT.0 ) THEN
181  info = -6
182  ELSE IF( band .AND. kl.LT.0 ) THEN
183  info = -7
184  ELSE IF( band .AND. ku.LT.0 ) THEN
185  info = -8
186  ELSE IF( nrhs.LT.0 ) THEN
187  info = -9
188  ELSE IF( ( .NOT.band .AND. lda.LT.max( 1, m ) ) .OR.
189  $ ( band .AND. ( sym .OR. tri ) .AND. lda.LT.kl+1 ) .OR.
190  $ ( band .AND. gen .AND. lda.LT.kl+ku+1 ) ) THEN
191  info = -11
192  ELSE IF( ( notran .AND. ldx.LT.max( 1, n ) ) .OR.
193  $ ( tran .AND. ldx.LT.max( 1, m ) ) ) THEN
194  info = -13
195  ELSE IF( ( notran .AND. ldb.LT.max( 1, m ) ) .OR.
196  $ ( tran .AND. ldb.LT.max( 1, n ) ) ) THEN
197  info = -15
198  END IF
199  IF( info.NE.0 ) THEN
200  CALL xerbla( 'SLARHS', -info )
201  return
202  END IF
203 *
204 * Initialize X to NRHS random vectors unless XTYPE = 'C'.
205 *
206  IF( tran ) THEN
207  nx = m
208  mb = n
209  ELSE
210  nx = n
211  mb = m
212  END IF
213  IF( .NOT.lsame( xtype, 'C' ) ) THEN
214  DO 10 j = 1, nrhs
215  CALL slarnv( 2, iseed, n, x( 1, j ) )
216  10 continue
217  END IF
218 *
219 * Multiply X by op( A ) using an appropriate
220 * matrix multiply routine.
221 *
222  IF( lsamen( 2, c2, 'GE' ) .OR. lsamen( 2, c2, 'QR' ) .OR.
223  $ lsamen( 2, c2, 'LQ' ) .OR. lsamen( 2, c2, 'QL' ) .OR.
224  $ lsamen( 2, c2, 'RQ' ) ) THEN
225 *
226 * General matrix
227 *
228  CALL sgemm( trans, 'N', mb, nrhs, nx, one, a, lda, x, ldx,
229  $ zero, b, ldb )
230 *
231  ELSE IF( lsamen( 2, c2, 'PO' ) .OR. lsamen( 2, c2, 'SY' ) ) THEN
232 *
233 * Symmetric matrix, 2-D storage
234 *
235  CALL ssymm( 'Left', uplo, n, nrhs, one, a, lda, x, ldx, zero,
236  $ b, ldb )
237 *
238  ELSE IF( lsamen( 2, c2, 'GB' ) ) THEN
239 *
240 * General matrix, band storage
241 *
242  DO 20 j = 1, nrhs
243  CALL sgbmv( trans, mb, nx, kl, ku, one, a, lda, x( 1, j ),
244  $ 1, zero, b( 1, j ), 1 )
245  20 continue
246 *
247  ELSE IF( lsamen( 2, c2, 'PB' ) ) THEN
248 *
249 * Symmetric matrix, band storage
250 *
251  DO 30 j = 1, nrhs
252  CALL ssbmv( uplo, n, kl, one, a, lda, x( 1, j ), 1, zero,
253  $ b( 1, j ), 1 )
254  30 continue
255 *
256  ELSE IF( lsamen( 2, c2, 'PP' ) .OR. lsamen( 2, c2, 'SP' ) ) THEN
257 *
258 * Symmetric matrix, packed storage
259 *
260  DO 40 j = 1, nrhs
261  CALL sspmv( uplo, n, one, a, x( 1, j ), 1, zero, b( 1, j ),
262  $ 1 )
263  40 continue
264 *
265  ELSE IF( lsamen( 2, c2, 'TR' ) ) THEN
266 *
267 * Triangular matrix. Note that for triangular matrices,
268 * KU = 1 => non-unit triangular
269 * KU = 2 => unit triangular
270 *
271  CALL slacpy( 'Full', n, nrhs, x, ldx, b, ldb )
272  IF( ku.EQ.2 ) THEN
273  diag = 'U'
274  ELSE
275  diag = 'N'
276  END IF
277  CALL strmm( 'Left', uplo, trans, diag, n, nrhs, one, a, lda, b,
278  $ ldb )
279 *
280  ELSE IF( lsamen( 2, c2, 'TP' ) ) THEN
281 *
282 * Triangular matrix, packed storage
283 *
284  CALL slacpy( 'Full', n, nrhs, x, ldx, b, ldb )
285  IF( ku.EQ.2 ) THEN
286  diag = 'U'
287  ELSE
288  diag = 'N'
289  END IF
290  DO 50 j = 1, nrhs
291  CALL stpmv( uplo, trans, diag, n, a, b( 1, j ), 1 )
292  50 continue
293 *
294  ELSE IF( lsamen( 2, c2, 'TB' ) ) THEN
295 *
296 * Triangular matrix, banded storage
297 *
298  CALL slacpy( 'Full', n, nrhs, x, ldx, b, ldb )
299  IF( ku.EQ.2 ) THEN
300  diag = 'U'
301  ELSE
302  diag = 'N'
303  END IF
304  DO 60 j = 1, nrhs
305  CALL stbmv( uplo, trans, diag, n, kl, a, lda, b( 1, j ), 1 )
306  60 continue
307 *
308  ELSE
309 *
310 * If PATH is none of the above, return with an error code.
311 *
312  info = -1
313  CALL xerbla( 'SLARHS', -info )
314  END IF
315 *
316  return
317 *
318 * End of SLARHS
319 *
320  END