LAPACK  3.10.0
LAPACK: Linear Algebra PACKage

◆ cchktz()

subroutine cchktz ( logical, dimension( * )  DOTYPE,
integer  NM,
integer, dimension( * )  MVAL,
integer  NN,
integer, dimension( * )  NVAL,
real  THRESH,
logical  TSTERR,
complex, dimension( * )  A,
complex, dimension( * )  COPYA,
real, dimension( * )  S,
complex, dimension( * )  TAU,
complex, dimension( * )  WORK,
real, dimension( * )  RWORK,
integer  NOUT 
)

CCHKTZ

Purpose:
 CCHKTZ tests CTZRZF.
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 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.
[in]TSTERR
          TSTERR is LOGICAL
          Flag that indicates whether error exits are to be tested.
[out]A
          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.
[out]COPYA
          COPYA is COMPLEX array, dimension (MMAX*NMAX)
[out]S
          S is REAL array, dimension
                      (min(MMAX,NMAX))
[out]TAU
          TAU is COMPLEX array, dimension (MMAX)
[out]WORK
          WORK is COMPLEX array, dimension
                      (MMAX*NMAX + 4*NMAX + MMAX)
[out]RWORK
          RWORK is REAL array, dimension (2*NMAX)
[in]NOUT
          NOUT is INTEGER
          The unit number for output.
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 135 of file cchktz.f.

137 *
138 * -- LAPACK test routine --
139 * -- LAPACK is a software package provided by Univ. of Tennessee, --
140 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
141 *
142 * .. Scalar Arguments ..
143  LOGICAL TSTERR
144  INTEGER NM, NN, NOUT
145  REAL THRESH
146 * ..
147 * .. Array Arguments ..
148  LOGICAL DOTYPE( * )
149  INTEGER MVAL( * ), NVAL( * )
150  REAL S( * ), RWORK( * )
151  COMPLEX A( * ), COPYA( * ), TAU( * ), WORK( * )
152 * ..
153 *
154 * =====================================================================
155 *
156 * .. Parameters ..
157  INTEGER NTYPES
158  parameter( ntypes = 3 )
159  INTEGER NTESTS
160  parameter( ntests = 3 )
161  REAL ONE, ZERO
162  parameter( one = 1.0e0, zero = 0.0e0 )
163 * ..
164 * .. Local Scalars ..
165  CHARACTER*3 PATH
166  INTEGER I, IM, IMODE, IN, INFO, K, LDA, LWORK, M,
167  $ MNMIN, MODE, N, NERRS, NFAIL, NRUN
168  REAL EPS
169 * ..
170 * .. Local Arrays ..
171  INTEGER ISEED( 4 ), ISEEDY( 4 )
172  REAL RESULT( NTESTS )
173 * ..
174 * .. External Functions ..
175  REAL CQRT12, CRZT01, CRZT02, SLAMCH
176  EXTERNAL cqrt12, crzt01, crzt02, slamch
177 * ..
178 * .. External Subroutines ..
179  EXTERNAL alahd, alasum, cerrtz, cgeqr2, clacpy, claset,
180  $ clatms, ctzrzf, slaord
181 * ..
182 * .. Intrinsic Functions ..
183  INTRINSIC cmplx, max, min
184 * ..
185 * .. Scalars in Common ..
186  LOGICAL LERR, OK
187  CHARACTER*32 SRNAMT
188  INTEGER INFOT, IOUNIT
189 * ..
190 * .. Common blocks ..
191  COMMON / infoc / infot, iounit, ok, lerr
192  COMMON / srnamc / srnamt
193 * ..
194 * .. Data statements ..
195  DATA iseedy / 1988, 1989, 1990, 1991 /
196 * ..
197 * .. Executable Statements ..
198 *
199 * Initialize constants and the random number seed.
200 *
201  path( 1: 1 ) = 'Complex precision'
202  path( 2: 3 ) = 'TZ'
203  nrun = 0
204  nfail = 0
205  nerrs = 0
206  DO 10 i = 1, 4
207  iseed( i ) = iseedy( i )
208  10 CONTINUE
209  eps = slamch( 'Epsilon' )
210 *
211 * Test the error exits
212 *
213  IF( tsterr )
214  $ CALL cerrtz( path, nout )
215  infot = 0
216 *
217  DO 70 im = 1, nm
218 *
219 * Do for each value of M in MVAL.
220 *
221  m = mval( im )
222  lda = max( 1, m )
223 *
224  DO 60 in = 1, nn
225 *
226 * Do for each value of N in NVAL for which M .LE. N.
227 *
228  n = nval( in )
229  mnmin = min( m, n )
230  lwork = max( 1, n*n+4*m+n )
231 *
232  IF( m.LE.n ) THEN
233  DO 50 imode = 1, ntypes
234  IF( .NOT.dotype( imode ) )
235  $ GO TO 50
236 *
237 * Do for each type of singular value distribution.
238 * 0: zero matrix
239 * 1: one small singular value
240 * 2: exponential distribution
241 *
242  mode = imode - 1
243 *
244 * Test CTZRZF
245 *
246 * Generate test matrix of size m by n using
247 * singular value distribution indicated by `mode'.
248 *
249  IF( mode.EQ.0 ) THEN
250  CALL claset( 'Full', m, n, cmplx( zero ),
251  $ cmplx( zero ), a, lda )
252  DO 30 i = 1, mnmin
253  s( i ) = zero
254  30 CONTINUE
255  ELSE
256  CALL clatms( m, n, 'Uniform', iseed,
257  $ 'Nonsymmetric', s, imode,
258  $ one / eps, one, m, n, 'No packing', a,
259  $ lda, work, info )
260  CALL cgeqr2( m, n, a, lda, work, work( mnmin+1 ),
261  $ info )
262  CALL claset( 'Lower', m-1, n, cmplx( zero ),
263  $ cmplx( zero ), a( 2 ), lda )
264  CALL slaord( 'Decreasing', mnmin, s, 1 )
265  END IF
266 *
267 * Save A and its singular values
268 *
269  CALL clacpy( 'All', m, n, a, lda, copya, lda )
270 *
271 * Call CTZRZF to reduce the upper trapezoidal matrix to
272 * upper triangular form.
273 *
274  srnamt = 'CTZRZF'
275  CALL ctzrzf( m, n, a, lda, tau, work, lwork, info )
276 *
277 * Compute norm(svd(a) - svd(r))
278 *
279  result( 1 ) = cqrt12( m, m, a, lda, s, work,
280  $ lwork, rwork )
281 *
282 * Compute norm( A - R*Q )
283 *
284  result( 2 ) = crzt01( m, n, copya, a, lda, tau, work,
285  $ lwork )
286 *
287 * Compute norm(Q'*Q - I).
288 *
289  result( 3 ) = crzt02( m, n, a, lda, tau, work, lwork )
290 *
291 * Print information about the tests that did not pass
292 * the threshold.
293 *
294  DO 40 k = 1, ntests
295  IF( result( k ).GE.thresh ) THEN
296  IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
297  $ CALL alahd( nout, path )
298  WRITE( nout, fmt = 9999 )m, n, imode, k,
299  $ result( k )
300  nfail = nfail + 1
301  END IF
302  40 CONTINUE
303  nrun = nrun + 3
304  50 CONTINUE
305  END IF
306  60 CONTINUE
307  70 CONTINUE
308 *
309 * Print a summary of the results.
310 *
311  CALL alasum( path, nout, nfail, nrun, nerrs )
312 *
313  9999 FORMAT( ' M =', i5, ', N =', i5, ', type ', i2, ', test ', i2,
314  $ ', ratio =', g12.5 )
315 *
316 * End if CCHKTZ
317 *
subroutine alasum(TYPE, NOUT, NFAIL, NRUN, NERRS)
ALASUM
Definition: alasum.f:73
subroutine alahd(IOUNIT, PATH)
ALAHD
Definition: alahd.f:107
real function crzt01(M, N, A, AF, LDA, TAU, WORK, LWORK)
CRZT01
Definition: crzt01.f:98
real function crzt02(M, N, AF, LDA, TAU, WORK, LWORK)
CRZT02
Definition: crzt02.f:91
real function cqrt12(M, N, A, LDA, S, WORK, LWORK, RWORK)
CQRT12
Definition: cqrt12.f:97
subroutine cerrtz(PATH, NUNIT)
CERRTZ
Definition: cerrtz.f:54
subroutine clatms(M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, KL, KU, PACK, A, LDA, WORK, INFO)
CLATMS
Definition: clatms.f:332
subroutine cgeqr2(M, N, A, LDA, TAU, WORK, INFO)
CGEQR2 computes the QR factorization of a general rectangular matrix using an unblocked algorithm.
Definition: cgeqr2.f:130
subroutine claset(UPLO, M, N, ALPHA, BETA, A, LDA)
CLASET initializes the off-diagonal elements and the diagonal elements of a matrix to given values.
Definition: claset.f:106
subroutine clacpy(UPLO, M, N, A, LDA, B, LDB)
CLACPY copies all or part of one two-dimensional array to another.
Definition: clacpy.f:103
subroutine ctzrzf(M, N, A, LDA, TAU, WORK, LWORK, INFO)
CTZRZF
Definition: ctzrzf.f:151
subroutine slaord(JOB, N, X, INCX)
SLAORD
Definition: slaord.f:73
real function slamch(CMACH)
SLAMCH
Definition: slamch.f:68
Here is the call graph for this function:
Here is the caller graph for this function: