XProfan

WindowTitle "STEFFENSEN-ALGORITHMUS"
'   berechnet implizit die "Biegung" der Funktionskurve, nähert sich exponentiell.
'   NUR FÜR DEMONSTRATIONSZWECKE! Keine Gewähr! No warranties whatsoever!
' Original: 1987 John H Mathews, Californa State Univ.
WindowStyle 24:Font 2
Randomize:CLS Rnd(8^8)
Set("Decimals",15)
Declare DELTA!,EPSILON!,max&,ANS$,P0!,SMALL!,POLD!
Declare K&,COND&,P1!,P2!,p3!,P4!,DF0!,D1!,D2!,DP!,DF1!,Y3!,RELERR!
'*** HIER DIE FUNKTION SOWIE IHRE ABLEITUNG EINPROGRAMMIEREN:
'    FNF (X!) = X!*X!*X! - 3*X! + 2
Def FNF(1)  @!(1)*@!(1)*@!(1) - 3 * @!(1) + 2
'    FNF1(X!) = 3*X!*X! - 3
Def FNF1(1)  3*@!(1)*@!(1) - 3
'***********************************************************
Goto "G52"'skip print subroutine
S30:
' DIE FUNKTION IN KLARTEXT AUSGEBEN:
REM SUBROUTINE PRINT FUNCTION
PRINT "         F(X)  =  X^3 - 3*X + 2  = 0            "
Return
'***********************************************************
G52:
Goto "G100"
G100:
REM PROGRAM STEFFENS
DELTA!  =Val("1E-16")'Relative Fehlergrenze des Parameters
EPSILON!=Val("1E-16")'Ansolute Funktionswert-Toleranz
MAX&=99'Maximale Anzahl an Iterationen
G140:
Gosub "S300": REM SUBROUTINE INPUTS
GOSUB "S400": REM SUBROUTINE STEFFENSEN
GOSUB "S1000":REM SUBROUTINE RESULTS
PRINT
Print
PRINT " ANDEREN STARTWERT PROBIEREN <j/n>? ";
Input ANS$
CaseNot (ANS$="N") Or (ANS$="n"):GOTO "G140"
GOTO "G5000"
S300:
REM SUBROUTINE INPUTS
CLS Rnd(8^8)
PRINT
PRINT " STEFFENSEN'S BESCHLEUNIGUNG DES NEWTON-RAPHSON-ALGORITHMUS "
PRINT "   ZUR NULLSTELLENSUCHE IN EINER (NICHTLINEAREN) FUNKTION   "
PRINT
Gosub "S30"' ZU SUBROUTINE PRINT FUNCTION
PRINT
PRINT " Es wird ein anfänglicher Startwert P0 benötigt:"
PRINT " Gewünschter Startwert P0 = ";
Input P0!
PRINT
RETURN
S400:
REM SUBROUTINE STEFFENSEN
SMALL!=Val("1E-20")
POLD!=P0!
K&=0
COND&=0
P3!=P0!
P2!=P0!+1
P1!=P0!+2

WHILE (K& < MAX&) And (COND& = 0)

    P0!=P3!
    DF0!=FNF1(P0!)

    If DF0!<>0:Goto "G520"

        Else:Goto "G540"

    EndIf

    G520:
    P1!=P0! - FNF(P0!)/DF0!' Newton-Raphson-Schritt
    Goto "G590"
    G540:
    REM ELSE
    COND&=1
    DP!=P3!-P2!
    P3!=P0!
    Goto "G860"
    G590:
    REM ENDIF
    DF1!=FNF1(P1!)

    If  DF1! <>0:Goto "G620"

        Else:Goto "G640"

    EndIf

    G620:
    P2!=P1! - FNF(P1!)/DF1!
    Goto "G690"
    G640:
    REM ELSE
    COND&=1
    DP!=P1!-P0!
    P3!=P1!
    Goto "G860"
    G690:
    REM ENDIF
    D1!=(P1!-P0!)*(P1!-P0!)
    D2!=P2!-2*P1!+P0!

    IF D2!=0:Goto "G730"

        Else:Goto "G770"

    EndIf

    G730:
    COND&=1
    DP!=P2!-P1!
    P3!=P2!
    GOTO "G800"
    G770:
    REM ELSE
    P3!=P0!-D1!/D2!
    DP!=P3!-P2!
    G800:
    REM ENDIF
    Y3!=FNF(P3!)
    RELERR!=Abs(DP!)/(Abs(P3!)+SMALL!)
    Case RELERR! < DELTA!:  COND&=2
    Case  Abs(Y3!) < EPSILON! : COND&=3
    Case  (RELERR!  < DELTA!) And (Abs(Y3!) < EPSILON!) : COND&=4
    G860:
    REM WEITER
    K&=K&+1

ENDWHILE

P0!=POLD!
RETURN
S1000:
REM SUBROUTINE RESULTS
CLS Rnd(8^8)
PRINT
PRINT " STEFFENSEN'S BESCHLEUNIGUNG DES NEWTON-RAPHSON-ALGORITHMUS "
PRINT "   ZUR NULLSTELLENSUCHE IN EINER (NICHTLINEAREN) FUNKTION   "
PRINT
Gosub "S30"'PRINT-SUBROUTINE
PRINT
PRINT " Der Startwert war P0 =",P0!
PRINT
PRINT " Nach "+Trim$(Str$(K&))+" Iterationen Quasi-Nullwert gefunden bei:"
Print : Print
Print "    P =",P3!
Print : Print
PRINT "  DP  =",ABS(DP!)," ist seine relative Genauigkeit."
PRINT
Print "  F(";Trim$(Str$(P3!));") =",FNF(P3!)
PRINT
Case FNF(P3!)=0  : PRINT "  Berechnete Funktion ergab GENAU NULL! "

If COND&=0:Goto "G1200"

    Else:Goto "G1240"

EndIf

PRINT "  Die Konvergenz des Verfahrens ist zweifelhaft. Begründung:"
PRINT
G1220:
PRINT "  Maximale Iterationszahl überschritten!"
Goto "G1400"
G1240:
REM ELSEIF

If COND&=1:Goto "G1260"

    Else:Goto "G1280"

EndIf

G1260:
PRINT "  Verfahrenskonvergenz zweifelhaft, da Division durch Null."
Goto "G1400"
G1280:
REM ELSEIF

IF  COND&=2:Goto "G1300"

    Else:Goto "G1320"

EndIf

G1300:
PRINT "  Lösung innerhalb der programmierten Toleranzen."
Goto "G1400"
G1320:
REM ELSEIF

If COND&=3:Goto "G1340"

    Else:Goto "G1360"

EndIf

G1340:
PRINT "  Funktionswert F(P) innerhalb der Toleranzgrenzen."
Goto "G1400"
G1360:
REM ELSEIF

If  COND&=4:Goto "G1380"

    Else: Goto "G1400"

EndIf

G1380:
PRINT "  Der Parameter-Wert  P und der Funktionswert F(P) "
PRINT "  liegen beide in den programmierten Toleranzen.       "
G1400:
REM ENDIF
Return
G5000:
END