# Table of singularities with their weights for quadratic and differential approximants

## Mathematica program

 (* Table of singularities with their weights for quadratic and differential approximants *) (* Options *) (*! was 15 *)mindlist = 20; (* number of approximants *) ncrop = 22; (* disregard coefficients with N>ncrop *) ncrop = 38; (* disregard coefficients with N>ncrop *) ndrop = 0; (* how many coeff. to drop from beginning of series *) xyrange = 2.5/asave[name]; (* plot range *) sect = "sngtable"; entity = "table"; 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 < 0 || nuse > nmax, Continue[]]; If[Abs[n1 - n2] > 1 || Abs[n2 - n3] > 1 || Abs[n3 - n1] > 1, Continue[]]; If[!(n3<=n2<=n1<=n3+1), Continue[]]; indlist = Append[indlist, {ind, prior, nuse}]; , {n2, 0, n1}, {n3, 0, n2}], {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]] &]; singsf = ToFileName[dir, "sings.htm"]; of = open[singsf]; "\n \n Singularities of Moller-Plesset series: example "" <> name <> ""\n \n \n \n

Singularities of Møller-Plesset series: example "" <> name <> ""

\n

Molecule " <> mol <> ". Basis "<> bas <> ". Structure "" <> fdat <> ""

" // p; "

Content

\n
\n
" // p; Clear[pol, c, funs]; Do[{{n1, n2, n3}, prior, nc} = indlist[[nind]]; indtxt = "[" <> ToString[n1] <> ", " <> ToString[n2] <> ", " <> ToString[n3] <> "]"; "
• ToString[nind] <> "\">Approximant " <> indtxt <> "" // p; 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)] &]; sqposit[nind] = sings = z /. sn; If[nc<=5, singularities[nser,nc]=sings//N; (*Print["Sing-s(",nc,"): ",singularities[nser,nc]]*)]; sqweight[nind] = 1/2 Sqrt[-z D[pold/pa^2, z]] /. sn; , {nind, mind}]; "
" // p; "
" // p; rulersing = StringReplace[ruler, "/index.htm\">"->"/sings.htm\">"]; "
" <> rulersing <> "
" // p; "
Plot of singularities" <> "" <> "List of examplesMathematica programsWork in UMassD " <> "Unpublished reports
\n \n \n \n \n \n \n \n \n \n
" // p; (* Definition of quadratic approximant *) "

\n

[n1n2n3] approximant is defined\n as a solution of the quadratic equation\n
A(z)f2 +  B(z)f +  C(z) = 0\n
with polynomial coefficients A(z),\n B(z) and\n C(z) of degree\n n3, n2 and n1 respectively.\n

Square-root singularities are determined as zeroes of the discriminant\n
D(z) = B2(z) - 4A(z)C(z).\n
The weight c of the singularity zc is defined so that\n
f ~ c(1 - z/zc)1/2 at z -> zc.\n
The weight is calculated by formula\n
c = 1/2[-z(D/A2)']1/2\n
where r. h. s. of the above equation is evaluated at z = zc.
" // p; Clear[pol, c, funs]; Do[{{n1, n2, n3}, prior, nc} = indlist[[nind]]; indtxt = "[" <> ToString[n1] <> ", " <> ToString[n2] <> ", " <> ToString[n3] <> "]"; "
ToString[nind] <> "\">\n

Table " <> ToString[nind] <> ". Singularities with their weights for the quadratic approximant " <> indtxt <> "
The most stable singularity is highlighted.
No. zcc Location in the complex plane
" <> hstart <> ToString[nsing] <> hend <> "
" <> If[nsing==nsing0, "", ""] <> print2a[sings[[nsing]],4] <> If[nsing==nsing0, "", ""] <> "
" <> hstart <> print2p[weights[[nsing]],3] <> hend <> "
ToString[nind] <> ".gif?" <> rndm <> "\" WIDTH=300 HEIGHT=300 ALT=\"Singularities of quadratic " <> indtxt <> " approximant\">
\n " // p; sings = sqposit[nind]//Chop//N; msing = Length[sings]; weights = sqweight[nind]//Chop//N; (*Stable singularity*) singsprev = If[nind == 1, sings, sqposit[nind - 1] // Chop // N]; singsnext = If[nind == mind, sings, sqposit[nind + 1] // Chop // N]; {mprev, mnext} = Length /@ {singsprev, singsnext}; stable = {Null, Null, Infinity}; Do[sing = sings[[n]]; If[Im[sing] < 0, Continue[]]; err1 = Abs[singsprev[[nprev]] - sing] + Abs[singsnext[[nnext]] - sing]; If[err1 < stable[[3]], stable = {sing, n, err1}], {n, msing}, {nprev, mprev}, {nnext, mnext}]; {sing0, nsing0, err0} = stable; Do[ hstart = If[nsing==nsing0, "", ""]; hend = If[nsing==nsing0, "", ""]; "" // p; If[nsing==1, "" // p]; "" // p; , {nsing, msing}]; "" // p; "  Top of the page    " // p; "
" // p; If[newfigure, sings0 = Union[{sing0}, {Conjugate[sing0]}]; xylist0 = {Re[#], Im[#]} & /@ sings0; xylist1 = {Re[#], Im[#]} & /@ sings; scale = 1.5; pltq0 = MultipleListPlot[xylist0, SymbolShape -> shape[1], SymbolStyle -> {{Thickness[0.008 scale], color[0]}}, TextStyle -> {FontFamily -> "Times New Roman", FontSize -> 12, FontSubstitutions -> {"Math1" -> "Symbol"}}, PlotRange -> xyrange{{-1, 1}, {-1, 1}}, AspectRatio -> 1, Frame -> True, ImageSize -> 300, DisplayFunction -> Identity]; scale = 0.9; pltq1 = MultipleListPlot[xylist1, SymbolShape -> shape[0], 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]; pltq = Show[pltq0, pltq1, DisplayFunction -> If[ifexport, Identity, \$DisplayFunction]]; If[ifexport, outfile = ToFileName[dir, "singsq" <>ToString[nind] <> ".gif"]; Export[outfile, pltq, "GIF", ImageSize -> 300, ImageResolution -> 72, ConversionOptions -> {"AnimationDisplayTime" -> 1, "Loop" -> True, "ColorReductionPalette" -> 16, "ColorReductionDither" -> False}]]; ]; , {nind,mind}]; "
" <> rulersing <> "
" // p; "
Plot of singularities" <> "" <> "List of examplesMathematica programsWork in UMassD " <> "Unpublished reports
\n \n \n \n \n \n \n \n \n \n
" // p; "

Designed by A. Sergeev.

" // p; close[singsf]; of = oexampf; printprogr[sect];

 Examples of MP seriesMathematica programsWork in UMassDUnpublished reports

Designed by A. Sergeev.