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

在 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 and WorkingPrecision的选项ContourPlot分别为30和20，无济于事。您还会注意到唯一的数字参数，r，是一个精确的有理数。我不知道还能尝试什么。谢谢。

编辑：我期望得到的曲线是下图中的三个黑色曲线（标记为A1、A2和A3）

您确定图片和/或定义吗a？从定义a它遵循a[k,w]==0 on k==w但那条曲线没有出现在你的图片中。

无论如何，假设定义a是的，绘制等值线的问题在于域中w^2/r^2-k^2<0, both p[k,w] and Sin[p[k,w]]变成纯粹的想象，这意味着a[k,w]也变得纯粹是想象的。自从ContourPlot不喜欢复值函数，只喜欢域中轮廓的部分w^2/r^2>=k^2被绘制。

不是那个Sin[p[k,w]]/p[k,w]对于 的所有值都是真实的k and 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}]

Result