Здравствуйте, Vedmak7!

Программу, предложенную Вами, я изменила под текстовые файлы. Теперь признаком, что файл считан, будет являться не -1, а пустая строка (исходный файл переписывается в новый без пустых строк, если они там содержались; если же их также необходимо перенести в новый файл, можно просто учесть их количество и добавить в начало или конец файла с результатом). Комментарии я изменила в соответствии с изменениями в программе.

Приложение:
Program SortSlian; { 3-ленточная, 2-фазная сортировка естественным слиянием } Uses Crt; Var Name, name1: string[30]; { имя исходного файла } A, B, C, Q: text; L: integer; S, T, K: string; e: boolean; Procedure Pech(var F: text); Begin Reset(F); While not eof(F) do begin Readln (F, S); Write(S,‘ ‘) end; WriteLn End; Procedure CopyElem(var X, Y: text; var Buf: string; var E: boolean); { копирование элемента и считывание следующего } { в Buf с проверкой конца серии (E=True) } Begin K:=Buf; Writeln (Y, Buf); if not Eof(X) then Readln (X, Buf) else Buf:=‘‘; { барьер: достигнут конец файла } E:=(Buf<K) { E=True в конце серии } End; Procedure CopySer(var X, Y: text; var Buf: string); { копирование серии из X в Y } { в начале Buf-первый элемент текущей серии на X } { в конце Buf-первый элемент следующей или ‘‘ (конец X) } Begin if Buf<>‘‘ then { файл X не считан } Repeat CopyElem(X, Y, Buf, E) Until E { E=True в конце серии } End; Procedure Raspred; { распределение A ---> B и C } Begin Reset(A); Readln (A, S); { первый элемент из A } Rewrite(B); Rewrite(C); Repeat CopySer(A, B, S); { S-первый элемент следующей серии } if S<>‘‘ then { файл A скопирован не весь } CopySer(A, C, S) Until S=‘‘ End; Procedure Slian; { слияние B и C--->A } Var E1, E2: boolean; Procedure SlianSer; { слияние серий из B и C ---> A } { S и T - первые элементы серий } { S=‘‘-весь файл B считан, T=‘‘-файл C считан } Begin Repeat E1:=False; E2:=False; if (S<>‘‘) and ((S<T) or (T=‘‘)) then { файл B не считан и текущий элемент B меньше, чем в C, здесь и определяется отсортированный участок} { либо файл C полностью считан } begin CopyElem(B, A, S, E1); if E1 then { достигнут конец серии на B } CopySer(C, A, T) end else begin CopyElem(C, A, T, E2); if E2 then { достигнут конец серии на C } CopySer(B, A, S) end Until E1 or E2 End; Begin { начало Slian } Reset(B); Reset(C); if not (Eof(B) or Eof(C)) then begin { оба файла не пусты } Rewrite(A); Readln(B, S); Readln(C, T); L:=0; { счетчик числа серий } While (S<>‘‘) or (T<>‘‘) do begin SlianSer; L:=L+1 end end End; Begin { начало основной программы } ClrScr; Write(‘Введите имя файла для сортировки элементов: ‘); ReadLn(name1); Write(‘Введите имя файла для записи элементов: ‘); ReadLn(name); Assign(Q, Name1); Assign(A, Name); Assign(B, ‘Rab1‘); Assign(C, ‘Rab2‘); Reset (Q); Rewrite (A); While not EOF (Q) do begin readln (Q, S); if S<>‘‘ then writeln (A, S); end; Close (Q); Close (A); L:=0; { L - число серий после слияния - параметр } Repeat WriteLn(‘Файл A: ‘); Pech(A); Raspred; { фаза распределения } WriteLn(‘Файл B: ‘); Pech(B); WriteLn(‘Файл C: ‘); Pech(C); ReadLn; { пауза } Slian { фаза слияния } Until L<=1; { L=0, если исходный файл отсортирован } WriteLn(‘Файл A в конце: ‘); Pech(A); Close(A); Close(B); Erase(B); { удаление рабочих файлов } Close(C); Erase(C); ReadLn End.

Здравствуйте, Vedmak7!

Предложу еще свой вариант - код в приложении. Смысл таков: из файла считывается 2 строки (если это можно) и во временный файл записываются в отсортированном виде. И так далее до конца файла.
После того, как достигли конца файла - исходный файл удаляется и временный файл переименовывается в имя исходного.
После этого из файла считывается 1 строка и записывается во временный и повторяется предыдущий цикл по считыванию и обработке 2-х строк.
Все эти действия происходят до тех пор, пока не случится такого, что при проходе цикла не будет ни одной перестановки строк.

Будут вопросы - спрашивайте.
Удачи!

Приложение:
var f,q:text; s1,s2,t:string; b:boolean; c,count:integer;begin assign(f,‘file.txt‘); b:=false; count:=0; repeat assign(q,‘temp.txt‘); c:=0; inc(count); reset(f); rewrite(q); if b and not(eof(f)) then begin readln(f,s1); writeln(q,s1); end; while not(eof(f)) do begin readln(f,s1); if not(eof(f)) then begin readln(f,s2); if s2<s1 then begin t:=s2; s2:=s1; s1:=t; c:=c+1; end; writeln(q,s1); writeln(q,s2); end else writeln(q,s1); end; erase(f); rename(q,‘file.txt‘); close(q); b:=not b; until (c=0) and (count>1); writeln(‘Fayl bil perepisan ‘,count,‘ raz.‘);end.