mdubp.bas

使用VB编写的神经网络BP算法程序

Attribute VB_Name = "MduBP"
'BP网算法模块
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 Integer   '学习次数
Public NN As Integer  '教师信号数
Public Count As Integer '第Count个教师信号数
Public II As Integer '输入层节点数
Public JJ As Integer  '中间层节点数
Public KK As Integer '输出层节点
Public Er1() As Double '输出层各单元一般化误差
Public Er2() As Double '中间层各单元一般化误差
Public L1 As Double '权调节系数
Public L2 As Double '阈调节系数

Public Sub StudyMain() '学习过程
Dim i, j, k As Integer

 For Count = 1 To NN
  Call MidLayer '计算中间层各单元的输入/输出
  Call OutLayer '计算输出层各单元的输入/输出
  Call OutError '计算输出层各单元的一般化误差
  Call MidError '计算中间层各单元的一般化误差
  Call Modify_Mid_Out '调节中间层至输出层之间的连接权及输出层节点的阈值
  Call Modify_In_Mid '调节输入层至中间层的连接权及中间层节点的阈值
 Next Count

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 Teacher()   '提供教师信号
Dim i, j, k As Integer
Dim Max As Double
For j = 1 To NN
 For k = 1 To KK
  For i = 1 To II
   z(j, i) = i / 2 + k / 3 + j / 4
   d(j, k) = d(j, k) + z(j, i) ^ 2
  Next i
 Next k
Next j
For j = 1 To NN
 For k = 1 To KK
 If Max < d(j, k) Then
   Max = d(j, k)
 End If
 Next k
Next j
For j = 1 To NN
 For k = 1 To KK
 d(j, k) = d(j, k) / Max
 Next k
Next j
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(Count, i)
  Next i
  y(Count, 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(Count, j)
  Next j
  o(Count, 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(Count, k) - o(Count, k)) * o(Count, k) * (1 - o(Count, 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(Count, j) * (1 - y(Count, 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) + L1 * Er1(k) * y(Count, j)
  Next j
  Q(k) = Q(k) - L2 * 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) + L1 * Er2(j) * z(Count, i)
  Next i
  R(j) = R(j) - L2 * Er2(j)
Next j
End Sub
Public Function f(x As Double) As Double
f = 1 / (1 + Exp(-x))
End Function