dharr

Dr. David Harrington

9162 Reputation

22 Badges

21 years, 288 days
University of Victoria
Professor or university staff
Victoria, British Columbia, Canada

Social Networks and Content at Maplesoft.com

Maple Application Center
I am a retired professor of chemistry at the University of Victoria, BC, Canada. My research areas are electrochemistry and surface science. I have been a user of Maple since about 1990.

MaplePrimes Activity


These are Posts that have been published by dharr

Recently @salim-barzani asked a question about a paper that involved analysing the different types of roots of polynomials. The appendix in that paper gave the example of the roots of x^4+x^2*e[2]+x*e[1]+e[0]using the analysis in Lu et al, "A complete discrimination system for polynomials", Science in China (Ser. E), 39 (1996) 628-646. The analysis uses the discriminant sequence and extensions. Maple provides this through RegularChains:-ParametricSystemTools:-DiscrminantSequence. For example for this polynomial we find there is a real root of multiplicity 2 and a complex conjugate pair when D__2*D__3 < 0 and D__4 = 0 where the D__i are the ith entries in the discriminant sequence [1, -e[2], -2*e[2]^3+8*e[0]*e[2]-9*e[1]^2, 16*e[0]*e[2]^4-4*e[1]^2*e[2]^3-128*e[0]^2*e[2]^2+144*e[0]*e[1]^2*e[2]-27*e[1]^4+256*e[0]^3].

 

The problem with these conditions is that they are in terms of the D__i and not directly in terms of the e__i parameters. One can derive these conditions and then solve them to find the conditions on the parameters, but Maple has various routines in the RegularChains, RootFinding:-Parametric and SolveTools packages that directly find conditions on parameters to find when there are specified numbers of real or complex roots for polynomial systems. So this post is my attempt to use these tools to find the conditions on the parameters of the above polynomial that give various types of roots. One immediate difficulty is that generally these routines count distinct roots irrespective of multiplicity, and so some indirect analysis is required. There are several different types of commands and analyses that could be used, and my choices here are more to do with my learning experience than an optimum analysis.

 

The first conclusion is that it is possible, although RealComprehensiveTriangularize did not work as I expected when asking for zero real roots (see cases (a) and (b)) (bug?). Assuming it had worked, RealComprehensiveTriangularize could cover all the cases here, though that will not be true when there are more parameters. There doesn't seem to be an obvious systematic way of doing this analysis, which is a downside. Another downside is the large number of subcase conditions, which look as if they could be combined into fewer subcases. CellDecomposition works well for cases without multiplicity.


Main worksheet [not all is displayed below]:

Download RootAnalysis4.mw

restart

with(RegularChains); with(ParametricSystemTools); with(RootFinding:-Parametric)

Consider the following polynomial in x with the three real parameters e[0], e[1], e[2]. We would like to know the conditions on these parameters that lead to different numbers of real and complex-conjugate pairs of roots of different multiplicities.

p := x^4+x^2*e[2]+x*e[1]+e[0]

x^4+x^2*e[2]+x*e[1]+e[0]

Consider first how many cases there are. We can set this up as a combinatorial problem in the combstruct package.

sys := {C = Atom, R = Atom, realrts = Set(multiplereal), rts = Prod(realrts, complexrts), complexpr = Prod(C, C), complexrts = Set(multiplecomplex), multiplecomplex = Sequence(complexpr, card > 0), multiplereal = Sequence(R, card > 0)}

Draw := proc (q) options operator, arrow; eval(q, {Epsilon = NULL, Prod = `[]`, Set = (proc () options operator, arrow; args end proc), Sequence = `*`}) end proc

For a degree 4 polynomial there are 9 different cases to consider. Here [C, C] means a (non-real) complex-conjugate pair of roots and R means a real root; the exponents indicate the multiplicities.

all := combstruct:-allstructs([rts, sys], size = degree(p, x)); nops(%); `~`[Draw](all)

9

[[[C, C]^2], [[C, C], [C, C]], [R^2, [C, C]], [R^4], [R, R, [C, C]], [R^2, R^2], [R^3, R], [R, R, R^2], [R, R, R, R]]

These are (in order)
(a) A duplicate pair of complex-conjugate roots

(b) Two distinct pairs of complex-conjugate roots

(c) A real root of multiplicity 2 and a pair of complex-conjugate roots

(d) A real root of multiplicity 4

(e) Two distinct real roots of multiplicity 1 and a complex-conjugate pair

(f) Two distinct real roots each of multiplicity 2

(g) A real root of multiplicity 3 and a real root of multiplicity 1

(h) Three distinct real roots, of multiplicities 2, 1, and 1

(i) Four distinct real roots of multiplicity 1

Declare the variables first and parameters last. np is the number of parameters. Use the suggested order.

vp := SuggestVariableOrder([p = 0], [x]); R := PolynomialRing(vp); np := nops(`minus`({vp[]}, {x}))

[x, e[0], e[1], e[2]]

polynomial_ring

3

Define derivative polynomials. p2 = 0 when there is a root of multiplicity 2 or more; p3 = 0 when there is a root of multiplicity 3 or more and p4 = 0when there is a root of multiplicity 4.

p2 := diff(p, x); p3 := diff(p2, x); p4 := diff(p3, x)

4*x^3+2*x*e[2]+e[1]

12*x^2+2*e[2]

24*x

Discriminant is zero if and only if there are repeated roots.

Delta := discrim(p, x)

16*e[0]*e[2]^4-4*e[1]^2*e[2]^3-128*e[0]^2*e[2]^2+144*e[0]*e[1]^2*e[2]-27*e[1]^4+256*e[0]^3

(d) A real root of multiplicity 4

 

This is perhaps the simplest case and can be done using RealComprehensiveTriangularize. Specifying np = 3 means use the last 3 variables in the PolynomialRing as parameters. The argument 1 means we want the cases where there is one distinct real root. We specify that all of p, p2, p3, p4 are zero so that the 1 real root is the common root of these polynomials, i.e., is a root on multiplicity 4. (I find the cadcell output a little easier to use, but it is not critical.)

rct := RealComprehensiveTriangularize({p = 0, p2 = 0, p3 = 0, p4 = 0}, np, R, 1, output = cadcell); Display(rct, R)

PiecewiseTools:-Is, "Wrong kind of parameters in piecewise"

This means that the conditions on the parameters to get a single real root of multiplicity 4 are

conds := Info(rct[2][1][1], R)

[e[2] = 0, e[1] = 0, e[0] = 0]

and that the polynomial to solve to find this root under these conditions is

poly := Info(rct[1][][2], R)

[x = 0]

which we can check:

eval(p, conds); solve(%, x)

x^4

0, 0, 0, 0

(g) A real root of multiplicity 3 and a real root of multiplicity 1

   

(f) Two distinct real roots each of multiplicity 2

   

(i) Four distinct real roots of multiplicity 1

   

(h) Three distinct real roots, of multiplicities 2, 1, and 1

   

(e) Two distinct real roots of multiplicity 1 and a complex-conjugate pair

   

(c) A real root of multiplicity 2 and a pair of complex-conjugate roots

   

(b) Two distinct pairs of complex-conjugate roots

   

(a) A duplicate pair of complex-conjugate roots

 

Here we want multiplicity 2 but no real roots. The discriminant is expected to be zero, but in most cases is not.

rct := RealComprehensiveTriangularize({p = 0, p2 = 0, p3 <> 0, p4 <> 0}, np, R, 0, output = cadcell); nops(rct[2]); Display(rct[2][1 .. 4], R)

40

[[PIECEWISE([e[0] < RootOf(256*_Z^3-128*e[2]^2*_Z^2+(16*e[2]^4+144*e[1]^2*e[2])*_Z-4*e[1]^2*e[2]^3-27*e[1]^4, index = real[1]), ``], [e[1] < -(2/9)*(-6*e[2]^3)^(1/2), ``], [e[2] < 0, ``]), []], [PIECEWISE([RootOf(256*_Z^3-128*e[2]^2*_Z^2+(16*e[2]^4+144*e[1]^2*e[2])*_Z-4*e[1]^2*e[2]^3-27*e[1]^4, index = real[1]) < e[0], ``], [e[1] < -(2/9)*(-6*e[2]^3)^(1/2), ``], [e[2] < 0, ``]), []], [PIECEWISE([e[0] < -(1/12)*e[2]^2, ``], [e[1] = -(2/9)*(-6*e[2]^3)^(1/2), ``], [e[2] < 0, ``]), []], [PIECEWISE([e[0] = -(1/12)*e[2]^2, ``], [e[1] = -(2/9)*(-6*e[2]^3)^(1/2), ``], [e[2] < 0, ``]), []]]

Consider one of the cases with an equality for e[0], suggesting a zero discriminant.
Find a sample point satisfying the conditions, and see what the roots are like

j := 37; cell := rct[2][j][1]; conds := Info(cell, R); pts := Info(SamplePoints(cell, R), R)[1]; `~`[is](eval(conds, pts))

37

cad_cell

[0 < e[2], e[1] = 0, e[0] = (1/4)*e[2]^2]

[e[0] = 1/16, e[1] = 0, e[2] = 1/2]

[true, true, true]

We find two complex roots of multiplicity 2, which are complex conjugates, as expected

eval(p, pts); solve(%, x)

x^4+(1/2)*x^2+1/16

(1/2)*I, -(1/2)*I, (1/2)*I, -(1/2)*I

Check that discriminant is zero.

eval(Delta, pts)

0

But, for example, the first cell does not have the discriminant zero, and does not give a correct result.

j := 1; cell := rct[2][j][1]; conds := Info(cell, R); pts := Info(SamplePoints(cell, R), R)[1]; `~`[is](eval(conds, pts))

1

cad_cell

[e[2] < 0, e[1] < -(2/9)*(-6*e[2]^3)^(1/2), e[0] < RootOf(256*_Z^3-128*e[2]^2*_Z^2+(16*e[2]^4+144*e[1]^2*e[2])*_Z-4*e[1]^2*e[2]^3-27*e[1]^4, index = real[1])]

[e[0] = 1/2, e[1] = -3/2, e[2] = -1/2]

[true, true, true]

We find a complex conjugate pair and two distinct real roots, which is not expected for this case.

eval(p, pts); fsolve(%, x, complex)

x^4-(1/2)*x^2-(3/2)*x+1/2

-.7473459056-.9001675303*I, -.7473459056+.9001675303*I, .3077440660, 1.186947745

The discriminant is indeed nonzero.

eval(Delta, pts)

-3073/16

We did not yet find the conditions for this case. We can ask for the conditions for different numbers of complex roots (complex in this context includes real).

cmplx := ComplexRootClassification([p], np, R)

[[constructible_set, 1], [constructible_set, 2], [constructible_set, 3], [constructible_set, 4]]

We are interested in the conditions for exactly two distinct roots, which is found from the second constructible_set. There are two subcases.

Display(cmplx[2][1], R)

PIECEWISE([12*e[0]+e[2]^2 = 0, ``], [27*e[1]^2+8*e[2]^3 = 0, ``], [e[2] <> 0, ``]), PIECEWISE([4*e[0]-e[2]^2 = 0, ``], [e[1] = 0, ``], [e[2] <> 0, ``])

Consider the second case

case2 := Info(cmplx[2][1], R)[2]

[[4*e[0]-e[2]^2, e[1]], [e[2]]]

solve(case2[1], {e[0], e[1]}); q1 := eval(p, %); rts2 := [solve(%, x)]

{e[0] = (1/4)*e[2]^2, e[1] = 0}

x^4+x^2*e[2]+(1/4)*e[2]^2

[(1/2)*(-2*e[2])^(1/2), -(1/2)*(-2*e[2])^(1/2), (1/2)*(-2*e[2])^(1/2), -(1/2)*(-2*e[2])^(1/2)]

We saw this before when e[2]<0 as case (f) with real roots of multiplicity 2. Now, for e[2]>0 we indeed have two duplicate pairs of complex conjugate roots

`assuming`([simplify(rts2)], [e[2] > 0])

[((1/2)*I)*2^(1/2)*e[2]^(1/2), -((1/2)*I)*2^(1/2)*e[2]^(1/2), ((1/2)*I)*2^(1/2)*e[2]^(1/2), -((1/2)*I)*2^(1/2)*e[2]^(1/2)]

Consider the first case

case1 := Info(cmplx[2][1], R)[1]

[[12*e[0]+e[2]^2, 27*e[1]^2+8*e[2]^3], [e[2]]]

ans1 := {solve(case1[1], {e[0], e[1]}, explicit)}; q11 := eval(p, ans1[1]); rts11 := [solve(%, x, explicit)]

{{e[0] = -(1/12)*e[2]^2, e[1] = -(2/9)*(-6*e[2])^(1/2)*e[2]}, {e[0] = -(1/12)*e[2]^2, e[1] = (2/9)*(-6*e[2])^(1/2)*e[2]}}

x^4+x^2*e[2]-(2/9)*x*(-6*e[2])^(1/2)*e[2]-(1/12)*e[2]^2

[(1/6)*(-6*e[2])^(1/2), (1/6)*(-6*e[2])^(1/2), (1/6)*(-6*e[2])^(1/2), -(1/2)*(-6*e[2])^(1/2)]

The rts11 subcase polynomial q11 must have real coefficients and therefore only applies for e[2]<0. The roots are real with multiplicity 3 and multiplicity 1 and this case is just case (g) above. The rts12 subcase polynomial q12 (below) also requires e[2]<0 and corresponds to case (g), but with signs reversed.

q12 := eval(p, ans1[2]); rts12 := [solve(%, x, explicit)]

x^4+x^2*e[2]+(2/9)*x*(-6*e[2])^(1/2)*e[2]-(1/12)*e[2]^2

[(1/2)*(-6*e[2])^(1/2), -(1/6)*(-6*e[2])^(1/2), -(1/6)*(-6*e[2])^(1/2), -(1/6)*(-6*e[2])^(1/2)]

Therefore the rts2 case is the solution for case (a); the cell37 example was a special case of this. In fact if we have a duplicate pair of complex-conjugate roots, the polynomial must be a pefect square, as we see it is

factor(q1)

(1/4)*(2*x^2+e[2])^2

NULL

Download RootAnalysis5.mw

 

[Edit: a general procedure based on these ideas is given below.]

Maple's isolve can solve some but not all of the quadratic equations in two variables describing the conic sections. Here I show that by transforming the equations, Maple can then solve these missing cases.

restart

with(plots)

I was recently surprised that isolve cannot solve the following simple Diophantine equation

isolve(2*x^2+4*x*y+y^2 = 7)

which has the obvious (to a human) solution {x = 1, y = 1}. This led me to think about the case of conic sections, which have the following general equation (= 0 implied), where I assume a, () .. (), f are integers.

P := a*x^2+b*x*y+c*y^2+d*x+e*y+f

a*x^2+b*x*y+c*y^2+d*x+e*y+f

The above equation has discriminant -4*a*c+b^2 positive, indicating that is is a hyperbola.

h_params := {a = 2, b = 4, c = 1, d = 0, e = 0, f = -7}; P__h := eval(P, h_params); disc := -4*a*c+b^2; eval(disc, h_params); plot__h := implicitplot(P__h, x = -10 .. 10, y = -10 .. 10, colour = red)

{a = 2, b = 4, c = 1, d = 0, e = 0, f = -7}

2*x^2+4*x*y+y^2-7

-4*a*c+b^2

8

Here's a parabola case (discriminant = 0) that isolve also has trouble with

p_params := {a = 2, b = 4, c = 2, d = 1, e = 2, f = 7}; eval(disc, p_params); P__p := eval(P, p_params); {isolve(P__p)}; plot__h := implicitplot(P__p, x = -10 .. 10, y = -10 .. 10, colour = red)

{a = 2, b = 4, c = 2, d = 1, e = 2, f = 7}

0

2*x^2+4*x*y+2*y^2+x+2*y+7

{}

But this has at least one solution

eval(P__p, {x = 7, y = -7})

0

Maple seems to do better in the elliptic case (discriminant negative) and finds two solutions. Examination of the plot suggests there are no other solutions.

e_params := {a = 2, b = 4, c = 3, d = 1, e = 2, f = -7}; eval(disc, e_params); P__e := eval(P, e_params); {isolve(P__e)}; plot__e := implicitplot(P__e, x = -10 .. 10, y = -10 .. 10, colour = red)

{a = 2, b = 4, c = 3, d = 1, e = 2, f = -7}

-8

2*x^2+4*x*y+3*y^2+x+2*y-7

{{x = -3, y = 2}, {x = 2, y = -3}}

I show that transformation of the general equation to the form -D*Y^2+X^2 = m, where D is the discriminant, allows Maple to solve the hyperbolic case, as well as the elliptic case it already knows how to solve; another transformation works for the parabolic case. Maple appears to be able to solve all (solvable) cases of the transformed equations, though this is not clear from the help page. The transformation is discussed in Bogdan Grechuk, Polynomial Diophantine Equations: A Systematic Approach, Springer, 2024, Sec. 3.1.7. doi: 10.1007/978-3-031-62949-5

 

A complete classification of the conics, including degenerate cases, is given in https://en.wikipedia.org/wiki/Matrix_representation_of_conic_sections. If the determinant, delta, of the following matrix is zero, we have a degenerate case.

A__Q := Matrix(3, 3, [a, (1/2)*b, (1/2)*d, (1/2)*b, c, (1/2)*e, (1/2)*d, (1/2)*e, f]); delta := LinearAlgebra:-Determinant(A__Q)

Matrix(%id = 36893489963432522084)

a*c*f-(1/4)*a*e^2-(1/4)*b^2*f+(1/4)*b*d*e-(1/4)*c*d^2

The case of a = b and b = c and c = 0 is just the linear case, which Maple can solve, and is one case where D = delta and delta = 0. Other degenerate parabola cases are two coincident lines or two parallel lines. Degenerate hyperbolas are two intersecting lines, and degenerate ellipses are a single point. Maple can solve all these cases, e.g.,NULL

expand((2*x+3*y+1)*(2*x+3*y)); {isolve(%)}; expand((2*x+3*y)*(2*x+3*y)); {isolve(%)}; expand((x-2)*(y-3)); {isolve(%)}; x^2+y^2 = 0; {isolve(%)}

4*x^2+12*x*y+9*y^2+2*x+3*y

{{x = -3*_Z1, y = 2*_Z1}, {x = -2-3*_Z1, y = 1+2*_Z1}}

4*x^2+12*x*y+9*y^2

{{x = -3*_Z1, y = 2*_Z1}}

x*y-3*x-2*y+6

{{x = _Z1, y = 3}}

x^2+y^2 = 0

{{x = 0, y = 0}}

(The intersecting lines case above only finds one of the lines.) The transformation will consider only the case where at least one of a or c is non-zero. This misses hyperbolas with a = c and c = 0; Maple seems to handle these bilinear equations, e.g.,

bl_params := {a = 0, b = 2, c = 0, d = 1, e = 1, f = 2}; P__bl := eval(P, bl_params); {isolve(P__bl)}

{a = 0, b = 2, c = 0, d = 1, e = 1, f = 2}

2*x*y+x+y+2

{{x = -2, y = 0}, {x = -1, y = 1}, {x = 0, y = -2}, {x = 1, y = -1}}

Transformation for non-zero discriminant
At least one of a or c must be non-zero; if necessary exchange x and y to ensure a is non-zero.

We multiply P by -4*a*(-4*a*c+b^2) and change to new variables X and Y.

itr := {X = (-4*a*c+b^2)*y+b*d-2*a*e, Y = 2*a*x+b*y+d}; tr := solve(itr, {x, y})

{X = (-4*a*c+b^2)*y+b*d-2*a*e, Y = 2*a*x+b*y+d}

{x = (1/2)*(4*Y*a*c-Y*b^2+2*a*b*e-4*a*c*d+X*b)/((4*a*c-b^2)*a), y = -(2*a*e-b*d+X)/(4*a*c-b^2)}

The transformed equation has the form -D*Y^2+X^2-m = 0 or -D*Y^2+X^2 = m, where D is the discriminant.

Q := collect(normal(eval(-4*P*a*(-4*a*c+b^2), tr)), {X, Y}); m := -coeff(coeff(Q, X, 0), Y, 0)

X^2+(4*a*c-b^2)*Y^2+16*a^2*c*f-4*a^2*e^2-4*a*b^2*f+4*a*b*d*e-4*a*c*d^2

-16*a^2*c*f+4*a^2*e^2+4*a*b^2*f-4*a*b*d*e+4*a*c*d^2

For positive discriminant D, this is a general Pell's equation, -D*Y^2+X^2 = m, which Maple knows how to solve. (The definition of Pell's equation requires that D is not a square, but Maple can also solve the simpler case where D is a square.) For the hyperbola above, we have an infinite number of solutions, parameterized by an arbitrary integer _Z1.

Q__h := eval(Q, h_params); solXY__h := {isolve(Q__h)}

X^2-8*Y^2+448

{{X = -12*(1+2^(1/2))^(1+2*_Z1)-12*(1-2^(1/2))^(1+2*_Z1)-4*2^(1/2)*((1+2^(1/2))^(1+2*_Z1)-(1-2^(1/2))^(1+2*_Z1)), Y = -3*2^(1/2)*((1+2^(1/2))^(1+2*_Z1)-(1-2^(1/2))^(1+2*_Z1))-2*(1+2^(1/2))^(1+2*_Z1)-2*(1-2^(1/2))^(1+2*_Z1)}, {X = -12*(1+2^(1/2))^(1+2*_Z1)-12*(1-2^(1/2))^(1+2*_Z1)-4*2^(1/2)*((1+2^(1/2))^(1+2*_Z1)-(1-2^(1/2))^(1+2*_Z1)), Y = 3*2^(1/2)*((1+2^(1/2))^(1+2*_Z1)-(1-2^(1/2))^(1+2*_Z1))+2*(1+2^(1/2))^(1+2*_Z1)+2*(1-2^(1/2))^(1+2*_Z1)}, {X = -12*(1+2^(1/2))^(1+2*_Z1)-12*(1-2^(1/2))^(1+2*_Z1)+4*2^(1/2)*((1+2^(1/2))^(1+2*_Z1)-(1-2^(1/2))^(1+2*_Z1)), Y = -3*2^(1/2)*((1+2^(1/2))^(1+2*_Z1)-(1-2^(1/2))^(1+2*_Z1))+2*(1+2^(1/2))^(1+2*_Z1)+2*(1-2^(1/2))^(1+2*_Z1)}, {X = -12*(1+2^(1/2))^(1+2*_Z1)-12*(1-2^(1/2))^(1+2*_Z1)+4*2^(1/2)*((1+2^(1/2))^(1+2*_Z1)-(1-2^(1/2))^(1+2*_Z1)), Y = 3*2^(1/2)*((1+2^(1/2))^(1+2*_Z1)-(1-2^(1/2))^(1+2*_Z1))-2*(1+2^(1/2))^(1+2*_Z1)-2*(1-2^(1/2))^(1+2*_Z1)}, {X = 12*(1+2^(1/2))^(1+2*_Z1)+12*(1-2^(1/2))^(1+2*_Z1)-4*2^(1/2)*((1+2^(1/2))^(1+2*_Z1)-(1-2^(1/2))^(1+2*_Z1)), Y = -3*2^(1/2)*((1+2^(1/2))^(1+2*_Z1)-(1-2^(1/2))^(1+2*_Z1))+2*(1+2^(1/2))^(1+2*_Z1)+2*(1-2^(1/2))^(1+2*_Z1)}, {X = 12*(1+2^(1/2))^(1+2*_Z1)+12*(1-2^(1/2))^(1+2*_Z1)-4*2^(1/2)*((1+2^(1/2))^(1+2*_Z1)-(1-2^(1/2))^(1+2*_Z1)), Y = 3*2^(1/2)*((1+2^(1/2))^(1+2*_Z1)-(1-2^(1/2))^(1+2*_Z1))-2*(1+2^(1/2))^(1+2*_Z1)-2*(1-2^(1/2))^(1+2*_Z1)}, {X = 12*(1+2^(1/2))^(1+2*_Z1)+12*(1-2^(1/2))^(1+2*_Z1)+4*2^(1/2)*((1+2^(1/2))^(1+2*_Z1)-(1-2^(1/2))^(1+2*_Z1)), Y = -3*2^(1/2)*((1+2^(1/2))^(1+2*_Z1)-(1-2^(1/2))^(1+2*_Z1))-2*(1+2^(1/2))^(1+2*_Z1)-2*(1-2^(1/2))^(1+2*_Z1)}, {X = 12*(1+2^(1/2))^(1+2*_Z1)+12*(1-2^(1/2))^(1+2*_Z1)+4*2^(1/2)*((1+2^(1/2))^(1+2*_Z1)-(1-2^(1/2))^(1+2*_Z1)), Y = 3*2^(1/2)*((1+2^(1/2))^(1+2*_Z1)-(1-2^(1/2))^(1+2*_Z1))+2*(1+2^(1/2))^(1+2*_Z1)+2*(1-2^(1/2))^(1+2*_Z1)}}

Transforming back to the original coordinates

sol__h := {seq(eval(eval(tr, h_params), solXY), `in`(solXY, solXY__h))}

{{x = -2*(1+2^(1/2))^(1+2*_Z1)-2*(1-2^(1/2))^(1+2*_Z1)-(5/4)*2^(1/2)*((1+2^(1/2))^(1+2*_Z1)-(1-2^(1/2))^(1+2*_Z1)), y = (3/2)*(1+2^(1/2))^(1+2*_Z1)+(3/2)*(1-2^(1/2))^(1+2*_Z1)+(1/2)*2^(1/2)*((1+2^(1/2))^(1+2*_Z1)-(1-2^(1/2))^(1+2*_Z1))}, {x = -2*(1+2^(1/2))^(1+2*_Z1)-2*(1-2^(1/2))^(1+2*_Z1)+(5/4)*2^(1/2)*((1+2^(1/2))^(1+2*_Z1)-(1-2^(1/2))^(1+2*_Z1)), y = (3/2)*(1+2^(1/2))^(1+2*_Z1)+(3/2)*(1-2^(1/2))^(1+2*_Z1)-(1/2)*2^(1/2)*((1+2^(1/2))^(1+2*_Z1)-(1-2^(1/2))^(1+2*_Z1))}, {x = -(1+2^(1/2))^(1+2*_Z1)-(1-2^(1/2))^(1+2*_Z1)-(1/4)*2^(1/2)*((1+2^(1/2))^(1+2*_Z1)-(1-2^(1/2))^(1+2*_Z1)), y = (3/2)*(1+2^(1/2))^(1+2*_Z1)+(3/2)*(1-2^(1/2))^(1+2*_Z1)-(1/2)*2^(1/2)*((1+2^(1/2))^(1+2*_Z1)-(1-2^(1/2))^(1+2*_Z1))}, {x = -(1+2^(1/2))^(1+2*_Z1)-(1-2^(1/2))^(1+2*_Z1)+(1/4)*2^(1/2)*((1+2^(1/2))^(1+2*_Z1)-(1-2^(1/2))^(1+2*_Z1)), y = (3/2)*(1+2^(1/2))^(1+2*_Z1)+(3/2)*(1-2^(1/2))^(1+2*_Z1)+(1/2)*2^(1/2)*((1+2^(1/2))^(1+2*_Z1)-(1-2^(1/2))^(1+2*_Z1))}, {x = (1+2^(1/2))^(1+2*_Z1)+(1-2^(1/2))^(1+2*_Z1)-(1/4)*2^(1/2)*((1+2^(1/2))^(1+2*_Z1)-(1-2^(1/2))^(1+2*_Z1)), y = -(3/2)*(1+2^(1/2))^(1+2*_Z1)-(3/2)*(1-2^(1/2))^(1+2*_Z1)-(1/2)*2^(1/2)*((1+2^(1/2))^(1+2*_Z1)-(1-2^(1/2))^(1+2*_Z1))}, {x = (1+2^(1/2))^(1+2*_Z1)+(1-2^(1/2))^(1+2*_Z1)+(1/4)*2^(1/2)*((1+2^(1/2))^(1+2*_Z1)-(1-2^(1/2))^(1+2*_Z1)), y = -(3/2)*(1+2^(1/2))^(1+2*_Z1)-(3/2)*(1-2^(1/2))^(1+2*_Z1)+(1/2)*2^(1/2)*((1+2^(1/2))^(1+2*_Z1)-(1-2^(1/2))^(1+2*_Z1))}, {x = 2*(1+2^(1/2))^(1+2*_Z1)+2*(1-2^(1/2))^(1+2*_Z1)-(5/4)*2^(1/2)*((1+2^(1/2))^(1+2*_Z1)-(1-2^(1/2))^(1+2*_Z1)), y = -(3/2)*(1+2^(1/2))^(1+2*_Z1)-(3/2)*(1-2^(1/2))^(1+2*_Z1)+(1/2)*2^(1/2)*((1+2^(1/2))^(1+2*_Z1)-(1-2^(1/2))^(1+2*_Z1))}, {x = 2*(1+2^(1/2))^(1+2*_Z1)+2*(1-2^(1/2))^(1+2*_Z1)+(5/4)*2^(1/2)*((1+2^(1/2))^(1+2*_Z1)-(1-2^(1/2))^(1+2*_Z1)), y = -(3/2)*(1+2^(1/2))^(1+2*_Z1)-(3/2)*(1-2^(1/2))^(1+2*_Z1)-(1/2)*2^(1/2)*((1+2^(1/2))^(1+2*_Z1)-(1-2^(1/2))^(1+2*_Z1))}}

Evaluate for some _Z1 values, say _Z1=0 and _Z1=5.
It is evident from tr above that integer solutions in X, Y may transform to non-integer solutions in x, y but that doesn't occur for these two cases

sol__h0 := evala(eval(sol__h, _Z1 = 0)); sol__h5 := evala(eval(sol__h, _Z1 = 5))

{{x = -9, y = 5}, {x = -3, y = 1}, {x = -1, y = -1}, {x = -1, y = 5}, {x = 1, y = -5}, {x = 1, y = 1}, {x = 3, y = -1}, {x = 9, y = -5}}

{{x = -61181, y = 35839}, {x = -21979, y = 12875}, {x = -10497, y = 35839}, {x = -3771, y = 12875}, {x = 3771, y = -12875}, {x = 10497, y = -35839}, {x = 21979, y = -12875}, {x = 61181, y = -35839}}

Check they are solutions to P__h

map2(eval, P__h, `union`(sol__h0, sol__h5))

{0}

For negative discriminant and negative m, the equation -D*Y^2+X^2 = m has no solutions. In the classification scheme for the conics, the "imaginary ellipse" case (no real solutions) occurs when (a+c)*delta > 0. For negative discriminant, we must have a and c the same sign, and this is the case of negative m.

factor(expand((16*(a+c))*delta)); factor(-m)

4*(a+c)*(4*a*c*f-a*e^2-b^2*f+b*d*e-c*d^2)

4*a*(4*a*c*f-a*e^2-b^2*f+b*d*e-c*d^2)

. In this case Maple returns NULL for both the untransformed and transformed case, which can mean no solutions or just that isolve couldn't find any.

ie_params := {a = 3, b = 0, c = 5, d = 0, e = 0, f = 8}; P__ie := eval(P, ie_params); {isolve(P__ie)}; Q__ie := eval(Q, ie_params); {isolve(Q__ie)}

{a = 3, b = 0, c = 5, d = 0, e = 0, f = 8}

3*x^2+5*y^2+8

{}

X^2+60*Y^2+5760

{}

For negative discriminant and positive m or (a+c)*delta < 0, the ellipse is real, and there are a finite number of solutions. Maple solves the untransformed and transformed equations.
Here we need to filter out non-integer solutions

P__e; {isolve(P__e)}; Q__e := eval(Q, e_params); solXY__e := {isolve(Q__e)}; {seq(eval(eval(tr, e_params), solXY), `in`(solXY, solXY__e))}; sol__e := select(proc (q) options operator, arrow; eval(x::integer, q) and eval(y::integer, q) end proc, %)

2*x^2+4*x*y+3*y^2+x+2*y-7

{{x = -3, y = 2}, {x = 2, y = -3}}

X^2+8*Y^2-472

{{X = -20, Y = -3}, {X = -20, Y = 3}, {X = 20, Y = -3}, {X = 20, Y = 3}}

{{x = -3, y = 2}, {x = 2, y = -3}, {x = -3/2, y = 2}, {x = 7/2, y = -3}}

{{x = -3, y = 2}, {x = 2, y = -3}}

Transformation for zero discriminant
For the case of zero discriminant (parabola), we need a different transformation.

itr0 := {X = 2*a*x+b*y+d, Y = y}; tr0 := solve(itr0, {x, y})

{X = 2*a*x+b*y+d, Y = y}

{x = (1/2)*(-Y*b+X-d)/a, y = Y}

The transformed equation is of the form A*Y+X^2+B = 0

Q0 := collect(normal(eval(4*a*P, tr0)), {X, Y})

X^2+(4*a*c-b^2)*Y^2+(4*a*e-2*b*d)*Y+4*f*a-d^2

We consider the parabolic example above, for which Maple finds no solutions without transformation.

P__p; {isolve(P__p)}

2*x^2+4*x*y+2*y^2+x+2*y+7

{}

For the transformed problem, Maple finds an infinite number of solutions

Q__p := eval(Q0, p_params); solXY__p := {isolve(Q__p)}; sol__p := {seq(eval(eval(tr0, p_params), solXY), `in`(solXY, solXY__p))}

X^2+8*Y+55

{{X = 1+8*_Z1, Y = -8*_Z1^2-2*_Z1-7}, {X = 3+8*_Z1, Y = -8*_Z1^2-6*_Z1-8}, {X = 5+8*_Z1, Y = -8*_Z1^2-10*_Z1-10}, {X = 7+8*_Z1, Y = -8*_Z1^2-14*_Z1-13}}

{{x = 17/2+8*_Z1+8*_Z1^2, y = -8*_Z1^2-6*_Z1-8}, {x = 29/2+16*_Z1+8*_Z1^2, y = -8*_Z1^2-14*_Z1-13}, {x = 8*_Z1^2+4*_Z1+7, y = -8*_Z1^2-2*_Z1-7}, {x = 8*_Z1^2+12*_Z1+11, y = -8*_Z1^2-10*_Z1-10}}

Two of the general solutions will not give integer solutions, so could be filtered out, but it is easier to filter after choosing some specific _Z1 values.

eval(sol__p, _Z1 = 0); sol__p0 := select(proc (q) options operator, arrow; eval(x::integer, q) and eval(y::integer, q) end proc, %); eval(sol__p, _Z1 = 5); sol__p5 := select(proc (q) options operator, arrow; eval(x::integer, q) and eval(y::integer, q) end proc, %)

{{x = 7, y = -7}, {x = 11, y = -10}, {x = 17/2, y = -8}, {x = 29/2, y = -13}}

{{x = 7, y = -7}, {x = 11, y = -10}}

{{x = 227, y = -217}, {x = 271, y = -260}, {x = 497/2, y = -238}, {x = 589/2, y = -283}}

{{x = 227, y = -217}, {x = 271, y = -260}}

Check they are solutions to P__p

map2(eval, P__p, `union`(sol__p0, sol__p5))

{0}

NULL

Download DiophantineConics2.mw

Thanks to @salim-barzani, I became interested in the Laplace Adomian Decompositon method to solve partial differential equations. It produces a sum of analytical components that converge to the exact solution. Probably it is not that efficient for numerical solutions, but the possibility of finding an exact solution to nonlinear PDEs by finding a formula for the components and therefore the infinite sum is interesting.

The version here covers many of the common forms of PDEs, but is still a work in progress. The method for finding the Adomian polynomials could be improved by using one of the reccurence formulas in the literature. Extension to more PDE forms, ODEs etc are possible and I will attempt some of these before uploading an improved version to the application centre. In the meantime, feedback about bugs, usability etc. are appreciated.

Laplace Adomian Decomposition method to solve partial differential equations.
 D.A. Harrington, June 2025, v 1.16.
 Procedure LAD is in the startup code region.

Arguments:

1. 

Partial differential equation in one "time" variable and several other variables (called spatial variables here). Specified as an equation, or an expression implicitly equal to zero.
Comprising: (1) one time derivative term of order m (denoted L), (2) linear terms that are derivatives in the spatial variables (R), (3) nonlinear terms with derivatives in the spatial variables (N). Together, (1)-(3) is a multivariate polynomial in the dependent variable, its derivatives, and any parameters. (4) inhomogenous terms in the time and spatial variables that do not contain the dependent variable or its derivatives (G). The general form is L = R+N-G.
Any symbolic parameters are assumed to be real. Any numeric coefficients or parameters should be of type algebraic. Floating point values will be converted to rationals with convert(value, rational).

2. 

Function to solve for, e.g., u(x, y, t).

3. 

m initial condition(s) (at time zero). For m > 1, these must be in a list, and are the values of the function and its successive derivatives with respect to time, evaluated at time zero.

4. 

name of time variable.

5. 

number of iterations.

6. 

(optional) order for a fractional derivative, specified as fracorder = name or fracorder = numeric*value (floating point values are converted to type rational). The permissible values alpha are related to the value of m: m-1 < alpha and alpha <= m, i.e., an mth order time derivative is specified in the pde and m initial conditions are provided, as well as the value of alpha in the correct range. A symbolic alpha is assumed to be in this range.

infolevel[LAD] may be set to different values to print out additional information as follows. Greater numbers include the information from smaller values.

1. 

The nonlinear expansion variables (those in the Adomian polynomials).

2. 

The different parts of the the pde (L, R, N, G) in jet notation.

3. 

Progress is indicated, as the time at each iteration.

4. 

Values of the components of the solution as they are produced (one per iteration).

restart

It may be useful to load the Physics package if derivatives contain abs. LAD converts these to a form without abs but with the conjugate of the dependent variable. The Physics package affects the internal simplifications and may affect the form of the output or the running time.

PDEtools:-declare(U(x, t), quiet)

Example from A-M. Wazwaz, Applied Mathematics and Computation 111 (2000) 53. Sec. 4.

pde := diff(U(x, t), t)+U(x, t)^2*(diff(U(x, t), x)); inx := 3*x

diff(U(x, t), t)+U(x, t)^2*(diff(U(x, t), x))

3*x

infolevel[LAD] := 2

approx := LAD(pde, U(x, t), inx, t, 10)

LAD: L = U[t]; R = 0; N = -U^2*U[x]; G = 0.

LAD: nonlinear expansion variables (conjugated functions denoted by C) are: [U, U[x]]

175692092397588*t^10*x^11-5650915252554*t^9*x^10+184670433090*t^8*x^9-6155681103*t^7*x^8+210450636*t^6*x^7-7440174*t^5*x^6+275562*t^4*x^5-10935*t^3*x^4+486*t^2*x^3-27*t*x^2+3*x

By extrapolating to an infinite number of terms, we can find an exact solution. (Wazwaz calculates the coefficient of x^4*t^3 incorrectly and deduces an incorrect exact solution.) Multiplying by t gives a series in y = x*t for which guessgf can use the coefficients to find the exact solution.

algsubs(x*t = y, expand(approx*t)); [seq(coeff(%, y, i), i = 0 .. degree(%, y))]; gfun:-guessgf(%, y)[1]; exact := (eval(%, y = x*t))/t

175692092397588*y^11-5650915252554*y^10+184670433090*y^9-6155681103*y^8+210450636*y^7-7440174*y^6+275562*y^5-10935*y^4+486*y^3-27*y^2+3*y

[0, 3, -27, 486, -10935, 275562, -7440174, 210450636, -6155681103, 184670433090, -5650915252554, 175692092397588]

6*y/(1+(1+36*y)^(1/2))

6*x/(1+(36*t*x+1)^(1/2))

Check

pdetest(U(x, t) = exact, [pde, U(x, 0) = inx])

[0, 0]

An example with inhomogeneous terms (but no nonlinear part). Ex. 3 from R. Shah et al, Entropy 21 (2019) 335.

pde := diff(U(x, t), t)+diff(U(x, t), `$`(x, 3)) = -sin(Pi*x)*sin(t)-Pi^3*cos(Pi*x)*cos(t); inx := sin(Pi*x); exact := sin(Pi*x)*cos(t); pdetest(U(x, t) = exact, [pde, U(x, 0) = inx])

diff(U(x, t), t)+diff(diff(diff(U(x, t), x), x), x) = -sin(Pi*x)*sin(t)-Pi^3*cos(Pi*x)*cos(t)

sin(Pi*x)

sin(Pi*x)*cos(t)

[0, 0]

approx := LAD(pde, U(x, t), inx, t, 10)

LAD: L = U[t]; R = -U[x,x,x]; N = 0; G = -sin(Pi*x)*sin(t)-Pi^3*cos(Pi*x)*cos(t).

LAD: nonlinear expansion variables (conjugated functions denoted by C) are: []

sin(Pi*x)-cos(Pi*x)*Pi^3*sin(t)+sin(Pi*x)*(-1+cos(t))-Pi^3*(Pi^3*(-1+cos(t))*sin(Pi*x)-cos(Pi*x)*sin(t))+(Pi^3*(-sin(t)+t)*cos(Pi*x)+sin(Pi*x)*(-1+cos(t)))*Pi^6-(1/2)*Pi^9*(Pi^3*(t^2+2*cos(t)-2)*sin(Pi*x)+2*cos(Pi*x)*(-sin(t)+t))-(1/6)*Pi^12*(Pi^3*(t^3+6*sin(t)-6*t)*cos(Pi*x)-3*sin(Pi*x)*(t^2+2*cos(t)-2))+(1/24)*(Pi^3*(t^4-12*t^2-24*cos(t)+24)*sin(Pi*x)+4*cos(Pi*x)*(t^3+6*sin(t)-6*t))*Pi^15+(1/120)*Pi^18*(Pi^3*(t^5-20*t^3-120*sin(t)+120*t)*cos(Pi*x)-5*sin(Pi*x)*(t^4-12*t^2-24*cos(t)+24))-(1/720)*Pi^21*(Pi^3*(t^6-30*t^4+360*t^2+720*cos(t)-720)*sin(Pi*x)+6*cos(Pi*x)*(t^5-20*t^3-120*sin(t)+120*t))-(1/5040)*(Pi^3*(t^7-42*t^5+840*t^3+5040*sin(t)-5040*t)*cos(Pi*x)-7*sin(Pi*x)*(t^6-30*t^4+360*t^2+720*cos(t)-720))*Pi^24+(1/40320)*Pi^27*(Pi^3*(t^8-56*t^6+1680*t^4-20160*t^2-40320*cos(t)+40320)*sin(Pi*x)+8*cos(Pi*x)*(t^7-42*t^5+840*t^3+5040*sin(t)-5040*t))+(1/362880)*Pi^30*(Pi^3*(t^9-72*t^7+3024*t^5-60480*t^3-362880*sin(t)+362880*t)*cos(Pi*x)-9*sin(Pi*x)*(t^8-56*t^6+1680*t^4-20160*t^2-40320*cos(t)+40320))

Expand the exact solution as a series in t to the same order and verify that it is the same as above.

series(exact-approx, t, 11, oterm = false)

0

An example with a complex solution

pde := I*(diff(U(x, t), t))+diff(U(x, t), `$`(x, 2))+2*abs(U(x, t))^2*U(x, t); inx := sech(x); exact := sech(x)*exp(I*t); `assuming`([simplify(pdetest(U(x, t) = exact, [pde, U(x, 0) = inx]))], [real])

I*(diff(U(x, t), t))+diff(diff(U(x, t), x), x)+2*abs(U(x, t))^2*U(x, t)

sech(x)

sech(x)*exp(I*t)

[0, 0]

approx := LAD(pde, U(x, t), inx, t, 10)

LAD: L = I*U[t]; R = -U[x,x]; N = -2*U^2*C; G = 0.

LAD: nonlinear expansion variables (conjugated functions denoted by C) are: [C, U]

sech(x)+I*sech(x)*t-(1/2)*sech(x)*t^2-((1/6)*I)*sech(x)*t^3+(1/24)*sech(x)*t^4+((1/120)*I)*sech(x)*t^5-(1/720)*sech(x)*t^6-((1/5040)*I)*sech(x)*t^7+(1/40320)*sech(x)*t^8+((1/362880)*I)*sech(x)*t^9-(1/3628800)*sech(x)*t^10

The series for exp(I*t) is apparent.

collect(approx, sech); series(approx-exact, t, 11, oterm = false)

(1+I*t-(1/2)*t^2-((1/6)*I)*t^3+(1/24)*t^4+((1/120)*I)*t^5-(1/720)*t^6-((1/5040)*I)*t^7+(1/40320)*t^8+((1/362880)*I)*t^9-(1/3628800)*t^10)*sech(x)

0

An example with fractional order differentiation wrt t of order alpha. For m-1 < alpha and alpha <= m, the derivative must be entered with order m and there must be a list of m initial conditions:f(x, 0), (D[2](f))(x, 0), (D[2, 2](f))(x, 0), () .. ()

 Ex. 1 from R. Shah et al, Entropy 21 (2019) 335

pde := diff(U(x, t), t) = -2*(diff(U(x, t), x))-(diff(U(x, t), `$`(x, 3))); inx := sin(x)

diff(U(x, t), t) = -2*(diff(U(x, t), x))-(diff(diff(diff(U(x, t), x), x), x))

sin(x)

Symbolic order is accepted.

approx := LAD(pde, U(x, t), inx, t, 6, fracorder = alpha)

LAD: L = U[t]; R = -2*U[x]-U[x,x,x]; N = 0; G = 0.

LAD: nonlinear expansion variables (conjugated functions denoted by C) are: []

sin(x)-cos(x)*t^alpha/GAMMA(1+alpha)-sin(x)*t^(2*alpha)/GAMMA(1+2*alpha)+cos(x)*t^(3*alpha)/GAMMA(1+3*alpha)+sin(x)*t^(4*alpha)/GAMMA(1+4*alpha)-cos(x)*t^(5*alpha)/GAMMA(1+5*alpha)-sin(x)*t^(6*alpha)/GAMMA(1+6*alpha)

Giving a numerical value for the order will generally be more efficient. For alpha = 1/2, we can find an exact solution.

approx := collect(LAD(pde, U(x, t), inx, t, 20, fracorder = 1/2), [sin, cos])

LAD: L = U[t]; R = -2*U[x]-U[x,x,x]; N = 0; G = 0.

LAD: nonlinear expansion variables (conjugated functions denoted by C) are: []

(1-t+(1/2)*t^2-(1/6)*t^3+(1/24)*t^4-(1/120)*t^5+(1/720)*t^6-(1/5040)*t^7+(1/40320)*t^8-(1/362880)*t^9+(1/3628800)*t^10)*sin(x)+(-2*t^(1/2)/Pi^(1/2)+(4/3)*t^(3/2)/Pi^(1/2)-(8/15)*t^(5/2)/Pi^(1/2)+(16/105)*t^(7/2)/Pi^(1/2)-(32/945)*t^(9/2)/Pi^(1/2)+(64/10395)*t^(11/2)/Pi^(1/2)-(128/135135)*t^(13/2)/Pi^(1/2)+(256/2027025)*t^(15/2)/Pi^(1/2)-(512/34459425)*t^(17/2)/Pi^(1/2)+(1024/654729075)*t^(19/2)/Pi^(1/2))*cos(x)

The first series is exp(-t), the second series is not so obvious, After some scaling, the second series may be passed to guessgf

ser2 := `assuming`([simplify(expand(sqrt(Pi)*op(2, approx)/(sqrt(t)*cos(x))))], [t > 0]); [seq(coeff(ser2, t, i), i = 0 .. 9)]; ser2ex := gfun:-guessgf(%, t)[1]

-2+(4/3)*t-(8/15)*t^2+(16/105)*t^3-(32/945)*t^4+(64/10395)*t^5-(128/135135)*t^6+(256/2027025)*t^7-(512/34459425)*t^8+(1024/654729075)*t^9

-exp(-t)*Pi^(1/2)*erfi(t^(1/2))/t^(1/2)

So the full solution is

exact := exp(-t)*sin(x)+ser2ex*sqrt(t)*cos(x)/sqrt(Pi)

exp(-t)*sin(x)-exp(-t)*erfi(t^(1/2))*cos(x)

Check. fracdiff's default method returns an integral, method = laplace fails, but method = series works with cancellation of all terms but the "left over" last half-integral-order one.

Ord := 20; fracdiff(exact, t, 1/2, method = series, methodoptions = [order = Ord])-series(eval(rhs(pde), U(x, t) = exact), t, Ord)

20

-(1048576/319830986772877770815625)*sin(x)*t^(39/2)/Pi^(1/2)+O(t^(39/2))-O(t^20)

A second-order example (linear)

pde := diff(U(x, t), t, t) = -c^2*(diff(U(x, t), `$`(x, 2))); inx := [exp(I*x/c), exp(I*x/c)]; exact := exp(t+I*x/c)

diff(diff(U(x, t), t), t) = -c^2*(diff(diff(U(x, t), x), x))

[exp(I*x/c), exp(I*x/c)]

exp(t+I*x/c)

pdetest(U(x, t) = exact, [pde, U(x, 0) = inx[1], (D[2](U))(x, 0) = inx[2]])

[0, 0, 0]

approx := LAD(pde, U(x, t), inx, t, 6)

LAD: L = U[t,t]; R = -c^2*U[x,x]; N = 0; G = 0.

LAD: nonlinear expansion variables (conjugated functions denoted by C) are: []

exp(I*x/c)*(1+t)+(1/6)*exp(I*x/c)*t^2*(3+t)+(1/120)*exp(I*x/c)*t^4*(t+5)+(1/5040)*exp(I*x/c)*t^6*(7+t)+(1/362880)*exp(I*x/c)*t^8*(9+t)+(1/39916800)*exp(I*x/c)*t^10*(t+11)+(1/6227020800)*exp(I*x/c)*t^12*(13+t)

series(exact-approx, t, 13, oterm = false)

0

Fractional order example

approx := collect(LAD(pde, U(x, t), inx, t, 10, fracorder = 3/2), [exp, t])

LAD: L = U[t,t]; R = -c^2*U[x,x]; N = 0; G = 0.

LAD: nonlinear expansion variables (conjugated functions denoted by C) are: []

(1+(1/20922789888000)*t^16+(1/1307674368000)*t^15+(32768/6190283353629375)*t^(29/2)/Pi^(1/2)+(16384/213458046676875)*t^(27/2)/Pi^(1/2)+(1/6227020800)*t^13+(1/479001600)*t^12+(4096/316234143225)*t^(23/2)/Pi^(1/2)+(2048/13749310575)*t^(21/2)/Pi^(1/2)+(1/3628800)*t^10+(1/362880)*t^9+(512/34459425)*t^(17/2)/Pi^(1/2)+(256/2027025)*t^(15/2)/Pi^(1/2)+(1/5040)*t^7+(1/720)*t^6+(64/10395)*t^(11/2)/Pi^(1/2)+(32/945)*t^(9/2)/Pi^(1/2)+(1/24)*t^4+(1/6)*t^3+(8/15)*t^(5/2)/Pi^(1/2)+(4/3)*t^(3/2)/Pi^(1/2)+t)*exp(I*x/c)

There appear to be two separate series in t, with integer and half-integer powers.

t_series := approx/exp(I*x/c); t1, t2 := selectremove(proc (w) options operator, arrow; (degree(w, t))::integer end proc, t_series)

1+(1/20922789888000)*t^16+(1/1307674368000)*t^15+(1/6227020800)*t^13+(1/479001600)*t^12+(1/3628800)*t^10+(1/362880)*t^9+(1/5040)*t^7+(1/720)*t^6+(1/24)*t^4+(1/6)*t^3+t, (32768/6190283353629375)*t^(29/2)/Pi^(1/2)+(16384/213458046676875)*t^(27/2)/Pi^(1/2)+(4096/316234143225)*t^(23/2)/Pi^(1/2)+(2048/13749310575)*t^(21/2)/Pi^(1/2)+(512/34459425)*t^(17/2)/Pi^(1/2)+(256/2027025)*t^(15/2)/Pi^(1/2)+(64/10395)*t^(11/2)/Pi^(1/2)+(32/945)*t^(9/2)/Pi^(1/2)+(8/15)*t^(5/2)/Pi^(1/2)+(4/3)*t^(3/2)/Pi^(1/2)

The integer-powers series is the series for exp(t) with every third term missing: missing powers 2, 5, 8, 11, ...

t1sum := simplify(exp(t)-(sum(t^(3*i+2)/factorial(3*i+2), i = 0 .. infinity))); series(%, t, 17)

(2/3)*exp(t)+(1/3)*(cos((1/2)*3^(1/2)*t)+3^(1/2)*sin((1/2)*3^(1/2)*t))*exp(-(1/2)*t)

series(1+t+(1/6)*t^3+(1/24)*t^4+(1/720)*t^6+(1/5040)*t^7+(1/362880)*t^9+(1/3628800)*t^10+(1/479001600)*t^12+(1/6227020800)*t^13+(1/1307674368000)*t^15+(1/20922789888000)*t^16+O(t^17),t,17)

And for the other one, the following scaled series shows coefficients with powers of two divided by double factorials, every third term missing: missing powers 2,5,8,11,...

expand(sqrt(Pi)*t2/(4*t^(3/2))); all := add(2^i*t^i/doublefactorial(2*(i+1)+1), i = 0 .. 9); missing := add(eval(2^i*t^i/doublefactorial(2*(i+1)+1), i = 3*j+2), j = 0 .. 3)

(8192/6190283353629375)*t^13+(4096/213458046676875)*t^12+(1024/316234143225)*t^10+(512/13749310575)*t^9+(128/34459425)*t^7+(64/2027025)*t^6+(16/10395)*t^4+(8/945)*t^3+(2/15)*t+1/3

1/3+(2/15)*t+(4/105)*t^2+(8/945)*t^3+(16/10395)*t^4+(32/135135)*t^5+(64/2027025)*t^6+(128/34459425)*t^7+(256/654729075)*t^8+(512/13749310575)*t^9

(4/105)*t^2+(32/135135)*t^5+(256/654729075)*t^8+(2048/7905853580625)*t^11

t2sum := 4*t^(3/2)*(sum(2^i*t^i/doublefactorial(2*(i+1)+1), i = 0 .. infinity)-(sum(eval(2^i*t^i/doublefactorial(2*(i+1)+1), i = 3*j+2), j = 0 .. infinity)))/sqrt(Pi)

4*t^(3/2)*((1/4)*(Pi^(1/2)*exp(t)-2*t^(1/2)-Pi^(1/2)*erfc(t^(1/2))*exp(t))/t^(3/2)-(4/105)*t^2*hypergeom([1], [3/2, 11/6, 13/6], (1/27)*t^3))/Pi^(1/2)

Putting it together suggests

exact := exp(I*x/c)*simplify(t1sum+t2sum)

(1/3)*exp(I*x/c)*(Pi^(1/2)*exp(-(1/2)*t)*sin((1/2)*3^(1/2)*t)*3^(1/2)+Pi^(1/2)*exp(-(1/2)*t)*cos((1/2)*3^(1/2)*t)+3*Pi^(1/2)*exp(t)*erf(t^(1/2))-(16/35)*t^(7/2)*hypergeom([1], [3/2, 11/6, 13/6], (1/27)*t^3)+2*Pi^(1/2)*exp(t)-6*t^(1/2))/Pi^(1/2)

Check.

Ord := 20; fracdiff(exact, t, 3/2, method = series, methodoptions = [order = Ord+1])-series(eval(rhs(pde), U(x, t) = exact), t, Ord)

20

O(t^(39/2))-(1048576/319830986772877770815625)*exp(I*x/c)*t^(39/2)/Pi^(1/2)-O(t^(41/2))

Numerical calculation of a soliton

pde := I*(diff(U(x, t), t))+diff(U(x, t), `$`(x, 2))+U(x, t)^2*conjugate(U(x, t)); exact := sqrt(2*B)*sech(sqrt(B)*(2*k*t-x-x__0))*exp(I*(k*x+(-k^2+B)*t)); `assuming`([simplify(pdetest(U(x, t) = exact, pde))], [real, B > 0]); inx := eval(exact, t = 0)

I*(diff(U(x, t), t))+diff(diff(U(x, t), x), x)+U(x, t)^2*conjugate(U(x, t))

2^(1/2)*B^(1/2)*sech(B^(1/2)*(2*k*t-x-x__0))*exp(I*(k*x+(-k^2+B)*t))

0

2^(1/2)*B^(1/2)*sech(B^(1/2)*(-x-x__0))*exp(I*k*x)

With numerical parameters it runs faster. Float parameters will be converted to rationals.

params := {B = 2, k = -1/2, x__0 = -2}; inxnum := eval(inx, params); exactnum := eval(exact, params)

2*sech(2^(1/2)*(-x+2))*exp(-((1/2)*I)*x)

2*sech(2^(1/2)*(-t-x+2))*exp(I*(-(1/2)*x+(7/4)*t))

infolevel[LAD] := 3; approx := LAD(pde, U(x, t), inxnum, t, 28)

LAD: L = I*U[t]; R = -U[x,x]; N = -U^2*C; G = 0.

LAD: nonlinear expansion variables (conjugated functions denoted by C) are: [C, U]

LAD: calculating component 1 at time 0.

LAD: calculating component 2 at time .221

[Edited for brevity]

LAD: calculating component 27 at time 90.414

LAD: calculating component 28 at time 103.870

LAD: completed at time 105.309

For larger x and t, the approximation diverges at a point that depends on the number of iterations.

plot3d([abs(exactnum), abs(approx)], t = 0 .. 2, x = -3 .. 3, color = [red, blue], view = [default, default, 0 .. 5], orientation = [-30, 60])

NULL

Download Laplace_Adomian_Decomposition_procedure8b.mw

Recently, @zenterix asked a question related to solving the quantum mechanics of the finite-wall-height particle-in-a-box problem. In the last two decades or so I've been teaching a quantum mechanics course every second year, in which I sketch the method of solution of this problem for the class, I but do not get into the mathematical details. A few times I've started to work on it in Maple, but abandoned it because of lack of time. So I decided to persist this time.

This post is more about some of the challenges and tradeoffs in making it work, hence the title. The title is also a nod to the fact that this problem appears in Engel's textbook [1] in a chapter entitled "Applying the particle in a box model to real-world topics". You don't need to know much about quantum mechanics to understand it. From the mathematical point of view you are solving three ordinary differential equations (in three regions) and stitching the solutions together so that the solution, a wavefunction, is continuous with continuous derivative and tends to zero at plus infinity and minus infinity.

The three regions and the wavefunctions for three eigenvalues (energies) are shown here in the figure, which is the final output of the worksheet. Next is the worksheet and I'll comment further on it below.

(It's a quirk of quantum mechanics that we plot two things with different units (wavefunctions and energy) on the same axis, and worse, we offset one by the other.)

Bound states for particle in finite height box of wall height
V(x) = piecewise(x < -(1/2)*a, V__0, -(1/2)*a <= x and x <= (1/2)*a, 0, (1/2)*a < x, V__0)
I'll call these regions left, box and right respectively.

restart

Schroedinger equation. Here as elsewhere "=0" is implied.

Schroedinger := -`&hbar;`^2*(diff(psi(x), x, x))/(2*m)+V*psi(x)-E*psi(x)

-(1/2)*`&hbar;`^2*(diff(diff(psi(x), x), x))/m+V*psi(x)-E*psi(x)

(1)

Nondimensionalize length as units of box length, X = x/a. Since psi(x)^2*dx is unitless probability, psi(x) has dimensions 1/length^(1/2)so we define a dimensionless Phi = a^(1/2)*psi

tr := {x = a*X, psi(x) = Phi(X)/sqrt(a)}; NDSchroedinger := PDETools:-dchange(tr, Schroedinger, [X, Phi(X)], params = [`&hbar;`, m, a], simplify)

{x = a*X, psi(x) = Phi(X)/a^(1/2)}

 

-((1/2)*`&hbar;`^2*(diff(diff(Phi(X), X), X))+a^2*m*Phi(X)*(E-V))/(a^(5/2)*m)

(2)

This will also change the normalization integrals, e.g., over the box region:

normint := Int(psi(x)^2, x = -(1/2)*a .. (1/2)*a); NDnormint := PDETools:-dchange(tr, normint, [X, Phi(X)], params = [`&hbar;`, m, a], simplify)

Int(psi(x)^2, x = -(1/2)*a .. (1/2)*a)

 

Int(Phi(X)^2, X = -1/2 .. 1/2)

(3)

Outside the box we have 0 <= E and E < V with V = V__0. Define a dimensionless positive constant kappa:

`&kappa;__eqn` := kappa = a*sqrt(2*m*(V__0-E)/`&hbar;`^2); de_outside := simplify(sqrt(a)*kappa^2*(eval(NDSchroedinger, {isolate(`&kappa;__eqn`, m), V = V__0}))/(E-V__0)); outside := rhs(dsolve(de_outside))

kappa = a*2^(1/2)*(m*(V__0-E)/`&hbar;`^2)^(1/2)

 

diff(diff(Phi(X), X), X)-kappa^2*Phi(X)

 

c__1*exp(-kappa*X)+c__2*exp(kappa*X)

(4)

Inside the box we have V = 0 and E > 0. Define a dimensionless positive constant k.

k__eqn := k = a*sqrt(2*m*E/`&hbar;`^2); de_box := simplify(-sqrt(a)*k^2*(eval(NDSchroedinger, {isolate(k__eqn, m), V = 0}))/E); box := rhs(eval(dsolve(de_box), {c__1 = A, c__2 = B}))

k = a*2^(1/2)*(m*E/`&hbar;`^2)^(1/2)

 

diff(diff(Phi(X), X), X)+k^2*Phi(X)

 

A*sin(k*X)+B*cos(k*X)

(5)

We have seven unknowns {A, B, E, c__1(L), c__1(R), c__2(L), c__2(R)}, where for example c__1(L) means Maple's c__1 for the left region. We need seven equations: goes to 0 at x = -infinityand at x = infinity(or Phi(X) wouldn't be square integrable), continuity at the two box boundaries, slopes continuous at the two box boundaries, and normalization. We deal with the ones at `&+-`(infinity)first.

At X = -infinity the wavefunction will be unbounded unless one of the constants goes to zero. We'll rename the other one A__L or A__R. The code here is just to handle the fact that c__1 and c__2 can be the the opposite way around, depending on the session.

`assuming`(['limit(outside, X = -infinity)' = limit(outside, X = -infinity)], [kappa > 0]); left0 := eval(outside, `~`[`=`](`minus`(indets(rhs(%), name), {infinity}), 0)); left1 := eval(left0, `~`[`=`](indets(left0, suffixed(c)), A__L)); `assuming`(['limit(outside, X = infinity)' = limit(outside, X = infinity)], [kappa > 0]); right0 := eval(outside, `~`[`=`](`minus`(indets(rhs(%), name), {infinity}), 0)); right1 := eval(right0, `~`[`=`](indets(right0, suffixed(c)), A__R))

limit(c__1*exp(-kappa*X)+c__2*exp(kappa*X), X = -infinity) = signum(c__1)*infinity

 

A__L*exp(kappa*X)

 

limit(c__1*exp(-kappa*X)+c__2*exp(kappa*X), X = infinity) = signum(c__2)*infinity

 

A__R*exp(-kappa*X)

(6)

Now we have five unknowns {A, A__L, A__R, B, E}. The strategy will be to eliminate A, A__L, A__R and then find the eigenvalues E. Then we will have expressions for all three regions containing the unknown B, which we will find by the normalization condition (The normalization condition fixes the scale of the wavefunction so that the probability of finding the particle somewhere is one.)

Continuity of the wavefunction and its derivative at the left boundary are below
We eliminate A__L and A using this boundary

bcleft := {eval(left1-box, X = -1/2), eval(diff(left1, X)-(diff(box, X)), X = -1/2)}; sol := solve(bcleft, {A, A__L}); left2 := eval(left1, sol); box2 := eval(box, sol)

{A__L*exp(-(1/2)*kappa)+A*sin((1/2)*k)-B*cos((1/2)*k), A__L*kappa*exp(-(1/2)*kappa)-A*k*cos((1/2)*k)-B*k*sin((1/2)*k)}

 

{A = -B*(sin((1/2)*k)*k-cos((1/2)*k)*kappa)/(sin((1/2)*k)*kappa+cos((1/2)*k)*k), A__L = B*k*(sin((1/2)*k)^2+cos((1/2)*k)^2)/(exp(-(1/2)*kappa)*(sin((1/2)*k)*kappa+cos((1/2)*k)*k))}

 

B*k*(sin((1/2)*k)^2+cos((1/2)*k)^2)*exp(kappa*X)/(exp(-(1/2)*kappa)*(sin((1/2)*k)*kappa+cos((1/2)*k)*k))

 

-B*(sin((1/2)*k)*k-cos((1/2)*k)*kappa)*sin(k*X)/(sin((1/2)*k)*kappa+cos((1/2)*k)*k)+B*cos(k*X)

(7)

Eliminate A__R at the right box boundary

bcright := {eval(box2-right1, X = 1/2), eval(diff(box2, X)-(diff(right1, X)), X = 1/2)}; elim := eliminate(bcright, A__R); right2 := eval(right1, elim[1]); energy_eqn := elim[2][]/B

{-B*(sin((1/2)*k)*k-cos((1/2)*k)*kappa)*sin((1/2)*k)/(sin((1/2)*k)*kappa+cos((1/2)*k)*k)+B*cos((1/2)*k)-A__R*exp(-(1/2)*kappa), -B*(sin((1/2)*k)*k-cos((1/2)*k)*kappa)*k*cos((1/2)*k)/(sin((1/2)*k)*kappa+cos((1/2)*k)*k)-B*k*sin((1/2)*k)+A__R*kappa*exp(-(1/2)*kappa)}

 

[{A__R = B*(2*sin((1/2)*k)*cos((1/2)*k)*kappa+2*cos((1/2)*k)^2*k-k)/(exp(-(1/2)*kappa)*(sin((1/2)*k)*kappa+cos((1/2)*k)*k))}, {-2*(sin((1/2)*k)*cos((1/2)*k)*k^2-sin((1/2)*k)*cos((1/2)*k)*kappa^2-2*cos((1/2)*k)^2*k*kappa+k*kappa)*B}]

 

B*(2*sin((1/2)*k)*cos((1/2)*k)*kappa+2*cos((1/2)*k)^2*k-k)*exp(-kappa*X)/(exp(-(1/2)*kappa)*(sin((1/2)*k)*kappa+cos((1/2)*k)*k))

 

-2*sin((1/2)*k)*cos((1/2)*k)*k^2+2*sin((1/2)*k)*cos((1/2)*k)*kappa^2+4*cos((1/2)*k)^2*k*kappa-2*k*kappa

(8)

Now we will get the quantized energies by finding which values will make energy_eqn zero. We recall the relationships of `&kappa;__` and k to energy:

k__eqn; `&kappa;__eqn;`

k = a*2^(1/2)*(m*E/`&hbar;`^2)^(1/2)

 

kappa = a*2^(1/2)*(m*(V__0-E)/`&hbar;`^2)^(1/2)

(9)

The energy scale is set by V__0, so can get a non-dimensionalized energy e = E/V__0 and a non-dimensional parameter b = a*sqrt(2*m*V__0/`&hbar;`^2).

b__eqn := b = a*sqrt(2*m*V__0/`&hbar;`^2); e__eqn := e = E/V__0; eqns := `assuming`([{simplify(eval(eval(k__eqn, isolate(e__eqn, E)), isolate(b__eqn, V__0))), simplify(eval(eval(`&kappa;__eqn`, isolate(e__eqn, E)), isolate(b__eqn, V__0)))}], [a > 0])

b = a*2^(1/2)*(m*V__0/`&hbar;`^2)^(1/2)

 

e = E/V__0

 

{k = (e*b^2)^(1/2), kappa = (-b^2*(e-1))^(1/2)}

(10)

So now for any values of the box length and height, one finds the parameter b describing the problem and solves for the possible e values.

energy_eqn2 := `assuming`([simplify((eval(energy_eqn, eqns))/b^2)], [b > 0, e > 0, e < 1])

2*e^(1/2)*(-e+1)^(1/2)*cos(b*e^(1/2))-2*e*sin(b*e^(1/2))+sin(b*e^(1/2))

(11)

Maple cannot find an analytical solution, so we will find the eigenvalues numerically. The zero solution is unphysical.

solve(energy_eqn2, e)

0, RootOf(-2*(-(_Z^2-b^2)/b^2)^(1/2)*(_Z^2/b^2)^(1/2)*b^2+2*tan(_Z)*_Z^2-tan(_Z)*b^2)^2/b^2

(12)

For any b, read off the possible energies off the vertical line for that b, e.g. there are 3 bound states for b = 9. For other values, choose bval and nsols on the next line appropriately.

bval := 9; nsols := 3; plots:-implicitplot([b = bval, energy_eqn2], b = 0 .. 15, e = 0 .. 1)

9

 

3

 

 

evals := [fsolve(eval(energy_eqn2, b = bval), e = 0 .. 1, maxsols = nsols)]

[0.8115199822e-1, .3189598393, .6884466500]

(13)

In terms of the parameters b and e and normalization constant B, the non-dimensionalized wavefunctions of the 3 regions are as below. The scale factor gives a simpler form and prevents 0/0 problems later in the calculation.

scale := `assuming`([denom(simplify(eval(left2, eqns)))], [positive]); left3 := `assuming`([simplify(eval(scale*left2, eqns))], [positive]); box3 := `assuming`([simplify(eval(scale*box2, eqns))], [positive]); right3 := `assuming`([simplify(eval(scale*right2, eqns))], [positive])

sin((1/2)*b*e^(1/2))*(-e+1)^(1/2)+cos((1/2)*b*e^(1/2))*e^(1/2)

 

B*e^(1/2)*exp((1/2)*b*(-e+1)^(1/2)*(2*X+1))

 

-(sin((1/2)*b*e^(1/2))*(e^(1/2)*sin(b*e^(1/2)*X)-(-e+1)^(1/2)*cos(b*e^(1/2)*X))-cos((1/2)*b*e^(1/2))*(cos(b*e^(1/2)*X)*e^(1/2)+sin(b*e^(1/2)*X)*(-e+1)^(1/2)))*B

 

B*exp(-(1/2)*b*(-e+1)^(1/2)*(-1+2*X))*(e^(1/2)*cos(b*e^(1/2))+(-e+1)^(1/2)*sin(b*e^(1/2)))

(14)

It remains to find the normalization constant B. The three parts of the normalization integral are:

P__L := `assuming`([int(left3^2, X = -infinity .. -1/2)], [positive]); P__box := `assuming`([int(box3^2, X = -1/2 .. 1/2)], [positive]); P__R := `assuming`([int(right3^2, X = 1/2 .. infinity)], [positive])

(1/2)*B^2*e/(b*(-e+1)^(1/2))

 

-(1/4)*B^2*(2*e^(1/2)*(-e+1)^(1/2)*cos(2*b*e^(1/2))-2*e^(1/2)*(-e+1)^(1/2)-2*b*e^(1/2)-2*e*sin(2*b*e^(1/2))+sin(2*b*e^(1/2)))/(b*e^(1/2))

 

(1/2)*B^2*(e^(1/2)*cos(b*e^(1/2))+(-e+1)^(1/2)*sin(b*e^(1/2)))^2/(b*(-e+1)^(1/2))

(15)

Solve for B. There are two (messy) solutions for B of opposite sign; it is conventional to choose the sign such that the ground state has positive values.

Bval := sort([solve(P__L+P__box+P__R = 1, B)])[2]

Assemble it into a single piecewise function.

`&Phi;__all` := eval(piecewise(X < -1/2, left3, `and`(X >= -1/2, X <= 1/2), box3, X > 1/2, right3), B = Bval)

Plot. Plots offset vertically by the energy as usual

Xmax := 1.5; psiscale := .15; colors := [red, blue, magenta]; wavefns := plot([seq(eval(psiscale*`&Phi;__all`, {b = bval, e = evals[i]})+evals[i], i = 1 .. nsols)], X = -Xmax .. Xmax, color = colors); walls := plot([-1/2, y, y = 0 .. 1], color = black), plot([1/2, y, y = 0 .. 1], color = black), plot(1, X = -Xmax .. -1/2, color = black), plot(0, X = -1/2 .. 1/2, color = black), plot(1, X = 1/2 .. Xmax, color = black); evalplot := plot(evals, X = -Xmax .. Xmax, linestyle = dash, color = colors); plots:-display(wavefns, walls, evalplot, axes = boxed, labels = [X, psiscale*Phi+E/V__0])

 

NULL

Download finite_box_non-dim2.mw

Comments
1. The first general comment is about the issue of how much Maple can do. In principle one should be able to give dsolve the three ODEs and the boundary conditions and it should output the result. We are still far away from that. Even for one region, the boundary conditions at infinity are not handled by dsolve. The other extreme is to solve the ODEs for their general solutions, and follow the algebraic manipulations for implementing the boundary conditions as one might do it on paper. Engel for example has a comment "At this point we notice that by dividing the equations in each pair, the coefficients can be eliminated to give [...]". Maple will not easily do that trick or the manipulations that led to the special form on which the trick is applied. Levine's textbook [2] gives a different non-intuitive set of steps.

But Maple can solve complicated equations, so I wanted a more general strategy that avoids as much as possible the requirement to manipulate into special forms. On the other hand, it is tempting (as @zenterix tried) to just give the three general solutions with 6 arbitrary constants and the boundary conditions to Maple's solve, and solve for the six constants. One finds that all six are zero. This us a consequence of the fact that the ODEs are linear, and misses the crucial point that it is an eigenvalue problem. So there must be some sort of step-by-step guidance for Maple and there is a general but non-obvious strategy to solving such problems.

2. The second general comment is that there is a trade-off between presenting the solution steps without any arcane Maple code, and getting to the solution efficiently and programmatically, without too many manual manipulations. One of my suggestions to @zenterix involved manually dividing both sides of an equations by a fairly complicated expression, to which @acer expressed a preference for programmatic solutions. At the time, I mainly did that to keep close the to existing solution, and was thinking that I usually set things up so that is not necessary. But I found here that I do it a lot, and it is a natural consequence of the interactive way I use Maple. Here's two examples:

In the second line of label (4), I originally got a more complicated form of de_outside, then manually figured out the factor to put inside simplify to get the form you see. I do this frequently with Maple, especially when I use dchange.

In the last line of label (8), I manually divided by B to remove it. Had B been in the denominator, I could have removed it programmatically with numer (an operation I use frequently, though it somewhat recklessly ignores denominator zeroes).

Programmatically doing things can be relatively unreadable and disrupt the readability for the non-Maple reader. For example in label (6) there is "extraneous" code to find which coefficient to set to zero so that the solution goes to zero at +/- infinity. This was forced on me since after generating the nice figure I re-ran the worksheet only to have multiple errors. I originally used eval(outside, {c__1 = B__L, c__2 = A__L}); to change Maple's dsolve constants to read the way I wanted. But I realized that dsolve does not reproducibly assign c__1 and c__2 to the same term each time, raising the general issue of: 

3. Session to session reproducibility. If I am only going to use a worksheet myself, I don't usually worry too much about this, since I can usually debug this fairly easily. On the other hand if the worksheet is for others, it needs to be foolproof. I have taken to always sorting the output of solve, e.g., the assignment to bval in the execution group after label (15). The code added for the dsolve constants works, but is non-trivial Maple (suffixed type testing). (Solving this issue for Eigenvectors is yet more difficult.)

4. Some efforts to make the worksheet more readable were hard to do.

- For some reason, Engel chose to call the two constants in the left region B and B'. Entering B*exp(-k*x) + B'*exp(k*x) in 2D leads to B(x)*exp(-k*x) + diff(B(x), x)*exp(k*x). No doubt this can be fixed, but I didn't pursue this.

- I would normally use upper case Psi for the non-dimensionalized psi, but Psi is the name of a special function in Maple. But wait, now we can use "local Psi;" to solve this problem. However diff(Psi(x),x,x) displays as Psi(2,x), so I had to settle for Phi. (SCR submitted.)

- I build up the left wavefunctions incrementally as expressions assigned to left1, left2, etc, which is rather ugly. Why not use arrow procedures so we can use psi(x), D(psi)(x) etc. Aside from some awkwardness in updating such procedures by redefining them as needed, I ran into the following problem:

limit(A*exp(-k*x) + B*exp(k*x), x = infinity) assuming k > 0; gives as expected
signum(B)*infinity;

but

psi := x -> A*exp(-k*x) + B*exp(k*x);
limit(psi(x), x = infinity) assuming k > 0;
returns unevaluated. What happened to full evaluation?

- I'm used to entering hbar as hbar in 1D; it displays as h with the bar through. In 2-D entering hbar^2 is displayed nicely, but internally it is `&hbar;`. We can have the following puzzle:

(hbar/m)^2-`&hbar;`^2/m^2

hbar^2/m^2-`&hbar;`^2/m^2

NULL

- I originally wanted a vertical axis label Psi, E/V__0, but labels = [X, Psi, E/V__0] obviously won't work. It took some time to figure out the answer is to make "Psi, E/V__0" an atomic variable. I finally settled on the more honest, if cryptic, label shown.

5. solve gives an "invalid" solution. Originally I worked with solutions left2 etc (see label (6)) after simplify(eval(left2, eqns)). Every second wavefunction was about 10^9 times higher than the others, which was difficult to debug. It turns out the denominator of those wavefunctions was exactly zero but numerically 10^(-10), meaning they plotted as large-scaled versions of the right shape, without any division-by-zero error. The fix is to remove the denominators by scaling (see label (14)).

This is just a consequence of Maple giving generic solutions, and the only way around it is to be aware of it.

Summary

To solve such problems with Maple requires one to play around in an interactive way. After hacking to a solution, it can take some effort to make it presentable and usable to others. But the final result is pleasing, and is certainly much easier than working through the problem on paper. The ability to manipulate complicated expressions means circumventing tricks that might be needed in manual solutions. 

References
[1] T. Engel, Quantum Chemistry and spectroscopy. Pearson 2019, 4th ed. Sec. 5.1, Prob. 5.3. 
[2] I. N. Levine, Quantum Chemistry. Pearson 2009, 6th ed. Sec. 2.4. 

Recently Mapleprimes user @vs140580  asked here about finding the shortest returning walk in a graph (explained more below). I provided an answer using the labelled adjacency matrix. @Carl Love pointed out that the storage requirements are significant. They can be reduced by storing only the vertices in the walks and not the walks themselves. This can be done surprisingly easily by redefining how matrix multiplication is done using Maple's LinearAlgebra:-Generic package.

(The result is independent of the chosen vertex.)

restart

with(GraphTheory)

Consider the following graph. We want to find, for a given vertex v, the shortest walk that visits all vertices and returns to v. A walk traverses the graph along the edges, and repeating an edge is allowed (as distinct from a path, in which an edge can be used only once).

G := AddVertex(PathGraph(5), [6, 7]); AddEdge(G, {{3, 7}, {4, 6}, {6, 7}}); DrawGraph(G, layout = circle, size = [250, 250])

GRAPHLN(undirected, unweighted, [1, 2, 3, 4, 5, 6, 7], Array(1..7, {(1) = {2}, (2) = {1, 3}, (3) = {2, 4}, (4) = {3, 5}, (5) = {4}, (6) = {}, (7) = {}}), `GRAPHLN/table/2`, 0)

n := NumberOfVertices(G)

7

A := AdjacencyMatrix(G)

As is well known, the (i, j) entry of A^k gives the number of walks of length k between vertices i and j. The labelled adjacency matrix shows the actual walks.

Alab := `~`[`*`](A, Matrix(n, n, symbol = omega))

Matrix(%id = 36893490455680637396)

For example, the (3,3) entry of Alab^2 has 3 terms, one for each walk of length 2 that starts and ends at vertex 3. The `&omega;__i,j` factors in a term give the edges visited.

So the algorithm to find the shortest walk is to raise Alab to successively higher powers until one of the terms in the diagonal entry for the vertex of interest has indices for all the vertices.

Alab^2

Matrix(%id = 36893490455709504684)

The expressions for higher powers get very large quickly, so an algorithm that only retains the sets of vertices in each term as a set of sets will use less storage space. So we can consider the following modified labelled adjacency matrix.

B := Matrix(n, n, proc (i, j) options operator, arrow; if A[i, j] = 1 then {{i, j}} else {} end if end proc)

Matrix(%id = 36893490455703852204)

Now we need to modify how we do matrix multiplication, but Maple has the LinearAlgebra:-Generic package to do this. We can redefine addition and multiplication to operate correctly on the sets of sets.

Consider two sets of sets of vertices for walks.

a := {{7}, {1, 3}, {2, 6, 7}}; b := {{1, 2}, {2, 3, 8}}

{{7}, {1, 3}, {2, 6, 7}}

{{1, 2}, {2, 3, 8}}

Addition is just combining the possibilities, and set union will do this. And addition of "zero" should add no possibilities, so we take {} as zero.

`union`(a, b); `union`(a, {})

{{7}, {1, 2}, {1, 3}, {2, 3, 8}, {2, 6, 7}}

{{7}, {1, 3}, {2, 6, 7}}

Multiplication is just combining all pairs by union. Notice here that {7} union {1,3,5} and {1,5} union {3,7} give the same result, but that we do not get duplicates in the set.

{seq(seq(`union`(i, j), `in`(i, a)), `in`(j, b))}

{{1, 2, 3}, {1, 2, 7}, {1, 2, 3, 8}, {1, 2, 6, 7}, {2, 3, 7, 8}, {2, 3, 6, 7, 8}}

The unit for multiplication should leave the set of sets unchanged, so {{}} can be used

{seq(seq(`union`(i, j), `in`(i, a)), `in`(j, {{}}))}

{{7}, {1, 3}, {2, 6, 7}}

And we should check that zero multiplied by a is zero

{seq(seq(`union`(i, j), `in`(i, a)), `in`(j, {}))}

{}

Define these operations for the LinearAlgebraGeneric package:

F[`=`] := `=`; F[`/`] := `/`; F[`0`] := {}; F[`1`] := {{}}; F[`+`] := `union`; F[`*`] := proc (x, y) options operator, arrow; {seq(seq(`union`(i, j), `in`(i, x)), `in`(j, y))} end proc

Warning, (in F[*]) `j` is implicitly declared local

Warning, (in F[*]) `i` is implicitly declared local

Compare B^2 with Alab^2. We have lost information about the details of the walks except for the vertices visited.

LinearAlgebra:-Generic:-MatrixMatrixMultiply[F](B, B)

Matrix(%id = 36893490455680647164)

So here is a procedure for finding the length of the shortest walk starting and ending at vertex v.

WalkLength:=proc(G::Graph,v)
  uses GraphTheory;
  local x,y,i,j,vv,A,B,F,n,vertset;
  if IsDirected(G) then error "graph must be undirected" end if;
  if not member(v,Vertices(G),'vv') then error "vertex not in graph" end if;
  if not IsConnected(G) then return infinity end if;
  F[`=`]:=`=`:F[`/`]:=`/`: # not required but have to be specified
  F[`0`]:={}:
  F[`1`]:={{}}:
  F[`+`]:=`union`;
  F[`*`]:=(x,y)->{seq(seq(i union j, i in x), j in y)};
  n:=NumberOfVertices(G);
  vertset:={$(1..n)};
  A:=Matrix(n,n, (i, j)-> if AdjacencyMatrix(G)[i, j] = 1 then {{i, j}} else {} end if);
  B:=copy(A);
  for i from 2 do
    B:=LinearAlgebra:-Generic:-MatrixMatrixMultiply[F](B,A);
  until vertset in B[vv,vv];
  i;
end proc:

WalkLength(G, 1)

10

NULL

Download WalksGenericSetOfSets.mw

1 2 Page 1 of 2