# Cod sursa(job #13211)

Utilizator Data 5 februarie 2007 23:03:57 Fractii 0 fpc done Arhiva de probleme 1.83 kb
``````{\$IFDEF NORMAL}
{\$I-,Q-,R-,S-}
{\$ENDIF NORMAL}
{\$IFDEF DEBUG}
{\$I+,Q+,R+,S-}
{\$ENDIF DEBUG}
{\$IFDEF RELEASE}
{\$I-,Q-,R-,S-}
{\$ENDIF RELEASE}

var fi,fo:text;
n:longint;
rez:int64;
i,j,k,ll:longint;
ok:boolean;
lim:integer;
bo:array[1..1000000] of integer;
p:array[1..1000000] of longint;
v,o:array[1..30] of longint;

procedure prim;
var i,j,k:longint;
begin
bo[1]:=0;
bo[2]:=0;
for i:=2 to n div 2 +2 do
begin
k:=i+i;
while k<=n do
begin
bo[k]:=1;
k:=k+i;
end;
end;
k:=1;
for i:=1 to n div 2 +2 do
if bo[i]=0 then
begin
p[k]:=i;
inc(k);
end;
if bo[n]=0 then begin p[k]:=n; inc(k); end;
lim:=k-1;
end;

function Euler(n:longint):longint;
var i:longint;
sum:real;
begin
sum:=n;
{    for i:=1 to k do
write(fo,o[i],' ');}
{  writeln(fo);}
for i:=1 to k do
sum:=sum*(1-1/(o[i]));
Euler:=trunc(sum);

{ writeln(fo,sum); }
end;

function min(i,j:longint):longint;
begin
if i>j then min:=j
else min:=i;
end;

begin
assign(fi,'fractii.in'); reset(fi);
assign(fo,'fractii.out'); rewrite(fo);
close(fi);
prim;
rez:=0;
ll:=2;
for i:=2 to n do
begin
k:=1;
ok:=false;
if p[ll]=i then begin inc(rez,p[ll]-1); inc(ll); end
else
for j:=2 to min(lim,i) do
if p[j]>0 then if i mod p[j]=0 then
begin
o[k]:=p[j];
inc(k);
ok:=true;
end;
dec(k);
if ok=true then rez:=rez+Euler(i);
end;

{ for i:=1 to 100 do
writeln(fo,p[i]);}
rez:=(rez)*2+1;
write(fo,rez);
close(fo);
end.
``````