TESTING/LIN/sdrvrf1.f

   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 November 2011
  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.4.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 *     November 2011
 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