!NEW ASSEMBLER WRITE ROUTINE ADDED  RRM 29.3.78
!**DELSTART
%SYSTEMINTEGERFNSPEC IOCP(%INTEGER EP,PARM)
!**DELEND
%LONGINTEGERFNSPEC LINT(%LONGLONGREAL X)
!*
!*
          %SYSTEMROUTINE READ(%INTEGER TYPEBND,ADR)
!***********************************************************************
!*       THIS ROUTINE IS THE IMP IMPLICITLY SPECIFIED ROUTINE WITH A   *
!*       %NAME PARAMETER. TYPEBND AND ADR ARE A 64 BIT DESCRIPTOR     *
!*    TO THE ACTUAL PARAMETER. THE BND FIELD HAS THE TYPE CODE INIT    *
!*    (=1 FOR INTEGER =2 FOR REAL).                                    *
!*                                                                     *
!*       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.                                                      *
!***********************************************************************
         %INTEGER TYPE,PREC,FLAG,CURSYM; ! FLAG= 0FOR'-',1 FOR '+'
         %INTEGER IVALUE,TVALUE,PARTYPE
         %LONGINTEGER LIVALUE
         %LONGLONGREAL RWORK,SCALE
         %SWITCH RL(5:7)
         FLAG=1; TYPE=0; PARTYPE=TYPEBND&7
         CURSYM=NEXT SYMBOL;          ! CARE NOT TO READ TERMINATOR
! NOW IGNORE LEADING SPACES
         %WHILE CURSYM=' ' %OR CURSYM=NL %CYCLE
            SKIP SYMBOL
            CURSYM=NEXT SYMBOL
         %REPEAT
         %IF CURSYM=X'19' %THEN %SIGNALEVENT 9,1
                                       ! RECORD INITIAL MINUS
         %IF CURSYM='-' %THEN FLAG=0 %AND CURSYM='+'
                                       ! MOVE OVER SIGN ONCE IT HAS
                                       ! BEEN RECORDED IN FLAG
         %IF CURSYM='+' %THEN SKIP SYMBOL %AND CURSYM=NEXT SYMBOL
         %IF '0'<=CURSYM %AND CURSYM<='9' %THEN %START
            RWORK=CURSYM-'0';          ! KEEP TOTAL IN RWORK
            TYPE=1;                    ! VALID DIGIT
            %CYCLE
               SKIP SYMBOL
               CURSYM=NEXT SYMBOL
               %EXIT %UNLESS '0'<=CURSYM %AND CURSYM<='9'
               RWORK=R'41A00000000000000000000000000000'*RWORK %C
                  +(CURSYM-'0');! CONTINUE EVALUATING
            %REPEAT
         %FINISH %ELSE RWORK=0
         %IF CURSYM='.' %AND PARTYPE=2 %THEN %START
            SCALE=R'41A00000000000000000000000000000'
            %CYCLE
               SKIP SYMBOL
               CURSYM=NEXT SYMBOL
               %EXIT %UNLESS '0'<=CURSYM %AND CURSYM<='9'
               TYPE=1
               RWORK=RWORK+(CURSYM-'0')/SCALE
               SCALE=R'41A00000000000000000000000000000'*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 (CURSYM='@' %OR CURSYM='&') %AND PARTYPE=2 %THEN %START
            %IF TYPE=0 %THEN TYPE=1 %AND RWORK=1
            SKIP SYMBOL;                ! MOVE PAST THE '@'
            READ(X'29000001',ADDR(IVALUE));! RECURSIVE CALL TO FIND EXPONENT
            %IF IVALUE=-99 %THEN RWORK=0 %ELSE %C
               RWORK=RWORK*R'41A00000000000000000000000000000'**IVALUE
         %FINISH
         %SIGNALEVENT 4,1 %IF TYPE=0;        ! NO VALID DIGIT FOUND
!
! KNOCK NUMBER INTO RIGHT FORM
!
         PREC=TYPEBND>>27&7
         PREC=5 %IF PREC<5
         %IF PARTYPE=1 %THEN %START
            %IF PREC=6 %THENSTART
             LIVALUE = LINT(RWORK)
            *LSD_LIVALUE
            *ST_(TYPEBND)
            %RETURN
          %FINISH
            IVALUE= INT(RWORK)
            %IF FLAG=0 %THEN IVALUE=-IVALUE
            *LSS_IVALUE
NOTLI:      *ST_(TYPEBND)
            %RETURN
         %FINISH
         %IF PARTYPE#2 %THEN PRINT STRING('
INVALID PARAMETER PASSED TO READ') %AND %MONITOR %AND %STOP
         %IF FLAG=0 %THEN RWORK=-RWORK
         ->RL(PREC)
RL(5):                                  ! 32 BIT REAL
         *LSD_=X'7F'; *USH_=25
         *OR_=1; *USH_=31;              ! ACC=X'7F00000080000000'
         *AND_RWORK; *RAD_RWORK;        ! SOFTWARE ROUND
         *STUH_(TYPEBND)
         %RETURN
RL(6):                                  ! 64 BIT REAL
         *LSD_=X'7F'; *USH_=56; *AND_RWORK
         *SLSD_=1; *USH_=55; *AND_RWORK+8
         *LUH_%TOS; *RAD_RWORK;         ! SOFTWARE ROUND
         *STUH_(TYPEBND)
         %RETURN
RL(7):                                  ! 128 BIT REAL
         *LSQ_RWORK
         *ST_(TYPEBND)
!
!  %MONITOR (N) == FORCE FAULT NO N
!  N=16    REAL INSTEAD OF INTEGER IN DATA
!  N=14    SYMBOL IN DATA
!
         %END
          %CONSTLONGREAL IMAX=2147483647; ! MAX INTEGER FOR 32 BIT WORD
                                          ! NEEDS CHANGING FOR OTHER WLENGT
          %CONSTLONGREAL DZ=0
         %SYSTEMLONGREALFN FRACPT(%LONGREAL X)
!***********************************************************************
!*       RETURNS (X-INTPT(X)) AS THE RESULT                            *
!***********************************************************************
         %RESULT=X-INTPT(X)
         %END
%CONSTLONGREALARRAY TENPOWERS(0:20)=1,10,100,1000,1@4,1@5,1@6,
                                    1@7,1@8,1@9,1@10,1@11,1@12,
                                    1@13,1@14,1@15,1@16,1@17,
                                    1@18,1@19,1@20;
%ROUTINESPEC PRINTFL(%LONGREAL X,%INTEGER N)
%SYSTEMROUTINE PRINT(%LONGREAL X,%INTEGER N,M)
!***********************************************************************
!*       PRINTS A REAL NUMBER (X) ALLOWING N PLACES BEFORE THE DECIMAL *
!*       POINT AND M PLACES AFTER.IT REQUIRES (M+N+2) PRINT PLACES     *
!*       UNLESS (M=0) WHEN  (N+1) PLACES ARE REQUIRED.                 *
!*                                                                     *
!*       A LITTLE CARE IS NEEDED TO AVOID UNNECESSARY LOSS OF ACCURACY *
!*       AND TO AVOID OVERFLOW WHEN DEALING WITH VERY LARGE NUMBERS    *
!***********************************************************************
%LONGREAL ROUND
%LONGLONGREAL Y,Z
%STRING(127)S
%INTEGER I,J,L,SIGN,SPTR
      M=M&63;                       ! DEAL WITH STUPID PARAMS
      %IF N<0 %THEN N=1; N=N&31;   ! DEAL WITH STUPID PARAMS
      X=X+DZ;                       ! NORMALISE
      SIGN=' ';                     ! '+' IMPLIED
      %IF X<0 %THEN SIGN='-'
      Y=MOD(X);                     ! ALL WORK DONE WITH Y
      %IF Y>1@15 %OR N=0 %THEN %START;      ! MEANINGLESS FIGURES GENERATED
         %IF N>M %THEN M=N;         ! FOR FIXED POINT PRINTING
         PRINT FL(X,M);             ! OF ENORMOUS NUMBERS
         %RETURN;                   ! SO PRINT IN FLOATING FORM
      %FINISH
      %IF M<=30 %THEN ROUND=1/(2*TENPOWERS(M)) %ELSE %C
         ROUND= 0.5/R'41A00000000000000000000000000000'**M;! ROUNDING FACTOR
      Y=Y+ROUND
      ->FASTPATH %IF N+M<=16 %AND Y<TENPOWERS(N)
      I=0;Z=1
      %UNTIL Z>Y %CYCLE;            ! COUNT LEADING PLACES
         I=I+1;Z=10*Z;              ! NO DANGER OF OVERFLOW HERE
      %REPEAT
      SPTR=1
      %WHILE SPTR<=N-I %CYCLE
         CHARNO(S,SPTR)=' '
         SPTR=SPTR+1
      %REPEAT
      CHARNO(S,SPTR)=SIGN
      SPTR=SPTR+1
      J=I-1; Z=R'41A00000000000000000000000000000'**J
      %CYCLE
         %UNTIL J<0 %CYCLE
            L=INT PT(Y/Z);          ! OBTAIN NEXT DIGIT
            Y=Y-L*Z;Z=Z/10;         ! AND REDUCE TOTAL
            CHARNO(S,SPTR)=L+'0'
            SPTR=SPTR+1
            J=J-1
         %REPEAT
         %IF M=0 %THEN %EXIT;       ! NO DECIMAL PART TO BE O/P
         CHARNO(S,SPTR)='.'
         SPTR=SPTR+1
         J=M-1; Z=R'41A00000000000000000000000000000'**(J-1)
         M=0
         Y=10*Y*Z
      %REPEAT
      LENGTH(S)=SPTR-1
      ->OPUT
FASTPATH:                               ! USE SUPK WITHOUT SCALING
      L=M+N+2;                          ! NO OF BYTES TO BE OPUT
      %IF M=0 %THEN L=L-1
      Y=Y*TENPOWERS(M);                 ! CONVERT TO INTEGER
      J=N-1
      I=30-M-N;                         ! FOR DECIMAL SHIFT
      *LSQ_Y
      *FIX_%B
      *MYB_4
      *ISH_%B
      *CDEC_0
      *LD_S
      *LB_L
      *MVL_%L=1;                        ! LENGTH INTO STRING
      *DSH_I
      *CPB_%B;                          ! SET CC=0 FOR SUPK
      *LDB_J
      *JAT_11,6;                        ! TILL SUPK FIXED!
      *SUPK_%L=%DR,0,32;                ! UNPACK WITH LEADING SPACES
      *JCC_7,<DESSTACKED>
      *STD_%TOS;                        ! FOR SIGN INSERTION
DESSTACKED:
      *LDB_2
      *SUPK_%L=1,0,32
      *SUPK_%L=1,0,48;                  ! FORCE ZERO BEFORE DP
      *SLD_%TOS
      *LB_SIGN
      *STB_(%DR);                       ! INSERT SIGN
      *LB_46;                           ! ISO DECIMAL POINT
      *LD_%TOS
      *LDB_M
      *JAT_11,<NOFRPART>;               ! INTEGER PRINTING
      *STB_(%DR)
      *INCA_1
      *SUPK_%L=%DR,0,48;                ! ZEROFILL
NOFRPART:
      *LDB_(S)
      *ANDS_%L=%DR,0,63;                ! FORCE ISO ZONE CODES
OPUT:
      J=IOCP(15,ADDR(S))
%END;                                  ! OF ROUTINE PRINT
!8
%SYSTEMROUTINE WRITE(%INTEGER VALUE,PLACES)
%STRING(16)S
%INTEGER D0,D1,D2,D3,L
      PLACES=PLACES&15
      *LSS_VALUE; *CDEC_0
      *LD_S; *INCA_1; *STD_%TOS
      *CPB_%B;                          ! SET CC=0
      *SUPK_%L=15,0,32;                 ! UNPACK & SPACE FILL
      *STD_D2; *JCC_8,<WASZERO>
      *LD_%TOS; *STD_D0;                 ! FOR SIGN INSERTION
      *LD_%TOS
      *MVL_%L=15,63,0;                 ! FORCE ISO ZONE CODES
      %IF VALUE<0 %THEN BYTEINTEGER(D1)='-'
      L=D3-D1
OUT:  %IF PLACES>=L %THEN L=PLACES+1
      D3=D3-L-1
      BYTEINTEGER(D3)=L
      D3=IOCP(15,D3)
      %RETURN
WASZERO:
      BYTEINTEGER(D3-1)='0'
      L=2; ->OUT
%END;    !OF WRITE
!*
%SYSTEMROUTINE PRINTFL(%LONGREAL XX,%INTEGER N)
!***********************************************************************
!*       PRINTS IN FLOATING POINT FORMAT WITH N PLACES AFTER THE       *
!*       DECIMAL POINT. ALWAYS TAKES N+7 PRINTING POSITIONS.           *
!*       CARE REQUIRED TO AVOID OVERFLOW WITH LARGE X                  *
!***********************************************************************
%STRING(47)S
%LONGLONGREAL ROUND,FACTOR,LB,UB,X,Y
%INTEGER COUNT,INC,SIGN,L,J
      N=N&31
      %IF N<=20 %THEN Y=TENPOWERS(N) %ELSE %C
         Y=TENPOWERS(20)*TENPOWERS(N-20)
      ROUND=R'41100000000000000000000000000000'/(2*Y)
      LB=1-ROUND; UB=10-ROUND
      SIGN=' '
      X=XX+DZ;                      ! NORMALISE
      %IF X=0 %THEN COUNT=-99 %ELSE %START
         %IF X<0 %THEN X=-X %AND SIGN='-'
         INC=1; COUNT=0
         FACTOR=R'4019999999999999999999999999999A'
         %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
      %IF N>16 %THEN %START;            ! TOO BIG FOR CDEC WITHOUT SCALING
         LENGTH(S)=N+4
         CHARNO(S,1)=SIGN
         L=INTPT(X)
         CHARNO(S,2)=L+'0'
         CHARNO(S,3)='.'
         J=1
         %WHILE J<=N %CYCLE
            X=(X-L)*10
            L=INTPT(X)
            CHARNO(S,J+3)=L+'0'
            J=J+1
         %REPEAT
      %FINISH %ELSE %START
         X=X*Y
         J=30-N
         *LSQ_X
         *FIX_%B
         *MYB_4
         *ISH_%B;                       ! NOCHECKING NEEDED AS N LIMITED
         *CDEC_0;                       ! GIVES 128 BIT DECIMAL N0
         *LB_N
         *ADB_4
         *LD_S
         *MVL_%L=1;                     ! LENGTH INTO STRING
         *DSH_J
         *LB_SIGN
         *MVL_%L=1;                     ! SIGN INTO STRING
         *SUPK_%L=1,0,48;               ! FIRST DIGIT INTO STRING
         *MVL_%L=1,0,46;                ! DOT INTO STRING
         *LDB_N
         *SUPK_%L=%DR,0,48;              ! UNPACK FR PT &ZEROFILL
         *LD_S
         *LDB_(%DR)
         *ANDS_%L=%DR,0,63;             ! FORCE ISO ZONE CODES
      %FINISH
      CHARNO(S,N+4)='@'
      J=IOCP(15,ADDR(S))
      WRITE(COUNT,2)
         %END;                         ! OF ROUTINE PRINTFL
         %SYSTEMROUTINE FPRINTFL(%LONGREAL XX,%INTEGER N,TYPE)
!***********************************************************************
!*       PRINTS IN FLOATING POINT FORMAT WITH N PLACES AFTER THE       *
!*       DECIMAL POINT. ALWAYS TAKES N+7 PRINTING POSITIONS.           *
!*       CARE REQUIRED TO AVOID OVERFLOW WITH LARGE X                  *
!***********************************************************************
!
         %LONGREAL ROUND,FACTOR,LB,UB,X,Y
         %INTEGER COUNT,INC,SIGN,L,J
         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
         PRINTSYMBOL(SIGN)
         L=INTPT(X)
         PRINTSYMBOL(L+'0')
         PRINTSYMBOL('.')
         J=1
         %WHILE J<=N %CYCLE
            X=(X-L)*10
            L=INTPT(X)
            PRINTSYMBOL(L+'0')
            J=J+1
         %REPEAT
         %IF TYPE=1 %THEN PRINTSTRING("E") %ELSE PRINTSTRING("D")
         WRITE(COUNT,2)
         %END;                         ! OF ROUTINE PRINTFL
!
!
!
!
! THREE BODIES ONLY USED IF INTRINSICS PASSED AS RT PARAMETERS
!
%SYSTEMINTEGERFN INT(%LONGREAL X)
      %RESULT=INTPT(X+0.5)
%END
%INTEGERFN FIX(%LONGREAL X)
      %RESULT=INTPT(X)
%END
%SYSTEMINTEGERFN INTPT(%LONGREAL X)
      %RESULT=FIX(X)
%END
%SYSTEMLONGINTEGERFN LINTPT(%LONGLONGREAL X)
   *LSQ_X
    *RSC_47
    *RSC_-47
    *FIX_%B
    *MYB_4
    *CPB_-64
    *JCC_10,<LI>
    *LB_-64
LI: *ISH_%B
    *EXIT_-64
%END
%SYSTEMLONGINTEGERFN LINT(%LONGLONGREAL X)
   *LSQ_X
    *RAD_R'40800000000000000000000000000000'
    *RSC_47
    *RSC_-47
    *FIX_%B
    *MYB_4
    *CPB_-64
    *JCC_10,<LI>
    *LB_-64
LI: *ISH_%B
    *EXIT_-64
%END
         %ENDOFFILE