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