XProfan

Titre de la fenêtre "Polynom-Regression avec qui Methode qui kleinsten Quadrate"
'---------------------------------------------------
' VisualBasic-Original (C) Prof.em. Rolf HIRTHE, https://www.rhirte.de/vb/home.htm
' Übertragen pour XProfan-11.2a 2014-10 by P.Specht, Wien; sans chacun Gewähr!
'---------------------------------------------------
Fenêtre Style 24:Fenêtre 0,0-%maxx,%maxy-40:randomize:set("decimals",16):font 0
imprimer "\n\n qui Gauss'sche Methode qui minimierten mittleren quadratischen Abweichung"
imprimer " wird ici en supplément verwendet, une Polynomkurve entre Messpunkte einzupassen. "
imprimer " but ist, par Anpassung des Polynomgrades trotz Messfehlern qui dem "
imprimer " Punktverlauf best-angepasste Funktion comme 'Gesetzmäßigkeit' pour trouver.\n"
Déclarer a![50,51],b![50,51],x![50],y![50],Xv![25],Yv![25],grad&,paar&
'---------------------------------------------------
' quelques Messpunkte P(xv,yv) comme Testbeispiel:
'---------------------------------------------------
paar&=5
Xv![1] = 1   : Yv![1]= -0.3
Xv![2] = 1.9 : Yv![2] = 0.3
Xv![3] = 2.9 : Yv![3] = 1.3
Xv![4] = 4   : Yv![4] = 3.3
Xv![5] = 5.1 : Yv![5] = 4.3
'---------------------------------------------------
grad& = 2' des Polynoms
'---------------------------------------------------
font 2
Imprimer "\n\n Anpassung eines Polynoms "+str$(grad&)+". Grades"
imprimer " à ";paar&;" Messpunkte (Einprogrammmiertes Beispiel)\n\n"
'---------------------------------------------------
imprimer AUSGLEICH(paar&,grad&,Xv![],Yv![])
'---------------------------------------------------
'ici pourrait une grafische Ausgabe den Kurvenverlauf montrer
waitinput
FIN
'===================================================

Proc AUSGLEICH :parameters paar&,Pgrad&,Xv![],Yv![]

    declare i&,j&,k&,Ggrad&,Mat![25,25],Fak!,A![25],sig!,txt$

    Si paar& < (Pgrad& + 1)'Vorbereitende Eingaben

        txt$=" FEHLER: numéro qui Wertepaare pas ausreichend!"
        goto "Exit_Sub"

    EndIf

    Ggrad&=Pgrad&+1

    Whileloop Ggrad&:i&=&Boucle

        WhileLoop Ggrad&+1:j&=&Boucle

            Mat![i&,j&]=0

        endwhile

    endwhile

    '---------------------------------------------------
    Mat![1,1]=paar&' Aufbau qui Matrix

    WhileLoop paar&:i&=&Boucle

        Mat![1,Ggrad&+1]=Mat![1,Ggrad&+1]+Yv![i&]
        Fak!=1

        Whileloop 2,Ggrad&:j&=&Boucle

            Fak! = Fak! * Xv![i&]
            Mat![1,j&]=Mat![1,j&]+Fak!
            Mat![j&,Ggrad&+1] = Mat![j&,Ggrad&+1]+Fak!*Yv![i&]

        Endwhile

        Whileloop 2,Ggrad&:j&=&Boucle

            Fak! = Fak! * Xv![i&]
            Mat![j&,Ggrad&]=Mat![j&,Ggrad&]+Fak!

        endwhile

    endwhile

    whileloop 2,Ggrad&:i&=&Boucle

        WhileLoop Ggrad&-1:j&=&Boucle

            Mat![i&,j&]=Mat![i&-1,j&+1]

        endwhile

    endwhile

    '---------------------------------------------------
    ' Aufruf qui Routine zur Solution des lin. GS
    GAUSS Ggrad&,Mat![],a![]
    '---------------------------------------------------
    txt$=»'Ergebnisanzeige

    WhileLoop Ggrad&:i&=&Boucle

        txt$=txt$+" a"+str$(int(i&-1))+" = "+str$(a![i&])+"\n"

    endwhile

    txt$=txt$+"\n"
    sig!=0
    '---------------------------------------------------
    ' Berechnung et Anzeige zur la qualité qui Anpassung
    '---------------------------------------------------

    whileloop paar&:i&=&Boucle

        Fak! = a![Ggrad&]

        WhileLoop Ggrad&-1,1,-1:j&=&Boucle

            Fak! = a![j&] + Xv![i&] * Fak!

        endwhile

        sig!=sig!+sqr(Yv![i&]-Fak!)
        txt$=txt$+" y("+str$(i&)+")="+str$(Yv![i&])+" -> "+format$("%g",Fak!)+"\n"

    endwhile

    txt$=txt$+"\n Durchschnittliche Abweichung [dsig] = " + str$(Sqrt(sig!/(paar&-2)))+"\n"
    '---------------------------------------------------
    Exit_Sub:
    return txt$

ENDPROC

Proc Gauss :parameters n&,A![],x![]

    declare i&,j&,k&,jmax&,kmax&,merk&[]
    declare s!,max!,skal![]
    setsize merk&[],n&
    setsize skal![],n&
    '---------------------------------------------------
    ' Reihenfolge sichern

    whileloop n&:i&=&Boucle

        merk&[i&] = i&

    endwhile

    '---------------------------------------------------
    ' Normalisierung

    whileloop n&:i&=&Boucle

        s! = 0

        whileloop n&:j&=&Boucle

            s! = s! + Abs(A![i&,j&])

        endwhile

        skal![i&]=1/s!

    endwhile

    '---------------------------------------------------
    ' Vorwärtselimination

    whileloop n&-1:k&=&Boucle

        max! = skal![k&]*Abs(A![k&,k&])
        kmax& = k&'Spalte avec max
        jmax& = k&'la ligne avec max
        'Pivotzelle chercher:

        whileloop k&,n&:j&=&Boucle

            whileloop k&,n&:i&=&Boucle

                Si (skal![j&]*Abs(A![j&,i&]))> max!

                    jmax& = j&
                    kmax& = i&
                    max! = skal![j&]*Abs(A![j&,i&])

                EndIf

            endwhile

        endwhile

        '---------------------------------------------------

        Si jmax& <> k&' Zeilentausch, si nötig

            whileloop k&,n&+1:j&=&Boucle

                s! = A![k&,j&]
                A![k&,j&] = A![jmax&,j&]
                A![jmax&,j&] = s!

            endwhile

            s! = skal![k&]
            skal![k&] = skal![jmax&]
            skal![jmax&] = s!

        EndIf

        '---------------------------------------------------

        Si kmax& <> k&'Spaltentausch, si nötig

            whileloop n&:i&=&Boucle

                s! = A![i&,k&]
                A![i&,k&] = A![i&,kmax&]
                A![i&,kmax&] = s!

            endwhile

            j& = merk&[k&]
            merk&[k&] = merk&[kmax&]
            merk&[kmax&] = j&

        EndIf

        '---------------------------------------------------
        ' eigentliche Elimination

        whileloop k&+1,n&:i&=&Boucle

            s! = A![i&,k&]/A![k&,k&]
            A![i&,k&]=0

            whileloop k&+1,n&+1:j&=&Boucle

                A![i&,j&] = A![i&,j&] - s! * A![k&,j&]

            endwhile

        endwhile

    endwhile

    '---------------------------------------------------
    ' Auflösung arriéré
    x![merk&[n&]] = A![n&,n&+1]/A![n&,n&]

    whileloop n&-1,1,-1:i&=&Boucle

        s! = A![i&,n&+1]

        whileloop i&+1,n&:j&=&Boucle

            s! = s! - A![i&,j&]*x![merk&[j&]]

        endwhile

        x![merk&[i&]]=s!/A![i&,i&]

    endwhile

ENDPROC