Оригинал статьи: http://www.cyberforum.ru/pascal/thread133142.html
Благодарен всем авторам, которые внесли свой вклад в сборку кода.

Удаление всех строк и столбцов, содержащих хоть 1 ноль. Также положительные, отрицательные и т.д.

  
var
  a: array[1..10, 1..9] of integer;
  b: array[1..9] of byte;
  m, n, i, j, f, p, k: byte;

begin
  
  randomize;
  n := 10;
  m := 9;
  writeln('Исходная матрица:');
  for i := 1 to n do
  begin
    for j := 1 to m do
    begin
      a[i, j] := random(10);
      write(a[i, j]:3);
    end;
    writeln;
  end;
  writeln;
  {номера столбцов с нолями}
  f := 0;
  for j := 1 to m do
  begin
    k := 0;
    for i := 1 to n do
      if a[i, j] = 0 then
      begin
        k := 1;
        f := 1;
      end;
    b[j] := k;
  end;
  if f = 0 then write('В матрице нет нолей!')
  else
  begin
    {удаление строк с нолем}
    i := n;{начнем с конца}
    while(i >= 1) and (n > 0) do
    begin
      k := 0;
      j := 1;
      while(j <= m) and (k = 0) do
        if a[i, j] = 0 then k := 1
        else j := j + 1;
      if k = 1 then{если есть ноль}
      begin
        f := f - 1;{вычитаем строку}
        if i = n then {если строка на этот момент последняя}
        begin
          n := n - 1;{обрезаем}
          i := i - 1;{верх}
        end
        else {если не последняя}
        begin
          for k := i to n - 1 do{от этой строки до предпоследней}
            for p := 1 to m do{всем элементам строк}
              a[k, p] := a[k + 1, p];{присваиваем значения нижней}
          n := n - 1;{уменьшаем количество}
        end;
      end
      else i := i - 1;{если нет нолей, вверх}
    end;
    if n = 0 then writeln('Все строки и столбцы удалены!')
    else{если остались строки, удаляем столбцы}
    begin
      f := m;{начнем с конца}
      for i := m downto 1 do{в обратном порядке читаем массив номеров}
        if b[i] = 1 then{если есть ноль}
        begin
          if i = f then{и последний на данный момент, также как строки}
          begin
            m := m - 1;
            f := f - 1;
          end
          else {если не последний, тоже как строки}
          begin
            for k := i to m - 1 do
              for p := 1 to n do
                a[p, k] := a[p, k + 1];
            m := m - 1;
          end;
        end;
      writeln('Матрица после сжатия:');
      for i := 1 to n do
      begin
        for j := 1 to m do
          write(a[i, j]:3);
        writeln;
      end;
    end;
  end;
  
end.