Cod sursa(job #29844)

Utilizator QbyxEros Lorand Qbyx Data 11 martie 2007 13:38:15
Problema Fractii Scor 100
Compilator fpc Status done
Runda Arhiva de probleme Marime 1.1 kb
var
  p: array[1..1000000] of boolean;
  t: array[1..1000000] of int64;
  n, i: longint;
  f: text;
  res: int64;

Procedure Erastostene;
var k, j: longint;
begin
  for k := 2 to n do p[k] := true;
  for  k := 2 to n do
    if p[k] then for j := 2 to (n div k) do p[k * j] := false;
end;

Function Tot(l: longint):longint;
var k1, k2, k3, o, i: longint;
begin
  if not(p[l]) then
    begin
      for i := 2 to n do
        if (p[i]) and (l mod i = 0) then
          begin
            o := i;
            Break;
          end;
      k1 := l;
      k2 := 0;
      k3 := 1;
      repeat
        k1 := k1 div o;
        Inc(k2);
      until (k1 mod o <> 0) {or (k1 div o = 1)};
      for i := 0 to k2 - 2 do
        k3:= k3 * o;
      t[l] := t[k1] * (o - 1) * k3;
    end
  else t[l] := l-1;
  Tot := t[l];
end;

begin
  Assign(f, 'fractii.in');
  Reset(f);
  ReadLn(f,n);
  Close(f);
  Erastostene;
  res := 0;
  t[1] := 1;
  for i := 2 to n do
     res := res + Round(Tot(i));
  res := 1 + 2 * res;
  Assign(f, 'fractii.out');
  ReWrite(f);
  Write(f, res);
  Close(f);
end.