Cod sursa(job #51283)

Utilizator ProtomanAndrei Purice Protoman Data 10 aprilie 2007 19:23:53
Problema Fractii Scor 30
Compilator fpc Status done
Runda Arhiva de probleme Marime 1.8 kb
type sir=array[1..1000000] of integer;

var n,nr,i,g,k,h,t:longint; f1,f2:text; v:sir; x:array[0..1000000] of longint;

procedure ciur(b:longint);
var i,j:longint;
begin
        i:=1;
        while ((i*i) shl 1)+(i shl 1)<=b do
        begin
                if v[i shr 3] and (1 shl (i and 7))=0 then
                begin
                        j:=((i*i)shl 1)+(i shl 1);
                        while 2*j+1<=b 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;
        i:=0;
        x[1]:=2;
        x[0]:=1;
        while 2*i+1<=n do
        begin
                inc(i);
                if v[i shr 3] and (1 shl (i and 7))=0 then
                begin
                        inc(x[0]);
                        x[x[0]]:=2*i+1;
                end;
        end;
end;

begin
        assign(f1,'fractii.in');
        reset(f1);
        assign(f2,'fractii.out');
        rewrite(f2);
        read(f1,n);
        nr:=1;
        Ciur(n);
        for g:=2 to n do
        begin
                k:=g;
                t:=1;
                h:=0;
                for i:=1 to x[0] do
                if k mod x[i]=0 then
                begin
                        t:=t*(x[i]-1);
                        k:=k div x[i];
                        while k mod x[i]=0 do
                        begin
                                t:=t*x[i];
                                k:=k div x[i];
                        end;
                        if k=1 then break;
                end;
                nr:=nr+2*t;
        end;
        writeln(f2,nr);
        close(f1);
        close(f2);
end.