Удалить столбцы матрицы если все элементы в нем равны 0 Опции

[lPolar]

Добрый день,уважаемые форумчане.
Не нашел подобных решений, поэтому новую тему открыл:
Задача: удалить столбцы матрицы, где все элементы равны 0.
В процессе решения у меня получилось настроить удаление столбцов, но только если они не стоят рядом друг с другом.
КОД:

 
program deletezerostring;
uses crt;
type
 ta=array[1..30,1..30] of integer;
var a,b:ta;
    i,n,j,m,c,k,q,x:integer;
procedure comfortoutput (j,n,m,i:integer; var a:ta);
 begin
  writeln('Матрица до удаления столбцов');
   for i:=1 to n do
    begin
     for j:=1 to m do
      write(a[i,j],'  ');
     writeln;
    end;
 end;
begin
 clrscr;
 writeln('Введите число строк и столбцов');
 readln(n,m);
 if (m*n) = 0 then writeln('В матрице нет строк или столбцов')
else
begin
 writeln('Введите элементы массива');
  for i:=1 to n do
   for j:=1 to m do
    read(a[i,j]);
 comfortoutput(j,n,m,i,a);
 x:=0;
 q:=m;
 for j:=1 to m do
  begin
   k:=0;
    for i:=1 to n do
       if a[i,j] <> 0 then
       begin
        k:=k+1;
        f:=false;
       end;
   if k = 0 then
    begin
     q:=q-1;
     c:=j;
     f:=true;
    end;
   if f then
    begin
     writeln('Столбец ',c,' нулевой');
      for j:=c to q do
       for i:=1 to n do
        a[i,j]:=a[i,j+1];
    end;
 end;
writeln('Число ненулевых столбцов ',q);
if m=q then writeln('Нулевых столбцов нет')
else
 begin
  writeln('Матрица после удаления столбцов');
   for i:=1 to n do
    begin
     for j:=1 to q do
      write(' ',a[i,j],' ');
     writeln;
    end;
 end;
end;
readkey;
end.
  

Подскажите пожалуйста, где ошибка?