Cod sursa(job #11022)

Utilizator Adrian001Vladulescu Adrian Adrian001 Data 30 ianuarie 2007 11:12:07
Problema Fractii Scor 0
Compilator fpc Status done
Runda Arhiva de probleme Marime 1.39 kb
Program cel;
Type vector=array[2..10000] of boolean;
     vector1=array[2..10000] of longint;
var f,g:text;
    a:vector;
    phi:vector1;
    n,i,j,p,nr,fm,d,x:longint;
Begin
Assign(f,'fractii.in');Reset(f);
Assign(g,'fractii.out');Rewrite(g);
Read(f,n);
For i:=2 to n do a[i]:=true;
For i:=2 to trunc(sqrt(n)) do
 If a[i]=true then Begin
                    j:=2;
                    While i*j<=n do
                     Begin
                      a[i*j]:=false;
                      inc(j);
                     end;
                   end;
For i:=2 to n do
 If a[i]=true then phi[i]:=i-1;
i:=2;
While i<=trunc(sqrt(n)) do
 Begin
  p:=i;
  While  i*p<=n do
   Begin
    phi[i*p]:=i*phi[p];
    a[i*p]:=true;
    i:=i*p;
 end;
 i:=p+1;
end;
For i:=6 to n do
 If a[i]=false then Begin
                     d:=2;
                     phi[i]:=1;
                     x:=i;
                     repeat
                      fm:=0;
                      While x mod d=0 do
                       Begin
                        x:=x div d;
                        inc(fm);
                       end;
                      If fm<>0 then phi[i]:=phi[i]*phi[round(exp(fm*ln(d)))];
                      inc(d);
                     until x=1;
                    end;
nr:=0;
For i:=2 to n do nr:=nr+phi[i];
nr:=1+2*nr;
Write(g,nr);
Close(f);
Close(g);
end.