my @k = sort { length($a) <=> length($b) } keys(%h3) ;

  my $lx = length($k[-1]) ;
  my $ll = 0 ;
  my $li = 0 ;

  for my $k (@k) {
    if (length($k) != $ll) {
      $ll = length($k) ;
      last if $ll == $lx ;
      ++$li until length($k[$li]) > $ll ;
    } ;

    for my $i ($li..$#k) {
      next if ($k[$i] !~ /$k/) ; 
      delete $h3{$k} ;
      last ;
    } ; 
  } ;