home *** CD-ROM | disk | FTP | other *** search
/ ProfitPress Mega CDROM2 …eeware (MSDOS)(1992)(Eng) / ProfitPress-MegaCDROM2.B6I / PROG / PASCAL / NRPAS13.ZIP / SIMPLX.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1991-04-29  |  3.0 KB  |  114 lines
  1. PROCEDURE simplx(VAR a: glmpbynp; m,n,mp,np,m1,m2,m3: integer;
  2.        VAR icase: integer; VAR izrov: glnarray;
  3.        VAR iposv: glmarray);
  4. (* Programs using routine SIMPLX must define the types
  5. TYPE
  6.    glmpbynp = ARRAY [1..mp,1..np] OF real;
  7.    glnarray = ARRAY [1..n] OF integer;
  8.    glmarray = ARRAY [1..m] OF integer;
  9.    glmparray = ARRAY [1..mp] OF integer;
  10.    glnparray = ARRAY [1..np] OF integer;
  11. in the main routine. *)
  12. LABEL 1,2,10,20,30,99;
  13. CONST eps=1.0e-6;
  14. VAR
  15.    nl2,nl1,m12,kp,kh,k,is,ir,ip,i: integer;
  16.    q1,bmax: real;
  17.    l1: glnparray;
  18.    l2,l3: glmparray;
  19. BEGIN
  20.    IF (m <> (m1+m2+m3)) THEN BEGIN
  21.       writeln('pause in routine SIMPLX');
  22.       writeln('bad input constraint counts'); readln
  23.    END;
  24.    nl1 := n;
  25.    FOR k := 1 TO n DO BEGIN
  26.       l1[k] := k;
  27.       izrov[k] := k
  28.    END;
  29.    nl2 := m;
  30.    FOR i := 1 TO m DO BEGIN
  31.       IF (a[i+1,1] < 0.0) THEN BEGIN
  32.          writeln('pause in routine SIMPLX');
  33.          writeln('bad input tableau'); readln
  34.       END;
  35.       l2[i] := i;
  36.       iposv[i] := n+i
  37.    END;
  38.    FOR i := 1 TO m2 DO BEGIN
  39.       l3[i] := 1
  40.    END;
  41.    ir := 0;
  42.    IF ((m2+m3) = 0) THEN GOTO 30;
  43.    ir := 1;
  44.    FOR k := 1 TO n+1 DO BEGIN
  45.       q1 := 0.0;
  46.       FOR i := m1+1 TO m DO BEGIN
  47.          q1 := q1+a[i+1,k]
  48.       END;
  49.       a[m+2,k] := -q1
  50.    END;
  51. 10:   simp1(a,mp,np,m+1,l1,nl1,0,kp,bmax);
  52.    IF ((bmax <= eps) AND (a[m+2,1] < -eps)) THEN BEGIN
  53.       icase := -1; GOTO 99 END
  54.    ELSE IF ((bmax <= eps) AND (a[m+2,1] <= eps)) THEN BEGIN
  55.       m12 := m1+m2+1;
  56.       IF (m12 <= m) THEN BEGIN
  57.          FOR ip := m12 TO m DO BEGIN
  58.             IF (iposv[ip] = (ip+n)) THEN BEGIN
  59.                simp1(a,mp,np,ip,l1,nl1,1,kp,bmax);
  60.                IF (bmax > 0.0) THEN GOTO 1
  61.             END
  62.          END
  63.       END;
  64.       ir := 0;
  65.       m12 := m12-1;
  66.       IF ((m1+1) > m12) THEN GOTO 30;
  67.       FOR i := m1+1 TO m12 DO BEGIN
  68.          IF (l3[i-m1] = 1) THEN BEGIN
  69.             FOR k := 1 TO n+1 DO BEGIN
  70.                a[i+1,k] := -a[i+1,k]
  71.             END
  72.          END
  73.       END;
  74.       GOTO 30
  75.    END;
  76.    simp2(a,m,n,mp,np,l2,nl2,ip,kp,q1);
  77.    IF (ip = 0) THEN BEGIN
  78.       icase := -1; GOTO 99
  79.    END;
  80. 1:   simp3(a,mp,np,m+1,n,ip,kp);
  81.    IF (iposv[ip] >= (n+m1+m2+1)) THEN BEGIN
  82.       FOR k := 1 TO nl1 DO BEGIN
  83.          IF (l1[k] = kp) THEN GOTO 2
  84.       END;
  85. 2:      nl1 := nl1-1;
  86.       FOR is := k TO nl1 DO BEGIN
  87.          l1[is] := l1[is+1]
  88.       END
  89.    END ELSE BEGIN
  90.       IF (iposv[ip] < (n+m1+1)) THEN GOTO 20;
  91.       kh := iposv[ip]-m1-n;
  92.       IF (l3[kh] = 0) THEN GOTO 20;
  93.       l3[kh] := 0
  94.    END;
  95.    a[m+2,kp+1] := a[m+2,kp+1]+1.0;
  96.    FOR i := 1 TO m+2 DO BEGIN
  97.       a[i,kp+1] := -a[i,kp+1]
  98.    END;
  99. 20:   is := izrov[kp];
  100.    izrov[kp] := iposv[ip];
  101.    iposv[ip] := is;
  102.    IF (ir <> 0) THEN GOTO 10;
  103. 30:   simp1(a,mp,np,0,l1,nl1,0,kp,bmax);
  104.    IF (bmax <= 0.0) THEN BEGIN
  105.       icase := 0; GOTO 99
  106.    END;
  107.    simp2(a,m,n,mp,np,l2,nl2,ip,kp,q1);
  108.    IF (ip = 0) THEN BEGIN
  109.       icase := 1; GOTO 99
  110.    END;
  111.    simp3(a,mp,np,m,n,ip,kp);
  112.    GOTO 20;
  113. 99:   END;
  114.