LAPACK  3.10.1
LAPACK: Linear Algebra PACKage
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