Cod sursa(job #52244)

Utilizator h_istvanHevele Istvan h_istvan Data 18 aprilie 2007 10:30:23
Problema Fractii Scor 100
Compilator fpc Status done
Runda Arhiva de probleme Marime 1.83 kb
program fractii;
var f:text;
    n,i,j,p,exp,m,np:longint;
    t:array[1..1000000] of longint;
    prim:array[1..1000000] of byte;
    primek:array[1..1000000] of longint;
    e:extended;

procedure bont(x:longint);
var i:longint;
begin
     p:=0;
     i:=1;
     while ((x>1) and (primek[i]<=trunc(sqrt(n)))) do
     begin
          if(x mod primek[i] = 0) then
          begin
               p:=primek[i];
               exp:=1;
               x:=x div primek[i];
               while(x mod primek[i] = 0) do
               begin
                    x:=x div primek[i];
                    exp:=exp+1;
               end;
               m:=x;

               break;
          end;
          i:=i+1;
     end;
     if(p=0) then
     begin
          p:=x;
          m:=1;
          exp:=1;
     end;
end;

function pwr(a,e:longint):longint;
var i,er:longint;
begin
     er:=1;
     for i:=1 to e do
         er:=er*a;
     pwr:=er;
end;

begin
     assign(f,'fractii.in');
     reset(f);
     readln(f,n);
     close(f);

     for i:=2 to n do
     begin
          if(prim[i] = 0) then
          begin
               j:=2*i;
               while(j<=n) do
               begin
                    prim[j]:=1;
                    j:=j+i;
               end;
          end;
     end;
     for i:=2 to n do
         if(prim[i] = 0) then
         begin
              np:=np+1;
              primek[np]:=i;
         end;

     e:=1;
     t[1]:=1;
     for i:=2 to n do
     begin
          if(prim[i] = 0) then
          begin
               p:=i;
               exp:=1;
               m:=1;
          end else bont(i);
          t[i]:=(p-1)*pwr(p,exp-1)*t[m];
          e:=e+2*t[i];
     end;

     assign(f,'fractii.out');
     rewrite(f);
     writeln(f,e:0:0);
     close(f);
end.