More rigorous root finding algorithm

(* korrekt mera rigorös algoritm men den hittar inte alla noll \
ställen *)
Do[
 (*start*)
 (*Mathematica 8*)
 Clear[x, polynomial, X, y, polynomialdegree];
(*a är polynomets koefficienter*)
 a = {3628800, -10628640, 12753576, -8409500, 3416930, -902055,
   157773, -18150, 1320, -55, 1};
 polynomialdegree = Length[a] - kk;
 polynomials =
  Table[Sum[a[[n]]*x^(n - 1), {n, 1, Length[a]}] - a[[k]]*x^(k - 1) +
    a[[k]]*y^(k - 1), {k, 2, Length[a]}];
 polynomial = polynomials[[polynomialdegree]];
 Print["The polynomial is: ", polynomial]
  nn = 8000;
 Do[Clear[x, X, y];
  X = y /. Solve[polynomial == 0, y, WorkingPrecision -> 100][[i]];
  x = 0;
  Table[x = N[Round[X, 10^-30], 30], {n, 1, nn}];
  y = x;
  Print["x", i, " = ", x, " polynomial value at x", i, " is: ",
   polynomial];, {i, 1, polynomialdegree}]
 (*end*), {kk, 1, Length[a] - 1}]