XProfan

Titre de la fenêtre "KURVEN-ANPASSUNG à Meßpunktwolke"
'{ (D) Demoware, 2012-05 traduit aus HP-Basic pour XProfan by P. Specht
' sans jegliche Gewähr! Nutzung dans alleiniger responsabilité des Anwenders!
' Rechtsvermerk qui Présentation:
' Copyright  1987
' John H. Mathews
' Dept. of Mathematics
' California State University, Fullerton
' Nonlinear Curve Fitting
' PROGRAM CURVEFIT
'}
'{ MAIN LOOP
AppendMenubar 10,"Welcher Gleichungstyp gibt mon Messdaten am besten wieder?"
Font 2:Randomiser:Set("decimals",15)' : Set("numwidth",15)
Var MaxN&=100
Déclarer X![100],X1![100],Y![100],Y1![100]
Déclarer à l'$,tmp$,n&,k&,CTYPE&,A!,B!,C!,D!,E!,F!,X!
Déclarer 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
Imprimer "\n WANT TO FIT ANOTHER CURVE TO THIS DATA ? ";
Contribution ANS$
Cas (ANS$ = "Y") Or (ANS$ = "y") Or (ANS$ = "J") Or (ANS$ = "j"): p6000' call SUBROUTINE REFRESH
Cas (ANS$ = "Y") Or (ANS$ = "y") Or (ANS$ = "J") Or (ANS$ = "j"): Goto "g125"
Imprimer "\n WANT TO FIT A CURVE FOR SOME NEW DATA? ";
Contribution ANS$
Cas (ANS$ = "Y") Or (ANS$ = "y") Or (ANS$ = "J") Or (ANS$ = "j"): Goto "g115"
Goto "g9999"
'}

Proc p200' SUBROUTINE GET DATA

    CLS Tour(8^8)
    Imprimer "\n Verwendet wird la méthode 'données-Linearisierung'"
    Imprimer " Verfügbare Formeln:\n"
    Imprimer " (1) Y=A*X+B,   (2) Y=A/X+B,   (3) Y=D/(X+C)       "
    Imprimer " (4) Y=1/(A*X+B), (5) Y=X/(A+B*X), (6) Y=A*Ln(X)+B "
    Imprimer " (7) Y=C*Exp(A*X),  (8) Y=C*X^A,  (9) Y=(A*X+B)^-2 "
    Imprimer " (10) Y=C*X*Exp(-D*X),    (11) Y=L/(1+C*Exp(A*X))  "
    Imprimer "\n ...pour N Messpunkte (X1,Y1),(X2,Y2)...(Xn,Yn) "
    Imprimer " Nombre de Messpunkte:  N = ";
    Contribution N&
    Cas  N&<2:N&=2
    Imprimer

    WhileLoop n&:K&=&Boucle

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

    Endwhile

ENDPROC

Proc p400' SUBROUTINE CURVE_TYPE

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

    Si  CTYPE& = 11

        Goto "g550"

    D'autre

        Goto "g645"

    EndIf

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

    WhileLoop 2,n&:k&=&Boucle

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

    Endwhile

    Cas 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: si (X!+C!)<>0:F!=D!/(X!+C!): D'autre 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&=&Boucle

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

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

    Endwhile

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

    WhileLoop n&:k&=&Boucle

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

    Endwhile

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

    WhileLoop n&:k&=&Boucle

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

    Endwhile

    SUMXY!=0

    WhileLoop n&:k&=&Boucle

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

    Endwhile

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

ENDPROC

Proc p4000' SUBROUTINE CONSTANTS

    Si  CTYPE& = 3

        Goto "g4020"

    D'autre

        Goto "g4050"

    EndIf

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

    Si  CTYPE& = 7

        Goto "g4070"

    D'autre

        Goto "g4090"

    EndIf

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

    Si  CTYPE& = 8

        Goto "g4110"

    D'autre

        Goto "g4130"

    Endif

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

    Si  CTYPE& = 10

        Goto "g4150"

    D'autre

        Goto "g4180"

    EndIf

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

    Si  CTYPE& = 11

        Goto "g4200"

    D'autre

        Goto "g4210"

    EndIf

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

ENDPROC

Proc p5000' SUBROUTINE RESULTS

    CLS

    Select CTYPE&

        CaseOf 1

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

        caseof 2

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

        caseof 3

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

        CaseOf 4

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

        CaseOf 5

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

        CaseOf 6

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

        CaseOf 7

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

        CaseOf 8

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

        caseof 9

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

        CaseOf 10

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

        CaseOf 11

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

    EndSelect

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

    WhileLoop n&:k&=&Boucle

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

    Endwhile

ENDPROC

Proc p6000' SUBROUTINE REFRESH

    WhileLoop  N&:k&=&Boucle

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

    Endwhile

ENDPROC

g9999:
Fin