!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