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