LAPACK  3.6.1 LAPACK: Linear Algebra PACKage
 subroutine ddrvrf3 ( integer NOUT, integer NN, integer, dimension( nn ) NVAL, double precision THRESH, double precision, dimension( lda, * ) A, integer LDA, double precision, dimension( * ) ARF, double precision, dimension( lda, * ) B1, double precision, dimension( lda, * ) B2, double precision, dimension( * ) D_WORK_DLANGE, double precision, dimension( * ) D_WORK_DGEQRF, double precision, dimension( * ) TAU )

DDRVRF3

Purpose:
``` DDRVRF3 tests the LAPACK RFP routines:
DTFSM```
Parameters
 [in] NOUT ``` NOUT is INTEGER The unit number for output.``` [in] NN ``` NN is INTEGER The number of values of N contained in the vector NVAL.``` [in] NVAL ``` NVAL is INTEGER array, dimension (NN) The values of the matrix dimension N.``` [in] THRESH ``` THRESH is DOUBLE PRECISION The threshold value for the test ratios. A result is included in the output file if RESULT >= THRESH. To have every test ratio printed, use THRESH = 0.``` [out] A ` A is DOUBLE PRECISION array, dimension (LDA,NMAX)` [in] LDA ``` LDA is INTEGER The leading dimension of the array A. LDA >= max(1,NMAX).``` [out] ARF ` ARF is DOUBLE PRECISION array, dimension ((NMAX*(NMAX+1))/2).` [out] B1 ` B1 is DOUBLE PRECISION array, dimension (LDA,NMAX)` [out] B2 ` B2 is DOUBLE PRECISION array, dimension (LDA,NMAX)` [out] D_WORK_DLANGE ` D_WORK_DLANGE is DOUBLE PRECISION array, dimension (NMAX)` [out] D_WORK_DGEQRF ` D_WORK_DGEQRF is DOUBLE PRECISION array, dimension (NMAX)` [out] TAU ` TAU is DOUBLE PRECISION array, dimension (NMAX)`
Date
November 2011

Definition at line 120 of file ddrvrf3.f.

120 *
121 * -- LAPACK test routine (version 3.4.0) --
122 * -- LAPACK is a software package provided by Univ. of Tennessee, --
123 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
124 * November 2011
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. 1) 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
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 *
subroutine dtrsm(SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA, B, LDB)
DTRSM
Definition: dtrsm.f:183
double precision function dlamch(CMACH)
DLAMCH
Definition: dlamch.f:65
subroutine dgeqlf(M, N, A, LDA, TAU, WORK, LWORK, INFO)
DGEQLF
Definition: dgeqlf.f:140
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
subroutine dgelqf(M, N, A, LDA, TAU, WORK, LWORK, INFO)
DGELQF
Definition: dgelqf.f:137
double precision function dlange(NORM, M, N, A, LDA, WORK)
DLANGE returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute value ...
Definition: dlange.f:116
double precision function dlarnd(IDIST, ISEED)
DLARND
Definition: dlarnd.f:75
subroutine dgeqrf(M, N, A, LDA, TAU, WORK, LWORK, INFO)
DGEQRF
Definition: dgeqrf.f:138
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

Here is the call graph for this function:

Here is the caller graph for this function: