home *** CD-ROM | disk | FTP | other *** search
/ Turbo Toolbox / Turbo_Toolbox.iso / spezial / 15 / graphen / reg / regquad.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1989-05-16  |  4.2 KB  |  103 lines
  1. { --------------------------------------------------------------- }
  2. {                   File : REGQUAD.PAS  ( gehört zu REG.PAS )     }
  3. {          Copyright (c) : 1988  Heinz Hagemeyer & TOOLBOX        }
  4. {                Sprache : TURBO PASCAL 4.0  (oder 3.0)           }
  5. {              Ein Programm zur Auswertung von Meßwerten          }
  6. {                   mit Hilfe von GRAPH.PAS                       }
  7. { --------------------------------------------------------------- }
  8.  
  9. FUNCTION   Quadratische_Regression
  10.                 ( n1,n2         : Index     ;
  11.                   x,y           : messwerte ;
  12.                   VAR Datei     : TEXT    ) : BOOLEAN ;
  13.  
  14. {     Berechnet die Koeffizienten der quadratischen Funktion  :  }
  15. {                    f(x) = ax^2 + bx + c                        }
  16. {          nach der Methode der kleinsten Fehlerquadrate         }
  17.  
  18. FUNCTION  Berechne_a_b_c ( n         : index       ;
  19.                            x,y       : messwerte   ;
  20.                            VAR x1,x2,x3 : REAL  )  : BOOLEAN ;
  21. VAR i,k     : Index ;
  22.     A       : ARRAY [1 .. 3,1 .. 3] OF REAL;
  23.     B       : ARRAY [1 .. 3] OF REAL;
  24.     D,xr,yr : REAL ;
  25.  
  26. BEGIN
  27.  
  28.      FOR i := 1 TO 3 DO              { Definiertes Besetzen der Variablen  }
  29.      BEGIN
  30.          FOR k := 1 TO 3 DO A [i,k] := 0;
  31.          B [i] := 0;
  32.      END;
  33.  
  34.      FOR i := 1 TO n DO              { Berechnung der Summen               }
  35.      BEGIN
  36.            xr     := x[i]                     ;    { Damit geht's leichter }
  37.            yr     := y[i]                     ;
  38.           A[1,1]  := A[1,1] + Sqr(xr)         ;    { Σ x ²                 }
  39.           A[1,2]  := A[1,2] + xr              ;    { Σ x                   }
  40.           A[2,1]  := A[2,1] + xr*sqr(xr)      ;    { Σ x ^ 3               }
  41.           A[3,1]  := A[3,1] + Sqr (Sqr (xr))  ;    { Σ x ^ 4               }
  42.  
  43.           B[1]    := B[1]   + yr              ;   { Σ y                    }
  44.           B[2]    := B[2]   + xr*yr           ;   { Σ x*y                  }
  45.           B[3]    := B[3]   + yr*sqr(xr)      ;   { Σ y*x ²                }
  46.     END;
  47.  
  48.     A[1,3] := n      ;                           { Besetzen der restlichen }
  49.     A[2,2] := A[1,1] ;                           { Koeffizienten           }
  50.     A[2,3] := A[1,2] ;
  51.     A[3,2] := A[2,1] ;
  52.     A[3,3] := A[1,1] ;
  53.  
  54.     { Lösen des Linearen Gleichungssystem mit Hilfe von 3 Reihigen Deter-  }
  55.     { minanten. Eine eindeutige Kösung existiert dann, wenn die Koeffizi-  }
  56.     { entendeterminante D <> 0 ist. Daher =>                               }
  57.  
  58.     D  :=   A[1,1]*A[2,2]*A[3,3] + A[1,2]*A[2,3]*A[3,1] + A[1,3]*A[2,1]*A[3,2]
  59.           - A[3,1]*A[2,2]*A[1,3] - A[3,2]*A[2,3]*A[1,1] - A[3,3]*A[2,1]*A[1,2] ;
  60.  
  61.     IF D=0 THEN  Berechne_a_b_c := FALSE
  62.     ELSE
  63.     BEGIN
  64.          Berechne_a_b_c := TRUE;
  65.  
  66.          X1 :=   B[1]*A[2,2]*A[3,3] + A[1,2]*A[2,3]*B[3] + A[1,3]*B[2]*A[3,2]
  67.                - B[3]*A[2,2]*A[1,3] - A[3,2]*A[2,3]*B[1] - A[3,3]*B[2]*A[1,2] ;
  68.  
  69.          X2 :=   A[1,1]*B[2]*A[3,3] + B[1]*A[2,3]*A[3,1] + A[1,3]*A[2,1]*B[3]
  70.                - A[3,1]*B[2]*A[1,3] - B[3]*A[2,3]*A[1,1] - A[3,3]*A[2,1]*B[1] ;
  71.  
  72.          X3 :=   A[1,1]*A[2,2]*B[3] + A[1,2]*B[2]*A[3,1] + B[1]*A[2,1]*A[3,2]
  73.                - A[3,1]*A[2,2]*B[1] - A[3,2]*B[2]*A[1,1] - B[3]*A[2,1]*A[1,2] ;
  74.  
  75.          X1 := X1/D ; X2 := X2/D ; X3 := X3/D ;
  76.     END;
  77. END;     { Berechne_a_b_c }
  78.  
  79. { ------------------------------------------------------------------------- }
  80.  
  81. VAR a, b, c, xr, xa, xe, yr       : REAL;
  82.  
  83. BEGIN
  84.      IF NOT Berechne_a_b_c (n2-n1+1,x,y,a,b,c)
  85.      THEN BEGIN Quadratische_Regression := FALSE; EXIT END;
  86.  
  87.      Quadratische_Regression := TRUE;
  88.  
  89.      xa := Minimum (n1,n2,x) - 2*Step ;   { Über den 1. und 2. Punkt hinaus     }
  90.      xe := Maximum (n1,n2,x) + 2*Step ;
  91.      xr := xa ;
  92.  
  93.      REPEAT
  94.         yr := xr * ( a*xr + b ) + c ; { Berechnung der Werte mit dem HORNER }
  95.         WriteLn (Datei, xr,' ',yr)  ; { Schema und in die Datei schreiben   }
  96.         xr := xr + Step             ;
  97.      UNTIL xr > xe ;
  98.      WriteLn (Datei);
  99. END;
  100.  
  101. { -------------------------------------------------------------------- }
  102. {                     Ende von REGQUAD.PAS                             }
  103.