优化的程序,一位一组的,没有完成速度提高不明显,暂时发一下:(有空在接着弄吧,有提升空间)
Dim l As Long, le As Long, le1 As Long, n As Long, r As Long, p As Long, q As Long, m As Byte
Dim wr As Double, w1 As Double, wlr As Double, wl1 As Double, tr As Double, t1 As Double
Dim pi As Double, t As Double, tr1 As Double
Private Sub Command1_Click()
Dim xr() As Double, a As String
a = Trim(Text1)
b = Trim(Text3)
ts = Timer
Text2 = js & "有" & Len(js) & "位,用时" & Timer - ts & "秒"
sb1 = Len(a) + Len(b)
sb2 = Log(sb1) / Log(2)
If InStr(sb2, ".") = 0 Then
sb2 = sb2
Else
sb2 = Int(sb2) + 1
End If
sb = 2 ^ sb2
Print sb
If Len(a) = Len(b) And 2 ^ (Int(Log(Len(a)) / Log(2))) = Len(a) Then
a = String(Val(sb) - Len(a), "0") & a
b = String(Val(sb) - Len(b), "0") & b
ax = a: bx = b
Else
a = String(Val(sb) - Len(a), "0") & a
b = String(Val(sb) - Len(b), "0") & b
ax = a: bx = b
End If
Dim y_() As Double, x_() As Double
ReDim x_(1 To sb): ReDim y_(1 To sb)
For i1 = 1 To sb
x_(i1) = Mid(ax, sb - i1 + 1, 1): y_(i1) = Mid(bx, sb - i1 + 1, 1)
Next
Dim n As Integer, I As Long, J As Long, mn As Long, lh As Long, t As Double, k As Long
'位序倒置
n = sb '求数组大小,其值必须是2的幂
lh = n / 2
J = n / 2
For I = 1 To n - 2
Debug.Print I, J
k = lh '下面是向右进位算法
Do
If k > J Then Exit Do '高位是1吗
J = J - k '是的,高位置0
k = k / 2 '准备次高位的权
Loop Until k = 0 '次高位的权若非0,则检查新的次高位
J = J + k '非则若最高位是0,则置1
s = s & x_(J + 1)
s1 = s1 & y_(J + 1)
Next
a = x_(1) & x_(1 + sb / 2) & s
b = y_(1) & y_(1 + sb / 2) & s1
ReDim xr(0 To Len(a) - 1): ReDim yr(0 To Len(b) - 1): ReDim zr(0 To Len(b) - 1)
For i1 = 0 To Len(a) - 1
xr(i1) = Mid(a, i1 + 1, 1)
yr(i1) = Mid(b, i1 + 1, 1)
Next
Dim xi(): Dim yi(): Dim zi()
n = Len(a) '求数组大小,其值必须是2的幂
m = 0
l = 2
pi = 3.14159265358979
Do
l = l + l
m = m + 1
Loop Until l > n
n = l / 2
ReDim xi(n - 1): ReDim yi(n - 1): ReDim zi(n - 1)
l = 1
Do
le = 2 ^ l
le1 = le / 2
wr = 1
wi = 0
If l = 1 Then
t = 0
Else
t = pi / le1
End If
w1r = Cos(t)
w1i = -Sin(t)
r = 0
Do
p = r
Do
q = p + le1
tr = xr(q) * wr - xi(q) * wi
ti = xr(q) * wi + xi(q) * wr
tr1 = yr(q) * wr - yi(q) * wi
ti1 = yr(q) * wi + yi(q) * wr
xr(q) = xr(p) - tr
xi(q) = xi(p) - ti
xr(p) = xr(p) + tr
xi(p) = xi(p) + ti
yr(q) = yr(p) - tr1
yi(q) = yi(p) - ti1
yr(p) = yr(p) + tr1
yi(p) = yi(p) + ti1
p = p + le
Loop Until p > n - 1
wr2 = wr * w1r - wi * w1i
wi2 = wr * w1i + wi * w1r
wr = wr2
wi = wi2
r = r + 1
Loop Until r > le1 - 1
l = l + 1
Loop Until l > m
For I = 0 To n - 1 '仅输出模
zr(I) = xr(I) * yr(I) - xi(I) * yi(I): zi(I) = xr(I) * yi(I) + xi(I) * yr(I)
's = s & "/" & zr(I)
's1 = s1 & "/" & zi(I)
Next
J = sb
ReDim x_(1 To sb): ReDim y_(1 To sb)
For k = 1 To J
n1 = n1 + 1
ReDim Preserve x_(1 To n1)
x_(n1) = zr(n1 - 1): y_(n1) = zi(n1 - 1)
Next
'位序倒置
n = sb '求数组大小,其值必须是2的幂
lh = n / 2
J = n / 2
For I = 1 To n - 2
Debug.Print I, J
k = lh '下面是向右进位算法
Do
If k > J Then Exit Do '高位是1吗
J = J - k '是的,高位置0
k = k / 2 '准备次高位的权
Loop Until k = 0 '次高位的权若非0,则检查新的次高位
J = J + k '非则若最高位是0,则置1
js = js & "/" & x_(J + 1)
js1 = js1 & "/" & y_(J + 1)
Next
sx1 = "/" & x_(1) & "/" & x_(1 + sb / 2) & js
sy1 = "/" & y_(1) & "/" & y_(1 + sb / 2) & js1
's2 = nifft(dxcx1(Trim(s)), dxcx1(Trim(s1)), Trim(sb1))
s3 = nifft(Trim(sx1), Trim(sy1), Trim(sb1))
Text2 = s3 & "有" & Len(s3) & "位,用时" & Timer - ts & "秒"
End Sub
Private Sub Command2_Click()
Text1 = ""
Text2 = ""
Text3 = ""
Form1.Cls
End Sub
Private Function qdqd0(sa As String) As String
a = sa
Do While Left(a, 1) = "0"
a = Mid(a, 2)
Loop
If a = "" Then
a = 0
Else
a = a
End If
qdqd0 = a
End Function
Private Function nifft(sa As String, sb As String, sb1 As String) As String
Dim xi(): Dim yi(): Dim zi()
Dim xr(), yr(), zr()
s2 = Split(sa, "/")
s3 = Split(sb, "/")
J = UBound(s2)
n = J
For k = 1 To J
n1 = n1 + 1
ReDim Preserve xr(0 To n1 - 1)
ReDim Preserve yr(0 To n1 - 1)
xr(n1 - 1) = s2(n1): yr(n1 - 1) = s3(n1)
Next
ReDim zr(0 To J - 1)
m = 0
l = 2
pi = 3.14159265358979
Do
l = l + l
m = m + 1
Loop Until l > n
n = l / 2
ReDim xi(n - 1): ReDim yi(n - 1): ReDim zi(n - 1)
l = 1
Do
le = 2 ^ l
le1 = le / 2
wr = 1
wi = 0
If l = 1 Then
t = 0
Else
t = -1 * pi / le1
End If
w1r = Cos(t)
w1i = -Sin(t)
r = 0
Do
p = r
Do
q = p + le1
tr = xr(q) * wr - xi(q) * wi
ti = xr(q) * wi + xi(q) * wr
tr1 = yr(q) * wr - yi(q) * wi
ti1 = yr(q) * wi + yi(q) * wr
xr(q) = xr(p) - tr
xi(q) = xi(p) - ti
xr(p) = xr(p) + tr
xi(p) = xi(p) + ti
yr(q) = yr(p) - tr1
yi(q) = yi(p) - ti1
yr(p) = yr(p) + tr1
yi(p) = yi(p) + ti1
p = p + le
Loop Until p > n - 1
wr2 = wr * w1r - wi * w1i
wi2 = wr * w1i + wi * w1r
wr = wr2
wi = wi2
r = r + 1
Loop Until r > le1 - 1
l = l + 1
Loop Until l > m
For I = 0 To n - 1 '仅输出模
zr(I) = (xr(I) - yi(I)) / n
s1 = Int(Val(zr(I) + 0.5))
s = "/" & s1 & s
zr(I) = s1
Next
For i1 = 1 To Val(J - sb1 + 1)
zr(sb1 + i1 - 2) = 0
Next
For i1 = 0 To n - 1
If zr(i1) < 0 Then
zr(i1) = 0
Else
zr(i1) = zr(i1)
End If
s5 = "/" & Int(zr(i1)) & s5
If i1 = 0 Then
s6 = Int(zr(i1)) \ 10
s8 = Int(zr(i1)) Mod 10
ElseIf Val(zr(i1)) >= 0 Then
s7 = Int(zr(i1)) + Val(s6)
s10 = Val(s7) Mod 10
s11 = s10 & s11
s6 = Val(s7) \ 10
Else
s6 = Val(s6)
End If
Next
s9 = s6 & s11 & s8
nifft = qdqd0(Trim(s9))
End Function
Private Function dxcx0(sa As String, sb As String) As String
Dim x_() As Double, a As String
a = Trim(sa)
ReDim x_(1 To sb)
For i1 = 1 To sb
x_(i1) = Mid(a, sb - i1 + 1, 1)
Next
Dim n As Integer, I As Long, J As Long, mn As Long, lh As Long, t As Double, k As Long
'位序倒置
n = sb '求数组大小,其值必须是2的幂
lh = n / 2
J = n / 2
For I = 1 To n - 2
Debug.Print I, J
k = lh '下面是向右进位算法
Do
If k > J Then Exit Do '高位是1吗
J = J - k '是的,高位置0
k = k / 2 '准备次高位的权
Loop Until k = 0 '次高位的权若非0,则检查新的次高位
J = J + k '非则若最高位是0,则置1
s = s & x_(J + 1)
Next
dxcx0 = x_(1) & x_(1 + sb / 2) & s
End Function
Public Function MbC(D1 As String, D2 As String) As String '乘法
Dim x, Y '两数长度
x = Len(D1): Y = Len(D2)
Dim a() As Integer
ReDim a(1 To x + Y, 1 To Y)
Dim I, J, C1, C2, CJ, JW
For J = Y To 1 Step -1 'D2
JW = 0 '进位清0
C2 = Mid$(D2, J, 1) '每位数
For I = x To 1 Step -1 'D1
C1 = Mid$(D1, I, 1) '每位数
CJ = C1 * C2 + JW '计算乘积
c = I + J: r = Y + 1 - J
a(c, r) = CJ Mod 10 '本位
JW = CJ \ 10 '进位
Next
a(c - 1, r) = JW
Next
Dim b() As Integer
ReDim b(1 To x + Y)
JW = 0
For I = x + Y To 1 Step -1
Bit = JW
For J = 1 To Y
Bit = Bit + a(I, J)
Next
b(I) = Bit Mod 10
JW = Bit \ 10
Next
If b(1) > 0 Then
MbC = MbC & b(1)
Else
MbC = MbC
End If
For I = 2 To x + Y
MbC = MbC & b(I)
Next
End Function
Private Function dxcx1(sa As String) As String
Dim x_() As Double, a As String
a = Trim(sa)
s2 = Split(sa, "/")
s3 = Split(sb, "/")
J = UBound(s2)
sb = J
ReDim x_(1 To sb)
For k = 1 To J
n1 = n1 + 1
ReDim Preserve x_(1 To n1)
x_(n1) = s2(n1)
Next
Dim n As Integer, I As Long, mn As Long, lh As Long, t As Double
'位序倒置
n = sb '求数组大小,其值必须是2的幂
lh = n / 2
J = n / 2
For I = 1 To n - 2
Debug.Print I, J
k = lh '下面是向右进位算法
Do
If k > J Then Exit Do '高位是1吗
J = J - k '是的,高位置0
k = k / 2 '准备次高位的权
Loop Until k = 0 '次高位的权若非0,则检查新的次高位
J = J + k '非则若最高位是0,则置1
s = s & "/" & x_(J + 1)
Next
dxcx1 = "/" & x_(1) & "/" & x_(1 + sb / 2) & s
End Function
Dim l As Long, le As Long, le1 As Long, n As Long, r As Long, p As Long, q As Long, m As Byte
Dim wr As Double, w1 As Double, wlr As Double, wl1 As Double, tr As Double, t1 As Double
Dim pi As Double, t As Double, tr1 As Double
Private Sub Command1_Click()
Dim xr() As Double, a As String
a = Trim(Text1)
b = Trim(Text3)
ts = Timer
Text2 = js & "有" & Len(js) & "位,用时" & Timer - ts & "秒"
sb1 = Len(a) + Len(b)
sb2 = Log(sb1) / Log(2)
If InStr(sb2, ".") = 0 Then
sb2 = sb2
Else
sb2 = Int(sb2) + 1
End If
sb = 2 ^ sb2
Print sb
If Len(a) = Len(b) And 2 ^ (Int(Log(Len(a)) / Log(2))) = Len(a) Then
a = String(Val(sb) - Len(a), "0") & a
b = String(Val(sb) - Len(b), "0") & b
ax = a: bx = b
Else
a = String(Val(sb) - Len(a), "0") & a
b = String(Val(sb) - Len(b), "0") & b
ax = a: bx = b
End If
Dim y_() As Double, x_() As Double
ReDim x_(1 To sb): ReDim y_(1 To sb)
For i1 = 1 To sb
x_(i1) = Mid(ax, sb - i1 + 1, 1): y_(i1) = Mid(bx, sb - i1 + 1, 1)
Next
Dim n As Integer, I As Long, J As Long, mn As Long, lh As Long, t As Double, k As Long
'位序倒置
n = sb '求数组大小,其值必须是2的幂
lh = n / 2
J = n / 2
For I = 1 To n - 2
Debug.Print I, J
k = lh '下面是向右进位算法
Do
If k > J Then Exit Do '高位是1吗
J = J - k '是的,高位置0
k = k / 2 '准备次高位的权
Loop Until k = 0 '次高位的权若非0,则检查新的次高位
J = J + k '非则若最高位是0,则置1
s = s & x_(J + 1)
s1 = s1 & y_(J + 1)
Next
a = x_(1) & x_(1 + sb / 2) & s
b = y_(1) & y_(1 + sb / 2) & s1
ReDim xr(0 To Len(a) - 1): ReDim yr(0 To Len(b) - 1): ReDim zr(0 To Len(b) - 1)
For i1 = 0 To Len(a) - 1
xr(i1) = Mid(a, i1 + 1, 1)
yr(i1) = Mid(b, i1 + 1, 1)
Next
Dim xi(): Dim yi(): Dim zi()
n = Len(a) '求数组大小,其值必须是2的幂
m = 0
l = 2
pi = 3.14159265358979
Do
l = l + l
m = m + 1
Loop Until l > n
n = l / 2
ReDim xi(n - 1): ReDim yi(n - 1): ReDim zi(n - 1)
l = 1
Do
le = 2 ^ l
le1 = le / 2
wr = 1
wi = 0
If l = 1 Then
t = 0
Else
t = pi / le1
End If
w1r = Cos(t)
w1i = -Sin(t)
r = 0
Do
p = r
Do
q = p + le1
tr = xr(q) * wr - xi(q) * wi
ti = xr(q) * wi + xi(q) * wr
tr1 = yr(q) * wr - yi(q) * wi
ti1 = yr(q) * wi + yi(q) * wr
xr(q) = xr(p) - tr
xi(q) = xi(p) - ti
xr(p) = xr(p) + tr
xi(p) = xi(p) + ti
yr(q) = yr(p) - tr1
yi(q) = yi(p) - ti1
yr(p) = yr(p) + tr1
yi(p) = yi(p) + ti1
p = p + le
Loop Until p > n - 1
wr2 = wr * w1r - wi * w1i
wi2 = wr * w1i + wi * w1r
wr = wr2
wi = wi2
r = r + 1
Loop Until r > le1 - 1
l = l + 1
Loop Until l > m
For I = 0 To n - 1 '仅输出模
zr(I) = xr(I) * yr(I) - xi(I) * yi(I): zi(I) = xr(I) * yi(I) + xi(I) * yr(I)
's = s & "/" & zr(I)
's1 = s1 & "/" & zi(I)
Next
J = sb
ReDim x_(1 To sb): ReDim y_(1 To sb)
For k = 1 To J
n1 = n1 + 1
ReDim Preserve x_(1 To n1)
x_(n1) = zr(n1 - 1): y_(n1) = zi(n1 - 1)
Next
'位序倒置
n = sb '求数组大小,其值必须是2的幂
lh = n / 2
J = n / 2
For I = 1 To n - 2
Debug.Print I, J
k = lh '下面是向右进位算法
Do
If k > J Then Exit Do '高位是1吗
J = J - k '是的,高位置0
k = k / 2 '准备次高位的权
Loop Until k = 0 '次高位的权若非0,则检查新的次高位
J = J + k '非则若最高位是0,则置1
js = js & "/" & x_(J + 1)
js1 = js1 & "/" & y_(J + 1)
Next
sx1 = "/" & x_(1) & "/" & x_(1 + sb / 2) & js
sy1 = "/" & y_(1) & "/" & y_(1 + sb / 2) & js1
's2 = nifft(dxcx1(Trim(s)), dxcx1(Trim(s1)), Trim(sb1))
s3 = nifft(Trim(sx1), Trim(sy1), Trim(sb1))
Text2 = s3 & "有" & Len(s3) & "位,用时" & Timer - ts & "秒"
End Sub
Private Sub Command2_Click()
Text1 = ""
Text2 = ""
Text3 = ""
Form1.Cls
End Sub
Private Function qdqd0(sa As String) As String
a = sa
Do While Left(a, 1) = "0"
a = Mid(a, 2)
Loop
If a = "" Then
a = 0
Else
a = a
End If
qdqd0 = a
End Function
Private Function nifft(sa As String, sb As String, sb1 As String) As String
Dim xi(): Dim yi(): Dim zi()
Dim xr(), yr(), zr()
s2 = Split(sa, "/")
s3 = Split(sb, "/")
J = UBound(s2)
n = J
For k = 1 To J
n1 = n1 + 1
ReDim Preserve xr(0 To n1 - 1)
ReDim Preserve yr(0 To n1 - 1)
xr(n1 - 1) = s2(n1): yr(n1 - 1) = s3(n1)
Next
ReDim zr(0 To J - 1)
m = 0
l = 2
pi = 3.14159265358979
Do
l = l + l
m = m + 1
Loop Until l > n
n = l / 2
ReDim xi(n - 1): ReDim yi(n - 1): ReDim zi(n - 1)
l = 1
Do
le = 2 ^ l
le1 = le / 2
wr = 1
wi = 0
If l = 1 Then
t = 0
Else
t = -1 * pi / le1
End If
w1r = Cos(t)
w1i = -Sin(t)
r = 0
Do
p = r
Do
q = p + le1
tr = xr(q) * wr - xi(q) * wi
ti = xr(q) * wi + xi(q) * wr
tr1 = yr(q) * wr - yi(q) * wi
ti1 = yr(q) * wi + yi(q) * wr
xr(q) = xr(p) - tr
xi(q) = xi(p) - ti
xr(p) = xr(p) + tr
xi(p) = xi(p) + ti
yr(q) = yr(p) - tr1
yi(q) = yi(p) - ti1
yr(p) = yr(p) + tr1
yi(p) = yi(p) + ti1
p = p + le
Loop Until p > n - 1
wr2 = wr * w1r - wi * w1i
wi2 = wr * w1i + wi * w1r
wr = wr2
wi = wi2
r = r + 1
Loop Until r > le1 - 1
l = l + 1
Loop Until l > m
For I = 0 To n - 1 '仅输出模
zr(I) = (xr(I) - yi(I)) / n
s1 = Int(Val(zr(I) + 0.5))
s = "/" & s1 & s
zr(I) = s1
Next
For i1 = 1 To Val(J - sb1 + 1)
zr(sb1 + i1 - 2) = 0
Next
For i1 = 0 To n - 1
If zr(i1) < 0 Then
zr(i1) = 0
Else
zr(i1) = zr(i1)
End If
s5 = "/" & Int(zr(i1)) & s5
If i1 = 0 Then
s6 = Int(zr(i1)) \ 10
s8 = Int(zr(i1)) Mod 10
ElseIf Val(zr(i1)) >= 0 Then
s7 = Int(zr(i1)) + Val(s6)
s10 = Val(s7) Mod 10
s11 = s10 & s11
s6 = Val(s7) \ 10
Else
s6 = Val(s6)
End If
Next
s9 = s6 & s11 & s8
nifft = qdqd0(Trim(s9))
End Function
Private Function dxcx0(sa As String, sb As String) As String
Dim x_() As Double, a As String
a = Trim(sa)
ReDim x_(1 To sb)
For i1 = 1 To sb
x_(i1) = Mid(a, sb - i1 + 1, 1)
Next
Dim n As Integer, I As Long, J As Long, mn As Long, lh As Long, t As Double, k As Long
'位序倒置
n = sb '求数组大小,其值必须是2的幂
lh = n / 2
J = n / 2
For I = 1 To n - 2
Debug.Print I, J
k = lh '下面是向右进位算法
Do
If k > J Then Exit Do '高位是1吗
J = J - k '是的,高位置0
k = k / 2 '准备次高位的权
Loop Until k = 0 '次高位的权若非0,则检查新的次高位
J = J + k '非则若最高位是0,则置1
s = s & x_(J + 1)
Next
dxcx0 = x_(1) & x_(1 + sb / 2) & s
End Function
Public Function MbC(D1 As String, D2 As String) As String '乘法
Dim x, Y '两数长度
x = Len(D1): Y = Len(D2)
Dim a() As Integer
ReDim a(1 To x + Y, 1 To Y)
Dim I, J, C1, C2, CJ, JW
For J = Y To 1 Step -1 'D2
JW = 0 '进位清0
C2 = Mid$(D2, J, 1) '每位数
For I = x To 1 Step -1 'D1
C1 = Mid$(D1, I, 1) '每位数
CJ = C1 * C2 + JW '计算乘积
c = I + J: r = Y + 1 - J
a(c, r) = CJ Mod 10 '本位
JW = CJ \ 10 '进位
Next
a(c - 1, r) = JW
Next
Dim b() As Integer
ReDim b(1 To x + Y)
JW = 0
For I = x + Y To 1 Step -1
Bit = JW
For J = 1 To Y
Bit = Bit + a(I, J)
Next
b(I) = Bit Mod 10
JW = Bit \ 10
Next
If b(1) > 0 Then
MbC = MbC & b(1)
Else
MbC = MbC
End If
For I = 2 To x + Y
MbC = MbC & b(I)
Next
End Function
Private Function dxcx1(sa As String) As String
Dim x_() As Double, a As String
a = Trim(sa)
s2 = Split(sa, "/")
s3 = Split(sb, "/")
J = UBound(s2)
sb = J
ReDim x_(1 To sb)
For k = 1 To J
n1 = n1 + 1
ReDim Preserve x_(1 To n1)
x_(n1) = s2(n1)
Next
Dim n As Integer, I As Long, mn As Long, lh As Long, t As Double
'位序倒置
n = sb '求数组大小,其值必须是2的幂
lh = n / 2
J = n / 2
For I = 1 To n - 2
Debug.Print I, J
k = lh '下面是向右进位算法
Do
If k > J Then Exit Do '高位是1吗
J = J - k '是的,高位置0
k = k / 2 '准备次高位的权
Loop Until k = 0 '次高位的权若非0,则检查新的次高位
J = J + k '非则若最高位是0,则置1
s = s & "/" & x_(J + 1)
Next
dxcx1 = "/" & x_(1) & "/" & x_(1 + sb / 2) & s
End Function
[此贴子已经被作者于2021-3-20 21:31编辑过]