const nn=10;
      sum=1000000;
type my=array[1..1000]of char;
     integer=longint;
var a:array[1..nn]of my;
    n:integer;
    t:array[1..2,1..nn]of integer;
    q:array[1..nn,1..nn]of integer;
    kol:integer;
    b,bb:array[1..nn]of integer;
    sk:array[1..nn]of longint;
    koch,noch:integer;
    tt:array[1..nn]of set of 1..nn;
procedure init;
var i,l:integer;
   ch:char;
begin
 assign(input,'');
 reset(input);
  readln(n);
  for i:=1 to n do
   begin
    ch:=#0;
    kol:=0;
    while ch<>'#' do
     begin
      read(ch);
      if ch='#' then break;
      if ch='*' then
       begin
        inc(kol);
        a[i][kol]:=ch;
        read(ch);
        l:=ord(ch)-48;
        inc(q[i,l]);
        inc(sk[i]);
       end;
      inc(kol);
      a[i][kol]:=ch;
     end;
    b[i]:=kol;
    read(ch);
    read(ch);
  end;
 close(input);
end;
procedure outNo;
begin
 assign(output,'');
 rewrite(output);
  write('#');
 close(output);
 halt;
end;
procedure createTree;
var st:set of 1..nn;
    ch,i:integer;
begin
 koch:=1;
 noch:=1;
 st:=[1];
 t[1,koch]:=1;
 t[2,koch]:=0;
 tt[1]:=[1];
 while noch<=koch do
  begin
   ch:=t[1,noch];
   for i:=1 to n do
    if (q[ch,i]<>0)and(not (i in tt[noch]))then
     begin
      inc(koch);
      t[1,koch]:=i;
      t[2,koch]:=noch;
      tt[koch]:=tt[noch]+[i];
     end else
    if (q[ch,i]<>0)and(i in tt[noch])then outNo;
   inc(noch);
  end;
end;
procedure calcSum;
var i:integer;
    sum:longint;
    k1,k2,kk,ch:integer;
begin
 for i:=koch downto 2 do
  begin
   k1:=t[2,i];
   k2:=t[1,i];
   kk:=q[k1,k2];
   b[k2]:=b[k2]-2*sk[k2];
   b[k1]:=b[k1]+kk*b[k2];
  end;
 b[1]:=b[1]-2*sk[1];
 if b[1]>sum then outNo;
end;
procedure solve;
begin
 bb:=b;
 createTree;
 calcSum;
end;
procedure writeAns(k,pp:integer);
var i:integer;
    kk:integer;
begin
 i:=pp;
 while i<=bb[k] do
  begin
   if (a[k][i]='*')then
    begin
     kk:=ord(a[k][i+1])-48;
     writeAns(kk,1);
     inc(i,2);
    end else
    begin
     if (i<=bb[k]) then write(a[k][i]);
     inc(i);
    end;
  end;
end;
procedure outt;
begin
 assign(output,'');
 rewrite(output);
  writeAns(1,1);
 close(output);
end;
begin
 init;
 solve;
 outt;
end.

Try this test:
6
*2*2*2*2*2*2*2*2*2*2#
*3*3*3*3*3*3*3*3*3*3#
*4*4*4*4*4*4*4*4*4*4#
*5*5*5*5*5*5*5*5*5*5#
*6*6*6*6*6*6*6*6*6*6#
a
a
a
a
#

I think your answer is wrong!

const nn=10;
      sum=1000000;
type my=array[1..3000]of char;
     integer=longint;
var a:array[1..nn]of my;
    n:integer;
    t:array[1..2,1..nn]of integer;
    q:array[1..nn,1..nn]of integer;
    kol:integer;
    b,bb:array[1..nn]of integer;
    sk:array[1..nn]of longint;
    koch,noch:integer;
    tt:array[1..nn]of set of 1..nn;
    kkk:longint;

procedure init;
var i,l:integer;
    ch:char;
begin
 assign(input,'');
 reset(input);
  readln(n);
  for i:=1 to n do
   begin
    ch:=#0;
    kol:=0;
    while ch<>'#' do
     begin
      read(ch);
      if ch='#' then break;
      if ch='*' then
       begin
        inc(kol);
        a[i][kol]:=ch;
        read(ch);
        l:=ord(ch)-48;
        inc(q[i,l]);
        inc(sk[i]);
       end;
      inc(kol);
      a[i][kol]:=ch;
     end;
    b[i]:=kol;
    readln;
   end;
 close(input);
end;

procedure outNo;
begin
 assign(output,'');
 rewrite(output);
  write('#');
 close(output);
 halt;
end;

procedure createTree;
var st:set of 1..nn;
    ch,i:integer;
begin
 koch:=1;
 noch:=1;
 st:=[1];
 t[1,koch]:=1;
 t[2,koch]:=0;
 tt[1]:=[1];
 while noch<=koch do
  begin
   ch:=t[1,noch];
   for i:=1 to n do
    if (q[ch,i]<>0)and(not (i in tt[noch]))then
     begin
      inc(koch);
      t[1,koch]:=i;
      t[2,koch]:=noch;
      tt[koch]:=tt[noch]+[i];
     end else
    if (q[ch,i]<>0)and(i in tt[noch])then outNo;
   inc(noch);
  end;
end;

procedure calcSum;
var i:integer;
    k1,k2,kk,ch:integer;
begin
 for i:=koch downto 2 do
  begin
   k1:=t[2,i];
   k2:=t[1,i];
   kk:=q[k1,k2];
   b[k2]:=b[k2]-2*sk[k2];
   b[k1]:=b[k1]+kk*b[k2];
  end;
 b[1]:=b[1]-2*sk[1];
 if b[1]>sum then outNo;
end;

procedure solve;
begin
 bb:=b;
 createTree;
 calcSum;
end;

procedure writeAns(k,pp:integer);
var i:integer;
    kk:integer;
begin
 i:=pp;
 while i<=bb[k] do
  begin
   if (a[k][i]='*')then
    begin
     kk:=ord(a[k][i+1])-48;
     writeAns(kk,1);
     inc(i,2);
    end else
    begin
     if (i<=bb[k]) then
      begin
       write(a[k][i]);
       inc(kkk);
      end;
     inc(i);
    end;
  end;
end;

procedure outt;
begin
 assign(output,'');
 rewrite(output);
  writeAns(1,1);
  writeln(kkk);
 close(output);
end;

begin
 init;
 solve;
 outt;
end.

> Try this test:
> 6
> *2*2*2*2*2*2*2*2*2*2#
> *3*3*3*3*3*3*3*3*3*3#
> *4*4*4*4*4*4*4*4*4*4#
> *5*5*5*5*5*5*5*5*5*5#
> *6*6*6*6*6*6*6*6*6*6#
> a
> a
> a
> a
> #
>
> I think your answer is wrong!

#13#10 is one simbol?

What do you mean ???

It's the "return symbol".
In C/C++ "return symbol" is '\n', it is just 1 byte.
But in Pascal "return symbol" is #13#10, it is 2 byte.

My program made the same mistake as your :-)
Good Luck!

How can i delete this bug ??????

> How can i delete this bug ??????
Your program dont use constant "sum"
you subscribe it in procedure calcSum as variable!