反向传播算法也称BP算法。由于这种算法在本质上是一种神经网络学习的数学模型，所以，有时也称为BP模型。BP算法是为了解决多层前向神经网络的权系数优化而提出来的；所以，BP算法也通常暗示着神经网络的拓扑结构是一种无反馈的多层前向网络，它含有输人层、输出层以及处于输入输出层之间的中间层。中间层有单层或多层，由于它们和外界没有直接的联系，故也称为隐层。在隐层中的神经元也称隐单元。隐层虽然和外界不连接．但是，它们的状态则影响输入输出之间的关系。这也是说，改变隐层的权系数，可以改变整个多层神经网络的性能。
    关于BP的计算原理，网络上又有一大堆，这里就不细说了，下面我们给出3层（输入层、隐含层、输出层）的BP网络代码（采用了动量算法）：
'程序实现功能：模拟QQ截屏
     '作    者： laviewpbt
     '联系方式： laviewpbt@sina.com
     'QQ:33184777
     '版本：Version 1.0.0
     '说明：复制请保留源作者信息，转载请说明，欢迎大家提出意见和建议



Private mW1() As Double             '隐含层的权值           S1  X  R
Private mW2() As Double             '输出层的权值           S2  X  R
Private mB1() As Double             '隐含层的偏置值         S1  X  1
Private mB2() As Double             '输出层的偏置值         S2  X  1
Private mErr() As Double            '均方误差
Private mMinMax() As Double         '输入向量的上下限       R  X  2
Private mS1 As Long                 '隐含层的神经元个数     S1
Private mS2 As Long                 '输出层的神经元个数     S2
Private mR As Long                  '输入层神经元个数       R
Private mGoal As Double             '收敛的精度
Private mLr As Double               '学习速度
Private mGama As Double             '动量系数
Private mMaxEpochs As Long          '最大的迭代次数
Private mIteration As Long          '实际的迭代次数

'****************************************  中间变量   *******************************************

Private HiddenOutput() As Double    '隐含层的输出
Private OutOutput() As Double       '输出层的输出
Private HiddenErr() As Double       '隐含层各神经元的误差
Private OutPutErr() As Double       '输出层各神经元的误差
Private Pdealing() As Double        '当前正在处理的输入
Private Tdealing() As Double        '当前正在处理的输入对应的输出
Private OldW1() As Double           '旧权值数组
Private OldW2() As Double           '旧权值数组
Private OldB1() As Double           '旧偏置值数组
Private OldB2() As Double           '旧偏置值数组
Private Ts As Long                  '输入向量的总个数
Private Initialized As Boolean      '是否已初始化

'****************************************  属性   *******************************************

Public Event Update(iteration)

Public Property Get W1() As Double()
    W1 = mW1
End Property

Public Property Get W2() As Double()
    W2 = mW2
End Property

Public Property Get B1() As Double()
    B1 = mB1
End Property

Public Property Get B2() As Double()
    B2 = mB2
End Property

Public Property Get Err() As Double()
    Err = mErr
End Property

Public Property Get S1() As Long
    S1 = mS1
End Property

Public Property Let S1(Value As Long)
    mS1 = Value
End Property

Public Property Get S2() As Long
    S2 = mS2
End Property

Public Property Get R() As Long
    R = mR
End Property

Public Property Get Goal() As Double
    Goal = mGoal
End Property

Public Sub MinMax(Value() As Double)
    mMinMax = Value
End Sub

Public Property Let Goal(Value As Double)
    mGoal = Value
End Property

Public Property Get Lr() As Double
    Lr = mLr
End Property

Public Property Let Lr(Value As Double)
    mLr = Value
End Property

Public Property Get Gama() As Double
    Gama = mGama
End Property

Public Property Let Gama(Value As Double)
    mGama = Value
End Property

Public Property Get MaxEpochs() As Long
    MaxEpochs = mMaxEpochs
End Property

Public Property Let MaxEpochs(Value As Long)
    mMaxEpochs = Value
End Property

Public Property Get iteration() As Long
    iteration = mIteration
End Property

'****************************************  初始化   *******************************************
Private Sub Class_Initialize()
    mS1 = 5
    mGoal = 0.0001
    mLr = 0.1
    mGama = 0.8
    mMaxEpochs = 1000
End Sub



'***********************************  训练  ***********************************
'
'过 程 名： Train
'参    数： P   -  输入矩阵
'           T   － 输出矩阵
'作    者： laviewpbt
'时    间： 2006-11-15
'
'***********************************  训练  ***********************************


Public Sub Train(P() As Double, T() As Double)
    Dim i As Long, j As Long, Index As Long
    Dim NmP() As Double
    mR = UBound(P, 1)                               '输入向量的元素个数
    mS2 = UBound(T, 1)                              '输出层神经元的个数
    Ts = UBound(P, 2)                               '输入向量的个数
    NmP = CopyArray(P)                              '保留原始的P,因为正规化的过程中会破坏原始数据
    IniParameters NmP                               '初始化参数和数组
    mIteration = 0
    For i = 1 To mMaxEpochs
        mIteration = mIteration + 1
        Index = Int(Rnd * Ts + 1)                   '随机选取一个输入向量作为训练样本，这样效果比按顺序循环要好
        For j = 1 To mR
            Pdealing(j) = NmP(j, Index)             '正在处理的输入向量
        Next
        For j = 1 To mS2
            Tdealing(j) = T(j, Index)               '正在处理的输出向量
        Next
        HiddenLayer                                 '计算隐含层各神经元的输出
        OutputLayer                                 '计算输出层各神经元的输出
        OutError                                    '计算输出层各神经元的误差
        HiddenError                                 '计算隐含层各神经元的误差
        Update_W2B2                                 '更新隐含层至输出层之间的连接权及输出层节点的偏置值
        Update_W1B1                                 '更新输入层至隐含层之间的连接权及隐含层节点的偏置值
        If iteration Mod 1000 = 0 Then RaiseEvent Update(mIteration)
        If mErr(mIteration) < mGoal Then Exit Sub    '达到要求，完成学习，退出
    Next
End Sub



'***********************************  初始化数据  ***********************************

Private Sub IniParameters(P() As Double)
    Dim i As Long, j As Long
    ReDim mW1(mS1, mR) As Double, mW2(mS2, mS1) As Double
    ReDim mB1(mS1) As Double, mB2(mS2) As Double
    ReDim OldW1(mS1, mR) As Double, OldW2(mS2, mS1) As Double
    ReDim OldB1(mS1) As Double, OldB2(mS2) As Double
    ReDim HiddenOutput(mS1) As Double, OutOutput(mS2) As Double
    ReDim HiddenErr(mS1) As Double, OutPutErr(mS2) As Double
    ReDim Pdealing(mR) As Double, Tdealing(mS2) As Double
    ReDim mErr(mMaxEpochs) As Double
    Randomize
    For i = 1 To mS1
        mB1(i) = 2 * Rnd - 1
        For j = 1 To mR
            mW1(i, j) = 2 * Rnd - 1
        Next
    Next
    For i = 1 To mS2
        mB2(i) = 2 * Rnd - 1
        For j = 1 To mS1
            mW2(i, j) = 2 * Rnd - 1
        Next
    Next
    NormalizeInput P
    Initialized = True
End Sub

'***********************************  输入数据影射到-1和1之间  ***********************************

Private Sub NormalizeInput(P() As Double)
    Dim i As Integer, j As Integer, m As Integer, n As Integer
    m = UBound(P, 1): n = UBound(P, 2)
    For i = 1 To m
        For j = 1 To n
            P(i, j) = 2 * (P(i, j) - mMinMax(i, 1)) / (mMinMax(i, 2) - mMinMax(i, 1)) - 1
        Next
    Next
End Sub

'***********************************  隐含层的数据  ***********************************

Private Sub HiddenLayer()
    Dim i As Long, j As Long
    Dim Sum As Double
    For i = 1 To mS1
        Sum = 0
        For j = 1 To mR
            Sum = Sum + mW1(i, j) * Pdealing(j)
        Next
        HiddenOutput(i) = 1 / (1 + Exp(-(Sum + mB1(i))))
    Next
End Sub





'***********************************  输出层的数据  ***********************************

Private Sub OutputLayer()
    Dim i As Long, j As Long
    Dim Sum As Double
    For i = 1 To mS2
        Sum = 0
        For j = 1 To mS1
            Sum = Sum + mW2(i, j) * HiddenOutput(j)
        Next
        OutOutput(i) = Sum + mB2(i)
    Next
End Sub

'***********************************  输出层的误差  ***********************************

Private Sub OutError()
    Dim i As Long, j As Long, Mse As Double
    For i = 1 To mS2
        OutPutErr(i) = Tdealing(i) - OutOutput(i)
        Mse = Mse + OutPutErr(i) * OutPutErr(i)
    Next
    mErr(mIteration) = Sqr(Mse / mS2)   '用某次迭代的均方误差来代替整体的均方误差
End Sub

'***********************************  隐含层的误差  ***********************************

Private Sub HiddenError()
    Dim i As Long, j As Long
    Dim Sum As Double
    For i = 1 To mS1
        Sum = 0
        For j = 1 To mS2
            Sum = Sum + OutPutErr(j) * mW2(j, i)
        Next
        HiddenErr(i) = Sum * (HiddenOutput(i)) * (1 - HiddenOutput(i))
    Next
End Sub

'***********************************  更新输出层的权值和偏置值  ***********************************

Private Sub Update_W2B2()
    Dim i As Long, j As Long
    Dim Temp As Double
    For i = 1 To mS2
        For j = 1 To mS1
            Temp = mLr * OutPutErr(i) * HiddenOutput(j) + mGama * OldW2(i, j) '动量学习方法
            mW2(i, j) = mW2(i, j) + Temp
            OldW2(i, j) = Temp
        Next
        Temp = mLr * OutPutErr(i) + mGama * OldB2(i)
        mB2(i) = mB2(i) + Temp
        OldB2(i) = Temp
    Next
End Sub


'***********************************  更新隐含层的权值和偏置值  ***********************************

Private Sub Update_W1B1()
    Dim i As Long, j As Long
    Dim Temp As Double
    For i = 1 To mS1
        For j = 1 To mR
            Temp = mLr * HiddenErr(i) * Pdealing(j) + mGama * OldW1(i, j)
            mW1(i, j) = mW1(i, j) + Temp
            OldW1(i, j) = Temp
        Next
        Temp = mLr * HiddenErr(i) + mGama * OldB1(i)
        mB1(i) = mB1(i) + Temp
        OldB1(i) = Temp
    Next
End Sub


'***********************************  均方误差  ***********************************


'Private Function Mse(P() As Double, T() As Double) As Double
    'Dim Temp() As Double
    'Dim i As Integer, j As Integer, Sum As Double, Subs As Double
    'Temp = Sim(P)
    'For i = 1 To mS2
        'For j = 1 To Ts
            'Subs = Temp(i, j) - T(i, j)
            'Sum = Sum + Subs * Subs
        'Next
    'Next
    'Mse = Sum / mS2 / Ts
'End Function


'***********************************  复制数组  ***********************************

Private Function CopyArray(P() As Double) As Double()
    CopyArray = P
End Function


Public Function Sim(P() As Double) As Double()
    Dim i As Integer, j As Integer, k As Integer
    Dim R As Integer, T As Integer
    Dim HiddenOut() As Double, OutOut() As Double, NmP() As Double
    R = UBound(P, 1): T = UBound(P, 2)
    ReDim HiddenOut(mS1, T) As Double, OutOut(mS2, T) As Double
    If Initialized = False Then Exit Function
    NmP = CopyArray(P)                              '保留原始的P,因为正规化的过程中会破坏原始数据
    NormalizeInput NmP                              '如果不是在训练，则把测试的输入正规化，如果在训练，则数据已经正规化
    For i = 1 To mS1
        For j = 1 To T
            For k = 1 To R
                HiddenOut(i, j) = HiddenOut(i, j) + mW1(i, k) * NmP(k, j)
            Next
            HiddenOut(i, j) = 1 / (1 + Exp(-(HiddenOut(i, j) + mB1(i))))
        Next
    Next

    For i = 1 To mS2
        For j = 1 To T
            For k = 1 To mS1
                OutOut(i, j) = OutOut(i, j) + mW2(i, k) * HiddenOut(k, j)
            Next
            OutOut(i, j) = OutOut(i, j) + mB2(i)
        Next
    Next
    Sim = OutOut
End Function


'***********************************  绘制误差曲线  ***********************************
'
'过 程 名： DrawErrorCurve
'参    数： pic   -  曲线绘制的容器
'           Color -  曲线的颜色
'作    者： laviewpbt
'时    间： 2006-11-15
'
'***********************************  绘制误差曲线  ***********************************

Public Sub DrawErrorCurve(pic As PictureBox, Color As OLE_COLOR)
    Dim i As Long, Max As Double
    pic.AutoRedraw = True
    pic.Cls
    pic.BorderStyle = 0
    pic.Scale (-0.15, 1)-(1.1, -0.1)
    pic.Line (-0.15, 1)-(1.095, -0.095), vbBlue, B
  
    For i = 1 To mIteration
        If Max < mErr(i) Then Max = mErr(i)
    Next
    pic.Line (0, 0)-(0, 1), Color
    pic.Line (0, 0)-(1.1, 0), Color
    For i = 1 To mIteration - 1
        pic.Line (i / mIteration, mErr(i) / Max)-((i + 1) / mIteration, mErr(i + 1) / Max), Color
    Next
    For i = 1 To 6
        pic.CurrentY = -0.02
        pic.CurrentX = 0.2 * (i - 1) - pic.TextWidth(mIteration / 5 * (i - 1))
        pic.Print CLng(mIteration / 5 * (i - 1))
    Next
        For i = 1 To 6
        pic.CurrentX = -0.13
        pic.CurrentY = 0.2 * (i - 1) - pic.TextHeight("5") + 0.02
        pic.Print Format(Max / 5 * (i - 1), "0.00")
    Next
    pic.CurrentX = 0.6 - pic.TextWidth("误差曲线")
    pic.CurrentY = 0.95
    pic.Print "误差曲线"
End Sub



'***********************************  字符串转为矩阵形式  ***********************************
'
'函 数 名： StringToMatrix
'参    数： str  -  待转换的矩阵
'返 回 值： 返回转换后的矩阵
'作    者： laviewpbt
'时    间： 2006-11-14
'
'***********************************  字符串转为矩阵形式  ***********************************

Public Function StringToMatrix(str As String) As Double()
    Dim i As Integer, m As Integer, n As Integer
    Dim Temp1() As String, Temp2() As String, Data() As Double
    Temp1 = Split(str, ";")
    Temp2 = Split(Temp1(0), " ")
    m = UBound(Temp1)
    n = UBound(Temp2)
    ReDim Data(1 To m + 1, 1 To n + 1) As Double
    For i = 1 To m + 1
        Temp2 = Split(Trim(Temp1(i - 1)), " ")
        For j = 1 To n + 1
            Data(i, j) = Val(Temp2(j - 1))
        Next
    Next
    StringToMatrix = Data
End Function






应用：


1、曲线逼近功能

     测试代码：

Private WithEvents Spline As BP
Private SplineP(1, 200) As Double
Private SplineT(1, 200) As Double

Private WithEvents SinBp As BP
Private SinP(1, 200) As Double
Private SinT(1, 200) As Double


Private Sub Form_Load()
    Set Spline = New BP
    For i = 1 To 200            '原始数据
        SplineP(1, i) = (i - 100) / 100 * 2
        SplineT(1, i) = 3 * SplineP(1, i) ^ 4 - 7 * SplineP(1, i) ^ 2 - 0.5 * SplineP(1, i) + 6
    Next
    Set SinBp = New BP
    For i = 1 To 200
        SinP(1, i) = (i - 100) / 100 * 7
        SinT(1, i) = Sin(SinP(1, i))
    Next
End Sub

Private Sub CmdSpline_Click()
    Dim s As New BP
    Dim tt() As Double, MinMax(1, 2) As Double
    MinMax(1, 1) = -2: MinMax(1, 2) = 2     '输入的上下限
    Picture1.Scale (-2.5, 30)-(2.5, 0)
    Spline.Lr = 0.02
    Spline.MinMax MinMax
    Spline.S1 = 8
    Spline.Goal = 0.000001
    Spline.MaxEpochs = 50000
    Spline.Train SplineP, SplineT
    Spline.DrawErrorCurve Picture2, vbRed
End Sub


Private Sub CmdSin_Click()
    Dim tt() As Double, MinMax(1, 2) As Double
    Picture1.Scale (-7, 2)-(7, -2)
    MinMax(1, 1) = -1
    MinMax(1, 2) = 1
    SinBp.MinMax MinMax
    SinBp.S1 = 5
    SinBp.Lr = 0.05
    SinBp.Goal = 0.000001
    SinBp.MaxEpochs = 100000
    SinBp.Train SinP, SinT
    SinBp.DrawErrorCurve Picture2, vbRed
End Sub


Private Sub SinBp_Update(iteration As Variant)
    Dim i As Integer, tt() As Double
    Picture1.Cls
    tt = SinBp.Sim(SinP)       '仿真
    For i = 1 To 199
        Picture1.Line ((i / 100 - 1) * 7, SinT(1, i))-(((i + 1) / 100 - 1) * 7, SinT(1, i + 1)), vbRed
    Next
    For i = 1 To 199
        Picture1.Line ((i / 100 - 1) * 7, tt(1, i))-(((i + 1) / 100 - 1) * 7, tt(1, i + 1)), vbBlue
    Next
    Picture1.Refresh
End Sub

Private Sub Spline_Update(iteration As Variant)
    Dim i As Integer, tt() As Double
    Picture1.Cls
    tt = Spline.Sim(SplineP)       '仿真
    For i = 1 To 199
        Picture1.Line ((i / 100 - 1) * 2, SplineT(1, i))-(((i + 1) / 100 - 1) * 2, SplineT(1, i + 1)), vbRed
    Next
    For i = 1 To 199
        Picture1.Line ((i / 100 - 1) * 2, tt(1, i))-(((i + 1) / 100 - 1) * 2, tt(1, i + 1)), vbBlue
    Next
    Picture1.Refresh
End Sub


Private Sub Form_Unload(Cancel As Integer)
    Set Spline = Nothing
    Set SinBp = Nothing
End Sub


       上述测试代码的目的是测试BP逼近正弦曲线的功能，并能够动态的查看每次迭代后所产生的曲线，由图中的最后结果可以知道逼近的比较完美（红色的是原始曲线)。

       说明一点：BP网络对权值初值非常敏感，因此可以有时迭代会产生不收敛的结果，另外，学习速度不可以取的过大，否则得不倒正确的结果,在计算过程中有时你会发现溢出错误的。


                                           迭代中的效果


                                           迭代完成
测试        T(1, i) = 3 * P(1, i) ^ 4 - 7 * P(1, i) ^ 2 - 0.5 * P(1, i) + 6的结果


2 、模式分类

     我们说过打单层感知机无法实现异或功能，单多层网络可以轻松实现：

    Dim P(2, 4) As Double
    Dim T(1, 4) As Double
    Dim TT() As Double
    Dim Range(2, 2) As Double
    Dim s As New bp
    Range(1, 1) = 0: Range(1, 2) = 1
    Range(2, 1) = 0: Range(2, 2) = 1
    P(1, 1) = 0: P(2, 1) = 0
    P(1, 2) = 0: P(2, 2) = 1
    P(1, 3) = 1: P(2, 3) = 0
    P(1, 4) = 1: P(2, 4) = 1
    T(1, 1) = 0
    T(1, 2) = 1
    T(1, 3) = 1
    T(1, 4) = 0
    s.MinMax Range
    s.S1 = 2
    s.Lr = 0.3
    s.MaxEpochs = 1000
    s.Train P, T
    TT = s.Sim(P)
    MsgBox MatrixToString(1, 4, TT, "0.00")

结果：

测试结果

3、故障诊断

     发动机运行过程中，油路和气路出现故障是最多的，我们将常见故障分类四类，分别为正常，油量少，气门漏气，气缸漏气，并且提取出六中特征参数来表示，通过对现场试验和对历史资料的收集分析，可以得到样本数据如下：

我们通过BP网络对其进行训练，并对其样本数据进行测试，发现BP网络收敛，即如下：

为了得到其外推能力，我们给出一组来源于真实的故障信息，来检测网络的正确性，数据如下：

比较诊断数据和标准样本数据，可以主观断定第一类是正常的，第二个是气缸漏气故障，测试我们刚刚训练的网络得到如下结果：

可见网络给出了正确的结果。

代码：

    Dim str1 As String, str2 As String
    Dim P() As Double, T() As Double, TT() As Double, Range(6, 2) As Double
    Dim s As New bp
    str1 = "0.999 0.102 0.111 0.215;0.999 0.091 0.125 0.185;0.999 0.035 0.021 0.152;0.999 0.085 0.078 0.098;0.999 0.078 0.121 0.115;0.999 0.105 0.192 0.113"
    str2 = "1 0 0 0;0 1 0 0;0 0 1 0;0 0 0 1"
    P = s.StringToMatrix(str1)
    T = s.StringToMatrix(str2)
    For i = 1 To 6
        Range(i, 2) = 0
        Range(i, 2) = 1
    Next
    s.MinMax Range
    s.MaxEpochs = 10000
    s.Train P, T
    TT = s.Sim(P)
    MsgBox MatrixToString(TT, "0.00"), vbInformation, "验证数据"
    str1 = "1.001 0.221;1.002 0.193;0.999 0.148;1.000 0.105;1.006 0.121;0.998 0.110"
    P = s.StringToMatrix(str1)
    TT = s.Sim(P)
    MsgBox MatrixToString(TT, "0.00"), vbInformation, "诊断结果"


     当然,BP网络还可以运用在很多地方，我这里只是举几个小例子。

     注意：程序中采用某个样本 的均方误差作为整个样本数据的均方误差，这样可以加快速度，但也存在不少问题，比入在那个多项式曲线的迭代中，你会发现曲线拟和的非常的时候他仍然迭代。

        在我最我的类模块中提供了另外一种常用的传输函数：logsig，在我未公布的函数中已经把这三种传输函数作为一个参数提供给用户，另外，我还写了下动量方法的BP和可变学习速度的BP，但效果都不理想，所以先给出这个最基本的代码， 等哪天搞定了问题的时候在发布出来。下图给个调整的界面图：

现在关键的问题是要迭代很多次，呵呵，慢慢的换其他的数值优化方法来改经速度吧，负剃度下降本来就不是很快。