home *** CD-ROM | disk | FTP | other *** search
/ Turbo Toolbox / Turbo_Toolbox.iso / spezial / 15 / graphen / reg / reglin.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1989-05-18  |  4.5 KB  |  123 lines
  1. { --------------------------------------------------------------- }
  2. {                   File : REGLIN.PAS ( gehört zu REG.PAS )       }
  3. {          Copyright (c) : 1989  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.  
  10. { -- Berechnet die Steigung m und den y - Achsenabschnitt b   -- }
  11. { -- gibt TRUE zurück, wenn dieses möglich war, sonst FALSE   -- }
  12.  
  13. FUNCTION  Berechne_m_b (     n1,n2 : Index     ;
  14.                         VAR    x,y : Messwerte ;
  15.                         VAR    m,b : Real       ) : BOOLEAN ;
  16.  
  17.  
  18. var i,n         : Index ;
  19.     sumx,sumy,           { Summe der x - Werte und der y - Werte }
  20.     sumxy,sumxx,         { Summe der Produkte x*y und x*x        }
  21.     xr, yr      : Real;  { Mittelwerte                           }
  22.  
  23. BEGIN
  24.      sumx  := 0; sumy  := 0;    { Vorbesetzen der Summen         }
  25.      sumxy := 0; sumxx := 0;
  26.  
  27.      FOR i:=n1 to n2 DO
  28.      BEGIN
  29.           SumX  := SumX  + x[i];      SumY  := SumY  + y[i]       ;
  30.           SumXY := SumXY + x[i]*y[i] ;SumXX := SumXX + Sqr (x[i]) ;
  31.  
  32.      END;
  33.  
  34.      n  := n2 - n1 + 1;         { Anzahl der Meßwerte            }
  35.      xr := sumx/n;              { Mittelwerte bilden             }
  36.      yr := sumy/n;
  37.  
  38.      IF sumxx - n*sqr(xr) = 0
  39.      THEN  Berechne_m_b := FALSE          { Fehler aufgetreten,  }
  40.      ELSE                                 { es droht Division    }
  41.                                           { durch Null.          }
  42.  
  43.      BEGIN       { Jetzt ist die Berechnung von m und b möglich  }
  44.          Berechne_m_b := TRUE;
  45.          m := (sumxy - n*xr*yr) / (sumxx - n*sqr(xr));
  46.          b := yr - m*xr;
  47.      END;
  48. END  { Berechne_m_b } ;
  49.  
  50. { ------------------------------------------------------------- }
  51.  
  52. FUNCTION F (a,b,x : Real; Welcher : Art) : Real;
  53. BEGIN
  54.      CASE Welcher OF
  55.           PotF,RPotF   : F := Exp(a+b*Ln(x)) ;
  56.           LogaF,RLogaF : F := a+b*Ln(x)      ;
  57.           ExpF,RExpF   : F := Exp(a+b*x)     ;
  58.      END;
  59. END;
  60.  
  61. FUNCTION Lineare_Regression ( Welcher   : Art       ;
  62.                               n1, n2    : Index     ;
  63.                               VAR x,y   : Messwerte ;
  64.                               VAR Datei : Text  )   : BOOLEAN ;
  65.  
  66. VAR  m,b,                   { Steigung und y - Achsenabschnitt  }
  67.      xa,xe,                 { Anfangs- und Endpunkt der Geraden }
  68.      d            : Real;   { Dummy  für RobustLinFit, da die   }
  69.                             { statistischen Berechnungen hier   }
  70.                             { nicht benötigt werden.            }
  71.     i             : Index;
  72.     xr,yr         : Messwerte;  { Zur Umrechnung bei Potenzfkt. usw. }
  73.  
  74. BEGIN  { Lineare Regression }
  75.  
  76.      xr := x; yr := y;
  77.      { Meßwerte ggf. für erschiedene Arten umrechnen }
  78.      FOR i := n1 TO n2 DO
  79.      BEGIN
  80.          CASE Welcher OF
  81.               PotF , RPotF : BEGIN xr[i] := Ln (x[i]); yr[i] := Ln (y[i]); END;
  82.               LogaF,RLogaF : xr[i] := Ln (xr[i]);
  83.               ExpF ,RExpF  : yr[i] := Ln (yr[i]);
  84.          END;
  85.      END;
  86.  
  87.      IF Welcher >= RLinF THEN      { wurde RobustLinFit gewählt }
  88.      BEGIN
  89.           IF NOT RobustLinFit (xr,yr,n1,n2,b,m,d,d,d) THEN
  90.           BEGIN
  91.                Lineare_Regression := FALSE;
  92.                EXIT;
  93.           END;
  94.      END ELSE
  95.      BEGIN
  96.           IF NOT Berechne_m_b (n1,n2,xr,yr,m,b) THEN
  97.           BEGIN
  98.                Lineare_Regression := FALSE;
  99.                EXIT;
  100.           END;
  101.      END;
  102.  
  103.      Lineare_Regression := TRUE;
  104.  
  105.      xa := Minimum (n1,n2,x) - 0.5;  { Berechnung der Anfangs- und  }
  106.      xe := Maximum (n1,n2,x) + 0.5;  { Endpunkte                    }
  107.  
  108.      IF (Welcher=LinF) OR (Welcher=RLinF) THEN  { genügen 2 Punkte  }
  109.      BEGIN
  110.           WriteLn (Datei,xa,' ',m*xa + b); {     Hereinschreiben in die   }
  111.           WriteLn (Datei,xe,' ',m*xe + b); { Datei zur Auswertung durch   }
  112.      END ELSE                              { WERTE.PAS                    }
  113.      REPEAT
  114.            WriteLn (Datei,xa,' ', F (b,m,xa,Welcher));
  115.            xa := xa + Step;
  116.      UNTIL xa > xe;
  117.  
  118.      WriteLn (Datei);                      { Leerzeile zur Trennung      }
  119. END;
  120.  
  121. { ----------------------------------------------------------------- }
  122. { --                  Ende von REGLIN.PAS                        -- }
  123.