XProfan

English

p.specht

with the rechnerischen Solution of/ one u.u. very complicated Gleichung 'F(x)=Vorgabewert', means the Search all jener x-values, with them these Gleichung erfüllt or. 'wahr' is, orders one üblicherweise The Gleichung in order to f(x) less Vorgabewert = 0, and seek to whom Nullstellen the y-Funktionswertes. the BISECTION(Unterteilungs)-take action was thereby of/ one the allerersten successful applied Computeralgorithmen, and has to date as very robuste method bewährt, should hot: the take action supply - tributary of angebenen Suchbereich - with safety very a exakten Nulldurchgang the function as Solution, if a such Solution existing.

Weiterer benefit: The found Solutions count as "technisch stabil". These strength becomes from visibility the maths-Puristen though duch a disadvantage erkauft: it go only Solutions found, The The x-axis objectively cut, means in the sew the Lösungspunkte sowohl positive as well as negatives y-Achsenwerte own. with others Worten: The Algorithmus can no Solutions detect, The through bloße touch the x-axis only of supra or only of under given wären. In such Make would take action How "Regula falsi" or "Newton-Raphson" geeigneter, both having though again your to- and detriments.

Info: The Urheberrechte lying with ACM; here watts only The Portierbarkeit to XProfan demonstrating. without each Gewähr therefore:

Compile Mark Separation

' 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 from https://www.netlib.org/toms/4.gz
' (C) Feb.1960 by ACM-TOMS Association of Computing Machinery
' ----------------------------------------------------------------------------
' (D) demonstration-Migration to XProfan-11.2a in 2014-11 by P.woodpecker, Vienna (Austria)
' it consist Urheberrechte Third! No Warranty Whatsoever! without each Gewähr!
' ----------------------------------------------------------------------------
' Description (F99): Date: Sun, 12 Feb 95 18:54:30 +0000
' hier is a transcription of algorithm #4 from Collected Algorithms
' from ACM. I had to modify some characters to make it fit into ASCII,
' specially the multiplicative operator has become * and greek letters
' are 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 computer Center, Philadelphia, Pa.
' ------------------------------------------------------------------------------
' Comment: Diese procedure evaluates a function at the end-points
' 	of a real interval, switching to on error exit (fools
' 	exit) FLSXT if there is no change of sign. Otherwise
' 	it finds a root by iterated bisection and evaluation
' 	at the midpoint, halting if either the value of the
' 	function is less than the free variable epsilon, or two
' 	successive approximations of the root differ by less
' 	than epsilon1. Epsilon should be chosen of the order of
' 	error in evaluating the function (otherwise time would be
' 	wasted), and epsilon1 of the order of desired accuracy.
' 	Epsilon1 must hardship be less than two units in the last place
' 	carried by the machine or else indefinite cycling wants
' 	occur due to roundoff on bisection. Although this
' 	method is of 0 order, and therefore among the slow-
' 	est, it is applicable to any continuous function. The
' 	fact that no differentiability conditions have to be
' 	checked makes it, therefore, on 'old work-horse'
' 	among routines for finding real roots which have
' 	already been isolated. The free varaibles y1 and y2
' 	are (presumably) the end-points of on interval within
' 	which there is on odd number of roots of the real function F.
' 	Alpha is the temporary exit fot the evaluation of F.;
'---------------------------------------------------------------
'---------------------------------------------------------------
' CERTIFICATION OF ALGORITHM 4
' BISECTION ROUTINE (s. Gorn, _Comm._ACM_, March 1960), Program by
' Patty jane Rader,* Argonne nationwide Laboratory, Argonne, illinois
'
' Bisec what coded for the Royal Precision LGP-30 computer, using inter-
' pretive floating point system (24.2) with 28 bits of significance.
'
'  The following minor correction what found necessary.
'	alpha: go to gamma[1] should be go to gamma[i]
' After this correction what maggot, the program ran smoothly for
'  F(x) = cos x, using the 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 all loops of the program.
' *) Work supported by the u. s. Atomic Energy Commission.
'}
'---------------------------------------------------------------
'{TESTPROGRAMM
CLS
Font 2
Set("decimals",15)
print "\n calculated Testwerte Please with the in the Kommentar"
print " angegebenen Tabellenresultaten vergleichen: \n"
print "   ";stature$("%g",BiSec(0,1,0.001,0.001))
print "   ";stature$("%g",BiSec(0,2,0.001,0.001))
print "   ";stature$("%g",BiSec(1.5,2,0.001,0.001))
print "   ";stature$("%g",BiSec(1.55,2,0.1,0.1))
print "   ";stature$("%g",BiSec(1.5,2,0.001,0.1))
Waitinput
END
'}-------------------------------------------------------------------------
'Function F(x) HIER 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'means ERROR, no Nullstelle in this area
    Bisec:
    i&=1:j&=1:k&=1:x!=y2!
    Alpha:
    f!=F(x!) : case abs(f!)<=epsilon!:return x!

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

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

        if (f!*f1!)>=0

            if j&=1: Print "Keine Nullstelle in this area! Error ";:return FLSXT!

            elseif j&=2: goto "Reg_delta"

            endif

        endif

        if 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:
            case (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'...

05/16/21 ▲

Vollständiges Quote

Absatzweise Quote Zeilenweise Quote

p.specht

Michael Wodrich has a improved Variante pictured:

his comment: "... and a zweiter BiSec(t) without Goto but with Iterationen-Begrenzer (so not unending runs). Both together gemixt and a Iteration before ausgebremst..."

Link: [...]

Compile Mark Separation

' 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 from https://www.netlib.org/toms/4.gz
' (C) Feb.1960 by ACM-TOMS Association of Computing Machinery
' ----------------------------------------------------------------------------
' (D) demonstration-Migration to XProfan-11.2a in 2014-11 by P.woodpecker, Vienna (Austria)
' it consist Urheberrechte Third! No Warranty Whatsoever! without each Gewähr!
' ----------------------------------------------------------------------------
' Description (F99): Date: Sun, 12 Feb 95 18:54:30 +0000
' hier is a transcription of algorithm #4 from Collected Algorithms
' from ACM. I had to modify some characters to make it fit into ASCII,
' specially the multiplicative operator has become * and greek letters
' are 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 computer Center, Philadelphia, Pa.
' ------------------------------------------------------------------------------
' Comment: Diese procedure evaluates a function at the end-points
' 	of a real interval, switching to on error exit (fools
' 	exit) FLSXT if there is no change of sign. Otherwise
' 	it finds a root by iterated bisection and evaluation
' 	at the midpoint, halting if either the value of the
' 	function is less than the free variable epsilon, or two
' 	successive approximations of the root differ by less
' 	than epsilon1. Epsilon should be chosen of the order of
' 	error in evaluating the function (otherwise time would be
' 	wasted), and epsilon1 of the order of desired accuracy.
' 	Epsilon1 must hardship be less than two units in the last place
' 	carried by the machine or else indefinite cycling wants
' 	occur due to roundoff on bisection. Although this
' 	method is of 0 order, and therefore among the slow-
' 	est, it is applicable to any continuous function. The
' 	fact that no differentiability conditions have to be
' 	checked makes it, therefore, on 'old work-horse'
' 	among routines for finding real roots which have
' 	already been isolated. The free varaibles y1 and y2
' 	are (presumably) the end-points of on interval within
' 	which there is on odd number of roots of the real function F.
' 	Alpha is the temporary exit fot the evaluation of F.;
'---------------------------------------------------------------
'---------------------------------------------------------------
' CERTIFICATION OF ALGORITHM 4
' BISECTION ROUTINE (s. Gorn, _Comm._ACM_, March 1960), Program by
' Patty jane Rader,* Argonne nationwide Laboratory, Argonne, illinois
'
' Bisec what coded for the Royal Precision LGP-30 computer, using inter-
' pretive floating point system (24.2) with 28 bits of significance.
'
'  The following minor correction what found necessary.
'	alpha: go to gamma[1] should be go to gamma[i]
' After this correction what maggot, the program ran smoothly for
'  F(x) = cos x, using the 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 all loops of the program.
' *) Work supported by the u. s. Atomic Energy Commission.
'}
'---------------------------------------------------------------
'{TESTPROGRAMM
CLS
Font 2
Set("decimals",15)
print "---------------------------------------------------------------"
print tab(2);"y1";  tab(8);"y2";tab(12);"Epsilon";tab(21);"Epsilon1";tab(31);"Results"
print "---------------------------------------------------------------"
print tab(2);"0";   tab(8);"1"; tab(12);".001";   tab(21);".001";    tab(31);"FLSXT"
print tab(2);"0";   tab(8);"2"; tab(12);".001";   tab(21);".001";    tab(31);"1.5703"
print tab(2);"1.5"; tab(8);"2"; tab(12);".001";   tab(21);".001";    tab(31);"1.5703"
print tab(2);"1.55";tab(8);"2"; tab(12);".1";     tab(21);".1";      tab(31);"1.5500"
print tab(2);"1.5"; tab(8);"2"; tab(12);".001";   tab(21);".1";      tab(31);"1.5625"
print "---------------------------------------------------------------"
print "\n calculated Testwerte Please with the obigen"
print " Tabellenresultaten vergleichen: \n"
print stature$("   BiSec(0,    1, .001, .001) = %g",BiSec(0,1,0.001,0.001))
print stature$("   BiSec(0,    2, .001, .001) = %g",BiSec(0,2,0.001,0.001))
print stature$("   BiSec(1.5,  2, .001, .001) = %g",BiSec(1.5,2,0.001,0.001))
print stature$("   BiSec(1.55, 2, .1,   .1  ) = %g",BiSec(1.55,2,0.1,0.1))
print stature$("   BiSec(1.5,  2, .001, .1  ) = %g",BiSec(1.5,2,0.001,0.1))
print "---------------------------------------------------------------"
print stature$("   BiSect(0,    1, .001, .001) = %g",BiSect(0,1,0.001,0.001))
print stature$("   BiSect(0,    2, .001, .001) = %g",BiSect(0,2,0.001,0.001,9))
print stature$("   BiSect(1.5,  2, .001, .001) = %g",BiSect(1.5,2,0.001,0.001))
print stature$("   BiSect(1.55, 2, .1,   .1  ) = %g",BiSect(1.55,2,0.1,0.1))
print stature$("   BiSect(1.5,  2, .001, .1  ) = %g",BiSect(1.5,2,0.001,0.1))
Waitinput
END
'}-------------------------------------------------------------------------
'Function F(x) HIER 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'means ERROR, no Nullstelle in this area
    Bisec:
    i&=1:j&=1:k&=1:x!=y2!:ii&=0
    Alpha:
    inc ii&':: print "(";ii&;")";
    f!=F(x!) : case abs(f!)<=epsilon!:return x!

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

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

        if (f!*f1!)>=0

            if j&=1: Print "\nKeine Nullstelle in this area! Error\n";:return FLSXT!

            elseif j&=2: goto "Reg_delta"

            endif

        endif

        if 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:
            case (abs(y1!-y2!)>=epsilon1!):goto "Midpoint"
            return x!
            Reg_etha:
            y1!=x!
            goto "Precision"

        ENDPROC

        '-------------------------------------------------------------------------
        'Bisec routine with NMAX:

        Proc BiSect

            Declare float y1,y2,epsilon,epsilon1, long Durchlaeufe

            If %PCount = 5

                Parameters 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

            Else

                Parameters float y1_4,y2_4,e_4,e1_4
                y1 = y1_4 : y2 = y2_4 : epsilon = e_4 : epsilon1 = e1_4 : Durchlaeufe = 100

            EndIf

            Declare float x,f0,f1
            Var long Iterationen = 0
            Var float KEINENULL = -999999999.0' means FEHLER; no Nullstelle in this area
            Var int First = 1
            x = y2

            Repeat

                Inc Iterationen':: print "(";Iterationen;")";
                f0 = F(x)' here becomes The function called
                Case Abs(f0) <= epsilon : Return x

                If Iterationen > 1

                    If (f0 * f1) >= 0

                        If First

                            Print "\nKeine Nullstelle in this area! FEHLER"
                            Return KEINENULL

                        EndIf

                        y2 = x
                        Case (Abs(y1 - y2) < epsilon1): Return x

                    Else

                        Ifnot First

                            y1 = x
                            Case (Abs(y1 - y2) < epsilon1): Return x

                        Else

                            Dec First

                        EndIf

                    EndIf

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

                Else

                    ' the first Durchlauf
                    f1 = f0
                    x = y1

                EndIf

            Until Iterationen >= Durchlaeufe

            Print "\nZu many Durchläufe! (";Durchlaeufe;" are allows)"
            Return x

        ENDPROC

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

05/16/21 ▲

Vollständiges Quote

Absatzweise Quote Zeilenweise Quote

p.specht

others Umsetzung, of yet former:

Compile Mark Separation

Windowtitle "Bisection-Algorithmus"
'Q: Fortran-IV Source from 1962, to XProfan portiert 2015-05 by PS
Cls:Font 2:randomize:AppendMenubar 200,\
"Eingabeln of/ one Nullstelle by Unterschiedliche_Vorzeichen-Regel"

Proc Fn :Parameters fn&,x!:Declare 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 :Return y!

    endproc

    Proc ShowFn :Parameters 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

            ' whom Vorzeichenwechsel eingabeln
            Parameters fn&,xl!,xr!,epsx!,epsy!
            Declare yl!,ym!,yr!,xm!
            yl!=Fn(fn&,xl!)

            Repeat

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

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

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

                    else : xl!=xm!

                endif

            Until 0

            Return xm!

        endproc

        '---------------------------------------------------------------
        'Hauptprogramm
        declare fn&,x1!,y1!,x2!,y2!,epsx!,epsy!,fakt!
        '---------------------------------------------------------------
        ' Erfolgs- and performanzkritische Parameter!:
        fn&=0'... Testfunktionsnummer
        epsx!=val("1e-16")
        epsy!=val("1e-16")'...Suchgenauigkeit
        x1!=0 : x2!=0.1'... Startintervall
        fakt!= -1.2'... works circa and vergrößert Suchbereich
        '---------------------------------------------------------------
        'Eingabeln:
        y1!=Fn(fn&,x1!)
        H1:
        y2!=Fn(fn&,x2!)
        case (y1!*y2!)<0:goto "H4"
        case (y1!*y2!)=0:goto "H5"
        '>0:' same omen ==> area strain through ...
        H2:
        x2!=x2!*fakt!'enhancement and reflection on 0-point
        case abs(x2!)<val("1.1e35"):goto "H1"
        H3:
        Print " Sorry, no Nullstelle found!":goto "H6"
        H4:
        x2!=Bisect(fn&,x1!,x2!,epsx!,epsy!)
        Print "\n Nullstelle the function  ";upper$(ShowFn(Fn&));"\n"
        Print " found with x = ";stature$("%g",x2!);"\n"
        Print " Nullprobe:   y = ";stature$("%g",Fn(fn&,x2!));"\n"
        Print " ----------------------------------------------------------"
        H6:
        waitinput
        END