绝好原创：vb神经网络原程序.txt

请让我成为会员

'程序中的乱码是注释，考到vb编辑环境即可变成汉字
Public Sub tranBP(putIN() As Single, Target() As Single, MaxPj As Integer, Wij() As Single, Sj() As Single, Vjk() As Single, Rk() As Single, NETin As Integer, NETmid As Integer, NETout As Integer, Ftype As Integer, ByVal MaxTime As Double, ByVal MaxError As Double, g As Single)
    Dim PreError As Double
    For Pj = 1 To MaxPj
        Call netMidOUT(putIN(), Midout(), Pj, Wij(), Sj(), NETin, NETmid, Ftype)
        Call netOUTV(Midout(), Pj, Vjk(), Rk(), NETmid, NETout, 1, putout())
    Next Pj
    TempError = NetError(Target(), MaxPj, NETout, putout())
    tempTime = 0
    Do While MaxTime > tempTime And MaxError < TempError
        ''????í???ê?3?2?òto?2?è¨?μμ÷??á?
        ''????í???ê?è?2?òto?2?è¨?μμ÷??á?
        Call DetaWij(DWij(), MaxPj, g)
        'DT??í???è¨?μ
        Call ChangeNET(Wij(), Vjk(), DWij(), DVjk())
        For Pj = 1 To MaxPj
            Call netMidOUT(putIN(), Midout(), Pj, Wij(), Sj(), NETin, NETmid, Ftype)
            Call netOUTV(Midout(), Pj, Vjk(), Rk(), NETmid, NETout, 1, putout())
        Next Pj
        PreError = TempError
        TempError = NetError(Target(), MaxPj, NETout, putout())
        If PreError > TempError Then
            g = 0.2
        Else
            g = Sqr(g) + 0.1 'MaxPj
        End If
        
If tempTime Mod 40000 = 39999 Then
Dim TempExlData As Excel.Application
Set TempExlData = New Excel.Application
TempExlData.Workbooks.Open App.Path & "\ê?è?ê?3?.xls"
TempExlData.Application.Visible = True
    For j = 1 To 50
        TempExlData.Application.Sheets("sheet1").Range(Excelij(j, 1)) = j
                TempExlData.Application.Sheets("sheet1").Range(Excelij(1, j)) = j
    Next j
    For i = 1 To MaxPj
        For j = 1 To 15
            TempExlData.Application.Sheets("sheet1").Range(Excelij(j + 1, i + 1)) = Target(i, j)
            TempExlData.Application.Sheets("sheet1").Range(Excelij(j + 16, i + 1)) = putout(i, j)
            TempExlData.Application.Sheets("sheet1").Range(Excelij(j + 32, i + 1)) = Target(i, j) - putout(i, j)
        Next j
    Next i
    i = 0
End If
        tempTime = tempTime + 1
        netchgtxt(0) = Format(TempError, "##,##0.00000000")
        netchgtxt(1) = tempTime
        frmGABP.Refresh
    Loop
'    TempExlData.Quit
End Sub
'DT??í???è¨?μ
Public Sub ChangeNET(Wij() As Single, Vjk() As Single, DWij() As Single, DVjk() As Single)
Dim i, j, k  As Integer
For j = 1 To NETmid
    For i = 0 To NETin
       Wij(i, j) = Wij(i, j) + DWij(i, j)
    Next i
    Sj(j) = Sj(j) + DWij(0, j)
Next j

For k = 1 To NETout
    For j = 0 To NETmid
        Vjk(j, k) = Vjk(j, k) + DVjk(j, k)
    Next j
    Rk(k) = Rk(k) + DVjk(0, k)
Next k

End Sub

'????í???ê?è?2?òto?2?è¨?μμ÷??á?
Public Sub DetaWij(DWij() As Single, MaxPj As Integer, ByVal g As Single)
Dim i, j, k, Pj As Integer
Dim Mc As Single
Dim Detjk(0 To 40, 0 To 20) As Single
Dim Detij(0 To 40, 0 To 40) As Single

Mc = 0.5
For j = 1 To NETmid
    For i = 0 To NETin
        DWij(i, j) = DWij(i, j) * MaxPj ' Mc / (1 - Mc)
    Next i
Next j
For k = 1 To NETout
     For j = 0 To NETmid
        DVjk(j, k) = DVjk(j, k) * MaxPj 'Mc / (1 - Mc)
     Next j
Next k

For Pj = 1 To MaxPj
    For k = 1 To NETout
        Detjk(0, k) = (Target(Pj, k) - putout(Pj, k)) * putout(Pj, k) * (1 - putout(Pj, k))
        DVjk(0, k) = DVjk(0, k) + Detjk(0, k)
        For j = 1 To NETmid
            DVjk(j, k) = DVjk(j, k) + Detjk(0, k) * Midout(Pj, j)
        Next j
    Next k
    
    For j = 1 To NETmid
        Detij(0, j) = 0
        For k = 1 To NETout
            Detij(0, j) = Detij(0, j) + Detjk(0, k) * Vjk(j, k)
        Next k
        Detij(0, j) = Midout(Pj, j) * (1 - Midout(Pj, j)) * Detij(0, j)
        DWij(0, j) = DWij(0, j) + Detij(0, j)
        For i = 1 To NETin
            DWij(i, j) = DWij(i, j) + Detij(0, j) * putIN(Pj, i)
        Next i
    Next j
Next Pj
For j = 1 To NETmid
    For i = 0 To NETin
        DWij(i, j) = g * DWij(i, j) / MaxPj * (1 - Mc)
    Next i
Next j
For k = 1 To NETout
     For j = 0 To NETmid
        DVjk(j, k) = g * DVjk(j, k) / MaxPj * (1 - Mc)
     Next j
Next k
End Sub

'????í?????±êê?3?ó??μá·ê?3?????μ??ó2?
Public Function NetError(Target() As Single, MaxPj As Integer, NETout As Integer, putout() As Single) As Double
Dim k, j As Integer
NetError = 0
For j = 1 To MaxPj
    For k = 1 To NETout
        NetError = NetError + (Target(j, k) - putout(j, k)) ^ 2
    Next k
Next j
NetError = Sqr(NetError / NETout / MaxPj)
End Function

'????í???μ?ê?3?￡??á1??úputoutêy×éà?
Public Sub netOUTV(Midout() As Single, ByVal Pj As Integer, Vjk() As Single, Rk() As Single, NETmid As Integer, NETout As Integer, ByVal Ftype As Integer, putout() As Single)
Dim i, k As Integer
Dim j As Integer
For k = 1 To NETout
    putout(Pj, k) = Rk(k)
    For j = 1 To NETmid
        putout(Pj, k) = putout(Pj, k) + Midout(Pj, k) * Vjk(j, k)
    Next j
        putout(Pj, k) = netF(putout(Pj, k), Ftype)
Next k
End Sub
'????é??-?aμ??D???μ,?á1?·??ú midout()êy×éà?
Public Sub netMidOUT(putIN() As Single, Midout() As Single, ByVal Pj As Integer, Wij() As Single, S() As Single, NETin As Integer, NETmid As Integer, ByVal Ftype As Integer)
Dim i, k As Integer
For k = 1 To NETmid
    Midout(Pj, k) = S(k)
    For i = 1 To NETin
        Midout(Pj, k) = Midout(Pj, k) + Wij(i, k) * putIN(Pj, i)
    Next i
    Midout(Pj, k) = netF(Midout(Pj, k), Ftype)
Next k
End Sub
'?ùó?μ?í???oˉêy
Public Function netF(ByVal x As Double, Ftype) As Double
If Ftype = 1 Then
netF = x
'ì?è?????oˉêy
Else
If x > -700 Then
netF = 1 / (1 + Exp(-x))
Else
netF = 1 / (1 + Exp(-700))
End If
End If
End Function