如何在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

通过单独绘制等式的lhs的实部和虚部,我得到了一些非常类似于你所期望的东西:

ContourPlot[{Re@a[k, w] == 0, Im@a[k, w] == 0}, {w, 0, 6}, {k, 0, 14},
  MaxRecursion -> 7]

Answer 2

您确定图片和/或定义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}]

结果