XProfan

'Var Koeff$="1,10"
'Var Koeff$="10,0,-1000"
'Var Koeff$="1,-10,0,100,0,10,0,1,0,-1000"
Var Koeff$="10,0,-20.2,1.8,-40,300,-1,0"
Titre de la fenêtre "Nullstellen de Polynomen - Bairstow-Verfahren"
' source: https://www.rhirte.de/vb/home2.htm
' Umsetzung des VB-Programms de Prof.em. Dr.Rolf Hirte, Technische Fachhochschule Wildau
' pour XProfan 11.2a; seulement zur manifestation gedacht; aucun garantie! Demoware only!
' Begleittext: qui Solution de Polynomausdrücken (Nullstellensuche) wird inconfortable, si cela
' Polynom etwa vom Grade 5 ou bien z,B. 25 ist. Bairstow verfährt dabei folgendermaßen:
' il spaltet dans einer Iteration laufend qui quadratischen Faktoren ab, qui ensuite dans bekannter Weise
' (phrase de Vieta) gelöst volonté - cela so longtemps, jusqu'à cela Restpolynom vom Grade 0 ou bien 1 ist.
' qui Anwender doit LEDIGLICH chaque Koeffizienten des sur Normalform "Polynom = 0" gebrachten Polynoms
' dans fallender Potenz bereitstellen (Text dans starker Anlehnung à qui genannte source).
'
' WIR ICI saisir qui Koeffizienten sowie cela Absolutglied pour fallendem Exponenten dans une
' Komma-separierten String, z.B. Var Koeff$="10,20,-2.2,1.8,-40,300,1.1111111,0", siehe 1. la ligne.
' après gehts à l'attaque:
Cls
Font 2
AppendMenuBar 253,"Run Bairstow"
AppendMenuBar 252,"Finish"
imprimer
Déclarer Grad&,A$[],A![],W!
A$[]=Explode(Koeff$,»):Grad&=SizeOf(A$[])-1
SetSize A![],Grad&

WhileLoop 0,Grad&

    A![&Boucle]=val(A$[Grad&-&Boucle])

Endwhile

WhileLoop Grad&,0,-1

    Set("NumWidth",1) :set("Décimal",0)

    si &Boucle<Grad&:imprimer " +";:d'autre:imprimer "  ";:endif

        Imprimer "X^";&Boucle,
        Set("NumWidth",26):set("Décimal",15):Imprimer " la fois ";A![&Boucle]

    Endwhile

    Imprimer:Imprimer " Pour Berechnungsstart s'il te plaît bouton drücken!"
    WaitInput
    CLS
    Set("NumWidth",1) :set("Décimal",0)
    Imprimer "Das gegebene Polynom vom Grad ";Grad&;" hat folgende Nullstellen:":Imprimer
    Bairstow(A![])
    WaitInput
    Fin'Main

    Proc Bairstow

        Paramètres A![]
        Var Grad& = SizeOf(A![])-1
        Déclarer i&,R!,P!,P1!,Q!,Q1!,Ce!,s!,t!
        Déclarer B![Grad&],C![Grad&]
        set("NumWidth",20):set("Décimal",15)

        Tandis que Grad& > 2

            R! = 0
            P1! = 1
            Q1! = -1
            B![Grad&] = A![Grad&]
            C![Grad&] = A![Grad&]

            Repeat

                P! = P1!
                Q! = Q1!
                B![Grad&-1] = B![Grad&] * P! + A![Grad& - 1]
                C![Grad&-1] = B![Grad&-1] + B![Grad&] * P!

                Whileloop Grad& - 2 , 0 , -1 : i& = &Boucle'For

                    B![i&] = B![i& + 2] * Q! + B![i& + 1] * P! + A![i&]
                    C![i&] = C![i& + 2] * Q! + C![i& + 1] * P! + B![i&]

                Endwhile' Next

                Ce! = C![2] * C![2] - C![1] * C![3]
                cas Ce! = 0 : Imprimer " autre Startwerte nötig!"
                P1! = P! - (B![1] * C![2] - B![0] * C![3]) / Ce!
                Q1! = Q! - (B![0] * C![2] - B![1] * C![1]) / Ce!
                R! = R! + 1

                Si R! > 4000

                    Imprimer:Imprimer:Imprimer "   Sorry, pour 4000 Runden aucun (weitere) Konvergenz!"
                    WaitInput
                    Fin

                EndIf

            Until Abs(B![0]) + Abs(B![1]) < 10^-12' intérieur loop

            ' Nullstelle des quad. Faktors
            s! = P1! / 2
            t! = P1!*P1! + 4 * Q1!

            Si t! < 0

                Imprimer s!;"   + ";0.5 * Sqrt(-t!);"*i "; : comment
                Imprimer s!;"   - ";0.5 * Sqrt(-t!);"*i "; : comment

            D'autre

                Imprimer s! + 0.5 * Sqrt(t!)
                Imprimer s! - 0.5 * Sqrt(t!)

            EndIf

            whileloop 2,Grad&

                i& = &Boucle
                A![i& - 2] = B![i&]

            endwhile

            Grad& = Grad& - 2

        Endwhile' Outer Boucle

        Si Grad& = 1

            Imprimer -A![0]/A![1]

        D'autre

            s! = -0.5 * A![1] / A![2]
            t! = A![1] * A![1] - 4 * A![2] * A![0]

            Si t! < 0

                Imprimer s!;"   + ";0.5 * Sqrt(-t!) / A![2];"*i "; : comment
                Imprimer s!;"   - ";0.5 * Sqrt(-t!) / A![2];"*i "; : comment

            D'autre

                Imprimer s! + 0.5 * Sqrt(t!) / A![2]
                Imprimer s! - 0.5 * Sqrt(t!) / A![2]

            EndIf

        EndIf

    ENDPROC

    Proc comment

        si nearly(s!,0,9)

            imprimer "(Imaginär)"

        d'autre

            imprimer "(Komplex)"

        endif

    endproc