LAPACK: TESTING/LIN/cchkqp.f Source File

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