Симплекс-метод

PROGRAM SIMPLEX_METOD;
USES CRT;
LABEL ZN,ST,ELL,_END;
 
  TYPE MAS=ARRAY[1..30] OF REAL;
       MASB=ARRAY[1..30] OF STRING[3];
       MASX=ARRAY[1..30,1..30] OF REAL;
 
 
VAR Fo,FunctPr,B,H,Hnew,C,Cnew,CPr,CPrnew,FX:MAS;
    X,Xnew:MASX;
    BS,Bvsp,ZNAC:MASB;
    MIN,I1,I,J,Kx,Ky,Kit,NachKell,NachY,K_st:INTEGER;
    PriznacY,KLstr,KLst,ErrCode,Dop_X:INTEGER;
    P,P1,Mo,F0,Epsilon,Z:REAL;
    VSP,S,PrGomory:STRING;
    F:TEXT;
 
    DPx,DPy,Fm,Kell,Kstr:INTEGER;
 
                     { ”г*ЄжЁп ᮧ¤**Ёп Ё*¤ҐЄб®ў }
 
FUNCTION SIMVB(V:INTEGER;S:CHAR):STRING;
  VAR M,Z:STRING;
BEGIN
 STR(V,M);
 Z:=S+M;
 SIMVB:=Z;
END;
 
                     { Џа®жҐ¤га* §*ЇЁбЁ ¤***ле ў д*©« }
 
PROCEDURE SAVE(X1:REAL;K:STRING;Mstr:INTEGER);
VAR V:STRING;
BEGIN
ASSIGN(F,'SIMPLEX.DAT');
APPEND(F);
CASE Mstr OF
 0:WRITELN(F,'');
 1:BEGIN
   IF K=' ' THEN STR(X1:1:0,V) ELSE STR(X1:10:4,V);
    WRITE(F,V);
    WRITE(F,'  ');
   END;
 2:WRITE(F,K);
 3:WRITELN(F,K);
END;
CLOSE(F);
END;
 
                     { ЋЇаҐ¤Ґ«Ґ*ЁҐ ¤®Ї®«*ЁвҐ«м*ле ЇҐаҐ¬Ґ**ле }
 
PROCEDURE DOP_PER;
 BEGIN
   IF ZNAC[I1]='=' THEN
      BEGIN
 
       Kell:=Kell+1;Bvsp[Kell]:=SIMVB(DPy,'Y');
       DPy:=DPy+1;
       Xnew[I1,Kell]:=1;
       IF Fm=1 THEN FX[Kell]:=-1 ELSE FX[Kell]:=1;
       FunctPr[Kell]:=1;
 
       FOR I:=1 TO Kstr DO
        IF I<>I1 THEN Xnew[I,Kell]:=0;
 
      END;
 
   IF ZNAC[I1]='>=' THEN
      BEGIN
 
       Kell:=Kell+1;Bvsp[Kell]:=SIMVB(DPx,'X');
      DPx:=DPx+1;Dop_X:=Dop_X+1;
       Xnew[I1,Kell]:=-1;FX[Kell]:=0;
 
       FOR I:=1 TO Kstr DO
        IF I<>I1 THEN Xnew[I,Kell]:=0;
 
       Kell:=Kell+1;Bvsp[Kell]:=SIMVB(DPy,'Y');
       DPy:=DPy+1;
       Xnew[I1,Kell]:=1;
 
       IF Fm=1 THEN FX[Kell]:=-1 ELSE FX[Kell]:=1;
       FunctPr[Kell]:=1;
 
       FOR I:=1 TO Kstr DO
        IF I<>I1 THEN Xnew[I,Kell]:=0;
 
      END;
 
   IF ZNAC[I1]='<=' THEN
      BEGIN
 
      Kell:=Kell+1;Bvsp[Kell]:=SIMVB(DPx,'X');
      DPx:=DPx+1;Dop_X:=Dop_X+1;
       Xnew[I1,Kell]:=1;FX[Kell]:=0;
 
       FOR I:=1 TO Kstr DO
        IF I<>I1 THEN Xnew[I,Kell]:=0;
 
      END;
 
 END;
 
                     { Џа®жҐ¤га* б®Єа*йҐ*Ёп Y }
 
PROCEDURE SOKR;
VAR P:INTEGER;
 BEGIN
  Kell:=Kell-1;
  FOR P:=NachKell+DOP_X TO Kell DO
   IF Bvsp[P]=BS[KLstr] THEN BEGIN
                         FOR J:=P TO Kell DO
                         Bvsp[J]:=Bvsp[J+1];
                         FunctPr[J]:=FunctPr[J+1];
                         Fx[J]:=Fx[J+1];
                         FOR I:=1 TO Kstr DO
                         Xnew[I,J]:=Xnew[I,J+1]
                             END;
 END;
 
                     { Џа®жҐ¤га*, ўлЇ®«*пой*п ¬Ґв®¤ ѓ®¬®аЁ }
 
PROCEDURE GOMORY;
VAR MAX,Z:REAL;
BEGIN
 KLstr:=1;
  MAX:=H[1]-INT(H[1]);
 FOR I1:=2 TO Kstr DO
   IF (H[I1]-INT(H[I1]))>=MAX THEN BEGIN MAX:=H[I1]; KLstr:=I1;END;
  Kstr:=Kstr+1;
 Hnew[Kstr]:=H[KLstr]-INT(H[KLstr]);
  FOR I1:=1 TO Kell DO
   BEGIN
    Z:=INT(X[KLstr,I1]);
    IF X[KLstr,I1]<0 THEN Z:=Z-1;
    Xnew[Kstr,I1]:=X[KLstr,I1]-Z;
   END;
ZNAC[Kstr]:='>=';
END;
 
                     { Џа®жҐ¤га*, ўлЇ®«*пой*п ‘Ё¬Ї«ҐЄб ¬Ґв®¤ }
 
PROCEDURE SIMPLEX;
 
  LABEL POVZNAC,NACH;
 
 
BEGIN
 
         { Џ®¤Ј®в®ўЄ* Є ўў®¤г ¤***ле }
 
NachKell:=Kell;
DPx:=Kell+1;DPy:=1;
Kx:=1;Ky:=4;
Epsilon:=0.00001;
CLRSCR;
WRITELN('‚ўҐ¤ЁвҐ бЁб⥬г га*ў*Ґ*Ё©:');
WRITELN('(Є®нддЁжЁҐ*вл ЇаЁ ўбҐе •,§**Є Ё бў®Ў®¤*лҐ з«Ґ*л)');
 
         { ‚ў®¤ ¤***ле }
 
  FOR I:=1 TO Kstr DO
   BEGIN
POVZNAC:
    WRITELN('‚ўҐ¤ЁвҐ ',I,'-Ґ га*ў*Ґ*ЁҐ:');
 
         { ‚ў®¤ Є®нддЁжЁҐ*в®ў ЇаЁ X ў I-⮬ га*ў*Ґ*ЁЁ }
 
    FOR J:=1 TO Kell DO
     BEGIN
      GOTOXY(Kx,Ky);Kx:=Kx+6;
      READLN(Xnew[I,J]);
     END;
 
         { ‚ў®¤ §**Є* ў I-⮬ га*ў*Ґ*ЁЁ }
 
    Kx:=Kx+6;GOTOXY(Kx,Ky);READLN(ZNAC[I]);
 
 
 
              {Џа®ўҐаЄ* ўўҐ¤Ґ**®Ј® §**Є* ** Їа*ўЁ«м*®бвм}
 
    IF (ZNAC[I]<>'>=') AND (ZNAC[I]<>'=') AND (ZNAC[I]<>'<=')
    THEN BEGIN
          WRITELN('ЌҐЇа*ўЁ«м*® §*¤** §**Є');
          Ky:=Ky+3;Kx:=1;
          GOTO POVZNAC;
         END;
 
    IF (ZNAC[I]='=') OR (ZNAC[I]='>=') THEN PriznacY:=1;
 
         { ‚ў®¤ бў®Ў®¤*®Ј® з«Ґ** ў I-⮬ га*ў*Ґ*ЁЁ }
 
    Kx:=Kx+6;GOTOXY(Kx,Ky);READ(B[I]);
    Kx:=1;
    Ky:=Ky+2;
 
   END;
 
WRITELN('‚ўҐ¤ЁвҐ Є®нддЁжЁҐ*вл ЇаЁ • ў 楫Ґў®© дг*ЄжЁЁ:');
 
         { ‚ў®¤ Є®нддЁжЁҐ*в®ў ЇаЁ • ў 楫Ґў®© дг*ЄжЁЁ }
 
   FOR J:=1 TO Kell DO
    BEGIN
     GOTOXY(Kx,Ky);Kx:=Kx+6;
     READ(FX[J]);
    END;
         { Џ®¤Ј®в®ўЄ*  Ё*¤ҐЄб*жЁЁ X }
 
FOR J:=1 TO Kell DO
 Bvsp[J]:=SIMVB(J,'X');
 
         { ЋЇаҐ¤Ґ«Ґ*ЁҐ ¤®Ї®«*ЁвҐ«м*ле ЇҐаҐ¬Ґ**ле }
 
FOR I1:=1 TO Kstr DO
 DOP_PER;
 
         { ‡*¬Ґ** ®ЇвЁ¬*«м*®© дг*ЄжЁЁ б MAX ** MIN ЇаЁ **«ЁзЁЁ
           ў Ў*§ЁбҐ Y-Є®ў Ґб«Ё Ё¤Ґв Ёбб«Ґ¤®ў**ЁҐ ** ¬Ё*Ё¬г¬    }
 
MIN:=0;
IF (Fm=1) AND (PriznacY=1) THEN
   BEGIN
    MIN:=Fm;Fm:=2;
     FOR J:=1 TO Kell DO
      FX[J]:=-FX[J];
   END;
 
         { ‘®авЁа®ўЄ* ¤®Ї®«*ЁвҐ«м*ле ЇҐаҐ¬Ґ**ле Ї® Ё*¤ҐЄбг }
 
FOR I1:=NachKell+1 TO Kell DO
  FOR J:=I1+1 TO Kell DO
  IF Bvsp[J]<Bvsp[I1] THEN
     BEGIN
      VSP:=Bvsp[J];Bvsp[J]:=Bvsp[I1];Bvsp[I1]:=VSP;
      P:=FX[J];FX[J]:=FX[I1];FX[I1]:=P;
      P:=FunctPr[J];FunctPr[J]:=FunctPr[I1];FunctPr[I1]:=P;
      FOR I:=1 TO Kstr DO
      BEGIN
       P:=Xnew[I,I1];Xnew[I,I1]:=Xnew[I,J];Xnew[I,J]:=P;
      END;
     END;
Kit:=1;
CLRSCR;
 
         { Џ®¤Ј®в®ўЄ* бв®«Ўж®ў C,B,H }
 
     FOR I:=1 TO Kstr DO
      BEGIN
       Hnew[I]:=B[I];
      FOR J:=NachKell+1 TO Kell DO
          IF Xnew[I,J]=1 THEN
             BEGIN
              BS[I]:=Bvsp[J];
              Cnew[I]:=FX[J];
              CPrnew[I]:=FunctPr[J];
        END;
             END;
 
NACH:;
 
REPEAT
 
PriznacY:=0;
 
         { ЏҐаҐ¤*з* ¤***ле ў Ёб室*лҐ ЇҐаҐ¬Ґ**лҐ c ®Ў*г«Ґ*ЁҐ¬ зЁбҐ«,
           Ї® ¬®¤г«о ¬Ґ*миЁе 祬 0.00001                            }
 
FOR I:=1 TO Kstr DO
 BEGIN
 IF INT(10000*Hnew[I])=0 THEN H[I]:=+0 ELSE H[I]:=Hnew[I];
 C[I]:=Cnew[I];
 CPr[I]:=CPrnew[I];
 IF BS[I][1]='Y' THEN PriznacY:=1;
 FOR J:=1 TO Kell DO
  IF INT(10000*Xnew[I,J])=0 THEN X[I,J]:=+0 ELSE X[I,J]:=Xnew[I,J];
   END;
 
         { ЋЎ*г«Ґ*ЁҐ Ё ўлў®¤ Ё*¤ҐЄб*жЁЁ н«Ґ¬Ґ*в®ў Ё*¤ҐЄб*®© бва®ЄЁ }
 
SAVE(0,'     C      Ѓ        H            ',2);
FOR J:=1 TO Kell DO
 BEGIN
 SAVE(0,Bvsp[J],2);
 P1:=LENGTH(Bvsp[J]);
 IF P1=2 THEN SAVE(0,' ',2);
 SAVE(0,'         ',2);
 Fo[J]:=0;
 END;
 SAVE(0,'',0);
 
         { ‚лў®¤ ‘Ё¬Ї«ҐЄб-в*Ў«Ёжл }
 
P1:=0;
FOR I:=1 TO Kstr DO
 BEGIN
 
  IF CPr[I]=1 THEN
      IF C[I]<0 THEN SAVE(0,'-M          ',2)
                ELSE SAVE(0,'+M          ',2)
  ELSE SAVE(C[I],'',1);
 
  SAVE(0,BS[I],2);
  P1:=LENGTH(BS[I]); IF P1=2 THEN SAVE(0,' ',2);
  SAVE(0,' ',2);SAVE(H[I],'',1);
 
  FOR J:=1 TO Kell DO
   SAVE(X[I,J],'',1);
  SAVE(0,'',0);
 END;
 
         { ‚лзЁб«Ґ*ЁҐ §**зҐ*Ё© ў Ё*¤ҐЄб*®© бва®ЄҐ }
 
F0:=0;
FOR J:=1 TO Kell DO
       Fo[J]:=0;
 
FOR I1:=1 TO Kstr DO
  BEGIN
  IF PriznacY=1 THEN
      IF BS[I1][1]='Y' THEN
         BEGIN
          F0:=F0+H[I1];
          FOR J:=1 TO Kell DO
            Fo[J]:=Fo[J]+X[I1,J];
         END;
  IF PriznacY=0 THEN
     BEGIN
      F0:=F0+H[I1]*C[I1];
      FOR J:=1 TO Kell DO
        Fo[J]:=Fo[J]+C[I1]*X[I1,J];
     END;
 
FOR J:=1 TO Kell DO
 IF Bvsp[J][1]='Y' THEN Fo[J]:=+0
                   ELSE IF ABS(Fo[J])<Epsilon THEN Fo[J]:=+0;
  END;
 
         { ‚лў®¤ §**зҐ*Ё© 楫Ґў®© дг*ЄжЁЁ }
 
SAVE(0,'                ',2);SAVE(F0,'',1);
FOR J:=1 TO Kell DO
 BEGIN
 
  IF PriznacY<>1 THEN Fo[J]:=Fo[J]-FX[J];
  SAVE(Fo[J],'',1);
 
 END;
SAVE(0,'',0);
 
         { Џа®ўҐаЄ* гб«®ўЁп ®ЇвЁ¬*«м*®бвЁ }
 
P:=0;
FOR J:=1 TO Kell DO
  IF Fm=1 THEN IF Fo[J]<-Epsilon THEN
                  BEGIN
                   P:=1;
                   CONTINUE;
                  END  ELSE
          ELSE IF Fo[J]>Epsilon THEN
                  BEGIN
                   P:=1;
                   CONTINUE;
                  END;
 
IF P<>1 THEN
   BEGIN
 
    SAVE(0,'‚ ',2);SAVE(Kit,' ',1);
    SAVE(0,'-© ЁвҐа*жЁЁ Ўл«® Ї®«гзҐ*® ®ЇвЁ¬*«м*®Ґ аҐиҐ*ЁҐ',3);
    SAVE(0,'в.Є. ЇаЁ Ёбб«Ґ¤®ў**ЁЁ ** ',2);
    IF Fm=1 THEN
     SAVE(0,'ЊЂЉ‘€Њ“Њ Ё*¤ҐЄб**п бва®Є* *Ґ ᮤҐа¦Ёв ®вЁж*⥫м*ле н«Ґ¬Ґ*в®ў.',3)
            ELSE
     SAVE(0,'Њ€Ќ€Њ“Њ Ё*¤ҐЄб**п бва®Є* *Ґ ᮤҐа¦Ёв Ї®«®¦ЁвҐ«м*ле н«Ґ¬Ґ*в®ў.',3);
 
    FOR I1:=1 TO Kstr DO
     IF BS[I1][1]='Y' THEN
        BEGIN
         SAVE(0,'Ќ® в.Є. Ё§ Ў*§Ёб* *Ґ ўлўҐ¤Ґ*л ўбҐ Y, в® ',3);
         SAVE(0,'¬®¦*® ᤥ«*вм ўлў®¤, зв® ђ…?…Ќ€‰ Ќ…’',3);
         HALT;
        END;
 
         { ЋЄагЈ«Ґ*ЁҐ §**зҐ*Ё© ¬*ббЁў* • ¤® 楫®Ј® зЁб«*,
           Ґб«Ё а*§*®бвм ®ЄагЈ«Ґ**®Ј® Ё ®Ўлз*®Ј® §**зҐ*Ё©
           Ї® ¬®¤г«о ¬Ґ*миҐ зҐ¬ 0.00001                   }
 
FOR I:=1 TO Kstr DO
 BEGIN
       Z:=ROUND(H[I]);
       IF ABS(Z-H[I])<Epsilon THEN H[I]:=ROUND(H[I]);
  FOR J:=1 TO Kell DO
   BEGIN
          IF X[I,J]<0 THEN Z:=ROUND(X[I,J]);
          IF ABS(Z-X[I,J])<Epsilon THEN X[I,J]:=ROUND(X[I,J]);
   END;
 END;
 
         { Џа®ўҐаЄ* 楫®зЁб«Ґ**®бвЁ аҐиҐ*Ёп }
 
P1:=0;
FOR I:=1 TO Kstr DO
 BEGIN
 IF INT(10000*FRAC(H[I]))<>0 THEN BEGIN P1:=1;CONTINUE; END;
 
        FOR J:=1 TO Kell DO
         IF BS[I]=Bvsp[J] THEN
            FOR I1:=1 TO Kstr DO
             IF ABS(FRAC(X[I1,J]))>=Epsilon THEN BEGIN P1:=1;CONTINUE; END;
 
 END;
 
         { ‘®бв*ў«Ґ*ЁҐ *®ў®© Ў*§Ёб*®© бва®ЄЁ ¤«п 楫®зЁб«Ґ**®Ј® аҐиҐ*Ёп }
 
    IF (PrGomory='Y') AND (P1=1) THEN
       BEGIN
                          GOMORY;
                          NachKell:=Kell;
                          I1:=Kstr;DPy:=1;
                          DOP_PER;
                          BS[Kstr]:=Bvsp[Kell];
                          CPrnew[Kstr]:=FunctPr[Kell];
                          Cnew[Kstr]:=FX[Kell];
                          GOTO NACH;
      END;
 
      IF P1=0 THEN SAVE(0,'„***®Ґ аҐиҐ*ЁҐ пў«пҐвбп 楫®зЁб«Ґ*л¬.',3);
 
    SAVE(0,'ЏаЁ н⮬:',3);
    IF MIN=1 THEN BEGIN F0:=-F0;Fm:=MIN; END;
    IF Fm=1 THEN
            SAVE(0,'Fmax=',2)
            ELSE
            SAVE(0,'Fmin=',2);
 
            SAVE(F0,'',1);
            SAVE(0,'',0);
 
 
    FOR I1:=1 TO Kstr DO
     BEGIN
      SAVE(0,'  ',2);
      SAVE(0,BS[I1],2);SAVE(0,'=',2);
      SAVE(H[I1],'',1);
      SAVE(0,'',0);
     END;
    HALT;
 
   END;
 
         { Ќ*宦¤Ґ*ЁҐ Є«о祢®Ј® бв®«Ўж* }
 
KLst:=1;Mo:=0;
FOR J:=1 TO Kell DO
 IF Fm=1 THEN
    IF Fo[J]<Mo THEN Mo:=Fo[J];
 
FOR J:=1 TO Kell DO
 BEGIN
  IF Bvsp[J][1]<>'Y' THEN
     IF Fm=1 THEN
        BEGIN
         IF Fo[J]<0 THEN
            IF Fo[J]>=Mo THEN
               BEGIN
                Mo:=Fo[J]; KLst:=J;
               END;
        END
             ELSE
        BEGIN
         IF Fo[J]>0 THEN
            IF Fo[J]>=Mo THEN
               BEGIN
                Mo:=Fo[J]; KLst:=J;
               END;
        END;
 END;
 
 SAVE(0,'Љ«о祢®© бв®«ЎҐж: ',2);SAVE(KLst,' ',1);
 
         { Ќ*宦¤Ґ*ЁҐ Є«о祢®© бва®ЄЁ }
 
P1:=0;K_st:=0;
FOR J:=1 TO Kell DO
 IF ABS(Mo-Fo[J])<Epsilon THEN
  BEGIN
   K_st:=K_st+1;
   FOR I:=1 TO Kstr DO
    IF X[I,KLst]>0 THEN BEGIN B[I]:=H[I]/X[I,KLst]; P:=B[I];KLstr:=I; END
                   ELSE BEGIN B[I]:=-1; P1:=P1+1; END;
  END;
 
IF P1=Kstr*K_st THEN
   BEGIN
    SAVE(0,'',0);
    SAVE(0,'ђ…?…Ќ€‰ Ќ…’ в.Є. *Ґў®§¬®¦*® ®ЇаҐ¤Ґ«Ёвм Є«о祢го бва®Єг',3);
    HALT;
   END;
 
P1:=0;
FOR J:=1 TO Kell DO
 IF ABS(Mo-Fo[J])<Epsilon THEN
  FOR I:=1 TO Kstr DO
    IF B[I]>=0 THEN BEGIN
       IF B[I]<P THEN IF Bvsp[KLst]<>BS[I] THEN BEGIN P:=B[I]; KLstr:=I; END;
 
        IF INT(10000*B[I])=INT(10000*P) THEN
         IF (BS[I][1]='Y') AND (BS[KLstr][1]='X') THEN
          IF Bvsp[KLst]<>BS[I] THEN BEGIN P:=B[I]; KLstr:=I; END;
                    END;
 
SAVE(0,'Љ«о祢*п бва®Є*: ',2);SAVE(KLstr,' ',1);
SAVE(0,'',0);
 
FOR I:=1 TO Kstr DO
 IF Bvsp[KLst]=BS[I] THEN
    BEGIN
     SAVE(0,'ђ…?…Ќ€‰ Ќ…’ в.Є. ў Ў*§Ёб*®¬ бв®«ЎжҐ 㦥 Ґбвм ',3);
     SAVE(0,'в*Є*п ЇҐаҐ¬Ґ***п.',3);
     HALT;
    END;
 
         { ‚맮ў Їа®жҐ¤гал б®Єа*йҐ*Ёп Y }
 
IF CPr[KLstr]=1 THEN SOKR;
 
 
         { Џ®бв஥*ЁҐ б«Ґ¤го饩 ‘Ё¬Ї«ҐЄб-в*Ў«Ёжл }
 
BS[KLstr]:=Bvsp[KLst];
Cnew[KLstr]:=FX[KLst];
CPrnew[KLstr]:=FunctPr[KLst];
 
FOR I:=1 TO Kstr DO
    BEGIN
     IF I=KLstr THEN Hnew[I]:=H[I]/X[KLstr,KLst]
                ELSE Hnew[I]:=H[I]-(H[KLstr]*X[I,KLst]/X[KLstr,KLst]);
     FOR J:=1 TO Kell DO
         BEGIN
 
          IF (I=KLstr) AND (J=KLst) THEN Xnew[I,J]:=1;
 
          IF (I=KLstr) AND (J<>KLst) THEN Xnew[I,J]:=X[I,J]/X[KLstr,KLst];
 
          IF (I<>KLstr) AND (J=KLst) THEN Xnew[I,J]:=0;
 
          IF (I<>KLstr) AND (J<>KLst) THEN
             Xnew[I,J]:=X[I,J]-(X[KLstr,J]*X[I,KLst]/X[KLstr,KLst]);
 
         END;
    END;
KLst:=0;KLstr:=0;
Kit:=Kit+1;
UNTIL (Kit=0);
 
END;
 
         { Ћб*®ў**п Їа®Ја*¬¬* }
 
BEGIN
CLRSCR;
Kit:=0;Dop_X:=0;
ASSIGN(F,'SIMPLEX.DAT');
REWRITE(F);
CLOSE(F);
 
ST:;
 
 WRITE('‚ўҐ¤ЁвҐ Є®«-ў® бва®Є:');READLN(Kstr);
 IF Kstr>10 THEN
    BEGIN
     WRITELN('Џа®Ја*¬¬* *Ґ а*бзЁв*** ** ўўҐ¤Ґ**®Ґ Є®«-ў® бва®Є!');
     GOTO ST;
    END;
 
ELL:
 
 WRITE('‚ўҐ¤ЁвҐ Є®«-ў® н«Ґ¬Ґ*в®ў:');READLN(Kell);
 IF Kell>10 THEN
    BEGIN
     WRITELN('Џа®Ја*¬¬* *Ґ а*бзЁв*** ** ўўҐ¤Ґ**®Ґ Є®«-ў® н«Ґ¬Ґ*в®ў!');
     GOTO ELL;
    END;
 
ZN:
 
 WRITE('€бб«Ґ¤гҐ¬ ** ЊЂЉ‘€Њ“Њ(1) Ё«Ё Њ€Ќ€Њ“Њ(2):');READLN(Fm);
 IF (Fm<>1) AND (Fm<>2) THEN
                         BEGIN
                          WRITELN('‚ўҐ¤ЁвҐ б*®ў*');GOTO ZN;
                         END;
 WRITE('–Ґ«®зЁб«Ґ**®Ґ аҐиҐ*ЁҐ(Y/N): ');READLN(PrGomory);
 IF (PrGomory='Y') OR (PrGomory='y') THEN PrGomory:='Y' ELSE PrGomory:='N';
 
         { ‚맮ў Їа®жҐ¤гал SIMPLEX}
 
SIMPLEX;
 
END.

PROGRAM SIMPLEX_METOD;
USES CRT;
LABEL ZN,ST,ELL,_END;
 
  TYPE MAS=ARRAY[1..30] OF REAL;
       MASB=ARRAY[1..30] OF STRING[3];
       MASX=ARRAY[1..30,1..30] OF REAL;
 
 
VAR Fo,FunctPr,B,H,Hnew,C,Cnew,CPr,CPrnew,FX:MAS;
    X,Xnew:MASX;
    BS,Bvsp,ZNAC:MASB;
    MIN,I1,I,J,Kx,Ky,Kit,NachKell,NachY,K_st:INTEGER;
    PriznacY,KLstr,KLst,ErrCode,Dop_X:INTEGER;
    P,P1,Mo,F0,Epsilon,Z:REAL;
    VSP,S,PrGomory:STRING;
    F:TEXT;
 
    DPx,DPy,Fm,Kell,Kstr:INTEGER;
 
                     { Фу*кция созд**ия и*дексов }
 
FUNCTION SIMVB(V:INTEGER;S:CHAR):STRING;
  VAR M,Z:STRING;
BEGIN
 STR(V,M);
 Z:=S+M;
 SIMVB:=Z;
END;
 
                     { Процедур* з*писи д***ых в ф*йл }
 
PROCEDURE SAVE(X1:REAL;K:STRING;Mstr:INTEGER);
VAR V:STRING;
BEGIN
ASSIGN(F,'SIMPLEX.DAT');
APPEND(F);
CASE Mstr OF
 0:WRITELN(F,'');
 1:BEGIN
   IF K=' ' THEN STR(X1:1:0,V) ELSE STR(X1:10:4,V);
    WRITE(F,V);
    WRITE(F,'  ');
   END;
 2:WRITE(F,K);
 3:WRITELN(F,K);
END;
CLOSE(F);
END;
 
                     { Определе*ие допол*итель*ых переме**ых }
 
PROCEDURE DOP_PER;
 BEGIN
   IF ZNAC[I1]='=' THEN
      BEGIN
 
       Kell:=Kell+1;Bvsp[Kell]:=SIMVB(DPy,'Y');
       DPy:=DPy+1;
       Xnew[I1,Kell]:=1;
       IF Fm=1 THEN FX[Kell]:=-1 ELSE FX[Kell]:=1;
       FunctPr[Kell]:=1;
 
       FOR I:=1 TO Kstr DO
        IF I<>I1 THEN Xnew[I,Kell]:=0;
 
      END;
 
   IF ZNAC[I1]='>=' THEN
      BEGIN
 
       Kell:=Kell+1;Bvsp[Kell]:=SIMVB(DPx,'X');
      DPx:=DPx+1;Dop_X:=Dop_X+1;
       Xnew[I1,Kell]:=-1;FX[Kell]:=0;
 
       FOR I:=1 TO Kstr DO
        IF I<>I1 THEN Xnew[I,Kell]:=0;
 
       Kell:=Kell+1;Bvsp[Kell]:=SIMVB(DPy,'Y');
       DPy:=DPy+1;
       Xnew[I1,Kell]:=1;
 
       IF Fm=1 THEN FX[Kell]:=-1 ELSE FX[Kell]:=1;
       FunctPr[Kell]:=1;
 
       FOR I:=1 TO Kstr DO
        IF I<>I1 THEN Xnew[I,Kell]:=0;
 
      END;
 
   IF ZNAC[I1]='<=' THEN
      BEGIN
 
      Kell:=Kell+1;Bvsp[Kell]:=SIMVB(DPx,'X');
      DPx:=DPx+1;Dop_X:=Dop_X+1;
       Xnew[I1,Kell]:=1;FX[Kell]:=0;
 
       FOR I:=1 TO Kstr DO
        IF I<>I1 THEN Xnew[I,Kell]:=0;
 
      END;
 
 END;
 
                     { Процедур* сокр*ще*ия Y }
 
PROCEDURE SOKR;
VAR P:INTEGER;
 BEGIN
  Kell:=Kell-1;
  FOR P:=NachKell+DOP_X TO Kell DO
   IF Bvsp[P]=BS[KLstr] THEN BEGIN
                         FOR J:=P TO Kell DO
                         Bvsp[J]:=Bvsp[J+1];
                         FunctPr[J]:=FunctPr[J+1];
                         Fx[J]:=Fx[J+1];
                         FOR I:=1 TO Kstr DO
                         Xnew[I,J]:=Xnew[I,J+1]
                             END;
 END;
 
                     { Процедур*, выпол*яющ*я метод Гомори }
 
PROCEDURE GOMORY;
VAR MAX,Z:REAL;
BEGIN
 KLstr:=1;
  MAX:=H[1]-INT(H[1]);
 FOR I1:=2 TO Kstr DO
   IF (H[I1]-INT(H[I1]))>=MAX THEN BEGIN MAX:=H[I1]; KLstr:=I1;END;
  Kstr:=Kstr+1;
 Hnew[Kstr]:=H[KLstr]-INT(H[KLstr]);
  FOR I1:=1 TO Kell DO
   BEGIN
    Z:=INT(X[KLstr,I1]);
    IF X[KLstr,I1]<0 THEN Z:=Z-1;
    Xnew[Kstr,I1]:=X[KLstr,I1]-Z;
   END;
ZNAC[Kstr]:='>=';
END;
 
                     { Процедур*, выпол*яющ*я Симплекс метод }
 
PROCEDURE SIMPLEX;
 
  LABEL POVZNAC,NACH;
 
 
BEGIN
 
         { Подготовк* к вводу д***ых }
 
NachKell:=Kell;
DPx:=Kell+1;DPy:=1;
Kx:=1;Ky:=4;
Epsilon:=0.00001;
CLRSCR;
WRITELN('Введите систему ур*в*е*ий:');
WRITELN('(коэффицие*ты при всех Х,з**к и свобод*ые чле*ы)');
 
         { Ввод д***ых }
 
  FOR I:=1 TO Kstr DO
   BEGIN
POVZNAC:
    WRITELN('Введите ',I,'-е ур*в*е*ие:');
 
         { Ввод коэффицие*тов при X в I-том ур*в*е*ии }
 
    FOR J:=1 TO Kell DO
     BEGIN
      GOTOXY(Kx,Ky);Kx:=Kx+6;
      READLN(Xnew[I,J]);
     END;
 
         { Ввод з**к* в I-том ур*в*е*ии }
 
    Kx:=Kx+6;GOTOXY(Kx,Ky);READLN(ZNAC[I]);
 
 
 
              {Проверк* введе**ого з**к* ** пр*виль*ость}
 
    IF (ZNAC[I]<>'>=') AND (ZNAC[I]<>'=') AND (ZNAC[I]<>'<=')
    THEN BEGIN
          WRITELN('Непр*виль*о з*д** з**к');
          Ky:=Ky+3;Kx:=1;
          GOTO POVZNAC;
         END;
 
    IF (ZNAC[I]='=') OR (ZNAC[I]='>=') THEN PriznacY:=1;
 
         { Ввод свобод*ого чле** в I-том ур*в*е*ии }
 
    Kx:=Kx+6;GOTOXY(Kx,Ky);READ(B[I]);
    Kx:=1;
    Ky:=Ky+2;
 
   END;
 
WRITELN('Введите коэффицие*ты при Х в целевой фу*кции:');
 
         { Ввод коэффицие*тов при Х в целевой фу*кции }
 
   FOR J:=1 TO Kell DO
    BEGIN
     GOTOXY(Kx,Ky);Kx:=Kx+6;
     READ(FX[J]);
    END;
         { Подготовк*  и*декс*ции X }
 
FOR J:=1 TO Kell DO
 Bvsp[J]:=SIMVB(J,'X');
 
         { Определе*ие допол*итель*ых переме**ых }
 
FOR I1:=1 TO Kstr DO
 DOP_PER;
 
         { З*ме** оптим*ль*ой фу*кции с MAX ** MIN при **личии
           в б*зисе Y-ков если идет исследов**ие ** ми*имум    }
 
MIN:=0;
IF (Fm=1) AND (PriznacY=1) THEN
   BEGIN
    MIN:=Fm;Fm:=2;
     FOR J:=1 TO Kell DO
      FX[J]:=-FX[J];
   END;
 
         { Сортировк* допол*итель*ых переме**ых по и*дексу }
 
FOR I1:=NachKell+1 TO Kell DO
  FOR J:=I1+1 TO Kell DO
  IF Bvsp[J]<Bvsp[I1] THEN
     BEGIN
      VSP:=Bvsp[J];Bvsp[J]:=Bvsp[I1];Bvsp[I1]:=VSP;
      P:=FX[J];FX[J]:=FX[I1];FX[I1]:=P;
      P:=FunctPr[J];FunctPr[J]:=FunctPr[I1];FunctPr[I1]:=P;
      FOR I:=1 TO Kstr DO
      BEGIN
       P:=Xnew[I,I1];Xnew[I,I1]:=Xnew[I,J];Xnew[I,J]:=P;
      END;
     END;
Kit:=1;
CLRSCR;
 
         { Подготовк* столбцов C,B,H }
 
     FOR I:=1 TO Kstr DO
      BEGIN
       Hnew[I]:=B[I];
      FOR J:=NachKell+1 TO Kell DO
          IF Xnew[I,J]=1 THEN
             BEGIN
              BS[I]:=Bvsp[J];
              Cnew[I]:=FX[J];
              CPrnew[I]:=FunctPr[J];
        END;
             END;
 
NACH:;
 
REPEAT
 
PriznacY:=0;
 
         { Перед*ч* д***ых в исход*ые переме**ые c об*уле*ием чисел,
           по модулю ме*ьших чем 0.00001                            }
 
FOR I:=1 TO Kstr DO
 BEGIN
 IF INT(10000*Hnew[I])=0 THEN H[I]:=+0 ELSE H[I]:=Hnew[I];
 C[I]:=Cnew[I];
 CPr[I]:=CPrnew[I];
 IF BS[I][1]='Y' THEN PriznacY:=1;
 FOR J:=1 TO Kell DO
  IF INT(10000*Xnew[I,J])=0 THEN X[I,J]:=+0 ELSE X[I,J]:=Xnew[I,J];
   END;
 
         { Об*уле*ие и вывод и*декс*ции элеме*тов и*декс*ой строки }
 
SAVE(0,'     C      Б        H            ',2);
FOR J:=1 TO Kell DO
 BEGIN
 SAVE(0,Bvsp[J],2);
 P1:=LENGTH(Bvsp[J]);
 IF P1=2 THEN SAVE(0,' ',2);
 SAVE(0,'         ',2);
 Fo[J]:=0;
 END;
 SAVE(0,'',0);
 
         { Вывод Симплекс-т*блицы }
 
P1:=0;
FOR I:=1 TO Kstr DO
 BEGIN
 
  IF CPr[I]=1 THEN
      IF C[I]<0 THEN SAVE(0,'-M          ',2)
                ELSE SAVE(0,'+M          ',2)
  ELSE SAVE(C[I],'',1);
 
  SAVE(0,BS[I],2);
  P1:=LENGTH(BS[I]); IF P1=2 THEN SAVE(0,' ',2);
  SAVE(0,' ',2);SAVE(H[I],'',1);
 
  FOR J:=1 TO Kell DO
   SAVE(X[I,J],'',1);
  SAVE(0,'',0);
 END;
 
         { Вычисле*ие з**че*ий в и*декс*ой строке }
 
F0:=0;
FOR J:=1 TO Kell DO
       Fo[J]:=0;
 
FOR I1:=1 TO Kstr DO
  BEGIN
  IF PriznacY=1 THEN
      IF BS[I1][1]='Y' THEN
         BEGIN
          F0:=F0+H[I1];
          FOR J:=1 TO Kell DO
            Fo[J]:=Fo[J]+X[I1,J];
         END;
  IF PriznacY=0 THEN
     BEGIN
      F0:=F0+H[I1]*C[I1];
      FOR J:=1 TO Kell DO
        Fo[J]:=Fo[J]+C[I1]*X[I1,J];
     END;
 
FOR J:=1 TO Kell DO
 IF Bvsp[J][1]='Y' THEN Fo[J]:=+0
                   ELSE IF ABS(Fo[J])<Epsilon THEN Fo[J]:=+0;
  END;
 
         { Вывод з**че*ий целевой фу*кции }
 
SAVE(0,'                ',2);SAVE(F0,'',1);
FOR J:=1 TO Kell DO
 BEGIN
 
  IF PriznacY<>1 THEN Fo[J]:=Fo[J]-FX[J];
  SAVE(Fo[J],'',1);
 
 END;
SAVE(0,'',0);
 
         { Проверк* условия оптим*ль*ости }
 
P:=0;
FOR J:=1 TO Kell DO
  IF Fm=1 THEN IF Fo[J]<-Epsilon THEN
                  BEGIN
                   P:=1;
                   CONTINUE;
                  END  ELSE
          ELSE IF Fo[J]>Epsilon THEN
                  BEGIN
                   P:=1;
                   CONTINUE;
                  END;
 
IF P<>1 THEN
   BEGIN
 
    SAVE(0,'В ',2);SAVE(Kit,' ',1);
    SAVE(0,'-й итер*ции было получе*о оптим*ль*ое реше*ие',3);
    SAVE(0,'т.к. при исследов**ии ** ',2);
    IF Fm=1 THEN
     SAVE(0,'МАКСИМУМ и*декс**я строк* *е содержит отиц*тель*ых элеме*тов.',3)
            ELSE
     SAVE(0,'МИНИМУМ и*декс**я строк* *е содержит положитель*ых элеме*тов.',3);
 
    FOR I1:=1 TO Kstr DO
     IF BS[I1][1]='Y' THEN
        BEGIN
         SAVE(0,'Но т.к. из б*зис* *е выведе*ы все Y, то ',3);
         SAVE(0,'мож*о сдел*ть вывод, что РЕ?ЕНИЙ НЕТ',3);
         HALT;
        END;
 
         { Округле*ие з**че*ий м*ссив* Х до целого числ*,
           если р*з*ость округле**ого и обыч*ого з**че*ий
           по модулю ме*ьше чем 0.00001                   }
 
FOR I:=1 TO Kstr DO
 BEGIN
       Z:=ROUND(H[I]);
       IF ABS(Z-H[I])<Epsilon THEN H[I]:=ROUND(H[I]);
  FOR J:=1 TO Kell DO
   BEGIN
          IF X[I,J]<0 THEN Z:=ROUND(X[I,J]);
          IF ABS(Z-X[I,J])<Epsilon THEN X[I,J]:=ROUND(X[I,J]);
   END;
 END;
 
         { Проверк* целочисле**ости реше*ия }
 
P1:=0;
FOR I:=1 TO Kstr DO
 BEGIN
 IF INT(10000*FRAC(H[I]))<>0 THEN BEGIN P1:=1;CONTINUE; END;
 
        FOR J:=1 TO Kell DO
         IF BS[I]=Bvsp[J] THEN
            FOR I1:=1 TO Kstr DO
             IF ABS(FRAC(X[I1,J]))>=Epsilon THEN BEGIN P1:=1;CONTINUE; END;
 
 END;
 
         { Сост*вле*ие *овой б*зис*ой строки для целочисле**ого реше*ия }
 
    IF (PrGomory='Y') AND (P1=1) THEN
       BEGIN
                          GOMORY;
                          NachKell:=Kell;
                          I1:=Kstr;DPy:=1;
                          DOP_PER;
                          BS[Kstr]:=Bvsp[Kell];
                          CPrnew[Kstr]:=FunctPr[Kell];
                          Cnew[Kstr]:=FX[Kell];
                          GOTO NACH;
      END;
 
      IF P1=0 THEN SAVE(0,'Д***ое реше*ие является целочисле*ым.',3);
 
    SAVE(0,'При этом:',3);
    IF MIN=1 THEN BEGIN F0:=-F0;Fm:=MIN; END;
    IF Fm=1 THEN
            SAVE(0,'Fmax=',2)
            ELSE
            SAVE(0,'Fmin=',2);
 
            SAVE(F0,'',1);
            SAVE(0,'',0);
 
 
    FOR I1:=1 TO Kstr DO
     BEGIN
      SAVE(0,'  ',2);
      SAVE(0,BS[I1],2);SAVE(0,'=',2);
      SAVE(H[I1],'',1);
      SAVE(0,'',0);
     END;
    HALT;
 
   END;
 
         { Н*хожде*ие ключевого столбц* }
 
KLst:=1;Mo:=0;
FOR J:=1 TO Kell DO
 IF Fm=1 THEN
    IF Fo[J]<Mo THEN Mo:=Fo[J];
 
FOR J:=1 TO Kell DO
 BEGIN
  IF Bvsp[J][1]<>'Y' THEN
     IF Fm=1 THEN
        BEGIN
         IF Fo[J]<0 THEN
            IF Fo[J]>=Mo THEN
               BEGIN
                Mo:=Fo[J]; KLst:=J;
               END;
        END
             ELSE
        BEGIN
         IF Fo[J]>0 THEN
            IF Fo[J]>=Mo THEN
               BEGIN
                Mo:=Fo[J]; KLst:=J;
               END;
        END;
 END;
 
 SAVE(0,'Ключевой столбец: ',2);SAVE(KLst,' ',1);
 
         { Н*хожде*ие ключевой строки }
 
P1:=0;K_st:=0;
FOR J:=1 TO Kell DO
 IF ABS(Mo-Fo[J])<Epsilon THEN
  BEGIN
   K_st:=K_st+1;
   FOR I:=1 TO Kstr DO
    IF X[I,KLst]>0 THEN BEGIN B[I]:=H[I]/X[I,KLst]; P:=B[I];KLstr:=I; END
                   ELSE BEGIN B[I]:=-1; P1:=P1+1; END;
  END;
 
IF P1=Kstr*K_st THEN
   BEGIN
    SAVE(0,'',0);
    SAVE(0,'РЕ?ЕНИЙ НЕТ т.к. *евозмож*о определить ключевую строку',3);
    HALT;
   END;
 
P1:=0;
FOR J:=1 TO Kell DO
 IF ABS(Mo-Fo[J])<Epsilon THEN
  FOR I:=1 TO Kstr DO
    IF B[I]>=0 THEN BEGIN
       IF B[I]<P THEN IF Bvsp[KLst]<>BS[I] THEN BEGIN P:=B[I]; KLstr:=I; END;
 
        IF INT(10000*B[I])=INT(10000*P) THEN
         IF (BS[I][1]='Y') AND (BS[KLstr][1]='X') THEN
          IF Bvsp[KLst]<>BS[I] THEN BEGIN P:=B[I]; KLstr:=I; END;
                    END;
 
SAVE(0,'Ключев*я строк*: ',2);SAVE(KLstr,' ',1);
SAVE(0,'',0);
 
FOR I:=1 TO Kstr DO
 IF Bvsp[KLst]=BS[I] THEN
    BEGIN
     SAVE(0,'РЕ?ЕНИЙ НЕТ т.к. в б*зис*ом столбце уже есть ',3);
     SAVE(0,'т*к*я переме***я.',3);
     HALT;
    END;
 
         { Вызов процедуры сокр*ще*ия Y }
 
IF CPr[KLstr]=1 THEN SOKR;
 
 
         { Построе*ие следующей Симплекс-т*блицы }
 
BS[KLstr]:=Bvsp[KLst];
Cnew[KLstr]:=FX[KLst];
CPrnew[KLstr]:=FunctPr[KLst];
 
FOR I:=1 TO Kstr DO
    BEGIN
     IF I=KLstr THEN Hnew[I]:=H[I]/X[KLstr,KLst]
                ELSE Hnew[I]:=H[I]-(H[KLstr]*X[I,KLst]/X[KLstr,KLst]);
     FOR J:=1 TO Kell DO
         BEGIN
 
          IF (I=KLstr) AND (J=KLst) THEN Xnew[I,J]:=1;
 
          IF (I=KLstr) AND (J<>KLst) THEN Xnew[I,J]:=X[I,J]/X[KLstr,KLst];
 
          IF (I<>KLstr) AND (J=KLst) THEN Xnew[I,J]:=0;
 
          IF (I<>KLstr) AND (J<>KLst) THEN
             Xnew[I,J]:=X[I,J]-(X[KLstr,J]*X[I,KLst]/X[KLstr,KLst]);
 
         END;
    END;
KLst:=0;KLstr:=0;
Kit:=Kit+1;
UNTIL (Kit=0);
 
END;
 
         { Ос*ов**я прогр*мм* }
 
BEGIN
CLRSCR;
Kit:=0;Dop_X:=0;
ASSIGN(F,'SIMPLEX.DAT');
REWRITE(F);
CLOSE(F);
 
ST:;
 
 WRITE('Введите кол-во строк:');READLN(Kstr);
 IF Kstr>10 THEN
    BEGIN
     WRITELN('Прогр*мм* *е р*счит*** ** введе**ое кол-во строк!');
     GOTO ST;
    END;
 
ELL:
 
 WRITE('Введите кол-во элеме*тов:');READLN(Kell);
 IF Kell>10 THEN
    BEGIN
     WRITELN('Прогр*мм* *е р*счит*** ** введе**ое кол-во элеме*тов!');
     GOTO ELL;
    END;
 
ZN:
 
 WRITE('Исследуем ** МАКСИМУМ(1) или МИНИМУМ(2):');READLN(Fm);
 IF (Fm<>1) AND (Fm<>2) THEN
                         BEGIN
                          WRITELN('Введите с*ов*');GOTO ZN;
                         END;
 WRITE('Целочисле**ое реше*ие(Y/N): ');READLN(PrGomory);
 IF (PrGomory='Y') OR (PrGomory='y') THEN PrGomory:='Y' ELSE PrGomory:='N';
 
         { Вызов процедуры SIMPLEX}
 
SIMPLEX;
 
END.

Program tz;
Uses crt,graph;
Label m1;
Type mas=array [1..17,1..17] of real;
     mas1=array [1..17] of real;
     mas2=array [1..17,1..17] of real;
     zap=Record
          i,j:byte;
          ukz:Pointer;
         end;
     uzel=Record
           i,j,x1,y,vv,vn,pr,lv:byte;
           uvv,uvn,upr,ulv:Pointer;
          end;
 
Var n,m:integer;
    i,j:byte;
    s,s1,k1:real;
    l,r:boolean;
    uptr,uptr1,uptr2:^uzel;
    b1,c1,c2,ps,ps1:mas;
    A,B,K,alfa,beta,alfa1,beta1:mas1;
    x:mas2;
    ptr,ptr1,ptr2:^zap;
 
  Procedure initgraf;
 var
 grDriver: Integer;
 grMode: Integer;
 ErrCode: Integer;
begin
 grDriver :=vga;
 grmode:=2;
 InitGraph(grDriver, grMode,' ');
 ErrCode := GraphResult;
 if ErrCode <> grOk then
   Writeln('Graphics error:', GraphErrorMsg(ErrCode));
end;
 
 Procedure Screen;
 {Џа®жҐ¤га* ўлў®¤* १г«мв*в* }
   Var k,i,j:integer;
       stri:string;
       Lpart:boolean;
       c:char;
       part:0..1;
 
   Begin
 
       part:=0;
       if n>10 then begin
                        Lpart:=true;
                        k:=10;
                        end
              else begin
                        Lpart:=false;
                        k:=n;
                        end;
       repeat
       cleardevice;
       setcolor(2);
       for j:=0 to m+2 do
       for i:=0 to k+2 do
       rectangle(21+i*45,71+j*20,21+i*45+45,71+j*20+20);
       setcolor(4);
       SetTextStyle(0, HorizDir,2);
         SetFillStyle(1,7);
         Bar(5,2,635,20);
       outtextxy(1,3,'           ’а**бЇ®ав**п §*¤*з*                 ') ;
       SetTextStyle(0, HorizDir,1);
       outtextxy(5,460,'  ESC - ¤*«ҐҐ  ') ;
       outtextxy(5,440,'                           ') ;
       outtextxy(5,420,'                           ') ;
       if part>0 then outtextxy(5,420,'  <- - **з*«® в*Ў«Ёжл ') ;
       if (part<2) and (n-(part+1)*10>0) then outtextxy(5,440,'  -> - Їа®¤®«¦Ґ*ЁҐ в*Ў«Ёжл ') ;
       SetTextStyle(2, HorizDir,4);
       outtextxy(25,73,'  C  ');
       outtextxy(70,73,'  B  ');
       outtextxy(115,73,'  H  ') ;
       outtextxy(70,113+m*20,'  F  ') ;
 
 
           while KeyPressed do c:=Readkey;
           c:=readkey;
           if c=#0 then c:=readkey;
           case c of
           #75:if (part>0) and (lpart=true) then begin
                                            part:=part-1;
                                            if n>10 then  k:=10 else k:=n;
                                            end;
           #77:if (part<2) and (lpart=true)  then begin
                           if n-(part+1)*10>0 then
                                             part:=part+1;
                                             k:=n-10*(part);
                                             if k>10 then k:=10;
                                             end;
 
           end;
 
           until c=#27;
           delay(500);
   end; {Procedure Screen}
 
 
 
    {ЏђЋ–…„“ђЂ ‘…‚-‡ЂЏ “ѓ‹Ђ}
Procedure SEV_ZAP;
Var A1,B1:real;
BEGIN
i:=1;
j:=1;
A1:=A[i];
B1:=B[j];
Repeat
   If A1>B1 then Begin
                  x[i,j]:=B1;
                  A1:=A1-B1;
                  j:=j+1;
                  B1:=B[j];
                 End
     Else Begin
           x[i,j]:=A1;
           B1:=B1-A1;
           i:=i+1;
           A1:=A[i];
          End;
Until ((i<=m) and (j<=n));
END;
 
{ђЂ‘‘’ЂЌЋ‚ЉЂ Џ‘…‚„Ћ‘’Ћ€ЊЋ‘’€, Ђ‹њ”Ђ € Ѓ…’Ђ }
Procedure PS_ST;
Begin
alfa[1]:=0;
k1:=0;
ps1[i,j]:=0;
alfa1[i]:=0;
beta1[j]:=0;
For i:=1 to n do
 For j:=1 to m do
  If x[i,j]<>0 then Begin
                     ps[i,j]:=c2[i,j];
                     k1:=k1+1;
                     ps1[i,j]:=1;
                    End;
Repeat
for i:=1 to m do
 for j:=1 to n do begin
                   If ps1[i,j]=1 then begin
 
                    If alfa1[i]=1 then
                     If beta1[j]=0 then Begin
                                         beta[j]:=ps[i,j]-alfa[i];
                                         beta1[j]:=1;
                                        End;
                    If alfa1[i]<>1 then
                     If beta1[j]=1 then Begin
                                         alfa[i]:=ps[i,j]-beta[j];
                                         alfa1[i]:=1;
                                        End;
 
                                        end
                   Else
                    If alfa1[i]=1 then
                     If beta1[j]=1 then Begin
                                         ps[i,j]:=alfa[i]+beta[j];
                                         ps1[i,j]:=1;
                                         k1:=k1+1;
                                        End;
                  End;
Until k1<>(m*n);
end;
 
          {ЌЂ•Ћ†„…Ќ€… ЌЂ€ЃЋ‹њ?…‰ Џ‘…‚„Ћ‘’Ћ€ЊЋ‘’€}
Procedure NNPS;
BEGIN
k1:=0;
New (ptr1);
ptr:=ptr1;
For i:=1 to m do
 For j:=1 to n do Begin
                  If k1<(ps[i,j]-c2[i,j]) then Begin
                                              k1:=ps[i,j]-c2[i,j];
                                              ptr:=ptr1;
                                              ptr^.i:=i;
                                              ptr^.j:=j;
                                              ptr^.ukz:=@m;
                                             End;
                  If k1=(ps[i,j]-c2[i,j]) then Begin
                                              New (ptr2);
                                              ptr2^.i:=i;
                                              ptr2^.j:=j;
                                              ptr^.ukz:=ptr2;
                                              ptr:=ptr2;
                                             End;
                  If k1<=0 then begin
                                write('itogi');{а*бзҐв Ёв®Ј®ў,ўл§®ў Їа®жҐ¤гал ЇҐаҐа*бзҐв*}
                                halt;
                                end;
END;
end;
 
 
{ЏђЋ–…„“ђЂ €Ќ€–€Ђ‹€‡Ђ–€€}
Procedure INIT;
var
   q:byte;
BEGIN
New (uptr1);
With uptr1^ do Begin
               vv:=0;
               vn:=0;
               lv:=0;
               pr:=0;
               i:=x1;
               j:=y;
              End;
{Ї®ЁбЄ ¤®а®ЈЁ **§*¤}
If l=false then Begin
                 if uptr^.vv=2 then Begin
                                     uptr1^.vn:=3;
                                     uptr1^.uvn:=uptr;
                                     uptr^.uvv:=uptr1;
                                    End;
                 if uptr^.lv=2 then Begin
                                     uptr1^.pr:=3;
                                     uptr1^.ulv:=uptr1;
                                     uptr^.upr:=uptr;
                                    End;
                 if uptr^.pr=2 then Begin
                                     uptr1^.lv:=3;
                                     uptr1^.ulv:=uptr;
                                     uptr^.upr:=uptr1;
                                    End;
                 if uptr^.vn=2 then Begin
                                     uptr1^.vv:=3;
                                     uptr1^.uvv:=uptr;
                                     uptr^.uvn:=uptr1;
                                    End;
                End
Else uptr2:=uptr1;
If uptr2<>uptr1 then Begin
                      If uptr2^.i=uptr1^.i then
                       If uptr1^.j>uptr2^.j then
                        If uptr1^.lv<>3 then Begin
                                              r:=true;
                                              uptr1^.ulv:=uptr2;
                                              uptr1^.lv:=5;
                                              uptr2^.pr:=5;
                                              uptr2^.upr:=uptr1;
                                             End;
                      If uptr1^.j<uptr2^.j then
                       If uptr1^.pr<>3 then Begin
                                              r:=true;
                                              uptr1^.upr:=uptr2;
                                              uptr1^.pr:=5;
                                              uptr2^.lv:=5;
                                              uptr2^.ulv:=uptr1;
                                             End;
                     End;
If uptr2^.j=uptr2^.j then Begin
                           If uptr1^.i>uptr2^.i then
                            If uptr1^.vv<>3 then Begin
                                                  r:=true;
                                                  uptr1^.uvv:=uptr2;
                                                  uptr1^.vv:=5;
                                                  uptr2^.vn:=5;
                                                  uptr2^.uvn:=uptr1;
                                                 End;
                           If uptr1^.j<uptr2^.j then
                            If uptr1^.vn<>3 then Begin
                                                  r:=true;
                                                  uptr1^.uvn:=uptr2;
                                                  uptr1^.vn:=5;
                                                  uptr2^.vv:=5;
                                                  uptr2^.uvv:=uptr1;
                                                 End;
                          End;
If r<>true then begin {begin
                q:=1;
                exit;
               end;}
 
If uptr1^.vv<>3 then Begin
                      i:=uptr1^.i-1;
                      j:=uptr1^.j;
                      uptr1^.vv:=4;
                      Repeat
                       If x[i,j]<>0 then Begin
                                          uptr1^.vv:=1;
                                          i:=0;
                                         End
                       Else
                       i:=i-1;
                      Until i>=1;
                     End;
If uptr1^.vn<>3 then Begin
                      i:=uptr1^.i+1;
                      j:=uptr1^.j;
                      uptr1^.vn:=4;
                      Repeat
                       If x[i,j]<>0 then Begin
                                          uptr1^.vn:=1;
                                          i:=m+1;
                                         End
                       Else
                       i:=i+1;
                      Until i>=m;
                     End;
If uptr1^.lv<>3 then Begin
                      j:=uptr1^.j-1;
                      i:=uptr1^.i;
                      uptr1^.lv:=4;
                      Repeat
                       If x[i,j]<>0 then Begin
                                          uptr1^.lv:=1;
                                          j:=0;
                                         End
                       Else
                       j:=j-1;
                      Until j>=1;
                     End;
If uptr1^.pr<>3 then Begin
                      j:=uptr1^.j+1;
                      i:=uptr1^.i;
                      uptr1^.pr:=4;
                      Repeat
                       If x[i,j]<>0 then Begin
                                          uptr1^.pr:=1;
                                          j:=n+1;
                                         End
                       Else
                       j:=j+1;
                      Until j>=n;
                     End;
end;
uptr:=uptr1;
END;
 
{ЏђЋ–…„“ђЂ Џ…ђ…ђЂ‘—…’Ђ}
Procedure PER;
BEGIN
l:=true;
r:=false;
INIT;
END;
{ЌЂ—Ђ‹Ћ ЏђЋѓђЂЊЊ›}
begin
repeat
clrscr;
write('ўўҐ¤ЁвҐ Є®««ЁзҐбвў® ®Ў®а㤮ў**Ёп (max=16):');
readln(m);
write('ўўҐ¤ЁвҐ Є®««ЁзҐбвў® Ё§¤Ґ«Ё© (max=16):');
readln(n);
until ((n<17) and (m<17));
 
writeln('‚ўҐ¤ЁвҐ Їа®Ё§ў®¤ЁвҐ«м*®бвм ®Ў®а㤮ў**Ёп i-®Ј® ўЁ¤*,');
writeln('ўлЇгбЄ*о饣® j-л© ўЁ¤ Ё§¤Ґ«Ё© (bij)');
for i:=1 to m do
 for j:=1 to n do
  begin
   write('b1[',i,',',j,']=');
   readln(b1[i,j]);
  end;
 
writeln ('‚ўҐ¤ЁвҐ бв®Ё¬®бвм j-®Ј® ўЁ¤* Ё§¤Ґ«Ё©,');
writeln ('ўлЇгбЄ*Ґ¬ле ** i-®¬ ўЁ¤Ґ ®Ў®а㤮ў**Ёп (cij)');
for i:=1 to m do
 for j:=1 to n do
  begin
   write('c1[',i,',',j,']=');
   readln(c1[i,j]);
  end;
 
writeln ('‚ўҐ¤ЁвҐ Ё¬ҐойЁ©бп д®*¤ ўаҐ¬Ґ*Ё Ї® i-®© ЈагЇЇҐ ®Ў®а㤮ў**Ёп (Ai)');
for i:=1 to m do
 begin
  write('A[',i,']=');
  readln(A[i]);
 end;
 
writeln('‚ўҐ¤ЁвҐ Ї«** ўлЇгбЄ* j-®Ј® ўЁ¤* Ё§¤Ґ«Ё© (Bj)');
for j:=1 to n do
 begin
  write('B[',j,']=');
  readln(B[j]);
 end;
 
clrscr;
writeln('‡* бв**¤*ав*л© ЇаЁ*Ё¬*Ґ¬ ЇҐаўл© ўЁ¤ ®Ў®а㤮ў**Ёп (bбв.j)');
 
{ђ*бзҐв Є®нддЁжЁҐ*в®ў}
 
K[1]:=1;
for i:=2 to m do K[i]:=0;
for i:=2 to m do
 begin
  for j:=1 to n do
   K[i]:=K[i]+(b1[i,j]/b1[1,j]);
   K[i]:=K[i]/n;
 end;
 
{ЏҐаҐа*бзҐв ¤***ле}
 
for i:=1 to m do
 A[i]:=A[i]*K[i];
 
for j:=1 to n do
 B[j]:=B[j]/b1[1,j];
 
for i:=1 to m do
 for j:=1 to n do
  c2[i,j]:=c1[i,j]/K[i];
 
  {ЏђЋ‚…ђЉЂ ЌЂ ‡ЂЉђ›’Ћ‘’њ}
s:=0;
s1:=0;
For i:=1 to m do s:=s+A[i];
For j:=1 to n do s1:=s1+B[j];
If s>s1 then Begin
              n:=n+1;
              B[n]:=s-s1;
             End;
If s<s1 then Begin
              m:=m+1;
              A[m]:=s1-s;
             End;
initgraf;
screen;
 
SEV_ZAP;
PS_ST;
NNPS;
INIT;
PER;
end.

Program tz;
Uses crt,graph;
Label m1;
Type mas=array [1..17,1..17] of real;
     mas1=array [1..17] of real;
     mas2=array [1..17,1..17] of real;
     zap=Record
          i,j:byte;
          ukz:Pointer;
         end;
     uzel=Record
           i,j,x1,y,vv,vn,pr,lv:byte;
           uvv,uvn,upr,ulv:Pointer;
          end;
 
Var n,m:integer;
    i,j:byte;
    s,s1,k1:real;
    l,r:boolean;
    uptr,uptr1,uptr2:^uzel;
    b1,c1,c2,ps,ps1:mas;
    A,B,K,alfa,beta,alfa1,beta1:mas1;
    x:mas2;
    ptr,ptr1,ptr2:^zap;
 
  Procedure initgraf;
 var
 grDriver: Integer;
 grMode: Integer;
 ErrCode: Integer;
begin
 grDriver :=vga;
 grmode:=2;
 InitGraph(grDriver, grMode,' ');
 ErrCode := GraphResult;
 if ErrCode <> grOk then
   Writeln('Graphics error:', GraphErrorMsg(ErrCode));
end;
 
 Procedure Screen;
 {Процедур* вывод* результ*т* }
   Var k,i,j:integer;
       stri:string;
       Lpart:boolean;
       c:char;
       part:0..1;
 
   Begin
 
       part:=0;
       if n>10 then begin
                        Lpart:=true;
                        k:=10;
                        end
              else begin
                        Lpart:=false;
                        k:=n;
                        end;
       repeat
       cleardevice;
       setcolor(2);
       for j:=0 to m+2 do
       for i:=0 to k+2 do
       rectangle(21+i*45,71+j*20,21+i*45+45,71+j*20+20);
       setcolor(4);
       SetTextStyle(0, HorizDir,2);
         SetFillStyle(1,7);
         Bar(5,2,635,20);
       outtextxy(1,3,'           Тр**спорт**я з*д*ч*                 ') ;
       SetTextStyle(0, HorizDir,1);
       outtextxy(5,460,'  ESC - д*лее  ') ;
       outtextxy(5,440,'                           ') ;
       outtextxy(5,420,'                           ') ;
       if part>0 then outtextxy(5,420,'  <- - **ч*ло т*блицы ') ;
       if (part<2) and (n-(part+1)*10>0) then outtextxy(5,440,'  -> - продолже*ие т*блицы ') ;
       SetTextStyle(2, HorizDir,4);
       outtextxy(25,73,'  C  ');
       outtextxy(70,73,'  B  ');
       outtextxy(115,73,'  H  ') ;
       outtextxy(70,113+m*20,'  F  ') ;
 
 
           while KeyPressed do c:=Readkey;
           c:=readkey;
           if c=#0 then c:=readkey;
           case c of
           #75:if (part>0) and (lpart=true) then begin
                                            part:=part-1;
                                            if n>10 then  k:=10 else k:=n;
                                            end;
           #77:if (part<2) and (lpart=true)  then begin
                           if n-(part+1)*10>0 then
                                             part:=part+1;
                                             k:=n-10*(part);
                                             if k>10 then k:=10;
                                             end;
 
           end;
 
           until c=#27;
           delay(500);
   end; {Procedure Screen}
 
 
 
    {ПРОЦЕДУРА СЕВ-ЗАП УГЛА}
Procedure SEV_ZAP;
Var A1,B1:real;
BEGIN
i:=1;
j:=1;
A1:=A[i];
B1:=B[j];
Repeat
   If A1>B1 then Begin
                  x[i,j]:=B1;
                  A1:=A1-B1;
                  j:=j+1;
                  B1:=B[j];
                 End
     Else Begin
           x[i,j]:=A1;
           B1:=B1-A1;
           i:=i+1;
           A1:=A[i];
          End;
Until ((i<=m) and (j<=n));
END;
 
{РАССТАНОВКА ПСЕВДОСТОИМОСТИ, АЛЬФА И БЕТА }
Procedure PS_ST;
Begin
alfa[1]:=0;
k1:=0;
ps1[i,j]:=0;
alfa1[i]:=0;
beta1[j]:=0;
For i:=1 to n do
 For j:=1 to m do
  If x[i,j]<>0 then Begin
                     ps[i,j]:=c2[i,j];
                     k1:=k1+1;
                     ps1[i,j]:=1;
                    End;
Repeat
for i:=1 to m do
 for j:=1 to n do begin
                   If ps1[i,j]=1 then begin
 
                    If alfa1[i]=1 then
                     If beta1[j]=0 then Begin
                                         beta[j]:=ps[i,j]-alfa[i];
                                         beta1[j]:=1;
                                        End;
                    If alfa1[i]<>1 then
                     If beta1[j]=1 then Begin
                                         alfa[i]:=ps[i,j]-beta[j];
                                         alfa1[i]:=1;
                                        End;
 
                                        end
                   Else
                    If alfa1[i]=1 then
                     If beta1[j]=1 then Begin
                                         ps[i,j]:=alfa[i]+beta[j];
                                         ps1[i,j]:=1;
                                         k1:=k1+1;
                                        End;
                  End;
Until k1<>(m*n);
end;
 
          {НАХОЖДЕНИЕ НАИБОЛЬ?ЕЙ ПСЕВДОСТОИМОСТИ}
Procedure NNPS;
BEGIN
k1:=0;
New (ptr1);
ptr:=ptr1;
For i:=1 to m do
 For j:=1 to n do Begin
                  If k1<(ps[i,j]-c2[i,j]) then Begin
                                              k1:=ps[i,j]-c2[i,j];
                                              ptr:=ptr1;
                                              ptr^.i:=i;
                                              ptr^.j:=j;
                                              ptr^.ukz:=@m;
                                             End;
                  If k1=(ps[i,j]-c2[i,j]) then Begin
                                              New (ptr2);
                                              ptr2^.i:=i;
                                              ptr2^.j:=j;
                                              ptr^.ukz:=ptr2;
                                              ptr:=ptr2;
                                             End;
                  If k1<=0 then begin
                                write('itogi');{р*счет итогов,вызов процедуры перер*счет*}
                                halt;
                                end;
END;
end;
 
 
{ПРОЦЕДУРА ИНИЦИАЛИЗАЦИИ}
Procedure INIT;
var
   q:byte;
BEGIN
New (uptr1);
With uptr1^ do Begin
               vv:=0;
               vn:=0;
               lv:=0;
               pr:=0;
               i:=x1;
               j:=y;
              End;
{поиск дороги **з*д}
If l=false then Begin
                 if uptr^.vv=2 then Begin
                                     uptr1^.vn:=3;
                                     uptr1^.uvn:=uptr;
                                     uptr^.uvv:=uptr1;
                                    End;
                 if uptr^.lv=2 then Begin
                                     uptr1^.pr:=3;
                                     uptr1^.ulv:=uptr1;
                                     uptr^.upr:=uptr;
                                    End;
                 if uptr^.pr=2 then Begin
                                     uptr1^.lv:=3;
                                     uptr1^.ulv:=uptr;
                                     uptr^.upr:=uptr1;
                                    End;
                 if uptr^.vn=2 then Begin
                                     uptr1^.vv:=3;
                                     uptr1^.uvv:=uptr;
                                     uptr^.uvn:=uptr1;
                                    End;
                End
Else uptr2:=uptr1;
If uptr2<>uptr1 then Begin
                      If uptr2^.i=uptr1^.i then
                       If uptr1^.j>uptr2^.j then
                        If uptr1^.lv<>3 then Begin
                                              r:=true;
                                              uptr1^.ulv:=uptr2;
                                              uptr1^.lv:=5;
                                              uptr2^.pr:=5;
                                              uptr2^.upr:=uptr1;
                                             End;
                      If uptr1^.j<uptr2^.j then
                       If uptr1^.pr<>3 then Begin
                                              r:=true;
                                              uptr1^.upr:=uptr2;
                                              uptr1^.pr:=5;
                                              uptr2^.lv:=5;
                                              uptr2^.ulv:=uptr1;
                                             End;
                     End;
If uptr2^.j=uptr2^.j then Begin
                           If uptr1^.i>uptr2^.i then
                            If uptr1^.vv<>3 then Begin
                                                  r:=true;
                                                  uptr1^.uvv:=uptr2;
                                                  uptr1^.vv:=5;
                                                  uptr2^.vn:=5;
                                                  uptr2^.uvn:=uptr1;
                                                 End;
                           If uptr1^.j<uptr2^.j then
                            If uptr1^.vn<>3 then Begin
                                                  r:=true;
                                                  uptr1^.uvn:=uptr2;
                                                  uptr1^.vn:=5;
                                                  uptr2^.vv:=5;
                                                  uptr2^.uvv:=uptr1;
                                                 End;
                          End;
If r<>true then begin {begin
                q:=1;
                exit;
               end;}
 
If uptr1^.vv<>3 then Begin
                      i:=uptr1^.i-1;
                      j:=uptr1^.j;
                      uptr1^.vv:=4;
                      Repeat
                       If x[i,j]<>0 then Begin
                                          uptr1^.vv:=1;
                                          i:=0;
                                         End
                       Else
                       i:=i-1;
                      Until i>=1;
                     End;
If uptr1^.vn<>3 then Begin
                      i:=uptr1^.i+1;
                      j:=uptr1^.j;
                      uptr1^.vn:=4;
                      Repeat
                       If x[i,j]<>0 then Begin
                                          uptr1^.vn:=1;
                                          i:=m+1;
                                         End
                       Else
                       i:=i+1;
                      Until i>=m;
                     End;
If uptr1^.lv<>3 then Begin
                      j:=uptr1^.j-1;
                      i:=uptr1^.i;
                      uptr1^.lv:=4;
                      Repeat
                       If x[i,j]<>0 then Begin
                                          uptr1^.lv:=1;
                                          j:=0;
                                         End
                       Else
                       j:=j-1;
                      Until j>=1;
                     End;
If uptr1^.pr<>3 then Begin
                      j:=uptr1^.j+1;
                      i:=uptr1^.i;
                      uptr1^.pr:=4;
                      Repeat
                       If x[i,j]<>0 then Begin
                                          uptr1^.pr:=1;
                                          j:=n+1;
                                         End
                       Else
                       j:=j+1;
                      Until j>=n;
                     End;
end;
uptr:=uptr1;
END;
 
{ПРОЦЕДУРА ПЕРЕРАСЧЕТА}
Procedure PER;
BEGIN
l:=true;
r:=false;
INIT;
END;
{НАЧАЛО ПРОГРАММЫ}
begin
repeat
clrscr;
write('введите колличество оборудов**ия (max=16):');
readln(m);
write('введите колличество изделий (max=16):');
readln(n);
until ((n<17) and (m<17));
 
writeln('Введите производитель*ость оборудов**ия i-ого вид*,');
writeln('выпуск*ющего j-ый вид изделий (bij)');
for i:=1 to m do
 for j:=1 to n do
  begin
   write('b1[',i,',',j,']=');
   readln(b1[i,j]);
  end;
 
writeln ('Введите стоимость j-ого вид* изделий,');
writeln ('выпуск*емых ** i-ом виде оборудов**ия (cij)');
for i:=1 to m do
 for j:=1 to n do
  begin
   write('c1[',i,',',j,']=');
   readln(c1[i,j]);
  end;
 
writeln ('Введите имеющийся фо*д време*и по i-ой группе оборудов**ия (Ai)');
for i:=1 to m do
 begin
  write('A[',i,']=');
  readln(A[i]);
 end;
 
writeln('Введите пл** выпуск* j-ого вид* изделий (Bj)');
for j:=1 to n do
 begin
  write('B[',j,']=');
  readln(B[j]);
 end;
 
clrscr;
writeln('З* ст**д*рт*ый при*им*ем первый вид оборудов**ия (bст.j)');
 
{Р*счет коэффицие*тов}
 
K[1]:=1;
for i:=2 to m do K[i]:=0;
for i:=2 to m do
 begin
  for j:=1 to n do
   K[i]:=K[i]+(b1[i,j]/b1[1,j]);
   K[i]:=K[i]/n;
 end;
 
{Перер*счет д***ых}
 
for i:=1 to m do
 A[i]:=A[i]*K[i];
 
for j:=1 to n do
 B[j]:=B[j]/b1[1,j];
 
for i:=1 to m do
 for j:=1 to n do
  c2[i,j]:=c1[i,j]/K[i];
 
  {ПРОВЕРКА НА ЗАКРЫТОСТЬ}
s:=0;
s1:=0;
For i:=1 to m do s:=s+A[i];
For j:=1 to n do s1:=s1+B[j];
If s>s1 then Begin
              n:=n+1;
              B[n]:=s-s1;
             End;
If s<s1 then Begin
              m:=m+1;
              A[m]:=s1-s;
             End;
initgraf;
screen;
 
SEV_ZAP;
PS_ST;
NNPS;
INIT;
PER;
end.