622 SUBROUTINE cchkst2stg( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH,
623 $ nounit, a, lda, ap, sd, se, d1, d2, d3, d4, d5,
624 $ wa1, wa2, wa3, wr, u, ldu, v, vp, tau, z, work,
625 $ lwork, rwork, lrwork, iwork, liwork, result,
634 INTEGER INFO, LDA, LDU, LIWORK, LRWORK, LWORK, NOUNIT,
640 INTEGER ISEED( 4 ), IWORK( * ), NN( * )
641 REAL D1( * ), D2( * ), D3( * ), D4( * ), D5( * ),
642 $ result( * ), rwork( * ), sd( * ), se( * ),
643 $ wa1( * ), wa2( * ), wa3( * ), wr( * )
644 COMPLEX A( lda, * ), AP( * ), TAU( * ), U( ldu, * ),
645 $ v( ldu, * ), vp( * ), work( * ), z( ldu, * )
651 REAL ZERO, ONE, TWO, EIGHT, TEN, HUN
652 parameter ( zero = 0.0e0, one = 1.0e0, two = 2.0e0,
653 $ eight = 8.0e0, ten = 10.0e0, hun = 100.0e0 )
655 parameter ( czero = ( 0.0e+0, 0.0e+0 ),
656 $ cone = ( 1.0e+0, 0.0e+0 ) )
658 parameter ( half = one / two )
660 parameter ( maxtyp = 21 )
662 parameter ( crange = .false. )
664 parameter ( crel = .false. )
667 LOGICAL BADNN, TRYRAC
668 INTEGER I, IINFO, IL, IMODE, INDE, INDRWK, ITEMP,
669 $ itype, iu, j, jc, jr, jsize, jtype, lgn,
670 $ liwedc, log2ui, lrwedc, lwedc, m, m2, m3,
671 $ mtypes, n, nap, nblock, nerrs, nmats, nmax,
672 $ nsplit, ntest, ntestt, lh, lw
673 REAL ABSTOL, ANINV, ANORM, COND, OVFL, RTOVFL,
674 $ rtunfl, temp1, temp2, temp3, temp4, ulp,
675 $ ulpinv, unfl, vl, vu
678 INTEGER IDUMMA( 1 ), IOLDSD( 4 ), ISEED2( 4 ),
679 $ kmagn( maxtyp ), kmode( maxtyp ),
685 REAL SLAMCH, SLARND, SSXT1
686 EXTERNAL ilaenv, slamch, slarnd, ssxt1
696 INTRINSIC abs,
REAL, CONJG, INT, LOG, MAX, MIN, SQRT
699 DATA ktype / 1, 2, 4, 4, 4, 4, 4, 5, 5, 5, 5, 5, 8,
700 $ 8, 8, 9, 9, 9, 9, 9, 10 /
701 DATA kmagn / 1, 1, 1, 1, 1, 2, 3, 1, 1, 1, 2, 3, 1,
702 $ 2, 3, 1, 1, 1, 2, 3, 1 /
703 DATA kmode / 0, 0, 4, 3, 1, 4, 4, 4, 3, 1, 4, 4, 0,
704 $ 0, 0, 4, 3, 1, 4, 4, 3 /
722 nmax = max( nmax, nn( j ) )
727 nblock = ilaenv( 1,
'CHETRD',
'L', nmax, -1, -1, -1 )
728 nblock = min( nmax, max( 1, nblock ) )
732 IF( nsizes.LT.0 )
THEN
734 ELSE IF( badnn )
THEN
736 ELSE IF( ntypes.LT.0 )
THEN
738 ELSE IF( lda.LT.nmax )
THEN
740 ELSE IF( ldu.LT.nmax )
THEN
742 ELSE IF( 2*max( 2, nmax )**2.GT.lwork )
THEN
747 CALL xerbla(
'CCHKST2STG', -info )
753 IF( nsizes.EQ.0 .OR. ntypes.EQ.0 )
758 unfl = slamch(
'Safe minimum' )
761 ulp = slamch(
'Epsilon' )*slamch(
'Base' )
763 log2ui = int( log( ulpinv ) / log( two ) )
764 rtunfl = sqrt( unfl )
765 rtovfl = sqrt( ovfl )
770 iseed2( i ) = iseed( i )
775 DO 310 jsize = 1, nsizes
778 lgn = int( log(
REAL( N ) ) / log( TWO ) )
783 lwedc = 1 + 4*n + 2*n*lgn + 4*n**2
784 lrwedc = 1 + 3*n + 2*n*lgn + 4*n**2
785 liwedc = 6 + 6*n + 5*n*lgn
791 nap = ( n*( n+1 ) ) / 2
792 aninv = one /
REAL( MAX( 1, N ) )
794 IF( nsizes.NE.1 )
THEN
795 mtypes = min( maxtyp, ntypes )
797 mtypes = min( maxtyp+1, ntypes )
800 DO 300 jtype = 1, mtypes
801 IF( .NOT.dotype( jtype ) )
807 ioldsd( j ) = iseed( j )
826 IF( mtypes.GT.maxtyp )
829 itype = ktype( jtype )
830 imode = kmode( jtype )
834 GO TO ( 40, 50, 60 )kmagn( jtype )
841 anorm = ( rtovfl*ulp )*aninv
845 anorm = rtunfl*n*ulpinv
850 CALL claset(
'Full', lda, n, czero, czero, a, lda )
852 IF( jtype.LE.15 )
THEN
855 cond = ulpinv*aninv / ten
862 IF( itype.EQ.1 )
THEN
865 ELSE IF( itype.EQ.2 )
THEN
873 ELSE IF( itype.EQ.4 )
THEN
877 CALL clatms( n, n,
'S', iseed,
'H', rwork, imode, cond,
878 $ anorm, 0, 0,
'N', a, lda, work, iinfo )
881 ELSE IF( itype.EQ.5 )
THEN
885 CALL clatms( n, n,
'S', iseed,
'H', rwork, imode, cond,
886 $ anorm, n, n,
'N', a, lda, work, iinfo )
888 ELSE IF( itype.EQ.7 )
THEN
892 CALL clatmr( n, n,
'S', iseed,
'H', work, 6, one, cone,
893 $
'T',
'N', work( n+1 ), 1, one,
894 $ work( 2*n+1 ), 1, one,
'N', idumma, 0, 0,
895 $ zero, anorm,
'NO', a, lda, iwork, iinfo )
897 ELSE IF( itype.EQ.8 )
THEN
901 CALL clatmr( n, n,
'S', iseed,
'H', work, 6, one, cone,
902 $
'T',
'N', work( n+1 ), 1, one,
903 $ work( 2*n+1 ), 1, one,
'N', idumma, n, n,
904 $ zero, anorm,
'NO', a, lda, iwork, iinfo )
906 ELSE IF( itype.EQ.9 )
THEN
910 CALL clatms( n, n,
'S', iseed,
'P', rwork, imode, cond,
911 $ anorm, n, n,
'N', a, lda, work, iinfo )
913 ELSE IF( itype.EQ.10 )
THEN
917 CALL clatms( n, n,
'S', iseed,
'P', rwork, imode, cond,
918 $ anorm, 1, 1,
'N', a, lda, work, iinfo )
920 temp1 = abs( a( i-1, i ) )
921 temp2 = sqrt( abs( a( i-1, i-1 )*a( i, i ) ) )
922 IF( temp1.GT.half*temp2 )
THEN
923 a( i-1, i ) = a( i-1, i )*
924 $ ( half*temp2 / ( unfl+temp1 ) )
925 a( i, i-1 ) = conjg( a( i-1, i ) )
934 IF( iinfo.NE.0 )
THEN
935 WRITE( nounit, fmt = 9999 )
'Generator', iinfo, n, jtype,
946 CALL clacpy(
'U', n, n, a, lda, v, ldu )
949 CALL chetrd(
'U', n, v, ldu, sd, se, tau, work, lwork,
952 IF( iinfo.NE.0 )
THEN
953 WRITE( nounit, fmt = 9999 )
'CHETRD(U)', iinfo, n, jtype,
956 IF( iinfo.LT.0 )
THEN
964 CALL clacpy(
'U', n, n, v, ldu, u, ldu )
967 CALL cungtr(
'U', n, u, ldu, tau, work, lwork, iinfo )
968 IF( iinfo.NE.0 )
THEN
969 WRITE( nounit, fmt = 9999 )
'CUNGTR(U)', iinfo, n, jtype,
972 IF( iinfo.LT.0 )
THEN
982 CALL chet21( 2,
'Upper', n, 1, a, lda, sd, se, u, ldu, v,
983 $ ldu, tau, work, rwork, result( 1 ) )
984 CALL chet21( 3,
'Upper', n, 1, a, lda, sd, se, u, ldu, v,
985 $ ldu, tau, work, rwork, result( 2 ) )
994 CALL scopy( n, sd, 1, d1, 1 )
996 $
CALL scopy( n-1, se, 1, rwork, 1 )
998 CALL csteqr(
'N', n, d1, rwork, work, ldu, rwork( n+1 ),
1000 IF( iinfo.NE.0 )
THEN
1001 WRITE( nounit, fmt = 9999 )
'CSTEQR(N)', iinfo, n, jtype,
1004 IF( iinfo.LT.0 )
THEN
1007 result( 3 ) = ulpinv
1017 CALL dlaset(
'Full', n, 1, zero, zero, sd, 1 )
1018 CALL dlaset(
'Full', n, 1, zero, zero, se, 1 )
1019 CALL clacpy(
'U', n, n, a, lda, v, ldu )
1023 $ work, lh, work( lh+1 ), lw, iinfo )
1027 CALL scopy( n, sd, 1, d2, 1 )
1029 $
CALL scopy( n-1, se, 1, rwork, 1 )
1032 CALL csteqr(
'N', n, d2, rwork, work, ldu, rwork( n+1 ),
1034 IF( iinfo.NE.0 )
THEN
1035 WRITE( nounit, fmt = 9999 )
'CSTEQR(N)', iinfo, n, jtype,
1038 IF( iinfo.LT.0 )
THEN
1041 result( 3 ) = ulpinv
1051 CALL dlaset(
'Full', n, 1, zero, zero, sd, 1 )
1052 CALL dlaset(
'Full', n, 1, zero, zero, se, 1 )
1053 CALL clacpy(
'L', n, n, a, lda, v, ldu )
1055 $ work, lh, work( lh+1 ), lw, iinfo )
1059 CALL scopy( n, sd, 1, d3, 1 )
1061 $
CALL scopy( n-1, se, 1, rwork, 1 )
1064 CALL csteqr(
'N', n, d3, rwork, work, ldu, rwork( n+1 ),
1066 IF( iinfo.NE.0 )
THEN
1067 WRITE( nounit, fmt = 9999 )
'CSTEQR(N)', iinfo, n, jtype,
1070 IF( iinfo.LT.0 )
THEN
1073 result( 4 ) = ulpinv
1089 temp1 = max( temp1, abs( d1( j ) ), abs( d2( j ) ) )
1090 temp2 = max( temp2, abs( d1( j )-d2( j ) ) )
1091 temp3 = max( temp3, abs( d1( j ) ), abs( d3( j ) ) )
1092 temp4 = max( temp4, abs( d1( j )-d3( j ) ) )
1095 result( 3 ) = temp2 / max( unfl, ulp*max( temp1, temp2 ) )
1096 result( 4 ) = temp4 / max( unfl, ulp*max( temp3, temp4 ) )
1104 ap( i ) = a( jr, jc )
1110 CALL ccopy( nap, ap, 1, vp, 1 )
1113 CALL chptrd(
'U', n, vp, sd, se, tau, iinfo )
1115 IF( iinfo.NE.0 )
THEN
1116 WRITE( nounit, fmt = 9999 )
'CHPTRD(U)', iinfo, n, jtype,
1119 IF( iinfo.LT.0 )
THEN
1122 result( 5 ) = ulpinv
1128 CALL cupgtr(
'U', n, vp, tau, u, ldu, work, iinfo )
1129 IF( iinfo.NE.0 )
THEN
1130 WRITE( nounit, fmt = 9999 )
'CUPGTR(U)', iinfo, n, jtype,
1133 IF( iinfo.LT.0 )
THEN
1136 result( 6 ) = ulpinv
1143 CALL chpt21( 2,
'Upper', n, 1, ap, sd, se, u, ldu, vp, tau,
1144 $ work, rwork, result( 5 ) )
1145 CALL chpt21( 3,
'Upper', n, 1, ap, sd, se, u, ldu, vp, tau,
1146 $ work, rwork, result( 6 ) )
1154 ap( i ) = a( jr, jc )
1160 CALL ccopy( nap, ap, 1, vp, 1 )
1163 CALL chptrd(
'L', n, vp, sd, se, tau, iinfo )
1165 IF( iinfo.NE.0 )
THEN
1166 WRITE( nounit, fmt = 9999 )
'CHPTRD(L)', iinfo, n, jtype,
1169 IF( iinfo.LT.0 )
THEN
1172 result( 7 ) = ulpinv
1178 CALL cupgtr(
'L', n, vp, tau, u, ldu, work, iinfo )
1179 IF( iinfo.NE.0 )
THEN
1180 WRITE( nounit, fmt = 9999 )
'CUPGTR(L)', iinfo, n, jtype,
1183 IF( iinfo.LT.0 )
THEN
1186 result( 8 ) = ulpinv
1191 CALL chpt21( 2,
'Lower', n, 1, ap, sd, se, u, ldu, vp, tau,
1192 $ work, rwork, result( 7 ) )
1193 CALL chpt21( 3,
'Lower', n, 1, ap, sd, se, u, ldu, vp, tau,
1194 $ work, rwork, result( 8 ) )
1200 CALL scopy( n, sd, 1, d1, 1 )
1202 $
CALL scopy( n-1, se, 1, rwork, 1 )
1203 CALL claset(
'Full', n, n, czero, cone, z, ldu )
1206 CALL csteqr(
'V', n, d1, rwork, z, ldu, rwork( n+1 ),
1208 IF( iinfo.NE.0 )
THEN
1209 WRITE( nounit, fmt = 9999 )
'CSTEQR(V)', iinfo, n, jtype,
1212 IF( iinfo.LT.0 )
THEN
1215 result( 9 ) = ulpinv
1222 CALL scopy( n, sd, 1, d2, 1 )
1224 $
CALL scopy( n-1, se, 1, rwork, 1 )
1227 CALL csteqr(
'N', n, d2, rwork, work, ldu, rwork( n+1 ),
1229 IF( iinfo.NE.0 )
THEN
1230 WRITE( nounit, fmt = 9999 )
'CSTEQR(N)', iinfo, n, jtype,
1233 IF( iinfo.LT.0 )
THEN
1236 result( 11 ) = ulpinv
1243 CALL scopy( n, sd, 1, d3, 1 )
1245 $
CALL scopy( n-1, se, 1, rwork, 1 )
1248 CALL ssterf( n, d3, rwork, iinfo )
1249 IF( iinfo.NE.0 )
THEN
1250 WRITE( nounit, fmt = 9999 )
'SSTERF', iinfo, n, jtype,
1253 IF( iinfo.LT.0 )
THEN
1256 result( 12 ) = ulpinv
1263 CALL cstt21( n, 0, sd, se, d1, dumma, z, ldu, work, rwork,
1274 temp1 = max( temp1, abs( d1( j ) ), abs( d2( j ) ) )
1275 temp2 = max( temp2, abs( d1( j )-d2( j ) ) )
1276 temp3 = max( temp3, abs( d1( j ) ), abs( d3( j ) ) )
1277 temp4 = max( temp4, abs( d1( j )-d3( j ) ) )
1280 result( 11 ) = temp2 / max( unfl, ulp*max( temp1, temp2 ) )
1281 result( 12 ) = temp4 / max( unfl, ulp*max( temp3, temp4 ) )
1287 temp1 = thresh*( half-ulp )
1289 DO 160 j = 0, log2ui
1290 CALL sstech( n, sd, se, d1, temp1, rwork, iinfo )
1297 result( 13 ) = temp1
1302 IF( jtype.GT.15 )
THEN
1306 CALL scopy( n, sd, 1, d4, 1 )
1308 $
CALL scopy( n-1, se, 1, rwork, 1 )
1309 CALL claset(
'Full', n, n, czero, cone, z, ldu )
1312 CALL cpteqr(
'V', n, d4, rwork, z, ldu, rwork( n+1 ),
1314 IF( iinfo.NE.0 )
THEN
1315 WRITE( nounit, fmt = 9999 )
'CPTEQR(V)', iinfo, n,
1318 IF( iinfo.LT.0 )
THEN
1321 result( 14 ) = ulpinv
1328 CALL cstt21( n, 0, sd, se, d4, dumma, z, ldu, work,
1329 $ rwork, result( 14 ) )
1333 CALL scopy( n, sd, 1, d5, 1 )
1335 $
CALL scopy( n-1, se, 1, rwork, 1 )
1338 CALL cpteqr(
'N', n, d5, rwork, z, ldu, rwork( n+1 ),
1340 IF( iinfo.NE.0 )
THEN
1341 WRITE( nounit, fmt = 9999 )
'CPTEQR(N)', iinfo, n,
1344 IF( iinfo.LT.0 )
THEN
1347 result( 16 ) = ulpinv
1357 temp1 = max( temp1, abs( d4( j ) ), abs( d5( j ) ) )
1358 temp2 = max( temp2, abs( d4( j )-d5( j ) ) )
1361 result( 16 ) = temp2 / max( unfl,
1362 $ hun*ulp*max( temp1, temp2 ) )
1378 IF( jtype.EQ.21 )
THEN
1380 abstol = unfl + unfl
1381 CALL sstebz(
'A',
'E', n, vl, vu, il, iu, abstol, sd, se,
1382 $ m, nsplit, wr, iwork( 1 ), iwork( n+1 ),
1383 $ rwork, iwork( 2*n+1 ), iinfo )
1384 IF( iinfo.NE.0 )
THEN
1385 WRITE( nounit, fmt = 9999 )
'SSTEBZ(A,rel)', iinfo, n,
1388 IF( iinfo.LT.0 )
THEN
1391 result( 17 ) = ulpinv
1398 temp2 = two*( two*n-one )*ulp*( one+eight*half**2 ) /
1403 temp1 = max( temp1, abs( d4( j )-wr( n-j+1 ) ) /
1404 $ ( abstol+abs( d4( j ) ) ) )
1407 result( 17 ) = temp1 / temp2
1415 abstol = unfl + unfl
1416 CALL sstebz(
'A',
'E', n, vl, vu, il, iu, abstol, sd, se, m,
1417 $ nsplit, wa1, iwork( 1 ), iwork( n+1 ), rwork,
1418 $ iwork( 2*n+1 ), iinfo )
1419 IF( iinfo.NE.0 )
THEN
1420 WRITE( nounit, fmt = 9999 )
'SSTEBZ(A)', iinfo, n, jtype,
1423 IF( iinfo.LT.0 )
THEN
1426 result( 18 ) = ulpinv
1436 temp1 = max( temp1, abs( d3( j ) ), abs( wa1( j ) ) )
1437 temp2 = max( temp2, abs( d3( j )-wa1( j ) ) )
1440 result( 18 ) = temp2 / max( unfl, ulp*max( temp1, temp2 ) )
1450 il = 1 + ( n-1 )*int( slarnd( 1, iseed2 ) )
1451 iu = 1 + ( n-1 )*int( slarnd( 1, iseed2 ) )
1459 CALL sstebz(
'I',
'E', n, vl, vu, il, iu, abstol, sd, se,
1460 $ m2, nsplit, wa2, iwork( 1 ), iwork( n+1 ),
1461 $ rwork, iwork( 2*n+1 ), iinfo )
1462 IF( iinfo.NE.0 )
THEN
1463 WRITE( nounit, fmt = 9999 )
'SSTEBZ(I)', iinfo, n, jtype,
1466 IF( iinfo.LT.0 )
THEN
1469 result( 19 ) = ulpinv
1479 vl = wa1( il ) - max( half*( wa1( il )-wa1( il-1 ) ),
1480 $ ulp*anorm, two*rtunfl )
1482 vl = wa1( 1 ) - max( half*( wa1( n )-wa1( 1 ) ),
1483 $ ulp*anorm, two*rtunfl )
1486 vu = wa1( iu ) + max( half*( wa1( iu+1 )-wa1( iu ) ),
1487 $ ulp*anorm, two*rtunfl )
1489 vu = wa1( n ) + max( half*( wa1( n )-wa1( 1 ) ),
1490 $ ulp*anorm, two*rtunfl )
1497 CALL sstebz(
'V',
'E', n, vl, vu, il, iu, abstol, sd, se,
1498 $ m3, nsplit, wa3, iwork( 1 ), iwork( n+1 ),
1499 $ rwork, iwork( 2*n+1 ), iinfo )
1500 IF( iinfo.NE.0 )
THEN
1501 WRITE( nounit, fmt = 9999 )
'SSTEBZ(V)', iinfo, n, jtype,
1504 IF( iinfo.LT.0 )
THEN
1507 result( 19 ) = ulpinv
1512 IF( m3.EQ.0 .AND. n.NE.0 )
THEN
1513 result( 19 ) = ulpinv
1519 temp1 = ssxt1( 1, wa2, m2, wa3, m3, abstol, ulp, unfl )
1520 temp2 = ssxt1( 1, wa3, m3, wa2, m2, abstol, ulp, unfl )
1522 temp3 = max( abs( wa1( n ) ), abs( wa1( 1 ) ) )
1527 result( 19 ) = ( temp1+temp2 ) / max( unfl, temp3*ulp )
1534 CALL sstebz(
'A',
'B', n, vl, vu, il, iu, abstol, sd, se, m,
1535 $ nsplit, wa1, iwork( 1 ), iwork( n+1 ), rwork,
1536 $ iwork( 2*n+1 ), iinfo )
1537 IF( iinfo.NE.0 )
THEN
1538 WRITE( nounit, fmt = 9999 )
'SSTEBZ(A,B)', iinfo, n,
1541 IF( iinfo.LT.0 )
THEN
1544 result( 20 ) = ulpinv
1545 result( 21 ) = ulpinv
1550 CALL cstein( n, sd, se, m, wa1, iwork( 1 ), iwork( n+1 ), z,
1551 $ ldu, rwork, iwork( 2*n+1 ), iwork( 3*n+1 ),
1553 IF( iinfo.NE.0 )
THEN
1554 WRITE( nounit, fmt = 9999 )
'CSTEIN', iinfo, n, jtype,
1557 IF( iinfo.LT.0 )
THEN
1560 result( 20 ) = ulpinv
1561 result( 21 ) = ulpinv
1568 CALL cstt21( n, 0, sd, se, wa1, dumma, z, ldu, work, rwork,
1577 CALL scopy( n, sd, 1, d1, 1 )
1579 $
CALL scopy( n-1, se, 1, rwork( inde ), 1 )
1580 CALL claset(
'Full', n, n, czero, cone, z, ldu )
1583 CALL cstedc(
'I', n, d1, rwork( inde ), z, ldu, work, lwedc,
1584 $ rwork( indrwk ), lrwedc, iwork, liwedc, iinfo )
1585 IF( iinfo.NE.0 )
THEN
1586 WRITE( nounit, fmt = 9999 )
'CSTEDC(I)', iinfo, n, jtype,
1589 IF( iinfo.LT.0 )
THEN
1592 result( 22 ) = ulpinv
1599 CALL cstt21( n, 0, sd, se, d1, dumma, z, ldu, work, rwork,
1606 CALL scopy( n, sd, 1, d1, 1 )
1608 $
CALL scopy( n-1, se, 1, rwork( inde ), 1 )
1609 CALL claset(
'Full', n, n, czero, cone, z, ldu )
1612 CALL cstedc(
'V', n, d1, rwork( inde ), z, ldu, work, lwedc,
1613 $ rwork( indrwk ), lrwedc, iwork, liwedc, iinfo )
1614 IF( iinfo.NE.0 )
THEN
1615 WRITE( nounit, fmt = 9999 )
'CSTEDC(V)', iinfo, n, jtype,
1618 IF( iinfo.LT.0 )
THEN
1621 result( 24 ) = ulpinv
1628 CALL cstt21( n, 0, sd, se, d1, dumma, z, ldu, work, rwork,
1635 CALL scopy( n, sd, 1, d2, 1 )
1637 $
CALL scopy( n-1, se, 1, rwork( inde ), 1 )
1638 CALL claset(
'Full', n, n, czero, cone, z, ldu )
1641 CALL cstedc(
'N', n, d2, rwork( inde ), z, ldu, work, lwedc,
1642 $ rwork( indrwk ), lrwedc, iwork, liwedc, iinfo )
1643 IF( iinfo.NE.0 )
THEN
1644 WRITE( nounit, fmt = 9999 )
'CSTEDC(N)', iinfo, n, jtype,
1647 IF( iinfo.LT.0 )
THEN
1650 result( 26 ) = ulpinv
1661 temp1 = max( temp1, abs( d1( j ) ), abs( d2( j ) ) )
1662 temp2 = max( temp2, abs( d1( j )-d2( j ) ) )
1665 result( 26 ) = temp2 / max( unfl, ulp*max( temp1, temp2 ) )
1669 IF( ilaenv( 10,
'CSTEMR',
'VA', 1, 0, 0, 0 ).EQ.1 .AND.
1670 $ ilaenv( 11,
'CSTEMR',
'VA', 1, 0, 0, 0 ).EQ.1 )
THEN
1681 IF( jtype.EQ.21 .AND. crel )
THEN
1683 abstol = unfl + unfl
1684 CALL cstemr(
'V',
'A', n, sd, se, vl, vu, il, iu,
1685 $ m, wr, z, ldu, n, iwork( 1 ), tryrac,
1686 $ rwork, lrwork, iwork( 2*n+1 ), lwork-2*n,
1688 IF( iinfo.NE.0 )
THEN
1689 WRITE( nounit, fmt = 9999 )
'CSTEMR(V,A,rel)',
1690 $ iinfo, n, jtype, ioldsd
1692 IF( iinfo.LT.0 )
THEN
1695 result( 27 ) = ulpinv
1702 temp2 = two*( two*n-one )*ulp*( one+eight*half**2 ) /
1707 temp1 = max( temp1, abs( d4( j )-wr( n-j+1 ) ) /
1708 $ ( abstol+abs( d4( j ) ) ) )
1711 result( 27 ) = temp1 / temp2
1713 il = 1 + ( n-1 )*int( slarnd( 1, iseed2 ) )
1714 iu = 1 + ( n-1 )*int( slarnd( 1, iseed2 ) )
1723 abstol = unfl + unfl
1724 CALL cstemr(
'V',
'I', n, sd, se, vl, vu, il, iu,
1725 $ m, wr, z, ldu, n, iwork( 1 ), tryrac,
1726 $ rwork, lrwork, iwork( 2*n+1 ),
1727 $ lwork-2*n, iinfo )
1729 IF( iinfo.NE.0 )
THEN
1730 WRITE( nounit, fmt = 9999 )
'CSTEMR(V,I,rel)',
1731 $ iinfo, n, jtype, ioldsd
1733 IF( iinfo.LT.0 )
THEN
1736 result( 28 ) = ulpinv
1744 temp2 = two*( two*n-one )*ulp*
1745 $ ( one+eight*half**2 ) / ( one-half )**4
1749 temp1 = max( temp1, abs( wr( j-il+1 )-d4( n-j+
1750 $ 1 ) ) / ( abstol+abs( wr( j-il+1 ) ) ) )
1753 result( 28 ) = temp1 / temp2
1766 CALL scopy( n, sd, 1, d5, 1 )
1768 $
CALL scopy( n-1, se, 1, rwork, 1 )
1769 CALL claset(
'Full', n, n, czero, cone, z, ldu )
1773 il = 1 + ( n-1 )*int( slarnd( 1, iseed2 ) )
1774 iu = 1 + ( n-1 )*int( slarnd( 1, iseed2 ) )
1780 CALL cstemr(
'V',
'I', n, d5, rwork, vl, vu, il, iu,
1781 $ m, d1, z, ldu, n, iwork( 1 ), tryrac,
1782 $ rwork( n+1 ), lrwork-n, iwork( 2*n+1 ),
1783 $ liwork-2*n, iinfo )
1784 IF( iinfo.NE.0 )
THEN
1785 WRITE( nounit, fmt = 9999 )
'CSTEMR(V,I)', iinfo,
1788 IF( iinfo.LT.0 )
THEN
1791 result( 29 ) = ulpinv
1803 CALL scopy( n, sd, 1, d5, 1 )
1805 $
CALL scopy( n-1, se, 1, rwork, 1 )
1808 CALL cstemr(
'N',
'I', n, d5, rwork, vl, vu, il, iu,
1809 $ m, d2, z, ldu, n, iwork( 1 ), tryrac,
1810 $ rwork( n+1 ), lrwork-n, iwork( 2*n+1 ),
1811 $ liwork-2*n, iinfo )
1812 IF( iinfo.NE.0 )
THEN
1813 WRITE( nounit, fmt = 9999 )
'CSTEMR(N,I)', iinfo,
1816 IF( iinfo.LT.0 )
THEN
1819 result( 31 ) = ulpinv
1829 DO 240 j = 1, iu - il + 1
1830 temp1 = max( temp1, abs( d1( j ) ),
1832 temp2 = max( temp2, abs( d1( j )-d2( j ) ) )
1835 result( 31 ) = temp2 / max( unfl,
1836 $ ulp*max( temp1, temp2 ) )
1843 CALL scopy( n, sd, 1, d5, 1 )
1845 $
CALL scopy( n-1, se, 1, rwork, 1 )
1846 CALL claset(
'Full', n, n, czero, cone, z, ldu )
1852 vl = d2( il ) - max( half*
1853 $ ( d2( il )-d2( il-1 ) ), ulp*anorm,
1856 vl = d2( 1 ) - max( half*( d2( n )-d2( 1 ) ),
1857 $ ulp*anorm, two*rtunfl )
1860 vu = d2( iu ) + max( half*
1861 $ ( d2( iu+1 )-d2( iu ) ), ulp*anorm,
1864 vu = d2( n ) + max( half*( d2( n )-d2( 1 ) ),
1865 $ ulp*anorm, two*rtunfl )
1872 CALL cstemr(
'V',
'V', n, d5, rwork, vl, vu, il, iu,
1873 $ m, d1, z, ldu, m, iwork( 1 ), tryrac,
1874 $ rwork( n+1 ), lrwork-n, iwork( 2*n+1 ),
1875 $ liwork-2*n, iinfo )
1876 IF( iinfo.NE.0 )
THEN
1877 WRITE( nounit, fmt = 9999 )
'CSTEMR(V,V)', iinfo,
1880 IF( iinfo.LT.0 )
THEN
1883 result( 32 ) = ulpinv
1890 CALL cstt22( n, m, 0, sd, se, d1, dumma, z, ldu, work,
1891 $ m, rwork, result( 32 ) )
1897 CALL scopy( n, sd, 1, d5, 1 )
1899 $
CALL scopy( n-1, se, 1, rwork, 1 )
1902 CALL cstemr(
'N',
'V', n, d5, rwork, vl, vu, il, iu,
1903 $ m, d2, z, ldu, n, iwork( 1 ), tryrac,
1904 $ rwork( n+1 ), lrwork-n, iwork( 2*n+1 ),
1905 $ liwork-2*n, iinfo )
1906 IF( iinfo.NE.0 )
THEN
1907 WRITE( nounit, fmt = 9999 )
'CSTEMR(N,V)', iinfo,
1910 IF( iinfo.LT.0 )
THEN
1913 result( 34 ) = ulpinv
1923 DO 250 j = 1, iu - il + 1
1924 temp1 = max( temp1, abs( d1( j ) ),
1926 temp2 = max( temp2, abs( d1( j )-d2( j ) ) )
1929 result( 34 ) = temp2 / max( unfl,
1930 $ ulp*max( temp1, temp2 ) )
1945 CALL scopy( n, sd, 1, d5, 1 )
1947 $
CALL scopy( n-1, se, 1, rwork, 1 )
1951 CALL cstemr(
'V',
'A', n, d5, rwork, vl, vu, il, iu,
1952 $ m, d1, z, ldu, n, iwork( 1 ), tryrac,
1953 $ rwork( n+1 ), lrwork-n, iwork( 2*n+1 ),
1954 $ liwork-2*n, iinfo )
1955 IF( iinfo.NE.0 )
THEN
1956 WRITE( nounit, fmt = 9999 )
'CSTEMR(V,A)', iinfo, n,
1959 IF( iinfo.LT.0 )
THEN
1962 result( 35 ) = ulpinv
1969 CALL cstt22( n, m, 0, sd, se, d1, dumma, z, ldu, work, m,
1970 $ rwork, result( 35 ) )
1976 CALL scopy( n, sd, 1, d5, 1 )
1978 $
CALL scopy( n-1, se, 1, rwork, 1 )
1981 CALL cstemr(
'N',
'A', n, d5, rwork, vl, vu, il, iu,
1982 $ m, d2, z, ldu, n, iwork( 1 ), tryrac,
1983 $ rwork( n+1 ), lrwork-n, iwork( 2*n+1 ),
1984 $ liwork-2*n, iinfo )
1985 IF( iinfo.NE.0 )
THEN
1986 WRITE( nounit, fmt = 9999 )
'CSTEMR(N,A)', iinfo, n,
1989 IF( iinfo.LT.0 )
THEN
1992 result( 37 ) = ulpinv
2003 temp1 = max( temp1, abs( d1( j ) ), abs( d2( j ) ) )
2004 temp2 = max( temp2, abs( d1( j )-d2( j ) ) )
2007 result( 37 ) = temp2 / max( unfl,
2008 $ ulp*max( temp1, temp2 ) )
2012 ntestt = ntestt + ntest
2019 DO 290 jr = 1, ntest
2020 IF( result( jr ).GE.thresh )
THEN
2025 IF( nerrs.EQ.0 )
THEN
2026 WRITE( nounit, fmt = 9998 )
'CST'
2027 WRITE( nounit, fmt = 9997 )
2028 WRITE( nounit, fmt = 9996 )
2029 WRITE( nounit, fmt = 9995 )
'Hermitian'
2030 WRITE( nounit, fmt = 9994 )
2034 WRITE( nounit, fmt = 9987 )
2037 IF( result( jr ).LT.10000.0e0 )
THEN
2038 WRITE( nounit, fmt = 9989 )n, jtype, ioldsd, jr,
2041 WRITE( nounit, fmt = 9988 )n, jtype, ioldsd, jr,
2051 CALL slasum(
'CST', nounit, nerrs, ntestt )
2054 9999
FORMAT(
' CCHKST2STG: ', a,
' returned INFO=', i6,
'.', / 9x,
2055 $
'N=', i6,
', JTYPE=', i6,
', ISEED=(', 3( i5,
',' ), i5,
')' )
2057 9998
FORMAT( / 1x, a3,
' -- Complex Hermitian eigenvalue problem' )
2058 9997
FORMAT(
' Matrix types (see CCHKST2STG for details): ' )
2060 9996
FORMAT( /
' Special Matrices:',
2061 $ /
' 1=Zero matrix. ',
2062 $
' 5=Diagonal: clustered entries.',
2063 $ /
' 2=Identity matrix. ',
2064 $
' 6=Diagonal: large, evenly spaced.',
2065 $ /
' 3=Diagonal: evenly spaced entries. ',
2066 $
' 7=Diagonal: small, evenly spaced.',
2067 $ /
' 4=Diagonal: geometr. spaced entries.' )
2068 9995
FORMAT(
' Dense ', a,
' Matrices:',
2069 $ /
' 8=Evenly spaced eigenvals. ',
2070 $
' 12=Small, evenly spaced eigenvals.',
2071 $ /
' 9=Geometrically spaced eigenvals. ',
2072 $
' 13=Matrix with random O(1) entries.',
2073 $ /
' 10=Clustered eigenvalues. ',
2074 $
' 14=Matrix with large random entries.',
2075 $ /
' 11=Large, evenly spaced eigenvals. ',
2076 $
' 15=Matrix with small random entries.' )
2077 9994
FORMAT(
' 16=Positive definite, evenly spaced eigenvalues',
2078 $ /
' 17=Positive definite, geometrically spaced eigenvlaues',
2079 $ /
' 18=Positive definite, clustered eigenvalues',
2080 $ /
' 19=Positive definite, small evenly spaced eigenvalues',
2081 $ /
' 20=Positive definite, large evenly spaced eigenvalues',
2082 $ /
' 21=Diagonally dominant tridiagonal, geometrically',
2083 $
' spaced eigenvalues' )
2085 9989
FORMAT(
' Matrix order=', i5,
', type=', i2,
', seed=',
2086 $ 4( i4,
',' ),
' result ', i3,
' is', 0p, f8.2 )
2087 9988
FORMAT(
' Matrix order=', i5,
', type=', i2,
', seed=',
2088 $ 4( i4,
',' ),
' result ', i3,
' is', 1p, e10.3 )
2090 9987
FORMAT( /
'Test performed: see CCHKST2STG for details.', / )
subroutine cstein(N, D, E, M, W, IBLOCK, ISPLIT, Z, LDZ, WORK, IWORK, IFAIL, INFO)
CSTEIN
subroutine clatmr(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)
CLATMR
subroutine cupgtr(UPLO, N, AP, TAU, Q, LDQ, WORK, INFO)
CUPGTR
subroutine cpteqr(COMPZ, N, D, E, Z, LDZ, WORK, INFO)
CPTEQR
subroutine chptrd(UPLO, N, AP, D, E, TAU, INFO)
CHPTRD
subroutine cungtr(UPLO, N, A, LDA, TAU, WORK, LWORK, INFO)
CUNGTR
subroutine chpt21(ITYPE, UPLO, N, KBAND, AP, D, E, U, LDU, VP, TAU, WORK, RWORK, RESULT)
CHPT21
subroutine claset(UPLO, M, N, ALPHA, BETA, A, LDA)
CLASET initializes the off-diagonal elements and the diagonal elements of a matrix to given values...
subroutine csteqr(COMPZ, N, D, E, Z, LDZ, WORK, INFO)
CSTEQR
subroutine cstt22(N, M, KBAND, AD, AE, SD, SE, U, LDU, WORK, LDWORK, RWORK, RESULT)
CSTT22
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 chetrd(UPLO, N, A, LDA, D, E, TAU, WORK, LWORK, INFO)
CHETRD
subroutine cchkst2stg(NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, NOUNIT, A, LDA, AP, SD, SE, D1, D2, D3, D4, D5, WA1, WA2, WA3, WR, U, LDU, V, VP, TAU, Z, WORK, LWORK, RWORK, LRWORK, IWORK, LIWORK, RESULT, INFO)
CCHKST2STG
subroutine sstech(N, A, B, EIG, TOL, WORK, INFO)
SSTECH
subroutine chet21(ITYPE, UPLO, N, KBAND, A, LDA, D, E, U, LDU, V, LDV, TAU, WORK, RWORK, RESULT)
CHET21
subroutine xerbla(SRNAME, INFO)
XERBLA
subroutine clatms(M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, KL, KU, PACK, A, LDA, WORK, INFO)
CLATMS
subroutine clacpy(UPLO, M, N, A, LDA, B, LDB)
CLACPY copies all or part of one two-dimensional array to another.
subroutine slabad(SMALL, LARGE)
SLABAD
subroutine chetrd_2stage(VECT, UPLO, N, A, LDA, D, E, TAU, HOUS2, LHOUS2, WORK, LWORK, INFO)
CHETRD_2STAGE
subroutine sstebz(RANGE, ORDER, N, VL, VU, IL, IU, ABSTOL, D, E, M, NSPLIT, W, IBLOCK, ISPLIT, WORK, IWORK, INFO)
SSTEBZ
subroutine cstt21(N, KBAND, AD, AE, SD, SE, U, LDU, WORK, RWORK, RESULT)
CSTT21
subroutine ccopy(N, CX, INCX, CY, INCY)
CCOPY
subroutine ssterf(N, D, E, INFO)
SSTERF
subroutine slasum(TYPE, IOUNIT, IE, NRUN)
SLASUM
subroutine scopy(N, SX, INCX, SY, INCY)
SCOPY
subroutine cstemr(JOBZ, RANGE, N, D, E, VL, VU, IL, IU, M, W, Z, LDZ, NZC, ISUPPZ, TRYRAC, WORK, LWORK, IWORK, LIWORK, INFO)
CSTEMR
subroutine cstedc(COMPZ, N, D, E, Z, LDZ, WORK, LWORK, RWORK, LRWORK, IWORK, LIWORK, INFO)
CSTEDC