 |
LAPACK 3.3.1
Linear Algebra PACKage
|
|
LAPACK 3.3.1
Linear Algebra PACKage
|
00001 SUBROUTINE ZDRVRF4( NOUT, NN, NVAL, THRESH, C1, C2, LDC, CRF, A, 00002 + LDA, D_WORK_ZLANGE ) 00003 * 00004 * -- LAPACK test routine (version 3.2.0) -- 00005 * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. 00006 * November 2008 00007 * 00008 * .. Scalar Arguments .. 00009 INTEGER LDA, LDC, NN, NOUT 00010 DOUBLE PRECISION THRESH 00011 * .. 00012 * .. Array Arguments .. 00013 INTEGER NVAL( NN ) 00014 DOUBLE PRECISION D_WORK_ZLANGE( * ) 00015 COMPLEX*16 A( LDA, * ), C1( LDC, * ), C2( LDC, *), 00016 + CRF( * ) 00017 * .. 00018 * 00019 * Purpose 00020 * ======= 00021 * 00022 * ZDRVRF4 tests the LAPACK RFP routines: 00023 * ZHFRK 00024 * 00025 * Arguments 00026 * ========= 00027 * 00028 * NOUT (input) INTEGER 00029 * The unit number for output. 00030 * 00031 * NN (input) INTEGER 00032 * The number of values of N contained in the vector NVAL. 00033 * 00034 * NVAL (input) INTEGER array, dimension (NN) 00035 * The values of the matrix dimension N. 00036 * 00037 * THRESH (input) DOUBLE PRECISION 00038 * The threshold value for the test ratios. A result is 00039 * included in the output file if RESULT >= THRESH. To have 00040 * every test ratio printed, use THRESH = 0. 00041 * 00042 * C1 (workspace) COMPLEX*16 array, dimension (LDC,NMAX) 00043 * 00044 * C2 (workspace) COMPLEX*16 array, dimension (LDC,NMAX) 00045 * 00046 * LDC (input) INTEGER 00047 * The leading dimension of the array A. LDA >= max(1,NMAX). 00048 * 00049 * CRF (workspace) COMPLEX*16 array, dimension ((NMAX*(NMAX+1))/2). 00050 * 00051 * A (workspace) COMPLEX*16 array, dimension (LDA,NMAX) 00052 * 00053 * LDA (input) INTEGER 00054 * The leading dimension of the array A. LDA >= max(1,NMAX). 00055 * 00056 * D_WORK_ZLANGE (workspace) DOUBLE PRECISION array, dimension (NMAX) 00057 * 00058 * ===================================================================== 00059 * .. 00060 * .. Parameters .. 00061 DOUBLE PRECISION ZERO, ONE 00062 PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) 00063 INTEGER NTESTS 00064 PARAMETER ( NTESTS = 1 ) 00065 * .. 00066 * .. Local Scalars .. 00067 CHARACTER UPLO, CFORM, TRANS 00068 INTEGER I, IFORM, IIK, IIN, INFO, IUPLO, J, K, N, 00069 + NFAIL, NRUN, IALPHA, ITRANS 00070 DOUBLE PRECISION ALPHA, BETA, EPS, NORMA, NORMC 00071 * .. 00072 * .. Local Arrays .. 00073 CHARACTER UPLOS( 2 ), FORMS( 2 ), TRANSS( 2 ) 00074 INTEGER ISEED( 4 ), ISEEDY( 4 ) 00075 DOUBLE PRECISION RESULT( NTESTS ) 00076 * .. 00077 * .. External Functions .. 00078 DOUBLE PRECISION DLAMCH, DLARND, ZLANGE 00079 COMPLEX*16 ZLARND 00080 EXTERNAL DLAMCH, DLARND, ZLANGE, ZLARND 00081 * .. 00082 * .. External Subroutines .. 00083 EXTERNAL ZHERK, ZHFRK, ZTFTTR, ZTRTTF 00084 * .. 00085 * .. Intrinsic Functions .. 00086 INTRINSIC DABS, MAX 00087 * .. 00088 * .. Scalars in Common .. 00089 CHARACTER*32 SRNAMT 00090 * .. 00091 * .. Common blocks .. 00092 COMMON / SRNAMC / SRNAMT 00093 * .. 00094 * .. Data statements .. 00095 DATA ISEEDY / 1988, 1989, 1990, 1991 / 00096 DATA UPLOS / 'U', 'L' / 00097 DATA FORMS / 'N', 'C' / 00098 DATA TRANSS / 'N', 'C' / 00099 * .. 00100 * .. Executable Statements .. 00101 * 00102 * Initialize constants and the random number seed. 00103 * 00104 NRUN = 0 00105 NFAIL = 0 00106 INFO = 0 00107 DO 10 I = 1, 4 00108 ISEED( I ) = ISEEDY( I ) 00109 10 CONTINUE 00110 EPS = DLAMCH( 'Precision' ) 00111 * 00112 DO 150 IIN = 1, NN 00113 * 00114 N = NVAL( IIN ) 00115 * 00116 DO 140 IIK = 1, NN 00117 * 00118 K = NVAL( IIN ) 00119 * 00120 DO 130 IFORM = 1, 2 00121 * 00122 CFORM = FORMS( IFORM ) 00123 * 00124 DO 120 IUPLO = 1, 2 00125 * 00126 UPLO = UPLOS( IUPLO ) 00127 * 00128 DO 110 ITRANS = 1, 2 00129 * 00130 TRANS = TRANSS( ITRANS ) 00131 * 00132 DO 100 IALPHA = 1, 4 00133 * 00134 IF ( IALPHA.EQ. 1) THEN 00135 ALPHA = ZERO 00136 BETA = ZERO 00137 ELSE IF ( IALPHA.EQ. 1) THEN 00138 ALPHA = ONE 00139 BETA = ZERO 00140 ELSE IF ( IALPHA.EQ. 1) THEN 00141 ALPHA = ZERO 00142 BETA = ONE 00143 ELSE 00144 ALPHA = DLARND( 2, ISEED ) 00145 BETA = DLARND( 2, ISEED ) 00146 END IF 00147 * 00148 * All the parameters are set: 00149 * CFORM, UPLO, TRANS, M, N, 00150 * ALPHA, and BETA 00151 * READY TO TEST! 00152 * 00153 NRUN = NRUN + 1 00154 * 00155 IF ( ITRANS.EQ.1 ) THEN 00156 * 00157 * In this case we are NOTRANS, so A is N-by-K 00158 * 00159 DO J = 1, K 00160 DO I = 1, N 00161 A( I, J) = ZLARND( 4, ISEED ) 00162 END DO 00163 END DO 00164 * 00165 NORMA = ZLANGE( 'I', N, K, A, LDA, 00166 + D_WORK_ZLANGE ) 00167 * 00168 ELSE 00169 * 00170 * In this case we are TRANS, so A is K-by-N 00171 * 00172 DO J = 1,N 00173 DO I = 1, K 00174 A( I, J) = ZLARND( 4, ISEED ) 00175 END DO 00176 END DO 00177 * 00178 NORMA = ZLANGE( 'I', K, N, A, LDA, 00179 + D_WORK_ZLANGE ) 00180 * 00181 END IF 00182 * 00183 * 00184 * Generate C1 our N--by--N Hermitian matrix. 00185 * Make sure C2 has the same upper/lower part, 00186 * (the one that we do not touch), so 00187 * copy the initial C1 in C2 in it. 00188 * 00189 DO J = 1, N 00190 DO I = 1, N 00191 C1( I, J) = ZLARND( 4, ISEED ) 00192 C2(I,J) = C1(I,J) 00193 END DO 00194 END DO 00195 * 00196 * (See comment later on for why we use ZLANGE and 00197 * not ZLANHE for C1.) 00198 * 00199 NORMC = ZLANGE( 'I', N, N, C1, LDC, 00200 + D_WORK_ZLANGE ) 00201 * 00202 SRNAMT = 'ZTRTTF' 00203 CALL ZTRTTF( CFORM, UPLO, N, C1, LDC, CRF, 00204 + INFO ) 00205 * 00206 * call zherk the BLAS routine -> gives C1 00207 * 00208 SRNAMT = 'ZHERK ' 00209 CALL ZHERK( UPLO, TRANS, N, K, ALPHA, A, LDA, 00210 + BETA, C1, LDC ) 00211 * 00212 * call zhfrk the RFP routine -> gives CRF 00213 * 00214 SRNAMT = 'ZHFRK ' 00215 CALL ZHFRK( CFORM, UPLO, TRANS, N, K, ALPHA, A, 00216 + LDA, BETA, CRF ) 00217 * 00218 * convert CRF in full format -> gives C2 00219 * 00220 SRNAMT = 'ZTFTTR' 00221 CALL ZTFTTR( CFORM, UPLO, N, CRF, C2, LDC, 00222 + INFO ) 00223 * 00224 * compare C1 and C2 00225 * 00226 DO J = 1, N 00227 DO I = 1, N 00228 C1(I,J) = C1(I,J)-C2(I,J) 00229 END DO 00230 END DO 00231 * 00232 * Yes, C1 is Hermitian so we could call ZLANHE, 00233 * but we want to check the upper part that is 00234 * supposed to be unchanged and the diagonal that 00235 * is supposed to be real -> ZLANGE 00236 * 00237 RESULT(1) = ZLANGE( 'I', N, N, C1, LDC, 00238 + D_WORK_ZLANGE ) 00239 RESULT(1) = RESULT(1) 00240 + / MAX( DABS( ALPHA ) * NORMA * NORMA 00241 + + DABS( BETA ) * NORMC, ONE ) 00242 + / MAX( N , 1 ) / EPS 00243 * 00244 IF( RESULT(1).GE.THRESH ) THEN 00245 IF( NFAIL.EQ.0 ) THEN 00246 WRITE( NOUT, * ) 00247 WRITE( NOUT, FMT = 9999 ) 00248 END IF 00249 WRITE( NOUT, FMT = 9997 ) 'ZHFRK', 00250 + CFORM, UPLO, TRANS, N, K, RESULT(1) 00251 NFAIL = NFAIL + 1 00252 END IF 00253 * 00254 100 CONTINUE 00255 110 CONTINUE 00256 120 CONTINUE 00257 130 CONTINUE 00258 140 CONTINUE 00259 150 CONTINUE 00260 * 00261 * Print a summary of the results. 00262 * 00263 IF ( NFAIL.EQ.0 ) THEN 00264 WRITE( NOUT, FMT = 9996 ) 'ZHFRK', NRUN 00265 ELSE 00266 WRITE( NOUT, FMT = 9995 ) 'ZHFRK', NFAIL, NRUN 00267 END IF 00268 * 00269 9999 FORMAT( 1X, 00270 ' *** Error(s) or Failure(s) while testing ZHFRK + ***') 00271 9997 FORMAT( 1X, ' Failure in ',A5,', CFORM=''',A1,''',', 00272 + ' UPLO=''',A1,''',',' TRANS=''',A1,''',', ' N=',I3,', K =', I3, 00273 + ', test=',G12.5) 00274 9996 FORMAT( 1X, 'All tests for ',A5,' auxiliary routine passed the ', 00275 + 'threshold (',I5,' tests run)') 00276 9995 FORMAT( 1X, A6, ' auxiliary routine:',I5,' out of ',I5, 00277 + ' tests failed to pass the threshold') 00278 * 00279 RETURN 00280 * 00281 * End of ZDRVRF4 00282 * 00283 END
1.7.3 
