Cod sursa(job #365065)

Utilizator SpiderManSimoiu Robert SpiderMan Data 17 noiembrie 2009 19:53:35
Problema Fractii Scor 0
Compilator fpc Status done
Runda Arhiva de probleme Marime 0.87 kb
program eratostene;
 var a:array[1..1000000]of longint;
     b:array[1..1000000]of longint;

     n,i,j,s,c,z:longint;
     f:text;
 begin
  assign(f,'fractii.in');
  reset(f);
  readln(f,n);
  close(f);
  a[1]:=n;
  for i:=1 to n do
   b[i]:=0;
  for i:=1 to n div 2 do
   for j:=2 to n div i do
    b[i*j]:=1;
  for i:=2 to n do
   a[i]:=n-1;
  i:=2;
  while i<=n div 2 do
   begin
    if a[i]=n-1 then
      for j:=1 to n do
      begin
       z:=2;
       c:=0;
       while z<=a[i*j] div 2 do
       begin;
        if (b[i]=0) and (a[i*j] mod z=0) then
          c:=c+1;
       inc(z);
       end;
       if c>=2 then
       a[i*j]:=a[i*j]-n div i
       else
       a[i*j]:=a[i*j]-n div i+1;
       end;
    inc(i);
   end;
  s:=0;
  for i:=1 to n do
   s:=s+a[i];
  assign(f,'fractii.out');
  rewrite(f);
  writeln(f,s);
  close(f);
 end.