LAPACK: TESTING/LIN/schkq3.f Source File

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