Cod sursa(job #196985)

Utilizator RobybrasovRobert Hangu Robybrasov Data 30 iunie 2008 15:39:36
Problema Fractii Scor 0
Compilator fpc Status done
Runda Arhiva de probleme Marime 1.14 kb
var v:array[1..4000] of longint;
    c:array[1..30000] of boolean;
    n,i:longint;
    kont:int64;
    f:text;

procedure ciur(x:longint);
var i,j,t,k:longint;
begin
  v[1]:=2;
  k:=1;
  i:=3;
  t:=trunc(sqrt(x));
  while i<=t do
    begin
      if c[i]=false then
        begin
          inc(k);
          v[k]:=i;
          j:=sqr(i);
          while j<=x do begin c[j]:=true; inc(j,i); end;
        end;
      inc(i,2);
    end;
  if not odd(i) then inc(i);
  while i<=x do
    begin
      if c[i]=false then begin inc(k); v[k]:=i; end;
      inc(i,2);
    end;
end;

function phi(x:longint):int64;
var p:real; i,k:integer;
begin
  p:=1;
  k:=1;
  while v[k]<=x shr 1 do
    begin
      if x mod v[k]=0 then p:=p*(1-1/v[k]);
      inc(k);
    end;
  if p=1 then phi:=x-1
  else
    begin
      p:=p*x;
      phi:=trunc(p);
    end;
end;

begin
  assign(f,'fractii.in');
  reset(f);
  read(f,n);
  close(f);
  ciur(n);
  assign(f,'fractii.out');
  rewrite(f);
  if n=1 then write(f,1)
  else
    begin
      for i:=2 to n do inc(kont,phi(i));
      write(f,2*kont+1);
    end;
  close(f);
end.