LAPACK  3.10.0
LAPACK: Linear Algebra PACKage

◆ schktz()

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

SCHKTZ

Purpose:
 SCHKTZ tests STZRZF.
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 REAL 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 REAL array, dimension (MMAX*NMAX)
[out]S
          S is REAL array, dimension
                      (min(MMAX,NMAX))
[out]TAU
          TAU is REAL array, dimension (MMAX)
[out]WORK
          WORK is REAL 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.

Definition at line 130 of file schktz.f.

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