 |
LAPACK 3.3.1
Linear Algebra PACKage
|
|
LAPACK 3.3.1
Linear Algebra PACKage
|
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
1.7.3 
