# Cod sursa(job #13157)

Utilizator Data 5 februarie 2007 22:04:45 Fractii 30 fpc done Arhiva de probleme 1.47 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:longint;
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 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 do
if bo[i]=0 then
begin
p[k]:=i;
inc(k);
end;
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;

begin
assign(fi,'fractii.in'); reset(fi);
assign(fo,'fractii.out'); rewrite(fo);
close(fi);
prim;
rez:=0;
for i:=2 to n do
begin
k:=1;
for j:=2 to i do
if p[j]>0 then if i mod p[j]=0 then
begin
o[k]:=p[j];
inc(k);
end;
dec(k);
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.
``````