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