Optimum d'une fonction

Commenter

Contenu du snippet

COMME TOUJOURS C'EST DU CALCUL NUMERIQUE

Source / Exemple : 


Private Const KMAX As Integer = 30
    Private Const INFINI As Double = 1E+30
    Private Const errNONVAL As Integer = -1
    Private Const errNONCNV As Integer = -2
    Private Const errNONAPP As Integer = -3
    Private Const errSINGUL As Integer = -4
    Private Const errDIVERG As Integer = -5
Option Explicit
Public Sub OPTIM_Dichotomie(ByVal nf As Integer, _
                             ByVal a As Double, _
                             ByVal b As Double, _
                             ByVal eps As Double, _
                             ByRef Xm As Double, _
                             ByRef Ym As Double, _
                             ByRef err As Integer)
                                 
    Dim l As Double
    Dim Xn As Double, Xp As Double
    Dim Yn As Double, Yp As Double
    
    Call BORN_Choix(a, b, Xn, Xp)
    If (Xp = Xn) Then err = errNONVAL: Exit Sub
    l = Xp - Xn
    
    err = -1
    Do
        err = err + 1
        If (err > KMAX) Then err = errNONCNV: Exit Sub
        l = 0.5 * l
        Xm = Xp - l
        Yp = Fonc(nf, Xm + eps / 2)
        Yn = Fonc(nf, Xm - eps / 2)
        If (Yp > Yn) Then
            Xn = Xm - eps / 2
        Else
            Xp = Xm + eps / 2
        End If
    Loop Until ((Abs(l) < eps))
    Xm = (Xn + Xp) / 2
    Ym = Fonc(nf, Xm)
End Sub
Public Sub OPTIM_Parabolique(ByVal nf As Integer, _
                             ByVal a As Double, _
                             ByVal b As Double, _
                             ByVal eps As Double, _
                             ByRef Xm As Double, _
                             ByRef Ym As Double, _
                             ByRef err As Integer)
                                 
    Dim l As Double, c As Double, Yc As Double
    Dim Xn As Double, Xp As Double, Xm1 As Double
    Dim Yn As Double, Yp As Double
    
    Call BORN_Choix(a, b, Xn, Xp)
    If (Xp = Xn) Then err = errNONVAL: Exit Sub
    
    c = (Xp + Xn) / 2
    err = -1
    Do
        err = err + 1
        If (err > KMAX) Then err = errNONCNV: Exit Sub
        Yc = Fonc(nf, c)
        Xm1 = 2 * (Xn * (Yc - Yp) + Xp * (Yn - Yc) + c * (Yp - Yn))
        If (Xm1 = 0) Then Exit Sub
        Xm = ((Xn ^ 2 - Xp ^ 2) * Yc - (Xn ^ 2 - c ^ 2) * Yp + (Xp ^ 2 - c ^ 2) * Yn) / Xm1
        Ym = Fonc(nf, Xm)
        If (Xm > c) Then
            If (Ym > Yc) Then
                Xn = c
                c = Xm
            Else
               If (Ym < Yc) Then
                   Xp = c
               Else
                   c = c + eps
               End If
            End If
        Else
            If (Xm < c) Then
               If (Ym > Yc) Then
                  Xp = c
                  c = Xm
               Else
                   If (Ym < Yc) Then
                      Xn = Xm
                   Else
                      c = c + eps
                   End If
               End If
            Else
               c = c + eps
            End If
         End If
        l = Xp - Xn
      
    Loop Until ((Abs(l) < eps))
    Xm = (Xn + Xp) / 2
    Ym = Fonc(nf, Xm)
End Sub
Public Sub OPTIM_NombreDor(ByVal nf As Integer, _
                             ByVal a As Double, _
                             ByVal b As Double, _
                             ByVal eps As Double, _
                             ByRef Xm As Double, _
                             ByRef Ym As Double, _
                             ByRef err As Integer)
                                 
    Dim l As Double, ALFA As Double
    Dim Xn As Double, Xp As Double
    Dim Yn As Double, Yp As Double
    
    Call BORN_Choix(a, b, Xn, Xp)
    If (Xp = Xn) Then err = errNONVAL: Exit Sub
    l = Xp - Xn
    ALFA = (Sqr(5) - 1) / 2
    Yn = Fonc(nf, Xn)
    Yp = Fonc(nf, Xp)
    
    err = -1
    Do
        err = err + 1
        If (err > KMAX) Then err = errNONCNV: Exit Sub
        l = ALFA * l
        If (Yp > Yn) Then
            Xn = Xn + l
            Yn = Fonc(nf, Xn)
        Else
            Xp = Xp - l
            Yp = Fonc(nf, Xp)
        End If
    Loop Until ((Abs(l) < eps))
    Xm = (Xn + Xp) / 2
    Ym = Fonc(nf, Xm)
End Sub
Private Sub BORN_Choix(ByVal a As Double, _
                       ByVal b As Double, _
                       ByRef Xn As Double, _
                       ByRef Xp As Double)
    If (b > a) Then
        Xp = b
        Xn = a
    Else
        Xp = a
        Xn = b
    End If
End Sub

A voir également

S'inscrire maintenant

Vous n'êtes pas encore membre ?

inscrivez-vous, c'est gratuit et ça prend moins d'une minute !

Les membres obtiennent plus de réponses que les utilisateurs anonymes.

Le fait d'être membre vous permet d'avoir un suivi détaillé de vos demandes et codes sources.

Le fait d'être membre vous permet d'avoir des options supplémentaires.

Du même auteur (azizimoh)