1*> \brief \b DLARHS
2*
3*  =========== DOCUMENTATION ===========
4*
5* Online html documentation available at
6*            http://www.netlib.org/lapack/explore-html/
7*
8*  Definition:
9*  ===========
10*
11*       SUBROUTINE DLARHS( PATH, XTYPE, UPLO, TRANS, M, N, KL, KU, NRHS,
12*                          A, LDA, X, LDX, B, LDB, ISEED, INFO )
13*
14*       .. Scalar Arguments ..
15*       CHARACTER          TRANS, UPLO, XTYPE
16*       CHARACTER*3        PATH
17*       INTEGER            INFO, KL, KU, LDA, LDB, LDX, M, N, NRHS
18*       ..
19*       .. Array Arguments ..
20*       INTEGER            ISEED( 4 )
21*       DOUBLE PRECISION   A( LDA, * ), B( LDB, * ), X( LDX, * )
22*       ..
23*
24*
25*> \par Purpose:
26*  =============
27*>
28*> \verbatim
29*>
30*> DLARHS chooses a set of NRHS random solution vectors and sets
31*> up the right hand sides for the linear system
32*>    op( A ) * X = B,
33*> where op( A ) may be A or A' (transpose of A).
34*> \endverbatim
35*
36*  Arguments:
37*  ==========
38*
39*> \param[in] PATH
40*> \verbatim
41*>          PATH is CHARACTER*3
42*>          The type of the real matrix A.  PATH may be given in any
43*>          combination of upper and lower case.  Valid types include
44*>             xGE:  General m x n matrix
45*>             xGB:  General banded matrix
46*>             xPO:  Symmetric positive definite, 2-D storage
47*>             xPP:  Symmetric positive definite packed
48*>             xPB:  Symmetric positive definite banded
49*>             xSY:  Symmetric indefinite, 2-D storage
50*>             xSP:  Symmetric indefinite packed
51*>             xSB:  Symmetric indefinite banded
52*>             xTR:  Triangular
53*>             xTP:  Triangular packed
54*>             xTB:  Triangular banded
55*>             xQR:  General m x n matrix
56*>             xLQ:  General m x n matrix
57*>             xQL:  General m x n matrix
58*>             xRQ:  General m x n matrix
59*>          where the leading character indicates the precision.
60*> \endverbatim
61*>
62*> \param[in] XTYPE
63*> \verbatim
64*>          XTYPE is CHARACTER*1
65*>          Specifies how the exact solution X will be determined:
66*>          = 'N':  New solution; generate a random X.
67*>          = 'C':  Computed; use value of X on entry.
68*> \endverbatim
69*>
70*> \param[in] UPLO
71*> \verbatim
72*>          UPLO is CHARACTER*1
73*>          Specifies whether the upper or lower triangular part of the
74*>          matrix A is stored, if A is symmetric.
75*>          = 'U':  Upper triangular
76*>          = 'L':  Lower triangular
77*> \endverbatim
78*>
79*> \param[in] TRANS
80*> \verbatim
81*>          TRANS is CHARACTER*1
82*>          Specifies the operation applied to the matrix A.
83*>          = 'N':  System is  A * x = b
84*>          = 'T':  System is  A'* x = b
85*>          = 'C':  System is  A'* x = b
86*> \endverbatim
87*>
88*> \param[in] M
89*> \verbatim
90*>          M is INTEGER
91*>          The number or rows of the matrix A.  M >= 0.
92*> \endverbatim
93*>
94*> \param[in] N
95*> \verbatim
96*>          N is INTEGER
97*>          The number of columns of the matrix A.  N >= 0.
98*> \endverbatim
99*>
100*> \param[in] KL
101*> \verbatim
102*>          KL is INTEGER
103*>          Used only if A is a band matrix; specifies the number of
104*>          subdiagonals of A if A is a general band matrix or if A is
105*>          symmetric or triangular and UPLO = 'L'; specifies the number
106*>          of superdiagonals of A if A is symmetric or triangular and
107*>          UPLO = 'U'.  0 <= KL <= M-1.
108*> \endverbatim
109*>
110*> \param[in] KU
111*> \verbatim
112*>          KU is INTEGER
113*>          Used only if A is a general band matrix or if A is
114*>          triangular.
115*>
116*>          If PATH = xGB, specifies the number of superdiagonals of A,
117*>          and 0 <= KU <= N-1.
118*>
119*>          If PATH = xTR, xTP, or xTB, specifies whether or not the
120*>          matrix has unit diagonal:
121*>          = 1:  matrix has non-unit diagonal (default)
122*>          = 2:  matrix has unit diagonal
123*> \endverbatim
124*>
125*> \param[in] NRHS
126*> \verbatim
127*>          NRHS is INTEGER
128*>          The number of right hand side vectors in the system A*X = B.
129*> \endverbatim
130*>
131*> \param[in] A
132*> \verbatim
133*>          A is DOUBLE PRECISION array, dimension (LDA,N)
134*>          The test matrix whose type is given by PATH.
135*> \endverbatim
136*>
137*> \param[in] LDA
138*> \verbatim
139*>          LDA is INTEGER
140*>          The leading dimension of the array A.
141*>          If PATH = xGB, LDA >= KL+KU+1.
142*>          If PATH = xPB, xSB, xHB, or xTB, LDA >= KL+1.
143*>          Otherwise, LDA >= max(1,M).
144*> \endverbatim
145*>
146*> \param[in,out] X
147*> \verbatim
148*>          X is or output) DOUBLE PRECISION array, dimension(LDX,NRHS)
149*>          On entry, if XTYPE = 'C' (for 'Computed'), then X contains
150*>          the exact solution to the system of linear equations.
151*>          On exit, if XTYPE = 'N' (for 'New'), then X is initialized
152*>          with random values.
153*> \endverbatim
154*>
155*> \param[in] LDX
156*> \verbatim
157*>          LDX is INTEGER
158*>          The leading dimension of the array X.  If TRANS = 'N',
159*>          LDX >= max(1,N); if TRANS = 'T', LDX >= max(1,M).
160*> \endverbatim
161*>
162*> \param[out] B
163*> \verbatim
164*>          B is DOUBLE PRECISION array, dimension (LDB,NRHS)
165*>          The right hand side vector(s) for the system of equations,
166*>          computed from B = op(A) * X, where op(A) is determined by
167*>          TRANS.
168*> \endverbatim
169*>
170*> \param[in] LDB
171*> \verbatim
172*>          LDB is INTEGER
173*>          The leading dimension of the array B.  If TRANS = 'N',
174*>          LDB >= max(1,M); if TRANS = 'T', LDB >= max(1,N).
175*> \endverbatim
176*>
177*> \param[in,out] ISEED
178*> \verbatim
179*>          ISEED is INTEGER array, dimension (4)
180*>          The seed vector for the random number generator (used in
181*>          DLATMS).  Modified on exit.
182*> \endverbatim
183*>
184*> \param[out] INFO
185*> \verbatim
186*>          INFO is INTEGER
187*>          = 0: successful exit
188*>          < 0: if INFO = -i, the i-th argument had an illegal value
189*> \endverbatim
190*
191*  Authors:
192*  ========
193*
194*> \author Univ. of Tennessee
195*> \author Univ. of California Berkeley
196*> \author Univ. of Colorado Denver
197*> \author NAG Ltd.
198*
199*> \date December 2016
200*
201*> \ingroup double_lin
202*
203*  =====================================================================
204      SUBROUTINE DLARHS( PATH, XTYPE, UPLO, TRANS, M, N, KL, KU, NRHS,
205     $                   A, LDA, X, LDX, B, LDB, ISEED, INFO )
206*
207*  -- LAPACK test routine (version 3.7.0) --
208*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
209*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
210*     December 2016
211*
212*     .. Scalar Arguments ..
213      CHARACTER          TRANS, UPLO, XTYPE
214      CHARACTER*3        PATH
215      INTEGER            INFO, KL, KU, LDA, LDB, LDX, M, N, NRHS
216*     ..
217*     .. Array Arguments ..
218      INTEGER            ISEED( 4 )
219      DOUBLE PRECISION   A( LDA, * ), B( LDB, * ), X( LDX, * )
220*     ..
221*
222*  =====================================================================
223*
224*     .. Parameters ..
225      DOUBLE PRECISION   ONE, ZERO
226      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
227*     ..
228*     .. Local Scalars ..
229      LOGICAL            BAND, GEN, NOTRAN, QRS, SYM, TRAN, TRI
230      CHARACTER          C1, DIAG
231      CHARACTER*2        C2
232      INTEGER            J, MB, NX
233*     ..
234*     .. External Functions ..
235      LOGICAL            LSAME, LSAMEN
236      EXTERNAL           LSAME, LSAMEN
237*     ..
238*     .. External Subroutines ..
239      EXTERNAL           DGBMV, DGEMM, DLACPY, DLARNV, DSBMV, DSPMV,
240     $                   DSYMM, DTBMV, DTPMV, DTRMM, XERBLA
241*     ..
242*     .. Intrinsic Functions ..
243      INTRINSIC          MAX
244*     ..
245*     .. Executable Statements ..
246*
247*     Test the input parameters.
248*
249      INFO = 0
250      C1 = PATH( 1: 1 )
251      C2 = PATH( 2: 3 )
252      TRAN = LSAME( TRANS, 'T' ) .OR. LSAME( TRANS, 'C' )
253      NOTRAN = .NOT.TRAN
254      GEN = LSAME( PATH( 2: 2 ), 'G' )
255      QRS = LSAME( PATH( 2: 2 ), 'Q' ) .OR. LSAME( PATH( 3: 3 ), 'Q' )
256      SYM = LSAME( PATH( 2: 2 ), 'P' ) .OR. LSAME( PATH( 2: 2 ), 'S' )
257      TRI = LSAME( PATH( 2: 2 ), 'T' )
258      BAND = LSAME( PATH( 3: 3 ), 'B' )
259      IF( .NOT.LSAME( C1, 'Double precision' ) ) THEN
260         INFO = -1
261      ELSE IF( .NOT.( LSAME( XTYPE, 'N' ) .OR. LSAME( XTYPE, 'C' ) ) )
262     $          THEN
263         INFO = -2
264      ELSE IF( ( SYM .OR. TRI ) .AND. .NOT.
265     $         ( LSAME( UPLO, 'U' ) .OR. LSAME( UPLO, 'L' ) ) ) THEN
266         INFO = -3
267      ELSE IF( ( GEN .OR. QRS ) .AND. .NOT.
268     $         ( TRAN .OR. LSAME( TRANS, 'N' ) ) ) THEN
269         INFO = -4
270      ELSE IF( M.LT.0 ) THEN
271         INFO = -5
272      ELSE IF( N.LT.0 ) THEN
273         INFO = -6
274      ELSE IF( BAND .AND. KL.LT.0 ) THEN
275         INFO = -7
276      ELSE IF( BAND .AND. KU.LT.0 ) THEN
277         INFO = -8
278      ELSE IF( NRHS.LT.0 ) THEN
279         INFO = -9
280      ELSE IF( ( .NOT.BAND .AND. LDA.LT.MAX( 1, M ) ) .OR.
281     $         ( BAND .AND. ( SYM .OR. TRI ) .AND. LDA.LT.KL+1 ) .OR.
282     $         ( BAND .AND. GEN .AND. LDA.LT.KL+KU+1 ) ) THEN
283         INFO = -11
284      ELSE IF( ( NOTRAN .AND. LDX.LT.MAX( 1, N ) ) .OR.
285     $         ( TRAN .AND. LDX.LT.MAX( 1, M ) ) ) THEN
286         INFO = -13
287      ELSE IF( ( NOTRAN .AND. LDB.LT.MAX( 1, M ) ) .OR.
288     $         ( TRAN .AND. LDB.LT.MAX( 1, N ) ) ) THEN
289         INFO = -15
290      END IF
291      IF( INFO.NE.0 ) THEN
292         CALL XERBLA( 'DLARHS', -INFO )
293         RETURN
294      END IF
295*
296*     Initialize X to NRHS random vectors unless XTYPE = 'C'.
297*
298      IF( TRAN ) THEN
299         NX = M
300         MB = N
301      ELSE
302         NX = N
303         MB = M
304      END IF
305      IF( .NOT.LSAME( XTYPE, 'C' ) ) THEN
306         DO 10 J = 1, NRHS
307            CALL DLARNV( 2, ISEED, N, X( 1, J ) )
308   10    CONTINUE
309      END IF
310*
311*     Multiply X by op( A ) using an appropriate
312*     matrix multiply routine.
313*
314      IF( LSAMEN( 2, C2, 'GE' ) .OR. LSAMEN( 2, C2, 'QR' ) .OR.
315     $    LSAMEN( 2, C2, 'LQ' ) .OR. LSAMEN( 2, C2, 'QL' ) .OR.
316     $    LSAMEN( 2, C2, 'RQ' ) ) THEN
317*
318*        General matrix
319*
320         CALL DGEMM( TRANS, 'N', MB, NRHS, NX, ONE, A, LDA, X, LDX,
321     $               ZERO, B, LDB )
322*
323      ELSE IF( LSAMEN( 2, C2, 'PO' ) .OR. LSAMEN( 2, C2, 'SY' ) ) THEN
324*
325*        Symmetric matrix, 2-D storage
326*
327         CALL DSYMM( 'Left', UPLO, N, NRHS, ONE, A, LDA, X, LDX, ZERO,
328     $               B, LDB )
329*
330      ELSE IF( LSAMEN( 2, C2, 'GB' ) ) THEN
331*
332*        General matrix, band storage
333*
334         DO 20 J = 1, NRHS
335            CALL DGBMV( TRANS, MB, NX, KL, KU, ONE, A, LDA, X( 1, J ),
336     $                  1, ZERO, B( 1, J ), 1 )
337   20    CONTINUE
338*
339      ELSE IF( LSAMEN( 2, C2, 'PB' ) ) THEN
340*
341*        Symmetric matrix, band storage
342*
343         DO 30 J = 1, NRHS
344            CALL DSBMV( UPLO, N, KL, ONE, A, LDA, X( 1, J ), 1, ZERO,
345     $                  B( 1, J ), 1 )
346   30    CONTINUE
347*
348      ELSE IF( LSAMEN( 2, C2, 'PP' ) .OR. LSAMEN( 2, C2, 'SP' ) ) THEN
349*
350*        Symmetric matrix, packed storage
351*
352         DO 40 J = 1, NRHS
353            CALL DSPMV( UPLO, N, ONE, A, X( 1, J ), 1, ZERO, B( 1, J ),
354     $                  1 )
355   40    CONTINUE
356*
357      ELSE IF( LSAMEN( 2, C2, 'TR' ) ) THEN
358*
359*        Triangular matrix.  Note that for triangular matrices,
360*           KU = 1 => non-unit triangular
361*           KU = 2 => unit triangular
362*
363         CALL DLACPY( 'Full', N, NRHS, X, LDX, B, LDB )
364         IF( KU.EQ.2 ) THEN
365            DIAG = 'U'
366         ELSE
367            DIAG = 'N'
368         END IF
369         CALL DTRMM( 'Left', UPLO, TRANS, DIAG, N, NRHS, ONE, A, LDA, B,
370     $               LDB )
371*
372      ELSE IF( LSAMEN( 2, C2, 'TP' ) ) THEN
373*
374*        Triangular matrix, packed storage
375*
376         CALL DLACPY( 'Full', N, NRHS, X, LDX, B, LDB )
377         IF( KU.EQ.2 ) THEN
378            DIAG = 'U'
379         ELSE
380            DIAG = 'N'
381         END IF
382         DO 50 J = 1, NRHS
383            CALL DTPMV( UPLO, TRANS, DIAG, N, A, B( 1, J ), 1 )
384   50    CONTINUE
385*
386      ELSE IF( LSAMEN( 2, C2, 'TB' ) ) THEN
387*
388*        Triangular matrix, banded storage
389*
390         CALL DLACPY( 'Full', N, NRHS, X, LDX, B, LDB )
391         IF( KU.EQ.2 ) THEN
392            DIAG = 'U'
393         ELSE
394            DIAG = 'N'
395         END IF
396         DO 60 J = 1, NRHS
397            CALL DTBMV( UPLO, TRANS, DIAG, N, KL, A, LDA, B( 1, J ), 1 )
398   60    CONTINUE
399*
400      ELSE
401*
402*        If PATH is none of the above, return with an error code.
403*
404         INFO = -1
405         CALL XERBLA( 'DLARHS', -INFO )
406      END IF
407*
408      RETURN
409*
410*     End of DLARHS
411*
412      END
413