XProfan

Título de la ventana "Polynom-Regression con el Método el kleinsten Quadrate"
'---------------------------------------------------
' VisualBasic-Original (C) Prof.em. Rolf HIRTHE, https://www.rhirte.de/vb/home.htm
' Übertragen después de XProfan-11.2a 2014-10 by P.Pájaro carpintero, Wien; Ohne jede Gewähr!
'---------------------------------------------------
Ventana de Estilo 24:Ventana 0,0-%maxx,%maxy-40:randomize:set("decimals",16):font 0
imprimir "\n\n El Gauss'sche Método el minimierten mittleren quadratischen Abweichung"
imprimir " se hier dazu verwendet, una Polynomkurve zwischen Messpunkte einzupassen. "
imprimir " Ziel es, por Anpassung des Polynomgrades trotz Messfehlern el el "
imprimir " Punktverlauf best-angepasste Función como 'Gesetzmäßigkeit' para encontrar.\n"
Declarar a![50,51],b![50,51],x![50],y![50],Xv![25],Yv![25],grad&,paar&
'---------------------------------------------------
' Einige Messpunkte P(xv,yv) como 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
Imprimir "\n\n Anpassung uno Polynoms "+str$(grad&)+". Grades"
imprimir " a ";paar&;" Messpunkte (Einprogrammmiertes Ejemplo)\n\n"
'---------------------------------------------------
imprimir AUSGLEICH(paar&,grad&,Xv![],Yv![])
'---------------------------------------------------
'Hier podría una grafische Edición el Kurvenverlauf zeigen
waitinput
FIN
'===================================================

Proc AUSGLEICH :parámetros paar&,Pgrad&,Xv![],Yv![]

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

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

        txt$=" FEHLER: Zahl el Wertepaare no ausreichend!"
        goto "Exit_Sub"

    EndIf

    Ggrad&=Pgrad&+1

    Whileloop Ggrad&:i&=&Loop

        WhileLoop Ggrad&+1:j&=&Loop

            Mat![i&,j&]=0

        endwhile

    endwhile

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

    WhileLoop paar&:i&=&Loop

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

        Whileloop 2,Ggrad&:j&=&Loop

            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&=&Loop

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

        endwhile

    endwhile

    whileloop 2,Ggrad&:i&=&Loop

        WhileLoop Ggrad&-1:j&=&Loop

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

        endwhile

    endwhile

    '---------------------------------------------------
    ' Aufruf el Rutina a Solución des lin. GS
    GAUSS Ggrad&,Mat![],a![]
    '---------------------------------------------------
    txt$=""'Ergebnisanzeige

    WhileLoop Ggrad&:i&=&Loop

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

    endwhile

    txt$=txt$+"\n"
    sig!=0
    '---------------------------------------------------
    ' Berechnung y Anzeige a Qualität el Anpassung
    '---------------------------------------------------

    whileloop paar&:i&=&Loop

        Fak! = a![Ggrad&]

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

            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:
    volver txt$

ENDPROC

Proc Gauss :parámetros n&,A![],x![]

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

    whileloop n&:i&=&Loop

        merk&[i&] = i&

    endwhile

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

    whileloop n&:i&=&Loop

        s! = 0

        whileloop n&:j&=&Loop

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

        endwhile

        skal![i&]=1/s!

    endwhile

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

    whileloop n&-1:k&=&Loop

        max! = skal![k&]*Abs(A![k&,k&])
        kmax& = k&'Spalte con max
        jmax& = k&'Línea con max
        'Pivotzelle suchen:

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

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

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

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

                EndIf

            endwhile

        endwhile

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

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

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

                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

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

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

            whileloop n&:i&=&Loop

                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&=&Loop

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

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

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

            endwhile

        endwhile

    endwhile

    '---------------------------------------------------
    ' Auflösung rückwärts
    x![merk&[n&]] = A![n&,n&+1]/A![n&,n&]

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

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

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

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

        endwhile

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

    endwhile

ENDPROC