Высшие симметрии

К лекции 5 (2024)

Определение (Subscript[D, x]),(Subscript[D, x]^(-1)) и (Subscript[D, t]), генерация однородных многочленов

Следующие функции уже использовались на лекции 2 (про законы сохранения). В них адаптируются встроенные функции D, Derivative и Integrate.

Пусть u[n] обозначает  (∂_x^n)(u(x)). Производная по x и интеграл:

n2x=u[n_]:>Derivative[n][u][x];
x2n={u[x]->u[0],Derivative[n_][u][x]:>u[n]};

dx[expr_]:=D[expr/.n2x,x]/.x2n
dx[expr_,k_]:=D[expr/.n2x,{x,k}]/.x2n

int[expr_]:=Block[{i=Integrate[expr/.n2x,x]},
If[FreeQ[i,Integrate],i/.x2n,i]]

Производная по t в силу уравнения (Subscript[u, t])=f:

n2t=u[n_]:>Derivative[n,0][u][x,t];
t2n={u[x,t]->u[0],Derivative[n_,0][u][x,t]:>u[n]};

dt[expr_,f_]:=D[expr/.n2t,t]/.Derivative[n_,1][u][x,t]:>D[f/.n2t,{x,n}]/.t2n

comm[f_,g_]:=Expand[dt[g,f]-dt[f,g]]

vars[f,u] список переменных (Subscript[u, n]) в выражении

mon[d,r,k]  список мономов степени d от (Subscript[u, k]), (Subscript[u, k+1]),...  с общей суммой индексов равной r

hom[m,n,M]  список всех мономов заданного веса M относительно веса (Subscript[u, j])∼m+j n

rhom[m,n,M]  то же самое, но без мономов, линейных по старшей переменной (следовательно, все мономы в этом списке неэквивалентны по модулю Im (Subscript[D, x]))

vars[f_,u__]:=Union[Flatten[Cases[f,Blank[#],{0,Infinity}]&/@{u}]]

mon[d_,r_,k_]:=If[d==1,If[r≥k,{u[r]},{}],
Flatten[Table[u[s]mon[d-1,r-s,s],{s,k,r}]]]

hom[m_,n_,M_]:=Flatten[Table[
If[IntegerQ[(M-m d)/n],mon[d,(M-m d)/n,0],{}],
{d,1,Floor[M/m]}]]

rhom[m_,n_,M_]:=Select[hom[m,n,M],Exponent[#,Last[vars[#,u]]]>1||#==u[0]&]

Тестовый пример: совместность КдФ с уравнением 5-го порядка:

ut3=u[3]-6u[0]u[1]

ut5=dx[u[4]-10u[0]u[2]-5((u[1])^2)+10((u[0])^3)]

dt[ut3,ut5]
dt[ut5,ut3]

Expand[%-%%]

Иерархия Бюргерса

Совместность линейных уравнений очевидна

dt[u[m],u[n]]

Понятно (?), что при точечных заменах и подстановках совместность не портится.  Сделаем замену к уравнению Бюргерса:

u=exp(v),  (u^B)=(Subscript[v, x])=(Subscript[u, x])/u

uBt[n_]:=Expand[dx[Exp[-u[0]]dx[Exp[u[0]],n]]]/.u[k_]:>u[k-1]

uBt[1]
uBt[2]
uBt[3]
uBt[4]

Действительно, коммутаторы равны 0:

comm[uBt[2],uBt[3]]
comm[uBt[2],uBt[4]]
comm[uBt[3],uBt[4]]

Оператор рекурсии R=D+u+(Subscript[u, 1])(D^(-1))

R[f_]:=Expand[dx[f]+u[0]f+u[1]int[f]]

Ut[1]=uBt[1]
Ut[2]=R[%]
Ut[3]=R[%]
Ut[4]=R[%]
Ut[5]=R[%]

Вычисление симметрий КдФ методом неопределенных коэффициентов

Вычисление симметрий 5-го и 7-го порядков

Составим общий однородный многочлен веса 7; коэффициент при (Subscript[u, 5]) положим равным 1

ut3=u[3]-6u[0]u[1];

hom[2,1,7]
a/@Range[Length[%]]

uT=%.%%/.a[1]->1

Составим уравнение [(Subscript[u, (Subscript[t, 3])]),(Subscript[u, T])]=0, соберем коэффициенты, решим систему, по решению определим (Subscript[u, (Subscript[t, 5])])

eq=dt[uT,ut3]-dt[ut3,uT]
vars[eq,u]
Union[Flatten[CoefficientList[eq,%]]]
sol=Solve[%==0]

ut5=uT/.sol[[1]]

Проверка

comm[ut5,ut3]

То же самое проделаем с однородным многочленом веса 9.

hom[2,1,9]
a/@Range[Length[%]]

uT=%.%%/.a[1]->1

eq=comm[ut3,uT]
vars[eq,u]
Union[Flatten[CoefficientList[eq,%]]]
sol=Solve[%==0]

ut7=uT/.sol[[1]]

Проверка

comm[ut7,ut3]
comm[ut7,ut5]

Вычисление в процедуре

Сделаем то же самое в виде процедуры для любого веса.

ut3=u[3]-6u[0]u[1];

sym[m_]:=Module[{uT,a,eq},
uT=hom[2,1,m+2];
uT=Table[a[i],{i,1,Length[uT]}].uT/.a[1]->1;
eq=comm[uT,ut3];
eq=Union[Flatten[{CoefficientList[eq,vars[eq,u]]}]];
eq=Solve[eq==0];
If[Length[eq]==0,0,uT/.eq[[1]]]
]

Симметрий чётного порядка нет:

sym[2]
sym[4]
sym[6]

Симметрии нечётного порядка:

uKt[1]=sym[1]
uKt[3]=sym[3]
uKt[5]=sym[5]
uKt[7]=sym[7]
uKt[9]=sym[9]
uKt[11]=sym[11]

Коммутативность симметрий:

comm[uKt[5],uKt[9]]
comm[uKt[7],uKt[9]]

Симметрия 15-го порядка вычисляется довольно долго:

sym[15]

Уравнения SK и KK

Попробуем поискать одновременно (Subscript[u, t])=f и (Subscript[u, T])=g

(Subscript[u, t]) порядка 4, (Subscript[u, T]) порядка 6

hom[2,1,6]
a/@Range[Length[%]];
f=%.%%/.a[1]->1

hom[2,1,8]
b/@Range[Length[%]];
g=%.%%/.b[1]->1

Система на коэффициенты получается нелинейная, но Mathematica с ней справляется. Решений нет.

eq=comm[f,g]
vars[eq,u]
Union[Flatten[CoefficientList[eq,%]]]
sol=Solve[%==0]

(Subscript[u, t]) порядка 5, (Subscript[u, T]) порядка 7

hom[2,1,7]
a/@Range[Length[%]];
f=%.%%/.a[1]->1

hom[2,1,9]
b/@Range[Length[%]];
g=%.%%/.b[1]->1

Находится 3 решения!

eq=comm[f,g];
vars[eq,u];
Union[Flatten[CoefficientList[eq,%]]]
sol=Solve[%==0]

Одно из них совпадает с симметрией КдФ, при подходящем выборе свободного коэффициента (который отвечает за растяжение)

uKt[5]
f/.sol[[3]]/.a[2]->-10

Два других – новые уравнения, не связанные с КдФ. Уравнение Савады-Котеры

uSKt[5]=f/.sol[[1]]/.a[2]->5
uSKt[7]=g/.sol[[1]]/.a[2]->5
comm[%,%%]

и Каупа-Купершмидта

uKKt[5]=f/.sol[[2]]/.a[2]->5
uKKt[7]=g/.sol[[2]]/.a[2]->5
comm[%,%%]

Для каждого из них можно найти и другие высшие симметрии, как и раньше для КдФ. Немного модифицируем предыдущую процедуру.

sym[m_,ut_]:=Module[{uT,a,eq},
uT=hom[2,1,m+2];
uT=Table[a[i],{i,1,Length[uT]}].uT/.a[1]->1;
eq=comm[uT,ut];
eq=Union[Flatten[{CoefficientList[eq,vars[eq,u]]}]];
eq=Solve[eq==0];
If[Length[eq]==0,0,uT/.eq[[1]]]
]

Оказывается, что симметрий 9-го порядка нет, 11-го есть. Вообще, для этих уравнений есть симметрии, порядки которых не делятся на 2 или 3.

sym[7,uSKt[5]]
sym[9,uSKt[5]]
sym[11,uSKt[5]]

sym[7,uKKt[5]]
sym[9,uKKt[5]]
sym[11,uKKt[5]]

Оператор рекурсии для КдФ

R=(D^2)-4u-2(Subscript[u, x])(D^(-1))

R[f_]:=Expand[dx[f,2]-4u[0]f-2u[1]int[f]]

Ut[1]=uKt[1]
Ut[3]=R[%]
Ut[5]=R[%]
Ut[7]=R[%]
Ut[9]=R[%]
Ut[11]=R[%]
Ut[13]=R[%]
Ut[15]=R[%]

Результаты совпадают с предыдущими:

Table[uKt[j]-Ut[j],{j,1,11,2}]