|
LAPACK 3.3.0
|
|
LAPACK 3.3.0
|
00001 SUBROUTINE ZCHKGT( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR, 00002 $ A, AF, B, X, XACT, WORK, RWORK, IWORK, NOUT ) 00003 * 00004 * -- LAPACK test routine (version 3.1) -- 00005 * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. 00006 * November 2006 00007 * 00008 * .. Scalar Arguments .. 00009 LOGICAL TSTERR 00010 INTEGER NN, NNS, NOUT 00011 DOUBLE PRECISION THRESH 00012 * .. 00013 * .. Array Arguments .. 00014 LOGICAL DOTYPE( * ) 00015 INTEGER IWORK( * ), NSVAL( * ), NVAL( * ) 00016 DOUBLE PRECISION RWORK( * ) 00017 COMPLEX*16 A( * ), AF( * ), B( * ), WORK( * ), X( * ), 00018 $ XACT( * ) 00019 * .. 00020 * 00021 * Purpose 00022 * ======= 00023 * 00024 * ZCHKGT tests ZGTTRF, -TRS, -RFS, and -CON 00025 * 00026 * Arguments 00027 * ========= 00028 * 00029 * DOTYPE (input) LOGICAL array, dimension (NTYPES) 00030 * The matrix types to be used for testing. Matrices of type j 00031 * (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) = 00032 * .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used. 00033 * 00034 * NN (input) INTEGER 00035 * The number of values of N contained in the vector NVAL. 00036 * 00037 * NVAL (input) INTEGER array, dimension (NN) 00038 * The values of the matrix dimension N. 00039 * 00040 * NNS (input) INTEGER 00041 * The number of values of NRHS contained in the vector NSVAL. 00042 * 00043 * NSVAL (input) INTEGER array, dimension (NNS) 00044 * The values of the number of right hand sides NRHS. 00045 * 00046 * THRESH (input) DOUBLE PRECISION 00047 * The threshold value for the test ratios. A result is 00048 * included in the output file if RESULT >= THRESH. To have 00049 * every test ratio printed, use THRESH = 0. 00050 * 00051 * TSTERR (input) LOGICAL 00052 * Flag that indicates whether error exits are to be tested. 00053 * 00054 * A (workspace) COMPLEX*16 array, dimension (NMAX*4) 00055 * 00056 * AF (workspace) COMPLEX*16 array, dimension (NMAX*4) 00057 * 00058 * B (workspace) COMPLEX*16 array, dimension (NMAX*NSMAX) 00059 * where NSMAX is the largest entry in NSVAL. 00060 * 00061 * X (workspace) COMPLEX*16 array, dimension (NMAX*NSMAX) 00062 * 00063 * XACT (workspace) COMPLEX*16 array, dimension (NMAX*NSMAX) 00064 * 00065 * WORK (workspace) COMPLEX*16 array, dimension 00066 * (NMAX*max(3,NSMAX)) 00067 * 00068 * RWORK (workspace) DOUBLE PRECISION array, dimension 00069 * (max(NMAX)+2*NSMAX) 00070 * 00071 * IWORK (workspace) INTEGER array, dimension (NMAX) 00072 * 00073 * NOUT (input) INTEGER 00074 * The unit number for output. 00075 * 00076 * ===================================================================== 00077 * 00078 * .. Parameters .. 00079 DOUBLE PRECISION ONE, ZERO 00080 PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) 00081 INTEGER NTYPES 00082 PARAMETER ( NTYPES = 12 ) 00083 INTEGER NTESTS 00084 PARAMETER ( NTESTS = 7 ) 00085 * .. 00086 * .. Local Scalars .. 00087 LOGICAL TRFCON, ZEROT 00088 CHARACTER DIST, NORM, TRANS, TYPE 00089 CHARACTER*3 PATH 00090 INTEGER I, IMAT, IN, INFO, IRHS, ITRAN, IX, IZERO, J, 00091 $ K, KL, KOFF, KU, LDA, M, MODE, N, NERRS, NFAIL, 00092 $ NIMAT, NRHS, NRUN 00093 DOUBLE PRECISION AINVNM, ANORM, COND, RCOND, RCONDC, RCONDI, 00094 $ RCONDO 00095 * .. 00096 * .. Local Arrays .. 00097 CHARACTER TRANSS( 3 ) 00098 INTEGER ISEED( 4 ), ISEEDY( 4 ) 00099 DOUBLE PRECISION RESULT( NTESTS ) 00100 COMPLEX*16 Z( 3 ) 00101 * .. 00102 * .. External Functions .. 00103 DOUBLE PRECISION DGET06, DZASUM, ZLANGT 00104 EXTERNAL DGET06, DZASUM, ZLANGT 00105 * .. 00106 * .. External Subroutines .. 00107 EXTERNAL ALAERH, ALAHD, ALASUM, ZCOPY, ZDSCAL, ZERRGE, 00108 $ ZGET04, ZGTCON, ZGTRFS, ZGTT01, ZGTT02, ZGTT05, 00109 $ ZGTTRF, ZGTTRS, ZLACPY, ZLAGTM, ZLARNV, ZLATB4, 00110 $ ZLATMS 00111 * .. 00112 * .. Intrinsic Functions .. 00113 INTRINSIC MAX 00114 * .. 00115 * .. Scalars in Common .. 00116 LOGICAL LERR, OK 00117 CHARACTER*32 SRNAMT 00118 INTEGER INFOT, NUNIT 00119 * .. 00120 * .. Common blocks .. 00121 COMMON / INFOC / INFOT, NUNIT, OK, LERR 00122 COMMON / SRNAMC / SRNAMT 00123 * .. 00124 * .. Data statements .. 00125 DATA ISEEDY / 0, 0, 0, 1 / , TRANSS / 'N', 'T', 00126 $ 'C' / 00127 * .. 00128 * .. Executable Statements .. 00129 * 00130 PATH( 1: 1 ) = 'Zomplex precision' 00131 PATH( 2: 3 ) = 'GT' 00132 NRUN = 0 00133 NFAIL = 0 00134 NERRS = 0 00135 DO 10 I = 1, 4 00136 ISEED( I ) = ISEEDY( I ) 00137 10 CONTINUE 00138 * 00139 * Test the error exits 00140 * 00141 IF( TSTERR ) 00142 $ CALL ZERRGE( PATH, NOUT ) 00143 INFOT = 0 00144 * 00145 DO 110 IN = 1, NN 00146 * 00147 * Do for each value of N in NVAL. 00148 * 00149 N = NVAL( IN ) 00150 M = MAX( N-1, 0 ) 00151 LDA = MAX( 1, N ) 00152 NIMAT = NTYPES 00153 IF( N.LE.0 ) 00154 $ NIMAT = 1 00155 * 00156 DO 100 IMAT = 1, NIMAT 00157 * 00158 * Do the tests only if DOTYPE( IMAT ) is true. 00159 * 00160 IF( .NOT.DOTYPE( IMAT ) ) 00161 $ GO TO 100 00162 * 00163 * Set up parameters with ZLATB4. 00164 * 00165 CALL ZLATB4( PATH, IMAT, N, N, TYPE, KL, KU, ANORM, MODE, 00166 $ COND, DIST ) 00167 * 00168 ZEROT = IMAT.GE.8 .AND. IMAT.LE.10 00169 IF( IMAT.LE.6 ) THEN 00170 * 00171 * Types 1-6: generate matrices of known condition number. 00172 * 00173 KOFF = MAX( 2-KU, 3-MAX( 1, N ) ) 00174 SRNAMT = 'ZLATMS' 00175 CALL ZLATMS( N, N, DIST, ISEED, TYPE, RWORK, MODE, COND, 00176 $ ANORM, KL, KU, 'Z', AF( KOFF ), 3, WORK, 00177 $ INFO ) 00178 * 00179 * Check the error code from ZLATMS. 00180 * 00181 IF( INFO.NE.0 ) THEN 00182 CALL ALAERH( PATH, 'ZLATMS', INFO, 0, ' ', N, N, KL, 00183 $ KU, -1, IMAT, NFAIL, NERRS, NOUT ) 00184 GO TO 100 00185 END IF 00186 IZERO = 0 00187 * 00188 IF( N.GT.1 ) THEN 00189 CALL ZCOPY( N-1, AF( 4 ), 3, A, 1 ) 00190 CALL ZCOPY( N-1, AF( 3 ), 3, A( N+M+1 ), 1 ) 00191 END IF 00192 CALL ZCOPY( N, AF( 2 ), 3, A( M+1 ), 1 ) 00193 ELSE 00194 * 00195 * Types 7-12: generate tridiagonal matrices with 00196 * unknown condition numbers. 00197 * 00198 IF( .NOT.ZEROT .OR. .NOT.DOTYPE( 7 ) ) THEN 00199 * 00200 * Generate a matrix with elements whose real and 00201 * imaginary parts are from [-1,1]. 00202 * 00203 CALL ZLARNV( 2, ISEED, N+2*M, A ) 00204 IF( ANORM.NE.ONE ) 00205 $ CALL ZDSCAL( N+2*M, ANORM, A, 1 ) 00206 ELSE IF( IZERO.GT.0 ) THEN 00207 * 00208 * Reuse the last matrix by copying back the zeroed out 00209 * elements. 00210 * 00211 IF( IZERO.EQ.1 ) THEN 00212 A( N ) = Z( 2 ) 00213 IF( N.GT.1 ) 00214 $ A( 1 ) = Z( 3 ) 00215 ELSE IF( IZERO.EQ.N ) THEN 00216 A( 3*N-2 ) = Z( 1 ) 00217 A( 2*N-1 ) = Z( 2 ) 00218 ELSE 00219 A( 2*N-2+IZERO ) = Z( 1 ) 00220 A( N-1+IZERO ) = Z( 2 ) 00221 A( IZERO ) = Z( 3 ) 00222 END IF 00223 END IF 00224 * 00225 * If IMAT > 7, set one column of the matrix to 0. 00226 * 00227 IF( .NOT.ZEROT ) THEN 00228 IZERO = 0 00229 ELSE IF( IMAT.EQ.8 ) THEN 00230 IZERO = 1 00231 Z( 2 ) = A( N ) 00232 A( N ) = ZERO 00233 IF( N.GT.1 ) THEN 00234 Z( 3 ) = A( 1 ) 00235 A( 1 ) = ZERO 00236 END IF 00237 ELSE IF( IMAT.EQ.9 ) THEN 00238 IZERO = N 00239 Z( 1 ) = A( 3*N-2 ) 00240 Z( 2 ) = A( 2*N-1 ) 00241 A( 3*N-2 ) = ZERO 00242 A( 2*N-1 ) = ZERO 00243 ELSE 00244 IZERO = ( N+1 ) / 2 00245 DO 20 I = IZERO, N - 1 00246 A( 2*N-2+I ) = ZERO 00247 A( N-1+I ) = ZERO 00248 A( I ) = ZERO 00249 20 CONTINUE 00250 A( 3*N-2 ) = ZERO 00251 A( 2*N-1 ) = ZERO 00252 END IF 00253 END IF 00254 * 00255 *+ TEST 1 00256 * Factor A as L*U and compute the ratio 00257 * norm(L*U - A) / (n * norm(A) * EPS ) 00258 * 00259 CALL ZCOPY( N+2*M, A, 1, AF, 1 ) 00260 SRNAMT = 'ZGTTRF' 00261 CALL ZGTTRF( N, AF, AF( M+1 ), AF( N+M+1 ), AF( N+2*M+1 ), 00262 $ IWORK, INFO ) 00263 * 00264 * Check error code from ZGTTRF. 00265 * 00266 IF( INFO.NE.IZERO ) 00267 $ CALL ALAERH( PATH, 'ZGTTRF', INFO, IZERO, ' ', N, N, 1, 00268 $ 1, -1, IMAT, NFAIL, NERRS, NOUT ) 00269 TRFCON = INFO.NE.0 00270 * 00271 CALL ZGTT01( N, A, A( M+1 ), A( N+M+1 ), AF, AF( M+1 ), 00272 $ AF( N+M+1 ), AF( N+2*M+1 ), IWORK, WORK, LDA, 00273 $ RWORK, RESULT( 1 ) ) 00274 * 00275 * Print the test ratio if it is .GE. THRESH. 00276 * 00277 IF( RESULT( 1 ).GE.THRESH ) THEN 00278 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) 00279 $ CALL ALAHD( NOUT, PATH ) 00280 WRITE( NOUT, FMT = 9999 )N, IMAT, 1, RESULT( 1 ) 00281 NFAIL = NFAIL + 1 00282 END IF 00283 NRUN = NRUN + 1 00284 * 00285 DO 50 ITRAN = 1, 2 00286 TRANS = TRANSS( ITRAN ) 00287 IF( ITRAN.EQ.1 ) THEN 00288 NORM = 'O' 00289 ELSE 00290 NORM = 'I' 00291 END IF 00292 ANORM = ZLANGT( NORM, N, A, A( M+1 ), A( N+M+1 ) ) 00293 * 00294 IF( .NOT.TRFCON ) THEN 00295 * 00296 * Use ZGTTRS to solve for one column at a time of 00297 * inv(A), computing the maximum column sum as we go. 00298 * 00299 AINVNM = ZERO 00300 DO 40 I = 1, N 00301 DO 30 J = 1, N 00302 X( J ) = ZERO 00303 30 CONTINUE 00304 X( I ) = ONE 00305 CALL ZGTTRS( TRANS, N, 1, AF, AF( M+1 ), 00306 $ AF( N+M+1 ), AF( N+2*M+1 ), IWORK, X, 00307 $ LDA, INFO ) 00308 AINVNM = MAX( AINVNM, DZASUM( N, X, 1 ) ) 00309 40 CONTINUE 00310 * 00311 * Compute RCONDC = 1 / (norm(A) * norm(inv(A)) 00312 * 00313 IF( ANORM.LE.ZERO .OR. AINVNM.LE.ZERO ) THEN 00314 RCONDC = ONE 00315 ELSE 00316 RCONDC = ( ONE / ANORM ) / AINVNM 00317 END IF 00318 IF( ITRAN.EQ.1 ) THEN 00319 RCONDO = RCONDC 00320 ELSE 00321 RCONDI = RCONDC 00322 END IF 00323 ELSE 00324 RCONDC = ZERO 00325 END IF 00326 * 00327 *+ TEST 7 00328 * Estimate the reciprocal of the condition number of the 00329 * matrix. 00330 * 00331 SRNAMT = 'ZGTCON' 00332 CALL ZGTCON( NORM, N, AF, AF( M+1 ), AF( N+M+1 ), 00333 $ AF( N+2*M+1 ), IWORK, ANORM, RCOND, WORK, 00334 $ INFO ) 00335 * 00336 * Check error code from ZGTCON. 00337 * 00338 IF( INFO.NE.0 ) 00339 $ CALL ALAERH( PATH, 'ZGTCON', INFO, 0, NORM, N, N, -1, 00340 $ -1, -1, IMAT, NFAIL, NERRS, NOUT ) 00341 * 00342 RESULT( 7 ) = DGET06( RCOND, RCONDC ) 00343 * 00344 * Print the test ratio if it is .GE. THRESH. 00345 * 00346 IF( RESULT( 7 ).GE.THRESH ) THEN 00347 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) 00348 $ CALL ALAHD( NOUT, PATH ) 00349 WRITE( NOUT, FMT = 9997 )NORM, N, IMAT, 7, 00350 $ RESULT( 7 ) 00351 NFAIL = NFAIL + 1 00352 END IF 00353 NRUN = NRUN + 1 00354 50 CONTINUE 00355 * 00356 * Skip the remaining tests if the matrix is singular. 00357 * 00358 IF( TRFCON ) 00359 $ GO TO 100 00360 * 00361 DO 90 IRHS = 1, NNS 00362 NRHS = NSVAL( IRHS ) 00363 * 00364 * Generate NRHS random solution vectors. 00365 * 00366 IX = 1 00367 DO 60 J = 1, NRHS 00368 CALL ZLARNV( 2, ISEED, N, XACT( IX ) ) 00369 IX = IX + LDA 00370 60 CONTINUE 00371 * 00372 DO 80 ITRAN = 1, 3 00373 TRANS = TRANSS( ITRAN ) 00374 IF( ITRAN.EQ.1 ) THEN 00375 RCONDC = RCONDO 00376 ELSE 00377 RCONDC = RCONDI 00378 END IF 00379 * 00380 * Set the right hand side. 00381 * 00382 CALL ZLAGTM( TRANS, N, NRHS, ONE, A, A( M+1 ), 00383 $ A( N+M+1 ), XACT, LDA, ZERO, B, LDA ) 00384 * 00385 *+ TEST 2 00386 * Solve op(A) * X = B and compute the residual. 00387 * 00388 CALL ZLACPY( 'Full', N, NRHS, B, LDA, X, LDA ) 00389 SRNAMT = 'ZGTTRS' 00390 CALL ZGTTRS( TRANS, N, NRHS, AF, AF( M+1 ), 00391 $ AF( N+M+1 ), AF( N+2*M+1 ), IWORK, X, 00392 $ LDA, INFO ) 00393 * 00394 * Check error code from ZGTTRS. 00395 * 00396 IF( INFO.NE.0 ) 00397 $ CALL ALAERH( PATH, 'ZGTTRS', INFO, 0, TRANS, N, N, 00398 $ -1, -1, NRHS, IMAT, NFAIL, NERRS, 00399 $ NOUT ) 00400 * 00401 CALL ZLACPY( 'Full', N, NRHS, B, LDA, WORK, LDA ) 00402 CALL ZGTT02( TRANS, N, NRHS, A, A( M+1 ), A( N+M+1 ), 00403 $ X, LDA, WORK, LDA, RWORK, RESULT( 2 ) ) 00404 * 00405 *+ TEST 3 00406 * Check solution from generated exact solution. 00407 * 00408 CALL ZGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC, 00409 $ RESULT( 3 ) ) 00410 * 00411 *+ TESTS 4, 5, and 6 00412 * Use iterative refinement to improve the solution. 00413 * 00414 SRNAMT = 'ZGTRFS' 00415 CALL ZGTRFS( TRANS, N, NRHS, A, A( M+1 ), A( N+M+1 ), 00416 $ AF, AF( M+1 ), AF( N+M+1 ), 00417 $ AF( N+2*M+1 ), IWORK, B, LDA, X, LDA, 00418 $ RWORK, RWORK( NRHS+1 ), WORK, 00419 $ RWORK( 2*NRHS+1 ), INFO ) 00420 * 00421 * Check error code from ZGTRFS. 00422 * 00423 IF( INFO.NE.0 ) 00424 $ CALL ALAERH( PATH, 'ZGTRFS', INFO, 0, TRANS, N, N, 00425 $ -1, -1, NRHS, IMAT, NFAIL, NERRS, 00426 $ NOUT ) 00427 * 00428 CALL ZGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC, 00429 $ RESULT( 4 ) ) 00430 CALL ZGTT05( TRANS, N, NRHS, A, A( M+1 ), A( N+M+1 ), 00431 $ B, LDA, X, LDA, XACT, LDA, RWORK, 00432 $ RWORK( NRHS+1 ), RESULT( 5 ) ) 00433 * 00434 * Print information about the tests that did not pass the 00435 * threshold. 00436 * 00437 DO 70 K = 2, 6 00438 IF( RESULT( K ).GE.THRESH ) THEN 00439 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) 00440 $ CALL ALAHD( NOUT, PATH ) 00441 WRITE( NOUT, FMT = 9998 )TRANS, N, NRHS, IMAT, 00442 $ K, RESULT( K ) 00443 NFAIL = NFAIL + 1 00444 END IF 00445 70 CONTINUE 00446 NRUN = NRUN + 5 00447 80 CONTINUE 00448 90 CONTINUE 00449 100 CONTINUE 00450 110 CONTINUE 00451 * 00452 * Print a summary of the results. 00453 * 00454 CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS ) 00455 * 00456 9999 FORMAT( 12X, 'N =', I5, ',', 10X, ' type ', I2, ', test(', I2, 00457 $ ') = ', G12.5 ) 00458 9998 FORMAT( ' TRANS=''', A1, ''', N =', I5, ', NRHS=', I3, ', type ', 00459 $ I2, ', test(', I2, ') = ', G12.5 ) 00460 9997 FORMAT( ' NORM =''', A1, ''', N =', I5, ',', 10X, ' type ', I2, 00461 $ ', test(', I2, ') = ', G12.5 ) 00462 RETURN 00463 * 00464 * End of ZCHKGT 00465 * 00466 END
1.7.3 
