离散信道容量的一般计算方法的源码.txt

实现离散信道容量的一般计算方法

Option Base 1
Dim b1()
Dim b2()
Dim a As Integer
 

Private Sub Command2_Click()
Picture1.Cls
Picture2.Cls
a = Val(Text1.Text)
ReDim b1(a, a + 1)
ReDim b2(a, a + 1)
For i = 1 To a
   For j = 1 To a
   b1(i, j) = Val(InputBox("输入第" & i & "行第" & j & "列的值:"))
   Picture1.Print b1(i, j);
Next j
Picture1.Print
Next i
For i = 1 To a
   f = 0
For j = 1 To a
 If b1(i, j) = 0 Then
  f = f
 Else
  f = f + b1(i, j) * (Log(b1(i, j)) / Log(2))
End If
Next j
b1(i, a + 1) = f
Next i
Dim ai As String
g b1, ai
Picture2.Print ai
End Sub
Function D(ByRef f1) As Single
Dim i As Long, j As Long, k  As Long, h  As Long, ri As Long
Dim r As Long, c As Long, Pi  As Single, Pi2 As Single, t() As Single
D = 1
Dim m
m = f1
h = UBound(m, 1)
If Not UBound(m, 2) = h + 1 Then MsgBox "无解！": Exit Function
ReDim t(1 To h)
For i = 1 To h
 Pi = 0
  For j = i To h
    For k = i To h
    If Abs(m(k, j)) > Pi Then
    Pi = Abs(m(k, j))
r = k:  c = j
End If
Next k
Next j
If Pi = 0 Then D = 0:  Exit Function
If r <> i Then
    ri = ri + 1
For j = 1 To h
    t(j) = m(i, j)
    m(i, j) = m(r, j)
    m(r, j) = t(j)
  Next j
End If
If c <> i Then
 ri = ri + 1
 For j = 1 To h
    t(j) = m(j, i)
    m(j, i) = m(j, c)
    m(j, c) = t(j)
Next j
End If
  Pi = m(i, i)
  D = D * Pi
For j = i + 1 To h
Pi2 = m(j, i)
If Pi2 <> 0 Then
 For k = 1 To h
    m(j, k) = m(j, k) - m(i, k) * Pi2 / Pi
    Next
End If
Next
Next
D = D * (-1) ^ ri
  End Function
    
  Sub g(ByRef f1(), ByRef ai As String)
  Picture3.Cls
  Picture4.Cls
  Dim h As Integer, i As Integer, D0 As Single
  Dim m
  Dim jg() As String
  h = UBound(f1, 1)
  ReDim jg(1 To h)
  D0 = D(f1)
  If D0 = 0 Then MsgBox "无解！":      Exit Sub
  For i = 1 To h
    m = f1
  For j = 1 To h
  m(j, i) = f1(j, h + 1)
  Next
 jg(i) = D(m) / D0
  Sum = Sum + 2 ^ (D(m) / D0)
  Next
  c = Log(Sum) / Log(2)
  Text2.Text = c
  ai = Join(jg, vbCrLf)
  
  Dim yy() As String
  row = UBound(f1, 1)
  ReDim jg(1 To h)
  ReDim yy(1 To h)
  D0 = D(f1)
  If D0 = 0 Then MsgBox "无解！":      Exit Sub
  For i = 1 To h
     m = f1
  For j = 1 To h
  m(j, i) = f1(j, h + 1)
  Next
  jg(i) = D(m) / D0
  yy(i) = 2 ^ (jg(i) - c)
  Picture3.Print yy(i)
  Next
  
  For i = 1 To a
    For j = 1 To a
    b2(i, j) = b1(j, i)
    Next j
  Next i
  For i = 1 To a
b2(i, a + 1) = yy(i)
  Next i
     Dim ai2 As String
  g2 b2, ai2
  Picture4.Print ai2
  End Sub

 Sub g2(ByRef f12(), ByRef ai2 As String)
  Dim h As Integer, i As Integer, D0 As Single
  Dim m
  Dim jg() As String
  h = UBound(f12, 1)
  ReDim jg(1 To h)
  D0 = D(f12)
  If D0 = 0 Then MsgBox "无解！":  Exit Sub
  For i = 1 To h
    m = f12
  For j = 1 To h
  m(j, i) = f12(j, h + 1)
  Next
  jg(i) = D(m) / D0
  Next
  ai2 = Join(jg, vbCrLf)
 End Sub

Private Sub Command1_Click()
End
End Sub