Здравствуйте, Семенов Алексей Анатольевич!
Код программы - в приложении. Программа работает с файлом input.txt
Привожу пример (то, что между **** и ****, сохранить в файл input.txt, который надо расположить в одной папке с экзэшником).
****
3
6
160 2 1 3 1 0 0
170 3 4 4 0 1 0
120 4 5 2 0 0 1
0 0 0
13 10 8 0 0 0
****
Это файл для решения следующей задачи
F=13x1+10x2+8x3 ->MAX
Ограничения:
2x1+x2+x3<=160
3x1+4x2+4x3<=170
4x1+5x2+2x3<=120


Вроде все
Рад был помочь

Приложение:
uses crt; const N1=5; M1=12; s=7;{для форматирования вывода} k=2; type col=array[1..N1+1] of real; row=array[0..M1] of real; matr=array[1..N1+1] of row; var finp:text;{файл данных} ifMax:boolean; Ci:col; Cj:row; q:col; {симплекс-отношения} a:matr; n,m:integer;{array n*m} i0,j0:integer; stop:boolean; procedure init; var i,j:integer; answer:char; begin clrscr; write('Задача на максимум? (y/n)'); readln(answer); ifMax:=answer='y'; stop:=false; i0:=-1; j0:=-1; assign(finp,'input.pas'); reset(finp); readln(finp,n); readln(finp,m); {write('Количество строк n='); readln(n); write('Количество столбцов м='); readln(m);} for i:=1 to n do for j:=0 to m do begin {write('a[',i,',',j,']=');} read(finp,a[i,j]); end; for i:=1 to n do begin {write('Ci[',i,']=');} read(finp,Ci[i]); end; for j:=1 to m do begin {write('Cj[',j,']=');} read(finp,Cj[j]); end; Cj[0]:=0; close(finp); end; procedure countDj;{вычисление строки дельта j} var i,j:integer; s:real; begin for j:=0 to m do begin s:=0; for i:=1 to n do s:=s+a[i,j]*Ci[i]; a[n+1,j]:=s-Cj[j]; end; end; function findj0:integer;{поиск разрешающего столбца} var j:integer; j0tmp:integer; mtmp:real;{max or min} begin j0tmp:=1; if ifMax then begin for j:=2 to m do if a[n+1,j]<a[n+1,j0tmp] then j0tmp:=j; if a[n+1,j0tmp]>=0 then stop:=true; end else begin for j:=2 to m do if a[n+1,j]>a[n+1,j0tmp] then j0tmp:=j; if a[n+1,j0tmp]<=0 then stop:=true; end; findj0:=j0tmp; end; function findi0:integer;{поиск разрешающей строки} var i:integer; i0tmp:integer; procedure countq;{расчет симплексных отношений} var i:integer; begin if stop then for i:=1 to n do q[i]:=-1 else for i:=1 to n do if a[i,j0]<>0 then q[i]:=a[i,0]/a[i,j0] else q[i]:=-1; end; Begin countq; i0tmp:=1; while (q[i0tmp]<0) and (i0tmp<=n) do i0tmp:=i0tmp+1; if i0tmp>n then stop:=true else for i:=1 to n do if (q[i]>0) and (q[i]<q[i0tmp]) then i0tmp:=i; findi0:=i0tmp; End; procedure showhead;{печать шапки таблицы} var j:integer; begin clrscr; write('Cj':s); for j:=0 to m do write(Cj[j]:s:0); writeln('Симп.':s+2); write('Ci ':s); write('f':s); for j:=1 to m do write('x':s-1,j); writeln('отн.':s); end; procedure show;{вывод таблицы} var i,j:integer; begin for i:=1 to n+1 do begin if i=n+1 then write('dj':s) else write(Ci[i]:s:0); for j:=0 to m do begin if (i=i0) and(j=j0) then textColor(4); write(a[i,j]:s:k); textColor(7); end; if i<n+1 then write(q[i]:s+2:k); writeln; end; end; procedure newtable;{пересчет таблицы} var i,j:integer; begin Ci[i0]:=Cj[j0]; for i:=1 to n do for j:=0 to m do if (i<>i0) and (j<>j0) then a[i,j]:=a[i,j]-(a[i0,j]*a[i,j0])/a[i0,j0]; for j:=0 to m do if j<>j0 then a[i0,j]:=a[i0,j]/a[i0,j0]; for i:=1 to n do if i<>i0 then a[i,j0]:=0; a[i0,j0]:=1; end; BEGIN init; showhead; repeat countDj; j0:=findj0; i0:=findi0; show; if not stop then newtable; readln; until stop; writeln('Решение окончено. Press Enter'); readln; END.