%CONSTBYTEINTEGERARRAY OTRTAB(0:127)=%C
                  26(9),9,10,26,12,13,26(11),25,26,26(5),
                  32,33,34,35,36,37,38,39,40,41,42,43,44,45,46,47,
                  48,49,50,51,52,53,54,55,56,57,58,59,60,61,62,63,
                  64,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,
                  80,81,82,83,84,85,86,87,88,89,90,91,92,93,94,95,
                  96,97,98,99,100,101,102,103,104,105,106,107,108,109,
                  110,111,112,113,114,115,116,117,118,119,
                  120,121,122,123,124,125,126,26;
%CONSTBYTEINTEGERARRAY ITRTAB(0:127)=%C
                  X'80'(10),10,X'80'(14),25,26,X'80'(5),
                  32,33,34,35,36,37,38,39,40,41,42,43,44,45,46,47,
                  48,49,50,51,52,53,54,55,56,57,58,59,60,61,62,63,
                  64,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,
                  80,81,82,83,84,85,86,87,88,89,90,91,92,93,94,95,
                  96,97,98,99,100,101,102,103,104,105,106,107,108,109,
                  110,111,112,113,114,115,116,117,118,119,
                  120,121,122,123,124,125,126,X'80';
%CONSTBYTEINTEGERARRAY ITOS4E(0 : 127) =       %C
            X'40',X'40',X'40',X'40',   X'40',X'40',X'40',X'40',
            X'40',X'40',X'15',X'40',   X'0C',X'0D',X'40',X'40',
            X'40',X'40',X'40',X'40',   X'40',X'40',X'40',X'40',
            X'40',X'40',X'40',X'40',   X'40',X'40',X'40',X'40',
            X'40',X'4F',X'7F',X'4A',   X'5B',X'6C',X'50',X'7D',
            X'4D',X'5D',X'5C',X'4E',   X'6B',X'60',X'4B',X'61',
            X'F0',X'F1',X'F2',X'F3',   X'F4',X'F5',X'F6',X'F7',
            X'F8',X'F9',X'7A',X'5E',   X'4C',X'7E',X'6E',X'6F',
            X'7C',X'C1',X'C2',X'C3',   X'C4',X'C5',X'C6',X'C7',
            X'C8',X'C9',X'D1',X'D2',   X'D3',X'D4',X'D5',X'D6',
            X'D7',X'D8',X'D9',X'E2',   X'E3',X'E4',X'E5',X'E6',
            X'E7',X'E8',X'E9',X'4A',   X'5F',X'5A',X'5F',X'6D',
            X'7C',X'81',X'82',X'83',   X'84',X'85',X'86',X'87',
            X'88',X'89',X'91',X'92',   X'93',X'94',X'95',X'96',
            X'97',X'98',X'99',X'A2',   X'A3',X'A4',X'A5',X'A6',
            X'A7',X'A8',X'A9',X'C0',   X'6A',X'D0',X'5F',X'FF';
%CONSTBYTEINTEGERARRAY S4ETOI(0 : 255) =     0,
     1,     2,     3,   127,     9,   127,   127,   127,   127,   127,
    11,    12,    13,    14,    15,    16,    17,    18,    19,   127,
    10,     8,   127,    24,    25,   127,   127,    28,    29,    30,
    31,   127,   127,   127,   127,   127,    10,    23,    27,   127,
   127,   127,   127,   127,     5,     6,     7,   127,   127,    22,
   127,   127,   127,   127,     4,   127,   127,   127,   127,    20,
    21,   127,    26,    32,   127,   127,   127,   127,   127,   127,
   127,   127,   127,    35,    46,    60,    40,    43,    124,    38,
   127,   127,   127,   127,   127,   127,   127,   127,   127,    33,
    36,    42,    41,    59,    92,    45,    47,   127,   127,   127,
   127,   127,   127,   127,   127,   94,    44,    37,    95,    62,
    63,   127,   127,   127,   127,   127,   127,   127,   127,   127,
    96,    58,    35,    64,    39,    61,    34,   127,    97,    98,
    99,   100,   101,   102,   103,   104,   105,   127,   127,   127,
   127,   127,   127,   127,   106,   107,   108,   109,   110,   111,
   112,   113,   114,   127,   127,   127,   127,   127,   127,   127,
   126,   115,   116,   117,   118,   119,   120,   121,   122,   127,
   127,   127,   127,   127,   127,   127,   127,   127,   127,   127,
   127,   127,   127,   127,   127,   127,   127,   127,   127,   127,
   127,   123,    65,    66,    67,    68,    69,    70,    71,    72,
    73,   127,   127,   127,   127,   127,   127,   125,    74,    75,
    76,    77,    78,    79,    80,    81,    82,   127,   127,   127,
   127,   127,   127,    92,   127,    83,    84,    85,    86,    87,
    88,    89,    90,   127,   127,   127,   127,   127,   127,    48,
    49,    50,    51,    52,    53,    54,    55,    56,    57,   127,
   127,   127,   127,   127,   127;
%SYSTEMROUTINESPEC SIM2(%INTEGER EP, R1, R2,%INTEGERNAME R3)
%SYSTEMROUTINESPEC SIGNAL(%INTEGER EP, WT, EXTRA, %INTEGERNAME FLAG)
%CONSTINTEGER NOPEN=8;                  ! NO OF JSTRMS OPEN AT ONCE
%CONSTINTEGER EM=25;                    ! ISO END MESSAGE CHAR
%CONSTINTEGER NEWPG=12
%OWNBYTEINTEGERARRAY JSTRMS(0:99)=255(100);  ! JSTRMS THAT ARE OPEN
%RECORDFORMAT SFORM(%BYTEINTEGER JSTRM,ISTRM,BUFFNO,CNTRL, %C
      %INTEGER BUFFSTART,BUFFEND,BUFFPTR,BUFFLAST)
%OWNBYTEINTEGERARRAY BUFFSPACE(0:1288); ! 0:161*NOPEN
%OWNRECORDARRAY JCNTL(0:7)(SFORM);      ! 0:NOPEN-1
%OWNINTEGER BUFFMASK=0;                 ! BITMASK OF BUFFERS IN USE
%OWNRECORDNAME CURRSTRM(SFORM);         ! FOR CURRENT TRANSACTION
%ROUTINE JRECOUT
!***********************************************************************
!*    OUTPUT THE IO RECORD DEFINED BY CURRSTRM                         *
!***********************************************************************
%INTEGER F,L,START
      START=CURRSTRM_BUFFSTART
      F=CURRSTRM_ISTRM
      L=CURRSTRM_BUFFPTR-START-1
      SIM2(3,ADDR(BUFFSPACE(START)),L,F)
      BUFFSPACE(START)=BUFFSPACE(CURRSTRM_BUFFPTR-1); ! MOVE DOWN CONTROL
      CURRSTRM_BUFFPTR=START+1
      CURRSTRM_CNTRL=0
%END
%ROUTINE JRECIN
!***********************************************************************
!*    OBTAINS ANOTHER INPUT RECORD FOR CURRSTRM                        *
!***********************************************************************
%INTEGER F,L,START
      START=CURRSTRM_BUFFSTART
      L=CURRSTRM_ISTRM
      SIM2(2,ADDR(BUFFSPACE(START)),0,L)
      %IF BUFFSPACE(START)=EM %THEN SIGNAL(2,140,0,F)
      BUFFSPACE(START+L)=NL;            ! EARLIER ONE USED IF PRESENT
      CURRSTRM_BUFFPTR=START
      CURRSTRM_CNTRL=0
%END

%SYSTEMROUTINE JOPEN(%INTEGER STRM)
!***********************************************************************
!*       OPENS A J STREAM MAY BE CALLED BY USER                        *
!***********************************************************************
%CONSTINTEGER DEFLTIN=40,DEFLTOUT=30,MONITORTT=107
%INTEGER I,J,SLOT
      I=JSTRMS(STRM)
      %IF I<NOPEN %THEN %RETURN
!
! FIND A FREE SLOT IN JCNTL USING THE MASK OF FREE BUFS & SLOTS
! AND GRAB THE SLOT + CORRESPONDING BUFF
!
      %CYCLE SLOT=0,1,NOPEN-1
         %IF BUFFMASK&(1<<SLOT)=0 %THEN ->FREE
      %REPEAT
      PRINTSTRING("JOPEN FAILS ALL BUFFERS IN USE
");   %MONITOR; %STOP
FREE: JSTRMS(STRM)=SLOT
      BUFFMASK=BUFFMASK!(1<<SLOT)
      CURRSTRM==JCNTL(SLOT)
      J=161*SLOT
      CURRSTRM_BUFFSTART=J
      CURRSTRM_BUFFEND=CURRSTRM_BUFFSTART+160
      BUFFSPACE(J)=NL
      CURRSTRM_BUFFPTR=J+1
      CURRSTRM_JSTRM=STRM
      CURRSTRM_ISTRM=STRM
      %IF STRM=DEFLTIN %THEN CURRSTRM_ISTRM=98
      %IF STRM=DEFLTOUT %THEN CURRSTRM_ISTRM=99 %AND %C
         CURRSTRM_BUFFEND=CURRSTRM_BUFFSTART+128;! 128 CH LINES DEFAULT
      %IF STRM=MONITORTT %THEN CURRSTRM_ISTRM=100
      CURRSTRM_BUFFNO=SLOT
      CURRSTRM_CNTRL=NL;                ! INPUT GET NEXT LINE
%END
%INTEGERFN JCHARI(%INTEGER STRM)
!***********************************************************************
!*    ALGOLS VERSION OF IMPS READ SYMBOL RESULT IN ISO                 *
!***********************************************************************
%INTEGER I,PTR
      I=JSTRMS(STRM)
      %IF I>=NOPEN %THEN JOPEN(STRM) %ELSE CURRSTRM==JCNTL(I)
      %IF CURRSTRM_CNTRL=NL %THEN JRECIN
      PTR=CURRSTRM_BUFFPTR
      I=BUFFSPACE(PTR)
      CURRSTRM_BUFFPTR=PTR+1
      %IF I=NL %THEN CURRSTRM_CNTRL=I
      %RESULT=I
%END
%SYSTEMINTEGERFN JCHARIN(%INTEGER STRM)
!***********************************************************************
!*    AS JCHARI BUT RESULT IN S4EBCDIC                                 *
!***********************************************************************
      %RESULT=ITOS4E(JCHARI(STRM)&127)
%END

%SYSTEMINTEGERFN JNEXTNS(%INTEGER STRM)
!***********************************************************************
!*    GETS THE NEXT NON SPACE SYMBOL. LEAVES THE POINTER POINTING AT   *
!*    AT IT SO THAT IT CAN BE REREAD BY THE NEXT CALL OF CHARIN        *
!***********************************************************************
%INTEGER SYM
      SYM=JCHARI(STRM) %UNTIL ' '#SYM
      CURRSTRM_BUFFPTR=CURRSTRM_BUFFPTR-1
      %RESULT=SYM
%END
%SYSTEMSTRING(255)%FN JGETSTR(%INTEGER STRM)
!***********************************************************************
!*    READ IN A STRING BETWEEN '(' AND ')' FROM GIVEN STRM             *
!***********************************************************************
%INTEGER I,SYM
%BYTEINTEGERARRAY A(0:256)
GO:   SYM=JCHARI(STRM) %UNTIL SYM=''''
      SYM=JCHARI(STRM)
      ->GO %UNLESS SYM='('
      SYM=JCHARI(STRM)
      ->GO %UNLESS SYM=''''
      I=1
      %CYCLE
         SYM=JCHARI(STRM) %UNTIL ' '#SYM#NL
         A(I)=SYM
         %IF A(I)='''' %AND A(I-1)=')' %AND I>2 %AND A(I-2)='''' %START
            A(0)=I-3
            %IF JNEXTNS(STRM)=';' %THEN SYM=JCHARI(STRM)
            %RESULT=STRING(ADDR(A(0)))
         %FINISH
         I=I+1
         %EXIT %IF I>255
      %REPEAT
      PRINTSTRING("OVERLENGTH STRING ON DEVICE ")
      WRITE(STRM,2)
      NEWLINE
      %MONITOR
      %STOP
%END
%ROUTINE JCHARO(%INTEGER STRM,CHAR)
!***********************************************************************
!*       J ALGOL VERSION OF IMPS PRINT SYMBOL CHAR IN ISO              *
!***********************************************************************
%INTEGER I
      I=JSTRMS(STRM)
      %IF I>=NOPEN %THEN JOPEN(STRM) %ELSE %C
         CURRSTRM==JCNTL(I)
      BUFFSPACE(CURRSTRM_BUFFPTR)=OTRTAB(CHAR&X'7F')
      CURRSTRM_BUFFPTR=CURRSTRM_BUFFPTR+1
      CURRSTRM_CNTRL=128;               ! NOTE NL NEEDED TO FLUSH BUFF
      %IF CHAR=NL %OR CHAR=NEWPG %THEN JRECOUT
      %IF CURRSTRM_BUFFPTR>=CURRSTRM_BUFFEND %THEN JCHARO(STRM,NL)
%END
%SYSTEMROUTINE JCHAROUT(%INTEGER STRM,CHAR)
!***********************************************************************
!*    AS JCHARO BUT CHAR IN SYTEM4 CODE                                *
!***********************************************************************
      JCHARO(STRM,S4ETOI(CHAR)&255)
%END
%SYSTEMROUTINE JPRSTNG(%INTEGER STRM,%STRINGNAME S)
!***********************************************************************
!*    OUTPUT A STRING AS FAST AS POSSIBLE. DIFFICULT CASES ARE STILL   *
!*    STILL DONE SYMBOL BY SYMBOL                                      *
!***********************************************************************
%INTEGER I,L,CHAR
%INTEGERNAME PTR
      I=JSTRMS(STRM)
      %IF I>=NOPEN %THEN JOPEN(STRM) %ELSE CURRSTRM==JCNTL(I)
      L=LENGTH(S)
      %IF L=0 %THEN %RETURN
      PTR==CURRSTRM_BUFFPTR
      %IF PTR+L>=CURRSTRM_BUFFEND %THEN %START;  ! SLOW PATH
         %CYCLE I=1,1,L
         JCHARO(STRM,CHARNO(S,I))
         %REPEAT
      %FINISH %ELSE %START;             ! FAST PATH
         %CYCLE I=1,1,L
            CHAR=CHARNO(S,I)
            BUFFSPACE(PTR)=CHAR
            PTR=PTR+1
            %IF CHAR=NL %OR CHAR=NEWPG %THEN JRECOUT
         %REPEAT
         %IF CHAR>=32 %THEN CURRSTRM_CNTRL=128
      %FINISH
%END
%SYSTEMROUTINE JNEWL(%INTEGER STRM,N)
      %WHILE N>0 %CYCLE
         JCHARO(STRM,NL)
         N=N-1
      %REPEAT
%END
%SYSTEMROUTINE JSPACE(%INTEGER STRM,N)
      %WHILE N>0 %CYCLE
         JCHARO(STRM,' ')
         N=N-1
      %REPEAT
%END
%SYSTEMROUTINE JPAGE(%INTEGER STRM,N)
      %WHILE N>0 %CYCLE
         JCHARO(STRM,NEWPG)
         N=N-1
      %REPEAT
%END
%SYSTEMROUTINE JTAB(%INTEGER STRM,N)
      %WHILE N>0 %CYCLE
         JCHARO(STRM,9); ! 9= HORIZONTAL TAB IN ISO
         N=N-1
      %REPEAT
%END
%SYSTEMROUTINE JGAP(%INTEGER STRM,N)
      %WHILE N>0 %CYCLE
         JCHARO(STRM,NEWPG)
         N=N-1
      %REPEAT
%END
%SYSTEMROUTINE JWRITE TEXT(%INTEGER STRM,%STRINGNAME TEXT)
%INTEGER I, R, CHAR, RR
%BYTEINTEGERARRAY SA(0:255)
%STRING (255)S, S1, S3
%STRING (3)QU
%STRINGNAME S2
%CONSTSTRING(1) BR1="{",BR2="}",SNL="
"
      S=TEXT
      SA(0)=0
      S2==STRING(ADDR(SA(0)))
      %WHILE S->S1.('%').S3 %THEN S=S1.SNL.S3; ! CHANGE '%' TO NL(TEMP)
      %WHILE S->S1.("_").S3 %THEN S=S1." ".S3;! CHABGE _ TO SPACE
      %WHILE S->S1.("$").S3 %THEN S=S1.TOSTRING(12).S3;! # TO NEWPAGE
      %WHILE S->S1.("?").S3 %THEN S=S1.TOSTRING(9).S3;! ? TO HORIZONTL TAB
NEXT: 
      %IF S->S1.(BR1).S2.(BR2).S3 %START 
         JPRSTNG(STRM,S1)
         S=S3
         R=0
         %CYCLE I=1, 1, SA(0)
            CHAR=SA(I)
            %IF R=0 %THEN RR=1 %ELSE RR=R
            %IF CHAR='T' %THEN JTAB(STRM,RR) %AND R=0 %AND ->REP
            %IF CHAR='S' %THEN JSPACE(STRM,RR) %AND R=0 %AND ->REP
            %IF CHAR='C' %THEN JNEWL(STRM,RR) %AND R=0 %AND ->REP
            %IF CHAR='Q' %OR CHAR='U' %START 
               %IF CHAR='Q' %THEN QU='''(''' %ELSE QU=''')'''
               %UNTIL RR=0 %CYCLE 
                  RR=RR-1
                  JPRSTNG(STRM,QU)
               %REPEAT 
               R=0
               ->REP
            %FINISH 
            %IF CHAR='P' %THEN JPAGE(STRM,RR) %AND R=0 %AND ->REP
            %IF '0'<=CHAR<='9' %THEN R=R*10+(CHAR-'0')
REP:        
         %REPEAT 
         ->NEXT
      %FINISH 
      JPRSTNG(STRM,S)
%END 
%SYSTEMROUTINE JCOPYTEXT(%INTEGER STRM1,STRM2,%STRINGNAME S)
!***********************************************************************
!*    COPY TEXT FROM STRM1 TO STRM2. USE WRITETEXT FOR OPUT TO EXPAND  *
!*    EDITING SYMBOLS AS PER J SPEC. CURRENTLY NOT FOOLPROOF FOR >255  *
!*    CHARS IN A COPY IY EDITING SUBSTRINGS STRADDLE THE 255 BNDRY     *
!***********************************************************************
%ROUTINESPEC OUT
%INTEGER CHAR1,CHAR2,L,CH
%BYTEINTEGERARRAY TX(0:255)
%STRINGNAME SN
      SN==STRING(ADDR(TX(0)))
      CHAR1=CHARNO(S,1)
      L=LENGTH(S)
      %IF L=1 %THEN CHAR2=CHAR1 %AND CHAR1=0 %ELSE CHAR2=CHARNO(S,2)
      %IF L>2 %THEN %START
         PRINTSTRING("COPYTEXT INVALID STRING:=".S."
")
         %MONITOR; %STOP
      %FINISH
      %IF CHAR1#0 %START
         CH=JCHARI(STRM1) %UNTIL CH=CHAR1
      %FINISH
!
      L=1
      %CYCLE
         CH=JCHARI(STRM1) %UNTIL CH>32;     ! IGNORE NEWLINES & SPACES
         %IF CH=CHAR2 %THEN %EXIT
         TX(L)=CH; L=L+1
         %IF L=255 %THEN OUT
      %REPEAT
      CURRSTRM_BUFFPTR=CURRSTRM_BUFFPTR-1;   ! TO REREAD TERMINATOR
      OUT
      %RETURN
%ROUTINE OUT
%STRING(255) S1,S2
      TX(0)=L-1
      %WHILE SN->S1.("'('").S2 %THEN SN=S1."{".S2
      %WHILE SN->S1.("')'").S2 %THEN SN=S1."}".S2
      JWRITETEXT(STRM2,SN)
      L=1
%END
%END

%SYSTEMROUTINE JOUTBS(%INTEGER STRM,VAL)
!***********************************************************************
!*    OUTPUTS A J BASIC SYMBOL USING J INTERNAL CODES FOR VALUE        *
!***********************************************************************
%INTEGER I
%CONSTBYTEINTEGERARRAY T(0:255)=%C
         '0','1','2','3','4','5','6','7','8','9',
         129,'.','A','B','C','D','E','F','G','H',
         'I','J','K','L','M','N','O','P','Q','R',
         'S','T','U','V','W','X','Y','Z',0,0,
         0(20),
         0(5),130,131,132,0,0,
         0,0,133,0(7),
         134,0(7),135,0,
         0(30),
         0,136,137,0(5),138,139,
         140,141,'(',142,143,0,144,145,0,0,
         146,147,148,149,0,150,151,152,')',153,
         154,0,';',155,0,0,156,157,0,158,
         0,'/',159,160,0,161,',',0(3),
         0(7),'*',162,163,
         0,164,165,0,0,':',0(4),
         '?',0,0,'+',166,167,0,0,168,0,
         0(5),169,10,0,0,'-',
         170,0(3),171,0(5),
         0,172,12,0,173,0(5),
         0(26);
%CONSTSTRING(11)%ARRAY CMPND(1:45)=%C
         "'10'","'REAL'","'INTEGER'","'BOOLEAN'","'ARRAY'",
         "'PROCEDURE'","'SWITCH'","'LABEL'","'STRING'","'COMMENT'",
         "'**'","'LT'","'NOT'","'IF'","'FOR'","'GOTO'",
         "'<'","'BEGIN'","'('","'_'","'OWN'","'/'","'LE'",
         "'AND'","'THEN'","'WHILE'","'>'","'END'","')'","'VALUE'",
         "'EQ'","'OR'","'ELSE'","'GE'","'IMPL'",":=","'STEP'",
         "'GT'","'EQUIV'","'UNTIL'","'FALSE'","'NE'","'DO'","'TRUE'",
         "ENTER";
%STRING(11) WORK
      VAL=VAL&255
      I=T(VAL)
      %IF I=0 %THEN %START
         PRINTSTRING("
INVALID BASIC SYMBOL OUTPUT
")
!         %MONITOR
!         %STOP
      %FINISH %ELSE %START
         %IF I<128 %THEN JCHARO(STRM,I) %ELSE %START
            WORK=CMPND(I-128)
            JPRSTNG(STRM,WORK)
         %FINISH
      %FINISH
%END
%SYSTEMINTEGERFN JINBS(%INTEGER STRM)
!***********************************************************************
!*    OBTAIN A J BASIC SYMBOL FROM STRM                                *
!*    THE CURRNET CHARACTER IS CLASSIFIED AS FOLLOWS:-                 *
!*       0  = TO BE IGNORED                                            *
!*       1  = SINGLE CORRESPONDENCE                                    *
!*       2  = MAY BE FIRST OF COMPOUND OR SINGLE                       *
!*       3  =   SPECIAL (IE QUOTE)                                     *
!*    TOP 4 BITS OF CLASS MAY CONTAIN EXTRA INFO                       *
!***********************************************************************
%SWITCH CSW(0:3),CL2(1:7)
%CONSTBYTEINTEGERARRAY CLASS(0:127)=0(33),1,0,1,1,1,
         1,3,X'12',1,X'22',1,1,1,1,X'32',1(10),
         X'42',1,X'52',1,X'62',1,1,1(26),
         1,X'72',1,1,1,0,1(26),0,1,0,0,0;
%CONSTBYTEINTEGERARRAY SINGLE(0:127)=0(33),163,0,210,222,206,
         147,0,132,148,177,193,166,209,11,161,0,1,2,3,4,5,6,7,8,9,
         185,152,130,162,194,190,10,
         12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,
         28,29,30,31,32,33,34,35,36,37,137,131,153,129,142,0,
         12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,
         28,29,30,31,32,33,34,35,36,37,0,163,0,0,0;
%CONSTSTRING(9)%ARRAY CMPND(1:52)="<","(","/","_",">",")",
         "10","**","LT","IF","LE","EQ","OR","GE","GT","NE","DO","",
         "NOT","FOR","OWN","AND","END","",
         "REAL","GOTO","THEN","ELSE","IMPL","STEP","TRUE","",
         "ARRAY","LABEL","BEGIN","WHILE","VALUE","EQUIV","UNTIL",
         "FALSE","ENTER","","SWITCH","STRING","",
         "INTEGER","BOOLEAN","COMMENT","","","PROCEDURE","";
%CONSTBYTEINTEGERARRAY POINTER(1:11)=1,7,19,25,33,43,46,49,50,51,52;
%CONSTBYTEINTEGERARRAY VALUE(1:52)=137,141,145,142,153,157,10,129,
      130,133,146,162,163,178,194,210,214,0,
      131,134,143,147,156,0,65,136,149,165,179,182,221,0,
      72,121,140,150,159,195,198,205,224,0,88,122,0,66,67,
      128,0,0,80,0;
%INTEGER SYM,CL,NEXT,I,J
%STRING(20)BASIC,B1,B2
CSW(0):                                 ! SYMBOL TO BE IGNORED
      SYM=JCHARI(STRM)
      CL=CLASS(SYM)
      ->CSW(CL&15)
CSW(2):                                 ! FIRST OF A POSSIBLE PAIR
      NEXT=JCHARI(STRM)
      ->CL2(CL>>4)
CL2(1):                                 ! '(' MAY BE '(/'
      %IF NEXT='/' %THEN %RESULT=137
WASNOT:                                 ! A COMPOUND SYMBOL
      CURRSTRM_BUFFPTR=CURRSTRM_BUFFPTR-1
CSW(1):  %RESULT=SINGLE(SYM)
CL2(2):                                 ! * MAY BE **
      %IF NEXT='*' %THEN %RESULT=129
      ->WASNOT
CL2(3):                                 ! / MAY BE // OR /)
      %IF NEXT='/' %THEN %RESULT=145
      %IF NEXT=')' %THEN %RESULT=153
      ->WASNOT
CL2(4):                                 ! : MAY BE :=
      %IF NEXT='=' %THEN %RESULT=181
      ->WASNOT
CL2(5):                                 ! < MAY BE ,=
      %IF NEXT='=' %THEN %RESULT=146
      ->WASNOT
CL2(6):                                 ! > MAY BE >=
      %IF NEXT='=' %THEN %RESULT=178
      ->WASNOT
CL2(7):                                 ! \ MAY BE \=
      %IF NEXT='=' %THEN %RESULT=210
      ->WASNOT
CSW(3):                                 ! QUOTE
      I=0
      %UNTIL I=10 %OR SYM='''' %CYCLE
         I=I+1
         SYM=JCHARI(STRM)
         CHARNO(BASIC,I)=SYM
      %REPEAT
AGN:
      I=I-1
      LENGTH(BASIC)=I
      %IF I<=10 %START
         %CYCLE J=POINTER(I),1,POINTER(I+1)
            %IF BASIC=CMPND(J) %THEN %RESULT=VALUE(J)
         %REPEAT
      %FINISH
      %IF BASIC->B1.(" ").B2 %THEN BASIC=B1.B2 %AND ->AGN
      PRINTSTRING("INVALID BASIC SYMBOL INPUT '".BASIC."'
")
      %MONITOR
      %STOP
%END
%SYSTEMROUTINE JOUTPUT(%INTEGER STRM,%LONGREAL XX)
!***********************************************************************
!*       PRINTS IN FLOATING POINT FORMAT WITH 15 PLACES AFTER THE      *
!*       DECIMAL POINT. ALWAYS TAKES 22 PRINTING POSITIONS.            *
!*       CARE REQUIRED TO AVOID OVERFLOW WITH LARGE X                  *
!***********************************************************************
%LONGREAL ROUND,FACTOR,LB,UB,X,Y
%INTEGER COUNT,INC,SIGN,L,J
%CONSTINTEGER N=15
%CONSTLONGREAL DZ=0
%STRINGNAME SN
%OWNBYTEINTEGERARRAY S(0:24)=24,10,'-','9','.','9'(15),
                                        '@','-','9'(2),';'
         ROUND=0.5/R'41A0000000000000'**N;! TO ROUND SCALED NO
         LB=1-ROUND; UB=10-ROUND
         SIGN='+'
         X=XX+DZ;                      ! NORMALISE
         Y=X
         %IF X=0 %THEN COUNT=-99 %ELSE %START
            %IF X<0 %THEN X=-X %AND SIGN='-'
            INC=1; COUNT=0; FACTOR=R'401999999999999A'
            %IF X<=1 %THEN FACTOR=10 %AND INC=-1
                                       ! FORCE INTO RANGE 1->10
            %WHILE X<LB %OR X>=UB %CYCLE
               X=X*FACTOR; COUNT=COUNT+INC
            %REPEAT
         %FINISH
         X=X+ROUND
         S(2)=SIGN
         L=INTPT(X)
         S(3)=L+'0'
         J=1
         %WHILE J<=N %CYCLE
            X=(X-L)*10
            L=INTPT(X)
            S(J+4)=L+'0'
            J=J+1
         %REPEAT
         SIGN='+'
         %IF COUNT<0 %THEN SIGN='-' %AND COUNT=-COUNT
         J=COUNT//10
         S(21)=SIGN
         S(22)=J+'0'
         S(23)=COUNT-10*J+'0'
         SN==STRING(ADDR(S(0)))
         JPRSTNG(STRM,SN)
%END
%OWNINTEGER LAST TERM
%SYSTEMINTEGERFN JIREAD(%INTEGER STRM)
!***********************************************************************
!*    J INTEGER READ USING INTEGER ARITHMETIC                          *
!***********************************************************************
%INTEGER CHAR,SIGN,TOT
      CHAR=JCHARI(STRM) %UNTIL '0'<=CHAR<='9' %OR CHAR='+' %C
                                        %OR CHAR='-'
      %IF CHAR='-' %THEN SIGN=-1 %ELSE SIGN=+1
      %IF '0'<=CHAR<='9' %THEN TOT=CHAR&15 %ELSE TOT=0
      %CYCLE
         CHAR=JCHARI(STRM) %UNTIL CHAR>32
         %EXIT %UNLESS '0'<=CHAR<='9'
         TOT=10*TOT+CHAR&15
      %REPEAT
      CURRSTRM_BUFFPTR=CURRSTRM_BUFFPTR-1
      LAST TERM=CHAR
      %RESULT=SIGN*TOT
%END
%SYSTEMLONGREALFN JREAD(%INTEGER STRM)
!***********************************************************************
!*       THIS ROUTINE IS THE 1900 IMPLICITLY SPECIFIED ROUTINE         *
!*                                                                     *
!*       THE METHOD USED IS SIMPLE REPEATED MULTIPLICATION USING LONG  *
!*       REAL VARIABLES. SOME ROUNDING ERRORS ARE INTRODUCED WHICH     *
!*       COULD BE AVOIDED BY USING PACKED DECIMAL INSTNS WITH NECESSARY*
!*       SCALING.                                                      *
!***********************************************************************
%INTEGERFNSPEC NEXT
%INTEGERFNSPEC CHECK EXP
%INTEGER TYPE, IVALUE, FLAG, CURSYM, EFLAG
                                       ! EFLAG&FLAG= 0 FOR'-',1 FOR '+'
%LONGREAL RWORK, SCALE
      FLAG=1;  TYPE=0
      CURSYM=NEXT;                     ! CARE NOT TO READ TERMINATOR
                                       ! NOW IGNORE LEADING SPACES
      %IF CURSYM=LAST TERM %THEN CURSYM=NEXT
      %WHILE CURSYM=NL %OR CURSYM=' ' %CYCLE 
         CURSYM=NEXT
      %REPEAT 
                                       ! RECORD INITIAL MINUS
      %IF CURSYM='-' %THEN FLAG=0 %AND CURSYM='+'
                                       ! MOVE OVER SIGN ONCE IT HAS
                                       ! BEEN RECORDED IN FLAG
      %IF CURSYM='+' %THEN CURSYM=NEXT
      %IF '0'<=CURSYM %AND CURSYM<='9' %THENSTART 
         RWORK=CURSYM-'0';             ! KEEP TOTAL IN RWORK
         TYPE=1;                       ! VALID DIGIT
         %CYCLE 
            CURSYM=NEXT
            %EXITUNLESS '0'<=CURSYM %AND CURSYM<='9'
            RWORK=10*RWORK+(CURSYM-'0')
                                       ! CONTINUE EVALUATING
         %REPEAT 
      %FINISHELSE RWORK=0
      %IF CURSYM='.' %THENSTART 
         SCALE=10
         %CYCLE 
            CURSYM=NEXT
            %EXITUNLESS '0'<=CURSYM %AND CURSYM<='9'
            TYPE=1
            RWORK=RWORK+(CURSYM-'0')/SCALE
            SCALE=10*SCALE
         %REPEAT 
      %FINISH 
                                       !
                                       ! THE VALUE HAS NOW BEEN READ
                                       ! INTO RWORK. THERE MIGHT BE
                                       ! AN EXPONENT
                                       ! E.G. '1.7@ 10'  IS VALID
                                       ! DATA FOR READ
                                       !
      %IF CHECKEXP#0 %THENSTART 
         %IF TYPE=0 %AND RWORK=0 %THEN RWORK=1
         CURSYM=NEXT
         %IF CURSYM='-' %THEN EFLAG=-1 %ELSE EFLAG=1
         %IF '0'<=CURSYM<='9' %THEN %START
            IVALUE=CURSYM&15
            %CYCLE
               CURSYM=NEXT
               %EXIT %UNLESS '0'<=CURSYM<='9'
               IVALUE=10*IVALUE+CURSYM&15
            %REPEAT
            IVALUE=IVALUE*EFLAG
         %FINISH %ELSE IVALUE=0
         %IF IVALUE=-99 %THEN RWORK=0 %ELSE %START
            ->FAIL %UNLESS IMOD(IVALUE)<77
            RWORK=RWORK*10**IVALUE
         %FINISH
         TYPE=1
      %FINISH 
      %IF TYPE=0 %THEN ->FAIL
      %IF FLAG=0 %THEN RWORK=-RWORK
      LAST TERM=CURSYM
      CURRSTRM_BUFFPTR=CURRSTRM_BUFFPTR-1
      %RESULT =RWORK
FAIL: PRINTSTRING("INVALID NO SUPPLIED TO READ
")
      %MONITOR; %STOP
%INTEGERFN NEXT
%INTEGER S
         S=JCHARI(STRM)
         %IF S=' ' %THEN S=JCHARI(STRM)
         %RESULT =S
      %END 


      %INTEGERFN CHECKEXP
         %INTEGER S
         %RESULT =1 %IF CURSYM='@' %OR CURSYM='&'
         %RESULT =0 %UNLESS CURSYM=''''
         S=NEXT; %RESULT=0 %UNLESS S='1'
         S=NEXT; %RESULT=0 %UNLESS S='0'
         S=NEXT; %RESULT=0 %UNLESS S=''''
         %RESULT =1
      %END 
%END 
%SYSTEMINTEGERFN JREAD BOOL(%INTEGER STRM)
%BYTEINTEGERARRAY TORF(0:6)
%STRINGNAME S
%INTEGER I,CH
      S==STRING(ADDR(TORF(0)))
FINDQ:
      I=JCHARI(STRM) %UNTIL I=''''
FOUNDQ:
      %CYCLE I=1, 1, 6
         CH=JCHARI(STRM)
         TORF(I)=CH
         ->OUT %IF CH=''''
      %REPEAT 
OUT:  
      TORF(0)=I
      %RESULT =-1 %IF S="TRUE'"
      %RESULT =0 %IF S="FALSE'"
      %IF CH='''' %THEN ->FOUNDQ %ELSE ->FINDQ
%END 
%SYSTEMROUTINE JWRITE BOOL(%INTEGER STRM,B)
%STRING(7) S
      %IF B#0 %THEN S="'TRUE'" %ELSE S="'FALSE'"
      JPRSTNG(STRM,S)
%END 
%SYSTEMLONGREALFN JFREAD(%INTEGER STRM,%STRINGNAME FORM)
!***********************************************************************
!*    READ A NUMBER IN FIXED FORMAT FROM STREAM STRM                   *
!***********************************************************************
%ROUTINESPEC GET SYMS(%INTEGER CH,N)
%INTEGERFNSPEC GET INT(%INTEGER F,L,%INTEGERNAME FLAG)
%INTEGERFNSPEC EXTRACT(%STRINGNAME S)
%BYTEINTEGERARRAY A(0:132)
%INTEGER I,J,CH,N,FLAG,CURSYM
%LONGREAL SIGN,RWORK,SCALE
%STRING(30) S1,S2,S3,S4
      S1=FORM
      %IF S1->S2.("X").S3 %THEN %START
         S1=S3; I=EXTRACT(S2)
         ->INV %IF I<0
         GET SYMS('X',I) %UNLESS I=0
         %IF S3="" %THEN %RESULT=0;     ! "X" ONLY SO IGNORING SYMS
      %FINISH
      S3=S1 %UNLESS S1->S3.(".").S2;    ! THROW AWAY .D TERM IF PRESENT
      %IF S3->S1.("I").S2 %THEN CH='I' %AND ->ON
      %IF S3->S1.("F").S2 %THEN CH='F' %AND ->ON
      %IF S3->S1.("E").S2 %THEN CH='E' %AND ->ON
INV:  PRINTSTRING("FREAD: INVALID FORMAT STRING ".FORM)
      NEWLINE; %MONITOR; %STOP
WSYM: PRINTSTRING("FREAD: INVALID SYMBOL IN FIELD ".TOSTRING(CURSYM))
      NEWLINE; %MONITOR; %STOP
ON:   N=EXTRACT(S2);                    ! GET NO OF SYMS IN FIELD
      ->INV %IF N<0;                    ! INVALID NO
      %RESULT=0 %IF N=0;                ! NOT DEFINED IN MANUAL
      GET SYMS(CH,N)
      %RESULT=0 %IF A(0)=0;             ! AGAIN NOT DEFINED
      ->WSYM %IF A(0)=255;              ! NON NUMERICS FOUND
      %IF CH='I' %THEN %START
         N=GET IN T(1,A(0),FLAG)
         ->WSYM %UNLESS FLAG=0
         %RESULT=N
      %FINISH
      ->INV %UNLESS FORM->S4.(".").S3 %AND S3#""
      N=A(0); I=1
      CURSYM=A(I); SIGN=1
      %IF CURSYM='-' %THEN SIGN=-1 %AND CURSYM='+'
      %IF CURSYM='+' %THEN I=I+1
      RWORK=0
      %WHILE I<=N %CYCLE
         CURSYM=A(I)
         %EXIT %IF CURSYM='.' %OR(CH='E' %AND CURSYM='@')
         ->WSYM %UNLESS '0'<=CURSYM<='9'
         RWORK=10*RWORK+CURSYM&15
         I=I+1
      %REPEAT
      %IF I>N %THEN %RESULT=RWORK*SIGN

      ->EXP %IF CURSYM='@'
      ->WSYM %UNLESS CURSYM='.' %AND I<N; ! DONT ALLOW 3. ETC
      I=I+1; SCALE=10
      %WHILE I<=N %CYCLE
         CURSYM=A(I)
         %EXIT %IF CURSYM='@' %AND CH='E'
         ->WSYM %UNLESS '0'<=CURSYM<='9'
         RWORK=RWORK+(CURSYM-'0')/SCALE
         SCALE=10*SCALE; I=I+1
      %REPEAT
      %IF I>N %THEN %RESULT=RWORK*SIGN
EXP:  ->WSYM %UNLESS CURSYM='@' %AND I<N
      J=GET INT(I+1,N,FLAG)
      ->WSYM %UNLESS FLAG=0
      %RESULT=RWORK*SIGN*10**J
%INTEGERFN GET INT(%INTEGER FIRST,LAST,%INTEGERNAME FLAG)
!***********************************************************************
!*    EXTRACT AN INTEGER FROM A(FIRST)-A(LAST). FLAG=0 IF DONE         *
!***********************************************************************
%INTEGER I,SIGN,TOT
      I=FIRST; CURSYM=A(I); SIGN=1
      %IF CURSYM='-' %THEN CURSYM='+' %AND SIGN=-1
      %IF CURSYM='+' %THEN I=I+1
      TOT=0
      %WHILE I<=LAST %CYCLE
         CURSYM=A(I)
         FLAG=1 %AND %RESULT=0 %UNLESS '0'<=CURSYM<='9'
         TOT=10*TOT+CURSYM&15
         I=I+1
      %REPEAT
      FLAG=0
      %RESULT=SIGN*TOT
%END
%INTEGERFN EXTRACT(%STRINGNAME S)
!***********************************************************************
!*    EXTRACT UNSIGNED INTEGER FROM S. RESULT=-1 IF NOT POSSIBLE       *
!***********************************************************************
%INTEGER I,J,L,N
      L=LENGTH(S); N=0
      ->INV %UNLESS 1<=L<=3
      %CYCLE I=1,1,L
         J=CHARNO(S,I)
         ->INV %UNLESS '0'<=J<='9'
         N=10*N+J&15
      %REPEAT
      %RESULT=N %IF 0<=N<=132
INV:  %RESULT=-1
%END
%ROUTINE GET SYMS(%INTEGER CH,N)
!***********************************************************************
!*    GET THE SYMBOL SET AND STORE IN ARRAY A. NL NOT COUNTED IN SET   *
!*    CHECK FOR VALIDITY AND STORE NON SPACE SYMBOLS ONLY              *
!***********************************************************************
%INTEGER I,J,K
      K=1
      %CYCLE I=1,1,N
         J=JCHARI(STRM) %UNTIL J#NL
         A(K)=J %AND K=K+1 %IF J>32
         ->INV %UNLESS CH='X' %OR J='+' %OR J='-' %OR '0'<=J<='9' %C
            %OR J=' ' %OR (J='@' %AND CH='E') %C
            %OR ('E'<=CH<='F' %AND J='.')
      %REPEAT
      A(K)=';'
      A(0)=K-1
      %RETURN
INV:  A(0)=255
      CURSYM=J
%END
%END
%SYSTEMROUTINE JCLOSE(%INTEGER STRM)
!***********************************************************************
!*    THE COUNTERPART TO JOPEN. CAN BE CALLED BY USER                  *
!***********************************************************************
%INTEGER SLOT
      SLOT=JSTRMS(STRM)
      %IF SLOT>=NOPEN %THEN %RETURN;    ! NOT CURRENTLY OPEN
      CURRSTRM==JCNTL(SLOT)
      %IF CURRSTRM_CNTRL=128 %THEN JCHARO(STRM,NL);! FLUSH BUFFER
      BUFFMASK=BUFFMASK&(X'FFFF'!!(1<<SLOT))
      CURRSTRM=0
      JSTRMS(STRM)=255
%END

! DECODING ALGOL J FORMATS
! ========================
!
! ROUTINE JFORMAT DECODES THE PICTURE FORMAT INTO A BITSTRING WHICH
! REPRESENTS THE FORMAT AS FOLLOWS(BIT 0 =LH BIT):-
! BITS 0-3     NO OF LEADING SPACES (0-15)
! BITS 4&5     SIGN REQUIRED 0=NO SIGN, 1=+, 2=-, 3=#
! BIT 6        SET IF LEADING ZEROS ARE TO BE SUPPRESSED
! BITS 7-10    TERMINATOR INDEX TO "TERMS", 0=NO TERMINATOR
! BIT  11      =1 FOR FLOATING =0 FOR FIXED
! BIT  12      =1 FOR NONSTANDARD (IE CONTAINS EMBEDDED SPACES)
! BIT 13       =1 IF DECIMAL POINT PRESENT IN FORMAT
! STANDARD FORMATS THEN CONTINUE
! BITS 16-20   PLACES AFTER DP
! BITS 21-27   PLACES BEFOR DP(OR EXPONENT TYPE FOR FLOATING)
! BITS 28-31   TRAILING ZEROES (IF IMPLEMENTED)
!
! NON STANDARD PATTERNS CONTINUE
! BITS 16-27   INDEX INTO ARRAY FORMPATS
!
%CONSTSTRING(4)%ARRAY TERMS(1:9)=";CCC",";CC",";C",";P",";",
                                        "CCC","CC","C","P"
%CONSTINTEGER FORMMAX=102
%OWNINTEGER FORMPTR=0
%OWNINTEGERARRAY FORMPATS(0:101)
!
%SYSTEMINTEGERFN JFORMAT(%STRINGNAME IN)
!***********************************************************************
!*    CONVERTS THE PICTURE STRING TO BITMASK AS ABOVE                  *
!***********************************************************************
%ROUTINESPEC SETMASK(%INTEGERNAME SP,P,BITS)
%INTEGERFNSPEC LOOKUP(%INTEGER ONE,TWO,THREE)
%INTEGERFNSPEC FEXP
%INTEGERFNSPEC SET TIND
%INTEGERFNSPEC GET ITEM(%INTEGERNAME REP)
%INTEGER LS,SIGN,CH,ITEM,SLZ,TINDX,FLT,NONS,TZS,I,J,K,L,CURPOS,DP, %C
         PBDP,PADP,SPBDP,SPADP,BITS0,BITS1
%STRING(40)SIN,WK1,WK2,WK3
%BYTEINTEGERARRAYFORMAT F(0:40)
%SWITCH SW(0:3)
%BYTEINTEGERARRAYNAME A
      A==ARRAY(ADDR(SIN),F)
      SIN=IN; L=A(0); PBDP=0; PADP=0
      LS=0; SIGN=0; SLZ=0; TINDX=0; DP=0
      FLT=0; NONS=0; TZS=0; CURPOS=1
      CH=A(L);                          ! LAST CHAR
      %IF CH=';' %OR CH='P' %OR CH='C' %THEN TINDX=SET TIND

      ITEM=GET ITEM(K)
      %IF ITEM='S' %START
         LS=K; ->ERR %IF LS>15
         ITEM=GET ITEM(K)
      %FINISH
!
! NOW THE SIGN
!
      %IF ITEM<='-' %START;             ! NOTHING BUT SIGNS IN THIS RANGE
         SIGN=1 %IF ITEM='+'
         SIGN=2 %IF ITEM='-'
         SIGN=3 %IF ITEM='#'
         ->ERR %IF SIGN=0;              ! SIGN INVALID
         ITEM=GET ITEM(K)
      %FINISH
!
      %IF ITEM='N' %START
         SLZ=1
         %IF K#1 %THEN ->ERR
         ITEM=GET ITEM(K)
      %FINISH
!
      ->ERR %UNLESS ITEM='D' %OR ITEM='.'
!
! COPY BALANCE INTO WK1
!
      J=1; I=CURPOS
      %WHILE I<=L %CYCLE
         CHARNO(WK1,J)=A(I)
         I=I+1; J=J+1
      %REPEAT
      LENGTH(WK1)=J-1
!
! CHECK FOR @ AND EMBEDDED SPACES
!
      %IF WK1->WK2.('@').WK3 %THEN FLT=1
      %IF WK1->WK2.("S") %THEN NONS=1
      %IF WK1->WK2.(".") %OR ITEM='.' %THEN DP=1
      ->SW(2*NONS+FLT)
!
SW(0):                                  ! STANDARD FIXED POINT
      %IF ITEM='.' %THEN PBDP=SLZ %ELSE PBDP=SLZ+K
      %IF DP=0 %THEN ->FINISH;          ! NO DECIMAL POINT
      ITEM=GET ITEM(K)
      %IF ITEM='.' %THEN ITEM=GET ITEM(K)
      ->FINISH %UNLESS ITEM='D' %OR ITEM='0'
      PADP=K; ->FINISH
SW(1):                                  ! STANDARD FLOATING POINT
      %IF DP=0 %THEN PADP=SLZ+K %ELSE %START
         ITEM=GET ITEM(K)
         %IF ITEM='.' %THEN ITEM=GET ITEM(K)
         ->ERR %IF ITEM#'D'
         PADP=K
      %FINISH
      PBDP=FEXP;                        ! FETCH EXPONENT PATTERN
      ->FINISH
SW(2):                                  ! NON STANDARD FIXED POINT
      %IF ITEM='.' %THEN %START
         PBDP=SLZ; SPBDP=PBDP
         BITS0=(-1)>>(32-PBDP)
      %FINISH %ELSE %START
         PBDP=SLZ+K
         SPBDP=PBDP
         BITS0=(-1)>>(32-PBDP)
         SET MASK(SPBDP,PBDP,BITS0)
      %FINISH
      SPADP=0; BITS1=0
      ->NONSCOM %IF DP=0
      ->ERR %UNLESS ITEM='.'
      SET MASK(SPADP,PADP,BITS1)
NONSCOM:
      I=SPADP<<24!PADP<<16!SPBDP<<8!PBDP
      K=LOOK UP(I,BITS0,BITS1)
      PADP=0; PBDP=K; ->FINISH;         ! TO FORCE ALTERNATIVE PATTERN
SW(3):                                  ! NON STANDARD FLOATING POINT
      %IF DP=0 %THEN %START
         PADP=SLZ+K; SPADP=PADP
         BITS0=(-1)>>(32-SPADP)
      %FINISH %ELSE %START
         %IF ITEM#'.' %THEN %START
            CURPOS=CURPOS+1 %WHILE A(CURPOS)#'.'
            CURPOS=CURPOS+1
         %FINISH
         SPADP=0; BITS0=0
      %FINISH
      SET MASK(SPADP,PADP,BITS0)
      BITS1=FEXP; SPBDP=0
      ->NONSCOM
FINISH:
      J=FLT<<20!NONS<<19!DP<<18
      J=J!PADP<<11!PBDP<<4
      %RESULT=LS<<28!SIGN<<26!SLZ<<25!TINDX<<21!J
ERR:  %RESULT=-1
%ROUTINE SET MASK(%INTEGERNAME SP,P,BITS)
!***********************************************************************
!*    SET UP A BIT PATERN IN BITS WITH ONES CORRESPONDING TO DIGITS    *
!*    AND 0 FOR EMBEDDED SPACES TO DESCRIBE NONSTANDARD LAYOUTS        *
!***********************************************************************
%INTEGER K
      %CYCLE
         %EXIT %IF CURPOS>L
         ITEM=A(CURPOS)
         %IF '0'<=ITEM<='9' %THEN ITEM=GET ITEM(K) %C
                            %ELSE K=1 %AND CURPOS=CURPOS+1
         %EXIT %UNLESS ITEM='D' %OR ITEM='S'
         %IF ITEM='D' %THEN P=P+K %AND BITS=BITS!((-1)>>(32-K)<<SP)
         SP=SP+K
      %REPEAT
%END
%INTEGERFN LOOKUP(%INTEGER ONE,TWO,THREE)
!***********************************************************************
!*    LOOK UP THE PATTERN TO SEE IF IT IS ALREADY IN FORMPATS          *
!*    IF IT IS NOT THERE THEN PUT IT IN                                *
!***********************************************************************
      %INTEGER I
      I=0
      %WHILE I<FORMPTR %CYCLE
         %RESULT=I %IF FORMPATS(I)=1 %AND FORMPATS(I+1)=TWO %AND %C
                  FORMPATS(I+2)=THREE
         I=I+3
      %REPEAT
      %IF FORMPTR>=FORMMAX %THEN %START
         PRINTSTRING("TOO MANY FORMAT PATTERNS IN ONE PROGRAM
")
         %MONITOR
         %STOP
      %FINISH
      FORMPATS(I)=ONE
      FORMPATS(I+1)=TWO
      FORMPATS(I+2)=THREE
      FORMPTR=I+3
      %RESULT=I
%END
%INTEGERFN SET TIND
!***********************************************************************
!*    SET THE CORRECT POINTER TO TERMS TO DESCRIBE TERMINATOR          *
!***********************************************************************
%INTEGER I
%STRING(40)S
      %CYCLE I=1,1,9
         %IF SIN->S.(TERMS(I)) %THEN %EXIT
      %REPEAT
      SIN=S; L=A(0)
      %RESULT=I
%END
%INTEGERFN GET ITEM(%INTEGERNAME REP)
!***********************************************************************
!*    GETS NEXT CHAR FROM STRING COMBINING MULTIPLE OCCURRENCES        *
!***********************************************************************
%INTEGER CH,COUNT,NEXTCH
      COUNT=1
      CH=A(CURPOS); CURPOS=CURPOS+1
      %IF '0'<=CH<='9' %THEN %START
         COUNT=CH&15; CH=A(CURPOS); CURPOS=CURPOS+1
         %IF '0'<=CH<='9' %THEN %START
            COUNT=10*COUNT+CH&15
            CH=A(CURPOS); CURPOS=CURPOS+1
         %FINISH
      %FINISH
!
AGN:  NEXTCH=A(CURPOS)
      %IF NEXTCH=CH %OR(CH='D' %AND NEXTCH='0') %THEN %START
         CURPOS=CURPOS+1
         COUNT=COUNT+1
         ->AGN
      %FINISH
      REP=COUNT
      %RESULT=CH
%END
%INTEGERFN FEXP
!***********************************************************************
!*    SET THE ALTERNATIVE OF EXPONENT FROM STRING WK3                  *
!***********************************************************************
%INTEGER I
      I=1
      %IF WK3="-ND" %THEN I=2
      %IF WK3="#ND" %THEN I=3
      %RESULT=I
%END
%END
%SYSTEMROUTINE JWRITE(%INTEGER STRM,FORM,%LONGREAL VAL)
!***********************************************************************
!*    OUTPUTS VAL ON STREAM STRM AS DIRECTED BY CONDENSED FORMAT FORM  *
!***********************************************************************
%ROUTINESPEC EMBEDS(%INTEGERNAME SP,%INTEGER BITS)
%CONSTINTEGER PLUSSIGN=X'2B202B00'
%INTEGER LS,SIGN,SLZ,TINDX,FLT,NONS,I,J,K,L,STARTSIG,CURPOS,DP,PBDP,%C
         PADP,SPBDP,SPADP,BITS0,BITS1,CH,BIT,COUNT
%STRING(4)WK1
%LONGREAL X,Y,Z,ROUND,LB,UB
%BYTEINTEGERARRAY A(-15:50)
      CURPOS=1; %IF FORM=-1 %THEN ->ALARM
!
! UNSCRAMBLE COMPRESSED FORMAT INTO COMPONENTS
!
      LS=FORM>>28; SIGN=FORM>>26&3
      SLZ=FORM>>25&1; TINDX=FORM>>21&15
      FLT=FORM>>20&1; NONS=FORM>>19&1
      DP=FORM>>18&1
!
      %IF NONS=0 %THEN %START
         PADP=FORM>>11&63; SPADP=PADP
         BITS0=-1; BITS1=BITS0
         PBDP=FORM>>4&127; SPBDP=PBDP
      %FINISH %ELSE %START
         I=FORM>>4&X'3FF';              ! INDEX TO PATTERNS
         J=FORMPATS(I)
         SPADP=J>>24&255
         PADP=J>>16&255
         SPBDP=J>>8&255
         PBDP=J&255
         BITS0=FORMPATS(I+1)
         BITS1=FORMPATS(I+2)
      %FINISH
!
! SORT THE SIGN IF ONE IS WANTED
!
      %IF SIGN#0 %THEN %START
         %IF VAL<0 %THEN I='-' %ELSE I=PLUSSIGN>>(8*SIGN)&255
         A(1)=I; CURPOS=2
      %FINISH
      Y=MOD(VAL)
      ROUND=0.5/10**PADP
      %IF FLT#0 %THEN ->FLOATING
      Y=Y+ROUND;                       ! ROUND LAST DIGIT             
!
! COUNT LEADING ZEROS
!
      I=0; Z=1; STARTSIG=-1
      I=I+1 %AND Z=10*Z %WHILE Y>=Z
      %IF I>PBDP %THEN ->ALARM
!
! FILL IN LEADING ZEROS(SPACES) AND ANY EMBEDDED SPACES
!
      %IF SLZ=0 %THEN CH='0' %ELSE CH=' '
!
! LEAVE THE LAST DIGIT BEFORE DP UNLESS IT IS 0 AND THE USER HAS SAID
! HE DOES NOT WANT IT BY GIVING 0 PLACES BEFORE DECIMAL POINT
!
      %IF I=0 %AND PBDP>0 %THEN I=1 %AND Z=10
      J=PBDP-I; BIT=1
      %WHILE J>0 %CYCLE
         %IF BIT&BITS0=0 %THEN EMBEDS(SPBDP,BITS0)
         A(CURPOS)=CH; CURPOS=CURPOS+1
         SPBDP=SPBDP-1; BIT=BIT<<1
         J=J-1
      %REPEAT
!
! NOW FOR THE CHARACTERS BEFORE THE DECIMAL POINT
!
      J=I-1; Z=Z/10
      %WHILE J>=0 %CYCLE
         %IF BIT&BITS0=0 %THEN EMBEDS(SPBDP,BITS0)
         L=INT PT(Y/Z)
         Y=Y-L*Z; Z=Z/10
         A(CURPOS)=L+'0'
         %IF STARTSIG<0 %THEN STARTSIG=CURPOS-1
         CURPOS=CURPOS+1; SPBDP=SPBDP-1
         BIT=BIT<<1; J=J-1
      %REPEAT
      %IF SPBDP>0 %THEN EMBEDS(SPBDP,BITS0)
                                        ! NOW FOR FRACTIONAL PART
      %IF DP#0 %THEN A(CURPOS)='.' %AND CURPOS=CURPOS+1
!
      %IF PADP>0 %THEN %START
         J=PADP-1; Z=10**(J-1)
         Y=10*Z*Y; BIT=1
         %UNTIL J<0 %CYCLE
            %IF BIT&BITS1=0 %THEN EMBEDS(SPADP,BITS1)
            L=INT PT(Y/Z)
            Y=Y-L*Z; Z=Z/10
            A(CURPOS)=L+'0'; CURPOS=CURPOS+1
            SPADP=SPADP-1; BIT=BIT<<1; J=J-1
         %REPEAT
         %IF SPADP>0 %THEN EMBEDS(SPADP,BITS1)
      %FINISH
!
! MOVE THE SIGN RIGHTWARDS IF APPROPIATE
!
      %IF 1<=SIGN<=2 %AND SLZ#0 %AND STARTSIG>1 %START
         A(STARTSIG)=A(1)
         A(1)=' '
      %FINISH
ADDTERM:                                ! ADD TERMINATING CHARS
      %IF TINDX>0 %START
         WK1=TERMS(TINDX)
         %CYCLE I=1,1,LENGTH(WK1)
            J=CHARNO(WK1,I)
            %IF J='C' %THEN J=10
            %IF J='P' %THEN J=12
            A(CURPOS)=J
            CURPOS=CURPOS+1
         %REPEAT
      %FINISH
      K=ADDR(A(0)); L=CURPOS-1
!
! ADD ON ANY LEADING SPACES
!
      %IF LS>0 %THEN %START
         K=K-LS; L=L+LS
         %CYCLE I=1-LS,1,0
            A(I)=' '
         %REPEAT
      %FINISH
      A(-LS)=L
      JPRSTNG(STRM,STRING(K))
      %RETURN
FLOATING:
      LB=1-ROUND; UB=10-ROUND
      %IF Y=0 %THEN COUNT=-99 %ELSE %START
         I=1; COUNT=0; Z=R'401999999999999A'
         %IF Y<=1 %THEN Z=10 %AND I=-1
         %WHILE Y<LB %OR Y>=UB %CYCLE
            Y=Y*Z; COUNT=COUNT+I
         %REPEAT
      %FINISH
!
! NUMBER NOW FORCED INTO RANGE 1->10. EXPONENT IN COUNT
!
      X=Y+ROUND
      L=INT PT(X)
      A(CURPOS)=L+'0'
      A(CURPOS+1)='.'
      CURPOS=CURPOS+2
!
! LOOP TO PRINT MANTISSA
!
      J=1; BIT=1
      %WHILE J<=PADP %CYCLE
         %IF BIT&BITS0=0 %THEN EMBEDS(SPADP,BITS0)
         X=(X-L)*10
         L=INT PT(X)
         A(CURPOS)=L+'0'
         CURPOS=CURPOS+1
         J=J+1; BIT=BIT<<1
         SPADP=SPADP-1
      %REPEAT
      %IF SPADP>0 %THEN EMBEDS(SPADP,BITS0)
!
! NOW THE EXPONENT
!
      A(CURPOS)='@'; CURPOS=CURPOS+1
      %IF COUNT<0 %THEN I='-' %AND COUNT=-COUNT %C
                              %ELSE I=PLUSSIGN>>(8*PBDP)&255
      J=COUNT//10
      %IF J=0 %THEN CH=' ' %ELSE CH=J+'0'
      %IF PBDP=3 %THEN %START;          ! EXPNT="#ND"
         A(CURPOS)=I; A(CURPOS+1)=CH
      %FINISH %ELSE %START
         %IF CH=' ' %THEN A(CURPOS)=' ' %AND A(CURPOS+1)=I %C
                    %ELSE A(CURPOS)=I %AND A(CURPOS+1)=CH
      %FINISH
      A(CURPOS+2)=(COUNT-10*J)+'0'
      CURPOS=CURPOS+3
      ->ADD TERM
ALARM:                                  ! ALARM PRINTING
      JCHARO(STRM,'*')
      JOUTPUT(STRM,VAL)
%ROUTINE EMBEDS(%INTEGERNAME SP,%INTEGER BITS)
      %WHILE SP>0 %AND BIT&BITS=0 %CYCLE
         A(CURPOS)=' '; CURPOS=CURPOS+1
         BIT=BIT<<1; SP=SP-1
      %REPEAT
%END
%END
%SYSTEMROUTINE JIWRITE(%INTEGER STRM,FORM,VAL)
!***********************************************************************
!*    OUTPUTS VAL ON STREAM STRM AS DIRECTED BY CONDENSED FORMAT FORM  *
!***********************************************************************
%ROUTINESPEC EMBEDS(%INTEGERNAME SP,%INTEGER BITS)
%CONSTINTEGER PLUSSIGN=X'2B202B00'
%INTEGER LS,SIGN,SLZ,TINDX,NONS,I,J,K,L,STARTSIG,CURPOS,PBDP,%C
         SPBDP,BITS0,Y,IZ,CH,BIT,COUNT
%STRING(4)WK1
%LONGREAL Z
%BYTEINTEGERARRAY A(-15:50)
      CURPOS=1
!
! UNSCRAMBLE COMPRESSED FORMAT INTO COMPONENTS
!
      LS=FORM>>28; SIGN=FORM>>26&3
      SLZ=FORM>>25&1; TINDX=FORM>>21&15
      NONS=FORM>>19&1
      %IF FORM>>18&5#0 %THEN ->ALARM
!
      %IF NONS=0 %THEN %START
         BITS0=-1
         PBDP=FORM>>4&127; SPBDP=PBDP
      %FINISH %ELSE %START
         I=FORM>>4&X'3FF';              ! INDEX TO PATTERNS
         J=FORMPATS(I)
         SPBDP=J>>8&255
         PBDP=J&255
         BITS0=FORMPATS(I+1)
      %FINISH
!
! SORT THE SIGN IF ONE IS WANTED
!
      %IF SIGN#0 %THEN %START
         %IF VAL<0 %THEN I='-' %ELSE I=PLUSSIGN>>(8*SIGN)&255
         A(1)=I; CURPOS=2
      %FINISH
      Y=IMOD(VAL)
!
! COUNT LEADING ZEROS (NEED TO USE REAL TO AVOID OVERFLOW)
!
      I=0; Z=1; STARTSIG=-1
      I=I+1 %AND Z=10*Z %WHILE Y>=Z
      %IF I>PBDP %THEN ->ALARM
!
! FILL IN LEADING ZEROS(SPACES) AND ANY EMBEDDED SPACES
!
      %IF SLZ=0 %THEN CH='0' %ELSE CH=' '
!
! LEAVE THE LAST DIGIT BEFORE DP UNLESS IT IS 0 AND THE USER HAS SAID
! HE DOES NOT WANT IT BY GIVING 0 PLACES BEFORE DECIMAL POINT
!
      %IF I=0 %AND PBDP>0 %THEN I=1 %AND Z=10
      J=PBDP-I; BIT=1
      %WHILE J>0 %CYCLE
         %IF BIT&BITS0=0 %THEN EMBEDS(SPBDP,BITS0)
         A(CURPOS)=CH; CURPOS=CURPOS+1
         SPBDP=SPBDP-1; BIT=BIT<<1
         J=J-1
      %REPEAT
!
! NOW FOR THE CHARACTERS BEFORE THE DECIMAL POINT
!
      J=I-1; IZ=INT(Z/10)
      %WHILE J>=0 %CYCLE
         %IF BIT&BITS0=0 %THEN EMBEDS(SPBDP,BITS0)
         L=Y//IZ
         Y=Y-L*IZ; IZ=IZ//10
         A(CURPOS)=L+'0'
         %IF STARTSIG<0 %THEN STARTSIG=CURPOS-1
         CURPOS=CURPOS+1; SPBDP=SPBDP-1
         BIT=BIT<<1; J=J-1
      %REPEAT
      %IF SPBDP>0 %THEN EMBEDS(SPBDP,BITS0)
!
! MOVE THE SIGN RIGHTWARDS IF APPROPIATE
!
      %IF 1<=SIGN<=2 %AND SLZ#0 %AND STARTSIG>1 %START
         A(STARTSIG)=A(1)
         A(1)=' '
      %FINISH
                                        ! ADD TERMINATING CHARS
      %IF TINDX>0 %START
         WK1=TERMS(TINDX)
         %CYCLE I=1,1,LENGTH(WK1)
            J=CHARNO(WK1,I)
            %IF J='C' %THEN J=10
            %IF J='P' %THEN J=12
            A(CURPOS)=J
            CURPOS=CURPOS+1
         %REPEAT
      %FINISH
      K=ADDR(A(0)); L=CURPOS-1
!
! ADD ON ANY LEADING SPACES
!
      %IF LS>0 %THEN %START
         K=K-LS; L=L+LS
         %CYCLE I=1-LS,1,0
            A(I)=' '
         %REPEAT
      %FINISH
      A(-LS)=L
      JPRSTNG(STRM,STRING(K))
      %RETURN
ALARM:                                  ! ALARM PRINTING
      JWRITE(STRM,-1,VAL)
      %RETURN
%ROUTINE EMBEDS(%INTEGERNAME SP,%INTEGER BITS)
      %WHILE SP>0 %AND BIT&BITS=0 %CYCLE
         A(CURPOS)=' '; CURPOS=CURPOS+1
         BIT=BIT<<1; SP=SP-1
      %REPEAT
%END
%END

%SYSTEMROUTINE JDCODEDV(%LONGINTEGER DV,%INTEGERARRAYNAME DATA)
!***********************************************************************
!*    WORK DOWN A DOPE VECTOR DESCRIBED BY WORD DESCRIPTOR DV AND      *
!*    RETURN SIZE,DIMENIONALITY AND SUBSCRIPT RANGES IN DATA           *
!***********************************************************************
%INTEGER I,J,ND,AD,U,T
      ND=(DV>>32)&255; ND=ND//3
      DATA(0)=ND
      AD=INTEGER(ADDR(DV)+4)+12*(ND-1)
      T=1
      %CYCLE I=1,1,ND
         U=INTEGER(AD+8)//INTEGER(AD+4)
         DATA(I)=U
         T=T*U
         AD=AD-12
      %REPEAT
      DATA(-1)=T
%END
%SYSTEMSTRINGFN JCHKSTR(%STRINGNAME SIN)
!***********************************************************************
!*    CHECK SIN EITHER SPACE FILL TO 8 OR IF IT IS ONE OR TWO DIGITS   *
!*    THEN READ A STRING FROM THIS STREAM                              *
!***********************************************************************
%INTEGER I
%STRING(255)S,T,RES
      S=SIN
      %WHILE S->S.(" ").T %THEN S=S.T
      %IF (LENGTH(S)=1 %AND '0'<=CHARNO(S,1)<='9' ) %OR (LENGTH(S)=2%C
         %AND '0'<=CHARNO(S,1)<='9' %AND '0'<=CHARNO(S,2)<='9') %START
         I=CHARNO(S,1)&15
         %IF LENGTH(S)=2 %THEN I=10*I+CHARNO(S,2)&15
         RES=JGETSTR(I)
      %FINISH %ELSE RES=SIN
      %RESULT=RES
%END

%SYSTEMROUTINE JWARRAY(%INTEGER STRM,FORM,DIM,%LONGINTEGER AR,DV,%C
                  %STRINGNAME S)
!***********************************************************************
!*    OUTPUT THE REAL ARRAY DESCRIBED BY AR IN HAIRY FORMAT AS PER     *
!*    J ALGOL MANUAL PP57-60                                           *
!***********************************************************************
%CONSTINTEGER SPECFORM=X'0A600070';     ! "-N6D(SC)C"
%INTEGER I,K
%STRING (21)OUT
%STRING(8)T
%INTEGERARRAY DOPE(-1:20)
      I=FORM>>21&15;                    ! CHECK TERMINATOR
      %IF I=0 %OR 4<=I<=15 %OR I=9 %THEN I=3
      FORM=FORM&X'FE1FFFFF'!I<<21;      ! FORCE IN A NEWLINE
      T=JCHKSTR(S)
      %WHILE LENGTH(T)<8 %THEN T=" ".T
      OUT="'('".T."')';
"
      JPRSTNG(STRM,OUT)
      JDCODEDV(DV,DOPE)
      DIM=DOPE(0)
!
      JIWRITE(STRM,SPECFORM,-1);        ! OPUT BY COLUMNS
      JIWRITE(STRM,SPECFORM,DIM);       ! DIMENSIONALITY
      %CYCLE I=1,1,DIM
         JIWRITE(STRM,SPECFORM,DOPE(I));     ! RANGE OF EACH COLUMN
      %REPEAT
      K=INTEGER(ADDR(AR)+4)
      %CYCLE I=0,1,DOPE(-1)-1
         JWRITE(STRM,FORM,LONGREAL(K+8*I))
      %REPEAT
%END
%SYSTEMROUTINE JIWARRAY(%INTEGER STRM,FORM,DIM,%LONGINTEGER AR,DV,%C
                  %STRINGNAME S)
!***********************************************************************
!*    OUTPUT THE INTEGER ARRAY DESCRIBED BY AR IN HAIRY FORMAT AS PER  *
!*    J ALGOL MANUAL PP57-60                                           *
!***********************************************************************
%CONSTINTEGER SPECFORM=X'0A600070';     ! "-N6D(SC)C"
%INTEGER I,K
%STRING (21)OUT
%STRING(8)T
%INTEGERARRAY DOPE(-1:20)
      I=FORM>>21&15;                    ! CHECK TERMINATOR
      %IF I=0 %OR 4<=I<=15 %OR I=9 %THEN I=3
      FORM=FORM&X'FE1FFFFF'!I<<21;      ! FORCE IN A NEWLINE
      T=JCHKSTR(S)
      %WHILE LENGTH(T)<8 %THEN T=" ".T
      OUT="'('".T."')';
"
      JPRSTNG(STRM,OUT)
      JDCODEDV(DV,DOPE)
      DIM=DOPE(0)
!
      JIWRITE(STRM,SPECFORM,-1);        ! OPUT BY COLUMNS
      JIWRITE(STRM,SPECFORM,DIM);       ! DIMENSIONALITY
      %CYCLE I=1,1,DIM
         JIWRITE(STRM,SPECFORM,DOPE(I));     ! RANGE OF EACH COLUMN
      %REPEAT
      K=INTEGER(ADDR(AR)+4)
      %CYCLE I=0,1,DOPE(-1)-1
         JIWRITE(STRM,FORM,INTEGER(K+4*I))
      %REPEAT
%END
%SYSTEMROUTINE JBWARRAY(%INTEGER STRM,FORM,DIM,%LONGINTEGER AR,DV,%C
                  %STRINGNAME S)
!***********************************************************************
!*    OUTPUT THE BOOLEAN ARRAY DESCRIBED BY AR IN HAIRY FORMAT AS PER  *
!*    J ALGOL MANUAL PP57-60                                           *
!***********************************************************************
%CONSTINTEGER SPECFORM=X'0A600070';     ! "-N6D(SC)C"
%CONSTSTRING(11)%ARRAY TF(0:3)="'FALSE';
","'TRUE';
","0;
","1;
"
%INTEGER I,J,K
%STRING(21)OUT
%STRING(8)T
%INTEGERARRAY DOPE(-1:20)
      T=JCHKSTR(S)
      %WHILE LENGTH(T)<8 %THEN T=" ".T
      OUT="'('".T."')';
"
      JPRSTNG(STRM,OUT)
      JDCODEDV(DV,DOPE)
      DIM=DOPE(0)
!
      JIWRITE(STRM,SPECFORM,-1);        ! OPUT BY COLUMNS
      JIWRITE(STRM,SPECFORM,DIM);       ! DIMENSIONALITY
      %CYCLE I=1,1,DIM
         JIWRITE(STRM,SPECFORM,DOPE(I));     ! RANGE OF EACH COLUMN
      %REPEAT
      K=INTEGER(ADDR(AR)+4)
      %CYCLE I=0,1,DOPE(-1)-1
         J=INTEGER(K+4*I)
         %IF J=0 %THEN J=1 %ELSE J=0;   ! SEE JBRARRAY FOR J AND E BOOLS
         %IF FORM#0 %THEN FORM=2
         T=TF(J+FORM)
         JPRSTNG(STRM,T)
      %REPEAT
%END
%ROUTINE UPDATE EL(%INTEGERARRAYNAME BOUNDS,SUBSCRIPTS,%INTEGER W)
!***********************************************************************
!*    W=+1 FOR ARRAY BY COLUMNS, W=-1 FOR ARRAY BY ROWS                *
!***********************************************************************
%INTEGER I
      %IF W=-1 %THEN I=1 %ELSE I=BOUNDS(0);   ! BOUNDS(0)=NO OF DIMENSNS
      %CYCLE
         SUBSCRIPTS(I)=SUBSCRIPTS(I)+1
         %EXIT %UNLESS SUBSCRIPTS(I)>BOUNDS(I)
         SUBSCRIPTS(I)=1
         I=I-W
      %REPEAT
%END
%INTEGERFN GETARAD(%INTEGERARRAYNAME BOUNDS,SUBSCRIPTS)
!***********************************************************************
!*    GET ARRAY RELATIVE ELEMENT ADDRESS OF ELEMENT IN SUBSCRIPTS      *
!***********************************************************************
%INTEGER ND,I,K,M1
      ND=BOUNDS(0)
      K=0; M1=1
      I=1
      %WHILE I<=ND %CYCLE
         K=K+M1*(SUBSCRIPTS(I)-1)
         M1=M1*BOUNDS(I)
         I=I+1
      %REPEAT
      %RESULT=K
%END
%ROUTINE ARRDERR(%INTEGER ERR,ELS,%STRINGNAME S)
!***********************************************************************
!*    PRINTS OUT AN ERROR MESSAGE FOR ANY ARRAY READS                  *
!***********************************************************************
%SWITCH SW(0:7)
%STRING(6)EXTRA
      EXTRA=""
      PRINTSTRING("
READING ARRAY ".S." FAILS AFTER")
      WRITE(ELS,2)
      PRINTSTRING(" ELEMENTS
REASON:= ")
      ->SW(ERR)
SW(0):   PRINTSTRING(" W NOT +1 OR -1")
EXIT: NEWLINE
      %MONITOR
      %STOP
SW(1):   PRINTSTRING("ARRAY SIZE INCORRECT")
      ->EXIT
SW(2):   EXTRA="GRAND "
SW(3):   PRINTSTRING(EXTRA."SUM CHECK IN WRONG PLACE")
      ->EXIT
SW(4):   EXTRA="GRAND "
SW(5):   PRINTSTRING(EXTRA."SUM CHECK FAILS")
      ->EXIT
SW(6):   PRINTSTRING("WRONG NO OF ZERO ELEMENTS PROVIDED")
      ->EXIT
SW(7):   PRINTSTRING("BOOLEAN NOT GIVEN AS 0 OR 1")
      ->EXIT
%END
%ROUTINE FINDARR(%STRINGNAME S,%INTEGERARRAYNAME BOUNDS,SUBSCRIPTS, %C
                  %INTEGERNAME W,RC,%INTEGER STRM)
!***********************************************************************
!*    SEARCH FOR STRING S ON STRM. READ W AND DIMENSIONS               *
!***********************************************************************
%INTEGER I,J,ND,M
%STRING(8)T,U
      T<-JCHKSTR(S)."       "
      %UNTIL T=U %THEN U<-JGETSTR(STRM)."       "
!
      I=JIREAD(STRM)
      ARRDERR(0,0,T) %UNLESS IMOD(I)=1
      W=I
!
      ND=JIREAD(STRM)
      ARRDERR(1,0,T) %UNLESS 1<=ND<=12
      BOUNDS(0)=ND; M=1
      %CYCLE I=1,1,ND
         J=JIREAD(STRM)
         SUBSCRIPTS(I)=1
         BOUNDS(I)=J
         M=M*J
      %REPEAT
      BOUNDS(-1)=M
      %IF W=1 %THEN RC=ND %ELSE RC=1
      SUBSCRIPTS(RC)=0
%END
%SYSTEMROUTINE JIRARRAY(%INTEGER STRM,%LONGINTEGER AD,DV, %C
                  %STRINGNAME STR)
!***********************************************************************
!*    READ AN INTEGER ARRAY FROM STRM IN J ALGOL FORMAT                *
!***********************************************************************
%ROUTINESPEC SUMCHECK(%INTEGER POS)
%INTEGER CHK,EL
%INTEGER I,J,K,TOTEL,AADDR,W,ZSEEN,ND,RC
%INTEGERARRAY BOUNDS(-1:12),SUBSCRIPTS(0:12)
      AADDR=INTEGER(ADDR(AD)+4)
      I=AD>>32; ZSEEN=0
      FINDARR(STR,BOUNDS,SUBSCRIPTS,W,RC,STRM)
      TOTEL=BOUNDS(-1)
      ND=BOUNDS(0)
      ARRDERR(1,0,STR) %UNLESS I&X'FFFFFF'=TOTEL
!
      %CYCLE I=1,1,TOTEL
         %IF ZSEEN#0 %THEN EL=0 %ELSE %START
            EL=JIREAD(STRM)
            J=JNEXTNS(STRM)
            %IF J='S' %THEN SUMCHECK(I-1) %AND J=JNEXTNS(STRM)
            %IF J='E' %AND I#TOTEL %THEN ARRDERR(4,I,STR)
            %IF J='Z' %THEN %START
               J=JCHARI(STRM)
               ARRDERR(6,I-1,STR) %UNLESS I+EL-1=TOTEL
               ZSEEN=1; EL=0
            %FINISH
         %FINISH
         UPDATE EL(BOUNDS,SUBSCRIPTS,W)
         K=GETARAD(BOUNDS,SUBSCRIPTS)
         INTEGER(AADDR+4*K)=EL
      %REPEAT
!
      %IF J='E' %THEN %START
         CHK=0
         %CYCLE I=0,1,TOTEL-1
            CHK=CHK+INTEGER(AADDR+4*I)
         %REPEAT
         J=JCHARI(STRM)
         EL=JIREAD(STRM)
         J=JCHARI(STRM)
         ARRDERR(5,TOTEL,STR) %UNLESS J='G' %AND EL=CHK
      %FINISH
      %RETURN
!
%ROUTINE SUMCHECK(%INTEGER POS)
%INTEGER I,J
!
! FIRST CHECK FOR RIGHT PLACE THEN CHECK THE SUM
!
      ARRDERR(3,POS,STR) %UNLESS BOUNDS(RC)=SUBSCRIPTS(RC)
      CHK=0
      %CYCLE I=1,1,BOUNDS(RC)
         SUBSCRIPTS(RC)=I
         J=GET ARAD(BOUNDS,SUBSCRIPTS)
         CHK=CHK+INTEGER(AADDR+4*J)
      %REPEAT
      ARRDERR(5,POS,STR) %UNLESS EL=CHK
      J=JCHARI(STRM);                  ! GET RID OS 'S'
      EL=JIREAD(STRM)
%END
%END
%SYSTEMROUTINE JRARRAY(%INTEGER STRM,%LONGINTEGER AD,DV, %C
                  %STRINGNAME STR)
!***********************************************************************
!*    READ A LONGREAL ARRAY FROM STRM IN J ALGOL FORMAT                *
!***********************************************************************
%ROUTINESPEC SUMCHECK(%INTEGER POS)
%LONGREAL CHK,EL
%INTEGER I,J,K,TOTEL,AADDR,W,ZSEEN,ND,RC
%INTEGERARRAY BOUNDS(-1:12),SUBSCRIPTS(0:12)
      AADDR=INTEGER(ADDR(AD)+4)
      I=AD>>32; ZSEEN=0
      FINDARR(STR,BOUNDS,SUBSCRIPTS,W,RC,STRM)
      TOTEL=BOUNDS(-1)
      ND=BOUNDS(0)
      ARRDERR(1,0,STR) %UNLESS I&X'FFFFFF'=TOTEL
!
      %CYCLE I=1,1,TOTEL
         %IF ZSEEN#0 %THEN EL=0 %ELSE %START
            EL=JREAD(STRM)
            J=JNEXTNS(STRM)
            %IF J='S' %THEN SUMCHECK(I-1) %AND J=JNEXTNS(STRM)
            %IF J='E' %AND I#TOTEL %THEN ARRDERR(4,I,STR)
            %IF J='Z' %THEN %START
               J=JCHARI(STRM)
               ARRDERR(6,I-1,STR) %UNLESS I+INT(EL)-1=TOTEL
               ZSEEN=1; EL=0
            %FINISH
         %FINISH
         UPDATE EL(BOUNDS,SUBSCRIPTS,W)
         K=GETARAD(BOUNDS,SUBSCRIPTS)
         LONGREAL(AADDR+8*K)=EL
      %REPEAT
!
      %IF J='E' %THEN %START
         CHK=0
         %CYCLE I=0,1,TOTEL-1
            CHK=CHK+LONGREAL(AADDR+8*I)
         %REPEAT
         J=JCHARI(STRM)
         EL=JREAD(STRM)
         J=JCHARI(STRM)
         ARRDERR(5,TOTEL,STR) %UNLESS J='G' %AND EL=CHK
      %FINISH
      %RETURN
!
%ROUTINE SUMCHECK(%INTEGER POS)
%INTEGER I,J
!
! FIRST CHECK FOR RIGHT PLACE THEN CHECK THE SUM
!
      ARRDERR(3,POS,STR) %UNLESS BOUNDS(RC)=SUBSCRIPTS(RC)
      CHK=0
      %CYCLE I=1,1,BOUNDS(RC)
         SUBSCRIPTS(RC)=I
         J=GET ARAD(BOUNDS,SUBSCRIPTS)
         CHK=CHK+LONGREAL(AADDR+8*J)
      %REPEAT
      ARRDERR(5,POS,STR) %UNLESS EL=CHK
      J=JCHARI(STRM);                  ! GET RID OS 'S'
      EL=JREAD(STRM)
%END
%END
%SYSTEMROUTINE JBRARRAY(%INTEGER STRM,F,%LONGINTEGER AD,DV, %C
                  %STRINGNAME STR)
!***********************************************************************
!*    READ A BOOLEAN ARRAY FROM STRM IN J ALGOL FORMAT                 *
!*    F=0 FOR 0 TRUE 1 FALSE. F#0 FOR 'TRUE' AND 'FALSE'               *
!*    NOTE ALGOLE USES 0 FOR FALSE AND -1 FOR TRUE                     *
!***********************************************************************
%ROUTINESPEC SUMCHECK(%INTEGER POS)
%INTEGER CHK,EL
%INTEGER I,J,K,TOTEL,AADDR,W,ZSEEN,ND,RC
%INTEGERARRAY BOUNDS(-1:12),SUBSCRIPTS(0:12)
      AADDR=INTEGER(ADDR(AD)+4)
      I=AD>>32; ZSEEN=0
      FINDARR(STR,BOUNDS,SUBSCRIPTS,W,RC,STRM)
      TOTEL=BOUNDS(-1)
      ND=BOUNDS(0)
      ARRDERR(1,0,STR) %UNLESS I&X'FFFFFF'=TOTEL
!
      %CYCLE I=1,1,TOTEL
         %IF F#0 %THEN EL=JREADBOOL(STRM) %ELSE %START
            %IF ZSEEN#0 %THEN EL=0 %ELSE %START
               EL=JIREAD(STRM)
               J=JNEXTNS(STRM)
               %IF J='S' %THEN SUMCHECK(I-1) %AND J=JNEXTNS(STRM)
               %IF J='E' %AND I#TOTEL %THEN ARRDERR(4,I,STR)
               %IF J='Z' %THEN %START
                  J=JCHARI(STRM)
                  ARRDERR(6,I-1,STR) %UNLESS I+EL-1=TOTEL
                  ZSEEN=1; EL=0
               %FINISH
            %FINISH
            ARRDERR(7,I,STR) %UNLESS 0<=EL<=1
         %FINISH
         UPDATE EL(BOUNDS,SUBSCRIPTS,W)
         K=GETARAD(BOUNDS,SUBSCRIPTS)
         INTEGER(AADDR+4*K)=EL
      %REPEAT
      %RETURN %IF F#0;                  ! NO CHECKSUMS IN BOOLEAN MODE
!
      CHK=0
      %CYCLE I=0,1,TOTEL-1
         K=INTEGER(AADDR+4*I)
         CHK=CHK+K; K=K-1
         INTEGER(AADDR+4*I)=K
      %REPEAT
      %IF J='E' %THEN %START
         J=JCHARI(STRM)
         EL=JIREAD(STRM)
         J=JCHARI(STRM)
         ARRDERR(5,TOTEL,STR) %UNLESS J='G' %AND EL=CHK
      %FINISH
      %RETURN
!
%ROUTINE SUMCHECK(%INTEGER POS)
%INTEGER I,J
!
! FIRST CHECK FOR RIGHT PLACE THEN CHECK THE SUM
!
      ARRDERR(3,POS,STR) %UNLESS BOUNDS(RC)=SUBSCRIPTS(RC)
      CHK=0
      %CYCLE I=1,1,BOUNDS(RC)
         SUBSCRIPTS(RC)=I
         J=GET ARAD(BOUNDS,SUBSCRIPTS)
         CHK=CHK+INTEGER(AADDR+4*J)
      %REPEAT
      ARRDERR(5,POS,STR) %UNLESS EL=CHK
      J=JCHARI(STRM);                  ! GET RID OS 'S'
      EL=JIREAD(STRM)
%END
%END
%SYSTEMROUTINE JFAULT(%STRINGNAME MESSAGE,%LONGREAL VALUE)
!*
!*THIS ENABLES AN ALGOL PROGRAM TO TERMINATE WITH A MESSAGE
!* AND DIAGNOSIS AS PER ALGOL 60M REPORT
!*
      PRINTSTRING('J-ALGOL FAULT  '.MESSAGE.'
PARAMETER = ')
      PRINTFL(VALUE,15)
      NEWLINE
      %MONITOR
      %STOP
%END
%SYSTEMROUTINE JTIDY
!***********************************************************************
!*    CLOSE ALL OPEN STREAMS. CALLED SOMEHOW AT END OF JOB             *
!***********************************************************************
%INTEGER I
      %CYCLE I=0,1,NOPEN-1
         CURRSTRM==JCNTL(I)
         %IF CURRSTRM_JSTRM>0 %THEN JCLOSE(CURRSTRM_JSTRM)
      %REPEAT
%END
%SYSTEMINTEGERFN IOCP(%INTEGER EP, N)
%OWNINTEGER INMARG1=1, INMARG2=72, OUTMARG1=1, OUTMARG2=120
%OWNINTEGER CONTROL;! 0  INCLUDE CONTROL CHARS IN LENGTH,1  EXCLUDE
%OWNBYTEINTEGERARRAY INPUTBUFF(0:160)
%OWNBYTEINTEGERARRAY RCHBUFF(0:160)
%OWNINTEGER PTR=1
%OWNBYTEINTEGERARRAY OUTPUTBUFF(0:133)=10,0(133)
%OWNINTEGER OUTPTR=1
%OWNINTEGER NLFLAG=1
%OWNINTEGER SUBCHAR=0
%OWNINTEGER EMFLAG=0
%ROUTINESPEC OUTPUTRECORD
%INTEGER FLAGS, FLAG, I, LENGTH, X, Q, L, CH, F
%SWITCH SW(1:20)
            %UNLESS 1<=EP<=19 %THEN SIGNAL(2,148,0,FLAG) %AND %STOP
            ->SW(EP)
SW(1):                                  ! READ SYMBOL(X)
            %IF NLFLAG=1 %THEN X=IOCP(6,0) %AND NLFLAG=0
            %UNTIL X#X'80' %CYCLE
               X=INPUTBUFF(PTR)
               PTR=PTR+1
            %REPEAT
            %IF X=NL %THEN NLFLAG=1
            %RESULT=X
SW(2):                                  ! X=NEXT SYMBOL
            %IF NLFLAG=1 %THEN X=IOCP(6,0) %AND NLFLAG=0
            %WHILE INPUTBUFF(PTR)=X'80' %THEN PTR=PTR+1
            %RESULT=INPUTBUFF(PTR)
SW(3):                                  ! PRINT SYMBOL(N)
            %IF N=10 %THEN ->OUTPUT
            OUTPUTBUFF(OUTPTR)=OTRTAB(N&X'7F')
            OUTPTR=OUTPTR+1
            %IF OUTPTR>OUTMARG2 %THENSTART
               OUTPUTBUFF(OUTPTR)=10
               OUTPUTRECORD
            %FINISH
END1:       %RESULT=0
SW(4):                                  ! READ CH(X)
SW(18):                                 ! NEXT CH (FOR ALGOLE
            %IF NLFLAG=1 %THEN X=IOCP(6,0) %AND NLFLAG=0
            X=RCHBUFF(PTR)
            %IF EP=18 %THEN %RESULT=X
            %IF X=NL %THEN NLFLAG=1
            PTR=PTR+1
            %RESULT=X
SW(5):                                  ! PRINT CH(N)
            %IF (N=10 %OR N=12 %OR N=13) %THEN %START
OUTPUT:        OUTPUTBUFF(OUTPTR)=N
               %IF CONTROL=0 %THEN OUTPTR=OUTPTR+1
               OUTPUTRECORD;  OUTPUTBUFF(0)=N
               ->END2
            %FINISH
            OUTPUTBUFF(OUTPTR)=N
            OUTPTR=OUTPTR+1
            %IF OUTPTR>OUTMARG2 %THEN %START
               OUTPUTBUFF(OUTPTR)=10
               OUTPUTRECORD;  OUTPUTBUFF(0)=10
            %FINISH
END2:       %RESULT=0
SW(6):                                  ! LINE RECONSTRUCTION
            PTR=1
            %IF EMFLAG=1 %THEN %START
               SIGNAL(2,140,0,FLAG);  %STOP
            %FINISH
!******READ A RECORD INTO RCHBUFF******
            SIM2(0,ADDR(RCHBUFF(1)),0,L)
!******SET FIRST BYTES OF BUFFERS TO LENGTH OF RECORD******
            %IF L=0 %THEN L=160
         RCHBUFF(0)=L
            INPUTBUFF(0)=L
!******TEST FOR EM IN INPUT RECORD******
            %IF RCHBUFF(PTR)=25 %THEN %START
               INPUTBUFF(0)=2;  EMFLAG=1
               INPUTBUFF(2)=10
               INPUTBUFF(1)=25; ->JUMP
            %FINISH
!******THE FOLLOWING MARKS CHARACTERS NOT CONTAINED IN IMP CHAR SET****
!******WHILST COPYING RECORD FROM RCHBUFF INTO INPUTBUFF******
!            %CYCLE I=1,1,INPUTBUFF(0)
!               X=RCHBUFF(I)
!               %IF X=X'1A' %THEN SUBCHAR=1
!               INPUTBUFF(I)=ITRTAB(X)
!            %REPEAT
         X=X'180000FF'
         *LD_INPUTBUFF; *INCA_=1
         *LSD_RCHBUFF; *IAD_=1
         *LDB_L; *STD_%TOS
         *MV_%L=%DR;                    ! COPY RCHBUFF TO INPUTBUFF
         *LD_%TOS; *LSS_ITRTAB+4; *LUH_X
         *STD_%TOS; *SWNE_%L=%DR,128,26;  ! CHECK FOR SUB

         *JCC_8,<NOSUB>
         *LB_=1; *STB_SUBCHAR
NOSUB:   *LD_%TOS; *TTR_%L=%DR
            %IF (SUBCHAR=1 %OR L=0) %THEN ->JUMP
!******FOLLOWING MARKS TO LEFT & RIGHT OF INMARG1 & INMARG2******
            %UNLESS INMARG1=1 %THEN %START
               %CYCLE I=1,1,INMARG1-1
                  INPUTBUFF(I)=X'80'
               %REPEAT
            %FINISH
            %IF INMARG2<L-1 %THEN %START
               %CYCLE I=INMARG2+1,1,L-1
                  INPUTBUFF(I)=X'80'
               %REPEAT
               L=INMARG2
            %FINISH
!!******THE FOLLOWING CARRIES OUT THE DELETION RULES******
!            %CYCLE I=1,1,L
!               Q=I
!               %IF INPUTBUFF(Q)=34 %THEN %START
!                  INPUTBUFF(Q)=X'80'
!BACK:             %IF (Q-1)<1 %THEN ->NEXT2
!                  %IF INPUTBUFF(Q-1)=X'80' %THEN Q=Q-1 %AND ->BACK
!                  INPUTBUFF(Q-1)=X'80'
!               %FINISH
!NEXT2:      %REPEAT
!******THE FOLLOWING MARKS TRAILING SPACES BEFORE NEWLINE******
!            %CYCLE I=L-1,-1,1
!               %IF INPUTBUFF(I)=32 %THEN INPUTBUFF(I)=X'80' 
!               %EXIT %UNLESS INPUTBUFF(I)=X'80'
!            %REPEAT
         *LD_INPUTBUFF; *LB_L; *SBB_=1
DTRS:    *LSS_(%DR+%B); *ICP_=32
         *JCC_7,<NOTSP>
         *LSS_=128; *ST_(%DR+%B); *DEBJ_<DTRS>
NOTSP:   *ICP_=128; *JCC_7,<JUMP>; *DEBJ_<DTRS>
!******RECONSTRUCTION NOW COMPLETE******
!******TEST FOR SUB CHAR IN INPUT******
JUMP:       I=ADDR(INPUTBUFF(0))
            %IF SUBCHAR=1 %THEN %START
               SUBCHAR=0;  SIGNAL(2,144,0,FLAG)
               %STOP
         %FINISH
         %RESULT=I
SW(15):                                 ! RESTRICTED PRINTSTRING
                                        ! STRING MUST HAVE NO UNPRINTABLES
                                        ! OR CONTROLS (XCEPT LAST CHAR)
                                        ! AND MAY NOT EXCEED MARGINS
         X=X'180000FF'
         L=BYTE INTEGER(N)
         *LD_OUTPUTBUFF; *MODD_OUTPTR;   ! TO RECEIVE STRING
         *LDB_L
         *STD_%TOS; *STD_%TOS
         *LDA_N; *INCA_=1; *CYD_=0
         *LD_%TOS; *MV_%L=%DR
         *LD_%TOS; *LSS_OTRTAB+4
         *LUH_X; *TTR_%L=%DR
         *INCA_=-1
         *LSS_(%DR); *ST_X
         OUTPTR=OUTPTR+L
         OUTPTR=OUTPTR-1 %AND OUTPUT RECORD %IF X=10
         %RESULT=0
!
! CAN DELETE M-C CODE AND ALLOX SW(15) TO DROP THRO TO SW(7)
! IF REQUIRED FOR ALL IMP VERSION
!
SW(7):                                  ! PRINT STRING(N) WHERE
                                        ! N IS ADDRESS OF STRING
            L=BYTEINTEGER(N)
            %IF L=0 %THEN %RESULT=0
            %CYCLE I=1,1,L
               CH=BYTEINTEGER(I+N)&X'7F'
               %IF CH=10 %THEN OUTPUT RECORD %ELSE %START
                  OUTPUTBUFF(OUTPTR)=OTRTAB(CH)
                  OUTPTR=OUTPTR+1
                  %IF OUTPTR>OUTMARG2 %THEN OUTPUT RECORD
               %FINISH
            %REPEAT
            %RESULT=0
SW(8):                                  ! SELECT INPUT(N)
            INPUTBUFF(0)=0
            EMFLAG=0; NLFLAG=1
            SIM2(15,0,N,FLAGS)
            %IF FLAGS<0 %THEN %START
               SIGNAL(2,152,0,FLAG)
               %STOP
            %FINISH
            INMARG1=(FLAGS>>8)&X'FF'
            INMARG2=FLAGS&X'FF'
            %RESULT=0
SW(9):                                  ! SELECT OUTPUT(N)
            OUTPUTRECORD %UNLESS (OUTPUTBUFF(0)=10 %AND OUTPTR=1)
            SIM2(15,1,N,FLAGS)
            %IF FLAGS<0 %THEN %START
               SIGNAL(2,152,0,FLAG)
               %STOP
            %FINISH
            OUTMARG1=(FLAGS>>8)&X'FF'
            OUTMARG2=FLAGS&X'FF'
            %IF OUTMARG2=0 %THENSTART
               OUTMARG2=132
               CONTROL=0
            %FINISHELSE CONTROL=1
            %RESULT=0
SW(10):                                 ! ISOCARD(N) WHERE N IS THE
                                        ! ADDRESS OF BUFFER CARD READ INTO
            SIM2(0,ADDR(INPUTBUFF(0)),0,LENGTH)
            %IF INPUTBUFF(0)=25 %THEN %START
               SIGNAL(2,140,0,FLAG);  %STOP
            %FINISH
            %CYCLE I=0,1,LENGTH-2
               BYTEINTEGER(N+I)=INPUTBUFF(I)
            %REPEAT
            INPUTBUFF(0)=0
            %RESULT=0
SW(11):                                 ! OUTPUT THE CURRENT RECORD
            OUTPUTBUFF(OUTPTR)=10
            %IF CONTROL=0 %THEN OUTPTR=OUTPTR+1
            %IF N>=0 %THEN SIM2(1,ADDR(OUTPUTBUFF(0)),OUTPTR,F)
            OUTPTR=1
            OUTPUTBUFF(0)=10
            EMFLAG=0; NLFLAG=1
            INMARG1=1;  INMARG2=72
            OUTMARG1=1;  OUTMARG2=120
            JTIDY
            %RESULT=0
SW(12):                                 ! SET INPUT MARGINS
            FLAGS=0
            INMARG1=(N>>16)&X'FF'
            INMARG2=N&X'FF'
            SIM2(16,0,(INMARG1<<8)!INMARG2,FLAGS)
            %RESULT=0
SW(13):                                 ! SET OUTPUT MARGINS
            FLAGS=0
            OUTMARG1=(N>>16)&X'FF'
            X=IOCP(5,10);               ! OUTPUT NEWLINE
            OUTMARG2=N&X'FF'
            SIM2(16,1,(OUTMARG1<<8)!OUTMARG2,FLAGS)
            %IF OUTMARG2=0 %THENSTART
               OUTMARG2=132
               CONTROL=0
            %FINISHELSE CONTROL=1
            %RESULT=0
SW(14):                                 ! ADDRESS OF RECORD AS READ IN
            %RESULT=ADDR(RCHBUFF(0))
SW(16):                                 ! CLOSE STREAM(N)
            SIM2(17,N,0,FLAGS)
            %RESULT=0
SW(17):                                 ! REPEATED PRINT SYMBOL
         %RESULT=0 %IF N<0 %OR N>>8=0
         %CYCLE I=1,1,N>>8
            X=IOCP(3,N&127)
         %REPEAT
         %RESULT=0
SW(19):                                     ! GET CURRNET MARGINS
         %RESULT=((INMARG1<<8!INMARG2)<<8!OUTMARG1)<<8!OUTMARG2
SW(20):      ! GET POSITION OF INPUT OR OUTPUT POINTER
            %IF N=0 %THEN %RESULT=PTR;! INPUT POINTER
            %RESULT=OUTPTR;! OUTPUT POINTER
%ROUTINE OUTPUTRECORD
%INTEGER F, I
            SIM2(1,ADDR(OUTPUTBUFF(0)),OUTPTR,F)
            OUTPTR=OUTMARG1
            OUTPUTBUFF(0)=10
            I=1
            %WHILE I<OUTMARG1 %THEN OUTPUTBUFF(I)=' ' %AND I=I+1
%END
%END
%ENDOFFILE