!* MODIFIED 24/01/78 16.00
!*
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)
*LSD_X
*RAD_X'4F00000000000000'
*RRSB_X
*JAF_2,<OK>
*RAD_R'4110000000000000'
OK: *EXIT_-64
END
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 Y,Z,ROUND
INTEGER I,J,L,SIGN
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
ROUND= 0.5/R'41A0000000000000'**M;! ROUNDING FACTOR
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
I=0;Z=1; Y=Y+ROUND
UNTIL Z>Y CYCLE ; ! COUNT LEADING PLACES
I=I+1;Z=10*Z; ! NO DANGER OF OVERFLOW HERE
REPEAT
SPACES(N-I); ! O.K FOR ZERO OR -VE SPACES
PRINT SYMBOL(SIGN)
J=I-1; Z=R'41A0000000000000'**J
CYCLE
UNTIL J<0 CYCLE
L=INT PT(Y/Z); ! OBTAIN NEXT DIGIT
Y=Y-L*Z;Z=Z/10; ! AND REDUCE TOTAL
PRINT SYMBOL(L+'0')
J=J-1
REPEAT
IF M=0 THEN RETURN ; ! NO DECIMAL PART TO BE O/P
PRINTSTRING(".")
J=M-1; Z=R'41A0000000000000'**(J-1); M=0
Y=10*Y*Z
REPEAT
END ; ! OF ROUTINE PRINT
!8
SYSTEMROUTINE WRITE(INTEGER NUM,N)
IF N=0 THEN N=1
PRINT(NUM,N,0)
END ;! 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 *
!***********************************************************************
!
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
PRINTSTRING("@")
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