352 SUBROUTINE ddrvsg( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH,
353 $ NOUNIT, A, LDA, B, LDB, D, Z, LDZ, AB, BB, AP,
354 $ BP, WORK, NWORK, IWORK, LIWORK, RESULT, INFO )
361 INTEGER INFO, LDA, LDB, LDZ, LIWORK, NOUNIT, NSIZES,
363 DOUBLE PRECISION THRESH
367 INTEGER ISEED( 4 ), IWORK( * ), NN( * )
368 DOUBLE PRECISION A( LDA, * ), AB( LDA, * ), AP( * ),
369 $ b( ldb, * ), bb( ldb, * ), bp( * ), d( * ),
370 $ result( * ), work( * ), z( ldz, * )
376 DOUBLE PRECISION ZERO, ONE, TEN
377 PARAMETER ( ZERO = 0.0d0, one = 1.0d0, ten = 10.0d0 )
379 parameter( maxtyp = 21 )
384 INTEGER I, IBTYPE, IBUPLO, IINFO, IJ, IL, IMODE, ITEMP,
385 $ itype, iu, j, jcol, jsize, jtype, ka, ka9, kb,
386 $ kb9, m, mtypes, n, nerrs, nmats, nmax, ntest,
388 DOUBLE PRECISION ABSTOL, ANINV, ANORM, COND, OVFL, RTOVFL,
389 $ RTUNFL, ULP, ULPINV, UNFL, VL, VU
392 INTEGER IDUMMA( 1 ), IOLDSD( 4 ), ISEED2( 4 ),
393 $ KMAGN( MAXTYP ), KMODE( MAXTYP ),
398 DOUBLE PRECISION DLAMCH, DLARND
399 EXTERNAL lsame, dlamch, dlarnd
407 INTRINSIC abs, dble, max, min, sqrt
410 DATA ktype / 1, 2, 5*4, 5*5, 3*8, 6*9 /
411 DATA kmagn / 2*1, 1, 1, 1, 2, 3, 1, 1, 1, 2, 3, 1,
413 DATA kmode / 2*0, 4, 3, 1, 4, 4, 4, 3, 1, 4, 4, 0,
426 nmax = max( nmax, nn( j ) )
433 IF( nsizes.LT.0 )
THEN
435 ELSE IF( badnn )
THEN
437 ELSE IF( ntypes.LT.0 )
THEN
439 ELSE IF( lda.LE.1 .OR. lda.LT.nmax )
THEN
441 ELSE IF( ldz.LE.1 .OR. ldz.LT.nmax )
THEN
443 ELSE IF( 2*max( nmax, 3 )**2.GT.nwork )
THEN
445 ELSE IF( 2*max( nmax, 3 )**2.GT.liwork )
THEN
450 CALL xerbla(
'DDRVSG', -info )
456 IF( nsizes.EQ.0 .OR. ntypes.EQ.0 )
461 unfl = dlamch(
'Safe minimum' )
462 ovfl = dlamch(
'Overflow' )
464 ulp = dlamch(
'Epsilon' )*dlamch(
'Base' )
466 rtunfl = sqrt( unfl )
467 rtovfl = sqrt( ovfl )
470 iseed2( i ) = iseed( i )
478 DO 650 jsize = 1, nsizes
480 aninv = one / dble( max( 1, n ) )
482 IF( nsizes.NE.1 )
THEN
483 mtypes = min( maxtyp, ntypes )
485 mtypes = min( maxtyp+1, ntypes )
490 DO 640 jtype = 1, mtypes
491 IF( .NOT.dotype( jtype ) )
497 ioldsd( j ) = iseed( j )
515 IF( mtypes.GT.maxtyp )
518 itype = ktype( jtype )
519 imode = kmode( jtype )
523 GO TO ( 40, 50, 60 )kmagn( jtype )
530 anorm = ( rtovfl*ulp )*aninv
534 anorm = rtunfl*n*ulpinv
544 IF( itype.EQ.1 )
THEN
550 CALL dlaset(
'Full', lda, n, zero, zero, a, lda )
552 ELSE IF( itype.EQ.2 )
THEN
558 CALL dlaset(
'Full', lda, n, zero, zero, a, lda )
560 a( jcol, jcol ) = anorm
563 ELSE IF( itype.EQ.4 )
THEN
569 CALL dlatms( n, n,
'S', iseed,
'S', work, imode, cond,
570 $ anorm, 0, 0,
'N', a, lda, work( n+1 ),
573 ELSE IF( itype.EQ.5 )
THEN
579 CALL dlatms( n, n,
'S', iseed,
'S', work, imode, cond,
580 $ anorm, n, n,
'N', a, lda, work( n+1 ),
583 ELSE IF( itype.EQ.7 )
THEN
589 CALL dlatmr( n, n,
'S', iseed,
'S', work, 6, one, one,
590 $
'T',
'N', work( n+1 ), 1, one,
591 $ work( 2*n+1 ), 1, one,
'N', idumma, 0, 0,
592 $ zero, anorm,
'NO', a, lda, iwork, iinfo )
594 ELSE IF( itype.EQ.8 )
THEN
600 CALL dlatmr( n, n,
'S', iseed,
'H', work, 6, one, one,
601 $
'T',
'N', work( n+1 ), 1, one,
602 $ work( 2*n+1 ), 1, one,
'N', idumma, n, n,
603 $ zero, anorm,
'NO', a, lda, iwork, iinfo )
605 ELSE IF( itype.EQ.9 )
THEN
619 IF( kb9.GT.ka9 )
THEN
623 ka = max( 0, min( n-1, ka9 ) )
624 kb = max( 0, min( n-1, kb9 ) )
625 CALL dlatms( n, n,
'S', iseed,
'S', work, imode, cond,
626 $ anorm, ka, ka,
'N', a, lda, work( n+1 ),
634 IF( iinfo.NE.0 )
THEN
635 WRITE( nounit, fmt = 9999 )
'Generator', iinfo, n, jtype,
648 il = 1 + ( n-1 )*dlarnd( 1, iseed2 )
649 iu = 1 + ( n-1 )*dlarnd( 1, iseed2 )
678 CALL dlatms( n, n,
'U', iseed,
'P', work, 5, ten, one,
679 $ kb, kb, uplo, b, ldb, work( n+1 ),
686 CALL dlacpy(
' ', n, n, a, lda, z, ldz )
687 CALL dlacpy( uplo, n, n, b, ldb, bb, ldb )
689 CALL dsygv( ibtype,
'V', uplo, n, z, ldz, bb, ldb, d,
690 $ work, nwork, iinfo )
691 IF( iinfo.NE.0 )
THEN
692 WRITE( nounit, fmt = 9999 )
'DSYGV(V,' // uplo //
693 $
')', iinfo, n, jtype, ioldsd
695 IF( iinfo.LT.0 )
THEN
698 result( ntest ) = ulpinv
705 CALL dsgt01( ibtype, uplo, n, n, a, lda, b, ldb, z,
706 $ ldz, d, work, result( ntest ) )
712 CALL dlacpy(
' ', n, n, a, lda, z, ldz )
713 CALL dlacpy( uplo, n, n, b, ldb, bb, ldb )
715 CALL dsygvd( ibtype,
'V', uplo, n, z, ldz, bb, ldb, d,
716 $ work, nwork, iwork, liwork, iinfo )
717 IF( iinfo.NE.0 )
THEN
718 WRITE( nounit, fmt = 9999 )
'DSYGVD(V,' // uplo //
719 $
')', iinfo, n, jtype, ioldsd
721 IF( iinfo.LT.0 )
THEN
724 result( ntest ) = ulpinv
731 CALL dsgt01( ibtype, uplo, n, n, a, lda, b, ldb, z,
732 $ ldz, d, work, result( ntest ) )
738 CALL dlacpy(
' ', n, n, a, lda, ab, lda )
739 CALL dlacpy( uplo, n, n, b, ldb, bb, ldb )
741 CALL dsygvx( ibtype,
'V',
'A', uplo, n, ab, lda, bb,
742 $ ldb, vl, vu, il, iu, abstol, m, d, z,
743 $ ldz, work, nwork, iwork( n+1 ), iwork,
745 IF( iinfo.NE.0 )
THEN
746 WRITE( nounit, fmt = 9999 )
'DSYGVX(V,A' // uplo //
747 $
')', iinfo, n, jtype, ioldsd
749 IF( iinfo.LT.0 )
THEN
752 result( ntest ) = ulpinv
759 CALL dsgt01( ibtype, uplo, n, n, a, lda, b, ldb, z,
760 $ ldz, d, work, result( ntest ) )
764 CALL dlacpy(
' ', n, n, a, lda, ab, lda )
765 CALL dlacpy( uplo, n, n, b, ldb, bb, ldb )
774 CALL dsygvx( ibtype,
'V',
'V', uplo, n, ab, lda, bb,
775 $ ldb, vl, vu, il, iu, abstol, m, d, z,
776 $ ldz, work, nwork, iwork( n+1 ), iwork,
778 IF( iinfo.NE.0 )
THEN
779 WRITE( nounit, fmt = 9999 )
'DSYGVX(V,V,' //
780 $ uplo //
')', iinfo, n, jtype, ioldsd
782 IF( iinfo.LT.0 )
THEN
785 result( ntest ) = ulpinv
792 CALL dsgt01( ibtype, uplo, n, m, a, lda, b, ldb, z,
793 $ ldz, d, work, result( ntest ) )
797 CALL dlacpy(
' ', n, n, a, lda, ab, lda )
798 CALL dlacpy( uplo, n, n, b, ldb, bb, ldb )
800 CALL dsygvx( ibtype,
'V',
'I', uplo, n, ab, lda, bb,
801 $ ldb, vl, vu, il, iu, abstol, m, d, z,
802 $ ldz, work, nwork, iwork( n+1 ), iwork,
804 IF( iinfo.NE.0 )
THEN
805 WRITE( nounit, fmt = 9999 )
'DSYGVX(V,I,' //
806 $ uplo //
')', iinfo, n, jtype, ioldsd
808 IF( iinfo.LT.0 )
THEN
811 result( ntest ) = ulpinv
818 CALL dsgt01( ibtype, uplo, n, m, a, lda, b, ldb, z,
819 $ ldz, d, work, result( ntest ) )
829 IF( lsame( uplo,
'U' ) )
THEN
849 CALL dspgv( ibtype,
'V', uplo, n, ap, bp, d, z, ldz,
851 IF( iinfo.NE.0 )
THEN
852 WRITE( nounit, fmt = 9999 )
'DSPGV(V,' // uplo //
853 $
')', iinfo, n, jtype, ioldsd
855 IF( iinfo.LT.0 )
THEN
858 result( ntest ) = ulpinv
865 CALL dsgt01( ibtype, uplo, n, n, a, lda, b, ldb, z,
866 $ ldz, d, work, result( ntest ) )
874 IF( lsame( uplo,
'U' ) )
THEN
894 CALL dspgvd( ibtype,
'V', uplo, n, ap, bp, d, z, ldz,
895 $ work, nwork, iwork, liwork, iinfo )
896 IF( iinfo.NE.0 )
THEN
897 WRITE( nounit, fmt = 9999 )
'DSPGVD(V,' // uplo //
898 $
')', iinfo, n, jtype, ioldsd
900 IF( iinfo.LT.0 )
THEN
903 result( ntest ) = ulpinv
910 CALL dsgt01( ibtype, uplo, n, n, a, lda, b, ldb, z,
911 $ ldz, d, work, result( ntest ) )
919 IF( lsame( uplo,
'U' ) )
THEN
939 CALL dspgvx( ibtype,
'V',
'A', uplo, n, ap, bp, vl,
940 $ vu, il, iu, abstol, m, d, z, ldz, work,
941 $ iwork( n+1 ), iwork, info )
942 IF( iinfo.NE.0 )
THEN
943 WRITE( nounit, fmt = 9999 )
'DSPGVX(V,A' // uplo //
944 $
')', iinfo, n, jtype, ioldsd
946 IF( iinfo.LT.0 )
THEN
949 result( ntest ) = ulpinv
956 CALL dsgt01( ibtype, uplo, n, m, a, lda, b, ldb, z,
957 $ ldz, d, work, result( ntest ) )
963 IF( lsame( uplo,
'U' ) )
THEN
985 CALL dspgvx( ibtype,
'V',
'V', uplo, n, ap, bp, vl,
986 $ vu, il, iu, abstol, m, d, z, ldz, work,
987 $ iwork( n+1 ), iwork, info )
988 IF( iinfo.NE.0 )
THEN
989 WRITE( nounit, fmt = 9999 )
'DSPGVX(V,V' // uplo //
990 $
')', iinfo, n, jtype, ioldsd
992 IF( iinfo.LT.0 )
THEN
995 result( ntest ) = ulpinv
1002 CALL dsgt01( ibtype, uplo, n, m, a, lda, b, ldb, z,
1003 $ ldz, d, work, result( ntest ) )
1009 IF( lsame( uplo,
'U' ) )
THEN
1013 ap( ij ) = a( i, j )
1014 bp( ij ) = b( i, j )
1022 ap( ij ) = a( i, j )
1023 bp( ij ) = b( i, j )
1029 CALL dspgvx( ibtype,
'V',
'I', uplo, n, ap, bp, vl,
1030 $ vu, il, iu, abstol, m, d, z, ldz, work,
1031 $ iwork( n+1 ), iwork, info )
1032 IF( iinfo.NE.0 )
THEN
1033 WRITE( nounit, fmt = 9999 )
'DSPGVX(V,I' // uplo //
1034 $
')', iinfo, n, jtype, ioldsd
1036 IF( iinfo.LT.0 )
THEN
1039 result( ntest ) = ulpinv
1046 CALL dsgt01( ibtype, uplo, n, m, a, lda, b, ldb, z,
1047 $ ldz, d, work, result( ntest ) )
1051 IF( ibtype.EQ.1 )
THEN
1059 IF( lsame( uplo,
'U' ) )
THEN
1061 DO 320 i = max( 1, j-ka ), j
1062 ab( ka+1+i-j, j ) = a( i, j )
1064 DO 330 i = max( 1, j-kb ), j
1065 bb( kb+1+i-j, j ) = b( i, j )
1070 DO 350 i = j, min( n, j+ka )
1071 ab( 1+i-j, j ) = a( i, j )
1073 DO 360 i = j, min( n, j+kb )
1074 bb( 1+i-j, j ) = b( i, j )
1079 CALL dsbgv(
'V', uplo, n, ka, kb, ab, lda, bb, ldb,
1080 $ d, z, ldz, work, iinfo )
1081 IF( iinfo.NE.0 )
THEN
1082 WRITE( nounit, fmt = 9999 )
'DSBGV(V,' //
1083 $ uplo //
')', iinfo, n, jtype, ioldsd
1085 IF( iinfo.LT.0 )
THEN
1088 result( ntest ) = ulpinv
1095 CALL dsgt01( ibtype, uplo, n, n, a, lda, b, ldb, z,
1096 $ ldz, d, work, result( ntest ) )
1104 IF( lsame( uplo,
'U' ) )
THEN
1106 DO 380 i = max( 1, j-ka ), j
1107 ab( ka+1+i-j, j ) = a( i, j )
1109 DO 390 i = max( 1, j-kb ), j
1110 bb( kb+1+i-j, j ) = b( i, j )
1115 DO 410 i = j, min( n, j+ka )
1116 ab( 1+i-j, j ) = a( i, j )
1118 DO 420 i = j, min( n, j+kb )
1119 bb( 1+i-j, j ) = b( i, j )
1124 CALL dsbgvd(
'V', uplo, n, ka, kb, ab, lda, bb,
1125 $ ldb, d, z, ldz, work, nwork, iwork,
1127 IF( iinfo.NE.0 )
THEN
1128 WRITE( nounit, fmt = 9999 )
'DSBGVD(V,' //
1129 $ uplo //
')', iinfo, n, jtype, ioldsd
1131 IF( iinfo.LT.0 )
THEN
1134 result( ntest ) = ulpinv
1141 CALL dsgt01( ibtype, uplo, n, n, a, lda, b, ldb, z,
1142 $ ldz, d, work, result( ntest ) )
1150 IF( lsame( uplo,
'U' ) )
THEN
1152 DO 440 i = max( 1, j-ka ), j
1153 ab( ka+1+i-j, j ) = a( i, j )
1155 DO 450 i = max( 1, j-kb ), j
1156 bb( kb+1+i-j, j ) = b( i, j )
1161 DO 470 i = j, min( n, j+ka )
1162 ab( 1+i-j, j ) = a( i, j )
1164 DO 480 i = j, min( n, j+kb )
1165 bb( 1+i-j, j ) = b( i, j )
1170 CALL dsbgvx(
'V',
'A', uplo, n, ka, kb, ab, lda,
1171 $ bb, ldb, bp, max( 1, n ), vl, vu, il,
1172 $ iu, abstol, m, d, z, ldz, work,
1173 $ iwork( n+1 ), iwork, iinfo )
1174 IF( iinfo.NE.0 )
THEN
1175 WRITE( nounit, fmt = 9999 )
'DSBGVX(V,A' //
1176 $ uplo //
')', iinfo, n, jtype, ioldsd
1178 IF( iinfo.LT.0 )
THEN
1181 result( ntest ) = ulpinv
1188 CALL dsgt01( ibtype, uplo, n, m, a, lda, b, ldb, z,
1189 $ ldz, d, work, result( ntest ) )
1196 IF( lsame( uplo,
'U' ) )
THEN
1198 DO 500 i = max( 1, j-ka ), j
1199 ab( ka+1+i-j, j ) = a( i, j )
1201 DO 510 i = max( 1, j-kb ), j
1202 bb( kb+1+i-j, j ) = b( i, j )
1207 DO 530 i = j, min( n, j+ka )
1208 ab( 1+i-j, j ) = a( i, j )
1210 DO 540 i = j, min( n, j+kb )
1211 bb( 1+i-j, j ) = b( i, j )
1218 CALL dsbgvx(
'V',
'V', uplo, n, ka, kb, ab, lda,
1219 $ bb, ldb, bp, max( 1, n ), vl, vu, il,
1220 $ iu, abstol, m, d, z, ldz, work,
1221 $ iwork( n+1 ), iwork, iinfo )
1222 IF( iinfo.NE.0 )
THEN
1223 WRITE( nounit, fmt = 9999 )
'DSBGVX(V,V' //
1224 $ uplo //
')', iinfo, n, jtype, ioldsd
1226 IF( iinfo.LT.0 )
THEN
1229 result( ntest ) = ulpinv
1236 CALL dsgt01( ibtype, uplo, n, m, a, lda, b, ldb, z,
1237 $ ldz, d, work, result( ntest ) )
1243 IF( lsame( uplo,
'U' ) )
THEN
1245 DO 560 i = max( 1, j-ka ), j
1246 ab( ka+1+i-j, j ) = a( i, j )
1248 DO 570 i = max( 1, j-kb ), j
1249 bb( kb+1+i-j, j ) = b( i, j )
1254 DO 590 i = j, min( n, j+ka )
1255 ab( 1+i-j, j ) = a( i, j )
1257 DO 600 i = j, min( n, j+kb )
1258 bb( 1+i-j, j ) = b( i, j )
1263 CALL dsbgvx(
'V',
'I', uplo, n, ka, kb, ab, lda,
1264 $ bb, ldb, bp, max( 1, n ), vl, vu, il,
1265 $ iu, abstol, m, d, z, ldz, work,
1266 $ iwork( n+1 ), iwork, iinfo )
1267 IF( iinfo.NE.0 )
THEN
1268 WRITE( nounit, fmt = 9999 )
'DSBGVX(V,I' //
1269 $ uplo //
')', iinfo, n, jtype, ioldsd
1271 IF( iinfo.LT.0 )
THEN
1274 result( ntest ) = ulpinv
1281 CALL dsgt01( ibtype, uplo, n, m, a, lda, b, ldb, z,
1282 $ ldz, d, work, result( ntest ) )
1291 ntestt = ntestt + ntest
1292 CALL dlafts(
'DSG', n, n, jtype, ntest, result, ioldsd,
1293 $ thresh, nounit, nerrs )
1299 CALL dlasum(
'DSG', nounit, nerrs, ntestt )
1305 9999
FORMAT(
' DDRVSG: ', a,
' returned INFO=', i6,
'.', / 9x,
'N=',
1306 $ i6,
', JTYPE=', i6,
', ISEED=(', 3( i5,
',' ), i5,
')' )
subroutine dlabad(SMALL, LARGE)
DLABAD
subroutine dlacpy(UPLO, M, N, A, LDA, B, LDB)
DLACPY copies all or part of one two-dimensional array to another.
subroutine dlaset(UPLO, M, N, ALPHA, BETA, A, LDA)
DLASET initializes the off-diagonal elements and the diagonal elements of a matrix to given values.
subroutine xerbla(SRNAME, INFO)
XERBLA
subroutine dlasum(TYPE, IOUNIT, IE, NRUN)
DLASUM
subroutine dlafts(TYPE, M, N, IMAT, NTESTS, RESULT, ISEED, THRESH, IOUNIT, IE)
DLAFTS
subroutine dsgt01(ITYPE, UPLO, N, M, A, LDA, B, LDB, Z, LDZ, D, WORK, RESULT)
DSGT01
subroutine ddrvsg(NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, NOUNIT, A, LDA, B, LDB, D, Z, LDZ, AB, BB, AP, BP, WORK, NWORK, IWORK, LIWORK, RESULT, INFO)
DDRVSG
subroutine dlatmr(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)
DLATMR
subroutine dlatms(M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, KL, KU, PACK, A, LDA, WORK, INFO)
DLATMS
subroutine dspgvx(ITYPE, JOBZ, RANGE, UPLO, N, AP, BP, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, IWORK, IFAIL, INFO)
DSPGVX
subroutine dsbgv(JOBZ, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, W, Z, LDZ, WORK, INFO)
DSBGV
subroutine dspgv(ITYPE, JOBZ, UPLO, N, AP, BP, W, Z, LDZ, WORK, INFO)
DSPGV
subroutine dsbgvd(JOBZ, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, W, Z, LDZ, WORK, LWORK, IWORK, LIWORK, INFO)
DSBGVD
subroutine dsbgvx(JOBZ, RANGE, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, Q, LDQ, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, IWORK, IFAIL, INFO)
DSBGVX
subroutine dspgvd(ITYPE, JOBZ, UPLO, N, AP, BP, W, Z, LDZ, WORK, LWORK, IWORK, LIWORK, INFO)
DSPGVD
subroutine dsygv(ITYPE, JOBZ, UPLO, N, A, LDA, B, LDB, W, WORK, LWORK, INFO)
DSYGV
subroutine dsygvx(ITYPE, JOBZ, RANGE, UPLO, N, A, LDA, B, LDB, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, LWORK, IWORK, IFAIL, INFO)
DSYGVX
subroutine dsygvd(ITYPE, JOBZ, UPLO, N, A, LDA, B, LDB, W, WORK, LWORK, IWORK, LIWORK, INFO)
DSYGVD