4
$\begingroup$

I would like an estimate of the three-dimensional volume lying within the cube $[-1,1]^3$ of the body defined by the constraints (the three variables being $t1, t2, t3$)

-(1/2) < t3 < 1/2 && -(1/2) < t2 < 1/2 && 4 t1^2 < (1 - 2 t3)^2 && 4 t1^2 < (1 + 2 t3)^2 && (Abs[t1] + Abs[t2] + Abs[t3])^2 > 1/2 && 6912 t1^2 t2^2 t3^2 <= 1

I've tried several of the NIntegrate Methods, using the Boole command. Method->"MonteCarlo" seems to be the most "realistic", but only accurate to one or two places, varying MaxPoints. Several of the Methods signal that "The number of piecewise regions has exceeded the maximum value specified by the option MaxPiecewiseCases -> 100".

$\endgroup$
6
$\begingroup$

Your constraint:

constraint = -(1/2) < t3 < 1/2 && -(1/2) < t2 < 1/2 && 4 t1^2 < (1 - 2 t3)^2 && 4 t1^2 < (1 + 2 t3)^2 && (Abs[t1] + Abs[t2] + Abs[t3])^2 > 1/2 && 6912 t1^2 t2^2 t3^2 <= 1;

Here's a couple more approaches to obtain the volume using ImplicitRegion:

NIntegrate[1, t ∈ ImplicitRegion[constraint, {t1,t2,t3}]]

0.0758044

and:

Volume[ImplicitRegion[constraint,{t1,t2,t3}], WorkingPrecision->MachinePrecision]

0.0758044

Volume will try to produce an exact answer, so I enforce a numerical approximation with the WorkingPrecision option.

$\endgroup$
1
  • $\begingroup$ I tried the indicated Volume command without the WorkingPrecision option, and it gave a numerical result--0.0758044. Maybe it gave up on an exact solution, and reverted to the numerical one? $\endgroup$ Jan 23 '20 at 18:22
3
$\begingroup$

First look on the "body"

RegionPlot3D[-(1/2) < t3 < 1/2 && -(1/2) < t2 < 1/2 && 4 t1^2 < (1 - 2 t3)^2 &&4 t1^2 < (1 + 2 t3)^2 && (Abs[t1] + Abs[t2] + Abs[t3])^2 > 1/2 &&6912 t1^2 t2^2 t3^2 <= 1
, {t1, -1, 1}, {t2, -1, 1}, {t3, -1, 1}, PlotPoints -> 100,MaxRecursion -> 4, AxesLabel -> Automatic]

enter image description here

shows two parts.

In the next step I define a region for one part (t2>0)

cube = ImplicitRegion[-(1/2) < t3 < 1/2 && 0 < t2 < 1/2 &&4 t1^2 < (1 - 2 t3)^2 &&4 t1^2 < (1 + 2 t3)^2 && (Abs[t1] + Abs[t2] + Abs[t3])^2 > 1/2 && 6912 t1^2 t2^2 t3^2 <= 1
, {{t1, -1, 1}, {t2, -1, 1}, {t3, -1, 1}}]

The volume of this part evaluates to

Volume[ DiscretizeRegion[cube, MaxCellMeasure -> .0001] ]
(*0.0346886*)

For this single part although NIntegratetogether with Boole evaluates without error to

NIntegrate[Boole[ 4 t1^2 < (1 - 2 t3)^2 && 4 t1^2 < (1 + 2 t3)^2 && (RealAbs[t1] + RealAbs[t2] + RealAbs[t3])^2 > 1/2 && 6912 t1^2 t2^2 t3^2 <= 1], 
{t1, -1,1}, {t2, 0, 1/2}, {t3, -1/2, 1/2}]
(*0.0379022*)
$\endgroup$
2
$\begingroup$

The problem seems to be the that the resolution of your implicit region is too small. This problem be reduced with the MaxCellMeasure option in DiscretizedRegion. Reducing it, leads to a converging result:

enter image description here

Here is the code:

ir = ImplicitRegion[
     -(1/2) < t3 < 1/2 &&
      -(1/2) < t2 < 1/2
      && 4 t1^2 < (1 - 2 t3)^2
      && 4 t1^2 < (1 + 2 t3)^2
      && (Abs[t1] + Abs[t2] + Abs[t3])^2 > 1/2
      && 6912 t1^2 t2^2 t3^2 <= 1
     , {t1, t2, t3}];

data = Table[   
   d1 = DiscretizeRegion[ir, MaxCellMeasure -> mcellm];
   {mcellm, d1, NIntegrate[1, {t1, t2, t3} \[Element] d1]}
   , {mcellm, Table[10.0^(-i), {i, 3, 7}]}];

plot = Grid[{data[[All, 1]],data[[All, 3]],data[[All, 2]]}];
Export[FileNameJoin[{NotebookDirectory[], "implicit_region_integration_resolution_plot.png"}], 
  plot];
$\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.