1
$\begingroup$

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.

$\endgroup$
  • 1
    $\begingroup$ Have you tried evaluating the integral symbolically? More in general, what have you tried so far? $\endgroup$ – MarcoB Mar 10 '17 at 5:06
2
$\begingroup$

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}}]

enter image description here

$\endgroup$
2
$\begingroup$

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"}]
$\endgroup$
1
$\begingroup$

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]

enter image description here

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)

$\endgroup$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.