home *** CD-ROM | disk | FTP | other *** search
/ Turbo Toolbox / Turbo_Toolbox.iso / spezial / 04 / quellen / solve.inc < prev    next >
Encoding:
Text File  |  1979-12-31  |  2.8 KB  |  78 lines
  1. (*****************************************************************************)
  2. (*                               SOLVE.INC                                   *)
  3. (*                                                                           *)
  4. (*                        Loesen der Gleichung f(x) = 0                      *)
  5. (*****************************************************************************)
  6.  
  7. Function Solve (    a,b,                                (* Suchintervall     *)
  8.                     d    :Real;                         (* Suchschrittweite  *)
  9.                     k    :Integer;                      (* k-te Ableitung    *)
  10.                 Var done :Boolean) :Real;               (* Loesung gefunden? *)
  11.  
  12.    Var  x,y,s,dy,Lastx,Lasty,Lastdy :Real;
  13.         key : Char;
  14.  
  15.    Function RegulaFalsi (    Lastx,Lasty,x,y :Real;
  16.                              k               :Integer;
  17.                          Var done            :Boolean) :Real;
  18.  
  19.       Var xmin,xmax,z :Real;
  20.  
  21.       Begin
  22.       xmin := Lastx;
  23.       xmax := x;
  24.       If y <> 0 then
  25.          Repeat                                (* Anwendung der Regula falsi *)
  26.             z := x;
  27.             x := x - y*(x-Lastx)/(y-Lasty);
  28.             Lastx := z;
  29.             Lasty := y;
  30.             y := fn (x,k)
  31.          until (abs(x-Lastx) < eps*abs(X)) or (y = Lasty) or keypressed;
  32.       done := (x >= xmin) and (x <= xmax) and not keypressed;
  33.       RegulaFalsi := x
  34.       End;
  35.  
  36.  
  37.    Begin
  38.    done    := false;
  39.    x       := a;
  40.    Lasty   := fn (x, k);
  41.    if k = 0 THEN Lastdy  := fn (x, k+1);
  42.    Lastx   := x;
  43.    x       := x + d;
  44.    If Lasty <> 0 then
  45.       Repeat
  46.          y  := fn (x, k);
  47.          If y*Lasty <= 0 then                      (* Nullstelle lokalisiert *)
  48.             s := RegulaFalsi (Lastx,Lasty,
  49.                               x,y,k,done)
  50.          else
  51.           if k = 0 THEN
  52.           BEGIN
  53.             dy      := fn (x, k+1);
  54.             If (dy*Lastdy <= 0) then                 (* Extremwert lokalisiert *)
  55.                Begin
  56.                s := RegulaFalsi (Lastx, Lastdy, x, dy, k+1, done);
  57.                done := done and
  58.                        (abs(fn(s,k)) < eps)      (* Extremwert = Nullstelle? *)
  59.                End;
  60.           END;
  61.          If not done then
  62.             Begin
  63.             Lasty  := y;
  64.             Lastx  := x;
  65.             Lastdy := dy;
  66.             x      := x + d
  67.             End
  68.          else
  69.             Solve := s
  70.       until (x > b) or done or keypressed(* suche bis Nullstelle gefunden... *)
  71.    else                                  (* ... oder Intervallende erreicht  *)
  72.       Begin
  73.       done := true;
  74.       Solve := x - d
  75.       End;
  76.      if keypressed THEN read(kbd,key)
  77.    End;
  78.