Cod sursa(job #117883)

Utilizator bogdan88Bogdan Popescu bogdan88 Data 22 decembrie 2007 17:16:25
Problema Sum Scor 35
Compilator fpc Status done
Runda Arhiva de probleme Marime 3.5 kb
var fi,fo:text;
    rez,l,nr_div,n:int64;
    ct,i1,j1,k,kl:longint;
    prime:array[1..110000]of byte;
    m:array[1..100010]of int64;
    ap:array[1..100000]of int64;
    primee:array[1..110000]of int64;
procedure gen(ba:int64);
var i,j:int64;
begin
  i:=3;
  primee[1]:=2;
  l:=1;
  prime[1]:=1;
  while i<=trunc(sqrt(ba)) do
    begin
      if prime[i]=0 then
        begin
          j:=i*i;
          inc(l);
          primee[l]:=i;
          while j<=trunc(sqrt(ba)) do
             begin
                prime[j]:=1; inc(j,i);
             end;
        end;
      inc(i,2);
    end;
end;
procedure prim(nr:int64);
var i,c:int64;
begin
  nr_div:=0; i:=1; c:=nr; ct:=1;
  if (nr=2)or((prime[nr]=0)and(nr and 1=1)) then
     begin
       inc(nr_div);
       rez:=rez+m[c];
       exit;
     end;
  while i<=l do
   if (nr mod primee[i]=0) then
     begin
       inc(nr_div);
       nr:=nr div primee[i];
       if nr=1 then
         begin
           if nr_div and 1=1 then rez:=rez+m[c]
             else rez:=rez-m[c];
           exit;
         end;
       if nr mod primee[i]= 0 then exit;
       if prime[nr]=0 then
         begin
           inc(nr_div);
           if nr_div and 1=1 then rez:=rez+m[c]
             else rez:=rez-m[c];
           exit;
         end;
       inc(i);
     end
   else inc(i);
  { if nr and 1=0 then
     begin
       inc(nr_div);
       nr:=nr shr 1;
       if nr and 1=0 then exit;
     end;
   while i<=trunc(sqrt(nr)) do
     begin
       if nr mod i=0 then
          begin
            inc(nr_div);
            nr:=nr div i;
            if nr mod i=0 then exit;
          end;
       inc(i,2);
     end;
  if nr>1 then inc(nr_div);      }
  if nr_div and 1 = 1 then rez:=rez + m[c]
                      else rez:=rez - m[c];
end;
{procedure scrie(k:qword);
var i,nr:longint;
    d:qword;
    st:string[15];
    c:array[1..15]of byte;
begin
  nr:=0;
  while k>0 do
    begin
      inc(nr);
      d:=k div 10;
      c[nr]:=k-10*d+48;
      k:=d;
    end;
  for i:=nr downto 1 do
    st[nr-i+1]:=chr(c[i]);
  st[0]:=chr(nr);
  writeln(fo,st);
end; }
var nr,x:int64;
begin
  assign(fi,'sum.in'); reset(fi);
  assign(fo,'sum.out'); rewrite(fo);
  readln(fi,kl);
  gen(100000);
  for k:=1 to kl do
    begin
      rez:=0;
      readln(fi,n);
      if ap[n]<>0 then writeln(fo,ap[n])
        else
          begin
            for i1:=2 to trunc(sqrt(n))-1 do
              begin
                if n mod i1=0 then
                  begin
                    nr:=2*n div i1;
                    m[i1]:=i1*(nr*(nr+1) shr 1);
                    prim(i1);
                    {if i1<>(n div i1) then
                      begin}
                        nr:=2*n div (n div i1);
                        m[n div i1]:=(n div i1)*(nr*(nr+1) shr 1);
                        prim(n div i1);
                    {  end;}
                  end;
              end;
            x:=trunc(sqrt(n));
            if (n mod x=0)and(x<>1) then begin
            nr:=2*n div x;
            m[x]:=x*(nr*(nr+1)shr 1);
            prim(x);
            if x<>sqrt(n) then
              begin
                x:=n div trunc(sqrt(n));
                nr:=2*n div x;
                m[x]:=x*(nr*(nr+1)shr 1);
                prim(x); end; end;
            m[n]:=n*3;
            prim(n);
            rez:=(n*(2*n+1))-rez;
            ap[n]:=rez;
            writeln(fo,rez);
          end;
    end;
  close(fi); close(fo);
end.