home *** CD-ROM | disk | FTP | other *** search
/ Turbo Toolbox / Turbo_Toolbox.iso / 1988 / 05 / gauss.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1988-02-17  |  9.8 KB  |  331 lines
  1. {$C+,U+}                           { Turbo Pascal Optionen }
  2. PROGRAM Gauss;
  3.  
  4. CONST   MAX   = 9;                    { maximale Dimension }
  5.         MAX1  = 10;                         { .. plus eins }
  6. TYPE    FIELD = ARRAY [0..MAX,0..MAX1] OF REAL;
  7.                                         {  Feld für Matrix }
  8.         F     = ARRAY [1..MAX] OF REAL;
  9. VAR     W     : FIELD;
  10.         X     : F;
  11.         M,C,L : INTEGER;
  12.         DRUCKER : BOOLEAN;      { Druckerprotokoll Ja/Nein }
  13.  
  14. PROCEDURE HALLO;
  15.  
  16. VAR       C  : INTEGER;
  17.           CH : CHAR;
  18.  
  19. BEGIN
  20.   ClrScr;
  21.   GotoXY(23,3); Write('Lineare Gleichungssysteme');
  22.   GotoXY(28,5); Write('Version 1.00');
  23.   FOR C:=20 TO 50 DO BEGIN
  24.     GotoXY(C,1); Write('─');
  25.     GotoXY(C,7); Write('─');
  26.   END;
  27.   FOR C:=1 TO 17 DO BEGIN
  28.     GotoXY(20,C); Write('│');
  29.     GotoXY(50,C); Write('│');
  30.   END;
  31.   GotoXY(23,15); Write('(C) Copyright 1987 by');
  32.   GotoXY(23,16); Write('    Carsten Bräutigam');
  33.   GotoXY(23,17); Write('& PASCAL INTERNATIONAL');
  34.   FOR C:=1 TO 80 DO BEGIN
  35.     GotoXY(C,20); Write('─');
  36.   END;
  37.   GotoXY(76,21); Write('cgb');
  38.   Read(CH);
  39. END;
  40.  
  41. PROCEDURE EINGABE
  42.     (VAR W:FIELD; VAR M:INTEGER; VAR DRUCKER:BOOLEAN);
  43.  
  44. VAR     C,D,
  45.         F,
  46.         CODE  : INTEGER;
  47.         MM    : CHAR;
  48.  
  49. BEGIN
  50.   ClrScr;
  51.   FOR F := 0 TO M+1 DO W[0,F] := 0;
  52.   GotoXY(2,1) ;
  53.   WriteLn('Lineare Gleichungssysteme ');
  54.   Write(' by Carsten Bräutigam & PASCAL INTERNATIONAL');
  55.   GotoXY(65,1); WriteLn('Drucker : OFF');
  56.   DRUCKER:=FALSE;                   { Druckerprotokoll aus }
  57.   FOR CODE:=1 TO 80 DO BEGIN
  58.     GotoXY(CODE,3);
  59.     Write('─');
  60.   END;
  61.   CODE:=0;
  62.   REPEAT
  63.     GotoXY(2,5); TEXTCOLOR(2);
  64.     Write ('Wieviele Variablen hat ihr System ? ');
  65.     Read(Kbd,MM);
  66.     IF MM=^D THEN BEGIN                       { Ctrl+D --> }
  67.       DRUCKER:=NOT DRUCKER;          { --> Drucker EIN/AUS }
  68.       IF DRUCKER THEN BEGIN
  69.         GotoXY(65,1);
  70.         Write('Drucker : ON ');        { Bildschirmausgabe }
  71.       END
  72.       ELSE BEGIN
  73.         GotoXY(65,1);
  74.         Write('Drucker : OFF');
  75.                        { Bildschirmausgabe DRUCKER : OFF   }
  76.       END;
  77.    END
  78.    ELSE
  79.      Val(MM,F,CODE);   { kein Ctrl-D --> also Zahlenangabe }
  80.   UNTIL (Ord(MM)>47) AND (Ord(MM)<58) AND (CODE=0);
  81.                             { richtige Zahlenangabe : 0..9 }
  82.   M:=F;                       { M = Dimension der Matrix   }
  83.   IF (M=0) OR (M>MAX) THEN BEGIN
  84.     ClrScr;
  85.     Halt;
  86.   END;
  87.   GotoXY(38,5); WriteLn(M);
  88.   GotoXY(2,7);
  89.   WriteLn('Bitte geben sie die Grundmatrix ein.');
  90.   FOR C:= 1 TO M DO BEGIN
  91.     GotoXY(C*5,9);
  92.     Write('X',C:1);
  93.   END;
  94.   GotoXY((M+1)*5,9); Write('Y');
  95.   FOR C:= 1 TO M DO BEGIN
  96.     GotoXY(2,C+10);
  97.     Write(C:1);
  98.   END;
  99.   FOR C:= 1 TO M DO BEGIN
  100.     FOR D:= 1 TO M+1 DO BEGIN
  101.       GotoXY(D*5,C+10);
  102.       Read(W[C,D]);
  103.     END;
  104.     WriteLn;
  105.   END;
  106. END;
  107.  
  108. PROCEDURE PRINT(VAR W:FIELD; VAR M:INTEGER);
  109.                           { Für Druckerprotokoll zuständig }
  110. VAR       C,F : INTEGER;
  111.  
  112. LABEL     99;
  113.  
  114. BEGIN
  115.   FOR C:= 1 TO M DO BEGIN
  116.     FOR F:= 1 TO M DO BEGIN
  117.       IF (W[C,F]=0) AND (F<C) THEN BEGIN
  118.         Write(Lst,'          ');
  119.         GOTO 99;       { nächster Durchlauf FOR - Schleife }
  120.       END;
  121.       IF W[C,F]>0 THEN Write(Lst,' +')
  122.       ELSE Write(Lst,' -');
  123.       Write(Lst,ABS(W[C,F]):6:3,'x',#27,#83,#1,F:1,#27,#84);
  124. 99:
  125.     END;
  126.     Write(Lst,' =');
  127.     IF W[C,M+1]>=0 THEN Write(Lst,' +')
  128.     ELSE Write(Lst,' -');
  129.     WriteLn(Lst,ABS(W[C,M+1]):6:3);
  130.   END;
  131.   WriteLn(Lst,'');
  132. END;
  133.  
  134. PROCEDURE Gauss(VAR W:FIELD; VAR M:INTEGER);
  135.  
  136. VAR     K,I,J,
  137.         L,C   : INTEGER;
  138.         U     : F;
  139.         Q     : ARRAY[1..MAX1] OF REAL;
  140.  
  141. BEGIN
  142.   K:=1;                        {     Arbeitszeile = 1      }
  143.   IF DRUCKER THEN BEGIN        { --> Druckerprotokoll ...  }
  144.     WriteLn(Lst,'Lineare Gleichungssysteme  Version 1.00');
  145.     Write(Lst,'(C) Copyright 1987 by Carsten Bräutigam');
  146.     WriteLn(Lst,' & PASCAL INTERNATIONAL ');
  147.     WriteLn(Lst);
  148.   END;
  149.   REPEAT
  150.     IF DRUCKER THEN PRINT(W,M);
  151.                              { Matrix auf Drucker ausgeben }
  152.     L:=K;                             {  L = Arbeitszeile  }
  153.     WHILE W[K,K] = 0 DO BEGIN
  154.                               { Wenn Pivotelemet gleich 0, }
  155.       L:=L+1;
  156.                         { nächste Zeile wird Arbeitszeile. }
  157.       IF L>M THEN Exit;
  158.                       { Wenn alle Zeilen durch, dann Ende, }
  159.  
  160.       FOR C:= 1 TO M+1 DO U[C]:=W[K,C];      { sonst beide }
  161.       W[K]:=W[L];                            { Zeilen      }
  162.       FOR C:= 1 TO M+1 DO W[L,C]:=U[C];      { tauschen    }
  163.     END;
  164.     FOR I:= K+1 TO M DO BEGIN
  165.       Q[I]:=W[I,K]/W[K,K];      { Quotienten bilden        }
  166.       W[I,K]:=0;                { Element der Pivotspalte  }
  167.       FOR J:= K+1 TO M+1 DO     { Null setzen.             }
  168.         W[I,J]:=W[I,J]-Q[I]*W[K,J];
  169.         { Multiplikation und Subtraktion durchführen.      }
  170.     END;
  171.     K:=K+1;                   { nächste Zeile Arbeitszeile }
  172.   UNTIL K>M-1;                  { bis zur vorletzten Zeile }
  173.                                 { Treppenform erreicht.    }
  174.   IF DRUCKER THEN PRINT(W,M);   { Endmatrix ausdrucken     }
  175. END;
  176.  
  177. FUNCTION SONDERLOESUNG(W:FIELD; M:INTEGER):INTEGER;
  178.  
  179. VAR       C,F,N,
  180.           V     : INTEGER;
  181.  
  182. BEGIN
  183.   SONDERLOESUNG:=0;                { 0 --> nur eine Lösung }
  184.   V:=0;
  185.   IF W[M,M]=0 THEN BEGIN
  186.     FOR C:= 1 TO M DO BEGIN
  187.       N:=0;
  188.       FOR F:= 1 TO M+1 DO
  189.         IF W[C,F]=0 THEN N:=N+1;      { Prüfung, ob alle   }
  190.                                       { Elemente der Zeile }
  191.       IF N=M+1 THEN V:=V+1;           { = Null - Nullzeile }
  192.     END;
  193.     IF V>0 THEN SONDERLOESUNG:=-V
  194.                     { negativ --> unendlich viele Lösungen }
  195.     ELSE SONDERLOESUNG:=2;
  196.                     { 2       --> keine Lösung             }
  197.   END;
  198. END;
  199.  
  200. PROCEDURE LOESUNG
  201.           (VAR W:FIELD; VAR M:INTEGER; VAR X:F; VAR L:INTEGER);
  202.  
  203. VAR     S     : REAL;
  204.         I,J,K,
  205.         A,B   : INTEGER;
  206.         V     : FIELD;
  207.  
  208. BEGIN
  209.   L := SONDERLOESUNG(W,M);
  210.   IF L<>2 THEN          { Es gibt eine/mehrere Lösung/en   }
  211.     IF L<0 THEN BEGIN   { Es gibt unendlich viele Lösungen }
  212.       A :=-L;           { Anzahl der Lösungsvariablen      }
  213.       B := 0;
  214.       FOR I := M DOWNTO M-A+1 DO BEGIN
  215.         FOR J  := 0 TO A DO V[J,I] := 0;
  216.       B      := Succ(B);
  217.       V[B,I] := 1;   { Initialisierung der Lösungsvariablen}
  218.     END;
  219.     FOR I := M-A DOWNTO 1 DO BEGIN
  220.                       { folgende Berechnung dient zum      }
  221.                       { Finden der Lösungsvektoren.        }
  222.       FOR K := 0 TO A DO BEGIN
  223.         V[K,I] := 0;
  224.         FOR J := I+1 TO M DO
  225.           V[K,I] := V[K,I] - W[I,J]*V[K,J]/W[I,I];
  226.       END;
  227.       V[0,I] := V[0,I] + W[I,M+1]/W[I,I];
  228.     END;
  229.     W := V;
  230.   END
  231.   ELSE BEGIN
  232.     X[M]:=W[M,M+1]/W[M,M];
  233.     FOR I:= M-1 DOWNTO 1 DO BEGIN
  234.       S:=0;
  235.       FOR J := 1 TO M-I DO S:=S+W[I,I+J]*X[I+J];
  236.       X[I]:=(1/W[I,I])*(W[I,M+1]-S);
  237.     END;
  238.   END;
  239. END;
  240.  
  241. PROCEDURE AUSGABE(VAR X:F; VAR W:FIELD;
  242.                   M:INTEGER; L:INTEGER; DRUCKER:BOOLEAN);
  243.  
  244. VAR     C,I,J : INTEGER;
  245.         CH     : CHAR;
  246.         A     : INTEGER;
  247.  
  248. BEGIN
  249.   A:=13+M;
  250.   IF L=2 THEN BEGIN                 { es gibt keine Lösung }
  251.     GotoXY(2,A);
  252.     WriteLn('Es gibt keine Lösung für dieses',
  253.             ' Gleichungssystem.');
  254.     IF DRUCKER THEN
  255.       WriteLn(Lst,'Es gibt keine Lösung für dieses',
  256.                   ' Gleichungssystem.');
  257.     Read(Kbd,CH); Exit;
  258.   END;
  259.   IF L<0 THEN BEGIN
  260.                    {  es gibt unendlich viele Lösungen mit }
  261.                    {  -L Lösungsvariablen                  }
  262.     GotoXY(2,A); WriteLn('Die Lösungsmenge lautet :');
  263.     WriteLn;  Write('               ');
  264.     IF DRUCKER THEN BEGIN
  265.       WriteLn(Lst,'Die Lösung lautet :');
  266.       WriteLn(Lst);  Write(Lst,'               ');
  267.     END;
  268.     FOR I := 0 TO -L DO BEGIN
  269.       Write('┌',W[I,1]:7:3,'┐     ');
  270.       IF DRUCKER THEN Write(Lst,'┌',W[I,1]:7:3,'┐     ');
  271.     END;
  272.     WriteLn;
  273.     Write(' L = { X │ X = ');
  274.     IF DRUCKER THEN BEGIN
  275.       WriteLn(Lst);
  276.       Write(Lst,' L = { X │ X = ');
  277.     END;
  278.     FOR I := 0 TO -L-1 DO BEGIN
  279.       Write('│',W[I,2]:7:3,'│',' + ',Chr(114+I),' ');
  280.       IF DRUCKER THEN
  281.         Write(Lst,'│',W[I,2]:7:3,'│',' + ',Chr(114+I),' ');
  282.     END;
  283.     WriteLn('│',W[-L,2]:7:3,'│');
  284.     IF DRUCKER THEN WriteLn(Lst,'│',W[-L,2]:7:3,'│');
  285.     FOR I := 3 TO M-1 DO BEGIN
  286.       Write('               ');
  287.       IF DRUCKER THEN Write(Lst,'               ');
  288.       FOR J := 0 TO -L-1 DO BEGIN
  289.         Write('│',W[J,I]:7:3,'│     ');
  290.         IF DRUCKER THEN Write(Lst,'│',W[J,I]:7:3,'│     ');
  291.       END;
  292.       WriteLn('│',W[-L,I]:7:3,'│');
  293.       IF DRUCKER THEN WriteLn(Lst,'│',W[-L,I]:7:3,'│');
  294.     END;
  295.     Write('               ');
  296.     IF DRUCKER THEN Write(Lst,'               ');
  297.     FOR J := 0 TO -L-1 DO BEGIN
  298.       Write('└',W[J,M]:7:3,'┘     ');
  299.       IF DRUCKER THEN Write(Lst,'└',W[J,M]:7:3,'┘     ');
  300.     END;
  301.     WriteLn('└',W[-L,M]:7:3,'┘');
  302.     IF DRUCKER THEN WriteLn(Lst,'└',W[-L,M]:7:3,'┘');
  303.   END;
  304.   IF L=0 THEN BEGIN            { es gibt genau eine Lösung }
  305.     GotoXY(2,A); Write('Die Lösungsmenge lautet : ');
  306.     IF DRUCKER THEN Write(Lst,'Die Lösungsmenge lautet : ');
  307.     Write('L = {'); IF DRUCKER THEN Write(Lst,'L = {');
  308.     FOR C:= 1 TO M-1 DO BEGIN
  309.       Write(X[C]:6:3,',');
  310.       IF DRUCKER THEN Write(Lst,X[C]:6:3,',');
  311.     END;
  312.     WriteLn(X[M]:6:3,' }');
  313.     IF DRUCKER THEN WriteLn(Lst,X[M]:6:3,' }');
  314.   END;
  315.   Read(Kbd,CH);
  316. END;
  317.  
  318. BEGIN
  319.   HALLO;
  320.   ClrScr;
  321.   TEXTCOLOR(2);
  322.   EINGABE(W,M,DRUCKER);
  323.   WHILE M>0 DO BEGIN           { 0 --> Ende des Programms  }
  324.     Gauss(W,M);       { Matrix auf Dreiecksgestalt bringen }
  325.     LOESUNG(W,M,X,L);       { Lösung der Matrix berechnen  }
  326.     AUSGABE(X,W,M,L,DRUCKER);                    { Ausgabe }
  327.     EINGABE(W,M,DRUCKER);
  328.   END;
  329.   ClrScr;
  330. END.
  331.