I have a function SQ[b,zQ,zh]
where I want to find at which zQ
it is a minimum given b
and zh
. I set b=10^-x
and zh=1.355 10^-x
where I choose x
. For x=3
I encounter a FindMinimum::lstol
issue. I have tried changing MaxRecursion
and WorkingPrecision
but it is not resolved. Can anyone help me with this?
I also want to extend the calculation for larger x=4,5,...,10
d = 3;
ag = 10;
pg = 10;
wp = 50;
f[z_, zh_] := 1 - (z/zh)^(d + 1);
torootsig[b_?NumericQ, sig_?NumericQ, zQ_?NumericQ, zh_?NumericQ] := Module[{br, sigr, zQr, zhr}, {br, sigr, zQr, zhr} = Rationalize[{b, sig, zQ, zh}, 0]; br - NIntegrate[z^d/Sqrt[f[z, zhr] (zQr^(2 d) (1 + (sigr^2/f[zQr, zhr])) - z^(2 d))], {z, 0, zQr}, AccuracyGoal -> ag, PrecisionGoal -> pg, WorkingPrecision -> wp, MaxRecursion -> 100]]
sig[b_?NumericQ, zQ_?NumericQ, zh_?NumericQ] := sig /. FindRoot[torootsig[b, sig, zQ, zh] == 0, {sig, -50 1.3 10^-3, 0}, AccuracyGoal -> ag, PrecisionGoal -> pg, WorkingPrecision -> wp, MaxIterations -> 100]
intSQ1[b_?NumericQ, zQ_?NumericQ, zh_?NumericQ] := Module[{br, zQr, zhr}, {br, zQr, zhr} = Rationalize[{b, zQ, zh}, 0]; (-1/(d - 1)) (1/(zQr^(2 d) (1 + sig[br, zQr, zhr]^2/f[zQr, zhr]))) NIntegrate[z^d Sqrt[f[z, zhr]/(1 - (1/(zQr^(2 d) (1 + sig[br, zQr, zhr]^2/f[zQr, zhr]))) z^(2 d))], {z, 0, zQr}, AccuracyGoal -> ag, PrecisionGoal -> pg, WorkingPrecision -> wp, MaxRecursion -> 100]]
intSQ2[b_?NumericQ, zQ_?NumericQ, zh_?NumericQ] := Module[{br, zQr, zhr}, {br, zQr, zhr} = Rationalize[{b, zQ, zh}, 0]; (-1/(2 zhr^(d + 1))) ((d + 1)/(d - 1)) NIntegrate[z Sqrt[(1 - (1/(zQr^(2 d) (1 + sig[br, zQr, zhr]^2/f[zQr, zhr]))) z^(2 d))/f[z, zhr]], {z, 0, zQr}, AccuracyGoal -> ag, PrecisionGoal -> pg, WorkingPrecision -> wp, MaxRecursion -> 100]]
intSQ3[b_?NumericQ, zQ_?NumericQ, zh_?NumericQ] := Module[{br, zQr, zhr}, {br, zQr, zhr} = Rationalize[{b, zQ, zh}, 0]; (1/zhr)^(d + 1) NIntegrate[z/Sqrt[f[z, zhr] (1 - (1/(zQr^(2 d) (1 + sig[br, zQr, zhr]^2/f[zQr, zhr]))) z^(2 d))], {z, 0, zQr}, AccuracyGoal -> ag, PrecisionGoal -> pg, WorkingPrecision -> wp, MaxRecursion -> 300, Method -> "LocalAdaptive"]]
SQ[b_?NumericQ, zQ_?NumericQ, zh_?NumericQ] := Module[{br, zQr, zhr}, {br, zQr, zhr} = Rationalize[{b, zQ, zh}, 0]; (-Sqrt[f[zQr, zhr] (1 - (1/(zQr^(2 d) (1 + sig[br, zQr, zhr]^2/f[zQr, zhr]))) zQr^(2 d))]/((d - 1) zQr^(d - 1)) + intSQ1[br, zQr, zhr] + intSQ2[br, zQr, zhr] + intSQ3[br, zQr, zhr] + 1/zQr^(d - 1))/4 ]
x = 3;
FindMinimum[{SQ[10^-x, zQ, 1.355 10^-x]/10^(2 x)}, {zQ, 0.9955 1.355 10^-x, 0.995 1.355 10^-x, 0.996 1.355 10^-x}, AccuracyGoal -> ag, PrecisionGoal -> pg, WorkingPrecision -> wp, MaxIterations -> 500] // AbsoluteTiming
FindMinimum::lstol: The line search decreased the step size to within the tolerance specified by AccuracyGoal and PrecisionGoal but was unable to find a sufficient decrease in the function. You may need more than 50.` digits of working precision to meet these tolerances.
{598.3201164, {0.19195144250523353513414807356587315266329459419565, {zQ -> 0.0013490146179865683928983415239627338448699548869898}}}
There is definitely a minimum as is shown below,
x = 3;
Plot[SQ[10^-x, n 1.355 10^-x, 1.355 10^-x]/10^(2 x), {n, 0.995, 0.996}, PlotStyle -> {Blue, Thickness[0.005]}, PlotRange -> Full, ImageSize -> Large] // AbsoluteTiming
NMinimize
. $\endgroup$NMinimize
with the same range given above (excluding initial point) and it just keeps running for so long and not ending so I just aborted it around 30 minutes later. That's so exaggerated for only one point. $\endgroup$