Die Community zu .NET und Classic VB.

Startseite / Tipps / VB.NET-Tipp 0144: Gewöhnliche Differentialgleichungen lösen

VB.NET-Tipp 0144: Gewöhnliche Differentialgleichungen lösen

 von Dario

Schwierigkeitsgrad:

Framework-Version(en): .NET Framework 3.0, .NET Framework 3.5, .NET Framework 4

.NET-Version(en): Visual Basic 2008, Visual Basic 2010

Download: Download des Beispielprojektes [12,11 KB]

' Dieser Quellcode stammt von http://www.activevb.de
' und kann frei verwendet werden. Für eventuelle Schäden
' wird nicht gehaftet.

' Um Fehler oder Fragen zu klären, nutzen Sie bitte unser Forum.
' Ansonsten viel Spaß und Erfolg mit diesem Source!

' Projektversion:   Visual Studio 2008
' Option Strict:    An
' Option Explicit:  An
' Option Infer:     An
'
' Referenzen: 
'  - System
'  - System.Data
'  - System.Deployment
'  - System.Drawing
'  - System.Windows.Forms
'  - System.Xml
'  - System.Core
'  - System.Xml.Linq
'  - System.Data.DataSetExtensions
'
' Imports: 
'  - Microsoft.VisualBasic
'  - System
'  - System.Collections
'  - System.Collections.Generic
'  - System.Data
'  - System.Drawing
'  - System.Diagnostics
'  - System.Windows.Forms
'  - System.Linq
'  - System.Xml.Linq
'

' ##############################################################################
' ################################# Form1.vb ###################################
' ##############################################################################
Option Strict On

Imports System.Math

Public Class frmMain

    ' Unsere Testfunktion definieren

    ' Startwert = 1
    Dim y0 As Double = 1

    ' Zum Vergleich: f(x) = e^(0.03x)
    Dim f As MathFunction = Function(x) Exp(0.03 * x)

    ' Unsere Differenzialgleichung für f: f'(x) = 0.03*f(x)
    Dim df As Derivative = Function(x, y) 0.03 * y

    Private Sub numH_ValueChanged(ByVal sender As System.Object, _
                                  ByVal e As System.EventArgs) _
                                  Handles numH.ValueChanged

        Dim Image = New Bitmap(PictureBox1.Width, PictureBox1.Height)

        Dim h = numH.Value

        Using g = Graphics.FromImage(Image)
            g.SmoothingMode = Drawing2D.SmoothingMode.HighQuality

            ' Koordinatensystem zeichnen
            g.DrawLine(Pens.Black, 0, PictureBox1.Height \ 2, _
                       PictureBox1.Width, PictureBox1.Height \ 2)
            g.DrawLine(Pens.Black, PictureBox1.Width \ 2, 0, _
                       PictureBox1.Width \ 2, PictureBox1.Height)

            ' Näherungen zeichnen
            ShowGraph(AddressOf Euler, h, Color.Red, g)
            ShowGraph(AddressOf RK4, h, Color.Blue, g)

            ' Exakte Funktion zum Vergleich zeigen
            ShowGraph(Function(_d, x, _y, _h) f(x), 1, Color.Green, g)
        End Using

        PictureBox1.Image = Image
    End Sub

    ' Graph für einen gegebenen Näherungsalgorithmus zeichnen
    Sub ShowGraph(ByVal Algo As Func(Of Derivative, Double, _
                                     Double, Double, Double), _
                  ByVal h As Double, _
                  ByVal Color As Color, _
                  ByVal g As Graphics)


        Dim x = 0.0
        Dim y = y0
        Dim Points As New List(Of PointF)

        ' Funktionswerte mit der Näherung ausrechnen...
        For i = 0 To Width Step h
            Points.Add(New PointF(CSng(x), CSng(y)))
            y = Algo(df, x, y, h)
            x += h
        Next

        Using Pen = New Pen(Color)
            g.DrawLines(Pen, Transform(Points, _
                                       PictureBox1.Width, PictureBox1.Height))
        End Using
    End Sub

    ' Punkte in unser Koordinatensystem umrechnen
    Private Function Transform(ByVal Points As IEnumerable(Of PointF), _
                               ByVal Width As Integer, _
                               ByVal Height As Integer) As PointF()
        Dim Points2 = From Pnt In Points _
                      Where (Not Double.IsInfinity(Pnt.Y)) _
                        AndAlso (Pnt.Y <= 10 * Height) _
                        AndAlso (Pnt.Y > 0) _
                      Select New PointF(CSng(Width / 2 + Pnt.X), _
                                        CSng(Height / 2 - Pnt.Y))
        Return Points2.ToArray()
    End Function
End Class

' ##############################################################################
' ################################## ODE.vb ####################################
' ##############################################################################
Option Strict On

Imports System.Math

Public Module ODE
    Public Delegate Function MathFunction(ByVal x As Double) As Double
    Public Delegate Function Derivative(ByVal x As Double, _
                                        ByVal y As Double) As Double

    ' Euler-Verfahren
    Public Function Euler(ByVal df As Derivative, ByVal x As Double, _
                          ByVal y As Double, ByVal h As Double) As Double
        Return y + df(x, y) * h
    End Function

    ' Runge-Kutta-Verfahren (RK4)
    Public Function RK4(ByVal df As Derivative, ByVal x As Double, _
                        ByVal y As Double, ByVal h As Double) As Double

        Dim k1 = df(x, y)
        Dim k2 = df(x + h / 2, y + h * k1 / 2)
        Dim k3 = df(x + h / 2, y + h * k2 / 2)
        Dim k4 = df(x + h, y + h * k3)

        Return y + h * (k1 + 2 * k2 + 2 * k3 + k4) / 6
    End Function
End Module