phynexis-deps/lapack
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity
Files
introduce-cpp
lapack/TESTING/LIN/dchktz.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

313 lines
8.9 KiB
FortranFixed
Raw Permalink Blame History

*> \brief \b DCHKTZ
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* SUBROUTINE DCHKTZ( DOTYPE, NM, MVAL, NN, NVAL, THRESH, TSTERR, A,
* COPYA, S, TAU, WORK, NOUT )
*
* .. Scalar Arguments ..
* LOGICAL TSTERR
* INTEGER NM, NN, NOUT
* DOUBLE PRECISION THRESH
* ..
* .. Array Arguments ..
* LOGICAL DOTYPE( * )
* INTEGER MVAL( * ), NVAL( * )
* DOUBLE PRECISION A( * ), COPYA( * ), S( * ),
* $ TAU( * ), WORK( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> DCHKTZ tests DTZRZF.
*> \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] THRESH
*> \verbatim
*> THRESH is DOUBLE PRECISION
*> 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[out] A
*> \verbatim
*> A is DOUBLE PRECISION 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 DOUBLE PRECISION array, dimension (MMAX*NMAX)
*> \endverbatim
*>
*> \param[out] S
*> \verbatim
*> S is DOUBLE PRECISION array, dimension
*> (min(MMAX,NMAX))
*> \endverbatim
*>
*> \param[out] TAU
*> \verbatim
*> TAU is DOUBLE PRECISION array, dimension (MMAX)
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is DOUBLE PRECISION array, dimension
*> (MMAX*NMAX + 4*NMAX + MMAX)
*> \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 double_lin
*
* =====================================================================
SUBROUTINE DCHKTZ( DOTYPE, NM, MVAL, NN, NVAL, THRESH, TSTERR, A,
$ COPYA, S, TAU, WORK, 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, NN, NOUT
DOUBLE PRECISION THRESH
* ..
* .. Array Arguments ..
LOGICAL DOTYPE( * )
INTEGER MVAL( * ), NVAL( * )
DOUBLE PRECISION A( * ), COPYA( * ), S( * ),
$ TAU( * ), WORK( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
INTEGER NTYPES
PARAMETER ( NTYPES = 3 )
INTEGER NTESTS
PARAMETER ( NTESTS = 3 )
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 )
* ..
* .. Local Scalars ..
CHARACTER*3 PATH
INTEGER I, IM, IMODE, IN, INFO, K, LDA, LWORK, M,
$ MNMIN, MODE, N, NERRS, NFAIL, NRUN
DOUBLE PRECISION EPS
* ..
* .. Local Arrays ..
INTEGER ISEED( 4 ), ISEEDY( 4 )
DOUBLE PRECISION RESULT( NTESTS )
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMCH, DQRT12, DRZT01, DRZT02
EXTERNAL DLAMCH, DQRT12, DRZT01, DRZT02
* ..
* .. External Subroutines ..
EXTERNAL ALAHD, ALASUM, DERRTZ, DGEQR2, DLACPY, DLAORD,
$ DLASET, DLATMS, DTZRZF
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
CHARACTER*32 SRNAMT
INTEGER INFOT, IOUNIT
* ..
* .. 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 ) = 'Double precision'
PATH( 2: 3 ) = 'TZ'
NRUN = 0
NFAIL = 0
NERRS = 0
DO 10 I = 1, 4
ISEED( I ) = ISEEDY( I )
10 CONTINUE
EPS = DLAMCH( 'Epsilon' )
*
* Test the error exits
*
IF( TSTERR )
$ CALL DERRTZ( PATH, NOUT )
INFOT = 0
*
DO 70 IM = 1, NM
*
* Do for each value of M in MVAL.
*
M = MVAL( IM )
LDA = MAX( 1, M )
*
DO 60 IN = 1, NN
*
* Do for each value of N in NVAL for which M .LE. N.
*
N = NVAL( IN )
MNMIN = MIN( M, N )
LWORK = MAX( 1, N*N+4*M+N, M*N+2*MNMIN+4*N )
*
IF( M.LE.N ) THEN
DO 50 IMODE = 1, NTYPES
IF( .NOT.DOTYPE( IMODE ) )
$ GO TO 50
*
* Do for each type of singular value distribution.
* 0: zero matrix
* 1: one small singular value
* 2: exponential distribution
*
MODE = IMODE - 1
*
* Test DTZRQF
*
* Generate test matrix of size m by n using
* singular value distribution indicated by `mode'.
*
IF( MODE.EQ.0 ) THEN
CALL DLASET( 'Full', M, N, ZERO, ZERO, A, LDA )
DO 30 I = 1, MNMIN
S( I ) = ZERO
30 CONTINUE
ELSE
CALL DLATMS( M, N, 'Uniform', ISEED,
$ 'Nonsymmetric', S, IMODE,
$ ONE / EPS, ONE, M, N, 'No packing', A,
$ LDA, WORK, INFO )
CALL DGEQR2( M, N, A, LDA, WORK, WORK( MNMIN+1 ),
$ INFO )
CALL DLASET( 'Lower', M-1, N, ZERO, ZERO, A( 2 ),
$ LDA )
CALL DLAORD( 'Decreasing', MNMIN, S, 1 )
END IF
*
* Save A and its singular values
*
CALL DLACPY( 'All', M, N, A, LDA, COPYA, LDA )
*
* Call DTZRZF to reduce the upper trapezoidal matrix to
* upper triangular form.
*
SRNAMT = 'DTZRZF'
CALL DTZRZF( M, N, A, LDA, TAU, WORK, LWORK, INFO )
*
* Compute norm(svd(a) - svd(r))
*
RESULT( 1 ) = DQRT12( M, M, A, LDA, S, WORK,
$ LWORK )
*
* Compute norm( A - R*Q )
*
RESULT( 2 ) = DRZT01( M, N, COPYA, A, LDA, TAU, WORK,
$ LWORK )
*
* Compute norm(Q'*Q - I).
*
RESULT( 3 ) = DRZT02( M, N, A, LDA, TAU, WORK, LWORK )
*
* Print information about the tests that did not pass
* the threshold.
*
DO 40 K = 1, NTESTS
IF( RESULT( K ).GE.THRESH ) THEN
IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
$ CALL ALAHD( NOUT, PATH )
WRITE( NOUT, FMT = 9999 )M, N, IMODE, K,
$ RESULT( K )
NFAIL = NFAIL + 1
END IF
40 CONTINUE
NRUN = NRUN + 3
50 CONTINUE
END IF
60 CONTINUE
70 CONTINUE
*
* Print a summary of the results.
*
CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS )
*
9999 FORMAT( ' M =', I5, ', N =', I5, ', type ', I2, ', test ', I2,
$ ', ratio =', G12.5 )
*
* End if DCHKTZ
*
END
Reference in New Issue View Git Blame Copy Permalink