Cod sursa(job #197554)

Utilizator RobybrasovRobert Hangu Robybrasov Data 4 iulie 2008 23:59:48
Problema Fractii Scor 40
Compilator fpc Status done
Runda Arhiva de probleme Marime 1.39 kb
var v:array[1..80000] of longint;
    c:array[1..1000000] 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,poz:longint):longint;
var k:longint; p:int64;
begin
  p:=x; k:=poz;
  while (v[k]>0) and (v[k]<=x shr 1) do
    begin
      if x mod v[k]=0 then dec(p,p div v[k]);
      inc(k);
    end;
  if p=x then phi:=x-1
  else phi:=p;
end;
}

function phi(x:longint):longint;
var k,rez,p:longint;
begin
  k:=1;
  rez:=1;
  while x>1 do
    begin
      p:=1;
      while x mod v[k]=0 do begin x:=x div v[k]; p:=p*v[k]; end;
      if p<>1 then rez:=rez*(p div v[k])*(v[k]-1);
      inc(k);
    end;
  phi:=rez;
end;

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