subroutine dchktz	(	logical, dimension( * )	DOTYPE,
		integer	NM,
		integer, dimension( * )	MVAL,
		integer	NN,
		integer, dimension( * )	NVAL,
		double precision	THRESH,
		logical	TSTERR,
		double precision, dimension( * )	A,
		double precision, dimension( * )	COPYA,
		double precision, dimension( * )	S,
		double precision, dimension( * )	TAU,
		double precision, dimension( * )	WORK,
		integer	NOUT
	)

DCHKTZ

Purpose:

 DCHKTZ tests DTZRZF.

Parameters

[in]	DOTYPE	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.
[in]	NM	NM is INTEGER The number of values of M contained in the vector MVAL.
[in]	MVAL	MVAL is INTEGER array, dimension (NM) The values of the matrix row dimension M.
[in]	NN	NN is INTEGER The number of values of N contained in the vector NVAL.
[in]	NVAL	NVAL is INTEGER array, dimension (NN) The values of the matrix column dimension N.
[in]	THRESH	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.
[in]	TSTERR	TSTERR is LOGICAL Flag that indicates whether error exits are to be tested.
[out]	A	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.
[out]	COPYA	COPYA is DOUBLE PRECISION array, dimension (MMAX*NMAX)
[out]	S	S is DOUBLE PRECISION array, dimension (min(MMAX,NMAX))
[out]	TAU	TAU is DOUBLE PRECISION array, dimension (MMAX)
[out]	WORK	WORK is DOUBLE PRECISION array, dimension (MMAX*NMAX + 4*NMAX + MMAX)
[in]	NOUT	NOUT is INTEGER The unit number for output.

Author

Univ. of Tennessee

Univ. of California Berkeley

Univ. of Colorado Denver

NAG Ltd.

Date

November 2015

Definition at line 134 of file dchktz.f.

*
*  -- LAPACK test routine (version 3.6.0) --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     November 2015
*
*     .. 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
*

Here is the call graph for this function:

Here is the caller graph for this function: