第一次来到本论坛，没什么好贴的，贴一个很久以前我自己编的程序。这个程序在tp7下至少能输出圆周率的小数点后10000位。
你可以自己改变dn的值试试。


program spi;
uses crt;
{ pi=16acrtg(1/5)-4arctg(1/239)   }
{ pi/4=1/1*(20/25-239/57121)-1/3(20/25^2-239/57121^2)+... }
label ext,ext2;
const
      dn=2502;
var
   i,ip,c:integer;
   k:longint;
   a,b,sum:array[1..dn] of integer;

procedure oupt;
var i:integer;
    k:longint;

procedure testk;
var
   ch:char;
begin
     if k mod 10=0 then write(' ');
     if (k mod 50=0) and (k mod 1000<>0) then
              writeln(':',k:8);
     if k mod 1000<>0 then exit;
     writeln(':',k:8,'  Press any key');
     ch:=readkey;
     writeln;

end;

begin
   clrscr;  k:=0;
   writeln('PI=');
   writeln(sum[1],'.');
   for i:=2 to dn do
     begin
       write(sum[i] div 1000);  k:=k+1; testk;
       write(sum[i] div 100 mod 10); k:=k+1; testk;
       write(sum[i] div 10 mod 10 ); k:=k+1; testk;
       write(sum[i] mod 10);  k:=k+1; testk;
     end;
   writeln; writeln;
   writeln('Programmed by j.t.chang.');

end;

procedure m_div(k:longint);
var
    i:integer;
    r1,c:longint;
begin
   c:=0;
   for i:=ip to dn do
     begin
        r1:=c*10000+a[i];
        a[i]:=r1 div k;
        c:=r1 mod k;
     end;
end;
procedure m_div2(k:longint);
var
    i:integer;
    r1,c:longint;
begin
   c:=0;
{   for i:= ip-1 downto 1 do  b[i]:=0; }
   for i:=ip to dn do
     begin
        r1:=c*10000+a[i];
        b[i]:=r1 div k;
        c:=r1 mod k;
     end;
end;


procedure sum_add;
var
   i:integer;
   r1,c:longint;
begin
   c:=0;
   for i:= dn downto ip do
    begin
        r1:=c+b[i]+sum[i];
        if r1>9999 then
          begin
              sum[i]:=r1 - 10000;
              c:=1;
          end
         else
           begin
             sum[i]:=r1;
             c:=0;
           end;
    end;
   if c=0 then exit;
   i:=ip-1;
   while c>0 do
      begin
         if i=1 then
            begin
               sum[1]:=c+sum[1];
               exit;
            end
         else
            begin
              r1:=c+sum[i];
              if r1>9999 then
                begin
                    sum[i]:=r1 - 10000;
                    c:=1;
                 end
               else
                  begin
                    sum[i]:=r1;
                    c:=0;
                  end;
            end;
          i:=i-1;
      end;
end;
procedure sum_sub;
var
   i:integer;
   r1,c:longint;
begin
   c:=0;
   for i:= dn downto ip do
    begin
        r1:=c-b[i]+sum[i];
        if r1<0 then
          begin
              sum[i]:=r1+10000;
              c:=-1;
          end
         else
           begin
             sum[i]:=r1;
             c:=0;
           end;
    end;
   if c=0 then exit;
   i:=ip-1;
   while c<0 do
      begin
         if i=1 then
            begin
               sum[1]:=c+sum[1];
               exit;
            end
         else
            begin
               r1:=c+sum[i];
               if r1<0 then
                 begin
                    sum[i]:=r1+10000;
                    c:=-1;
                 end
              else
                  begin
                     sum[i]:=r1;
                     c:=0;
                  end;
            end;
          i:=i-1;
      end;
end;

procedure proc;
var
  r1,c:longint;
  i:integer;
begin
    c:=0;
    for i:=dn downto 1 do
      begin
        r1:=1;
        r1:=c+r1*sum[i]*4;
        if r1>9999 then
          begin
             sum[i]:=r1 mod 10000;
             c:=r1 div 10000;
          end
        else
           begin
             sum[i]:=r1;
             c:=0;
           end;
      end;

end;

begin
   clrscr;
   for i:=1 to dn do sum[i]:=0;
   a:=sum;
   a[1]:=20;
   k:=1;
   ip:=1;
   c:=1;
   repeat
      gotoxy(1,1);
      write(ip:8);
      i:=ip;
      while  a[i]=0 do
        begin
            i:=i+1;
            if i>dn then goto ext;
        end;
      ip:=i;
      m_div(25);
      m_div2(k);
      if c=1 then  sum_add
       else sum_sub;
      k:=k+2;
      c:=-c;
   until false;
ext:
   for i:=1 to dn do a[i]:=0;
   a[1]:=239;
   b:=a;
   k:=1;
   ip:=1;
   c:=-1;
   repeat
      gotoxy(1,1);
      write(ip:8);
      i:=ip;
      while  a[i]=0 do
        begin
            i:=i+1;
            if i>dn then goto ext2;
        end;
      ip:=i;
      m_div(57121);
      m_div2(k);
      if c=1 then  sum_add
       else sum_sub;
      k:=k+2;
      c:=-c;
   until false;
ext2:
      proc;
      gotoxy(1,10);
      oupt;
end.