LAPACK 3.3.0

schkeq.f

Go to the documentation of this file.
00001       SUBROUTINE SCHKEQ( 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       REAL               THRESH
00010 *     ..
00011 *
00012 *  Purpose
00013 *  =======
00014 *
00015 *  SCHKEQ tests SGEEQU, SGBEQU, SPOEQU, SPPEQU and SPBEQU
00016 *
00017 *  Arguments
00018 *  =========
00019 *
00020 *  THRESH  (input) REAL
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       REAL               ZERO, ONE, TEN
00030       PARAMETER          ( ZERO = 0.0E0, ONE = 1.0E+0, TEN = 1.0E1 )
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       REAL               CCOND, EPS, NORM, RATIO, RCMAX, RCMIN, RCOND
00042 *     ..
00043 *     .. Local Arrays ..
00044       REAL               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       REAL               SLAMCH
00050       EXTERNAL           SLAMCH
00051 *     ..
00052 *     .. External Subroutines ..
00053       EXTERNAL           SGBEQU, SGEEQU, SPBEQU, SPOEQU, SPPEQU
00054 *     ..
00055 *     .. Intrinsic Functions ..
00056       INTRINSIC          ABS, MAX, MIN
00057 *     ..
00058 *     .. Executable Statements ..
00059 *
00060       PATH( 1:1 ) = 'Single precision'
00061       PATH( 2:3 ) = 'EQ'
00062 *
00063       EPS = SLAMCH( '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 SGEEQU
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 SGEEQU( 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 SGEEQU( 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 SGEEQU( 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 SGBEQU
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 SGBEQU( 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 SPOEQU
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 SPOEQU( 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 SPOEQU( 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 SPPEQU
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 SPPEQU( '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 SPPEQU( '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 SPPEQU( '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 SPBEQU
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 SPBEQU( '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 SPBEQU( '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 SPBEQU( '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 SPBEQU( '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( ' SGEEQU failed test with value ', E10.3, ' exceeding',
00436      $      ' threshold ', E10.3 )
00437  9997 FORMAT( ' SGBEQU failed test with value ', E10.3, ' exceeding',
00438      $      ' threshold ', E10.3 )
00439  9996 FORMAT( ' SPOEQU failed test with value ', E10.3, ' exceeding',
00440      $      ' threshold ', E10.3 )
00441  9995 FORMAT( ' SPPEQU failed test with value ', E10.3, ' exceeding',
00442      $      ' threshold ', E10.3 )
00443  9994 FORMAT( ' SPBEQU failed test with value ', E10.3, ' exceeding',
00444      $      ' threshold ', E10.3 )
00445       RETURN
00446 *
00447 *     End of SCHKEQ
00448 *
00449       END
 All Files Functions