Cod sursa(job #601742)

Utilizator ctlin04UAIC.VlasCatalin ctlin04 Data 7 iulie 2011 17:50:19
Problema Sum Scor 40
Compilator fpc Status done
Runda Arhiva de probleme Marime 1.61 kb
program sum;
 var x,y,n,j,i:longint;
   s:int64;
   fi,fo:text;
 function cmmdc(x,y:longint):boolean;
 var i,j:longint;
 begin
 cmmdc:=true;
  if x>=y then if x mod y=0 then cmmdc:=false
            else
               for i:=2 to y div 2 do
                if (y mod i=0) and (x mod i=0) then begin
                                                    cmmdc:=false;
                                                    break;
                                                    end
               else if i=y div 2 then
                                   cmmdc:=true;
  if y>x then if y mod x=0 then cmmdc:=false
           else
             for i:=2 to x div 2 do
                if (y mod i=0) and (x mod i=0) then begin
                                                    cmmdc:=false;
                                                    break;
                                                    end
               else if i=x div 2 then
                                   cmmdc:=true;
   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;
begin
 assign(fi,'sum.in');
  reset(fi);
 assign(fo,'sum.out');
  rewrite(fo);
 readln(fi,n);
  for i:=1 to n do begin
   readln(fi,x);
   s:=x+1;
    for j:=2 to x-1 do
     if cmmdc(j,x) then s:=s+x+2*j;
   scrie(s+1);
   end;
  close(fo);
end.