Cod sursa(job #198969)

Utilizator RobybrasovRobert Hangu Robybrasov Data 16 iulie 2008 14:18:24
Problema Fractii Scor 100
Compilator fpc Status done
Runda Arhiva de probleme Marime 1.13 kb
var v,d:array[1..1000000] of longint;
    n,i,j,t:longint;
    kont:qword;
    f:text;

procedure phi(nr,poz:longint);
var p:longint;
begin
  p:=1;
  while v[poz] mod nr=0 do begin v[poz]:=v[poz] div nr; p:=p*nr; end;
  if p<>1 then d[poz]:=d[poz]*(p div nr)*(nr-1);
end;

begin
  assign(f,'fractii.in');
  reset(f);
  read(f,n);
  close(f);
  assign(f,'fractii.out');
  rewrite(f);
//  append(f);
  kont:=0;
  if n=1 then write(f,1)
  else
    begin
      for i:=2 to n do begin d[i]:=1; v[i]:=i; end;
      t:=n shr 1;
//      t:=trunc(sqrt(n));
      i:=2;
      while i<=t do
        begin
          if v[i]>1 then
            begin
              d[i]:=i-1;
              j:=i shl 1;
              //j:=sqr(i);
              while j<=n do
                begin
                  phi(i,j);
                  inc(j,i);
                end;
              v[i]:=1;
            end;
          inc(i);
        end;
      for j:=i to n do if v[j]>1 then d[j]:=j-1;
    end;
{  for i:=2 to n do write(f,v[i],' ');
  writeln(f);
  for i:=2 to n do write(f,d[i],' ');
  writeln(f);}
  for i:=2 to n do inc(kont,d[i]);
  writeln(f,kont shl 1+1);
  close(f);
end.