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