Turbo Toolbox/Turbo_Toolbox.iso/sonderh1/solve.inc

Text File | 1988-02-01 | 3KB | 74 lines

(*****************************************************************************)
(*                               SOLVE.INC                                   *)
(*                                                                           *)
(*                         Lösen der Gleichung f(x) = 0                      *)
(*****************************************************************************)

Function Solve (    a,b,                                (* Suchintervall     *)
                    d    :Real;                         (* Suchschrittweite  *)
                    k    :Integer;                      (* k-te Ableitung    *)
                Var done :Boolean) :Real;               (* Lösung gefunden?  *)

   Var  x,y,s,dy,Lastx,Lasty,Lastdy :Real;


   Function RegulaFalsi (    Lastx,Lasty,x,y :Real;
                             k               :Integer;
                         Var done            :Boolean) :Real;

      Var xmin,xmax,z :Real;

      Begin
      xmin := Lastx;
      xmax := x;
      If y <> 0 then
         Repeat                                (* Anwendung der Regula falsi *)
            z := x;
            x := x - y*(x-Lastx)/(y-Lasty);
            Lastx := z;
            Lasty := y;
            y := fn (x,k)
         until (abs(x-Lastx) < eps) or (y = Lasty);
      done := (x >= xmin) and (x <= xmax);
      RegulaFalsi := x
      End;


   Begin
   done    := false;
   x       := a;
   Lasty   := fn (x, k);
   Lastdy  := fn (x, k+1);
   Lastx   := x;
   x       := x + d;
   If Lasty <> 0 then
      Repeat
         y  := fn (x, k);
         dy := fn (x, k+1);
         If y*Lasty <= 0 then                      (* Nullstelle lokalisiert *)
            s := RegulaFalsi (Lastx,Lasty,
                              x,y,k,done)
         else
            If dy*Lastdy <= 0 then                 (* Extremwert lokalisiert *)
               Begin
               s := RegulaFalsi (Lastx, Lastdy, x, dy, k+1, done);
               done := done and
                       (abs(fn(s,k)) < eps)      (* Extremwert = Nullstelle? *)
               End;
         If not done then
            Begin
            Lasty  := y;
            Lastx  := x;
            Lastdy := dy;
            x      := x + d
            End
         else
            Solve := s
      until (x > b) or done              (* suche bis Nullstelle gefunden... *)
   else                                  (* ... oder Intervallende erreicht  *)
      Begin
      done := true;
      Solve := x - d
      End
   End;