How to obtain accurate plot curves in Mathematica?

Question

Run the following code In 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}]

This gives me very inaccurate curves:

I have tried setting the PlotPoints and WorkingPrecision options of ContourPlot to 30 and 20 respectively, to no avail. You will also notice that the only numerical parameter, r, is an exact rational number. I don't know what else to try. Thanks.

Edit: The curves I expect to get are the three black ones (marked A1, A2, and A3) on the following picture

Answer 1

Are you sure about the picture and/or the definition for a? From the definition of a it follows that a[k,w]==0 on k==w but that curve doesn't appear in your picture.

Anyway, assuming that the definition of a is right, the problem with plotting the contours is that in the domain w^2/r^2-k^2<0, both p[k,w] and Sin[p[k,w]] become purely imaginary which means that a[k,w] becomes purely imaginary as well. Since ContourPlot doesn't like complex valued functions only the parts of the contours in the domain w^2/r^2>=k^2 are plotted.

Not that Sin[p[k,w]]/p[k,w] is real for all values of k and w (and it's nicely behaved in the limit p[k,w]->0). Therefore, to get around the problem of a becoming complex you could plot the contours a[k,w]/p[k,w]==0 instead:

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

Result

Answer 2

I have got something very similar to what you expect by separate plotting of real and imaginary parts of the l.h.s. of the equation:

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