|
LAPACK 3.3.0
|
|
LAPACK 3.3.0
|
00001 SUBROUTINE DCHKEQ( THRESH, NOUT ) 00002 * 00003 * -- LAPACK test routine (version 3.1) -- 00004 * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. 00005 * November 2006 00006 * 00007 * .. Scalar Arguments .. 00008 INTEGER NOUT 00009 DOUBLE PRECISION THRESH 00010 * .. 00011 * 00012 * Purpose 00013 * ======= 00014 * 00015 * DCHKEQ tests DGEEQU, DGBEQU, DPOEQU, DPPEQU and DPBEQU 00016 * 00017 * Arguments 00018 * ========= 00019 * 00020 * THRESH (input) DOUBLE PRECISION 00021 * Threshold for testing routines. Should be between 2 and 10. 00022 * 00023 * NOUT (input) INTEGER 00024 * The unit number for output. 00025 * 00026 * ===================================================================== 00027 * 00028 * .. Parameters .. 00029 DOUBLE PRECISION ZERO, ONE, TEN 00030 PARAMETER ( ZERO = 0.0D0, ONE = 1.0D+0, TEN = 1.0D1 ) 00031 INTEGER NSZ, NSZB 00032 PARAMETER ( NSZ = 5, NSZB = 3*NSZ-2 ) 00033 INTEGER NSZP, NPOW 00034 PARAMETER ( NSZP = ( NSZ*( NSZ+1 ) ) / 2, 00035 $ NPOW = 2*NSZ+1 ) 00036 * .. 00037 * .. Local Scalars .. 00038 LOGICAL OK 00039 CHARACTER*3 PATH 00040 INTEGER I, INFO, J, KL, KU, M, N 00041 DOUBLE PRECISION CCOND, EPS, NORM, RATIO, RCMAX, RCMIN, RCOND 00042 * .. 00043 * .. Local Arrays .. 00044 DOUBLE PRECISION A( NSZ, NSZ ), AB( NSZB, NSZ ), AP( NSZP ), 00045 $ C( NSZ ), POW( NPOW ), R( NSZ ), RESLTS( 5 ), 00046 $ RPOW( NPOW ) 00047 * .. 00048 * .. External Functions .. 00049 DOUBLE PRECISION DLAMCH 00050 EXTERNAL DLAMCH 00051 * .. 00052 * .. External Subroutines .. 00053 EXTERNAL DGBEQU, DGEEQU, DPBEQU, DPOEQU, DPPEQU 00054 * .. 00055 * .. Intrinsic Functions .. 00056 INTRINSIC ABS, MAX, MIN 00057 * .. 00058 * .. Executable Statements .. 00059 * 00060 PATH( 1: 1 ) = 'Double precision' 00061 PATH( 2: 3 ) = 'EQ' 00062 * 00063 EPS = DLAMCH( 'P' ) 00064 DO 10 I = 1, 5 00065 RESLTS( I ) = ZERO 00066 10 CONTINUE 00067 DO 20 I = 1, NPOW 00068 POW( I ) = TEN**( I-1 ) 00069 RPOW( I ) = ONE / POW( I ) 00070 20 CONTINUE 00071 * 00072 * Test DGEEQU 00073 * 00074 DO 80 N = 0, NSZ 00075 DO 70 M = 0, NSZ 00076 * 00077 DO 40 J = 1, NSZ 00078 DO 30 I = 1, NSZ 00079 IF( I.LE.M .AND. J.LE.N ) THEN 00080 A( I, J ) = POW( I+J+1 )*( -1 )**( I+J ) 00081 ELSE 00082 A( I, J ) = ZERO 00083 END IF 00084 30 CONTINUE 00085 40 CONTINUE 00086 * 00087 CALL DGEEQU( M, N, A, NSZ, R, C, RCOND, CCOND, NORM, INFO ) 00088 * 00089 IF( INFO.NE.0 ) THEN 00090 RESLTS( 1 ) = ONE 00091 ELSE 00092 IF( N.NE.0 .AND. M.NE.0 ) THEN 00093 RESLTS( 1 ) = MAX( RESLTS( 1 ), 00094 $ ABS( ( RCOND-RPOW( M ) ) / RPOW( M ) ) ) 00095 RESLTS( 1 ) = MAX( RESLTS( 1 ), 00096 $ ABS( ( CCOND-RPOW( N ) ) / RPOW( N ) ) ) 00097 RESLTS( 1 ) = MAX( RESLTS( 1 ), 00098 $ ABS( ( NORM-POW( N+M+1 ) ) / POW( N+M+ 00099 $ 1 ) ) ) 00100 DO 50 I = 1, M 00101 RESLTS( 1 ) = MAX( RESLTS( 1 ), 00102 $ ABS( ( R( I )-RPOW( I+N+1 ) ) / 00103 $ RPOW( I+N+1 ) ) ) 00104 50 CONTINUE 00105 DO 60 J = 1, N 00106 RESLTS( 1 ) = MAX( RESLTS( 1 ), 00107 $ ABS( ( C( J )-POW( N-J+1 ) ) / 00108 $ POW( N-J+1 ) ) ) 00109 60 CONTINUE 00110 END IF 00111 END IF 00112 * 00113 70 CONTINUE 00114 80 CONTINUE 00115 * 00116 * Test with zero rows and columns 00117 * 00118 DO 90 J = 1, NSZ 00119 A( MAX( NSZ-1, 1 ), J ) = ZERO 00120 90 CONTINUE 00121 CALL DGEEQU( NSZ, NSZ, A, NSZ, R, C, RCOND, CCOND, NORM, INFO ) 00122 IF( INFO.NE.MAX( NSZ-1, 1 ) ) 00123 $ RESLTS( 1 ) = ONE 00124 * 00125 DO 100 J = 1, NSZ 00126 A( MAX( NSZ-1, 1 ), J ) = ONE 00127 100 CONTINUE 00128 DO 110 I = 1, NSZ 00129 A( I, MAX( NSZ-1, 1 ) ) = ZERO 00130 110 CONTINUE 00131 CALL DGEEQU( NSZ, NSZ, A, NSZ, R, C, RCOND, CCOND, NORM, INFO ) 00132 IF( INFO.NE.NSZ+MAX( NSZ-1, 1 ) ) 00133 $ RESLTS( 1 ) = ONE 00134 RESLTS( 1 ) = RESLTS( 1 ) / EPS 00135 * 00136 * Test DGBEQU 00137 * 00138 DO 250 N = 0, NSZ 00139 DO 240 M = 0, NSZ 00140 DO 230 KL = 0, MAX( M-1, 0 ) 00141 DO 220 KU = 0, MAX( N-1, 0 ) 00142 * 00143 DO 130 J = 1, NSZ 00144 DO 120 I = 1, NSZB 00145 AB( I, J ) = ZERO 00146 120 CONTINUE 00147 130 CONTINUE 00148 DO 150 J = 1, N 00149 DO 140 I = 1, M 00150 IF( I.LE.MIN( M, J+KL ) .AND. I.GE. 00151 $ MAX( 1, J-KU ) .AND. J.LE.N ) THEN 00152 AB( KU+1+I-J, J ) = POW( I+J+1 )* 00153 $ ( -1 )**( I+J ) 00154 END IF 00155 140 CONTINUE 00156 150 CONTINUE 00157 * 00158 CALL DGBEQU( M, N, KL, KU, AB, NSZB, R, C, RCOND, 00159 $ CCOND, NORM, INFO ) 00160 * 00161 IF( INFO.NE.0 ) THEN 00162 IF( .NOT.( ( N+KL.LT.M .AND. INFO.EQ.N+KL+1 ) .OR. 00163 $ ( M+KU.LT.N .AND. INFO.EQ.2*M+KU+1 ) ) ) THEN 00164 RESLTS( 2 ) = ONE 00165 END IF 00166 ELSE 00167 IF( N.NE.0 .AND. M.NE.0 ) THEN 00168 * 00169 RCMIN = R( 1 ) 00170 RCMAX = R( 1 ) 00171 DO 160 I = 1, M 00172 RCMIN = MIN( RCMIN, R( I ) ) 00173 RCMAX = MAX( RCMAX, R( I ) ) 00174 160 CONTINUE 00175 RATIO = RCMIN / RCMAX 00176 RESLTS( 2 ) = MAX( RESLTS( 2 ), 00177 $ ABS( ( RCOND-RATIO ) / RATIO ) ) 00178 * 00179 RCMIN = C( 1 ) 00180 RCMAX = C( 1 ) 00181 DO 170 J = 1, N 00182 RCMIN = MIN( RCMIN, C( J ) ) 00183 RCMAX = MAX( RCMAX, C( J ) ) 00184 170 CONTINUE 00185 RATIO = RCMIN / RCMAX 00186 RESLTS( 2 ) = MAX( RESLTS( 2 ), 00187 $ ABS( ( CCOND-RATIO ) / RATIO ) ) 00188 * 00189 RESLTS( 2 ) = MAX( RESLTS( 2 ), 00190 $ ABS( ( NORM-POW( N+M+1 ) ) / 00191 $ POW( N+M+1 ) ) ) 00192 DO 190 I = 1, M 00193 RCMAX = ZERO 00194 DO 180 J = 1, N 00195 IF( I.LE.J+KL .AND. I.GE.J-KU ) THEN 00196 RATIO = ABS( R( I )*POW( I+J+1 )* 00197 $ C( J ) ) 00198 RCMAX = MAX( RCMAX, RATIO ) 00199 END IF 00200 180 CONTINUE 00201 RESLTS( 2 ) = MAX( RESLTS( 2 ), 00202 $ ABS( ONE-RCMAX ) ) 00203 190 CONTINUE 00204 * 00205 DO 210 J = 1, N 00206 RCMAX = ZERO 00207 DO 200 I = 1, M 00208 IF( I.LE.J+KL .AND. I.GE.J-KU ) THEN 00209 RATIO = ABS( R( I )*POW( I+J+1 )* 00210 $ C( J ) ) 00211 RCMAX = MAX( RCMAX, RATIO ) 00212 END IF 00213 200 CONTINUE 00214 RESLTS( 2 ) = MAX( RESLTS( 2 ), 00215 $ ABS( ONE-RCMAX ) ) 00216 210 CONTINUE 00217 END IF 00218 END IF 00219 * 00220 220 CONTINUE 00221 230 CONTINUE 00222 240 CONTINUE 00223 250 CONTINUE 00224 RESLTS( 2 ) = RESLTS( 2 ) / EPS 00225 * 00226 * Test DPOEQU 00227 * 00228 DO 290 N = 0, NSZ 00229 * 00230 DO 270 I = 1, NSZ 00231 DO 260 J = 1, NSZ 00232 IF( I.LE.N .AND. J.EQ.I ) THEN 00233 A( I, J ) = POW( I+J+1 )*( -1 )**( I+J ) 00234 ELSE 00235 A( I, J ) = ZERO 00236 END IF 00237 260 CONTINUE 00238 270 CONTINUE 00239 * 00240 CALL DPOEQU( N, A, NSZ, R, RCOND, NORM, INFO ) 00241 * 00242 IF( INFO.NE.0 ) THEN 00243 RESLTS( 3 ) = ONE 00244 ELSE 00245 IF( N.NE.0 ) THEN 00246 RESLTS( 3 ) = MAX( RESLTS( 3 ), 00247 $ ABS( ( RCOND-RPOW( N ) ) / RPOW( N ) ) ) 00248 RESLTS( 3 ) = MAX( RESLTS( 3 ), 00249 $ ABS( ( NORM-POW( 2*N+1 ) ) / POW( 2*N+ 00250 $ 1 ) ) ) 00251 DO 280 I = 1, N 00252 RESLTS( 3 ) = MAX( RESLTS( 3 ), 00253 $ ABS( ( R( I )-RPOW( I+1 ) ) / RPOW( I+ 00254 $ 1 ) ) ) 00255 280 CONTINUE 00256 END IF 00257 END IF 00258 290 CONTINUE 00259 A( MAX( NSZ-1, 1 ), MAX( NSZ-1, 1 ) ) = -ONE 00260 CALL DPOEQU( NSZ, A, NSZ, R, RCOND, NORM, INFO ) 00261 IF( INFO.NE.MAX( NSZ-1, 1 ) ) 00262 $ RESLTS( 3 ) = ONE 00263 RESLTS( 3 ) = RESLTS( 3 ) / EPS 00264 * 00265 * Test DPPEQU 00266 * 00267 DO 360 N = 0, NSZ 00268 * 00269 * Upper triangular packed storage 00270 * 00271 DO 300 I = 1, ( N*( N+1 ) ) / 2 00272 AP( I ) = ZERO 00273 300 CONTINUE 00274 DO 310 I = 1, N 00275 AP( ( I*( I+1 ) ) / 2 ) = POW( 2*I+1 ) 00276 310 CONTINUE 00277 * 00278 CALL DPPEQU( 'U', N, AP, R, RCOND, NORM, INFO ) 00279 * 00280 IF( INFO.NE.0 ) THEN 00281 RESLTS( 4 ) = ONE 00282 ELSE 00283 IF( N.NE.0 ) THEN 00284 RESLTS( 4 ) = MAX( RESLTS( 4 ), 00285 $ ABS( ( RCOND-RPOW( N ) ) / RPOW( N ) ) ) 00286 RESLTS( 4 ) = MAX( RESLTS( 4 ), 00287 $ ABS( ( NORM-POW( 2*N+1 ) ) / POW( 2*N+ 00288 $ 1 ) ) ) 00289 DO 320 I = 1, N 00290 RESLTS( 4 ) = MAX( RESLTS( 4 ), 00291 $ ABS( ( R( I )-RPOW( I+1 ) ) / RPOW( I+ 00292 $ 1 ) ) ) 00293 320 CONTINUE 00294 END IF 00295 END IF 00296 * 00297 * Lower triangular packed storage 00298 * 00299 DO 330 I = 1, ( N*( N+1 ) ) / 2 00300 AP( I ) = ZERO 00301 330 CONTINUE 00302 J = 1 00303 DO 340 I = 1, N 00304 AP( J ) = POW( 2*I+1 ) 00305 J = J + ( N-I+1 ) 00306 340 CONTINUE 00307 * 00308 CALL DPPEQU( 'L', N, AP, R, RCOND, NORM, INFO ) 00309 * 00310 IF( INFO.NE.0 ) THEN 00311 RESLTS( 4 ) = ONE 00312 ELSE 00313 IF( N.NE.0 ) THEN 00314 RESLTS( 4 ) = MAX( RESLTS( 4 ), 00315 $ ABS( ( RCOND-RPOW( N ) ) / RPOW( N ) ) ) 00316 RESLTS( 4 ) = MAX( RESLTS( 4 ), 00317 $ ABS( ( NORM-POW( 2*N+1 ) ) / POW( 2*N+ 00318 $ 1 ) ) ) 00319 DO 350 I = 1, N 00320 RESLTS( 4 ) = MAX( RESLTS( 4 ), 00321 $ ABS( ( R( I )-RPOW( I+1 ) ) / RPOW( I+ 00322 $ 1 ) ) ) 00323 350 CONTINUE 00324 END IF 00325 END IF 00326 * 00327 360 CONTINUE 00328 I = ( NSZ*( NSZ+1 ) ) / 2 - 2 00329 AP( I ) = -ONE 00330 CALL DPPEQU( 'L', NSZ, AP, R, RCOND, NORM, INFO ) 00331 IF( INFO.NE.MAX( NSZ-1, 1 ) ) 00332 $ RESLTS( 4 ) = ONE 00333 RESLTS( 4 ) = RESLTS( 4 ) / EPS 00334 * 00335 * Test DPBEQU 00336 * 00337 DO 460 N = 0, NSZ 00338 DO 450 KL = 0, MAX( N-1, 0 ) 00339 * 00340 * Test upper triangular storage 00341 * 00342 DO 380 J = 1, NSZ 00343 DO 370 I = 1, NSZB 00344 AB( I, J ) = ZERO 00345 370 CONTINUE 00346 380 CONTINUE 00347 DO 390 J = 1, N 00348 AB( KL+1, J ) = POW( 2*J+1 ) 00349 390 CONTINUE 00350 * 00351 CALL DPBEQU( 'U', N, KL, AB, NSZB, R, RCOND, NORM, INFO ) 00352 * 00353 IF( INFO.NE.0 ) THEN 00354 RESLTS( 5 ) = ONE 00355 ELSE 00356 IF( N.NE.0 ) THEN 00357 RESLTS( 5 ) = MAX( RESLTS( 5 ), 00358 $ ABS( ( RCOND-RPOW( N ) ) / RPOW( N ) ) ) 00359 RESLTS( 5 ) = MAX( RESLTS( 5 ), 00360 $ ABS( ( NORM-POW( 2*N+1 ) ) / POW( 2*N+ 00361 $ 1 ) ) ) 00362 DO 400 I = 1, N 00363 RESLTS( 5 ) = MAX( RESLTS( 5 ), 00364 $ ABS( ( R( I )-RPOW( I+1 ) ) / 00365 $ RPOW( I+1 ) ) ) 00366 400 CONTINUE 00367 END IF 00368 END IF 00369 IF( N.NE.0 ) THEN 00370 AB( KL+1, MAX( N-1, 1 ) ) = -ONE 00371 CALL DPBEQU( 'U', N, KL, AB, NSZB, R, RCOND, NORM, INFO ) 00372 IF( INFO.NE.MAX( N-1, 1 ) ) 00373 $ RESLTS( 5 ) = ONE 00374 END IF 00375 * 00376 * Test lower triangular storage 00377 * 00378 DO 420 J = 1, NSZ 00379 DO 410 I = 1, NSZB 00380 AB( I, J ) = ZERO 00381 410 CONTINUE 00382 420 CONTINUE 00383 DO 430 J = 1, N 00384 AB( 1, J ) = POW( 2*J+1 ) 00385 430 CONTINUE 00386 * 00387 CALL DPBEQU( 'L', N, KL, AB, NSZB, R, RCOND, NORM, INFO ) 00388 * 00389 IF( INFO.NE.0 ) THEN 00390 RESLTS( 5 ) = ONE 00391 ELSE 00392 IF( N.NE.0 ) THEN 00393 RESLTS( 5 ) = MAX( RESLTS( 5 ), 00394 $ ABS( ( RCOND-RPOW( N ) ) / RPOW( N ) ) ) 00395 RESLTS( 5 ) = MAX( RESLTS( 5 ), 00396 $ ABS( ( NORM-POW( 2*N+1 ) ) / POW( 2*N+ 00397 $ 1 ) ) ) 00398 DO 440 I = 1, N 00399 RESLTS( 5 ) = MAX( RESLTS( 5 ), 00400 $ ABS( ( R( I )-RPOW( I+1 ) ) / 00401 $ RPOW( I+1 ) ) ) 00402 440 CONTINUE 00403 END IF 00404 END IF 00405 IF( N.NE.0 ) THEN 00406 AB( 1, MAX( N-1, 1 ) ) = -ONE 00407 CALL DPBEQU( 'L', N, KL, AB, NSZB, R, RCOND, NORM, INFO ) 00408 IF( INFO.NE.MAX( N-1, 1 ) ) 00409 $ RESLTS( 5 ) = ONE 00410 END IF 00411 450 CONTINUE 00412 460 CONTINUE 00413 RESLTS( 5 ) = RESLTS( 5 ) / EPS 00414 OK = ( RESLTS( 1 ).LE.THRESH ) .AND. 00415 $ ( RESLTS( 2 ).LE.THRESH ) .AND. 00416 $ ( RESLTS( 3 ).LE.THRESH ) .AND. 00417 $ ( RESLTS( 4 ).LE.THRESH ) .AND. ( RESLTS( 5 ).LE.THRESH ) 00418 WRITE( NOUT, FMT = * ) 00419 IF( OK ) THEN 00420 WRITE( NOUT, FMT = 9999 )PATH 00421 ELSE 00422 IF( RESLTS( 1 ).GT.THRESH ) 00423 $ WRITE( NOUT, FMT = 9998 )RESLTS( 1 ), THRESH 00424 IF( RESLTS( 2 ).GT.THRESH ) 00425 $ WRITE( NOUT, FMT = 9997 )RESLTS( 2 ), THRESH 00426 IF( RESLTS( 3 ).GT.THRESH ) 00427 $ WRITE( NOUT, FMT = 9996 )RESLTS( 3 ), THRESH 00428 IF( RESLTS( 4 ).GT.THRESH ) 00429 $ WRITE( NOUT, FMT = 9995 )RESLTS( 4 ), THRESH 00430 IF( RESLTS( 5 ).GT.THRESH ) 00431 $ WRITE( NOUT, FMT = 9994 )RESLTS( 5 ), THRESH 00432 END IF 00433 9999 FORMAT( 1X, 'All tests for ', A3, 00434 $ ' routines passed the threshold' ) 00435 9998 FORMAT( ' DGEEQU failed test with value ', D10.3, ' exceeding', 00436 $ ' threshold ', D10.3 ) 00437 9997 FORMAT( ' DGBEQU failed test with value ', D10.3, ' exceeding', 00438 $ ' threshold ', D10.3 ) 00439 9996 FORMAT( ' DPOEQU failed test with value ', D10.3, ' exceeding', 00440 $ ' threshold ', D10.3 ) 00441 9995 FORMAT( ' DPPEQU failed test with value ', D10.3, ' exceeding', 00442 $ ' threshold ', D10.3 ) 00443 9994 FORMAT( ' DPBEQU failed test with value ', D10.3, ' exceeding', 00444 $ ' threshold ', D10.3 ) 00445 RETURN 00446 * 00447 * End of DCHKEQ 00448 * 00449 END
1.7.3 
