Cod sursa(job #810428)

Utilizator t.g.g.tt.g.g.t t.g.g.t Data 10 noiembrie 2012 12:31:48
Problema Sum Scor 0
Compilator fpc Status done
Runda Arhiva de probleme Marime 0.98 kb
const max=100000;
var b:array[1..100000]of longint; a:array[1..100000]of byte; sf,t:int64;  i,j,n,nr,pr,t1:longint; buf1,buf2:array[1..1 shl 16]of char;
begin
for i:=2 to 500 do begin if a[i]=0 then begin j:=i*i; while j<=max do begin a[j]:=1; j:=j+i; end end; end;
for i:=2 to max do
  begin
    t:=i; j:=2;b[i]:=1;
    while (t>1) and (j<=(t div 2)) do
      begin
        if a[j]=0 then
          begin
            nr:=0; pr:=1;
            if (t mod j=0) then
            while (t mod j=0) do
            begin
            inc(nr);
            t:=t div j;
            pr:=pr*j
            end;
            if nr>0 then begin b[i]:=b[i]*(j-1)*(pr div j) end;
          end;
        inc(j);
      end;
    if t>1 then begin b[i]:=b[i]*(t-1); end;
  end;
assign(input,'sum.in'); reset(input); settextbuf(input,buf1);
assign(output,'sum.out'); rewrite(output); settextbuf(output,buf2);
readln(n);
for i:=1 to n do
  begin
    readln(t);
    sf:=b[t]*2*t;
    writeln(sf);
  end;
close(output);
end.