If you got ac can you test my program:
thanks in advance

program N1007;
const
Max=3002;
VAR
 c:char;
 N,i,j,M,S,L,k,q:integer;
 W:array[1..Max] of array[0..2001] of byte;
 D:array[0..2001] of byte;
begin
  Readln(N);i:=0;j:=1;
  Repeat
      if j<>0 then inc(i);
      j:=0;


      while not eoln(input) do begin
           read(c);
           if c in ['0','1']   then begin
           inc(j);
           W[i][j]:=ord(c)-48;
           end;
      end;
      if j<>0 then W[I][0]:=J;
      readln;
 Until eof(input);

  m:=i;
  //if (m=2001)and(n=500) then m:=m div (i-i);
  for i:=1 to  M do begin
    S:=0;
    L:= W[i][0];
    for j:=1 to L  do if W[i][j]=1 then S:=S+j;
    if (L=N) then begin
      j:=0;
      while (S-j*W[i][j]) mod (N+1) <>0 do inc(j);
      if j<>0 then W[i][j]:=0;

      for q:=1 to L do write(W[i][q]);
      writeln;
    end;


    if (L<N) then begin
           k:=0;
      for j:=L downto 1 do begin
        if W[i][j]=1 then inc(k);
        D[j]:=k;
     end;
       j:=1;
      while (((S+D[j]) mod (N+1) <>0) and ((S+D[j]+j) mod (N+1) <>0))and(j<=L)  do
      inc(j);
      if (S+D[j]) mod (N+1) =0 then k:=0 else k:=1;
      for q:=1 to j-1 do write(W[i][q]);
      write(k);
      for q:=j to L do  write(W[i][q]);
       writeln;
    end;
    if (L>N) then begin
    k:=0;
    for j:=L downto 1 do begin
     D[j]:=k;
      if W[i][j]=1 then inc(k);

    end;
       j:=1;
      while (((S-D[j]-j*W[i][j]) mod (N+1) <>0) )and(j<L)   do
      inc(j);
      for q:=1 to j-1 do write(W[i][q]);

      for q:=j+1 to L do  write(W[i][q]);
       writeln;
    end;
  end;
  Readln;
end.

Edited by author 19.11.2010 00:03

It was very stupid error:

I used:
W:array[1..Max] of array[0..2001] of byte;
for storing code words (array[1..2001] of byte;)

and zero element of same array for lenght of code word.
But max length could be great than byte
I change byte to integer and got AC.

This example shows how not to write programs!
))