XProfan

Français

p.specht

chez qui rechnerischen Solution einer u.U. très komplizierten Gleichung 'F(x)=Vorgabewert', alors qui cherche espace celui-là x-Werte, chez denen cet Gleichung erfüllt bzw. 'wahr' ist, ordnet on üblicherweise qui Gleichung afin de f(x) minus Vorgabewert = 0, et cherchez pour den Nullstellen des y-Funktionswertes. cela BISECTION(Unterteilungs)-procéder était dabei einer qui allerersten erfolgreich angewendeten Computeralgorithmen, et hat sich jusqu'à aujourd'hui comme très robuste Methode bewährt, soll appeler: cela procéder liefert - dépendant vom angebenen Suchbereich - avec Sicherheit oui c'est ca une exakten Nulldurchgang qui Funktion comme Solution, si une solche Solution existiert.

Weiterer Vorteil: qui gefundenen Lösungen gelten comme "technisch stabil". cet Stabilität wird aus Sicht qui mathématique-Puristen allerdings duch une le tort erkauft: Es volonté seulement Lösungen trouvé, qui qui x-Achse réellement schneiden, alors dans qui Nähe qui Lösungspunkte sowohl positive comme aussi negative y-Achsenwerte besitzen. avec anderen Worten: qui Algorithmus peux aucun Lösungen ermitteln, qui par bloße Berührung qui x-Achse seulement de dessus ou bien seulement de unten gegeben wären. dans solchen Fällen wäre procéder comment "Regula falsi" ou bien "Newton-Raphson" approprié, beide avons allerdings aussi wieder ses avant- et Nachteile.

Hinweis: qui Urheberrechte liegen chez ACM; ici wurde seulement qui Portierbarkeit pour XProfan demonstriert. sans chacun Gewähr daher:

Kompilieren Marque Séparation

' ACM TOMS Algorithm 4 'BISECTION'
'{Depending on 4 start parameters, BISEC finds one x where Function y=F(x)=0
' Original Fortran Source by S. Gorn à partir de https://www.netlib.org/toms/4.gz
' (C) Feb.1960 by ACM-TOMS Association of Computing Machinery
' ----------------------------------------------------------------------------
' (D) Demo-Migration to XProfan-11.2a dans 2014-11 by P.Specht, Vienna (Austria)
' Es bestehen Urheberrechte Dritter! No Warranty Whatsoever! sans chacun Gewähr!
' ----------------------------------------------------------------------------
' Description (F99): Date: Sun, 12 Feb 95 18:54:30 +0000
' Here is a transcription of algorithm #4 à partir de Collected Algorithms
' à partir de ACM. I had to modify some characters to faire il fit into ASCII,
' specially le multiplicative operator has become * and greek letters
' sont substituted by their equivalent names.
'         Jose R. Valverde, European Bioinformatics Institute, txomsy@ebi.ac.uk
' ------------------------------------------------------------------------------
' Original Algorithm 4: BISECTION ROUTINE
' by S. Gorn, Univeristy of Pennsylvania ordinateur Center, Philadelphia, Pa.
' ------------------------------------------------------------------------------
' Comment: This procedure evaluates a function at le end-points
' 	of a réel interval, switching to à error exit (fools
' 	exit) FLSXT si there is no change of sign. Otherwise
' 	it finds a racine by iterated bisection and evaluation
' 	at le midpoint, halting si either le value of le
' 	function is less than le free variable epsilon, or two
' 	successive approximations of le racine differ by less
' 	than epsilon1. Epsilon should être chosen of le l'ordre of
' 	error dans evaluating le function (otherwise time would être
' 	wasted), and epsilon1 of le l'ordre of desired accuracy.
' 	Epsilon1 must not être less than two units dans le charge place
' 	carried by le machine or d'autre indefinite cycling veux
' 	occur due to roundoff on bisection. Although this
' 	method is of 0 l'ordre, and therefore among le slow-
' 	est, il is applicable to any continuous function. The
' 	fact that no differentiability conditions have to être
' 	checked makes il, therefore, à 'old work-horse'
' 	among routines for finding réel roots which have
' 	already been isolated. The free varaibles y1 and y2
' 	are (presumably) le end-points of à interval within
' 	which there is à odd number of roots of le réel function F.
' 	Alpha is le temporary exit fot le evaluation of F.;
'---------------------------------------------------------------
'---------------------------------------------------------------
' CERTIFICATION OF ALGORITHM 4
' BISECTION ROUTINE (S. Gorn, _Comm._ACM_, March 1960), Program by
' Patty Jane Rader,* Argonne national Laboratory, Argonne, Illinois
'
' Bisec quoi coded for le Royal Precision LGP-30 ordinateur, using inter-
' pretive floating point system (24.2) with 28 bits of significance.
'
'  The following minor correction quoi found necessary.
'	alpha: go to gamma[1] should être go to gamma[i]
' After this correction quoi asticot, le program ran smoothly for
'  F(x) = cos x, using le following parameters:
'---------------------------------------------------------------
'	y1	 y2	 Epsilon	Epsilon1      Results
'---------------------------------------------------------------
' 0     1	  .001		.001		      FLSXT
' 0	    2	  .001		.001		      1.5703
'	1.5	  2	  .001		.001		      1.5703
'	1.55	2	  .1		  .1		        1.5500
'	1.5	  2	  .001		.1		        1.5625
'---------------------------------------------------------------
' These combinations test espace loops of le program.
' *) Work supported by le U. S. Atomic Energy Commission.
'}
'---------------------------------------------------------------
'{TESTPROGRAMM
CLS
Font 2
Set("decimals",15)
imprimer "\n Berechnete Testwerte s'il te plaît avec den im Kommentar"
imprimer " angegebenen Tabellenresultaten comparer: \n"
imprimer "   ";format$("%g",BiSec(0,1,0.001,0.001))
imprimer "   ";format$("%g",BiSec(0,2,0.001,0.001))
imprimer "   ";format$("%g",BiSec(1.5,2,0.001,0.001))
imprimer "   ";format$("%g",BiSec(1.55,2,0.1,0.1))
imprimer "   ";format$("%g",BiSec(1.5,2,0.001,0.1))
Waitinput
FIN
'}-------------------------------------------------------------------------
'Function F(x) ICI EINPORGRAMMIEREN!

proc F :parameters x!

    return cos(x!)

endproc

'-------------------------------------------------------------------------
'Bisec Routine:

proc BISEC :parameters y1!,y2!,epsilon!,epsilon1!

    declare x!,f!,f1!,i&,j&,k&,FLSXT!
    FLSXT!=-999999999'bedeutet ERROR, aucun Nullstelle dans diesem Bereich
    Bisec:
    i&=1:j&=1:k&=1:x!=y2!
    Alpha:
    f!=F(x!) : cas abs(f!)<=epsilon!:return x!

    si i&=1:goto "First_val" : elseif i&=2:goto "Succ_val" :endif

        First_val:
        i&=2 : f1!=f! : x!=y1!
        goto "Alpha"
        Succ_val:

        si (f!*f1!)>=0

            si j&=1: Imprimer "Keine Nullstelle dans diesem Bereich! Error ";:return FLSXT!

            elseif j&=2: goto "Reg_delta"

            endif

        endif

        si k&=1:goto "Sec_val" : elseif k&=2:goto "Reg_etha" :endif

            Sec_val:
            j&=2:k&=2
            Midpoint:
            x!=(y1!+y2!)/2
            goto "Alpha"
            Reg_delta:
            y2!=x!
            Precision:
            cas (abs(y1!-y2!)>=epsilon1!):goto "Midpoint"
            return x!
            Reg_etha:
            y1!=x!
            goto "Precision"

        ENDPROC

XProfan 11
Computer: Gerät, daß es in Mikrosekunden erlaubt, 50.000 Fehler zu machen, zB 'daß' statt 'das'...

16.05.2021 ▲

Vollständiges citation

Absatzweise Citation Zeilenweise Citation

p.specht

Michael Wodrich hat une verbesserte variante vorgestellt:

son Kommentar: "... et un zweiter BiSec(t) sans Goto mais avec Iterationen-Begrenzer (avec cela es pas endlos fonctionne). Beides zusammen gemixt et une Iteration auparavant ausgebremst..."

Link: [...]

Kompilieren Marque Séparation

' ACM TOMS Algorithm 4 'BISECTION'
'{Depending on 4 start parameters, BISEC finds one x where Function y=F(x)=0
' Original Fortran Source by S. Gorn à partir de https://www.netlib.org/toms/4.gz
' (C) Feb.1960 by ACM-TOMS Association of Computing Machinery
' ----------------------------------------------------------------------------
' (D) Demo-Migration to XProfan-11.2a dans 2014-11 by P.Specht, Vienna (Austria)
' Es bestehen Urheberrechte Dritter! No Warranty Whatsoever! sans chacun Gewähr!
' ----------------------------------------------------------------------------
' Description (F99): Date: Sun, 12 Feb 95 18:54:30 +0000
' Here is a transcription of algorithm #4 à partir de Collected Algorithms
' à partir de ACM. I had to modify some characters to faire il fit into ASCII,
' specially le multiplicative operator has become * and greek letters
' sont substituted by their equivalent names.
'         Jose R. Valverde, European Bioinformatics Institute, txomsy@ebi.ac.uk
' ------------------------------------------------------------------------------
' Original Algorithm 4: BISECTION ROUTINE
' by S. Gorn, Univeristy of Pennsylvania ordinateur Center, Philadelphia, Pa.
' ------------------------------------------------------------------------------
' Comment: This procedure evaluates a function at le end-points
' 	of a réel interval, switching to à error exit (fools
' 	exit) FLSXT si there is no change of sign. Otherwise
' 	it finds a racine by iterated bisection and evaluation
' 	at le midpoint, halting si either le value of le
' 	function is less than le free variable epsilon, or two
' 	successive approximations of le racine differ by less
' 	than epsilon1. Epsilon should être chosen of le l'ordre of
' 	error dans evaluating le function (otherwise time would être
' 	wasted), and epsilon1 of le l'ordre of desired accuracy.
' 	Epsilon1 must not être less than two units dans le charge place
' 	carried by le machine or d'autre indefinite cycling veux
' 	occur due to roundoff on bisection. Although this
' 	method is of 0 l'ordre, and therefore among le slow-
' 	est, il is applicable to any continuous function. The
' 	fact that no differentiability conditions have to être
' 	checked makes il, therefore, à 'old work-horse'
' 	among routines for finding réel roots which have
' 	already been isolated. The free varaibles y1 and y2
' 	are (presumably) le end-points of à interval within
' 	which there is à odd number of roots of le réel function F.
' 	Alpha is le temporary exit fot le evaluation of F.;
'---------------------------------------------------------------
'---------------------------------------------------------------
' CERTIFICATION OF ALGORITHM 4
' BISECTION ROUTINE (S. Gorn, _Comm._ACM_, March 1960), Program by
' Patty Jane Rader,* Argonne national Laboratory, Argonne, Illinois
'
' Bisec quoi coded for le Royal Precision LGP-30 ordinateur, using inter-
' pretive floating point system (24.2) with 28 bits of significance.
'
'  The following minor correction quoi found necessary.
'	alpha: go to gamma[1] should être go to gamma[i]
' After this correction quoi asticot, le program ran smoothly for
'  F(x) = cos x, using le following parameters:
'---------------------------------------------------------------
'	y1	 y2	 Epsilon	Epsilon1      Results
'---------------------------------------------------------------
' 0     1	  .001		.001		      FLSXT
' 0	    2	  .001		.001		      1.5703
'	1.5	  2	  .001		.001		      1.5703
'	1.55	2	  .1		  .1		        1.5500
'	1.5	  2	  .001		.1		        1.5625
'---------------------------------------------------------------
' These combinations test espace loops of le program.
' *) Work supported by le U. S. Atomic Energy Commission.
'}
'---------------------------------------------------------------
'{TESTPROGRAMM
CLS
Font 2
Set("decimals",15)
imprimer "---------------------------------------------------------------"
imprimer Tab(2);"y1";  Tab(8);"y2";Tab(12);"Epsilon";Tab(21);"Epsilon1";Tab(31);"Results"
imprimer "---------------------------------------------------------------"
imprimer Tab(2);"0";   Tab(8);"1"; Tab(12);".001";   Tab(21);".001";    Tab(31);"FLSXT"
imprimer Tab(2);"0";   Tab(8);"2"; Tab(12);".001";   Tab(21);".001";    Tab(31);"1.5703"
imprimer Tab(2);"1.5"; Tab(8);"2"; Tab(12);".001";   Tab(21);".001";    Tab(31);"1.5703"
imprimer Tab(2);"1.55";Tab(8);"2"; Tab(12);".1";     Tab(21);".1";      Tab(31);"1.5500"
imprimer Tab(2);"1.5"; Tab(8);"2"; Tab(12);".001";   Tab(21);".1";      Tab(31);"1.5625"
imprimer "---------------------------------------------------------------"
imprimer "\n Berechnete Testwerte s'il te plaît avec den obigen"
imprimer " Tabellenresultaten comparer: \n"
imprimer format$("   BiSec(0,    1, .001, .001) = %g",BiSec(0,1,0.001,0.001))
imprimer format$("   BiSec(0,    2, .001, .001) = %g",BiSec(0,2,0.001,0.001))
imprimer format$("   BiSec(1.5,  2, .001, .001) = %g",BiSec(1.5,2,0.001,0.001))
imprimer format$("   BiSec(1.55, 2, .1,   .1  ) = %g",BiSec(1.55,2,0.1,0.1))
imprimer format$("   BiSec(1.5,  2, .001, .1  ) = %g",BiSec(1.5,2,0.001,0.1))
imprimer "---------------------------------------------------------------"
imprimer format$("   BiSect(0,    1, .001, .001) = %g",BiSect(0,1,0.001,0.001))
imprimer format$("   BiSect(0,    2, .001, .001) = %g",BiSect(0,2,0.001,0.001,9))
imprimer format$("   BiSect(1.5,  2, .001, .001) = %g",BiSect(1.5,2,0.001,0.001))
imprimer format$("   BiSect(1.55, 2, .1,   .1  ) = %g",BiSect(1.55,2,0.1,0.1))
imprimer format$("   BiSect(1.5,  2, .001, .1  ) = %g",BiSect(1.5,2,0.001,0.1))
Waitinput
FIN
'}-------------------------------------------------------------------------
'Function F(x) ICI EINPORGRAMMIEREN!

proc F :parameters x!

    return cos(x!)

endproc

'-------------------------------------------------------------------------
'Bisec Routine:

proc BISEC :parameters y1!,y2!,epsilon!,epsilon1!

    declare x!,f!,f1!,i&,j&,k&,FLSXT!,ii&
    FLSXT!=-999999999'bedeutet ERROR, aucun Nullstelle dans diesem Bereich
    Bisec:
    i&=1:j&=1:k&=1:x!=y2!:ii&=0
    Alpha:
    inc ii&':: imprimer "(";ii&;")";
    f!=F(x!) : cas abs(f!)<=epsilon!:return x!

    si i&=1:goto "First_val" : elseif i&=2:goto "Succ_val" :endif

        First_val:
        i&=2 : f1!=f! : x!=y1!
        goto "Alpha"
        Succ_val:

        si (f!*f1!)>=0

            si j&=1: Imprimer "\nKeine Nullstelle dans diesem Bereich! Error\n";:return FLSXT!

            elseif j&=2: goto "Reg_delta"

            endif

        endif

        si k&=1:goto "Sec_val" : elseif k&=2:goto "Reg_etha" :endif

            Sec_val:
            j&=2:k&=2
            Midpoint:
            x!=(y1!+y2!)/2
            goto "Alpha"
            Reg_delta:
            y2!=x!
            Precision:
            cas (abs(y1!-y2!)>=epsilon1!):goto "Midpoint"
            return x!
            Reg_etha:
            y1!=x!
            goto "Precision"

        ENDPROC

        '-------------------------------------------------------------------------
        'Bisec Routine avec NMAX:

        Proc BiSect

            Déclarer float y1,y2,epsilon,epsilon1, long Durchlaeufe

            Si %PCount = 5

                Paramètres float y1_5,y2_5,e_5,e1_5, long NMAX
                y1 = y1_5 : y2 = y2_5 : epsilon = e_5 : epsilon1 = e1_5 : Durchlaeufe = NMAX

            D'autre

                Paramètres float y1_4,y2_4,e_4,e1_4
                y1 = y1_4 : y2 = y2_4 : epsilon = e_4 : epsilon1 = e1_4 : Durchlaeufe = 100

            EndIf

            Déclarer float x,f0,f1
            Var long Iterationen = 0
            Var float KEINENULL = -999999999.0' bedeutet FEHLER; aucun Nullstelle dans diesem Bereich
            Var int First = 1
            x = y2

            Repeat

                Inc Iterationen':: imprimer "(";Iterationen;")";
                f0 = F(x)' ici wird qui Funktion aufgerufen
                Cas Abs(f0) <= epsilon : Retour x

                Si Iterationen > 1

                    Si (f0 * f1) >= 0

                        Si First

                            Imprimer "\nKeine Nullstelle dans diesem Bereich! FEHLER"
                            Retour KEINENULL

                        EndIf

                        y2 = x
                        Cas (Abs(y1 - y2) < epsilon1): Retour x

                    D'autre

                        Si non First

                            y1 = x
                            Cas (Abs(y1 - y2) < epsilon1): Retour x

                        D'autre

                            Décembre First

                        EndIf

                    EndIf

                    Cas (Iterationen < Durchlaeufe) : x = (y1 + y2) / 2

                D'autre

                    ' qui erste Durchlauf
                    f1 = f0
                    x = y1

                EndIf

            Until Iterationen >= Durchlaeufe

            Imprimer "\nZu viele Durchläufe! (";Durchlaeufe;" sommes erlaubt)"
            Retour x

        ENDPROC

Computer: Gerät, daß es in Mikrosekunden erlaubt, 50.000 Fehler zu machen, zB 'daß' statt 'das'...

16.05.2021 ▲

Vollständiges citation

Absatzweise Citation Zeilenweise Citation

p.specht

autre Umsetzung, de encore früher:

Kompilieren Marque Séparation

Windowtitle "Bisection-Algorithmus"
'Q: Fortran-IV Source aus 1962, pour XProfan portiert 2015-05 by PS
Cls:Font 2:randomize:AppendMenubar 200,\
"Eingabeln einer Nullstelle per Unterschiedliche_Vorzeichen-Regel"

Proc Fn :Paramètres fn&,x!:Déclarer y!

    Select fn&

        caseof 0: y!=sqr(x!)+exp(x!)-2

        caseof 1: y!=cos(x!)

        caseof 2: y!=3-sin(x!)

        caseof 3: y!=40-exp(x!)

        caseof 4: y!=10

        Otherwise : y!=rnd(1000)
        Endselect :Retour y!

    endproc

    Proc ShowFn :Paramètres fn& :declare y$

        Select fn&

            caseof 0: y$="y=sqr(x)+exp(x)-2"

            caseof 1: y$="y=cos(x)"

            caseof 2: y$="y=3-sin(x)"

            caseof 3: y$="y=40-exp(x)"

            caseof 4: y$="y=10"

            Otherwise : y$="y=Undefined "
            Endselect :return y$

        endproc

        Proc Bisect

            ' Den Vorzeichenwechsel eingabeln
            Paramètres fn&,xl!,xr!,epsx!,epsy!
            Déclarer yl!,ym!,yr!,xm!
            yl!=Fn(fn&,xl!)

            Repeat

                xm!=(xl!+xr!)*0.5
                ym!=Fn(fn&,xm!)
                cas (abs(ym!)-epsy!)<=0:BREAK

                si (yl!*ym!)<0: xr!=xm!

                elseif (yl!*ym!)=0:BREAK

                    d'autre : xl!=xm!

                endif

            Until 0

            Retour xm!

        endproc

        '---------------------------------------------------------------
        'Hauptprogramm
        declare fn&,x1!,y1!,x2!,y2!,epsx!,epsy!,fakt!
        '---------------------------------------------------------------
        ' Erfolgs- et performanzkritische paramètre!:
        fn&=0'... Testfunktionsnummer
        epsx!=val("1e-16")
        epsy!=val("1e-16")'...Suchgenauigkeit
        x1!=0 : x2!=0.1'... Startintervall
        fakt!= -1.2'... klappt um et vergrößert Suchbereich
        '---------------------------------------------------------------
        'Eingabeln:
        y1!=Fn(fn&,x1!)
        H1:
        y2!=Fn(fn&,x2!)
        cas (y1!*y2!)<0:goto "H4"
        cas (y1!*y2!)=0:goto "H5"
        '>0:' gleiche Vorzeichen ==> Bereich erweitern par ...
        H2:
        x2!=x2!*fakt!'Vergrößerung et Spiegelung à 0-Punkt
        cas abs(x2!)<val("1.1e35"):goto "H1"
        H3:
        Imprimer " Sorry, aucun Nullstelle trouvé!":goto "H6"
        H4:
        x2!=Bisect(fn&,x1!,x2!,epsx!,epsy!)
        Imprimer "\n Nullstelle qui Funktion  ";upper$(ShowFn(Fn&));"\n"
        Imprimer " trouvé chez x = ";format$("%g",x2!);"\n"
        Imprimer " Nullprobe:   y = ";format$("%g",Fn(fn&,x2!));"\n"
        Imprimer " ----------------------------------------------------------"
        H6:
        waitinput
        FIN