math - 如何在Mathematica中获得准确的绘图曲线？

Question

在Mathematica中运行以下代码:

r=6197/3122;
p[k_,w_]:=Sqrt[w^2/r^2-k^2];q[k_,w_]:=Sqrt[w^2-k^2];
a[k_,w_,p_,q_]:=(k^2-q^2)^2 Sin[p]Cos[q]+4k^2 p q Cos[p]Sin[q]
a[k_,w_]:=a[k,w,p[k,w],q[k,w]];
ContourPlot[a[k,w]==0,{w,0,6},{k,0,14}]

这给了我非常不准确的曲线:

我尝试将 PlotPoints的 WorkingPrecision和 ContourPlot选项分别设置为30和20，无济于事。您还将注意到，唯一的数字参数 r是精确的有理数。我不知道还能尝试什么。谢谢。

编辑:我期望得到的曲线是下图上的三个黑色曲线(标记为A1，A2和A3)

Answer 1

您确定图片和/或a的定义吗？根据a的定义，可以得出a[k,w]==0上的k==w，但该曲线未出现在您的图片中。

无论如何，假设a的定义是正确的，绘制轮廓的问题是在w^2/r^2-k^2<0域中，p[k,w]和Sin[p[k,w]]都变为纯虚构的，这意味着a[k,w]也变为纯虚构的。由于ContourPlot不喜欢复杂的值函数，因此仅绘制了w^2/r^2>=k^2域中的轮廓部分。

并不是说Sin[p[k,w]]/p[k,w]对于k和w的所有值都是真实的(并且在p[k,w]->0限制中表现得很好)。因此，要解决a变得复杂的问题，您可以绘制轮廓a[k,w]/p[k,w]==0来代替:

ContourPlot[a[k, w]/p[k, w] == 0, {w, 0, 6}, {k, 0, 14}]

结果