LAPACK: TESTING/LIN/dchkqp.f Source File

Go to the documentation of this file.
00001       SUBROUTINE DCHKQP( DOTYPE, NM, MVAL, NN, NVAL, THRESH, TSTERR, A,
00002      $                   COPYA, S, COPYS, TAU, WORK, IWORK, NOUT )
00003 *
00004 *  -- LAPACK test routine (version 3.1.1) --
00005 *     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
00006 *     January 2007
00007 *
00008 *     .. Scalar Arguments ..
00009       LOGICAL            TSTERR
00010       INTEGER            NM, NN, NOUT
00011       DOUBLE PRECISION   THRESH
00012 *     ..
00013 *     .. Array Arguments ..
00014       LOGICAL            DOTYPE( * )
00015       INTEGER            IWORK( * ), MVAL( * ), NVAL( * )
00016       DOUBLE PRECISION   A( * ), COPYA( * ), COPYS( * ), S( * ),
00017      $                   TAU( * ), WORK( * )
00018 *     ..
00019 *
00020 *  Purpose
00021 *  =======
00022 *
00023 *  DCHKQP tests DGEQPF.
00024 *
00025 *  Arguments
00026 *  =========
00027 *
00028 *  DOTYPE  (input) LOGICAL array, dimension (NTYPES)
00029 *          The matrix types to be used for testing.  Matrices of type j
00030 *          (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
00031 *          .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
00032 *
00033 *  NM      (input) INTEGER
00034 *          The number of values of M contained in the vector MVAL.
00035 *
00036 *  MVAL    (input) INTEGER array, dimension (NM)
00037 *          The values of the matrix row dimension M.
00038 *
00039 *  NN      (input) INTEGER
00040 *          The number of values of N contained in the vector NVAL.
00041 *
00042 *  NVAL    (input) INTEGER array, dimension (NN)
00043 *          The values of the matrix column dimension N.
00044 *
00045 *  THRESH  (input) DOUBLE PRECISION
00046 *          The threshold value for the test ratios.  A result is
00047 *          included in the output file if RESULT >= THRESH.  To have
00048 *          every test ratio printed, use THRESH = 0.
00049 *
00050 *  TSTERR  (input) LOGICAL
00051 *          Flag that indicates whether error exits are to be tested.
00052 *
00053 *  A       (workspace) DOUBLE PRECISION array, dimension (MMAX*NMAX)
00054 *          where MMAX is the maximum value of M in MVAL and NMAX is the
00055 *          maximum value of N in NVAL.
00056 *
00057 *  COPYA   (workspace) DOUBLE PRECISION array, dimension (MMAX*NMAX)
00058 *
00059 *  S       (workspace) DOUBLE PRECISION array, dimension
00060 *                      (min(MMAX,NMAX))
00061 *
00062 *  COPYS   (workspace) DOUBLE PRECISION array, dimension
00063 *                      (min(MMAX,NMAX))
00064 *
00065 *  TAU     (workspace) DOUBLE PRECISION array, dimension (MMAX)
00066 *
00067 *  WORK    (workspace) DOUBLE PRECISION array, dimension
00068 *                      (MMAX*NMAX + 4*NMAX + MMAX)
00069 *
00070 *  IWORK   (workspace) INTEGER array, dimension (NMAX)
00071 *
00072 *  NOUT    (input) INTEGER
00073 *          The unit number for output.
00074 *
00075 *  =====================================================================
00076 *
00077 *     .. Parameters ..
00078       INTEGER            NTYPES
00079       PARAMETER          ( NTYPES = 6 )
00080       INTEGER            NTESTS
00081       PARAMETER          ( NTESTS = 3 )
00082       DOUBLE PRECISION   ONE, ZERO
00083       PARAMETER          ( ONE = 1.0D0, ZERO = 0.0D0 )
00084 *     ..
00085 *     .. Local Scalars ..
00086       CHARACTER*3        PATH
00087       INTEGER            I, IHIGH, ILOW, IM, IMODE, IN, INFO, ISTEP, K,
00088      $                   LDA, LWORK, M, MNMIN, MODE, N, NERRS, NFAIL,
00089      $                   NRUN
00090       DOUBLE PRECISION   EPS
00091 *     ..
00092 *     .. Local Arrays ..
00093       INTEGER            ISEED( 4 ), ISEEDY( 4 )
00094       DOUBLE PRECISION   RESULT( NTESTS )
00095 *     ..
00096 *     .. External Functions ..
00097       DOUBLE PRECISION   DLAMCH, DQPT01, DQRT11, DQRT12
00098       EXTERNAL           DLAMCH, DQPT01, DQRT11, DQRT12
00099 *     ..
00100 *     .. External Subroutines ..
00101       EXTERNAL           ALAHD, ALASUM, DERRQP, DGEQPF, DLACPY, DLAORD,
00102      $                   DLASET, DLATMS
00103 *     ..
00104 *     .. Intrinsic Functions ..
00105       INTRINSIC          MAX, MIN
00106 *     ..
00107 *     .. Scalars in Common ..
00108       LOGICAL            LERR, OK
00109       CHARACTER*32       SRNAMT
00110       INTEGER            INFOT, IOUNIT
00111 *     ..
00112 *     .. Common blocks ..
00113       COMMON             / INFOC / INFOT, IOUNIT, OK, LERR
00114       COMMON             / SRNAMC / SRNAMT
00115 *     ..
00116 *     .. Data statements ..
00117       DATA               ISEEDY / 1988, 1989, 1990, 1991 /
00118 *     ..
00119 *     .. Executable Statements ..
00120 *
00121 *     Initialize constants and the random number seed.
00122 *
00123       PATH( 1: 1 ) = 'Double precision'
00124       PATH( 2: 3 ) = 'QP'
00125       NRUN = 0
00126       NFAIL = 0
00127       NERRS = 0
00128       DO 10 I = 1, 4
00129          ISEED( I ) = ISEEDY( I )
00130    10 CONTINUE
00131       EPS = DLAMCH( 'Epsilon' )
00132 *
00133 *     Test the error exits
00134 *
00135       IF( TSTERR )
00136      $   CALL DERRQP( PATH, NOUT )
00137       INFOT = 0
00138 *
00139       DO 80 IM = 1, NM
00140 *
00141 *        Do for each value of M in MVAL.
00142 *
00143          M = MVAL( IM )
00144          LDA = MAX( 1, M )
00145 *
00146          DO 70 IN = 1, NN
00147 *
00148 *           Do for each value of N in NVAL.
00149 *
00150             N = NVAL( IN )
00151             MNMIN = MIN( M, N )
00152             LWORK = MAX( 1, M*MAX( M, N ) + 4*MNMIN + MAX( M, N ),
00153      $                   M*N + 2*MNMIN + 4*N )
00154 *
00155             DO 60 IMODE = 1, NTYPES
00156                IF( .NOT.DOTYPE( IMODE ) )
00157      $            GO TO 60
00158 *
00159 *              Do for each type of matrix
00160 *                 1:  zero matrix
00161 *                 2:  one small singular value
00162 *                 3:  geometric distribution of singular values
00163 *                 4:  first n/2 columns fixed
00164 *                 5:  last n/2 columns fixed
00165 *                 6:  every second column fixed
00166 *
00167                MODE = IMODE
00168                IF( IMODE.GT.3 )
00169      $            MODE = 1
00170 *
00171 *              Generate test matrix of size m by n using
00172 *              singular value distribution indicated by `mode'.
00173 *
00174                DO 20 I = 1, N
00175                   IWORK( I ) = 0
00176    20          CONTINUE
00177                IF( IMODE.EQ.1 ) THEN
00178                   CALL DLASET( 'Full', M, N, ZERO, ZERO, COPYA, LDA )
00179                   DO 30 I = 1, MNMIN
00180                      COPYS( I ) = ZERO
00181    30             CONTINUE
00182                ELSE
00183                   CALL DLATMS( M, N, 'Uniform', ISEED, 'Nonsymm', COPYS,
00184      $                         MODE, ONE / EPS, ONE, M, N, 'No packing',
00185      $                         COPYA, LDA, WORK, INFO )
00186                   IF( IMODE.GE.4 ) THEN
00187                      IF( IMODE.EQ.4 ) THEN
00188                         ILOW = 1
00189                         ISTEP = 1
00190                         IHIGH = MAX( 1, N / 2 )
00191                      ELSE IF( IMODE.EQ.5 ) THEN
00192                         ILOW = MAX( 1, N / 2 )
00193                         ISTEP = 1
00194                         IHIGH = N
00195                      ELSE IF( IMODE.EQ.6 ) THEN
00196                         ILOW = 1
00197                         ISTEP = 2
00198                         IHIGH = N
00199                      END IF
00200                      DO 40 I = ILOW, IHIGH, ISTEP
00201                         IWORK( I ) = 1
00202    40                CONTINUE
00203                   END IF
00204                   CALL DLAORD( 'Decreasing', MNMIN, COPYS, 1 )
00205                END IF
00206 *
00207 *              Save A and its singular values
00208 *
00209                CALL DLACPY( 'All', M, N, COPYA, LDA, A, LDA )
00210 *
00211 *              Compute the QR factorization with pivoting of A
00212 *
00213                SRNAMT = 'DGEQPF'
00214                CALL DGEQPF( M, N, A, LDA, IWORK, TAU, WORK, INFO )
00215 *
00216 *              Compute norm(svd(a) - svd(r))
00217 *
00218                RESULT( 1 ) = DQRT12( M, N, A, LDA, COPYS, WORK, LWORK )
00219 *
00220 *              Compute norm( A*P - Q*R )
00221 *
00222                RESULT( 2 ) = DQPT01( M, N, MNMIN, COPYA, A, LDA, TAU,
00223      $                       IWORK, WORK, LWORK )
00224 *
00225 *              Compute Q'*Q
00226 *
00227                RESULT( 3 ) = DQRT11( M, MNMIN, A, LDA, TAU, WORK,
00228      $                       LWORK )
00229 *
00230 *              Print information about the tests that did not pass
00231 *              the threshold.
00232 *
00233                DO 50 K = 1, 3
00234                   IF( RESULT( K ).GE.THRESH ) THEN
00235                      IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
00236      $                  CALL ALAHD( NOUT, PATH )
00237                      WRITE( NOUT, FMT = 9999 )M, N, IMODE, K,
00238      $                  RESULT( K )
00239                      NFAIL = NFAIL + 1
00240                   END IF
00241    50          CONTINUE
00242                NRUN = NRUN + 3
00243    60       CONTINUE
00244    70    CONTINUE
00245    80 CONTINUE
00246 *
00247 *     Print a summary of the results.
00248 *
00249       CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS )
00250 *
00251  9999 FORMAT( ' M =', I5, ', N =', I5, ', type ', I2, ', test ', I2,
00252      $      ', ratio =', G12.5 )
00253 *
00254 *     End of DCHKQP
00255 *
00256       END