nihe.txt

VB 开发的拟合函数

Function StadMain(FileName As Variant)
    Dim i As Integer, j As Integer
    Dim n As Integer, r As Integer
    Dim d As Boolean, k As Boolean
    Dim x(51) As Single, y(51) As Single
    Dim d1 As Single, d2 As Single
    Dim a(51) As Single, c(51) As Single, u(1024) As Single, g(51) As Single, m(51) As Single, s(1024) As Single
    Dim min As Single, max As Single, Step As Single
    Dim str As Variant
''''''''''''''''''''''''''''''''''''''''''无敌分隔线 ''''''''''''''''''''''''''''''''''''''''''''''
    Open FileName For Input As #1
        Do While Not EOF(1)
            Line Input #1, str
            If Len(str) > 10 And Mid(str, 1, 1) = "-" Then
                For i = 1 To Len(str)
                    If Mid(str, i, 1) = "-" Then
                        j = j + 1
                    End If
                Next i
                If j = Len(str) Then
                    d = True
                    j = 0
                End If
            End If
        Loop
    Close #1
    If d = True Then
        Open FileName For Input As #1
            Do While Not EOF(1)
                Line Input #1, str
                If str <> "" And k = True Then
                    x(n) = Left(str, InStr(str, " "))
                    str = Trim(Right(str, Len(str) - InStr(str, " ")))
                    y(n) = str
                    n = n + 1
                End If
                If Len(str) > 10 And Mid(str, 1, 1) = "-" Then
                    For i = 1 To Len(str)
                        If Mid(str, i, 1) = "-" Then
                            j = j + 1
                        End If
                    Next i
                    If j = Len(str) Then
                        k = True
                    End If
                End If
            
            Loop
        Close #1
    Else
        Open FileName For Input As #1
            Do While Not EOF(1)
                Line Input #1, str
                
                If str <> "" Then
                    If InStr(str, " ") > 0 Then
                        
                        x(n) = Left(str, InStr(str, " "))
                        str = Trim(Right(str, Len(str) - InStr(str, " ")))
                        y(n) = str
                        n = n + 1
                    Else
                        x(n) = Left(str, InStr(str, Chr(9)))
                        str = Trim(Right(str, Len(str) - InStr(str, Chr(9))))
                        y(n) = str
                        n = n + 1
                    End If
                End If
            Loop
        Close #1
    
    End If

    
    
    
    
    
    r = 1023
    n = n - 1
    d1 = 0
    d2 = 0
    min = x(0)
    max = x(n)
    Step = Format((max - min) / 1024, "0.00000000")
    For j = 1 To r
        u(j) = min + Step * j
    Next j
    Call spl(n, r, d1, d2, x, y, a, c, u, g, m, s)
    If Form4.Text2.Text <> "" Then
        Open Form4.Text2.Text For Output As 1
        Close #1
        Open Form4.Text2.Text For Append As 1
            For i = 1 To 1023
                Print #1, Format(u(i), "0.00000000") & "     " & Format(s(i), "0.00000000")
            Next i
        Close #1
    End If
    
End Function

Function spl(n As Integer, r As Integer, d1 As Single, d2 As Single, x() As Single, y() As Single, a() As Single, c() As Single, u() As Single, g() As Single, m() As Single, s() As Single)
    Dim i As Integer, k As Integer
    Dim p1(1024) As Single, p2(1024) As Single, p3(1024) As Single, p4(1024) As Single, h(50) As Single
    For k = 0 To n - 1
        h(k) = x(k + 1) - x(k)
    Next k
    For k = 1 To n - 1
        a(k) = h(k) / (h(k) + h(k - 1))
        c(k) = 1 - a(k)
        g(k) = 3 * (c(k) * (y(k + 1) - y(k)) / h(k) + a(k) * (y(k) - y(k - 1)) / h(k - 1))
    Next k
    c(0) = 1
    a(n) = 1
    g(0) = 3 * (y(1) - y(0)) / h(0) - d1 * h(0) / 2
    g(n) = 3 * (y(n) - y(n - 1)) / h(n - 1) + d2 * h(n - 1) / 2
    Call zgf(a, c, g, m, n)

    For i = 0 To r
        k = 1
        Do While (1)
            If k > n Then
                GoTo L1
            Else
                If u(i) <= x(k - 1) Then
                    GoTo L1
                Else
                    k = k + 1
                End If
            End If
        Loop
L1:
        k = k - 2
        If k >= 0 Then
            p1(i) = ((h(k) + 2 * (u(i) - x(k))) * (u(i) - x(k + 1)) * (u(i) - x(k + 1)) * y(k)) / h(k) / h(k) / h(k)
            p2(i) = ((h(k) - 2 * (u(i) - x(k + 1))) * (u(i) - x(k)) * (u(i) - x(k)) * y(k + 1)) / h(k) / h(k) / h(k)
            p3(i) = ((u(i) - x(k)) * (u(i) - x(k + 1)) * (u(i) - x(k + 1)) * m(k)) / h(k) / h(k)
            p4(i) = ((u(i) - x(k + 1)) * (u(i) - x(k)) * (u(i) - x(k)) * m(k + 1)) / h(k) / h(k)
            s(i) = p1(i) + p2(i) + p3(i) + p4(i)
        End If
    Next i

End Function

Function zgf(a() As Single, c() As Single, g() As Single, m() As Single, n As Integer)
    Dim i As Integer
    Dim b(51) As Single
    
    c(0) = c(0) / 2
    g(0) = g(0) / 2
    
    For i = 1 To n - 1
        b(i) = 2 - a(i) * c(i - 1)
        c(i) = c(i) / b(i)
        g(i) = (g(i) - a(i) * g(i - 1)) / b(i)
    Next i
    b(n) = 2 - a(n) * c(n - 1)
    m(n) = (g(n) - a(n) * g(n - 1)) / b(n)
    For i = n - 1 To 0 Step -1
        m(i) = g(i) - c(i) * m(i + 1)
    Next i
        
End Function