LAPACK 3.12.1
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 DO i = 1, ntests
612 result( i ) = zero
613 END DO
614*
615 abstol = -1.0
616 reltol = -1.0
617*
618* Compute the QR factorization with pivoting of A
619*
620 lw = max( 1, max( 2*n + nb*( n+nrhs+1 ),
621 $ 3*n + nrhs - 1 ) )
622*
623* Compute ZGEQP3RK factorization of A.
624*
625 srnamt = 'ZGEQP3RK'
626 CALL zgeqp3rk( m, n, nrhs, kmax, abstol, reltol,
627 $ a, lda, kfact, maxc2nrmk,
628 $ relmaxc2nrmk, iwork( n+1 ), tau,
629 $ work, lw, rwork, iwork( 2*n+1 ),
630 $ info )
631*
632* Check error code from ZGEQP3RK.
633*
634 IF( info.LT.0 )
635 $ CALL alaerh( path, 'ZGEQP3RK', info, 0, ' ',
636 $ m, n, nx, -1, nb, imat,
637 $ nfail, nerrs, nout )
638*
639 IF( kfact.EQ.minmn ) THEN
640*
641* Compute test 1:
642*
643* This test in only for the full rank factorization of
644* the matrix A.
645*
646* Array S(1:min(M,N)) contains svd(A) the sigular values
647* of the original matrix A in decreasing absolute value
648* order. The test computes svd(R), the vector sigular
649* values of the upper trapezoid of A(1:M,1:N) that
650* contains the factor R, in decreasing order. The test
651* returns the ratio:
652*
653* 2-norm(svd(R) - svd(A)) / ( max(M,N) * 2-norm(svd(A)) * EPS )
654*
655 result( 1 ) = zqrt12( m, n, a, lda, s, work,
656 $ lwork , rwork )
657*
658 nrun = nrun + 1
659*
660* End test 1
661*
662 END IF
663
664* Compute test 2:
665*
666* The test returns the ratio:
667*
668* 1-norm( A*P - Q*R ) / ( max(M,N) * 1-norm(A) * EPS )
669*
670 result( 2 ) = zqpt01( m, n, kfact, copya, a, lda, tau,
671 $ iwork( n+1 ), work, lwork )
672*
673* Compute test 3:
674*
675* The test returns the ratio:
676*
677* 1-norm( Q**T * Q - I ) / ( M * EPS )
678*
679 result( 3 ) = zqrt11( m, kfact, a, lda, tau, work,
680 $ lwork )
681*
682 nrun = nrun + 2
683*
684* Compute test 4:
685*
686* This test is only for the factorizations with the
687* rank greater than 2.
688* The elements on the diagonal of R should be non-
689* increasing.
690*
691* The test returns the ratio:
692*
693* Returns 1.0D+100 if abs(R(K+1,K+1)) > abs(R(K,K)),
694* K=1:KFACT-1
695*
696 IF( min(kfact, minmn).GE.2 ) THEN
697*
698 DO j = 1, kfact-1, 1
699*
700 dtemp = (( abs( a( (j-1)*lda+j ) ) -
701 $ abs( a( (j)*lda+j+1 ) ) ) /
702 $ abs( a(1) ) )
703*
704 IF( dtemp.LT.zero ) THEN
705 result( 4 ) = bignum
706 END IF
707*
708 END DO
709*
710 nrun = nrun + 1
711*
712* End test 4.
713*
714 END IF
715*
716* Compute test 5:
717*
718* This test in only for matrix A with min(M,N) > 0.
719*
720* The test returns the ratio:
721*
722* 1-norm(Q**T * B - Q**T * B ) /
723* ( M * EPS )
724*
725* (1) Compute B:=Q**T * B in the matrix B.
726*
727 IF( minmn.GT.0 ) THEN
728*
729 lwork_mqr = max(1, nrhs)
730 CALL zunmqr( 'Left', 'Conjugate transpose',
731 $ m, nrhs, kfact, a, lda, tau, b, lda,
732 $ work, lwork_mqr, info )
733*
734 DO i = 1, nrhs
735*
736* Compare N+J-th column of A and J-column of B.
737*
738 CALL zaxpy( m, -cone, a( ( n+i-1 )*lda+1 ), 1,
739 $ b( ( i-1 )*lda+1 ), 1 )
740 END DO
741*
742 result( 5 ) = abs(
743 $ zlange( 'One-norm', m, nrhs, b, lda, rdummy ) /
744 $ ( dble( m )*dlamch( 'Epsilon' ) ) )
745*
746 nrun = nrun + 1
747*
748* End compute test 5.
749*
750 END IF
751*
752* Print information about the tests that did not pass
753* the threshold.
754*
755 DO t = 1, ntests
756 IF( result( t ).GE.thresh ) THEN
757 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
758 $ CALL alahd( nout, path )
759 WRITE( nout, fmt = 9999 ) 'ZGEQP3RK', m, n,
760 $ nrhs, kmax, abstol, reltol,
761 $ nb, nx, imat, t, result( t )
762 nfail = nfail + 1
763 END IF
764 END DO
765*
766* END DO KMAX = 1, MIN(M,N)+1
767*
768 END DO
769*
770* END DO for INB = 1, NNB
771*
772 END DO
773*
774* END DO for IMAT = 1, NTYPES
775*
776 END DO
777*
778* END DO for INS = 1, NNS
779*
780 END DO
781*
782* END DO for IN = 1, NN
783*
784 END DO
785*
786* END DO for IM = 1, NM
787*
788 END DO
789*
790* Print a summary of the results.
791*
792 CALL alasum( path, nout, nfail, nrun, nerrs )
793*
794 9999 FORMAT( 1x, a, ' M =', i5, ', N =', i5, ', NRHS =', i5,
795 $ ', KMAX =', i5, ', ABSTOL =', g12.5,
796 $ ', RELTOL =', g12.5, ', NB =', i4, ', NX =', i4,
797 $ ', type ', i2, ', test ', i2, ', ratio =', g12.5 )
798*
799* End of ZCHKQP3RK
800*
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:101
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:113
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:104
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:165
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:582
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: