mdupublic.bas

一个用于实现BP神经网络算法的程序

Attribute VB_Name = "MduPublic"
Option Explicit
Public V(), W() As Double '连接权
Public R(), Q() As Double '阈值
Public z() As Double '输入层输出
Public y() As Double '中间层输出
Public o() As Double '输出层输出
Public d() As Double '教师信号
Public N As Double   '教师信号数
Public II As Integer '输入层节点数
Public JJ As Integer  '中间层节点数
Public KK As Integer '输出层节点
Public Er1() As Double '输出层各单元一般化误差
Public Er2() As Double '中间层各单元一般化误差
'BP网算法模块
Public L As Double '调节系数
Public Sub StudyMain() '学习过程
Call StudyMode '提供教师信号
Call MidLayer '计算中间层各单元的输入/输出
Call OutLayer '计算输出层各单元的输入/输出
Call OutError '计算输出层各单元的一般化误差
Call MidError '计算中间层各单元的一般化误差
Call Modify_Mid_Out '调节中间层至输出层之间的连接权及输出层节点的阈值
Call Modify_In_Mid '调节输入层至中间层的连接权及中间层节点的阈值
End Sub
Public Sub WorkMain()
Call StudyMode
Call MidLayer
Call OutLayer
End Sub

Public Sub Initial() '连接权、阈值初始化
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()   '提供教师信号
z(1) = N
d(1) = Sqr(N)
End Sub

Public Sub MidLayer() '计算中间层各单元的输入/输出
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() '计算输出层各单元的输入/输出
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() '计算输出层各单元的一般化误差
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() '计算中间层各单元的一般化误差
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() '调节中间层至输出层之间的连接权及输出层节点的阈值
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() '调节输入层至中间层的连接权及中间层节点的阈值
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