Cod sursa(job #252147)

Utilizator ioalexno1Alexandru Bunget ioalexno1 Data 3 februarie 2009 22:21:37
Problema Sum Scor 0
Compilator fpc Status done
Runda Arhiva de probleme Marime 1.13 kb
program alex;
var f,g:text;
    c:array[1..200005]of integer;
    p:array[1..100000]of longint;
    k,i,j,x,y,n,j:longint;
    s:int64;
begin
k:=1;
p[1]:=2;
i:=3;
repeat
if c[i]=0 then begin
               k:=k+1;
               p[k]:=i;
               j:=i;
               while j<=100000 do
                     begin
                     c[j]:=1;
                     j:=j+i;
                     end;
               end;
i:=i+2;
until(i>=100000);
assign(f,'sum.in');reset(f);
assign(g,'sum.out');rewrite(g);
readln(f,n);
for i:=1 to n do
    begin
    readln(f,x);
    j:=1;
    s:=x;
    y:=x;
    while(p[j]*p[j]<=x)and(x<>1)do
         begin
         if x mod p[j]=0 then begin
                              s:=s div p[j];
                              s:=s*(p[j]-1);
                              while x mod p[j]=0 do
                                    x:=x div p[j];
                              end;
         j:=j+1;
         end;
    if x>1 then begin
                s:=s div x;
                s:=s*(x-1);
                end;
    s:=s*y*2;
    writeln(g,s);
    end;
close(f);
close(g);
end.