1*> \brief \b DDRVRF3
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 DDRVRF3( NOUT, NN, NVAL, THRESH, A, LDA, ARF, B1, B2,
12*      +                    D_WORK_DLANGE, D_WORK_DGEQRF, TAU )
13*
14*       .. Scalar Arguments ..
15*       INTEGER            LDA, NN, NOUT
16*       DOUBLE PRECISION   THRESH
17*       ..
18*       .. Array Arguments ..
19*       INTEGER            NVAL( NN )
20*       DOUBLE PRECISION   A( LDA, * ), ARF( * ), B1( LDA, * ),
21*      +                   B2( LDA, * ), D_WORK_DGEQRF( * ),
22*      +                   D_WORK_DLANGE( * ), TAU( * )
23*       ..
24*
25*
26*> \par Purpose:
27*  =============
28*>
29*> \verbatim
30*>
31*> DDRVRF3 tests the LAPACK RFP routines:
32*>     DTFSM
33*> \endverbatim
34*
35*  Arguments:
36*  ==========
37*
38*> \param[in] NOUT
39*> \verbatim
40*>          NOUT is INTEGER
41*>                The unit number for output.
42*> \endverbatim
43*>
44*> \param[in] NN
45*> \verbatim
46*>          NN is INTEGER
47*>                The number of values of N contained in the vector NVAL.
48*> \endverbatim
49*>
50*> \param[in] NVAL
51*> \verbatim
52*>          NVAL is INTEGER array, dimension (NN)
53*>                The values of the matrix dimension N.
54*> \endverbatim
55*>
56*> \param[in] THRESH
57*> \verbatim
58*>          THRESH is DOUBLE PRECISION
59*>                The threshold value for the test ratios.  A result is
60*>                included in the output file if RESULT >= THRESH.  To have
61*>                every test ratio printed, use THRESH = 0.
62*> \endverbatim
63*>
64*> \param[out] A
65*> \verbatim
66*>          A is DOUBLE PRECISION array, dimension (LDA,NMAX)
67*> \endverbatim
68*>
69*> \param[in] LDA
70*> \verbatim
71*>          LDA is INTEGER
72*>                The leading dimension of the array A.  LDA >= max(1,NMAX).
73*> \endverbatim
74*>
75*> \param[out] ARF
76*> \verbatim
77*>          ARF is DOUBLE PRECISION array, dimension ((NMAX*(NMAX+1))/2).
78*> \endverbatim
79*>
80*> \param[out] B1
81*> \verbatim
82*>          B1 is DOUBLE PRECISION array, dimension (LDA,NMAX)
83*> \endverbatim
84*>
85*> \param[out] B2
86*> \verbatim
87*>          B2 is DOUBLE PRECISION array, dimension (LDA,NMAX)
88*> \endverbatim
89*>
90*> \param[out] D_WORK_DLANGE
91*> \verbatim
92*>          D_WORK_DLANGE is DOUBLE PRECISION array, dimension (NMAX)
93*> \endverbatim
94*>
95*> \param[out] D_WORK_DGEQRF
96*> \verbatim
97*>          D_WORK_DGEQRF is DOUBLE PRECISION array, dimension (NMAX)
98*> \endverbatim
99*>
100*> \param[out] TAU
101*> \verbatim
102*>          TAU is DOUBLE PRECISION array, dimension (NMAX)
103*> \endverbatim
104*
105*  Authors:
106*  ========
107*
108*> \author Univ. of Tennessee
109*> \author Univ. of California Berkeley
110*> \author Univ. of Colorado Denver
111*> \author NAG Ltd.
112*
113*> \ingroup double_lin
114*
115*  =====================================================================
116      SUBROUTINE DDRVRF3( NOUT, NN, NVAL, THRESH, A, LDA, ARF, B1, B2,
117     +                    D_WORK_DLANGE, D_WORK_DGEQRF, TAU )
118*
119*  -- LAPACK test routine --
120*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
121*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
122*
123*     .. Scalar Arguments ..
124      INTEGER            LDA, NN, NOUT
125      DOUBLE PRECISION   THRESH
126*     ..
127*     .. Array Arguments ..
128      INTEGER            NVAL( NN )
129      DOUBLE PRECISION   A( LDA, * ), ARF( * ), B1( LDA, * ),
130     +                   B2( LDA, * ), D_WORK_DGEQRF( * ),
131     +                   D_WORK_DLANGE( * ), TAU( * )
132*     ..
133*
134*  =====================================================================
135*     ..
136*     .. Parameters ..
137      DOUBLE PRECISION   ZERO, ONE
138      PARAMETER          ( ZERO = ( 0.0D+0, 0.0D+0 ) ,
139     +                     ONE  = ( 1.0D+0, 0.0D+0 ) )
140      INTEGER            NTESTS
141      PARAMETER          ( NTESTS = 1 )
142*     ..
143*     .. Local Scalars ..
144      CHARACTER          UPLO, CFORM, DIAG, TRANS, SIDE
145      INTEGER            I, IFORM, IIM, IIN, INFO, IUPLO, J, M, N, NA,
146     +                   NFAIL, NRUN, ISIDE, IDIAG, IALPHA, ITRANS
147      DOUBLE PRECISION   EPS, ALPHA
148*     ..
149*     .. Local Arrays ..
150      CHARACTER          UPLOS( 2 ), FORMS( 2 ), TRANSS( 2 ),
151     +                   DIAGS( 2 ), SIDES( 2 )
152      INTEGER            ISEED( 4 ), ISEEDY( 4 )
153      DOUBLE PRECISION   RESULT( NTESTS )
154*     ..
155*     .. External Functions ..
156      DOUBLE PRECISION   DLAMCH, DLANGE, DLARND
157      EXTERNAL           DLAMCH, DLANGE, DLARND
158*     ..
159*     .. External Subroutines ..
160      EXTERNAL           DTRTTF, DGEQRF, DGEQLF, DTFSM, DTRSM
161*     ..
162*     .. Intrinsic Functions ..
163      INTRINSIC          MAX, SQRT
164*     ..
165*     .. Scalars in Common ..
166      CHARACTER*32       SRNAMT
167*     ..
168*     .. Common blocks ..
169      COMMON             / SRNAMC / SRNAMT
170*     ..
171*     .. Data statements ..
172      DATA               ISEEDY / 1988, 1989, 1990, 1991 /
173      DATA               UPLOS  / 'U', 'L' /
174      DATA               FORMS  / 'N', 'T' /
175      DATA               SIDES  / 'L', 'R' /
176      DATA               TRANSS / 'N', 'T' /
177      DATA               DIAGS  / 'N', 'U' /
178*     ..
179*     .. Executable Statements ..
180*
181*     Initialize constants and the random number seed.
182*
183      NRUN = 0
184      NFAIL = 0
185      INFO = 0
186      DO 10 I = 1, 4
187         ISEED( I ) = ISEEDY( I )
188   10 CONTINUE
189      EPS = DLAMCH( 'Precision' )
190*
191      DO 170 IIM = 1, NN
192*
193         M = NVAL( IIM )
194*
195         DO 160 IIN = 1, NN
196*
197            N = NVAL( IIN )
198*
199            DO 150 IFORM = 1, 2
200*
201               CFORM = FORMS( IFORM )
202*
203               DO 140 IUPLO = 1, 2
204*
205                  UPLO = UPLOS( IUPLO )
206*
207                  DO 130 ISIDE = 1, 2
208*
209                     SIDE = SIDES( ISIDE )
210*
211                     DO 120 ITRANS = 1, 2
212*
213                        TRANS = TRANSS( ITRANS )
214*
215                        DO 110 IDIAG = 1, 2
216*
217                           DIAG = DIAGS( IDIAG )
218*
219                           DO 100 IALPHA = 1, 3
220*
221                              IF ( IALPHA.EQ. 1) THEN
222                                 ALPHA = ZERO
223                              ELSE IF ( IALPHA.EQ. 2) THEN
224                                 ALPHA = ONE
225                              ELSE
226                                 ALPHA = DLARND( 2, ISEED )
227                              END IF
228*
229*                             All the parameters are set:
230*                                CFORM, SIDE, UPLO, TRANS, DIAG, M, N,
231*                                and ALPHA
232*                             READY TO TEST!
233*
234                              NRUN = NRUN + 1
235*
236                              IF ( ISIDE.EQ.1 ) THEN
237*
238*                                The case ISIDE.EQ.1 is when SIDE.EQ.'L'
239*                                -> A is M-by-M ( B is M-by-N )
240*
241                                 NA = M
242*
243                              ELSE
244*
245*                                The case ISIDE.EQ.2 is when SIDE.EQ.'R'
246*                                -> A is N-by-N ( B is M-by-N )
247*
248                                 NA = N
249*
250                              END IF
251*
252*                             Generate A our NA--by--NA triangular
253*                             matrix.
254*                             Our test is based on forward error so we
255*                             do want A to be well conditioned! To get
256*                             a well-conditioned triangular matrix, we
257*                             take the R factor of the QR/LQ factorization
258*                             of a random matrix.
259*
260                              DO J = 1, NA
261                                 DO I = 1, NA
262                                    A( I, J) = DLARND( 2, ISEED )
263                                 END DO
264                              END DO
265*
266                              IF ( IUPLO.EQ.1 ) THEN
267*
268*                                The case IUPLO.EQ.1 is when SIDE.EQ.'U'
269*                                -> QR factorization.
270*
271                                 SRNAMT = 'DGEQRF'
272                                 CALL DGEQRF( NA, NA, A, LDA, TAU,
273     +                                        D_WORK_DGEQRF, LDA,
274     +                                        INFO )
275                              ELSE
276*
277*                                The case IUPLO.EQ.2 is when SIDE.EQ.'L'
278*                                -> QL factorization.
279*
280                                 SRNAMT = 'DGELQF'
281                                 CALL DGELQF( NA, NA, A, LDA, TAU,
282     +                                        D_WORK_DGEQRF, LDA,
283     +                                        INFO )
284                              END IF
285*
286*                             Store a copy of A in RFP format (in ARF).
287*
288                              SRNAMT = 'DTRTTF'
289                              CALL DTRTTF( CFORM, UPLO, NA, A, LDA, ARF,
290     +                                     INFO )
291*
292*                             Generate B1 our M--by--N right-hand side
293*                             and store a copy in B2.
294*
295                              DO J = 1, N
296                                 DO I = 1, M
297                                    B1( I, J) = DLARND( 2, ISEED )
298                                    B2( I, J) = B1( I, J)
299                                 END DO
300                              END DO
301*
302*                             Solve op( A ) X = B or X op( A ) = B
303*                             with DTRSM
304*
305                              SRNAMT = 'DTRSM'
306                              CALL DTRSM( SIDE, UPLO, TRANS, DIAG, M, N,
307     +                               ALPHA, A, LDA, B1, LDA )
308*
309*                             Solve op( A ) X = B or X op( A ) = B
310*                             with DTFSM
311*
312                              SRNAMT = 'DTFSM'
313                              CALL DTFSM( CFORM, SIDE, UPLO, TRANS,
314     +                                    DIAG, M, N, ALPHA, ARF, B2,
315     +                                    LDA )
316*
317*                             Check that the result agrees.
318*
319                              DO J = 1, N
320                                 DO I = 1, M
321                                    B1( I, J) = B2( I, J ) - B1( I, J )
322                                 END DO
323                              END DO
324*
325                              RESULT(1) = DLANGE( 'I', M, N, B1, LDA,
326     +                                            D_WORK_DLANGE )
327*
328                              RESULT(1) = RESULT(1) / SQRT( EPS )
329     +                                    / MAX ( MAX( M, N), 1 )
330*
331                              IF( RESULT(1).GE.THRESH ) THEN
332                                 IF( NFAIL.EQ.0 ) THEN
333                                    WRITE( NOUT, * )
334                                    WRITE( NOUT, FMT = 9999 )
335                                 END IF
336                                 WRITE( NOUT, FMT = 9997 ) 'DTFSM',
337     +                              CFORM, SIDE, UPLO, TRANS, DIAG, M,
338     +                              N, RESULT(1)
339                                 NFAIL = NFAIL + 1
340                              END IF
341*
342  100                      CONTINUE
343  110                   CONTINUE
344  120                CONTINUE
345  130             CONTINUE
346  140          CONTINUE
347  150       CONTINUE
348  160    CONTINUE
349  170 CONTINUE
350*
351*     Print a summary of the results.
352*
353      IF ( NFAIL.EQ.0 ) THEN
354         WRITE( NOUT, FMT = 9996 ) 'DTFSM', NRUN
355      ELSE
356         WRITE( NOUT, FMT = 9995 ) 'DTFSM', NFAIL, NRUN
357      END IF
358*
359 9999 FORMAT( 1X, ' *** Error(s) or Failure(s) while testing DTFSM
360     +         ***')
361 9997 FORMAT( 1X, '     Failure in ',A5,', CFORM=''',A1,''',',
362     + ' SIDE=''',A1,''',',' UPLO=''',A1,''',',' TRANS=''',A1,''',',
363     + ' DIAG=''',A1,''',',' M=',I3,', N =', I3,', test=',G12.5)
364 9996 FORMAT( 1X, 'All tests for ',A5,' auxiliary routine passed the ',
365     +        'threshold ( ',I5,' tests run)')
366 9995 FORMAT( 1X, A6, ' auxiliary routine: ',I5,' out of ',I5,
367     +        ' tests failed to pass the threshold')
368*
369      RETURN
370*
371*     End of DDRVRF3
372*
373      END
374