LAPACK  3.4.1
LAPACK: Linear Algebra PACKage
schkqp.f
Go to the documentation of this file.
00001 *> \brief \b SCHKQP
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 SCHKQP( DOTYPE, NM, MVAL, NN, NVAL, THRESH, TSTERR, A,
00012 *                          COPYA, S, TAU, WORK, IWORK, NOUT )
00013 * 
00014 *       .. Scalar Arguments ..
00015 *       LOGICAL            TSTERR
00016 *       INTEGER            NM, NN, NOUT
00017 *       REAL               THRESH
00018 *       ..
00019 *       .. Array Arguments ..
00020 *       LOGICAL            DOTYPE( * )
00021 *       INTEGER            IWORK( * ), MVAL( * ), NVAL( * )
00022 *       REAL               A( * ), COPYA( * ), S( * ),
00023 *      $                   TAU( * ), WORK( * )
00024 *       ..
00025 *  
00026 *
00027 *> \par Purpose:
00028 *  =============
00029 *>
00030 *> \verbatim
00031 *>
00032 *> SCHKQP tests SGEQPF.
00033 *> \endverbatim
00034 *
00035 *  Arguments:
00036 *  ==========
00037 *
00038 *> \param[in] DOTYPE
00039 *> \verbatim
00040 *>          DOTYPE is LOGICAL array, dimension (NTYPES)
00041 *>          The matrix types to be used for testing.  Matrices of type j
00042 *>          (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
00043 *>          .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
00044 *> \endverbatim
00045 *>
00046 *> \param[in] NM
00047 *> \verbatim
00048 *>          NM is INTEGER
00049 *>          The number of values of M contained in the vector MVAL.
00050 *> \endverbatim
00051 *>
00052 *> \param[in] MVAL
00053 *> \verbatim
00054 *>          MVAL is INTEGER array, dimension (NM)
00055 *>          The values of the matrix row dimension M.
00056 *> \endverbatim
00057 *>
00058 *> \param[in] NN
00059 *> \verbatim
00060 *>          NN is INTEGER
00061 *>          The number of values of N contained in the vector NVAL.
00062 *> \endverbatim
00063 *>
00064 *> \param[in] NVAL
00065 *> \verbatim
00066 *>          NVAL is INTEGER array, dimension (NN)
00067 *>          The values of the matrix column dimension N.
00068 *> \endverbatim
00069 *>
00070 *> \param[in] THRESH
00071 *> \verbatim
00072 *>          THRESH is REAL
00073 *>          The threshold value for the test ratios.  A result is
00074 *>          included in the output file if RESULT >= THRESH.  To have
00075 *>          every test ratio printed, use THRESH = 0.
00076 *> \endverbatim
00077 *>
00078 *> \param[in] TSTERR
00079 *> \verbatim
00080 *>          TSTERR is LOGICAL
00081 *>          Flag that indicates whether error exits are to be tested.
00082 *> \endverbatim
00083 *>
00084 *> \param[out] A
00085 *> \verbatim
00086 *>          A is REAL array, dimension (MMAX*NMAX)
00087 *>          where MMAX is the maximum value of M in MVAL and NMAX is the
00088 *>          maximum value of N in NVAL.
00089 *> \endverbatim
00090 *>
00091 *> \param[out] COPYA
00092 *> \verbatim
00093 *>          COPYA is REAL array, dimension (MMAX*NMAX)
00094 *> \endverbatim
00095 *>
00096 *> \param[out] S
00097 *> \verbatim
00098 *>          S is REAL array, dimension
00099 *>                      (min(MMAX,NMAX))
00100 *> \endverbatim
00101 *>
00102 *> \param[out] TAU
00103 *> \verbatim
00104 *>          TAU is REAL array, dimension (MMAX)
00105 *> \endverbatim
00106 *>
00107 *> \param[out] WORK
00108 *> \verbatim
00109 *>          WORK is REAL array, dimension
00110 *>                      (MMAX*NMAX + 4*NMAX + MMAX)
00111 *> \endverbatim
00112 *>
00113 *> \param[out] IWORK
00114 *> \verbatim
00115 *>          IWORK is INTEGER array, dimension (NMAX)
00116 *> \endverbatim
00117 *>
00118 *> \param[in] NOUT
00119 *> \verbatim
00120 *>          NOUT is INTEGER
00121 *>          The unit number for output.
00122 *> \endverbatim
00123 *
00124 *  Authors:
00125 *  ========
00126 *
00127 *> \author Univ. of Tennessee 
00128 *> \author Univ. of California Berkeley 
00129 *> \author Univ. of Colorado Denver 
00130 *> \author NAG Ltd. 
00131 *
00132 *> \date November 2011
00133 *
00134 *> \ingroup single_lin
00135 *
00136 *  =====================================================================
00137       SUBROUTINE SCHKQP( DOTYPE, NM, MVAL, NN, NVAL, THRESH, TSTERR, A,
00138      $                   COPYA, S, TAU, WORK, IWORK, NOUT )
00139 *
00140 *  -- LAPACK test routine (version 3.4.0) --
00141 *  -- LAPACK is a software package provided by Univ. of Tennessee,    --
00142 *  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
00143 *     November 2011
00144 *
00145 *     .. Scalar Arguments ..
00146       LOGICAL            TSTERR
00147       INTEGER            NM, NN, NOUT
00148       REAL               THRESH
00149 *     ..
00150 *     .. Array Arguments ..
00151       LOGICAL            DOTYPE( * )
00152       INTEGER            IWORK( * ), MVAL( * ), NVAL( * )
00153       REAL               A( * ), COPYA( * ), S( * ),
00154      $                   TAU( * ), WORK( * )
00155 *     ..
00156 *
00157 *  =====================================================================
00158 *
00159 *     .. Parameters ..
00160       INTEGER            NTYPES
00161       PARAMETER          ( NTYPES = 6 )
00162       INTEGER            NTESTS
00163       PARAMETER          ( NTESTS = 3 )
00164       REAL               ONE, ZERO
00165       PARAMETER          ( ONE = 1.0E0, ZERO = 0.0E0 )
00166 *     ..
00167 *     .. Local Scalars ..
00168       CHARACTER*3        PATH
00169       INTEGER            I, IHIGH, ILOW, IM, IMODE, IN, INFO, ISTEP, K,
00170      $                   LDA, LWORK, M, MNMIN, MODE, N, NERRS, NFAIL,
00171      $                   NRUN
00172       REAL               EPS
00173 *     ..
00174 *     .. Local Arrays ..
00175       INTEGER            ISEED( 4 ), ISEEDY( 4 )
00176       REAL               RESULT( NTESTS )
00177 *     ..
00178 *     .. External Functions ..
00179       REAL               SLAMCH, SQPT01, SQRT11, SQRT12
00180       EXTERNAL           SLAMCH, SQPT01, SQRT11, SQRT12
00181 *     ..
00182 *     .. External Subroutines ..
00183       EXTERNAL           ALAHD, ALASUM, SERRQP, SGEQPF, SLACPY, SLAORD,
00184      $                   SLASET, SLATMS
00185 *     ..
00186 *     .. Intrinsic Functions ..
00187       INTRINSIC          MAX, MIN
00188 *     ..
00189 *     .. Scalars in Common ..
00190       LOGICAL            LERR, OK
00191       CHARACTER*32       SRNAMT
00192       INTEGER            INFOT, IOUNIT
00193 *     ..
00194 *     .. Common blocks ..
00195       COMMON             / INFOC / INFOT, IOUNIT, OK, LERR
00196       COMMON             / SRNAMC / SRNAMT
00197 *     ..
00198 *     .. Data statements ..
00199       DATA               ISEEDY / 1988, 1989, 1990, 1991 /
00200 *     ..
00201 *     .. Executable Statements ..
00202 *
00203 *     Initialize constants and the random number seed.
00204 *
00205       PATH( 1: 1 ) = 'Single precision'
00206       PATH( 2: 3 ) = 'QP'
00207       NRUN = 0
00208       NFAIL = 0
00209       NERRS = 0
00210       DO 10 I = 1, 4
00211          ISEED( I ) = ISEEDY( I )
00212    10 CONTINUE
00213       EPS = SLAMCH( 'Epsilon' )
00214 *
00215 *     Test the error exits
00216 *
00217       IF( TSTERR )
00218      $   CALL SERRQP( PATH, NOUT )
00219       INFOT = 0
00220 *
00221       DO 80 IM = 1, NM
00222 *
00223 *        Do for each value of M in MVAL.
00224 *
00225          M = MVAL( IM )
00226          LDA = MAX( 1, M )
00227 *
00228          DO 70 IN = 1, NN
00229 *
00230 *           Do for each value of N in NVAL.
00231 *
00232             N = NVAL( IN )
00233             MNMIN = MIN( M, N )
00234             LWORK = MAX( 1, M*MAX( M, N ) + 4*MNMIN + MAX( M, N ),
00235      $                   M*N + 2*MNMIN + 4*N )
00236 *
00237             DO 60 IMODE = 1, NTYPES
00238                IF( .NOT.DOTYPE( IMODE ) )
00239      $            GO TO 60
00240 *
00241 *              Do for each type of matrix
00242 *                 1:  zero matrix
00243 *                 2:  one small singular value
00244 *                 3:  geometric distribution of singular values
00245 *                 4:  first n/2 columns fixed
00246 *                 5:  last n/2 columns fixed
00247 *                 6:  every second column fixed
00248 *
00249                MODE = IMODE
00250                IF( IMODE.GT.3 )
00251      $            MODE = 1
00252 *
00253 *              Generate test matrix of size m by n using
00254 *              singular value distribution indicated by `mode'.
00255 *
00256                DO 20 I = 1, N
00257                   IWORK( I ) = 0
00258    20          CONTINUE
00259                IF( IMODE.EQ.1 ) THEN
00260                   CALL SLASET( 'Full', M, N, ZERO, ZERO, COPYA, LDA )
00261                   DO 30 I = 1, MNMIN
00262                      S( I ) = ZERO
00263    30             CONTINUE
00264                ELSE
00265                   CALL SLATMS( M, N, 'Uniform', ISEED, 'Nonsymm', S,
00266      $                         MODE, ONE / EPS, ONE, M, N, 'No packing',
00267      $                         COPYA, LDA, WORK, INFO )
00268                   IF( IMODE.GE.4 ) THEN
00269                      IF( IMODE.EQ.4 ) THEN
00270                         ILOW = 1
00271                         ISTEP = 1
00272                         IHIGH = MAX( 1, N / 2 )
00273                      ELSE IF( IMODE.EQ.5 ) THEN
00274                         ILOW = MAX( 1, N / 2 )
00275                         ISTEP = 1
00276                         IHIGH = N
00277                      ELSE IF( IMODE.EQ.6 ) THEN
00278                         ILOW = 1
00279                         ISTEP = 2
00280                         IHIGH = N
00281                      END IF
00282                      DO 40 I = ILOW, IHIGH, ISTEP
00283                         IWORK( I ) = 1
00284    40                CONTINUE
00285                   END IF
00286                   CALL SLAORD( 'Decreasing', MNMIN, S, 1 )
00287                END IF
00288 *
00289 *              Save A and its singular values
00290 *
00291                CALL SLACPY( 'All', M, N, COPYA, LDA, A, LDA )
00292 *
00293 *              Compute the QR factorization with pivoting of A
00294 *
00295                SRNAMT = 'SGEQPF'
00296                CALL SGEQPF( M, N, A, LDA, IWORK, TAU, WORK, INFO )
00297 *
00298 *              Compute norm(svd(a) - svd(r))
00299 *
00300                RESULT( 1 ) = SQRT12( M, N, A, LDA, S, WORK, LWORK )
00301 *
00302 *              Compute norm( A*P - Q*R )
00303 *
00304                RESULT( 2 ) = SQPT01( M, N, MNMIN, COPYA, A, LDA, TAU,
00305      $                       IWORK, WORK, LWORK )
00306 *
00307 *              Compute Q'*Q
00308 *
00309                RESULT( 3 ) = SQRT11( M, MNMIN, A, LDA, TAU, WORK,
00310      $                       LWORK )
00311 *
00312 *              Print information about the tests that did not pass
00313 *              the threshold.
00314 *
00315                DO 50 K = 1, 3
00316                   IF( RESULT( K ).GE.THRESH ) THEN
00317                      IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
00318      $                  CALL ALAHD( NOUT, PATH )
00319                      WRITE( NOUT, FMT = 9999 )M, N, IMODE, K,
00320      $                  RESULT( K )
00321                      NFAIL = NFAIL + 1
00322                   END IF
00323    50          CONTINUE
00324                NRUN = NRUN + 3
00325    60       CONTINUE
00326    70    CONTINUE
00327    80 CONTINUE
00328 *
00329 *     Print a summary of the results.
00330 *
00331       CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS )
00332 *
00333  9999 FORMAT( ' M =', I5, ', N =', I5, ', type ', I2, ', test ', I2,
00334      $      ', ratio =', G12.5 )
00335 *
00336 *     End of SCHKQP
00337 *
00338       END
 All Files Functions