Attribute VB_Name = "MduPublic"
Option Explicit
Public V(), W() As Double '連接權(quán)
Public R(), Q() As Double '閾值
Public z() As Double '輸入層輸出
Public y() As Double '中間層輸出
Public o() As Double '輸出層輸出
Public d() As Double '教師信號(hào)
Public N As Double   '教師信號(hào)數(shù)
Public II As Integer '輸入層節(jié)點(diǎn)數(shù)
Public JJ As Integer  '中間層節(jié)點(diǎn)數(shù)
Public KK As Integer '輸出層節(jié)點(diǎn)
Public Er1() As Double '輸出層各單元一般化誤差
Public Er2() As Double '中間層各單元一般化誤差
'BP網(wǎng)算法模塊
Public L As Double '調(diào)節(jié)系數(shù)
Public Sub StudyMain() '學(xué)習(xí)過程
Call StudyMode '提供教師信號(hào)
Call MidLayer '計(jì)算中間層各單元的輸入/輸出
Call OutLayer '計(jì)算輸出層各單元的輸入/輸出
Call OutError '計(jì)算輸出層各單元的一般化誤差
Call MidError '計(jì)算中間層各單元的一般化誤差
Call Modify_Mid_Out '調(diào)節(jié)中間層至輸出層之間的連接權(quán)及輸出層節(jié)點(diǎn)的閾值
Call Modify_In_Mid '調(diào)節(jié)輸入層至中間層的連接權(quán)及中間層節(jié)點(diǎn)的閾值
End Sub
Public Sub WorkMain()
Call StudyMode
Call MidLayer
Call OutLayer
End Sub

Public Sub Initial() '連接權(quán)、閾值初始化
Dim i, j, k As Integer
Randomize
For j = 1 To JJ
  For i = 1 To II
    V(j, i) = 2 * Rnd - 1
  Next i
Next j
For k = 1 To KK
  For j = 1 To JJ
  W(k, j) = 2 * Rnd - 1
  Next j
Next k
For j = 1 To JJ
  R(j) = 2 * Rnd - 1
Next j
For k = 1 To KK
  Q(k) = 2 * Rnd - 1
Next k
End Sub
Public Sub StudyMode()   '提供教師信號(hào)
z(1) = N
d(1) = Sqr(N)
End Sub

Public Sub MidLayer() '計(jì)算中間層各單元的輸入/輸出
Dim i, j As Integer
Dim net() As Double
ReDim net(JJ)
For j = 1 To JJ
  For i = 1 To II
    net(j) = net(j) + V(j, i) * z(i)
  Next i
  y(j) = f(net(j) - R(j))
Next j
End Sub
Public Sub OutLayer() '計(jì)算輸出層各單元的輸入/輸出
Dim j, k As Integer
Dim net() As Double
ReDim net(KK)
For k = 1 To KK
  For j = 1 To JJ
    net(k) = net(k) + W(k, j) * y(j)
  Next j
  o(k) = f(net(k) - Q(k))
Next k
End Sub
Public Sub OutError() '計(jì)算輸出層各單元的一般化誤差
Dim k As Integer
For k = 1 To KK
Er1(k) = (d(k) - o(k)) * o(k) * (1 - o(k))
Next k
End Sub
Public Sub MidError() '計(jì)算中間層各單元的一般化誤差
Dim j, k As Integer
For j = 1 To JJ
  For k = 1 To KK
    Er2(j) = Er2(j) + Er1(k) * W(k, j)
  Next k
  Er2(j) = Er2(j) * y(j) * (1 - y(j))
Next j
End Sub
Public Sub Modify_Mid_Out() '調(diào)節(jié)中間層至輸出層之間的連接權(quán)及輸出層節(jié)點(diǎn)的閾值
Dim k, j As Integer
For k = 1 To KK
  For j = 1 To JJ
  W(k, j) = W(k, j) + L * Er1(k) * y(j)
  Next j
  Q(k) = Q(k) - L * Er1(k)
Next k
End Sub
Public Sub Modify_In_Mid() '調(diào)節(jié)輸入層至中間層的連接權(quán)及中間層節(jié)點(diǎn)的閾值
Dim i, j As Integer
For j = 1 To JJ
  For i = 1 To II
  V(j, i) = V(j, i) + L * Er2(j) * z(i)
  Next i
  R(j) = R(j) - L * Er2(j)
Next j
End Sub
Public Function f(x As Double) As Double
f = 1 / (1 + Exp(-x))
End Function