Cod sursa(job #55360)

Utilizator maria_pparcalabescu maria daniela maria_p Data 27 aprilie 2007 09:56:24
Problema Fractii Scor 0
Compilator fpc Status done
Runda Arhiva de probleme Marime 1.43 kb
var f,g:text;
    v,b:array[0..1000000]of longint;
    i,j,n,s,t,exp,m:longint;


begin
assign(f,'fractii.in');reset(f);
assign(g,'fractii.out');rewrite(g);
readln(f,n);
i:=1;
while ((i*i)shl 1)+(i shl 1)<=n do
      begin
      if (v[i shr 3] shr (i and 7))and 1=0 then begin
                                                j:=((i*i)shl 1)+(i shl 1);
                                                while 2*j+1<=n do
                                                      begin
                                                      v[j shr 3]:=v[j shr 3]or(1 shl(j and 7));
                                                      j:=j+(i shl 1)+1;
                                                      end;
                                                end;
      inc(i);
      end;
b[0]:=1;b[1]:=2;
for i:=1 to n do
    if (v[i shr 3] shr (i and 7))and 1=0 then
                if 2*i+1<=n then begin
                                 inc(b[0]);
                                 b[b[0]]:=2*i+1;
                                 end;
s:=1;
for i:=2 to n do
    begin
    t:=1;m:=i;
    for j:=1 to b[0] do
        begin
        exp:=0;q:=1;
        while m mod b[j]=0 do
              begin
              inc(exp);
              m:=m div b[j];
              q:=q*b[j];
              end;
        if exp>0 then t:=t*(b[j]-1)*(q div b[j]);
        end;
    s:=s+2*t;
    end;
writeln(g,s);
close(f);
close(g);
end.