phynexis-deps/lapack
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity
Files
introduce-cpp
lapack/TESTING/LIN/schkrq.f
T
Julie e18d437924 Making LAPACK's code eternal... no more version and date in source files. 
GitHub is now enabling us to track accurately version and date.
No need for this anymore.
2021-03-25 10:16:58 -07:00

443 lines
13 KiB
FortranFixed
Raw Permalink Blame History

*> \brief \b SCHKRQ
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* SUBROUTINE SCHKRQ( DOTYPE, NM, MVAL, NN, NVAL, NNB, NBVAL, NXVAL,
* NRHS, THRESH, TSTERR, NMAX, A, AF, AQ, AR, AC,
* B, X, XACT, TAU, WORK, RWORK, IWORK, NOUT )
*
* .. Scalar Arguments ..
* LOGICAL TSTERR
* INTEGER NM, NMAX, NN, NNB, NOUT, NRHS
* REAL THRESH
* ..
* .. Array Arguments ..
* LOGICAL DOTYPE( * )
* INTEGER IWORK( * ), MVAL( * ), NBVAL( * ), NVAL( * ),
* $ NXVAL( * )
* REAL A( * ), AC( * ), AF( * ), AQ( * ), AR( * ),
* $ B( * ), RWORK( * ), TAU( * ), WORK( * ),
* $ X( * ), XACT( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> SCHKRQ tests SGERQF, SORGRQ and SORMRQ.
*> \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] 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] NRHS
*> \verbatim
*> NRHS is INTEGER
*> The number of right hand side vectors to be generated for
*> each linear system.
*> \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[in] TSTERR
*> \verbatim
*> TSTERR is LOGICAL
*> Flag that indicates whether error exits are to be tested.
*> \endverbatim
*>
*> \param[in] NMAX
*> \verbatim
*> NMAX is INTEGER
*> The maximum value permitted for M or N, used in dimensioning
*> the work arrays.
*> \endverbatim
*>
*> \param[out] A
*> \verbatim
*> A is REAL array, dimension (NMAX*NMAX)
*> \endverbatim
*>
*> \param[out] AF
*> \verbatim
*> AF is REAL array, dimension (NMAX*NMAX)
*> \endverbatim
*>
*> \param[out] AQ
*> \verbatim
*> AQ is REAL array, dimension (NMAX*NMAX)
*> \endverbatim
*>
*> \param[out] AR
*> \verbatim
*> AR is REAL array, dimension (NMAX*NMAX)
*> \endverbatim
*>
*> \param[out] AC
*> \verbatim
*> AC is REAL array, dimension (NMAX*NMAX)
*> \endverbatim
*>
*> \param[out] B
*> \verbatim
*> B is REAL array, dimension (NMAX*NRHS)
*> \endverbatim
*>
*> \param[out] X
*> \verbatim
*> X is REAL array, dimension (NMAX*NRHS)
*> \endverbatim
*>
*> \param[out] XACT
*> \verbatim
*> XACT is REAL array, dimension (NMAX*NRHS)
*> \endverbatim
*>
*> \param[out] TAU
*> \verbatim
*> TAU is REAL array, dimension (NMAX)
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is REAL array, dimension (NMAX*NMAX)
*> \endverbatim
*>
*> \param[out] RWORK
*> \verbatim
*> RWORK is REAL array, dimension (NMAX)
*> \endverbatim
*>
*> \param[out] IWORK
*> \verbatim
*> IWORK is INTEGER array, dimension (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 single_lin
*
* =====================================================================
SUBROUTINE SCHKRQ( DOTYPE, NM, MVAL, NN, NVAL, NNB, NBVAL, NXVAL,
$ NRHS, THRESH, TSTERR, NMAX, A, AF, AQ, AR, AC,
$ B, X, XACT, TAU, WORK, RWORK, IWORK, NOUT )
*
* -- 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 ..
LOGICAL TSTERR
INTEGER NM, NMAX, NN, NNB, NOUT, NRHS
REAL THRESH
* ..
* .. Array Arguments ..
LOGICAL DOTYPE( * )
INTEGER IWORK( * ), MVAL( * ), NBVAL( * ), NVAL( * ),
$ NXVAL( * )
REAL A( * ), AC( * ), AF( * ), AQ( * ), AR( * ),
$ B( * ), RWORK( * ), TAU( * ), WORK( * ),
$ X( * ), XACT( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
INTEGER NTESTS
PARAMETER ( NTESTS = 7 )
INTEGER NTYPES
PARAMETER ( NTYPES = 8 )
REAL ZERO
PARAMETER ( ZERO = 0.0E0 )
* ..
* .. Local Scalars ..
CHARACTER DIST, TYPE
CHARACTER*3 PATH
INTEGER I, IK, IM, IMAT, IN, INB, INFO, K, KL, KU, LDA,
$ LWORK, M, MINMN, MODE, N, NB, NERRS, NFAIL, NK,
$ NRUN, NT, NX
REAL ANORM, CNDNUM
* ..
* .. Local Arrays ..
INTEGER ISEED( 4 ), ISEEDY( 4 ), KVAL( 4 )
REAL RESULT( NTESTS )
* ..
* .. External Subroutines ..
EXTERNAL ALAERH, ALAHD, ALASUM, SERRRQ, SGERQS, SGET02,
$ SLACPY, SLARHS, SLATB4, SLATMS, SRQT01, SRQT02,
$ SRQT03, XLAENV
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
CHARACTER*32 SRNAMT
INTEGER INFOT, NUNIT
* ..
* .. Common blocks ..
COMMON / INFOC / INFOT, NUNIT, 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 ) = 'Single precision'
PATH( 2: 3 ) = 'RQ'
NRUN = 0
NFAIL = 0
NERRS = 0
DO 10 I = 1, 4
ISEED( I ) = ISEEDY( I )
10 CONTINUE
*
* Test the error exits
*
IF( TSTERR )
$ CALL SERRRQ( PATH, NOUT )
INFOT = 0
CALL XLAENV( 2, 2 )
*
LDA = NMAX
LWORK = NMAX*MAX( NMAX, NRHS )
*
* Do for each value of M in MVAL.
*
DO 70 IM = 1, NM
M = MVAL( IM )
*
* Do for each value of N in NVAL.
*
DO 60 IN = 1, NN
N = NVAL( IN )
MINMN = MIN( M, N )
DO 50 IMAT = 1, NTYPES
*
* Do the tests only if DOTYPE( IMAT ) is true.
*
IF( .NOT.DOTYPE( IMAT ) )
$ GO TO 50
*
* Set up parameters with SLATB4 and generate a test matrix
* with SLATMS.
*
CALL SLATB4( PATH, IMAT, M, N, TYPE, KL, KU, ANORM, MODE,
$ CNDNUM, DIST )
*
SRNAMT = 'SLATMS'
CALL SLATMS( M, N, DIST, ISEED, TYPE, RWORK, MODE,
$ CNDNUM, ANORM, KL, KU, 'No packing', A, LDA,
$ WORK, INFO )
*
* Check error code from SLATMS.
*
IF( INFO.NE.0 ) THEN
CALL ALAERH( PATH, 'SLATMS', INFO, 0, ' ', M, N, -1,
$ -1, -1, IMAT, NFAIL, NERRS, NOUT )
GO TO 50
END IF
*
* Set some values for K: the first value must be MINMN,
* corresponding to the call of SRQT01; other values are
* used in the calls of SRQT02, and must not exceed MINMN.
*
KVAL( 1 ) = MINMN
KVAL( 2 ) = 0
KVAL( 3 ) = 1
KVAL( 4 ) = MINMN / 2
IF( MINMN.EQ.0 ) THEN
NK = 1
ELSE IF( MINMN.EQ.1 ) THEN
NK = 2
ELSE IF( MINMN.LE.3 ) THEN
NK = 3
ELSE
NK = 4
END IF
*
* Do for each value of K in KVAL
*
DO 40 IK = 1, NK
K = KVAL( IK )
*
* Do for each pair of values (NB,NX) in NBVAL and NXVAL.
*
DO 30 INB = 1, NNB
NB = NBVAL( INB )
CALL XLAENV( 1, NB )
NX = NXVAL( INB )
CALL XLAENV( 3, NX )
DO I = 1, NTESTS
RESULT( I ) = ZERO
END DO
NT = 2
IF( IK.EQ.1 ) THEN
*
* Test SGERQF
*
CALL SRQT01( M, N, A, AF, AQ, AR, LDA, TAU,
$ WORK, LWORK, RWORK, RESULT( 1 ) )
ELSE IF( M.LE.N ) THEN
*
* Test SORGRQ, using factorization
* returned by SRQT01
*
CALL SRQT02( M, N, K, A, AF, AQ, AR, LDA, TAU,
$ WORK, LWORK, RWORK, RESULT( 1 ) )
END IF
IF( M.GE.K ) THEN
*
* Test SORMRQ, using factorization returned
* by SRQT01
*
CALL SRQT03( M, N, K, AF, AC, AR, AQ, LDA, TAU,
$ WORK, LWORK, RWORK, RESULT( 3 ) )
NT = NT + 4
*
* If M>=N and K=N, call SGERQS to solve a system
* with NRHS right hand sides and compute the
* residual.
*
IF( K.EQ.M .AND. INB.EQ.1 ) THEN
*
* Generate a solution and set the right
* hand side.
*
SRNAMT = 'SLARHS'
CALL SLARHS( PATH, 'New', 'Full',
$ 'No transpose', M, N, 0, 0,
$ NRHS, A, LDA, XACT, LDA, B, LDA,
$ ISEED, INFO )
*
CALL SLACPY( 'Full', M, NRHS, B, LDA,
$ X( N-M+1 ), LDA )
SRNAMT = 'SGERQS'
CALL SGERQS( M, N, NRHS, AF, LDA, TAU, X,
$ LDA, WORK, LWORK, INFO )
*
* Check error code from SGERQS.
*
IF( INFO.NE.0 )
$ CALL ALAERH( PATH, 'SGERQS', INFO, 0, ' ',
$ M, N, NRHS, -1, NB, IMAT,
$ NFAIL, NERRS, NOUT )
*
CALL SGET02( 'No transpose', M, N, NRHS, A,
$ LDA, X, LDA, B, LDA, RWORK,
$ RESULT( 7 ) )
NT = NT + 1
END IF
END IF
*
* Print information about the tests that did not
* pass the threshold.
*
DO 20 I = 1, NT
IF( RESULT( I ).GE.THRESH ) THEN
IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
$ CALL ALAHD( NOUT, PATH )
WRITE( NOUT, FMT = 9999 )M, N, K, NB, NX,
$ IMAT, I, RESULT( I )
NFAIL = NFAIL + 1
END IF
20 CONTINUE
NRUN = NRUN + NT
30 CONTINUE
40 CONTINUE
50 CONTINUE
60 CONTINUE
70 CONTINUE
*
* Print a summary of the results.
*
CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS )
*
9999 FORMAT( ' M=', I5, ', N=', I5, ', K=', I5, ', NB=', I4, ', NX=',
$ I5, ', type ', I2, ', test(', I2, ')=', G12.5 )
RETURN
*
* End of SCHKRQ
*
END
Reference in New Issue View Git Blame Copy Permalink