Сортировка

[DTroy]

Задана сортировка ectecтвeнным слиянием. По возрастанию и убыванию. По возрастанию она написана а во убыванию не получается.
Кто может помочь
Вот собственно код

uses crt;
var
   a,b,c:array[1..100000] of integer; //начальный массив
   i,x,y,k,l,n,m,j,p,o,z:integer;
   f1, f2: text;
   procedure error(d, e, f: Integer);
begin
  if (d > (e - 1)) or (d < (f + 1)) then
  begin
    repeat
      begin
        write('Параметр задан неправильно! Введите пожалуйста снова: ');
        read(d);
      end
    until (d < e) and (d > f);
  end;
end;

begin
  o:=0;
  Assign(f1, 'Исходный файл.txt');
  Assign(f2, 'Конечный файл.txt');
  rewrite(f1);
  close(f1);
  rewrite(f2);
  close(f2);
  begin
    append(f1);
    writeln(f1, 'Исходные данные: ');
    close(f1);
  end;
  begin
    append(f2);
    writeln(f2, 'Конечные данные: ');
    close(f2);
  end;
  writeln('Здравствуйте!');
  writeln('Сортировка - Естественное слияние');
  write('Введите количество чисел, n= ');
  read(n);
  error(n, 50001, 0);
   while o=0 do begin
    writeln('Как создать файл с числами?');
    writeln('Рандомом - 1');
    writeln('Ручками - 2');
    readln(l);
    if l=1 then o:=1;
    if l=2 then o:=2;
    if (l<>2) and (l<>1) then writeln('ошибка, недопустимый вариант ответа')
   end;
    if o=2 then begin
      writeln('Вы выбрали ввод чисел вручную.');
      writeln('Введите числа(через Enter)');
      for i:=1 to n do begin
      readln(a[i]);
       end;
   end;
    if o=1 then
    begin
      randomize;
      append(f1);
      writeln(f1);
      for i:=1 to n do begin
      a[i] := random(0, 100);
      write(f1,a[i],' ');
      end;
    close(f1);
    reset(f1);
    end;
    //Разбиение массива
    m:=2;
    x:=1;
    y:=0;
    z:=2;
    b[1]:=a[1];
    for i:=2 to n do begin
      if a[i]<a[i-1] then m:=m+1;
      if (m mod 2)=0 then begin
        x:=x+1;
        b[x]:=a[i];
       end;
    if (m mod 2)<>0 then begin
         y:=y+1;
         c[y]:=a[i];
        end;
    end;
    if o=2 then begin
       writeln;
        for i:=1 to n do begin
        write(a[i],' ');
        end;
       writeln;
       writeln('Шаг 1');
    for i:=1 to x do begin
     write(b[i],' ');
    end;
     write('    ');
     for i:=1 to y do begin
     write(c[i],' ');
    end;
    writeln;
    end;
    p:=m-1;
    i:=1;
    k:=1;
    l:=1;
    while i<=n do begin
     if (k<=x) and (l<=y) then begin
      if b[k]>=c[l] then begin
       a[i]:=c[l];
       l:=l+1;
       i:=i+1;
      end else begin
        a[i]:=b[k];
        k:=k+1;
        i:=i+1;
       end;
    end;
    if k>x then begin
       for m:=i to n do begin
       a[m]:=c[l];
       l:=l+1;
      end;
      i:=n+1;
    end;
    if l>y then begin
       for m:=i to n do begin
       a[m]:=b[k];
       k:=k+1;
      end;
     i:=n+1;
    end;
    end;
    for i:=1 to n do begin
    if o=2 then
    write(a[i],' ');
    c[i]:=0;       {обнуление массивов c и d}
    b[i]:=0;
    end;
     if o=2 then
     writeln;
    for j:=2 to p do begin
        m:=2;
        x:=1;
        y:=0;
        b[1]:=a[1];
        for i:=2 to n do begin
          if a[i]<a[i-1] then m:=m+1;
          if (m mod 2)=0 then begin
          x:=x+1;
          b[x]:=a[i];
        end;
    if (m mod 2)<>0 then begin
        y:=y+1;
        c[y]:=a[i];
      end;
    end;
    if o=2 then begin
      writeln;
      writeln('Шаг ', z);
      for i:=1 to x do begin
          write(b[i],' ');
      end;
      write('    ');
        for i:=1 to y do begin
          write(c[i],' ');
        end;
      writeln;
    end;
    i:=1;
    k:=1;
    l:=1;
    while i<=n do begin
       if (k<=x) and (l<=y) then begin
         if b[k]>=c[l] then begin
         a[i]:=c[l];
         l:=l+1;
         i:=i+1;
         end else begin
              a[i]:=b[k];
              k:=k+1;
              i:=i+1;
         end;
    end;
    if k>x then begin
        for m:=i to n do begin
        a[m]:=c[l];
        l:=l+1;
        end;
       i:=n+1;
    end;
    if l>y then begin
       for m:=i to n do begin
         a[m]:=b[k];
         k:=k+1;
        end;
        i:=n+1;
       end;
    end;
    //Слияние разбитых чисел
    for i:=1 to n do begin
    if o=2 then
    write(a[i],' ');
    c[i]:=0;   {обнуление массивов c и d}
    b[i]:=0;
    end;
    if o=2 then
    writeln;
    z:=z+1;
    end;
    //Сохранение в файл
    if o=1 then begin
    append(f2);
    writeln(f2);
    for i:=1 to n do begin
    write(f2,a[i],' ');
    end;
    close(f2);
    end;
    writeln;
    writeln('Сортировка завершена!');
    if o=2 then begin
    writeln('Результат!');
    for i:=1 to n do begin
    write(a[i],' ');
    end;
    end;
    writeln;
    readln;
end.

оформляйте код тегом [CODE]..[/СODE]

[Вадим Мошев]

Конкретно по сортировке естественным слиянием проконсультировать не смогу, поскольку не знаю о ней ничего, но могу дать немного рекомендаций касательно оптимизации вашего кода.

1. Не используйте идентификатор "o" для имени переменной. Может возникнуть случай, когда вы (или кто-то другой) может принять его за число нуль.

Также я считаю, что лучше не использовать идентификатор "l" (маленькая латинская буква L), поскольку её можно спутать с цифрой 1. Вот сами смотрите

1 = l

Легко отличить?

2.

o:=0; 
  Assign(f1, 'Исходный файл.txt'); 
  Assign(f2, 'Конечный файл.txt'); 
  rewrite(f1); 
  close(f1); 
  rewrite(f2); 
  close(f2); 
  begin 
    append(f1); 
    writeln(f1, 'Исходные данные: '); 
    close(f1); 
  end; 
  begin 
    append(f2); 
    writeln(f2, 'Конечные данные: '); 
    close(f2); 
  end;

Зачем использовать составной оператор (пара слов begin-end) в том месте программы, где нет циклов, условных операторов? Нет смысла заключать между ними последовательность действий. Жирные слова можно и не использовать

[Alex11223]

но могу дать немного рекомендаций касательно оптимизации вашего кода.

Да не его это код. Автор уже решил свою проблему выводом массива в консоль с конца )