Как можно ускорить программу? Чтобы работало для N до миллиона? Максимум удалось посчитать 23!, потом возникает переполн

function LastDigit(N: integer): integer;
 
var
   p, i, temp: uint64;
begin
   if (N = 0) or (N = 1) then 
      LastDigit := 1
   else begin
       p := 1;
       for i := 2 to N do begin
          temp := i;
          while temp mod 10 = 0 do
             temp := temp div 10;
          p := p * temp;
          while p mod 10 = 0 do
             p := p div 10;
      end;
      LastDigit := p mod 10; 
   end;
end;
 
var
   A: array [1..1000] of uint64; 
   K, i: uint64;         
begin
    ReadLn(K);
    for i := 1 to K do
       ReadLn(A[i]);
    for i := 1 to K do
       WriteLn(LastDigit(A[i]));
end.

var
  n,r,d:Integer;
begin
  Read(n);
  r:=1;
  for n:=2 to n do
    begin
      d:=n;while d mod 10=0 do d:=d div 10;
      r:=r*(d mod 10);while r mod 10=0 do r:=r div 10;r:=r mod 10;
    end;
  Write(r);
end.

var
  n,r,d:Integer;
begin
  Read(n);
  r:=1;
  for n:=2 to n do
    begin
      d:=n;
      while d mod 10=0 do
        d:=d div 10;
      r:=r*(d mod 1000);
      while r mod 10=0 do
        r:=r div 10;
      r:=r mod 1000;
    end;
  Write(r mod 10);
end.

var
  a : array [0..9] of Integer;
  n, i, d, p : Integer;
begin
  a[0] := 1; for i := 1 to 9 do a[i] := 0;
  Read(n);
  for n := 2 to n do
    begin
      d := n; while d mod 10 = 0 do d := d div 10;
      p := 0; for i := 0 to 9 do begin p := p + a[i] * d; a[i] := p mod 10; p := p div 10; end;
      while a[0] = 0 do begin for i := 1 to 9 do a[i-1] := a[i]; a[9] := 0; end;
    end;
  Write(a[0]);
end.

// (c) volvo
var
  n,m : qword;
  i : integer;
begin
  Read(m);// := 10000;
  n := 1;
  for i := 1 to m do
  begin
    n := n * i;
    while n mod 10 = 0 do n := n div 10;
    n := n mod 1000;
    // writeln(i,' ',n)
  end;
  writeln(n mod 10);
end.

  Read(k);
  for k:=1 to k do begin
     <тут код полностью, начиная с Read(m)>
  end;