Как ускорить работу цикла?

const n=1000000;
var
  a: array [1..n] of Word; { стоит проверить с Longint, хватит ли Word }
  i, j: Longint;
begin
  for i:=2 to n do begin { на 1 делятся все }
    j:=i; while j<=n do begin Inc(a[j]); Inc(j,i); end;
  end;
  j:=1; for i:=2 to n do if a[i]>a[j] then i:=j;
  Write(a[j]+1,' делителей у');
  for i:=j to n do if a[i]=a[j] then Write(' ',i); WriteLn;
end.

var n,i,j,k,max,maxn:longint;
begin
max:=1;
maxn:=1;
for i:=2 to 100000 do
 begin
  k:=2;{1 и само}
  for j:=2 to trunc(sqrt(i)) do{считаем делители до корня из числа и умножаем на 2}
  if i mod j=0 then inc(k,2);
  if frac(sqrt(i))=0 then dec(k);{если число полный квадрат, то минус 1}
  if k>max then
   begin
    max:=k;
    maxn:=i;
   end;
  end;
write(maxn,' ',max);
readln
end.

var n,i,j,k,max,maxn:longint;
time:real;
begin
max:=1;
maxn:=1;
time:=milliseconds;
for i:=2 to 1000000 do
 begin
  k:=2;{1 и само}
  for j:=2 to trunc(sqrt(i)) do{считаем делители до корня из числа и умножаем на 2}
  if i mod j=0 then inc(k,2);
  if frac(sqrt(i))=0 then dec(k);{если число полный квадрат, то минус 1}
  if k>max then
   begin
    max:=k;
    maxn:=i;
   end;
  end;
  time:=(milliseconds-time)/1000;
writeln (maxn,' ',max);
writeln (time);
readln
end.

for j:=1 to maxn do
  begin
 if maxn mod j  = 0 then
  writeln (j);
  end;