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