Cod sursa(job #576844)

Utilizator andreifirstCioara Andrei Ioan andreifirst Data 9 aprilie 2011 16:01:42
Problema Fractii Scor 50
Compilator fpc Status done
Runda Arhiva de probleme Marime 1.02 kb
var v:array [1..1000000] of longint;
    ciur:array[1..100000] of boolean;
    prim :array [1..1000000] of longint;
    i, j, m, n, c, a, l:longint;
    sum:int64;
    f, g:text;

begin
assign (f, 'fractii.in'); reset (f);
assign (g, 'fractii.out'); rewrite (g);
read (f, n);
c:=1; prim[c]:=2;
m:= n;

i:=3;
while i <= m do
  begin
  if ciur [i] = false then
    begin
    j:=i;
    c:=c+1; prim[c]:=i;
    while j <= m do
      begin
      ciur[j]:=true;
      j:=j+i shl 1;
      end;
    end;
  i:=i+2;
  end;

v[1]:=1;
for i := 2 to n do
  begin
  j:=i;
  l:=1;
  while j mod prim[l] <> 0 do l := l+1;
  if prim[l] = i then v[i]:=i-1
                 else
    begin
    a:=0;
    while j mod prim[l]= 0 do begin j := j div prim[l]; inc(a); end;
    if j <> 1 then v[i] := v[j]*v[i div j]
              else
      begin
      v[i]:=(prim[l]-1)*(i div prim[l]);
      end;
    end;
  end;

for i := 1 to n do sum := sum + v[i];

sum:=sum*2-1;
writeln (g, sum);
close (f); close (g);
end.