![]() |
LAPACK
3.4.1
LAPACK: Linear Algebra PACKage
|
00001 *> \brief \b SDRVRF1 00002 * 00003 * =========== DOCUMENTATION =========== 00004 * 00005 * Online html documentation available at 00006 * http://www.netlib.org/lapack/explore-html/ 00007 * 00008 * Definition: 00009 * =========== 00010 * 00011 * SUBROUTINE SDRVRF1( NOUT, NN, NVAL, THRESH, A, LDA, ARF, WORK ) 00012 * 00013 * .. Scalar Arguments .. 00014 * INTEGER LDA, NN, NOUT 00015 * REAL THRESH 00016 * .. 00017 * .. Array Arguments .. 00018 * INTEGER NVAL( NN ) 00019 * REAL A( LDA, * ), ARF( * ), WORK( * ) 00020 * .. 00021 * 00022 * 00023 *> \par Purpose: 00024 * ============= 00025 *> 00026 *> \verbatim 00027 *> 00028 *> SDRVRF1 tests the LAPACK RFP routines: 00029 *> SLANSF 00030 *> \endverbatim 00031 * 00032 * Arguments: 00033 * ========== 00034 * 00035 *> \param[in] NOUT 00036 *> \verbatim 00037 *> NOUT is INTEGER 00038 *> The unit number for output. 00039 *> \endverbatim 00040 *> 00041 *> \param[in] NN 00042 *> \verbatim 00043 *> NN is INTEGER 00044 *> The number of values of N contained in the vector NVAL. 00045 *> \endverbatim 00046 *> 00047 *> \param[in] NVAL 00048 *> \verbatim 00049 *> NVAL is INTEGER array, dimension (NN) 00050 *> The values of the matrix dimension N. 00051 *> \endverbatim 00052 *> 00053 *> \param[in] THRESH 00054 *> \verbatim 00055 *> THRESH is REAL 00056 *> The threshold value for the test ratios. A result is 00057 *> included in the output file if RESULT >= THRESH. To have 00058 *> every test ratio printed, use THRESH = 0. 00059 *> \endverbatim 00060 *> 00061 *> \param[out] A 00062 *> \verbatim 00063 *> A is REAL array, dimension (LDA,NMAX) 00064 *> \endverbatim 00065 *> 00066 *> \param[in] LDA 00067 *> \verbatim 00068 *> LDA is INTEGER 00069 *> The leading dimension of the array A. LDA >= max(1,NMAX). 00070 *> \endverbatim 00071 *> 00072 *> \param[out] ARF 00073 *> \verbatim 00074 *> ARF is REAL array, dimension ((NMAX*(NMAX+1))/2). 00075 *> \endverbatim 00076 *> 00077 *> \param[out] WORK 00078 *> \verbatim 00079 *> WORK is REAL array, dimension ( NMAX ) 00080 *> \endverbatim 00081 * 00082 * Authors: 00083 * ======== 00084 * 00085 *> \author Univ. of Tennessee 00086 *> \author Univ. of California Berkeley 00087 *> \author Univ. of Colorado Denver 00088 *> \author NAG Ltd. 00089 * 00090 *> \date November 2011 00091 * 00092 *> \ingroup single_lin 00093 * 00094 * ===================================================================== 00095 SUBROUTINE SDRVRF1( NOUT, NN, NVAL, THRESH, A, LDA, ARF, WORK ) 00096 * 00097 * -- LAPACK test routine (version 3.4.0) -- 00098 * -- LAPACK is a software package provided by Univ. of Tennessee, -- 00099 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- 00100 * November 2011 00101 * 00102 * .. Scalar Arguments .. 00103 INTEGER LDA, NN, NOUT 00104 REAL THRESH 00105 * .. 00106 * .. Array Arguments .. 00107 INTEGER NVAL( NN ) 00108 REAL A( LDA, * ), ARF( * ), WORK( * ) 00109 * .. 00110 * 00111 * ===================================================================== 00112 * .. 00113 * .. Parameters .. 00114 REAL ONE 00115 PARAMETER ( ONE = 1.0E+0 ) 00116 INTEGER NTESTS 00117 PARAMETER ( NTESTS = 1 ) 00118 * .. 00119 * .. Local Scalars .. 00120 CHARACTER UPLO, CFORM, NORM 00121 INTEGER I, IFORM, IIN, IIT, INFO, INORM, IUPLO, J, N, 00122 + NERRS, NFAIL, NRUN 00123 REAL EPS, LARGE, NORMA, NORMARF, SMALL 00124 * .. 00125 * .. Local Arrays .. 00126 CHARACTER UPLOS( 2 ), FORMS( 2 ), NORMS( 4 ) 00127 INTEGER ISEED( 4 ), ISEEDY( 4 ) 00128 REAL RESULT( NTESTS ) 00129 * .. 00130 * .. External Functions .. 00131 REAL SLAMCH, SLANSY, SLANSF, SLARND 00132 EXTERNAL SLAMCH, SLANSY, SLANSF, SLARND 00133 * .. 00134 * .. External Subroutines .. 00135 EXTERNAL STRTTF 00136 * .. 00137 * .. Scalars in Common .. 00138 CHARACTER*32 SRNAMT 00139 * .. 00140 * .. Common blocks .. 00141 COMMON / SRNAMC / SRNAMT 00142 * .. 00143 * .. Data statements .. 00144 DATA ISEEDY / 1988, 1989, 1990, 1991 / 00145 DATA UPLOS / 'U', 'L' / 00146 DATA FORMS / 'N', 'T' / 00147 DATA NORMS / 'M', '1', 'I', 'F' / 00148 * .. 00149 * .. Executable Statements .. 00150 * 00151 * Initialize constants and the random number seed. 00152 * 00153 NRUN = 0 00154 NFAIL = 0 00155 NERRS = 0 00156 INFO = 0 00157 DO 10 I = 1, 4 00158 ISEED( I ) = ISEEDY( I ) 00159 10 CONTINUE 00160 * 00161 EPS = SLAMCH( 'Precision' ) 00162 SMALL = SLAMCH( 'Safe minimum' ) 00163 LARGE = ONE / SMALL 00164 SMALL = SMALL * LDA * LDA 00165 LARGE = LARGE / LDA / LDA 00166 * 00167 DO 130 IIN = 1, NN 00168 * 00169 N = NVAL( IIN ) 00170 * 00171 DO 120 IIT = 1, 3 00172 * Nothing to do for N=0 00173 IF ( N .EQ. 0 ) EXIT 00174 00175 * Quick Return if possible 00176 IF ( N .EQ. 0 ) EXIT 00177 * 00178 * IIT = 1 : random matrix 00179 * IIT = 2 : random matrix scaled near underflow 00180 * IIT = 3 : random matrix scaled near overflow 00181 * 00182 DO J = 1, N 00183 DO I = 1, N 00184 A( I, J) = SLARND( 2, ISEED ) 00185 END DO 00186 END DO 00187 * 00188 IF ( IIT.EQ.2 ) THEN 00189 DO J = 1, N 00190 DO I = 1, N 00191 A( I, J) = A( I, J ) * LARGE 00192 END DO 00193 END DO 00194 END IF 00195 * 00196 IF ( IIT.EQ.3 ) THEN 00197 DO J = 1, N 00198 DO I = 1, N 00199 A( I, J) = A( I, J) * SMALL 00200 END DO 00201 END DO 00202 END IF 00203 * 00204 * Do first for UPLO = 'U', then for UPLO = 'L' 00205 * 00206 DO 110 IUPLO = 1, 2 00207 * 00208 UPLO = UPLOS( IUPLO ) 00209 * 00210 * Do first for CFORM = 'N', then for CFORM = 'C' 00211 * 00212 DO 100 IFORM = 1, 2 00213 * 00214 CFORM = FORMS( IFORM ) 00215 * 00216 SRNAMT = 'STRTTF' 00217 CALL STRTTF( CFORM, UPLO, N, A, LDA, ARF, INFO ) 00218 * 00219 * Check error code from STRTTF 00220 * 00221 IF( INFO.NE.0 ) THEN 00222 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) THEN 00223 WRITE( NOUT, * ) 00224 WRITE( NOUT, FMT = 9999 ) 00225 END IF 00226 WRITE( NOUT, FMT = 9998 ) SRNAMT, UPLO, CFORM, N 00227 NERRS = NERRS + 1 00228 GO TO 100 00229 END IF 00230 * 00231 DO 90 INORM = 1, 4 00232 * 00233 * Check all four norms: 'M', '1', 'I', 'F' 00234 * 00235 NORM = NORMS( INORM ) 00236 NORMARF = SLANSF( NORM, CFORM, UPLO, N, ARF, WORK ) 00237 NORMA = SLANSY( NORM, UPLO, N, A, LDA, WORK ) 00238 * 00239 RESULT(1) = ( NORMA - NORMARF ) / NORMA / EPS 00240 NRUN = NRUN + 1 00241 * 00242 IF( RESULT(1).GE.THRESH ) THEN 00243 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) THEN 00244 WRITE( NOUT, * ) 00245 WRITE( NOUT, FMT = 9999 ) 00246 END IF 00247 WRITE( NOUT, FMT = 9997 ) 'SLANSF', 00248 + N, IIT, UPLO, CFORM, NORM, RESULT(1) 00249 NFAIL = NFAIL + 1 00250 END IF 00251 90 CONTINUE 00252 100 CONTINUE 00253 110 CONTINUE 00254 120 CONTINUE 00255 130 CONTINUE 00256 * 00257 * Print a summary of the results. 00258 * 00259 IF ( NFAIL.EQ.0 ) THEN 00260 WRITE( NOUT, FMT = 9996 ) 'SLANSF', NRUN 00261 ELSE 00262 WRITE( NOUT, FMT = 9995 ) 'SLANSF', NFAIL, NRUN 00263 END IF 00264 IF ( NERRS.NE.0 ) THEN 00265 WRITE( NOUT, FMT = 9994 ) NERRS, 'SLANSF' 00266 END IF 00267 * 00268 9999 FORMAT( 1X, 00269 ' *** Error(s) or Failure(s) while testing SLANSF + ***') 00270 9998 FORMAT( 1X, ' Error in ',A6,' with UPLO=''',A1,''', FORM=''', 00271 + A1,''', N=',I5) 00272 9997 FORMAT( 1X, ' Failure in ',A6,' N=',I5,' TYPE=',I5,' UPLO=''', 00273 + A1, ''', FORM =''',A1,''', NORM=''',A1,''', test=',G12.5) 00274 9996 FORMAT( 1X, 'All tests for ',A6,' auxiliary routine passed the ', 00275 + 'threshold ( ',I5,' tests run)') 00276 9995 FORMAT( 1X, A6, ' auxiliary routine: ',I5,' out of ',I5, 00277 + ' tests failed to pass the threshold') 00278 9994 FORMAT( 26X, I5,' error message recorded (',A6,')') 00279 * 00280 RETURN 00281 * 00282 * End of SDRVRF1 00283 * 00284 END