|
|
|
作了大数开平方程序,只可算22位,有大数的加减乘除和比较大小的程序(大于为1,小于输出-1,等于为0),
天山草老师的除法被当作只要调用程序,对我帮助太大了,对老师的帮助表示衷心感谢!
调用程序名字为:MPC1为加法,MPC()减法,MbC()乘法,MPCC()除法,MBJC()为比较大小,
Private Sub Command1_Click()
D1 = Text1.Text
D2 = Text2.Text
Text3.Text = MBBC(Text1.Text)
End Sub
Public Function MBBC(D1 As String) As String ';kai pingfang
Dim X ';shuju changdu
X = Len(D1) \ 4
D2 = String(4 - Len(D1) + 4 * X, "0") & D1
Dim A() As String
ReDim A(4 To 4 * X + 4)
Dim B() As String
ReDim B(2 To 2 * X)
Dim I, j, js, JW
For I = 4 To 4 * X + 4 Step 4
A(I) = Mid(D2, I - 3, 4)
js = Int(Sqr(Val(A(4))))
JW = Val(A(4)) - (js) ^ 2
For j = 2 To 2 * X Step 2
B(j) = 0
Do While Val(JW & A(2 * j + 4)) - Val(B(j)) * (200 * Val(js) + Val(B(j))) > 2 * Val(js * 100 + B(j))
B(j) = B(j) + 1
Loop
JW = Val(JW & A(2 * j + 4)) - (200 * js + B(j)) * B(j)
js = js * 100 + B(j)
MBBC = Left(js * 100 + B(j), Len(js * 100 + B(j)) - 2)
Next
Next
End Function
Public Function MPCC(aa1 As String, bb1 As String) As String
Open "相除结果111.txt" For Output As #1
Dim a1(100000) As Long ';……………… 被除数的各位数字
Dim ay(100000) As Long ';……………… 余数的各位数字（最后一次试商要修正时）
Dim ayy(100000) As Long ';………………余数的各位数字（最后一次试商不必修正时）
Dim b1(100000) As Long ';……………… 除数的各位数字
Dim c1(100000) As Long ';……………… 近似商与除数相乘后的各位数字
Dim d(10) As Long
Dim pp As String ';商的每一位
Dim ppp As String ';作为商的输出字符串
Dim s1(1000) As Long ';……………… 商的各位数字
Dim js As Long '; js 是商的位数加一
Dim ta, tb, j, e As Long
Dim fa As Long ';………………………… 被除数的位数
Dim fb As Long ';………………………… 除数的位数
aa1 = aa1
bb1 = bb1
GoSub sub1
999: Close
Exit Function
sub1:
Z = 8 ';100 ';需要计算的小数位数
Print: Print #1,
Print "aa1 = "; aa1: Print #1, "aa1 = "; aa1
Print "bb1 = "; bb1: Print #1, "bb1 = "; bb1
Print "ppp = ";: Print #1, "ppp = ";
pp = "": ppp = "": mv = 0
If Len(bb1) <= 2 Then aa1 = aa1 + "00": bb1 = bb1 + "00" ';除数小于 3 位时
mv = 0
If Val(aa1) < Val(bb1) And Val(aa1) <> 0 Then ';除数大于被除数时
ppp = "0."
Z = Z - 1
aa1 = aa1 + "0"
mv = 1
End If
If mv = 0 Then
GoTo 2
Else
1: If (Len(aa1) = Len(bb1) And aa1 < bb1) Or Len(Trim$(aa1)) < Len(Trim$(bb1)) Then ';被除数小于除数时
ppp = ppp + "0"
aa1 = aa1 + "0"
Z = Z - 1
GoTo 1
Else
GoSub sub3
If Val(sy$) * Val(aa1) = 0 Then GoTo 4 ';余数或被除数为零停止计算
GoTo 3
End If
End If
2:
GoSub sub3
If Val(sy$) * Val(aa1) = 0 Then GoTo 4 ';余数或被除数为零停止计算
ppp = ppp + "." ';以下计算小数部分
3: For iv = 1 To Z '; Z 是事先设定的小数位数
If Val(sy$) * Val(aa1) = 0 Then GoTo 4 ';余数或被除数为零停止计算
aa1 = sy$ + "0"
GoSub sub3
Next iv
4: Print ppp: Print #1, ppp
MPCC = ppp
Return
sub3: ';大数相除
ccc = 0
vvv = 0 ';试余数不大于除数时的标志
If (Len(aa1) = Len(bb1) And aa1 = bb1) Then pp = "1": sy$ = "0": GoTo 50
If (Len(aa1) = Len(bb1) And aa1 < bb1) Or Len(Trim$(aa1)) < Len(Trim$(bb1)) Then ';被除数小于除数时
pp = "0"
sy$ = aa1
GoTo 50
End If
mv = 0 ';如果除数位数小于 3 位，则分子分母同放大 100 倍：
If Len(bb1) <= 2 Then aa1 = aa1 + "00": bb1 = bb1 + "00": mv = 1
fa = Len(aa1) ';把被除数的各位数码放在数组 a1(i)中
For I = 1 To fa ';a1(1)为最低位，a1(fa)为最高位
a1(I) = Mid(aa1, fa - I + 1, 1)
Next I
fb = Len(bb1) ';把除数的各位数码放在数组 b1(i)中
For I = 1 To fb ';b1(1)为最低位，b1(fb)为最高位
b1(I) = Mid(bb1, fb - I + 1, 1)
Next I
';以下取除数的近似数
e = b1(fb) * 1000 + (b1(fb - 1)) * 100 + b1(fb - 2) * 10 + b1(fb - 3) + 1
ta = fa: js = 0
For j = fa - fb + 1 To 1 Step -1 ';………… 做除法求商，求余数
js = js + 1
f = a1(ta) * 1000 + a1(ta - 1) * 100 + a1(ta - 2) * 10 + a1(ta - 3)
';取被除数的近似数
s1(js) = Int(f / e) ';…………………………………… 试商
For I = 1 To fb ';…………………………………… 求试商的积
c1(I) = b1(I) * s1(js) ';…… 近似商与除数相乘后的各位数字
Next I
d(0) = 0
For I = 1 To fb - 1 ';…………………………………… 满 10 进位
d(1) = Int((c1(I) + d(0)) / 10): c1(I) = c1(I) + d(0) - d(1) * 10
d(0) = d(1)
Next I
c1(fb) = c1(fb) + d(0)
qq$ = ""
For I = fb To 1 Step -1 ';……………… 求试商的精确积
qq$ = qq$ & c1(I) ';…… 试商与除数相乘后的精确积
Next I
For I = fb To 1 Step -1
a1(ta - fb + I) = a1(ta - fb + I) - c1(I)
Next I
For I = 1 To fb
If a1(ta - fb + I) < 0 Then
a1(ta - fb + I) = a1(ta - fb + I) + 10
a1(ta - fb + I + 1) = a1(ta - fb + I + 1) - 1
End If
Next I
a1(ta - 1) = a1(ta - 1) + a1(ta) * 10
ta = ta - 1
Next j ';至此，已初步算出最后的试商
a1(fb - 1) = a1(fb - 1) Mod (10)
For I = fb To 1 Step -1
ayy(I) = a1(I) ';试余数的各位数码
Next
ssy$ = "" ';以下做出试余数的字符串 ssy$
For I = fb To 1 Step -1
ssy$ = ssy$ & ayy(I)
11: Next I
If (Len(ssy$) = Len(bb1) And ssy$ > bb1) Or Len(Trim$(ssy$)) > Len(Trim$(bb1)) Then
vvv = 1 ';试余数大于除数时的标志
For I = 1 To fb ';试余数减去除数，得到正确余数 sy$
ay(I) = ayy(I) - b1(I)
If ay(I) < 0 Then
ay(I) = ay(I) + 10
ayy(I + 1) = ayy(I + 1) - 1
End If
Next I
sy$ = "" ';把 ay(i) 组装成 sy$
For I = 1 To fb
sy$ = Trim$(Str$(ay(I))) & sy$
Next I
71: If Mid$(sy$, 1, 1) = " " Or Mid$(sy$, 1, 1) = "0" Then sy$ = Mid$(sy$, 2) Else GoTo 72
GoTo 71 ';去掉结果中的多余 0
End If
72:
For I = 1 To fb - 1
c1(1) = a1(I) - b1(I)
ay(I) = c1(1) ';最后一次试商要修正时，这就是余数各位数（除最高位）
If c1(1) < 0 Then
ccc = -1
c1(1) = c1(1) + 10: a1(I + 1) = a1(I + 1) - 1
End If
Next I
c1(1) = a1(fb) - b1(fb)
ay(fb) = c1(1) ';最后一次试商要修正时，这就是余数的最高位
If c1(1) >= 0 Then '; c(1) 不是负数时最后一次试商要修正
s1(js) = s1(js) + 1 '; 所谓修正就是加一
End If
For I = js To 1 Step -1
If s1(I) >= 10 Then ';由于修正，商的某一位有大于10者，要调整进位
s1(I) = s1(I) - 10: s1(I - 1) = s1(I - 1) + 1
End If
Next I
If js = 1 Then ';以下做出商的字符串 pp
pp = s1(js)
End If
If js >= 2 Then
pp = 10 * s1(1) + s1(2)
End If
For I = 3 To js
pp = pp & s1(I)
Next I
If vvv = 1 Then GoTo 50 ';试余数大于除数
10: sy$ = "" ';以下做出余数的字符串 sy$
If ccc = -1 Then ';最后一次试商不必修正时的余数
For I = fb To 1 Step -1
If ayy(I) <> 0 Then yyy = 1
If ayy(I) = 0 And yyy = 0 Then GoTo 20
sy$ = sy$ & ayy(I)
20: Next I
End If
If ccc = 0 Then ';最后一次试商须修正时的余数
For I = fb To 1 Step -1
If ay(I) <> 0 Then yyy = 1
If ay(I) = 0 And yyy = 0 Then GoTo 30
sy$ = sy$ & ay(I)
30: Next
End If
If Mid(sy$, 1, 1) = "-" Then ccc = -1: GoTo 10 ';余数为负，重做余数
40: If Mid(sy$, 1, 1) = "0" Then sy$ = Mid(sy$, 2) ';去掉余数前面的多余零
If Mid(sy$, 1, 1) = "0" Then GoTo 40
50: If sy$ = "" Then sy$ = "0"
If mv = 1 And sy$ <> "0" Then sy$ = Mid(sy$, 1, Len(sy$) - 2)
If mv = 1 And sy$ = "0" Then sy$ = "0"
ppp = ppp + pp ';包括整数及小数的商
90: Return
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)
Next
End Function
Private Sub Command2_Click()
Text1.Text = ""
Text2.Text = ""
Text3.Text = ""
End Sub
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) 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)
ReDim B(4 To 4 * y)
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)
If Val(A(I)) - Val(B(I)) > 0 Then
MBJC = 1
Else
If Val(A(I)) - Val(B(I)) < 0 Then
MBJC = -1
Else
MBJC = 0
End If
End If
Next
End If
End If
End If
End If
End If
End Function
验证：
输入：3535000647287053716310161223639238642910682574781777736223167，
程序：溢出，
计算器输出：5945587142820340.2595447699599928，
输入：123456789，
程序：11111，
计算器输出：11111.111060555555440541666143353，
输入：6958000001674999998647，
程序：83414627024，
计算器输出：83414627024.731100206414473822321，
输入：123456789123456789123456789，
程序：1.11111110661111E+，
计算器输出：11111111066111.110974986110509249， |
|
IP卡
狗仔卡
发表于 2012-5-27 11:51
提升卡
置顶卡
沉默卡
喧嚣卡
变色卡
显身卡
楼主