唉，这贴子挂了这么多天，也没一个人回复一下，就自己回一下吧！

把每一个数都采用高精度除法，保留31位，再采用高精度加法累加。一个不太完善的程序如下：
var
a,s:array[0..31] of longint;
i,n,x,k,j:longint;
begin
   for i:=1 to 31 do
     s[i]:=0;
   for k:=1 to 999999 do 
   begin 
      n:=1;
      a[0]:=n div k;
      n:=n mod k;
      j:=1;
      while(j<=31) do
        if (n<k)  then
          begin
           n:=n*10;
           a[j]:=n div k;
           j:=j+1;
          end
         else
          begin
           n:=n mod k;
          end;

   
     for i:=31 downto 1 do
       begin
       s[i]:=s[i]+a[i];
         if s[i]>10 then
                begin
                  s[i]:=s[i]-10;
                  s[i-1]:=s[i-1]+1;
                end
       end;

     s[0]:=s[0]+a[0];
    end;    




   write(s[0],'.');
   for i:=1 to 31 do
     write(s[i]);
  writeln;




end.


end.

我的程序严重超时
  var
    s,t:array [1..50] of byte;
    i,j,a,b:longint;
begin
  fillchar(t,sizeof(t),0);
  for i:=1 to 999999 do begin
    a:=1; b:=i;
    fillchar(s,sizeof(s),0);
    for j:=10 to 50 do begin
      s[j]:=a div b;
      a:=a mod b*10;
      if a=0 then break;
    end;
    for j:=1 to 50 do t[j]:=t[j]+s[j];
    for j:=50 downto 1 do begin
      t[j-1]:=t[j-1]+t[j] div 10;
      t[j]:=t[j] mod 10;
    end;
  end;
  for i:=1 to 10 do if t[i]<>0 then break;
  for j:=i to 10 do write(t[j]);
  write('.');
  for j:=11 to 40 do write(t[j]);
  readln;
end.

那肯定嘎。。
O(999999*2500)
建议预先把1/i的结果算出来，再累加把

好囧，我不会写高精度除法。。。
幸亏NOIP不考。。。。

不过这个只不过是单精度的两个整数相除，最后化为高精度而已，不是完全的高精度除法，所以应该也不难，竞赛也是可以考的吧。
（我两年没考竞赛了，说错什么还多包涵）

什么，高精度除法竟然要考！！！晕菜了。。。。

我只会加法啊，给点分吧，我还是小学生哦，很不容易了哦~
Program gaojingdu;
  var a,b:array[1..256]of integer;
      j,k:qword;
      cd1,cd2,n,i,t,c,f1,f2:integer;
 begin
     readln(j,k);
     while j<>0 do
       begin
           f1:=j mod 10;
           cd1:=cd1+1;
           i:=i+1;
           a[i]:=f1;
           j:=j div 10;
       end;
     while k<>0 do
       begin
           f2:=k mod 10;
           cd2:=cd2+1;
           t:=t+1;
           b[t]:=f2;
           k:=k div 10;
       end;
     if cd1>cd2 then c:=cd1
                else c:=cd2;
     for n:=1 to c do
       begin
           a[n]:=a[n]+b[n];
           if a[n]>10 then
                         begin
                             a[i]:=a[i]-10;
                             a[i+1]:=a[i+1]+1;
                         end;
       end;
     if a[c+1]=0 then c:=c-1;
     for n:=c+1 downto 1 do
         write(a[n]);
  end.