%SYSTEMROUTINESPEC PHEX(%INTEGER N)
!* PERQ IMP DIAGNOSTIC ROUTINE (ALAN 19/FEB/82)
!*
! LAYOUT OF DIAGNOSIC TABLES
!****** ** ********* ******
! THE BOUND FIELD OF PLT DESCRIPTOR STORED AT (LNB+3 & LNB+4) IF
! USED TO CONTAIN A DISPLACEMENT RELATIVE TO THE START OF SST OF THE
! DIAGNOSTIC TABLES FOR THE BLOCK OR ROUTINE BEING EXECUTED.
! A ZERO BOUND MEANS NO DIAGNOSTIC REQUESTED.(NB THIS MAY MEAN A DUMMY
! FIRST WORD IN THE SST).
! THE ABSOLUTE ADDRESS OF THE SST FOR THE CURRENT CODE SEGMENT WILL
! ALWAYS BE FOUND IN THE STANDARD 10 WORDS OF THE GLA/PLT
! FORM OF THE TABLES:-
! WORD 0    =   LINE OF RT IN SOURCE PROG <<16 ! LINE NO POSN(FROM LNB)
! WORD 1    =   (12 LANG DEPENDENT BITS)<<20 ! ENVIRONMENT
!               (TOP 2 BITS FOR ROUTINE TYPE.B'01'==SYSTEM ROUTINE)
!               (NEXT BIT SET FOR EBCDIC CHARS&STRINGS(ALGOLE ONLY))
! WORD 2    =   DISPLAY POSN (FROM LNB)<<16 ! RT TYPE INFO
! WORD 3    =   ZERO FOR BLKS OR STRING(<=11BYTES) BEING THE
!               RT NAME. THIS WILL TAKE WORDS 4 AND 5 IF NEEDED
! WORD 6    =  LANGUAGE DEPENDENT INFO . IMP ON CONDITIONS ETC
! THE REST IS MADE UP OF VARIABLE ENTRIES AND THE SECTION IS TERMINATED BY
! A WORD OF X'FFFFFFFF'
!  EACH VARIABLE ENTRY CONSISTS OF THE VARIABLE WORD FOLLOWED BY
! THE VARIABLE NAME AS A STRING. THE WORD CONSISTS OF
! BITS 2**31 TO 2**20 TYPE INFORMATION (MAY BE LANGUAGE DEPENDENT
! BIT  2**19  =0 UNDER LNB =1 IN GLA
! BITS 2**18 TO 2**0 DISPLACEMENT FROM LNB(GLA) IN BYTES
! THE ENVIRONMENT IS A POINTER (RELATIVE TO SST) OF THE NEXT OUTERMOST
! BLOCK OR A POINTER TO GLOBAL OWNS, EXTERNAL OR COMMON AREAS
! A ZERO MEANS NO ENCLOSING BLOCK. WORD1=WORD3=0 IS AN
! IMP MAIN PROGRAM AND WILL TERMINATE THE DIAGNOSTICS.
!!
!! NOTE: ALL DISPLACEMENTS ARE BYTE WITHIN THE DIAGNOSTIC TABLES.
!!
%EXTERNALROUTINE QINDIAG(%INTEGER LP,GP,ACB,ADIAGS,%INTEGER DIAGDISP,MODE,   %C
         DIAG, ASIZE, FIRST, %INTEGERNAME FLAG)
!***********************************************************************
!*       THE DIAGNOSTIC ROUTINE FOR IMP                                *
!*       MODE = 0 FOR JOBBER&EMAS2900, =1 FOR OPEH IN VMEB&VMEK        *
!*       DIAG = DIAGNOSTIC LEVEL                                       *
!*       1 = ROUTE SUMMARY ONLY (ASIZE)=ADDR MODULE NAME FROM OPEH     *
!*       2 = DIAGNOSTICS AS TRADITIONALLY PERFORMED                    *
!*       ASIZE IS NO OF ELEMENTS OF EACH ARRAY TO BE PRINTED(DIAG>1)   *
!***********************************************************************
%RECORDFORMAT VARF(%HALFINTEGER FLAGS,DISP, %STRING (11) VNAME)
%ROUTINESPEC PLOCALS(%INTEGER ADATA, %STRING (15) LOC)
%ROUTINESPEC PSCALAR(%RECORD(VARF)%NAME VAR)
! %ROUTINESPEC PARR(%RECORD(VARF)%NAME VAR, %INTEGER ASIZE)
%ROUTINESPEC PVAR(%HALFINTEGER TYPE, PREC, NAM, FORM,  %C
         %INTEGER VADDR)
%INTEGERFNSPEC CKREC(%STRING(51) NAME); ! CHECK RECURSION
%RECORDFORMAT RTHEADF(%HALFINTEGER RTLINE,LINENO POS,RTFLAGS,
                                 ENV,DISPLAY,RTTYPE,
                          (%HALFINTEGER IDHEAD %OR %STRING(11) RTNAME))
!*                      FOLLOWED BY 32 BITS ONCOND WORD
!*
!*
%RECORD(RTHEADF)%NAME RTHEAD
%RECORD(VARF)%NAME VAR
%HALFINTEGER TYPE
%INTEGER GLAAD, FLINE, NAM,  PREC, TSTART,  I
%OWNINTEGERARRAY GLOBAD(0:20)
%HALFINTEGER INHIBIT
%HALFINTEGER RLEN
%OWNINTEGER GLOBPTR
%STRING (10) STMNT
%STRING (20) PROC
%STRING (51) NAME
%HALFINTEGER COUNT;                         ! Used in checking for recursion.
      %IF FIRST=1 %THEN %START
         GLOBPTR=0
         COUNT = 0
      %FINISH
      STMNT=" LINE"
      PROC=" ROUTINE/FN/MAP " 
      %CYCLE
         TSTART=ADIAGS+DIAGDISP; ! Address of shareable symbol tables.
         RTHEAD==RECORD(TSTART)
         %IF RTHEAD_LINENO POS=0 %THEN FLINE=-1   %C
                        %ELSE FLINE=HALFINTEGER(LP+(RTHEAD_LINENO POS>>1))
      %IF RTHEAD_IDHEAD#0 %START
         NAME = RTHEAD_RTNAME
         INHIBIT = CKREC (NAME); ! CHECK RECURSION
        %FINISHELSE INHIBIT=0
         %IF INHIBIT=0 %START
            NEWLINE
            %IF MODE=1 %THEN PRINTSTRING(" IMP ") %ELSE %START
               %IF FIRST=1 %THEN FIRST=0 %C
                  %AND PRINTSTRING("DIAGNOSTICS ")
               PRINTSTRING("ENTERED FROM")
            %FINISH
            %IF RTHEAD_RTLINE=0 %THEN %START
               %IF MODE=0 %THEN PRINTSTRING(" IMP ")
               PRINTSTRING("ENVIRONMENTAL BLOCK
   ")
            %FINISH %ELSE %START
               %IF FLINE>=0 %AND FLINE#RTHEAD_RTLINE %THEN %START
                  PRINTSTRING(STMNT)
                  WRITE(FLINE,4)
                  PRINTSTRING(" OF")
               %FINISH
               %IF RTHEAD_IDHEAD=0 %THEN PRINTSTRING(" BLOCK")  %AND RLEN=10 %C
                  %ELSE PRINT STRING(PROC.NAME) %AND RLEN =(20+LENGTH(RTHEAD_RTNAME))>>2<<1
               PRINTSTRING(" STARTING AT".STMNT)
               WRITE(RTHEAD_RTLINE,2)
               NEWLINE
               %IF MODE=0 %OR DIAG>1 %THEN %START
                 PLOCALS(TSTART+RLEN,"LOCAL")
                  %IF RTHEAD_RTFLAGS&X'C000'#0 %THEN %START
                                           ! EXTERNAL(ETC) ROUTINE
                     I = ADIAGS + ((RTHEAD_ENV+20)>>1)
                     PLOCALS(I,"GLOBAL")
                  %FINISH
               %FINISH
            %FINISH
         %FINISH
         %IF RTHEAD_IDHEAD#0 %START
               FLAG = 1 ;! ROUTINE
            %UNLESS DIAG = 1  %OR INHIBIT=1 %THEN NEWLINE
            %RETURN
         %FINISH
         DIAGDISP=RTHEAD_ENV>>1
      %REPEAT %UNTIL DIAGDISP=0
         FLAG = 0  ;! MAIN PROGRAM
      NEWLINE
      %RETURN
%ROUTINE QSORT(%RECORD(VARF)%ARRAYNAME A, %HALFINTEGER I, J)
%RECORD (VARF)D
%HALFINTEGER L, U
      %IF I>=J %THEN %RETURN
      L = I - 1;  U = J;  D = A(J)
      %CYCLE
         %CYCLE
            L = L+1
      {%EXIT outer loop} %IF L=U %THEN -> FOUND
         %REPEAT %UNTIL A(L)_VNAME>D_VNAME
         A(U) = A(L)
         %CYCLE
            U = U-1
      {%EXIT outer loop} %IF L=U %THEN -> FOUND
         %REPEAT %UNTIL D_VNAME>A(U)_VNAME
         A(L) = A(U)
      %REPEAT
FOUND:
      A(U) = D
      QSORT(A,I,L-1)
      QSORT(A,U+1,J)
%END
!*
%INTEGERFN CKREC(%STRING(51) NAME); ! CHECK RECURSION
!********************************************************
!*    AVOID PRINTING TRACE OF RECURSING RTS             *
!********************************************************
%OWNSTRING(51) LASTNAME=""
%IF LASTNAME=NAME %START
   COUNT=COUNT+1
   %IF COUNT=6 %THEN PRINTSTRING("


**** ".NAME." CONTINUED TO RECURSE ****

")
%RESULT=1 %IF COUNT>5
%FINISHELSESTART
   %IF COUNT>6 %THEN %START
       PRINTSTRING("**** (FOR A FURTHER ")
        WRITE(COUNT-6,1)
        PRINTSTRING(" LEVEL")
       %IF COUNT>7 %THEN PRINTSYMBOL('S')
       PRINTSTRING(") ****


")
     %FINISH
     COUNT=0
      LASTNAME=NAME
  %FINISH
%RESULT=0
%END
%ROUTINE PLOCALS(%INTEGER ADATA, %STRING (15) LOC)
!***********************************************************************
!*      ADATA POINTS TO THE FIRST ENTRY FOR LOCALS IN THE SYMBOL TABLES*
!***********************************************************************
%RECORD(VARF) %NAME VAR
%HALFINTEGER I, NRECS
%INTEGER SADATA
      %IF LOC="GLOBAL" %THEN %START
         I=0
         %WHILE I<GLOBPTR %CYCLE
            %IF GLOBAD(I)=ADATA %THEN %RETURN
            I=I+1
         %REPEAT
         %IF GLOBPTR<=20 %THEN %START
            GLOBAD(GLOBPTR)=ADATA
            GLOBPTR=GLOBPTR+1
         %FINISH
      %FINISH
      NEWLINE
      %IF INTEGER(ADATA)<0 %THEN PRINTSTRING("NO ")
      PRINTSTRING(LOC." VARIABLES
")
      NRECS=0;  SADATA=ADATA
      %WHILE INTEGER(ADATA)>0 %CYCLE
         VAR == RECORD(ADATA)
         NRECS=NRECS+1
           ADATA=ADATA+((8+LENGTH(VAR_VNAME))>>2<<1) 
      %REPEAT
      %RETURN %IF NRECS=0
%BEGIN
%RECORD(VARF)%ARRAY VARS(1:NRECS)
%HALFINTEGER I
      ADATA=SADATA
      %FOR I=NRECS,-1,1 %CYCLE
         VAR == RECORD(ADATA)
         VARS(I)<-RECORD(ADATA)
        ADATA = ADATA + ((8+LENGTH(VAR_VNAME))>>2<<1)
      %REPEAT
      QSORT(VARS,1,NRECS)
      %FOR I=1,1,NRECS %CYCLE
         %IF VARS(I)_FLAGS>>12&3=0 %THEN PSCALAR(VARS(I))
      %REPEAT
!      %IF ASIZE>0 %THEN %START
!         %FOR I=1,1,NRECS %CYCLE
!            %IF VARS(I)_FLAGS>>12&3#0 %THEN PARR(VARS(I), %C
!               ASIZE)
!         %REPEAT
!      %FINISH
%END
%END
%ROUTINE PSCALAR(%RECORD(VARF)%NAME VAR)
!***********************************************************************
!*       OUTPUT THE NEXT VARIABLE IN THE CURRENT BLOCK.                *
!*       A VARIABLE ENTRY IN THE TABLES IS:-                           *
!*       FLAG<<20!VBREG<<18!DISP                                       *
!*       WHERE:-                                                       *
!*         VBREG IS VARIABLE'S BASE REGISTER, DISP IS IT'S OFFSET      *
!*         AND FLAGS=NAM<<6!PREC<<3!TYPE                               *
!***********************************************************************
%INTEGER VADDR
%HALFINTEGER I,K
%STRING (11) LNAME
      I=VAR_FLAGS
      K=I>>4
      TYPE=K&7
      PREC=K>>4&7
      NAM=K>>10&1
      LNAME<-VAR_VNAME."          "
      PRINT STRING(LNAME."=")
      %IF I&X'4'=0 %THEN VADDR=LP %ELSE VADDR=GP
      VADDR=VADDR+(VAR_DISP>>1)
      PVAR(TYPE,PREC,NAM,0,VADDR)
      NEWLINE
%END

%ROUTINE PRHEX(%INTEGER N)

%CONSTBYTEINTEGERARRAY K(0:15)='0','1','2','3','4','5','6','7','8','9','A','B','C','D','E','F'
%HALFINTEGER I,J
%CYCLE J=1,-1,0
   %CYCLE I=12,-4,0
       PRINTSYMBOL(K((HALFINTEGER(ADDR(N)+J)>>I)&15))
   %REPEAT
%REPEAT
%END

%ROUTINE PVAR(%HALFINTEGER TYPE, PREC, NAM, FORM, %INTEGER VADDR)
!***********************************************************************
!*    OUTPUT A VARIABLE. FIXED FORMAT(FORM#0) TAKE 14 PLACES FOR       *
!*    VARIABLES UP TO 32 BITS AND 21 PLACES THEREAFTER                 *
!***********************************************************************
%STRING(255) %NAME SV
%INTEGER A
%STRING(255) SX
%HALFINTEGER K, I, J, DTOPHALF
%CONSTINTEGER UNASSI=X'80808080'
%SWITCH INTV, REALV(3:7)
     %BYTEINTEGERARRAYFORMAT SAFM(0:255)
     %BYTEINTEGERARRAYNAME SA
      %IF NAM#0 %THEN %START
         VADDR=INTEGER(VADDR)
         ->NOT ASS %IF VADDR=UNASSI
      %FINISH
      ->ILL ENT %IF PREC<3;             ! BITS NOT IMPLEMENTED
      %IF TYPE=1 %THEN ->INTV(PREC)
      %IF TYPE=2 %THEN ->REALV(PREC)
      %IF TYPE=5 %THEN ->STR
INTV(4):                                ! 16 BIT INTEGER
      K=HALFINTEGER(VADDR)
      WRITE(K,12*FORM+1)
      %RETURN
INTV(6):                                ! 64 BIT INTEGER
REALV(7):                               ! 128 BIT REAL
INTV(7):                                ! 128 BIT INTEGER
REALV(3):                               ! 8 BIT REAL
REALV(4):                               ! 16 BIT REAL
ILL ENT:                                ! SHOULD NOT OCCURR
      PRINTSTRING("UNKNOWN TYPE OF VARIABLE")
      %RETURN
INTV(5):                                ! 32 BIT INTEGER
      ->NOT ASS %IF INTEGER(VADDR)=UN ASSI
      WRITE(INTEGER(VADDR),1+12*FORM)
      %UNLESS FORM=1 %OR -255<=INTEGER(VADDR)<=255 %START
      PRINTSTRING(" (X'")
      PRHEX(INTEGER(VADDR));  PRINTSTRING("')")
      %FINISH
      %RETURN
INTV(3):                                ! 8 BIT INTEGER
      WRITE(BYTEINTEGER(VADDR),1+12*FORM);  %RETURN
REALV(5):                               ! 32 BIT REAL
      ->NOT ASS %IF INTEGER(VADDR)=UN ASSI
      PRINT FL(REAL(VADDR),7)
      %RETURN
REALV(6):                               ! 64 BIT REAL
      ->NOT ASS %IF UNASSI=INTEGER(VADDR)=INTEGER(VADDR+4)
      PRINT FL(LONG REAL(VADDR),14)
      %RETURN
STR:
         SV == STRING(VADDR)
         I = (LENGTH(SV)>>1)
!         ->NOT ASS %IF BYTE INTEGER(SVADDR+1)=UNASSI&255=I

     SA == ARRAY(VADDR,SAFM)
      K=1
      %WHILE K<=I %CYCLE
         ->NPRINT %UNLESS 32<=SA(K)<=126 %OR SA(K)=10
         K=K+1
      %REPEAT
      PRINT SYMBOL ('"')
      PRINTSTRING(SV);  PRINT SYMBOL ('"')
      %RETURN
NPRINT:

      PRINT STRING(" CONTAINS UNPRINTABLE CHARS")
      %RETURN
NOT ASS:

      PRINTSTRING("  NOT ASSIGNED")
AIGN:
      %IF PREC>=6 %AND FORM=1 %THEN SPACES(7)
%END;                                   ! PVAR
!!A %INTEGERFN XDP (%INTEGER REFADDR, VADDR, ELSIZE); ! CHECK DUPS
!***********************************************************************
!*    CHECK IF VAR THE SAME AS PRINTED LAST TIME                       *
!***********************************************************************
!!A      ELSIZE=ELSIZE!X'18000000'
!!A      *LDTB_ELSIZE;  *LDA_REFADDR
!!A      *CYD_0;  *LDA_VADDR
!!A      *CPS_%L=%DR
!!A      *JCC_8,<A DUP>
!!A      %RESULT =0
!!AADUP:
!!A       %RESULT =1
!!A %END
!!B %ROUTINE DDV(%INTEGER DV,%INTEGERARRAYNAME LB,UB); ! decode dope vector.
!***********************************************************************
!*    WORK DOWN A DOPE VECTOR DESCRIBED BY WORD DESCRIPTOR DV AND      *
!*    RETURN SIZE,DIMENIONALITY AND SUBSCRIPT RANGES IN DATA           *
!***********************************************************************
!!B %INTEGER I, ND, AD, U
!!B      ND=(DV>>32)&255;  ND=ND//3
!!B      LB(0)=ND;  UB(0)=ND
!!B      AD=INTEGER(ADDR(DV)+4)
!!B      %FOR I=ND,-1,1 %CYCLE
!!B         U=INTEGER(AD+8)//INTEGER(AD+4)-1
!!B         LB(I)=INTEGER(AD)
!!B         UB(I)=LB(I)+U
!!B         AD=AD+12
!!B      %REPEAT
!!B      UB(ND+1)=0
!!B      LB(ND+1)=0
!!B %END
!!C %ROUTINE PARR(%RECORD(VARF)%NAME VAR, %INTEGER ASIZE)
!***********************************************************************
!*    PRINT THE FIRST ASIZE ELEMENTS OF THE ARRAY DEFINED BY VAR       *
!*    ARRAYNAMES PRINTED ALSO AT PRESENT. UP TO COMPILERS TO AVOID THIS*
!***********************************************************************
!!C %INTEGER I, J, K, TYPE, PREC, ELS, ND, VADDR, HDADDR,  %C
      BASEADDR, ELSP, M1, REFADDR, ELSL, DUPSEEN
!!C %INTEGER ARRD,DOPED
!!C %INTEGERARRAY LBS, UBS, SUBS(0:13)
!!C      I=VAR_VAL
!!C      K=I>>20
!!C      PREC=K>>4&7
!!C      TYPE=K&7
!!C      PRINTSTRING("
!!C
!!CARRAY 
!!C      %IF I&X'40000'#0 %THEN VADDR=GLAAD %ELSE VADDR=OLDLNB
!!C      HDADDR=VADDR+I&X'3FFFF'
!!C                                        ! VALIDATE HEADER AND THE 2 DESCRIPTORS
!!C      *LDTB_X'18000010'
!!C      *LDA_HDADDR
!!C      *VAL_(%LNB+1)
!!C      *JCC_3,<HINV>
!!C      ARRD=LONG INTEGER(HDADDR)
!!C      DOPED=LONG INTEGER(HDADDR+8)
!!C      *LD_ARRD
!!C      *VAL_(%LNB+1)
!!C      *JCC_3,<HINV>
!!C      *LD_DOPED
!!C      *VAL_(%LNB+1)
!!C      *JCC_3,<HINV>
!!C      ! Check the descriptor of the dope vector:
!!C      ! It must be a (scaled, bounded) word vector.
!!C      ! The bound must be a multiple of 3.  It is in fact
!!C      ! (3 * No. of dimensions).  The number of dimensions
!!C      ! must be greater than zero and not greater than 12.
!!C      I = (DOPED>>32) !! X'28000000'
!!C      ND = I // 3
!!C      -> HINV %UNLESS 3*ND=I %AND 0<ND<=12
!!C      BASEADDR=INTEGER(ADDR(ARRD)+4)
!!C      DDV(DOPED,LBS,UBS); ! decode dope vector.
!!C      %IF TYPE#5 %THEN ELS=1<<(PREC-3) %ELSE %START
!!C         I=INTEGER(ADDR(DOPED)+4)
!!C         ELS=INTEGER(I+12*(ND-1)+4)
!!C      %FINISH
!!C                                        ! PRINT OUT AND CHECK BOUND PAIR LIST
!!C      PRINT SYMBOL('(');  J=0
!!C      %FOR I=1,1,ND %CYCLE
!!C         SUBS(I)=LBS(I);                ! SET UP SUBS TO FIRST EL
!!C         WRITE(LBS(I),1)
!!C         PRINT SYMBOL(':')
!!C         WRITE(UBS(I),1)
!!C         PRINT SYMBOL(',') %UNLESS I=ND
!!C         J=1 %IF LBS(I)>UBS(I)
!!C      %REPEAT
!!C      PRINT SYMBOL(')')
!!C      NEWLINE
!!C      %IF J#0 %THEN PRINTSTRING("BOUND PAIRS INVALID") %AND %RETURN
!!C      ! WORK OUT HOW MANY ELEMENTS TO PRINT ON A LINE
!!C      %IF       TYPE=5 %THEN ELSP=1 %C
!!C      %ELSE %IF ELS<=4 %THEN ELSP=6 %C
!!C      %ELSE                  ELSP=4
!!C      %CYCLE;                              ! THROUGH ALL THE COLUMNS
!!C                                        ! PRINT COLUMN HEADER EXCEPT FOR 1-D ARRAYS
!!C         %IF ND>1 %THEN %START
!!C            PRINT STRING("
!!CCOLUMN (*,")
!!C            %FOR I=2,1,ND %CYCLE
!!C               WRITE(SUBS(I),1)
!!C               PRINT SYMBOL(',') %UNLESS I=ND
!!C            %REPEAT
!!C            PRINT SYMBOL(')')
!!C         %FINISH
!!C                                        ! COMPUTE THE ADDRESS OF FIRST ELEMENT OF THE COLUMN
!!C         K=0;  M1=1;  I=1
!!C         %WHILE I<=ND %CYCLE
!!C            K=K+M1*(SUBS(I)-LBS(I))
!!C            M1=M1*(UBS(I)-LBS(I)+1)
!!C            I=I+1
!!C         %REPEAT
!!C         VADDR=BASEADDR+K*ELS
!!C         REFADDR=0;                     ! ADDR OF LAST ACTUALLY PRINTED
!!C         DUPSEEN=0;  ELSL=99;      ! FORCE FIRST EL ONTO NEW LINE
!!C!!
!!C! %CYCLE DOWN THE COLUMN AND PRINT THE ELEMENTS. SEQUENCES OF REPEATED
!!C! ELEMENTS ARE REPLACED BY "(RPT)". AT THE START OF EACH LINE THE
!!C! CURRENT VALUE OF THE FIRST SUBSCRIPTED IS PRINTED FOLLOWED BY A APAREN
!!C!!
!!C         %FOR I=LBS(1),1,UBS(1) %CYCLE
!!C            %IF REFADDR#0 %THEN %START; ! CHK LAST PRINTED IN THIS COL
!!C               K = XDP(REFADDR,VADDR,ELS); ! CHECK DUPS
!!C               %IF K#0 %THEN %START
!!C                  PRINT STRING("(RPT)") %IF DUPSEEN=0
!!C                  DUPSEEN=DUPSEEN+1
!!C                  ->SKIP
!!C               %FINISH
!!C            %FINISH
!!C                                        ! START A NEW LINE AND
!!C                                        ! PRINT SUBSCRIPT VALUE IF NEEDED
!!C            %IF DUPSEEN#0 %OR ELSL>=ELSP %START
!!C               NEWLINE;  WRITE(I,3);  PRINT STRING(")")
!!C               DUPSEEN=0;  ELSL=0
!!C            %FINISH
!!C            PVAR(TYPE,PREC,0,1,VADDR)
!!C            ELSL=ELSL+1
!!C            REFADDR=VADDR
!!CSKIP:
!!C            VADDR=VADDR+ELS
!!C            ASIZE=ASIZE-1
!!C            %EXIT %IF ASIZE<0
!!C         %REPEAT;                       ! UNTIL COLUMN FINISHED
!!C         NEWLINE
!!C         %EXIT %IF ASIZE<=0 %OR ND=1
!!C                                        ! UPDATE SECOND SUBSCRIPT TO NEXT COLUMN
!!C                                        ! CHECK FOR AND DEAL WITH OVERFLOW
!!C                                        ! INTO NEXT OR FURTHER CLOUMNS
!!C         I=2;  SUBS(1)=LBS(1)
!!C         %CYCLE
!!C            SUBS(I)=SUBS(I)+1
!!C            %EXIT %UNLESS SUBS(I)>UBS(I)
!!C            SUBS(I)=LBS(I);             ! RESET TO LOWER BOUND
!!C            I=I+1
!!C         %REPEAT
!!C         %EXIT %IF I>ND;                ! ALL DONE
!!C      %REPEAT;                          ! FOR FURTHER CLOMUNS
!!C      %RETURN
!!CHINV:
!!C      PRINTSTRING(" HAS INVALID HEADER
!!C")
!!C %END;                                   ! OF RT PARR
%END;                                   ! OF RT IDIAGS
!*
%ROUTINE ERMESS(%INTEGER N, INF)
!***********************************************************************
!*       OUTPUTS AN ERROR MESSAGE STORED IN A COMPRESSED FORMAT        *
!***********************************************************************
!!D      %RETURN %IF N<=0
!!D      PRINTMESS(N)
!!D      %IF N=26 %OR N=34 %THEN PRINT SYMBOL(NEXT SYMBOL)
!!D      %IF N=10 %THEN WRITE(INF,1);      ! GIVE WT FOR FUNNY INTS
!!D      NEWLINE
%END;                                   ! ERMESS
!*
%ENDOFFILE