1*> \brief \b ZDRVRF4 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 ZDRVRF4( NOUT, NN, NVAL, THRESH, C1, C2, LDC, CRF, A, 12* + LDA, D_WORK_ZLANGE ) 13* 14* .. Scalar Arguments .. 15* INTEGER LDA, LDC, 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, * ), C1( LDC, * ), C2( LDC, *), 22* + CRF( * ) 23* .. 24* 25* 26*> \par Purpose: 27* ============= 28*> 29*> \verbatim 30*> 31*> ZDRVRF4 tests the LAPACK RFP routines: 32*> ZHFRK 33*> \endverbatim 34* 35* Arguments: 36* ========== 37* 38*> \param[in] NOUT 39*> \verbatim 40*> NOUT is INTEGER 41*> The unit number for output. 42*> \endverbatim 43*> 44*> \param[in] NN 45*> \verbatim 46*> NN is INTEGER 47*> The number of values of N contained in the vector NVAL. 48*> \endverbatim 49*> 50*> \param[in] NVAL 51*> \verbatim 52*> NVAL is INTEGER array, dimension (NN) 53*> The values of the matrix dimension N. 54*> \endverbatim 55*> 56*> \param[in] THRESH 57*> \verbatim 58*> THRESH is DOUBLE PRECISION 59*> The threshold value for the test ratios. A result is 60*> included in the output file if RESULT >= THRESH. To have 61*> every test ratio printed, use THRESH = 0. 62*> \endverbatim 63*> 64*> \param[out] C1 65*> \verbatim 66*> C1 is COMPLEX*16 array, dimension (LDC,NMAX) 67*> \endverbatim 68*> 69*> \param[out] C2 70*> \verbatim 71*> C2 is COMPLEX*16 array, dimension (LDC,NMAX) 72*> \endverbatim 73*> 74*> \param[in] LDC 75*> \verbatim 76*> LDC is INTEGER 77*> The leading dimension of the array A. LDA >= max(1,NMAX). 78*> \endverbatim 79*> 80*> \param[out] CRF 81*> \verbatim 82*> CRF is COMPLEX*16 array, dimension ((NMAX*(NMAX+1))/2). 83*> \endverbatim 84*> 85*> \param[out] A 86*> \verbatim 87*> A is COMPLEX*16 array, dimension (LDA,NMAX) 88*> \endverbatim 89*> 90*> \param[in] LDA 91*> \verbatim 92*> LDA is INTEGER 93*> The leading dimension of the array A. LDA >= max(1,NMAX). 94*> \endverbatim 95*> 96*> \param[out] D_WORK_ZLANGE 97*> \verbatim 98*> D_WORK_ZLANGE is DOUBLE PRECISION array, dimension (NMAX) 99*> \endverbatim 100* 101* Authors: 102* ======== 103* 104*> \author Univ. of Tennessee 105*> \author Univ. of California Berkeley 106*> \author Univ. of Colorado Denver 107*> \author NAG Ltd. 108* 109*> \date November 2011 110* 111*> \ingroup complex16_lin 112* 113* ===================================================================== 114 SUBROUTINE ZDRVRF4( NOUT, NN, NVAL, THRESH, C1, C2, LDC, CRF, A, 115 + LDA, D_WORK_ZLANGE ) 116* 117* -- LAPACK test routine (version 3.4.0) -- 118* -- LAPACK is a software package provided by Univ. of Tennessee, -- 119* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- 120* November 2011 121* 122* .. Scalar Arguments .. 123 INTEGER LDA, LDC, NN, NOUT 124 DOUBLE PRECISION THRESH 125* .. 126* .. Array Arguments .. 127 INTEGER NVAL( NN ) 128 DOUBLE PRECISION D_WORK_ZLANGE( * ) 129 COMPLEX*16 A( LDA, * ), C1( LDC, * ), C2( LDC, *), 130 + CRF( * ) 131* .. 132* 133* ===================================================================== 134* .. 135* .. Parameters .. 136 DOUBLE PRECISION ZERO, ONE 137 PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) 138 INTEGER NTESTS 139 PARAMETER ( NTESTS = 1 ) 140* .. 141* .. Local Scalars .. 142 CHARACTER UPLO, CFORM, TRANS 143 INTEGER I, IFORM, IIK, IIN, INFO, IUPLO, J, K, N, 144 + NFAIL, NRUN, IALPHA, ITRANS 145 DOUBLE PRECISION ALPHA, BETA, EPS, NORMA, NORMC 146* .. 147* .. Local Arrays .. 148 CHARACTER UPLOS( 2 ), FORMS( 2 ), TRANSS( 2 ) 149 INTEGER ISEED( 4 ), ISEEDY( 4 ) 150 DOUBLE PRECISION RESULT( NTESTS ) 151* .. 152* .. External Functions .. 153 DOUBLE PRECISION DLAMCH, DLARND, ZLANGE 154 COMPLEX*16 ZLARND 155 EXTERNAL DLAMCH, DLARND, ZLANGE, ZLARND 156* .. 157* .. External Subroutines .. 158 EXTERNAL ZHERK, ZHFRK, ZTFTTR, ZTRTTF 159* .. 160* .. Intrinsic Functions .. 161 INTRINSIC DABS, MAX 162* .. 163* .. Scalars in Common .. 164 CHARACTER*32 SRNAMT 165* .. 166* .. Common blocks .. 167 COMMON / SRNAMC / SRNAMT 168* .. 169* .. Data statements .. 170 DATA ISEEDY / 1988, 1989, 1990, 1991 / 171 DATA UPLOS / 'U', 'L' / 172 DATA FORMS / 'N', 'C' / 173 DATA TRANSS / 'N', 'C' / 174* .. 175* .. Executable Statements .. 176* 177* Initialize constants and the random number seed. 178* 179 NRUN = 0 180 NFAIL = 0 181 INFO = 0 182 DO 10 I = 1, 4 183 ISEED( I ) = ISEEDY( I ) 184 10 CONTINUE 185 EPS = DLAMCH( 'Precision' ) 186* 187 DO 150 IIN = 1, NN 188* 189 N = NVAL( IIN ) 190* 191 DO 140 IIK = 1, NN 192* 193 K = NVAL( IIN ) 194* 195 DO 130 IFORM = 1, 2 196* 197 CFORM = FORMS( IFORM ) 198* 199 DO 120 IUPLO = 1, 2 200* 201 UPLO = UPLOS( IUPLO ) 202* 203 DO 110 ITRANS = 1, 2 204* 205 TRANS = TRANSS( ITRANS ) 206* 207 DO 100 IALPHA = 1, 4 208* 209 IF ( IALPHA.EQ. 1) THEN 210 ALPHA = ZERO 211 BETA = ZERO 212 ELSE IF ( IALPHA.EQ. 1) THEN 213 ALPHA = ONE 214 BETA = ZERO 215 ELSE IF ( IALPHA.EQ. 1) THEN 216 ALPHA = ZERO 217 BETA = ONE 218 ELSE 219 ALPHA = DLARND( 2, ISEED ) 220 BETA = DLARND( 2, ISEED ) 221 END IF 222* 223* All the parameters are set: 224* CFORM, UPLO, TRANS, M, N, 225* ALPHA, and BETA 226* READY TO TEST! 227* 228 NRUN = NRUN + 1 229* 230 IF ( ITRANS.EQ.1 ) THEN 231* 232* In this case we are NOTRANS, so A is N-by-K 233* 234 DO J = 1, K 235 DO I = 1, N 236 A( I, J) = ZLARND( 4, ISEED ) 237 END DO 238 END DO 239* 240 NORMA = ZLANGE( 'I', N, K, A, LDA, 241 + D_WORK_ZLANGE ) 242* 243 ELSE 244* 245* In this case we are TRANS, so A is K-by-N 246* 247 DO J = 1,N 248 DO I = 1, K 249 A( I, J) = ZLARND( 4, ISEED ) 250 END DO 251 END DO 252* 253 NORMA = ZLANGE( 'I', K, N, A, LDA, 254 + D_WORK_ZLANGE ) 255* 256 END IF 257* 258* 259* Generate C1 our N--by--N Hermitian matrix. 260* Make sure C2 has the same upper/lower part, 261* (the one that we do not touch), so 262* copy the initial C1 in C2 in it. 263* 264 DO J = 1, N 265 DO I = 1, N 266 C1( I, J) = ZLARND( 4, ISEED ) 267 C2(I,J) = C1(I,J) 268 END DO 269 END DO 270* 271* (See comment later on for why we use ZLANGE and 272* not ZLANHE for C1.) 273* 274 NORMC = ZLANGE( 'I', N, N, C1, LDC, 275 + D_WORK_ZLANGE ) 276* 277 SRNAMT = 'ZTRTTF' 278 CALL ZTRTTF( CFORM, UPLO, N, C1, LDC, CRF, 279 + INFO ) 280* 281* call zherk the BLAS routine -> gives C1 282* 283 SRNAMT = 'ZHERK ' 284 CALL ZHERK( UPLO, TRANS, N, K, ALPHA, A, LDA, 285 + BETA, C1, LDC ) 286* 287* call zhfrk the RFP routine -> gives CRF 288* 289 SRNAMT = 'ZHFRK ' 290 CALL ZHFRK( CFORM, UPLO, TRANS, N, K, ALPHA, A, 291 + LDA, BETA, CRF ) 292* 293* convert CRF in full format -> gives C2 294* 295 SRNAMT = 'ZTFTTR' 296 CALL ZTFTTR( CFORM, UPLO, N, CRF, C2, LDC, 297 + INFO ) 298* 299* compare C1 and C2 300* 301 DO J = 1, N 302 DO I = 1, N 303 C1(I,J) = C1(I,J)-C2(I,J) 304 END DO 305 END DO 306* 307* Yes, C1 is Hermitian so we could call ZLANHE, 308* but we want to check the upper part that is 309* supposed to be unchanged and the diagonal that 310* is supposed to be real -> ZLANGE 311* 312 RESULT(1) = ZLANGE( 'I', N, N, C1, LDC, 313 + D_WORK_ZLANGE ) 314 RESULT(1) = RESULT(1) 315 + / MAX( DABS( ALPHA ) * NORMA * NORMA 316 + + DABS( BETA ) * NORMC, ONE ) 317 + / MAX( N , 1 ) / EPS 318* 319 IF( RESULT(1).GE.THRESH ) THEN 320 IF( NFAIL.EQ.0 ) THEN 321 WRITE( NOUT, * ) 322 WRITE( NOUT, FMT = 9999 ) 323 END IF 324 WRITE( NOUT, FMT = 9997 ) 'ZHFRK', 325 + CFORM, UPLO, TRANS, N, K, RESULT(1) 326 NFAIL = NFAIL + 1 327 END IF 328* 329 100 CONTINUE 330 110 CONTINUE 331 120 CONTINUE 332 130 CONTINUE 333 140 CONTINUE 334 150 CONTINUE 335* 336* Print a summary of the results. 337* 338 IF ( NFAIL.EQ.0 ) THEN 339 WRITE( NOUT, FMT = 9996 ) 'ZHFRK', NRUN 340 ELSE 341 WRITE( NOUT, FMT = 9995 ) 'ZHFRK', NFAIL, NRUN 342 END IF 343* 344 9999 FORMAT( 1X, ' *** Error(s) or Failure(s) while testing ZHFRK 345 + ***') 346 9997 FORMAT( 1X, ' Failure in ',A5,', CFORM=''',A1,''',', 347 + ' UPLO=''',A1,''',',' TRANS=''',A1,''',', ' N=',I3,', K =', I3, 348 + ', test=',G12.5) 349 9996 FORMAT( 1X, 'All tests for ',A5,' auxiliary routine passed the ', 350 + 'threshold ( ',I6,' tests run)') 351 9995 FORMAT( 1X, A6, ' auxiliary routine: ',I6,' out of ',I6, 352 + ' tests failed to pass the threshold') 353* 354 RETURN 355* 356* End of ZDRVRF4 357* 358 END 359