Program Carmichael Investigator
Steven J Miller
November 2011

Goal: investigate composite numbers in a region and report on the percentage of witnesses

carmichaeltester[start_, end_] := Module[{},
list = {};
pairlist = {};
carmichael = {};
firstwitness = {};
minnonzero = 2;
numcarmichael = 0;

For[n = start, n ≤ end, n++, 
{
numwitness = 0;

If[PrimeQ[n] == False,
{
foundwitness = 0;

For[a = 2, a ≤ n-1, a++, 
If[Mod[a^n-a,n] ≠  0, 
{
foundwitness = foundwitness + 1;
numwitness = numwitness+1;
If[foundwitness == 1, firstwitness = AppendTo[firstwitness, 1.0 (a-1) / (n-2)]];
}] (* end of if loop *)
]; (* end of a loop *)

x = numwitness * 1.0 / (n-2);
list = AppendTo[list, x];
pairlist = AppendTo[pairlist, {n,x}];
If[x > 0 && x < minnonzero, minnonzero = x];
If[x == 0, 
{
numcarmichael = numcarmichael + 1;
carmichael = AppendTo[carmichael, n];
}]; (* end of x loop *)
}]; (* end of if n is composite loop *)

}]; (* end of n loop *)

Print["Histogram of percentage of witnesses in range ", start, " to ", end, "."];
Print[Histogram[list, Automatic, "Probability"]];
Print["Range is ", start, " to ", end, "."];
Print["Minimum percentage exceeding zero is ", minnonzero];
Print["Average percentage (including zeros) is ", Mean[list]];
Print["Median percentage (including zeros) is ", Median[list]];
Print["StDev of percentage (including zeros) is ", StandardDeviation[list]];

prunelist = {};
meanlist = Mean[list];
stdevlist = StandardDeviation[list];
For[m = 1, m ≤ Length[list], m++, 
{
x = list[[m]];
If[x - meanlist > -2 stdevlist, prunelist = AppendTo[prunelist,x]];
}];
Print["Histogram of percentage of witnesses in range ", start, " to ", end, " within two standard deviations of the mean."];
Print["Percentage within two standard deviations is ", 100.0 Length[prunelist] / Length[list], "%."];
Print[Histogram[prunelist,Automatic, "Probability"]];

Print["Found ",  numcarmichael, " Carmichael numbers: ", carmichael];
Print["Number of primes in this interval is ",  PrimePi[end] - PrimePi[start - 1]];

Print["Histogram first scaled witnesses in range ", start, " to ", end, "."];
Print[Histogram[firstwitness, Automatic, "Probability"]];
Print["Average first witness (scaled) is ", Mean[firstwitness]];
Print["Median first witness (scaled) is ", Median[firstwitness]];
Print["StDev of first witness (scaled) is ", StandardDeviation[firstwitness]];
];

Timing[carmichaeltester[1000,2000]]

Timing[carmichaeltester[2000,4000]]

Timing[carmichaeltester[11000,12000]]

List of Carmichael numbers and factors

Hyperlink["http://kobep525.rsjp.net/~math/notes/note02.html"]

561=3*11*17
1105=5*13*17
1729=7*13*19
2465=5*17*29
2821=7*13*31
6601=7*23*41
8911=7*19*67
10585=5*29*73
15841=7*31*73
29341=13*37*61
41041=7*11*13*41
46657=13*37*97
52633=7*73*103
62745=3*5*47*89
63973=7*13*19*37
75361=11*13*17*31
101101=7*11*13*101
115921=13*37*241
126217=7*13*19*73
162401=17*41*233
172081=7*13*31*61
188461=7*13*19*109
252601=41*61*101
278545=5*17*29*113
294409=37*73*109
314821=13*61*397
334153=19*43*409
340561=13*17*23*67
399001=31*61*211
410041=41*73*137
449065=5*19*29*163
488881=37*73*181
512461=31*61*271
530881=13*97*421
552721=13*17*41*61
656601=3*11*101*197
658801=11*13*17*271
670033=7*13*37*199
748657=7*13*19*433
825265=5*7*17*19*73
838201=7*13*61*151
852841=11*31*41*61
997633=7*13*19*577
1024651=19*199*271
1033669=7*13*37*307
1050985=5*13*19*23*37
1082809=7*13*73*163
1152271=43*127*211
1193221=31*61*631
1461241=37*73*541
1569457=17*19*43*113
1615681=23*199*353
1773289=7*19*67*199
1857241=31*181*331
1909001=41*101*461
2100901=11*31*61*101
2113921=19*31*37*97
2433601=17*37*53*73
2455921=13*19*61*163
2508013=53*79*599
2531845=5*19*29*919
2628073=7*37*73*139
2704801=11*29*61*139
3057601=43*211*337
3146221=13*31*37*211
3224065=5*13*193*257
3581761=29*113*1093
3664585=5*29*127*199
3828001=101*151*251
4335241=53*157*521
4463641=7*13*181*271
4767841=13*19*97*199
4903921=11*31*73*197
4909177=7*13*73*739
5031181=19*23*29*397
5049001=31*271*601
5148001=41*241*521
5310721=13*37*61*181
5444489=29*197*953
5481451=31*151*1171
5632705=5*13*193*449
5968873=43*127*1093
6049681=11*31*113*157
6054985=5*53*73*313
6189121=61*241*421
6313681=11*17*19*1777
6733693=109*163*379
6840001=7*17*229*251
6868261=43*211*757
7207201=17*353*1201
7519441=41*241*761
7995169=7*13*103*853
8134561=37*109*2017
8341201=11*31*61*401
8355841=13*41*61*257
8719309=19*37*79*157
8719921=7*23*41*1321
8830801=7*19*67*991
8927101=31*37*43*181
9439201=61*271*571
9494101=23*61*67*101
9582145=5*23*97*859
9585541=7*31*163*271
9613297=19*29*73*239
9890881=7*11*13*41*241

highpercentage[c_,p_] := 1 + Log[1-c] / Log[(1. - p)]

highpercentage[1-10^(-10),.5]
highpercentage[1-10^(-100),.5]
highpercentage[1-10^(-1000),.5]

Plot[highpercentage[1-10^(-x),.5],{x,10,10000}]