Dim aa As Double, bb As Double  '分别接收findway有根区间两端值的变量
Dim x(1) As Double '分别接收ercigenway的根

'1.0  ercigenway  求二次方程实根                                                         -已测试
Private Sub ercigenway(a As Single, b As Single, c As Single) 'a、b、c对应为二次方程的系数
Dim d As Double
d = b ^ 2 - 4 * a * c
If d < 0 Then
  MsgBox "Δ小于0，没有实根", , "消息"
  x(0) = 0: x(1) = 0
ElseIf d = 0 Then
  x(0) = -b / (2 * a): x(1) = x(0)
Else
  x(0) = (-b - Sgn(b) * Sqr(d)) / (2 * a): x(1) = c / (a * x(0))
End If
End Sub

'2.1  findway     等步长扫描有根区间                                                      -已测试
Private Sub findway(ByVal a As Single, ByVal b As Single, h As Double) 'a、b分别为待扫描区间端点，h为步长
  Dim a1 As Double
  a1 = a
  Do
    If f(a1) * f(a1 + h) <= 0 Then
      aa = a1: bb = a1 + h
      Exit Sub
    End If
    a1 = a1 + h
  Loop While a1 < b
  If a1 > b Then
    MsgBox "没有找到有根区间，请换更小的步长试一下"
    Exit Sub
  End If
End Sub

'2.2  erfenfun  二分法求根                                                                -已测试
Private Function erfenfun(ByVal a As Single, ByVal b As Single, eps As Double) 'a、b为有根区间端点，eps为误差
  Dim x0 As Double, x1 As Double, x2 As Double, f0 As Double, f1 As Double, f2 As Double
  x1 = a: x2 = b
  Do
    x0 = (x1 + x2) / 2
    f0 = f(x0)
    If f0 = 0 Then
      Exit Do
    Else
      f1 = f(x1): f2 = f(x2)
      If f0 * f1 < 0 Then
        x2 = x0
      Else
        x1 = x0
      End If
    End If
  Loop While Abs(x1 - x2) > eps
  x0 = (x1 + x2) / 2
  erfenfun = x0
End Function

'2.4 newtonfxfun  Newton切线法                                                             -已测试
Private Function newtonfxfun(ByVal x0 As Double, eps As Double) As Double 'x0为附近根，eps为误差
  Dim x1 As Double, f0 As Double, f1 As Double
  x1 = x0
  Do
    x0 = x1
    f0 = f(x0): f1 = fd(x0) 'fd表示f的导函数
    If Abs(f1) < eps Then
      x1 = x0: Exit Do
    End If
    x1 = x0 - f0 / f1
  Loop Until Abs(x1 - x0) < eps
  newtonfxfun = x1
End Function

'2.3  stediedaifun  Seffensen加速迭代法  (方程形式为x-f(x)=0)                             -已测试
Private Function stediedaifun(ByVal x0 As Double, eps1 As Double, eps2 As Double) As Double 'x0为解析解附近的根，eps1为输出结果误差，eps2为迭代能否继续判断标准
  Dim y As Double, z As Double, x1 As Double
  x1 = x0
  Do
    x0 = x1
    y = f(x0): z = f(y)
    If Abs(z - 2 * y + x0) < eps2 Then
      MsgBox "为满足eps2条件，不能继续迭代"
      Exit Function
    End If
    x1 = x0 - (y - x0) ^ 2 / (z - 2 * y + x0)
  Loop Until Abs(x1 - x0) < eps1
  stediedaifun = x1
End Function
 
'2.5  newtonfxnfun  n次代数方程Newton切线法                                               -已测试
Private Function newtonfxnfun(a() As Single, eps As Double, x0 As Double) As Double  'a()分别存储按降幂排列的方程的n个系数，eps为误差，x0为附近根
  Dim k As Integer, n As Integer, f0 As Double, f1 As Double, x1 As Double
  n = UBound(a)
  x1 = x0
  Do
    x0 = x1
    f0 = a(0): f1 = f0
    For k = 1 To n - 1
      f0 = a(k) + f0 * x0
      f1 = f0 + f1 * x0
    Next k
    f0 = a(n) + f0 * x0
    x1 = x0 - f0 / f1
  Loop Until Abs(x1 - x0) < eps
  newtonfxnfun = x1
End Function

'2.6  linecutfun  弦截法                                                                  -已测试
Private Function linecutfun(ByVal x0 As Double, ByVal x1 As Double, eps As Double, n As Long) As Double  'n为迭代次数限制，x0、x1为有根区间端点，eps为误差
  Dim f0 As Double, f1 As Double, f2 As Double
  Dim x2 As Double, i As Long
  f0 = f(x0): f1 = f(x1)
  For i = 1 To n
    x2 = x1 - (x1 - x0) * f1 / (f1 - f0)
    f2 = f(x2)
    If Abs(f2) < eps Then
      Exit For
    End If
    x0 = x1: x1 = x2: f0 = f1: f1 = f2
  Next i
  If i = n + 1 Then
  MsgBox "要求的计算次数太低，没有达到精度要求"
  End If
  linecutfun = x2
End Function

'4.1  lagrangeczfun  拉格朗日插值法                                                         -已测试
Private Function lagrangeczfun(a() As Double, ByVal u As Double) As Double  'a(1,n)存储n+1个节点，u为插值点
  Dim i As Integer, j As Integer, n As Integer
  Dim l As Double, v As Double
  v = 0
  n = UBound(a, 2)
  For j = 0 To n
    l = 1#
    For i = 0 To n
      If i = j Then GoTo hulue
      l = l * (u - a(0, i)) / (a(0, j) - a(0, i))
hulue:
    Next i
    v = v + l * a(1, j)
  Next j
  lagrangeczfun = v
End Function

'4.2  newtonczfun  newton插值法                                                           -已测试
Private Function newtonczfun(a() As Double, u As Double) As Double 'a(1,n)存储n+1个节点，u为插值点
  Dim n As Integer, i As Integer, j As Integer, k As Integer
  Dim z() As Double, f() As Double, v As Double
  n = UBound(a, 2)
  ReDim z(n), f(n)
  For i = 0 To n
    z(i) = a(1, i)
  Next i
  For i = 1 To n
    k = k + 1
    For j = i To n
      f(j) = (z(j) - z(j - 1)) / (a(0, j) - a(0, j - k))
    Next j
    For j = i To n
      z(j) = f(j)
    Next j
  Next i
  f(0) = a(1, 0)
  v = 0
  For i = n To 0 Step -1
    v = v * (u - a(0, i)) + f(i)
  Next i
  newtonczfun = v
End Function

'4.3  hermiteczfun  Hermite插值法                                                        -已测试
Private Function hermiteczfun(a() As Double, fd() As Double, u As Double) As Double 'a(1,n)存储n+1个节点，fd(n)存储n+1个节点处导数值，u为插值点
  Dim l() As Double, ld() As Double, g() As Double, h() As Double, aim As Double
  Dim n As Integer, i As Integer, j As Integer
  n = UBound(a)
  ReDim l(n), ld(n), g(n), h(n)
  aim = 0
  For i = 0 To n
    l(i) = 1: ld(i) = 0
    For j = 0 To n
      If j = i Then GoTo hulue
      l(i) = l(i) * (u - a(0, j)) / (a(0, i) - a(0, j))
      ld(i) = ld(i) + 1 / (a(0, i) - a(0, j))
hulue:
    Next j
    g(i) = (1 + 2 * (a(0, i) - u) * ld(i)) * l(i) * l(i)
    h(i) = (u - a(0, i)) * l(i) * l(i)
    aim = aim + g(i) * a(1, i) + h(i) * fd(i)
  Next i
  hermiteczfun = aim
End Function

'5.2.1  tixingjffun  变步长梯形积分法                                                   -已测试
Private Function tixingjffun(a As Single, b As Single, eps As Double, m As Long) As Double 'a、b分别为积分上下限，eps为误差，m为最大计算次数
  Dim h As Double, t1 As Double, t2 As Double, t As Double, hh As Double
  Dim n As Long: n = 1
  h = b - a: t1 = h * (f(a) + f(b)) / 2
  Do
    t = 0
    For i = 1 To n
      t = t + f(a + (i - 0.5) * h)
    Next i
    hh = h * t
    t2 = (t1 + hh) / 2
    If Abs(t2 - t1) < eps Then Exit Do
    t1 = t2: h = h / 2: n = 2 * n
  Loop Until n > 2 * m
  If n > 2 * m Then
  MsgBox "计算次数预定太小，不能达到误差要求"
  End If
  tixingjffun = t2
End Function

'5.2.2  simpsonjffun  变步长Simpson积分法                                              -已测试
Private Function simpsonjffun(a As Single, b As Single, eps As Double, m As Long) As Double 'a、b分别为积分上下限，eps为误差，m为最大计算次数
  Dim n As Long, i As Long
  Dim h As Double, t1 As Double, t2 As Double, hh As Double, s1 As Double, s2 As Double
  n = 1: h = b - a: t1 = h * (f(a) + f(b)) / 2
  hh = h * (f((a + b) / 2)): s1 = (t1 + 2 * hh) / 3
  Do
    n = 2 * n: h = h / 2: t2 = (t1 + hh) / 2
    t = 0
    For i = 1 To n
      t = t + f(a + (i - 0.5) * h)
    Next i
    hh = t * h
    s2 = (t1 + 2 * hh) / 3
    If Abs(s2 - s1) < eps Then Exit Do
    t1 = t2: s1 = s2
  Loop Until n > m
  If n > m Then MsgBox "计算次数预定太小，不能达到误差要求"
  simpsonjffun = s2
End Function

'5.3  Rombergjffun  Romberg积分法
Private Function rombergjffun(a As Single, b As Single, eps As Double) As Double
Dim k As Integer, n As Integer, h As Double

k = 0: n = 1: h = b - a

End Function

'5.5.1  ds1fun  求一阶导数                                                             -已测试
Private Function ds1fun(x0 As Single, eps As Double) As Double 'x0为求导点，eps为误差
  Dim h As Double, t1 As Double, t2 As Double
  h = 1: t1 = (f(x0 + h) - f(x0 - h)) / (2 * h)
  h = h / 2: t2 = (f(x0 + h) - f(x0 - h)) / (2 * h)
  Do While Abs(t2 - t1) > eps
    t1 = t2
    h = h / 2
    t2 = (f(x0 + h) - f(x0 - h)) / (2 * h)
  Loop
  ds1fun = t2
End Function

'5.5.2  ds2fun  求二阶导数                                                                    -已测试
Private Function ds2fun(x0 As Single, eps As Double) As Double 'x0为求导点，eps为误差
  Dim h As Double, t1 As Double, t2 As Double
  h = 1: t1 = (f(x0 + h) + f(x0 - h) - 2 * f(x0)) / (h * h)
  h = h / 2: t2 = (f(x0 + h) + f(x0 - h) - 2 * f(x0)) / (h * h)
  Do While Abs(t2 - t1) > eps
    t1 = t2
    h = h / 2
    t2 = (f(x0 + h) + f(x0 - h) - 2 * f(x0)) / (h * h)
  Loop
  ds2fun = t2
End Function