XProfan

Deutsch

p.specht

Es ist nicht immer leicht, zu einem empirisch gefundenen Bezug zwischen zwei Größen eine geeignete mathematische Formel zu finden. Das folgende Programm hilft dabei, eine Funktion mit möglichst kleiner Abweichung von den tatsächlichen Messergebnissen zu finden - auf Englisch heißt das "Curve fitting". Achtung, reine Demo - Rechtslage ungeprüft!

Kompilieren Markieren Separieren

WindowTitle "KURVEN-ANPASSUNG an Meßpunktwolke"
'{ (D) Demoware, 2012-05 übersetzt aus HP-Basic nach XProfan by P. Specht
' Ohne jegliche Gewähr! Nutzung in alleiniger Verantwortung des Anwenders!
' Rechtsvermerk der Vorlage:
' Copyright  1987
' John H. Mathews
' Dept. of Mathematics
' California State University, Fullerton
' Nonlinear Curve Fitting
' PROGRAM CURVEFIT
'}
'{ MAIN LOOP
AppendMenubar 10,"Welcher Gleichungstyp gibt meine Messdaten am besten wieder?"
Font 2:Randomize:Set("decimals",15)' : Set("numwidth",15)
Var MaxN&=100
Declare X![100],X1![100],Y![100],Y1![100]
Declare ans$,tmp$,n&,k&,CTYPE&,A!,B!,C!,D!,E!,F!,X!
Declare XMEAN!,YMEAN!,SUMX!,SUMXY!,ERRER!,L!,LM!
g115:
p200' call SUBROUTINE GET DATA
g125:
p400' call SUBROUTINE CURVE TYPE
p2000' call SUBROUTINE CHANGE VARIABLES
p3000' call SUBROUTINE LINEAR REGRESSION
p4000' call SUBROUTINE CONSTANTS
p5000' call SUBROUTINE RESULTS
Print "\n WANT TO FIT ANOTHER CURVE TO THIS DATA ? ";
Input ANS$
Case (ANS$ = "Y") Or (ANS$ = "y") Or (ANS$ = "J") Or (ANS$ = "j"): p6000' call SUBROUTINE REFRESH
Case (ANS$ = "Y") Or (ANS$ = "y") Or (ANS$ = "J") Or (ANS$ = "j"): Goto "g125"
Print "\n WANT TO FIT A CURVE FOR SOME NEW DATA? ";
Input ANS$
Case (ANS$ = "Y") Or (ANS$ = "y") Or (ANS$ = "J") Or (ANS$ = "j"): Goto "g115"
Goto "g9999"
'}

Proc p200' SUBROUTINE GET DATA

    CLS Rnd(8^8)
    Print "\n Verwendet wird die Methode 'Daten-Linearisierung'"
    Print " Verfügbare Formeln:\n"
    Print " (1) Y=A*X+B,   (2) Y=A/X+B,   (3) Y=D/(X+C)       "
    Print " (4) Y=1/(A*X+B), (5) Y=X/(A+B*X), (6) Y=A*Ln(X)+B "
    Print " (7) Y=C*Exp(A*X),  (8) Y=C*X^A,  (9) Y=(A*X+B)^-2 "
    Print " (10) Y=C*X*Exp(-D*X),    (11) Y=L/(1+C*Exp(A*X))  "
    Print "\n ...für N Messpunkte (X1,Y1),(X2,Y2)...(Xn,Yn) "
    Print " Anzahl der Messpunkte:  N = ";
    Input N&
    Case  N&<2:N&=2
    Print

    WhileLoop n&:K&=&Loop

        Print "X(";K&;") = ";
        Input tmp$
        X![K&]=Val(tmp$)
        X1![K&]=X![K&]
        Locate %csrlin-1,%pos+35
        Print "Y(";K&;") = ";
        Input tmp$
        Y![K&]=Val(tmp$)
        Y1![K&]=Y![K&]
        'PRINT

    EndWhile

EndProc

Proc p400' SUBROUTINE CURVE_TYPE

    CLS Rnd(8^8)
    Print "      WHICH CURVE DO YOU WANT TO FIT ?\n"
    Print " 1:   Y = A * X + B"
    Print " 2:   Y = A / X + B"
    Print " 3:   Y = D / (X + C)"
    Print " 4:   Y = 1 / (A * X + B)"
    Print " 5:   Y = X / (A + B * X)"
    Print " 6:   Y = A * Ln(X) + B"
    Print " 7:   Y = C * Exp(A * X)"
    Print " 8:   Y = C * X^A"
    Print " 9:   Y = (A * X + B)^-2"
    Print "10:   Y = C * X * EXP(-D * X)"
    Print "11:   Y = L / (1 + C * EXP(A * X) )\n"
    Print "      CHOOSE TYPE OF CURVE [1-11]: ";
    Input CTYPE&

    If  CTYPE& = 11

        Goto "g550"

    Else

        Goto "g645"

    EndIf

    g550:
    CLS
    Print
    Print "     YOU CHOSE THE CURVE  Y = L / (1 + C * EXP(A * X))"
    Print
    Print " THE LIMITING  VALUE  L =  LIM   Y(X)  MUST BE GIVEN."
    Print "                                         X ->INF"
    Print
    Print " ENTER  THE  VALUE    L = ";
    Input L!
    LM!=Abs(Y![1])

    WhileLoop 2,n&:k&=&Loop

        Case LM!<Abs(Y![K&]): LM!=Abs(Y![K&])

    EndWhile

    Case L!<=LM!: L!=LM! * 1.0001
    g645:

EndProc

Proc p1000' SUBROUTINE FUNCTIONS

    Select CTYPE&

        CaseOf 1: F!=A!*X!+B! : Goto "g1115"

        CaseOf 2: F!=A!/X!+B! : Goto "g1115"

        CaseOf 3: if (X!+C!)<>0:F!=D!/(X!+C!): Else F!=10^30:endif :Goto "g1115"

        CaseOf 4: F!=1/(A!*X!+B!) : Goto "g1115"

        CaseOf 5: F!=X!/(A!+B!*X!) : Goto "g1115"

        CaseOf 6: F!=A!*LG(X!)+B! : Goto "g1115"

        CaseOf 7: F!=C!*Exp(A!*X!) : Goto "g1115"

        CaseOf 8: F!=C!*Exp(A!*LG(X!)) : Goto "g1115"

        CaseOf 9: F!=1/((A!*X!+B!)*(A!*X!+B!)) : Goto "g1115"

        CaseOf 10: F!=C!*X!*Exp(-D!*X!) : Goto "g1115"

        CaseOf 11: F!=L!/(1+C!*Exp(A!*X!))

    EndSelect

    g1115:

EndProc

Proc p2000' SUBROUTINE CHANGE VARIABLES

    WhileLoop n&:k&=&Loop

        Select CTYPE&

            CaseOf 1

            X![K&]=X1![K&]:Y![K&]=Y1![K&] : Goto "g2118"

            CaseOf 2

            X![K&]=1/X1![K&]:Y![K&]=Y1![K&] : Goto "g2118"

            CaseOf 3

            X![K&]=X1![K&]*Y![K&]:Y![K&]=Y1![K&] : Goto "g2118"

            CaseOf 4

            X![K&]=X1![K&]:Y![K&]=1/Y1![K&] : Goto "g2118"

            CaseOf 5

            X![K&]=1/X1![K&]:Y![K&]=1/Y1![K&] : Goto "g2118"

            CaseOf 6

            X![K&]=LG(X1![K&]):Y![K&]=Y1![K&] : Goto "g2118"

            CaseOf 7

            X![K&]=X1![K&]:Y![K&]=LG(Y1![K&]) : Goto "g2118"

            CaseOf 8

            X![K&]=LG(X1![K&]):Y![K&]=LG(Y1![K&]) : Goto "g2118"

            CaseOf 9

            X![K&]=X1![K&]:Y![K&]=1/SQR(Y1![K&]) : Goto "g2118"

            CaseOf 10

            X![K&]=X1![K&]:Y![K&]=LG(Y1![K&]/X1![K&]) : Goto "g2118"

            CaseOf 11

            X![K&]=X1![K&]:Y![K&]=LG(L!/Y1![K&]-1) : Goto "g2118"

        EndSelect

        g2118:

    EndWhile

Endproc

Proc p3000' SUBROUTINE LINEAR REGRESSION

    XMEAN!=0

    WhileLoop n&:k&=&Loop

        XMEAN!=XMEAN!+X![K&]

    EndWhile

    XMEAN!=XMEAN!/n&
    YMEAN!=0

    WhileLoop n&:k&=&Loop

        YMEAN!=YMEAN!+Y![K&]

    EndWhile

    YMEAN!=YMEAN!/N&
    SUMX!=0

    WhileLoop n&:k&=&Loop

        SUMX!=SUMX!+(X![K&]-XMEAN!)*(X![K&]-XMEAN!)

    EndWhile

    SUMXY!=0

    WhileLoop n&:k&=&Loop

        SUMXY!=SUMXY!+(X![K&]-XMEAN!)*(Y![K&]-YMEAN!)

    EndWhile

    A!=SUMXY!/SUMX!
    B!=YMEAN!-A!*XMEAN!

EndProc

Proc p4000' SUBROUTINE CONSTANTS

    If  CTYPE& = 3

        Goto "g4020"

    Else

        Goto "g4050"

    EndIf

    g4020:
    C!= -1.0/A! : D!= -B!/A! : Goto "g4210"
    g4050:

    If  CTYPE& = 7

        Goto "g4070"

    Else

        Goto "g4090"

    EndIf

    g4070:
    C!=Exp(B!) : Goto "g4210"
    g4090:

    If  CTYPE& = 8

        Goto "g4110"

    Else

        Goto "g4130"

    Endif

    g4110:
    C!=Exp(B!) : Goto "g4210"
    g4130:

    If  CTYPE& = 10

        Goto "g4150"

    Else

        Goto "g4180"

    EndIf

    g4150:
    C!=Exp(B!):D!= -1*A! : Goto "g4210"
    g4180:

    If  CTYPE& = 11

        Goto "g4200"

    Else

        Goto "g4210"

    EndIf

    g4200:
    C!=Exp(B!)
    g4210:

EndProc

Proc p5000' SUBROUTINE RESULTS

    CLS

    Select CTYPE&

        CaseOf 1

        Print "  F(X) = A*X +B"
        Print
        Print "    A  = ",A!
        Print "    B  = ",B!
        Goto "g5120"

        caseof 2

        Print "  F(X) = A/X + B"
        Print
        Print "    A  =",A!
        Print "    B  =",B!
        Goto "g5120"

        caseof 3

        Print "  F(X) = D/(X + C)"
        Print
        Print "    C  =",C!
        Print "    D  =",D!
        Goto "g5120"

        CaseOf 4

        Print "  F(X) = 1/(A*X + B)"
        Print
        Print "    A  =",A!
        Print "    B  =",B!
        Goto "g5120"

        CaseOf 5

        Print "  F(X) = X/(A + B*X)"
        Print
        Print "    A  =",A!
        Print "    B  =",B!
        Goto "g5120"

        CaseOf 6

        Print "  F(X) = A*Ln(X) + B"
        Print
        Print "    A  =",A!
        Print "    B  =",B!
        Goto "g5120"

        CaseOf 7

        Print "  F(X) = C*Exp(A*X)"
        Print
        Print "    A  =",A!
        Print "    C  =",C!
        Goto "g5120"

        CaseOf 8

        Print "  F(X) = C*X^A"
        Print
        Print "    A  =",A!
        Print "    C  =",C!
        Goto "g5120"

        caseof 9

        Print "  F(X) = (A*X + B)^-2"
        Print
        Print "    A  =",A!
        Print "    B  =",B!
        Goto "g5120"

        CaseOf 10

        Print "  F(X) = C*X*EXP(-D*X)"
        Print
        Print "    C  =",C!
        Print "    D  =",D!
        Goto "g5120"

        CaseOf 11

        Print "  F(X) = L/(1+C*EXP(A*X))"
        Print
        Print "    L  =",L!
        Print "    C  =",C!
        Print "    A  =",A!

    EndSelect

    g5120:
    Print
    Print "K            Xk            Yk           F(Xk)       Error  "
    Print "_______________________________________________"

    WhileLoop n&:k&=&Loop

        X! = X1![K&]
        p1000' call SUBROUTINE FUNCTIONS
        ERRER!=Y1![K&] - F!
        Print K&, X1![K&], Y1![K&], F!, ERRER!

    EndWhile

EndProc

Proc p6000' SUBROUTINE REFRESH

    WhileLoop  N&:k&=&Loop

        X![K&]=X1![K&]
        Y![K&]=Y1![K&]

    EndWhile

EndProc

g9999:
End