Pivoting

In practice all we need is a decent pivot.  I can find the big half of a list

n=BlockSize*NumBlock;
A=RandomReal[{-1,1},{n,n}];

FindMax[test_List]:=test[[Ordering[test,1,Abs[#1]>Abs[#2]&][[1]]]]

2^8

Clear[test]
n=(2^8)*124;
test[1]=RandomReal[{-1,1},n];
ChunkSize=2;
Do[
test[i+1]=Map[FindMax,Partition[test[i],ChunkSize]],
{i,1,5}]
Histogram[Table[Abs[test[i]],{i,1,5}],
Automatic,"Probability",
ChartStyle->Table[Hue[i/6],{i,1,5}] ,
ChartStyle->Table[Hue[i/8],{i,1,5}] ]

Clear[test]
n=(2^8)*124;
test[1]=RandomReal[{-1,1},n];
ChunkSize=4;
Do[
test[i+1]=Map[FindMax,Partition[test[i],ChunkSize]],
{i,1,4}]
Histogram[Table[Abs[test[i]],{i,1,4}],
ChartStyle->Table[Hue[i/4],{i,1,4}] ]

Clear[test]
n=(2^10)*124;
test[1]=RandomReal[{-1,1},n];
(*test[1]=Reverse[Sort[test[1],Abs[#1]>Abs[#2]&]];*)
ChunkSize=8;
Do[
test[i+1]=Map[FindMax,Partition[test[i],ChunkSize]],
{i,1,5}]
Histogram[Table[Abs[test[i]],{i,1,4}],
Automatic,"Probability",
ChartStyle->Table[Hue[i/4],{i,1,4}] ]

Histogram[Abs[test[6]]]

Clear[test]
n=(2^10)*124;
test[1]=RandomVariate[NormalDistribution[0,1],n];
(*test[1]=Reverse[Sort[test[1],Abs[#1]>Abs[#2]&]];*)
ChunkSize=4;
Do[
test[i+1]=Map[FindMax,Partition[test[i],ChunkSize]],
{i,1,5}]
Histogram[Table[Abs[test[i]],{i,0,5}],
Automatic,"Probability",
ChartStyle->Table[Hue[i/6],{i,1,6}] 
]

Histogram[Abs[test[5]]]

n=8*124;
test=RandomReal[{-1,1},n];
Histogram[test]
Table[ 
Sample=test[[i;;i+size]];

test[[Ordering[test,1,Abs[#1]>Abs[#2]&]]]

FindMax[test_List]:=test[[Ordering[test,1,Abs[#1]>Abs[#2]&][[1]]]]
FindMax[test]

Reducing Precision

I want to be able to reducethe precision of a number

$MaxPrecision=$MachinePrecision

x=N[π,3];
FullForm[x]
y=SetPrecision[x+ 1/(2^8),3];
FullForm[y]
FullForm[x-y]

$MachinePrecision
$MachineEpsilon

DoubleToSingle[x_]:= Block[{$MaxPrecision=3,$MinPrecision=3},x]
x=N[π]
DoubleToSingle[x]-x

WriteString[3.141592653589793`]

3.141592653589793`

SlowConvert[x_]:=ImportString[ExportString[x,"Real32"],"Real32"][[1]]
FastConvert = Compile[
{{x, _Real}}, 
Z=ImportString[ExportString[{x},"Real32"],"Real32"];
Z[[1]],
{{Z,_Real,1}},
CompilationOptions->{"ExpressionOptimization"->True},
CompilationTarget->"C"]
x=N[π];
Timing[Do[SlowConvert[x],{100}];]
Timing[Do[FastConvert[x],{100}];]
FastConvert[x]-SlowConvert[x]

file = $TemporaryPrefix <>"test1";
FunnyFast[x_]:=Module[
{X},
BinaryWrite[file,x,"Real32"];
Close[file];
X=BinaryRead[file,"Real32"];
Close[file];
X
]

x=N[π];
Timing[Do[
y=FunnyFast[x];,
{(10^4)}]]

Compile

x=N[π]
Timing[
Do[
y=ImportString[ExportString[x,"Real32"],"Real32"][[1]],
{23}]
]
((Abs[x-y])/(Abs[x]))
{x,y}

{3.141592653589793`,3.1415927410125732`}

3.1415927410125732`

DoubleToSingle[x_]:=N[Sign[x]FromDigits[RealDigits[x,2,52],2]]

x=N[π];
BitSet[3.14159`,0]

SampleSize=(10^6);
Data=Table[
x=N[RandomReal[{-100,100}]];
y=DoubleToSingle[x];
(1/$MachineEpsilon)((x-y)/(Abs[x])),
{SampleSize}];
Histogram[Data,{-12.5,12.5,1}]

Double

$MaxPrecision=

Break

BadQuadratic[{a_,b_,c_}]:= Sort[ {((-b + (Sqrt[(b^2)- 4 a c]))/(2a)),((-b -(Sqrt[(b^2)- 4 a c]))/(2a))}];

As you can see below this does not always give as good an answer as you might hope.

ListLogPlot[
Sort[
Table[
{a,b,c}=RandomReal[{-1,1},{3}];
{x1,x2}=BadQuadratic[{a,b,c}];
Norm[{a (x1^2)+ b x1 + c,a (x2^2)+ b x2 + c}],
{2300}]
],
PlotRange->All,
GridLines->Automatic,
Frame->True
]

A little though shows that the bad stuff probably happens when a×c is small.

a=(10.0^(-4));
ListLogPlot[
Sort[
Table[
{b,c}=RandomReal[{-1,1},{2}];
{x1,x2}=BadQuadratic[{a,b,c}];
Norm[{a (x1^2)+ b x1 + c,a (x2^2)+ b x2 + c}],
{2300}]
],
PlotRange->All,
PlotLabel->StringForm["a=``",a],
GridLines->Automatic,
Frame->True
]

a=(10.0^(-8));
ListLogPlot[
Sort[
Table[
{b,c}=RandomReal[{-1,1},{2}];
{x1,x2}=BadQuadratic[{a,b,c}];
Norm[{a (x1^2)+ b x1 + c,a (x2^2)+ b x2 + c}],
{2300}]
],
PlotRange->All,
PlotLabel->StringForm["a=``",a],
GridLines->Automatic,
Frame->True
]

a=(10.0^(-12));
ListLogPlot[
Sort[
Table[
{b,c}=RandomReal[{-1,1},{2}];
{x1,x2}=BadQuadratic[{a,b,c}];
Norm[{a (x1^2)+ b x1 + c,a (x2^2)+ b x2 + c}],
{2300}]
],
PlotRange->All,
PlotLabel->StringForm["a=``",a],
GridLines->Automatic,
Frame->True
]

a=(10.0^(-16));
ListLogPlot[
Sort[
Table[
{b,c}=RandomReal[{-1,1},{2}];
{x1,x2}=BadQuadratic[{a,b,c}];
Norm[{a (x1^2)+ b x1 + c,a (x2^2)+ b x2 + c}],
{2300}]
],
PlotRange->All,
PlotLabel->StringForm["a=``",a],
GridLines->Automatic,
Frame->True
]

Big=(10^8);
aUp=0.0;
Do[
aUp = aUp + 1.0/i,
{i,1,Big,1}]

aDown=0.0;
Do[
aDown = aDown + 1.0/i,
{i,Big,1,-1}]
{aUup,aDown}
aDown-aUp

a