Транспортная задача линейного программирования

 симплексным  методом}

uses crt;

const n=2;{число  неизвестных исходной задачи}

      m=3;{число ограничений}

      m1=0;{последняя строка равенств}

      m2=1;{последняя строка неравенств  вида >=}

label 5,15,20,10;

var b,cb:array[1..m] of real;c,x,e:array[1..50] of real;a:array[1..m,1..50] of real;

    s0,max,mb,s1:real;i,j,k,i0,j0,m21,nm1,n1:integer; Bi:array[1..m] of integer;

begin

     clrscr;

     writeln;

     writeln (' Симплексный метод решения  задачи линейного программирования:');

     writeln;

     writeln (' Проведем некоторые преобразования с данной задачей:');

     writeln;

     writeln (' Подготовьте матрицу: сначала  равенства, потом неравенства  вида >= и неравенства  вида <=;');

     writeln (' Целевая функция должна  быть на минимум (привести ее  к такому виду); ');

     writeln (' Вектор b должен состоять только  из положительных элементов (привести  его к та-  кому виду);');

     writeln(' Введите матрицу А ',m,'*',n,' построчно:');

     for i:=1 to m

         do begin for j:=1 to n

                      do read (a[i,j]);

                      readln

                  end;

     writeln (' Введите в виде строки  вектор b, состоящий из ',m,' компонент:');

     for i:=1 to m

         do read (b[i]);

     writeln(' Введите теперь вектор с, состоящий из ',n,' компонент:');

     for i:=1 to n

          do read (c[i]);

     m21:=m2-m1+n;nm1:=n+m-m1;n1:=n+m-m1+m2;

     for i:=1 to m

         do for j:=n+1 to n1

                do a[i,j]:=0;

     {переход к равенствам в неравенствах >=}

     for i:=m1+1 to m2

         do a[i,n+i-m1]:=-1;

     {переход к равенствам в неравенствах <=}

     for i:=m2+1 to m

         do a[i,m21+i-m2]:=1;

     {создание искуственного базиса}

     for i:=1 to m2

         do a[i,nm1+i]:=1;

         {ввод mb в вектор с}

     mb:=12345;

     for i:=n+1 to nm1

         do c[i]:=0;

     for i:=nm1+1 to n1

         do c[i]:=mb;

     {выписать cb}

     for i:=1 to m2

         do begin cb[i]:=mb; Bi[i]:=nm1+i end;

     for i:=m2+1 to m

         do begin Bi[i]:=m21+i-m2;

                  cb[i]:=0;

            end;

     for i:=1 to n1

         do x[i]:=0;

     writeln(' Решение задачи:');

     {применяем симплексный метод,  вычисляем оценки}

     5: for j:=1 to n1

            do begin s0:=0;

                     for i:=1 to m

                         do s0:=s0+cb[i]*a[i,j];

                     e[j]:=s0-c[j]

               end;

     max:=e[1];j0:=1;

     for i:=2 to n1

         do if e[i]>max

               then begin max:=e[i];

                          j0:=i

                    end;

     {получили столбец с максимальной  оценкой}

     if max<=0

        then begin for i:=1 to m

                       do x[Bi[i]]:=b[i];

                                        goto 15

             end;

     s1:=a[1,j0];

     for i:=2 to m

         do if s1<a[i,j0]

               then s1:=a[i,j0];

     if s1<=0

        then goto 10;

     s1:=mb;

     for i:=1 to m

         do if a[i,j0]>0

               then if s1>b[i]/a[i,j0]

                       then begin

                                  s1:=b[i]/a[i,j0];

                                  i0:=i

                            end;

     {главный элемент a[i0,j0]}

     s0:=a[i0,j0]; Bi[i0]:=j0;

     for j:=1 to n1

         do a[i0,j]:=a[i0,j]/s0;

     b[i0]:=b[i0]/s0;

     for i:=1 to m

         do if i<>i0

               then begin s1:=-a[i,j0];

                          b[i]:=b[i]+b[i0]*s1;

                          for j:=1 to n1

                              do a[i,j]:=a[i,j]+a[i0,j]*s1

                    end;

      cb[i0]:=c[j0];

      goto 5;

      10: writeln(' Нет оптимального плана, функция неограничена');

      goto 20;

      {просмотр иск. переменных}

      15: for i:=nm1+1 to n1

              do if x[i]>0

                    then begin writeln(' Пустое множество планов');

                               goto 20

                         end; 

      for i:=1 to n

          do writeln(' x[',i,']=',x[i]:7:4);

      20:readkey

end.