Can you help me speed up my algorithm?
It give me valid answers but it is slow.

TYPE
  TRef =
    RECORD
      Pos, Num : LongInt;
    END;
VAR
  N, I, J, L : LongInt;
  S : ARRAY[1..20, 1..2000] OF Char;
  XRef : ARRAY[1..20, 1..20] OF TRef;
  CRef : ARRAY[1..20] OF LongInt;
  Size : ARRAY[1..20] OF Integer;
  Used : ARRAY[1..20] OF Byte;
  C : Char;

  FUNCTION Test(C, Total : LongInt) : LongInt;
  VAR
    Result, I : LongInt;
  BEGIN
    IF Used[C] = 1 THEN
      BEGIN
        Write('#'); Halt;
      END;
    IF Total > 1000000 THEN
      BEGIN
        Write('#'); Halt;
      END;
    Used[C] := 1;
    Result := Size[C];
    FOR I := 1 TO CRef[C] DO
      Result := Result+Test(XRef[C][I].Num, Total+Result);
    Test := Result;
    Used[C] := 0;
  END;

  PROCEDURE SWrite(C : LongInt);
  VAR
    I, J, Pred : LongInt;
  BEGIN
    Pred := 1;
    FOR I := 1 TO CRef[C] DO
      WITH XRef[C][I] DO
        BEGIN
          FOR J := Pred TO Pos DO Write(S[C][J]);
          SWrite(Num);
          Pred := Pos+1;
        END;
    FOR J := Pred TO Size[C] DO Write(S[C][J]);
  END;

BEGIN
  ReadLn(N);
  FOR J := 1 TO N DO
    BEGIN
      I := 0;
      WHILE True DO
        BEGIN
          Read(C);
          IF C = '#' THEN Break;
          Inc(I);
          S[J][I] := C;
        END;
      Size[J] := I;
      ReadLn;
    END;
  FillChar(Used, SizeOf(Used), 0);
  FillChar(CRef, SizeOf(CRef), 0);
  FOR J := 1 TO N DO
    BEGIN
      I := 1;
      L := 0;
      WHILE (I <= Size[J]) DO
        BEGIN
          IF (I < Size[J]) AND (S[J][I] = '*') THEN
            BEGIN
              Inc(CRef[J]);
              XRef[J][CRef[J]].Pos := L;
              XRef[J][CRef[J]].Num := Ord(S[J][I+1])-Ord('0');
              Inc(I);
            END
          ELSE
            BEGIN
              Inc(L);
              S[J][L] := S[J][I];
            END;
          Inc(I);
        END;
      Size[J] := L;
    END;
  IF Test(1, 0) > 1000000 THEN
    BEGIN
      Write('#'); Halt;
    END;
  SWrite(1);
END.