Sorry about that. I really ought to upgrade to 9.

Apparently Mathematica added some new features in version 9 that are intended to better handle differential equations with discontinuities (see http://reference.wolfram.com/mathematica/tutorial/NDSolveWhe...). Apparently this is getting tripped up at the boundary between the two behaviors.

One simple thing that might work is to change the force law to either

  force[disp1_, disp2_, dir_] := -k Abs[(disp1 - disp2).dir ]^(3/2) dir* If[(disp1 - disp2).dir > 0, 1, 0]

or

  force[disp1_, disp2_, dir_] := -k Abs[(disp1 - disp2).dir ]^(3/2) dir* Piecewise[{{1, (disp1 - disp2).dir > 0}}, 0]

If these don't fix it, then you would need to play around with the options for NDSolve.