;
;
;COPYRIGHT (C) 1975,1981,1982 BY
;DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS.
;
;
;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY BE USED AND COPIED
;ONLY  IN  ACCORDANCE  WITH  THE  TERMS  OF  SUCH LICENSE AND 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.  NO TITLE TO AND OWNERSHIP OF THE  SOFTWARE  IS  HEREBY
;TRANSFERRED.
;
;THE INFORMATION IN THIS SOFTWARE IS SUBJECT TO CHANGE WITHOUT  NOTICE
;AND  SHOULD  NOT  BE  CONSTRUED  AS A COMMITMENT BY DIGITAL EQUIPMENT
;CORPORATION.
;
;DIGITAL ASSUMES NO RESPONSIBILITY FOR THE USE OR RELIABILITY  OF  ITS
;SOFTWARE ON EQUIPMENT WHICH IS NOT SUPPLIED BY DIGITAL.
;
;
; SUBTTL GLOBAL DECLARATIONS

	SEARCH ALGPRM,ALGSYS		; SEARCH PARAMETER FILES

	SALL

%TITLE(ALGLIB,ALGOL LIBRARY)

	IF2, <
	IFE PROC-KA10, <PRINTX KA10 version>
	IFE PROC-KI10, <PRINTX KL/KI-10 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

	.GTRDI==136		; [275] GETTAB CODE FOR PROG. RUN DIRECTORY
	.GTRFN==137		; [275] PROGRAM RUN FILENAME
	.GTRDV==135		; [275] PROGRAM RUN DEVICE
	.GTRS0==145		; [275] GETTAB FUNCTION CODE FOR SFD'S
	.PTSFD==3		; [275] PATH. BLOCK INDEX FOR SFD'S
	.PTPPN==2		; [275] INDEX FOR PPN

	LOC	.JBREN
	%REN			; [275] 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	A0,IFDAT+1	; [275] SAVE PROGRAM NAME (PRE 7.00 ONLY)
	MOVEM	A7,IFDAT	; [275] SAVE RUN PPN FOR FUNCT.
	MOVEM	A11,IFDAT+2	; [275] SAVE DEVICE NAME
	HRROI	A1,.GTRFN	; [275] SETUP TO GET PROGRAM NAME
	GETTAB	A1,		; [275] GET IT
	 SKIPA			; [275] FAILED, ASSUME WE ALREADY SAVED IT
	MOVEM	A1,IFDAT+1	; [275] SAVE IT
	HRROI	A1,.GTRDV	; [275] SETUP TO GET DEVICE
	GETTAB	A1,		; [275] GET IT
	 SKIPA			; [275] FAILED, ASSUME WE ALREADY SAVED IT
	MOVEM	A1,IFDAT+2	; [275] SAVE IT
	SETZM	PATH+.PTSFD	; [275] INIT. TO HAVE NO SFD'S
	MOVSI	A1,-5		; [275] LOAD PTR. TO BUILD PATH BLOCK (5 SFDS)
GET275:	HRROI	A2,.GTRS0(A1)	; [275] LOAD SFD NAME
	GETTAB	A2,		; [275] GET IT
	 JRST	GETDON		; [275] FAILED, ASSUME DONE
	MOVEM	A2,PATH+.PTSFD(A1) ; [275] WORKED, SAVE PTR.
	AOBJN	A1,GET275	; [275] LOOP UNTIL DONE
GETDON:	SETZM	PATH+.PTSFD(A1)	; [275] PUT ZERO AT END OF LIST
	HRROI	A1,.GTRDI	; [275] SETUP TO GET PPN PROGRAM CAME FROM
	GETTAB	A1,		; [275] GET IT
	 MOVE	A1,IFDAT	; [275] FAILED, ASSUME WE HAVE IT ALREADY
	MOVEM	A1,PATH+.PTPPN	; [275] SAVE RUN PPN
	SKIPE	PATH+.PTSFD	; [275] IF ANY SFD'S AROUND,
	MOVEI	A1,PATH		; [275] LOAD PATH BLOCK PTR.
	MOVEM	A1,IFDAT	; [275] ELSE USE PPN
	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:	OUTSTR	SEGMES		; [265] COMPLAIN ON TTY
	LDB	A1,[POINT 3,A0,32]  ; [265] ASSUME 2 DIGIT ERROR CODE
	ADDI	A1,"0"		; [265] CONVERT FIRST DIGIT TO ASCII
	CAIE	A1,"0"		; [275] SUPPRESS FIRST ZERO
	OUTCHR	A1		; [265] TYPE IT
	LDB	A1,[POINT 3,A0,35]  ; [265] GET SECOND DIGIT
	ADDI	A1,"0"		; [265] CONVERT TO ASCII
	OUTCHR	A1		; [265] TYPE IT
	OUTSTR	CRLF		; [265]
	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:	%BEGIN
	%ALGDA
	%OWN
	%FLAGS,,%HEAP
	%JBVER,,%JBEDT
IFDAT:	BLOCK	3		; INITIAL-FILE DATA FOR FUNCT.
	%TRACE			; TRACE BUFFER-LENGTH
PATH:	BLOCK	12		; [275] PATH BLOCK FOR FUNCT.

SEGMES:	ASCIZ /
?ALGOL object time system ALGNNN.EXE not found, GETSEG error code / ; [265]
CRLF:	ASCIZ/
/				; [265]

	ENTRY	FUNCT.

FUNCT.:	JRST	FUNCT	; OVERLAY-HANDLER SUB-ROUTINE ENTRY

	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]	;
	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.

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

;
; POWER1:
;
;	AC	USE AT ENTRY			USE AT EXIT
;	--	--------------------		----------------------
;
;	A0					ANSWER
;	A1	0 = RESULT MUST BE INTEGER
;		1 = RESULT MUST BE REAL
;		(COMPILER SAYS SO)
;	AX	RETURN ADDRESS			RETURN ADDRESS
;	(SP)	EXPONENT
;	-1(SP)	BASE
;

;
; POWER2:
;
;	AC	USE AT ENTRY			USE AT EXIT
;	--	--------------------		----------------------
;
;	A0					ANSWER
;	AX	RETURN ADDRESS			RETURN ADDRESS
;	(SP)	EXPONENT
;	-1(SP)	BASE
;

	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	; JUMP AHEAD IF EXPONENT IS NON-ZERO
	EDIT(050)		; 0^0 IS UNDEFINED, SO GENERATE ERROR MESSAGE
	JUMPE	A0,POW110	; [E050] ERROR IF BASE = 0 TOO
	XCT	[		; ELSE LOAD THE APPROPRIATE ANSWER FOR X^0
	MOVEI	A0,1		; INTEGER ANSWER
	MOVSI	A0,(1.0)	; REAL ANSWER
	MOVSI	A0,(1.0)	; REAL ANSWER
		](A1)		; (A1 = 0 FOR INTEGER, 1 OR 2 FOR REAL)
	JRST	(AX)		; RETURN TO CALLING ROUTINE

POW101:	JUMPN	A1,POW103	; JUMP AHEAD IF POWER1 ROUTINE IS NEEDED

;
;	POWER1 ROUTINE
;
;	AC	USE AT ENTRY		USE WITHIN ROUTINE
;	--	-------------------	---------------------------
;
;	A0	CONTAINS BASE		ANSWER IS BUILT HERE
;	A1	UNDEFINED		MODIFIED BASE
;	A2	EXPONENT		MODIFIED EXPONENT
;	AX	RETURN ADDRESS		RETURN ADDRESS
;
	JUMPE	A0,(AX)		; ELSE TAKE QUICK EXIT IF BASE = 0
	MOVE	A1,A0		; BASE ISN'T 0 - PUT IT IN A1
	MOVEI	A0,1		; PREPARE FOR INTEGER MULTIPLICATION

POW102:	TRZN	A2,1		; [230] IS LSB SET IN EXPONENT?
	JRST	.+3		; [230] NO, SKIP THE MATH
	IMUL	A0,A1		; YES, MULTIPLY ANSWER BY MODIFIED BASE
	JOV	POW109		; CHECK FOR OVERFLOW
	JUMPE	A2,(AX)		; RETURN IF FINISHED
	IMUL	A1,A1		; ELSE SQUARE BASE
	JOV	POW109		; CHECK FOR OVERFLOW
	LSH	A2,-1		; SHIFT EXPONENT RIGHT
	JRST	POW102		; KEEP DOING IT UNTIL DONE
;
;	POWER2 ROUTINE
;
;	AC	USE AT ENTRY		USE WITHIN ROUTINE
;	---	---------------------------------------------------
;
;	A0	CONTAINS BASE		ANSWER IS BUILT HERE
;	A1	BASE FLAG: 0=INTEGER	MODIFIED BASE
;		1=REAL, 2=OTHER
;	A2	EXPONENT		MODIFIED EXPONENT
;	A3	UNDEFINED		EXPONENT FLAG: 1=POSITIVE, 0=NEGATIVE
;
;	AX	RETURN ADDRESS		RETURN ADDRESS
;

POW103:	JUMPE	A0,POW107	; SKIP WHOLE ROUTINE IF BASE = 0
	SOJN	A1,POW104	; ELSE IS 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		; YES, TRANSFER BASE TO A1
	JUMPG	A2,POW105	; JUMP AHEAD IF EXPONENT IS POSITIVE
	MOVN	A2,A2		; ELSE MAKE IT POSITIVE
	JOV	POW109		; ERROR IF OVERFLOW HAPPENED
	TDZA	A3,A3		; ELSE CLEAR POSITIVE FLAG AND SKIP

POW105:	MOVEI	A3,1		; SET POSITIVE FLAG
	MOVSI	A0,(1.0)	; PREPARE FOR MULTIPLICATION/DIVISION
POW106:	TRZN	A2,1		; IS LSB SET IN EXPONENT?
	JRST	.+3		; NO, SKIP THE MATH
	XCT	[		; YES, DO THE APPROPRIATE MATH FUNCTION
	FDVR	A0,A1		; DIVIDE IF EXPONENT IS NEGATIVE
	FMPR	A0,A1		; MULTIPLY IF EXPONENT IS POSITIVE
		](A3)		; (A3 = 0 FOR NEG., 1 FOR POS. EXPONENT)
	JFOV	POW108		; CHECK FOR OVERFLOW
	JUMPE	A2,(AX)		; RETURN TO CALLING ROUTINE IF ALL DONE
	FMPR	A1,A1		; ELSE SQUARE BASE
	JFOV	POW108		; CHECK FOR OVERFLOW
	LSH	A2,-1		; SHIFT EXPONENT RIGHT
	JRST	POW106		; KEEP LOOPING UNTIL DONE

POW107:	JUMPG	A2,(AX)		; BASE IS ZERO - RETURN IF EXPONENT > 0
	SYSER2	2,(AX)		; [230] ELSE ERROR - CAN'T HAVE EXPONENT <= 0

POW108:	SKIPE	A3		; [230] OVERFLOW - WAS EXPONENT NEGATIVE?
	SYSER2	2,(AX)		; NO, A REAL FLOATING OVERFLOW HAPPENED
	MOVSI	A0,(0.0)	; [230] YES, IT'S OK - SET RESULT TO 0
	JRST	(AX)		; [230] RETURN TO CALLING ROUTINE

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

POW110:	LIBERR	1,(AX)		; [E050] 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
	INTERN	JBS236, POW306	; [236] DECLARE THESE SYMBOLS FOR KA10
				; [236] MATH FUNCTIONS TO USE AFTER ERROR

	%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(050); 0^0 is undefined, so generate error message
	JUMPE	A3,POW308	; [E050] 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		; [236] YES - MULTIPLY/DIVIDE
	DFMP	A0,A3](A10)
	JFOV	POW306
	>
	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
	JFOV	POW306		; [236] JUMP AHEAD IF OVERFLOW HAPPENED
	>			; [236]
JBS236:	LSH	A7,-1		; [236] SHIFT AROUND EXPONENT
	JRST	POW304		; AND CARRY ON

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

POW306:	TRNE	A10,1		; [236] OVERFLOW HAPPENED -WAS EXPONENT NEG.?
	SYSER2	2,@(SP)		; [236] NO, FATAL ERROR - FLOATING OVERLFLOW
	SETZB	A0,A1		; [236] YES, SET RESULT TO 0
	JRST	POW301		; [236] GO RETURN TO CALLING ROUTINE

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

POW308:	LIBERR	1,@(SP)		; [E050] 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(050); 0^0 is undefined, so generate error message
	JUMPN	A0,POW405	; [E050] 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(050); 0^0 is undefined, so generate error message
	JUMPE	A0,POW509	; [E050] 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			; 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
	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):
IFE PROC-KI10,<			;[172]
	SETZ	A1,		;[172] CLEAR SECOND WORD OF RESULT
	ASHC	A0,-8		;[172] SHIFT
	TLC	A0,243000	;[172] CONSTRUCT EXPONENT
	DFAD	A0,[EXP 0,0]	;[172] NORMALIZE ANSWER
>				;[172]
IFE PROC-KA10,<			;[172]
	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>
>				;[172]
	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]	; [E005] 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:	PUSH	SP,A2		;[250] SAVE A2 BEFORE WE STEP ON IT
	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
	POP	SP,A2		;[250] RESTORE A2
	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.0		; [272] ENSURE NORMALISED
	MOVM	A1,A0		; SINE - GET MAGNITUDE OF X
	CAMGE	A1,SIN6		; VERY SMALL?
	POPJ	SP,		; [272] YES - QUICK EXIT: SIN(X) = X
COS2:	FDVR	A1,SIN4		; [272] Y:=ABS(X)/(PI/2)
	CAMGE	A1,[1.0]	; [272] LESS THAN 1.0?
	JRST	SIN1		; YES
	MULI	A1,400		; NO - SEPARATE EXPONENT AND MANTISSA
	LSH	A2,-202(A1)
	TLZ	A2,(1B0)	; [272] 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,0.0		; [272] NORMALIZE
	JUMPE	A2,SIN1		; OK IF IN FIRST QUADRANT
	TLCE	A2,1000		; [272] SECOND OR FOURTH QUADRANT
	FSBRI	A1,(1.0)	; [272] YES - SUBTRACT 1.0
	TLCE	A2,3000		; [272] SECOND QUADRANT
	TLNN	A2,3000		; [272] OR THIRD QUADRANT?
	MOVN	A1,A1		; YES - NEGATE
SIN1:	SKIPGE	A0		; [272] X < 0?
	MOVN	A1,A1		; YES - NEGATE Y
	MOVE	A2,A1		; [272] SAVE Y
	FMPR	A1,A1		; AND FORM Y^2
	MOVEI	A3,3
	MOVE	A0,SIN5
SIN3:	FMPR	A0,A1
	FAD	A0,SIN4(A3)	; [272]
	SOJGE	A3,SIN3
	FMPR	A0,A2		; FORM POLYNOMIAL IN Y
	POPJ	SP,		; [272]

SIN4:	201622,,077325		; [272] PI/2
	577265,,210372		; [272] -(PI/2)^3/3!
	175506,,321276		; [272] (PI/2)^5/5!
	606315,,546346		; [272] -(PI/2)^7/7!
SIN5:	164475,,536722		; [272] (PI/2)^9/9!
SIN6:	162400,,000000		; [272] 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]		; NO - RESULT IS PI.
	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
	;
	Edit(155);  Improve accuracy of LARCTAN for x in neighbourhood of 1.0
	;
STDENT(116,LARCTAN)
	JUMPE	A0,LTN9		; ARGUMENT = 0?
	HLLZ	A6,A0		; LH(A6)=SGN(A0), RH(A6) = 0
	TLZ	A6,377777	; [E155]
	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
	TLO	A6,1		; [E155]
	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
	AOJA	A6,LTN2		; [E155]

LTN3:	MOVM	A3,A0
	CAMGE	A3,LTN23	; CAN ATAN(X)=X?
	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:	TRNN	A6,-1		; [E155] ADD ARCTAN(1/2)?
	JRST	LTN7		; [E155] NO
	DFAD0	LTN18		; [E155]
	SOJA	A6,LTN6		; [E155]

LTN7:	IFE PROC-KA10<		; [E155]
	TLNN	A6,1		; [E155]
	JRST	LTN8		; ADD -PI/2?
	DFAD0	LTN22		; NO

LTN8:>
	IFE	PROC-KI10, <	; [E155]
	TLNE	A6,1		; [E155]
	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

;	[240]	OLD VERSION WAS VERY MESSY AND INACCURATE IN SOME CASES.
	EDIT	(240)

; THIS ROUTINE USES THE FOLLOWING ALGORITHM:
;
;  IF X < -88.028, RESULT = 0
;  IF X > 88.028, AN ERROR RESULTS
;  IF X = 0.0, RESULT = 1
;
;  ELSE
;	THE ARGUMENT REDUCTION IS:
;		X1 = [X], THE GREATEST INTEGER IN X
;		X2 = X - X1
;		N  = THE NEAREST INTEGER TO X/LN(2)
;
;		THE REDUCED ARGUMENT IS
;
;			G = ((X1 - N*C1)+X2)-N*C2
;		WHERE C1 = .543 (OCTAL),
;		AND C2 IS GIVEN BELOW
;
;		THE CALCULATION IS:
;
;			EXP = R(G)*2**N
;
;		WHERE R(G) = 0.5 + G*P/(Q - G*P)
;			 P = ((((P2*G**2)+P1)*G**2)+P0)*G**2
;			 Q = (((((Q3*G**2)+Q2)*G**2)+Q1)*G**2)+Q0
;
;		P0, P1, P2, Q0, Q1, Q2, AND Q3 ARE GIVEN BELOW AS
;		XP0, XP1, XP2, XQ0, XQ1, XQ2, AND XQ3 .
;
;	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)		; [240]
	JUMPE	A0,[			; [240]
		MOVSI A0,(1.0)		; [240] LOAD 1.0 FOR ARGUMENT OF ZERO
		JRST LEXP3		; [240] AND RETURN TO CALLING ROUTINE
		]			; [240]
	MOVM	A2,A0		; [240] GET MAGNITUDE OF ARGUMENT
	CAML	A2,LEXP4	; [240] WITHIN LIMITS?
	JRST	[			; [240] NO, GO TAKE A CLOSER LOOK
		MOVE	A3,A0		; [240] TAKE COPY OF HIGH ORDER WORD
		SETZB	A0,A1		; [240] SET ARG. = 0
		JUMPL	A3,LEXP3	; [240] EXIT IF ARG. WAS < 0
		LIBERR	2,@(SP)		; [240] ELSE ERROR
		]			; [240]

;****************************************************************************
;			; [240] BEGINNING OF MAJOR CODE CHANGE TO LEXP
;****************************************************************************

	PUSH	SP,A5			; SAVE A5 BEFORE USING IT
	LRLOAD	A2,A0			; PUT A COPY OF ARG IN A2,A3
	DFMP2	LEXP5			; CALCULATE ARG * 1/LN(2)
	FIXR	A2,A2			; GET NEAREST INTEGER
	FLTR	A2,A2			; FLOAT IT
	MOVEI	A3,0			; CLEAR SECOND WORD OF A2, A3
	FIX	A4,A0			; GET FIXED POINT HIGH-ORDER ARG. IN A4
	FLTR	A4,A4			; FLOAT IT
	MOVEI	A5,0			; CLEAR SECOND WORD OF A4, A5
	DFSB	A0,A4			; CALCULATE X2
	MOVE	A7,A2			; SAVE EXPONENT SCALING FACTOR FOR LATER
	DFMP2	C1			; CALCULATE N*C1
	DFAD4	A2			; ADD X1
	DFAD4	A0			; ADD X2
	MOVE	A2,A7			; GET EXPONENT SCALING FACTOR BACK
	MOVEI	A3,0			; CLEAR LOW ORDER WORD OF A2, A3
	DFMP2	C2			; CALCULATE N*C2
	DFAD4	A2			; CALCULATE (N*C2)+X1+(N*C1)+X2
	LRLOAD	A0,A4			; MOVE ANSWER TO A0
	MOVM	A2,A4			; GET ABSOLUTE VALUE IN A2
	CAML	A2,CM2			; IS REDUCED ARG < 2^-32?
	JRST	LEXPOK			; NO, JUMP AHEAD
	DFAD0	DBLONE			; YES, ADD 1.0 TO G
	FSC	A0,-1			; DIVIDE IT BY 2.0
	JRST	LDONE			; ALL DONE - JUMP AHEAD

LEXPOK:	DFMP4	A4			; SQUARE A4
	LRLOAD	A2,A4			; SAVE IT
	DFMP4	XP2			; AND MULTIPLY IT BY XP2
	DFAD4	XP1			; ADD XP1
	DFMP4	A2			; MULTIPLY IT BY Z
	DFAD4	XP0			; ADD XP0
	DFMP0	A4			; MULTIPLY BY G, ANSWER IN A0, A1
	LRLOAD	A4,A2			; PUT ANSWER IN A4, A5
	DFMP4	XQ3			; MULTIPLY BY Z
	DFAD4	XQ2			; ADD XQ2
	DFMP4	A2			; MULTILPLY BY Z
	DFAD4	XQ1			; ADD XQ1
	DFMP4	A2			; MULTIPLY BY Z
	DFAD4	XQ0			; ADD XQ0
	DFSB4	A0			; CALCULATE XQ - G*XP
	DFDV0	A4			; CALCULATE (G*XP)/(XQ-G*XP)
	DFAD0	XQ0			; ADD 0.5
LDONE:	FIX	A7,A7			; GET FIXED POINT SCALING VALUE
	ADDI	A7,1			; ADD ONE
	FSC	A0,(A7)			; ADJUST FINAL ANSWER IN A0, A1
	POP	SP,A5			; RESTORE A5
LEXP3:	POPJ	SP,			; RETURN TO CALLING ROUTINE

LEXP4:	XWD	207540,071260		; 88.028
LEXP5:	EXP	201561250731,112701376065  ; 1.44269504088896341=1/LN(2)
DBLONE:	EXP	201400000000,000000000000  ; 1.0&&0
CM2:	EXP	141400000000,000000000000  ; 2^-32
C1:	EXP	577235000000,000000000000  ; -0.693359375&&0
C2:	EXP	164675002027,030206250331  ; 2.12194440054690583&&-4
XP0:	EXP	177400000000,000000000000  ; 0.250&&0
XP1:	EXP	171760351374,212411245446  ; 0.757531801594227767&&-2
XP2:	EXP	162410550412,271511036101  ; 0.315551927656846464&&-4
XQ0:	EXP	200400000000,000000000000  ; 0.5&&0
XQ1:	EXP	174721345024,167754776545  ; 0.568173026985512218&&-1
XQ2:	EXP	166512741427,012152337316  ; 0.631218943743985036&&-3
XQ3:	EXP	154623154303,071202125117  ; 0.751040283998700461&&-6

	PRGEND

;****************************************************************************
;			; [240] END OF MAJOR CODE CHANGE TO LEXP
;****************************************************************************
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
; IFE PROC-KI10<
IFE PROC-KA10<	;
	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,276434757153	; 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 DFMP2 - KA10/KI10 DOUBLE PRECISION MULTIPLY (A2,A3)

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

	%ENTER<50>

	SALL

%SUBTTL(ALGLIB,ALGOL LIBRARY)

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

DFMP50:	SYSER2	2,0		; OVERFLOW
	>

	IFE	PROC-KI10,
	<
	DFMP	A2,(AX)
	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
	EXTERN	JBS236, POW306	; [236] THESE ARE ADDRESSES IN POWER3 -
				; [236] NEEDED AFTER AN ERROR

	%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:	HRRZ	A5,(SP)		; [236] GET RETURN PC
	CAIE	A5,JBS236	; [236] WERE WE CALLED FROM POWER3?
	SYSER2	2,0		; [236] NO, OVERFLOW OCCURED - PUNT
	POP	SP,(SP)		; [236] YES, FIX STACK POINTER
	JRST	POW306		; [236] RETURN AND LET POWER3 WORRY ABOUT IT
	>

	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 DFAD4 - KA10/KI10 DOUBLE PRECISION ADD (A4,A5)

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

	%ENTER<52>


	SALL

%SUBTTL(ALGLIB,ALGOL LIBRARY)

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

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

	LIT
	PRGEND
TITLE DFSB4 - KA10/KI10 DOUBLE PRECISION SUBTRACT (A4,A5)

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

	%ENTER<53>


	SALL

%SUBTTL(ALGLIB,ALGOL LIBRARY)

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

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

	LIT
	PRGEND
TITLE DFMP4 - KA10/KI10 DOUBLE PRECISION MULTIPLY (A4,A5)

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

	%ENTER<51>

	SALL

%SUBTTL(ALGLIB,ALGOL LIBRARY)

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

DFMP51:	SYSER2	2,0>		; OVERFLOW

	IFE	PROC-KI10,<
	DFMP	A4,(AX)
	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

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

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

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

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		; JUMP IF SFIELD
	EDIT	(244)		; [244] FIX GFIELD FOR STRINGS
	CAIE	A0,$S		; [244] ELSE GFIELD - IS THIS A STRING?
	JRST	GSF98		; [244] NO, LONG REAL - JUMP AHEAD
	EDIT	(245)		; [245] FIX GFIELD/SFIELD FOR STRINGS
				; [245] INSTALL EDIT 244 BEFORE THIS ONE
	SKIPN	A1,.A(DL)	; [245] LOAD STRING ADDR. AND SKIP IF SET UP
	JRST	GSF2		; [245] ERROR IF STRING NOT SET UP YET
	ADDI	A4,@A1		; [244] [245] CALCULATE FINAL BYTE ADDR.
	SKIPA			; [244] SKIP AHEAD
GSF98:	ADDI	A4,.A(DL)	; [244] ADD ADDRESS TO BYTE PTR.
	LDB	A0,A4
	MOVEM	A0,.EXIT+1(DL)	; GET RESULT
	JRST	.EXIT(DL)

;
;	SFIELD - SET A BYTE INTO A VARIABLE
;
GSF4:	;[245]PUSH	SP,A4		; SFIELD - SAVE BYTE POINTER
	MOVE	A5,A0		; [245] SAVE VARIABLE TYPE IN A5
	XCT	.A(DL)		; [245] LOAD "A" (OR STRING HEADER)
;[245]	MOVE	A4,(SP)		; RESTORE BYTE POINTER
	CAIE	A5,$S		; [245] IS THIS A STRING?
	JRST	GSF93		; [245] NO, JUMP AHEAD
	JUMPE	A0,GSF2		; [245] ERROR IF STRING DOESN'T EXIST YET
	HRR	A4,A0		; [245] ELSE PUT ADDRESS OF STRING IN BYTE PTR.
	MOVE	A5,.N(DL)	; [245] LOAD BYTE TO BE DEPOSITED
	DPB	A5,A4		; [245] PUT IT IN THE STRING
	JRST	.EXIT(DL)	; [245] EXIT
GSF93:	MOVE	A5,.N(DL)
	DPB	A5,A4		; DEPOSIT BYTE (IN A0 OR A1)
	MOVEM	A0,(SP)
;[245]	PUSH	SP,A1		; SAVE VALUE(S)
;[245]	XCTA	.A(DL)		; GET ADDRESS OF A
;[245]	POP	SP,A1
;[245]	POP	SP,A0		; RESTORE VALUE(S)
	XCT	.A+1(DL)	; AND WRITE IT IN A
	JRST	.EXIT(DL)

;
;	GFIELD - FOR 2 WORD ARGUMENT (LONG REAL OR STRING).
;
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, BYTE IS SPLIT ACROSS TWO WORDS
	MOVEI	A4,100(A5)	; YES - FUDGE BYTE POINTER FOR A1
	JRST	GSF3		; GO HANDLE IT LIKE A 1-WORD GFIELD

;
;	GFIELD/SFIELD FOR TWO WORD VARIABLE, BYTE SPLIT ACROSS WORD BOUNDRIES..
;
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		; JUMP IF THIS IS AN SFIELD
	CAIE	A0,$S		; [244] ELSE GFIELD - IS THIS A STRING?
	JRST	GSF99		; [244] NO, LONG REAL - JUMP AHEAD
	SKIPN	A1,.A(DL)	; [245] LOAD STRING ADDR. AND SKIP IF SET UP
	JRST	GSF2		; [244] [245] NOT SET UP YET - ERROR
	LRLOAD	A0,@A1		; [244] [245] LOAD FIRST TWO WORDS OF STRING
	JRST	GSF91		; [244] [245]
GSF99:	LRLOAD	A0,.A(DL)	; [244] LOAD BOTH WORDS OF VARIABLE
GSF91:	LDB	A0,A3		; [245] 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)

;
;	SFIELD FOR TWO WORD VARIABLE, BYTE SPLIT ACROSS WORD BOUNDIRES.
;
GSF7:	PUSH	SP,A2
	PUSH	SP,A3
;[245]	PUSH	SP,A4		; SAVE A2-A4
	MOVE	A5,A0		; [245] SAVE VARIABLE TYPE IN A5
	XCT	.A(DL)		; GET VALUE OF A
;[245]	POP	SP,A4
	MOVE	A3,(SP)		; RESTORE BYTE POINTERS
	MOVN	A2,-1(SP)	; AND SHIFT
	CAIE	A5,$S		; [245] IS THIS A STRING?
	JRST	GSF92		; [245] NO, LONG REAL - JUMP AHEAD
	JUMPE	A0,GSF2		; [245] YES, ERROR IF STRING DOESN'T EXIST YET
	HRR	A3,A0		; [245] LOAD STRING ADDRESS FOR FIRST WORD
	HRR	A4,A0		; [245] DO IT FOR A4 TOO
	AOS	A4		; [245] INCREMENT TO SECOND WORD OF STRING
	MOVE	A5,.N(DL)	; [245] LOAD BYTE TO BE WRITTEN
	DPB	A5,A4		; [245] STORE PART OF BYTE IN SECOND WORD
	LSH	A5,(A2)		; [245] ROTATE REMAINDER OF BYTE INTO POSITION
	DPB	A5,A3		; [245] STORE REMAINDER OF BYTE IN FIRST WORD
	POP	SP,(SP)		; [245] FIX STACK POINTER
	POP	SP,(SP)		; [245]
	JRST	.EXIT(DL)	; [245] ALL DONE
GSF92:	MOVE	A5,.N(DL)	; [245] 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
;[245]	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
EDIT(023); SAVE STRING HEADER ADDRESS DELOCATED
	MOVEM	A2,%SYS11(DB)	; [E023]
	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))
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)	; [E023] 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
	SUBI	A0,2		; PROCEDURE LEVEL+1
	HRLM	A0,(A1)		;
	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(064); Correct base address for long real arrays
ARRAY2:	TLNE	A4,$VAR1	; [E064] LONG REAL ARRAY ?
	ADD	A1,-1(A2)	; [E064] 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
	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)
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
	PUSH	SP,A0		; [256] SAVE STRING ADDRESS
	PUSH	SP,A1		; [256] AND SECOND WORD OF HEADER TOO
	MOVEI	A2,@A2
	SKIPN	STR1(A2)	; IS THIS A NULL STRING ?
	TDZA	A0,A0		; YES - LENGTH IS ZERO
	LDB	A0,[POINT 24,STR2(A2),35]  ; [256] NO  - GET ITS LENGTH
	MOVEM	A0,.EXIT+1(DL)	; STORE RESULT
	POP	SP,A2		; [256] RESTORE STRING BITS
	POP	SP,A1		; [256] RESTORE STRING ADDRESS
	SETZ	A0,		; [256] GET READY TO DELETE STRING SPACE
	TLC	A2,STRDYN!STRPRC; [256] COMPLEMENT STRING STATUS BITS
	TLCE	A2,STRDYN!STRPRC; [256] WAS THIS A TRANSIENT STRING?
	JRST	.EXIT(DL)	; [256] NO, EXIT
	PUSHJ	SP,GETOWN	; [256] YES, DELETE IT
	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
	PUSH	SP,A0		; [256] SAVE STRING ADDRESS
	PUSH	SP,A1		; [256] AND SECOND WORD OF HEADER TOO
	MOVEI	A2,@A2		; STATICISE
	LDB	A0,[POINT 6,STR1(A2),11]  ; [256] GET BYTE-SIZE
	MOVEM	A0,.EXIT+1(DL)	;  & RETURN IT
	POP	SP,A2		; [256] RESTORE STRING BITS
	POP	SP,A1		; [256] RESTORE STRING ADDRESS
	SETZ	A0,		; [256] GET READY TO DELETE STRING SPACE
	TLC	A2,STRDYN!STRPRC; [256] COMPLEMENT STRING STATUS BITS
	TLCE	A2,STRDYN!STRPRC; [256] WAS THIS A TRANSIENT STRING?
	JRST	.EXIT(DL)	; [256] NO, EXIT
	PUSHJ	SP,GETOWN	; [256] YES, DELETE 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)		; GET ADDRESS OF STRING
EDIT (133)	; AVOID STACK-SHIFT PROBLEMS
	PUSH	SP,A0		; [256] SAVE STIRNG ADDRESS
	AOS	A2		; [256] [E133]
	MOVE	A0,@A2		; [256] [E133]
	SOS	A2		; [256] [E133]
	TLNN	A0,STRDYN	; DYNAMIC?
	JRST	.EXIT(DL)	; NO - LEAVE THIS ONE
	HRRZ	A1,@A2
	JUMPE	A1,DEL2		; MAKE SURE THERE IS A BYTE STRING
	MOVEI	A0,0
	POP	SP,A1		; [256] RESTORE STRING ADDRESS
	PUSH	SP,A2		; SAVE ADDRESS
	PUSHJ	SP,GETOWN	; DELETE STRING
	POP	SP,A2		; RESTORE ADDRESS
DEL2:	MOVEI	A2,@A2		; [E133]
	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

	;
	; Edit(1015)  Evaluate parameter by NAME correctly.
	;
	XCTA	.I(DL)		; [E1015] Get address of I
	PUSH	SP,A2		; [E1015] Save over NXTBYT
	PUSHJ	SP,NXTBYT	; GET NEXT BYTE
	IOERR	6,(A13)		; EOF - CHAN # IN A13
	MOVE	A0,A13		; [E1015] Not EOF - byte in A13
	POP 	SP,A2		; [E1015] Get back address of I
	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	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		; [E060] 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)
	XCT	(A5)		; [251] GET STRING HEADER
	PUSH	SP,A2		; AND SAVE IT
	MOVSI	A0,400000	; [251] SETUP TO GET EXPANDABLE HEAP SPACE
EDIT(035) ; DONT WASTE TIME CLEARING THE SPACE FIRST
	PUSHJ	SP,GETOWN	; [251][E035] GET IT FOR THE NEW STRING
	MOVEM	A1,GETTMP(DB)	; [251] SET "HEAP SPACE IN USE" IN CASE OF ERROR
	HLRZ	A0,-1(A1)	; [251] GET LENGTH OF NEW SPACE
	ADDI	A0,-2(A1)	; [251] CALCULATE UPPER BOUND OF SPACE
	MOVEI	A2,0		; CLEAR BYTE COUNT
	HRLI	A1,(POINT 7,)	; [251] MAKE IT INTO A BYTE PTR.
	MOVE	A3,A1		; [251] COPY ADDRESS OF NEW STRING SPACE

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
	CCORE1	^D128		; 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

EDIT(1017)	;DON'T LOSE CHR. AFTER END OF STRING
READ9:	PUSHJ	SP,NXTBYT	; [251][E1017] FOUND DOUBLE-QUOTE, GET NEXT BYTE
	IOERR	6,(A13)		; [251][E1017] HIT EOF, ERROR WITH CH. # IN A13
	CAIE	A13,""""	; [251][E1017] ANOTHER DOUBLE-QUOTE?
	JRST	READ90		; [251][E1017] NO, END OF STRING
	JSP	AX,INCHAR	; [251][E1017] YES, ADVANCE BUFFER PTR.
	JRST	READ8		; [251][E1017] AND STORE THE BYTE
READ90:	POP	SP,A4		; [251] FINISHED - RESTORE STRING ADDRESS
	MOVEI	A4,@A4
	PUSH	SP,A0		; [251] SAVE AC'S FOR A MOMENT
	PUSH	SP,A1		; [251]
	PUSH	SP,A2		; [251]
	MOVEI	A0,0		; [251] SETUP TO DELETE OLD STRING
	SKIPE	A1,STR1(A4)	; [251] DID IT EXIST BEFORE?
	PUSHJ	SP,GETOWN	; [251] YES, DELETE IT SINCE WE HAVE A NEW ONE
	POP	SP,A2		; [251] NO, RESTORE AC'S
	POP	SP,A1		; [251]
	POP	SP,A0		; [251]
	JUMPE	A2,READ11	; [251] NULL STRING?
	TLO	A2,STRDYN	; [251] NO - ADD CORRECT BITS TO COUNT
	LRSTOR	A1,STR1(A4)	; [251] AND UPDATE STRING HEADER
	SUBI	A0,(A3)		; REMAINING SPACE
	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
	SUB	A0,-1(A1)
	MOVNM	A0,-1(A1)	; SET UP LENGTH OF USED PORTION
	MOVEI	A1,2(A3)	; SET UP ADDRESS OF REMAINDER
READ10:	MOVEI	A0,0
	PUSHJ	SP,GETOWN	; DELETE REMAINDER
READ14:	MOVE	A5,.V2(DL)
	ADDI	A5,2
	AOBJN	A5,READ12	; CARRY ON IF MORE
	SETZM	GETTMP(DB)	; [251] ELSE CLEAR "HEAP SPACE IN USE" FLAG
	JRST	.EXIT(DL)

READ11:	SETZM	STR1(A4)	; NULL STRING
	SETZM	STR2(A4)
	JRST	READ10		; DELETE SPACE OBTAINED

EDIT(060); Trap fixed point overflow on data input
READOV:	HLRZ	A1,%CHAN(DB)	; [E060] GET CHANNEL NUMBER
	IOERR	11,(A1)		; [E060] 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,INCHR0	; [E145] 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
	PUSH	SP,A0		; [256] SAVE STRING ADDRESS
	PUSH	SP,A1		; [256] AND HEADER INFORMATION TOO
	MOVEI	A4,0		; CLEAR SPECIAL MODE FLAG
	MOVEI	AX,WRIT5	; SET LINK

WRIT1:	MOVE	A3,STR1(A0)	; [237] GET BYTE-POINTER
	LDB	A1,[POINT 24,STR2(A0),35]  ; [237] GET STRING LENGTH

WRIT2:	SOJL	A1,WRIT3	; [256] DECREMENT BYTE COUNT - EXHAUSTED?
	ILDB	A13,A3		; NO - LOAD UP BYTE
	JUMPE	A13,WRIT2	; IGNORE NULLS
	JRST	(AX)

WRIT3:	POP	SP,A2		; [256] RESTORE STRING BITS
	POP	SP,A1		; [256] RESTORE STRING ADDRESS
	SETZ	A0,		; [256] GET READY TO DELETE STRING SPACE
	TLC	A2,STRDYN!STRPRC; [256] COMPLEMENT STRING STATUS BITS
	TLCE	A2,STRDYN!STRPRC; [256] WAS THIS A TRANSIENT STRING?
	JRST	.EXIT(DL)	; [256] NO, EXIT
	PUSHJ	SP,GETOWN	; [256] YES, DELETE IT
	JRST	.EXIT(DL)	; [256] AND EXIT
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	;