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)
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.
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
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 *
dtrsm
subroutine dtrsm(SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA, B, LDB)
DTRSM
Definition: dtrsm.f:183
dlamch
double precision function dlamch(CMACH)
DLAMCH
Definition: dlamch.f:65
dgeqlf
subroutine dgeqlf(M, N, A, LDA, TAU, WORK, LWORK, INFO)
DGEQLF
Definition: dgeqlf.f:140
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
dgelqf
subroutine dgelqf(M, N, A, LDA, TAU, WORK, LWORK, INFO)
DGELQF
Definition: dgelqf.f:137
dlange
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
dlarnd
double precision function dlarnd(IDIST, ISEED)
DLARND
Definition: dlarnd.f:75
dgeqrf
subroutine dgeqrf(M, N, A, LDA, TAU, WORK, LWORK, INFO)
DGEQRF
Definition: dgeqrf.f:138
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

Here is the call graph for this function:

Here is the caller graph for this function: