home *** CD-ROM | disk | FTP | other *** search
/ Oakland CPM Archive / oakcpm.iso / sigm / vol133 / linear.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1984-04-29  |  7.2 KB  |  323 lines
  1. Program LINEAR(0);
  2. (*  PROGRAM TITLE:    Linear Programming
  3. **
  4. **  WRITTEN BY:        W.M. Yarnall
  5. **            19 Angus Lane
  6. **            Warren, N.J. 07060
  7. **  DATE WRITTEN:    March 1980
  8. **
  9. **  WRITTEN FOR:    S100 MICROSYSTEMS
  10. **            MAR 1980
  11. **
  12. **  SUMMARY:        Minimize a cost function to constraints.
  13. **            Maximize negative of 'profit' function.
  14. **            This program uses the Revised Simplex Algorithm.
  15. **
  16. **  MODIFICATION RECORD:
  17. **    25 MAY 1980    -MODIFIED FOR PASCAL/Z BY RAYMOND E. PENLEY
  18. **
  19. **    30 JAN 83     -MODIFIED BY BUDDENBERG:
  20.         EXTERNAL INITIAL AND PRINT ROUTINES TO CUSTOMIZE
  21.         DATA INPUT AND OUTPUT.
  22. **        ---NOTE---
  23. **
  24. ** The first logical record in Pascal/Z is No.1, NOT record
  25. ** No. 0 as in Pascal/M or UCSD Pascal. This can be rectified
  26. ** very eaisly by adding a "BIAS" to each record number.
  27. **    Pascal/Z : bias = 1    |    Pascal/M : bias = 0
  28. **
  29. *)
  30. LABEL    99;      { File not found exit }
  31.  
  32. CONST
  33.   maxrow = 32;
  34.   maxcol = 64;
  35.   bias   =  1;       (* Bias added to each record *)
  36.   FID_LENGTH = 14; (* MAXIMUM LENGTH ALLOWED FOR A FILE NAME *)
  37.  
  38. TYPE
  39.   FID  = STRING FID_LENGTH;
  40.   ROW = array [1..maxrow] of real;
  41.   COL = array [1..maxcol] of real;
  42.   Frec = record
  43.        CASE TAG : integer of
  44.         0: (name : STRING 20; num1, num2 : integer);
  45.         1: (header : STRING 64);
  46.         2: (Rname : STRING 20; Rindex : integer; RHS : real);
  47.         4: (Cname : STRING 20; Cindex : integer; OBJ : real);
  48.         6: (R, S : integer; T : real);
  49.        99: () {End_Of_File}
  50.      end;
  51.  
  52.   STRING80 = STRING 80;
  53.  
  54. VAR
  55.   ABAR         : array [1..maxrow, 1..maxcol] of real;
  56.   Colname     : array [1..maxcol] of STRING 20;
  57.   fa        : FILE of Frec;    (*---File descriptor <FCB>---*)
  58.   File_ID    : FID;        (*---File Identifier <FID>---*)
  59.   F        : Frec;
  60.   heading    : STRING 64;
  61.   hdrflag    : boolean;
  62.   list        : array [1..maxrow] of integer;
  63.   M, N,
  64.   MP, M1    : integer;
  65.   PNAME        : STRING 20;
  66.   Result    : integer;
  67.   Rowname     : array [1..maxrow] of STRING 20;
  68.   U         : array [1..maxrow, 1..maxrow] of real;
  69.   X,XIK        : ROW;
  70.  
  71. PROCEDURE GETID( MESSAGE : STRING80; VAR ID: FID );
  72. (**
  73.     FID_LENGTH = 14;
  74.     STRING80 = STRING 80;
  75.     FID      = STRING FID_LENGTH;
  76. **)
  77. CONST    SPACE = ' ';
  78. TYPE
  79. (*----Required for PASCAL/Z supplied functions----*)
  80.   STR0 = STRING 0;
  81.   STR255 = STRING 255;
  82.         (*----required by PASCAL/Z----*)
  83.     FUNCTION  LENGTH(X: STR255): INTEGER; EXTERNAL;
  84.     PROCEDURE SETLENGTH(VAR X: STR0; Y: INTEGER); EXTERNAL;
  85.  
  86. begin{GetID}
  87.   SETLENGTH(ID,0);
  88.   writeln;
  89.   write(message);
  90.   READLN(ID);
  91.   While Length(ID)<FID_LENGTH DO APPEND(ID,SPACE)
  92. End{---of GETID---};
  93.  
  94. Procedure PRINTH; external;
  95.  
  96. Procedure PRINTC( B : row ; C : col ); external;
  97.  
  98. Procedure PRINTD; external;
  99.  
  100. Procedure PRINTX; external;
  101.  
  102. Procedure EXITER(exitcode, X : integer);
  103. begin
  104.   CASE exitcode of
  105.    1:    begin
  106.     Result := 1; (* Normal exit *)
  107.     Writeln(' End of Phase 1 for ', Pname, ' after', X:3,
  108.         ' Iterations');
  109.     PRINTX
  110.     end;
  111.    2:    begin
  112.     Result := 2; (* Error exit *)
  113.     Writeln(' Error in Iteration', X:3);
  114.     PRINTX
  115.     end;
  116.    3:    begin
  117.     Result := 3; (* No feasible solution *)
  118.     Writeln(' No feasible solution after', X:3, ' Iterations');
  119.     PRINTX
  120.     end;
  121.    4:    begin
  122.     Result := 1; (* Normal exit *)
  123.     Writeln(' End of Phase 2 for ', Pname, ' after', X:3,
  124.         ' Iterations');
  125.     PRINTX
  126.     end;
  127.    5:    begin
  128.     Result := 2; (* Unbounded solution *)
  129.     Writeln(' Unbounded solution for ', Pname);
  130.     PRINTX
  131.     end
  132.    end(* CASE exitcode of *)
  133. end(*---of EXITER---*);
  134.  
  135. Procedure INITIAL; external;
  136.  
  137. Procedure PHASE1;
  138. LABEL    304; (* Exit point *)
  139. CONST    TOL = 1.0E-5;
  140. VAR    iter, I, J, L, ksave : integer;
  141.     sum, temp, theta, Z  : real;
  142.     XL, XLK             : real;
  143.     DEL, V, W         : ROW;
  144.     test             : boolean;
  145. begin
  146.   writeln(' Start Phase 1');
  147.   writeln;
  148.   iter := 0;
  149.   While true do
  150.     begin
  151.     If ABS(X[MP])<tol then {normal exit}
  152.     begin EXITER(1,iter); goto 304 end;
  153.     If X[MP]>tol then {error exit}
  154.     begin EXITER(2,iter); goto 304 end;
  155.     iter := iter +1;
  156.     For J:=1 to N do
  157.       begin
  158.     SUM := 0.0;
  159.     For I:=1 to MP do
  160.       SUM := SUM + U[MP,I] * ABAR[I,J];
  161.     DEL[J] := SUM
  162.       end;
  163.     test := true;
  164.     For J:=1 to N do
  165.       If DEL[J]<0.0 then test := false;
  166.     If test then {no feasible solution exit}
  167.       begin EXITER(3,iter); goto 304 end;
  168.     temp := 1.0E+36;
  169.     ksave := 0;
  170.     For J:=1 to N do
  171.       If DEL[J]<temp then
  172.     begin temp := DEL[J]; ksave := J end;
  173.     For I:=1 to MP do
  174.       begin
  175.     SUM := 0.0;
  176.     For J:=1 to MP do
  177.       SUM := SUM + U[I,J] * ABAR[J,ksave];
  178.     XIK[I] := SUM
  179.       end;
  180.     theta := 1.0E+36;
  181.     L := 0;
  182.     For I:=1 to M do
  183.       If XIK[I]>0.0 then
  184.     begin
  185.     Z := X[I] / XIK[I];
  186.     If (Z=theta) AND (list[I]>N) then
  187.       L := I
  188.     Else
  189.       If Z<theta then
  190.         begin theta := Z; L := I end
  191.     end;
  192.     If L=0 then
  193.       begin EXITER(2,iter); goto 304 end;
  194.     list[L] := ksave;
  195.     For I:=1 to MP do
  196.       begin
  197.     V[I] := XIK[I] / XIK[L];
  198.     W[I] := U[L,I]
  199.       end;
  200.     XL := X[L];
  201.     XLK := XIK[L];
  202.     For I:=1 to MP do
  203.       begin
  204.     Z := theta;
  205.     If (list[I]<>ksave) then Z := X[I] - XL * V[I];
  206.     X[I] := Z;
  207.     For J:=1 to M do
  208.       begin
  209.         Z := W[J] / XLK;
  210.         If I<>L then Z := U[I,J] - W[J] * V[I];
  211.         U[I,J] := Z
  212.       end
  213.       end;
  214.     writeln(' Iteration', iter:3, ' of ', Pname);
  215.     {PRINTX    OMITTED FOR LINPROG}
  216.     end(* While true *);
  217. 304: (* Exit point *)
  218. end(*---of PHASE1---*);
  219.  
  220. Procedure PHASE2;
  221. LABEL    403; (* Exit point *)
  222. CONST    TOL = -1.0E-5;
  223. VAR    I, J, L, iter, ksave : integer;
  224.     SUM, temp, theta, Z  : real;
  225.     XL, XLK             : real;
  226.     DEL, V, W         : ROW;
  227.     test             : boolean;
  228. begin
  229.   iter := 0;
  230.   writeln(' Start Phase 2');
  231.   writeln;
  232.   While true do
  233.     begin
  234.     For J:=1 to N do
  235.       begin
  236.     SUM := 0.0;
  237.     For I:=1 to MP do
  238.       SUM := SUM + U[M1,I] * ABAR[I,J];
  239.     DEL[J] := SUM
  240.       end;
  241.     test := true;
  242.     For J:=1 to N do
  243.       If DEL[J]<tol then test := false;
  244.     If test then
  245.       begin EXITER(4,iter); goto 403 end;
  246.     iter := iter +1;
  247.     temp := 1.0E+36;
  248.     ksave := 0;
  249.     For J:=1 to N do
  250.       If DEL[J]<temp then
  251.     begin temp := DEL[J]; ksave := J end;
  252.     For I:=1 to MP do
  253.       begin
  254.     SUM := 0.0;
  255.     For J:=1 to MP do
  256.       SUM := SUM + U[I,J] * ABAR[J,ksave];
  257.     XIK[I] := SUM
  258.       end;
  259.     test := true;
  260.     For I:=1 to MP do
  261.       If XIK[I]>0.0 then test := false;
  262.     If test then
  263.       begin EXITER(5,iter); goto 403 end;
  264.     theta := 1.0E+36;
  265.     L := 0;
  266.     For I:=1 to M do
  267.       If XIK[I]>0.0 then
  268.     begin
  269.       Z := X[I] / XIK[I];
  270.       If Z<theta then
  271.         begin theta := Z; L := I end
  272.     end;
  273.     List[L] := ksave;
  274.     For I:=1 to MP do
  275.       begin
  276.     V[I] := XIK[I] / XIK[L];
  277.     W[I] := U[L,I];
  278.       end;
  279.     XL := X[L];
  280.     XLK := XIK[L];
  281.     For I:=1 to MP do
  282.       begin
  283.     Z := theta;
  284.     If (list[I]<>ksave) then Z := X[I] - XL * V[I];
  285.     X[I] := Z;
  286.     For J:=1 to M do
  287.       begin
  288.         Z := W[J] / XLK;
  289.         If I<>L then Z := U[I,J] - W[J] * V[I];
  290.         U[I,J] := Z
  291.       end
  292.       end;
  293.     writeln(' Iteration', iter:3, ' of ', Pname);
  294.     {PRINTX;    OMITTED FOR LINPROG}
  295.     end(* While true *);
  296. 403: (* Exit point *)
  297. end(*---of PHASE2---*);
  298.  
  299. Procedure CLEAR;
  300. (* simple screen clear routine *)
  301. VAR    ix : 1..25;
  302. begin
  303.   for ix:=1 to 25 do writeln
  304. end;
  305.  
  306. BEGIN (***   MAIN PROGRAM   ***)
  307.   CLEAR;
  308.   GETID(' Enter data File Name ---> ', File_ID);
  309.   RESET(File_ID, fa);    (*---RESET( <FID> , <FCB> )---*)
  310.   If EOF(fa) then
  311.     begin
  312.     Writeln(CHR(7),'File ',File_ID,'not found');
  313.     {exit}goto 99
  314.     end;
  315.   Writeln;
  316.   INITIAL;
  317.   If Result<>2 then PHASE1;
  318.   If Result=1 then PHASE2;
  319.   If hdrflag then Writeln(' ', heading);
  320. 99: {File not found exit};
  321.   Writeln;Writeln;Writeln;Writeln;Writeln
  322. end(*---of Linear---*).
  323.