Location of singularities of diagonal quadratic and differential approximants

Mathematica program

(*Location of singularities of diagonal quadratic and differential approximants*)
sect = "sings3";
entity = "figure";
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, If[newfigure == True, Clear[pol, c, funs];
      prec = 256;
      setprec[z_] := SetPrecision[z, prec];
      xyrange = 1.7/asave[name];
      (*Presumed locations*)
      Clear[s1, s2, s3, s4, s5, s6, s7, s8, s9];
      s1 = -0.955 + 0.328 I;
      s2 = 0.058 + 0.923 I;
      s3 = 1.161 + 0.334 I;
      s4 = -0.955 - 0.328 I;
      s5 = 0.058 - 0.923 I;
      s6 = 1.161 - 0.334 I;
      slist = Select[{s1, s2, s3, s4, s5, s6, s7, s8, s9}, NumberQ];
      mslist = Length[slist];
      slist = {{Re[#], Im[#]}} & /@ slist;
      scale = 2.8;
      plts = If[mslist == 0, {},
          MultipleListPlot[Sequence @@ slist,
            SymbolShape -> shape[1],
            SymbolStyle -> {{Thickness[0.003 scale], color[0]}},
            PlotRange -> xyrange{{-1, 1}, {-1, 1}},
            AspectRatio -> 1,
            Frame -> True,
            ImageSize -> 400,
            DisplayFunction -> Identity]];
      pltseq = {};
      (*Cycle over indexes*)
      Do[
        {{n1, n2, n3}, prior, nc} = indlist[[nindlist]];
        cf = func // setprec;
        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;
        xylist = {Re[#], Im[#]} & /@ sings;
        xylist = 
          Select[xylist, (Abs[#[[1]]] < 1.05 xyrange && 
                  Abs[#[[2]]] < 1.05 xyrange) &];
        msing = Length[xylist];
        scale = (10/(msing + 1))^0.3;
        plt = 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 = (15/(msing + 1))^0.3;
        plt = 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[nindlist <= 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, 
    DisplayFunction -> Identity];
      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, mindlist}];
      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.
<BR>To view an individual approximant, click on the right bar.
</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=\"window.open('" <> ref <>
 "','Singularities','toolbar=no,status=no,scrollbars=no,
location=no,menubar=no,directories=no,width=776,height=324'); 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>&nbsp;&nbsp;
<A HREF=\"#top\">Top&nbsp;of&nbsp;the&nbsp;page</A>
&nbsp;&nbsp;&nbsp;&nbsp;" // p;
    If[nser != 1, namem = names[[nser - 1]];
      nameml = StringReplace[ToLowerCase[namem], "+" -> "-"];
      ref = "../" <> nameml <> "/index.htm#" <> sect;
      "&nbsp;&nbsp;&nbsp;&nbsp;<A HREF=\"" <> ref <> 
          "\"><IMG SRC=\"../../../../iconz/top270.gif\" WIDTH=9 HEIGHT=13
BORDER=0 ALT=\"Previous Example\" ALIGN=\"MIDDLE\"></A>&nbsp;&nbsp;
<A  HREF=\"" <> ref <> "\">Prev.&nbsp;(" <> namem <> ")</A>" // p];
    "&nbsp;&nbsp;&nbsp;&nbsp;<IMG SRC=\"../../../../blank.gif\" WIDTH=13
 HEIGHT=9 BORDER=0 ALT=\"Blank\" ALIGN=\"MIDDLE\">&nbsp;&nbsp;Current&nbsp;(" <>
         name <> ")" // p;
    If[nser != mser, namep = names[[nser + 1]];
      namepl = StringReplace[ToLowerCase[namep], "+" -> "-"];
      ref = "../" <> namepl <> "/index.htm#" <> sect;
      "&nbsp;&nbsp;&nbsp;&nbsp;<A HREF=\"" <> ref <> 
          "\"><IMG SRC=\"../../../../iconz/top90.gif\" WIDTH=9 HEIGHT=13
 BORDER=0 ALT=\"Next Example\" ALIGN=\"MIDDLE\"></A>&nbsp;&nbsp;<A HREF=\"" <> 
          ref <> "\">Next&nbsp;(" <> namep <> ")</A>" // p];
    "&nbsp;&nbsp;&nbsp;&nbsp;" // p;
    "&nbsp;&nbsp;&nbsp;&nbsp;<A HREF=\"../" <> sect <> 
        ".htm\"><IMG SRC=\"../../../../iconz/smalldig.gif\" WIDTH=12
 HEIGHT=17 BORDER=0 ALT=\"Mathematica program\"
 ALIGN=\"MIDDLE\"></A>&nbsp;&nbsp;<A HREF=\"../" <> sect <> 
        ".htm\"><I>Mathematica</I>&nbsp;program</A>" // p;
    "</FONT><BR><BR>" // p;];

All Mathematica programs used to study M. - P. series Blank Work in UMassD BlankWaste icon Unpublished reports

Designed by A. Sergeev.