1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155
| '********** Tâche # 1 : Programmation de fonctions VBA **********
Function f(k As Double, a As Double, b As Double) As Double
'Fonction permettant de calculer le bêta
'Déclaration des variables
Dim z As Double
Dim C As Double, D As Double
C = 0 'Borne inférieure de l'intégrale
D = 1 'Borne supérieure de l'intégrale
'Déclaration d'une nouvelle variable
Quotient = (D - C) / 2
'Calculs
z = ((Quotient * k) + ((C + D) / 2))
f = (z ^ (a - 1)) * ((1 - z) ^ (b - 1))
'Fin de la procédure
End Function
Function Beta(a As Double, b As Double, Optional n As Long = 10, Optional m As Byte = 5) As Variant
'Fonction permettant de calculer la fonction bêta
'Référence : http://en.wikipedia.org/wiki/Gaussian_quadrature
'Déclaration des variables
Dim w1 As Double, w2 As Double, w3 As Double, w4 As Double, w5 As Double, _
w6 As Double, w7 As Double, w8 As Double, w9 As Double, w10 As Double, _
w11 As Double, w12 As Double, w13 As Double, w14 As Double, w15 As Double 'Poids
Dim x1 As Double, x2 As Double, x3 As Double, x4 As Double, x5 As Double, _
x6 As Double, x7 As Double, x8 As Double, x9 As Double, x10 As Double, _
x11 As Double, x12 As Double, x13 As Double, x14 As Double, x15 As Double 'Points
Dim j As Long
Dim c_i As Double
Dim Somme As Double, Somme1 As Double, Somme2 As Double, Somme3 As Double, Somme4 As Double, Somme5 As Double
Dim Quotient As Double, delta_x As Double
Dim C As Double, D As Double
C = 0 'Borne inférieure de l'intégrale
D = 1 'Borne supérieure de l'intégrale
'Message si a est négatif
If a < 0 Then
Message1 = MsgBox("La valeur de a est négative.", vbRetryCancel + vbCritical, "Problématique")
If Message1 = vbCancel Then Exit Function
If Message1 = vbRetry Then
Message2 = MsgBox("Veuillez réessayer votre calcul avec un a positif.", vbOKOnly + vbInformation, "Problématique")
If Message2 = vbOK Then Exit Function
End If
End If
'Message si b est négatif
If b < 0 Then
Message3 = MsgBox("La valeur de b est négative.", vbRetryCancel + vbCritical, "Problématique")
If Message3 = vbCancel Then Exit Function
If Message3 = vbRetry Then
Message4 = MsgBox("Veuillez réessayer votre calcul avec un b positif.", vbOKOnly + vbInformation, "Problématique")
If Message4 = vbOK Then Exit Function
End If
End If
'Message si a est nul
If a = 0 Then
Message5 = MsgBox("La valeur de a est nulle.", vbRetryCancel + vbCritical, "Problématique")
If Message5 = vbCancel Then Exit Function
If Message5 = vbRetry Then
Message6 = MsgBox("Veuillez réessayer votre calcul avec un a positif.", vbOKOnly + vbInformation, "Problématique")
If Message6 = vbOK Then Exit Function
End If
End If
'Message si b est nul
If b = 0 Then
Message7 = MsgBox("La valeur de b est nulle.", vbRetryCancel + vbCritical, "Problématique")
If Message7 = vbCancel Then Exit Function
If Message7 = vbRetry Then
Message8 = MsgBox("Veuillez réessayer votre calcul avec un b positif.", vbOKOnly + vbInformation, "Problématique")
If Message8 = vbOK Then Exit Function
End If
End If
'Longueur des n sous-intervalles de l'intervalle [C,D]
delta_x = (D - C) / n 'n est le nombre de sous-intervalles
'Déclaration d'une nouvelle variable
Quotient = (D - C) / 2
For j = 1 To n
'Borne inférieure des n sous-intervalles
c_i = C + (j - 1) * delta_x
'Déclaration des points et des poids qui sont déterminés grâce aux polynômes de Legendre
'Référence : http://en.wikipedia.org/wiki/Gaussian_quadrature
x1 = c_i + 0
w1 = 2
x2 = c_i - ((3 ^ 0.5) / 3)
w2 = 1
x3 = c_i + ((3 ^ 0.5) / 3)
w3 = 1
x4 = c_i + 0
w4 = 8 / 9
x5 = c_i - ((3 / 5) ^ 0.5)
w5 = 5 / 9
x6 = c_i + ((3 / 5) ^ 0.5)
w6 = 5 / 9
x7 = c_i + (((3 - (2 * (6 / 5) ^ 0.5)) / 7) ^ 0.5)
w7 = (18 + (30 ^ 0.5)) / 36
x8 = c_i - (((3 - (2 * (6 / 5) ^ 0.5)) / 7) ^ 0.5)
w8 = (18 + (30 ^ 0.5)) / 36
x9 = c_i + (((3 + (2 * (6 / 5) ^ 0.5)) / 7) ^ 0.5)
w9 = (18 - (30 ^ 0.5)) / 36
x10 = c_i - (((3 + (2 * (6 / 5) ^ 0.5)) / 7) ^ 0.5)
w10 = (18 - (30 ^ 0.5)) / 36
x11 = c_i + 0
w11 = 128 / 225
x12 = c_i + (((5 - (2 * (10 / 7) ^ 0.5)) ^ 0.5) / 3)
w12 = (322 + (13 * (70 ^ 0.5))) / 900
x13 = c_i - (((5 - (2 * (10 / 7) ^ 0.5)) ^ 0.5) / 3)
w13 = (322 + (13 * (70 ^ 0.5))) / 900
x14 = c_i + (((5 + (2 * (10 / 7) ^ 0.5)) ^ 0.5) / 3)
w14 = (322 - (13 * (70 ^ 0.5))) / 900
x15 = c_i - (((5 + (2 * (10 / 7) ^ 0.5)) ^ 0.5) / 3)
w15 = (322 - (13 * (70 ^ 0.5))) / 900
If m = 1 Then 'm est le nombre de points de la quadrature gaussienne
'Somme du produit des poids et de f
Somme1 = w1 * f(x1, a, b)
ElseIf m = 2 Then
'Somme du produit des poids et de f
Somme2 = (w2 * f(x2, a, b)) + (w3 * f(x3, a, b))
ElseIf m = 3 Then
'Somme du produit des poids et de f
Somme3 = (w4 * f(x4, a, b)) + (w5 * f(x5, a, b)) + (w6 * f(x6, a, b))
ElseIf m = 4 Then
'Somme du produit des poids et de f
Somme4 = (w7 * f(x7, a, b)) + (w8 * f(x8, a, b)) + (w9 * f(x9, a, b)) + (w10 * f(x10, a, b))
ElseIf m = 5 Then
'Somme du produit des poids et de f
Somme5 = (w11 * f(x11, a, b)) + (w12 * f(x12, a, b)) + (w13 * f(x13, a, b)) + (w14 * f(x14, a, b)) + (w15 * f(x15, a, b))
End If
Somme = Somme + Somme1 + Somme2 + Somme3 + Somme4 + Somme5
Next
'Approximation de la fonction bêta avec la quadrature gaussienne
Beta = Somme * Quotient
'Fin de la procédure
End Function |
Partager