Wealth Distribution Model with
Fractional Transfer and Return on Wealth

NN  =  2000;
TT  =  1000;
MM  =  100;
r  =  0.05;

wealths  =  Table[0.6, {NN}];
logwealths = 
Table[
Log[{i, Reverse[Sort[wealths]][[i]]}], 
{i, 1, 
            NN}
];
ListPlot[
logwealths, 
PlotRange -> {All, {-0.61, 3.9}}, 
Prolog -> {PointSize[
              0.015], Thickness[0.005]}, 
PlotStyle -> 
          RGBColor[1, 0, 
            0], 
AxesStyle  ->  {Thickness[
              0.005]}
];
Do[
Do[
x  =  
            Random[Integer, {1, NN}]; 
y  =  
            Random[Integer, {1, NN}]; 
delta  = 
            0.1  wealths[[y]]; 
wealths  =  
            ReplacePart[wealths, wealths[[x]] + delta, 
              x]; 
wealths  =  
            ReplacePart[wealths, wealths[[y]] - delta, 
              y], 
{m, 1, 
            MM}
]; 
Do[
wealths  =  
            ReplacePart[wealths, 
              wealths[[i]] (1 + 0.2 (Random[Integer] - 0.5)), 
              i], 
{i, 1, 
            Length[wealths]}
]; 
logwealths  =  
Table[
            Log[{i, Reverse[Sort[wealths]][[i]]}], {i, 1, 
              NN}]; 
ListPlot[
logwealths, 
PlotRange -> {All, {-0.61, 
                3.9}}, 
Prolog -> {PointSize[0.015], 
              Thickness[0.005]}, 
PlotStyle -> 
            RGBColor[1, 0, 
              0], 
AxesStyle  ->  {Thickness[
                0.005]}
], 
{t, 1, 
          TT}
];