!* MODIFIED 20/02/78 ERROR MESSAGE VALUES
!* MODIFIED 8/11/77 READ1900 IGNORES MULTIPLE SP & NL AFTER EXP CHAR
!* MODIFIED 18/02/77 SQ AND DA FILE ROUTINES ADDED
!* MODIFIED 13/01/77 SET MARGINS
!* MODIFIED 03/12/76 NEW VERSIONS OF READ1900,WRITETEXT
!******** MODIFIED 02:07:76 15.15 LCG (ALGLRTS,MATHFNS CONCATONATED
! ,COMPLEX ROUTINES
! & DUPLICATES FOR FORTRAN)
SYSTEMROUTINESPEC SSERR(INTEGER I)
SYSTEMROUTINESPEC IOCP(INTEGER A,B)
SYSTEMINTEGERMAPSPEC COMREG(INTEGER N)
SYSTEMROUTINESPEC MLIBERR(INTEGER ERR)
CONSTLONGREAL R1=R'41C98867F42983DF'
CONSTLONGREAL R2=R'C2562FB2813C6014'
CONSTLONGREAL R3=R'C1146D547FED8A3D'
CONSTLONGREAL R4=R'C0157BD961F06C89'
CONSTLONGREAL S1=R'421B189E39236635'
CONSTLONGREAL S2=R'4168EE1BDE0C3700'
CONSTLONGREAL S3=R'41224E7F3CBDFE41'
CONSTLONGREAL S4=R'41144831DAFBF542'
CONSTLONGREAL RT3=R'411BB67AE8584CAA'
CONSTLONGREAL PIBY6=R'40860A91C16B9B2C'
CONSTLONGREAL PIBY2M1=R'40921FB54442D184'
CONSTLONGREAL RT3M1=R'40BB67AE8584CAA7'
CONSTLONGREAL TANPIBY12=R'404498517A7B3559'
CONSTLONGREAL PIBY4=R'40C90FDAA22168C2'
CONSTLONGREAL A1=R'40C0000000000000'
CONSTLONGREAL A2=R'3F90FDAA22168C23'
CONSTLONGREAL DEFALLT=R'40B504F333F9DE65'
CONSTLONGREAL MAX=R'4DC90FDAA22168C2'
CONSTLONGREAL GREATEST=R'7FFFFFFFFFFFFFFF'
SYSTEMLONGREALFN ISIN(LONGREAL INARG)
INTEGER N, N1, N0
LONGREAL ARG, DIV, REM, RES
LONGREAL R1, R2, APPROX
CONSTLONGREAL S0=0.785398163397448307
CONSTLONGREAL S1=-0.0807455121882805396;!@-1
CONSTLONGREAL S2=0.00249039457018884507;!@-2
CONSTLONGREAL S3=-0.0000365762041589190506;!@-4
CONSTLONGREAL S4=0.000000313361622553306939;!@-6
CONSTLONGREAL S5=-0.00000000175715008354919024;!@-8
CONSTLONGREAL S6=0.00000000000687736352204187372;!@-11
CONSTLONGREAL C0=1.0
CONSTLONGREAL C1=-0.308425137534042457
CONSTLONGREAL C2=0.0158543442438154890;!@-1
CONSTLONGREAL C3=-0.000325991886927199623;!@-3
CONSTLONGREAL C4=0.00000359086044744883857;!@-5
CONSTLONGREAL C5=-0.0000000246113662387505408;!@-7
CONSTLONGREAL C6=0.000000000115006797403238400;!@-9
CONSTLONGREAL C7=-0.000000000000386315826585600000;!@-12
N1=0
CONSTLONGREAL MDEFALLT=R'C0B504F333F9DE65'
*LSD_INARG; *LB_4; *JAF_2,<NN>
*STB_N1; *AND_X'7FFFFFFFFFFFFFFF'
NN: *ST_ARG; *ICP_MAX; *JCC_4,<CALC>
MLIBERR(54); ! ERROR(1, 2, 1, 0, 1, 0)
IF N1=4 THEN RESULT =MDEFALLT ELSE RESULT =DEFALLT
CALC:
! DIV=ARG/PIBY4
! N=INTPT(DIV)
! REM=(ARG-N*A1-N*A2)/PIBY4
! N0=(N+N1)&7
! %IF N0&1=0 %THEN R1=REM %ELSE R1=1.0-REM
! R2=R1*R1
! %IF N0=0 %OR N0=3 %OR N0=4 %OR N0=7 %THEN APPROX=((((( %C
! (S6*R2+S5)*R2+S4)*R2+S3)*R2+S2)*R2+S1)*R2+S0)*R1 %ELSE %C
! APPROX=((((((C7*R2+C6)*R2+C5)*R2+C4)*R2+C3)*R2+C2)*R2+C1)*R2+C0
! %IF N0>3 %THENRESULT =-APPROX %ELSERESULT =APPROX
*RDV_PIBY4; *FIX_B ; *MYB_4
*CPB_-64; *JCC_10,<NTS>; *LB_-64
NTS: *ISH_B ; *STUH_B ; *ST_N
*FLT_0; *SLSD_A1; *RAD_A2; *RMY_TOS ; *RRSB_ARG; *RDV_PIBY4
*ST_REM; *LSS_N; *IAD_N1; *AND_7; *ST_B
*AND_1; *JAF_4,<EL>; *LSD_REM; *J_<BTH>
EL: *LSD_1.0; *RSB_REM
BTH: *ST_R1; *RMY_R1; *ST_R2; *JAT_12,<SWAY>
*CPB_3; *JCC_8,<SWAY>; *CPB_4; *JCC_8,<SWAY>
*CPB_7; *JCC_7,<CWAY>
SWAY: *RMY_S6; *RAD_S5; *RMY_R2; *RAD_S4
*RMY_R2; *RAD_S3; *RMY_R2; *RAD_S2
*RMY_R2; *RAD_S1; *RMY_R2; *RAD_S0
*RMY_R1; *J_<BWAY>
CWAY: *RMY_C7; *RAD_C6; *RMY_R2; *RAD_C5
*RMY_R2; *RAD_C4; *RMY_R2; *RAD_C3
*RMY_R2; *RAD_C2; *RMY_R2; *RAD_C1
*RMY_R2; *RAD_C0
BWAY: *CPB_3; *JCC_2,<NRG>; *EXIT_-64
NRG: *RRSB_0; *EXIT_-64
END
SYSTEMLONGREALFN ICOS(LONGREAL INARG)
INTEGER N
LONGREAL R1, R2, APPROX
LONGREAL ARG, DIV, REM, RES
INTEGER N0
CONSTLONGREAL S0=0.785398163397448307
CONSTLONGREAL S1=-0.0807455121882805396;!@-1
CONSTLONGREAL S2=0.00249039457018884507;!@-2
CONSTLONGREAL S3=-0.0000365762041589190506;!@-4
CONSTLONGREAL S4=0.000000313361622553306939;!@-6
CONSTLONGREAL S5=-0.00000000175715008354919024;!@-8
CONSTLONGREAL S6=0.00000000000687736352204187372;!@-11
CONSTLONGREAL C0=1.0
CONSTLONGREAL C1=-0.308425137534042457
CONSTLONGREAL C2=0.0158543442438154890;!@-1
CONSTLONGREAL C3=-0.000325991886927199623;!@-3
CONSTLONGREAL C4=0.00000359086044744883857;!@-5
CONSTLONGREAL C5=-0.0000000246113662387505408;!@-7
CONSTLONGREAL C6=0.000000000115006797403238400;!@-9
CONSTLONGREAL C7=-0.000000000000386315826585600000;!@-12
*LSD_INARG; *AND_X'7FFFFFFFFFFFFFFF'
*ST_ARG; *ICP_MAX; *JCC_4,<CALC>
MLIBERR(55); ! ERROR(1, 5, 1, 0, 1, 0)
RESULT =DEFALLT
CALC:
! DIV=ARG/PIBY4
! N=INTPT(DIV)
! REM=(ARG-N*A1-N*A2)/PIBY4
! N0=(N+2)&7
! %IF N0&1=0 %THEN R1=REM %ELSE R1=1.0-REM
! R2=R1*R1
! %IF N0=0 %OR N0=3 %OR N0=4 %OR N0=7 %THEN APPROX=((((( %C
! (S6*R2+S5)*R2+S4)*R2+S3)*R2+S2)*R2+S1)*R2+S0)*R1 %ELSE %C
! APPROX=((((((C7*R2+C6)*R2+C5)*R2+C4)*R2+C3)*R2+C2)*R2+C1)*R2+C0
! %IF N0>3 %THENRESULT =-APPROX %ELSERESULT =APPROX
*RDV_PIBY4; *FIX_B ; *MYB_4
*CPB_-64; *JCC_10,<NTS>; *LB_-64
NTS: *ISH_B ; *STUH_B ; *ST_N
*FLT_0; *SLSD_A1; *RAD_A2; *RMY_TOS ; *RRSB_ARG; *RDV_PIBY4
*ST_REM; *LSS_N; *IAD_2; *AND_7; *ST_B
*AND_1; *JAF_4,<EL>; *LSD_REM; *J_<BTH>
EL: *LSD_1.0; *RSB_REM
BTH: *ST_R1; *RMY_R1; *ST_R2; *JAT_12,<SWAY>
*CPB_3; *JCC_8,<SWAY>; *CPB_4; *JCC_8,<SWAY>
*CPB_7; *JCC_7,<CWAY>
SWAY: *RMY_S6; *RAD_S5; *RMY_R2; *RAD_S4
*RMY_R2; *RAD_S3; *RMY_R2; *RAD_S2
*RMY_R2; *RAD_S1; *RMY_R2; *RAD_S0
*RMY_R1; *J_<BWAY>
CWAY: *RMY_C7; *RAD_C6; *RMY_R2; *RAD_C5
*RMY_R2; *RAD_C4; *RMY_R2; *RAD_C3
*RMY_R2; *RAD_C2; *RMY_R2; *RAD_C1
*RMY_R2; *RAD_C0
BWAY: *CPB_3; *JCC_2,<NRG>; *EXIT_-64
NRG: *RRSB_0; *EXIT_-64
END
SYSTEMLONGREALFN ITAN(LONGREAL ARG)
CONSTLONGREAL P0=0.108886004372816875@8
CONSTLONGREAL P1=-0.895888440067680411@6
CONSTLONGREAL P2=0.141898542527617784@5
CONSTLONGREAL P3=-0.456493194386656319@2
CONSTLONGREAL Q0=0.138637966635676292@8
CONSTLONGREAL Q1=-0.399130951803516515@7
CONSTLONGREAL Q2=0.135382712805119094@6
CONSTLONGREAL Q3=-0.101465619025288534@4
CONSTLONGREAL LEASTDIV=R'0210000000000000'
INTEGER SIGN, Q, QM
LONGREAL DIV, REM, RES, W2
SIGN=0
IF ARG<0 THEN SIGN=1 AND ARG=-ARG
IF ARG>MAX START
MLIBERR(56); ! ERROR(1, 14, 1, 0, 1, 0)
RES=1
FINISHELSESTART
DIV=ARG/PIBY4
Q=INTPT(DIV)
REM=(ARG-Q*A1-Q*A2)/PIBY4
IF Q&1#0 THEN REM=1.0-REM
W2=REM*REM
RES=(((P3*W2+P2)*W2+P1)*W2+P0)/((((W2+Q3)*W2+Q2)*W2+Q1)*W2+Q0)*REM
QM=Q&3
IF QM=1 OR QM=2 START
IF RES<=LEASTDIV START
! ERROR(1, 14, 2, 0, 1, 0)
RES=GREATEST
FINISHELSE RES=1.0/RES
FINISH
IF QM>1 START
IF SIGN=0 THEN RES=-RES
FINISHELSESTART
IF SIGN=1 THEN RES=-RES
FINISH
FINISH
RESULT =RES
END
SYSTEMLONGREALFN AARCTAN(LONGREAL X1)
INTEGER DUMMY
LONGREAL XX1, XSQ, CONSTANT
INTEGER SIGN, INV
! CONSTANT=0
! %IF X1<0 %THEN SIGN=1 %AND XX1=-X1 %ELSE SIGN=0 %AND XX1=X1
! %IF XX1>R'4110000000000000' %C
! %THEN XX1=1.0/XX1 %AND INV=1 %ELSE INV=0
! %IF XX1>TANPIBY12 %THEN XX1=(RT3M1*XX1-1.0+XX1)/(XX1+RT3) %AND %C
! CONSTANT=PIBY6
! XSQ=XX1*XX1
! XX1=XX1*(R1/(XSQ+S1+(R2/(XSQ+S2+(R3/(XSQ+S3+(R4/(XSQ+S4))))))) %C
! )+CONSTANT
! %IF INV=1 %THEN XX1=1.0-XX1+PIBY2M1
! %IF SIGN=1 %THEN XX1=-XX1
! %RESULT =XX1
*LSD_0; *ST_CONSTANT; *ST_SIGN
*LB_1; *LSD_X1; *JAF_6,<POS>
*STB_SIGN; *AND_X'7FFFFFFFFFFFFFFF'
POS: *RCP_R'4110000000000000'; *JCC_12,<NOTGZ>
*STB_INV; *RRDV_R'4110000000000000'
NOTGZ: *RCP_TANPIBY12; *JCC_12,<NTP>
*LD_PIBY6; *STD_CONSTANT; ! USE DR SO XX1 STAYS IN ACC
*ST_XX1; *RMY_RT3M1; *RSB_1.0; *RAD_XX1
*SLSD_XX1; *RAD_RT3; *RRDV_TOS
NTP: *ST_XX1; *RMY_XX1; *ST_XSQ
*RAD_S4; *RRDV_R4; *RAD_S3; *RAD_XSQ
*RRDV_R3; *RAD_S2; *RAD_XSQ
*RRDV_R2; *RAD_S1; *RAD_XSQ
*RRDV_R1; *RMY_XX1; *RAD_CONSTANT
*LB_INV; *JAT_12,<INVZ>; *RRSB_1.0; *RAD_PIBY2M1
INVZ: *LB_SIGN; *JAT_12,<SIGNZ>; *RRSB_0
SIGNZ: *EXIT_-64
END
SYSTEMLONGREALFN ILOG(LONGREAL IN)
INTEGER P, Q, SHORTF
LONGREAL PRESULT, INARG2
CONSTLONGREAL MIN=R'FFFFFFFFFFFFFFFF'
CONSTLONGREAL SQRTHALF=R'40B504F333F9DE65'
CONSTLONGREAL A1=0.594603557501360533
CONSTLONGREAL A2=0.840896415253714543
CONSTLONGREAL B1=R'40C0000000000000'
CONSTLONGREAL B2=R'4040000000000000'
CONSTLONGREAL LOGE2=R'40B17217F7D1CF7A'
CONSTLONGREAL R0=-0.184416657749370267@2
CONSTLONGREAL R1=-0.234508372303045254@2
CONSTLONGREAL R2=-0.244294581969260792
CONSTLONGREAL S0=-0.157942837832759265@2
CONSTLONGREAL S1=-0.374252034640387355@1
CONSTLONGREAL S2=-0.139586882716355509@1
IF IN<=0 START
IF IN<0 START
MLIBERR(51); ! ERROR(1, PROCNO, 1, 0, 1, 0)
IN=-IN
FINISHELSESTART
MLIBERR(52); ! ERROR(1, PROCNO, 2, 0, 1, 0)
RESULT =MIN
FINISH
FINISH
! P=BYTEINTEGER(ADDR(IN))-64
! BYTEINTEGER(ADDR(IN))=0
! SHORTF=INTEGER(ADDR(IN))
! %IF SHORTF>=X'00400000' %START
! %IF SHORTF>=X'00800000' %THEN Q=0 %ELSE Q=1
! %FINISHELSESTART
! %IF SHORTF>=X'00200000' %THEN Q=2 %ELSE Q=3
! %FINISH
*LSS_IN; *LUH_0
*USH_8; *ISB_X'4000000000'
*STUH_P; *USH_-8; *ST_IN
*USH_-21; *USH_2; *IRSB_0; *SLSS_X'00001123'
*USH_TOS ; *AND_15; *ST_Q
! INTEGER(ADDR(IN))=(INTEGER(ADDR(IN))<<Q)!(INTEGER(ADDR(IN)+4 %C
)>>(32-Q))
! INTEGER(ADDR(IN)+4)=INTEGER(ADDR(IN)+4)<<Q
! BYTEINTEGER(ADDR(IN))=X'40'
*LSD_IN; *USH_Q
*OR_X'4000000000000000'
*ST_IN
IF IN>0 AND IN<SQRTHALF START
IN=(IN-A1)/(IN+A1)
PRESULT=((4*P-Q)-B1)*LOGE2
FINISHELSESTART
IN=(IN-A2)/(IN+A2)
PRESULT=((4*P-Q)-B2)*LOGE2
FINISH
INARG2=IN*IN
RESULT =R0/(INARG2+S0+(R1/(INARG2+S1+(R2/(INARG2+S2)))) C
)*IN+PRESULT
END
SYSTEMLONGREALFN ISQRT(LONGREAL ARG)
CONSTINTEGERARRAY A(0:7)=C
X'2112E2AC',X'20D5AA18',X'20971564',X'206AD50C',
X'204B8AB2',X'20356A86',X'2025C559',X'201AB543'
LONGREAL X,Z
*LSD_ARG
*ASF_4
*ST_X
*JAF_5,<NOTPOS>
MAINPATH:*LSS_X
*USH_-1
*ROT_8
*ST_B
*USH_1
*SHZ_TOS
*USH_-12
*ST_TOS
*UAD_X'410B504F'
*RRDV_X'C1207B4E'
*LD_A
*JAT_14,<EXPODD>
*INCA_16
EXPODD:*RAD_X'41393FED'
*UAD_TOS
*RMYD_(DR +TOS )
*RSC_B
*ST_Z
*RRDV_X
*RAD_Z
*RMY_X'4080000000000000'
*ST_Z
*RRDV_X
*RSB_Z
*RMY_X'4080000000000000'
*RAD_Z
DONE:*EXIT_-64
NOTPOS:*JAT_4,<DONE>
MLIBERR(50)
ARG=-ARG
-> MAINPATH
END
SYSTEMLONGREALFN IEXP(LONGREAL INARG)
INTEGER DUMMY
LONGREAL W
LONGREAL Y,FY
CONSTLONGREAL LOG2E=R'41171547652B82FE'
INTEGER B, YINT, P, NEGQ
CONSTLONGREAL UE=R'C2B437DF00000000'
CONSTLONGREAL E=R'42AEAC4D00000000'
CONSTLONGREAL RMAX=R'7FFFFFFFFFFFFFFF'
CONSTLONGREAL C0=0.999999999999999993
CONSTLONGREAL C1=-0.693147180559934648
CONSTLONGREAL C2=0.240226506956369776
CONSTLONGREAL C3=-0.0555041084024485261;!@-1
CONSTLONGREAL C4=0.00961811709948153328;!@-2
CONSTLONGREAL C5=-0.00133307347698115810;!@-2
CONSTLONGREAL C6=0.000150737171272758723;!@-3
CONSTLONGREALARRAY EXP2(0:15)=1.0,
0.957603280698573647,
0.917004043204671232,
0.878126080186649742,
0.840896415253714543,
0.805245165974627154,
0.771105412703970412,
0.738413072969749656,
0.707106781186547524,
0.677127773468446364,
0.648419777325504833,
0.620928906036742024,
0.594603557501360533,
0.569394317378345827,
0.545253866332628830,
0.522136891213706920
IF INARG<=UE THEN RESULT =0
IF INARG>=E THEN MLIBERR(53) AND RESULT =RMAX;! ERROR(1,98,1,0,1,0)
! Y=INARG*R'41171547652B82FE001777D0FFDA0D24'
! %IF INARG>0 %START
! YINT=INTPT(Y)+1
! Y=YINT-Y
! %UNLESS Y<1.0 %START
! YINT=YINT-1
! Y=0
! %FINISH
! %IF YINT&3=0 %THEN P=YINT>>2 %AND NEGQ=0 %ELSE %C
! P=YINT>>2+1 %AND NEGQ=-(P<<2)+YINT
! %FINISHELSESTART
! %IF INARG<0 %THEN YINT=-INTPT(-Y) %ELSE YINT=INTPT(Y)
! Y=YINT-Y
! B=-YINT
! P=-(B>>2)
! %IF B&3=0 %THEN NEGQ=0 %ELSE NEGQ=(-P<<2)-B
! %FINISH
*LSD_INARG; *RMY_LOG2E; *ST_Y
*RAD_R'4F00000000000000'; *ST_FY
*FIX_B ; *MYB_4; *ISH_B ; *STUH_B ; *ST_B
*LSD_INARG; *JAF_1,<ZORNEG>
*ADB_1; *STB_YINT; *LSS_B
*FLT_0; *RSB_Y; *ST_Y
*RCP_1.0; *JCC_4,<L1>
*LSS_YINT; *ISB_1; *ST_YINT; *LSD_0; *ST_Y
L1: *LSS_YINT; *AND_3; *JAF_4,<L2>
*ST_NEGQ; *LSS_YINT; *USH_-2; *ST_P
*J_<BOTH>
L2: *LSS_YINT; *USH_-2; *IAD_1; *ST_P
*USH_2; *IRSB_YINT; *ST_NEGQ; *J_<BOTH>
ZORNEG: *STB_YINT; *LSD_FY;
*RSB_Y; *ST_Y
*LSS_YINT; *IRSB_0; *ST_B
*USH_-2; *IRSB_0; *ST_P
*LSS_B; *AND_3; *JAT_4,<L3>
*LSS_P; *USH_2; *IRSB_0; *ISB_B
L3: *ST_NEGQ
BOTH:
! W=Y
! %IF W<R'4010000000000000' %THEN B=0 %ELSESTART
! LONGINTEGER(ADDR(W))=LONGINTEGER(ADDR(W))<<4
! B=INTEGER(ADDR(W))>>24
! BYTEINTEGER(ADDR(W))=X'3F'
! INTEGER(ADDR(W)+4)=INTEGER(ADDR(W)+4) %C
! !(INTEGER(ADDR(Y)+8)>>20)&15
! %FINISH
*LSD_Y; *ST_W; *LB_0
*RCP_R'4010000000000000'; *JCC_4,<EVAL>
*USH_4;
*OR_8; *ST_W; *USH_-24; *STUH_B
*LUH_X'3F'; *USH_24; *STUH_W
EVAL:
! W=((((((C6*W+C5)*W+C4)*W+C3)*W+C2)*W+C1)*W+C0)*EXP2(B)
*LSD_C6; *RMY_W; *RAD_C5; *RMY_W
*RAD_C4; *RMY_W; *RAD_C3; *RMY_W
*RAD_C2; *RMY_W; *RAD_C1; *RMY_W
*RAD_C0; *RMY_(EXP2+B ); *ST_W
! %IF BYTEINTEGER(ADDR(W))=X'41' %START
! %IF NEGQ#0 %THEN NEGQ=NEGQ+4 %ELSE P=P+1 %AND ->NOSHIFT
! %FINISH
! LONGINTEGER(ADDR(W))=LONGINTEGER(ADDR(W))<<NEGQ
*LSS_W; *USH_-24; *ICP_X'41'; *JCC_7,<SHIFT>
*LB_NEGQ; *JAT_12,<NEGZ>
*ADB_4; *STB_NEGQ; *J_<SHIFT>
NEGZ: *LB_P; *ADB_1; *LSD_W; *J_<NOSHIFT>
SHIFT: *LSD_W; *USH_NEGQ; *LB_P
NOSHIFT:
! BYTEINTEGER(ADDR(W))=P+64
! %RESULT =W
*ADB_64
*AND_X'00FFFFFFFFFFFFFF'; *RSC_B
*EXIT_-64
END
OWNSTRING (2) ARRAY REP(1:15)="1", "2", "3", "4", "5", "6", "7",
"8", "9", "10", "11", "12", "13", "14", "15"
SYSTEMROUTINE ININTEGER(INTEGER CH, INTEGERNAME VAL)
LONGREAL X
IF CH#COMREG(22) THEN SELECT INPUT(CH)
READ(X)
SKIP SYMBOL
VAL=INT(X)
END
SYSTEMROUTINE INREAL(INTEGER CH, LONGREALNAME VAL)
LONGREAL X
IF CH#COMREG(22) THEN SELECT INPUT(CH)
READ(X)
SKIP SYMBOL
VAL=X
END
SYSTEMROUTINE OUTINTEGER(INTEGER CH, VALUE)
IF CH#COMREG(23) THEN SELECT OUTPUT(CH)
WRITE(VALUE, 1)
PRINTSTRING(';
')
END
SYSTEMROUTINE OUTREAL(INTEGER CH, LONGREAL VALUE)
IF CH#COMREG(23) THEN SELECT OUTPUT(CH)
PRINTFL(VALUE, 15)
PRINTSTRING(';
')
END
SYSTEMROUTINE OUTTERMINATOR(INTEGER CH)
IF CH#COMREG(23) THEN SELECT OUTPUT(CH)
PRINTSTRING(';
')
END
SYSTEMLONGREALFN ABS(LONGREAL VALUE)
RESULT =MOD(VALUE)
END
SYSTEMINTEGERFN IABS(INTEGER VALUE)
RESULT =IMOD(VALUE)
END
SYSTEMINTEGERFN SIGN(LONGREAL VALUE)
IF VALUE>0 THENRESULT =1
IF VALUE<0 THENRESULT =-1
RESULT =0
END
SYSTEMLONGREALFN MAXREAL
RESULT =GREATEST
END
SYSTEMLONGREALFN MINREAL
RESULT =R'0010000000000000'
END
SYSTEMINTEGERFN MAXINT
RESULT =X'7FFFFFFF'
END
SYSTEMLONGREALFN EPSILON
RESULT =R'3410000000000000'
END
SYSTEMLONGREALFN ALREAD
LONGREAL X
READ(X)
SKIP SYMBOL
RESULT =X
END
SYSTEMINTEGERFN ANXTSY
RESULT =NEXT SYMBOL
END
SYSTEMROUTINE APRSYM(INTEGER SYM)
PRINTSYMBOL(SYM)
END
SYSTEMROUTINE ARDSYM(INTEGERNAME SYM)
INTEGER S
READSYMBOL(S)
*LSS_S; *LD_SYM; *ST_(DR );
END
SYSTEMROUTINE ALGPTH
NEWPAGE
END
SYSTEMROUTINE PRSTNG(STRINGNAME S)
STRING (255)P, Q
P=S
WHILE P->P.("_").Q THEN P=P." ".Q
WHILE P->P.("¬").Q THEN P=P."
".Q
PRINTSTRING(P)
END
SYSTEMROUTINE ASELIN(INTEGER CH)
SELECT INPUT(CH)
END
SYSTEMROUTINE ASELOU(INTEGER CH)
SELECT OUTPUT(CH)
END
SYSTEMROUTINE ALGNWL
NEWLINE
END
SYSTEMROUTINE ALGSPC
SPACE
END
SYSTEMROUTINE ALGNLS(INTEGER N)
NEWLINES(N)
END
SYSTEMROUTINE ALGSPS(INTEGER N)
SPACES(N)
END
SYSTEMINTEGERFN LENGTH(STRINGNAME S)
RESULT = INTEGER(ADDR(S))>>24
END
SYSTEMROUTINE INSYMBOL(INTEGER CH, STRINGNAME S, INTEGERNAME CHAR)
STRING (1)ITEM
STRING (65)S1, S2
INTEGER I
IF CH#COMREG(22) THEN SELECT INPUT(CH)
READ ITEM(ITEM)
IF S->S1.(ITEM).S2 THEN CHAR=LENGTH(S1)+1 ANDRETURN
I=CHARNO(ITEM, 1)
IF (' '<=I<='Z' AND I#34) OR I=92 OR I=95 OR I=126 OR C
I=10 THEN CHAR=-I ELSE CHAR=0
END
SYSTEMROUTINE OUTSYMBOL(INTEGER CH, STRINGNAME S, INTEGER CHAR)
IF CH#COMREG(23) THEN SELECT OUTPUT(CH)
IF 1<=CHAR<=LENGTH(S) THEN PRINTSYMBOL(CHARNO(S, CHAR)) C
ELSE PRINTSYMBOL(-CHAR)
END
SYSTEMINTEGERFN AICODE(STRINGNAME S)
INTEGER I
I=CHARNO(S, 1)
IF I='_' THEN I=' '
IF I='¬' OR S='EL' THEN I=NL
IF S='SS' THEN I='%'
RESULT =I
END
SYSTEMROUTINE OUTSTRING(INTEGER CH, STRINGNAME S)
IF CH#COMREG(23) THEN SELECT OUTPUT(CH)
PRSTNG(S)
END
SYSTEMROUTINE WRITE TEXT(STRINGNAME TEXT)
SYSTEMROUTINESPEC PRSTNG(STRINGNAME S)
INTEGER I, R, SUCCESS
BYTEINTEGERARRAY SA(0:255)
STRING (255)S, S1, S3
STRING (3)QU
STRINGNAME S2
STRING (1)BR1, BR2
BR1="<"
BR2=">"
SUCCESS=0
START:
S=TEXT
SA(0)=0
S2==STRING(ADDR(SA(0)))
WHILE S->S1.("%").S3 THEN S=S1."_".S3; ! CHANGE '%' TO '_'(TEMP)
NEXT:
IF S->S1.(BR1).S2.(BR2).S3 START
SUCCESS=1
PRSTNG(S1)
S=S3
R=0
CYCLE I=1, 1, SA(0)
IF SA(I)='S' START
IF R=0 THEN SPACE ELSE SPACES(R)
R=0
->REP
FINISH
IF SA(I)='C' START
IF R=0 THEN NEWLINE ELSE NEWLINES(R)
R=0
->REP
FINISH
IF SA(I)='Q' OR SA(I)='U' START
IF SA(I)='Q' THEN QU='''(''' ELSE QU=''')'''
IF R=0 THEN R=1
UNTIL R=0 CYCLE
R=R-1
PRSTNG(QU)
REPEAT
->REP
FINISH
IF SA(I)='P' THEN NEWPAGE AND ->REP
R=R*10+(SA(I)-'0')
REP:
REPEAT
->NEXT
FINISH
IF SUCCESS=1 THEN PRSTNG(S) ELSESTART
BR1=TOSTRING('['+32)
BR2=TOSTRING(']'+32)
SUCCESS=1
->START
FINISH
END
OWNINTEGER LEVEL=0
SYSTEMLONGREALFN READ1900
!**************************************************************
!*********
!* 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
! FLAG= 0FOR'-',1 FOR '+'
LONGREAL RWORK, SCALE
FLAG=1; TYPE=0
LEVEL=LEVEL+1
START:CURSYM=NEXT; ! CARE NOT TO READ TERMINATOR
! NOW IGNORE LEADING SPACES
UNLESS LEVEL>1 START
CYCLE
EXITIF '0'<=CURSYM<='9' OR CURSYM='+' OR CURSYM='-' OR C
CURSYM='.' OR CURSYM='@' OR CURSYM='&' OR CURSYM=''''
CURSYM=NEXT
REPEAT
FINISH ELSE START
CURSYM = NEXT WHILE CURSYM = NL OR CURSYM = ' '
FINISH
! 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 LEVEL>1 THEN ->RETEXP
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
IVALUE=INT(READ1900); ! CALL TO FIND EXPONENT
IF IVALUE = -99 THEN RWORK = 0 ELSE C
RWORK=RWORK*10**IVALUE
TYPE=1
FINISH
IF TYPE=0 THEN ->START
RETEXP:
IF FLAG=0 THEN RWORK=-RWORK
LEVEL=LEVEL-1
RESULT =RWORK
INTEGERFN NEXT
INTEGER S
READ SYMBOL(S)
IF S=' ' THEN READ SYMBOL(S)
RESULT =S
END
INTEGERFN CHECKEXP
INTEGER S
RESULT =1 IF CURSYM='@' OR CURSYM='&' OR CURSYM='E'
RESULT =0 UNLESS CURSYM='''' AND NEXTSYMBOL='1'
SKIP SYMBOL; READ SYMBOL(S)
RESULT =0 UNLESS S='0' AND NEXT SYMBOL=''''
SKIP SYMBOL
RESULT =1
END
END
SYSTEMROUTINE PRINT1900(LONGREAL X, INTEGER M, N)
PRINT(X, M, N); SPACES(2)
END
SYSTEMROUTINE OUTPUT(LONGREAL X)
PRINT(X, 0, 10)
PRINTSYMBOL(';')
NEWLINE
END
SYSTEMINTEGERFN READ BOOLEAN
BYTEINTEGERARRAY TORF(0:6)
STRINGNAME S
INTEGER I
S==STRING(ADDR(TORF(0)))
FINDQ:
READSYMBOL(I) UNTIL I=''''
FOUNDQ:
CYCLE I=1, 1, 6
READSYMBOL(TORF(I))
->OUT IF TORF(I)=''''
REPEAT
OUT:
TORF(0)=I
RESULT =-1 IF S='TRUE'''
RESULT =0 IF S='FALSE'''
IF TORF(I)='''' THEN ->FOUNDQ ELSE ->FINDQ
END
SYSTEMROUTINE WRITE BOOLEAN(INTEGER B)
IF B#0 THEN PRINTSTRING('''TRUE'' ') ELSE PRINTSTRING('' C
'FALSE'' ')
END
SYSTEMROUTINE COPYTEXT(STRINGNAME TEXT)
INTEGER I, J, K, L
L=LENGTH(TEXT)
BEGIN
BYTEINTEGERARRAY T(1:L*2), T1(0:L)
STRINGNAME S
S==STRING(ADDR(T1(0)))
S=TEXT
CYCLE I=1, 2, L*2-1
T(I)=I+2
READSYMBOL(T(I+1))
REPEAT
T(I)=1
I=1
J=1
NEXT:
CYCLE K=1, 1, L
IF T1(K)#T(I+1) THEN ->OUT
I=T(I)
REPEAT
->RET
OUT:
I=T(J)
PRINTSYMBOL(T(J+1))
READSYMBOL(T(J+1))
J=I
->NEXT
RET:
END
RETURN
END
SYSTEMINTEGERFN ALRDCH
INTEGER CH
READCH(CH)
RESULT =CH
END
SYSTEMINTEGERFN ALNXCH
SYSTEMINTEGERFNSPEC IOCP(INTEGER A, B)
RESULT =IOCP(18, 0)
END
SYSTEMROUTINE ALPRCH(INTEGER CH)
PRINTCH(CH)
END
SYSTEMROUTINE ALSKCH
INTEGER CH
READCH(CH)
END
SYSTEMROUTINE ALGMON
MONITOR
END
SYSTEMROUTINE CLOSE STREAM(INTEGER STREAM)
IF STREAM > 98 OR STREAM < 1 OR COMREG(22) = STREAM C
OR COMREG(23) = STREAM THEN SSERR(29)
IOCP(16,STREAM)
END
SYSTEMINTEGERFNSPEC FORTRANDF(INTEGER DSNUM, NUMBLOCKS, BLKSIZE, C
ASVARD)
SYSTEMINTEGERFNSPEC OUTREC(INTEGER LENGTH)
SYSTEMINTEGERFNSPEC INREC
SYSTEMINTEGERFNSPEC NEW FILE OP(INTEGER DSNUM, ACTION, TYPE, C
INTEGERNAME AFD)
RECORDFORMAT NRFDFMT(INTEGER LINK, DSNUM, BYTEINTEGER STATUS, C
ACCESS ROUTE, VALID ACTION, CUR STATE, BYTEINTEGER MODE OF USE, C
MODE, FILE ORG, DEV CLASS, BYTEINTEGER REC TYPE, FLAGS, LM, RM, C
INTEGER ASVAR, AREC, RECSIZE, MINREC, MAXREC, MAXSIZE, ROUTECCY, C
INTEGER C0, C1, C2, C3, TRANSFERS, DARECNUM, SPARE1, SPARE2, C
STRING (31)IDEN)
CONSTINTEGERARRAY BYTES(3:7)=1, 2, 4, 8, 16
!
!
!*
ROUTINE MOVE(INTEGER LENGTH, FROM, TO)
INTEGER I
RETURNIF LENGTH <= 0
I = X'18000000'!LENGTH
*LSS_FROM
*LUH_I
*LDTB_I
*LDA_TO
*MV_L =DR
END ; !OF MOVE
!*
ROUTINE FILL(INTEGER LENGTH, FROM,FILLER)
INTEGER I
RETURNIF LENGTH <= 0
I = X'18000000'!LENGTH
*LDTB_I
*LDA_FROM
*LB_FILLER
*MVL_L =DR
END
!*
SYSTEMROUTINE GETSQ(INTEGER CHAN, DESC1,DESC2,DESC3,DESC4)
RECORDNAME SQFD(NRFDFMT)
INTEGER START, SIZE, AFD, FLAG, LENGTH
SSERR(164) UNLESS 1<=CHAN<=99; ! INVALID DATA SET NUMBER
FLAG=NEW FILE OP(CHAN, 1, 2, AFD)
! OPEN FILE
SSERR(FLAG) IF FLAG>0; ! INVALID OPERATION ON FILE
SQFD==RECORD(AFD)
SSERR(178) IF SQFD_STATUS<2
SIZE=(DESC1&X'38000000')>>27
START=DESC2
LENGTH = BYTES(SIZE) * (DESC1 & X'FFFFFF')
IF LENGTH<=0 THEN SSERR(177); ! ADDRESS INSIDE OUT
FLAG=INREC; ! READ RECORD INTO BUFFER
IF FLAG>0 THEN SSERR(153); ! INPUT FILE ENDED
IF SQFD_RECSIZE<LENGTH START
MOVE(SQFD_RECSIZE, SQFD_AREC, START)
FILL(LENGTH-SQFD_RECSIZE, START+SQFD_RECSIZE, 0)
LENGTH=SQFD_RECSIZE
FINISHELSE MOVE(LENGTH, SQFD_AREC, START)
RETURN
END
!
!
SYSTEMROUTINE PUTSQ(INTEGER CHAN,DESC1,DESC2,DESC3,DESC4)
RECORDNAME SQFD(NRFDFMT)
INTEGER START, SIZE, AFD, FLAG, LENGTH
SSERR(164) UNLESS 1<=CHAN<=99; ! INVALID DATA SET NUMBER
FLAG=NEW FILE OP(CHAN, 2, 2, AFD)
! OPEN FILE
SSERR(FLAG) UNLESS FLAG <= 0
SIZE=(DESC1&X'38000000')>>27
START=DESC2
LENGTH = BYTES(SIZE) * (DESC1 & X'FFFFFF')
IF LENGTH<=0 THEN SSERR(177); ! ADDRESS INSIDE OUT
SQFD==RECORD(AFD)
UNLESS SQFD_MINREC<=LENGTH<=SQFD_MAXREC THEN SSERR(161)
!INVALID RECORD SIZE
MOVE(LENGTH, START, SQFD_AREC)
FLAG=OUTREC(LENGTH); ! OUTPUT RECORD
SSERR(FLAG) UNLESS FLAG<=0; ! INVALID OPERATION ON FILE
RETURN
END
!
!
SYSTEMROUTINE GETDA(INTEGER CHAN, INTEGERNAME SECT, INTEGER C
DESC1,DESC2, DESC3,DESC4)
OWNINTEGER FSECT
LONGINTEGER ADFSECT
RECORDNAME DAFD(NRFDFMT)
INTEGER START, FINISH, AFD, FLAG, SIZE, LEN
SSERR(164) UNLESS 1<=CHAN<=99; ! INVALID FILE NUMBER
FLAG=NEW FILE OP(CHAN, 1, 3, AFD)
SSERR(FLAG) IF FLAG>0
DAFD==RECORD(AFD)
SSERR(178) UNLESS DAFD_STATUS>=2
SIZE=(DESC1&X'38000000')>>27
START=DESC2
FINISH = BYTES(SIZE) * (DESC1 & X'FFFFFF') + START
IF FINISH<=START THEN SSERR(177)
FSECT=SECT
ADFSECT = ADDR(FSECT)
FLAG=FORTRANDF(CHAN, -1, DAFD_RECSIZE, ADDR(ADFSECT))
SSERR(FLAG) IF FLAG>0
LEN = DAFD_RECSIZE
WHILE START<FINISH THENCYCLE
IF START + LEN > FINISH THEN LEN = FINISH - START
DAFD_DARECNUM = FSECT
FLAG = INREC
SSERR(FLAG) IF FLAG>0
MOVE (LEN , DAFD_AREC , START)
START=START+LEN
REPEAT
SECT=FSECT
END
!
!
SYSTEMROUTINE PUTDA(INTEGER CHAN, INTEGERNAME SECT, INTEGER C
DESC1,DESC2, DESC3,DESC4)
OWNINTEGER FSECT
LONGINTEGER ADFSECT
RECORDNAME DAFD(NRFDFMT)
INTEGER START, FINISH, AFD, FLAG, SIZE
SSERR(164) UNLESS 1<=CHAN<=99; ! INVALID FILE NUMBER
FLAG=NEW FILE OP(CHAN, 2, 3, AFD)
SSERR(FLAG) IF FLAG>0
DAFD==RECORD(AFD)
SSERR(178) UNLESS DAFD_STATUS>=2
SIZE=(DESC1&X'38000000')>>27
START=DESC2
FINISH = BYTES(SIZE) * (DESC1 & X'FFFFFF') + START
IF FINISH<=START THEN SSERR(177)
FSECT=SECT
ADFSECT = ADDR(FSECT)
FLAG=FORTRANDF(CHAN, -1, DAFD_RECSIZE, ADDR(ADFSECT))
SSERR(FLAG) IF FLAG>0
WHILE START<FINISH THENCYCLE
DAFD_DARECNUM = FSECT
MOVE (DAFD_RECSIZE , START , DAFD_AREC)
FLAG = OUTREC (DAFD_RECSIZE)
SSERR(FLAG) IF FLAG>0
START=START+DAFD_RECSIZE
REPEAT
SECT=FSECT
END
!
!
SYSTEMROUTINE RWNDSQ (INTEGER CHAN)
INTEGER I , AFD
SSERR(164) UNLESS 1 <= CHAN <= 99 ; ! INVALID DATA SET NUM
I = NEWFILEOP (CHAN, 4, 0, AFD)
IF I > 0 THEN SSERR(I)
END
!
!
SYSTEMROUTINE AFAULT(STRINGNAME MESSAGE,LONGREAL VALUE)
!*
!*THIS ENABLES AN ALGOL PROGRAM TO TERMINATE WITH A MESSAGE
!* AND DIAGNOSIS AS PER ALGOL 60M REPORT
!*
SELECT OUTPUT(107)
PRINTSTRING('ALGOL FAULT '.MESSAGE.'
PARAMETER = ')
PRINTFL(VALUE,15)
NEWLINE
MONITOR
STOP
END
!
!
ENDOFFILE