Dinamica Cuantica

phi[x_, 
            n_Integer] := 
(Sqrt[(1/((Sqrt[Pi ])*(2^(n ))* n!))]) * Exp[((-(x^2))/2)]* 
            HermiteH[n , x ]


  

ω = 1;
Ener[
              n_Integer]  :=    (n + (1/2)) ω;

Plot[
{phi[x, 0], phi[x, 1], 
          phi[x, 2]}, {x, -5, 
          5},  
PlotStyle  ->  {{RGBColor[0, 0, 
                1]}, {RGBColor[
                0,  .5,  .5]}, 
                                  {RGBColor[1, 0, 
                0]}
                       } , 
ImageSize  ->  
          500
   ];

τ  =  2*Pi/(Ener[0]);

Table[
                Plot[
        {     Re[  phi[
                          x, 0]*Exp[- I*Ener[0]*
                            t] ] , 
       Im[  phi[x, 0]*Exp[- I*Ener[0]*t]  ], 
Abs[
                      phi[x, 0]*
                        Exp[- I*Ener[0]*
                            t] ]
}, 
        {x, -5, 
                    5},  
         PlotRange  ->  {- .8,  .8}, 
       PlotStyle  ->  {
                                  {RGBColor[0, 0, 
                          1]}, 
                                 {RGBColor[0, 1, 
                          0]}, 
                                  {RGBColor[1, 0, 0],  
                        Thickness[
                          0.01] }
                                 } ,  
      ImageSize  ->  
                    500
       ], 
       {t, 
                  0, τ,  τ/50}
    ];

c  =   {Sqrt[1. /2. ],  
            Sqrt[1. /2. ]};


      Plot[
{phi[x, 0], 
            phi[x, 1], 
c[[1]] phi[x, 0]  +  
              c[[2]] phi[x, 1]}, 
{x, -5, 
            5},  
PlotStyle  ->  {
                          {RGBColor[0, 0, 
                  1]          }, 
                          {RGBColor[0, 
                  0.5,  .5]      }, 
                          {RGBColor[1, 0, 0],  
                Thickness [ 
                  0.01]  }
                        } , 
ImageSize  ->  
            500
];

Table[
              Plot[{Re[
                    c[[1]]*phi[x, 0]*Exp[-I*Ener[0]*t] + 
                      c[[2]]*phi[x, 1]*Exp[-I*Ener[1]*t]], 
                  Im[c[[1]]*phi[x, 0]*Exp[-I*Ener[0]*t] + 
                      c[[2]]*phi[x, 1]*Exp[-I*Ener[1]*t]], 
                  Abs[c[[1]]*phi[x, 0]*Exp[-I*Ener[0]*t] + 
                      c[[2]]*phi[x, 1]*
                        Exp[-I*Ener[1]*
                            t]]}, 
          {x, -5, 5}, 
    PlotRange -> {- .9,  .9}, 
PlotStyle -> {
{RGBColor[0, 0, 
                        1]}, 
{RGBColor[0, 1, 
                        0]}, 
{RGBColor[1, 0, 0],  
                      Thickness[
                        0.01] }
},  
ImageSize  ->  
                  500
        ], 
{t, 0, τ, τ/50}];

c  =   {Sqrt[1. /2. ],  
            Sqrt[1. /2. ]};


      Plot[
{phi[x, 0], 
            phi[x, 2], 
c[[1]] phi[x, 0]  +  
              c[[2]] phi[x, 2]}, 
{x, -5, 
            5},  
PlotStyle  ->  {
                          {RGBColor[0, 0, 
                  1]          }, 
                          {RGBColor[0, 
                  0.5,  .5]      }, 
                          {RGBColor[1, 0, 0],  
                Thickness [ 
                  0.01]  }
                        } , 
ImageSize  ->  
            500
];

(* ---- 
                evolucion temporal de la parte real ---- *) 
   

τ  =  
          2*Pi/(Ener[0]) ;movie1  =  
          Table[Plot[{Re[
                  c[[1]]*phi[x, 0]*
                    Exp[- I*Ener[0]*
                        t] ], 
         Re[
                  c[[2]]*phi[x, 2]*
                    Exp[- I*Ener[2]*t] ], 
Re[
                  c[[1]]*phi[x, 0]*
                      Exp[- I*Ener[0]*
                          t]  + 
       c[[2]]*
                      phi[x, 2]*
                      Exp[- I*Ener[2]*
                          t]]}, 
        {x, -5, 5},  
         PlotRange  ->  {- .9,  .9}, 
     PlotStyle  ->  {
                                  {RGBColor[0, 0, 
                      1]}, 
                                  {RGBColor[0, 
                      0.5,  .5]}, 
                                  {RGBColor[1, 0, 0] ,  
                    Thickness[
                      0.01] }
                             } ,  
   ImageSize  ->  
                500
       ], 
       {t, 
              0, τ,  τ/
                50}
    ] ;

(* ---- 
                  funciones con la misma paridad   ---- *) 
(* ---- Evolucion de la onda (Real, Imaginaria y Modulo)   ---- *)
   

Table[
              Plot[{Re[
                    c[[1]]*phi[x, 0]*Exp[-I*Ener[0]*t] + 
                      c[[2]]*phi[x, 2]*Exp[-I*Ener[2]*t]], 
                  Im[c[[1]]*phi[x, 0]*Exp[-I*Ener[0]*t] + 
                      c[[2]]*phi[x, 2]*Exp[-I*Ener[2]*t]], 
                  Abs[c[[1]]*phi[x, 0]*Exp[-I*Ener[0]*t] + 
                      c[[2]]*phi[x, 2]*
                        Exp[-I*Ener[2]*
                            t]]}, 
          {x, -5, 5}, 
    PlotRange -> {- .9,  .9}, 
PlotStyle -> {
{RGBColor[0, 0, 
                        1]}, 
{RGBColor[0, 1, 
                        0]}, 
{RGBColor[1, 0, 0],  
                      Thickness[
                        0.01] }
},  
ImageSize  ->  
                  500
        ], 
{t, 0, τ, τ/50}];

nmin  =  1; 

          nmax  =  11;

          n0  =  (nmax - nmin)/2 ;

          
          b :=  Table[  Exp[ -(i - n0)^2  /  n0],  {i, 
                nmin,  nmax}]

           Sumb  =  
              Sum[ (b[[n]] )  ,  {n, nmin, 
                  nmax}] ;


          
          b :=  Table[  Exp[ -(i - n0)^2  /  n0]  / 
                Sumb,  {i, nmin,  nmax}]

ListPlot[    b   ,   
                      PlotStyle  ->   {
                                            RGBColor[1, 0.25, 0.25] ,  
                  PointSize[
                    0.03]
                                                   } ,  
PlotRange  ->  
                All,  
ImageSize  ->  
                500
               ] ;

ξ[x_] :=   Sum[  
                                      b[[n]]*phi[x, n - 1] ,
                                       {n, nmin, nmax} 
                                    ] ;

Plot[ {b[[5]]*
            phi[x, 4], b[[6]]*phi[x, 5], 
          b[[7]]*phi[x, 6],   ξ[x]},  {x, -5, 
          5},  
         PlotRange  ->   All,  
         PlotStyle   -> {
                                  {RGBColor[0.2, 0, 0],   Thickness[
                0.001]  }, 
                                  {RGBColor[0.0, 0.2, 0],   Thickness[
                0.001]  }, 
                                  {RGBColor[0, 0, 0.2],   Thickness[
                0.001]  }, 
                                    {RGBColor[1, 0, 0],   Thickness[
                0.01]  }, 
                                  },  
         ImageSize  ->  500] ;

ξ[x_, t_] :=   Sum[  
                                      b[[n]]*phi[x, n - 1]* Exp[-I*Ener[n - 1]*t]   ,
                                       {n, nmin, nmax} 
                                    ] ;

τ  = 1*Pi/(Ener[0]);
Table[
                Plot[ 
      Abs[ ξ[x, 
                      t]  ], 
          {x, -5, 5}, 
    PlotRange ->  {0. , 
                      0.4}, 
PlotStyle -> {
{RGBColor[1, 0, 0],  
                        Thickness[
                          0.01]   }
},  
ImageSize  ->  
                    500
        ], 
{t, 0, τ, τ/25}];

d = 4;

      Plot[
          phi[x - d, 0],  {x, -10, 
            10},  
PlotRange  ->  
            All,  
PlotStyle  ->  {RGBColor[1, 0, 
                0],  Thickness[0.01]}, 
ImageSize  ->  
            500];

f[n_Integer]  :=  
          NIntegrate[ 
            phi[x - d, 0]*phi[x, n - 1],  {x, -Infinity,  
              Infinity}];

nmin  =  1 ;
nmax  =  20;
b :=  Table[  f[n],  {n, nmin,  nmax}];

ListPlot[    b   ,   
                      PlotStyle  ->   {
                                            RGBColor[1, 0.25, 0.25] ,  
                PointSize[
                  0.03]
                                                   } ,  
PlotRange  ->  {0, 
                0.4},  
ImageSize  ->  
              500
               ] ;

b[[n]]

rrr  = {0.018315638888889173`, 0.051804449838926805`, 
        0.10360889968207333`, 0.16919262468414065`, 0.23927450447660478`, 
        0.30266096808297815`, 0.34948278277392736`, 0.3736127972169554`, 
        0.37361281027655086`, 0.35224553559712785`, 0.31505798504125754`, 
        0.26868235234184806`, 0.2193782220055621`, 0.1720944359903972`, 
        0.1300911657910072`, 0.09500515477277238`, 0.06717878889559205`, 
        0.04608426913209869`, 0.030722846088117355`, 
        0.019935615014398337`}

ξ[x_, t_] :=   Sum[  
                                     rrr[[n]]*phi[x, n - 1]* Exp[-I*Ener[n - 1]*t]   ,
                                       {n, nmin, nmax} 
                                    ] ;

τ  = 1*Pi/(Ener[0]);
Table[
                Plot[ 
      Abs[ ξ[x, 
                      t]  ], 
          {x, -10, 10}, 
    PlotRange ->  {0. , 
                      1}, 
PlotStyle -> {
{RGBColor[1, 0, 0],  
                        Thickness[
                          0.01]   }
},  
ImageSize  ->  
                    500
        ], 
{t, 0, τ, τ/25}];

\( (*\ \ \ HTMLSave["coherentes.html", \ "coherentes.nb"]\ \ *) \)