XProfan

Titre de la fenêtre "ROMBERG-INTEGRATION"
'{Numerische intégration einer Funktionskurve
' pour dem Rundungsfehler-resistenten Romberg-procéder
' (Siehe https://de.wikipedia.org/wiki/Werner_Romberg)
' Konvergiert chez allen stetigen Funktionen!
' Demo-Übersetzung pour XProfan 11.2a 2012-05 by P.Specht,
' source: https://de.wikipedia.org/wiki/Romberg-intégration,
' plus deux 30 Jahre vieille EDV-Zeitschriften. sans Gewähr!
' situation juridique ungeprüft! seulement pour Demonstrationszwecke!
'}
'{ initialisation
Font 2:randomize:cls rnd(8^8):set("decimals",18)
AppendMenuBar 10,"Numerische intégration pour Rhomberg"
Déclarer xu!,xo!,n!,g!,tmp!,Integral!
'}

proc Fnk :parameters x!

    var a!=100
    var b!=50
    declare y!,aa!,il%
    aa!=a!*a!

    si (a!<>0) and (a!<>x!)

        ' ======= PROGRAMMTEIL A =============
        y! = b!*sqrt(1-x!*x!/aa!)' ELLIPSE a , b
        ' ====================================

    d'autre

        y!=-1*10^-35

    endif

    return y!

endproc

'{ un/Ausgabeteil
Begin:
imprimer "\n qui Funktion ist dans Programmteil A programmiert!"
imprimer "\n Untere Integrationsgrenze Xu= ";:input xu!
imprimer "\n  Obere Integrationsgrenze Xo= ";:input xo!
imprimer "\n Abbruch-Genauigkeit [se mettre]: ";:input g!
g!=1/10^g!
Integral! = Romberg(xu!,xo!,g!)
imprimer "\n Ergebnis:\n"
imprimer " cela Flächen-Integral entre "
imprimer " ";xu!;" et ";xo!
imprimer " beträgt ";format$("%e",Integral!)
imprimer " avec Fehlerschranke ";format$("%e",tmp!)
WaitInput
Goto "Begin"
'}

proc Romberg : parameters xu!,xo!

    var anz&=10' Streifenzahl, empfohlen 10, 12, max.16 (Laufzeit carrée!)
    Déclarer i&,j&,k&,n&[anz&+1],H![anz&+1],L![anz&,anz&],Q!
    n&[0]=2
    H![0]=(xo!-xu!)/n&[0]
    ' benutzt Trapezregel:
    L![0,0]=H![0]/2*(Fnk(xu!)+Fnk(xo!)+2*Fnk(xu!+H![0]))

    WhileLoop Anz&:j&=&Boucle

        H![j&]=H![0]/(2^j&)
        n&[j&]=n&[0]*(2^j&)
        Q!=0

        whileLoop 0,n&[j&-1]-1:i&=&Boucle

            Q!=Q! + Fnk(xu!+(2*i&+1)*H![j&])

        endwhile

        L![0,j&]=L![0,j&-1]/2+H![j&]*Q!

    Endwhile

    WhileLoop Anz&:k&=&Boucle

        whileloop 0,Anz&-1:j&=&Boucle

            L![k&,j&]=1/(2^(2*k&)-1)*(2^(2*k&)*L![k&-1,j&+1]-L![k&-1,j&])

        endwhile

        tmp!=abs(L![k&,0]-L![k&-1,1])
        cas tmp!<=g!:pause

    Endwhile

    ' tmp! contient aktuelle Fehlergrenze
    return L![k&,0]

endproc