LAPACK  3.9.0
LAPACK: Linear Algebra PACKage
ddrvrf3.f
Go to the documentation of this file.
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 *> \date June 2017
114 *
115 *> \ingroup double_lin
116 *
117 * =====================================================================
118  SUBROUTINE ddrvrf3( NOUT, NN, NVAL, THRESH, A, LDA, ARF, B1, B2,
119  + D_WORK_DLANGE, D_WORK_DGEQRF, TAU )
120 *
121 * -- LAPACK test routine (version 3.7.1) --
122 * -- LAPACK is a software package provided by Univ. of Tennessee, --
123 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
124 * June 2017
125 *
126 * .. Scalar Arguments ..
127  INTEGER LDA, NN, NOUT
128  DOUBLE PRECISION THRESH
129 * ..
130 * .. Array Arguments ..
131  INTEGER NVAL( NN )
132  DOUBLE PRECISION A( LDA, * ), ARF( * ), B1( LDA, * ),
133  + b2( lda, * ), d_work_dgeqrf( * ),
134  + d_work_dlange( * ), tau( * )
135 * ..
136 *
137 * =====================================================================
138 * ..
139 * .. Parameters ..
140  DOUBLE PRECISION ZERO, ONE
141  parameter( zero = ( 0.0d+0, 0.0d+0 ) ,
142  + one = ( 1.0d+0, 0.0d+0 ) )
143  INTEGER NTESTS
144  parameter( ntests = 1 )
145 * ..
146 * .. Local Scalars ..
147  CHARACTER UPLO, CFORM, DIAG, TRANS, SIDE
148  INTEGER I, IFORM, IIM, IIN, INFO, IUPLO, J, M, N, NA,
149  + nfail, nrun, iside, idiag, ialpha, itrans
150  DOUBLE PRECISION EPS, ALPHA
151 * ..
152 * .. Local Arrays ..
153  CHARACTER UPLOS( 2 ), FORMS( 2 ), TRANSS( 2 ),
154  + diags( 2 ), sides( 2 )
155  INTEGER ISEED( 4 ), ISEEDY( 4 )
156  DOUBLE PRECISION RESULT( NTESTS )
157 * ..
158 * .. External Functions ..
159  DOUBLE PRECISION DLAMCH, DLANGE, DLARND
160  EXTERNAL dlamch, dlange, dlarnd
161 * ..
162 * .. External Subroutines ..
163  EXTERNAL dtrttf, dgeqrf, dgeqlf, dtfsm, dtrsm
164 * ..
165 * .. Intrinsic Functions ..
166  INTRINSIC max, sqrt
167 * ..
168 * .. Scalars in Common ..
169  CHARACTER*32 SRNAMT
170 * ..
171 * .. Common blocks ..
172  COMMON / srnamc / srnamt
173 * ..
174 * .. Data statements ..
175  DATA iseedy / 1988, 1989, 1990, 1991 /
176  DATA uplos / 'U', 'L' /
177  DATA forms / 'N', 'T' /
178  DATA sides / 'L', 'R' /
179  DATA transs / 'N', 'T' /
180  DATA diags / 'N', 'U' /
181 * ..
182 * .. Executable Statements ..
183 *
184 * Initialize constants and the random number seed.
185 *
186  nrun = 0
187  nfail = 0
188  info = 0
189  DO 10 i = 1, 4
190  iseed( i ) = iseedy( i )
191  10 CONTINUE
192  eps = dlamch( 'Precision' )
193 *
194  DO 170 iim = 1, nn
195 *
196  m = nval( iim )
197 *
198  DO 160 iin = 1, nn
199 *
200  n = nval( iin )
201 *
202  DO 150 iform = 1, 2
203 *
204  cform = forms( iform )
205 *
206  DO 140 iuplo = 1, 2
207 *
208  uplo = uplos( iuplo )
209 *
210  DO 130 iside = 1, 2
211 *
212  side = sides( iside )
213 *
214  DO 120 itrans = 1, 2
215 *
216  trans = transs( itrans )
217 *
218  DO 110 idiag = 1, 2
219 *
220  diag = diags( idiag )
221 *
222  DO 100 ialpha = 1, 3
223 *
224  IF ( ialpha.EQ. 1) THEN
225  alpha = zero
226  ELSE IF ( ialpha.EQ. 2) THEN
227  alpha = one
228  ELSE
229  alpha = dlarnd( 2, iseed )
230  END IF
231 *
232 * All the parameters are set:
233 * CFORM, SIDE, UPLO, TRANS, DIAG, M, N,
234 * and ALPHA
235 * READY TO TEST!
236 *
237  nrun = nrun + 1
238 *
239  IF ( iside.EQ.1 ) THEN
240 *
241 * The case ISIDE.EQ.1 is when SIDE.EQ.'L'
242 * -> A is M-by-M ( B is M-by-N )
243 *
244  na = m
245 *
246  ELSE
247 *
248 * The case ISIDE.EQ.2 is when SIDE.EQ.'R'
249 * -> A is N-by-N ( B is M-by-N )
250 *
251  na = n
252 *
253  END IF
254 *
255 * Generate A our NA--by--NA triangular
256 * matrix.
257 * Our test is based on forward error so we
258 * do want A to be well conditionned! To get
259 * a well-conditionned triangular matrix, we
260 * take the R factor of the QR/LQ factorization
261 * of a random matrix.
262 *
263  DO j = 1, na
264  DO i = 1, na
265  a( i, j) = dlarnd( 2, iseed )
266  END DO
267  END DO
268 *
269  IF ( iuplo.EQ.1 ) THEN
270 *
271 * The case IUPLO.EQ.1 is when SIDE.EQ.'U'
272 * -> QR factorization.
273 *
274  srnamt = 'DGEQRF'
275  CALL dgeqrf( na, na, a, lda, tau,
276  + d_work_dgeqrf, lda,
277  + info )
278  ELSE
279 *
280 * The case IUPLO.EQ.2 is when SIDE.EQ.'L'
281 * -> QL factorization.
282 *
283  srnamt = 'DGELQF'
284  CALL dgelqf( na, na, a, lda, tau,
285  + d_work_dgeqrf, lda,
286  + info )
287  END IF
288 *
289 * Store a copy of A in RFP format (in ARF).
290 *
291  srnamt = 'DTRTTF'
292  CALL dtrttf( cform, uplo, na, a, lda, arf,
293  + info )
294 *
295 * Generate B1 our M--by--N right-hand side
296 * and store a copy in B2.
297 *
298  DO j = 1, n
299  DO i = 1, m
300  b1( i, j) = dlarnd( 2, iseed )
301  b2( i, j) = b1( i, j)
302  END DO
303  END DO
304 *
305 * Solve op( A ) X = B or X op( A ) = B
306 * with DTRSM
307 *
308  srnamt = 'DTRSM'
309  CALL dtrsm( side, uplo, trans, diag, m, n,
310  + alpha, a, lda, b1, lda )
311 *
312 * Solve op( A ) X = B or X op( A ) = B
313 * with DTFSM
314 *
315  srnamt = 'DTFSM'
316  CALL dtfsm( cform, side, uplo, trans,
317  + diag, m, n, alpha, arf, b2,
318  + lda )
319 *
320 * Check that the result agrees.
321 *
322  DO j = 1, n
323  DO i = 1, m
324  b1( i, j) = b2( i, j ) - b1( i, j )
325  END DO
326  END DO
327 *
328  result(1) = dlange( 'I', m, n, b1, lda,
329  + d_work_dlange )
330 *
331  result(1) = result(1) / sqrt( eps )
332  + / max( max( m, n), 1 )
333 *
334  IF( result(1).GE.thresh ) THEN
335  IF( nfail.EQ.0 ) THEN
336  WRITE( nout, * )
337  WRITE( nout, fmt = 9999 )
338  END IF
339  WRITE( nout, fmt = 9997 ) 'DTFSM',
340  + cform, side, uplo, trans, diag, m,
341  + n, result(1)
342  nfail = nfail + 1
343  END IF
344 *
345  100 CONTINUE
346  110 CONTINUE
347  120 CONTINUE
348  130 CONTINUE
349  140 CONTINUE
350  150 CONTINUE
351  160 CONTINUE
352  170 CONTINUE
353 *
354 * Print a summary of the results.
355 *
356  IF ( nfail.EQ.0 ) THEN
357  WRITE( nout, fmt = 9996 ) 'DTFSM', nrun
358  ELSE
359  WRITE( nout, fmt = 9995 ) 'DTFSM', nfail, nrun
360  END IF
361 *
362  9999 FORMAT( 1x, ' *** Error(s) or Failure(s) while testing DTFSM
363  + ***')
364  9997 FORMAT( 1x, ' Failure in ',a5,', CFORM=''',a1,''',',
365  + ' SIDE=''',a1,''',',' UPLO=''',a1,''',',' TRANS=''',a1,''',',
366  + ' DIAG=''',a1,''',',' M=',i3,', N =', i3,', test=',g12.5)
367  9996 FORMAT( 1x, 'All tests for ',a5,' auxiliary routine passed the ',
368  + 'threshold ( ',i5,' tests run)')
369  9995 FORMAT( 1x, a6, ' auxiliary routine: ',i5,' out of ',i5,
370  + ' tests failed to pass the threshold')
371 *
372  RETURN
373 *
374 * End of DDRVRF3
375 *
376  END
dtfsm
subroutine dtfsm(TRANSR, SIDE, UPLO, TRANS, DIAG, M, N, ALPHA, A, B, LDB)
DTFSM solves a matrix equation (one operand is a triangular matrix in RFP format).
Definition: dtfsm.f:279
dtrsm
subroutine dtrsm(SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA, B, LDB)
DTRSM
Definition: dtrsm.f:183
dtrttf
subroutine dtrttf(TRANSR, UPLO, N, A, LDA, ARF, INFO)
DTRTTF copies a triangular matrix from the standard full format (TR) to the rectangular full packed f...
Definition: dtrttf.f:196
dgelqf
subroutine dgelqf(M, N, A, LDA, TAU, WORK, LWORK, INFO)
DGELQF
Definition: dgelqf.f:145
dgeqlf
subroutine dgeqlf(M, N, A, LDA, TAU, WORK, LWORK, INFO)
DGEQLF
Definition: dgeqlf.f:140
ddrvrf3
subroutine ddrvrf3(NOUT, NN, NVAL, THRESH, A, LDA, ARF, B1, B2, D_WORK_DLANGE, D_WORK_DGEQRF, TAU)
DDRVRF3
Definition: ddrvrf3.f:120
dgeqrf
subroutine dgeqrf(M, N, A, LDA, TAU, WORK, LWORK, INFO)
DGEQRF
Definition: dgeqrf.f:147