Cod sursa(job #348857)

Utilizator ScriamTertiuc Afanasie Scriam Data 17 septembrie 2009 11:13:18
Problema Fractii Scor 0
Compilator fpc Status done
Runda Arhiva de probleme Marime 0.99 kb
Program P1;
var b : array[1..10000] of boolean;
    a : array[1..10000] of longint;
    n,k : longint;
    rez : int64;




Procedure ciur(n : longint);
var i,j : longint;
begin
fillchar(b,sizeof(b),true);
for i:=2 to n do
if b[i] then
begin
   j:=2;
   while i*j<=n do
   begin
   b[i*j]:=false;
   inc(j);
   end;
end;
end;

Function tot(n : integer) : integer;
var g,i,l,y,f,c : integer;
begin
fillchar(a,sizeof(a),0);
if b[n] then begin tot:=n-1; exit; end;
g:=n;
i:=2;
l:=0;
repeat
if b[i] and (g mod i=0) then
dec(i);
repeat
inc(i);
until (b[i]) and (g mod i=0);
inc(l);
a[l]:=i;

y:=g div i;
g:=y;
until g=1;
c:=a[1];
i:=1;
f:=n;
repeat
c:=a[i];
while (a[i]=c) do
inc(i);
f:=(f*(c-1)) div c;
until i>l;
tot:=f;


end;




begin
assign(f,'fractii.in');   assign(g,'fractii.out');
reset(f);                 rewrite(g);
readln(f,n);
ciur(n+1);
for k:=1 to n do
rez:=rez+tot(k);
rez:=rez*2+1;
writeln(g,rez);
close(f);
close(g);
end.