LAPACK  3.10.1
LAPACK: Linear Algebra PACKage

◆ ddrvrf3()

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.

Definition at line 116 of file ddrvrf3.f.

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 *
double precision function dlamch(CMACH)
DLAMCH
Definition: dlamch.f:69
subroutine dtrsm(SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA, B, LDB)
DTRSM
Definition: dtrsm.f:181
double precision function dlarnd(IDIST, ISEED)
DLARND
Definition: dlarnd.f:73
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:114
subroutine dgeqlf(M, N, A, LDA, TAU, WORK, LWORK, INFO)
DGEQLF
Definition: dgeqlf.f:138
subroutine dgeqrf(M, N, A, LDA, TAU, WORK, LWORK, INFO)
DGEQRF
Definition: dgeqrf.f:146
subroutine dgelqf(M, N, A, LDA, TAU, WORK, LWORK, INFO)
DGELQF
Definition: dgelqf.f:143
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:194
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:277
Here is the call graph for this function:
Here is the caller graph for this function: