应《网络安全法》要求，自2017年10月1日起，未进行实名认证将不得使用互联网跟帖服务。为保障您的帐号能够正常使用，请尽快对帐号进行手机号验证，感谢您的理解与支持！

24小时热门版块排行榜    

小木虫论坛-学术科研互动平台 » 计算模拟区 » 程序语言 » Windows编程 » 【求助】求助：vb编程中用牛顿迭代解三次方程为什么只得到一个根？【已完成】
161/2返回列表12下一页
查看: 2802  |  回复: 15
只看楼主 @他人 存档 新回复提醒 (忽略) 收藏    在APP中查看
本帖产生 2 个 程序强帖 ，点击这里进行查看

liangzidou

银虫 (小有名气)

[交流] 【求助】求助：vb编程中用牛顿迭代解三次方程为什么只得到一个根？【已完成】 已有5人参与

我在用vb编写中，遇到这样一个问题，解一个一元三次方程只得到一个根，实际上不只一个根。请各位高手帮忙找一下错误。
Private Sub Command1_Click()
Dim r, p, t, w, pc, tc, m, a, b, ca, cb, xl, xm, xn As Double
r = 8.314
p = 101.325
t = 301
pc = 3384
tc = 460.4
w = 0.227
m = 0.37464 + 1.5422 * w + 0.2699 * w ^ 2
tr = t / tc
a = 0.45723553 * r ^ 2 * tc ^ 2 * (1 + m * (1 - Sqr(tr))) ^ 2 / pc
b = 0.077796074 * r * tc / pc
Print "a="; a, "b="; b
ca = a * p / (r ^ 2 * t ^ 2)
cb = b * p / (r * t)
xl = cb - 1
xm = -3 * cb ^ 2 - 2 * cb + ca
xn = cb ^ 3 + cb ^ 2 - ca * cb
Print "A="; ca, "B="; cb
Print "xl="; xl, "xm="; xm
Print "xn="; xn
Dim f, z As Single
z = 0.01
Do
z = z1
f = z ^ 3 + xl * z ^ 2 + xm * z + xn
f1 = 3 * z ^ 2 + 2 * xl * z + xm
z1 = z - f / f1
Loop While Abs(z - z1) >= 0.0005
Print z1
End Sub

[ Last edited by liangzidou on 2010-5-15 at 22:22 ]
回复此楼

» 猜你喜欢

» 本主题相关价值贴推荐，对您同样有帮助:
1楼 2010-04-19 22:21:04
已阅   回复此楼   关注TA 给TA发消息 送TA红花 TA的回帖

liangzidou

银虫 (小有名气)
jjdg:把方程具体的值给出来 2010-04-20 12:52
方程就是f = z ^ 3 + xl * z ^ 2 + xm * z + xn=0
其中xl,xm,xn分别是方程的二次项、一次项系数及常数项。
下面这段程序就是我用迭代法就该方程的程序：

Dim f, z As Single
z = 0.01
Do
z = z1
f = z ^ 3 + xl * z ^ 2 + xm * z + xn
f1 = 3 * z ^ 2 + 2 * xl * z + xm
z1 = z - f / f1
Loop While Abs(z - z1) >= 0.0005
Print z1


最后得到的结果只有一个根。
赞一下(1人) 回复此楼
2楼2010-04-20 10:05:18
已阅   回复此楼   关注TA 给TA发消息 送TA红花 TA的回帖

jjdg

版主 (知名作家)

优秀版主
★ ★
liangzidou(金币+2):谢谢了，我这个只能用vb程序解，因为下面的程序还要用到。 2010-04-20 12:37
wangen994(金币+2):辛苦了，jjdg 2010-04-20 14:13
不是还有其他解法吗？
我查到的其他解法是先判断delta与0的关系
①：当A=B=0时，方程有一个三重实根；
②：当Δ=B^2－4AC>0时，方程有一个实根和一对共轭虚根；
③：当Δ=B^2－4AC=0时，方程有三个实根，其中有一个两重根；
④：当Δ=B^2－4AC<0时，方程有三个不相等的实根。
赞一下(1人) 回复此楼
努力学习！以正当途径！获得需要的知识！
3楼2010-04-20 12:29:43
已阅   回复此楼   关注TA 给TA发消息 送TA红花 TA的回帖

jjdg

版主 (知名作家)

优秀版主
我用盛金公式 写的
Private Sub Command1_Click()
Dim a, b, c, d, aa, bb, cc, delta, y1, y2, k, theta, t, x, x1, x2, x3, tt, tt1, xx2, xx3,s
'az^3+bz^2+cz+d=0，a、b、c、d来自一个例子（见最后）

a = 1
b = -70.5
c = 1533.54
d = -10082.44
aa = Round((b ^ 2 - 3 * a * c), 4)
bb = Round((b * c - 9 * a * d), 4)
cc = Round((c * c - 3 * b * d), 4)
delta = Round((bb * bb - 4 * aa * cc), 4)
If (aa = 0) And (bb = 0) Then
    x = -b / (3 * a)
    Label1.Caption = "X1=X2=X3=:" & x
Else
    Select Case delta
    Case Is > 0
        y1 = aa * b + 3 * a * (-bb + Sqr(delta)) / 2
        If y1 > 0 Then
            y1 = y1 ^ (1 / 3)
        Else
            y1 = y1 * (-1)
            y1 = y1 ^ (1 / 3) * (-1)
        End If
        y2 = aa * b + 3 * a * (-bb - Sqr(delta)) / 2
        If y2 > 0 Then
            y2 = y2 ^ (1 / 3)
        Else
            y2 = y2 * (-1)
            y2 = y2 ^ (1 / 3) * (-1)
        End If
        tt = y1 + y2
        tt1 = 3 ^ (1 / 3) * (y1 - y2) / (6 * a)
        s = (-2 * b + tt) / (6 * a)
        x1 = (-b - tt) / (3 * a)
        x2 = s & "+" & tt1 & "i"
        x3 = s & "-" & tt1 & "i"
        Label1.Caption = "X1=" & x1
        Label2.Caption = "X2=" & x2
        Label3.Caption = "X3=" & x3
    Case Is = 0
        k = bb / aa
        x1 = -b / a + k
        x = Str(-k / 2)
        Label1.Caption = "X1=" & x1
        Label2.Caption = "X2=" & x
        Label3.Caption = "X3=" & x
    Case Is < 0
        t = (2 * aa * b - 3 * a * bb) / (2 * aa ^ (3 / 2))
        theta = Atn(-t / Sqr(-t * t + 1)) + 2 * Atn(1)
        theta = theta / 3
        tt = aa ^ (1 / 2) * Cos(theta)
        tt1 = 3 ^ (1 / 2) * Sin(theta)
        x1 = (-b - 2 * tt) / (3 * a)
        xx2 = (-b + tt + tt1) / (3 * a)
        xx3 = (-b + tt - tt1) / (3 * a)
        Label1.Caption = "X1=" & x1
        Label2.Caption = "X2=" & xx2
        Label3.Caption = "X3=" & xx3        
    End Select
End If
End Sub

一建筑物的楼顶要建一个储水池，按施工的设计要求，这个储水池的长、宽、高之和为67.4dm，且宽=高，满储水量为9539.712(dm)＾3，立体对角线为1706.92dm，问：如何施工才能达到设计要求？
解：设取长、宽、高分别为X⑴、X⑵、X⑶，依题意：
X⑴＋X⑵＋X⑶=67.4；
X⑴X⑵X⑶=9539.712；
X⑴^2＋X⑵^2＋X⑶^2=1706.92。
解这个方程组，得一元三次方程
X＾3－67.4X＾2＋1417.92X－9539.712=0
a=1，b=－67.4，c=1417.92，d=－9539.712。
A=289；B=－9710.4；C=81567.36，
Δ=0。
根据盛金判别法，此方程有三个实根，其中两个相等。
应用盛金公式③求解。
K=—33.6。
把有关值代入盛金公式③，得：
X⑴=33.8(dm)；X⑵=X⑶=16.8(dm)。
经检验，结果正确。
因为宽=高，
所以，应取长为33.8dm；宽=高=16.8dm来进行施工。

[ Last edited by jjdg on 2010-4-20 at 14:20 ]
赞一下 回复此楼
努力学习！以正当途径！获得需要的知识！
4楼2010-04-20 14:18:56
已阅   回复此楼   关注TA 给TA发消息 送TA红花 TA的回帖

jjdg

版主 (知名作家)

优秀版主
★ ★ ★ ★ ★ ★ ★ ★ ★ ★ ★ ★ ★ ★ ★
wangen994(金币+5):辛苦了 2010-04-20 17:38
liangzidou(金币+28):我之前没学过编程语言，现在学习热力学用到这些知识了，很是抓狂，多谢大侠帮忙，我试了试大侠给编的程序，解立方型方程很好用。太感谢了，辛苦了，呵呵。 2010-04-20 23:10
wangen994(金币+10, 程序强帖+1):辛苦了，呵呵 2010-04-21 08:30
或者：
Private Sub Command1_Click()
Dim a, b, c, d, aa, bb, cc, delta, y1, y2, k, theta, t, x, x1, x2, x3, tt, tt1, xx2, xx3
'az^3+bz^2+cz+d=0
a = Val(Text1.Text)
b = Val(Text2.Text)
c = Val(Text3.Text)
d = Val(Text4.Text)

aa = Round((b ^ 2 - 3 * a * c), 4)
bb = Round((b * c - 9 * a * d), 4)
cc = Round((c * c - 3 * b * d), 4)

delta = Round((bb * bb - 4 * aa * cc), 4)

If (aa = 0) And (bb = 0) Then
    x = -b / (3 * a)
    Label1.Caption = "X1=X2=X3=:" & x
Else
    Select Case delta
    Case Is > 0
        y1 = aa * b + 3 * a * (-bb + Sqr(delta)) / 2
        If y1 > 0 Then
            y1 = y1 ^ (1 / 3)
        Else
            y1 = y1 * (-1)
            y1 = y1 ^ (1 / 3) * (-1)
        End If
        y2 = aa * b + 3 * a * (-bb - Sqr(delta)) / 2
        If y2 > 0 Then
            y2 = y2 ^ (1 / 3)
        Else
            y2 = y2 * (-1)
            y2 = y2 ^ (1 / 3) * (-1)
        End If
        tt = y1 + y2
        tt1 = 3 ^ (1 / 3) * (y1 - y2) / (6 * a)
        s = (-2 * b + tt) / (6 * a)
        x1 = (-b - tt) / (3 * a)
        x2 = s & "+" & tt1 & "i"
        x3 = s & "-" & tt1 & "i"
        Label1.Caption = "X1=" & x1
        Label2.Caption = "X2=" & x2
        Label3.Caption = "X3=" & x3
    Case Is = 0
        k = bb / aa
        x1 = -b / a + k
        x = Str(-k / 2)
        Label1.Caption = "X1=" & x1
        Label2.Caption = "X2=" & x
        Label3.Caption = "X3=" & x
    Case Is < 0
        t = (2 * aa * b - 3 * a * bb) / (2 * aa ^ (3 / 2))
        theta = Atn(-t / Sqr(-t * t + 1)) + 2 * Atn(1)
        theta = theta / 3
        tt = aa ^ (1 / 2) * Cos(theta)
        tt1 = 3 ^ (1 / 2) * Sin(theta)
        x1 = (-b - 2 * tt) / (3 * a)
        xx2 = (-b + tt + tt1) / (3 * a)
        xx3 = (-b + tt - tt1) / (3 * a)
        Label1.Caption = "X1=" & x1
        Label2.Caption = "X2=" & xx2
        Label3.Caption = "X3=" & xx3
    End Select
End If
End Sub
Private Sub Text1_Click()
Text1.SelStart = 0
Text1.SelLength = Len(Text1.Text)
End Sub
Private Sub Text2_Click()
Text2.SelStart = 0
Text2.SelLength = Len(Text2)
End Sub
Private Sub Text3_Click()
Text3.SelStart = 0
Text3.SelLength = Len(Text3)
End Sub
Private Sub Text4_Click()
Text4.SelStart = 0
Text4.SelLength = Len(Text4)
End Sub


[ Last edited by jjdg on 2010-4-20 at 14:40 ]
赞一下(2人) 回复此楼
努力学习！以正当途径！获得需要的知识！
5楼2010-04-20 14:34:06
已阅   回复此楼   关注TA 给TA发消息 送TA红花 TA的回帖

liangzidou

银虫 (小有名气)
方程具体值如下：
xl=-0.9964370251388
xm=0.0345649889308
xn=-1.35939438932387E-04
只得到一个液相根为
z=4.51886001901873E-03
赞一下 回复此楼
6楼2010-04-20 23:20:50
已阅   回复此楼   关注TA 给TA发消息 送TA红花 TA的回帖

jjdg

版主 (知名作家)

优秀版主
★
小木虫(金币+0.5):给个红包，谢谢回帖交流
引用回帖:
Originally posted by liangzidou at 2010-04-20 23:20:50:
方程具体值如下：
xl=-0.9964370251388
xm=0.0345649889308
xn=-1.35939438932387E-04
只得到一个液相根为
z=4.51886001901873E-03

你的输入有问题吧！


[ Last edited by jjdg on 2010-4-21 at 10:54 ]
赞一下(1人) 回复此楼
努力学习！以正当途径！获得需要的知识！
7楼2010-04-21 10:24:35
已阅   回复此楼   关注TA 给TA发消息 送TA红花 TA的回帖

jjdg

版主 (知名作家)

优秀版主
★
小木虫(金币+0.5):给个红包，谢谢回帖交流
代码如下：
Dim res1
Private Sub Command1_Click()
Dim a, b, c, d, aa, bb, cc, delta, y1, y2, k, theta, t, x, x1, x2, x3, tt, tt1, xx2, xx3
'az^3+bz^2+cz+d=0
a = Val(Text1.Text)
b = Val(Text2.Text)
c = Val(Text3.Text)
d = Val(Text4.Text)

aa = Round((b ^ 2 - 3 * a * c), 4)
bb = Round((b * c - 9 * a * d), 4)
cc = Round((c * c - 3 * b * d), 4)

delta = Round((bb * bb - 4 * aa * cc), 4)

If (aa = 0) And (bb = 0) Then
    Label6.Caption = "当A=B=0时，方程有一个三重实根"
    x = -b / (3 * a)
    Label7.Caption = "X1=X2=X3=:" & x
    Label8.Caption = ""
    Label9.Caption = ""
Else
    Select Case delta
    Case Is > 0
        y1 = aa * b + 3 * a * (-bb + Sqr(delta)) / 2
        If y1 > 0 Then
            y1 = y1 ^ (1 / 3)
        Else
            y1 = y1 * (-1)
            y1 = y1 ^ (1 / 3) * (-1)
        End If
        y2 = aa * b + 3 * a * (-bb - Sqr(delta)) / 2
        If y2 > 0 Then
            y2 = y2 ^ (1 / 3)
        Else
            y2 = y2 * (-1)
            y2 = y2 ^ (1 / 3) * (-1)
        End If
        tt = y1 + y2
        tt1 = 3 ^ (1 / 3) * (y1 - y2) / (6 * a)
        s = (-2 * b + tt) / (6 * a)
        x1 = (-b - tt) / (3 * a)
        x2 = s & "+" & tt1 & "i"
        x3 = s & "-" & tt1 & "i"
        Label6.Caption = "当Δ=B^2－4AC>0时，方程有一个实根和一对共轭虚根"
        Label7.Caption = "X1= " & x1
        Label8.Caption = "X2=" & x2
        Label9.Caption = "X3=" & x3
    Case Is = 0
        k = bb / aa
        x1 = -b / a + k
        x = Str(-k / 2)
        Label6.Caption = "当Δ=B^2－4AC=0时，方程有三个实根，其中有一个两重根"
        Label7.Caption = "X1= " & x1
        Label8.Caption = "X2=" & x
        Label9.Caption = "X3=" & x
    Case Is < 0
        t = (2 * aa * b - 3 * a * bb) / (2 * aa ^ (3 / 2))
        theta = Atn(-t / Sqr(-t * t + 1)) + 2 * Atn(1)
        theta = theta / 3
        tt = aa ^ (1 / 2) * Cos(theta)
        tt1 = 3 ^ (1 / 2) * Sin(theta)
        x1 = (-b - 2 * tt) / (3 * a)
        xx2 = (-b + tt + tt1) / (3 * a)
        xx3 = (-b + tt - tt1) / (3 * a)
        Label6.Caption = "当Δ=B^2－4AC<0时，方程有三个不相等的实根"
        Label7.Caption = "X1= " & x1
        Label8.Caption = "X2=" & xx2
        Label9.Caption = "X3=" & xx3
    End Select
End If
res1 = Label6.Caption + vbCrLf + Label7.Caption + vbCrLf + Label8.Caption + vbCrLf + Label9.Caption
End Sub

Private Sub Command2_Click()
Clipboard.Clear
Clipboard.SetText (res1)
End Sub

Private Sub Text1_GotFocus()
Text1.SelStart = 0
Text1.SelLength = Len(Text1.Text)
End Sub
Private Sub Text2_GotFocus()
Text2.SelStart = 0
Text2.SelLength = Len(Text2)
End Sub
Private Sub Text3_GotFocus()
Text3.SelStart = 0
Text3.SelLength = Len(Text3)
End Sub
Private Sub Text4_GotFocus()
Text4.SelStart = 0
Text4.SelLength = Len(Text4)
End Sub
赞一下(1人) 回复此楼
努力学习！以正当途径！获得需要的知识！
8楼2010-04-21 10:55:12
已阅   回复此楼   关注TA 给TA发消息 送TA红花 TA的回帖

liangzidou

银虫 (小有名气)
wangen994:求助完成请在标题后添加【已完成】 2010-04-21 12:26
嗯，我把这段程序放到整个程序里再仔细看看，可能是系数输入的有差错了。谢谢啊
赞一下(1人) 回复此楼
9楼2010-04-21 11:06:08
已阅   回复此楼   关注TA 给TA发消息 送TA红花 TA的回帖

magic7004

金虫 (职业作家)
★ ★ ★ ★
小木虫(金币+0.5):给个红包，谢谢回帖交流
wangen994(金币+2):主要还是算符 2010-04-21 12:26
wangen994(金币+1):活动期间额外奖励 2010-04-21 12:26
这个貌似和VB没关系吧，只是解方程的算法问题。
赞一下(3人) 回复此楼
流氓不可怕，可怕的是流氓有文化，有文化又BH的流氓无敌~~！
10楼2010-04-21 11:18:07
已阅   回复此楼   关注TA 给TA发消息 送TA红花 TA的回帖
相关版块跳转 我要订阅楼主 liangzidou 的主题更新
161/2返回列表12下一页
普通表情 龙 兔 虎 猫 高级回复 (可上传附件)
最具人气热帖推荐 [查看全部] 作者 回/看 最后发表
[硕博家园] 售SCI一区文章，我:8.O.551.O.5.4,科目全,可伽急 +3 0XLacIJUOj8D 2026-08-24 5/250 2026-08-24 21:51 by BZKMTicpDhFj
[基金申请] 人气不行了 +10 fansofjerry 2026-08-21 10/500 2026-08-24 21:03 by zhanghaozhu
[基金申请] 如果此刻你正在为国基感到焦虑，不妨来听听这首《基金之外》 +6 scalable 2026-08-24 6/300 2026-08-24 20:28 by 苦寒来香
[基金申请] 我面上完蛋了 +9 且听虎啸 2026-08-20 10/500 2026-08-24 20:08 by 苦寒来香
[基金申请] 能否退出参与的面上项目解除限项 +21 koalala 2026-08-24 24/1200 2026-08-24 19:25 by 家与远方
[基金申请] filecode，4个jtjc了 +14 ziyangfang 2026-08-19 17/850 2026-08-24 18:37 by 哈哈蛤？
[基金申请] 2026国自然函评费到账 +17 羊腰板 2026-08-21 19/950 2026-08-24 16:52 by iaeyuan
[基金申请] 建议基金发布提前给出明确的时间点 +13 kulium 2026-08-21 16/800 2026-08-24 16:27 by superceng
[基金申请] 今日不放榜？网传国自然预计 8 月 27 日可查结果 +17 医学老男孩 2026-08-20 21/1050 2026-08-24 14:21 by refreshing11
[基金申请] 估计是周四 +4 archvillain 2026-08-18 4/200 2026-08-24 13:53 by zzuzxg
[基金申请] 范进中举一文的中心思想 +6 炎黄贵胄 2026-08-22 7/350 2026-08-24 11:58 by 6543yes
[基金申请] 朋友圈看到的 +7 wangzilk 2026-08-18 9/450 2026-08-24 10:50 by cmrandy
[基金申请] 放榜前的不淡定 20+4 snowwithsea 2026-08-19 17/850 2026-08-24 10:20 by echo8914667
[基金申请] 科研孤儿太难了 +18 我4大白菜 2026-08-20 19/950 2026-08-24 09:47 by 凯恩广盛催化分�
[基金申请] 什么时候开奖？ +10 CrisMessi 2026-08-18 11/550 2026-08-24 06:50 by 开心的小狮子
[基金申请] 2026年的国家社科基金项目通讯评审的新规则与新动向、新挑战 +4 process2012 2026-08-23 5/250 2026-08-23 19:58 by jurkat.1640
[基金申请] 今天放榜吗？ +15 布布和一二 2026-08-19 16/800 2026-08-23 09:55 by 张春生
[基金申请] 时间戳今天，20号变了 +5 archvillain 2026-08-20 5/250 2026-08-22 06:12 by hui_daxiao
[基金申请] 今天放榜没戏了吧 +9 yuleib84 2026-08-19 11/550 2026-08-21 10:06 by gltch
[基金申请] 今天维护系统维护 祝所有人 高中 +8 gjjjzhong 2026-08-18 9/450 2026-08-18 13:01 by 家与远方
信息提示
关闭
请填处理意见
关闭