各位老师好！求助编辑一个大整数的快速乘除法可调用程序 - VB6论坛

得分:0

把4位一组的快速程序代码发一下，代码如下：

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

  x = Len(a) \ 4: Y = Len(b) \ 4
   a = String(Val(x * 4 + 4 - Len(a)), "0") & a
  b = String(Val(Y * 4 + 4 - Len(b)), "0") & b
  x = x + 1: Y = Y + 1
  sb1 = x + Y
  sb2 = Log(sb1) / Log(2)
  If InStr(sb2, ".") = 0 Then
  sb2 = sb2
  Else
  sb2 = Int(sb2) + 1
  End If
  sb = 2 ^ sb2
  Print sb
  a = String(Val(sb) * 4 - Len(a), "0") & a
  b = String(Val(sb) * 4 - Len(b), "0") & b
  Print a



   ReDim x_(1 To sb): ReDim y_(1 To sb)
    For i1 = 1 To sb
    x_(i1) = Mid(a, (sb - i1 + 1) * 4 - 3, 4): y_(i1) = Mid(b, (sb - i1 + 1) * 4 - 3, 4)
    If Len(x_(i1)) < 4 Then
    x_(i1) = String(4 - Len(x_(i1)), "0") & x_(i1)
    ElseIf Len(y_(i1)) < 4 Then
    y_(i1) = String(4 - Len(y_(i1)), "0") & y_(i1)
    Else
    x_(i1) = x_(i1): y_(i1) = y_(i1)
    End If

      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) - 4) \ 4): ReDim yr(0 To (Len(b) - 4) \ 4): ReDim zr(0 To (Len(b) - 4) \ 4)
  If Len(a) = 4 Then
  xr(0) = a: yr(0) = b
  Else
  For i1 = 0 To (Len(a) - 4) \ 4
  xr(i1) = Mid(a, (i1 + 1) * 4 - 3, 4)
  yr(i1) = Mid(b, (i1 + 1) * 4 - 3, 4)

     Next
     End If

  Dim xi(): Dim yi(): Dim zi()
  n = sb '求数组大小，其值必须是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
     xr(p) = Format(Val(xr(p)), "0.000000"): xi(p) = Format(Val(xi(p)), "0.000000")
     yr(p) = Format(Val(yr(p)), "0.000000"): yi(p) = Format(Val(yi(p)), "0.000000")

      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)
    zr(I) = Format(Val(zr(I)), "0.000000"): zi(I) = Format(Val(zi(I)), "0.000000")


      '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)
         x_(n1) = Format(Val(x_(n1)), "0.000000"): y_(n1) = Format(Val(y_(n1)), "0.000000")

       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

xr(I + 1) = x_(J + 1): yr(I + 1) = y_(J + 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
   xr(0) = x_(1): xr(1) = x_(1 + sb / 2)
   yr(0) = y_(1): yr(1) = y_(1 + sb / 2)


   ns = Len(a) \ 4: Jn = ns




  ReDim zr(0 To ns - 1)

  m = 0
  l = 2
  pi = 3.14159265358979
  Do
  l = l + l
  m = m + 1
  Loop Until l > ns
  ns = l / 2
  ReDim xi(ns - 1): ReDim yi(ns - 1): ReDim zi(ns - 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
     xr(p) = Format(Val(xr(p)), "0.000000"): xi(p) = Format(Val(xi(p)), "0.000000")
     yr(p) = Format(Val(yr(p)), "0.000000"): yi(p) = Format(Val(yi(p)), "0.000000")
      p = p + le
  Loop Until p > ns - 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 ns - 1 '仅输出模
zr(I) = (xr(I) - yi(I)) / n
      zr(I) = Format(Val(zr(I) + 0.5), "0.000000")
     If InStr(zr(I), ".") = 0 Then
     s121 = zr(I)
     Else
     s121 = Left(zr(I), InStr(zr(I), ".") - 1)
      End If
      s0 = "/" & s121 & s0
      zr(I) = s121
      Next
      For i1 = 1 To Val(Jn - sb1 + 1)
      zr(sb1 + i1 - 2) = 0
      Next



      For i1 = 0 To n - 1
      If zr(i1) < 0 Then
      zr(i1) = "0000"
      ElseIf Len(zr(i1)) < 4 Then
      zr(i1) = String(4 - Len(zr(i1)), "0") & zr(i1)
      Else
      zr(i1) = zr(i1)
      End If

      s5 = s5 & "/" & zr(i1)

      If i1 = 0 Then

      s6 = Val(Left(zr(i1), Len(zr(i1)) - 4))
      If Len(s6) < 4 Then
      s6 = String(4 - Len(s6), "0") & s6
      Else
      s6 = s6
      End If
      s8 = Right(zr(i1), 4)
      ElseIf Val(zr(i1)) >= 0 Then
      s7 = MPC1(Trim(zr(i1)), Trim(s6))
      s10 = Right(s7, 4)
      s11 = s10 & s11
      If Len(s7) < 4 Then
      s7 = String(4 - Len(s7), "0") & s7
      ElseIf Len(s7) = 4 Then
      s6 = "0000"
      Else
      s7 = s7
      s6 = Val(Left(s7, Len(s7) - 4))
      End If
      Else
      s6 = s6
      End If

      Next
      s9 = s6 & s11 & s8


   s9 = qdqd0(Trim(s9))



     's2 = nifft(dxcx1(Trim(s)), dxcx1(Trim(s1)), Trim(sb1))

     's3 = nifft(Trim(sx1), Trim(sy1), Trim(sb1))
      Text2 = s9 & "有" & Len(s9) & "位，用时" & 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 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
    Public Function MPC1(D1 As String, D2 As String) As String 'jiafa
Dim x, Y '两数长度

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): Y = Len(D4)
Dim a() As Integer, B1() As Integer, C1() As Integer, E1() As Integer
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 = 0 '进位清0
B1(J) = Mid$(D4, J, 1) '每位数
For I = x To 1 Step -1  'D1
   a(I) = Mid$(d3, I, 1) '每位数
   C1(I) = a(I) + B1(I) + JW '计算jia
   JW = C1(I) \ 10
   E1(I) = C1(I) Mod 10
  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

End Function



    '移动小数点的程序
Private Function ydxsd(sa As String, sd As String) As String
If Len(sa) = 1 And Val(sa) = 0 Then
  ydxsd = 0
  Else

    sc = InStr(sa, ".")
    If Val(sc) = 0 Then
    ydxsd = sa & String(sd, "0")
    Else
    se = Left(sa, Val(sc) - 1)
    sf = Right(sa, Len(sa) - Val(sc))
    If Val(Len(sf)) >= Val(sd) Then
    ydxsd = se & Mid(sf, 1, sd)
      Else
      ydxsd = se & sf & String(Val(sd) - Len(sf), "0")
      End If
      End If
      End If
      End Function

'符号运算程序
Private Function fhys(sa As String) As String

If InStr(sa, "-") = 0 Then
  fhys = 1
   Else
   fhys = -1
End If


End Function

'添加符号程序
Private Function tjfh(sa As String, sf As String) As String 'qianjia fuhao
If Val(sf) < 0 Then
tjfh = "-" & sa
Else
tjfh = sa
End If


End Function

'带符号的加法程序
Private Function mpc3(sa As String, sb As String) As String 'jiafa jingdu daifh
Dim ja
fh1 = fhys(sa)
fh2 = fhys(sb)
If Val(fh1) * Val(fh2) > 0 Then
ja = MPC1(qdfh(sa), qdfh(sb))

If Val(fh1) > 0 Then
mpc3 = ja
Else
mpc3 = "-" & ja
End If
Else
xd = MBJC(qdfh(sa), qdfh(sb))
If xd >= 0 Then
jb = qqdl(MPC(qdfh(sa), qdfh(sb)))
Else
jb = qqdl(MPC(qdfh(sb), qdfh(sa)))
End If
If xd >= 0 And Val(fh1) > 0 Then
mpc3 = jb
Else
If xd > 0 And Val(fh1) < 0 Then
mpc3 = "-" & jb
Else
If Val(fh2) < 0 Then
mpc3 = "-" & jb
Else
mpc3 = jb
End If
End If
End If
End If

End Function

'带符号的减法程序
Private Function mpc2(sa As String, sb As String) As String 'jianfa jingdu daifh
Dim ja
fh1 = fhys(sa)
fh2 = fhys(sb)
xd = MBJC(qqdl(qdfh(sa)), qqdl(qdfh(sb)))
If Val(fh1) * Val(fh2) < 0 Then
ja = MPC1(qdfh(sa), qdfh(sb))

If Val(fh1) > 0 Then
mpc2 = ja
Else

mpc2 = "-" & ja

End If
Else

If xd >= 0 Then
jb = qqdl(MPC(qdfh(sa), qdfh(sb)))
Else
jb = qqdl(MPC(qdfh(sb), qdfh(sa)))
End If
If xd >= 0 And Val(fh1) > 0 Then
mpc2 = jb
Else
If xd > 0 And Val(fh1) < 0 Then
mpc2 = "-" & jb
Else
If Val(fh2) <= 0 Then
mpc2 = jb
Else
mpc2 = "-" & jb
End If
End If
End If
End If

End Function

'去前导0的程序
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 Function mbjc2(sa As String, sb As String) As String 'bi jiao dx daifh
Dim ja
fh1 = fhys(sa)
fh2 = fhys(sb)
If Val(fh1) < Val(fh2) Then
mbjc2 = -1
Else
If Val(fh1) > Val(fh2) Then
mbjc2 = 1
Else

ja = MBJC(qdfh(sa), qdfh(sb))

If Val(fh1) > 0 And Val(ja) > 0 Then
mbjc2 = 1
Else
If Val(fh1) < 0 And Val(ja) > 0 Then
mbjc2 = -1
Else
If Val(fh1) > 0 And Val(ja) < 0 Then
mbjc2 = -1
Else
If Val(fh1) < 0 And Val(ja) < 0 Then
mbjc2 = 1
Else
mbjc2 = 0
End If
End If
End If
End If
End If
End If

End Function

'带符号的乘法程序
Private Function mbc2(sa As String, sb As String, sd As String) As String 'chengfa jingdu daifh
Dim ja
fh1 = fhys(sa)
fh2 = fhys(sb)
If sa = 0 Or sb = 0 Then
mbc2 = 0
Else

ja = MbC(qdfh(sa), qdfh(sb))
If Val(Len(ja)) > Val(sd) Then
jb = Left(ja, Val(Len(ja)) - Val(sd))

If Val(fh1) * Val(fh2) > 0 Then
mbc2 = jb
Else
mbc2 = "-" & jb
End If

Else
mbc2 = 0
End If
End If

End Function

'去掉符号的程序
Private Function qdfh(sa As String) As String

If InStr(sa, "-") > 0 Then
qdfh = Mid(sa, 2)
Else
If InStr(sa, "+") > 0 Then
qdfh = Mid(sa, 2)
Else
qdfh = sa
End If
End If

End Function

'减法程序（必须大的减去小的不输出负值）：（这个收集进来这回就全了，可以组装起来成为快速程序了）
Public Function MPC(D1 As String, D2 As String) As String ';jianfaqi
Dim x, Y ';两数长度
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): Y = Len(D4)
Dim a() As Integer, B1() As Integer, C1() As Integer, E1() As Integer
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, 1) ';每位数
For I = x To 1 Step -1  ';D1
   a(I) = Mid(d3, I, 1) ';每位数
   C1(I) = 10 + a(I) - B1(I) - 1 + JW ';计算jia
   JW = C1(I) \ 10
   E1(I) = C1(I) Mod 10
  Next
  Next
  For r = 1 To x
  MPC = MPC & E1(r)
  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 Function

'比较大小的程序
Public Function MBJC(D1 As String, D2 As String) As String 'bijiao
If Len(D1) > Len(D2) Then
MBJC = 1
Else
If Len(D1) < Len(D2) Then
MBJC = -1
Else
If Len(D1) = Len(D2) And Len(D1) >= 10 Then

Dim x, Y
x = Len(D1) \ 4: Y = Len(D2) \ 4
Dim a() As String, b() As String
ReDim a(4 To 4 * x + 4)
ReDim b(4 To 4 * Y + 4)
If Val(Left(D1, Len(D1) - 4 * x)) > Val(Left(D2, Len(D2) - 4 * Y)) Then
MBJC = 1
Else
If Val(Left(D1, Len(D1) - 4 * x)) < Val(Left(D2, Len(D2) - 4 * Y)) Then
MBJC = -1
Else
For I = 4 To 4 * x Step 4
a(I) = Mid(D1, Len(D1) - I + 1, 4)
b(I) = Mid(D2, Len(D2) - I + 1, 4)
Next
J = 4 * x
Do While a(J) = b(J) And J >= 8

J = J - 4
    Loop


  If Val(a(J)) - Val(b(J)) > 0 Then
  MBJC = 1
  Else
  If Val(a(J)) - Val(b(J)) < 0 Then
  MBJC = -1
  Else
  MBJC = 0
  End If

End If

End If
End If
End If
If Len(D1) < 10 Then
ja = Val(D1) - Val(D2)
  If ja > 0 Then
   MBJC = 1
   Else
    If ja = 0 Then
     MBJC = 0
    Else

  MBJC = -1
End If
End If
End If

End If
End If
End Function

[此贴子已经被作者于2021-3-29 14:16编辑过]

第 182 楼

得分:0

回复 227楼 ysr2857

999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999*9=8999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999991有271位，用时0.0859375秒（明显快了一点点）

第 183 楼

得分:0

4999999999999999999999999有25位，用时2.197266E-02秒（这个是我的程序计算的60度的余弦值点后25位，可以用于8位一组的利用快速傅里叶变换的乘法程序，50位的就慢些（可用于16位一组的快速乘法），大约0.15秒，150位的（可用于48位一组的快速乘法）更慢大约4.5秒，要想提高计算正弦余弦的速度看来必须改变算法，可以用到秦九韶算法，用到秦九韶多项式，就是把泰勒级数展开式写成秦九韶多项式，就是有多层括号的多项式，由内向外逐层计算，迭代几次就可以达到精度，希望老师指点！欢迎指导，欢迎提供更好的方法。）

50000000000000000000000000000000000000000000000001有50位，用时0.1572266秒

500000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000有150位，用时4.741211秒

有空试试8位一组的就是把8位当作1位数，看看能不能提高速度（因为要多次用到正弦余弦值，前面的速度还是不够快，得不偿失的话，速度不一定能快），有空再试试吧。
各位老师晚安！！

第 184 楼

得分:0

下面把这个程序传一下：

Private Sub Command1_Click() '快速求高精度三角函数的实验程序
Dim a, b
  a = Trim(Text1): b = Trim(Text2): b3 = b: a3 = a
  ts = Timer

  a2 = zhengchuqy(MCC1(jspaizh(Val(150)), Val(3)))
  a1 = jsyuxian(Trim(a2), Val(150))


  Text3 = a1 & "有" & Len(a1) & "位，用时" & Timer - ts & "秒"

  End Sub

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

  End Sub

  Private Function mpc3(sa As String, sb As String) As String 'jiafa jingdu daifh
Dim ja
fh1 = fhys(sa)
fh2 = fhys(sb)
If Val(fh1) * Val(fh2) > 0 Then
ja = MPC1(qdfh(sa), qdfh(sb))

If Val(fh1) > 0 Then
mpc3 = ja
Else
mpc3 = "-" & ja
End If
Else
xd = MBJC(qdfh(sa), qdfh(sb))
If xd >= 0 Then
jb = qqdl(MPC(qdfh(sa), qdfh(sb)))
Else
jb = qqdl(MPC(qdfh(sb), qdfh(sa)))
End If
If xd >= 0 And Val(fh1) > 0 Then
mpc3 = jb
Else
If xd > 0 And Val(fh1) < 0 Then
mpc3 = "-" & jb
Else
If Val(fh2) < 0 Then
mpc3 = "-" & jb
Else
mpc3 = jb
End If
End If
End If
End If

End Function


  Private Function jspaizh(sd As String) As String '派/2=1+1/3+1*2/3*5+1*2*3/3*5*7+……
'应该是 Pi/4=1-1/3+1/5-1/7+…+（-1）^(n-1)/(2*n-1)吧，呵呵
'派/2=2/1*2/3*4/3*4/5^^^^^=2*2/1*3*4*4/3*5*6*6/5*7*^^^^^^^
Dim s1 As String
s1 = "31415926535 8979323846 2643383279 5028841971 6939937510 5820974944 5923078164 0628620899 8628034825 3421170679 8214808651 32823066470938446095 5058223172 5359408128 4811174502 8410270193 8521105559 6446229489 5493038196 4428810975 6659334461 2847564823 37867831652712019091 4564856692 3460348610 4543266482 1339360726 0249141273 7245870066 0631558817 4881520920 9628292540 9171536436 7892590360" _
& "0113305305 4882046652 1384146951 9415116094 3305727036 5759591953 0921861173 8193261179 3105118548 0744623799 6274956735 1885752724" _
& "8912279381 8301194912 9833673362 4406566430 8602139494 6395224737 1907021798 6094370277 0539217176 2931767523 8467481846 7669405132" _
& "0005681271 4526356082 7785771342 7577896091 7363717872 1468440901 2249534301 4654958537 1050792279 6892589235 4201995611 2129021960" _
& "8640344181 5981362977 4771309960 5187072113 4999999837 2978049951 0597317328 1609631859 5024459455 3469083026 4252230825 3344685035"
s2 = DeleteSpace(s1)
jspaizh = Left(s2, Val(sd) + 1)

End Function

Public Function DeleteSpace(Tmp As String) As String
   Dim Inst As Integer
   Do
       Tmp = Replace(Tmp, " ", "")
       DoEvents
       Inst = InStr(Tmp, " ")
   Loop While Inst > 0
   DeleteSpace = Tmp
End Function

Private Function jcjs(sa As String) As String

Dim s
s = 1
For I = 1 To sa
s = MbC(Trim(s), Val(I))
Next
jcjs = s


End Function

  Private Function tjfh(sa As String, sf As String) As String 'qianjia fuhao
If Val(sf) < 0 Then
tjfh = "-" & sa
Else
tjfh = sa
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 Function jszhxian(sa As String, sd As String) As String
Dim s1
s1 = 1 & String(Val(sd), "0")
s2 = mbc2(Trim(sa), Trim(sa), Val(sd))
fs1 = -1
s3 = 3
Do While MBJC(zhengchuqy(MCC1(Trim(s1), jcjs(Val(s3)))), 1) >= 0
s1 = mbc2(Trim(s1), Trim(s2), Val(sd))

s = mpc3(Trim(s), tjfh(zhengchuqy(MCC1(Trim(s1), jcjs(Val(s3)))), Val(fs1)))

s3 = Val(Val(s3) + 2)

fs1 = Val(-1) * Val(fs1)

Loop

jszhxian = mbc2(Trim(sa), mpc3(Val(1) & String(Val(sd), "0"), Trim(s)), Val(sd))
End Function

Private Function zhengchuqy(sa As String) As String
If InStr(sa, "/") = 0 Then
zhengchuqy = sa
Else
zhengchuqy = Left(sa, InStr(sa, "/") - 1)
End If

End Function

Private Function jsyuxian(sa As String, sd As String) As String
If MBJC(qdfh(Trim(sa)), 1 & String(sd, "0")) = 1 Then
js = zhengchuqy(MCC1(Trim(jspaizh(sd)), Val(2)))
jsyuxian = jszhxian(MPC(Trim(js), qdfh(Trim(sa))), Val(sd))
Else
Dim s1
s1 = 1 & String(Val(sd), "0")
s2 = mbc2(Trim(sa), Trim(sa), Val(sd))
fs1 = -1
s3 = 2
Do While MBJC(zhengchuqy(MCC1(Trim(s1), jcjs(Val(s3)))), 1) >= 0
s1 = mbc2(Trim(s1), Trim(s2), Val(sd))

s = mpc3(Trim(s), tjfh(zhengchuqy(MCC1(Trim(s1), jcjs(Val(s3)))), Val(fs1)))

s3 = Val(Val(s3) + 2)

fs1 = Val(-1) * Val(fs1)

Loop

jsyuxian = mpc3(Val(1) & String(Val(sd), "0"), Trim(s))
End If
End Function

Private Function qdfh(sa As String) As String

If InStr(sa, "-") > 0 Then
qdfh = Mid(sa, 2)
Else
If InStr(sa, "+") > 0 Then
qdfh = Mid(sa, 2)
Else
qdfh = sa
End If
End If


End Function

  Private Function fhys(sa As String) As String

If InStr(sa, "-") = 0 Then
  fhys = 1
   Else
   fhys = -1
End If


End Function

  Private Function mpc2(sa As String, sb As String) As String 'jianfa jingdu daifh
Dim ja
fh1 = fhys(sa)
fh2 = fhys(sb)
xd = MBJC(qqdl(qdfh(sa)), qqdl(qdfh(sb)))
If Val(fh1) * Val(fh2) < 0 Then
ja = MPC1(qdfh(sa), qdfh(sb))

If Val(fh1) > 0 Then
mpc2 = ja
Else

mpc2 = "-" & ja

End If
Else

If xd >= 0 Then
jb = qqdl(MPC(qdfh(sa), qdfh(sb)))
Else
jb = qqdl(MPC(qdfh(sb), qdfh(sa)))
End If
If xd >= 0 And Val(fh1) > 0 Then
mpc2 = jb
Else
If xd > 0 And Val(fh1) < 0 Then
mpc2 = "-" & jb
Else
If Val(fh2) <= 0 Then
mpc2 = jb
Else
mpc2 = "-" & jb
End If
End If
End If
End If

End Function

Private Function mcc2(sa As String, sb As String, sd As String) As String 'chufa jingdu daifh
Dim ja
fh1 = fhys(sa)
fh2 = fhys(sb)

ja = MCC1(qdfh(sa) & String(sd, "0"), qdfh(Trim(sb)))
If InStr(ja, "/") = 0 And Val(fh1) * Val(fh2) > 0 Then
mcc2 = ja
Else
If InStr(ja, "/") = 0 And Val(fh1) * Val(fh2) < 0 Then
mcc2 = "-" & ja
Else
If Val(fh1) * Val(fh2) > 0 Then
mcc2 = Left(ja, InStr(ja, "/") - 1)
Else
mcc2 = "-" & Left(ja, InStr(ja, "/") - 1)
End If
End If
End If

End Function

  Private Function mbc2(sa As String, sb As String, sd As String) As String 'chengfa jingdu daifh
Dim ja
fh1 = fhys(sa)
fh2 = fhys(sb)
If sa = 0 Or sb = 0 Then
mbc2 = 0
Else

ja = MbC(qdfh(sa), qdfh(sb))
If Val(Len(ja)) > Val(sd) Then
jb = Left(ja, Val(Len(ja)) - Val(sd))

If Val(fh1) * Val(fh2) > 0 Then
mbc2 = jb
Else
mbc2 = "-" & jb
End If

Else
mbc2 = 0
End If
End If

End Function

Private Function qdhz0(sa As String) As String
  a = sa
  Do While Right(a, 1) = "0"
  a = Left(a, Len(a) - 1)
  Loop
  If a = "" Then
  a = 0
  Else
  a = a
  End If
  qdhz0 = a
  End Function

  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 tjxsd(sa As String, sd As String) As String
  If Val(Len(sa)) > Val(sd) Then
  tjxsd = Left(sa, Val(Len(sa)) - Val(sd)) & "." & Mid(sa, Val(Len(sa)) - Val(sd) + 1)
  Else
  If Val(Len(sa)) = Val(sd) Then
    tjxsd = "0." & sa
    Else
    tjxsd = "0." & String(Val(sd) - Val(Len(sa)), "0") & Trim(sa)
    End If
    End If

  End Function

  Private Function ydxsd(sa As String, sd As String) As String
  If Len(sa) = 1 And Val(sa) = 0 Then
    ydxsd = 0
    Else

      sc = InStr(sa, ".")
      If Val(sc) = 0 Then
      ydxsd = sa & String(sd, "0")
      Else
      se = Left(sa, Val(sc) - 1)
      sf = Right(sa, Len(sa) - Val(sc))
      If Val(Len(sf)) >= Val(sd) Then
      ydxsd = se & Mid(sf, 1, sd)
        Else
        ydxsd = se & sf & String(Val(sd) - Len(sf), "0")
        End If
        End If
        End If
        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

  Public Function MPC(D1 As String, D2 As String) As String ';jianfaqi
  Dim x, Y ';两数长度
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 Len(d3) > 8 * x 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, 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
     JW = C1(I) \ 10 ^ 8
     E1(I) = C1(I) Mod 10 ^ 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 Function

    Public Function MCC1(D1 As String, D2 As String) As String ';大整数的除法
Dim ss
ss = MBJC(D1, D2)
If ss = -1 Then
MCC1 = "0" & "/" & D1
  Else
  If ss = 0 Then
   MCC1 = 1
   Else
   If Len(D1) = Len(D2) Then
     s = Val(Left(D1, 1)) \ Val(Left(D2, 1))

Do While MBJC(MbC(Trim(s), Trim(D2)), D1) = 1
  s = s - 1
  Loop
  If MBJC(MbC(Trim(s), Trim(D2)), D1) = 0 Then
   MCC1 = s
   Else
   MCC1 = s & "/" & MPC(Trim(D1), MbC(Trim(s), Trim(D2)))

End If
    Else
    If Len(D2) < 9 Then
     MCC1 = MCC(D1, D2)
     Else
    Dim x, Y ';定义分段长度
    x = Len(D1): Y = Len(D2)

Dim JW, jcc, jss, jcs

  Dim a() As String, b() As String

  ReDim a(1 To x)
  ReDim b(1 To Y)
  For I = 1 To x
  a(I) = Mid(D1, I, 1)
  Next
  For J = 1 To Y
  b(J) = Mid(D2, J, 1)
  Next
  jcc = Val(a(1) & a(2)) \ Val(b(1) & b(2))



  jss = MbC(Trim(jcc), D2)
   For i1 = 1 To Y
    jws = jws & a(i1)
      Next

      Do While MBJC(Trim(jws), Trim(jss)) = -1
      jcc = jcc - 1
      jss = MbC(Trim(jcc), D2)
      Loop
  JW = MPC(Trim(jws), Trim(jss))

    z = x - Y

    Dim c() As String
    ReDim c(1 To z)
    For s = 1 To z
     If MBJC(JW & a(s + Y), D2) = -1 Then
       c(s) = "0"
       Else
     jwc = Val(Left(JW & a(s + Y), 3)) \ Val(Left(D2, 2))
      If Len(jwc) > 1 Then
      c(s) = "9"
       Else
        c(s) = jwc
         End If

     Do While MBJC(JW & a(s + Y), MbC(Val(c(s)), D2)) = -1
    c(s) = Right(10000 + Val(c(s) - 1), 1)
     Loop
     End If

     JW = MPC(JW & a(s + Y), MbC(Val(c(s)), D2))

    jcc = jcc & c(s)
    Next s
    If JW = 0 Then
    MCC1 = jcc
    Else
    MCC1 = jcc & "/" & JW
    End If

  For I = 1 To Len(MCC1)
    If Not Mid(MCC1, I, 1) = "0" Then
        Exit For
    End If
Next
strTmp = Mid(MCC1, I)
  If Len(strTmp) = 0 Then
  MCC1 = "0"
  Else
MCC1 = strTmp
End If



    End If






  End If
End If
End If
End Function



    Public Function MCC(D1 As String, D2 As String) As String ';除数少于8位的除法
If Len(D1) < Len(D2) Then
   MCC = "0" & "/" & D1
   Else
   If Len(D1) < 9 Then
    MCC = Val(D1) \ Val(D2) & "/" & Val(D1) - (Val(D1) \ Val(D2)) * Val(D2)
     If Mid(MCC, InStr(MCC, "/") + 1) = 0 Then
  MCC = Left(MCC, InStr(MCC, "/") - 1)
Else
MCC = MCC
End If

    Else

   Dim x ';fen duan changdu
   x = Len(D1)



     Dim a() As String
      ReDim a(1 To x)  ';定义数组的储存空间
      For I = 1 To x Step 1  ';把被除数各位放在a()中
       a(I) = Mid(D1, I, 1)


       Next I
      Dim b() As String
      JW = 0
     ReDim b(1 To x)
     For J = 1 To x Step 1
    b(J) = Val(JW & a(J)) \ Val(D2)
      JW = Val(JW & a(J)) - Val(b(J)) * Val(D2)
       Next J
       For r = 1 To x
       If JW = 0 Then
          MCC = MCC & b(r)
          Else
          CJ = CJ & b(r)
          MCC = CJ & "/" & JW

    End If

    For I = 1 To Len(MCC)
   If Not Mid(MCC, I, 1) = "0" Then
       Exit For
   End If
Next
strTmp = Mid(MCC, I)
If Len(strTmp) = 0 Then
MCC = "0"
Else
MCC = strTmp
End If

   Next

   End If

     End If

End Function




    Public Function MPC1(D1 As String, D2 As String) As String 'jiafa
  Dim x, Y '两数长度

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): Y = Len(d4)
  Dim a() As Integer, B1() As Integer, C1() As Integer, E1() As Integer
  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 = 0 '进位清0
  B1(J) = Mid$(d4, J, 1) '每位数
For I = x To 1 Step -1  'D1
     a(I) = Mid$(d3, I, 1) '每位数
   C1(I) = a(I) + B1(I) + JW '计算jia
     JW = C1(I) \ 10
     E1(I) = C1(I) Mod 10
    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

  End Function

  Public Function MBJC(D1 As String, D2 As String) As String ';bijiao
  If Len(D1) <= 10 And Len(D2) <= 10 Then
  If Val(D1) > Val(D2) Then
  MBJC = 1
  Else
  If Val(D1) = Val(D2) Then
  MBJC = 0
  Else
  MBJC = -1
  End If
  End If
  Else

  If Len(D1) > Len(D2) Then
  MBJC = 1
  Else
  If Len(D1) < Len(D2) Then
  MBJC = -1
  Else
  If Len(D1) = Len(D2) Then
  Dim x, Y
  x = Len(D1) \ 4: Y = Len(D2) \ 4
  Dim a() As String, b() As String
  ReDim a(4 To 4 * x + 4)
  ReDim b(4 To 4 * Y + 4)
  If Val(Left(D1, Len(D1) - 4 * x)) > Val(Left(D2, Len(D2) - 4 * Y)) Then
     MBJC = 1
     Else
     If Val(Left(D1, Len(D1) - 4 * x)) < Val(Left(D2, Len(D2) - 4 * Y)) Then
     MBJC = -1
     Else
     For I = 4 To 4 * x Step 4
     a(I) = Mid(D1, Len(D1) - I + 1, 4)
     b(I) = Mid(D2, Len(D2) - I + 1, 4)
     Next
     J = 4 * x
     Do While a(J) = b(J) And J >= 8

     J = J - 4
        Loop


      If Val(a(J)) - Val(b(J)) > 0 Then
      MBJC = 1
      Else
      If Val(a(J)) - Val(b(J)) < 0 Then
      MBJC = -1
      Else
      MBJC = 0
      End If

     End If



  End If
  End If
  End If
  End If
  End If
  End If
  End Function

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

第 185 楼

得分:0

秦九韶算法：把一个一元n次多项式改写成秦九韶多项式，求多项式的值时，首先计算最内层括号内一次多项式的值，然后由内向外逐层计算一次多项式的值，这样，求n次多项式f(x)的值就转化为求n个一次多项式的值。上述方法称为秦九韶算法。直到今天，这种算法仍是多项式求值比较先进的算法。

可见老祖宗留下的方法还是好的，珍贵的有用的，在当时是先进的！

反复提取公因子后，原函数可以写成秦九韶多项式，可以用来加快计算速度。

对于一个n次的多项式函数，用常规方法（用重复乘法计算幂，再把各项相加）计算出结果最多需要n次加法和[n*(n+1)]/2次乘法。若用x迭代的方法计算幂则需要n次加法和2n+1次乘法。如果计算中的数值数据是以字节方式储存的，那么常规方法约需要x占用的字节的2n倍空间。

而使用秦九韶算法时，至多只需作n次加法和n次乘法，最多需要x占用的字节的n倍空间。

该算法看似简单，其最大的意义在于将求n次多项式的值转化为求n个一次多项式的值。在人工计算时，利用秦九韶算法和其中的系数表可以大幅简化运算；对于计算机程序算法而言，加法比乘法的计算效率要高很多，因此该算法仍有极大的意义，用于减少CPU运算时间。

该算法看似简单，其最大的意义在于将求n次多项式的值转化为求n个一次多项式的值。在人工计算时，利用秦九韶算法和其中的系数表可以大幅简化运算；对于计算机程序算法而言，加法比乘法的计算效率要高很多，因此该算法仍有极大的意义，对于计算机来说，做一次乘法运算所用的时间比作一次加法运算要长得多，所以此算法极大地缩短了CPU运算时间。

第 186 楼

得分:0

Public Function MPC1(D1 As String, D2 As String) As String 'jiafa
  Dim x, Y, jw '两数长度

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 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

[此贴子已经被作者于2021-4-2 23:44编辑过]

第 187 楼

得分:0

51750801837147361345408953922231823615475578427966187002956389087112242842559611794590895524485015222232340190036677951157401229518412775512617768569186939216558814320044037671525512763073762127357272238470370174050144130962253437215369727381909754581075278888137687950749577751967083233227932391898438489520107788418593104216764745143648165875043861634459264809523254076330115365651752264033578829280651927862062277153553168278640509846511729608378923480331705134467105387853440058108864733429085916392927954109944314725590758950098556991513109760871599045355054258610189920009222629391227784118536578933067532162200768112408111142115021110731900107445187734955403922470144187293970602024056652942406064101184615113779243566842311336047149767396006622923831778833173731302325162741660053390002572456069410383734906953419854919650114722834689335022576764661864630532595250136417800041415827379233503655173380741283758557001102498493237113089198106283487003030225058520047964863929279622015825870972146222540614667928697270131499340362072956956518213266361286372027834000838185920579641835952404678850816456467012890793914108776148483471455515695596694573035435841962871983614397882366460940068418989292218104650923374259244879331938925143014431488635252724366437874702141802712286424754174951797598162531093933772708024046029028652425912112434874797404878317364682580259997737809632860143160557722236459697738869857870982308547756781808568834445404196611833859447257611721058384661943492980180884154939581533269700568975940675513953240040220315659784214936947443784598154082110443748171557676558299300252057475022409541083454882202785077569281268346332901357829843950754331120530978456454396022570647840977328115888711408099894489014427119253061839770890965114853246067272044090282103668762164047374624856119676063310166566519499552342907590495696658359542582469176737197423550084705962160477441546453931948920780829433665262356431973422034925001341330921812806939990688094288773216182971976433480031438271163051341645350474631300965486818841553843112688792803367397276204832936049162335586140151875524537720425345701193713093955432559579831822084761702059241698184717469616732582600658006352069963017377661059372648121969448644394344799369193952197519795756182552461838014896498816263546256621347748100920475049252091842372001283217811864786225692344297842649982716736752004086642881662614773154743879410328420184057019873899911520017723788801*
51750801837147361345408953922231823615475578427966187002956389087112242842559611794590895524485015222232340190036677951157401229518412775512617768569186939216558814320044037671525512763073762127357272238470370174050144130962253437215369727381909754581075278888137687950749577751967083233227932391898438489520107788418593104216764745143648165875043861634459264809523254076330115365651752264033578829280651927862062277153553168278640509846511729608378923480331705134467105387853440058108864733429085916392927954109944314725590758950098556991513109760871599045355054258610189920009222629391227784118536578933067532162200768112408111142115021110731900107445187734955403922470144187293970602024056652942406064101184615113779243566842311336047149767396006622923831778833173731302325162741660053390002572456069410383734906953419854919650114722834689335022576764661864630532595250136417800041415827379233503655173380741283758557001102498493237113089198106283487003030225058520047964863929279622015825870972146222540614667928697270131499340362072956956518213266361286372027834000838185920579641835952404678850816456467012890793914108776148483471455515695596694573035435841962871983614397882366460940068418989292218104650923374259244879331938925143014431488635252724366437874702141802712286424754174951797598162531093933772708024046029028652425912112434874797404878317364682580259997737809632860143160557722236459697738869857870982308547756781808568834445404196611833859447257611721058384661943492980180884154939581533269700568975940675513953240040220315659784214936947443784598154082110443748171557676558299300252057475022409541083454882202785077569281268346332901357829843950754331120530978456454396022570647840977328115888711408099894489014427119253061839770890965114853246067272044090282103668762164047374624856119676063310166566519499552342907590495696658359542582469176737197423550084705962160477441546453931948920780829433665262356431973422034925001341330921812806939990688094288773216182971976433480031438271163051341645350474631300965486818841553843112688792803367397276204832936049162335586140151875524537720425345701193713093955432559579831822084761702059241698184717469616732582600658006352069963017377661059372648121969448644394344799369193952197519795756182552461838014896498816263546256621347748100920475049252091842372001283217811864786225692344297842649982716736752004086642881662614773154743879410328420184057019873899911520017723788801=
2678145490787694710138406683675886762424440548647327525594133873038347266950777818028529804877891353347244255046176220880989519574806598935727647635506939520211209794328712328126947740602255036264392628020291100698432900022333877728824270241063030019536831205264726059774673235680796770108334187808344470141093691232926021244583649747591446066921535333854157441330339217364515328375889937313870826987520723914810358707312468857074455945610038118763873992681688857200178452843740327143990247797893489008808544535536081089994800692174759199578596435124153437689121057209523619989593900355037400039597165241729693472001589594642879166693443994939359639600558001937547209387175085119128575833396037478944824322315197771750730768383267287661855880237549141571520374996029107650341071074081501632143441365461865431362023790463469688071768208320226561675630348708531708110373889241713511809029065048200924851629507265095151843687852114948736130517024578482059771284515915597919026074110811882700307150650858080695566672584075215926450360584738705106755945308199980660478183563586945902705730231409948938478910176292179410952310592864745025373902249844607078729230098512959498522851990040833671698873183076996740726479481352429756295966452788332789259316653805673821716832204368483794501474641036177256005810416507649770210480747056764697918800240201155395628561684853684747063434500664449114760179367086926249813006056735202795763742271472136500817313178050955623517148960973128433455798444839070215800699075256371341531892841721456473301085595261371522078416420399702683504171019191363372883472415693921509069484448792009627325245658854979159002549542769741504596589556474585723101403486046952706847309188488390899096649210853675228464611999630360164703837131620319658277117300208326944026347808645954842782309633205645471959842390075986572806483755223497552549948718545978420793425036666212191832327909389117021539426917904222971515424022606157676379417252939026404363841301595348953340657745965591468370831371449860774296757556463049237248472613472436666799615694672489600751763956185893123579218797539971253828850163437053164723845196089466298000486042246621634263064752906475198879616484926366053597071510886820878425907736453843197228282179943365206039514850477377542684361730162273246709577442085159313947668552462343596819299335060863266863059421286080919061657175757802930378698062290163092494909661982639303946271889619023417245433500782685534406291391527022657608608130680134939380126048353657648559735671562230714451258764762350451448379438849319710473631625533527602085050858633346936315115309333355986556546113134787213610042970405680162084678021281774169131725296977361816657904233850711837826724976507876061043779177845550646612327663283839673950405472039432309339110648301347672597370034346896334064135099613033528785924976781865447506814375627647103020761819104412269362847848884053177378762432543285984193091289854949394023586451139393716370633759317698908834326333339634557238526607966375935960004339535161203546369910853171524516945554862019134684985868547068709986010719120259421723270478586992153989283736650948010894951434857207445141886625290777550599700738909777829412358941157674866550887608199469723859806486384262574182811908513849905040209776132986875560077482527819093584150609347560543627976011009349905362597935257895287412087233810106693141683912683308201407373637490835862452911394718399632093441745957478079754723679119343225931665785380948807114301164623717144211285944154289093317610519159281033583963015810556464180819928345256832572962092994993950655913067768151113345566231088759030148164710287289335782462899525700500822021472132532771242198844498579102733028256523810973405350508253183399668290339844052874956694050028526577775764032598023622192221226501334606994447870277619118208162133562541678250491647671042612088902952091163094215645902682086024337098910110924115381788866213335441814530141911754446270296630426675020592640816713810936850961517475097707179713115856513919631998747192606018612535436009162735908155778165736923393260822217415131632296810207091918499370220533980666393617256227781299273913099896641458499949922475383775878771011361417556799406151773618626138749998464514570482965286184387350245762317271666329142667987131139265167425606863654107927682419958167046956962340419295394058625063862272314570914511355913547470055072878835349142049813368019960713974852351833144227544851625677753419141348585495260230041111323576432417502998832485027071744397105338790364666312325483218209150368759120749671419554589928540715813531144241705501211397506662448276056294585639532800634727428900861538486753011006379264618338782036690340859441153926551954112364946638768223012718907190897165613382555036872673785444132692292217184974818914501886689736449912131900762592363447945036085692999163815947845753538999001633767986447907729462453017601有4888位，用时1.316406秒（这个是前面的4位一组的快速乘法程序的结果，这个速度已经可以用来搜索和判断几千位的大素数了，但距离世界纪录还远着呢，继续优化吧，继续努力！）

第 188 楼

得分:0

还可以用迭代法快速计算，发个截图，如何算的？希望老师指点，谢谢！

图片附件: 游客没有浏览图片的权限，请登录或注册

第 189 楼

得分:0

这个迭代法会用到复数域，会用到如下公式：
sinx=(e^ix-e^-ix)/(2i),cosx=(e^ix+e^-ix)/2.\叫做欧拉公式.将e^ix=cosx+isinx中的x取作π就得到:e^iπ+1=0.这个也叫做欧拉公式.
复数除法定义：满足(c+di)(x+yi)=(a+bi)的复数x+yi(x,y∈R)叫复数a+bi除以复数c+di的商。

运算方法：可以把除法换算成乘法做，在分子分母同时乘上分母的共轭.。所谓共轭你可以理解为加减号的变换，互为共轭的两个复数相乘是个实常数。

复数除法：(a+bi)/(c+di)=((a+bi)/(c+di))*((c-di)/(c-di))=((ac+bd)/(c^2+d^2))+((bc-ad)/(c^2+d^2))i

棣莫佛定理：对于复数z=r(cosθ+isinθ），有z的n次幂为：z^n=r^n*(cosnθ+isinnθ).

这个迭代法会用到这么多公式，每次迭代都会用到多种公式，都是大数运算，即使迭代次数很少，速度也不会太快，消耗时间长，这个怕是不快。

第 190 楼

得分:0

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的时候，此程序居然比快速傅里叶变换的乘法还快！