二次插值法求函数最小值

'求表达式的值
Function erresult(ByVal expression As String, ByVal x As String) As Single
      Dim tmpStr As String
          tmpStr = Replace(UCase(expression), "LN", "Log")
          tmpStr = Replace(tmpStr, "X", x)
          Dim OBJ As Object
           Set OBJ = CreateObject("MSScriptControl.ScriptControl")
           OBJ.Language = "vbscript"
           erresult = OBJ.Eval(tmpStr)
           Set OBJ = Nothing
    End Function
'小数点后保留四位
Function yxw(ByVal b As Single) As Single
yxw = CSng(Fix(b * 10000) / 10000)
End Function

Public Function fmin(ByVal f As String, ByVal a1 As String, ByVal a2 As String, ByVal a3 As String) As String
Const e = 0.01
Dim a4 As String
Dim c1, c2 As Single
Dim f1, f2, f3, f4 As Single
Dim flag As Integer
f1 = erresult(f, a1)
f2 = erresult(f, a2)
f3 = erresult(f, a3)

Do
If a2 = a3 Then
a3 = a3 + 1 '保证分母不为零,如果求得结果与书值不同.修改此处
End If
If a3 = a1 Then
a3 = a3 + 1 '保证分母不为零,如果求得结果与书值不同.修改此处
End If
If f3 = f1 Then
f3 = f3 + 1
End If
c1 = (f3 - f1) / (CSng(a3) - CSng(a1))
c2 = ((f2 - f1) / (CSng(a2) - CSng(a1)) - c1) / (CSng(a2) - CSng(a3))
If c2 = 0 Then
  flag = 1
  Exit Do
End If
a4 = 0.5 * (CSng(a1) + CSng(a3) - c1 / c2)
If (CSng(a4) - CSng(a1)) * (CSng(a3) - CSng(a4)) > 0 Then
     a4 = CStr(a4)
      f4 = erresult(f, a4)
       Else
    flag = 1
      Exit Do
   End If
     If Abs((f2 - f4) / f2) > e Then
         If (CSng(a4) - CSng(a2)) * (CSng(a4) - CSng(a1)) > 0 Then
           If f2 > f4 Then
          a1 = CStr(a2)
          f1 = f2
           a2 = CStr(a4)
          f2 = f4
          Else
          a3 = CStr(a4)
          f3 = f4
          End If
      Else
        If f2 > f4 Then
          a2 = CStr(a4)
          f2 = f4
          a3 = CStr(a2)
          f3 = f2
         Else
         f1 = f4
         a1 = CStr(a4)
         End If
        End If
      Else
         f44 = f4
        a44 = CSng(a4)
        f22 = f2
        a22 = CSng(a2)
          Exit Do
         End If
     Loop
If f44 > f22 Then '这儿怎么和条件相反合适p67有空查查
         fmin = yxw(a44)
            
         Else
        
        flag = 1
        GoTo ee
      End If
      
ee:   If flag = 1 Then
    fmin = yxw(a22)
    End If
        
End Function


'测试函数8*x^3-2*x^2-7*x+3
'区间[0 1 2]
'精度0.01如果不对修改精度
'得最小值x=0.6209 f=-0.204
Private Sub Command1_Click()
Print fmin("8*x^3-2*x^2-7*x+3", 0, 1, 2)
End Sub

Private Sub Form_Load()
Form1.WindowState = 2
End Sub

你可能感兴趣的:(二次插值法求函数最小值)