|
123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836 |
- *> \brief \b CCHKQP3RK
- *
- * =========== DOCUMENTATION ===========
- *
- * Online html documentation available at
- * http://www.netlib.org/lapack/explore-html/
- *
- * Definition:
- * ===========
- *
- * SUBROUTINE CCHKQP3RK( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL,
- * $ NNB, NBVAL, NXVAL, THRESH, A, COPYA,
- * $ B, COPYB, S, TAU,
- * $ WORK, RWORK, IWORK, NOUT )
- * IMPLICIT NONE
- *
- * .. Scalar Arguments ..
- * INTEGER NM, NN, NNB, NOUT
- * REAL THRESH
- * ..
- * .. Array Arguments ..
- * LOGICAL DOTYPE( * )
- * INTEGER IWORK( * ), MVAL( * ), NBVAL( * ), NVAL( * ),
- * $ NXVAL( * )
- * REAL S( * ), RWORK( * )
- * COMPLEX A( * ), COPYA( * ), TAU( * ), WORK( * )
- * ..
- *
- *
- *> \par Purpose:
- * =============
- *>
- *> \verbatim
- *>
- *> CCHKQP3RK tests CGEQP3RK.
- *> \endverbatim
- *
- * Arguments:
- * ==========
- *
- *> \param[in] DOTYPE
- *> \verbatim
- *> DOTYPE is LOGICAL array, dimension (NTYPES)
- *> The matrix types to be used for testing. Matrices of type j
- *> (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
- *> .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
- *> \endverbatim
- *>
- *> \param[in] NM
- *> \verbatim
- *> NM is INTEGER
- *> The number of values of M contained in the vector MVAL.
- *> \endverbatim
- *>
- *> \param[in] MVAL
- *> \verbatim
- *> MVAL is INTEGER array, dimension (NM)
- *> The values of the matrix row dimension M.
- *> \endverbatim
- *>
- *> \param[in] NN
- *> \verbatim
- *> NN is INTEGER
- *> The number of values of N contained in the vector NVAL.
- *> \endverbatim
- *>
- *> \param[in] NVAL
- *> \verbatim
- *> NVAL is INTEGER array, dimension (NN)
- *> The values of the matrix column dimension N.
- *> \endverbatim
- *>
- *> \param[in] NNS
- *> \verbatim
- *> NNS is INTEGER
- *> The number of values of NRHS contained in the vector NSVAL.
- *> \endverbatim
- *>
- *> \param[in] NSVAL
- *> \verbatim
- *> NSVAL is INTEGER array, dimension (NNS)
- *> The values of the number of right hand sides NRHS.
- *> \endverbatim
- *> \param[in] NNB
- *> \verbatim
- *> NNB is INTEGER
- *> The number of values of NB and NX contained in the
- *> vectors NBVAL and NXVAL. The blocking parameters are used
- *> in pairs (NB,NX).
- *> \endverbatim
- *>
- *> \param[in] NBVAL
- *> \verbatim
- *> NBVAL is INTEGER array, dimension (NNB)
- *> The values of the blocksize NB.
- *> \endverbatim
- *>
- *> \param[in] NXVAL
- *> \verbatim
- *> NXVAL is INTEGER array, dimension (NNB)
- *> The values of the crossover point NX.
- *> \endverbatim
- *>
- *> \param[in] THRESH
- *> \verbatim
- *> THRESH is REAL
- *> The threshold value for the test ratios. A result is
- *> included in the output file if RESULT >= THRESH. To have
- *> every test ratio printed, use THRESH = 0.
- *> \endverbatim
- *>
- *> \param[out] A
- *> \verbatim
- *> A is COMPLEX array, dimension (MMAX*NMAX)
- *> where MMAX is the maximum value of M in MVAL and NMAX is the
- *> maximum value of N in NVAL.
- *> \endverbatim
- *>
- *> \param[out] COPYA
- *> \verbatim
- *> COPYA is COMPLEX array, dimension (MMAX*NMAX)
- *> \endverbatim
- *>
- *> \param[out] B
- *> \verbatim
- *> B is COMPLEX array, dimension (MMAX*NSMAX)
- *> where MMAX is the maximum value of M in MVAL and NSMAX is the
- *> maximum value of NRHS in NSVAL.
- *> \endverbatim
- *>
- *> \param[out] COPYB
- *> \verbatim
- *> COPYB is COMPLEX array, dimension (MMAX*NSMAX)
- *> \endverbatim
- *>
- *> \param[out] S
- *> \verbatim
- *> S is REAL array, dimension
- *> (min(MMAX,NMAX))
- *> \endverbatim
- *>
- *> \param[out] TAU
- *> \verbatim
- *> TAU is COMPLEX array, dimension (MMAX)
- *> \endverbatim
- *>
- *> \param[out] WORK
- *> \verbatim
- *> WORK is COMPLEX array, dimension
- *> (max(M*max(M,N) + 4*min(M,N) + max(M,N)))
- *> \endverbatim
- *>
- *> \param[out] RWORK
- *> \verbatim
- *> RWORK is REAL array, dimension (4*NMAX)
- *> \endverbatim
- *>
- *> \param[out] IWORK
- *> \verbatim
- *> IWORK is INTEGER array, dimension (2*NMAX)
- *> \endverbatim
- *>
- *> \param[in] NOUT
- *> \verbatim
- *> NOUT is INTEGER
- *> The unit number for output.
- *> \endverbatim
- *
- * Authors:
- * ========
- *
- *> \author Univ. of Tennessee
- *> \author Univ. of California Berkeley
- *> \author Univ. of Colorado Denver
- *> \author NAG Ltd.
- *
- *> \ingroup complex_lin
- *
- * =====================================================================
- SUBROUTINE CCHKQP3RK( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL,
- $ NNB, NBVAL, NXVAL, THRESH, A, COPYA,
- $ B, COPYB, S, TAU,
- $ WORK, RWORK, IWORK, NOUT )
- IMPLICIT NONE
- *
- * -- LAPACK test routine --
- * -- LAPACK is a software package provided by Univ. of Tennessee, --
- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
- *
- * .. Scalar Arguments ..
- INTEGER NM, NN, NNB, NNS, NOUT
- REAL THRESH
- * ..
- * .. Array Arguments ..
- LOGICAL DOTYPE( * )
- INTEGER IWORK( * ), NBVAL( * ), MVAL( * ), NVAL( * ),
- $ NSVAL( * ), NXVAL( * )
- REAL S( * ), RWORK( * )
- COMPLEX A( * ), COPYA( * ), B( * ), COPYB( * ),
- $ TAU( * ), WORK( * )
- * ..
- *
- * =====================================================================
- *
- * .. Parameters ..
- INTEGER NTYPES
- PARAMETER ( NTYPES = 19 )
- INTEGER NTESTS
- PARAMETER ( NTESTS = 5 )
- REAL ONE, ZERO, BIGNUM
- COMPLEX CONE, CZERO
- PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0,
- $ CZERO = ( 0.0E+0, 0.0E+0 ),
- $ CONE = ( 1.0E+0, 0.0E+0 ),
- $ BIGNUM = 1.0E+38 )
- * ..
- * .. Local Scalars ..
- CHARACTER DIST, TYPE
- CHARACTER*3 PATH
- INTEGER I, IHIGH, ILOW, IM, IMAT, IN, INC_ZERO,
- $ INB, IND_OFFSET_GEN,
- $ IND_IN, IND_OUT, INS, INFO,
- $ ISTEP, J, J_INC, J_FIRST_NZ, JB_ZERO,
- $ KFACT, KL, KMAX, KU, LDA, LW, LWORK,
- $ LWORK_MQR, M, MINMN, MINMNB_GEN, MODE, N,
- $ NB, NB_ZERO, NERRS, NFAIL, NB_GEN, NRHS,
- $ NRUN, NX, T
- REAL ANORM, CNDNUM, EPS, ABSTOL, RELTOL,
- $ DTEMP, MAXC2NRMK, RELMAXC2NRMK
- * ..
- * .. Local Arrays ..
- INTEGER ISEED( 4 ), ISEEDY( 4 )
- REAL RESULT( NTESTS ), RDUMMY( 1 )
- * ..
- * .. External Functions ..
- REAL SLAMCH, CQPT01, CQRT11, CQRT12, CLANGE
- EXTERNAL SLAMCH, CQPT01, CQRT11, CQRT12, CLANGE
- * ..
- * .. External Subroutines ..
- EXTERNAL ALAERH, ALAHD, ALASUM, SLAORD, ICOPY, CAXPY,
- $ XLAENV, CGEQP3RK, CLACPY, CLASET, CLATB4,
- $ CLATMS, CUNMQR, CSWAP
- * ..
- * .. Intrinsic Functions ..
- INTRINSIC ABS, MAX, MIN, MOD, REAL
- * ..
- * .. Scalars in Common ..
- LOGICAL LERR, OK
- CHARACTER*32 SRNAMT
- INTEGER INFOT, IOUNIT, CUNMQR_LWORK
- * ..
- * .. Common blocks ..
- COMMON / INFOC / INFOT, IOUNIT, OK, LERR
- COMMON / SRNAMC / SRNAMT
- * ..
- * .. Data statements ..
- DATA ISEEDY / 1988, 1989, 1990, 1991 /
- * ..
- * .. Executable Statements ..
- *
- * Initialize constants and the random number seed.
- *
- PATH( 1: 1 ) = 'Complex precision'
- PATH( 2: 3 ) = 'QK'
- NRUN = 0
- NFAIL = 0
- NERRS = 0
- DO I = 1, 4
- ISEED( I ) = ISEEDY( I )
- END DO
- EPS = SLAMCH( 'Epsilon' )
- INFOT = 0
- *
- DO IM = 1, NM
- *
- * Do for each value of M in MVAL.
- *
- M = MVAL( IM )
- LDA = MAX( 1, M )
- *
- DO IN = 1, NN
- *
- * Do for each value of N in NVAL.
- *
- N = NVAL( IN )
- MINMN = MIN( M, N )
- LWORK = MAX( 1, M*MAX( M, N )+4*MINMN+MAX( M, N ),
- $ M*N + 2*MINMN + 4*N )
- *
- DO INS = 1, NNS
- NRHS = NSVAL( INS )
- *
- * Set up parameters with CLATB4 and generate
- * M-by-NRHS B matrix with CLATMS.
- * IMAT = 14:
- * Random matrix, CNDNUM = 2, NORM = ONE,
- * MODE = 3 (geometric distribution of singular values).
- *
- CALL CLATB4( PATH, 14, M, NRHS, TYPE, KL, KU, ANORM,
- $ MODE, CNDNUM, DIST )
- *
- SRNAMT = 'CLATMS'
- CALL CLATMS( M, NRHS, DIST, ISEED, TYPE, S, MODE,
- $ CNDNUM, ANORM, KL, KU, 'No packing',
- $ COPYB, LDA, WORK, INFO )
- *
- * Check error code from CLATMS.
- *
- IF( INFO.NE.0 ) THEN
- CALL ALAERH( PATH, 'CLATMS', INFO, 0, ' ', M,
- $ NRHS, -1, -1, -1, 6, NFAIL, NERRS,
- $ NOUT )
- CYCLE
- END IF
- *
- DO IMAT = 1, NTYPES
- *
- * Do the tests only if DOTYPE( IMAT ) is true.
- *
- IF( .NOT.DOTYPE( IMAT ) )
- $ CYCLE
- *
- * The type of distribution used to generate the random
- * eigen-/singular values:
- * ( 'S' for symmetric distribution ) => UNIFORM( -1, 1 )
- *
- * Do for each type of NON-SYMMETRIC matrix: CNDNUM NORM MODE
- * 1. Zero matrix
- * 2. Random, Diagonal, CNDNUM = 2 CNDNUM = 2 ONE 3 ( geometric distribution of singular values )
- * 3. Random, Upper triangular, CNDNUM = 2 CNDNUM = 2 ONE 3 ( geometric distribution of singular values )
- * 4. Random, Lower triangular, CNDNUM = 2 CNDNUM = 2 ONE 3 ( geometric distribution of singular values )
- * 5. Random, First column is zero, CNDNUM = 2 CNDNUM = 2 ONE 3 ( geometric distribution of singular values )
- * 6. Random, Last MINMN column is zero, CNDNUM = 2 CNDNUM = 2 ONE 3 ( geometric distribution of singular values )
- * 7. Random, Last N column is zero, CNDNUM = 2 CNDNUM = 2 ONE 3 ( geometric distribution of singular values )
- * 8. Random, Middle column in MINMN is zero, CNDNUM = 2 CNDNUM = 2 ONE 3 ( geometric distribution of singular values )
- * 9. Random, First half of MINMN columns are zero, CNDNUM = 2 CNDNUM = 2 ONE 3 ( geometric distribution of singular values )
- * 10. Random, Last columns are zero starting from MINMN/2+1, CNDNUM = 2 CNDNUM = 2 ONE 3 ( geometric distribution of singular values )
- * 11. Random, Half MINMN columns in the middle are zero starting
- * from MINMN/2-(MINMN/2)/2+1, CNDNUM = 2 CNDNUM = 2 ONE 3 ( geometric distribution of singular values )
- * 12. Random, Odd columns are ZERO, CNDNUM = 2 CNDNUM = 2 ONE 3 ( geometric distribution of singular values )
- * 13. Random, Even columns are ZERO, CNDNUM = 2 CNDNUM = 2 ONE 3 ( geometric distribution of singular values )
- * 14. Random, CNDNUM = 2 CNDNUM = 2 ONE 3 ( geometric distribution of singular values )
- * 15. Random, CNDNUM = sqrt(0.1/EPS) CNDNUM = BADC1 = sqrt(0.1/EPS) ONE 3 ( geometric distribution of singular values )
- * 16. Random, CNDNUM = 0.1/EPS CNDNUM = BADC2 = 0.1/EPS ONE 3 ( geometric distribution of singular values )
- * 17. Random, CNDNUM = 0.1/EPS, CNDNUM = BADC2 = 0.1/EPS ONE 2 ( one small singular value, S(N)=1/CNDNUM )
- * one small singular value S(N)=1/CNDNUM
- * 18. Random, CNDNUM = 2, scaled near underflow CNDNUM = 2 SMALL = SAFMIN
- * 19. Random, CNDNUM = 2, scaled near overflow CNDNUM = 2 LARGE = 1.0/( 0.25 * ( SAFMIN / EPS ) ) 3 ( geometric distribution of singular values )
- *
- IF( IMAT.EQ.1 ) THEN
- *
- * Matrix 1: Zero matrix
- *
- CALL CLASET( 'Full', M, N, CZERO, CZERO, COPYA, LDA )
- DO I = 1, MINMN
- S( I ) = ZERO
- END DO
- *
- ELSE IF( (IMAT.GE.2 .AND. IMAT.LE.4 )
- $ .OR. (IMAT.GE.14 .AND. IMAT.LE.19 ) ) THEN
- *
- * Matrices 2-5.
- *
- * Set up parameters with DLATB4 and generate a test
- * matrix with CLATMS.
- *
- CALL CLATB4( PATH, IMAT, M, N, TYPE, KL, KU, ANORM,
- $ MODE, CNDNUM, DIST )
- *
- SRNAMT = 'CLATMS'
- CALL CLATMS( M, N, DIST, ISEED, TYPE, S, MODE,
- $ CNDNUM, ANORM, KL, KU, 'No packing',
- $ COPYA, LDA, WORK, INFO )
- *
- * Check error code from CLATMS.
- *
- IF( INFO.NE.0 ) THEN
- CALL ALAERH( PATH, 'CLATMS', INFO, 0, ' ', M, N,
- $ -1, -1, -1, IMAT, NFAIL, NERRS,
- $ NOUT )
- CYCLE
- END IF
- *
- CALL SLAORD( 'Decreasing', MINMN, S, 1 )
- *
- ELSE IF( MINMN.GE.2
- $ .AND. IMAT.GE.5 .AND. IMAT.LE.13 ) THEN
- *
- * Rectangular matrices 5-13 that contain zero columns,
- * only for matrices MINMN >=2.
- *
- * JB_ZERO is the column index of ZERO block.
- * NB_ZERO is the column block size of ZERO block.
- * NB_GEN is the column blcok size of the
- * generated block.
- * J_INC in the non_zero column index increment
- * for matrix 12 and 13.
- * J_FIRS_NZ is the index of the first non-zero
- * column.
- *
- IF( IMAT.EQ.5 ) THEN
- *
- * First column is zero.
- *
- JB_ZERO = 1
- NB_ZERO = 1
- NB_GEN = N - NB_ZERO
- *
- ELSE IF( IMAT.EQ.6 ) THEN
- *
- * Last column MINMN is zero.
- *
- JB_ZERO = MINMN
- NB_ZERO = 1
- NB_GEN = N - NB_ZERO
- *
- ELSE IF( IMAT.EQ.7 ) THEN
- *
- * Last column N is zero.
- *
- JB_ZERO = N
- NB_ZERO = 1
- NB_GEN = N - NB_ZERO
- *
- ELSE IF( IMAT.EQ.8 ) THEN
- *
- * Middle column in MINMN is zero.
- *
- JB_ZERO = MINMN / 2 + 1
- NB_ZERO = 1
- NB_GEN = N - NB_ZERO
- *
- ELSE IF( IMAT.EQ.9 ) THEN
- *
- * First half of MINMN columns is zero.
- *
- JB_ZERO = 1
- NB_ZERO = MINMN / 2
- NB_GEN = N - NB_ZERO
- *
- ELSE IF( IMAT.EQ.10 ) THEN
- *
- * Last columns are zero columns,
- * starting from (MINMN / 2 + 1) column.
- *
- JB_ZERO = MINMN / 2 + 1
- NB_ZERO = N - JB_ZERO + 1
- NB_GEN = N - NB_ZERO
- *
- ELSE IF( IMAT.EQ.11 ) THEN
- *
- * Half of the columns in the middle of MINMN
- * columns is zero, starting from
- * MINMN/2 - (MINMN/2)/2 + 1 column.
- *
- JB_ZERO = MINMN / 2 - (MINMN / 2) / 2 + 1
- NB_ZERO = MINMN / 2
- NB_GEN = N - NB_ZERO
- *
- ELSE IF( IMAT.EQ.12 ) THEN
- *
- * Odd-numbered columns are zero,
- *
- NB_GEN = N / 2
- NB_ZERO = N - NB_GEN
- J_INC = 2
- J_FIRST_NZ = 2
- *
- ELSE IF( IMAT.EQ.13 ) THEN
- *
- * Even-numbered columns are zero.
- *
- NB_ZERO = N / 2
- NB_GEN = N - NB_ZERO
- J_INC = 2
- J_FIRST_NZ = 1
- *
- END IF
- *
- *
- * 1) Set the first NB_ZERO columns in COPYA(1:M,1:N)
- * to zero.
- *
- CALL CLASET( 'Full', M, NB_ZERO, CZERO, CZERO,
- $ COPYA, LDA )
- *
- * 2) Generate an M-by-(N-NB_ZERO) matrix with the
- * chosen singular value distribution
- * in COPYA(1:M,NB_ZERO+1:N).
- *
- CALL CLATB4( PATH, IMAT, M, NB_GEN, TYPE, KL, KU,
- $ ANORM, MODE, CNDNUM, DIST )
- *
- SRNAMT = 'CLATMS'
- *
- IND_OFFSET_GEN = NB_ZERO * LDA
- *
- CALL CLATMS( M, NB_GEN, DIST, ISEED, TYPE, S, MODE,
- $ CNDNUM, ANORM, KL, KU, 'No packing',
- $ COPYA( IND_OFFSET_GEN + 1 ), LDA,
- $ WORK, INFO )
- *
- * Check error code from CLATMS.
- *
- IF( INFO.NE.0 ) THEN
- CALL ALAERH( PATH, 'CLATMS', INFO, 0, ' ', M,
- $ NB_GEN, -1, -1, -1, IMAT, NFAIL,
- $ NERRS, NOUT )
- CYCLE
- END IF
- *
- * 3) Swap the gererated colums from the right side
- * NB_GEN-size block in COPYA into correct column
- * positions.
- *
- IF( IMAT.EQ.6
- $ .OR. IMAT.EQ.7
- $ .OR. IMAT.EQ.8
- $ .OR. IMAT.EQ.10
- $ .OR. IMAT.EQ.11 ) THEN
- *
- * Move by swapping the generated columns
- * from the right NB_GEN-size block from
- * (NB_ZERO+1:NB_ZERO+JB_ZERO)
- * into columns (1:JB_ZERO-1).
- *
- DO J = 1, JB_ZERO-1, 1
- CALL CSWAP( M,
- $ COPYA( ( NB_ZERO+J-1)*LDA+1), 1,
- $ COPYA( (J-1)*LDA + 1 ), 1 )
- END DO
- *
- ELSE IF( IMAT.EQ.12 .OR. IMAT.EQ.13 ) THEN
- *
- * ( IMAT = 12, Odd-numbered ZERO columns. )
- * Swap the generated columns from the right
- * NB_GEN-size block into the even zero colums in the
- * left NB_ZERO-size block.
- *
- * ( IMAT = 13, Even-numbered ZERO columns. )
- * Swap the generated columns from the right
- * NB_GEN-size block into the odd zero colums in the
- * left NB_ZERO-size block.
- *
- DO J = 1, NB_GEN, 1
- IND_OUT = ( NB_ZERO+J-1 )*LDA + 1
- IND_IN = ( J_INC*(J-1)+(J_FIRST_NZ-1) )*LDA
- $ + 1
- CALL CSWAP( M,
- $ COPYA( IND_OUT ), 1,
- $ COPYA( IND_IN), 1 )
- END DO
- *
- END IF
- *
- * 5) Order the singular values generated by
- * DLAMTS in decreasing order and add trailing zeros
- * that correspond to zero columns.
- * The total number of singular values is MINMN.
- *
- MINMNB_GEN = MIN( M, NB_GEN )
- *
- CALL SLAORD( 'Decreasing', MINMNB_GEN, S, 1 )
-
- DO I = MINMNB_GEN+1, MINMN
- S( I ) = ZERO
- END DO
- *
- ELSE
- *
- * IF(MINMN.LT.2) skip this size for this matrix type.
- *
- CYCLE
- END IF
- *
- * Initialize a copy array for a pivot array for DGEQP3RK.
- *
- DO I = 1, N
- IWORK( I ) = 0
- END DO
- *
- DO INB = 1, NNB
- *
- * Do for each pair of values (NB,NX) in NBVAL and NXVAL.
- *
- NB = NBVAL( INB )
- CALL XLAENV( 1, NB )
- NX = NXVAL( INB )
- CALL XLAENV( 3, NX )
- *
- * We do MIN(M,N)+1 because we need a test for KMAX > N,
- * when KMAX is larger than MIN(M,N), KMAX should be
- * KMAX = MIN(M,N)
- *
- DO KMAX = 0, MIN(M,N)+1
- *
- * Get a working copy of COPYA into A( 1:M,1:N ).
- * Get a working copy of COPYB into A( 1:M, (N+1):NRHS ).
- * Get a working copy of COPYB into into B( 1:M, 1:NRHS ).
- * Get a working copy of IWORK(1:N) awith zeroes into
- * which is going to be used as pivot array IWORK( N+1:2N ).
- * NOTE: IWORK(2N+1:3N) is going to be used as a WORK array
- * for the routine.
- *
- CALL CLACPY( 'All', M, N, COPYA, LDA, A, LDA )
- CALL CLACPY( 'All', M, NRHS, COPYB, LDA,
- $ A( LDA*N + 1 ), LDA )
- CALL CLACPY( 'All', M, NRHS, COPYB, LDA,
- $ B, LDA )
- CALL ICOPY( N, IWORK( 1 ), 1, IWORK( N+1 ), 1 )
- *
- ABSTOL = -1.0
- RELTOl = -1.0
- *
- * Compute the QR factorization with pivoting of A
- *
- LW = MAX( 1, MAX( 2*N + NB*( N+NRHS+1 ),
- $ 3*N + NRHS - 1 ) )
- *
- * Compute CGEQP3RK factorization of A.
- *
- SRNAMT = 'CGEQP3RK'
- CALL CGEQP3RK( M, N, NRHS, KMAX, ABSTOL, RELTOL,
- $ A, LDA, KFACT, MAXC2NRMK,
- $ RELMAXC2NRMK, IWORK( N+1 ), TAU,
- $ WORK, LW, RWORK, IWORK( 2*N+1 ),
- $ INFO )
- *
- * Check error code from CGEQP3RK.
- *
- IF( INFO.LT.0 )
- $ CALL ALAERH( PATH, 'CGEQP3RK', INFO, 0, ' ',
- $ M, N, NX, -1, NB, IMAT,
- $ NFAIL, NERRS, NOUT )
- *
- IF( KFACT.EQ.MINMN ) THEN
- *
- * Compute test 1:
- *
- * This test in only for the full rank factorization of
- * the matrix A.
- *
- * Array S(1:min(M,N)) contains svd(A) the sigular values
- * of the original matrix A in decreasing absolute value
- * order. The test computes svd(R), the vector sigular
- * values of the upper trapezoid of A(1:M,1:N) that
- * contains the factor R, in decreasing order. The test
- * returns the ratio:
- *
- * 2-norm(svd(R) - svd(A)) / ( max(M,N) * 2-norm(svd(A)) * EPS )
- *
- RESULT( 1 ) = CQRT12( M, N, A, LDA, S, WORK,
- $ LWORK , RWORK )
- *
- DO T = 1, 1
- IF( RESULT( T ).GE.THRESH ) THEN
- IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
- $ CALL ALAHD( NOUT, PATH )
- WRITE( NOUT, FMT = 9999 ) 'CGEQP3RK', M, N,
- $ NRHS, KMAX, ABSTOL, RELTOL, NB, NX,
- $ IMAT, T, RESULT( T )
- NFAIL = NFAIL + 1
- END IF
- END DO
- NRUN = NRUN + 1
- *
- * End test 1
- *
- END IF
-
- * Compute test 2:
- *
- * The test returns the ratio:
- *
- * 1-norm( A*P - Q*R ) / ( max(M,N) * 1-norm(A) * EPS )
- *
- RESULT( 2 ) = CQPT01( M, N, KFACT, COPYA, A, LDA, TAU,
- $ IWORK( N+1 ), WORK, LWORK )
- *
- * Compute test 3:
- *
- * The test returns the ratio:
- *
- * 1-norm( Q**T * Q - I ) / ( M * EPS )
- *
- RESULT( 3 ) = CQRT11( M, KFACT, A, LDA, TAU, WORK,
- $ LWORK )
- *
- * Print information about the tests that did not pass
- * the threshold.
- *
- DO T = 2, 3
- IF( RESULT( T ).GE.THRESH ) THEN
- IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
- $ CALL ALAHD( NOUT, PATH )
- WRITE( NOUT, FMT = 9999 ) 'CGEQP3RK', M, N,
- $ NRHS, KMAX, ABSTOL, RELTOL,
- $ NB, NX, IMAT, T, RESULT( T )
- NFAIL = NFAIL + 1
- END IF
- END DO
- NRUN = NRUN + 2
- *
- * Compute test 4:
- *
- * This test is only for the factorizations with the
- * rank greater than 2.
- * The elements on the diagonal of R should be non-
- * increasing.
- *
- * The test returns the ratio:
- *
- * Returns 1.0D+100 if abs(R(K+1,K+1)) > abs(R(K,K)),
- * K=1:KFACT-1
- *
- IF( MIN(KFACT, MINMN).GE.2 ) THEN
- *
- DO J = 1, KFACT-1, 1
- *
- DTEMP = (( ABS( A( (J-1)*M+J ) ) -
- $ ABS( A( (J)*M+J+1 ) ) ) /
- $ ABS( A(1) ) )
- *
- IF( DTEMP.LT.ZERO ) THEN
- RESULT( 4 ) = BIGNUM
- END IF
- *
- END DO
- *
- * Print information about the tests that did not
- * pass the threshold.
- *
- DO T = 4, 4
- IF( RESULT( T ).GE.THRESH ) THEN
- IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
- $ CALL ALAHD( NOUT, PATH )
- WRITE( NOUT, FMT = 9999 ) 'CGEQP3RK',
- $ M, N, NRHS, KMAX, ABSTOL, RELTOL,
- $ NB, NX, IMAT, T,
- $ RESULT( T )
- NFAIL = NFAIL + 1
- END IF
- END DO
- NRUN = NRUN + 1
- *
- * End test 4.
- *
- END IF
- *
- * Compute test 5:
- *
- * This test in only for matrix A with min(M,N) > 0.
- *
- * The test returns the ratio:
- *
- * 1-norm(Q**T * B - Q**T * B ) /
- * ( M * EPS )
- *
- * (1) Compute B:=Q**T * B in the matrix B.
- *
- IF( MINMN.GT.0 ) THEN
- *
- LWORK_MQR = MAX(1, NRHS)
- CALL CUNMQR( 'Left', 'Conjugate transpose',
- $ M, NRHS, KFACT, A, LDA, TAU, B, LDA,
- $ WORK, LWORK_MQR, INFO )
- *
- DO I = 1, NRHS
- *
- * Compare N+J-th column of A and J-column of B.
- *
- CALL CAXPY( M, -CONE, A( ( N+I-1 )*LDA+1 ), 1,
- $ B( ( I-1 )*LDA+1 ), 1 )
- END DO
- *
- RESULT( 5 ) =
- $ ABS(
- $ CLANGE( 'One-norm', M, NRHS, B, LDA, RDUMMY ) /
- $ ( REAL( M )*SLAMCH( 'Epsilon' ) )
- $ )
- *
- * Print information about the tests that did not pass
- * the threshold.
- *
- DO T = 5, 5
- IF( RESULT( T ).GE.THRESH ) THEN
- IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
- $ CALL ALAHD( NOUT, PATH )
- WRITE( NOUT, FMT = 9999 ) 'CGEQP3RK', M, N,
- $ NRHS, KMAX, ABSTOL, RELTOL,
- $ NB, NX, IMAT, T, RESULT( T )
- NFAIL = NFAIL + 1
- END IF
- END DO
- NRUN = NRUN + 1
- *
- * End compute test 5.
- *
- END IF
- *
- * END DO KMAX = 1, MIN(M,N)+1
- *
- END DO
- *
- * END DO for INB = 1, NNB
- *
- END DO
- *
- * END DO for IMAT = 1, NTYPES
- *
- END DO
- *
- * END DO for INS = 1, NNS
- *
- END DO
- *
- * END DO for IN = 1, NN
- *
- END DO
- *
- * END DO for IM = 1, NM
- *
- END DO
- *
- * Print a summary of the results.
- *
- CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS )
- *
- 9999 FORMAT( 1X, A, ' M =', I5, ', N =', I5, ', NRHS =', I5,
- $ ', KMAX =', I5, ', ABSTOL =', G12.5,
- $ ', RELTOL =', G12.5, ', NB =', I4, ', NX =', I4,
- $ ', type ', I2, ', test ', I2, ', ratio =', G12.5 )
- *
- * End of CCHKQP3RK
- *
- END
|