1*> \brief \b CDRVRF3 2* 3* =========== DOCUMENTATION =========== 4* 5* Online html documentation available at 6* http://www.netlib.org/lapack/explore-html/ 7* 8* Definition: 9* =========== 10* 11* SUBROUTINE CDRVRF3( NOUT, NN, NVAL, THRESH, A, LDA, ARF, B1, B2, 12* + S_WORK_CLANGE, C_WORK_CGEQRF, TAU ) 13* 14* .. Scalar Arguments .. 15* INTEGER LDA, NN, NOUT 16* REAL THRESH 17* .. 18* .. Array Arguments .. 19* INTEGER NVAL( NN ) 20* REAL S_WORK_CLANGE( * ) 21* COMPLEX A( LDA, * ), ARF( * ), B1( LDA, * ), 22* + B2( LDA, * ) 23* COMPLEX C_WORK_CGEQRF( * ), TAU( * ) 24* .. 25* 26* 27*> \par Purpose: 28* ============= 29*> 30*> \verbatim 31*> 32*> CDRVRF3 tests the LAPACK RFP routines: 33*> CTFSM 34*> \endverbatim 35* 36* Arguments: 37* ========== 38* 39*> \param[in] NOUT 40*> \verbatim 41*> NOUT is INTEGER 42*> The unit number for output. 43*> \endverbatim 44*> 45*> \param[in] NN 46*> \verbatim 47*> NN is INTEGER 48*> The number of values of N contained in the vector NVAL. 49*> \endverbatim 50*> 51*> \param[in] NVAL 52*> \verbatim 53*> NVAL is INTEGER array, dimension (NN) 54*> The values of the matrix dimension N. 55*> \endverbatim 56*> 57*> \param[in] THRESH 58*> \verbatim 59*> THRESH is DOUBLE PRECISION 60*> The threshold value for the test ratios. A result is 61*> included in the output file if RESULT >= THRESH. To have 62*> every test ratio printed, use THRESH = 0. 63*> \endverbatim 64*> 65*> \param[out] A 66*> \verbatim 67*> A is COMPLEX*16 array, dimension (LDA,NMAX) 68*> \endverbatim 69*> 70*> \param[in] LDA 71*> \verbatim 72*> LDA is INTEGER 73*> The leading dimension of the array A. LDA >= max(1,NMAX). 74*> \endverbatim 75*> 76*> \param[out] ARF 77*> \verbatim 78*> ARF is COMPLEX array, dimension ((NMAX*(NMAX+1))/2). 79*> \endverbatim 80*> 81*> \param[out] B1 82*> \verbatim 83*> B1 is COMPLEX array, dimension (LDA,NMAX) 84*> \endverbatim 85*> 86*> \param[out] B2 87*> \verbatim 88*> B2 is COMPLEX array, dimension (LDA,NMAX) 89*> \endverbatim 90*> 91*> \param[out] S_WORK_CLANGE 92*> \verbatim 93*> S_WORK_CLANGE is REAL array, dimension (NMAX) 94*> \endverbatim 95*> 96*> \param[out] C_WORK_CGEQRF 97*> \verbatim 98*> C_WORK_CGEQRF is COMPLEX array, dimension (NMAX) 99*> \endverbatim 100*> 101*> \param[out] TAU 102*> \verbatim 103*> TAU is COMPLEX array, dimension (NMAX) 104*> \endverbatim 105* 106* Authors: 107* ======== 108* 109*> \author Univ. of Tennessee 110*> \author Univ. of California Berkeley 111*> \author Univ. of Colorado Denver 112*> \author NAG Ltd. 113* 114*> \ingroup complex_lin 115* 116* ===================================================================== 117 SUBROUTINE CDRVRF3( NOUT, NN, NVAL, THRESH, A, LDA, ARF, B1, B2, 118 + S_WORK_CLANGE, C_WORK_CGEQRF, TAU ) 119* 120* -- LAPACK test routine -- 121* -- LAPACK is a software package provided by Univ. of Tennessee, -- 122* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- 123* 124* .. Scalar Arguments .. 125 INTEGER LDA, NN, NOUT 126 REAL THRESH 127* .. 128* .. Array Arguments .. 129 INTEGER NVAL( NN ) 130 REAL S_WORK_CLANGE( * ) 131 COMPLEX A( LDA, * ), ARF( * ), B1( LDA, * ), 132 + B2( LDA, * ) 133 COMPLEX C_WORK_CGEQRF( * ), TAU( * ) 134* .. 135* 136* ===================================================================== 137* .. 138* .. Parameters .. 139 COMPLEX ZERO, ONE 140 PARAMETER ( ZERO = ( 0.0E+0, 0.0E+0 ) , 141 + ONE = ( 1.0E+0, 0.0E+0 ) ) 142 INTEGER NTESTS 143 PARAMETER ( NTESTS = 1 ) 144* .. 145* .. Local Scalars .. 146 CHARACTER UPLO, CFORM, DIAG, TRANS, SIDE 147 INTEGER I, IFORM, IIM, IIN, INFO, IUPLO, J, M, N, NA, 148 + NFAIL, NRUN, ISIDE, IDIAG, IALPHA, ITRANS 149 COMPLEX ALPHA 150 REAL EPS 151* .. 152* .. Local Arrays .. 153 CHARACTER UPLOS( 2 ), FORMS( 2 ), TRANSS( 2 ), 154 + DIAGS( 2 ), SIDES( 2 ) 155 INTEGER ISEED( 4 ), ISEEDY( 4 ) 156 REAL RESULT( NTESTS ) 157* .. 158* .. External Functions .. 159 REAL SLAMCH, CLANGE 160 COMPLEX CLARND 161 EXTERNAL SLAMCH, CLARND, CLANGE 162* .. 163* .. External Subroutines .. 164 EXTERNAL CTRTTF, CGEQRF, CGEQLF, CTFSM, CTRSM 165* .. 166* .. Intrinsic Functions .. 167 INTRINSIC MAX, SQRT 168* .. 169* .. Scalars in Common .. 170 CHARACTER*32 SRNAMT 171* .. 172* .. Common blocks .. 173 COMMON / SRNAMC / SRNAMT 174* .. 175* .. Data statements .. 176 DATA ISEEDY / 1988, 1989, 1990, 1991 / 177 DATA UPLOS / 'U', 'L' / 178 DATA FORMS / 'N', 'C' / 179 DATA SIDES / 'L', 'R' / 180 DATA TRANSS / 'N', 'C' / 181 DATA DIAGS / 'N', 'U' / 182* .. 183* .. Executable Statements .. 184* 185* Initialize constants and the random number seed. 186* 187 NRUN = 0 188 NFAIL = 0 189 INFO = 0 190 DO 10 I = 1, 4 191 ISEED( I ) = ISEEDY( I ) 192 10 CONTINUE 193 EPS = SLAMCH( 'Precision' ) 194* 195 DO 170 IIM = 1, NN 196* 197 M = NVAL( IIM ) 198* 199 DO 160 IIN = 1, NN 200* 201 N = NVAL( IIN ) 202* 203 DO 150 IFORM = 1, 2 204* 205 CFORM = FORMS( IFORM ) 206* 207 DO 140 IUPLO = 1, 2 208* 209 UPLO = UPLOS( IUPLO ) 210* 211 DO 130 ISIDE = 1, 2 212* 213 SIDE = SIDES( ISIDE ) 214* 215 DO 120 ITRANS = 1, 2 216* 217 TRANS = TRANSS( ITRANS ) 218* 219 DO 110 IDIAG = 1, 2 220* 221 DIAG = DIAGS( IDIAG ) 222* 223 DO 100 IALPHA = 1, 3 224* 225 IF ( IALPHA.EQ. 1) THEN 226 ALPHA = ZERO 227 ELSE IF ( IALPHA.EQ. 2) THEN 228 ALPHA = ONE 229 ELSE 230 ALPHA = CLARND( 4, ISEED ) 231 END IF 232* 233* All the parameters are set: 234* CFORM, SIDE, UPLO, TRANS, DIAG, M, N, 235* and ALPHA 236* READY TO TEST! 237* 238 NRUN = NRUN + 1 239* 240 IF ( ISIDE.EQ.1 ) THEN 241* 242* The case ISIDE.EQ.1 is when SIDE.EQ.'L' 243* -> A is M-by-M ( B is M-by-N ) 244* 245 NA = M 246* 247 ELSE 248* 249* The case ISIDE.EQ.2 is when SIDE.EQ.'R' 250* -> A is N-by-N ( B is M-by-N ) 251* 252 NA = N 253* 254 END IF 255* 256* Generate A our NA--by--NA triangular 257* matrix. 258* Our test is based on forward error so we 259* do want A to be well conditioned! To get 260* a well-conditioned triangular matrix, we 261* take the R factor of the QR/LQ factorization 262* of a random matrix. 263* 264 DO J = 1, NA 265 DO I = 1, NA 266 A( I, J) = CLARND( 4, ISEED ) 267 END DO 268 END DO 269* 270 IF ( IUPLO.EQ.1 ) THEN 271* 272* The case IUPLO.EQ.1 is when SIDE.EQ.'U' 273* -> QR factorization. 274* 275 SRNAMT = 'CGEQRF' 276 CALL CGEQRF( NA, NA, A, LDA, TAU, 277 + C_WORK_CGEQRF, LDA, 278 + INFO ) 279 ELSE 280* 281* The case IUPLO.EQ.2 is when SIDE.EQ.'L' 282* -> QL factorization. 283* 284 SRNAMT = 'CGELQF' 285 CALL CGELQF( NA, NA, A, LDA, TAU, 286 + C_WORK_CGEQRF, LDA, 287 + INFO ) 288 END IF 289* 290* After the QR factorization, the diagonal 291* of A is made of real numbers, we multiply 292* by a random complex number of absolute 293* value 1.0E+00. 294* 295 DO J = 1, NA 296 A( J, J) = A(J,J) * CLARND( 5, ISEED ) 297 END DO 298* 299* Store a copy of A in RFP format (in ARF). 300* 301 SRNAMT = 'CTRTTF' 302 CALL CTRTTF( CFORM, UPLO, NA, A, LDA, ARF, 303 + INFO ) 304* 305* Generate B1 our M--by--N right-hand side 306* and store a copy in B2. 307* 308 DO J = 1, N 309 DO I = 1, M 310 B1( I, J) = CLARND( 4, ISEED ) 311 B2( I, J) = B1( I, J) 312 END DO 313 END DO 314* 315* Solve op( A ) X = B or X op( A ) = B 316* with CTRSM 317* 318 SRNAMT = 'CTRSM' 319 CALL CTRSM( SIDE, UPLO, TRANS, DIAG, M, N, 320 + ALPHA, A, LDA, B1, LDA ) 321* 322* Solve op( A ) X = B or X op( A ) = B 323* with CTFSM 324* 325 SRNAMT = 'CTFSM' 326 CALL CTFSM( CFORM, SIDE, UPLO, TRANS, 327 + DIAG, M, N, ALPHA, ARF, B2, 328 + LDA ) 329* 330* Check that the result agrees. 331* 332 DO J = 1, N 333 DO I = 1, M 334 B1( I, J) = B2( I, J ) - B1( I, J ) 335 END DO 336 END DO 337* 338 RESULT(1) = CLANGE( 'I', M, N, B1, LDA, 339 + S_WORK_CLANGE ) 340* 341 RESULT(1) = RESULT(1) / SQRT( EPS ) 342 + / MAX ( MAX( M, N), 1 ) 343* 344 IF( RESULT(1).GE.THRESH ) THEN 345 IF( NFAIL.EQ.0 ) THEN 346 WRITE( NOUT, * ) 347 WRITE( NOUT, FMT = 9999 ) 348 END IF 349 WRITE( NOUT, FMT = 9997 ) 'CTFSM', 350 + CFORM, SIDE, UPLO, TRANS, DIAG, M, 351 + N, RESULT(1) 352 NFAIL = NFAIL + 1 353 END IF 354* 355 100 CONTINUE 356 110 CONTINUE 357 120 CONTINUE 358 130 CONTINUE 359 140 CONTINUE 360 150 CONTINUE 361 160 CONTINUE 362 170 CONTINUE 363* 364* Print a summary of the results. 365* 366 IF ( NFAIL.EQ.0 ) THEN 367 WRITE( NOUT, FMT = 9996 ) 'CTFSM', NRUN 368 ELSE 369 WRITE( NOUT, FMT = 9995 ) 'CTFSM', NFAIL, NRUN 370 END IF 371* 372 9999 FORMAT( 1X, ' *** Error(s) or Failure(s) while testing CTFSM 373 + ***') 374 9997 FORMAT( 1X, ' Failure in ',A5,', CFORM=''',A1,''',', 375 + ' SIDE=''',A1,''',',' UPLO=''',A1,''',',' TRANS=''',A1,''',', 376 + ' DIAG=''',A1,''',',' M=',I3,', N =', I3,', test=',G12.5) 377 9996 FORMAT( 1X, 'All tests for ',A5,' auxiliary routine passed the ', 378 + 'threshold ( ',I5,' tests run)') 379 9995 FORMAT( 1X, A6, ' auxiliary routine: ',I5,' out of ',I5, 380 + ' tests failed to pass the threshold') 381* 382 RETURN 383* 384* End of CDRVRF3 385* 386 END 387