下面把改进后的代码发一下:
Private Sub Command1_Click()
Dim a, B
Dim ja(), jb()
a = Trim(Text1): B = Trim(Text2): a3 = a: b3 = B
ts = Timer
If Len(a) < Len(B) Then
a = String(Len(B) - Len(a), "0") & a
B = B
Else
a = a
B = String(Len(a) - Len(B), "0") & B
End If
x = Len(a) \ 300: Y = x + 2: x11 = x
sb = Y * 2
a = String(Val(sb * 300 - Len(a)), "0") & a
B = String(Val(sb * 300 - Len(B)), "0") & B
x = sb / 2
ReDim ja(0 To x - 1): ReDim jb(-x + 1 To x - 1)
For I = 0 To x - 1
ja(I) = Mid(a, Len(a) - 600 * I - 599, 600)
jb(I) = Mid(B, Len(B) - 600 * I - 599, 600)
'倒序输出,减少加法计算量,提高速度
Next
For i0 = -1 To -x + 1 Step -1
jb(i0) = String(600, "0")
Next
jw2 = 0: jw3 = 0
For i1 = 0 To x - 1
d3 = ""
For i2 = 0 To x - 1
a1 = Mid(ja(i2), 1, 300): a2 = Mid(ja(i2), 301, 300)
B1 = Mid(jb(i1 - i2), 1, 300): b2 = Mid(jb(i1 - i2), 301, 300)
C1 = MbC(Trim(a1), Trim(B1)): C2 = MbC(Trim(a2), Trim(b2))
c3 = MPC1(Trim(a1), Trim(a2)): c4 = MPC1(Trim(B1), Trim(b2))
c5 = MbC(Trim(c3), Trim(c4))
D1 = MPC(Trim(c5), Trim(C1)): D1 = MPC(Trim(D1), Trim(C2))
D2 = MPC1(Trim(C1) & String(600, "0"), Trim(D1) & String(300, "0"))
D2 = MPC1(Trim(D2), Trim(C2))
d3 = MPC1(Trim(D2), Trim(d3))
Next
d3 = MPC1(Trim(d3), Trim(jw3))
d5 = d3
If Len(d3) <= 600 Then
jw3 = 0
Else
jw3 = Left(d3, Len(d3) - 600)
End If
d3 = Right(d3, 600)
d4 = Trim(d3) & Trim(d4)
Next
d4 = Trim(jw3) & Trim(d4)
d4 = qqdl(Trim(d4))
d10 = Mid(d4, 1, 88)
Text3 = d4 & "有" & Len(d4) & "位,用时" & Timer - ts & "秒"
End Sub
Private Sub Command2_Click()
Text1 = ""
Text2 = ""
Text3 = ""
End Sub
Public Function MbC(D1 As String, D2 As String) As String
Dim x, Y ';两数长度
x = Len(D1) \ 4: Y = Len(D2) \ 4
d3 = String(4 * x + 4 - Len(D1), "0") & D1
d4 = String(4 * Y + 4 - Len(D2), "0") & D2
x = x + 1: Y = Y + 1
Dim a() As String
ReDim a(4 To 4 * x + 4 * Y, 4 To 4 * Y)
Dim I, J, C1, C2, CJ, jw, s, t
For J = 4 * Y To 4 Step -4 ';D2
jw = 0 ';进位清0
C2 = Mid(d4, J - 3, 4) ';每位数
For I = 4 * x To 4 Step -4 ';D1
C1 = Mid(d3, I - 3, 4) ';每位数
CJ = Val(C1) * Val(C2) + jw ';计算乘积
c = I + J: r = 4 * Y + 4 - J
a(c, r) = String(4 - Len(CJ Mod 10000), "0") & CJ Mod 10000 ';本位
jw = CJ \ 10000 ';进位
Next
a(c - 4, r) = jw
Next
Dim B() As String
ReDim B(1 To x + Y)
jw = 0
For s = x + Y To 1 Step -1
Bit = jw
For t = 1 To Y
Bit = Bit + Val(a(4 * s, 4 * t))
Next
B(s) = String(4 - Len(Bit Mod 10000), "0") & Bit Mod 10000
jw = Bit \ 10000
Next
If B(1) > 0 Then
MbC = Val(Left(MbC, 5)) & Mid(MbC, 6) & B(1)
Else
MbC = Val(Left(MbC, 5)) & Mid(MbC, 6)
End If
For s = 2 To x + Y
MbC = Val(Left(MbC, 5)) & Mid(MbC, 6) & B(s)
Next
End Function
'该程序已经做了修改,是模仿手工计算的程序,采用4位一组,在位数少于5000的时候,此程序居然比快速傅里叶变换的乘法还快!
Public Function MPC1(D1 As String, D2 As String) As String 'jiafa
Dim x, Y, jw '两数长度
If qqdl(D1) = "0" Then
MPC1 = D2
ElseIf qqdl(D2) = "0" Then
MPC1 = D1
Else
If Len(D1) >= Len(D2) Then
d4 = String(Len(D1) - Len(D2), "0") & D2
d3 = D1
Else
d4 = D2
d3 = String(Len(D2) - Len(D1), "0") & D1
End If
x = Len(d3) \ 8: Y = Len(d4) \ 8
If 8 * x < Len(d3) Then
d3 = String(8 * x + 8 - Len(d3), "0") & d3
d4 = String(8 * Y + 8 - Len(d4), "0") & d4
x = x + 1: Y = Y + 1
Else
x = x: Y = Y
d3 = d3: d4 = d4
End If
Dim a() As String, B1() As String, C1() As String, E1() As String
ReDim a(1 To x)
ReDim B1(1 To Y)
ReDim C1(1 To x)
ReDim E1(1 To x)
Dim I, J, C2, CJ
For J = Y To 1 Step -1 'D2
jw = 0 '进位清0
B1(J) = Mid$(d4, J * 8 - 7, 8) '每位数
For I = x To 1 Step -1 'D1
a(I) = Mid$(d3, I * 8 - 7, 8) '每位数
C1(I) = Val(a(I)) + Val(B1(I)) + Val(jw) '计算jia
If Len(C1(I)) < 8 Then
C1(I) = String(8 - Len(C1(I)), "0") & C1(I)
Else
C1(I) = C1(I)
End If
jw = Left(C1(I), Len(C1(I)) - 8)
E1(I) = Right(C1(I), 8)
Next
Next
For r = 1 To x
If jw = 0 Then
MPC1 = MPC1 & E1(r)
Else
jc = jc & E1(r)
MPC1 = jw & jc
End If
Next
MPC1 = qqdl(Trim(MPC1))
End If
End Function
Public Function MPC(D1 As String, D2 As String) As String ';jianfaqi
Dim x, Y ';两数长度
If qqdl(D2) = "0" Then
MPC = D1
Else
If Len(D1) >= Len(D2) Then
d4 = String(Len(D1) - Len(D2), "0") & D2
d3 = D1
Else
d4 = D2
d3 = String(Len(D2) - Len(D1), "0") & D1
End If
x = Len(d3) \ 8: Y = Len(d4) \ 8
d3 = String(8 * x + 8 - Len(d3), "0") & d3
d4 = String(8 * Y + 8 - Len(d4), "0") & d4
x = x + 1: Y = Y + 1
Dim a() As String, B1() As String, C1() As String, E1() As String
ReDim a(1 To x)
ReDim B1(1 To Y)
ReDim C1(1 To x)
ReDim E1(1 To x)
Dim I, J, C2, CJ, jw
For J = Y To 1 Step -1 ';D2
jw = 1 ';yu jie weichuzhi
B1(J) = Mid(d4, J * 8 - 7, 8) ';每位数
For I = x To 1 Step -1 ';D1
a(I) = Mid(d3, I * 8 - 7, 8) ';每位数
C1(I) = Val(1 & a(I)) - Val(B1(I)) - Val(1) + Val(jw) ';计算jia
If Len(C1(I)) <= 8 Then
jw = 0
C1(I) = String(8 - Len(C1(I)), "0") & C1(I)
Else
jw = Left(C1(I), Len(C1(I)) - 8)
End If
E1(I) = Right(C1(I), 8)
If Len(E1(I)) < 8 Then
E1(I) = String(8 - Len(E1(I)), "0") & E1(I)
Else
E1(I) = E1(I)
End If
Next
Next
For r = 1 To x
MPC = MPC & E1(r)
If Len(MPC) > Len(D1) Then
MPC = Mid(MPC, Len(MPC) - Len(D1) + 1)
Else
MPC = MPC
End If
For I = 1 To Len(MPC)
If Not Mid(MPC, I, 1) = "0" Then
Exit For
End If
Next
strTmp = Mid(MPC, I)
If Len(strTmp) = 0 Then
MPC = "0"
Else
MPC = strTmp
End If
Next
End If
End Function
Private Function qqdl(sa As String) As String
For I = 1 To Len(sa)
If Not Mid(sa, I, 1) = "0" Then
Exit For
End If
Next
strTmp = Mid(sa, I)
If Len(strTmp) = 0 Then
qqdl = "0"
Else
qqdl = strTmp
End If
End Function
Private Sub Command1_Click()
Dim a, B
Dim ja(), jb()
a = Trim(Text1): B = Trim(Text2): a3 = a: b3 = B
ts = Timer
If Len(a) < Len(B) Then
a = String(Len(B) - Len(a), "0") & a
B = B
Else
a = a
B = String(Len(a) - Len(B), "0") & B
End If
x = Len(a) \ 300: Y = x + 2: x11 = x
sb = Y * 2
a = String(Val(sb * 300 - Len(a)), "0") & a
B = String(Val(sb * 300 - Len(B)), "0") & B
x = sb / 2
ReDim ja(0 To x - 1): ReDim jb(-x + 1 To x - 1)
For I = 0 To x - 1
ja(I) = Mid(a, Len(a) - 600 * I - 599, 600)
jb(I) = Mid(B, Len(B) - 600 * I - 599, 600)
'倒序输出,减少加法计算量,提高速度
Next
For i0 = -1 To -x + 1 Step -1
jb(i0) = String(600, "0")
Next
jw2 = 0: jw3 = 0
For i1 = 0 To x - 1
d3 = ""
For i2 = 0 To x - 1
a1 = Mid(ja(i2), 1, 300): a2 = Mid(ja(i2), 301, 300)
B1 = Mid(jb(i1 - i2), 1, 300): b2 = Mid(jb(i1 - i2), 301, 300)
C1 = MbC(Trim(a1), Trim(B1)): C2 = MbC(Trim(a2), Trim(b2))
c3 = MPC1(Trim(a1), Trim(a2)): c4 = MPC1(Trim(B1), Trim(b2))
c5 = MbC(Trim(c3), Trim(c4))
D1 = MPC(Trim(c5), Trim(C1)): D1 = MPC(Trim(D1), Trim(C2))
D2 = MPC1(Trim(C1) & String(600, "0"), Trim(D1) & String(300, "0"))
D2 = MPC1(Trim(D2), Trim(C2))
d3 = MPC1(Trim(D2), Trim(d3))
Next
d3 = MPC1(Trim(d3), Trim(jw3))
d5 = d3
If Len(d3) <= 600 Then
jw3 = 0
Else
jw3 = Left(d3, Len(d3) - 600)
End If
d3 = Right(d3, 600)
d4 = Trim(d3) & Trim(d4)
Next
d4 = Trim(jw3) & Trim(d4)
d4 = qqdl(Trim(d4))
d10 = Mid(d4, 1, 88)
Text3 = d4 & "有" & Len(d4) & "位,用时" & Timer - ts & "秒"
End Sub
Private Sub Command2_Click()
Text1 = ""
Text2 = ""
Text3 = ""
End Sub
Public Function MbC(D1 As String, D2 As String) As String
Dim x, Y ';两数长度
x = Len(D1) \ 4: Y = Len(D2) \ 4
d3 = String(4 * x + 4 - Len(D1), "0") & D1
d4 = String(4 * Y + 4 - Len(D2), "0") & D2
x = x + 1: Y = Y + 1
Dim a() As String
ReDim a(4 To 4 * x + 4 * Y, 4 To 4 * Y)
Dim I, J, C1, C2, CJ, jw, s, t
For J = 4 * Y To 4 Step -4 ';D2
jw = 0 ';进位清0
C2 = Mid(d4, J - 3, 4) ';每位数
For I = 4 * x To 4 Step -4 ';D1
C1 = Mid(d3, I - 3, 4) ';每位数
CJ = Val(C1) * Val(C2) + jw ';计算乘积
c = I + J: r = 4 * Y + 4 - J
a(c, r) = String(4 - Len(CJ Mod 10000), "0") & CJ Mod 10000 ';本位
jw = CJ \ 10000 ';进位
Next
a(c - 4, r) = jw
Next
Dim B() As String
ReDim B(1 To x + Y)
jw = 0
For s = x + Y To 1 Step -1
Bit = jw
For t = 1 To Y
Bit = Bit + Val(a(4 * s, 4 * t))
Next
B(s) = String(4 - Len(Bit Mod 10000), "0") & Bit Mod 10000
jw = Bit \ 10000
Next
If B(1) > 0 Then
MbC = Val(Left(MbC, 5)) & Mid(MbC, 6) & B(1)
Else
MbC = Val(Left(MbC, 5)) & Mid(MbC, 6)
End If
For s = 2 To x + Y
MbC = Val(Left(MbC, 5)) & Mid(MbC, 6) & B(s)
Next
End Function
'该程序已经做了修改,是模仿手工计算的程序,采用4位一组,在位数少于5000的时候,此程序居然比快速傅里叶变换的乘法还快!
Public Function MPC1(D1 As String, D2 As String) As String 'jiafa
Dim x, Y, jw '两数长度
If qqdl(D1) = "0" Then
MPC1 = D2
ElseIf qqdl(D2) = "0" Then
MPC1 = D1
Else
If Len(D1) >= Len(D2) Then
d4 = String(Len(D1) - Len(D2), "0") & D2
d3 = D1
Else
d4 = D2
d3 = String(Len(D2) - Len(D1), "0") & D1
End If
x = Len(d3) \ 8: Y = Len(d4) \ 8
If 8 * x < Len(d3) Then
d3 = String(8 * x + 8 - Len(d3), "0") & d3
d4 = String(8 * Y + 8 - Len(d4), "0") & d4
x = x + 1: Y = Y + 1
Else
x = x: Y = Y
d3 = d3: d4 = d4
End If
Dim a() As String, B1() As String, C1() As String, E1() As String
ReDim a(1 To x)
ReDim B1(1 To Y)
ReDim C1(1 To x)
ReDim E1(1 To x)
Dim I, J, C2, CJ
For J = Y To 1 Step -1 'D2
jw = 0 '进位清0
B1(J) = Mid$(d4, J * 8 - 7, 8) '每位数
For I = x To 1 Step -1 'D1
a(I) = Mid$(d3, I * 8 - 7, 8) '每位数
C1(I) = Val(a(I)) + Val(B1(I)) + Val(jw) '计算jia
If Len(C1(I)) < 8 Then
C1(I) = String(8 - Len(C1(I)), "0") & C1(I)
Else
C1(I) = C1(I)
End If
jw = Left(C1(I), Len(C1(I)) - 8)
E1(I) = Right(C1(I), 8)
Next
Next
For r = 1 To x
If jw = 0 Then
MPC1 = MPC1 & E1(r)
Else
jc = jc & E1(r)
MPC1 = jw & jc
End If
Next
MPC1 = qqdl(Trim(MPC1))
End If
End Function
Public Function MPC(D1 As String, D2 As String) As String ';jianfaqi
Dim x, Y ';两数长度
If qqdl(D2) = "0" Then
MPC = D1
Else
If Len(D1) >= Len(D2) Then
d4 = String(Len(D1) - Len(D2), "0") & D2
d3 = D1
Else
d4 = D2
d3 = String(Len(D2) - Len(D1), "0") & D1
End If
x = Len(d3) \ 8: Y = Len(d4) \ 8
d3 = String(8 * x + 8 - Len(d3), "0") & d3
d4 = String(8 * Y + 8 - Len(d4), "0") & d4
x = x + 1: Y = Y + 1
Dim a() As String, B1() As String, C1() As String, E1() As String
ReDim a(1 To x)
ReDim B1(1 To Y)
ReDim C1(1 To x)
ReDim E1(1 To x)
Dim I, J, C2, CJ, jw
For J = Y To 1 Step -1 ';D2
jw = 1 ';yu jie weichuzhi
B1(J) = Mid(d4, J * 8 - 7, 8) ';每位数
For I = x To 1 Step -1 ';D1
a(I) = Mid(d3, I * 8 - 7, 8) ';每位数
C1(I) = Val(1 & a(I)) - Val(B1(I)) - Val(1) + Val(jw) ';计算jia
If Len(C1(I)) <= 8 Then
jw = 0
C1(I) = String(8 - Len(C1(I)), "0") & C1(I)
Else
jw = Left(C1(I), Len(C1(I)) - 8)
End If
E1(I) = Right(C1(I), 8)
If Len(E1(I)) < 8 Then
E1(I) = String(8 - Len(E1(I)), "0") & E1(I)
Else
E1(I) = E1(I)
End If
Next
Next
For r = 1 To x
MPC = MPC & E1(r)
If Len(MPC) > Len(D1) Then
MPC = Mid(MPC, Len(MPC) - Len(D1) + 1)
Else
MPC = MPC
End If
For I = 1 To Len(MPC)
If Not Mid(MPC, I, 1) = "0" Then
Exit For
End If
Next
strTmp = Mid(MPC, I)
If Len(strTmp) = 0 Then
MPC = "0"
Else
MPC = strTmp
End If
Next
End If
End Function
Private Function qqdl(sa As String) As String
For I = 1 To Len(sa)
If Not Mid(sa, I, 1) = "0" Then
Exit For
End If
Next
strTmp = Mid(sa, I)
If Len(strTmp) = 0 Then
qqdl = "0"
Else
qqdl = strTmp
End If
End Function