There is my program

Program t1007;

Type BigM=array[1..1500]of byte;

Var  Mas1,Mas2   :BigM;
     ch          :char;
     N,i,j,C,m,l :integer;

Function Sum(X:BigM):boolean;
Var S,i :longint;
 begin
  S:=0;
  for i:=1 to n do
   if X[i]=1 then
    S:=S+i;
  Sum:= (S mod (N+1)) = 0;
 end;

begin
Readln(N);
C:=0;
repeat
 c:=c+1;
 ch:=' ';
 m:=0;
 while (ch<>#13)and(ch<>#10)and(ch<>#26) do begin
  read(ch);
  if (ch<>#13)and(ch<>#10)and(ch<>#26)and(ch<>#32) then begin
   m:=m+1;
   if ch='0' then Mas1[m]:=0;
   if ch='1' then Mas1[m]:=1;
  end;
 end;
 if m=0 then c:=c-1 else begin
  if m=n then begin
   Mas2:=Mas1;
   if not(Sum(Mas2)) then
   i:=0;
   repeat
    i:=i+1;
    if i>1 then Mas2[i-1]:=Mas1[i-1];
    Mas2[i]:=0;
   until Sum(Mas2);
   for i:=1 to n do write(Mas2[i]);writeln;
  end;
  {/--------/}
  if m-1=n then begin
   for i:=2 to n do begin
    l:=0;
    for j:=1 to n+1 do if i<>j then begin
     l:=l+1;
     Mas2[l]:=Mas1[j];
    end;
    if Sum(Mas2) then break;
   end;
   for i:=1 to n do write(Mas2[i]);writeln;
  end;
  if m+1=n then begin
   l:=0;
   repeat
    l:=l+1;
    for i:=1 to l-1 do Mas2[i]:=Mas1[i];
    Mas2[l]:=1;
    for i:=l to m do Mas2[i+1]:=Mas1[i];
    if Sum(Mas2) then break;
    Mas2[l]:=0;
    if Sum(Mas2) then break;
   until False;
   for i:=1 to n do write(Mas2[i]);writeln;
  end;
 end;
until seekEOF;
end.