1*> \brief \b SDRVRF1
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 SDRVRF1( NOUT, NN, NVAL, THRESH, A, LDA, ARF, WORK )
12*
13*       .. Scalar Arguments ..
14*       INTEGER            LDA, NN, NOUT
15*       REAL               THRESH
16*       ..
17*       .. Array Arguments ..
18*       INTEGER            NVAL( NN )
19*       REAL               A( LDA, * ), ARF( * ), WORK( * )
20*       ..
21*
22*
23*> \par Purpose:
24*  =============
25*>
26*> \verbatim
27*>
28*> SDRVRF1 tests the LAPACK RFP routines:
29*>     SLANSF
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 REAL
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 REAL 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 REAL array, dimension ((NMAX*(NMAX+1))/2).
75*> \endverbatim
76*>
77*> \param[out] WORK
78*> \verbatim
79*>          WORK is REAL 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*> \date December 2016
91*
92*> \ingroup single_lin
93*
94*  =====================================================================
95      SUBROUTINE SDRVRF1( NOUT, NN, NVAL, THRESH, A, LDA, ARF, WORK )
96*
97*  -- LAPACK test routine (version 3.7.0) --
98*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
99*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
100*     December 2016
101*
102*     .. Scalar Arguments ..
103      INTEGER            LDA, NN, NOUT
104      REAL               THRESH
105*     ..
106*     .. Array Arguments ..
107      INTEGER            NVAL( NN )
108      REAL               A( LDA, * ), ARF( * ), WORK( * )
109*     ..
110*
111*  =====================================================================
112*     ..
113*     .. Parameters ..
114      REAL               ONE
115      PARAMETER          ( ONE = 1.0E+0 )
116      INTEGER            NTESTS
117      PARAMETER          ( NTESTS = 1 )
118*     ..
119*     .. Local Scalars ..
120      CHARACTER          UPLO, CFORM, NORM
121      INTEGER            I, IFORM, IIN, IIT, INFO, INORM, IUPLO, J, N,
122     +                   NERRS, NFAIL, NRUN
123      REAL               EPS, LARGE, NORMA, NORMARF, SMALL
124*     ..
125*     .. Local Arrays ..
126      CHARACTER          UPLOS( 2 ), FORMS( 2 ), NORMS( 4 )
127      INTEGER            ISEED( 4 ), ISEEDY( 4 )
128      REAL               RESULT( NTESTS )
129*     ..
130*     .. External Functions ..
131      REAL               SLAMCH, SLANSY, SLANSF, SLARND
132      EXTERNAL           SLAMCH, SLANSY, SLANSF, SLARND
133*     ..
134*     .. External Subroutines ..
135      EXTERNAL           STRTTF
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', 'T' /
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 = SLAMCH( 'Precision' )
162      SMALL = SLAMCH( '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*           Quick Return if possible
176            IF ( N .EQ. 0 ) EXIT
177*
178*           IIT = 1 : random matrix
179*           IIT = 2 : random matrix scaled near underflow
180*           IIT = 3 : random matrix scaled near overflow
181*
182            DO J = 1, N
183               DO I = 1, N
184                  A( I, J) = SLARND( 2, ISEED )
185               END DO
186            END DO
187*
188            IF ( IIT.EQ.2 ) THEN
189               DO J = 1, N
190                  DO I = 1, N
191                     A( I, J) = A( I, J ) * LARGE
192                  END DO
193               END DO
194            END IF
195*
196            IF ( IIT.EQ.3 ) THEN
197               DO J = 1, N
198                  DO I = 1, N
199                     A( I, J) = A( I, J) * SMALL
200                  END DO
201               END DO
202            END IF
203*
204*           Do first for UPLO = 'U', then for UPLO = 'L'
205*
206            DO 110 IUPLO = 1, 2
207*
208               UPLO = UPLOS( IUPLO )
209*
210*              Do first for CFORM = 'N', then for CFORM = 'C'
211*
212               DO 100 IFORM = 1, 2
213*
214                  CFORM = FORMS( IFORM )
215*
216                  SRNAMT = 'STRTTF'
217                  CALL STRTTF( CFORM, UPLO, N, A, LDA, ARF, INFO )
218*
219*                 Check error code from STRTTF
220*
221                  IF( INFO.NE.0 ) THEN
222                     IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) THEN
223                        WRITE( NOUT, * )
224                        WRITE( NOUT, FMT = 9999 )
225                     END IF
226                     WRITE( NOUT, FMT = 9998 ) SRNAMT, UPLO, CFORM, N
227                     NERRS = NERRS + 1
228                     GO TO 100
229                  END IF
230*
231                  DO 90 INORM = 1, 4
232*
233*                    Check all four norms: 'M', '1', 'I', 'F'
234*
235                     NORM = NORMS( INORM )
236                     NORMARF = SLANSF( NORM, CFORM, UPLO, N, ARF, WORK )
237                     NORMA = SLANSY( NORM, UPLO, N, A, LDA, WORK )
238*
239                     RESULT(1) = ( NORMA - NORMARF ) / NORMA / EPS
240                     NRUN = NRUN + 1
241*
242                     IF( RESULT(1).GE.THRESH ) THEN
243                        IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) THEN
244                           WRITE( NOUT, * )
245                           WRITE( NOUT, FMT = 9999 )
246                        END IF
247                        WRITE( NOUT, FMT = 9997 ) 'SLANSF',
248     +                      N, IIT, UPLO, CFORM, NORM, RESULT(1)
249                        NFAIL = NFAIL + 1
250                     END IF
251   90             CONTINUE
252  100          CONTINUE
253  110       CONTINUE
254  120    CONTINUE
255  130 CONTINUE
256*
257*     Print a summary of the results.
258*
259      IF ( NFAIL.EQ.0 ) THEN
260         WRITE( NOUT, FMT = 9996 ) 'SLANSF', NRUN
261      ELSE
262         WRITE( NOUT, FMT = 9995 ) 'SLANSF', NFAIL, NRUN
263      END IF
264      IF ( NERRS.NE.0 ) THEN
265         WRITE( NOUT, FMT = 9994 ) NERRS, 'SLANSF'
266      END IF
267*
268 9999 FORMAT( 1X, ' *** Error(s) or Failure(s) while testing SLANSF
269     +         ***')
270 9998 FORMAT( 1X, '     Error in ',A6,' with UPLO=''',A1,''', FORM=''',
271     +        A1,''', N=',I5)
272 9997 FORMAT( 1X, '     Failure in ',A6,' N=',I5,' TYPE=',I5,' UPLO=''',
273     +        A1, ''', FORM =''',A1,''', NORM=''',A1,''', test=',G12.5)
274 9996 FORMAT( 1X, 'All tests for ',A6,' auxiliary routine passed the ',
275     +        'threshold ( ',I5,' tests run)')
276 9995 FORMAT( 1X, A6, ' auxiliary routine: ',I5,' out of ',I5,
277     +        ' tests failed to pass the threshold')
278 9994 FORMAT( 26X, I5,' error message recorded (',A6,')')
279*
280      RETURN
281*
282*     End of SDRVRF1
283*
284      END
285