LAPACK: TESTING/LIN/sdrvrf1.f Source File

Go to the documentation of this file.
00001       SUBROUTINE SDRVRF1( NOUT, NN, NVAL, THRESH, A, LDA, ARF, WORK )
00002 *
00003 *  -- LAPACK test routine (version 3.2.0) --
00004 *     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
00005 *     November 2008
00006 *
00007 *     .. Scalar Arguments ..
00008       INTEGER            LDA, NN, NOUT
00009       REAL               THRESH
00010 *     ..
00011 *     .. Array Arguments ..
00012       INTEGER            NVAL( NN )
00013       REAL               A( LDA, * ), ARF( * ), WORK( * )
00014 *     ..
00015 *
00016 *  Purpose
00017 *  =======
00018 *
00019 *  SDRVRF1 tests the LAPACK RFP routines:
00020 *      SLANSF
00021 *
00022 *  Arguments
00023 *  =========
00024 *
00025 *  NOUT          (input) INTEGER
00026 *                The unit number for output.
00027 *
00028 *  NN            (input) INTEGER
00029 *                The number of values of N contained in the vector NVAL.
00030 *
00031 *  NVAL          (input) INTEGER array, dimension (NN)
00032 *                The values of the matrix dimension N.
00033 *
00034 *  THRESH        (input) REAL
00035 *                The threshold value for the test ratios.  A result is
00036 *                included in the output file if RESULT >= THRESH.  To have
00037 *                every test ratio printed, use THRESH = 0.
00038 *
00039 *  A             (workspace) REAL array, dimension (LDA,NMAX)
00040 *
00041 *  LDA           (input) INTEGER
00042 *                The leading dimension of the array A.  LDA >= max(1,NMAX).
00043 *
00044 *  ARF           (workspace) REAL array, dimension ((NMAX*(NMAX+1))/2).
00045 *
00046 *  WORK          (workspace) REAL array, dimension ( NMAX )
00047 *
00048 *  =====================================================================
00049 *     ..
00050 *     .. Parameters ..
00051       REAL               ONE
00052       PARAMETER          ( ONE = 1.0E+0 )
00053       INTEGER            NTESTS
00054       PARAMETER          ( NTESTS = 1 )
00055 *     ..
00056 *     .. Local Scalars ..
00057       CHARACTER          UPLO, CFORM, NORM
00058       INTEGER            I, IFORM, IIN, IIT, INFO, INORM, IUPLO, J, N,
00059      +                   NERRS, NFAIL, NRUN
00060       REAL               EPS, LARGE, NORMA, NORMARF, SMALL
00061 *     ..
00062 *     .. Local Arrays ..
00063       CHARACTER          UPLOS( 2 ), FORMS( 2 ), NORMS( 4 )
00064       INTEGER            ISEED( 4 ), ISEEDY( 4 )
00065       REAL               RESULT( NTESTS )
00066 *     ..
00067 *     .. External Functions ..
00068       REAL               SLAMCH, SLANSY, SLANSF, SLARND
00069       EXTERNAL           SLAMCH, SLANSY, SLANSF, SLARND
00070 *     ..
00071 *     .. External Subroutines ..
00072       EXTERNAL           STRTTF
00073 *     ..
00074 *     .. Scalars in Common ..
00075       CHARACTER*32       SRNAMT
00076 *     ..
00077 *     .. Common blocks ..
00078       COMMON             / SRNAMC / SRNAMT
00079 *     ..
00080 *     .. Data statements ..
00081       DATA               ISEEDY / 1988, 1989, 1990, 1991 /
00082       DATA               UPLOS / 'U', 'L' /
00083       DATA               FORMS / 'N', 'T' /
00084       DATA               NORMS / 'M', '1', 'I', 'F' /
00085 *     ..
00086 *     .. Executable Statements ..
00087 *
00088 *     Initialize constants and the random number seed.
00089 *
00090       NRUN = 0
00091       NFAIL = 0
00092       NERRS = 0
00093       INFO = 0
00094       DO 10 I = 1, 4
00095          ISEED( I ) = ISEEDY( I )
00096    10 CONTINUE
00097 *
00098       EPS = SLAMCH( 'Precision' )
00099       SMALL = SLAMCH( 'Safe minimum' )
00100       LARGE = ONE / SMALL
00101       SMALL = SMALL * LDA * LDA 
00102       LARGE = LARGE / LDA / LDA
00103 *
00104       DO 130 IIN = 1, NN
00105 *
00106          N = NVAL( IIN )
00107 *
00108          DO 120 IIT = 1, 3
00109 *
00110 *           IIT = 1 : random matrix
00111 *           IIT = 2 : random matrix scaled near underflow
00112 *           IIT = 3 : random matrix scaled near overflow
00113 *
00114             DO J = 1, N
00115                DO I = 1, N
00116                   A( I, J) = SLARND( 2, ISEED )
00117                END DO
00118             END DO
00119 *
00120             IF ( IIT.EQ.2 ) THEN
00121                DO J = 1, N
00122                   DO I = 1, N
00123                      A( I, J) = A( I, J ) * LARGE
00124                   END DO
00125                END DO
00126             END IF
00127 *
00128             IF ( IIT.EQ.3 ) THEN
00129                DO J = 1, N
00130                   DO I = 1, N
00131                      A( I, J) = A( I, J) * SMALL
00132                   END DO
00133                END DO
00134             END IF
00135 *
00136 *           Do first for UPLO = 'U', then for UPLO = 'L'
00137 *
00138             DO 110 IUPLO = 1, 2
00139 *
00140                UPLO = UPLOS( IUPLO )
00141 *
00142 *              Do first for CFORM = 'N', then for CFORM = 'C'
00143 *
00144                DO 100 IFORM = 1, 2
00145 *
00146                   CFORM = FORMS( IFORM )
00147 *
00148                   SRNAMT = 'STRTTF'
00149                   CALL STRTTF( CFORM, UPLO, N, A, LDA, ARF, INFO )
00150 *
00151 *                 Check error code from STRTTF
00152 *
00153                   IF( INFO.NE.0 ) THEN
00154                      IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) THEN
00155                         WRITE( NOUT, * )
00156                         WRITE( NOUT, FMT = 9999 )
00157                      END IF
00158                      WRITE( NOUT, FMT = 9998 ) SRNAMT, UPLO, CFORM, N
00159                      NERRS = NERRS + 1
00160                      GO TO 100
00161                   END IF
00162 *
00163                   DO 90 INORM = 1, 4
00164 *
00165 *                    Check all four norms: 'M', '1', 'I', 'F'
00166 *
00167                      NORM = NORMS( INORM )
00168                      NORMARF = SLANSF( NORM, CFORM, UPLO, N, ARF, WORK )
00169                      NORMA = SLANSY( NORM, UPLO, N, A, LDA, WORK )
00170 *
00171                      RESULT(1) = ( NORMA - NORMARF ) / NORMA / EPS
00172                      NRUN = NRUN + 1
00173 *
00174                      IF( RESULT(1).GE.THRESH ) THEN
00175                         IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) THEN
00176                            WRITE( NOUT, * )
00177                            WRITE( NOUT, FMT = 9999 )
00178                         END IF
00179                         WRITE( NOUT, FMT = 9997 ) 'SLANSF', 
00180      +                      N, IIT, UPLO, CFORM, NORM, RESULT(1)
00181                         NFAIL = NFAIL + 1
00182                      END IF
00183    90             CONTINUE
00184   100          CONTINUE
00185   110       CONTINUE
00186   120    CONTINUE
00187   130 CONTINUE
00188 *
00189 *     Print a summary of the results.
00190 *
00191       IF ( NFAIL.EQ.0 ) THEN
00192          WRITE( NOUT, FMT = 9996 ) 'SLANSF', NRUN
00193       ELSE
00194          WRITE( NOUT, FMT = 9995 ) 'SLANSF', NFAIL, NRUN
00195       END IF
00196       IF ( NERRS.NE.0 ) THEN
00197          WRITE( NOUT, FMT = 9994 ) NERRS, 'SLANSF'
00198       END IF
00199 *
00200  9999 FORMAT( 1X, 
00201 ' *** Error(s) or Failure(s) while testing SLANSF     +         ***')
00202  9998 FORMAT( 1X, '     Error in ',A6,' with UPLO=''',A1,''', FORM=''',
00203      +        A1,''', N=',I5)
00204  9997 FORMAT( 1X, '     Failure in ',A6,' N=',I5,' TYPE=',I5,' UPLO=''',
00205      +        A1, ''', FORM =''',A1,''', NORM=''',A1,''', test=',G12.5)
00206  9996 FORMAT( 1X, 'All tests for ',A6,' auxiliary routine passed the ',
00207      +        'threshold (',I5,' tests run)')
00208  9995 FORMAT( 1X, A6, ' auxiliary routine:',I5,' out of ',I5,
00209      +        ' tests failed to pass the threshold')
00210  9994 FORMAT( 26X, I5,' error message recorded (',A6,')')
00211 *
00212       RETURN
00213 *
00214 *     End of SDRVRF1
00215 *
00216       END