LAPACK  3.4.1
LAPACK: Linear Algebra PACKage
dchkeq.f
Go to the documentation of this file.
00001 *> \brief \b DCHKEQ
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 DCHKEQ( THRESH, NOUT )
00012 * 
00013 *       .. Scalar Arguments ..
00014 *       INTEGER            NOUT
00015 *       DOUBLE PRECISION   THRESH
00016 *       ..
00017 *  
00018 *
00019 *> \par Purpose:
00020 *  =============
00021 *>
00022 *> \verbatim
00023 *>
00024 *> DCHKEQ tests DGEEQU, DGBEQU, DPOEQU, DPPEQU and DPBEQU
00025 *> \endverbatim
00026 *
00027 *  Arguments:
00028 *  ==========
00029 *
00030 *> \param[in] THRESH
00031 *> \verbatim
00032 *>          THRESH is DOUBLE PRECISION
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 double_lin
00053 *
00054 *  =====================================================================
00055       SUBROUTINE DCHKEQ( 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       DOUBLE PRECISION   THRESH
00065 *     ..
00066 *
00067 *  =====================================================================
00068 *
00069 *     .. Parameters ..
00070       DOUBLE PRECISION   ZERO, ONE, TEN
00071       PARAMETER          ( ZERO = 0.0D0, ONE = 1.0D+0, TEN = 1.0D1 )
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       DOUBLE PRECISION   CCOND, EPS, NORM, RATIO, RCMAX, RCMIN, RCOND
00083 *     ..
00084 *     .. Local Arrays ..
00085       DOUBLE PRECISION   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       DOUBLE PRECISION   DLAMCH
00091       EXTERNAL           DLAMCH
00092 *     ..
00093 *     .. External Subroutines ..
00094       EXTERNAL           DGBEQU, DGEEQU, DPBEQU, DPOEQU, DPPEQU
00095 *     ..
00096 *     .. Intrinsic Functions ..
00097       INTRINSIC          ABS, MAX, MIN
00098 *     ..
00099 *     .. Executable Statements ..
00100 *
00101       PATH( 1: 1 ) = 'Double precision'
00102       PATH( 2: 3 ) = 'EQ'
00103 *
00104       EPS = DLAMCH( '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 DGEEQU
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 DGEEQU( 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 DGEEQU( 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 DGEEQU( 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 DGBEQU
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 DGBEQU( 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 DPOEQU
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 DPOEQU( 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 DPOEQU( 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 DPPEQU
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 DPPEQU( '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 DPPEQU( '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 DPPEQU( '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 DPBEQU
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 DPBEQU( '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 DPBEQU( '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 DPBEQU( '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 DPBEQU( '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( ' DGEEQU failed test with value ', D10.3, ' exceeding',
00477      $      ' threshold ', D10.3 )
00478  9997 FORMAT( ' DGBEQU failed test with value ', D10.3, ' exceeding',
00479      $      ' threshold ', D10.3 )
00480  9996 FORMAT( ' DPOEQU failed test with value ', D10.3, ' exceeding',
00481      $      ' threshold ', D10.3 )
00482  9995 FORMAT( ' DPPEQU failed test with value ', D10.3, ' exceeding',
00483      $      ' threshold ', D10.3 )
00484  9994 FORMAT( ' DPBEQU failed test with value ', D10.3, ' exceeding',
00485      $      ' threshold ', D10.3 )
00486       RETURN
00487 *
00488 *     End of DCHKEQ
00489 *
00490       END
 All Files Functions