411 SUBROUTINE zchkbd( NSIZES, MVAL, NVAL, NTYPES, DOTYPE, NRHS,
412 $ ISEED, THRESH, A, LDA, BD, BE, S1, S2, X, LDX,
413 $ Y, Z, Q, LDQ, PT, LDPT, U, VT, WORK, LWORK,
414 $ RWORK, NOUT, INFO )
421 INTEGER INFO, LDA, LDPT, LDQ, LDX, LWORK, NOUT, NRHS,
423 DOUBLE PRECISION THRESH
427 INTEGER ISEED( 4 ), MVAL( * ), NVAL( * )
428 DOUBLE PRECISION BD( * ), BE( * ), RWORK( * ), S1( * ), S2( * )
429 COMPLEX*16 A( LDA, * ), PT( LDPT, * ), Q( LDQ, * ),
430 $ u( ldpt, * ), vt( ldpt, * ), work( * ),
431 $ x( ldx, * ), y( ldx, * ), z( ldx, * )
437 DOUBLE PRECISION ZERO, ONE, TWO, HALF
438 PARAMETER ( ZERO = 0.0d0, one = 1.0d0, two = 2.0d0,
440 COMPLEX*16 CZERO, CONE
441 parameter( czero = ( 0.0d+0, 0.0d+0 ),
442 $ cone = ( 1.0d+0, 0.0d+0 ) )
444 parameter( maxtyp = 16 )
447 LOGICAL BADMM, BADNN, BIDIAG
450 INTEGER I, IINFO, IMODE, ITYPE, J, JCOL, JSIZE, JTYPE,
451 $ log2ui, m, minwrk, mmax, mnmax, mnmin, mq,
452 $ mtypes, n, nfail, nmax, ntest
453 DOUBLE PRECISION AMNINV, ANORM, COND, OVFL, RTOVFL, RTUNFL,
454 $ TEMP1, TEMP2, ULP, ULPINV, UNFL
457 INTEGER IOLDSD( 4 ), IWORK( 1 ), KMAGN( MAXTYP ),
458 $ KMODE( MAXTYP ), KTYPE( MAXTYP )
459 DOUBLE PRECISION DUMMA( 1 ), RESULT( 14 )
462 DOUBLE PRECISION DLAMCH, DLARND
463 EXTERNAL DLAMCH, DLARND
471 INTRINSIC abs, exp, int, log, max, min, sqrt
479 COMMON / infoc / infot, nunit, ok, lerr
480 COMMON / srnamc / srnamt
483 DATA ktype / 1, 2, 5*4, 5*6, 3*9, 10 /
484 DATA kmagn / 2*1, 3*1, 2, 3, 3*1, 2, 3, 1, 2, 3, 0 /
485 DATA kmode / 2*0, 4, 3, 1, 4, 4, 4, 3, 1, 4, 4, 0,
501 mmax = max( mmax, mval( j ) )
504 nmax = max( nmax, nval( j ) )
507 mnmax = max( mnmax, min( mval( j ), nval( j ) ) )
508 minwrk = max( minwrk, 3*( mval( j )+nval( j ) ),
509 $ mval( j )*( mval( j )+max( mval( j ), nval( j ),
510 $ nrhs )+1 )+nval( j )*min( nval( j ), mval( j ) ) )
515 IF( nsizes.LT.0 )
THEN
517 ELSE IF( badmm )
THEN
519 ELSE IF( badnn )
THEN
521 ELSE IF( ntypes.LT.0 )
THEN
523 ELSE IF( nrhs.LT.0 )
THEN
525 ELSE IF( lda.LT.mmax )
THEN
527 ELSE IF( ldx.LT.mmax )
THEN
529 ELSE IF( ldq.LT.mmax )
THEN
531 ELSE IF( ldpt.LT.mnmax )
THEN
533 ELSE IF( minwrk.GT.lwork )
THEN
538 CALL xerbla(
'ZCHKBD', -info )
544 path( 1: 1 ) =
'Zomplex precision'
548 unfl = dlamch(
'Safe minimum' )
549 ovfl = dlamch(
'Overflow' )
550 ulp = dlamch(
'Precision' )
552 log2ui = int( log( ulpinv ) / log( two ) )
553 rtunfl = sqrt( unfl )
554 rtovfl = sqrt( ovfl )
559 DO 180 jsize = 1, nsizes
563 amninv = one / max( m, n, 1 )
565 IF( nsizes.NE.1 )
THEN
566 mtypes = min( maxtyp, ntypes )
568 mtypes = min( maxtyp+1, ntypes )
571 DO 170 jtype = 1, mtypes
572 IF( .NOT.dotype( jtype ) )
576 ioldsd( j ) = iseed( j )
601 IF( mtypes.GT.maxtyp )
604 itype = ktype( jtype )
605 imode = kmode( jtype )
609 GO TO ( 40, 50, 60 )kmagn( jtype )
616 anorm = ( rtovfl*ulp )*amninv
620 anorm = rtunfl*max( m, n )*ulpinv
625 CALL zlaset(
'Full', lda, n, czero, czero, a, lda )
630 IF( itype.EQ.1 )
THEN
636 ELSE IF( itype.EQ.2 )
THEN
640 DO 80 jcol = 1, mnmin
641 a( jcol, jcol ) = anorm
644 ELSE IF( itype.EQ.4 )
THEN
648 CALL zlatms( mnmin, mnmin,
'S', iseed,
'N', rwork, imode,
649 $ cond, anorm, 0, 0,
'N', a, lda, work,
652 ELSE IF( itype.EQ.5 )
THEN
656 CALL zlatms( mnmin, mnmin,
'S', iseed,
'S', rwork, imode,
657 $ cond, anorm, m, n,
'N', a, lda, work,
660 ELSE IF( itype.EQ.6 )
THEN
664 CALL zlatms( m, n,
'S', iseed,
'N', rwork, imode, cond,
665 $ anorm, m, n,
'N', a, lda, work, iinfo )
667 ELSE IF( itype.EQ.7 )
THEN
671 CALL zlatmr( mnmin, mnmin,
'S', iseed,
'N', work, 6, one,
672 $ cone,
'T',
'N', work( mnmin+1 ), 1, one,
673 $ work( 2*mnmin+1 ), 1, one,
'N', iwork, 0, 0,
674 $ zero, anorm,
'NO', a, lda, iwork, iinfo )
676 ELSE IF( itype.EQ.8 )
THEN
680 CALL zlatmr( mnmin, mnmin,
'S', iseed,
'S', work, 6, one,
681 $ cone,
'T',
'N', work( mnmin+1 ), 1, one,
682 $ work( m+mnmin+1 ), 1, one,
'N', iwork, m, n,
683 $ zero, anorm,
'NO', a, lda, iwork, iinfo )
685 ELSE IF( itype.EQ.9 )
THEN
689 CALL zlatmr( m, n,
'S', iseed,
'N', work, 6, one, cone,
690 $
'T',
'N', work( mnmin+1 ), 1, one,
691 $ work( m+mnmin+1 ), 1, one,
'N', iwork, m, n,
692 $ zero, anorm,
'NO', a, lda, iwork, iinfo )
694 ELSE IF( itype.EQ.10 )
THEN
698 temp1 = -two*log( ulp )
700 bd( j ) = exp( temp1*dlarnd( 2, iseed ) )
702 $ be( j ) = exp( temp1*dlarnd( 2, iseed ) )
716 IF( iinfo.EQ.0 )
THEN
721 CALL zlatmr( mnmin, nrhs,
'S', iseed,
'N', work, 6,
722 $ one, cone,
'T',
'N', work( mnmin+1 ), 1,
723 $ one, work( 2*mnmin+1 ), 1, one,
'N',
724 $ iwork, mnmin, nrhs, zero, one,
'NO', y,
725 $ ldx, iwork, iinfo )
727 CALL zlatmr( m, nrhs,
'S', iseed,
'N', work, 6, one,
728 $ cone,
'T',
'N', work( m+1 ), 1, one,
729 $ work( 2*m+1 ), 1, one,
'N', iwork, m,
730 $ nrhs, zero, one,
'NO', x, ldx, iwork,
737 IF( iinfo.NE.0 )
THEN
738 WRITE( nout, fmt = 9998 )
'Generator', iinfo, m, n,
748 IF( .NOT.bidiag )
THEN
753 CALL zlacpy(
' ', m, n, a, lda, q, ldq )
754 CALL zgebrd( m, n, q, ldq, bd, be, work, work( mnmin+1 ),
755 $ work( 2*mnmin+1 ), lwork-2*mnmin, iinfo )
759 IF( iinfo.NE.0 )
THEN
760 WRITE( nout, fmt = 9998 )
'ZGEBRD', iinfo, m, n,
766 CALL zlacpy(
' ', m, n, q, ldq, pt, ldpt )
778 CALL zungbr(
'Q', m, mq, n, q, ldq, work,
779 $ work( 2*mnmin+1 ), lwork-2*mnmin, iinfo )
783 IF( iinfo.NE.0 )
THEN
784 WRITE( nout, fmt = 9998 )
'ZUNGBR(Q)', iinfo, m, n,
792 CALL zungbr(
'P', mnmin, n, m, pt, ldpt, work( mnmin+1 ),
793 $ work( 2*mnmin+1 ), lwork-2*mnmin, iinfo )
797 IF( iinfo.NE.0 )
THEN
798 WRITE( nout, fmt = 9998 )
'ZUNGBR(P)', iinfo, m, n,
806 CALL zgemm(
'Conjugate transpose',
'No transpose', m,
807 $ nrhs, m, cone, q, ldq, x, ldx, czero, y,
814 CALL zbdt01( m, n, 1, a, lda, q, ldq, bd, be, pt, ldpt,
815 $ work, rwork, result( 1 ) )
816 CALL zunt01(
'Columns', m, mq, q, ldq, work, lwork,
817 $ rwork, result( 2 ) )
818 CALL zunt01(
'Rows', mnmin, n, pt, ldpt, work, lwork,
819 $ rwork, result( 3 ) )
825 CALL dcopy( mnmin, bd, 1, s1, 1 )
827 $
CALL dcopy( mnmin-1, be, 1, rwork, 1 )
828 CALL zlacpy(
' ', m, nrhs, y, ldx, z, ldx )
829 CALL zlaset(
'Full', mnmin, mnmin, czero, cone, u, ldpt )
830 CALL zlaset(
'Full', mnmin, mnmin, czero, cone, vt, ldpt )
832 CALL zbdsqr( uplo, mnmin, mnmin, mnmin, nrhs, s1, rwork, vt,
833 $ ldpt, u, ldpt, z, ldx, rwork( mnmin+1 ),
838 IF( iinfo.NE.0 )
THEN
839 WRITE( nout, fmt = 9998 )
'ZBDSQR(vects)', iinfo, m, n,
842 IF( iinfo.LT.0 )
THEN
853 CALL dcopy( mnmin, bd, 1, s2, 1 )
855 $
CALL dcopy( mnmin-1, be, 1, rwork, 1 )
857 CALL zbdsqr( uplo, mnmin, 0, 0, 0, s2, rwork, vt, ldpt, u,
858 $ ldpt, z, ldx, rwork( mnmin+1 ), iinfo )
862 IF( iinfo.NE.0 )
THEN
863 WRITE( nout, fmt = 9998 )
'ZBDSQR(values)', iinfo, m, n,
866 IF( iinfo.LT.0 )
THEN
879 CALL zbdt03( uplo, mnmin, 1, bd, be, u, ldpt, s1, vt, ldpt,
880 $ work, result( 4 ) )
881 CALL zbdt02( mnmin, nrhs, y, ldx, z, ldx, u, ldpt, work,
882 $ rwork, result( 5 ) )
883 CALL zunt01(
'Columns', mnmin, mnmin, u, ldpt, work, lwork,
884 $ rwork, result( 6 ) )
885 CALL zunt01(
'Rows', mnmin, mnmin, vt, ldpt, work, lwork,
886 $ rwork, result( 7 ) )
892 DO 110 i = 1, mnmin - 1
893 IF( s1( i ).LT.s1( i+1 ) )
894 $ result( 8 ) = ulpinv
895 IF( s1( i ).LT.zero )
896 $ result( 8 ) = ulpinv
898 IF( mnmin.GE.1 )
THEN
899 IF( s1( mnmin ).LT.zero )
900 $ result( 8 ) = ulpinv
908 temp1 = abs( s1( j )-s2( j ) ) /
909 $ max( sqrt( unfl )*max( s1( 1 ), one ),
910 $ ulp*max( abs( s1( j ) ), abs( s2( j ) ) ) )
911 temp2 = max( temp1, temp2 )
919 temp1 = thresh*( half-ulp )
922 CALL dsvdch( mnmin, bd, be, s1, temp1, iinfo )
934 IF( .NOT.bidiag )
THEN
935 CALL dcopy( mnmin, bd, 1, s2, 1 )
937 $
CALL dcopy( mnmin-1, be, 1, rwork, 1 )
939 CALL zbdsqr( uplo, mnmin, n, m, nrhs, s2, rwork, pt,
940 $ ldpt, q, ldq, y, ldx, rwork( mnmin+1 ),
948 CALL zbdt01( m, n, 0, a, lda, q, ldq, s2, dumma, pt,
949 $ ldpt, work, rwork, result( 11 ) )
950 CALL zbdt02( m, nrhs, x, ldx, y, ldx, q, ldq, work,
951 $ rwork, result( 12 ) )
952 CALL zunt01(
'Columns', m, mq, q, ldq, work, lwork,
953 $ rwork, result( 13 ) )
954 CALL zunt01(
'Rows', mnmin, n, pt, ldpt, work, lwork,
955 $ rwork, result( 14 ) )
962 IF( result( j ).GE.thresh )
THEN
964 $
CALL dlahd2( nout, path )
965 WRITE( nout, fmt = 9999 )m, n, jtype, ioldsd, j,
970 IF( .NOT.bidiag )
THEN
981 CALL alasum( path, nout, nfail, ntest, 0 )
987 9999
FORMAT(
' M=', i5,
', N=', i5,
', type ', i2,
', seed=',
988 $ 4( i4,
',' ),
' test(', i2,
')=', g11.4 )
989 9998
FORMAT(
' ZCHKBD: ', a,
' returned INFO=', i6,
'.', / 9x,
'M=',
990 $ i6,
', N=', i6,
', JTYPE=', i6,
', ISEED=(', 3( i5,
',' ),
subroutine alasum(type, nout, nfail, nrun, nerrs)
ALASUM
subroutine xerbla(srname, info)
subroutine dlahd2(iounit, path)
DLAHD2
subroutine dsvdch(n, s, e, svd, tol, info)
DSVDCH
subroutine zbdsqr(uplo, n, ncvt, nru, ncc, d, e, vt, ldvt, u, ldu, c, ldc, rwork, info)
ZBDSQR
subroutine dcopy(n, dx, incx, dy, incy)
DCOPY
subroutine zgebrd(m, n, a, lda, d, e, tauq, taup, work, lwork, info)
ZGEBRD
subroutine zgemm(transa, transb, m, n, k, alpha, a, lda, b, ldb, beta, c, ldc)
ZGEMM
subroutine zlacpy(uplo, m, n, a, lda, b, ldb)
ZLACPY copies all or part of one two-dimensional array to another.
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.
subroutine zungbr(vect, m, n, k, a, lda, tau, work, lwork, info)
ZUNGBR
subroutine zbdt01(m, n, kd, a, lda, q, ldq, d, e, pt, ldpt, work, rwork, resid)
ZBDT01
subroutine zbdt02(m, n, b, ldb, c, ldc, u, ldu, work, rwork, resid)
ZBDT02
subroutine zbdt03(uplo, n, kd, d, e, u, ldu, s, vt, ldvt, work, resid)
ZBDT03
subroutine zchkbd(nsizes, mval, nval, ntypes, dotype, nrhs, iseed, thresh, a, lda, bd, be, s1, s2, x, ldx, y, z, q, ldq, pt, ldpt, u, vt, work, lwork, rwork, nout, info)
ZCHKBD
subroutine zlatmr(m, n, dist, iseed, sym, d, mode, cond, dmax, rsign, grade, dl, model, condl, dr, moder, condr, pivtng, ipivot, kl, ku, sparse, anorm, pack, a, lda, iwork, info)
ZLATMR
subroutine zlatms(m, n, dist, iseed, sym, d, mode, cond, dmax, kl, ku, pack, a, lda, work, info)
ZLATMS
subroutine zunt01(rowcol, m, n, u, ldu, work, lwork, rwork, resid)
ZUNT01