Cod sursa(job #72027)

Utilizator adrianraduleaRadulea Adrian adrianradulea Data 12 iulie 2007 15:38:59
Problema Fractii Scor 0
Compilator fpc Status done
Runda Arhiva de probleme Marime 1.26 kb
var f,g:text;
    put,n,nr,i,j,x,d,k,l:longint;
    a:array[1..100] of 0..1;
    totient:array[1..100] of longint;
    ok:boolean;
procedure putere;
begin
put:=1;
for l:=1 to k do put:=put*d;
end;
procedure ciur;
begin
for i:=2 to trunc(sqrt(n)) do begin
  j:=sqr(i);
  while j<=n do begin
     a[j]:=1;
     j:=j+i;
  end;
end;
end;
begin
assign(f,'fractii.in'); reset(f);
assign(g,'fractii.out'); rewrite(g);
read(f,n);
ciur;
nr:=0;
for i:=2 to n do
  if a[i]=0 then begin
    nr:=nr+i-1;
    totient[i]:=i-1;
  end
  else begin
    x:=i;
    d:=2;
    ok:=true;
    totient[i]:=1;
    while (x<>1) and (ok) do begin
      k:=0;
      while x mod d=0 do begin
        x:=x div d;
        inc(k);
      end;
      if k=1 then begin
        totient[i]:=totient[d]*totient[i div d];
        ok:=false;
      end
      else if (k>1) and (x<>1) then begin putere;
                                          totient[i]:=totient[i]*totient[put];
                                    end
                               else begin putere; put:=put div d;
                                          totient[i]:=(d-1)*put;
                                    end;
      d:=d+1;
    end;
    nr:=nr+totient[i];
  end;
write(g,nr*2+1);
close(g);
end.