Try this test:
5
0110
The correct answer is
01010
The answer of your program is
010100

GL

var a:array[1..1005]of char;
    b,c:array[0..1000]of longint;
    h,n,i,j:integer;
    x:longint;
    ch:char;
    bol:boolean;
function m(i:integer):integer;
begin
  if a[i]='0' then m:=0
  else m:=i;
end;

begin
{  assign(input,'1007.dat');
  reset(input);}
  readln(N);
  while not SeekEOF(input) do
  begin
    h:=0;bol:=false;
    while true do
    begin
      if Not SeekEOLN(input) then read(ch) else ch:=#0;
      if (ch = '1')or(ch = '0') then
      begin
        inc(h);
        a[h]:=ch;
      end
      else
      begin
        readln;
        break;
      end;
    end;
    if N = H then
    begin
      x:=0;
      for i:=1 to h do if a[i]='1' then inc(x,i);
      if x mod (N+1)=0 then
      begin
        for i:=1 to h do write(a[i]);
        writeln;
      end
      else
      begin
           for i:=1 to h do if (a[i]='1')and((x-i) mod (N+1)=0) then
           begin
              for j:=1 to h do if j=i then write(0) else write(a[j]);
              writeln;
           end;
      end;
    end
    else if N=h+1 then
    begin
      for i:=0 to h do b[i]:=0;
      for i:=0 to h do c[i]:=0;
      for i:=1 to h do if a[i]='1' then
      begin
        b[i]:=b[i-1]+i;
        c[i]:=c[i-1]+1;
      end
      else
      begin
        b[i]:=b[i-1];
        c[i]:=c[i-1];
      end;
      for i:=0 to h do if (b[h]+c[h]-c[i])mod (n+1)=0 then
      begin
        for j:=1 to h do if j=i+1 then write('0',a[j]) else write(a
[j]);
        if i=h then write(0);
        writeln;
        bol:=true;
        break;
      end;
      if not bol then
      begin
          for i:=0 to h do if (b[h]+c[h]-c[i]+i+1)mod (n+1)=0 then
          begin
            for j:=1 to h do if j=i+1 then write('1',a[j]) else write
(a[j]);
            writeln;
            break;
          end;
      end;
    end
    else
    begin
      for i:=0 to h do b[i]:=0;
      for i:=0 to h do c[i]:=0;
      for i:=1 to h do if a[i]='1' then
      begin
        b[i]:=b[i-1]+i;
        c[i]:=c[i-1]+1;
      end
      else
      begin
        b[i]:=b[i-1];
        c[i]:=c[i-1];
      end;
      for i:=1 to h do if (b[h]-(c[h]-c[i])-m(i)) mod (n+1)=0 then
      begin
        for j:=1 to h do if j<>i then write(a[j]);
        writeln;
        break;
      end;
    end;
  end;
end.