Google
 

Trailing-Edge - PDP-10 Archives - ap-5069b-sb - 10,6/alglib.mac
There are 11 other files named alglib.mac in the archive. Click here to see a list.
;
;
;
;
;
;
;	COPYRIGHT (C) 1975,1976,1977
;	DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS.
;
;
;	THIS SOFTWARE IS FURNISHED UNDER A LICENSE FOR USE ONLY ON A
;	SINGLE COMPUTER SYSTEM AND MAY BE COPIED ONLY WITH THE INCLUSION
;	OF THE ABOVE COPYRIGHT NOTICE.  THIS SOFTWARE, OR ANY OTHER
;	COPIES THEREOF, MAY NOT BE PROVIDED OR OTHERWISE MADE AVAILABLE
;	TO ANY OTHER PERSON EXCEPT FOR USE ON SUCH SYSTEM AND TO ONE WHO
;	AGREES TO THESE LICENSE TERMS.  TITLE TO AND OWNERSHIP OF THE
;	SOFTWARE SHALL AT ALL TIMES REMAIN IN DEC.
;
;	THE INFORMATION IN THIS SOFTWARE IS SUBJECT TO CHANGE WITHOUT
;	NOTICE AND SHOULD NOT BE CONSTRUED AS A COMMITMENT BY DIGITAL
;	EQUIPMENT CORPORATION.
;
;	DEC ASSUMES NO RESPONSIBILITY FOR THE USE OR RELIABILITY OF ITS
;	SOFTWARE ON EQUIPMENT WHICH IS NOT SUPPLIED BY DEC.
;
; SUBTTL GLOBAL DECLARATIONS

; COPYRIGHT 1971,1972,1973,1974 DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS.

	SEARCH ALGPRM,ALGSYS		; SEARCH PARAMETER FILES

	SALL

%TITLE(ALGLIB,ALGOL LIBRARY)

	IF2, <
	IFE PROC-KA10, <PRINTX KA10 VERSION>
	IFE PROC-KI10, <PRINTX KI10 VERSION>>

	EXTERNAL %ENTRY,%ALGDR

	ENTRY %ALGDA

%ALGDA:

	LIT
	PRGEND
SUBTTL SHARABLE ALGOTS ENTRY

	ENTRY %SHARE

	INTERNAL %ENTRY,%ALGDR,%START,%REN

	EXTERNAL %BEGIN,%OWN,%HEAP,%ALGDA,%JBVER,%JBEDT,%FLAGS,%TRACE

	SEARCH ALGPRM,ALGSYS	; SEARCH PARAMETER FILES

	SALL

%TITLE(ALGOBJ,ALGOL LIBRARY)

	INTERNAL .JBREN,.JBOPS,.JBHDA

	%ENTRY=0

	%SHARE=0

	%ALGDR=400000+.JBHDA

	LOC	.JBREN
	XWD	0,%REN		; INITIAL REENTER
	RELOC

%START:	TDZA	AX,AX		; START ENTRY POINT
%REN:	HRLZI	AX,REEN		; REENTER ENTRY POINT
	MOVEM	AX,.JBOPS	; SAVE START/REENTER FLAG DURING GETSEG
	MOVEM	A7,IFDAT	; SAVE LOAD-FILE INFO FOR OVRLAY
	MOVEM	A0,IFDAT+1
	MOVEM	A11,IFDAT+2
PATCH (31)	; OVERLAY HANDLER

PATCH (21)	; REMOVE PRESET OTS NAME
	HRLZI	A1,%JBEDT
	LSH	A1,^D9
	MOVEI	A2,3
	HRLZI	A5,(SIXBIT/ALG/)
	MOVE	A3,[
	POINT	6,A5,17]
	MOVE	A4,[
	POINT	7,SEGMES+6,6]

GET2:	SETZ	A0,
	LSHC	A0,3
	ADDI	A0,20		; TO SIXBIT
	IDPB	A0,A3
	ADDI	A0,40		; TO ASCII
	IDPB	A0,A4		; TO ERROR-MESSAGE
	SOJG	A2,GET2
	MOVEM	A5,HSEG+1
	MOVEM	A5,HSEG1+1

GETSYS:	MOVEI	A0,HSEG
	GETSEG	A0,		; TRY TO GET SHARABLE ALGOTS
	JRST	NOSYS		; NOT FOUND

GET1:	MOVE	AX,.JBOPS	; RESTORE START/REENTER FLAG
	HRRI	AX,OBJDAT
	JRST	INITIA		; ENTER TO INITIALIZE

NOSYS:	MOVEI	A0,HSEG1
	GETSEG	A0,		; TRY ON DSK INSTEAD
	JRST	NOSEG		; NOT THERE EITHER
	JRST	GET1		; FOUND ON DSK
NOSEG:	TTCALL	3,SEGMES	; COMPLAIN ON TTY
	EXIT	1,		; AND RETIRE
	JRST	GETSYS		; TRY AGAIN IF CONTINUE

HSEG:	SIXBIT /SYS/
	0	0
	0
	0
	0

HSEG1:	SIXBIT /DSK/
	0	0
	0
	0
	0

OBJDAT:	XWD	0,%BEGIN	; DATA-BLOCK FOR OTS
	XWD	0,%ALGDA
	XWD	0,%OWN
	XWD	%FLAGS,%HEAP
PATCH (2)	; RE-IMPLEMENT /HEAP SWITCH
	XWD	%JBVER,%JBEDT
IFDAT:	BLOCK	3		; INITIAL-FILE DATA FOR OVRLAY
PATCH (31)	; OVERLAY-HANDLER
	XWD	0,%TRACE	; [P37] TRACE BUFFER-LENGTH
PATCH (37)	; TRACE

SEGMES:	ASCIZ /
?ALGOL object time system ALGNNN.SHR not found
/

	ENTRY	FUNCT.

FUNCT.:	JRST	FUNCT	; OVERLAY-HANDLER SUB-ROUTINE ENTRY
PATCH (31)	; OVERLAY HANDLER

	LIT
	PRGEND	%START		; ENTRY POINT
SUBTTL NON-SHARABLE ALGOTS ENTRY

	ENTRY	%ENTRY

	INTERNAL %START,%REN

	EXTERNAL %BEGIN,%ALGDR,%OWN,%HEAP,%ALGDA,%JBVER,%JBEDT,%FLAGS,%TRACE

	SEARCH ALGPRM,ALGSYS	; SEARCH PARAMETER FILES

	SALL

%TITLE(ALGOBJ,ALGOL LIBRARY)

	INTERNAL .JBREN

	%ENTRY=0

	LOC	.JBREN
	XWD	0,%REN		; INITIAL RENTER
	RELOC

%START:	TDZA	AX,AX		; START ENTRY POINT
%REN:	HRLZI	AX,REEN		; REENTER ENTRY POINT
	HRRI	AX,[
	XWD	0,%BEGIN
	XWD	0,%ALGDA
	XWD	0,%OWN
	XWD	%FLAGS,%HEAP
	XWD	%JBVER,%JBEDT
	EXP	0,0,0
	XWD	0,%TRACE]	; [P37]
PATCH (37)	; TRACE
PATCH (2)	; RE-IMPLEMENT /HEAP (SET HEAP SIZE) SWITCH
	JRST	INITIA		; ENTER TO INITIALIZE

	ENTRY	FUNCT.		; DUMMY OVERLAY-HANDLER ENTRY-POINT

FUNCT.:	TTCALL	3,[ASCIZ/?ALGNSO Sharable programs may not be overlaid.
/]
	EXIT			; FATAL. ONE DAY GO TO DEBUGGER.
PATCH (31)	; OVERLAYS

	LIT
	PRGEND	%START		; ENTRY POINT
TITLE POWER1/POWER2 - INTEGER/REAL TO INTEGER EXPONENTIATION ROUTINE


; POWER1:

; ON ENTRY:
; THE BASE AND EXPONENT ARE ON THE STACK
; A1=0 IF RESULT MUST BE INTEGRAL (COMPILER SAYS SO)
; A1=1 IF RESULT IS TO BE REAL
; THE LINK IS IN AX
; ON EXIT, THE RESULT IS IN A0

; POWER2:

; ON ENTRY:
; THE BASE AND EXPONENT ARE ON THE STACK
; THE LINK IS IN AX
; ON EXIT, THE RESULT IS IN A0
	SEARCH	ALGPRM,ALGSYS

	%ENTER<1,2>

	SALL

	%SUBTTL(ALGLIB,ALGOL LIBRARY)

	MLON

LABEL(2):	MOVEI	A1,2

LABEL(1):	POP	SP,A2		; RECOVER EXPONENT
	POP	SP,A0		; RECOVER BASE
	JUMPN	A2,POW101	; EXPONENT = 0?
EDIT(704); 0^0 is undefined, so generate error message
	JUMPE	A0,POW110	; [E704] ERROR IF BASE = 0
	XCT	[
	MOVEI	A0,1
	MOVSI	A0,(1.0)
	MOVSI	A0,(1.0)](A1)	; YES - I^0 IS 1 OR 1.0
	JRST	(AX)

POW101:	JUMPN	A1,POW103	; POWER1?
	JUMPE	A0,(AX)		; YES - QUICK EXIT FOR ZERO BASE
	MOVE	A1,A0		; NO - COPY BASE
	MOVEI	A0,1		; AND PREPARE FOR MULTIPLICATION

POW102:	TRZE	A2,000001	; BIT SET IN EXPONENT?
	IMUL	A0,A1		; YES - MULTIPLY
	JOV	POW109		; CHECK OVERFLOW
	JUMPE	A2,(AX)		; EXIT IF FINISHED
	IMUL	A1,A1		; OTHERWISE SQUARE MULTIPLIER
	JOV	POW109		; CHECK OVERFLOW
	LSH	A2,-1		; SHIFT ROUND EXPONENT
	JRST	POW102		; AND CARRY ON
POW103:	JUMPE	A0,POW107	; POWER2 - BASE = 0?
	SOJN	A1,POW104	; NO - BASE IN REAL MODE?
	IFE PROC-KA10, <
	IDIVI	A0,400000
	JUMPE	A0,.+2
	TLC	A0,254000
	TLC	A1,233000
	FADR	A0,A1>
	IFE PROC-KI10, <
	FLTR	A0,A0>		; NO - CONVERT TO REAL

POW104:	MOVE	A1,A0		; TRANSFER BASE TO A1
	JUMPG	A2,POW105	; EXPONENT POSITIVE?
	MOVN	A2,A2		; NO - NEGATE IT
	JOV	POW109		; CHECK OVERFLOW
	TDZA	A3,A3		; AND CLEAR POSITIVE FLAG

POW105:	MOVEI	A3,1		; SET POSITIVE FLAG
	MOVSI	A0,(1.0)	; PREPARE FOR MULTIPLICATION/DIVISION

POW106:	TRZN	A2,000001	; BIT SET IN EXPONENT?
	JRST	.+3		; NO
	XCT	[
	FDVR	A0,A1
	FMPR	A0,A1](A3)	; YES - MULTIPLY/DIVIDE
	JFOV	POW108		; CHECK OVERFLOW
	JUMPE	A2,(AX)		; EXIT IF FINISHED
	FMPR	A1,A1		; OTHERWISE SQUARE MULTIPLIER
	JFOV	POW108		; CHECK OVERFLOW
	LSH	A2,-1		; SHIFT AROUND EXPONENT
	JRST	POW106		; AND CARRY ON

POW107:	JUMPG	A2,(AX)		; BASE = 0 - EXIT IF EXPONENT > 0

POW108:	SYSER2	2,(AX)		; OTHERWISE GIVE OVERFLOW

POW109:	SYSER2	3,(AX)		; FIXED POINT OVERFLOW

POW110:	LIBERR	1,(AX)		; [E704] BASE & EXPONENT BOTH ZERO

	LIT
	PRGEND
TITLE POWER3 - LONG REAL TO INTEGER EXPONENTIATION ROUTINE

; ON ENTRY:
; THE BASE AND EXPONENT ARE ON THE STACK
; THE LINK IS IN AX
; ON EXIT, THE RESULT (TYPE LONG REAL) IS IN A0,A1
	SEARCH	ALGPRM,ALGSYS

	%ENTER<3>

	SALL

	%SUBTTL(ALGLIB,ALGOL LIBRARY)

	IFE PROC-KA10, <
	EXTLAB<21,22,27>>

LABEL(3):	POP	SP,A7		; RECOVER EXPONENT
	POP	SP,A4
	EXCH	AX,(SP)		; RECOVER BASE
	MOVE	A3,AX		; AND SAVE LINK
	JUMPN	A7,POW302	; EXPONENT = 0?
EDIT(704); 0^0 is undefined, so generate error message
	JUMPE	A3,POW308	; [E704] ERROR IF BASE = 0.0&&0
	MOVSI	A0,(1.0)
	MOVEI	A1,0		; YES - L^0 IS ALWAYS 1.0&&0

POW301:	POPJ	SP,0

POW302:	JUMPE	A3,POW305	; BASE = 0?
	JUMPGE	A7,POW303	; NO - EXPONENT POSITIVE?
	MOVN	A7,A7		; NO - NEGATE IT
	JOV	POW307		; CHECK OVERFLOW
	TDZA	A10,A10		; AND CLEAR POSITIVE FLAG

POW303:	MOVEI	A10,1		; SET POSITIVE FLAG
	MOVSI	A0,(1.0)
	MOVEI	A1,0		; PREPARE FOR MULTIPLICATION/DIVISION
POW304:	TRZN	A7,000001	; BIT SET IN EXPONENT?
	JRST	.+3		; NO
	IFE PROC-KA10, <
	MOVEI	AX,A3
	PUSHJ	SP,@[
	XWD	0,LABEL(22)
	XWD	0,LABEL(21)](A10)>
	IFE PROC-KI10, <
	XCT	[
	DFDV	A0,A3
	DFMP	A0,A3](A10)
	JFOV	POW306>		; YES - MULTIPLY/DIVIDE
	JUMPE	A7,POW301	; EXIT IF FINISHED
	IFE PROC-KA10, <
	MOVEI	AX,A3
	PUSHJ	SP,LABEL(27)>
	IFE PROC-KI10, <
	DFMP	A3,A3>		; OTHERWISE SQUARE MULTIPLIER
	LSH	A7,-1		; SHIFT AROUND EXPONENT
	JRST	POW304		; AND CARRY ON

POW305:	SETZB	A0,A1		; BASE = 0
	JUMPG	A7,POW301	; EXIT IF EXPONENT > 0

POW306:	SYSER2	2,@(SP)		; OTHERWISE GIVE OVERFLOW

POW307:	SYSER2	3,@(SP)		; FIXED POINT OVERFLOW

POW308:	LIBERR	1,@(SP)		; [E704] BASE & EXPONENT BOTH ZERO

	LIT
	PRGEND
TITLE POWER4 - INTEGER/REAL TO REAL EXPONENTIATION ROUTINE

; ON ENTRY:
; THE BASE AND EXPONENT ARE ON THE STACK
; A1 = 0 IF BASE IS INTEGER
; A1 = 1 IF BASE IS REAL
; THE LINK IS IN AX
; ON EXIT, THE RESULT (TYPE REAL) IS IN A0
	SEARCH	ALGPRM,ALGSYS

	%ENTER<4>

	EXTLAB<7,104,105>

	SALL

	%SUBTTL(ALGLIB,ALGOL LIBRARY)

LABEL(4):	POP	SP,A2		; RECOVER EXPONENT
	EXCH	AX,(SP)		; RECOVER BASE
	MOVE	A0,AX		; AND SAVE LINK
	JUMPN	A2,POW401	; EXPONENT = 0?
EDIT(704); 0^0 is undefined, so generate error message
	JUMPN	A0,POW405	; [E704] O.K. IF BASE NON-ZERO

POW403:	LIBERR	1,@(SP)		; NO - COMPLAIN

POW401:	JUMPN	A1,.+2
	JSP	AX,LABEL(7)		; CONVERT BASE TO REAL IF NECESSARY
	JUMPLE	A0,POW402	; BASE <= 0?
	PUSH	SP,A2		; NO - SAVE EXPONENT
	PUSHJ	SP,LABEL(105)		; AND TAKE LOGARITHM OF BASE
	POP	SP,A1		; RESTORE EXPONENT
	JUMPE	A0,POW405	; QUICK EXIT IF RESULT ZERO
	FMPR	A0,A1		; OTHERWISE MULTIPLY BY EXPONENT
	JRST	LABEL(104)		; AND TAKE EXPONENTIAL

POW402:	JUMPN	A0,POW403	; BASE = 0?

POW404:	JUMPL	A2,POW403	; YES - EXPONENT < 0?
	TDZA	A0,A0		; NO - RESULT IS 0.0

POW405:	MOVSI	A0,(1.0)	; RESULT IS 1.0
	POPJ	SP,0

	LIT
	PRGEND
TITLE POWER5 - INTEGER/REAL TO LONG REAL, LONG REAL TO REAL/LONG REAL EXPONENTIATION ROUTINE

; ON ENTRY:
; THE BASE AND EXPONENT ARE ON THE STACK
; A1 = 0 IF INTEGER TO LONG REAL
; A1 = 1 IF REAL TO LONG REAL
; A1 = 2 IF LONG REAL TO REAL
; A1 = 3 IF LONG REAL TO LONG REAL
; THE LINK IS IN AX
; ON EXIT, THE RESULT (TYPE LONG REAL) IS IN A0,A1
	SEARCH	ALGPRM,ALGSYS
	%ENTER<5>

	EXTLAB<10,13,21,120,121>

	SALL

	%SUBTTL(ALGLIB,ALGOL LIBRARY)

LABEL(5):	JRST	@POW501(A1)	; USE APPROPRIATE SEQUENCE

POW501:	XWD	0,POW502	; I^LR
	XWD	0,POW503	; R^LR
	XWD	0,POW504	; LR^R
	XWD	0,POW505	; LR^LR

POW502:	POP	SP,A4
	POP	SP,A3		; RECOVER EXPONENT
	EXCH	AX,(SP)		; RECOVER BASE
	MOVE	A0,AX		; AND SAVE LINK
	JSP	AX,LABEL(10)		; CONVERT BASE TO LONG REAL
	JRST	POW506

POW503:	POP	SP,A4
	POP	SP,A3		; RECOVER EXPONENT
	EXCH	AX,(SP)		; RECOVER BASE
	MOVE	A0,AX		; AND SAVE LINK
	JSP	AX,LABEL(13)		; CONVERT BASE TO LONG REAL
	JRST	POW506

POW504:	POP	SP,A0		; RECOVER EXPONENT
	POP	SP,A4
	EXCH	AX,(SP)		; RECOVER BASE
	MOVE	A3,AX		; AND SAVE LINK
	JSP	AX,LABEL(13)		; CONVERT EXPONENT TO LONG REAL
	EXCH	A0,A3
	EXCH	A1,A4		; GET THINGS IN RIGHT ACCUMULATORS
	JRST	POW506
POW505:	POP	SP,A4
	POP	SP,A3		; RECOVER EXPONENT
	POP	SP,A1
	EXCH	AX,(SP)		; RECOVER BASE
	MOVE	A0,AX		; AND SAVE LINK

POW506:	JUMPN	A3,POW507	; EXPONENT = 0?
EDIT(704); 0^0 is undefined, so generate error message
	JUMPE	A0,POW509	; [E704] ERROR IF BASE ALSO ZERO
	MOVSI	A0,(1.0)
	MOVEI	A1,0
	POPJ	SP,0		; YES - RESULT IS 1.0&&0

POW507:	JUMPLE	A0,POW508	; BASE <= 0?
	PUSH	SP,A3
	PUSH	SP,A4		; NO - SAVE EXPONENT
	PUSHJ	SP,LABEL(121)		; AND TAKE LOGARITHM OF BASE
	POP	SP,A4
	POP	SP,A3		; RESTORE EXPONENT
	JUMPE	A0,LABEL(120)		; QUICK EXIT IF RESULT ZERO
	MOVEI	AX,A3
	PUSHJ	SP,LABEL(21)		; OTHERWISE MULTIPLY BY EXPONENT
	JRST	LABEL(120)		; AND TAKE EXPONENTIAL

POW508:	JUMPE	A0,POW510	; BASE = 0?

POW509:	LIBERR	1,@(SP)		; NO - COMPLAIN

POW510:	JUMPL	A3,POW509	; YES - EXPONENT < 0?
	SETZB	A0,A1		; NO - RESULT IS 0.0&&0

POW511:	POPJ	SP,0

	LIT
	PRGEND
TITLE DSIGN - DUMMY BODY FOR SIGN

; INTEGER PROCEDURE SIGN(I); VALUE I; INTEGER I;
; INTEGER PROCEDURE SIGN(X); VALUE X; REAL X;
; INTEGER PROCEDURE SIGN(D); VALUE D; LONG REAL D;

	.EXIT=1
	.IXD=3
	SEARCH	ALGPRM,ALGSYS

	%ENTER<223>

	EXTERNAL	%ALGDR

	SALL

	%SUBTTL(ALGLIB,ALGOL LIBRARY)

	EXTLAB<6>

LABEL(223):	JSP	AX,PARAM
	Z			; [P37] ZERO POINTER. ROUTINE ITSELF CALLS TRACE
	XWD	0,4
	XWD	$PRO!$I!$SIM,2
	XWD	$VAR!$WA!$FOV,.IXD

	MOVE	A0,.IXD(DL)	; GET ARGUMENT
	JSP	AX,LABEL(6)		; AND ITS SIGN
	MOVEM	A0,.EXIT+1(DL)
	JRST	.EXIT(DL)

	LIT
	PRGEND
TITLE SIGN - SIGN ROUTINE

; ON ENTRY:
; THE ARGUMENT (INTEGER, REAL OR THE HIGH ORDER WORD OF LONG REAL) IS IN A0
; THE LINK IS IN AX
; ON EXIT:
; THE RESULT:	-1 IF ARGUMENT < 0
;		 0 IF ARGUMENT = 0
;		 1 IF ARGUMENT > 0
; IS IN A0
	SEARCH	ALGPRM,ALGSYS

STDENT(6,SIGN)
	JUMPE	A0,(AX)		; EXIT IF ZERO ARGUMENT
	JUMPL	A0,SIGN1	; ARGUMENT < 0?
	MOVEI	A0,1		; NO - RESULT IS 1
	JRST	(AX)

SIGN1:	MOVNI	A0,1		; YES - RESULT IS -1
	JRST	(AX)

	LIT
	PRGEND
TITLE DABS - DUMMY BODY FOR ABS

; INTEGER PROCEDURE ABS(I); VALUE I; INTEGER I;
; REAL PROCEDURE ABS(X); VALUE X; REAL X;
; LONG REAL PROCEDURE ABS(D); VALUE D; LONG REAL D;

	.EXIT=1
	.IX=3
	.D=4
	SEARCH	ALGPRM,ALGSYS

	%ENTER<222>

	EXTERNAL	%ALGDR

	SALL

	%SUBTTL(ALGLIB,ALGOL LIBRARY)

ABS:
LABEL(222):	MOVE	A1,(SP)		; GET PROGRAM LINK
	HRRZ	A0,(A1)		; NUMBER OF PARAMETERS+1
	CAIE	A0,2		; TWO?
	SYSER1	10,0		; NO - COMPLAIN
	HLRZ	A0,1(A1)
	ANDI	A0,$TYPE	; GET TYPE
	CAIN	A0,$I
	JRST	DABS2		; INTEGER I
	CAIN	A0,$R
	JRST	DABS3		; REAL
	CAIE	A0,$LR		; LONG REAL?
	SYSER1	7,0		; NO - COMPLAIN

	JSP	AX,PARAM	; (D)
	EXP	PMB
PATCH (32)	;  PLANT POST-MORTEM BLOCKS
	XWD	0,5
	XWD	$PRO!$LR!$SIM,2
	XWD	$VAR!$LR!$FOV,.D

	LRLOAD	A0,.D(DL)
	JUMPGE	A0,DABS1
	IFN PROC-KI10, <
	LRNEG	A0,A1>
	IFE PROC-KI10, <
	DMOVN	A0,A0>

DABS1:	LRSTOR	A0,.EXIT+1(DL)
	JRST	.EXIT(DL)
DABS2:	JSP	AX,PARAM	; (I)
	XWD	0,3
	XWD	$PRO!$I!$SIM,2
	XWD	$VAR!$I!$FOV,.IX

	JRST	DABS4

DABS3:	JSP	AX,PARAM	; (R)
	XWD	0,3
	XWD	$PRO!$R!$SIM,2
	XWD	$VAR!$R!$FOV,.IX

DABS4:	MOVM	A0,.IX(DL)	; GET MAGNITUDE
	MOVEM	A0,.EXIT+1(DL)
	JRST	.EXIT(DL)

PMB:
PMB:	0		; PROFILE WORD
	1,,3
	SIXBIT/ABS/

	LIT
	PRGEND
TITLE DENTIER - DUMMY BODY FOR ENTIER

; INTEGER PROCEDURE ENTIER(X); VALUE X; REAL X;
; INTEGER PROCEDURE ENTIER(D); VALUE D; LONG REAL D;

	.EXIT=1
	.XD=3
	SEARCH	ALGPRM,ALGSYS

	%ENTER<224>

	EXTERNAL	%ALGDR

	SALL

	%SUBTTL(ALGLIB,ALGOL LIBRARY)

	EXTLAB<11,14>

LABEL(224):	JSP	AX,PARAM
	Z
	XWD	0,4
	XWD	$PRO!$I!$SIM,2
	XWD	$VAR!$WF!$FOV,.XD

	MOVE	A1,PRGLNK(DL)	; GET PROGRAM LINK
	HLRZ	A2,-1(A1)
	ANDI	A2,$TYPE	; GET TYPE OF PARAMETER
	MOVEI	AX,DENT1	; SET RETURN LINK
	MOVE	A0,.XD(DL)	; AND LOAD FIRST ARGUMENT WORD
	CAIN	A2,$R		; REAL?
	JRST	LABEL(11)		; YES - USE ENTIER
	MOVE	A1,.XD+1(DL)	; NO - LOAD SECOND WORD OF ARGUMENT
	JRST	LABEL(14)		; AND USE ENTIEL

DENT1:	MOVEM	A0,.EXIT+1(DL)	; RESULT
	JRST	.EXIT(DL)

	LIT
	PRGEND
TITLE DINT - DUMMY BODY FOR INT

; INTEGER PROCEDURE INT(B); VALUE B; BOOLEAN B;

	.EXIT=1
	.B=2
	SEARCH	ALGPRM,ALGSYS

LIBENT(225,INT)
	XWD	0,2
	XWD	$PRO!$I!$SIM,2
	XWD	$VAR!$B!$FOV,.B

	JRST	.EXIT(DL)	; RESULT TRANSFERRED AUTOMATICALLY!

	LIT
	PRGEND
TITLE DBOOL - DUMMY BODY FOR BOOL

; BOOLEAN PROCEDURE BOOL(I); VALUE I; INTEGER I;

	.EXIT=1
	.I=2
	SEARCH	ALGPRM,ALGSYS

LIBENT(226,BOOL)
	XWD	0,2
	XWD	$PRO!$B!$SIM,2
	XWD	$VAR!$I!$FOV,.I

	JRST	.EXIT(DL)	; RESULT TRANSFERRED AUTOMATICALLY!

	LIT
	PRGEND
TITLE IR - INTEGER TO REAL CONVERSION ROUTINE

; ON ENTRY:
; THE ARGUMENT IS IN A0
; THE LINK IS IN AX
; ON EXIT, THE RESULT IS IN A0
	SEARCH	ALGPRM,ALGSYS

	%ENTER<7>

	SALL

	%SUBTTL(ALGLIB,ALGOL LIBRARY)

LABEL(7):	IFE	PROC-KA10, <
	IDIVI	A0,400		; SEPARATE HIGH AND LOW HALVES
	JUMPE	A0,.+2		; ONLY 18 BITS?
	TLC	A0,243000	; NO - SET UP HIGH HALF EXPONENT
	TLC	A1,233000	; SET UP LOW HALF EXPONENT
	FADR	A0,A1		; AND ADD BITS TOGETHER>
	IFE PROC-KI10, <
	FLTR	A0,A0>
	JRST	(AX)

	LIT
	PRGEND
TITLE ILR - INTEGER TO LONG REAL CONVERSION ROUTINE

; ON ENTRY:
; THE ARGUMENT IS IN A0
; THE LINK IS IN AX
; ON EXIT, THE RESULT IS IN A0,A1
	SEARCH	ALGPRM,ALGSYS

	%ENTER<10>

	SALL

	%SUBTTL(ALGLIB,ALGOL LIBRARY)

LABEL(10):	IDIVI	A0,400		; SEPARATE HIGH AND LOW HALVES
	JUMPE	A0,.+2		; ONLY 18 BITS?
	TLC	A0,243000	; NO - SET UP HIGH HALF EXPONENT
	TLC	A1,233000	; SET UP LOW HALF EXPONENT
	FADL	A0,A1		; AND ADD BITS TOGETHER
	IFE PROC-KI10, <
	TLZ	A1,777000	; IF KI10, WIPE OUT LOW WORD EXPONENT
	LSH	A1,10		; AND SHIFT UP MANTISSA>
	JRST	(AX)

	LIT
	PRGEND
TITLE ENTIER/RI - ENTIER/REAL TO INTEGER CONVERSION ROUTINE

; ON ENTRY:
; THE ARGUMENT IS IN A0
; THE LINK IS IN AX
; ON EXIT, THE RESULT IS IN A0
	SEARCH	ALGPRM,ALGSYS
	SALL

	%ENTER<12>


	%SUBTTL(ALGLIB,ALGOL LIBRARY)

STDENT(11,ENTIER)
ENT1:	MULI	A0,400		; ENTIER - SEPARATE EXPONENT AND MANTISSA
	EXCH	A0,A1
	TSC	A1,A1		; FIX UP EXPONENT
	ASH	A0,-243(A1)	; AND SHIFT MANTISSA TO FORM INTEGER
	JRST	(AX)

	IFE PROC-KA10, <
LABEL(12):FAD	A0,[EXP	0.5]	; [E641] UNROUNDED ADD
	JRST	ENT1>

	IFE PROC-KI10, <
LABEL(12):FIXR	A0,A0		; RI - CONVERT TO NEAREST INTEGER
	JRST	(AX)>

	LIT

	PRGEND
TITLE RLR - REAL TO LONG REAL CONVERSION ROUTINE

; ON ENTRY:
; THE ARGUMENT IS IN A0
; THE LINK IS IN AX
; ON EXIT, THE RESULT IS IN A0,A1
	SEARCH	ALGPRM,ALGSYS

	%ENTER<13>

	SALL

	%SUBTTL(ALGLIB,ALGOL LIBRARY)

LABEL(13):	MOVEI	A1,0		; ZERO LOW ORDER WORD
	JRST	(AX)

	LIT
	PRGEND
TITLE ENTIEL/LRI - ENTIEL/LONG REAL TO INTEGER CONVERSION ROUTINE

; ON ENTRY:
; THE ARGUMENT IS IN A0,A1
; THE LINK IS IN AX
; ON EXIT, THE RESULT IS IN A0
	SEARCH	ALGPRM,ALGSYS


	%ENTER<15>

	SALL

	%SUBTTL(ALGLIB,ALGOL LIBRARY)

	IFE PROC-KA10, <
LABEL(15):	MOVE	A2,A1		; LI - ADD 0.5
	FADL	A0,[0.5]
	UFA	A1,A2
	FADL	A0,A2>

	IFE PROC-KI10, <
LABEL(15):	DFAD	A0,[
	EXP	0.5,0.0]	; LI - ADD 0.5>
	JRST	LRI1

STDENT(14,ENTIER)
LRI1:	HLRZ	A2,A0		; ENTIEL
	LSH	A2,-11
	ANDI	A2,000377	; EXTRACT HIGH ORDER EXPONENT
	TLZ	A0,377000	; AND CLEAR IT OUT
	JUMPGE	A0,.+3		; NUMBER POSITIVE?
	TRC	A2,000377	; NO - COMPLEMENT EXTRACTED EXPONENT
	TLO	A0,377000	; AND SET ALL ONES
	IFE PROC-KA10, <
	LSH	A1,10		; IF KA10, SHIFT UP LOW ORDER MANTISSA>
	ASHC	A0,-233(A2)	; SHIFT MANTISSA TO INTEGER
	JRST	(AX)

	LIT
	PRGEND
TITLE LRR - LONG REAL TO REAL CONVERSION ROUTINE

; ON ENTRY:
; THE ARGUMENT IS IN A0,A1
; THE LINK IS IN AX
; ON EXIT, THE RESULT IS IN A0
	SEARCH	ALGPRM,ALGSYS

	%ENTER<16>

	SALL

	%SUBTTL(ALGLIB,ALGOL LIBRARY)

	MLON

LABEL(16):	IFE PROC-KA10, <
	FADR	A0,A1		; ADD HIGH AND LOW PARTS
	JRST	(AX)>
	IFE PROC-KI10, <
	JUMPGE	A0,.+3		; ARGUMENT POSITIVE?
	DMOVN	A0,A0		; NO - NEGATE IT
	TLZA	A1,400000	; AND CLEAR BIT 0 FLAG
	TLO	A1,400000	; YES - SET BIT 0 FLAG
	TLNN	A1,200000	; ROUNDING REQUIRED?
	JRST	LR1		; NO
	CAMN	A0,[
	XWD	377777,777777]	; NUMBER TOO LARGE?
	SYSER2	2,0		; YES - REPORT OVERFLOW
	ADDI	A0,1		; NO
	TLO	A0,400		; CARRY

LR1:	JUMPL	A1,(AX)		; EXIT IF POSITIVE
	MOVN	A0,A0		; OTHEWISE NEGATE
	JRST	(AX)>

	LIT
	PRGEND
TITLE DSINE - DUMMY BODY FOR SINE

; REAL PROCEDURE SIN(X); VALUE X; REAL X;

	.EXIT=1
	.X=3
	SEARCH	ALGPRM,ALGSYS

	%ENTER<200>

	SALL

	EXTERNAL	%ALGDR

	%SUBTTL(ALGLIB,ALGOL LIBRARY)

	EXTLAB<100>

LABEL(200):	JSP	AX,PARAM
	Z
	XWD	0,3
	XWD	$PRO!$R!$SIM,2
	XWD	$VAR!$R!$FOV,.X

	MOVE	A0,.X(DL)	; GET ARGUMENT
	PUSHJ	SP,LABEL(100)		; CALL SINE
	MOVEM	A0,.EXIT+1(DL)	; STORE RESULT
	JRST	.EXIT(DL)

	LIT
	PRGEND
TITLE DCOSINE - DUMMY BODY FOR COSINE

; REAL PROCEDURE COS(X); VALUE X; REAL X;

	.EXIT=1
	.X=3
	SEARCH	ALGPRM,ALGSYS

	%ENTER<201>

	SALL

	EXTERNAL	%ALGDR

	%SUBTTL(ALGLIB,ALGOL LIBRARY)

	EXTLAB<101>

LABEL(201):	JSP	AX,PARAM
	Z
	XWD	0,3
	XWD	$PRO!$R!$SIM,2
	XWD	$VAR!$R!$FOV,.X

	MOVE	A0,.X(DL)	; GET ARGUMENT
	PUSHJ	SP,LABEL(101)		; CALL COSINE
	MOVEM	A0,.EXIT+1(DL)	; STORE RESULT
	JRST	.EXIT(DL)

	LIT
	PRGEND
TITLE SINE/COSINE - SINGLE PRECISION SINE/COSINE ROUTINES

; TRANSCRIBED FROM LIB40 V.22/EY/KK

; METHOD: TAYLOR SERIES WITH FIVE TERMS

; ON ENTRY:
; THE ARGUMENT (X) IS IN A0
; THE LINK IS ON THE STACK
; ON EXIT, THE RESULT IS IN A0
	SEARCH	ALGPRM,ALGSYS

STDENT(101,COSINE)
	MOVE	A1,A0		; COSINE
	FADR	A1,SIN4		; ADD PI/2
	MOVM	A1,A1		; AND TAKE MAGNITUDE
	CAMGE	A1,SIN6		; VERY SMALL?
	MOVN	A0,A0		; YES - CALCULATE COS(-X)
	FADR	A0,SIN4
	MOVM	A1,A0
	JRST	COS2

STDENT(100,SINE)
	FADRI	A0,0		; ENSURE NORMALISED
	MOVM	A1,A0		; SINE - GET MAGNITUDE OF X
	CAMGE	A1,SIN6		; VERY SMALL?
	POPJ	SP,0		; YES - QUICK EXIT: SIN(X) = X
COS2:	FMPR	A1,[
	XWD	200505,746034]	; Y = ABS(X)/(PI/2)
	CAMGE	A1,[
	XWD	201400,000000]	; Y < 1.0?
	JRST	SIN1		; YES
	MULI	A1,400		; NO - SEPARATE EXPONENT AND MANTISSA
	LSH	A2,-202(A1)
	TLZ	A2,400000	; SHIFT OUT INTEGER PART OF NUMBER
	MOVEI	A1,200		; PREPARE NEW EXPONENT
	ROT	A2,3		; SAVE QUADRANT BITS
	LSHC	A1,33		; AND BRING INTO RANGE (0,1)
	FADRI	A1,000000	; NORMALIZE
	JUMPE	A2,SIN1		; OK IF IN FIRST QUADRANT
	TLCE	A2,001000	; SECOND OR FOURTH QUADRANT
	FSBRI	A1,201400	; YES - SUBTRACT 1.0
	TLCE	A2,003000	; SECOND QUADRANT
	TLNN	A2,003000	; OR THIRD QUADRANT?
	MOVN	A1,A1		; YES - NEGATE

SIN1:	JUMPGE	A0,SIN2		; X < 0?
	MOVN	A1,A1		; YES - NEGATE Y

SIN2:	MOVE	A2,A1		; SAVE Y
	FMPR	A1,A1		; AND FORM Y^2
	MOVEI	A3,3
	MOVE	A0,SIN5

SIN3:	FMPR	A0,A1
	FADR	A0,SIN4(A3)
	SOJGE	A3,SIN3
	FMPR	A0,A2		; FORM POLYNOMIAL IN Y
	POPJ	SP,0

SIN4:	XWD	201622,077325	; PI/2
	XWD	577265,210372	; -(PI/2)^3/3!
	XWD	175506,321276	; (PI/2)^5/5!
	XWD	606315,546346	; -(PI/2)^7/7!
SIN5:	XWD	164475,536722	; (PI/2)^9/9!
SIN6:	XWD	162400,000000	; 2&-15

	LIT
	PRGEND
TITLE DARCSIN - DUMMY BODY FOR ARCSINE

; REAL PROCEDURE ARCSIN(X); VALUE X; REAL X;

	.EXIT=1
	.X=3
	SEARCH	ALGPRM,ALGSYS

	%ENTER<207>

	SALL

	EXTERNAL	%ALGDR

	%SUBTTL(ALGLIB,ALGOL LIBRARY)

	EXTLAB<107>

LABEL(207):	JSP	AX,PARAM
	Z
	XWD	0,3
	XWD	$PRO!$R!$SIM,2
	XWD	$VAR!$R!$FOV,.X

	MOVE	A0,.X(DL)	; GET ARGUMENT
	PUSHJ	SP,LABEL(107)		; CALL ARCSINE
	MOVEM	A0,.EXIT+1(DL)	; STORE RESULT
	JRST	.EXIT(DL)

	LIT
	PRGEND
TITLE ARCSIN - SINGLE PRECISION INVERSE SINE ROUTINE

; REWRITE OF LIB40 V.27/EY/KK/DMN

; METHOD:
;
; IF X < -1.0 OR X > 1.0 AN ERROR RESULTS
;
; IF -1 <= X <= 1, ARCSIN(X) = ARCTAN(X/SQRT(1 - X^2))

; ON ENTRY:
; THE ARGUMENT (X) IS IN A0
; THE LINK IS ON THE STACK
; ON EXIT, THE RESULT IS IN A0
	SEARCH	ALGPRM,ALGSYS

	EXTLAB<102,103>
STDENT(107,ARCSIN)
	MOVM	A1,A0		; MAGNITUDE OF ARGUMENT
	CAML	A1,[
	XWD	201400,000000]	; STRICTLY IN RANGE?
	JRST	ARCS1		; NO
	MOVE	A4,A0		; TAKE SAFE COPY OF X
	MOVN	A1,A0
	FMPR	A0,A1
	FADRI	A0,201400	; FORM 1 - X^2
	PUSHJ	SP,LABEL(103)		; AND TAKE SQRT
	FDVRM	A4,A0		; FORM X/SQRT(1 - X^2)
	JRST	LABEL(102)		; AND LET ARCTAN FINISH OFF

ARCS1:	CAME	A1,[
	XWD	201400,000000]	; X = -1.0 OR 1.0?
	LIBERR	3,@(SP)		; NO
	FMPR	A0,[
	XWD	201622,077325]	; YES - RETURN -PI/2 OR PI/2
	POPJ	SP,0

	LIT
	PRGEND
TITLE DARCCOS - DUMMY BODY FOR ARCCOS

; REAL PROCEDURE ARCCOS(X); VALUE X; REAL X;

	.EXIT=1
	.X=3
	SEARCH	ALGPRM,ALGSYS

	%ENTER<210>

	SALL

	EXTERNAL	%ALGDR

	%SUBTTL(ALGLIB,ALGOL LIBRARY)

	EXTLAB<110>

LABEL(210):	JSP	AX,PARAM
	Z
	XWD	0,3
	XWD	$PRO!$R!$SIM,2
	XWD	$VAR!$R!$FOV,.X

	MOVE	A0,.X(DL)	; GET ARGUMENT
	PUSHJ	SP,LABEL(110)		; CALL ARCCOS
	MOVEM	A0,.EXIT+1(DL)	; STORE RESULT
	JRST	.EXIT(DL)

	LIT
	PRGEND
TITLE ARCCOS - SINGLE PRECISION INVERSE COSINE ROUTINE

; REWRITE OF LIB40 V.27/KK/DMN

; METHOD:
;
; IF X < -1.0 OR X > 1.0 AN ERROR RESULTS
; IF X = -1.0, ARCCOS(X) = PI
; IF -1.0 < X < 0, ARCCOS(X) = PI + ARCTAN(SQRT(1 - X^2)/X)
; IF X = 0, ARCCOS(X) = PI/2
; IF 0 < X < 1.0, ARCCOS(X) = ARCTAN(SQRT(1 - X^2)/X)
; IF X = 1.0, ARCCOS(X) = 0

; ON ENTRY:
; THE ARGUMENT (X) IS IN A0
; THE LINK IS ON THE STACK
; ON EXIT, THE RESULT IS IN A0
	SEARCH	ALGPRM,ALGSYS

	EXTLAB<102,103>

STDENT(110,ARCCOS)
	MOVM	A1,A0		; MAGNITUDE OF ARGUMENT
	CAML	A1,[
	XWD	201400,000000]	; STRICTLY IN RANGE?
	JRST	ARCC1		; NO
	JUMPE	A0,ARCC2	; SPECIAL CASE X = 0?
	MOVE	A4,A0		; SAFE COPY OF ARGUMENT
	MOVN	A1,A0
	FMPR	A0,A1
	FADRI	A0,201400	; FORM 1 - X^2
	PUSHJ	SP,LABEL(103)		; AND TAKE SQRT
	FDVR	A0,A4		; AND DIVIDE BY X
	JUMPG	A4,LABEL(102)		; LET ARCTAN PROCEDE IF X > 0
	PUSHJ	SP,LABEL(102)		; OTHERWISE CALL ARCTAN
	FADR	A0,[
	XWD	202622,077325]	; AND ADD PI
	POPJ	SP,0
ARCC1:	CAME	A1,[
	XWD	201400,000000]	; X = -1.0 OR 1.0
	LIBERR	3,@(SP)		; NO - COMPLAIN
	JUMPL	A0,.+2		; X = 1.0?
	TDZA	A0,A0		; YES - RESULT IS 0
	MOVE	A0,[
	202622,,077325]		; [E615] NO - RESULT IS PI.
EDIT (615) ; WRONG ANSWER FOR ARCCOS(-1)
	POPJ	SP,0

ARCC2:	MOVE	A0,[
	XWD	201622,077325]	; X = 0, RESULT IS PI/2
	POPJ	SP,0

	LIT
	PRGEND
TITLE DARCTAN - DUMMY BODY FOR ARCTAN

; REAL PROCEDURE ARCTAN(X); VALUE X; REAL X;

	.EXIT=1
	.X=3
	SEARCH	ALGPRM,ALGSYS

	%ENTER<202>

	SALL

	EXTERNAL	%ALGDR

	%SUBTTL(ALGLIB,ALGOL LIBRARY)

	EXTLAB<102>

LABEL(202):	JSP	AX,PARAM
	Z
	XWD	0,3
	XWD	$PRO!$R!$SIM,2
	XWD	$VAR!$R!$FOV,.X

	MOVE	A0,.X(DL)	; GET ARGUMENT
	PUSHJ	SP,LABEL(102)		; CALL ARCTAN
	MOVEM	A0,.EXIT+1(DL)	; STORE RESULT
	JRST	.EXIT(DL)

	LIT
	PRGEND
TITLE ARCTAN - SINGLE PRECISION INVERSE TANGENT ROUTINE

; TRANSCRIBED FROM LIB40 V.22/EY/KK

; METHOD:
;
; IF X < 0, ARCTAN(X) = -ARCTAN(-X)
;
; IF 0 <= X < 2^(-27), ARCTAN(X) = X
;
; IF 2^(-27) <= X <= 1.0:
;
; ARCTAN(X) = X*(B0 + A1/(X^2 + B1 + A2/(X^2 + B2 + A3/(X^2 + B3))))
;
; IF 1.0 < X < 2^27, ARCTAN(X) = PI/2 - ARCTAN(1/X)
;
; IF X >= 2^27, ARCTAN(X) = PI/2

; ON ENTRY:
; THE ARGUMENT IS IN A0
; THE LINK IS ON THE STACK
; ON EXIT, THE RESULT IS IN A0
	SEARCH	ALGPRM,ALGSYS
STDENT(102,ARCTAN)
	MOVM	A1,A0		; GET ABS(X)
	CAMGE	A1,[
	XWD	145400,000000]	; ABS(X) < 2^(-27)?
	JRST	ARCT3		; YES - ARCTAN(X) = X
	CAMGE	A1,[
	XWD	233400,000000]	; ABS(X) >= 2^27?
	JRST	ARCT1		; NO
	JUMPL	A0,.+2		; YES: X < 0?
	SKIPA	A1,ARCT4	; NO - RESULT IS PI/2
	MOVN	A1,ARCT4	; YES - RESULT IS -PI/2
	MOVE	A0,A1
	POPJ	SP,0
ARCT1:	HRRI	A0,0		; CLEAR RANGE FLAG
	MOVSI	A2,201400
	CAMG	A1,A2		; ABS(X) > 1.0?
	JRST	ARCT2		; NO
	FDVRM	A2,A1		; YES - FORM 1/ABS(X)
	SETCA	A0,0		; SET RANGE FLAG AND INVERT SIGN

ARCT2:	MOVE	A2,A1
	FMPR	A2,A2		; FORM X^2
	MOVE	A3,ARCT8
	FADR	A3,A2		; X^2 + B3
	MOVE	A4,ARCT11
	FDVR	A4,A3
	FADR	A4,ARCT7
	FADR	A4,A2		; X^2 + B2 + A3/(X^2 + B3)
	MOVE	A3,ARCT10
	FDVR	A3,A4
	FADR	A3,ARCT6
	FADR	A3,A2		; X^2 + B1 + A2/(X^2 + B2 + A3/(X^2 + B3))
	MOVE	A4,ARCT9
	FDVR	A4,A3
	FADR	A4,ARCT5	; B0 + A1/(X^2 + B1 + A2/(X^2 + B2 + A3/(X^2 + B3)))
	FMPR	A1,A4		; MULTIPLY BY ABS(X) TO GIVE ARCTAN(X)
	TRNE	A0,-1		; RANGE FLAG SET?
	FSBR	A1,ARCT4	; YES - SUBTRACT PI/2
	EXCH	A0,A1		; LOAD UP RESULT
	JUMPGE	A1,ARCT3	; SHOULD IT BE NEGATIVE?
	MOVN	A0,A0		; YES- NEGATE IT

ARCT3:	POPJ	SP,0


ARCT4:	XWD	201622,077325	; PI/2

ARCT5:	XWD	176545,543401	; B0
ARCT6:	XWD	203660,615617	; B1
ARCT7:	XWD	202650,373270	; B2
ARCT8:	XWD	201562,663021	; B3

ARCT9:	XWD	202732,621643	; A1
ARCT10:	XWD	574071,125540	; A2
ARCT11:	XWD	600360,700773	; A3

	LIT
	PRGEND
TITLE DSQRT - DUMMY BODY FOR SQRT

; REAL PROCEDURE SQRT(X); VALUE X; REAL X;

	.EXIT=1
	.X=3
	SEARCH	ALGPRM,ALGSYS

	%ENTER<203>

	SALL

	EXTERNAL	%ALGDR

	%SUBTTL(ALGLIB,ALGOL LIBRARY)

	EXTLAB<103>

LABEL(203):	JSP	AX,PARAM
	Z
	XWD	0,3
	XWD	$PRO!$R!$SIM,2
	XWD	$VAR!$R!$FOV,.X

	MOVE	A0,.X(DL)	; GET ARGUMENT
	PUSHJ	SP,LABEL(103)		; CALL SQRT
	MOVEM	A0,.EXIT+1(DL)	; STORE RESULT
	JRST	.EXIT(DL)

	LIT
	PRGEND
TITLE SQRT - SINGLE PRECISION SQUARE ROOT ROUTINE

; TRANSCRIBED FROM LIB40 V.27I/TL/TWE

; METHOD: LINEAR APPROXIMATION WITH TWO NEWTON-RAPHESON ITERATIONS

; ON ENTRY:
; THE ARGUMENT (X) IS IN A0
; THE LINK IS ON THE STACK
; ON EXIT, THE RESULT IS IN A0
	SEARCH	ALGPRM,ALGSYS

STDENT(103,SQRT)
	JUMPGE	A0,SQRT1	; ENSURE POSITIVE ARGUMENT
	LIBERR	0,@(SP)		; NO - COMPLAIN

SQRT1:	JUMPE	A0,SQRT4	; QUICK EXIT FOR ZERO ARGUMENT
	MOVEI	A1,0
	ROTC	A0,11		; GET EXPONENT IN A1
	LSH	A0,-11		; AND CLEAR IT OUT OF ARGUMENT
	SUBI	A1,201		; TRUE EXPONENT - 1
	ROT	A1,-1		; HALVE AND SAVE ODD/EVEN BIT IN A1
	JUMPL	A1,SQRT2	; 0.25 <= FRACTION < 0.5?
	TLO	A0,177000	; YES - FIX UP EXPONENT TO FORM Y
	MOVE	A2,A0
	FMPRI	A2,200640	; R1 = LINEAR APPROXIMATION TO SQRT(Y)
	FADRI	A2,177465	; = (832*Y + 309)/1024
	JRST	SQRT3

SQRT2:	TLO	A0,200000	; NO - FIX UP EXPONENT TO FORM Y
	MOVE	A2,A0
	FMPRI	A2,200450	; R1 = LINEAR APPROXIMATION TO SQRT(Y)
	FADRI	A2,177660	; = (37*Y + 27)/64

SQRT3:	MOVE	A3,A0
	FDVR	A3,A2
	FADR	A3,A2		; FIRST NEWTON-RAPHESON ITERATION:
	FSC	A3,-1		; R2 = (Y/R1 + R1)/2
	FDVR	A0,A3		; SECOND NEWTON-RAPHESON ITERATION:
	FADR	A0,A3		; R3 = (Y/R2 + R2)/2
	FSC	A0,(A1)		; SCALE BACK TO SIZE (INCLUDES HALVING TO R3)
SQRT4:	POPJ	SP,0

	LIT
	PRGEND
TITLE DLN - DUMMY BODY FOR LN

; REAL PROCEDURE LN(X); VALUE X; REAL X;

	.EXIT=1
	.X=3
	SEARCH	ALGPRM,ALGSYS

	%ENTER<205>

	SALL

	EXTERNAL	%ALGDR

	%SUBTTL(ALGLIB,ALGOL LIBRARY)

	EXTLAB<105>

LABEL(205):	JSP	AX,PARAM
	Z
	XWD	0,3
	XWD	$PRO!$R!$SIM,2
	XWD	$VAR!$R!$FOV,.X

	MOVE	A0,.X(DL)	; GET ARGUMENT
	PUSHJ	SP,LABEL(105)		; CALL LN
	MOVEM	A0,.EXIT+1(DL)	; STORE RESULT
	JRST	.EXIT(DL)

	LIT
	PRGEND
TITLE LN - SINGLE PRECISION LOGARITHM ROUTINE

; REWRITE OF LIB40 V.22/KK/DMN

; METHOD:
;
; X = F*2^I, WHERE 0.5 <= F < 1
;
; LN(X) = LN(2)*(I + LOG2(F))
;
; LOG2(F) = C1*Z + C3*Z^3 + C5*Z^5 - 0.5
;
; WHERE Z = (F - SQRT(0.5))/(F + SQRT(0.5))

; ON ENTRY:
; THE ARGUMENT (X) IS IN A0
; THE LINK IS ON THE STACK
; ON EXIT, THE RESULT IS IN A0
	SEARCH	ALGPRM,ALGSYS

STDENT(105,LN)
	JUMPG	A0,.+2		; ARGUMENT POSITIVE?
	LIBERR	1,@(SP)		; NO - COMPLAIN
	CAMN	A0,[
	XWD	201400,000000]	; X = 1.0?
	JRST	LN1		; YES - QUICK EXIT
	ASHC	A0,-33		; SEPARATE EXPONENT AND MANTISSA
	HRLI	A0,233000
	FSBRI	A0,210401	; FORM I - 0.5, FLOATING POINT
	ASH	A1,-10
	TLO	A1,200000	; FIX UP F
	MOVE	A2,A1
	FSBR	A1,LN2
	FADR	A2,LN2
	FDVRB	A1,A2		; Z = (F - SQRT(0.5))/(F + SQRT(0.5))
	FMPR	A1,A1		; FORM Z^2
	MOVE	A3,LN5
	FMPR	A3,A1
	FADR	A3,LN4
	FMPR	A3,A1
	FADR	A3,LN3
	FMPR	A2,A3		; C1*Z + C3*Z^3 + C5*Z^5
	FADR	A0,A2		; ADD I - 0.5
	FMPR	A0,[
	XWD	200542,710300]	; AND MULTIPLY BY LN(2)
	POPJ	SP,0

LN1:	MOVEI	A0,0
	POPJ	SP,0

LN2:	XWD	200552,023632	; SQRT(0.5)

LN3:	XWD	202561,251002	; C1
LN4:	XWD	200754,213604	; C3
LN5:	XWD	200462,432521	; C5

	LIT
	PRGEND
TITLE DTAN - DUMMY BODY FOR TAN

; REAL PROCEDURE TAN(X); VALUE X; REAL X;

	.EXIT=1
	.X=3
	SEARCH	ALGPRM,ALGSYS

	%ENTER<206>

	SALL

	EXTERNAL	%ALGDR

	%SUBTTL(ALGLIB,ALGOL LIBRARY)

	EXTLAB<106>

LABEL(206):	JSP	AX,PARAM
	Z
	XWD	0,3
	XWD	$PRO!$R!$SIM,2
	XWD	$VAR!$R!$FOV,.X

	MOVE	A0,.X(DL)	; GET ARGUMENT
	PUSHJ	SP,LABEL(106)		; CALL TAN
	MOVEM	A0,.EXIT+1(DL)	; STORE RESULT
	JRST	.EXIT(DL)

	LIT
	PRGEND
TITLE TAN - SINGLE PRECISION TANGENT ROUTINE

; REWRITE OF ATLAS EXTRACODE 1735

; METHOD:
;
; X = (N+Y)*PI/2, WHERE N IS AN INTEGER, AND -0.5 <= Y < 0.5
;
; IF N IS EVEN, TAN(X) = P(Y)/(1 - Y^2)
;
; IF N IS ODD, TAN(X) = -(1 - Y^2)/P(Y)
;
; WHERE P(Y) IS AN ODD POLYNOMIAL IN Y

; ON ENTRY:
; THE ARGUMENT (X) IS IN A0
; THE LINK IS ON THE STACK
; ON EXIT, THE REULT IS IN A0
	SEARCH	ALGPRM,ALGSYS

STDENT(106,TAN)
	JUMPE	A0,TAN4		; QUICK EXIT FOR ZERO
	FMPR	A0,[
	XWD	200505,746034]	; MULTIPLY BY 2/PI
	MOVM	A2,A0		; ABS(X)/(PI/2)
	MOVEI	A1,1		; SET FLAG FOR EVEN N
	CAMGE	A2,[
	XWD	200400,000000]	; LESS THAN 0.5?
	JRST	TAN1		; YES - TAKE SHORT CUT
	FSBRI	A2,200400	; NO - SUBTRACT 0.5
	MULI	A2,400		; SEPARATE EXPONENT AND MANTISSA
	EXCH	A2,A3		; THINGS ARE NOW THE WRONG WAY ROUND
	MOVEI	A1,0
	CAIL	A3,233		; WILL SHIFT CAUSE LOSS OF MANTISSA?
	TDZA	A2,A2		; YES - SAVE A LOT OF WORK
	ASHC	A1,-200(A3)	; SHIFT OUT INTEGER PART
	ANDI	A1,1		; SET ODD/EVEN FLAG FOR N
	LSH	A2,-10
	TLO	A2,200000	; AND FIX UP NEW EXPONENT
	FSBRI	A2,200400	; SUBTRACT 0.5 TO GET Y
TAN1:	MOVE	A3,A2		; SAVE Y
	FMPR	A2,A2		; SAVE Y^2
	MOVEI	A5,3
	MOVE	A4,TAN7

TAN2:	FMPR	A4,A2
	FADR	A4,TAN6(A5)
	SOJGE	A5,TAN2
	FMPR	A4,A3		; FORM -P(Y)
	MOVN	A2,A2
	FADRI	A2,201400	; FORM 1 - Y^2
	JUMPN	A1,TAN3		; N ODD?
	EXCH	A4,A2		; YES - EXCHANGE OPERANDS
	MOVN	A0,A0		; AND INVERT ARGUMENT SIGN

TAN3:	FDVR	A4,A2		; FORM FINAL RESULT
	JFOV	TAN5		; OVERFLOW IS FATAL
	EXCH	A0,A4		; LOAD UP RESULT
	JUMPGE	A4,TAN4		; SHOULD IT BE NEGATIVE?
	MOVN	A0,A0		; YES - NEGATE IT

TAN4:	POPJ	SP,0

TAN5:	LIBERR	4,@(SP)

TAN6:	XWD	201622,077325	; PI/2
	XWD	600342,340621	; PI/2*((PI/2)^2/3 - 1)
	XWD	604353,774024	; (PI/2)^3*((PI/2)^2*2/15 - 1/3)
	XWD	610120,631722	; (PI/2)^5*((PI/2)^2*17/315 - 2/15)
TAN7:	XWD	613217,113617	; (PI/2)^7*((PI/2)^2*62/2835 - 17/315)

	LIT
	PRGEND
TITLE DSINH - DUMMY BODY FOR SINH

; REAL PROCEDURE SINH(X); VALUE X; REAL X;

	.EXIT=1
	.X=3
	SEARCH	ALGPRM,ALGSYS

	%ENTER<211>

	SALL

	EXTERNAL	%ALGDR

	%SUBTTL(ALGLIB,ALGOL ALIAS)

	EXTLAB<111>

LABEL(211):	JSP	AX,PARAM
	Z
	XWD	0,3
	XWD	$PRO!$R!$SIM,2
	XWD	$VAR!$R!$FOV,.X

	MOVE	A0,.X(DL)	; GET ARGUMENT
	PUSHJ	SP,LABEL(111)		; CALL SINH
	MOVEM	A0,.EXIT+1(DL)	; STORE RESULT
	JRST	.EXIT(DL)

	LIT
	PRGEND
TITLE SINH - SINGLE PRECISION SINH ROUTINE

; TRANSCRIBED FROM LIB40 V.27/KK/DMN

; METHOD:
;
; IF ABS(X) < 0.1, SINH(X) = X + X^3/6 + X^5/120
;
; IF 0.1 <= ABS(X) < 88.029, SINH(X) = (EXP(X) - EXP(-X))/2
;
; IF ABS(X) >= 88.029, SINH(X) = SIGN(X)*EXP(ABS(X) - LN(2))
;
; EXP(-X) IS 1/EXP(X)

; ON ENTRY:
; THE ARGUMENT (X) IS IN A0
; THE LINK IS ON THE STACK
; ON EXIT, THE RESULT IS IN A0
	SEARCH	ALGPRM,ALGSYS

	EXTLAB<104>

STDENT(111,SINH)
	MOVM	A1,A0		; SAVE ABS(X)
	CAML	A1,[
	XWD	175631,463146]	; < 0.1?
	JRST	SINH1		; NO
	FMPR	A1,A1		; YES - FORM X^2
	MOVE	A2,A1		; AND SAVE IT
	FDVRI	A1,207740
	FADR	A1,[
	XWD	176525,252525]
	FMPR	A1,A2
	FADRI	A1,201400
	FMPR	A0,A1		; FORM X + X^3/6 + X^5/120
	POPJ	SP,0
SINH1:	CAML	A1,[
	XWD	207540,074636]	; < 88.029?
	JRST	SINH2		; NO
	PUSHJ	SP,LABEL(104)		; YES - CALCULATE EXP(X)
	MOVSI	A1,576400
	FDVR	A1,A0		; CALCULATE -EXP(-X)
	FADR	A0,A1
	FSC	A0,-1		; FORM SINH(X)
	POPJ	SP,0

SINH2:	PUSH	SP,A0		; SAVE X
	MOVE	A0,A1
	FSBR	A0,[
	XWD	200542,710300]	; FORM ABS(X) - LN(2)
	PUSHJ	SP,LABEL(104)		; AND CALL EXP
	POP	SP,A1		; RESTORE X
	JUMPGE	A1,SINH3	; POSITIVE?
	MOVN	A0,A0		; NO - NEGATE RESULT

SINH3:	POPJ	SP,0

	LIT
	PRGEND
TITLE DCOSH - DUMMY BODY FOR COSH

; REAL PROCEDURE COSH(X); VALUE X; REAL X;

	.EXIT=1
	.X=3
	SEARCH	ALGPRM,ALGSYS

	%ENTER<212>

	SALL

	EXTERNAL	%ALGDR

	%SUBTTL(ALGLIB,ALGOL LIBRARY)

	EXTLAB<112>

LABEL(212):	JSP	AX,PARAM
	Z
	XWD	0,3
	XWD	$PRO!$R!$SIM,2
	XWD	$VAR!$R!$FOV,.X

	MOVE	A0,.X(DL)	; GET ARGUMENT
	PUSHJ	SP,LABEL(112)		; CALL COSH
	MOVEM	A0,.EXIT+1(DL)	; STORE RESULT
	JRST	.EXIT(DL)

	LIT
	PRGEND
TITLE COSH - SINGLE PRECISION COSH ROUTINE

; TRANSCRIBED FROM LIB40 V27/EY/KK/DMN

; METHOD:
;
; IF ABS(X) < 88.029, COSH(X) = (EXP(X) + EXP(-X))/2
;
; IF 88.029 <= ABS(X) < 88.029 + LN(2), COSH(X) = EXP(ABS(X) + LN(2))
;
; EXP(-X) IS 1/EXP(X)

; ON ENTRY:
; THE ARGUMENT (X) IS IN A0
; THE LINK IS ON THE STACK
; ON EXIT, THE RESULT IS IN A0
	SEARCH	ALGPRM,ALGSYS

	EXTLAB<104>

STDENT(112,COSH)
	MOVM	A0,A0		; FORM ABS(X)
	CAML	A0,COSH2	; < 88.029?
	JRST	COSH1		; NO
	PUSHJ	SP,LABEL(104)		; YES - CALCULATE EXP(X)
	MOVSI	A1,201400
	FDVR	A1,A0		; CALCULATE EXP(-X)
	FADR	A0,A1
	FSC	A0,-1		; FORM COSH(X)
	POPJ	SP,0

COSH1:	FSBR	A0,[
	XWD	200542,710300]
	CAML	A0,COSH2	; < 88.029 + LN(2)?
	LIBERR	4,@(SP)		; NO - COMPLAIN
	JRST	LABEL(104)		; YES - LET EXP DO THE WORK

COSH2:	XWD	207540,074635	; 88.029

	LIT
	PRGEND
TITLE DTANH - DUMMY BODY FOR TANH

; REAL PROCEDURE TANH(X); VALUE X; REAL X;

	.EXIT=1
	.X=3
	SEARCH	ALGPRM,ALGSYS

	%ENTER<213>

	SALL

	EXTERNAL	%ALGDR

	%SUBTTL(ALGLIB,ALGOL LIBRARY)

	EXTLAB<113>

LABEL(213):	JSP	AX,PARAM
	Z
	XWD	0,3
	XWD	$PRO!$R!$SIM,2
	XWD	$VAR!$R!$FOV,.X

	MOVE	A0,.X(DL)	; GET ARGUMENT
	PUSHJ	SP,LABEL(113)		; CALL TANH
	MOVEM	A0,.EXIT+1(DL)	; STORE RESULT
	JRST	.EXIT(DL)

	LIT
	PRGEND
TITLE TANH - SINGLE PRECISION TANH ROUTINE

; TRANSCRIBED FROM LIB40 V.21/EY/KK

; METHOD:
;
; IF ABS(X) < 0.00034, TANH(X) = X
;
; IF 0.00034 <= ABS(X) < 0.17, TANH(X) = F/(K1 + F^2*(K2 + K3
;
;	/(K4 + F^2)))
;
; WHERE F = 4*LOG2(E)*X
;
; IF 0.17 <= ABS(X) < 12.0, TANH(X) = (1 - 2/(1 + EXP(2*X))*SIGN(X)
;
; IF X >= 12.0, TANH(X) = SIGN(X)

; ON ENTRY:
; THE ARGUMENT (X) IS IN A0
; THE LINK IS ON THE STACK
; ON EXIT, THE RESULT IS IN A0
	SEARCH	ALGPRM,ALGSYS

	EXTLAB<104>
STDENT(113,TANH)
	MOVM	A5,A0	; MAGNITUDE OF ARGUMENT
	CAMGE	A5,[
	XWD	165544,410070]	; < 0.00034?
	JRST	TANH1		; YES - TANH(X) = X
	CAML	A5,[
	XWD	204600,000000]	; ABS(X) >= 12.0?
	JRST	TANH3		; YES - TANH(X) = SIGN(X)
	CAMGE	A5,[
	XWD	176534,121727]	; ABS(X) >= 0.17?
	JRST	TANH2		; NO
	FSC	A0,1
	PUSHJ	SP,LABEL(104)		; CALCULATE EXP(2*X)
	FADRI	A0,201400
	MOVSI	A1,575400
	FDVRM	A1,A0
	FADRI	A0,201400	; 1 - 2/(1 + EXP(2*ABS(X)))

TANH1:	POPJ	SP,0

TANH2:	FMPR	A0,TANH4	; F = 4*LOG2(E)*X
	MOVE	A1,A0
	FMPR	A1,A1
	MOVE	A2,A1		; FORM AND TAKE COPY OF F^2
	FADR	A1,TANH7	; ADD K4
	MOVE	A5,TANH6
	FDVR	A5,A1		; K3/(K4 + F^2)
	FADR	A5,TANH5	; + K2
	FMPR	A5,A2		; *F^2
	FADR	A5,TANH4	; + K1

TANH3:	FDVR	A0,A5
	POPJ	SP,0

TANH4:	XWD	203561,250731	; K1 = 4*LOG2(E)
TANH5:	XWD	173433,723376	; K2 = 1.73286795&-1
TANH6:	XWD	204704,333567	; K3 = 1.41384514
TANH7:	XWD	211535,527022	; K4 = 3.49669988&2

	LIT
	PRGEND
TITLE DEXP - DUMMY BODY FOR EXP

; REAL PROCEDURE EXP(X); VALUE X; REAL X;

	.EXIT=1
	.X=3
	SEARCH	ALGPRM,ALGSYS

	%ENTER<204>

	SALL

	EXTERNAL %ALGDR

	%SUBTTL(ALGLIB,ALGOL LIBRARY)

	EXTLAB<104>

LABEL(204):	JSP	AX,PARAM
	Z
	XWD	0,3
	XWD	$PRO!$R!$SIM,2
	XWD	$VAR!$R!$FOV,.X

	MOVE	A0,.X(DL)	; GET ARGUMENT
	PUSHJ	SP,LABEL(104)		; CALL EXP
	MOVEM	A0,.EXIT+1(DL)	; STORE RESULT
	JRST	.EXIT(DL)

	LIT
	PRGEND
TITLE EXP - SINGLE PRECISION EXPONENTIATION ROUTINE

; REWRITE OF LIB40 V.21/EY/KK/DMN

; METHOD:
;
; IF X < -89.416, EXP(X) = 0
;
; IF -89.416 <= X < 88.029:
;
; X = (N+Y)*LN(2), WHERE N IS AN INTEGER, AND 0 <= Y < 1
;
; EXP(X) = 2^(N+Y) = 2^N*2^Y
;
; WHERE 2^Y = 2*(0.5 + Y/(K1 - Y + K2*Y^2 + K3/(K4 + Y^2))
;
; IS DERIVED FROM THE PADE (4,4) APPROXIMATION

; ON ENTRY:
; THE ARGUMENT (X) IS IN A0
; THE LINK IS ON THE STACK
; ON EXIT, THE RESULT IS IN A0
	SEARCH	ALGPRM,ALGSYS
STDENT(104,EXP)
	CAMGE	A0,[
	XWD	570232,254037]	; X < -89.416?
	JRST	EXP1		; YES - QUICK EXIT
	CAML	A0,[
	XWD	207540,074636]	; X >= 88.029?
	LIBERR	2,@(SP)		; YES - COMPLAIN
	MULI	A0,400		; SEPARATE EXPONENT FROM MANTISSA
	MOVE	3,A0
	TSC	A3,A3		; GET POSITIVE EXPONENT
	MUL	A1,[
	XWD	270524,354513]	; MULTIPLY MANTISSA BY LOG2(E)
	ASHC	A1,-242(A3)	; SEPARATE INTEGER PART
	JUMPGE	A1,.+2
	ADDI	A1,1		; ADJUST IF NEGATIVE FRACTION
	JUMPG	A2,EXP6
	TRNE	A2,000377	; IF NECESSARY ...
	ADDI	A2,200		; DO A LITTLE ROUNDING

EXP6:	ASH	A2,-10
	TLC	A2,200000	; FORM Y
	FADRI	A2,000000	; NORMALIZE
	MOVE	A0,A2		; SAVE A COPY
	FMPR	A2,A2		; AND FORM Y^2
	MOVE	A3,A2
	FADR	A3,EXP5		; K4 + Y^2
	MOVE	A4,EXP4
	FDVR	A4,A3		; K3/(K4 + Y^2)
	FMPR	A2,EXP3
	FADR	A2,A4
	FADR	A2,EXP2
	FSBR	A2,A0		; K1 - Y + K2*Y^2 + K3/(K4 + Y^2)
	FDVR	A0,A2
	FADRI	A0,200400	; 0.5 + Y/(K1 - Y + K2*Y^2 + K3/(K4 + Y^2))
	FSC	A0,1(A1)	; MULTIPLY BY 2^(N+1)
	POPJ	SP,0

EXP1:	MOVEI	A0,0
	POPJ	SP,0

EXP2:	XWD	204476,430062	; K1 = 9.95459578
EXP3:	XWD	174433,723400	; K2 = 3.46573590&-2
EXP4:	XWD	565313,007063	; K3 = -6.17972270&2
EXP5:	XWD	207535,527022	; K4 = 8.74174972&1

	LIT
	PRGEND
TITLE DLSIN - DUMMY BODY FOR LSIN

; LONG REAL PROCEDURE LSIN(D); VALUE D; LONG REAL D;

	.EXIT=1
	.D=4
	SEARCH	ALGPRM,ALGSYS

	%ENTER<214>

	SALL

	EXTERNAL %ALGDR

	%SUBTTL(ALGLIB,ALGOL LIBRARY)

	EXTLAB<114>

LABEL(214):	JSP	AX,PARAM
	Z
	XWD	0,5
	XWD	$PRO!$LR!$SIM,2
	XWD	$VAR!$LR!$FOV,.D

	LRLOAD	A0,.D(DL)	; GET ARGUMENT
	PUSHJ	SP,LABEL(114)		; CALL LSIN
	LRSTOR	A0,.EXIT+1(DL)	; STORE RESULT
	JRST	.EXIT(DL)

	LIT
	PRGEND
TITLE DLCOS - DUMMY BODY FOR LCOS

; LONG REAL PROCEDURE LCOS(D); VALUE D; LONG REAL D;

	.EXIT=1
	.D=4
	SEARCH	ALGPRM,ALGSYS

	%ENTER<215>

	SALL

	EXTERNAL %ALGDR

	%SUBTTL(ALGLIB,ALGOL LIBRARY)

	EXTLAB<115>

LABEL(215):	JSP	AX,PARAM
	Z
	XWD	0,5
	XWD	$PRO!$LR!$SIM,2
	XWD	$VAR!$LR!$FOV,.D

	LRLOAD	A0,.D(DL)	; GET ARGUMENT
	PUSHJ	SP,LABEL(115)		; CALL LCOS
	LRSTOR	A0,.EXIT+1(DL)	; STORE RESULT
	JRST	.EXIT(DL)

	LIT
	PRGEND
TITLE LSIN /LCOS - DOUBLE PRECISION SINE/COSINE ROUTINES

; TRANSCRIBED FROM LIB40 V.022/.020/.005/KK/TWE

; METHOD:  SEE SCIENCE LIBRARY AND FORTRAN UTILITY SUBPROGRAMS
;          MANUAL

; ON ENTRY:
; THE ARGUMENT (X) IS IN A0,A1
; THE LINK IS ON THE STACK
; ON EXIT, THE RESULT IS IN A0,A1
	SEARCH	ALGPRM,ALGSYS


STDENT(115,LCOS)
	DFAD0	LSIN22		; COS(X)=SIN(PI/2+X), LEAVE RESULT IN A0
	JRST	LSIN0
STDENT(114,LSIN)

LSIN0:	JUMPE	A0,LSIN8	; ARGUMENT OF ZERO?
	SETZB	A6,A12		; SET FLAG FOR POSITIVE ARGUMENT
	JUMPGE	A0,LSIN1	; IS ARGUMENT POSITIVE?
	MOVNI	A12,1		; NO, CHANGE FLAG
	LRNEG	A0,A1		; NEGATE THE ARGUMENT

LSIN1:	LRLOAD	A7,A0
	DFDV0	LSIN22		; CALCULATE X/(PI/2)
	CAML	A0,LSIN21	; X < PI/2?
	JRST	LSIN10		; NO, REDUCE IT
	CAML	A0,[
	XWD	200400,000000]	; X >= PI/4
	MOVEI	A6,1		; YES, 2ND OCTANT

LSIN2:	LRLOAD	A0,A7
LSIN3:	TRNE	A6,4		; QUADRANTS 3 OR 4?
	SETCA	A12,0		; YES, SINE IS NEGATIVE
	JUMPE	A6,LSIN5	; X < PI/4
	TRNE	A6,1		; NO, GET INDEX INTO QUADRANT TABLE
	ADDI	A6,1		; ...

	DFAD0	LSIN20-2(A6)	; MAKE -PI/4 <= X < PI/4
	JUMPGE	A0,LSIN4
	LRNEG	A0,A1		; TAKE ABSOLUTE VALUE

LSIN4:	LRLOAD	A7,A0

LSIN5:	TRZ	A6,777775	; LEAVE ONLY OCTANT BIT
	HRRZ	A11,A6		; 0 FOR SINE SERIES, 2 FOR COSINE
	CAMG	A0,[
	XWD	147471,421605]	; X < SQRT(6)*2^(-27)?
	JRST	LSIN9		; YES, THEN SIN(X)=X
	DFMP0	A7		; CALCULATE X^2
	LRLOAD	A3,LSIN11(A6)	; INITIALIZE PARTIAL SUM
	MOVEI	A6,LSIN12(A6)	; TURN OCTANT POINTER INTO TABLE ADDRESS

LSIN6:	DFMP3	A0		; MULTIPLY PARTIAL SUM BY X^2
	DFAD3	0(A6)		; ADD NEXT CONSTANT TO PARTIAL SUM
	ADDI	A6,4		; MOVE POINTER TO NEXT CONSTANT
	CAIG	A6,LSIN19	; DONE?
	JRST	LSIN6		; NO, LOOP BACK FOR MORE OF SERIES
	DFMP0	A3		; YES, ONE MORE MULTIPLY
	DFAD0	LSIN21		; ADD 1.0 INTO SUM
	JUMPN	A11,LSIN7	; IS THIS COSINE SERIES?
	DFMP0	A7		; NO, MULTIPLY BY X, THIS IS SIN

LSIN7:	JUMPE	A12,LSIN8	; NEGATE RESULT?
	LRNEG	A0,A1		; YES

LSIN8:	POPJ	SP,0		; EXIT

LSIN9:	JUMPE	A6,LSIN7	; CALCULATING COSINE?
	LRLOAD	A0,LSIN21	; YES, COS(X)=1.0
	JRST	LSIN7
LSIN10:	MOVE	A3,A0		; SAVE QUADRANT NUMBER
	LDB	A6,[
	POINT	8,A0,8]		; GET EXPONENT
	IFE PROC-KA10,<
	LSH	A1,11		; WIPE OUT LOW EXPONENT>
	IFE PROC-KI10, <
	LSH	A1,1		; FOR KI10>
	TLZ	A0,777000	; DITTO HIGH EXPONENT
	LSHC	A0,-202(A6)	; MAKE ARGUMENT MODULO 2 PI
	LDB	A6,[
	POINT	3,A0,11]	; GET QUADRANT AND OCTANT BITS
	CAMGE	A3,[
	XWD	203400,000000]	; IS NON-REDUCED ARGUMENT OK?
	JRST	LSIN2		; YES, SAVE THE DFMP INACCURACIES
	TLZ	A0,777000	; MAKE WAY FOR EXPONENT
	IFE PROC-KA10, <
	FSC	A0,202		; PUT EXP IN HIGH WORD
	LSH	A1,-11		; MAKE WAY FOR LOW EXPONENT
	FSC	A1,202-^D27	; PUT IN LOW EXPONENT
	FADL	A0,A1		; UNNORMALIZE LOW WORD>
	IFE PROC-KI10, <
	TLO	A0,202000
	LSH	A1,-1
	DFAD	A0,[EXP 0,0]>
	DFMP0	LSIN22		; CHANGE MAKE TO RADIANS (MOD 2 PI)
	LRLOAD	A7,A0		; TEMPORARY X
	JRST	LSIN3		; GO CHANGE ARGUMENT TO 1ST OCTANT

LSIN11:	DOUBLE	120625130734,014126512326	; 1/17!=.28114572543455207632&&-14
	DOUBLE	124656376371,314734037043	; 1/16!=.47794773323873852974&&-13

LSIN12:	DOUBLE	647121401406,463043740735	; -1/15!=-.76471637318198164759&&-12
	DOUBLE	643154321325,717701542677	; -1/14! =-.11470745597729724714&&-10

LSIN13:	DOUBLE	140541110604,352066411370	; 1/13!=.16059043836821614599&&-9
	DOUBLE	144436733073,376154227552	; 1/12!=.20876756987868098979&&-8

LSIN14:	DOUBLE	630121467246,402535434340	; -1/11!=-.25052108385441718775&&-7
	DOUBLE	624330066022,441660243433	; -1/10!=-.27557319223985890653&&-6

LSIN15:	DOUBLE	156561674351,125543463437	; 1/9!=.27557319223985890653&&-5
	DOUBLE	161640064006,200320032003	; 1/8!=.24801587301587301587&&-4
LSIN16:	DOUBLE	613137713771,577457745775	; -1/7!=-.19841269841269841270&&-3
	DOUBLE	610223722372,517511751175	; -1/6!=-.1388888888888888889&&-2

LSIN17:	DOUBLE	172421042104,104210421042	; 1/5!=.00833333333333333333333
	DOUBLE	174525252525,125252525253	; 1/4!=.041666666666666666667

LSIN18:	DOUBLE	601252525252,652525252526	; -1/3!=-0.16666666666666666667

LSIN19:	DOUBLE	577400000000,000000000000	; -1/2!=-0.50000000000000000000

	PIOTLO=021026430215	; LOW HALF OF PI/2 FOR KI10

LSIN20:	DOUBLE	576155700452,-PIOTLO	; -PI/2
	DOUBLE	575155700452,-PIOTLO	; -PI
		574322320340	; -3*PI/2
IFE PROC-KA10,<	150146336134>
IFE PROC-KI10,<	463157055627>
	DOUBLE	574155700452,-PIOTLO	; -2*PI

LSIN21:	DOUBLE	201400000000,000000000000	; 1.0

LSIN22:	DOUBLE	201622077325,PIOTLO	; PI/2

	LIT
	PRGEND
TITLE DLARCTAN - DUMMY BODY FOR LARCTAN

; LONG REAL PROCEDURE LARCTAN(D); VALUE D; LONG REAL D;

	.EXIT=1
	.D=4
	SEARCH	ALGPRM,ALGSYS

	%ENTER<216>

	SALL

	EXTERNAL %ALGDR

	%SUBTTL(ALGLIB,ALGOL LIBRARY)

	EXTLAB<116>

LABEL(216):	JSP	AX,PARAM
	Z
	XWD	0,5
	XWD	$PRO!$LR!$SIM,2
	XWD	$VAR!$LR!$FOV,.D

	LRLOAD	A0,.D(DL)	; GET ARGUMENT
	PUSHJ	SP,LABEL(116)		; CALL LARCTAN
	LRSTOR	A0,.EXIT+1(DL)	; STORE RESULT
	JRST	.EXIT(DL)

	LIT
	PRGEND
TITLE LARCTAN - DOUBLE PRECISION ARCTANGENT ROUTINE

; TRANSCRIBED FROM LIB40 V.022/.020/.005/KK/TWE

; METHOD:

; THIS ROUTINE CALCULATES THE ACTANGENT OF A DOUBLE PRECISION
; ARGUMENT ACCORDING TO THE ALGORITHM

; ARCTAN(X) = LAMBDA*X/(Z+LTN11+LTN12/(Z+LTN13+LTN14/(Z+LTN15+LTN16/(Z+LTN17))))

; FOR X > 1.0, THE IDENTITY
; 			ARCTAN(X) = PI/2 - ARCTAN(1/X)
; IS USED. FOR 0.5 < X < 1.0, THE IDENTITY
; 			ARCTAN(X) = ARCTAN(1/2) + ARCTAN(2X-1/X+2)
; IS USED.
; FOR X < SQRT(3)*2^(-27), ARCTAN(X) = X IS USED

; ON ENTRY:
; THE ARGUMENT (X) IS IN A0,A1
; THE LINK IS ON THE STACK
; ON EXIT, THE RESULT IS IN A0,A1
	SEARCH	ALGPRM,ALGSYS

STDENT(116,LARCTAN)
	JUMPE	A0,LTN9		; ARGUMENT = 0?
	HLLZ	A6,A0		; LH(A6)=SGN(A0), RH(A6) = 0
	JUMPGE	A0,LTN1		; IS THE ARGUMENT POSITIVE?
	LRNEG	A0,A1		; NO, NEGATE IT

LTN1:	MOVSI	A3,201400	; GET DOUBLE PRECISION 1.0
	MOVEI	A4,0		; 0 LOW PART
	CAMN	A0,A3		; IS HIGH ORDER EQUAL TO 1.0?
	JUMPE	A1,LTN2		; YES, IS LOW ORDER ZERO?
	CAMGE	A0,A3		; NO, IS ARGUMENT > 1.0?
	JRST	LTN2		; NO
	TLC	A6,400000	; COMPLEMENT FINAL SIGN BIT, GET 1/X
	IORI	A6,2		; ADD -PI/2 TO FINAL ANSWER
	DFDV3	A0
	LRLOAD	A0,A3

LTN2:	LRLOAD	A10,A0
	CAMGE	A0,[0.236]	; IS ARGUMENT >= SQRT(5)-2 ?
	JRST	LTN3		; NO, PROCEED WITH ALGORITHM
				; CALCULATE X+2
	DFAD0	LTN21
	EXCH	A0,A10		; GET X, SAVE X+2
	EXCH	A1,A11		; ...
	FSC	A0,1		; CALCULATE 2X
	IFE PROC-KA10, <
	FSC	A1,1		; ...
	FADL	A0,A1		; ...>
				; CALCULATE 2X-1
	DFAD0	LTN20
				; (2X-1)/(X+2) WITH RESULTS IN A0,A1
	DFDV0	A10
	LRLOAD	A10,A0
	IORI	A6,1		; SET FLAG TO LATER ADD ARCTAN(1/2)

LTN3:	MOVM	A3,A0
	CAMGE	A3,LTN23	; [E536]CAN ATAN(X)=X?
EDIT (536)	; LARCTAN GAVE WRONG ANSWERS
	JRST	LTN6		; YES
	DFMP0	A10		; CALCULATE X^2
	LRLOAD	A12,A0
	LRLOAD	A0,LTN17	; INITIALIZE CONTINUED FRACTION
				; COMPARISON WITH LTN17
	MOVEI	A7,LTN17	; INITIALIZE POINTER TO NUMBER TABLE
	JRST	LTN5		; ENTER LOOP

LTN4:	DFAD0	0(A7)		; ADD LTN13

LTN5:	DFAD0	A12		; ADD X^2
	LRLOAD	A3,-2(A7)	; GET LTN16 (OR LTN12)
	DFDV3	A0
	DFAD3	-4(A7)		; ADD LTN15 (OR LTN11)
	DFAD3	A12		; ADD X^2
	LRLOAD	A0,-6(A7)	; GET LTN14 (OR LAMBDA)
	DFDV0	A3
	SUBI	A7,10		; DECREMENT TABLE POINTER
	CAILE	A7,LTN10	; FINISHED?
	JRST	LTN4		; NO, DO IT LAST TIME
	DFMP0	A10		; MULTIPLY BY X

LTN6:	IFE PROC-KA10, <
	TRNN	A6,1		; ADD ARCTAN(1/2)?
	JRST	LTN7		; NO
	DFAD0	LTN18

LTN7:	TRNN	A6,2		; ADD -PI/2?
	JRST	LTN8		; NO
	DFAD0	LTN22

LTN8:>
	IFE	PROC-KI10, <
	TRNE	A6,1		; [E536]
EDIT (536)	; LARCTAN GAVE WRONG ANSWERS
	DFAD0	LTN18
	TRNE	A6,2
	DFAD0	LTN22>

	JUMPGE	A6,LTN9		; NEGATE RESULT?
	LRNEG	A0,A1		; YES

LTN9:	POPJ	SP,0		; EXIT


LTN10:	DOUBLE	204613772770,017027645561	; 12.37469 38775 51020 40816

LTN11:	DOUBLE	205644272446,121335250615	; 26.27277 52490 26980 67155

LTN12:	DOUBLE	570276502107,437176661671	; -80.34270 56102 16599 70467

LTN13:	DOUBLE	203627237361,165414142742	; 6.36424 16870 04411 34492

LTN14:	DOUBLE	576316772502,512470127251	; -1.19144 72238 50426 48905

LTN15:	DOUBLE	202415301602,015271031674	; 2.10451 89515 40978 95180

LTN16:	DOUBLE	602277106546,717167531241	; -0.07833 54278 56532 11777

LTN17:	DOUBLE	201502125320,370207664057	; 1.25846 41124 27629 031727

LTN18:	DOUBLE	177732614701,130335517321	; ATAN(1/2)
LTN19:	XWD	200400,000000	; 0.5
LTN20:	DOUBLE	576400000000,000000000000	; -1.0

LTN21:	DOUBLE	202400000000,000000000000	; EXP 2.0

LTN22:	DOUBLE	576155700452,756751347563	; -PI/2

LTN23:	XWD	146673,317272	; SQRT(3)*2^(-27)

	LIT
	PRGEND
TITLE DLSQRT - DUMMY BODY FOR LSQRT

; LONG REAL PROCEDURE LSQRT(D); VALUE D; LONG REAL D;

	.EXIT=1
	.D=4
	SEARCH	ALGPRM,ALGSYS

	%ENTER<217>

	SALL

	EXTERNAL %ALGDR

	%SUBTTL(ALGLIB,ALGOL LIBRARY)

	EXTLAB<117>

LABEL(217):	JSP	AX,PARAM
	Z
	XWD	0,5
	XWD	$PRO!$LR!$SIM,2
	XWD	$VAR!$LR!$FOV,.D

	LRLOAD	A0,.D(DL)	; GET ARGUMENT
	PUSHJ	SP,LABEL(117)		; CALL SQRT
	LRSTOR	A0,.EXIT+1(DL)	; STORE RESULT
	JRST	.EXIT(DL)

	LIT
	PRGEND
TITLE LSQRT  - DOUBLE PRECISION SQUARE ROOT ROUTINE

; TRANSCRIBED FROM LIB40 V.022/.020/.005/KK/TWE

; METHOD:

; THIS ROUTINE CALCULATES THE SQUARE ROOT OF A DOUBLE PRECISION
; ARGUMENT BY DOING A LINEAR SINGLE PRECISION APPROXIMATION ON
; THE HIGH ORDER WORD, THEN TWO DOUBLE PRECISION ITERATIONS OF
; NEWTONS METHOD. THIS SHOULD GENERATE A RESULT ACCURATE TO
; 20 SIGNIFICANT DECIMAL DIGITS. THE ALGORITHM IS AS FOLLOWS
; X = (2^(2N))*F, WHERE 1/2 < F < 1
; HENCE SQRT(X) = 2^N*SQRT(F)
; THE LINEAR APPROXIMATION IS OF THE FORM
; SQRT(F) = LSQ3 - LSQ4/(LSQ5+F-LSQ6/(LSQ7+F))
; WHERE THE CONSTANTS LSQ3,LSQ4,LSQ5,LSQ6, AND LSQ7 HAVE THE FOLLOWING
; VALUES
; CONSTANT	VALUE WHEN 0.25<F<0.50	VALUE WHEN 0.50<F<1.0
; LSQ3		(5/14)*SQRT(70)		(5/7)*SQRT(35)
; LSQ4		(50/49)*SQRT(70)	(200/49)*SQRT(35)
; LSQ5		47/14			47/7
; LSQ6		4/49			16/49
; LSQ7		3/14			3/7

; ON ENTRY:
; THE ARGUMENT (X) IS IN A0,A1
; THE LINK IS ON THE STACK
; ON EXIT, THE RESULT IS IN A0,A1
	SEARCH	ALGPRM,ALGSYS

STDENT(117,LSQRT)
	JUMPE	A0,LSQ2		; ARGUMENT OF ZERO?
	JUMPGE	A0,.+2		; IS ARGUMENT POSITIVE?
	LIBERR	0,@(SP)		; NO, COMPLAIN
	MOVE	A5,A0		; GET SPARE COPY OF HIGH ORDER
	LSH	A5,-33		; GET RID OF FRACTION BITS
	SUBI	A5,201		; GET RID OF THE BASE 200 PART OF
				; EXPONENT. EXTRA 1 IS A FUDGE.
	ROT	A5,-1		; CUT EXPONENT IN HALF, SAVE EXTRA
				; BIT FOR LATER USE AS INDEX REG.
	HRRZ	A11,A5		; SAVE REDUCED EXPONENT FOR SCALING
	LSH	A5,-43		; BRING BIT BACK - IF 0, THEN
				; 1/4<A5<1/2,OTHERWISE 1/2<A5<1.
	TLZ	A0,777000	; WIPE OUT EXPONENT BITS IN ARG.
	FSC	A0,177(A5)	; RESET IT TO EITHER 177 OR 200
	IFE PROC-KA10, <
	TLZ	A1,777000	; WIPE OUT EXPONENT BITS IN LOW ARGUMENT
	FSC	A1,177-^D27(A5)	; SET IT TO 27 LESS THAN HIGH PART
	FADL	A0,A1		; UNNORMALIZE LOW PART>
	MOVE	A3,A0		; PICK UP ANOTHER COPY OF NEW FRAC.
	FADR	A3,LSQ7(A5)	; FORM LSQ7+F
	MOVN	A2,LSQ6(A5)	; PICK UP -LSQ6
	FDVR	A2,A3		; CALCULATE -LSQ6/(LSQ7+F)
	FADR	A2,LSQ5(A5)	; GET LSQ5-LSQ6/(LSQ7+F)
	FADR	A2,A0		; CALCULATE F+LSQ5-LSQ6/(LSQ7+F)
	MOVN	A3,LSQ4(A5)	; PICK UP -LSQ4
	FDVR	A3,A2		; GET -LSQ4/(F+LSQ5-LSQ6/(LSQ7+F))
	FADR	A3,LSQ3(A5)	; GET FINAL FIRST APPROXIMATION
	MOVEI	A4,0		; LOW HALF OF 1ST APPROX. IS 0
	LRLOAD	A7,A0		; SAVE LSQRT ARGUMENT
	DFDV0	A3		; GET N/X0
	DFAD0	A3		; X0+N/X0
	FSC	A0,-1		; X1=.5*(X0+N/X0)
	IFE PROC-KA10, <
	FSC	A1,-1		; ...
	FADL	A0,A1		; UNNORMALIZE LOW WORD>
	EXCH	A0,A7		; GET ARGUMENT INTO AC, SAVE X1
	EXCH	A1,A10		; ...
				; N/X1
	DFDV0	A7
				; X1+N/X1
	DFAD0	A7

LSQ1:	FSC	A0,(A11)	; SCALE RESULTS FOR ANSWER 
	IFE PROC-KA10, <
	FSC	A1,(A11)	; ...
	FADL	A0,A1>

LSQ2:	POPJ	SP,0		; EXIT

LSQ3:	XWD	202576,362203	; 2.98807152
	XWD	203416,346045	; 4.225771271
LSQ4:	XWD	204421,143713	; 8.537347194
	XWD	205602,266310	; 24.14726441

LSQ5:	XWD	202655,555556	; 3.357142857
	XWD	203655,555556	; 6.7142857143

LSQ6:	XWD	175516,274052	; 0.0816326531
	XWD	177516,274052	; 0.326530612

LSQ7:	XWD	176666,666667	; 0.2142857143
	XWD	177666,666667	; 0.4285714286

	LIT
	PRGEND
TITLE DLEXP - DUMMY BODY FOR LEXP

; LONG REAL PROCEDURE LEXP(D); VALUE D; LONG REAL D;

	.EXIT=1
	.D=4
	SEARCH	ALGPRM,ALGSYS

	%ENTER<220>

	SALL

	EXTERNAL %ALGDR

	%SUBTTL(ALGLIB,ALGOL LIBRARY)

	EXTLAB<120>

LABEL(220):	JSP	AX,PARAM
	Z
	XWD	0,5
	XWD	$PRO!$LR!$SIM,2
	XWD	$VAR!$LR!$FOV,.D

	LRLOAD	A0,.D(DL)	; GET ARGUMENT
	PUSHJ	SP,LABEL(120)		; CALL LEXP
	LRSTOR	A0,.EXIT+1(DL)	; STORE RESULT
	JRST	.EXIT(DL)

	LIT
	PRGEND
TITLE LEXP - DOUBLE PRECISION EXPONENTIAL FUNCTION

; TRANSCRIBED FROM LIB40 V.022/.020/.005/KK/TWE

; METHOD:

; THE ROUTINE USES THE FOLLOWING ALGORITHM:
; EXP(X) = 2^(X*LOG2(E))
; 	= 2^(M+F) WHERE M IS AN INTEGER AND 0 < F < 1
; 	= 2^(M+N+R) WHERE 0 < R < 1/8 AND M+N+R = X*LOG2(E)
; 	= 2^(M+N)*EXP(R*LN(2))
; 2^M IS CALCULATED EASILY WITH THE FLOATING SCALE INSTRUCTION.
; 2^N IS CALCULATED BY DETERMINING THE CORRECT INTERVAL OF N AND
; USING A TABLE OF POWERS OF TWO FROM 2^1/8 TO 2^7/8.
; FINALLY, EXP(R*LN(2)) IS CALCULATED BY A CONTINUED FRACTION

; TAKEN FROM RALSTON AND WILF, "METHODS FOR DIGITAL COMPUTERS" :
; EXP(R*LN(2)) = 1+E/((LEXP9/R) - C4 + LEXP11*R + LEXP12/(R + LEXP9/R))

; ON ENTRY:
; THE ARGUMENT (X) IS IN A0,A1
; THE LINK IS ON THE STACK
; ON EXIT, THE RESULT IS IN A0,A1
	SEARCH	ALGPRM,ALGSYS

STDENT(120,LEXP)
	JUMPE	A0,[
	MOVSI	A0,(1.0)	; RETURN 1.0 FOR ARGUMENT OF ZERO
	JRST	LEXP3]		; EXIT
	MOVM	A2,A0		; GET MAGNITUDE OF ARGUMENT
	CAML	A2,LEXP4	; IN RANGE?
	JRST	[
	MOVE	A3,A0		; TAKE COPY OF HIGH ORDER WORD
	SETZB	A0,A1
	JUMPL	A3,LEXP3	; ARGUMENT < 0?
	LIBERR	2,@(SP)]
	DFMP0	LEXP5
	HLRE	A4,A0		; EXTRACT EXPONENT
	ASH	A4,-11		; ...
	TSC	A4,A4		; TAKE 1'S COMPLEMENT IF NUM < 0
	IFE PROC-KA10, <
	LSH	A1,10		; REMOVE LOW ORDER EXPONENT>
	JUMPGE	A0,.+2		; CHANGE EXPONENT BITS TO SIGN BITS
	TLOA	A0,377000	; NUMBER NEGATIVE, SET BITS
	TLZ	A0,377000	; NUMBER POSITIVE, CLEAR BITS
	ASHC	A0,10		; LEFT JUSTIFY ARGUMENT FRACTION BITS
				; GET ANOTHER COPY OF FRACTION
	LRLOAD	A2,A0
	ASHC	A0,-243(A4)	; SIMULATE THREE-WORD SHIFT WITH...
				; TWO LONG SHIFTS. THIS LEAVES INTEGER
				; IN A0, FRACTION IN A1 AND C.
	LSH	A3,1		; SQUEEZE OUT SIGN BIT
	LSHC	A2,43-200(A4)	; THEN DO 2ND LONG SHIFT, (THE LSHC HERE
				; PREVENTS OVERFLOW GOING LEFT)
	TLZ	A1,400000	; CLEAR SIGN BIT. IF FRACTION WAS < 0,
				; THIS GIVES 1-FRACTION AND PROPER EXPONENT
	HRRZ	A7,A0		; SAVE EXPONENT FOR FUTURE SCALING
	MOVEI	A6,7		; GET INDEX REGISTER POINTER TO TABLE

LEXP1:	CAMN	A1,LEXP6(A6)	; DOES ARGUMENT MATCH TABLE ENTRY?
	JUMPE	A2,[
	LSH	A6,1		; YES, IF LOW HALF = 0. CHANGE INDEX TO POINTER
	LRLOAD	A0,LEXP7(A6)	; PICK UP DOUBLE WORD ANSWER
	JRST	LEXP2]		; SCALE RESULTS AND EXIT
	CAMGE	A1,LEXP6(A6)	; IS ARGUMENT GREATER THAN ENTRY?
	SOJA	A6,LEXP1	; NO, TRY NEXT LOWER ENTRY
	SUB	A1,LEXP6(A6)	; YES, ALL DONE -REDUCE ARGUMENT
	LSH	A6,1		; SAVE INDEX AS A0 POINTER
	ASHC	A1,-10		; MAKE ROOM FOR EXPONENT
	IFE PROC-KA10, <
	MOVE	A0,A1		; SET UP ARG. FOR NORMALIZING
	ASH	A2,-10		; MAKE ROOM FOR LOW ORDER EXPONENT
	FSC	A0,200		; SET EXP TO 200
	FSC	A2,200-^D27	; SET EXP 27 LOWER
	FADL	A0,A2		; MAKE STANDARD NUMBER>
	IFE PROC-KI10, <
	TLO	A1,200000
	DFAD	A1,[EXP 0,0]
	LRLOAD	A0,A1>
	LRLOAD	A3,LEXP9	; GET LEXP9/F
	DFDV3	A0
	LRLOAD	A10,A3		; SAVE LEXP9/F
	DFAD3	A0		; GET F+LEXP9/F
	LRLOAD	A12,A3		; GET LEXP12/(F+LEXP9/F)
	LRLOAD	A3,LEXP12
	DFDV3	A12
	DFMP0	LEXP11		; GET LEXP11*F
	DFAD3	A0		; GET (LEXP9/F)-C4+LEXP11*F+(LEXP12/(F+LEXP9/F))
	DFAD3	LEXP10
	DFAD3	A10
	LRLOAD	A0,LEXP8	; GET 1.0+E/REST
	DFDV0	A3
	DFAD0	LEXP7
	JUMPE	A6,LEXP2	; MULTIPLY BY POWER OF TWO?
	DFMP0	LEXP7(A6)

LEXP2:	FSC	A0,(A7)		; SCALE RESULTS
	IFE PROC-KA10, <
	FSC	A1,(A7)
	JFCL	17,.+1		; IGNORE UNDERFLOW 
	FADL	A0,A1		; MAKE STANDARD NUMBER>

LEXP3:	POPJ	SP,0		; EXIT

LEXP4:	XWD	207540,071260	; 88.028

LEXP5:	DOUBLE	201561250731,112701376057	; LOG2(E) =  1.44269 50408 88963 40740

LEXP6:	XWD	000000,000000
	XWD	040000,000000	; 1/8
	XWD	100000,000000	; 2/8
	XWD	140000,000000	; 3/8
	XWD	200000,000000	; 4/8
	XWD	240000,000000	; 5/8
	XWD	300000,000000	; 6/8
	XWD	340000,000000	; 7/8

LEXP7:	DOUBLE	201400000000,000000000000	; 2^0 = 1.0
	DOUBLE	201427127017,037250572672	; 2^1/8 = 1.09050 77326 65257 65919
	DOUBLE	201460337602,214333425134	; 2^2/8 = 1.18920 71150 02721 06671
	DOUBLE	201513773265,115425047073	; 2^3/8 = 1.29683 95546 51009 66590
	DOUBLE	201552023631,237635714441	; 2^4/8 = 1.41421 35623 73095 04878
	DOUBLE	201612634520,212520333270	; 2^5/8 = 1.54221 08254 07940 824
	DOUBLE	201656423746,126551655275	; 2^(6/8) = 1.68179 28305 07429 086
	DOUBLE	201725403067,076722207113	; 2^(7/8) = 1.83400 80864 09342 463

LEXP8:	DOUBLE	206744575555,062215755376	; LEXP8 = 60.59319 17173 36463 11080

LEXP9:	DOUBLE	207535527021,213670572221	; LEXP9 = 87.41749 72022 35527 474

LEXP10:	DOUBLE	572033202222,715562022402	; LEXP10 = -C4 = -30.29659 58586 68231 555

LEXP11:	DOUBLE	201414631463,063146314632	; LEXP11 = 1.05

LEXP12:	DOUBLE	210654261010,261565402456	; LEXP12 = 214.17286 81454 77042 3113

	LIT
	PRGEND

TITLE DLLN - DUMMY BODY FOR LLN

; LONG REAL PROCEDURE LLN(D); VALUE D; LONG REAL D;

	.EXIT=1
	.D=4
	SEARCH	ALGPRM,ALGSYS

	%ENTER<221>

	SALL

	EXTERNAL %ALGDR

	%SUBTTL(ALGLIB,ALGOL LIBRARY)

	EXTLAB<121>

LABEL(221):	JSP	AX,PARAM
	Z
	XWD	0,5
	XWD	$PRO!$LR!$SIM,2
	XWD	$VAR!$LR!$FOV,.D

	LRLOAD	A0,.D(DL)	; GET ARGUMENT
	PUSHJ	SP,LABEL(121)		; CALL LLN
	LRSTOR	A0,.EXIT+1(DL)	; STORE RESULT
	JRST	.EXIT(DL)

	LIT
	PRGEND
TITLE LLN - DOUBLE PRECISION LOGARITHM FUNCTION

; TRANSCRIBED FROM LIB40 V.022/.020/.005/KK/TWE

; METHOD:
; THIS PROGRAM CALCULATES THE LOGARITHM OF A DOUBLE PRECISION
; ARGUMENT. THE ALGORITHM USED IS DESCRIBED ON PAGES 29-30 OF
; RALSTON AND WILF, "MATHEMATICAL METHODS FOR DIGITAL COMPUTERS".
; THE ARGUMENT X IS WRITTEN AS
; 	X = (2^N)*F	WHERE 1/2 < F < 1
; THEN LN(X) = (N*LN(2)) + LN(F)
; F IS REDUCED BY FIXED POINT MULTIPLICATION BY NOT MORE THAN
; THREE CONSTANTS. THIS YIELDS
; 	0 < T = K1*K2*K3*F - 1.0 < (2^(-7))/5
; NOTE THAT NOT ALL THE K1,K2,K3 NEED BE INCLUDED IN THE PRODUCT.
; FINALLY, 
; 	LN(F) = LN(1+T) - LN(K1) - LN(K2) - LN(K3)
; LN(1+T) IS CALCULATED AS A TAYLOR SERIES IN T.
	SEARCH	ALGPRM,ALGSYS

; ON ENTRY:
; THE ARGUMENT (X) IS IN A0,A1
; THE LINK IS ON THE STACK
; ON EXIT, THE RESULT IS IN A0,A1

STDENT(121,LLN)
	JUMPG	A0,.+2		; ARGUMENT <= 0?
	LIBERR	1,@(SP)		; YES, COMPLAIN
	CAMN	A0,LLN17	; X PRECISELY 1.0?
	JUMPE	A1,[
	MOVEI	A0,0
	JRST	LLN5]		; YES, RETURN ZERO

LLN1:	LDB	A3,[
	POINT	8,A0,8]		; NO, PICK UP EXPONENT FROM HIGH ORDER
	SUBI	A3,200		; GET EXPONENT EXCESS 200
	FSC	A3,233		; MAKE FLOATING POINT NUMBER
	MOVEI	A4,0		; SET UP LOW HALF
				; CALCULATE N*LN(2)
	DFMP3	LLN8
	LRLOAD	A7,A3
EDIT(621) ; TEST FOR CORRECT PROCESSOR, IDIOT !!
; [E621] IFE PROC-KI10<
IFE PROC-KA10<	; [E621]
	LSH	A1,10		; GET RID OF LOW ORDER EXPONENT>
	TLZ	A0,777000	; MASK OUT EXPONENT
	ASHC	A0,10		; NORMALIZE FRACTION TO BIT 1
	SETZB	A3,A4		; INITIALIZE REDUCTION CONSTANT TO 0

LLN2:	LDB	A6,[
	POINT	3,A0,4]		; GET HIGH 3 BITS BELOW 1/2
	MUL	A1,LLN7(A6)	; FIXED POINT MULTIPLY FOR LOW HALF
	MOVE	A2,A1		; SAVE HIGH HALF OF LOW PRODUCT
				; (LOW HALF IS ALL 0'S, THROW IT AWAY)
	MUL	A0,LLN7(A6)	; MULTIPLY HIGH ORDER, TOO
	TLO	A1,400000	; SET BIT 0, TO AVOID OVERFLOW
	ADD	A1,A2		; COMBINE RESULTS OF MULTIPLY
	TLZN	A1,400000	; CLEAR BIT 0, WAS THERE OVERFLOW?
	ADDI	A0,1		; YES, PROPOGATE CARRY
	ASH	A6,1		; TURN BITS INTO D.P. POINTER
	DFAD3	LLN6(A6)
	TLZE	A0,200000	; IS THE PRODUCT >= 1.0?
	JRST	LLN3		; YES
	ASHC	A0,1		; NO, GET RID OF EXTRANEOUS ZERO
	JRST	LLN2		; TRY ANOTHER MULTIPLICATION


LLN3:	ASHC	A0,-7		; MAKE ROOM FOR THE EXPONENT
IFE PROC-KA10<
	FSC	A0,200		; SET EXPONENT TO 200
	ASH	A1,-10		; MAKE ROOM FOR LOW EXPONENT
	FSC	A1,200-^D27	; INSERT LOW EXPONENT
	FADL	A0,A1		; MAKE NORMAL DOUBLE PRECISION NUMBER>
IFE PROC-KI10 <
	TLC	A0,200000	; INSERT EXPONENT
	DFAD0	LLN18		; NORMALIZE>
	LRNEG	A3,A4		; NEGATE LOG OF MAGIC NUMBERS
				; AND ADD INTO FINAL SUMMATION
	DFAD3	A7
	LRLOAD	A7,A3
	LRLOAD	A3,LLN9		; PICK UP CONSTANT TO START
	MOVEI	A6,LLN10	; INITIALIZE TABLE POINTER AT LLN10

LLN4:	DFMP3	A0		; MULTIPLY ACCUMULATED SUM BY X
	DFAD3	0(A6)		; ADD NEXT CONSTANT INTO PARTIAL SUM
	ADDI	A6,2		; UPDATE POINTER TO NEXT CONSTANT
	CAIG	A6,LLN17	; ARE WE DONE YET?
	JRST	LLN4		; NO, LOOP BACK FOR MORE TAYLOR SERIES
	DFMP0	A3		; YES, ONE LAST MULTIPLICATION
	DFAD0	A7		; AND ADD SERIES SUM INTO FINAL ANSWER
LLN5:	POPJ	SP,0		; EXIT

LLN6:	DOUBLE	200471174064,325425031470	; 0.61180 15411 05992 8976
	DOUBLE	200402252251,151350376610	; 0.50455 60107 52395 2859
	DOUBLE	177637144373,057714113734	; 0.40546 51081 08164 3810
	DOUBLE	177506061360,207057302360	; 0.31845 37311 18534 6147
	DOUBLE	176710776761,346515041520	; 0.22314 35513 14209 7553
	DOUBLE	176537746034,051711723600	; 0.17185 02569 26659 2214
	DOUBLE	175557032242,271265512760	; 0.08961 21586 89687 12374
	DOUBLE	173770123303,236031377700	; 0.03077 16586 66753 68689

LLN7:	XWD	354000,000000	; 1.11011 BINARY
	XWD	324000,000000	; 1.10101 BINARY
	XWD	300000,000000	; 1.10000 BINARY
	XWD	260000,000000	; 1.01100 BINARY
	XWD	240000,000000	; 1.01000 BINARY
	XWD	230000,000000	; 1.00110 BINARY
	XWD	214000,000000	; 1.00011 BINARY
	XWD	204000,000000	; 1.00001 BINARY

LLN8:	DOUBLE	200542710277,276434757143	; 0.69314 71805 59945 30941 72321

LLN9:	DOUBLE	175707070707,0343434344	; 1/9

LLN10:	DOUBLE	601400000000,000000000000	; -1/8

LLN11:	DOUBLE	176444444444,222222222222	; 1/7

LLN12:	DOUBLE	601252525252,652525252526	; -1/6

LLN13:	DOUBLE	176631463146,146314631463	; 1/5

LLN14:	DOUBLE	600400000000,000000000000	; -1/4
LLN15:	DOUBLE	177525252525,125252525253	; 1/3

LLN16:	DOUBLE	577400000000,000000000000	; -1/2

LLN17:	XWD	201400,000000	; 1.0
LLN18:	XWD	000000,000000	; FOR KI10 DOUBLE-LENGTH ZERO
IFE PROC-KI10 <
	XWD	000000,000000>

	LIT
	PRGEND
TITLE DFAD0 - KA10/KI10 DOUBLE PRECISION ADD (A0,A1)

; ON ENTRY:
; THE LEFT HAND OPERAND IS IN A0,A1
; THE RIGHT HAND OPERAND IS ADDRESSED BY AX
; THE LINK IS ON THE STACK
; ON EXIT, THE RESULT IS IN A0,A1
	SEARCH	ALGPRM,ALGSYS

	%ENTER<17>


	SALL

%SUBTTL(ALGLIB,ALGOL LIBRARY)

LABEL(17):
	IFE	PROC-KA10,<
	UFA	A1,1(AX)	; ADD LOW ORDER PARTS IN A2
	FADL	A0,(AX)		; ADD HIGH ORDER PARTS IN A0,A1
	UFA	A1,A2		; ADD LOW PART OF HIGH SUM TO A2
	FADL	A0,A2		; ADD LOW SUM TO HIGH SUM
	POPJ	SP,0>

	IFE	PROC-KI10,<
	DFAD	A0,(AX)
	POPJ	SP,0>

	LIT
	PRGEND
TITLE DFSB0 - KA10/KI10 DOUBLE PRECISION SUBTRACT (A0,A1)

; ON ENTRY:
; THE LEFT HAND OPERAND IS IN A0,A1
; THE RIGHT HAND OPERAND IS ADDRESSED BY AX
; THE LINK IS ON THE STACK
; ON EXIT, THE RESULT IS IN A0,A1
	SEARCH	ALGPRM,ALGSYS

	%ENTER<20>


	SALL

%SUBTTL(ALGLIB,ALGOL LIBRARY)

LABEL(20):
	IFE	PROC-KA10,<
	LRNEG	A0,A1		; NEGATE LEFT HAND OPERAND
	UFA	A1,1(AX)
	FADL	A0,(AX)
	UFA	A1,A2
	FADL	A0,A2		; ADD RIGHT HAND OPERAND
	LRNEG	A0,A1		; AND NEGATE RESULT
	POPJ	SP,0>

	IFE	PROC-KI10,<
	DFSB	A0,(AX)
	POPJ	SP,0>

	LIT
	PRGEND
TITLE DFMP0 - KA10/KI10 DOUBLE PRECISION MULTIPLY (A0,A1)

; ON ENTRY:
; THE LEFT HAND OPERAND IS IN A0,A1
; THE RIGHT HAND OPERAND IS ADDRESSED BY AX
; THE LINK IS ON THE STACK
; ON EXIT, THE RESULT IS IN A0,A1
	SEARCH	ALGPRM,ALGSYS

	%ENTER<21>


	SALL

%SUBTTL(ALGLIB,ALGOL LIBRARY)

LABEL(21):
	IFE	PROC-KA10,<
	MOVE	A2,A0		; COPY HIGH WORD OF LEFT HAND OPERAND
	FMPR	A2,1(AX)	; FORM ONE CROSS PRODUCT IN A2
	JFOVO	DFMP01		; SPECIAL UNDERFLOW HANDLING
	FMPR	A1,(AX)		; FORM OTHER CROSS PRODUCT IN A1
	JFOVO	DFMP01		; SPECIAL UNDERFLOW HANDLING
	UFA	A1,A2		; ADD CROSS PRODUCTS IN A2
	FMPL	A0,(AX)		; FORM HIGH ORDER PRODUCT IN A0,A1
	UFA	A1,A2		; ADD CROSS PRODUCTS SUM TO LOW PART
	FADL	A0,A2		; ADD TOGETHER LOW AND HIGH PARTS OF RESULT
	POPJ	SP,0

DFMP01:	SYSER2	2,0>		; OVERFLOW

	IFE	PROC-KI10,<
	DFMP	A0,(AX)
	POPJ	SP,0>

	LIT
	PRGEND
TITLE DFDV0 - KA10/KI10 DOUBLE PRECISION DIVIDE (A0,A1)

; ON ENTRY:
; THE LEFT HAND OPERAND IS IN A0,A1
; THE RIGHT HAND OPERAND IS ADDRESSED BY AX
; THE LINK IS ON THE STACK
; ON EXIT, THE RESULT IS IN A0,A1
	SEARCH	ALGPRM,ALGSYS

	%ENTER<22>


	SALL

%SUBTTL(ALGLIB,ALGOL LIBRARY)

LABEL(22):
	IFE	PROC-KA10,<
	FDVL	A0,(AX)		; GET HIGH PART OF QUOTIENT
	MOVN	A2,A0		; AND NEGATE IT
	FMPR	A2,1(AX)	; MULTIPLY BY LOW PART OF DIVISOR
	JFOVO	DFDV01		; SPECIAL UNDERFLOW HANDLING
	UFA	A1,A2		; ADD REMAINDER
	FDVR	A2,(AX)		; DIVIDE SUM BY HIGH PART OF DIVISOR
	FADL	A0,A2		; ADD RESULT TO ORIGINAL QUOTIENT
	POPJ	SP,0

DFDV01:	SYSER2	2,0>		; OVERFLOW

	IFE	PROC-KI10,<
	DFDV	A0,(AX)
	POPJ	SP,0>

	LIT
	PRGEND
TITLE RDFSB0 - KA10/KI10 DOUBLE PRECISION REVERSE SUBTRACT (A0,A1)

; ON ENTRY:
; THE LEFT HAND OPERAND IS IN A0,A1
; THE RIGHT HAND OPERAND IS ADDRESSED BY AX
; THE LINK IS ON THE STACK
; ON EXIT, THE RESULT IS IN A0,A1
	SEARCH	ALGPRM,ALGSYS

	%ENTER<23>


	SALL

%SUBTTL(ALGLIB,ALGOL LIBRARY)

LABEL(23):	IFE PROC-KA10, <
	LRNEG	A0,A1		; NEGATE LEFT HAND OPERAND
	UFA	A1,1(AX)
	FADL	A0,(AX)
	UFA	A1,A2
	FADL	A0,A2		; ADD RIGHT HAND OPERAND
	POPJ	SP,0>

	IFE PROC-KI10, <
	DMOVN	A0,A0		; NEGATE LEFT HAND OPERAND
	DFAD	A0,(AX)		; ADD RIGHT HAND OPERAND
	POPJ	SP,0>

	LIT
	PRGEND
TITLE RDFDV0 - KA10/KI10 DOUBLE PRECISION REVERSE DIVIDE (A0,A1)

; ON ENTRY:
; THE LEFT HAND OPERAND IS IN A0,A1
; THE RIGHT HAND OPERAND IS ADDRESSED BY AX
; THE LINK IS ON THE STACK
; ON EXIT, THE RESULT IS IN A0,A1
	SEARCH	ALGPRM,ALGSYS

	%ENTER<24>


	SALL

%SUBTTL(ALGLIB,ALGOL LIBRARY)

LABEL(24):	IFE PROC-KA10, <
	LRSTOR	A0,%SYS12(DB)	; SAVE LEFT HAND OPERAND
	LRLOAD	A0,(AX)		; AND LOAD RIGHT HAND OPERAND
	FDVL	A0,%SYS12(DB)
	MOVN	A2,A0
	FMPR	A2,%SYS13(DB)
	JFOVO	DFDV02
	UFA	A1,A2
	FDVR	A2,%SYS12(DB)
	FADL	A0,A2		; AND DIVIDE BY LEFT HAND OPERAND
	POPJ	SP,0

DFDV02:	SYSER2	2,0		; OVERFLOW>

	IFE PROC-KI10, <
	LRSTOR	A0,%SYS12(DB)	; SAVE LEFT HAND OPERAND
	LRLOAD	A0,(AX)		; LOAD RIGHT HAND OPERAND INTO A0,A1
	DFDV	A0,%SYS12(DB)	; AND DIVIDE BY LEFT HAND OPERAND
	POPJ	SP,0>

	LIT
	PRGEND
TITLE DFAD3 - KA10/KI10 DOUBLE PRECISION ADD (A3,A4)

; ON ENTRY:
; THE LEFT HAND OPERAND IS IN A3,A4
; THE RIGHT HAND OPERAND IS ADDRESSED BY AX
; THE LINK IS ON THE STACK
; ON EXIT, THE RESULT IS IN A3,A4
	SEARCH	ALGPRM,ALGSYS

	%ENTER<25>


	SALL

%SUBTTL(ALGLIB,ALGOL LIBRARY)

LABEL(25):
	IFE	PROC-KA10,<
	UFA	A4,1(AX)	; ADD LOW ORDER PARTS IN A5
	FADL	A3,(AX)		; ADD HIGH ORDER PARTS IN A3,A4
	UFA	A4,A5		; ADD LOW PART OF HIGH SUM TO A5
	FADL	A3,A5		; ADD LOW SUM TO HIGH SUM
	POPJ	SP,0>

	IFE	PROC-KI10,<
	DFAD	A3,(AX)
	POPJ	SP,0>

	LIT
	PRGEND
TITLE DFSB3 - KA10/KI10 DOUBLE PRECISION SUBTRACT (A3,A4)

; ON ENTRY:
; THE LEFT HAND OPERAND IS IN A3,A4
; THE RIGHT HAND OPERAND IS ADDRESSED BY AX
; THE LINK IS ON THE STACK
; ON EXIT, THE RESULT IS IN A3,A4
	SEARCH	ALGPRM,ALGSYS

	%ENTER<26>


	SALL

%SUBTTL(ALGLIB,ALGOL LIBRARY)

LABEL(26):
	IFE	PROC-KA10,<
	LRNEG	A3,A4		; NEGATE LEFT HAND OPERAND
	UFA	A4,1(AX)
	FADL	A3,(AX)
	UFA	A4,A5
	FADL	A3,A5		; ADD RIGHT HAND OPERAND
	LRNEG	A3,A4		; AND NEGATE RESULT
	POPJ	SP,0>

	IFE	PROC-KI10,<
	DFSB	A3,(AX)
	POPJ	SP,0>

	LIT
	PRGEND
TITLE DFMP3 - KA10/KI10 DOUBLE PRECISION MULTIPLY (A3,A4)

; ON ENTRY:
; THE LEFT HAND OPERAND IS IN A3,A4
; THE RIGHT HAND OPERAND IS ADDRESSED BY AX
; THE LINK IS ON THE STACK
; ON EXIT, THE RESULT IS IN A3,A4
	SEARCH	ALGPRM,ALGSYS

	%ENTER<27>


	SALL

%SUBTTL(ALGLIB,ALGOL LIBRARY)

LABEL(27):
	IFE	PROC-KA10,<
	MOVE	A5,A3		; COPY HIGH WORD OF LEFT HAND OPERAND
	FMPR	A5,1(AX)	; FORM ONE CROSS PRODUCT IN A5
	JFOVO	DFMP31		; SPECIAL UNDERFLOW HANDLING
	FMPR	A4,(AX)		; FORM OTHER CROSS PRODUCT IN A4
	JFOVO	DFMP31		; SPECIAL UNDERFLOW HANDLING
	UFA	A4,A5		; ADD CROSS PRODUCTS IN A5
	FMPL	A3,(AX)		; FORM HIGH ORDER PRODUCT IN A3,A4
	UFA	A4,A5		; ADD CROSS PRODUCTS SUM TO LOW PART
	FADL	A3,A5		; ADD TOGETHER LOW AND HIGH PARTS OF RESULT
	POPJ	SP,0

DFMP31:	SYSER2	2,0>		; OVERFLOW

	IFE	PROC-KI10,<
	DFMP	A3,(AX)
	POPJ	SP,0>

	LIT
	PRGEND
TITLE DFDV3 - KA10/KI10 DOUBLE PRECISION DIVIDE (A3,A4)

; ON ENTRY:
; THE LEFT HAND OPERAND IS IN A3,A4
; THE RIGHT HAND OPERAND IS ADDRESSED BY AX
; THE LINK IS ON THE STACK
; ON EXIT, THE RESULT IS IN A3,A4
	SEARCH	ALGPRM,ALGSYS

	%ENTER<30>


	SALL

%SUBTTL(ALGLIB,ALGOL LIBRARY)

LABEL(30):
	IFE	PROC-KA10,<
	FDVL	A3,(AX)		; GET HIGH PART OF QUOTIENT
	MOVN	A5,A3		; AND NEGATE IT
	FMPR	A5,1(AX)	; MULTIPLY BY LOW PART OF DIVISOR
	JFOVO	DFDV31		; SPECIAL UNDERFLOW HANDLING
	UFA	A4,A5		; ADD REMAINDER
	FDVR	A5,(AX)		; DIVIDE SUM BY HIGH PART OF DIVISOR
	FADL	A3,A5		; ADD RESULT TO ORIGINAL QUOTIENT
	POPJ	SP,0

DFDV31:	SYSER2	2,0>		; OVERFLOW

	IFE	PROC-KI10,<
	DFDV	A3,(AX)
	POPJ	SP,0>

	LIT
	PRGEND
TITLE RDFSB3 - KA10/KI10 DOUBLE PRECISION REVERSE SUBTRACT (A3,A4)

; ON ENTRY:
; THE LEFT HAND OPERAND IS IN A3,A4
; THE RIGHT HAND OPERAND IS ADDRESSED BY AX
; THE LINK IS ON THE STACK
; ON EXIT, THE RESULT IS IN A3,A4
	SEARCH	ALGPRM,ALGSYS

	%ENTER<31>


	SALL

%SUBTTL(ALGLIB,ALGOL LIBRARY)

LABEL(31):	IFE PROC-KA10, <
	LRNEG	A3,A4		; NEGATE LEFT HAND OPERAND
	UFA	A4,1(AX)
	FADL	A3,(AX)
	UFA	A4,A5
	FADL	A3,A5		; ADD RIGHT HAND OPERAND
	POPJ	SP,0>

	IFE PROC-KI10, <
	DMOVN	A3,A3		; NEGATE LEFT HAND OPERAND
	DFAD	A3,(AX)		; ADD RIGHT HAND OPERAND
	POPJ	SP,0>

	LIT
	PRGEND
TITLE RDFDV3 - KA10/KI10 DOUBLE PRECISION REVERSE DIVIDE (A3,A4)

; ON ENTRY:
; THE LEFT HAND OPERAND IS IN A3,A4
; THE RIGHT HAND OPERAND IS ADDRESSED BY AX
; THE LINK IS ON THE STACK
; ON EXIT, THE RESULT IS IN A3,A4
	SEARCH	ALGPRM,ALGSYS

	%ENTER<32>


	SALL

%SUBTTL(ALGLIB,ALGOL LIBRARY)

LABEL(32):	IFE PROC-KA10, <
	LRSTOR	A3,%SYS12(DB)	; SAVE LEFT HAND OPERAND
	LRLOAD	A3,(AX)		; AND LOAD RIGHT HAND OPERAND
	FDVL	A3,%SYS12(DB)
	MOVN	A5,A3
	FMPR	A5,%SYS13(DB)
	JFOVO	DFDV32
	UFA	A4,A5
	FDVR	A5,%SYS12(DB)
	FADL	A3,A5		; AND DIVIDE BY LEFT HAND OPERAND
	POPJ	SP,0

DFDV32:	SYSER2	2,0		; OVERFLOW>

	IFE PROC-KI10, <
	LRSTOR	A3,%SYS12(DB)	; SAVE LEFT HAND OPERAND
	LRLOAD	A3,(AX)		; LOAD RIGHT HAND OPERAND INTO A3,A4
	DFDV	A3,%SYS12(DB)	; AND DIVIDE BY LEFT HAND OPERAND
	POPJ	SP,0>

	LIT
	PRGEND
TITLE DFAD6 - KA10/KI10 DOUBLE PRECISION ADD (A6,A7)

; ON ENTRY:
; THE LEFT HAND OPERAND IS IN A6,A7
; THE RIGHT HAND OPERAND IS ADDRESSED BY AX
; THE LINK IS ON THE STACK
; ON EXIT, THE RESULT IS IN A6,A7
	SEARCH	ALGPRM,ALGSYS

	%ENTER<33>


	SALL

%SUBTTL(ALGLIB,ALGOL LIBRARY)

LABEL(33):
	IFE	PROC-KA10,<
	UFA	A7,1(AX)	; ADD LOW ORDER PARTS IN A10
	FADL	A6,(AX)		; ADD HIGH ORDER PARTS IN A6,A7
	UFA	A7,A10		; ADD LOW PART OF HIGH SUM TO A10
	FADL	A6,A10		; ADD LOW SUM TO HIGH SUM
	POPJ	SP,0>

	IFE	PROC-KI10,<
	DFAD	A6,(AX)
	POPJ	SP,0>

	LIT
	PRGEND
TITLE DFSB6 - KA10/KI10 DOUBLE PRECISION SUBTRACT (A6,A7)

; ON ENTRY:
; THE LEFT HAND OPERAND IS IN A6,A7
; THE RIGHT HAND OPERAND IS ADDRESSED BY AX
; THE LINK IS ON THE STACK
; ON EXIT, THE RESULT IS IN A6,A7
	SEARCH	ALGPRM,ALGSYS

	%ENTER<34>


	SALL

%SUBTTL(ALGLIB,ALGOL LIBRARY)

LABEL(34):
	IFE	PROC-KA10,<
	LRNEG	A6,A7		; NEGATE LEFT HAND OPERAND
	UFA	A7,1(AX)
	FADL	A6,(AX)
	UFA	A7,A10
	FADL	A6,A10		; ADD RIGHT HAND OPERAND
	LRNEG	A6,A7		; AND NEGATE RESULT
	POPJ	SP,0>

	IFE	PROC-KI10,<
	DFSB	A6,(AX)
	POPJ	SP,0>

	LIT
	PRGEND
TITLE DFMP6 - KA10/KI10 DOUBLE PRECISION MULTIPLY (A6,A7)

; ON ENTRY:
; THE LEFT HAND OPERAND IS IN A6,A7
; THE RIGHT HAND OPERAND IS ADDRESSED BY AX
; THE LINK IS ON THE STACK
; ON EXIT, THE RESULT IS IN A6,A7
	SEARCH	ALGPRM,ALGSYS

	%ENTER<35>


	SALL

%SUBTTL(ALGLIB,ALGOL LIBRARY)

LABEL(35):
	IFE	PROC-KA10,<
	MOVE	A10,A6		; COPY HIGH WORD OF LEFT HAND OPERAND
	FMPR	A10,1(AX)	; FORM ONE CROSS PRODUCT IN A10
	JFOVO	DFMP61		; SPECIAL UNDERFLOW HANDLING
	FMPR	A7,(AX)		; FORM OTHER CROSS PRODUCT IN A7
	JFOVO	DFMP61		; SPECIAL UNDERFLOW HANDLING
	UFA	A7,A10		; ADD CROSS PRODUCTS IN A10
	FMPL	A6,(AX)		; FORM HIGH ORDER PRODUCT IN A6,A7
	UFA	A7,A10		; ADD CROSS PRODUCTS SUM TO LOW PART
	FADL	A6,A10		; ADD TOGETHER LOW AND HIGH PARTS OF RESULT
	POPJ	SP,0

DFMP61:	SYSER2	2,0>		; OVERFLOW
	IFE	PROC-KI10,<
	DFMP	A6,(AX)
	POPJ	SP,0>

	LIT
	PRGEND
TITLE DFDV6 - KA10/KI10 DOUBLE PRECISION DIVIDE (A6,A7)

; ON ENTRY:
; THE LEFT HAND OPERAND IS IN A6,A7
; THE RIGHT HAND OPERAND IS ADDRESSED BY AX
; THE LINK IS ON THE STACK
; ON EXIT, THE RESULT IS IN A6,A7
	SEARCH	ALGPRM,ALGSYS

	%ENTER<36>


	SALL

%SUBTTL(ALGLIB,ALGOL LIBRARY)

LABEL(36):
	IFE	PROC-KA10,<
	FDVL	A6,(AX)		; GET HIGH PART OF QUOTIENT
	MOVN	A10,A6		; AND NEGATE IT
	FMPR	A10,1(AX)	; MULTIPLY BY LOW PART OF DIVISOR
	JFOVO	DFDV61		; SPECIAL UNDERFLOW HANDLING
	UFA	A7,A10		; ADD REMAINDER
	FDVR	A10,(AX)	; DIVIDE SUM BY HIGH PART OF DIVISOR
	FADL	A6,A10		; ADD RESULT TO ORIGINAL QUOTIENT
	POPJ	SP,0

DFDV61:	SYSER2	2,0>		; OVERFLOW

	IFE	PROC-KI10,<
	DFDV	A6,(AX)
	POPJ	SP,0>

	LIT
	PRGEND
TITLE RDFSB6 - KA10/KI10 DOUBLE PRECISION REVERSE SUBTRACT (A6,A7)

; ON ENTRY:
; THE LEFT HAND OPERAND IS IN A6,A7
; THE RIGHT HAND OPERAND IS ADDRESSED BY AX
; THE LINK IS ON THE STACK
; ON EXIT, THE RESULT IS IN A6,A7
	SEARCH	ALGPRM,ALGSYS

	%ENTER<37>


	SALL

%SUBTTL(ALGLIB,ALGOL LIBRARY)

LABEL(37):	IFE PROC-KA10, <
	LRNEG	A6,A7		; NEGATE LEFT HAND OPERAND
	UFA	A7,1(AX)
	FADL	A6,(AX)
	UFA	A7,A10
	FADL	A6,A10		; ADD RIGHT HAND OPERAND
	POPJ	SP,0>

	IFE PROC-KI10, <
	DMOVN	A6,A6		; NEGATE LEFT HAND OPERAND
	DFAD	A6,(AX)		; ADD RIGHT HAND OPERAND
	POPJ	SP,0>

	LIT
	PRGEND
TITLE RDFDV6 - KA10/KI10 DOUBLE PRECISION REVERSE DIVIDE (A6,A7)

; ON ENTRY:
; THE LEFT HAND OPERAND IS IN A6,A7
; THE RIGHT HAND OPERAND IS ADDRESSED BY AX
; THE LINK IS ON THE STACK
; ON EXIT, THE RESULT IS IN A6,A7
	SEARCH	ALGPRM,ALGSYS

	%ENTER<40>


	SALL

%SUBTTL(ALGLIB,ALGOL LIBRARY)

LABEL(40):	IFE PROC-KA10, <
	LRSTOR	A6,%SYS12(DB)	; SAVE LEFT HAND OPERAND
	LRLOAD	A6,(AX)		; AND LOAD RIGHT HAND OPERAND
	FDVL	A6,%SYS12(DB)
	MOVN	A10,A6
	FMPR	A10,%SYS13(DB)
	JFOVO	DFDV62
	UFA	A7,A10
	FDVR	A10,%SYS12(DB)
	FADL	A6,A10		; AND DIVIDE BY LEFT HAND OPERAND
	POPJ	SP,0

DFDV62:	SYSER2	2,0		; OVERFLOW>

	IFE PROC-KI10, <
	LRSTOR	A6,%SYS12(DB)	; SAVE LEFT HAND OPERAND
	LRLOAD	A6,(AX)		; LOAD RIGHT HAND OPERAND INTO A6,A7
	DFDV	A6,%SYS12(DB)	; AND DIVIDE BY LEFT HAND OPERAND
	POPJ	SP,0>

	LIT
	PRGEND
TITLE DFAD9 - KA10/KI10 DOUBLE PRECISION ADD (A11,A12)

; ON ENTRY:
; THE LEFT HAND OPERAND IS IN A11,A12
; THE RIGHT HAND OPERAND IS ADDRESSED BY AX
; THE LINK IS ON THE STACK
; ON EXIT, THE RESULT IS IN A11,A12
	SEARCH	ALGPRM,ALGSYS

	%ENTER<41>


	SALL

%SUBTTL(ALGLIB,ALGOL LIBRARY)

LABEL(41):
	IFE	PROC-KA10,<
	UFA	A12,1(AX)	; ADD LOW ORDER PARTS IN A13
	FADL	A11,(AX)	; ADD HIGH ORDER PARTS IN A11,A12
	UFA	A12,A13		; ADD LOW PART OF HIGH SUM TO A13
	FADL	A11,A13		; ADD LOW SUM TO HIGH SUM
	POPJ	SP,0>

	IFE	PROC-KI10,<
	DFAD	A11,(AX)
	POPJ	SP,0>

	LIT
	PRGEND
TITLE DFSB9 - KA10/KI10 DOUBLE PRECISION SUBTRACT (A11,A12)

; ON ENTRY:
; THE LEFT HAND OPERAND IS IN A11,A12
; THE RIGHT HAND OPERAND IS ADDRESSED BY AX
; THE LINK IS ON THE STACK
; ON EXIT, THE RESULT IS IN A11,A12
	SEARCH	ALGPRM,ALGSYS

	%ENTER<42>


	SALL

%SUBTTL(ALGLIB,ALGOL LIBRARY)

LABEL(42):
	IFE	PROC-KA10,<
	LRNEG	A11,A12		; NEGATE LEFT HAND OPERAND
	UFA	A12,1(AX)
	FADL	A11,(AX)
	UFA	A12,A13
	FADL	A11,A13		; ADD RIGHT HAND OPERAND
	LRNEG	A11,A12		; AND NEGATE RESULT
	POPJ	SP,0>

	IFE	PROC-KI10,<
	DFSB	A11,(AX)
	POPJ	SP,0>

	LIT
	PRGEND
TITLE DFMP9 - KA10/KI10 DOUBLE PRECISION MULTIPLY (A11,A12)

; ON ENTRY:
; THE LEFT HAND OPERAND IS IN A11,A12
; THE RIGHT HAND OPERAND IS ADDRESSED BY AX
; THE LINK IS ON THE STACK
; ON EXIT, THE RESULT IS IN A11,A12
	SEARCH	ALGPRM,ALGSYS

	%ENTER<43>


	SALL

%SUBTTL(ALGLIB,ALGOL LIBRARY)

LABEL(43):
	IFE	PROC-KA10,<
	MOVE	A13,A11		; COPY HIGH WORD OF LEFT HAND OPERAND
	FMPR	A13,1(AX)	; FORM ONE CROSS PRODUCT IN A13
	JFOVO	DFMP91		; SPECIAL UNDERFLOW HANDLING
	FMPR	A12,(AX)	; FORM OTHER CROSS PRODUCT IN A12
	JFOVO	DFMP91		; SPECIAL UNDERFLOW HANDLING
	UFA	A12,A13		; ADD CROSS PRODUCTS IN A13
	FMPL	A11,(AX)	; FORM HIGH ORDER PRODUCT IN A11,A12
	UFA	A12,A13		; ADD CROSS PRODUCTS SUM TO LOW PART
	FADL	A11,A13		; ADD TOGETHER LOW AND HIGH PARTS OF RESULT
	POPJ	SP,0

DFMP91:	SYSER2	2,0>		; OVERFLOW

	IFE	PROC-KI10,<
	DFMP	A11,(AX)
	POPJ	SP,0>

	LIT
	PRGEND
TITLE DFDV9 - KA10/KI10 DOUBLE PRECISION DIVIDE (A11,A12)

; ON ENTRY:
; THE LEFT HAND OPERAND IS IN A11,A12
; THE RIGHT HAND OPERAND IS ADDRESSED BY AX
; THE LINK IS ON THE STACK
; ON EXIT, THE RESULT IS IN A11,A12
	SEARCH	ALGPRM,ALGSYS

	%ENTER<44>


	SALL

%SUBTTL(ALGLIB,ALGOL LIBRARY)

LABEL(44):
	IFE	PROC-KA10,<
	FDVL	A11,(AX)	; GET HIGH PART OF QUOTIENT
	MOVN	A13,A11		; AND NEGATE IT
	FMPR	A13,1(AX)	; MULTIPLY BY LOW PART OF DIVISOR
	JFOVO	DFDV91		; SPECIAL UNDERFLOW HANDLING
	UFA	A12,A13		; ADD REMAINDER
	FDVR	A13,(AX)	; DIVIDE SUM BY HIGH PART OF DIVISOR
	FADL	A11,A13		; ADD RESULT TO ORIGINAL QUOTIENT
	POPJ	SP,0

DFDV91:	SYSER2	2,0>		; OVERFLOW
	IFE	PROC-KI10,<
	DFDV	A11,(AX)
	POPJ	SP,0>

	LIT
	PRGEND
TITLE RDFSB9 - KA10/KI10 DOUBLE PRECISION REVERSE SUBTRACT (A11,A12)

; ON ENTRY:
; THE LEFT HAND OPERAND IS IN A11,A12
; THE RIGHT HAND OPERAND IS ADDRESSED BY AX
; THE LINK IS ON THE STACK
; ON EXIT, THE RESULT IS IN A11,A12
	SEARCH	ALGPRM,ALGSYS

	%ENTER<45>


	SALL

%SUBTTL(ALGLIB,ALGOL LIBRARY)

LABEL(45):	IFE PROC-KA10, <
	LRNEG	A11,A12		; NEGATE LEFT HAND OPERAND
	UFA	A12,1(AX)
	FADL	A11,(AX)
	UFA	A12,A13
	FADL	A11,A13		; ADD RIGHT HAND OPERAND
	POPJ	SP,0>

	IFE PROC-KI10, <
	DMOVN	A11,A11		; NEGATE LEFT HAND OPERAND
	DFAD	A11,(AX)	; ADD RIGHT HAND OPERAND
	POPJ	SP,0>

	LIT
	PRGEND
TITLE RDFDV9 - KA10/KI10 DOUBLE PRECISION REVERSE DIVIDE (A11,A12)

; ON ENTRY:
; THE LEFT HAND OPERAND IS IN A11,A12
; THE RIGHT HAND OPERAND IS ADDRESSED BY AX
; THE LINK IS ON THE STACK
; ON EXIT, THE RESULT IS IN A11,A12
	SEARCH	ALGPRM,ALGSYS

	%ENTER<46>


	SALL

%SUBTTL(ALGLIB,ALGOL LIBRARY)

LABEL(46):	IFE PROC-KA10, <
	LRSTOR	A11,%SYS12(DB)	; SAVE LEFT HAND OPERAND
	LRLOAD	A11,(AX)	; AND LOAD RIGHT HAND OPERAND
	FDVL	A11,%SYS12(DB)
	MOVN	A13,A11
	FMPR	A13,%SYS13(DB)
	JFOVO	DFDV92
	UFA	A12,A13
	FDVR	A13,%SYS12(DB)
	FADL	A11,A13		; AND DIVIDE BY LEFT HAND OPERAND
	POPJ	SP,0

DFDV92:	SYSER2	2,0		; OVERFLOW>

	IFE PROC-KI10, <
	LRSTOR	A11,%SYS12(DB)	; SAVE LEFT HAND OPERAND
	LRLOAD	A11,(AX)	; LOAD RIGHT HAND OPERAND INTO A11,A12
	DFDV	A11,%SYS12(DB)	; AND DIVIDE BY LEFT HAND OPERAND
	POPJ	SP,0>

	LIT
	PRGEND
TITLE DIM - ARRAY DIMENSION ROUTINE

; INTEGER PROCEDURE DIM(A); (INTEGER/REAL/LONG REAL/BOOLEAN/STRING) ARRAY A;

	.EXIT=1
	.A=3
	SEARCH	ALGPRM,ALGSYS

LIBENT(300,DIM)
	XWD	0,4
	XWD	$PRO!$I!$SIM,2
	XWD	$ARR!$WV!$FON,.A

	HLRE	A0,.A+1(DL)
	MOVNM	A0,.EXIT+1(DL)	; GET NUMBER OF DIMENSIONS
	JRST	.EXIT(DL)

	LIT
	PRGEND
TITLE LB/UB - ARRAY BOUND ROUTINE

; INTEGER PROCEDURE LB(A,N); VALUE N; (INTEGER/REAL/LONG REAL/BOOLEAN/STRING) ARRAY; INTEGER N;
; INTEGER PROCEDURE UB(A,N); VALUE N; (INTEGER/REAL/LONG REAL/BOOLEAN/STRING) ARRAY; INTEGER N;

	.EXIT=1
	.LU=3
	.A=4
	.N=6
	SEARCH	ALGPRM,ALGSYS

LIBENT(301,LB)
	XWD	0,6
	XWD	$PRO!$I!$SIM,3
	XWD	$ARR!$WV!$FON,.A
	XWD	$VAR!$I!$FOV,.N
	SETZM	.LU(DL)		; FLAG AS LB ENTRY
	JRST	LB1

LIBENT(302,UB)
	XWD	0,6
	XWD	$PRO!$I!$SIM,3
	XWD	$ARR!$WV!$FON,.A
	XWD	$VAR!$I!$FOV,.N
	MOVEI	A0,1
	MOVEM	A0,.LU(DL)	; FLAG AS UB ENTRY

PATCH (32)	; PLANT PM BUFFERS
LB1:	MOVE	A0,.N(DL)	; GET SUBSCRIPT NUMBER
	JUMPLE	A0,LBUB1	; ANY GOOD?
	HLRE	A1,.A+1(DL)
	MOVN	A1,A1		; GET NUMBER OF SUBSCRIPTES
	CAMGE	A1,A0		; ENOUGH
	JRST	LBUB1		; NO
	HRRZ	A1,.A+1(DL)	; GET DOPE VECTOR ADDRESS
	LSH	A0,1		; DOUBLE SUBSCRIPT NUMBER
	ADD	A1,A0
	ADD	A1,.LU(DL)	; AND ALLOW FOR LB/UB
	SKIPA	A1,-2(A1)	; GET RELEVANT BOUND
LBUB1:	MOVEI	A1,0		; OUT OF RANGE
	MOVEM	A1,.EXIT+1(DL)
	JRST	.EXIT(DL)

	LIT
	PRGEND
TITLE IMIN/IMAX - INTEGER MINIMUM/MAXIMUM ROUTINES


; INTEGER PROCEDURE IMIN(I); VALUE I; INTEGER I;
; INTEGER PROCEDURE IMAX(I); VALUE I; INTEGER I;
	SEARCH	ALGPRM,ALGSYS

	DEFINE REP(M,A,I)
	<Q=0
	R=A-I
	REPEAT PRMMAX, <
	IF2,
	<Q=Q+1
	R=R+I>
	M \Q,\R>>

	DEFINE DECL(A,B)
	<IF2, <.I'A=B>>

	DEFINE PAR(A,B)
	<IF1, <Z>
	IF2, <XWD	$VAR!$I!$FOV,.I'A>>

	.EXIT=1
	.MM=3
	.V=4
	REP	DECL,5,1

LIBENT(303,IMIN,.V)
	XWD	0,PRMMAX+4
	XWD	$PRO!$I!$SIM,PRMMAX+1
	REP	PAR,5,1

	MOVEI	A2,0		; IMIN FLAG
	JRST	IM1

LIBENT(304,IMAX,.V)
	XWD	0,PRMMAX+4
	XWD	$PRO!$I!$SIM,PRMMAX+1
	REP	PAR,5,1
	MOVEI	A2,1		; IMAX FLAG
PATCH (32)	; PLANT PM BLOCKS

IM1:	MOVN	A1,.V(DL)	; NUMBER OF PARAMETERS+1
	AOJE	A1,IM5		; NO PARAMETERS?
	HRLZ	A1,A1
	HRRI	A1,.I1(DL)	; SET UP COUNTER POINTER
	SKIPE	A2		; MIN OR MAX
	JRST	IM3
	HRLOI	A0,377777	; MIN

IM2:	CAMLE	A0,(A1)
	MOVE	A0,(A1)
	AOBJN	A1,IM2
	JRST	IM6

IM3:	HRLZI	A0,400000	; MAX

IM4:	CAMGE	A0,(A1)
	MOVE	A0,(A1)
	AOBJN	A1,IM4
	JRST	IM6

IM5:	MOVEI	A0,0		; NO PARAMETER CASE

IM6:	MOVEM	A0,.EXIT+1(DL)	; RESULT
	JRST	.EXIT(DL)

	LIT

	PRGEND
TITLE RMIN/RMAX - REAL MINIMUM/MAXIMUM ROUTINES

; REAL PROCEDURE RMIN(X); VALUE X; REAL X;
; REAL PROCEDURE RMAX(X); VALUE X; REAL X;
	SEARCH	ALGPRM,ALGSYS

	DEFINE REP(M,A,I)
	<Q=0
	R=A-I
	REPEAT PRMMAX, <
	IF2,
	<Q=Q+1
	R=R+I>
	M \Q,\R>>

	DEFINE DECL(A,B)
	<IF2, <.X'A=B>>

	DEFINE PAR(A,B)
	<IF1, <Z>
	IF2, <XWD	$VAR!$R!$FOV,.X'A>>

	.EXIT=1
	.MM=3
	.V=4
	REP	DECL,5,1

LIBENT(305,RMIN,.V)
	XWD	0,PRMMAX+4
	XWD	$PRO!$R!$SIM,PRMMAX+1
	REP	PAR,5,1
	MOVEI	A2,0		; RMIN FLAG
	JRST	RM1

LIBENT(306,RMAX,.V)
	XWD	0,PRMMAX+4
	XWD	$PRO!$R!$SIM,PRMMAX+1
	REP	PAR,5,1
	MOVEI	A2,1		; RMAX FLAG
PATCH (32)	; PLANT PM BLOCKS

RM1:	MOVN	A1,.V(DL)	; NUMBER OF PARAMETERS+1
	AOJE	A1,RM5		; NO PARAMETERS?
	HRLZ	A1,A1
	HRRI	A1,.X1(DL)	; SET UP COUNTER POINTER
	SKIPE	A2		; MIN OR MAX
	JRST	RM3
	HRLOI	A0,377777	; MIN

RM2:	CAMLE	A0,(A1)
	MOVE	A0,(A1)
	AOBJN	A1,RM2
	JRST	RM6

RM3:	MOVE	A0,[
	XWD	400000,000001]

RM4:	CAMGE	A0,(A1)
	MOVE	A0,(A1)
	AOBJN	A1,RM4
	JRST	RM6

RM5:	MOVEI	A0,0		; NO PARAMETER CASE

RM6:	MOVEM	A0,.EXIT+1(DL)	; RESULT
	JRST	.EXIT(DL)

	LIT
	PRGEND
TITLE LMIN/LMAX - LONG REAL MINIMUM/MAXIMUM ROUTINES

; LONG REAL PROCEDURE LMIN(D); VALUE D; LONG REAL D;
; LONG REAL PROCEDURE LMAX(D); VALUE D; LONG REAL D;
	SEARCH	ALGPRM,ALGSYS

	DEFINE REP(M,A,I)
	<Q=0
	R=A-I
	REPEAT PRMMAX, <
	IF2,
	<Q=Q+1
	R=R+I>
	M \Q,\R>>

	DEFINE DECL(A,B)
	<IF2, <.D'A=B>>

	DEFINE PAR(A,B)
	<IF1, <Z>
	IF2, <XWD	$VAR!$LR!$FOV,.D'A>>

	.EXIT=1
	.MM=4
	.V=5
	REP	DECL,6,2

LIBENT(307,LMIN,.V)
	XWD	0,2*PRMMAX+5
	XWD	$PRO!$LR!$SIM,PRMMAX+1
	REP	PAR,6,2
	MOVEI	A0,0		; FLAG AS LMIN
	JRST	LM1

LIBENT(310,LMAX,.V)
	XWD	0,2*PRMMAX+5
	XWD	$PRO!$LR!$SIM,PRMMAX+1
	REP	PAR,6,2
	MOVEI	A0,1		; FLAG AS LMAX
PATCH (32)	; PLANT PM BLOCKS

LM1:	MOVN	A2,.V(DL)	; NUMBER OF PARAMETERS+1
	AOJE	A2,LM7		; NO PARAMETERS?
	HRLZ	A2,A2
	HRRI	A2,.D1(DL)	; SET UP COUNTER POINTER
	SKIPE	A0		; MIN OR MAX?
	JRST	LM4
	HRLOI	A0,377777	; MIN
	HRLOI	A1,344777

LM2:	CAMN	A0,(A2)
	CAMLE	A1,1(A2)
	CAMGE	A0,(A2)
	AOJA	A2,LM3
	LRLOAD	A0,(A2)
	ADDI	A2,1

LM3:	AOBJN	A2,LM2
	JRST	LM8

LM4:	HRLZI	A0,400000	; MAX
	MOVE	A1,[
	XWD	344000,000001]

LM5:	CAMN	A0,(A2)
	CAMGE	A1,1(A2)
	CAMLE	A0,(A2)
	AOJA	A2,LM6
	LRLOAD	A0,(A2)
	ADDI	A2,1

LM6:	AOBJN	A2,LM5
	JRST	LM8
LM7:	SETZB	A0,A1		; NO PARAMETER CASE

LM8:	LRSTOR	A0,.EXIT+1(DL)	; RESULT
	JRST	.EXIT(DL)

	LIT
	PRGEND
TITLE GFIELD/SFIELD - FIELD ACCESS ROUTINES

; INTEGER PROCEDURE GFIELD(A,I,J); VALUE A,I,J;
;	(INTEGER/REAL/LONG REAL/BOOLEAN/STRING) A; INTEGER I,J;

; PROCEDURE SFIELD(A,I,J,N); VALUE I,J,N;
;	(INTEGER/REAL/LONG REAL/BOOLEAN/STRING) A; INTEGER I,J,N;

	.EXIT=1
	.A=3
	.I=6
	.J=7
	.N=10
	SEARCH	ALGPRM,ALGSYS

LIBENT(312,SFIELD)
	XWD	0,10
	XWD	$PRO!$N!$SIM,5
	XWD	$VAR!$WV!$FON,.A
	XWD	$VAR!$I!$FOV,.I
	XWD	$VAR!$I!$FOV,.J
	XWD	$VAR!$I!$FOV,.N

	MOVEI	A1,1		; SET SFIELD FLAG
	JRST	GSF1

LIBENT(311,GFIELD)
	XWD	0,10
	XWD	$PRO!$I!$SIM,4
	XWD	$VAR!$WV!$FOV,.A
	XWD	$VAR!$I!$FOV,.I
	XWD	$VAR!$I!$FOV,.J

	MOVEI	A1,0		; CLEAR SFIELD FLAG
GSF1:	MOVE	A2,PRGLNK(DL)	; GET PROGRAM LINK
	SUBI	A2,3(A1)	; GET ADDRESS OF AP FOR A
	HLRZ	A0,(A2)
	ANDI	A0,$TYPE	; GET TYPE OF A
	CAIE	A0,$LR
	CAIN	A0,$S
	HRLI	A1,400000	; SET LONG FLAG IF DOUBLE WORD
	SKIPL	A2,.I(DL)	; GET I
	SKIPG	A3,.J(DL)	; AND J

GSF2:	SYSER1	15,0		; BAD VALUES
	TLZE	A1,400000
	JRST	GSF5		; LONG CASE?
	MOVEI	A4,^D36		; NO
	SUB	A4,A2
	SUB	A4,A3		; FORM 36-I-J
	JUMPL	A4,GSF2		; FAIL UNLESS I+J <= 36

GSF3:	LSH	A4,6
	ADDI	A4,(A3)		; FORM 64*P + S
	ROT	A4,-14		; FUDGE BYTE POINTER
	JUMPN	A1,GSF4		; GFIELD?
	ADDI	A4,.A(DL)	; YES - ADD ADDRESS TO BYTE POINTER
	LDB	A0,A4
	MOVEM	A0,.EXIT+1(DL)	; GET RESULT
	JRST	.EXIT(DL)
GSF4:	PUSH	SP,A4		; SFIELD - SAVE BYTE POINTER
	XCT	.A(DL)		; LOAD A
	MOVE	A4,(SP)		; RESTORE BYTE POINTER
	MOVE	A5,.N(DL)
	DPB	A5,A4		; DEPOSIT BYTE (IN A0 OR A1)
	MOVEM	A0,(SP)
	PUSH	SP,A1		; SAVE VALUE(S)
	XCTA	.A(DL)		; GET ADDRESS OF A
	POP	SP,A1
	POP	SP,A0		; RESTORE VALUE(S)
	XCT	.A+1(DL)	; AND WRITE IT IN A
	JRST	.EXIT(DL)

GSF5:	MOVEI	A5,^D72		; LONG CASE
	SUB	A5,A2
	SUB	A5,A3		; FORM 72-I-J
	JUMPL	A5,GSF2		; FAIL UNLESS I+J <= 72
	HRREI	A4,-^D36(A5)	; TEST FOR SIMPLE CASE
	JUMPGE	A4,GSF3		; OF I+J <= 36
	CAIGE	A2,^D36		; I >= 36?
	JRST	GSF6		; NO
	MOVEI	A4,100*A1(A5)	; YES - FUDGE BYTE POINTER FOR A1
	JRST	GSF3

GSF6:	CAILE	A3,^D36		; FRAGMENTED CASE
	JRST	GSF2		; LOSES IF J > 36
	MOVN	A4,A4		; S2 = I+J-36
	MOVEI	A2,(A4)		; SAVE SHIFT
	SUBI	A3,(A4)		; S1 = 36-I
	ROT	A3,-14		; FORM FIRST BYTE POINTER
	LSH	A5,6
	ADDI	A4,(A5)
	ROT	A4,-14
	ADDI	A4,A1		; FORM SECOND BYTE POINTER
	JUMPN	A1,GSF7		; GBYTE?
	LRLOAD	A0,.A(DL)	; YES - LOAD A
	LDB	A0,A3		; GET FIRST BYTE
	LDB	A1,A4		; GET SECOND BYTE
	LSH	A0,(A2)
	ADD	A0,A1		; ASSEMBLE RESULT
	MOVEM	A0,.EXIT+1(DL)
	JRST	.EXIT(DL)
GSF7:	PUSH	SP,A2
	PUSH	SP,A3
	PUSH	SP,A4		; SAVE A2-A4
	XCT	.A(DL)		; GET VALUE OF A
	POP	SP,A4
	MOVE	A3,(SP)		; RESTORE BYTE POINTERS
	MOVN	A2,-1(SP)	; AND SHIFT
	MOVE	A5,.N(DL)	; GET BYTE VALUE FROM N
	DPB	A5,A4		; DEPOSIT SECOND BYTE
	LSH	A5,(A2)		; SHIFT DOWN BYTE
	DPB	A5,A3		; DEPOSIT FIRST BYTE
	LRSTOR	A0,-1(SP)	; SAVE NEW VALUE
	XCTA	.A(DL)		; GET ADDRESS OF A
	POP	SP,A1
	POP	SP,A0		; RESTORE NEW VALUE
	XCT	.A+1(DL)	; AND STORE IT
	JRST	.EXIT(DL)

	LIT
	PRGEND
TITLE COPY - COPY STRING ROUTINE

; STRING PROCEDURE COPY(S,M,N); VALUE M,N; STRING S; INTEGER M,N;

	.EXIT=1
	.S=4
	.M=7
	.N=10
	.V=11
	SEARCH	ALGPRM,ALGSYS

LIBENT(314,COPY,.V)
	XWD	0,11
	XWD	$PRO!$S!$SIM,4
	XWD	$VAR!$S!$FON,.S
	XWD	$VAR!$I!$FOV,.M
	XWD	$VAR!$I!$FOV,.N

	SOSN	.V(DL)		; ANY PARAMETERS?
	SYSER1	10,0		; NO - COMPLAIN
	XCT	.S(DL)		; GET ADDRESS OF STRING
PATCH (5)	; REVISE STRING-HEADERS
EDIT(657); SAVE STRING HEADER ADDRESS DELOCATED
	MOVEM	A2,%SYS11(DB)	; [E657]
	MOVEI	A2,@A2
	LDB	A0,[
	POINT	24,STR2(A2),35]	; AND ITS LENGTH
	MOVEI	A7,1
	MOVE	A10,A0		; SET UP DEFAULT PARAMETERS
	SOSN	A1,.V(DL)
	JRST	COPY1		; ONLY ONE PARAMETER
	CAMLE	A10,.M(DL)
	MOVE	A10,.M(DL)	; MIN(M,LENGTH(S))
	SOJE	A1,COPY1	; IF TWO PARAMETERS
	MOVE	A7,A10
	CAIGE	A7,1
	MOVEI	A7,1		; MAX(M,1)
	MOVE	A10,.N(DL)
	CAMLE	A10,A0
	MOVE	A10,A0		; MIN(N,LENGTH(S))
EDIT(626); TIDY UP CODE FOR COPYING ZERO-LENGTH STRINGS
COPY1:	SUB	A10,A7
	AOJG	A10,.+3		; NUMBER OF BYTES TO BE COPIED
	MOVEI	A10,0
	JRST	COPY2		; MAYBE NONE AT ALL
	LDB	A0,[
	POINT	6,STR1(A2),11]	; GET BYTE SIZE
	MOVEI	A1,^D36
	IDIV	A1,A0		; CALCULATE NUMBER OF BYTES PER WORD
	MOVE	A0,A10
	IDIVI	A0,(A1)
	JUMPE	A1,.+2
	ADDI	A0,1		; NUMBER OF WORDS IN BYTE STRING
	LRSTOR	A7,%SYS12(DB)	; SAVE A7,A10
	PUSHJ	SP,GETCLR	; ASK FOR SPACE FOR STRING (ZEROED)
	LRLOAD	A7,%SYS12(DB)	; RESTORE A7,A10

COPY2:	MOVEI	A2,.EXIT+1(DL)	; ADDRESS OF NEW STRING
	MOVEI	A4,(A1)		; ADDRESS OF NEW BYTE STRING
	MOVEI	A3,@%SYS11(DB)	; [E657] ADDRESS OF OLD HEADER
	LRLOAD	A0,(A3)		; LOAD UP VALUE OF OLD STRING
	JSP	AX,CPYSTR	; AND COPY STRING
	JRST	.EXIT(DL)

	LIT
	PRGEND
TITLE TRAP - TRAP ERROR ROUTINE

; PROCEDURE TRAP(N,L); VALUE N,L; INTEGER N; LABEL L;

	.EXIT=1
	.N=2
	.L=3
	.V=6
	SEARCH	ALGPRM,ALGSYS

LIBENT(315,TRAP,.V)
	XWD	0,6
	XWD	$PRO!$N!$SIM,3
	XWD	$VAR!$I!$FOV,.N
	XWD	$VAR!$L!$FOV,.L

	SOSN	.V(DL)		; HOW MANY ACTUAL PARAMETERS?
	SYSER1	10,0		; NONE - COMPLAIN
	SKIPL	A2,.N(DL)	; GET TRAP NUMBER
	CAIL	A2,100
	JRST	.EXIT(DL)	; OUT OF RANGE
	MOVEI	A0,0
	ADDI	A2,(DB)
	HRRZ	A1,%TRAPS(A2)
	JUMPE	A1,TRAP0
	PUSHJ	SP,GETOWN	; YES - RELEASE IT

TRAP0:	MOVEI	A1,0
	SOSN	.V(DL)
	JRST	TRAP1		; TRAP TO BE UNSET
	XCT	.L(DL)		; GET LABEL ADDRESS
	JUMPE	A2,TRAP0	; EXIT IF SWITCH OUT OF RANGE
	HLRZ	A3,A2		; GET F[0]
	ADDI	A3,(DB)
	HLRZ	A4,2(A3)	; SAVE ITS DL
	HRRZ	A3,1(A3)	; AND GET THE ACTUAL LABEL ADDRESS
	HRRZ	A0,1(A3)	; PROCEDURE LEVEL OF LABEL
	ADDI	A0,2
	PUSH	SP,A3		; SAVE LABEL ADDRESS
	PUSH	SP,A4		; AND RELEVANT DL
	PUSHJ	SP,GETOWN	; GET DUMP AREA
	POP	SP,A2		; RESTORE RELEVANT DL
	POP	SP,(A1)		; STORE LABEL ADDRESS

	HLRZ	A0,-1(A1)	; LABEL		EDIT #303
	SUBI	A0,2		; PROCEDURE LEVEL+1
	HRLM	A0,(A1)		;	 	EDIT #303
	ADDI	A2,(DB)		; RELOCATE RELEVANT DL
	HRLZI	A2,(A2)
	HRRI	A2,1(A1)	; SET UP BLT POINTER
	ADDI	A0,(A1)
	BLT	A2,@A0		; AND MAKE COPY OF DISPLAY

TRAP1:	MOVE	A3,.N(DL)
	ADDI	A3,(DB)
	MOVEM	A1,%TRAPS(A3)	; SET UP TRAP ENTRY
	JRST	.EXIT(DL)

	LIT
	PRGEND
	TITLE	FCALLS - FORTRAN INTERFACE ROUTINES
	SEARCH	ALGPRM,ALGSYS
	%ENTER<434,435,436,437,440>
	%ENTER<450,451,452,453,454>
	EXTERNAL %ALGDR
	SALL
	%SUBTTL(ALGLIB,ALGOL LIBRARY)
	.EXIT=1
	.SUBR=4

LABEL(450):	;  F10CALL
LABEL(451):	; F10ICALL
LABEL(452):	; F10RCALL
LABEL(453):	; F10DCALL
LABEL(454):	; F10LCALL
	TDZA	A0,A0		; F10 - SET A0 TO 0
LABEL(434):	;     CALL
LABEL(435):	;    ICALL
LABEL(436):	;    RCALL
LABEL(437):	;    DCALL
LABEL(440):	;    LCALL
	MOVEI	A0,1		; F40 - SET A0 TO 1

	SKIPE	A13,A0		; SKIP IF F10 & CLEAR A13
	MOVSI	A13,(JUMP)	; F40 - SET NOOP CODE
	HRRZS	A2,(SP)		; GET RETURN LINK
	HRRZ	A1,(A2)		; GET NUMBER OF PARAMETERS (+1)
	HRLI	A2,-1(A1)	; GET ACTUAL NUMBER OF PARAMETERS
	TLC	A2,-1		; GET -(N+1) IN L.H. OF A2
	AOBJN	A2,.+2		; ARE THERE ANY PARAMETERS ?
	SYSER1	10,0		; NO - FATAL ERROR
	MOVEI	A3,(SP)		; SAVE STACK POINTER
	PUSH	SP,A0		; STACK F10/F40 INDICATOR
	PUSH	SP,A0		; RESERVE WORD FOR ARRAY COUNT
	PUSH	SP,[JSP AX,PARAM]; STACK CALL TO PARAM
	SKIPN	A0		; WHAT TYPE OF FORTRAN ?
	TROA	A0,F10PMB	; F10 - A0 := F10 PMB ADDRESS
	MOVEI	A0,F40PMB	; F40 - A0 := F40 PMB ADDRESS
	PUSH	SP,A0		; STACK PMB ADDRESS
	PUSH	SP,[EXP 3]	; STACK INITIAL PL,,L
	IMULM	A1,(SP)		; (3 WORDS/PARAMETER + 3)
	PUSH	SP,A1		; STACK FTYPE,,M+1
	MOVE	A1,(A2)		; GET DESCRIPTOR FOR FIRST ARGUMENT
	TLC	A1,<$PRO!$EXT>	; PREPARE FOR TESTS
	TLCN	A1,$PRO		; IS IT A PROCEDURE ?
	TLNE	A1,$STAT	; YES - IS IT EXTERNAL ?
CALL01:	SYSER1	7,0		; NO TO EITHER - FATAL ERROR
	HLLM	A1,(SP)		; SET TYPE BITS OF RESULT FOR PARAM
	HRRI	A1,.SUBR	; GET OFFSET WITHIN FIXED STACK
	SETZ	A4,		; CLEAR COUNT OF ARRAYS FOUND
	JRST	CALL03		; AND GO SET TYPE FIELD
CALL02:	HRRZI	A1,3(A1)	; GET NEXT OFFSET WITHIN FIXED STACK
	HLL	A1,(A2)		; GET KIND,TYPE,STATUS OF NEXT ACTUAL
	TLNN	A1,$ARR		; VARIABLE OR EXPRESSION ?
	JRST	CALL04		; YES
	TLNN	A1,$EXP		; NO - ARRAY ?
	AOJA	A4,CALL04	; YES (COUNT IT IN A4)
	TLC	A1,$EXT		; NO - MUST BE A PROCEDURE !
	TLNE	A1,$STAT	; WAS IT EXTERNAL ?
	SYSER1	7,0		; NO - FATAL ERROR
CALL03:	TLZA	A1,$TYPE	; [PRO] CLEAR TYPE FIELD
CALL04:	TLZA	A1,<$EXP!$TYPE!$STAT>; [VAR] SET KIND TO $VAR OR $ARR
	TLOA	A1,$ABN		; [PRO] SET TYPE TO WILD ARITH/BOOL/NON
	TLO	A1,<$AB!$FON>	; [VAR] SET WILD ARITHMETIC/BOOLEAN BY NAME
	PUSH	SP,A1		; STACK FORMAL PARAMETER DESCRIPTOR
	AOBJN	A2,CALL02	; REPEAT IF MORE PARAMETERS

	PUSH	SP,[JRST CALL05]; STACK RETURN JUMP
	PUSH	SP,A13		; SAVE OPCODE FOR DESCRIPTORS
	PUSH	SP,A3		; SAVE POINTER TO START
	PUSH	SP,(A3)		; STACK PROGRAM LINK
	MOVEM	A4,2(A3)	; SAVE COUNT OF ARRAYS
	JRST	3(A3)		; **** ENTER PARAM INTERLUDE ****

CALL05:	MOVE	A3,LINKDL-1(DL)	; PICK UP TOP-OF-STACK ON ENTRY TO FCALL
	HRRZ	A1,BLKPTR(DL)	; GET CURRENT TOP-OF-STACK (DELOCATED)
	HRLI	A1,DB		; SET DB INTO INDEX FIELD
	EXCH	A1,2(A3)	; SWAP WITH COUNT OF ARRAYS
	JUMPE	A1,.+3		; ARE THERE ANY ARRAYS ?
	PUSH	SP,A1		; IF SO, RESERVE ONE WORD ON
	SOJG	A1,.-1		; THE STACK FOR EACH ONE
	MOVEI	A2,CALL20	; GET INTERMEDIATE RETURN ADDRESS
	EXCH	A2,PRGLNK(DL)	; SWAP WITH (POSSIBLY DELOCATED) LINK
	EXCH	A2,(A3)		; SWAP THIS WITH ORIGINAL LINK
	SUBI	A2,@(A3)	; GET DIFFERENCE (-(N+1))
	AOS	A1,A2		; ADD 1 (STEP OVER COUNT OF PARAMETERS)
	ADD	A2,(A3)		; AND GET (DELOCATED?) ADDR OF DESCRIPTORS
	HRRZ	A0,.SUBR+1(DL)	; GET ADDRESS OF FORTRAN ROUTINE
	ADDM	A0,1(A3)	; SAVE IT (+1 IF F40 CALL)
	SUBI	A3,-2(DB)	; DELOCATE ADDRESS
	HRLI	A3,DB		; SET DB INTO INDEX FIELD
	MOVEM	A3,LINKDL-1(DL)	; AND SAVE IT
	HRLZI	A3,1(A1)	; SET A3 TO ARG-COUNT WORD FOR F10
	PUSH	SP,A3		; PUSH IT ONTO PARAMETER BLOCK
	MOVE	A3,[Z .SUBR(DL)]; GET DELOCATED POINTER INTO A3
	AOJGE	A1,CALL07	; JUMP IF NO PARAMETERS TO FORTRAN
CALL06:	HRRI	A2,1(A2)	; STEP TO NEXT DESCRIPTOR WORD
	HRRI	A3,3(A3)	; AND NEXT 3-WORD AREA ON LOCAL STACK
	MOVE	A4,@A2		; GET DESCRIPTOR WORD
	TLNN	A4,$ARR		; DECODE TYPE
	SKIPA	A13,[ARGVAR,,ARGEXP]; TYPE 0 (VAR) OR TYPE 1 (EXP)
	MOVE	A13,[ARGARR,,ARGPRO]; TYPE 2 (ARR) OR TYPE 3 (PRO)
	TLNN	A4,$EXP		; DECIDE WHICH HALF WE NEED
	MOVS	A13,A13		; LEFT HALF - SWAP HALVES
	PUSHJ	SP,(A13)	; EVALUATE ADDRESS INTO A13
	TLNN	A4,<$TYPE-$B>	; IS TYPE BOOLEAN ?
	TLO	A13,(Z 01,0)	; YES - FORTRAN TYPE CODE = 1
	TLNN	A4,<$TYPE-$I>	; IS TYPE INTEGER ?
	TLO	A13,(Z 02,0)	; YES - FORTRAN TYPE CODE = 2
	TLNN	A4,<$TYPE-$R>	; IS TYPE REAL ?
	TLO	A13,(Z 04,0)	; YES - FORTRAN TYPE CODE = 4
	TLNN	A4,<$TYPE-$LR>	; IS TYPE LONG REAL ?
	TLO	A13,(Z 10,0)	; YES - FORTRAN TYPE CODE = 8
	IOR	A13,LINKDL-2(DL); SET NOOP IF F40
	PUSH	SP,A13		; PUSH PARAMETER WORD ONTO STACK
	AOJL	A1,CALL06	; REPEAT FOR EACH PARAMETER
CALL07:	PUSH	SP,[POPJ SP,]	; PUSH RETURN INSTRUCTION (FOR F40)
	PUSH	SP,DB		; SAVE ENVIRONMENT
	PUSH	SP,DL		; ..
	MOVEI	A1,@LINKDL-1(DL); GET ADDRESS OF ARRAY-WORD POINTER
	AOS	A2,(A1)		; GET DELOCATED ADDRESS OF COUNT WORD
	MOVEI	A2,@A2		; CONVERT TO ABSOLUTE ADDRESS
	AOS	AX,A2		; POINT AX TO FORTRAN ARG BLOCK
	HLL	A2,-1(A2)	; GET AOBJN WORD OVER ARG BLOCK
	JUMPGE	A2,CALL09	; JUMP IF NO PARAMETERS TO FORTRAN
CALL08:	MOVE	A3,(A2)		; GET A FORTRAN DESCRIPTOR WORD
	HRRI	A3,@A3		; CONVERT TO ABSOLUTE ADDRESS
	TLZE	A3,17		; MAKE SURE INDEX FIELD IS ZERO
	MOVEM	A3,(A2)		; UPDATE ADDRESS IF DYNAMIC
	AOBJN	A2,CALL08	; REPEAT FOR EACH PARAMETER
CALL09:	MOVEI	A2,(SP)		; GET ADDRESS OF TOP-OF-STACK
	PUSH	SP,A2		; AND REMEMBER IT
	PUSHJ	SP,@-1(A1)	; **** CALL FORTRAN ROUTINE ****
	POP	SP,A2		; RETURN HERE FROM FORTRAN ROUTINE
	CAIE	A2,(SP)		; HAS STACK BEEN SHIFTED ?
	LIBERR	6,0		; YES - VERY FATAL
	POP	SP,DL		; RESTORE ENVIRONMENT
	POP	SP,DB		; ..
	MOVEM	A0,.EXIT+1(DL)	; STORE ANSWER (IF ANY)
	MOVEM	A1,.EXIT+2(DL)	; (2 WORDS IF LONG REAL)
CALL10:	SOS	A2,@LINKDL-1(DL); STEP ARRAY WORD POINTER BACK ONE
	SKIPGE	A1,@A2		; PICK UP A WORD
	JRST	CALL15		; NEGATIVE MEANS BLOCK POINTER
	HRRZ	A3,(A1)		; GET ALGOL BASE ADDRESS
	SOJ	A3,.+1		; (MINUS 1, FOR "PUSH")
	HLRZ	A4,(A1)		; AND FORTRAN BASE ADDRESS
	MOVE	A0,-2(A4)	; GET WORDS PER ELEMENT
CALL11:	MOVEI	A5,2(A1)	; GET ADDRESS OF TABLE
	PUSH	A3,(A4)		; COPY ONE WORD BACK TO ALGOL ARRAY
	CAIN	A0,2		; TWO WORDS PER ELEMENT ?
	PUSH	A3,1(A4)	; YES - COPY OVER SECOND WORD
CALL12:	ADD	A4,2(A5)	; STEP TO NEXT FORTRAN ADDRESS
	SOSLE	1(A5)		; ALL DONE FOR THIS SUBSCRIPT ?
	JRST	CALL11		; NO  - COPY NEXT ELEMENT
	MOVE	A6,0(A5)	; YES - RESET SUBSCRIPT RANGE
	MOVEM	A6,1(A5)	; TO (UB-LB)+1
	SUB	A4,-1(A5)	; STEP BACK OVER SUB-ARRAY
	MOVEI	A5,3(A5)	; STEP TO NEXT SUBSCRIPT
	SKIPE	(A5)		; ALL DONE ?
	JRST	CALL12		; IF NOT, CONTINUE COPYING
	SETZM	A0		; FLAG GIVING BACK SPACE
	PUSHJ	SP,GETOWN	; RETURN IT
	JRST	CALL10		; REPEAT FOR NEXT ARRAY

CALL15:	MOVEI	A2,@A2		; GET DESIRED TOP-OF-STACK
	SUBI	A2,(SP)		; GET CORRECTION TO SP
	HRLI	A2,(A2)		; GET CORRECTION IN LH ALSO
	ADD	SP,A2		; ADJUST STACK POINTER
	JRST	.EXIT(DL)	; **** UNWIND BLOCK STRUCTURE ****

CALL20:	MOVEI	A2,@(SP)	; GET ADDRESS OF RETURN ADDRESS (+2)
	SUBI	A2,2(SP)	; STEP STACK POINTER BACK OVER THE
	HRLI	A2,(A2)		; CALL TO PARAM THAT WAS BUILT UP
	ADD	SP,A2		; ON THE STACK
	POPJ	SP,		; AND RETURN TO CALLING PROGRAM
ARGVAR:	JUMPGE	A4,STATIC	; DYNAMIC VARIABLE ?
	PUSH	SP,A1		; YES - SAVE CURRENT VALUES
	PUSH	SP,A2		; OF A1,A2 AND A3
	PUSH	SP,A3		; ..
	XCTA	@A3		; TRY AND GET ADDRESS OF VARIABLE
	HRRZ	A13,A2		; SUCCESS - GET 23-BIT ADDRESS
	CAIG	A13,(SP)	; IN A13 (DELOCATED IF DYNAMIC,
	CAIG	A13,(DB)	; IN WHICH CASE WE NEED TO SET
	JRST	.+3		; DB IN THE INDEX FIELD, AND
	SUBI	A13,(DB)	; SET THE RIGHT HALF OF A13
	HRLI	A13,DB		; TO THE OFFSET FOR THIS VARIABLE)
	JRST	ARGRET		; RESTORE A1,A2,A3,A4 & RETURN
STATIC:	HLRZ	A13,A4		; GET DESCRIPTOR
	ANDI	A13,$STATUS	; MASK TO STATUS FIELD
	CAIN	A13,$FON	; AND IF FORMAL-BY-NAME
	JRST	ARGEXP		; TREAT AS A LOCAL (BY VALUE)
	MOVEI	A13,@A3		; GET ACTUAL ADDRESS OF 3-WORD BLOCK
	TLNE	A4,$VAR1	; LONG REAL ?
	JUMPG	DB,.+2		; YES - SPECIAL IF KA10
	SKIPA	A13,(A13)	; GET F[0] (MOVE/DMOVE INSRUCTION)
	MOVE	A13,2(A13)	; LR ON KA10 - ADDRESS IS IN F[2]
	TLZ	A13,777760	; CLEAR OPCODE & AC FIELDS
	POPJ	SP,		; AND RETURN

ARGEXP:	PUSH	SP,A1		; ACTUAL ARGUMENT IS AN EXPRESSION
	PUSH	SP,A2		; FIRST SAVE A1,A2 AND A3, AS EXPRESSION
	PUSH	SP,A3		; COULD INVOLVE A PROCEDURE CALL
	XCT	@A3		; EVALUATE EXPRESSION INTO A0,A1
	MOVEI	A3,@(SP)	; GET ADDRESS OF 3 WORD AREA ON LOCAL
	MOVEM	A0,0(A3)	; FIXED STACK, AND USE THIS TO STORE
	MOVEM	A1,1(A3)	; THE VALUE OF THE EXPRESSION
	MOVE	A13,(SP)	; GET ADDRESS OF PARAMETER
	JRST	ARGRET		; RESTORE A1,A2,A3,A4 & RETURN
ARGARR:	PUSH	SP,A1		; SAVE CURRENT VALUES OF
	PUSH	SP,A2		; A1,A2,A3 (DELOCATED, AS
	PUSH	SP,A3		; GETOWN MAY SHIFT STACK)
	MOVEI	A1,@A3		; GET STATIC ADDRESS OF DESCRIPTOR
	HRLI	A1,A3		; AND SET A3 INTO INDEX FIELD
	MOVE	A2,1(A1)	; GET POINTER TO BOUND PAIRS
	HLRE	A0,A2		; GET -(NO OF SUBSCRIPTS) IN A0
	MOVEI	A5,1		; ASSUME ONE WORD PER ELEMENT
	TLNE	A4,$VAR1	; LONG REAL ARRAY ?
	MOVEI	A5,2		; YES - TWO WORDS PER ELEMENT
ARRAY1:	HRR	A1,(A1)		; GET ADDRESS OF 0'TH ELEMENT
	MOVE	A3,(A2)		; GET LOWER SUBSCRIPT BOUND
	HRRI	A1,@A1		; "ADD" OFFSET TO A1
	SUB	A3,1(A2)	; -(UB-LB)
	MOVN	A3,A3		; +(UB-LB)
	AOJ	A3,.+1		; (UB-LB)+1
	PUSH	SP,A3		; SAVE RANGE OF SUBSCRIPT
	IMUL	A5,A3		; AND ADJUST SIZE
	AOBJP	A2,ARRAY2	; LAST SUBSCRIPT ?
	AOJA	A2,ARRAY1	; NO - REPEAT FOR NEXT
EDIT(720); Correct base address for long real arrays
ARRAY2:	TLNE	A4,$VAR1	; [E720] LONG REAL ARRAY ?
	ADD	A1,-1(A2)	; [E720] YES - DOUBLE FINAL SUBSCRIPT
	PUSH	SP,A0		; SAVE NUMBER OF SUBSCRIPTS
	PUSH	SP,A1		; ADDRESS OF FIRST (ALGOL) ELEMENT
	PUSH	SP,A5		; SIZE OF ARRAY
	MOVN	A0,A0		; OVERHEAD = 3 WORDS PER DIMENSION
	IMULI	A0,3		; PLUS THREE HOUSEKEEPING
	ADDI	A0,3(A5)	; GET SIZE OF OWN AREA NEEDED
	PUSHJ	SP,GETOWN	; AND ASK FOR IT FROM OTS
	POP	SP,A2		; GET SIZE OF ARRAY AGAIN
	POP	SP,A0		; AND ADDRESS OF FIRST ALGOL ELEMENT
	HRRZM	A0,(A1)		; SAVE IN LOCAL AREA
	MOVEM	A2,1(A1)	; SAVE TOTAL ARRAY SIZE
	POP	SP,A0		; GET NUMBER OF DIMENSIONS
	MOVEI	A13,3(A1)	; INITIALIZE POINTER
ARRAY3:	POP	SP,A3		; GET RANGE OF SUBSCRIPT
	MOVEM	A3,-1(A13)	; SAVE SUBSCRIPT RANGE
	MOVEM	A3,00(A13)	; AND CURRENT VALUE
	IDIVI	A2,(A3)		; GET SUB-ARRAY SIZE
	MOVEM	A2,+1(A13)	; AND SAVE THAT AS WELL
	MOVEI	A13,3(A13)	; INCREASE POINTER BY THREE
	AOJL	A0,ARRAY3	; REPEAT FOR EACH SUBSCRIPT
	SETZM	-1(A13)		; SET FLAG WORD AT END
	HRLM	A13,(A1)	; ADDRESS OF FIRST (FORTRAN) ELEMENT
	AOS	A3,@LINKDL-1(DL); STEP POINTER TO ARRAY WORDS
	MOVEM	A1,@A3		; SAVE ADDRESS OF OWN AREA
	HRRZ	A3,(A1)		; GET ALGOL BASE ADDRESS
	HLRZ	A4,(A1)		; AND FORTRAN BASE ADDRESS
	MOVE	A0,-2(A4)	; GET WORDS/ELEMENT
	SOJ	A0,.+1		; A0 NOW NON-ZERO FOR TYPE LONG REAL
ARRAY4:	MOVEI	A5,2(A1)	; GET ADDRESS OF TABLE
	MOVE	A6,(A3)		; COPY ONE WORD OF THE ALGOL
	MOVEM	A6,(A4)		; ARRAY TO THE FORTRAN ARRAY
	AOJ	A3,.+1		; STEP ALGOL ARRAY ADDRESS
	JUMPE	A0,ARRAY5	; TWO WORDS PER ELEMENT ?
	MOVE	A6,(A3)		; YES - COPY OVER LOW ORDER
	MOVEM	A6,1(A4)	; WORD OF LONG REAL ITEM
	AOJ	A3,.+1		; STEP ALGOL ADDRESS AGAIN
ARRAY5:	ADD	A4,2(A5)	; STEP TO NEXT FORTRAN ADDRESS
	SOSLE	1(A5)		; FINISHED WITH THIS SUBSCRIPT ?
	JRST	ARRAY4		; NO  - COPY ANOTHER ELEMENT
	MOVE	A6,(A5)		; YES - GET SUBSCRIPT RANGE
	MOVEM	A6,1(A5)	; RESET SUBSCRIPT VALUE
	SUB	A4,-1(A5)	; STEP BACK OVER ENTIRE SUB-ARRAY
	MOVEI	A5,3(A5)	; STEP TO NEXT SUBSCRIPT
	SKIPE	(A5)		; LAST ONE ?
	JRST	ARRAY5		; IF NOT, CARRY ON COPYING
ARGRET:	POP	SP,A3		; RESTORE ORIGINAL VALUES
	POP	SP,A2		; OF A1,A2 AND A3
	POP	SP,A1		; ..
	MOVE	A4,@A2		; GET DESCRIPTOR WORD AGAIN
	POPJ	SP,

ARGPRO:	MOVEI	A13,(A4)	; GET PROCEDURE ADDRESS INTO A13
	POPJ	SP,		; AND RETURN

FORER.::LIBERR	7,0		; ALLOW FORTRAN TO HAVE ERRORS !

F40PMB:	0			; PROFILE WORD
	XWD	1,5		; WORDS,,BYTES
	SIXBIT	/CALL*/
F10PMB:	0			; PROFILE WORD
	XWD	2,10		; WORDS,,BYTES
	SIXBIT	/F10CAL/
	SIXBIT	/L*/
	LIT
	PRGEND
TITLE NEWSTRING - NEW BYTE STRING ROUTINE

; STRING PROCEDURE NEWSTRING(M,N); VALUE M,N; INTEGER M,N;

	.EXIT=1
	.M=4
	.N=5
	SEARCH	ALGPRM,ALGSYS

LIBENT(320,NEWSTRING)
	XWD	0,5
	XWD	$PRO!$S!$SIM,3
	XWD	$VAR!$I!$FOV,.M
	XWD	$VAR!$I!$FOV,.N

	MOVE	A0,.N(DL)	; BYTE SIZE
	JUMPLE	A0,.+2
	CAILE	A0,^D36		; 1 <= N <= 36?
	SYSER1	15,0		; NO - COMPLAIN
	MOVEI	A1,^D36
	IDIV	A1,A0		; NUMBER OF BYTES PER WORD
	MOVE	A0,.M(DL)	; NUMBER OF BYTES REQUIRED
	JUMPE	A0,NEW1		; TREAT SPECIAL CASE OF NULL STRING
	TLNE	A0,777700	; EXCEEDS MAXIMUM LENGTH?
	SYSER1	2,0		; YES - COMPLAIN
	IDIVI	A0,(A1)
	JUMPE	A1,.+2
	ADDI	A0,1		; CALCULATE NUMBER OF WORDS REQUIRED
	PUSHJ	SP,GETCLR	; AND ASK FOR THEM (ZEROED)
	MOVEM	A1,.EXIT+1(DL)	; SET UP FIRST WORD OF RESULT
	HRLZ	A0,.N(DL)
	LSH	A0,6
PATCH (5)	; REVISE STRING-HEADERS
	TLO	A0,440000
	HLLM	A0,.EXIT+1(DL)	; COMPLETE STR1
	MOVE	A0,.M(DL)	; GET NUMBER OF BYTES
	TLO	A0,STRDYN!STRPRC ; FLAG STRING DYNAMIC & RESULT OF PROC
	MOVEM	A0,.EXIT+2(DL)	; AND SET UP SECOND WORD OF RESULT
	JRST	.EXIT(DL)
PATCH (5)	; REVISE STRING-HEADERS
NEW1:	SETZM	.EXIT+2(DL)	; SPECIAL CASE OF A NULL STRING
	HRLZ	A0,.N(DL)
	LSH	A0,6
	MOVEM	A0,.EXIT+1(DL)
	JRST	.EXIT(DL)

	LIT
	PRGEND
TITLE LENGTH - LENGTH OF STRING ROUTINE

; INTEGER PROCEDURE LENGTH(S); STRING S;

	.EXIT=1
	.S=3
	SEARCH	ALGPRM,ALGSYS

LIBENT(321,LENGTH)
	XWD	0,5
	XWD	$PRO!$I!$SIM,2
	XWD	$VAR!$S!$FON,.S

	XCT	.S(DL)		; GET VALUE OF STRING
PATCH (5)	; REVISE STRING-HEADERS
	MOVEI	A2,@A2
EDIT(633); LENGTH OF NULL STRING SHOULD BE ZERO
	SKIPN	STR1(A2)	; [E633] IS THIS A NULL STRING ?
	TDZA	A0,A0		; [E633] YES - LENGTH IS ZERO
	LDB	A0,[
	POINT	24,STR2(A2),35]	; [E633] NO  - GET ITS LENGTH
	MOVEM	A0,.EXIT+1(DL)	; STORE RESULT
	JRST	.EXIT(DL)

	LIT
	PRGEND
TITLE SIZE - BYTE-SIZE OF STRING ROUTINE

	; INTEGER PROCEDURE SIZE(S); STRING S;

	.EXIT=1
	.S=3

	SEARCH	ALGPRM,ALGSYS

LIBENT(326,SIZE)
	XWD	0,5
	XWD	$PRO!$I!$SIM,2
	XWD	$VAR!$S!$FON,.S
	XCT	.S(DL)		; GET VALUE OF STRING
	MOVEI	A2,@A2		; STATICISE
	LDB	A0,[
	POINT	6,STR1(A2),11]	; GET BYTE-SIZE
	MOVEM	A0,.EXIT+1(DL)	;  & RETURN IT
	JRST	.EXIT(DL)

	LIT

	PRGEND
TITLE DELETE - DELETE STRING ROUTINE

; PROCEDURE DELETE(S); STRING S;

	.EXIT=1
	.S=2
	SEARCH	ALGPRM,ALGSYS

LIBENT(322,DELETE)
	XWD	0,4
	XWD	$PRO!$N!$SIM,2
	XWD	$VAR!$S!$FON,.S

	XCT	.S(DL)		; [E612]GET ADDRESS OF STRING
EDIT (612) ; CONSTANT A.P. FAILED.
PATCH (5)	; REVISE STRING-HEADERS
	MOVEI	A2,@A2

DEL1:	MOVE	A0,STR2(A2)
	TLNN	A0,STRDYN	; DYNAMIC?
	JRST	.EXIT(DL)	; NO - LEAVE THIS ONE
	HRRZ	A1,STR1(A2)
	JUMPE	A1,DEL2		; MAKE SURE THERE IS A BYTE STRING
	MOVEI	A0,0
	PUSH	SP,A2		; SAVE ADDRESS
	PUSHJ	SP,GETOWN	; DELETE STRING
	POP	SP,A2		; RESTORE ADDRESS
DEL2:	SETZM	STR1(A2)	; CLEAR BYTE STRING POINTER

	SETZM	A0,STR2(A2)	; CLEAR SECOND WORD
	JRST	.EXIT(DL)	; EXIT

	LIT
	PRGEND
	TITLE	CONCAT - STRING CONCATENATION ROUTINE

	SEARCH	ALGPRM,ALGSYS

; STRING PROCEDURE CONCAT(S1,S2,...,Sn); STRING S1,S2,...,Sn;

	.EXIT=1
	.N=4	; COUNT OF PARAMETERS
	.W=5	; WHERE IN STACK WE ARE
	.F=6
	.S=3

	DEFINE REP(M,S,I),<
	Q=0
	V=S-I
	REPEAT PRMMAX,<
	IF2,<
	Q=Q+1
	V=V+I>
	M(\Q,\V)>>

	DEFINE DEC(A,B),<
	IF2,<.S'A=B>>

	DEFINE PAR(A,B),<
	IF1,<BLOCK	1>
	IF2,<XWD $VAR!$S!$FON,.S'A>>

	REP(DEC,.F,.S)

LIBENT(325,CONCAT,.N)
	XWD	0,3*PRMMAX+5	; PL,,STACK-SIZE
	XWD	$PRO!$S!$SIM,PRMMAX+1; STRING PROCEDURE
	REP(PAR,.F,.S)		; WITH A VARIABLE NUMBER OF PARAMETERS
	SOSG	A1,.N(DL)	; GET COUNT OF PARAMETERS
	SYSER1	10,0		; NONE - ERROR.
	PUSH	SP,A1		; SAVE COUNT OF PARAMETERS
	SETZM	.EXIT+1(DL)	; INITIALIZE RESULT TO THE
	SETZB	A0,.EXIT+2(DL)	; NULL STRING
	PUSH	SP,A0		; AND SET MAXIMUM BYTE-SIZE TO ZERO
	MOVE	A0,[XWD DL,.F]	; INITIALIZE INDIRECT POINTER
	MOVEM	A0,.W(DL)	; IN W
CONCA1:	XCT	@.W(DL)		; GET A STRING HEADER INTO A0,A1
	SKIPN	A0		; IS IT A NULL STRING ?
	SETZ	A1,		; YES - SET LENGTH TO ZERO
	MOVEI	A2,@.W(DL)	; GET ACTUAL ADDRESS
	MOVEM	A0,STR1(A2)	; STORE BYTE POINTER
	MOVEM	A1,STR2(A2)	; AND LENGTH
	LDB	A0,[
	POINT	6,STR1(A2),11]	; GET BYTE-SIZE INTO A0
	LDB	A1,[
	POINT 24,STR2(A2),35]	; AND LENGTH INTO A1
	CAMLE	A0,(SP)		; IF THIS BYTE SIZE IS LARGEST
	MOVEM	A0,(SP)		; SO FAR, REMEMBER IT
	ADDB	A1,.EXIT+2(DL)	; ADD LENGTH INTO RUNNING TOTAL
	MOVEI	A2,.S		; THEN STEP .W TO POINT TO
	ADDM	A2,.W(DL)	; THE NEXT FORMAL PARAMETER
	SOSLE	.N(DL)		; COUNT DOWN PARAMETER COUNT
	JRST	CONCA1		; REPEAT FOR EACH PARAMETER

	POP	SP,A3		; GET BYTE-SIZE INTO A3
	POP	SP,.N(DL)	; AND RESTORE NUMBER OF PARAMETERS
	TLO	A1,STRDYN!STRPRC; MARK AS DYNAMIC, AND PROCEDURE RESULT
	EXCH	A1,.EXIT+2(DL)	; SAVE AS STR2 OF RESULT
	JUMPE	A1,CONCA7	; RETURN IF LENGTH IS ZERO
	MOVE	A0,A1		; GET NUMBER OF BYTES INTO A0
	MOVEI	A1,^D36		; FIND OUT HOW MANY BYTES
	IDIVI	A1,(A3)		; FIT INTO A 36-BIT WORD
	ADDI	A0,-1(A1)	; AND HENCE HOW MANY WORDS
	IDIVI	A0,(A1)		; WILL BE NEEDED FOR THE STRING
	ROT	A3,-^D12	; SHIFT BYTE-SIZE INTO BITS 6-11
	TLO	A3,440000	; SET 'P' FIELD
	MOVEM	A3,.EXIT+1(DL)	; AND STORE LH OF STR1 OF RESULT
	PUSHJ	SP,GETCLR	; GET THE SPACE NEEDED
	HRRM	A1,.EXIT+1(DL)	; AND STORE ADDRESS IN STR1.
	MOVE	A1,.EXIT+1(DL)	; GET BYTE-POINTER TO RESULT
	MOVEI	A2,.F(DL)	; GET ADDRESS OF FIRST HEADER
	SKIPA	A3,.N(DL)	; GET NUMBER OF STRINGS
CONCA2:	ADDI	A2,.S		; STEP ON TO NEXT STRING
	MOVE	A4,STR1(A2)	; GET BYTE POINTER TO SOURCE
	LDB	A5,[
	POINT 24,STR2(A2),35]	; GET LENGTH OF STRING
	JUMPE	A5,CONCA4	; IGNORE IF NULL STRING
CONCA3:	ILDB	A0,A4		; GET BYTE FROM SOURCE STRING
	IDPB	A0,A1		; STORE IN DESTINATION STRING
	SOJG	A5,CONCA3	; REPEAT FOR ENTIRE STRING
CONCA4:	SOJG	A3,CONCA2	; REPEAT FOR EACH STRING
CONCA5:	MOVNI	A2,.S		; GET SIZE OF ENTRY
	ADDB	A2,.W(DL)	; COUNT W DOWN TO POINT TO HEADER
	MOVEI	A2,@A2		; DELOCATE  ADDRESS
	MOVEI	A1,@STR1(A2)	; GET ADDRESS OF STRING
	MOVE	A0,STR2(A2)	; GET LENGTH INTO A0
	TLZE	A0,STRDYN	; IF STRING IS NOT DYNAMIC
	TLZN	A0,STRPRC	; OR NOT RESULT OF A PROCEDURE
	JRST	CONCA6		; LEAVE IT ALONE
	TDZE	A0,A0		; CLEAR A0 AND UNLESS ALREADY ZERO
	PUSHJ	SP,GETOWN	; CALL GETOWN TO RETURN THE SPACE
CONCA6:	SOSLE	.N(DL)		; COUNT ONE MORE CHECKED
	JRST	CONCA5		; REPEAT FOR EACH STRING
CONCA7:	JRST	.EXIT(DL)	; THEN RETURN

	LIT
	PRGEND
TITLE INSYMBOL - INPUT SYMBOL ROUTINE

; PROCEDURE INSYMBOL(I); INTEGER I;

	.EXIT=1
	.I=2
	SEARCH	ALGPRM,ALGSYS

LIBENT(401,INSYMBOL)
	XWD	0,4
	XWD	$PRO!$N!$SIM,2
	XWD	$VAR!$I!$FON,.I

	XCTA	.I(DL)		; GET ADDRESS OF I
	PUSH	SP,A2
	JSP	AX,INCHAR	; INPUT CHARACTER
	MOVE	A0,A13
	POP	SP,A2		; RESTORE ADDRESS.
	XCT	.I+1(DL)	; AND STORE IN I
	JRST	.EXIT(DL)

	LIT
	PRGEND






TITLE OUTSYMBOL - OUTPUT SYMBOL ROUTINE

; PROCEDURE OUTSYMBOL(N); VALUE N; INTEGER N;

	.EXIT=1
	.N=2
	SEARCH	ALGPRM,ALGSYS

LIBENT(402,OUTSYMBOL)
	XWD	0,2
	XWD	$PRO!$N!$SIM,2
	XWD	$VAR!$I!$FOV,.N

	MOVE	A13,.N(DL)	; GET BYTE
	MOVEI	AX,.EXIT(DL)
	JRST	OUCHAR		; AND OUTPUT IT

	LIT
	PRGEND
TITLE NEXTSYMBOL - NEXT SYMBOL ROUTINE

; PROCEDURE NEXTSYMBOL(I); INTEGER I;

	.EXIT=1
	.I=2
	SEARCH	ALGPRM,ALGSYS

LIBENT(403,NEXTSYMBOL)
	XWD	0,4
	XWD	$PRO!$N!$SIM,2
	XWD	$VAR!$I!$FON,.I

	PUSHJ	SP,NXTBYT	; GET NEXT BYTE
	IOERR	6,(A13)		; EOF - CHAN # IN A13
PATCH (17)	; IMPROVE I/O ERROR MESSAGES
	PUSH	SP,A13		; NOT EOF - BYTE IN A13
	XCTA	.I(DL)		; GET ADDRESS OF I
	POP	SP,A0		; RESTORE BYTE
	XCT	.I+1(DL)	; AND STORE IN I
	JRST	.EXIT(DL)

	LIT
	PRGEND
TITLE SKIPSYMBOL - SKIP SYMBOL ROUTINE

; PROCEDURE SKIPSYMBOL;

	.EXIT=1
	SEARCH	ALGPRM,ALGSYS

LIBENT(404,SKIPSYMBOL)
	XWD	0,1
	XWD	$PRO!$N!$SIM,1

	MOVEI	AX,.EXIT(DL)
	JRST	INCHAR		; INPUT BYTE AND IGNORE IT

	LIT
	PRGEND
TITLE BREAKOUTPUT - BREAK OUTPUT ROUTINE

; PROCDURE BREAKOUTPUT;

	.EXIT=1
	SEARCH	ALGPRM,ALGSYS

LIBENT(405,BREAKOUTPUT)
	XWD	0,1
	XWD	$PRO!$N!$SIM,1

	MOVEI	AX,.EXIT(DL)
	JRST	BRKCHR		; BREAK OUTPUT

	LIT
	PRGEND
TITLE SPACE - SPACE ROUTINE

; PROCEDURE SPACE(N); VALUE N; INTEGER N;

	.EXIT=1
	.N=2
	.V=3
	SEARCH	ALGPRM,ALGSYS

LIBENT(406,SPACE,.V)
	XWD	0,3
	XWD	$PRO!$N!$SIM,2
	XWD	$VAR!$I!$FOV,.N

	MOVEI	A0,1		; SET DEFAULT
	SOSE	.V(DL)		; ANY ARGUMENT
	MOVE	A0,.N(DL)	; YES - GET IT
	JUMPLE	A0,SPACE2	; IGNORE IF <= 0

SPACE1:	MOVEI	A13," "
	JSP	AX,OUCHAR	; OUTPUT SPACE
	SOJN	A0,SPACE1	; REPEAT UNTIL FINISHED

SPACE2:	JRST	.EXIT(DL)

	LIT
	PRGEND
TITLE TAB - TAB ROUTINE

; PROCEDURE TAB(N); VALUE N; INTEGER N;

	.EXIT=1
	.N=2
	.V=3
	SEARCH	ALGPRM,ALGSYS

LIBENT(407,TAB,.V)
	XWD	0,3
	XWD	$PRO!$N!$SIM,2
	XWD	$VAR!$I!$FOV,.N

	MOVEI	A0,1		; SET DEFAULT
	SOSE	.V(DL)		; ANY ARGUMENT?
	MOVE	A0,.N(DL)	; YES - GET IT
	JUMPLE	A0,TAB2		; IGNORE IF <= 0

TAB1:	MOVEI	A13,"	"
	JSP	AX,OUCHAR	; OUTPUT TAB
	SOJN	A0,TAB1		; REPEAT UNTIL FINISHED

TAB2:	JRST	.EXIT(DL)

	LIT
	PRGEND
TITLE NEWLINE - NEWLINE ROUTINE

; PROCEDURE NEWLINE(N); VALUE N; INTEGER N;

	.EXIT=1
	.N=2
	.V=3
	SEARCH	ALGPRM,ALGSYS

LIBENT(410,NEWLINE,.V)
	XWD	0,3
	XWD	$PRO!$N!$SIM,2
	XWD	$VAR!$I!$FOV,.N

	MOVEI	A0,1		; SET DEFAULT
	SOSE	.V(DL)		; ANY ARGUMENT
	MOVE	A0,.N(DL)	; YES - GET IT
	JUMPLE	A0,NEWL2	; IGNORE IF <= 0

NEWL1:	MOVEI	A13,CR
	JSP	AX,OUCHAR	; CARRIAGE RETURN
	MOVEI	A13,LF
	JSP	AX,OUCHAR	; LINE FEED
	SOJN	A0,NEWL1	; REPEAT UNTIL FINISHED
	TLNE	A11,TTYDEV	; TTY TYPE DEVICE?
	JSP	AX,BRKCHR	; YES - BREAK OUTPUT

NEWL2:	JRST	.EXIT(DL)

	LIT
	PRGEND
TITLE PAGE - PAGE ROUTINE

; PROCEDURE PAGE(N); VALUE N; INTEGER N;

	.EXIT=1
	.N=2
	.V=3
	SEARCH	ALGPRM,ALGSYS

LIBENT(411,PAGE,.V)
	XWD	0,3
	XWD	$PRO!$N!$SIM,2
	XWD	$VAR!$I!$FOV,.N

	MOVEI	A13,CR
	JSP	AX,OUCHAR	; CARRIAGE RETURN
	MOVEI	A13,LF
	JSP	AX,OUCHAR	; LINE FEED
	MOVEI	A0,1		; SET DEFAULT
	SOSE	.V(DL)		; ANY ARGUMENT
	MOVE	A0,.N(DL)	; YES - GET IT
	JUMPLE	A0,PAGE2	; IGNORE IF <= 0

PAGE1:	MOVEI	A13,FF
	JSP	AX,OUCHAR	; FORM FEED
	SOJN	A0,PAGE1	; REPEAT UNTIL FINISHED
	TLNE	A11,TTYDEV	; TTY TYPE DEVICE?
	JSP	AX,BRKCHR	; YES - BREAK OUTPUT

PAGE2:	JRST	.EXIT(DL)

	LIT
	PRGEND
TITLE READ - READ ROUTINE

; PROCEDURE READ(A); (INTEGER/REAL/LONG REAL/BOOLEAN/STRING) A;
	SEARCH	ALGPRM,ALGSYS

	DEFINE REP(M,A,I)
	<Q=0
	R=A-I
	REPEAT PRMMAX, <
	IF2,
	<Q=Q+1
	R=R+I>
	M \Q,\R>>

	DEFINE DECL(A,B)
	<IF2, <.WV'A=B>>

	DEFINE PAR(A,B)
	<IF1, <Z>
	IF2, <XWD	$VAR!$WV!$FON,.WV'A>>

	.EXIT=1
	.V1=2
	.V2=3
	REP	DECL,4,3

LIBENT(412,READ,.V1)
	XWD	0,3*PRMMAX+3
	XWD	$PRO!$N!$SIM,PRMMAX+1
	REP	PAR,4,3
	SOSN	A5,.V1(DL)	; CHECK NUMBER OF PARAMETERS
	SYSER1	10,0		; NONE
	MOVE	A1,PRGLNK(DL)	; GET PROGRAM LINK
	SUBI	A1,1(A5)	; MOVE BEFORE FIRST ACTUAL PARAMETER
	MOVEM	A1,.V1(DL)	; AND SAVE IN V1
	MOVN	A5,A5
	HRLZI	A5,(A5)
	HRRI	A5,.WV1(DL)	; MAKE COUNTER/POINTER TO FORMALS
	SUBI	A5,(DB)		; AND DELOCATE IT

READ12:	MOVEM	A5,.V2(DL)	; UPDATE FORMAL POINTER
	AOS	A1,.V1(DL)	; UPDATE ACTUAL POINTER
	HLRZ	A0,@A1
	ANDI	A0,$D!$KIND!$TYPE!$STAT
	CAIN	A0,$D!$VAR!$S!$REG
				; DYNAMIC VARIABLE REGULAR STRING?
	JRST	READ3		; YES - BYTE
	ANDI	A0,$TYPE	; GET TYPE
	CAIN	A0,$S
	JRST	READ4		; STRING
	MOVEI	A2,2		; SET UP FOR LONG REAL
	CAIN	A0,$LR
	JRST	READ1		; LONG REAL
	CAIE	A0,$R

READ3:	TDZA	A2,A2		; INTEGER/BOOLEAN
	MOVEI	A2,1		; REAL

READ1:	PUSH	SP,A2		; SAVE READ MODE
	MOVE	A5,.V2(DL)	; GET ADDRESS OF NEXT FORMAL
	ADDI	A5,(DB)
	XCTA	(A5)
	EXCH	A2,(SP)		; AND EXCHANGE THEM
	PUSHJ	SP,READ.	; READ NUMBER
	JOV	READOV		; [E714] TRAP OVERFLOW

READ2:	POP	SP,A2		; RESTORE ADDRESS OF PARAMETER
	AOS	A5,.V2(DL)	; INCREMENT FORMAL ADDRESS
	ADDI	A5,(DB)
	XCT	(A5)		; AND STORE RESULT


READ13:	AOS	A5,.V2(DL)
	AOBJN	A5,READ12	; CARRY ON IF MORE ACTUALS
	JRST	.EXIT(DL)
READ4:	MOVE	A5,.V2(DL)	; GET FORMAL ADDRESS
	ADDI	A5,(DB)
	XCTA	(A5)
	PUSH	SP,A2		; AND SAVE IT
	MOVEI	A0,0		; FOR DELETE
	MOVEI	A2,@A2		; STATICISE
	SKIPE	A1,STR1(A2)	; OLD STRING
	PUSHJ	SP,GETOWN	; DELETE, IF EXISTS
	MOVSI	A0,400000
EDIT(671) ; DONT WASTE TIME CLEARING THE SPACE FIRST
	PUSHJ	SP,GETOWN	; [E671] FLEX GETOWN
	HLRZ	A0,-1(A1)
	ADDI	A0,-2(A1)	; UPPER BOUND OF SPACE OBTAINED
	MOVEI	A2,0		; CLEAR BYTE COUNT
PATCH (5)	; REVISE STRING-HEADERS
	HRLI	A1,440700
	MOVE	A3,A1		; INITIAL BYTE POINTER

READ6:	JSP	AX,INCHAR
	CAIE	A13,""""	; SEARCH FOR "
	JRST	READ6

READ7:	JSP	AX,INCHAR	; GET NEXT SYMBOL
	CAIN	A13,""""	; "?
	JRST	READ9		; YES

READ8:	CAILE	A0,(A3)		; NO - SAFE TO STORE?
	JRST	READ5		; YES
EDIT(630); CHANGE CCORE 1,  TO CCORE1
	CCORE1	^D128		; [E630] NO - SHIFT UP THE STACK
	HRLZI	A4,^D128
	ADDM	A4,-1(A1)	; AND UPDATE THE LENGTH WORD
	ADDI	A0,^D128	; AND THE TOP ADDRESS

READ5:	IDPB	A13,A3		; YES - STORE BYTE
	AOJA	A2,READ7	; COUNT BYTES AND CONTINUE

READ9:	JSP	AX,INCHAR	; " FOUND
	CAIN	A13,""""	; ANOTHER "?
	JRST	READ8		; YES - STORE IT
	POP	SP,A4		; FINISHED - RESTORE STRING ADDRESS
	MOVEI	A4,@A4
	JUMPE	A2,READ11	; NULL STRING?
PATCH (5)	; REVISE STRING-HEADERS
	TLO	A2,STRDYN
				; NO - ADD CORRECT BITS TO COUNT
	LRSTOR	A1,STR1(A4)	; AND SET UP STRING WORDS
	SUBI	A0,(A3)		; REMAINING SPACE	EDIT # 317
	JUMPE	A0,READ14	; FINISHED IF ALL USED (UNLIKELY!)
	HRLZ	A0,A0		; MOVE TO LEFT HALF
	MOVEM	A0,1(A3)	; AND SET UP LENGTH OF REMAINDER EDIT # 317
	SUB	A0,-1(A1)
	MOVNM	A0,-1(A1)	; SET UP LENGTH OF USED PORTION
	MOVEI	A1,2(A3)	; SET UP ADDRESS OF REMAINDER EDIT #317

READ10:	MOVEI	A0,0
	PUSHJ	SP,GETOWN	; DELETE REMAINDER

READ14:	MOVE	A5,.V2(DL)
	ADDI	A5,2
	AOBJN	A5,READ12	; CARRY ON IF MORE
	JRST	.EXIT(DL)

READ11:	SETZM	STR1(A4)	; NULL STRING
	SETZM	STR2(A4)
PATCH (5)	; REVISE STRING-HEADERS
	JRST	READ10		; DELETE SPACE OBTAINED

EDIT(714); Trap fixed point overflow on data input
READOV:	HLRZ	A1,%CHAN(DB)	; [E714] GET CHANNEL NUMBER
	IOERR	11,(A1)		; [E714] CAUSE CORRECT ERROR

	LIT
	PRGEND
	TITLE	INLINE - READ NEXT LINE FROM INPUT

	; INTEGER PROCEDURE INLINE(S); STRING(S);

		.EXIT=1
		.CHAR=2
		.S=3
	SEARCH	ALGPRM,ALGSYS

	LIBENT(433,INLINE)
	XWD	0,5
	XWD	$PRO!$I!$SIM,2
	XWD	$VAR!$S!$FON,.S

	XCT	1,.S(DL)	; GET ADDRESS OF STRING
	PUSH	SP,A2		; SAVE IT ON THE STACK
	SETZB	A0,A1		; CLEAR COUNT
	MOVSI	A2,(POINT 7,A0)	; SET A2 TO A BYTE POINTER

INLIN1:	JSP	AX,INCHAR	; READ NEXT CHARACTER
	CAIL	A13,40		; CONTROL CHAR ?
	JRST	INLIN4		; NO - ACCEPT IT
	CAIN	A13,15		; CARRIAGE RETURN ?
	JRST	INLIN1		; YES - IGNORE IT
	CAIG	A13,14		; IS IT A TERMINATOR
	CAIG	A13,11		; (FF=14, VT=13, LF=12)
	JRST	INLIN3		; NO - ACCEPT CHAR
	MOVEM	A13,.CHAR(DL)	; SAVE TERMINATOR
	SKIPN	A2,A1		; ANY CHARACTERS READ ?
	JRST	INLIN2		; NO  - EASY
	EXCH	A0,(SP)		; YES - STORE FINAL WORD
	PUSH	SP,A0		; REPLACE HEADER ADDRESS
	ADDI	A2,4		; ROUND UP CHAR COUNT
	IDIVI	A2,5		; CONVERT TO # OF WORDS
	MOVNI	A0,-1(A2)	; GET -(# OF WORDS)
	ADDI	A0,-1(SP)	; GET BASE ADDRESS
	SUBI	A0,(DB)		; DELOCATE IT
	HRLI	A0,(<POINT 7,0(DB)>); AND FORM BYTE POINTER
	HRLI	A2,(A2)		; COPY COUNT TO L.H. OF A2
INLIN2:	EXCH	A2,(SP)		; SAVE COUNT, GET HEADER ADDRESS
	XCT	.S+1(DL)	; WRITE NEW STRING
	POP	SP,A2		; RESTORE COUNT
	SUB	SP,A2		; TIDY UP THE STACK
	JRST	.EXIT(DL)	; AND EXIT
INLIN3:	CAIN	A13,33		; ALTMODE ?
	JRST	INLIN5		; YES
	CAIN	A13,11		; OR TAB ?
	JRST	INLIN6		; YES
	MOVSI	A13,100(A13)	; NO - SAVE CONTROL CHAR
	HRRI	A13,"^"		; GET UP-ARROW
	JSP	AX,INLIN7	; PLACE IN BUFFER
	HLRZ	A13,A13		; GET CHAR AGAIN
INLIN4:	CAIE	A13,"["		; IF CHARACTER IS A SQUARE
	CAIN	A13,"]"		; BRACKET (SPECIAL CASE)
	JSP	AX,INLIN7	; PUT IT IN TWICE
	CAIL	A13,175		; IS IT AN ESCAPE ?
INLIN5:	MOVEI	A13,"$"		; YES - SUBSTITUTE DOLLAR
INLIN6:	MOVEI	AX,INLIN1	; SET TRANSFER ADDRESS
INLIN7:	TLNE	A2,760000	; FILLED A COMPLETE WORD ?
	JRST	INLIN8		; NO
	EXCH	A0,(SP)		; YES - PLACE IT ON THE STACK
	PUSH	SP,A0		; REPLACE HEADER ADDRESS
	MOVSI	A2,(POINT 7,A0)	; AND RESET BYTE POINTER
	SETZ	A0,		; CLEAR JUNK CHARS
INLIN8:	IDPB	A13,A2		; STORE CHARACTER IN A0
	AOJA	A1,(AX)		; AND GO READ NEXT

	LIT
	PRGEND
TITLE WRITE - WRITE STRING ROUTINE

; PROCEDURE WRITE(S); STRING(S);

	.EXIT=1
	.S=2
	SEARCH	ALGPRM,ALGSYS

LIBENT(413,WRITE)
	XWD	0,4
	XWD	$PRO!$N!$SIM,2
	XWD	$VAR!$S!$FON,.S

	XCT	.S(DL)		; GET ARGUMENT
	MOVEI	A2,@A2
	MOVEI	A4,0		; CLEAR SPECIAL MODE FLAG
	MOVEI	AX,WRIT5	; SET LINK

PATCH (5)	; REVISE STRING-HEADERS
WRIT1:	MOVE	A3,STR1(A2)	; GET BYTE-POINTER
	LDB	A1,[
	POINT	24,STR2(A2),35]	; GET STRING LENGTH

WRIT2:	SOJL	A1,.EXIT(DL)	; DECREMENT BYTE COUNT - EXHAUSTED?
	ILDB	A13,A3		; NO - LOAD UP BYTE
	JUMPE	A13,WRIT2	; IGNORE NULLS
	JRST	(AX)
WRIT4:	JSP	AX,WRIT2	; GET NEXT BYTE

WRIT5:	CAIN	A13,"["		; LEFT SQUARE BRACKET?
	XCT	[
	AOJA	A4,WRIT4
	AOJA	A4,WRIT4
	SOJA	A4,WRIT6]+1(A4)
	CAIN	A13,"]"		; NO - RIGHT SQUARE BRACKET?
	XCT	[
	AOJA	A4,WRIT6
	SOJA	A4,WRIT4
	SOJA	A4,WRIT6]+1(A4)
	XCT	[
	AOJA	A4,WRIT6
	JRST	WRIT6
	JRST	WRIT8]+1(A4)	; NO

WRIT6:	MOVEI	AX,WRIT4
	JRST	OUCHAR		; OUTPUT CHARACTER

WRIT7:	TDZA	A5,A5		; CLEAR COUNT (SUBSEQUENT TIMES)

WRIT8:	TDZA	A5,A5		; CLEAR COUNT (FIRST TIME)

WRIT9:	JSP	AX,WRIT2	; GET NEXT CHARACTER
	CAIL	A13,"0"
	CAIL	A13,"0"+^D10	; DIGIT?
	JRST	WRIT11		; NO
	JUMPL	A5,WRIT9	; YES - IGNORE IF OVERFLOWED
	IMULI	A5,^D10		; MULTIPLY BY TEN
	JOV	WRIT10		; AND CHECK FOR OVERFLOW
	ADDI	A5,-"0"(A13)	; ADD IN DIGIT
	JOV	WRIT10		; AND CHECK AGAIN
	JRST	WRIT9		; CARRY ON

WRIT10:	MOVNI	A5,1		; FLAG OVERFLOW
	JRST	WRIT9

WRIT11:	CAIN	A13,"]"		; RIGHT SQUARE BRACKET?
	SOJA	A4,WRIT4	; YES
	JUMPG	A5,WRIT12	; NO - GOT A NUMBER?
	AOJE	A5,WRIT9	; NO - SORT IT OUT
EDIT(625); RECCOGNISE SPECIAL CHARACTERS IN LOWER CASE
WRIT12:	ANDI	A13,137		; [E625] CONVERT LOWER CASE TO UPPER
	CAIN	A13,"S"
	JRST	WRIT18		; SPACE
	CAIN	A13,"T"
	JRST	WRIT17		; TAB
	CAIN	A13,"P"
	JRST	WRIT15		; PAGE
	CAIE	A13,"C"
	CAIN	A13,"N"
	JRST	WRIT13		; NEWLINE
	CAIE	A13,"B"
	JRST	WRIT7		; RUBBISH
	JRST	WRIT20		; BREAK

WRIT13:	MOVEI	A13,CR		; NEWLINE
	JSP	AX,OUCHAR
	MOVEI	A13,LF
	JSP	AX,OUCHAR
	SOJG	A5,WRIT13

WRIT14:	TLNE	A11,TTYDEV	; TTY TYPE DEVICE?

WRIT20:	JSP	AX,BRKCHR	; YES - BREAK OUTPUT
	JRST	WRIT9

WRIT15:	MOVEI	A13,CR		; PAGE
	JSP	AX,OUCHAR
	MOVEI	A13,LF
	JSP	AX,OUCHAR

WRIT16:	MOVEI	A13,FF
	JSP	AX,OUCHAR
	SOJG	A5,WRIT16
	JRST	WRIT14

WRIT17:	SKIPA	A7,["	"]	; TAB

WRIT18:	MOVEI	A7," "		; SPACE

WRIT19:	MOVE	A13,A7
	JSP	AX,OUCHAR
	SOJG	A5,WRIT19
	JRST	WRIT9

	LIT
	PRGEND
TITLE PRINT NUMBER ROUTINE

; PROCEDURE PRINT(I,M,N); VALUE I,M,N; INTEGER I,M,N;
; PROCEDURE PRINT(X,M,N); VALUE X,M,N; REAL X; INTEGER M,N;
; PROCEDURE PRINT(D,M,N); VALUE D,M,N; LONG REAL D; INTEGER M,N;

	.EXIT=1
	.IXD=2
	.M=4
	.N=5
	.V=6
	SEARCH	ALGPRM,ALGSYS

LIBENT(414,PRINT,.V)
	XWD	0,6
	XWD	$PRO!$N!$SIM,4
	XWD	$VAR!$WA!$FOV,.IXD
	XWD	$VAR!$I!$FOV,.M
	XWD	$VAR!$I!$FOV,.N

	SOSE	A5,.V(DL)
	JRST	PRIN1(A5)	; BRANCH ON NUMBER OF PARAMETERS

PRIN1:	SYSER1	10,0		; 0
	SETZM	.M(DL)		; 1
	SETZM	.N(DL)		; 2
	MOVM	A3,.M(DL)
	MOVM	A4,.N(DL)	; GET M,N
EDIT(737); Allow for stacked call to PRINT
	MOVEI	A1,@PRGLNK(DL)	; [E737] GET PROGRAM LINK
	SUBI	A1,(A5)		; AND LOCATE FIRST PARAMETER
	HLRZ	A0,(A1)
	ANDI	A0,$D!$KIND!$TYPE!$STAT
	MOVEI	A2,1		; SET REAL MODE
	CAIN	A0,$D!$VAR!$S!$REG
				; DYNAMIC VARIABLE REGULAR STRING?
	SOJA	A2,PRIN2	; YES - BYTE
	ANDI	A0,$TYPE	; GET ITS TYPE
	CAIN	A0,$I
	SOJA	A2,PRIN2	; INTEGER
	CAIN	A5,2		; TWO PARAMETERS?
	EXCH	A3,A4		; YES - SWAP M AND N
	CAIE	A0,$R
	MOVEI	A2,2		; LONG REAL

PRIN2:	LRLOAD	A0,.IXD(DL)	; LOAD UP FIRST PARAMETER
	PUSHJ	SP,PRINT.	; AND PRINT IT
	JRST	.EXIT(DL)

	LIT
	PRGEND
TITLE READOCTAL - READ OCTAL ROUTINE

; PROCEDURE READOCTAL(A); (INTEGER/REAL/LONG REAL/BOOLEAN) A;

	.EXIT=1
	.A=2
	SEARCH	ALGPRM,ALGSYS

LIBENT(415,READOCTAL)
	XWD	0,4
	XWD	$PRO!$N!$SIM,2
	XWD	$VAR!$AB!$FON,.A

	XCTA	.A(DL)		; GET ADDRESS OF A
	PUSH	SP,A2		; AND SAVE IT
	MOVE	A1,PRGLNK(DL)	; GET PROGRAM LINK
	HLRZ	A0,-1(A1)
	ANDI	A0,$TYPE	; GET TYPE
	CAIN	A0,$LR		; LONG REAL?
	JRST	RDOCT3		; YES

RDOCT1:	PUSHJ	SP,RDOCT	; READ OCTAL NUMBER

RDOCT2:	POP	SP,A2		; RESTORE ADDRESS OF A
	XCT	.A+1(DL)	; AND STORE RESULT
	JRST	.EXIT(DL)

RDOCT3:	PUSHJ	SP,RDOCT	; READ HIGH ORDER WORD
	PUSH	SP,A0		; AND SAVE IT
	PUSHJ	SP,RDOCT	; READ LOW ORDER WORD
	MOVE	A1,A0
	POP	SP,A0		; RESTORE LOW ORDER WORD
	JRST	RDOCT2

	LIT
	PRGEND
TITLE PRINTOCTAL - PRINT OCTAL ROUTINE

; PROCEDURE PRINTOCTAL(A); VALUE A; (INTEGER/REAL/LONG REAL/BOOLEAN) A;

	.EXIT=1
	.A=2
	SEARCH	ALGPRM,ALGSYS

LIBENT(416,PRINTOCTAL)
	XWD	0,4
	XWD	$PRO!$N!$SIM,2
	XWD	$VAR!$AB!$FOV,.A

	MOVE	A1,.A(DL)	; GET VALUE OF A
	MOVE	A2,PRGLNK(DL)	; GET PROGRAM LINK
	HLRZ	A2,-1(A2)
	ANDI	A2,$TYPE	; GET TYPE
	CAIN	A2,$LR		; LONG REAL?
	JRST	PROCT1		; YES
	PUSHJ	SP,PROWD	; NO - PRINT WORD
	JRST	.EXIT(DL)

PROCT1:	PUSH	SP,.A+1(DL)	; SAVE LOW ORDER WORD
	PUSHJ	SP,PROWD	; PRINT HIGH ORDER WORD
	MOVEI	A13," "
	JSP	AX,OUCHAR	; SPACE
	POP	SP,A1		; RESTORE LOW ORDER WORD
	PUSHJ	SP,PROWD	; AND PRINT IT
	JRST	.EXIT(DL)

PROWD:	MOVEI	A13,"%"		; PRINT OCTAL WORD
	JSP	AX,OUCHAR	; "%"
	MOVS	A1,A1
	PUSHJ	SP,PROCT	; PRINT HIGH HALF WORD
	MOVS	A1,A1
	JRST	PROCT		; PRINT LOW HALF WORD

	LIT
	PRGEND
TITLE INPUT/OUTPUT - INPUT/OUTPUT CHANNEL ROUTINES

; PROCEDURE INPUT(N,S,M,B,L); VALUE N,M,B,L; INTEGER N,M,B; STRING S; LABEL L;
; PROCEDURE OUTPUT(N,S,M,B,L); VALUE N,M,B,L; INTEGER N,M,B; STRING S; LABEL L;

	.EXIT=1
	.IO=2			; IO FLAG
	.N=3			; CHANNEL NUMBER
	.S=4			; DEVICE NAME/LOGICAL STRING
	.M=7			; MODE
	.B=10			; NUMBER OF BUFFERS
	.L=11
	.V=14
	SEARCH	ALGPRM,ALGSYS

LIBENT(417,INPUT,.V)
	XWD	0,14
	XWD	$PRO!$N!$SIM,6
	XWD	$VAR!$I!$FOV,.N
	XWD	$VAR!$S!$FON,.S
	XWD	$VAR!$IB!$FOV,.M
	XWD	$VAR!$I!$FOV,.B
	XWD	$VAR!$L!$FOV,.L
PATCH (17)	; PROVIDE  ERROR-RETURN FROM I/O ROUTINES
	SETZM	.IO(DL)			; FLAG AS INPUT
	JRST	IO1

LIBENT(420,OUTPUT,.V)
	XWD	0,14
	XWD	$PRO!$N!$SIM,6
	XWD	$VAR!$I!$FOV,.N
	XWD	$VAR!$S!$FON,.S
	XWD	$VAR!$IB!$FOV,.M
	XWD	$VAR!$I!$FOV,.B
	XWD	$VAR!$L!$FOV,.L
	MOVEI	A0,1
	MOVEM	A0,.IO(DL)		; FLAG AS OUTPUT
PATCH (32)	; PLANT PM BLOCKS

IO1:	SOSE	A1,.V(DL)

IO2:	JRST	IO2(A1)		; BRANCH ON NUMBER OF PARAMETERS
	SYSER1	10,0		; 0,1
	SETZM	.M(DL)		; 2
	SETZM	.B(DL)		; 3
	SETZM	.L(DL)		; 4
	SKIPL	A1,.N(DL)	; GET CHANNEL NUMBER
	CAIL	A1,40		; 0 <= N < 40?
	IOERR	14,(A1)		; NO - COMPLAIN
PATCH (17)	; IMPROVE I/O ERROR MESSAGES
	CAIGE	A1,20		; LOGICAL CHANNEL?
	JRST	IO3		; NO
	XCTA	.S(DL)		; YES - GET ADDRESS OF STRING
	MOVE	A0,A2
	MOVE	A1,.N(DL)	; RESTORE CHANNEL NUMBER
	MOVE	A2,.IO(DL)
	PUSHJ	SP,INPT(A2)	; AND OPEN LOGICAL DEVICE
PATCH	(17)	; PROVIDE ERROR-RETURN
	SKIPN	A1		; OK ?
	JRST	.EXIT(DL)
	SKIPE	A2,.L(DL)	; NO - ERROR LABEL ?
	XCT	.L(DL)		; YES - GET IT
	JUMPN	A2,(A2)		;  & GO THERE (A2=0 IF SWITCH OUT OF BOUNDS)
	XCT	A1		;   ELSE IOERR (LEFT IN A1 BY OTS)

IO3:	XCT	.S(DL)		; PHYSICAL DEVICE - GET STRING ADDRESS
PATCH (5)	; REVISE STRING-HEADERS
	MOVEI	A2,@A2		; STATICISE IT
	LDB	A0,[
	POINT	24,STR2(A2),35]	; GET ITS LENGTH
	CAIL	A0,6
	MOVEI	A0,6		; ONLY SIX BYTES REQUIRED
	JUMPE	A0,IO5		; NO NAME - FAILS LATER ON
	MOVE	A5,A0		; BYTE INDEX
	MOVEI	A0,0		; NAME ACCUMULATOR
	MOVSI	A6,(POINT	6,A0,)
				; SET UP BYTE POINTER
	MOVEI	A7,1		; BYTE NUMBER
	MOVE	A4,STR1(A2)	; GET BYTE POINTER TO STRING
PATCH (5)	; REVISE STRING-HEADERS

PATCH (5)	; REVISE STRING-HEADERS
IO4:	ILDB	A2,A4		; LOAD BYTE
	SUBI	A2,40
	JUMPL	A2,IO5		; TOO LOW
	CAILE	A2,132
	JRST	IO5		; TOO HIGH
	CAIL	A2,100		; LOWER CASE ALPHA?
	SUBI	A2,40		; YES - RECODE TO UPPER CASE ALPHA
	IDPB	A2,A6		; INSERT SIXBIT BYTE
	CAIE	A7,(A5)		; FINISHED?
	AOJA	A7,IO4		; NO

IO5:	MOVE	A1,.N(DL)	; GET CHANNEL NUMBER
	HRL	A1,.B(DL)	; GET NUMBER OF BUFFERS
	MOVE	A2,.M(DL)	; GET MODE
	MOVE	A3,.IO(DL)
	PUSHJ	SP,INPT(A3)	; AND GO TO INPT OR OUTPT
	SKIPE	A2,.L(DL)	; IF HE GAVE AN ERROR-LABEL
	XCT	.L(DL)		;  ELABORATE IT
	SKIPN	A1		; OK ?
PATCH (17)	; IMPROVE I/O ERROR MESSAGES
	JRST	.EXIT(DL)	; YES - RETURN
	JUMPN	A2,(A2)		; GOTO ERR (UNLESS IT'S AN OUT OF RANGE SWITCH)
	XCT	A1		; OTHERWISE IOERR (LEFT IN A1 BY OTS)

	LIT
	PRGEND
TITLE SELIN/SELOUT - SELECT INPUT/OUTPUT ROUTINES

; PROCEDURE SELECTINPUT(N); VALUE N; INTEGER N;
; PROCEDURE SELECTOUTPUT(N); VALUE N; INTEGER N;

	.EXIT=1
	.IO=2
	.N=3
	SEARCH	ALGPRM,ALGSYS

LIBENT(421,SELECTINPUT)
	XWD	0,3
	XWD	$PRO!$N!$SIM,2
	XWD	$VAR!$I!$FOV,.N
	MOVEI	A3,0		; FLAG AS SELIN
	JRST	SEL1

LIBENT(422,SELECTOUTPUT)
	XWD	0,3
	XWD	$PRO!$N!$SIM,2
	XWD	$VAR!$I!$FOV,.N
	MOVEI	A3,1		; FLAG AS SELOUT
PATCH (32)	; PLANT PM BLOCKS

SEL1:	MOVE	A1,.N(DL)	; GET ARGUMENT
	CAML	A1,[-1]
	CAIL	A1,40		; -1 <= N < 40?
	IOERR	14,(A1)		; NO - COMPLAIN
PATCH (17)	; IMPROVE I/O ERROR MESSAGES
	PUSHJ	SP,SELIN(A3)	; YES - SELECT RELEVANT INPUT/OUTPUT CHANNEL
	JRST	.EXIT(DL)

	LIT
	PRGEND
TITLE	INCHAN/OUTCHAN - INPUT/OUTPUT CHANNEL ROUTINES

;	INTEGER PROCEDURE INCHAN;
;	INTEGER PROCEDURE OUTCHAN;

	.EXIT=1
	.IO=2

	SEARCH	ALGPRM,ALGSYS		; SEARCH PARAMETER-FILE.

LIBENT(316,INCHAN)
	XWD	0,2
	XWD	$PRO!$I!$SIM,1
	MOVEI	A1,0			; FLAG AS INCHAN
	JRST	INCH1

LIBENT(317,OUTCHAN)
	XWD	0,2
	XWD	$PRO!$I!$SIM,1
	MOVEI	A1,1			; FLAG AS OUTCHAN
PATCH (32)	; PLANT PM BLOCKS

INCH1:	XCT	[
	HLRE	A0,%CHAN(DB)
	HRRE	A0,%CHAN(DB)](A1)
	MOVEM	A0,.IO(DL)		; CURRENT INPUT/OUTPUT CHANNEL
	JRST	.EXIT(DL)

	LIT
PRGEND
TITLE RELEASE - RELEASE ROUTINE

; PROCEDURE RELEASE(N); VALUE N; INTEGER N;

	.EXIT=1
	.N=2
	SEARCH	ALGPRM,ALGSYS

LIBENT(423,RELEASE)
	XWD	0,2
	XWD	$PRO!$N!$SIM,2
	XWD	$VAR!$I!$FOV,.N

	SKIPL	A1,.N(DL)	; GET ARGUMENT
	CAIL	A1,40		; 0 <= N < 40?
	IOERR	14,(A1)		; NO - COMPLAIN
PATCH (17)	; IMPROVE I/O ERROR MESSAGES
	PUSHJ	SP,RELESE	; YES - RELEASE RELEVANT CHANNEL
	IOERR	13,(A1)		; CHANNEL NOT IN USE
	JRST	.EXIT(DL)

	LIT
	PRGEND
TITLE OPENFILE - OPEN FILE ROUTINE

; PROCEDURE OPENFILE(N,S,P,PP,L,I); VALUE N,P,PP,L; INTEGER N,I; STRING S;
;	LABEL L; BOOLEAN P,PP;

	.EXIT=1
	.N=2
	.S=3
	.P=6
	.PP=7
	.L=10
	.I=13
	.LU=16
	.V=17
	SEARCH	ALGPRM,ALGSYS

LIBENT(424,OPENFILE,.V)
	XWD	0,17
	XWD	$PRO!$N!$SIM,7
	XWD	$VAR!$I!$FOV,.N
	XWD	$VAR!$S!$FON,.S
	XWD	$VAR!$IB!$FOV,.P
	XWD	$VAR!$IB!$FOV,.PP
PATCH (17)	; PROVIDE ERROR-RETURN
	XWD	$VAR!$L!$FOV,.L
	XWD	$VAR!$I!$FON,.I

	SOSE	A1,.V(DL)

OPF0:	JRST	OPF0(A1)	; BRANCH ON NUMBER OF PARAMETERS
	SYSER1	10,0		; 0,1
	SETZM	.P(DL)		; 2
	SETZM	.PP(DL)		; 3
	SETZM	.L(DL)		; 4
	SETZM	.I(DL)		; 5
	SKIPL	A1,.N(DL)	; GET CHANNEL NUMBER
	CAIL	A1,20		; 0 <= N < 20?
	IOERR	14,(A1)		; NO - COMPLAIN
PATCH (17)	; IMPROVE I/O ERROR MESSAGES
	XCT	.S(DL)		; GET ADDRESS OF STRING
	MOVEM	A2,.LU(DL)	;  AND SAVE IT
	SKIPE	A2,.L(DL)	; IF HE GAVE A LABEL
	XCT	.L(DL)		;  EVALUATE IT
	PUSH	SP,A2		;   AND SAVE IT
	SKIPE	.I(DL)	; IF HE GAVE A STATUS-WORD
	XCTA	.I(DL)		;  EVALUATE ITS ADDRESS
	PUSH	SP,A2		;   AND SAVE THAT
	MOVE	A2,.LU(DL)	; RESTORE ADDRESS OF STRING
PATCH (5)	; REVISE STRING-HEADERS
	MOVEI	A2,@A2		; STATICISE IT
	LDB	A0,[
	POINT	24,STR2(A2),35]	; GET ITS LENGTH
	MOVE	A4,STR1(A2)	; AND SAVE BYTE POINTER
	SETZB	A5,A6		; CLEAR FILE AND EXTENSION
	JUMPE	A0,OPF5		; NULL STRING?
	MOVE	A7,[
	POINT	6,A5,]		; BYTE POINTER FOR FILE NAME
	MOVEI	A10,1		; BYTE INDEX
OPF1:	PUSHJ	SP,OPF6		; GET NEXT BYTE
	CAIN	A2,'.'		; POINT?
	AOJA	A10,OPF3	; YES
	IDPB	A2,A7		; PLANT BYTE IN NAME
	CAIGE	A10,6		; NAME FULL?
	AOJA	A10,OPF1	; NO - KEEP GOING

OPF2:	PUSHJ	SP,OPF6		; SCAN FOR POINT
	CAIE	A2,'.'
	AOJA	A10,OPF2
	ADDI	A10,1

OPF3:	MOVE	A7,[
	POINT	6,A6,]		; BYTE POINTER FOR FILE EXTENSION
	MOVEI	A11,3		; BYTE COUNT

OPF4:	PUSHJ	SP,OPF6		; GET NEXT BYTE
	IDPB	A2,A7		; AND PLANT IT IN EXTENSION
	SOJE	A11,OPF5	; ANY MORE EXTENSION?
	AOJA	A10,OPF4	; NO - KEEP GOING

EDIT(672); FIX STACK ON RETURN FROM OPF6
OPF5A:	POP	SP,(SP)		; [E673] STEP BACK OVER RETURN ADDRESS
OPF5:	MOVE	A1,.N(DL)	; RESTORE CHANNEL NUMBER
	LRLOAD	A2,A5		; LOAD FILE NAME AND EXTENSION
	HRLZ	A4,.P(DL)
	LSH	A4,11		; PROTECTION
	MOVE	A5,.PP(DL)	; PROJECT-PROGRAMMER
	PUSHJ	SP,OPFILE	; AND OPEN FILE
PATCH (17)	; IMPROVE I/O ERROR MESSAGES
	POP	SP,A2		; GET ADDR OF I (OR 0)
	POP	SP,A3		; GET LABEL (OR 0)
	SKIPN	A0,		; ERROR ?
	JRST	.EXIT(DL)
	SUBI	A0,100		; ERR-CODE HAS 100 ADDED TO IT BY OTS
	SKIPE	.I(DL)		; YES - I ?
	XCT	.I+1(DL)	; YES - PUT ERROR-CODE IN IT
EDIT(654) ; FORLAB NEEDS ADDRESS IN A2, NOT A3 !
	SKIPE	A2,A3		; [E654] IS THERE AN ERROR EXIT ?
	JRST	(A2)		; [E654] IF SO, TAKE IT
	IOERR	5,(A1)		;  ELSE GIVE ERROR MESSAGE

OPF6:	CAMLE	A10,A0		; GET SIXBIT BYTE SUBROUTINE
	JRST	OPF5A		; [E673] NONE LEFT - ERROR RETURN
PATCH (5)	; REVISE STRING-HEADERS
	ILDB	A2,A4		; AND GET NEXT BYTE
	SUBI	A2,40
	JUMPL	A2,OPF7		; TOO LOW
	CAILE	A2,132
	JRST	OPF7		; TOO HIGH
	CAIL	A2,100		; LOWER CASE ALPHA?
	SUBI	A2,40		; YES - RECODE TO UPPER CASE ALPHA
	POPJ	SP,0

OPF7:	MOVEI	A2,0
	POPJ	SP,0

	LIT
	PRGEND
TITLE CLOSEFILE - CLOSEFILE ROUTINE

; PROCEDURE CLOSEFILE(N); VALUE N; INTEGER N;

	.EXIT=1
	.N=2
	SEARCH	ALGPRM,ALGSYS

LIBENT(425,CLOSEFILE)
	XWD	0,2
	XWD	$PRO!$N!$SIM,2
	XWD	$VAR!$I!$FOV,.N

	SKIPL	A1,.N(DL)	; GET ARGUMENT
	CAIL	A1,40		; 0 <= N < 40?
	IOERR	14,(A1)		; NO - COMPLAIN
PATCH (17)	; IMPROVE I/O ERROR MESSAGES
	PUSHJ	SP,CLFILE	; YES - CLOSE RELEVANT FILE
	JRST	.EXIT(DL)

	LIT
	PRGEND
TITLE TRANSFILE - TRANSFER FILE ROUTINE

; PROCEDURE TRANSFILE;

	.EXIT=1
	SEARCH	ALGPRM,ALGSYS

LIBENT(426,TRANSFILE)
	XWD	0,1
	XWD	$PRO!$N!$SIM,1

	PUSHJ	SP,XFILE	; TRANSFER FILE
	JRST	.EXIT(DL)

	LIT
	PRGEND
TITLE BACKSPACE - MAGNETIC TAPE BACKSPACE ROUTINE

; PROCEDURE BACKSPACE(N); VALUE N; INTEGER N;

	.EXIT=1
	.N=2
	SEARCH	ALGPRM,ALGSYS

LIBENT(427,BACKSPACE)
	XWD	0,2
	XWD	$PRO!$N!$SIM,2
	XWD	$VAR!$I!$FOV,.N

	SKIPL	A1,.N(DL)	; GET CHANNEL NUMBER
	CAIL	A1,20		; 0 <= N < 20?
	IOERR	14,(A1)		; NO - COMPLAIN
PATCH (17)	; IMPROVE I/O ERROR MESSAGES
	PUSHJ	SP,BSPACE
	JRST	.EXIT(DL)

	LIT
	PRGEND
TITLE ENDFILE - MAGNETIC TAPE ENDFILE ROUTINE

; PROCEDURE ENDFILE(N); VALUE N; INTEGER N;

	.EXIT=1
	.N=2
	SEARCH	ALGPRM,ALGSYS

LIBENT(430,ENDFILE)
	XWD	0,2
	XWD	$PRO!$N!$SIM,2
	XWD	$VAR!$I!$FOV,.N

	SKIPL	A1,.N(DL)	; GET CHANNEL NUMBER
	CAIL	A1,20		; 0 <= N < 20?
	IOERR	14,(A1)		; NO - COMPLAIN
PATCH (17)	; IMPROVE I/O ERROR MESSAGES
	PUSHJ	SP,ENFILE
	JRST	.EXIT(DL)

	LIT
	PRGEND
TITLE REWIND - MAGNETIC TAPE REWIND ROUTINE

; PROCEDURE REWIND(N); VALUE N; INTEGER N;

	.EXIT=1
	.N=2
	SEARCH	ALGPRM,ALGSYS

LIBENT(431,REWIND)
	XWD	0,2
	XWD	$PRO!$N!$SIM,2
	XWD	$VAR!$I!$FOV,.N

	SKIPL	A1,.N(DL)	; GET CHANNEL NUMBER
	CAIL	A1,20		; 0 <= N < 20?
	IOERR	14,(A1)		; NO - COMPLAIN
PATCH (17)	; IMPROVE I/O ERROR MESSAGES
	PUSHJ	SP,REWND.
	JRST	.EXIT(DL)

	LIT
	PRGEND
TITLE IOCHAN - INPUT/OUTPUT CHANNEL STATUS ROUTINE

; BOOLEAN PROCEDURE IOCHAN(N); VALUE N; INTEGER N;

	.EXIT=1
	.N=3
	SEARCH	ALGPRM,ALGSYS

LIBENT(432,IOCHAN)
	XWD	0,3
	XWD	$PRO!$B!$SIM,2
	XWD	$VAR!$I!$FOV,.N

EDIT(672) ; ALLOW IOCHAN TO REFERENCE DEFAULT TTY CHANNEL
	AOSL	A1,.N(DL)	; [E672] GET CHANNEL NUMBER + 1
	CAILE	A1,40		; [E672] -1 <= N < 40?
	IOERR	14,(A1)		; NO - COMPLAIN
PATCH (17)	; IMPROVE I/O ERROR MESSAGES
	ADDI	A1,-1(DB)	; [E672] RELOCATE CHANNEL NUMBER
	MOVE	A0,%IODR(A1)	; GET CHANNEL ENTRY
	HLRZM	A0,.EXIT+1(DL)	; AND SET UP RESULT
	JRST	.EXIT(DL)

	PRGEND
TITLE INFO - GENERAL INFORMATION ROUTINE

; INTEGER PROCEEDURE INFO(I); INTEGER I; VALUE I;

	.EXIT=1
	.I=3

	SEARCH	ALGPRM,ALGSYS

	EXTERNAL .JBREL

LIBENT(441,INFO)
	XWD	0,3
	XWD	$PRO!$I!$SIM,2
	XWD	$VAR!$I!$FOV,.I

	SETO	A2,		; PRESET ANSWER
	MOVE	A1,.I(DL)	; GET FUNCTION REQUIRED
	CAIL	A1,0		; SENSIBLE ?
	CAIL	A1,MAXINF
	AOJA	A2,INFO1	; NO
	XCT	INFOTB(A1)	; DO IT
INFO1:	MOVEM	A2,.EXIT+1(DL)	;  AND RETURN RESULT
	JRST	.EXIT(DL)

INFOTB:	HRRZ	A2,.JBREL	; 0 -CORE SIZE
	DATE	A2,		; 1 - DATE (15 BIT FORMAT)
	TIMER	A2,		; 2 - TIME (TICKS FROM MIDNIGHT)
	MSTIME	A2,		; 3 - TIME (MSEC FROM MIDNIGHT)
	PUSHJ	SP,INFRUN	; 4 - RUNTIME
	PUSHJ	SP,INFPRC	; 5 - PROCESSOR (1=KA,2=KI,3=KL)
	MOVE	A2,%SYS20(DB)	; 6 - # OF STACK-SHIFTS
	MOVE	A2,%SYS23(DB)	; 7 - COMPILER VERSION WORD

	MAXINF==.-INFOTB

INFRUN:	PJOB	A2,
	RUNTIM	A2,
	POPJ	SP,

INFPRC:	HLRZ	A2,DB
	LSH	A2,-^D16	; GET OMC BITS (PROCESSOR TYPE)
	AOS	2(A2)		; KLUDGE - IF 0, MAKE IT 1 !
	POPJ	SP,

	PRGEND
TITLE FDATE/VDATE - STRING DATE ROUTINES

; STRING PROCEDURE FDATE/VDATE;

	.EXIT=1
	.LU=4

	SEARCH	ALGPRM,ALGSYS

	EXTERNAL .JBREL

LIBENT(442,FDATE)
	XWD	0,4
	XWD	$PRO!$SIM!$S,1
	MOVEI	A0,3		; FLAG AS FDATE
	JRST	DATE0

LIBENT(443,VDATE)
	XWD	0,4
	XWD	$PRO!$SIM!$S,1
	MOVEI	A0,77

PATCH(32)	; PLANT PM BLOCKS
DATE0:	MOVEM	A0,.LU(DL)
	MOVEI	A0,4
	PUSHJ	SP,GETCLR	; GET SPACE
	HRLI	A1,440700	; MAKE BYTE-POINTER
	MOVEM	A1,.EXIT+1(DL)	; SET AS WORD 0 OF ANSWER
	MOVEI	A4,^D8		; INITIALIZE COUNT
	MOVE	A2,[
	XWD	%CNDAY,.GTCNF]
	GETTAB	A2,		; GET YEAR
	LIBERR	5,0		; DISASTER !
	IDIVI	A2,^D10
	ADDI	A2,"0"		; TO ASCII
	CAIN	A2,"0"		; IF 0
	MOVEI	A2," "		;  SUPPRESS IT
	IDPB	A2,A1
	ADDI	A3,"0"
	IDPB	A3,A1
	MOVEI	A5,"-"
	IDPB	A5,A1
	MOVE	A2,[
	XWD	%CNMON,.GTCNF]
	GETTAB	A2,		; GET MONTH
	LIBERR	5,0		; FAILED
	LSH	A2,1		; * 2
	ADD	A2,[
	POINT	7,MONTAB-2]	; GET POINTER TO ASCII MONTH
	MOVE	A0,.LU(DL)		; RECOVER # CHARS (3 OR MANY)

DATE2:	ILDB	A3,A2		; GET CHARACTER OF MONTH
	SOJL	A0,DATE3	; DONE IF FDATE & 3 CHARS DONE
	JUMPE	A3,DATE3	;  OR IF VDATE & ALL DONE
	IDPB	A3,A1
	AOJA	A4,DATE2	; COUNT THE CHARACTERS

DATE3:	IDPB	A5,A1		; "-"
	MOVE	A2,[
	XWD	%CNYER,.GTCNF]
	GETTAB	A2,		; GET YEAR
	LIBERR	5,0

DATE4:	IDIVI	A2,^D10
	ADDI	A3,"0"
	PUSH	SP,A3
	JUMPN	A2,DATE4
	MOVEI	A0,4
	POP	SP,A3
	IDPB	A3,A1
	SOJG	A0,.-2
	TLO	A4,STRDYN!STRPRC ; MARK DYNAMIC (R.H. = # CHARS)
	MOVEM	A4,.EXIT+2(DL)	;  AND PLANT AS WORD 2 OF RESULT
	JRST	.EXIT(DL)
MONTAB:
ASCIZ/January/
ASCIZ/February/
ASCIZ/March/
ASCIZ/April/
ASCIZ/May/
0		; THEY MUST ALL BE 2 WORDS LONG
ASCIZ/June/
0
ASCIZ/July/
0
ASCIZ/August/
ASCIZ/Septmeber/
ASCIZ/October/
ASCIZ/November/
ASCIZ/December/

	PRGEND
TITLE TIME - GET TIME OF DAY STRING ROUTINE

; STRING PROCEDURE TIME;

	.EXIT=1

	SEARCH	ALGPRM,ALGSYS

LIBENT(444,TIME)
	XWD	0,3
	XWD	$PRO!$SIM!$S,1

	MOVEI	A0,2
	PUSHJ	SP,GETCLR	; GET SPACE FOR STRING
	HRLI	A1,440700	; MAKE BYTE-POINTER TO IT
	MOVE	A2,[
	STRDYN!STRPRC,,^D8]
	LRSTOR	A1,.EXIT+1(DL)	; THE ANSWER (8 CHARS, DYNAMIC, RESULT-OF-PROC)
	MOVEI	A4,":"		; GET SEPARATOR
	MOVE	A2,[
	XWD	%CNHOR,.GTCNF]
	PUSHJ	SP,TIME2	; GET HOUR & CONVERT TO ASCII
	IDPB	A4,A1		; DEPOSIT SEPARATOR
	MOVE	A2,[
	XWD	%CNMIN,.GTCNF]	; MINUTE
	PUSHJ	SP,TIME2
	IDPB	A4,A1
	MOVE	A2,[
	XWD	%CNSEC,.GTCNF]	; SECOND
	PUSHJ	SP,TIME2
	JRST	.EXIT(DL)	; DONE

TIME2:	GETTAB	A2,		; GET THE PIECE OF TIME
	LIBERR	5,0		; CAN'T
	IDIVI	A2,^D10
	ADDI	A2,"0"
	ADDI	A3,"0"
	IDPB	A2,A1
	IDPB	A3,A1
	POPJ	SP,

	PRGEND
TITLE RAN / SETRAN / SAVRAN - RANDOM NUMBER GENERATOR

; INTEGER PROCEDURE RAN;
; PROCEDURE SETRAN(I); VALUE I; INTEGER I;
; INTEGER PROCEDURE SAVRAN;

	.EXIT=1
	.I=2

	SEARCH	ALGPRM,ALGSYS

LIBENT(445,RAN)
	XWD	0,2
	XWD	$PRO!$SIM!$I,1

	MOVE	A0,[
	4544503720]		; 14**29
	MUL	A0,%RAND(DB)	; LAST NUMBER
	ASHC	A0,4
	LSH	A1,-4
	ADD	A0,A1
	TLZE	A0,760000	; IF OVERFLOW
	ADDI	A0,1		;  ADD 1
	MOVEM	A0,%RAND(DB)
	MOVEM	A0,.EXIT+1(DL)	; RETURN IT
	JRST	.EXIT(DL)


LIBENT(446,SETRAN)
	XWD	0,2
	XWD	$PRO!$SIM!$N,2
	XWD	$VAR!$I!$FOV,.I

	SKIPN	A1,.I(DL)	; IF PARAM IS 0
	MOVE	A1,[
	XWD	1,-1]		;  THEN SET DEFAULT START
	MOVEM	A1,%RAND(DB)
	JRST	.EXIT(DL)



LIBENT(447,SAVRAN)
	XWD	0,2
	XWD	$PRO!$SIM!$I,1
	MOVE	A1,%RAND(DB)
	MOVEM	A1,.EXIT+1(DL)	; RETURN LAST RANDOM NUMBER 
	JRST	.EXIT(DL)

	PRGEND
TITLE TRACEON /OFF - TURN ON/OFF DYNAMIC TRACE FLAG.

; PROCEDURE TRACEON;
; PROCEDURE TRACEOFF;

	.EXIT=1

	SEARCH	ALGPRM,ALGSYS

LIBENT(455,TRACEON)
	XWD	0,1
	XWD	$PRO!$N!$SIM,1
	TLO	DB,STMTST	; LIGHT BIT.
	JRST	.EXIT(DL)

LIBENT(456,TRACEOFF)
	XWD	0,1
	XWD	$PRO!$N!$SIM,1
	TLZ	DB,STMTST
	JRST	.EXIT(DL)

	PRGEND
TITLE TRAPNO - GET TRAP # (USE ONLY IN TRAP ROUTINE)

; INTEGER PROCEDURE TRAPNO;

	.EXIT=1

	SEARCH	ALGPRM,ALGSYS

LIBENT(460,TRAPNO)
	XWD	0,2
	XWD	$PRO!$I!$SIM,1
	HLRZ	A0,%SYS17(DB)
	ANDI	A0,77		; ISOLATE TRAP #
	MOVEM	A0,.EXIT+1(DL)
	JRST	.EXIT(DL)

	PRGEND
TITLE PAUSE - DO AN EXIT 1,

; PROCEDURE PAUSE;

	.EXIT=1

	SEARCH	ALGPRM,ALGSYS

LIBENT(461,PAUSE)
	XWD	0,1
	XWD	$PRO!$N!$SIM,1
	EXIT	1,
	JRST	.EXIT(DL)

	PRGEND
TITLE DUMP - GET ALGDDT DUMP.

; PROCEDURE DUMP(N); VALUE(N); INTEGER(N); !N IS # OF BLOCKS TO DUMP. 0 = ALL;

	.EXIT=1
	.N=2

	SEARCH	ALGPRM,ALGSYS

LIBENT(462,DUMP)
	XWD	0,2
	XWD	$PRO!$N!$SIM,2
	XWD	$VAR!$I!$FOV,.N
	SKIPN	A7,.N(DL)
	MOVEI	A7,777777	; 'ALL'
	PUSHJ	SP,DDDUMP	; DO IT (TO CURRENT O/P CHANNEL)
	JRST	.EXIT(DL)

	END