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