(* Location of singularities of diagonal quadratic and differential approximants *)
(* Options *)
mindlist = 10; (* number of approximants *)
ncrop = 20; (* disregard coefficients with N>ncrop *)
ndrop = 0; (* how many coeff. to drop from beginning of series *)
xyrange = 2.5/asave[name]; (* plot range *)
sect = "sings3";
entity = "figure";
cf = If[nm > ncrop, Take[func, ncrop], func];
cf = Drop[cf, ndrop];
nmax = Length[cf];
(* Create table of indexes of approximants *)
indlist = {};
Do[Do[
ind = {n1, n2, n3};
nuse = Plus@@ind + 2;
prior = 1.1^nuse;
If[n1 < 0 || n2 < 0 || n3 < 1 || nuse > nmax,
Continue[]];
If[Abs[n1 - n2] > 1 || Abs[n2 - n3] > 1 || Abs[n3 - n1] > 1,
Continue[]];
If[!(n1<=n2<=n3<=n1+1), Continue[]];
(*
If[n1 == n2 == n3, prior = 30 prior];
prior = (*2^(n2 - n1) 3^(n3 - n2)*) prior;
*)
indlist = Append[indlist, {ind, prior, nuse}];
, {n2, n1, n1 + 1}, {n3, n1, n1 + 1}], {n1, 0, nm}];
indlist = Sort[indlist, #1[[2]] > #2[[2]] &];
mi = Length[indlist];
If[mindlist < mi, indlist = Take[indlist, mindlist]; mind = mindlist, mind = mi];
indlist = Sort[indlist, #1[[3]] < #2[[3]] &];
tind = Transpose[indlist];
pind = {ToString /@ tind[[1]], tind[[3]]};
If[iprint,Print["Indexes: ", pind // TableForm]];
boxed1[symb_] :=
"\!\(\* StyleBox[ FrameBox[StyleBox[\"" <> symb <>
"\", FontSize->16, FontWeight->\"Bold\", FontColor->GrayLevel[0]],
BoxMargins->{{0.2, 0.2}, {0.6, 0.6}}], FontSize->12,
FontWeight->\"Plain\", FontColor->GrayLevel[1],
Background->GrayLevel[1], FontVariations->{\"CompatibilityType\"->0}]\)";
boxed2[symb_] :=
"\!\(\* StyleBox[ FrameBox[StyleBox[\"" <> symb <>
"\", FontSize->16, FontWeight->\"Bold\", FontColor->RGBColor[0,0,0]],
BoxMargins->{{0.2, 0.2}, {0.6, 0.6}}], FontSize->12,
FontWeight->\"Plain\", FontColor->GrayLevel[0.7],
Background->GrayLevel[1], FontVariations->{\"CompatibilityType\"->0}]\)";
If[mindlist > 1,
mslist = Length[slist0];
If[mslist==0, plts = {}];
If[mslist==1,
{singdom} = slist0;
slist = Union[slist0, Conjugate[slist0]];
slist = {{Re[#], Im[#]}} & /@ slist;
scale = 2.2;
If[newfigure == True, plts = MultipleListPlot[slist,
SymbolShape -> shape[1],
SymbolStyle -> {{Thickness[0.004 scale], RGBColor[1,0,0]}},
PlotRange -> xyrange{{-1, 1}, {-1, 1}},
AspectRatio -> 1,
Frame -> True,
ImageSize -> 400,
DisplayFunction -> Identity]];
];
If[mslist==2,
{singdom, singsub} = slist0;
slist1 = Union[{singdom}, {Conjugate[singdom]}];
slist1 = {{Re[#], Im[#]}} & /@ slist1;
slist2 = Union[{singsub}, {Conjugate[singsub]}];
slist2 = {{Re[#], Im[#]}} & /@ slist2;
scale = 2.2;
If[newfigure == True, plts = MultipleListPlot[slist1, slist2,
SymbolShape -> shape[1],
SymbolStyle -> {{Thickness[0.004 scale], RGBColor[1,0,0]}, {Thickness[0.004 scale], RGBColor[1,0.5,0.5]}},
PlotRange -> xyrange{{-1, 1}, {-1, 1}},
AspectRatio -> 1,
Frame -> True,
ImageSize -> 400,
DisplayFunction -> Identity]];
];
If[newfigure == True,
pltseq = {};
Clear[pol, c, funs];
(*Cycle over indexes*)
Do[
{{n1, n2, n3}, prior, nc} = indlist[[nindlist]];
c[0] = 1;
pol[0] = Sum[c[n]z^n, {n, 0, n1}];
pol[1] = Sum[c[n + n1 + 1]z^n, {n, 0, n2}];
pol[2] = Sum[c[n + n1 + n2 + 2]z^n, {n, 0, n3}];
funs[z_] = Sum[cf[[n]]z^(n - 1), {n, nc}];
(*Quadratic approximant*)
pattern = pol[0] + pol[1]f[z] + pol[2]f[z]^2;
eqs = Take[CoefficientList[pattern /. f -> funs, z], nc];
s = Solve[eqs == Table[0, {nc}], Table[c[n], {n, nc}]];
ls = Length[s];
If[ls == 0, Print["No solutions of linear equations found!"]];
If[ls > 1, Print["More than one solution of linear equations!"]];
s1 = s[[1]];
{pa, pb, pc} = {pol[2], pol[1], pol[0]} /. s1;
pold = pb^2 - 4 pa pc;
sn = NSolve[pold == 0, z];
sn = Sort[sn, Abs[((z /. #1) - 0)] < Abs[((z /. #2) - 0)] &];
sings = z /. sn;
xylist1 = {Re[#], Im[#]} & /@ sings;
xylist =
Select[xylist1, (Abs[#[[1]]] < 1.05 xyrange &&
Abs[#[[2]]] < 1.05 xyrange) &];
msing = Length[xylist];
scale = 0.8;
plt = If[msing == 0, {}, MultipleListPlot[xylist,
SymbolShape -> shape[2],
SymbolStyle -> {{Thickness[0.008 scale], color[1]}},
TextStyle -> {FontFamily -> "Times New Roman", FontSize -> 12,
FontSubstitutions -> {"Math1" -> "Symbol"}},
PlotRange -> xyrange{{-1, 1}, {-1, 1}},
AspectRatio -> 1,
Frame -> True,
ImageSize -> 300,
DisplayFunction -> Identity]];
label1 = Graphics[{Text[boxed1["Quadratic"], Scaled[{0.2, 0.95}]]}];
plt1 = Show[{plt, label1, plts},
Frame -> True,
DisplayFunction -> Identity];
(*Differential approximant*)
pattern = pol[0] + Sum[pol[k]D[f[z], {z, k - 1}], {k, 2}];
eqs = Take[CoefficientList[pattern /. f -> funs, z], nc];
s = Solve[eqs == Table[0, {nc}], Table[c[n], {n, nc}]];
ls = Length[s];
If[ls == 0, Print["No solutions of linear equations found!"]];
If[ls > 1, Print["More than one solution of linear equations!"]];
s1 = s[[1]];
nlast = 2;
pold = pol[2] /. s1;
sn = NSolve[pold == 0, z];
sn = Sort[sn, Abs[((z /. #1) - 0)] < Abs[((z /. #2) - 0)] &];
sings = z /. sn;
xylist = {Re[#], Im[#]} & /@ sings;
xylist =
Select[xylist, (Abs[#[[1]]] < 1.05 xyrange &&
Abs[#[[2]]] < 1.05 xyrange) &];
msing = Length[xylist];
scale = 1.0;
plt = If[msing == 0, {}, MultipleListPlot[xylist,
SymbolShape -> shape[4],
SymbolStyle -> {{Thickness[0.008 scale], color[1]}},
TextStyle -> {FontFamily -> "Times New Roman", FontSize -> 12,
FontSubstitutions -> {"Math1" -> "Symbol"}},
PlotRange -> xyrange{{-1, 1}, {-1, 1}},
AspectRatio -> 1,
Frame -> True,
ImageSize -> 300,
DisplayFunction -> Identity]];
label2 =
Graphics[{Text[boxed1["Differential"], Scaled[{0.2, 0.95}]]}];
plt2 =
Show[{plt, label2, plts}, Frame -> True,
DisplayFunction -> Identity];
(*Show together*)
wr = 0.1;
plt1r = Rectangle[{0, 0} // Scaled, {(1 - wr)/2, 1} // Scaled, plt1];
plt2r = Rectangle[{(1 - wr)/2, 0} // Scaled, {1 - wr, 1} // Scaled, plt2];
pltind = Table[{{n1, n2, n3}, prior, nc} = indlist[[n]];
txt =
If[n <= mind,
"[" <> ToString[n1] <> ", " <> ToString[n2] <> ", " <>
ToString[n3] <> "]", ""];
t =
Text[txt, {1/2, 1/2},
TextStyle -> {FontFamily -> "Times New Roman", FontSize -> 14,
FontWeight -> If[n == nindlist, "Bold", "Plain"],
FontColor -> RGBColor[0, 0, 0.5]}];
col =
If[n > mind, RGBColor[1, 1, 1],
If[n == nindlist, RGBColor[1, 1, 0], RGBColor[3/4, 3/4, 3/4]]];
g = Graphics[t, Background -> col];
r =
Rectangle[{1 - wr, 0.062 + 0.938(mindlist - n)/mindlist} //
Scaled, {1, 0.062 + 0.938(mindlist - n + 1)/mindlist} // Scaled,
g];
r, {n, mindlist}];
plt = Show[{plt1r, plt2r, pltind} // Graphics, AspectRatio -> 0.41, ImageSize -> 766,
DisplayFunction -> If[ifexport, Identity, $DisplayFunction]];
If[ifexport,
outfile = ToFileName[dir, sect <>ToString[nindlist] <> ".gif"];
Export[outfile, plt, "GIF", ImageSize -> 766, ImageResolution -> 72,
ConversionOptions -> {"AnimationDisplayTime" -> 1, "Loop" -> True,
"ColorReductionPalette" -> 16, "ColorReductionDither" -> False}];
pltseq = Append[pltseq, plt] ],
{nindlist, mind}];
If[ifexport,
outfile = ToFileName[dir, sect <> ".gif"];
Export[outfile, pltseq, "GIF", ImageSize -> 766, ImageResolution -> 72,
ConversionOptions -> {"AnimationDisplayTime" -> 1, "Loop" -> True,
"ColorReductionPalette" -> 16, "ColorReductionDither" -> False}];
];
];
"<A NAME=\"" <> sect <>
"\"></A><TABLE BORDER=1 CELLPADDING=8 CELLSPACING=0
BGCOLOR=\"#FFFFFF\"><TR><TD>" // p;
"<TABLE BORDER=0 CELLPADDING=8 BGCOLOR=\"#FFFFFF\">" // p;
"<TR ALIGN=\"CENTER\" VALIGN=\"MIDDLE\" BGCOLOR=\"#FEF8CB\"><TH>
Location of singularities in the complex plane of the parameter <I>z</I>.
<BR>Left panel refers to quadratic approximants,
<BR>right panel to differential approximants." // p;
If[mslist==1,
"<BR>Encircled area is a subjectively estimated location of\n
<BR>the <FONT COLOR=\"#FF0000\">dominant</FONT> singularity
<I>z</I><SUB>c</SUB> = " <> print2a[singdom,2] <> "." // p ];
If[mslist==2,
"<BR>Encircled areas are subjectively estimated locations of\n
<BR>the <FONT COLOR=\"#FF0000\">dominant</FONT>
<I>z</I><SUB>c</SUB> = " <> print2a[singdom,2] <>
" and a <FONT COLOR=\"#FF8080\">subdominant</FONT> <I>z</I>'<SUB>c</SUB> = " <>
print2a[singsub,2] <> " singularities." // p ];
"<BR>To view an individual approximant, click on the right bar.
<BR>To view all singularities with their weights, see <A HREF=\"sings.htm\">this table</A>.
</TH></TR>" // p;
"<TR ALIGN=\"CENTER\" VALIGN=\"MIDDLE\"><TD>" <> "<IMG SRC=\"" <> sect <>
".gif?" <> rndm <>
"\" WIDTH=766 HEIGHT=314 BORDER=0 ALT=\"Location of singularities in the
complex plane\" USEMAP=\"#indbar\"></TD></TR>" <> "</TABLE></TD></TR></TABLE>
<MAP name=\"indbar\">" // p;
x0 = 687;
x1 = 764;
ytop = 0;
ybot = 294;
Do[y1 = ytop + n/mindlist (ybot-ytop);
y0 = ytop + (n-1)/mindlist (ybot-ytop);
{x0p, x1p, y0p, y1p} = ToString/@Round/@{x0, x1, y0, y1};
ref = sect <> ToString[n] <> ".gif?" <> rndm;
{{n1, n2, n3}, prior, nc} = indlist[[n]];
app = "[" <> ToString[n1] <> ", " <> ToString[n2] <> ", " <> ToString[n3] <> "]";
"<AREA shape=\"rect\" coords=\"" <> x0p <> ","<> y0p <> ","<> x1p <> ","<> y1p <>
"\" href=\"" <> ref <> "\" onclick=\"vappr=window.open('" <> ref <>
"','Singularities" <> (*ToString[n]*)"" <> "','toolbar=no,status=no,scrollbars=no,
location=no,menubar=no,directories=no,width=776,height=324'); vappr.focus(); return false\">" // p;
, {n, mind}];
"<AREA shape=\"default\" nohref></MAP>" // p;
printprogr[sect]; printnav,
"<A NAME=\"" <> sect <>
"\"></A><TABLE BORDER=1 CELLPADDING=8 CELLSPACING=0
BGCOLOR=\"#FFFFFF\"><TR><TD>" // p;
"<TABLE BORDER=0 CELLPADDING=8 BGCOLOR=\"#FFFFFF\">" // p;
"<TR ALIGN=\"CENTER\" VALIGN=\"MIDDLE\" BGCOLOR=\"#FEF8CB\"><TH>
Singularities of approximants in the complex plane
<BR>are <FONT COLOR=\"#FF0000\">not shown</FONT> for this example (" <> name <>
")
<BR>because number of available coefficients of the series (" <>
ToString[nm] <> ")
<BR>is too small to construct a meaningful approximant
</TH></TR>
</TABLE></TD></TR></TABLE>" // p;
"<FONT SIze=\"-2\"><A HREF=\"#top\">
<IMG SRC=\"../../../../iconz/top.gif\" WIDTH=13 HEIGHT=9 BORDER=0
ALT=\"Top of Page\" ALIGN=\"MIDDLE\"></A>
<A HREF=\"#top\">Top of the page</A>
" // p;
If[nser != 1, namem = names[[nser - 1]];
nameml = StringReplace[ToLowerCase[namem], "+" -> "-"];
ref = "../" <> nameml <> "/index.htm#" <> sect;
" <A HREF=\"" <> ref <>
"\"><IMG SRC=\"../../../../iconz/top270.gif\" WIDTH=9 HEIGHT=13
BORDER=0 ALT=\"Previous Example\" ALIGN=\"MIDDLE\"></A>
<A HREF=\"" <> ref <> "\">Prev. (" <> namem <> ")</A>" // p];
" <IMG SRC=\"../../../../blank.gif\" WIDTH=13
HEIGHT=9 BORDER=0 ALT=\"Blank\" ALIGN=\"MIDDLE\"> Current (" <>
name <> ")" // p;
If[nser != mser, namep = names[[nser + 1]];
namepl = StringReplace[ToLowerCase[namep], "+" -> "-"];
ref = "../" <> namepl <> "/index.htm#" <> sect;
" <A HREF=\"" <> ref <>
"\"><IMG SRC=\"../../../../iconz/top90.gif\" WIDTH=9 HEIGHT=13
BORDER=0 ALT=\"Next Example\" ALIGN=\"MIDDLE\"></A> <A HREF=\"" <>
ref <> "\">Next (" <> namep <> ")</A>" // p];
" " // p;
" <A HREF=\"../" <> sect <>
".htm\"><IMG SRC=\"../../../../iconz/smalldig.gif\" WIDTH=12
HEIGHT=17 BORDER=0 ALT=\"Mathematica program\"
ALIGN=\"MIDDLE\"></A> <A HREF=\"../" <> sect <>
".htm\"><I>Mathematica</I> program</A>" // p;
"</FONT><BR><BR>" // p;]; |
Examples of MP series
Work in UMassD
Unpublished reports