How do I plot the solutions to an integral equation defined over a 2D region?

Question

I have a hexagonal region R (in the x-y plane) defined by the following 6 points:

R = Polygon[{{4Pi/3, 0}, {2Pi/3, 2Pi/Sqrt[3]}, {-2Pi/3, 2Pi/Sqrt[3]}, {-4 Pi/3, 0}, {-2Pi/3, -2Pi/Sqrt[3]}, {2Pi/3, -2Pi/Sqrt[3]}}];

I would like to obtain a plot showing the value of m (from say U=0 to U=10) which satisfies the following equation:

$$ 1 = A*U\iint_R \frac{1}{\sqrt{U^2m^2+f(x,y)}} $$

where $$f(x,y)= 3+ 2\cos\left[\frac{\sqrt3}{2}y +\frac{x}{2}\right]+2\cos\left[\frac{\sqrt3}{2}y -\frac{x}{2}\right] + 2\cos[x],$$

$$A=\frac{3\sqrt{3}}{8\pi^2},$$

and the integral is over all points {x,y} within R. Can anyone suggest how this can be done? Thanks for any help.

Answer 1

First define functions to characterize your Polygon R:

    f1[x_] = 2 Pi/Sqrt[3]/(-2 Pi/3 - (-4 Pi/3)) (x + 4 Pi/3)

    f2[x_] = -2 Pi/Sqrt[3]/(-2 Pi/3 - (-4 Pi/3)) (x + 4 Pi/3)

    f3[x_] = 2 Pi/Sqrt[3]

    f4[x_] = -2 Pi/Sqrt[3]

    f5[x_] = -2 Pi/Sqrt[3]/(-2 Pi/3 - (-4 Pi/3)) (x - 4 Pi/3)

    f6[x_] = 2 Pi/Sqrt[3]/(-2 Pi/3 - (-4 Pi/3)) (x - 4 Pi/3)

    func1[x_] = 
    Piecewise[{{f1[x], -4 Pi/3 <= x <= -2 Pi/3}, {f3[x], -2 Pi/3 < x < 
    2 Pi/3}, {f5[x], 2 Pi/3 <= x <= 4 Pi/3}}, 0]

    func2[x_] = 
    Piecewise[{{f2[x], -4 Pi/3 <= x <= -2 Pi/3}, {f4[x], -2 Pi/3 < x < 
    2 Pi/3}, {f6[x], 2 Pi/3 <= x <= 4 Pi/3}}, 0]

Test it

   Plot[{func1[x], func2[x]}, {x, -5, 5}, Epilog -> Point[Identity @@ R]]

Define your integration and FindRoot for m with given U:

    f[x_, y_] = 
    3 + 2 Cos[Sqrt[3]/2 y + x/2] + 2 Cos[Sqrt[3]/2 y - x/2] + 2 Cos[x]

    int[U_?NumericQ, m_?NumericQ] := 
    NIntegrate[
    1/Sqrt[U^2 m^2 + f[x, y]], {x, -4 Pi/3, 4 Pi/3}, {y, func2[x], 
    func1[x]}, MaxRecursion -> 100] // Quiet

    mfr[U_] := 
    m /. FindRoot[A U int[U, m] == 1, {m, 0, 10}, MaxIterations -> 2000]

    mfrneg[U_] := 
    m /. FindRoot[A U int[U, m] == 1, {m, -10, 0}, MaxIterations -> 2000]

With Plot you see, that a positive and a negitive m fullfil the condition, but only for U > 0.371841

    Manipulate[
    Plot[{1, A U int[U, m]}, {m, -6, 6}, PlotRange -> {0, 3}], {U, 10, 
    0}]

    FindRoot[A U int[U, 0] == 1, {U, 0, 1}, 
    MaxIterations -> 2000]

    (*   {U -> 0.371841}   *)

Plot the two m as a function of U

    pl = Plot[{mfr[U], mfrneg[U]}, {U, .4, 10}, 
    PlotRange -> {{0, 10}, {-3.5, 3.5}}]

Answer 2

Here is one possible solution:

 R = Polygon[{{4 Pi/3, 0}, {2 Pi/3, 2 Pi/Sqrt[3]}, {-2 Pi/3, 
 2 Pi/Sqrt[3]}, {-4 Pi/3, 
 0}, {-2 Pi/3, -2 Pi/Sqrt[3]}, {2 Pi/3, -2 Pi/Sqrt[3]}}];
 A = 3*Sqrt[3]/8/\[Pi]^2;
 f[x_, y_] := 3 + 2*Cos[Sqrt[3]/2*y + x/2] + 2*Cos[Sqrt[3]/2*y - x/2] + 2*Cos[x];
 int[U_?NumericQ][m_?NumericQ] := A*U*NIntegrate[1/Sqrt[U^2*m^2 + f[x, y]], {x, y} \[Element] R]

data = Table[{U, m /. FindRoot[int[U][m] == 1, {m, 2}]}, {U, 0, 10}] // Quiet

(* result {{0, 2.}, {1, 2.53439}, {2, 2.87748}, {3, 2.94495}, {4, 2.96891}, {5, 2.98007}, {6, 2.98614}, {7, 2.98981}, {8, 2.9922}, {9, 2.99383}, {10, 2.995}} *)

 ListLinePlot[data, Epilog -> {Red, PointSize[0.02], Point[data]}, PlotRange -> {{0, 10}, {2, 3}}, PlotRangePadding -> {{0, 0}, {0, 0.2}}, Frame -> True, GridLines -> Automatic, FrameLabel -> {"U", "m"}]

Answer 3

This is using the region as defined by @Akku14, but notice you do not need to use FindRoot. Eval the integral in terms of the parameter m U , solve for U and make your plot parametrically:

int[mu_?NumericQ] := 
 NIntegrate[
   1/Sqrt[mu^2 + f[x, y]], {x, -4 Pi/3, 4 Pi/3}, {y, func2[x], 
    func1[x]}, MaxRecursion -> 100] // Quiet
U[mu_] := 1/int[mu]/A
ParametricPlot[{{{#, mu/#}, {#, -mu/#}} &@U[mu]}, {mu, 0, 30}, 
 AspectRatio -> 1/GoldenRatio, PlotRange -> All]

note we can also do the integral like this

reg = Polygon[{{4 Pi/3, 0}, {2 Pi/3, 2 Pi/Sqrt[3]}, {-2 Pi/3, 
     2 Pi/Sqrt[3]}, {-4 Pi/3, 
     0}, {-2 Pi/3, -2 Pi/Sqrt[3]}, {2 Pi/3, -2 Pi/Sqrt[3]}}];
int[mu_?NumericQ] := 
 NIntegrate[1/Sqrt[mu^2 + f[x, y]], Element[{x, y}, reg]]

but it is a good bit slower (oddly)