LAPACK 3.11.0
LAPACK: Linear Algebra PACKage
Loading...
Searching...
No Matches

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