![]() |
LAPACK
3.4.1
LAPACK: Linear Algebra PACKage
|
00001 *> \brief \b SDRVRF4 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 SDRVRF4( NOUT, NN, NVAL, THRESH, C1, C2, LDC, CRF, A, 00012 * + LDA, S_WORK_SLANGE ) 00013 * 00014 * .. Scalar Arguments .. 00015 * INTEGER LDA, LDC, NN, NOUT 00016 * REAL THRESH 00017 * .. 00018 * .. Array Arguments .. 00019 * INTEGER NVAL( NN ) 00020 * REAL A( LDA, * ), C1( LDC, * ), C2( LDC, *), 00021 * + CRF( * ), S_WORK_SLANGE( * ) 00022 * .. 00023 * 00024 * 00025 *> \par Purpose: 00026 * ============= 00027 *> 00028 *> \verbatim 00029 *> 00030 *> SDRVRF4 tests the LAPACK RFP routines: 00031 *> SSFRK 00032 *> \endverbatim 00033 * 00034 * Arguments: 00035 * ========== 00036 * 00037 *> \param[in] NOUT 00038 *> \verbatim 00039 *> NOUT is INTEGER 00040 *> The unit number for output. 00041 *> \endverbatim 00042 *> 00043 *> \param[in] NN 00044 *> \verbatim 00045 *> NN is INTEGER 00046 *> The number of values of N contained in the vector NVAL. 00047 *> \endverbatim 00048 *> 00049 *> \param[in] NVAL 00050 *> \verbatim 00051 *> NVAL is INTEGER array, dimension (NN) 00052 *> The values of the matrix dimension N. 00053 *> \endverbatim 00054 *> 00055 *> \param[in] THRESH 00056 *> \verbatim 00057 *> THRESH is REAL 00058 *> The threshold value for the test ratios. A result is 00059 *> included in the output file if RESULT >= THRESH. To 00060 *> have every test ratio printed, use THRESH = 0. 00061 *> \endverbatim 00062 *> 00063 *> \param[out] C1 00064 *> \verbatim 00065 *> C1 is REAL array, 00066 *> dimension (LDC,NMAX) 00067 *> \endverbatim 00068 *> 00069 *> \param[out] C2 00070 *> \verbatim 00071 *> C2 is REAL array, 00072 *> dimension (LDC,NMAX) 00073 *> \endverbatim 00074 *> 00075 *> \param[in] LDC 00076 *> \verbatim 00077 *> LDC is INTEGER 00078 *> The leading dimension of the array A. 00079 *> LDA >= max(1,NMAX). 00080 *> \endverbatim 00081 *> 00082 *> \param[out] CRF 00083 *> \verbatim 00084 *> CRF is REAL array, 00085 *> dimension ((NMAX*(NMAX+1))/2). 00086 *> \endverbatim 00087 *> 00088 *> \param[out] A 00089 *> \verbatim 00090 *> A is REAL array, 00091 *> dimension (LDA,NMAX) 00092 *> \endverbatim 00093 *> 00094 *> \param[in] LDA 00095 *> \verbatim 00096 *> LDA is INTEGER 00097 *> The leading dimension of the array A. LDA >= max(1,NMAX). 00098 *> \endverbatim 00099 *> 00100 *> \param[out] S_WORK_SLANGE 00101 *> \verbatim 00102 *> S_WORK_SLANGE is REAL array, dimension (NMAX) 00103 *> \endverbatim 00104 * 00105 * Authors: 00106 * ======== 00107 * 00108 *> \author Univ. of Tennessee 00109 *> \author Univ. of California Berkeley 00110 *> \author Univ. of Colorado Denver 00111 *> \author NAG Ltd. 00112 * 00113 *> \date November 2011 00114 * 00115 *> \ingroup single_lin 00116 * 00117 * ===================================================================== 00118 SUBROUTINE SDRVRF4( NOUT, NN, NVAL, THRESH, C1, C2, LDC, CRF, A, 00119 + LDA, S_WORK_SLANGE ) 00120 * 00121 * -- LAPACK test routine (version 3.4.0) -- 00122 * -- LAPACK is a software package provided by Univ. of Tennessee, -- 00123 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- 00124 * November 2011 00125 * 00126 * .. Scalar Arguments .. 00127 INTEGER LDA, LDC, NN, NOUT 00128 REAL THRESH 00129 * .. 00130 * .. Array Arguments .. 00131 INTEGER NVAL( NN ) 00132 REAL A( LDA, * ), C1( LDC, * ), C2( LDC, *), 00133 + CRF( * ), S_WORK_SLANGE( * ) 00134 * .. 00135 * 00136 * ===================================================================== 00137 * .. 00138 * .. Parameters .. 00139 REAL ZERO, ONE 00140 PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 ) 00141 INTEGER NTESTS 00142 PARAMETER ( NTESTS = 1 ) 00143 * .. 00144 * .. Local Scalars .. 00145 CHARACTER UPLO, CFORM, TRANS 00146 INTEGER I, IFORM, IIK, IIN, INFO, IUPLO, J, K, N, 00147 + NFAIL, NRUN, IALPHA, ITRANS 00148 REAL ALPHA, BETA, EPS, NORMA, NORMC 00149 * .. 00150 * .. Local Arrays .. 00151 CHARACTER UPLOS( 2 ), FORMS( 2 ), TRANSS( 2 ) 00152 INTEGER ISEED( 4 ), ISEEDY( 4 ) 00153 REAL RESULT( NTESTS ) 00154 * .. 00155 * .. External Functions .. 00156 REAL SLAMCH, SLARND, SLANGE 00157 EXTERNAL SLAMCH, SLARND, SLANGE 00158 * .. 00159 * .. External Subroutines .. 00160 EXTERNAL SSYRK, SSFRK, STFTTR, STRTTF 00161 * .. 00162 * .. Intrinsic Functions .. 00163 INTRINSIC ABS, MAX 00164 * .. 00165 * .. Scalars in Common .. 00166 CHARACTER*32 SRNAMT 00167 * .. 00168 * .. Common blocks .. 00169 COMMON / SRNAMC / SRNAMT 00170 * .. 00171 * .. Data statements .. 00172 DATA ISEEDY / 1988, 1989, 1990, 1991 / 00173 DATA UPLOS / 'U', 'L' / 00174 DATA FORMS / 'N', 'T' / 00175 DATA TRANSS / 'N', 'T' / 00176 * .. 00177 * .. Executable Statements .. 00178 * 00179 * Initialize constants and the random number seed. 00180 * 00181 NRUN = 0 00182 NFAIL = 0 00183 INFO = 0 00184 DO 10 I = 1, 4 00185 ISEED( I ) = ISEEDY( I ) 00186 10 CONTINUE 00187 EPS = SLAMCH( 'Precision' ) 00188 * 00189 DO 150 IIN = 1, NN 00190 * 00191 N = NVAL( IIN ) 00192 * 00193 DO 140 IIK = 1, NN 00194 * 00195 K = NVAL( IIN ) 00196 * 00197 DO 130 IFORM = 1, 2 00198 * 00199 CFORM = FORMS( IFORM ) 00200 * 00201 DO 120 IUPLO = 1, 2 00202 * 00203 UPLO = UPLOS( IUPLO ) 00204 * 00205 DO 110 ITRANS = 1, 2 00206 * 00207 TRANS = TRANSS( ITRANS ) 00208 * 00209 DO 100 IALPHA = 1, 4 00210 * 00211 IF ( IALPHA.EQ. 1) THEN 00212 ALPHA = ZERO 00213 BETA = ZERO 00214 ELSE IF ( IALPHA.EQ. 2) THEN 00215 ALPHA = ONE 00216 BETA = ZERO 00217 ELSE IF ( IALPHA.EQ. 3) THEN 00218 ALPHA = ZERO 00219 BETA = ONE 00220 ELSE 00221 ALPHA = SLARND( 2, ISEED ) 00222 BETA = SLARND( 2, ISEED ) 00223 END IF 00224 * 00225 * All the parameters are set: 00226 * CFORM, UPLO, TRANS, M, N, 00227 * ALPHA, and BETA 00228 * READY TO TEST! 00229 * 00230 NRUN = NRUN + 1 00231 * 00232 IF ( ITRANS.EQ.1 ) THEN 00233 * 00234 * In this case we are NOTRANS, so A is N-by-K 00235 * 00236 DO J = 1, K 00237 DO I = 1, N 00238 A( I, J) = SLARND( 2, ISEED ) 00239 END DO 00240 END DO 00241 * 00242 NORMA = SLANGE( 'I', N, K, A, LDA, 00243 + S_WORK_SLANGE ) 00244 * 00245 00246 ELSE 00247 * 00248 * In this case we are TRANS, so A is K-by-N 00249 * 00250 DO J = 1,N 00251 DO I = 1, K 00252 A( I, J) = SLARND( 2, ISEED ) 00253 END DO 00254 END DO 00255 * 00256 NORMA = SLANGE( 'I', K, N, A, LDA, 00257 + S_WORK_SLANGE ) 00258 * 00259 END IF 00260 * 00261 * Generate C1 our N--by--N symmetric matrix. 00262 * Make sure C2 has the same upper/lower part, 00263 * (the one that we do not touch), so 00264 * copy the initial C1 in C2 in it. 00265 * 00266 DO J = 1, N 00267 DO I = 1, N 00268 C1( I, J) = SLARND( 2, ISEED ) 00269 C2(I,J) = C1(I,J) 00270 END DO 00271 END DO 00272 * 00273 * (See comment later on for why we use SLANGE and 00274 * not SLANSY for C1.) 00275 * 00276 NORMC = SLANGE( 'I', N, N, C1, LDC, 00277 + S_WORK_SLANGE ) 00278 * 00279 SRNAMT = 'STRTTF' 00280 CALL STRTTF( CFORM, UPLO, N, C1, LDC, CRF, 00281 + INFO ) 00282 * 00283 * call ssyrk the BLAS routine -> gives C1 00284 * 00285 SRNAMT = 'SSYRK ' 00286 CALL SSYRK( UPLO, TRANS, N, K, ALPHA, A, LDA, 00287 + BETA, C1, LDC ) 00288 * 00289 * call ssfrk the RFP routine -> gives CRF 00290 * 00291 SRNAMT = 'SSFRK ' 00292 CALL SSFRK( CFORM, UPLO, TRANS, N, K, ALPHA, A, 00293 + LDA, BETA, CRF ) 00294 * 00295 * convert CRF in full format -> gives C2 00296 * 00297 SRNAMT = 'STFTTR' 00298 CALL STFTTR( CFORM, UPLO, N, CRF, C2, LDC, 00299 + INFO ) 00300 * 00301 * compare C1 and C2 00302 * 00303 DO J = 1, N 00304 DO I = 1, N 00305 C1(I,J) = C1(I,J)-C2(I,J) 00306 END DO 00307 END DO 00308 * 00309 * Yes, C1 is symmetric so we could call SLANSY, 00310 * but we want to check the upper part that is 00311 * supposed to be unchanged and the diagonal that 00312 * is supposed to be real -> SLANGE 00313 * 00314 RESULT(1) = SLANGE( 'I', N, N, C1, LDC, 00315 + S_WORK_SLANGE ) 00316 RESULT(1) = RESULT(1) 00317 + / MAX( ABS( ALPHA ) * NORMA 00318 + + ABS( BETA ) , ONE ) 00319 + / MAX( N , 1 ) / EPS 00320 * 00321 IF( RESULT(1).GE.THRESH ) THEN 00322 IF( NFAIL.EQ.0 ) THEN 00323 WRITE( NOUT, * ) 00324 WRITE( NOUT, FMT = 9999 ) 00325 END IF 00326 WRITE( NOUT, FMT = 9997 ) 'SSFRK', 00327 + CFORM, UPLO, TRANS, N, K, RESULT(1) 00328 NFAIL = NFAIL + 1 00329 END IF 00330 * 00331 100 CONTINUE 00332 110 CONTINUE 00333 120 CONTINUE 00334 130 CONTINUE 00335 140 CONTINUE 00336 150 CONTINUE 00337 * 00338 * Print a summary of the results. 00339 * 00340 IF ( NFAIL.EQ.0 ) THEN 00341 WRITE( NOUT, FMT = 9996 ) 'SSFRK', NRUN 00342 ELSE 00343 WRITE( NOUT, FMT = 9995 ) 'SSFRK', NFAIL, NRUN 00344 END IF 00345 * 00346 9999 FORMAT( 1X, 00347 ' *** Error(s) or Failure(s) while testing SSFRK + ***') 00348 9997 FORMAT( 1X, ' Failure in ',A5,', CFORM=''',A1,''',', 00349 + ' UPLO=''',A1,''',',' TRANS=''',A1,''',', ' N=',I3,', K =', I3, 00350 + ', test=',G12.5) 00351 9996 FORMAT( 1X, 'All tests for ',A5,' auxiliary routine passed the ', 00352 + 'threshold ( ',I5,' tests run)') 00353 9995 FORMAT( 1X, A6, ' auxiliary routine: ',I5,' out of ',I5, 00354 + ' tests failed to pass the threshold') 00355 * 00356 RETURN 00357 * 00358 * End of SDRVRF4 00359 * 00360 END