Optimize parameters for differential equations

Question

I have differential equations f11, f12, f21, and f22 with respect to t with parameters A and B. I've defined and solved these equations using NDSolve in Mathematica as follows:

A = 2;
B = 6;
NDSolve[
{f11'[t] == -(1/2) I A f12[t] + 1/2 I A f21[t], 
  f12'[t] == -(1/2) I A f11[t] - I B f12[t] + 1/2 I A f22[t], 
  f21'[t] == 1/2 I A f11[t] + I B f21[t] - 1/2 I A f22[t], 
  f22'[t] == 1/2 I A f12[t] - 1/2 I A f21[t], 
  f22[0] == 0,f11[0] == 1, f12[0] == 0, f21[0] == 0}, 
{f11[t], f12[t], f21[t], f22[t]}, {t, 0, 1}]

Plotting the solution for f22[t] produces a graph :

I want to adjust the parameters A and B to maximize the value of f22[t]. I just want the maximum value that f22[t] can achieve in any t. In this example, there will be several solutions available, I am interested in understand how I can approach the problem in Mathematica using this example.

Can you advise how to optimize A, B (and t) to achieve this maximum? I'm open to using numerical optimization methods or machine learning algorithms if necessary. Any guidance would be much appreciated.

Answer 1

You could use ParametricNDSolve with A and B as parameters and then use NArgMax. I use the range of t=0 to 1 for my range for ParametricNDSolve and NArgMax and I don't specify any restrictions on the domain of A and B

tMin = 0;
tMax = 1;
soln = f22[t] /. 
  ParametricNDSolve[{f11'[t] == -(1/2) I A f12[t] + 1/2 I A f21[t], 
    f12'[t] == -(1/2) I A f11[t] - I B f12[t] + 1/2 I A f22[t], 
    f21'[t] == 1/2 I A f11[t] + I B f21[t] - 1/2 I A f22[t], 
    f22'[t] == 1/2 I A f12[t] - 1/2 I A f21[t], f22[0] == 0, 
    f11[0] == 1, f12[0] == 0, f21[0] == 0}, {f22[t]}, {t, tMin, 
    tMax}, {A, B}]
NArgMax[{soln[A, B], tMin < t < tMax}, {A, B, t}]
(*{3.62302, 2.92786*10^-7, 0.867124}*)

Answer 2

Clear["Global`*"]

eqns = {f11'[t] == -(1/2) I A f12[t] + 1/2 I A f21[t], 
   f12'[t] == -(1/2) I A f11[t] - I B f12[t] + 1/2 I A f22[t], 
   f21'[t] == 1/2 I A f11[t] + I B f21[t] - 1/2 I A f22[t], 
   f22'[t] == 1/2 I A f12[t] - 1/2 I A f21[t], f22[0] == 0, f11[0] == 1, 
   f12[0] == 0, f21[0] == 0};

The equations can be solved exactly with DSolve for arbitrary A and B

sol = DSolve[eqns, {f11, f12, f21, f22}, t]

Verifying the solutions,

eqns /. sol[[1]] // Simplify

(* {True, True, True, True, True, True, True, True} *)

funcs = {f11[t], f12[t], f21[t], f22[t]} /. sol[[1]] // FullSimplify

(* {(A^2 + 2 B^2 + A^2 Cos[Sqrt[A^2 + B^2] t])/(
 2 (A^2 + B^2)), -((
  A (B - B Cos[Sqrt[A^2 + B^2] t] + 
     I Sqrt[A^2 + B^2] Sin[Sqrt[A^2 + B^2] t]))/(2 (A^2 + B^2))), (
 A (-B + B Cos[Sqrt[A^2 + B^2] t] + 
    I Sqrt[A^2 + B^2] Sin[Sqrt[A^2 + B^2] t]))/(2 (A^2 + B^2)), (
 A^2 Sin[1/2 Sqrt[A^2 + B^2] t]^2)/(A^2 + B^2)} *)

funcs[[4]] // InputForm

(* (A^2*Sin[(Sqrt[A^2 + B^2]*t)/2]^2)/(A^2 + B^2) *)

For simplicity, assume that A and B are positive. Then to restrict the argument of the Sin to the interval {0, Pi}

Assuming[A > 0 && B > 0, 
 Reduce[{0 <= (Sqrt[A^2 + B^2]*t)/2 <= Pi, A > 0, B > 0}, t, Reals] //
  Simplify]

(* 0 <= t <= (2 π)/Sqrt[A^2 + B^2] *)

{max, arg} = (NMaximize[
     {funcs[[4]], 0 <= t <= 2 Pi /Sqrt[A^2 + B^2], A > 0, B > 0},
     {t, A, B}, WorkingPrecision -> 15] // Rationalize[#, 0] &) /. 
  r_Rational :> N[r]

(* {1, {t -> 1.82578, A -> 1.72068, B -> 0}} *)

funcs[[4]] /. arg

(* 1. *)