var
n:array[1..9,0..1001]of char;
b:array[1..9]of byte;
textlen:array[1..9]of longint;
wypisane,ile:longint;

procedure wczytaj;
var
   i,k:longint;
   zn:char;
   zb:text;
begin
{assign(zb,'1253.in');
reset(zb);}
readln({zb,}ile);
 for i:=1 to ile do
  begin
  k:=0;
  read({zb,}zn);
   while zn<>'#'do
    begin
    inc(k);
    n[i,k]:=zn;
    read({zb,}zn)
    end;
  inc(k);
  n[i,k]:='#';
  readln{(zb)}
  end;
{close(zb)}
end;

procedure dzialaj(x:longint);
 var
  i,kt:longint;
  zn:char;
begin
 i:=1;
 zn:=n[x,i];
  while zn<>'#'do
   begin
    if zn='*' then
      begin
       kt:=ord(n[x,i+1])-48;
       i:=i+2;
       dzialaj(kt)
      end
    else
     begin
     write(zn);
     inc(i)
     end;
   zn:=n[x,i];
   end;
end;

procedure koniec;
begin
writeln('#');
halt
end;

procedure dfsvisit(v:byte);
var zn:char;
     i:integer;
begin
b[v]:=1;
i:=1;
textlen[v]:=0;
zn:=n[v,i];
 while zn<>'#'do
  begin
   if ((ord(zn)-48)>0)and((ord(zn)-48)<10)and(n[v,i-1]='*')then
    begin
     if b[ord(zn)-48]=1 then
      begin
       writeln('#');
       halt
      end
     else if b[ord(zn)-48]=2 then
       begin
       textlen[v]:=textlen[v]+textlen[ord(zn)-48];
       if textlen[v]>1000000 then koniec
       end
     else if b[ord(zn)-48]=0 then
      begin
      dfsvisit(ord(zn)-48);
      textlen[v]:=textlen[v]+textlen[ord(zn)-48];
      if textlen[v]>1000000 then koniec
      end;
     inc(i)
    end
   else if zn='*'then inc(i)
   else
     begin
     inc(textlen[v]);
     if textlen[v]>1000000 then koniec;
     inc(i)
     end;
   zn:=n[v,i]
  end;
b[v]:=2;
end;

procedure dfs;
begin
 fillchar(b,sizeof(b),0);
 fillchar(textlen,sizeof(textlen),0);
 dfsvisit(1)
end;

begin
wczytaj;
dfs;
dzialaj(1);
end.

I got accepted with your program making FEW modifications:

1)
n:array[1..9,0..1001]of char;
replaced with
n:array[1..9,0..1021]of char;

2) replaced all 48 by ord('0');

3) In DFSvisit
added Next varible: Next := ord(zn)-48
every occurance of ord(zn)-48 replaced by Next
this avoided recalculating ord(zn)-48.

I got AC after 0.991 second extreme!!!

----- ALMOST YOUR PROGRAM -----
var
n:array[1..9,0..1021]of char;
b:array[1..9]of byte;
textlen:array[1..9]of longint;
wypisane,ile:longint;

procedure wczytaj;
var
   i,k:longint;
   zn:char;
   zb:text;
begin
readln({zb,}ile);
 for i:=1 to ile do
  begin
  k:=0;
  read({zb,}zn);
   while zn<>'#'do
    begin
    inc(k);
    n[i,k]:=zn;
    read({zb,}zn)
    end;
  inc(k);
  n[i,k]:='#';
  readln{(zb)}
  end;
{close(zb)}
end;

procedure dzialaj(x:longint);
 var
  i,kt:longint;
  zn:char;
begin
 i:=1;
 zn:=n[x,i];
  while zn<>'#'do
   begin
    if zn='*' then
      begin
       kt:=ord(n[x,i+1])-Ord('0');
       i:=i+2;
       dzialaj(kt)
      end
    else
     begin
     write(zn);
     inc(i)
     end;
   zn:=n[x,i];
   end;
end;

procedure koniec;
begin
writeln('#');
halt
end;

procedure dfsvisit(v:byte);
var zn:char;
    next: Integer;
     i:integer;
begin
b[v]:=1;
i:=1;
textlen[v]:=0;
zn:=n[v,i];
 while zn<>'#'do
  begin
   if ((ord(zn)-Ord('0'))>0)and((ord(zn)-Ord('0'))<10)and(n[v,i-1]
='*')then
    begin
        Next := ord(zn)-Ord('0');

     if b[Next]=1 then
      begin
       writeln('#');
       halt
      end
     else if b[Next]=2 then
       begin
       textlen[v]:=textlen[v]+textlen[Next];
       if textlen[v]>1000000 then koniec
       end
     else if b[Next]=0 then
      begin
      dfsvisit(Next);
      textlen[v] := textlen[v]+textlen[Next];
      if textlen[v]>1000000 then koniec
      end;
     inc(i)
    end
   else if zn='*'then inc(i)
   else
     begin
     inc(textlen[v]);
     if textlen[v]>1000000 then koniec;
     inc(i)
     end;
   zn:=n[v,i]
  end;
b[v]:=2;
end;

procedure dfs;
begin
 fillchar(b,sizeof(b),0);
 fillchar(textlen,sizeof(textlen),0);
 dfsvisit(1)
end;

begin
wczytaj;
dfs;
dzialaj(1);
end.

> I got accepted with your program making FEW modifications:
>
> 1)
> n:array[1..9,0..1001]of char;
> replaced with
> n:array[1..9,0..1021]of char;
>
> 2) replaced all 48 by ord('0');
>
> 3) In DFSvisit
> added Next varible: Next := ord(zn)-48
> every occurance of ord(zn)-48 replaced by Next
> this avoided recalculating ord(zn)-48.
>
> I got AC after 0.991 second extreme!!!
>
> ----- ALMOST YOUR PROGRAM -----
> var
> n:array[1..9,0..1021]of char;
> b:array[1..9]of byte;
> textlen:array[1..9]of longint;
> wypisane,ile:longint;
>
> procedure wczytaj;
> var
>    i,k:longint;
>    zn:char;
>    zb:text;
> begin
> readln({zb,}ile);
>  for i:=1 to ile do
>   begin
>   k:=0;
>   read({zb,}zn);
>    while zn<>'#'do
>     begin
>     inc(k);
>     n[i,k]:=zn;
>     read({zb,}zn)
>     end;
>   inc(k);
>   n[i,k]:='#';
>   readln{(zb)}
>   end;
> {close(zb)}
> end;
>
> procedure dzialaj(x:longint);
>  var
>   i,kt:longint;
>   zn:char;
> begin
>  i:=1;
>  zn:=n[x,i];
>   while zn<>'#'do
>    begin
>     if zn='*' then
>       begin
>        kt:=ord(n[x,i+1])-Ord('0');
>        i:=i+2;
>        dzialaj(kt)
>       end
>     else
>      begin
>      write(zn);
>      inc(i)
>      end;
>    zn:=n[x,i];
>    end;
> end;
>
> procedure koniec;
> begin
> writeln('#');
> halt
> end;
>
> procedure dfsvisit(v:byte);
> var zn:char;
>     next: Integer;
>      i:integer;
> begin
> b[v]:=1;
> i:=1;
> textlen[v]:=0;
> zn:=n[v,i];
>  while zn<>'#'do
>   begin
>    if ((ord(zn)-Ord('0'))>0)and((ord(zn)-Ord('0'))<10)and(n[v,i-1]
> ='*')then
>     begin
>         Next := ord(zn)-Ord('0');
>
>      if b[Next]=1 then
>       begin
>        writeln('#');
>        halt
>       end
>      else if b[Next]=2 then
>        begin
>        textlen[v]:=textlen[v]+textlen[Next];
>        if textlen[v]>1000000 then koniec
>        end
>      else if b[Next]=0 then
>       begin
>       dfsvisit(Next);
>       textlen[v] := textlen[v]+textlen[Next];
>       if textlen[v]>1000000 then koniec
>       end;
>      inc(i)
>     end
>    else if zn='*'then inc(i)
>    else
>      begin
>      inc(textlen[v]);
>      if textlen[v]>1000000 then koniec;
>      inc(i)
>      end;
>    zn:=n[v,i]
>   end;
> b[v]:=2;
> end;
>
> procedure dfs;
> begin
>  fillchar(b,sizeof(b),0);
>  fillchar(textlen,sizeof(textlen),0);
>  dfsvisit(1)
> end;
>
> begin
> wczytaj;
> dfs;
> dzialaj(1);
> end.
>