# Location of singularities of diagonal quadratic and differential approximants

## Mathematica program

 ```(* 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}]; ]; ]; " sect <> "\">
" // p; "" // p; "" // p; "" <> "
Location of singularities in the complex plane of the parameter z.
Left panel refers to quadratic approximants,
right panel to differential approximants." // p; If[mslist==1, "
Encircled area is a subjectively estimated location of\n
the dominant singularity zc = " <> print2a[singdom,2] <> "." // p ]; If[mslist==2, "
Encircled areas are subjectively estimated locations of\n
the dominant zc = " <> print2a[singdom,2] <> " and a subdominant z'c = " <> print2a[singsub,2] <> " singularities." // p ]; "
To view an individual approximant, click on the right bar.
To view all singularities with their weights, see this table.
" <> " sect <> ".gif?" <> rndm <> "\" WIDTH=766 HEIGHT=314 BORDER=0 ALT=\"Location of singularities in the complex plane\" USEMAP=\"#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] <> "]"; " 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}]; "" // p; printprogr[sect]; printnav, " sect <> "\">
" // p; "" // p; "
Singularities of approximants in the complex plane
are not shown for this example (" <> name <> ")
because number of available coefficients of the series (" <> ToString[nm] <> ")
is too small to construct a meaningful approximant
" // p; "    Top of the page     " // p; If[nser != 1, namem = names[[nser - 1]]; nameml = StringReplace[ToLowerCase[namem], "+" -> "-"]; ref = "../" <> nameml <> "/index.htm#" <> sect; "     ref <> "\">   ref <> "\">Prev. (" <> namem <> ")" // p]; "      Current (" <> name <> ")" // p; If[nser != mser, namep = names[[nser + 1]]; namepl = StringReplace[ToLowerCase[namep], "+" -> "-"]; ref = "../" <> namepl <> "/index.htm#" <> sect; "     ref <> "\">   ref <> "\">Next (" <> namep <> ")" // p]; "    " // p; "     sect <> ".htm\">   sect <> ".htm\">Mathematica program" // p; "

" // p;];```

 Examples of MP seriesMathematica programsWork in UMassDUnpublished reports

Designed by A. Sergeev.