如何在Mathematica同图绘制两个方程并显示曲线交点

步骤说明 #

1. 添加目标曲线：将方程\[Lambda] = k^2 + Log[0.75]转换为等高线方程形式，加入原ContourPlot的方程列表中。
2. 计算交点：使用FindRoot求解原有每条曲线与新曲线的数值交点，结合绘图范围设置初始猜测值保证收敛。
3. 可视化交点：通过Epilog在图中用醒目样式标记所有交点。

完整修改代码 #

eqn[d_Integer?NonNegative, r_, B_, nmax_Integer?Positive] := 
  Sum[Exp[-n*\[Lambda]]*(1 - r)^
     n Exp[n*k^2 - k^2*B (HarmonicNumber[n + d] - HarmonicNumber[d])], {n, 1, nmax}] == -1 + Exp[\[Lambda]]/r;
BValues = {0, 0.5, 5};
newEqn = \[Lambda] == k^2 + Log[0.75];

Block[{$MaxExtraPrecision = 500},
  (* 计算每条曲线与新曲线的交点 *)
  intersections = Table[
    FindRoot[{eqn[10, 0.25, B, 100], newEqn}, {{k, 0.5}, {\[Lambda], 0}}],
    {B, BValues}
  ];
  points = {k, \[Lambda]} /. intersections;

  (* 绘制包含新曲线和交点的图形 *)
  ContourPlot[
    Evaluate@Join[Table[eqn[10, 0.25, B, 100], {B, BValues}], {newEqn}],
    {k, 1/20, 2}, {\[Lambda], -1, 3.5},
    FrameLabel -> (Style[#, 14] & /@ {k, Subscript[\[Lambda], r]}),
    RotateLabel -> False,
    PlotPoints -> 100,
    MaxRecursion -> 4,
    AspectRatio -> 1/GoldenRatio,
    (* 区分曲线样式：原有B值曲线用彩色实线，新曲线用黑色粗虚线 *)
    ContourStyle -> Join[Table[ColorData["Rainbow"][i/Length[BValues]], {i, 1, Length[BValues]}], {Directive[Black, Dashed, AbsoluteThickness[2]]}],
    PlotLegends -> Placed[
      LineLegend[
        Join[N@BValues, {"\[Lambda] = k² + Log[0.75]"}],
        LegendLabel -> "曲线"
      ], {.1, .6}
    ],
    GridLines -> {None, {0}},
    GridLinesStyle -> Directive[Gray, AbsoluteThickness[1], Dashed],
    (* 标记交点：红色实心大圆点 *)
    Epilog -> {Red, AbsolutePointSize[8], Point[points]}
  ]
]

代码细节说明 #

• newEqn：将目标曲线转换为ContourPlot支持的等式形式，确保能被识别为等高线。
• FindRoot：针对每个B值，选取绘图范围内的初始值（k=0.5, λ=0）求解联立方程，得到精确交点坐标。
• ContourStyle：通过不同样式区分原有曲线与新曲线，新曲线用黑色虚线突出显示。
• Epilog：在等高线绘制完成后叠加绘制交点，红色大圆点保证交点清晰可见。

内容的提问来源于stack exchange，提问作者caren