LAPACK 3.12.0
LAPACK: Linear Algebra PACKage
Loading...
Searching...
No Matches

◆ zchkqp3rk()

subroutine zchkqp3rk ( logical, dimension( * )  dotype,
integer  nm,
integer, dimension( * )  mval,
integer  nn,
integer, dimension( * )  nval,
integer  nns,
integer, dimension( * )  nsval,
integer  nnb,
integer, dimension( * )  nbval,
integer, dimension( * )  nxval,
double precision  thresh,
complex*16, dimension( * )  a,
complex*16, dimension( * )  copya,
complex*16, dimension( * )  b,
complex*16, dimension( * )  copyb,
double precision, dimension( * )  s,
complex*16, dimension( * )  tau,
complex*16, dimension( * )  work,
double precision, dimension( * )  rwork,
integer, dimension( * )  iwork,
integer  nout 
)

ZCHKQP3RK

Purpose:
 ZCHKQP3RK tests ZGEQP3RK.
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]NNS
          NNS is INTEGER
          The number of values of NRHS contained in the vector NSVAL.
[in]NSVAL
          NSVAL is INTEGER array, dimension (NNS)
          The values of the number of right hand sides NRHS.
[in]NNB
          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).
[in]NBVAL
          NBVAL is INTEGER array, dimension (NNB)
          The values of the blocksize NB.
[in]NXVAL
          NXVAL is INTEGER array, dimension (NNB)
          The values of the crossover point NX.
[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.
[out]A
          A is COMPLEX*16 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*16 array, dimension (MMAX*NMAX)
[out]B
          B is COMPLEX*16 array, dimension (MMAX*NSMAX)
          where MMAX is the maximum value of M in MVAL and NSMAX is the
          maximum value of NRHS in NSVAL.
[out]COPYB
          COPYB is COMPLEX*16 array, dimension (MMAX*NSMAX)
[out]S
          S is DOUBLE PRECISION array, dimension
                      (min(MMAX,NMAX))
[out]TAU
          TAU is COMPLEX*16 array, dimension (MMAX)
[out]WORK
          WORK is COMPLEX*16 array, dimension
                      (max(M*max(M,N) + 4*min(M,N) + max(M,N)))
[out]RWORK
          RWORK is DOUBLE PRECISION array, dimension (4*NMAX)
[out]IWORK
          IWORK is INTEGER 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 180 of file zchkqp3rk.f.

184 IMPLICIT NONE
185*
186* -- LAPACK test routine --
187* -- LAPACK is a software package provided by Univ. of Tennessee, --
188* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
189*
190* .. Scalar Arguments ..
191 INTEGER NM, NN, NNB, NNS, NOUT
192 DOUBLE PRECISION THRESH
193* ..
194* .. Array Arguments ..
195 LOGICAL DOTYPE( * )
196 INTEGER IWORK( * ), NBVAL( * ), MVAL( * ), NVAL( * ),
197 $ NSVAL( * ), NXVAL( * )
198 DOUBLE PRECISION S( * ), RWORK( * )
199 COMPLEX*16 A( * ), COPYA( * ), B( * ), COPYB( * ),
200 $ TAU( * ), WORK( * )
201* ..
202*
203* =====================================================================
204*
205* .. Parameters ..
206 INTEGER NTYPES
207 parameter( ntypes = 19 )
208 INTEGER NTESTS
209 parameter( ntests = 5 )
210 DOUBLE PRECISION ONE, ZERO, BIGNUM
211 COMPLEX*16 CONE, CZERO
212 parameter( one = 1.0d+0, zero = 0.0d+0,
213 $ czero = ( 0.0d+0, 0.0d+0 ),
214 $ cone = ( 1.0d+0, 0.0d+0 ),
215 $ bignum = 1.0d+38 )
216* ..
217* .. Local Scalars ..
218 CHARACTER DIST, TYPE
219 CHARACTER*3 PATH
220 INTEGER I, IHIGH, ILOW, IM, IMAT, IN, INC_ZERO,
221 $ INB, IND_OFFSET_GEN,
222 $ IND_IN, IND_OUT, INS, INFO,
223 $ ISTEP, J, J_INC, J_FIRST_NZ, JB_ZERO,
224 $ KFACT, KL, KMAX, KU, LDA, LW, LWORK,
225 $ LWORK_MQR, M, MINMN, MINMNB_GEN, MODE, N,
226 $ NB, NB_ZERO, NERRS, NFAIL, NB_GEN, NRHS,
227 $ NRUN, NX, T
228 DOUBLE PRECISION ANORM, CNDNUM, EPS, ABSTOL, RELTOL,
229 $ DTEMP, MAXC2NRMK, RELMAXC2NRMK
230* ..
231* .. Local Arrays ..
232 INTEGER ISEED( 4 ), ISEEDY( 4 )
233 DOUBLE PRECISION RESULT( NTESTS ), RDUMMY( 1 )
234* ..
235* .. External Functions ..
236 DOUBLE PRECISION DLAMCH, ZQPT01, ZQRT11, ZQRT12, ZLANGE
237 EXTERNAL dlamch, zqpt01, zqrt11, zqrt12, zlange
238* ..
239* .. External Subroutines ..
240 EXTERNAL alaerh, alahd, alasum, dlaord, icopy, zaxpy,
241 $ xlaenv, zgeqp3rk, zlacpy, zlaset, zlatb4,
242 $ zlatms, zunmqr, zswap
243* ..
244* .. Intrinsic Functions ..
245 INTRINSIC abs, dble, max, min, mod
246* ..
247* .. Scalars in Common ..
248 LOGICAL LERR, OK
249 CHARACTER*32 SRNAMT
250 INTEGER INFOT, IOUNIT, ZUNMQR_LWORK
251* ..
252* .. Common blocks ..
253 COMMON / infoc / infot, iounit, ok, lerr
254 COMMON / srnamc / srnamt
255* ..
256* .. Data statements ..
257 DATA iseedy / 1988, 1989, 1990, 1991 /
258* ..
259* .. Executable Statements ..
260*
261* Initialize constants and the random number seed.
262*
263 path( 1: 1 ) = 'Zomplex precision'
264 path( 2: 3 ) = 'QK'
265 nrun = 0
266 nfail = 0
267 nerrs = 0
268 DO i = 1, 4
269 iseed( i ) = iseedy( i )
270 END DO
271 eps = dlamch( 'Epsilon' )
272 infot = 0
273*
274 DO im = 1, nm
275*
276* Do for each value of M in MVAL.
277*
278 m = mval( im )
279 lda = max( 1, m )
280*
281 DO in = 1, nn
282*
283* Do for each value of N in NVAL.
284*
285 n = nval( in )
286 minmn = min( m, n )
287 lwork = max( 1, m*max( m, n )+4*minmn+max( m, n ),
288 $ m*n + 2*minmn + 4*n )
289*
290 DO ins = 1, nns
291 nrhs = nsval( ins )
292*
293* Set up parameters with ZLATB4 and generate
294* M-by-NRHS B matrix with ZLATMS.
295* IMAT = 14:
296* Random matrix, CNDNUM = 2, NORM = ONE,
297* MODE = 3 (geometric distribution of singular values).
298*
299 CALL zlatb4( path, 14, m, nrhs, TYPE, KL, KU, ANORM,
300 $ MODE, CNDNUM, DIST )
301*
302 srnamt = 'ZLATMS'
303 CALL zlatms( m, nrhs, dist, iseed, TYPE, S, MODE,
304 $ CNDNUM, ANORM, KL, KU, 'No packing',
305 $ COPYB, LDA, WORK, INFO )
306*
307* Check error code from ZLATMS.
308*
309 IF( info.NE.0 ) THEN
310 CALL alaerh( path, 'ZLATMS', info, 0, ' ', m,
311 $ nrhs, -1, -1, -1, 6, nfail, nerrs,
312 $ nout )
313 cycle
314 END IF
315*
316 DO imat = 1, ntypes
317*
318* Do the tests only if DOTYPE( IMAT ) is true.
319*
320 IF( .NOT.dotype( imat ) )
321 $ cycle
322*
323* The type of distribution used to generate the random
324* eigen-/singular values:
325* ( 'S' for symmetric distribution ) => UNIFORM( -1, 1 )
326*
327* Do for each type of NON-SYMMETRIC matrix: CNDNUM NORM MODE
328* 1. Zero matrix
329* 2. Random, Diagonal, CNDNUM = 2 CNDNUM = 2 ONE 3 ( geometric distribution of singular values )
330* 3. Random, Upper triangular, CNDNUM = 2 CNDNUM = 2 ONE 3 ( geometric distribution of singular values )
331* 4. Random, Lower triangular, CNDNUM = 2 CNDNUM = 2 ONE 3 ( geometric distribution of singular values )
332* 5. Random, First column is zero, CNDNUM = 2 CNDNUM = 2 ONE 3 ( geometric distribution of singular values )
333* 6. Random, Last MINMN column is zero, CNDNUM = 2 CNDNUM = 2 ONE 3 ( geometric distribution of singular values )
334* 7. Random, Last N column is zero, CNDNUM = 2 CNDNUM = 2 ONE 3 ( geometric distribution of singular values )
335* 8. Random, Middle column in MINMN is zero, CNDNUM = 2 CNDNUM = 2 ONE 3 ( geometric distribution of singular values )
336* 9. Random, First half of MINMN columns are zero, CNDNUM = 2 CNDNUM = 2 ONE 3 ( geometric distribution of singular values )
337* 10. Random, Last columns are zero starting from MINMN/2+1, CNDNUM = 2 CNDNUM = 2 ONE 3 ( geometric distribution of singular values )
338* 11. Random, Half MINMN columns in the middle are zero starting
339* from MINMN/2-(MINMN/2)/2+1, CNDNUM = 2 CNDNUM = 2 ONE 3 ( geometric distribution of singular values )
340* 12. Random, Odd columns are ZERO, CNDNUM = 2 CNDNUM = 2 ONE 3 ( geometric distribution of singular values )
341* 13. Random, Even columns are ZERO, CNDNUM = 2 CNDNUM = 2 ONE 3 ( geometric distribution of singular values )
342* 14. Random, CNDNUM = 2 CNDNUM = 2 ONE 3 ( geometric distribution of singular values )
343* 15. Random, CNDNUM = sqrt(0.1/EPS) CNDNUM = BADC1 = sqrt(0.1/EPS) ONE 3 ( geometric distribution of singular values )
344* 16. Random, CNDNUM = 0.1/EPS CNDNUM = BADC2 = 0.1/EPS ONE 3 ( geometric distribution of singular values )
345* 17. Random, CNDNUM = 0.1/EPS, CNDNUM = BADC2 = 0.1/EPS ONE 2 ( one small singular value, S(N)=1/CNDNUM )
346* one small singular value S(N)=1/CNDNUM
347* 18. Random, CNDNUM = 2, scaled near underflow CNDNUM = 2 SMALL = SAFMIN
348* 19. Random, CNDNUM = 2, scaled near overflow CNDNUM = 2 LARGE = 1.0/( 0.25 * ( SAFMIN / EPS ) ) 3 ( geometric distribution of singular values )
349*
350 IF( imat.EQ.1 ) THEN
351*
352* Matrix 1: Zero matrix
353*
354 CALL zlaset( 'Full', m, n, czero, czero, copya, lda )
355 DO i = 1, minmn
356 s( i ) = zero
357 END DO
358*
359 ELSE IF( (imat.GE.2 .AND. imat.LE.4 )
360 $ .OR. (imat.GE.14 .AND. imat.LE.19 ) ) THEN
361*
362* Matrices 2-5.
363*
364* Set up parameters with DLATB4 and generate a test
365* matrix with ZLATMS.
366*
367 CALL zlatb4( path, imat, m, n, TYPE, KL, KU, ANORM,
368 $ MODE, CNDNUM, DIST )
369*
370 srnamt = 'ZLATMS'
371 CALL zlatms( m, n, dist, iseed, TYPE, S, MODE,
372 $ CNDNUM, ANORM, KL, KU, 'No packing',
373 $ COPYA, LDA, WORK, INFO )
374*
375* Check error code from ZLATMS.
376*
377 IF( info.NE.0 ) THEN
378 CALL alaerh( path, 'ZLATMS', info, 0, ' ', m, n,
379 $ -1, -1, -1, imat, nfail, nerrs,
380 $ nout )
381 cycle
382 END IF
383*
384 CALL dlaord( 'Decreasing', minmn, s, 1 )
385*
386 ELSE IF( minmn.GE.2
387 $ .AND. imat.GE.5 .AND. imat.LE.13 ) THEN
388*
389* Rectangular matrices 5-13 that contain zero columns,
390* only for matrices MINMN >=2.
391*
392* JB_ZERO is the column index of ZERO block.
393* NB_ZERO is the column block size of ZERO block.
394* NB_GEN is the column blcok size of the
395* generated block.
396* J_INC in the non_zero column index increment
397* for matrix 12 and 13.
398* J_FIRS_NZ is the index of the first non-zero
399* column.
400*
401 IF( imat.EQ.5 ) THEN
402*
403* First column is zero.
404*
405 jb_zero = 1
406 nb_zero = 1
407 nb_gen = n - nb_zero
408*
409 ELSE IF( imat.EQ.6 ) THEN
410*
411* Last column MINMN is zero.
412*
413 jb_zero = minmn
414 nb_zero = 1
415 nb_gen = n - nb_zero
416*
417 ELSE IF( imat.EQ.7 ) THEN
418*
419* Last column N is zero.
420*
421 jb_zero = n
422 nb_zero = 1
423 nb_gen = n - nb_zero
424*
425 ELSE IF( imat.EQ.8 ) THEN
426*
427* Middle column in MINMN is zero.
428*
429 jb_zero = minmn / 2 + 1
430 nb_zero = 1
431 nb_gen = n - nb_zero
432*
433 ELSE IF( imat.EQ.9 ) THEN
434*
435* First half of MINMN columns is zero.
436*
437 jb_zero = 1
438 nb_zero = minmn / 2
439 nb_gen = n - nb_zero
440*
441 ELSE IF( imat.EQ.10 ) THEN
442*
443* Last columns are zero columns,
444* starting from (MINMN / 2 + 1) column.
445*
446 jb_zero = minmn / 2 + 1
447 nb_zero = n - jb_zero + 1
448 nb_gen = n - nb_zero
449*
450 ELSE IF( imat.EQ.11 ) THEN
451*
452* Half of the columns in the middle of MINMN
453* columns is zero, starting from
454* MINMN/2 - (MINMN/2)/2 + 1 column.
455*
456 jb_zero = minmn / 2 - (minmn / 2) / 2 + 1
457 nb_zero = minmn / 2
458 nb_gen = n - nb_zero
459*
460 ELSE IF( imat.EQ.12 ) THEN
461*
462* Odd-numbered columns are zero,
463*
464 nb_gen = n / 2
465 nb_zero = n - nb_gen
466 j_inc = 2
467 j_first_nz = 2
468*
469 ELSE IF( imat.EQ.13 ) THEN
470*
471* Even-numbered columns are zero.
472*
473 nb_zero = n / 2
474 nb_gen = n - nb_zero
475 j_inc = 2
476 j_first_nz = 1
477*
478 END IF
479*
480*
481* 1) Set the first NB_ZERO columns in COPYA(1:M,1:N)
482* to zero.
483*
484 CALL zlaset( 'Full', m, nb_zero, czero, czero,
485 $ copya, lda )
486*
487* 2) Generate an M-by-(N-NB_ZERO) matrix with the
488* chosen singular value distribution
489* in COPYA(1:M,NB_ZERO+1:N).
490*
491 CALL zlatb4( path, imat, m, nb_gen, TYPE, KL, KU,
492 $ ANORM, MODE, CNDNUM, DIST )
493*
494 srnamt = 'ZLATMS'
495*
496 ind_offset_gen = nb_zero * lda
497*
498 CALL zlatms( m, nb_gen, dist, iseed, TYPE, S, MODE,
499 $ CNDNUM, ANORM, KL, KU, 'No packing',
500 $ COPYA( IND_OFFSET_GEN + 1 ), LDA,
501 $ WORK, INFO )
502*
503* Check error code from ZLATMS.
504*
505 IF( info.NE.0 ) THEN
506 CALL alaerh( path, 'ZLATMS', info, 0, ' ', m,
507 $ nb_gen, -1, -1, -1, imat, nfail,
508 $ nerrs, nout )
509 cycle
510 END IF
511*
512* 3) Swap the gererated colums from the right side
513* NB_GEN-size block in COPYA into correct column
514* positions.
515*
516 IF( imat.EQ.6
517 $ .OR. imat.EQ.7
518 $ .OR. imat.EQ.8
519 $ .OR. imat.EQ.10
520 $ .OR. imat.EQ.11 ) THEN
521*
522* Move by swapping the generated columns
523* from the right NB_GEN-size block from
524* (NB_ZERO+1:NB_ZERO+JB_ZERO)
525* into columns (1:JB_ZERO-1).
526*
527 DO j = 1, jb_zero-1, 1
528 CALL zswap( m,
529 $ copya( ( nb_zero+j-1)*lda+1), 1,
530 $ copya( (j-1)*lda + 1 ), 1 )
531 END DO
532*
533 ELSE IF( imat.EQ.12 .OR. imat.EQ.13 ) THEN
534*
535* ( IMAT = 12, Odd-numbered ZERO columns. )
536* Swap the generated columns from the right
537* NB_GEN-size block into the even zero colums in the
538* left NB_ZERO-size block.
539*
540* ( IMAT = 13, Even-numbered ZERO columns. )
541* Swap the generated columns from the right
542* NB_GEN-size block into the odd zero colums in the
543* left NB_ZERO-size block.
544*
545 DO j = 1, nb_gen, 1
546 ind_out = ( nb_zero+j-1 )*lda + 1
547 ind_in = ( j_inc*(j-1)+(j_first_nz-1) )*lda
548 $ + 1
549 CALL zswap( m,
550 $ copya( ind_out ), 1,
551 $ copya( ind_in), 1 )
552 END DO
553*
554 END IF
555*
556* 5) Order the singular values generated by
557* DLAMTS in decreasing order and add trailing zeros
558* that correspond to zero columns.
559* The total number of singular values is MINMN.
560*
561 minmnb_gen = min( m, nb_gen )
562*
563 CALL dlaord( 'Decreasing', minmnb_gen, s, 1 )
564
565 DO i = minmnb_gen+1, minmn
566 s( i ) = zero
567 END DO
568*
569 ELSE
570*
571* IF(MINMN.LT.2) skip this size for this matrix type.
572*
573 cycle
574 END IF
575*
576* Initialize a copy array for a pivot array for DGEQP3RK.
577*
578 DO i = 1, n
579 iwork( i ) = 0
580 END DO
581*
582 DO inb = 1, nnb
583*
584* Do for each pair of values (NB,NX) in NBVAL and NXVAL.
585*
586 nb = nbval( inb )
587 CALL xlaenv( 1, nb )
588 nx = nxval( inb )
589 CALL xlaenv( 3, nx )
590*
591* We do MIN(M,N)+1 because we need a test for KMAX > N,
592* when KMAX is larger than MIN(M,N), KMAX should be
593* KMAX = MIN(M,N)
594*
595 DO kmax = 0, min(m,n)+1
596*
597* Get a working copy of COPYA into A( 1:M,1:N ).
598* Get a working copy of COPYB into A( 1:M, (N+1):NRHS ).
599* Get a working copy of COPYB into into B( 1:M, 1:NRHS ).
600* Get a working copy of IWORK(1:N) awith zeroes into
601* which is going to be used as pivot array IWORK( N+1:2N ).
602* NOTE: IWORK(2N+1:3N) is going to be used as a WORK array
603* for the routine.
604*
605 CALL zlacpy( 'All', m, n, copya, lda, a, lda )
606 CALL zlacpy( 'All', m, nrhs, copyb, lda,
607 $ a( lda*n + 1 ), lda )
608 CALL zlacpy( 'All', m, nrhs, copyb, lda,
609 $ b, lda )
610 CALL icopy( n, iwork( 1 ), 1, iwork( n+1 ), 1 )
611*
612 abstol = -1.0
613 reltol = -1.0
614*
615* Compute the QR factorization with pivoting of A
616*
617 lw = max( 1, max( 2*n + nb*( n+nrhs+1 ),
618 $ 3*n + nrhs - 1 ) )
619*
620* Compute ZGEQP3RK factorization of A.
621*
622 srnamt = 'ZGEQP3RK'
623 CALL zgeqp3rk( m, n, nrhs, kmax, abstol, reltol,
624 $ a, lda, kfact, maxc2nrmk,
625 $ relmaxc2nrmk, iwork( n+1 ), tau,
626 $ work, lw, rwork, iwork( 2*n+1 ),
627 $ info )
628*
629* Check error code from ZGEQP3RK.
630*
631 IF( info.LT.0 )
632 $ CALL alaerh( path, 'ZGEQP3RK', info, 0, ' ',
633 $ m, n, nx, -1, nb, imat,
634 $ nfail, nerrs, nout )
635*
636 IF( kfact.EQ.minmn ) THEN
637*
638* Compute test 1:
639*
640* This test in only for the full rank factorization of
641* the matrix A.
642*
643* Array S(1:min(M,N)) contains svd(A) the sigular values
644* of the original matrix A in decreasing absolute value
645* order. The test computes svd(R), the vector sigular
646* values of the upper trapezoid of A(1:M,1:N) that
647* contains the factor R, in decreasing order. The test
648* returns the ratio:
649*
650* 2-norm(svd(R) - svd(A)) / ( max(M,N) * 2-norm(svd(A)) * EPS )
651*
652 result( 1 ) = zqrt12( m, n, a, lda, s, work,
653 $ lwork , rwork )
654*
655 DO t = 1, 1
656 IF( result( t ).GE.thresh ) THEN
657 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
658 $ CALL alahd( nout, path )
659 WRITE( nout, fmt = 9999 ) 'ZGEQP3RK', m, n,
660 $ nrhs, kmax, abstol, reltol, nb, nx,
661 $ imat, t, result( t )
662 nfail = nfail + 1
663 END IF
664 END DO
665 nrun = nrun + 1
666*
667* End test 1
668*
669 END IF
670
671* Compute test 2:
672*
673* The test returns the ratio:
674*
675* 1-norm( A*P - Q*R ) / ( max(M,N) * 1-norm(A) * EPS )
676*
677 result( 2 ) = zqpt01( m, n, kfact, copya, a, lda, tau,
678 $ iwork( n+1 ), work, lwork )
679*
680* Compute test 3:
681*
682* The test returns the ratio:
683*
684* 1-norm( Q**T * Q - I ) / ( M * EPS )
685*
686 result( 3 ) = zqrt11( m, kfact, a, lda, tau, work,
687 $ lwork )
688*
689* Print information about the tests that did not pass
690* the threshold.
691*
692 DO t = 2, 3
693 IF( result( t ).GE.thresh ) THEN
694 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
695 $ CALL alahd( nout, path )
696 WRITE( nout, fmt = 9999 ) 'ZGEQP3RK', m, n,
697 $ nrhs, kmax, abstol, reltol,
698 $ nb, nx, imat, t, result( t )
699 nfail = nfail + 1
700 END IF
701 END DO
702 nrun = nrun + 2
703*
704* Compute test 4:
705*
706* This test is only for the factorizations with the
707* rank greater than 2.
708* The elements on the diagonal of R should be non-
709* increasing.
710*
711* The test returns the ratio:
712*
713* Returns 1.0D+100 if abs(R(K+1,K+1)) > abs(R(K,K)),
714* K=1:KFACT-1
715*
716 IF( min(kfact, minmn).GE.2 ) THEN
717*
718 DO j = 1, kfact-1, 1
719*
720 dtemp = (( abs( a( (j-1)*m+j ) ) -
721 $ abs( a( (j)*m+j+1 ) ) ) /
722 $ abs( a(1) ) )
723*
724 IF( dtemp.LT.zero ) THEN
725 result( 4 ) = bignum
726 END IF
727*
728 END DO
729*
730* Print information about the tests that did not
731* pass the threshold.
732*
733 DO t = 4, 4
734 IF( result( t ).GE.thresh ) THEN
735 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
736 $ CALL alahd( nout, path )
737 WRITE( nout, fmt = 9999 ) 'ZGEQP3RK',
738 $ m, n, nrhs, kmax, abstol, reltol,
739 $ nb, nx, imat, t,
740 $ result( t )
741 nfail = nfail + 1
742 END IF
743 END DO
744 nrun = nrun + 1
745*
746* End test 4.
747*
748 END IF
749*
750* Compute test 5:
751*
752* This test in only for matrix A with min(M,N) > 0.
753*
754* The test returns the ratio:
755*
756* 1-norm(Q**T * B - Q**T * B ) /
757* ( M * EPS )
758*
759* (1) Compute B:=Q**T * B in the matrix B.
760*
761 IF( minmn.GT.0 ) THEN
762*
763 lwork_mqr = max(1, nrhs)
764 CALL zunmqr( 'Left', 'Conjugate transpose',
765 $ m, nrhs, kfact, a, lda, tau, b, lda,
766 $ work, lwork_mqr, info )
767*
768 DO i = 1, nrhs
769*
770* Compare N+J-th column of A and J-column of B.
771*
772 CALL zaxpy( m, -cone, a( ( n+i-1 )*lda+1 ), 1,
773 $ b( ( i-1 )*lda+1 ), 1 )
774 END DO
775*
776 result( 5 ) =
777 $ abs(
778 $ zlange( 'One-norm', m, nrhs, b, lda, rdummy ) /
779 $ ( dble( m )*dlamch( 'Epsilon' ) )
780 $ )
781*
782* Print information about the tests that did not pass
783* the threshold.
784*
785 DO t = 5, 5
786 IF( result( t ).GE.thresh ) THEN
787 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
788 $ CALL alahd( nout, path )
789 WRITE( nout, fmt = 9999 ) 'ZGEQP3RK', m, n,
790 $ nrhs, kmax, abstol, reltol,
791 $ nb, nx, imat, t, result( t )
792 nfail = nfail + 1
793 END IF
794 END DO
795 nrun = nrun + 1
796*
797* End compute test 5.
798*
799 END IF
800*
801* END DO KMAX = 1, MIN(M,N)+1
802*
803 END DO
804*
805* END DO for INB = 1, NNB
806*
807 END DO
808*
809* END DO for IMAT = 1, NTYPES
810*
811 END DO
812*
813* END DO for INS = 1, NNS
814*
815 END DO
816*
817* END DO for IN = 1, NN
818*
819 END DO
820*
821* END DO for IM = 1, NM
822*
823 END DO
824*
825* Print a summary of the results.
826*
827 CALL alasum( path, nout, nfail, nrun, nerrs )
828*
829 9999 FORMAT( 1x, a, ' M =', i5, ', N =', i5, ', NRHS =', i5,
830 $ ', KMAX =', i5, ', ABSTOL =', g12.5,
831 $ ', RELTOL =', g12.5, ', NB =', i4, ', NX =', i4,
832 $ ', type ', i2, ', test ', i2, ', ratio =', g12.5 )
833*
834* End of ZCHKQP3RK
835*
alasum
subroutine alasum(type, nout, nfail, nrun, nerrs)
ALASUM
Definition alasum.f:73
xlaenv
subroutine xlaenv(ispec, nvalue)
XLAENV
Definition xlaenv.f:81
alaerh
subroutine alaerh(path, subnam, info, infoe, opts, m, n, kl, ku, n5, imat, nfail, nerrs, nout)
ALAERH
Definition alaerh.f:147
alahd
subroutine alahd(iounit, path)
ALAHD
Definition alahd.f:107
dlaord
subroutine dlaord(job, n, x, incx)
DLAORD
Definition dlaord.f:73
zaxpy
subroutine zaxpy(n, za, zx, incx, zy, incy)
ZAXPY
Definition zaxpy.f:88
zlacpy
subroutine zlacpy(uplo, m, n, a, lda, b, ldb)
ZLACPY copies all or part of one two-dimensional array to another.
Definition zlacpy.f:103
dlamch
double precision function dlamch(cmach)
DLAMCH
Definition dlamch.f:69
zlange
double precision function zlange(norm, m, n, a, lda, work)
ZLANGE returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute value ...
Definition zlange.f:115
zlaset
subroutine zlaset(uplo, m, n, alpha, beta, a, lda)
ZLASET initializes the off-diagonal elements and the diagonal elements of a matrix to given values.
Definition zlaset.f:106
zswap
subroutine zswap(n, zx, incx, zy, incy)
ZSWAP
Definition zswap.f:81
zunmqr
subroutine zunmqr(side, trans, m, n, k, a, lda, tau, c, ldc, work, lwork, info)
ZUNMQR
Definition zunmqr.f:167
icopy
subroutine icopy(n, sx, incx, sy, incy)
ICOPY
Definition icopy.f:75
zgeqp3rk
subroutine zgeqp3rk(m, n, nrhs, kmax, abstol, reltol, a, lda, k, maxc2nrmk, relmaxc2nrmk, jpiv, tau, work, lwork, rwork, iwork, info)
ZGEQP3RK computes a truncated Householder QR factorization with column pivoting of a complex m-by-n m...
Definition zgeqp3rk.f:591
zlatb4
subroutine zlatb4(path, imat, m, n, type, kl, ku, anorm, mode, cndnum, dist)
ZLATB4
Definition zlatb4.f:121
zlatms
subroutine zlatms(m, n, dist, iseed, sym, d, mode, cond, dmax, kl, ku, pack, a, lda, work, info)
ZLATMS
Definition zlatms.f:332
zqpt01
double precision function zqpt01(m, n, k, a, af, lda, tau, jpvt, work, lwork)
ZQPT01
Definition zqpt01.f:120
zqrt11
double precision function zqrt11(m, k, a, lda, tau, work, lwork)
ZQRT11
Definition zqrt11.f:98
zqrt12
double precision function zqrt12(m, n, a, lda, s, work, lwork, rwork)
ZQRT12
Definition zqrt12.f:97
Here is the call graph for this function:
Here is the caller graph for this function: