标题:这个倒序和蝶形算法vb程序如何运行?
只看楼主
ysr2857
Rank: 6Rank: 6
等 级:贵宾
威 望:28
帖 子:767
专家分:65
注 册:2020-2-10
得分:0 
改了一下(改了逆变换的符号)还是不对了困难了,啊啊!
输入:Text1 =80607000,Text2=20403000,结果:
/11/2/10/24/34/65/29/16
与正确值比较: 0, 0, 0, 24, 46, 65, 38, 16也是不对。

Private Sub Command1_Click()
Dim xr() As Double, a As String
a = Trim(Text1)
b = Trim(Text3)
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
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 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
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
 
  r = 0
Do
  p = r
  Do
   q = p + le1
   
   tr = xr(q) * Cos((-2 * pi / 2 ^ l) * r)
   ti = xr(q) * Sin((-2 * pi / 2 ^ l) * r)
   
   tr1 = yr(q) * Cos((-2 * pi / 2 ^ l) * r)
   ti1 = yr(q) * Sin((-2 * pi / 2 ^ l) * r)
   
   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


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)
   If InStr(zr(i), ".") = 0 Then
   zr(i) = zr(i)
   Else
   a1 = Left(zr(i), InStr(zr(i), ".") - 1)
   b1 = Mid(zr(i), InStr(zr(i), "."), 3)
   zr(i) = a1 & b1
   End If
   If InStr(zi(i), ".") = 0 Then
   zi(i) = zi(i)
   Else
   a2 = Left(zi(i), InStr(zi(i), ".") - 1)
   b2 = Mid(zi(i), InStr(zi(i), "."), 3)
   zi(i) = a2 & b2
   End If
   s = s & "/" & zr(i)
   s1 = s1 & "/" & zi(i)
   Next
  s2 = nifft(dxcx1(Trim(s)), dxcx1(Trim(s1)))
   Text2 = s2
End Sub

Private Sub Command2_Click()
Text1 = ""
Text2 = ""
Text3 = ""
Form1.Cls
End Sub

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

Private Function nifft(sa As String, sb As String) As String
Dim l As Long, le As Long, le1 As Long, j 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
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 n - 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
  
  r = 0
Do
  p = r
  Do
   q = p + le1
   
   tr = xr(q) * Cos((2 * pi / 2 ^ l) * r)
   ti = xr(q) * Sin((2 * pi / 2 ^ l) * r)
   
   tr1 = yr(q) * Cos((2 * pi / 2 ^ l) * r)
   ti1 = yr(q) * Sin((2 * pi / 2 ^ l) * r)
   
   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


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
   If InStr(zr(i), ".") = 0 Then
   zr(i) = zr(i)
   Else
   a1 = Left(zr(i), InStr(zr(i), ".") - 1)
   b1 = Mid(zr(i), InStr(zr(i), "."), 3)
   zr(i) = a1 & b1
   End If
   
   s1 = Int(Val(zr(i) + 0.5))
   s = "/" & s1 & s
   Next
   
   
nifft = s

End Function


Private Function dxcx1(sa As String) As String

Dim x_() As Double, a As String
 a = Trim(sa)
   

s2 = Split(sa, "/")

   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-03-03 10:44
ysr2857
Rank: 6Rank: 6
等 级:贵宾
威 望:28
帖 子:767
专家分:65
注 册:2020-2-10
得分:0 
中间过程比较(傅里叶正变换的结果与实际值的比较):
/-13.65+124.39i/-25+-8.00i/-2.34+-5.60i/21+0i/-2.34+5.60i/-25+7.99i/-13.65+-124.39i/189+0i
与正确值比较:-13.6+123.4i, -25-8i, -2.4-5.8i, 21, -2.4+5.8i, -25+8i, -13.6-123.4i, 189
准确度差了点?
2021-03-03 11:22
ysr2857
Rank: 6Rank: 6
等 级:贵宾
威 望:28
帖 子:767
专家分:65
注 册:2020-2-10
得分:0 
5.6与5.8,124.39与123.4??咋回事呢?
2021-03-03 11:27
ysr2857
Rank: 6Rank: 6
等 级:贵宾
威 望:28
帖 子:767
专家分:65
注 册:2020-2-10
得分:0 
改了一下(改了逆变换的符号)还是不对,啊啊!
 输入:Text1 =80607000,Text2=20403000,结果:
/12/0/9/24/34/65/29/16
与正确值比较: 0, 0, 0, 24, 46, 65, 38, 16也是不对。
看上去是A1+A4=A1,A2+A6=A2,A3+A7=A3??手工计算一下就得到:/0/0/0/24/46/65/38/16,错位相加就可以得到正确答案了。
正确答案是:292896.
代码如下:

Private Sub Command1_Click()
Dim xr() As Double, a As String
a = Trim(Text1)
b = Trim(Text3)
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
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 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
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
 
  r = 0
Do
  p = r
  Do
   q = p + le1
   
   tr = xr(q) * Cos((-2 * pi / 2 ^ l) * r)
   ti = xr(q) * Sin((-2 * pi / 2 ^ l) * r)
   
   tr1 = yr(q) * Cos((-2 * pi / 2 ^ l) * r)
   ti1 = yr(q) * Sin((-2 * pi / 2 ^ l) * r)
   
   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


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)
   If InStr(zr(i), ".") = 0 Then
   zr(i) = zr(i)
   Else
   a1 = Left(zr(i), InStr(zr(i), ".") - 1)
   b1 = Mid(zr(i), InStr(zr(i), "."), 3)
   zr(i) = a1 & b1
   End If

   s = s & "/" & zr(i)
   s1 = s1 & "/" & zi(i)
   Next
  s2 = nifft(dxcx1(Trim(s)), dxcx1(Trim(s1)))
  s3 = nifft(Trim(s), Trim(s1))
   Text2 = s2
End Sub

Private Sub Command2_Click()
Text1 = ""
Text2 = ""
Text3 = ""
End Sub

Private Function nifft(sa As String, sb As String) As String
Dim l As Long, le As Long, le1 As Long, j 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
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
  
  r = 0
Do
  p = r
  Do
   q = p + le1
   
   tr = xr(q) * Cos((2 * pi / 2 ^ l) * r)
   ti = xr(q) * Sin((2 * pi / 2 ^ l) * r)
   
   tr1 = yr(q) * Cos((2 * pi / 2 ^ l) * r)
   ti1 = yr(q) * Sin((2 * pi / 2 ^ l) * r)
   
   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


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
   If InStr(zr(i), ".") = 0 Then
   zr(i) = zr(i)
   Else
   a1 = Left(zr(i), InStr(zr(i), ".") - 1)
   b1 = Mid(zr(i), InStr(zr(i), "."), 3)
   zr(i) = a1 & b1
   End If
   
   s1 = Int(Val(zr(i) + 0.5))
   s = "/" & s1 & s
   Next
   zr(4) = Val(zr(4)) + 0.5
   zr(1) = Val(zr(1)) + Val(zr(5) + 0.5)
   zr(2) = Val(zr(2)) + Val(zr(6) + 0.5)
   zr(3) = Val(zr(3)) + Val(zr(7) + 0.5)
   zr(5) = 0: zr(6) = 0: zr(7) = 0
   
   For I1 = 0 To n - 1
   s5 = "/" & Int(zr(I1)) & s5
   If I1 = 0 Then
   s6 = Mid(s5, 2, 1)
   s8 = Mid(s5, 3, 1)
   ElseIf Val(zr(I1)) > 0 Then
   s7 = Val(Mid(s5, 2, 2)) + Val(s6)
   s10 = Mid(s7, 2)
   s11 = s10 & s11
   s6 = Left(s7, 1)
   Else
   s6 = s6
   End If
   
   Next
   s9 = s6 & s11 & s8
   
nifft = 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

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-03-03 20:52
ysr2857
Rank: 6Rank: 6
等 级:贵宾
威 望:28
帖 子:767
专家分:65
注 册:2020-2-10
得分:0 
啥情况?只要最高位出现9,结果都能符合实际:
如:678*923=625794,而程序结果:/0/0/0/54/75/104/37/24,错位相加得到:625794.
678*993=673254,而程序结果:/0/0/0/54/117/153/93/24,错位相加得到:673254.
678*999=677322,而程序结果:/0/0/0/54/117/189/135/72,错位相加得到:677322.
978*123=120294,而程序结果:/0/0/0/9/25/49/37/24,错位相加得到:120294.
999*999=998001,而程序结果:/0/0/0/79/162/243/162/83,错位相加得到:978003(这个不对了).
999*99=98901,而程序结果/0/0/0/4/81/162/162/81,错位相加得到:138901(这个不对了).

Private Sub Command1_Click()
Dim xr() As Double, a As String
a = Trim(Text1)
b = Trim(Text3)
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 = a: b = b
Else

a = String(Val(sb) - Len(a), "0") & a
b = String(Val(sb) - Len(b), "0") & b
a = dxcx0(Trim(a), Val(sb)): b = dxcx0(Trim(b), Val(sb))
End If
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 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
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
 
  r = 0
Do
  p = r
  Do
   q = p + le1
   
   tr = xr(q) * Cos((-2 * pi / 2 ^ l) * r)
   ti = xr(q) * Sin((-2 * pi / 2 ^ l) * r)
   
   tr1 = yr(q) * Cos((-2 * pi / 2 ^ l) * r)
   ti1 = yr(q) * Sin((-2 * pi / 2 ^ l) * r)
   
   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


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)
   If InStr(zr(i), ".") = 0 Then
   zr(i) = zr(i)
   Else
   a1 = Left(zr(i), InStr(zr(i), ".") - 1)
   b1 = Mid(zr(i), InStr(zr(i), "."), 3)
   zr(i) = a1 & b1
   End If

   s = s & "/" & zr(i)
   s1 = s1 & "/" & zi(i)
   Next
  s2 = nifft(dxcx1(Trim(s)), dxcx1(Trim(s1)))
  s3 = nifft(Trim(s), Trim(s1))
   Text2 = s2
End Sub

Private Sub Command2_Click()
Text1 = ""
Text2 = ""
Text3 = ""
Form1.Cls
End Sub

Private Function nifft(sa As String, sb As String) As String
Dim l As Long, le As Long, le1 As Long, j 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
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
  
  r = 0
Do
  p = r
  Do
   q = p + le1
   
   tr = xr(q) * Cos((2 * pi / 2 ^ l) * r)
   ti = xr(q) * Sin((2 * pi / 2 ^ l) * r)
   
   tr1 = yr(q) * Cos((2 * pi / 2 ^ l) * r)
   ti1 = yr(q) * Sin((2 * pi / 2 ^ l) * r)
   
   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


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
   If InStr(zr(i), ".") = 0 Then
   zr(i) = zr(i)
   Else
   a1 = Left(zr(i), InStr(zr(i), ".") - 1)
   b1 = Mid(zr(i), InStr(zr(i), "."), 3)
   zr(i) = a1 & b1
   End If
   
   s1 = Int(Val(zr(i) + 0.5))
   s = "/" & s1 & s
   Next
   
   zr(0) = Val(zr(0)) + 0.5
   zr(2) = Val(zr(2)) + 0.5
   zr(4) = Val(zr(4)) + 0.5
   zr(1) = Val(zr(1)) + Val(zr(5) + 0.5)
   zr(3) = Val(zr(3)) + Val(zr(7) + 0.5)
   zr(5) = 0: zr(6) = 0: zr(7) = 0
   
   For I1 = 0 To n - 1
   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 = s6
   End If
   
   Next
   s9 = s6 & s11 & s8
   
nifft = 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

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-03-04 01:48
ysr2857
Rank: 6Rank: 6
等 级:贵宾
威 望:28
帖 子:767
专家分:65
注 册:2020-2-10
得分:0 
回复 45楼 ysr2857
修改了代码,只有被乘数和乘数都是小于4位的数才有个别正确,咋回事呢?
代码如下:

Private Sub Command1_Click()
 Dim xr() As Double, a As String
 a = Trim(Text1)
 b = Trim(Text3)
 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
 a = dxcx0(Trim(a), Val(sb)): b = dxcx0(Trim(b), Val(sb))
 Else

 a = String(Val(sb) - Len(a), "0") & a
 b = String(Val(sb) - Len(b), "0") & b
 a = dxcx0(Trim(a), Val(sb)): b = dxcx0(Trim(b), Val(sb))
 End If
 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 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
 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
  
   r = 0
 Do
   p = r
   Do
    q = p + le1
   
    tr = xr(q) * Cos((-2 * pi / 2 ^ l) * r)
    ti = xr(q) * Sin((-2 * pi / 2 ^ l) * r)
   
    tr1 = yr(q) * Cos((-2 * pi / 2 ^ l) * r)
    ti1 = yr(q) * Sin((-2 * pi / 2 ^ l) * r)
   
    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


 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)
    If InStr(zr(i), ".") = 0 Then
    zr(i) = zr(i)
    Else
    a1 = Left(zr(i), InStr(zr(i), ".") - 1)
    b1 = Mid(zr(i), InStr(zr(i), "."), 3)
    zr(i) = a1 & b1
    End If

    s = s & "/" & zr(i)
    s1 = s1 & "/" & zi(i)
    Next
   s2 = nifft(dxcx1(Trim(s)), dxcx1(Trim(s1)))
   s3 = nifft(Trim(s), Trim(s1))
    Text2 = s2
 End Sub

 Private Sub Command2_Click()
 Text1 = ""
 Text2 = ""
 Text3 = ""
 Form1.Cls
 End Sub

 Private Function nifft(sa As String, sb As String) As String
 Dim l As Long, le As Long, le1 As Long, j 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
 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
   
   r = 0
 Do
   p = r
   Do
    q = p + le1
   
    tr = xr(q) * Cos((2 * pi / 2 ^ l) * r)
    ti = xr(q) * Sin((2 * pi / 2 ^ l) * r)
   
    tr1 = yr(q) * Cos((2 * pi / 2 ^ l) * r)
    ti1 = yr(q) * Sin((2 * pi / 2 ^ l) * r)
   
    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


 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
    If InStr(zr(i), ".") = 0 Then
    zr(i) = zr(i)
    Else
    a1 = Left(zr(i), InStr(zr(i), ".") - 1)
    b1 = Mid(zr(i), InStr(zr(i), "."), 3)
    zr(i) = a1 & b1
    End If
   
    s1 = Int(Val(zr(i) + 0.5))
    s = "/" & s1 & s
    zr(i) = s1
    Next
    For i1 = 1 To Val(j / 4 - 1)
    zr(i1) = Val(zr(i1)) + Val(zr(j / 2 + i1))
    zr(j / 2 + i1) = 0
    Next
    For i2 = j / 4 + 1 To j / 2 - 1
    zr(i2) = Val(zr(i2)) + Val(zr(j / 2 + i2))
    zr(j / 2 + i2) = 0
    Next
   
   
    For i1 = 0 To n - 1
    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 = s6
    End If
   
    Next
    s9 = s6 & s11 & s8
   
 nifft = 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

 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-5 17:21编辑过]

2021-03-04 22:42
ysr2857
Rank: 6Rank: 6
等 级:贵宾
威 望:28
帖 子:767
专家分:65
注 册:2020-2-10
得分:0 
快速傅里叶逆变换有问题?咋回事呢?咋逆不回去?
2021-03-05 12:59
ysr2857
Rank: 6Rank: 6
等 级:贵宾
威 望:28
帖 子:767
专家分:65
注 册:2020-2-10
得分:0 
输入:Text1=456789,Text2=123456,程序结果为:/278.65+416.29/-20.48+113.74/11.51+33.76/9.99+45/-1.04+12.07/-3.51+-6.25/-5.13+-17.39/9+0
/-5.13+17.39/-3.51+6.25/-1.04+-12.07/10.00+-45.00/11.51+-33.76/-20.48+-113.74/278.65+-416.29/819+0.
2021-03-10 21:23
ysr2857
Rank: 6Rank: 6
等 级:贵宾
威 望:28
帖 子:767
专家分:65
注 册:2020-2-10
得分:0 
456789*123456=56393342784,咋连这么小的数都算不对?
2021-03-11 18:23
ysr2857
Rank: 6Rank: 6
等 级:贵宾
威 望:28
帖 子:767
专家分:65
注 册:2020-2-10
得分:0 
手工逆变换计算得到:A0=1367.99/16=85.499375,这个可能就不对,应该是94?

[此贴子已经被作者于2021-3-11 21:56编辑过]

2021-03-11 18:49



参与讨论请移步原网站贴子:https://bbs.bccn.net/thread-504309-1-1.html




关于我们 | 广告合作 | 编程中国 | 清除Cookies | TOP | 手机版

编程中国 版权所有,并保留所有权利。
Powered by Discuz, Processed in 0.227066 second(s), 7 queries.
Copyright©2004-2024, BCCN.NET, All Rights Reserved