LAPACK 3.12.0
LAPACK: Linear Algebra PACKage
Loading...
Searching...
No Matches
ddrvrf1.f
Go to the documentation of this file.
1*> \brief \b DDRVRF1
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 DDRVRF1( NOUT, NN, NVAL, THRESH, A, LDA, ARF, WORK )
12*
13* .. Scalar Arguments ..
14* INTEGER LDA, NN, NOUT
15* DOUBLE PRECISION THRESH
16* ..
17* .. Array Arguments ..
18* INTEGER NVAL( NN )
19* DOUBLE PRECISION A( LDA, * ), ARF( * ), WORK( * )
20* ..
21*
22*
23*> \par Purpose:
24* =============
25*>
26*> \verbatim
27*>
28*> DDRVRF1 tests the LAPACK RFP routines:
29*> DLANSF
30*> \endverbatim
31*
32* Arguments:
33* ==========
34*
35*> \param[in] NOUT
36*> \verbatim
37*> NOUT is INTEGER
38*> The unit number for output.
39*> \endverbatim
40*>
41*> \param[in] NN
42*> \verbatim
43*> NN is INTEGER
44*> The number of values of N contained in the vector NVAL.
45*> \endverbatim
46*>
47*> \param[in] NVAL
48*> \verbatim
49*> NVAL is INTEGER array, dimension (NN)
50*> The values of the matrix dimension N.
51*> \endverbatim
52*>
53*> \param[in] THRESH
54*> \verbatim
55*> THRESH is DOUBLE PRECISION
56*> The threshold value for the test ratios. A result is
57*> included in the output file if RESULT >= THRESH. To have
58*> every test ratio printed, use THRESH = 0.
59*> \endverbatim
60*>
61*> \param[out] A
62*> \verbatim
63*> A is DOUBLE PRECISION array, dimension (LDA,NMAX)
64*> \endverbatim
65*>
66*> \param[in] LDA
67*> \verbatim
68*> LDA is INTEGER
69*> The leading dimension of the array A. LDA >= max(1,NMAX).
70*> \endverbatim
71*>
72*> \param[out] ARF
73*> \verbatim
74*> ARF is DOUBLE PRECISION array, dimension ((NMAX*(NMAX+1))/2).
75*> \endverbatim
76*>
77*> \param[out] WORK
78*> \verbatim
79*> WORK is DOUBLE PRECISION array, dimension ( NMAX )
80*> \endverbatim
81*
82* Authors:
83* ========
84*
85*> \author Univ. of Tennessee
86*> \author Univ. of California Berkeley
87*> \author Univ. of Colorado Denver
88*> \author NAG Ltd.
89*
90*> \ingroup double_lin
91*
92* =====================================================================
93 SUBROUTINE ddrvrf1( NOUT, NN, NVAL, THRESH, A, LDA, ARF, WORK )
94*
95* -- LAPACK test routine --
96* -- LAPACK is a software package provided by Univ. of Tennessee, --
97* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
98*
99* .. Scalar Arguments ..
100 INTEGER LDA, NN, NOUT
101 DOUBLE PRECISION THRESH
102* ..
103* .. Array Arguments ..
104 INTEGER NVAL( NN )
105 DOUBLE PRECISION A( LDA, * ), ARF( * ), WORK( * )
106* ..
107*
108* =====================================================================
109* ..
110* .. Parameters ..
111 DOUBLE PRECISION ONE
112 parameter( one = 1.0d+0 )
113 INTEGER NTESTS
114 parameter( ntests = 1 )
115* ..
116* .. Local Scalars ..
117 CHARACTER UPLO, CFORM, NORM
118 INTEGER I, IFORM, IIN, IIT, INFO, INORM, IUPLO, J, N,
119 + NERRS, NFAIL, NRUN
120 DOUBLE PRECISION EPS, LARGE, NORMA, NORMARF, SMALL
121* ..
122* .. Local Arrays ..
123 CHARACTER UPLOS( 2 ), FORMS( 2 ), NORMS( 4 )
124 INTEGER ISEED( 4 ), ISEEDY( 4 )
125 DOUBLE PRECISION RESULT( NTESTS )
126* ..
127* .. External Functions ..
128 DOUBLE PRECISION DLAMCH, DLANSY, DLANSF, DLARND
129 EXTERNAL dlamch, dlansy, dlansf, dlarnd
130* ..
131* .. External Subroutines ..
132 EXTERNAL dtrttf
133* ..
134* .. Scalars in Common ..
135 CHARACTER*32 SRNAMT
136* ..
137* .. Common blocks ..
138 COMMON / srnamc / srnamt
139* ..
140* .. Data statements ..
141 DATA iseedy / 1988, 1989, 1990, 1991 /
142 DATA uplos / 'U', 'L' /
143 DATA forms / 'N', 'T' /
144 DATA norms / 'M', '1', 'I', 'F' /
145* ..
146* .. Executable Statements ..
147*
148* Initialize constants and the random number seed.
149*
150 nrun = 0
151 nfail = 0
152 nerrs = 0
153 info = 0
154 DO 10 i = 1, 4
155 iseed( i ) = iseedy( i )
156 10 CONTINUE
157*
158 eps = dlamch( 'Precision' )
159 small = dlamch( 'Safe minimum' )
160 large = one / small
161 small = small * lda * lda
162 large = large / lda / lda
163*
164 DO 130 iin = 1, nn
165*
166 n = nval( iin )
167*
168 DO 120 iit = 1, 3
169* Nothing to do for N=0
170 IF ( n .EQ. 0 ) EXIT
171*
172* IIT = 1 : random matrix
173* IIT = 2 : random matrix scaled near underflow
174* IIT = 3 : random matrix scaled near overflow
175*
176 DO j = 1, n
177 DO i = 1, n
178 a( i, j) = dlarnd( 2, iseed )
179 END DO
180 END DO
181*
182 IF ( iit.EQ.2 ) THEN
183 DO j = 1, n
184 DO i = 1, n
185 a( i, j) = a( i, j ) * large
186 END DO
187 END DO
188 END IF
189*
190 IF ( iit.EQ.3 ) THEN
191 DO j = 1, n
192 DO i = 1, n
193 a( i, j) = a( i, j) * small
194 END DO
195 END DO
196 END IF
197*
198* Do first for UPLO = 'U', then for UPLO = 'L'
199*
200 DO 110 iuplo = 1, 2
201*
202 uplo = uplos( iuplo )
203*
204* Do first for CFORM = 'N', then for CFORM = 'C'
205*
206 DO 100 iform = 1, 2
207*
208 cform = forms( iform )
209*
210 srnamt = 'DTRTTF'
211 CALL dtrttf( cform, uplo, n, a, lda, arf, info )
212*
213* Check error code from DTRTTF
214*
215 IF( info.NE.0 ) THEN
216 IF( nfail.EQ.0 .AND. nerrs.EQ.0 ) THEN
217 WRITE( nout, * )
218 WRITE( nout, fmt = 9999 )
219 END IF
220 WRITE( nout, fmt = 9998 ) srnamt, uplo, cform, n
221 nerrs = nerrs + 1
222 GO TO 100
223 END IF
224*
225 DO 90 inorm = 1, 4
226*
227* Check all four norms: 'M', '1', 'I', 'F'
228*
229 norm = norms( inorm )
230 normarf = dlansf( norm, cform, uplo, n, arf, work )
231 norma = dlansy( norm, uplo, n, a, lda, work )
232*
233 result(1) = ( norma - normarf ) / norma / eps
234 nrun = nrun + 1
235*
236 IF( result(1).GE.thresh ) THEN
237 IF( nfail.EQ.0 .AND. nerrs.EQ.0 ) THEN
238 WRITE( nout, * )
239 WRITE( nout, fmt = 9999 )
240 END IF
241 WRITE( nout, fmt = 9997 ) 'DLANSF',
242 + n, iit, uplo, cform, norm, result(1)
243 nfail = nfail + 1
244 END IF
245 90 CONTINUE
246 100 CONTINUE
247 110 CONTINUE
248 120 CONTINUE
249 130 CONTINUE
250*
251* Print a summary of the results.
252*
253 IF ( nfail.EQ.0 ) THEN
254 WRITE( nout, fmt = 9996 ) 'DLANSF', nrun
255 ELSE
256 WRITE( nout, fmt = 9995 ) 'DLANSF', nfail, nrun
257 END IF
258 IF ( nerrs.NE.0 ) THEN
259 WRITE( nout, fmt = 9994 ) nerrs, 'DLANSF'
260 END IF
261*
262 9999 FORMAT( 1x, ' *** Error(s) or Failure(s) while testing DLANSF
263 + ***')
264 9998 FORMAT( 1x, ' Error in ',a6,' with UPLO=''',a1,''', FORM=''',
265 + a1,''', N=',i5)
266 9997 FORMAT( 1x, ' Failure in ',a6,' N=',i5,' TYPE=',i5,' UPLO=''',
267 + a1, ''', FORM =''',a1,''', NORM=''',a1,''', test=',g12.5)
268 9996 FORMAT( 1x, 'All tests for ',a6,' auxiliary routine passed the ',
269 + 'threshold ( ',i5,' tests run)')
270 9995 FORMAT( 1x, a6, ' auxiliary routine: ',i5,' out of ',i5,
271 + ' tests failed to pass the threshold')
272 9994 FORMAT( 26x, i5,' error message recorded (',a6,')')
273*
274 RETURN
275*
276* End of DDRVRF1
277*
278 END
subroutine ddrvrf1(nout, nn, nval, thresh, a, lda, arf, work)
DDRVRF1
Definition ddrvrf1.f:94
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