|
对3楼的算术开方算法,进行了改良,
即,不是每次增加1位小数的计算,而是每一次增加尽可能多的小数位数。
考虑到代码的复杂度不大幅增加的情况下,较为可靠的是每次计算8位小数。
因为一开始的计算误差会比较大,所以不能一下子取太多位数。
只能2位2位计算几次,然后开始大幅度进行计算。
这样可以比原先的速度要快40-60倍了。
如果计算小数点后几千乃至几万位,也可以了。
代码如下:
- Option Explicit
- Sub test2() 'by kagawa 2017/12/17
- Dim d&, i&, j&, n&, r&, s$, s2$, t#, p&, tms#
- tms = Timer
- ' s = "1.41421356237309504880168872420969807856967187537694807317667973799073247846210703885038753432764157"
-
- p = 1000 '取小数点后1千位
- For n = 2 To 200 '计算2到200
- t = Sqr(n)
- If t <> Int(t) Then '非完全平方数时
-
- s = LongSqr2(n, p) '按指定小数位开方
-
- DoEvents
-
- s2 = LongMult(s, s) '大数相乘验算
- j = InStr(s2, ".") '小数点位置
- For i = j + 1 To Len(s2)
- If Mid(s2, i, 1) <> 9 Then Exit For '验证实际有效小数位
- Next
- ' Debug.Print n; p; i - j
- End If
- Next
- Debug.Print Format(Timer - tms, " 0.000s")
- End Sub
- Function LongSqr2(ByVal n&, ByVal p&)
- '对于任意正整数n、 返回其小数长度p的平方根 计算单位d
- Dim a$, b$, b1, d2&, i&, j&, j1&, j2&, t&, t1$, t2$, tms#
- ' tms = Timer
-
- d = 8: d2 = d * 2 '每次增量计算8位
-
- b1 = Int(Sqr(n) * 10 ^ 5) '利用自带函数开方取开方值整数部分
-
- a = (n * 10 ^ 10 - b1 * b1) * 5 & String(4, "0") '第一次计算直接扣除开方整数部分 然后扩大5倍好算
- b = b1 & String(2 + 1, "0") 'b*10 扩大10倍相当于2*b*5 可以简化计算
- j1 = Len(a): j2 = Len(b)
- For i = -2 To Int(p / d) '循环直至小数位足够
- If j2 > 18 Then j = 18 Else j = j2 '取有效位数计算'
- t = Int(Val(Left(a, j1 - j2 + j)) / Val(Left(b, j))) '取当前有效个位商t
- If t Then ' b'=b*10^d*10
- t1 = LargeSum(b, t * 5) '=(b'+t*5)=(b*10^d*10+t*5)
- t2 = LargeMult(t1, t) '=(b'+t*5)*t=(b*10^d*10+t*5)*t =(2*b*10^d*t+t*t)*5
- a = LongMinus(a, t2) 'a'=(N-b^2)*5*10^d2-[b^2*5*10^d2+(b*10^d*10+t*5)*t]
- b = LargeSum(b, t & "0") '=b'+t*10=b*10^d*10+t*10=b"*10
- End If
- a = a & String(IIf(i < 0, 4, d2), "0"): j1 = Len(a)
- b = b & String(IIf(i < 0, 2, d), "0"): j2 = Len(b)
- Next
-
- ' Debug.Print Format(Timer - tms, "0.000s"); n; p; d
- b1 = Int(Sqr(n))
- LongSqr2 = b1 & "." & Mid(b, Len(b1) + 1, p) '按指定小数位输出结果
- End Function
- Function LargeSum$(ByVal a$, ByVal b$) '大数a+小数b(<16位)
- Dim i&, t$, t1$, t2$
- If Len(a) <= Len(b) Then
- LargeSum = Val(a) + Val(b)
- Else
- t1 = Left(a, Len(a) - Len(b)) '截取a前面超出b的部分不用计算
- t2 = CDec(Right(a, Len(b))) + CDec(b) '仅计算尾部对齐b的部分
- If Len(t2) > Len(b) Then '如果有进位
- t = Left(t2, 1) '截取进位数字t
- For i = Len(t1) To 1 Step -1 '倒序检查拼接
- If Mid(t1, i, 1) + t > 9 Then '超9时需进位
- Mid(t1, i, 1) = 0: t = 1 '本位归零、进位=1
- Else '不超9时直接相加然后退出
- Mid(t1, i, 1) = Mid(t1, i, 1) + t: Exit For
- End If
- Next
- If i = 0 Then t1 = 1 & t1 '检查至头部仍需进位时前面+1
- End If
- LargeSum = t1 & t2
- End If
- End Function
- Function LongMinus$(ByVal a$, ByVal b$) '大数a-大数b
- Dim i&, n0&, n1&, r$, s$, t, t0
-
- n1 = Len(a): n0 = Len(b)
- If n1 < 29 Then LongMinus = CDec(a) - CDec(b): Exit Function
- r = String(28, "0"): t0 = CDec(1 & r)
- t = 0
- For i = 1 To (n0 - 1) \ 28
- t = t0 + t + CDec(Mid(a, n1 - i * 28 + 1, 28)) - CDec(Mid(b, n0 - i * 28 + 1, 28))
- s = Right(r & t, 28) & s: If Len(t) > 28 Then t = 0 Else t = -1
- Next
-
- t = t - CDec(Left(b, n0 - i * 28 + 28))
- For i = i To (n1 - 1) \ 28
- t = t0 + t + CDec(Mid(a, n1 - i * 28 + 1, 28))
- If Len(t) > 28 Then
- LongMinus = Left(a, n1 - i * 28) & Right(t, 28) & s: Exit Function
- Else
- s = Right(r & t, 28) & s: t = -1
- End If
- Next
- s = (CDec(Left(a, n1 - i * 28 + 28)) + t) & s
- For i = 1 To Len(s) - 1
- If Mid(s, i, 1) > 0 Then Exit For
- Next
- LongMinus = Mid(s, i)
- End Function
- Function LargeMult$(ByVal a$, ByVal b&) '计算任意多位数的a 乘以小数字b(<16位)
- Dim i&, l&, m&, n&, s$, s0$, t$
- l = 28 - Len("" & b)
- s0 = String(28, "0")
- n = Len(a): m = Int((n - 1) / l)
- For i = 1 To m
- t = Right(s0 & CDec(Mid(a, n - l * i + 1, l)) * b + Val(t), 28)
- s = Right(t, l) & s
- t = Left(t, 28 - l)
- Next
- LargeMult = (CDec(Left(a, n - l * m)) * b + Val(t)) & s
- End Function
- Function LongMult$(ByVal x$, ByVal y$) '长数位整数的相乘计算,返回长数位乘积
- '在本附件中用作中间计算,以及可用于工作表自定义函数来验证平方计算结果
- Dim i&, j&, l&, la&, lb&, n&, p&, s$
-
- If InStr(x, ".") Then p = Len(x) - InStr(x, "."): x = Replace(x, ".", "")
- If InStr(y, ".") Then p = p + Len(y) - InStr(y, "."): y = Replace(y, ".", "")
-
- n = 12 'CDec +/-79,228,162,514,264,337,593,543,950,335
-
- la = (Len(x) - 1) \ n
- ReDim a(la)
- For i = 1 To la
- a(i - 1) = CDec(Mid(x, Len(y) - n * i + 1, n))
- Next
- a(la) = CDec(Mid(x, 1, Len(x) - n * la))
-
- lb = (Len(y) - 1) \ n
- ReDim b(lb)
- For i = 1 To lb
- b(i - 1) = CDec(Mid(y, Len(y) - n * i + 1, n))
- Next
- b(lb) = CDec(Mid(y, 1, Len(y) - n * lb))
-
- ReDim c(la + lb)
- For i = 0 To la
- For j = 0 To lb
- c(la - i + lb - j) = c(la - i + lb - j) + a(i) * b(j)
- Next
- Next
-
- For i = la + lb To 1 Step -1
- If Len(c(i)) > n Then
- If i = 1 Then
- c(0) = c(0) + Left(c(i), Len(c(i)) - n)
- If Len(c(0)) > n Then c(0) = Left(c(0), Len(c(0)) - n) & Right(c(0), n)
- Else
- c(i - 1) = Format(c(i - 1) + Left(c(i), Len(c(i)) - n), String(n, "0"))
- End If
- c(i) = Right(c(i), n)
- ElseIf Len(c(i)) < n Then
- c(i) = Format(c(i), String(n, "0"))
- End If
- Next
-
- s = Join(c, "")
-
- If p Then '有小数位时
- If Len(s) > p Then '小数位在中间
- s = Left(s, Len(s) - p) & "." & Right(s, p)
- Else 'len(s)<p为首位0的含0纯小数
- s = "0." & String(p - Len(s), "0") & s
- End If
- l = Len(s)
- For i = 0 To p - 1
- If Mid(s, l - i, 1) > 0 Then Exit For '检查多余的0
- Next
- If i = p Then s = Left(s, l - i - 1) Else s = Left(s, l - i)
- End If
-
- LongMult = s
- End Function
复制代码
|
|