	.TITLE	INTERPRETER PROGRAM FOR PSEUDO-OPERATION OPCODES
/
/  19 JUN 75 (JAF) CORRECTLY LOAD IMAGINARY PART OF DOUBLE COMPLEX
/		   INTO ACCUMULATOR B.
/  18 SEP 73 (JAF) CORRECT 'GETCNT' FOR PDP-15
/  12 SEP 73 (PDH) REMOVE .SNAFU; TIDY UP COMMENTS
/  28 MAY 73 (PDH) MOVE CONSTANT TABLES TO EXTERNAL FILE
/  13 APR 73 (PDH) CHANGE ERROR HANDLING
/
/  MACROS FOR CONDITIONAL PDP-15 ASSEMBLY
/
	.DEFIN	.LACI,A
	.IFDEF	PDP15
	LAC*	A
	.ENDC
	.ENDM
/
/
	.DEFIN	.AND,A
	.IFDEF	PDP15
	AND	A
	.ENDC
	.ENDM
/
/  EXTERNAL GLOBALS
	.GLOBL	.OPST,FET.X,.ERROR,.NERR,.RTRN2,.RTRN4
/  EXTERNAL CONSTANT TABLES
	.GLOBL	.CE25,.MSQ2O2,.DC8,.RT216,.LOG2,.LN2
	.GLOBL	.MPT16,.MPT63,.T,.S,.A,.B,.C,.C1,.C2,.C3,.C4
/
/
/ INTERNAL GLOBALS
/ ARITHMETIC ACCUMULATORS
	.GLOBL	.MODEA,.SIGNA,.EXPA,.MOSTA,.LESTA,.A3,.A4
	.GLOBL	.SGNIA,.EXPIA,.MSTIA,.LSTIA,.AI3,.AI4
	.GLOBL	.MODEB,.SIGNB,.EXPB,.MOSTB,.LESTB,.B3,.B4
	.GLOBL	.SGNIB,.EXPIB,.MSTIB,.LSTIB,.BI3,.BI4
	.GLOBL	.INT1,.INT2,.LOGAC
/ SUBROUTINES (ARITHMETIC)
	.GLOBL	.SPRML,.SPRDV,.SPADD,.SPRST,.SPRLD
	.GLOBL	.DPRML,.DPRDV,.DPADD,.DPRST,.DPRLD
	.GLOBL	.DPSER,.DBNRM,.FLOTA,.FLOTB,.FIX
	.GLOBL	.LDREL,.LDDBL,.LODBD,.LODBS,.CMPLA,.CMPLB
	.GLOBL	.LOAD1,.RVRSG,.ZRVAL,.ZROIA,.PICK1,.PICK2
/ SUBROUTINES (OTHER)
	.GLOBL	.STORE,.CHRGT,.CMPIT,.LDPT5,.PSHBA
	.GLOBL	.SWPIT,.SWPUS,.SWPBI,.SWPIB,.SPBIA,.MVIMA
/ FUNCTIONS (WITH ENTRANCES FOR MACRO)
	.GLOBL	.IABS,.FLOAT,.IFIX,.SNGL,.ALG10
	.GLOBL	.SPXP2,.DPXP2,.SPLG2,.DPLG2
/ REFERENCED LOCATIONS
	.GLOBL	L.BOX,.TABLE,.BOX,.ADDR1,.ADDR2,.CNTR
/ ENTRY POINTS
	.GLOBL	.NEXT,.NEXT2,.STORP,.STORN,.LOADS,.NEXT1,.NEXT3,.ILMDE
	.EJECT
/  DEFINITION OF FLOATING ACCUMULATORS
/  ACC   A
MODEA;SIGNA;EXPA;MOSTA;LEASTA;A3;A4;SIGNIA;EXPIA;MOSTIA;LESTIA;AI3;AI4
/  ACC   B
MODEB;SIGNB;EXPB;MOSTB;LEASTB;B3;B4;SIGNIB;EXPIB;MOSTIB;LESTIB;BI3;BI4
/ DEFINITION OF INTEGER ACCUMULATOR
INT1;INT2
/  LOGICAL ACC
LOGACC
/
/ EQUIVALENCES FOR GLOBALING
.MODEA=MODEA;.SIGNA=SIGNA;.EXPA=EXPA;.MOSTA=MOSTA;.LESTA=LEASTA
.A3=A3;.A4=A4;.SGNIA=SIGNIA;.EXPIA=EXPIA;.MSTIA=MOSTIA;.LSTIA=LESTIA
.AI3=AI3;.AI4=AI4
.MODEB=MODEB;.SIGNB=SIGNB;.EXPB=EXPB;.MOSTB=MOSTB;.LESTB=LEASTB
.B3=B3;.B4=B4;.SGNIB=SIGNIB;.EXPIB=EXPIB;.MSTIB=MOSTIB;.LSTIB=LESTIB
.BI3=BI3;.BI4=BI4
.INT1=INT1;.INT2=INT2;.LOGAC=LOGACC
/
/	LOCATIONS FOR DIVIDE ROUTINES
/
DPDSTA	.BLOCK	5
/
/ STORAGE FOR COMPLEX MULTIPLY AND DIVIDE
/
SIGNS	.BLOCK	5
SIGNH	.BLOCK	5
SIGND	.BLOCK	5
SIGNE	.BLOCK	5
/
ERROR	LAW	25
	JMP*	.NERR
/
/ TABLE ADDRESS - MUST BE INSERTED AT EXECUTION TIME
TABLE	0
.TABLE=TABLE
/
/  STORAGE LOCATIONS
/
INTMA;INTMB;INTM3;INTM4
BOX;CNTRL;MOVCNT
SIZE;BOXX
.BOX=BOX
/
/ THIS SUBROUTINE MOVES DATA FROM B PSEUDO-ACCUMULATOR TO 
/ A PSEUDO-ACCUMULATOR, GIVEN THE MODE BITS RIGHT JUSTIFIED
/ IN THE AC. IT RETURNS WITH THE MODE IN THE AC.
.PSHBA	XX
	TAD	(XCT  .LOADS
	DAC	.+1
	XX		/ PERFORM ENTRY TO LOAD ROUTINE
	LAC	MODEA	/ GET MODE
	JMP*	.PSHBA
	.EJECT
/
/ OPERATION CODE INTERPRETER DISPATCH ROUTINE
/
/ THIS SECTION DECODES NON-ARITHMETIC OPERATIONS
/
NOARIT	CLLS	6	/ GET OPCODE
	ADD	.OPST	/ LOCATION OF ADDRESS TABLE
	DAC	TIE+1
	JMP*	TIE+1	/ GO TO EXECUTION ROUTINE
/ THIS SECTION DECODES ALL ARITHMETIC OPCODES AND LOADS ACCUMULATOR
/ B WITH THE ARGUMENT.
/
TIE	DAC	.+1	/GET ENTRY
	XX		/EXECUTE IT
/PICK UP NEXT INSTRUCTION ,GET DATA AND ENTER SUBROUTINE
/  ALSO ENTRY POINT FOR INTERPRETER
/
/
.NEXT	LAC*	AUTO1	/GET NEXT INSTRUCTION
	GSLMQ		/BIT 0 TO LINK,SAVE INST. IN MQ
.NEXT3	AND	(7777	/ADDRESS ADJUSTMENT REMAINS
	TAD	TABLE	/ADD BASE ADDRESS OF ADDRESS TABLE
.NEXT1	DAC	BOX	/LOCATION IN ADDRESS TABLE
L.BOX	LAC*	BOX	/ GET TRUE ADDRESS FROM TABLE
	.AND	(077777	/ REMOVE UPPER MOST BITS FOR PDP-15
	DAC*	(AUTO2
	SZL		/ LINK IS ZERO IF ARITHMETIC INSTRUCTION
	JMP	NOARIT	/ GO TO SORT OUT NON-ARITHMETIC ROUTINE
	.LACI	BOX	/ REGAIN MODE BITS FOR PDP-15
/TEST MODE BITS TO FIND CORRECT LOADING ROUTINE
.NEXT2	SPA!RAL		/MODE BITS ARE STILL IN AC
	JMP	TEMPOR	/COMPLEX LOGICAL OR CHARACTER
	SMA!RAL		/NOTE IF EXIT TO INTGR L=0
	JMP	INTGR	/INTEGER,SINGLE OR DOUBLE
	SPA!CLL!CML
	JMP	DOUBLE	/DOUBLE PRECISION FLOATING POINT
/ARGUMENT IS REAL-BREAK INTO FORM FOR ARITHMETIC
	LAC*	AUTO2	/GET FIRST WORD(LINK IS SET)
	RAR		 /SIGN TO LINK, 1 TO ACO
	DAC	MOSTB	/MOST SIGNIFICANT PORTION OF FRACTION
	CLA!RAR		/GET SIGN BIT
	DAC	SIGNB	/SET FRACTION SIGN
	LAC*	AUTO2	/GET NEXT WORD
	DAC	EXPB	/SAVE IT
	AND	(777000	/SET TRAILING NINE BITS TO ZERO
	DAC	LEASTB	/LEAST SIGNIFICANT PART OF FRACTION
	XOR	EXPB	/GET EXP. SIGN AND MAG.
	CLL!RAR		/EXPONENT SIGN TO LINK
	SAD	(377	/IS IT ZERO OR INFINITY (8 BITS)
	JMS	ZERINF	/GENERATE ZERO OR INFINITY
	SZL		/IS EXPONENT NEGATIVE
	CMA		/YES-FROM ONE'S COMPLIMENT
	DAC	EXPB	/EXPONENT
REALTY	CLLS	6	/GET OP CODE FROM MQ
	CLL!RAL		/LEAVE SPACE FOR MODE TYPE
	RTL
	ADD	(XCT SUBR+2	/LOCATE ENTRY IN SUBROUTINE TABLE
	JMP	TIE	/GO TO EXECUTE IT
/GENERATE ZERO OR INFINITY IN REAL OR DOUBLE PRECISION
ZERINF	XX		/RETURN ADDRESS
	SZL!CLA!CMA	/TEST SIGN AND SET AC TO 1'S
	CLA		/NEGATIVE - SET AC TO ZEROS
	DAC	MOSTB	/SET FRACTION TO ALL 0'S 0R 1'S
	DAC	LEASTB
	DAC	B3
	DAC	B4
	LAC	(377777
	JMP*	ZERINF	/MAXIMUM EXPONENT
/ARGUMENT IS DOUBLE PRECISION-BREAK INTO FORM FOR ARITHMETIC
DOUBLE	LAC*	AUTO2
	RAR
	DAC	MOSTB
	CLA!RAR
	DAC	SIGNB
	LAC*	AUTO2
	DAC	LEASTB
	LAC*	AUTO2
	DAC	B3
	LAC*	AUTO2
	DAC	EXPB
	AND	(777000
	DAC	B4
	XOR	EXPB
	CLL!RAR
	SAD	(377
	JMS	ZERINF
	SZL
	CMA
	DAC	EXPB
DBLTY	CLLS	6
	CLL!RAL
	RTL
	ADD	(XCT SUBR+3
	JMP	TIE
/ARGUMENT IS INTEGER-SET PRECISION INDICATOR
/ LINK IS ZERO ON ENTRY TO INTGR FOR INTEGERS
/ COMPLEX ROUTINES ENTER WITH L=1
INTGR	SPA!CLA		/TEST FOR SINGLE OR DOUBLE, CLEAR AC
INTGRD	LAC	(2000	/DOUBLE , SET AC TO 2000
	LLS	6	/SHIFT IN OP CODE
	RAL		/ROTATE MODE BITS IN (L=0 FOR INTEGER
	RTL		/1  FOR COMPLEX
	ADD	(XCT SUBR 	/LOCATE ENTRY IN OP. TABLE
	JMP	TIE
/ARGUMENT IS COMPLEX, LOGICAL OR TEMPORARY ACCUMULATOR
COMPLX	DAC	CNTRL	/SAVE DATA (BIT 0=1 FOR DOUBLE)
	CLL!CML		/SET LINK
	LAC*	AUTO2	/GET MOST SIGNIFICANT PART & SIGN
	RAR
	DAC	MOSTB
	CLA!RAR
	DAC	SIGNB
	LAC	CNTRL	/RETRIEVE DATA
	SMA!RAL		/SINGLE OR DOUBLE
	JMP	CMPTIE	/SINGLE-GO ON DOWN
	LAC*	AUTO2	/DOUBLE-STORE NEXT TWO WORDS
	DAC	LEASTB
	LAC*	AUTO2
	DAC	B3
CMPTIE	LAC*	AUTO2	/GET LAST WORD OF REAL PART
	DAC	EXPB
	AND	(777000
	SNL		/SINGLE OR DOUBLE PRECISION
	DAC	LEASTB	/SINGLE (ONLY)
	DAC	B4	/DOUBLE(ALWAYS, INFINITE)
	XOR	EXPB
	CLL!RAR
	SAD	(377
	JMS	ZERINF
	SZL!CLL!CML	/SET LINK WHILE TESTING EXPONENT SIGN
	CMA
	DAC	EXPB
	LAC*	AUTO2	/NOW DO IMAGINARY PART
	RAR		/SIGN TO LINK, 1 TO ACO FROM LINK
	DAC	MOSTIB
	CLA!RAR
	DAC	SIGNIB
	LAC	CNTRL
	SMA!RAL
	JMP	CMP5
	LAC*	AUTO2
	DAC	LESTIB
	LAC*	AUTO2
	DAC	BI3
CMP5	LAC*	AUTO2
	DAC	EXPIB
	AND	(777000
	SNL
	DAC	LESTIB
	DAC	BI4
	XOR	EXPIB
	CLL!RAR
	SAD	(377
	JMP	CMP8
CMP9	SZL!CLL!CML	/L=1 FOR ENTRY TO INTGR
	CMA
	DAC	EXPIB
	LAC	CNTRL
	JMP	INTGR
CMP8	SZL!CLA!CMA
	CLA
	DAC	MOSTIB
	DAC	LESTIB
	DAC	BI3
	DAC	BI4
	LAC	(377777
	JMP	CMP9
/LOGICAL,CHARACTER OR TEMPORARY ACCUMULATOR
LOGT	CLLS	6	/SET UP FOR LOGICAL OR CHARACTER DATA
	CLL!RAL
	RTL
	ADD	(XCT   SUBR+6 /LOCATE ENTRY IN OP.TABLE
	JMP	TIE	/GO TO EXECUTE IT
/RECOVER TEMPORARY ACCUMULATOR
TEMPOR	SMA!RAL
	JMP	COMPLX
	SMA
	JMP	LOGT
/START RECOVERING
	LAC*	AUTO2	/MODE
	SPA!RTL
	JMP	TEMP3	/COMPLEX OR CHARACTER
	SNA!RAL		/PRECISION BIT TO LINK
	JMP	INTGRD	/DOUBLE INTEGER
	LAC*	AUTO2
	DAC	SIGNB	/SIGN
	LAC*	AUTO2
	DAC	EXPB	/EXPONENT
	LAC*	AUTO2
	DAC	MOSTB
	LAC*	AUTO2
	DAC	LEASTB
	SNL
	JMP	REALTY
	LAC*	AUTO2
	DAC	B3
	LAC*	AUTO2
	DAC	B4
	JMP	DBLTY
TEMP3	SZL!RAL		/PRECISION BIT TO LINK
	JMP	CHARAC
	LAC*	AUTO2
	DAC	SIGNB
	LAC*	AUTO2
	DAC	EXPB
	LAC*	AUTO2
	DAC	MOSTB
	LAC*	AUTO2
	DAC	LEASTB
	SNL		/CHECK PRECISION BIT
	JMP	TEMP2	/SINGLE
	LAC*	AUTO2	/DOUBLE
	DAC	B3
	LAC*	AUTO2
	DAC	B4
TEMP2	LAC*	AUTO2
	DAC	SIGNIB
	LAC*	AUTO2
	DAC	EXPIB
	LAC*	AUTO2
	DAC	MOSTIB
	LAC*	AUTO2
	DAC	LESTIB
	SNL!CLL!CML!CLA	/SET LINK TO 1,AC=0
	JMP	INTGRD+1	/CALCULATE XCT SUBR+5+OP CODE*8
	LAC*	AUTO2
	DAC	BI3
	LAC	AUTO2
	DAC	BI4
	JMP	INTGRD	/CALC  XCT SUBR+4 + OP. CODE*8
/
/ PROCESS CHARACTER CONSTANT. IT IS EITHER
/	7XXXXX, DATA POINTER
/	6XXXXX, DATA
/
CHARAC	JMS	GETCNT
	CLLS	6
	CLL!RAL
	RTL
	ADD	(XCT SUBR+7
	JMP	TIE
/
/ THIS SUBROUTINE GETS THE # OF CHARS/ELEMENT FOR CHARACTER
/ CONSTANTS AND VARIABLES.
GETCNT	XX
	SNL!CLL!RAR
	JMP	CHAR2
	CLL!RAR
	CLL!RAR
	DAC	SIGNB	/CHARACTER COUNT
	LAC*	AUTO2
	.AND	(077777
	DAC*	(AUTO2
	JMP*	GETCNT
CHAR2	CLL!RAR
	CLL!RAR
	DAC	SIGNB
	JMP*	GETCNT
	.EJECT
/
/ THIS TABLE IS USED TO ACCESS THE ARITHMETIC ROUTINES. A JMS IMPLIES
/  THAT ROUTINE IS OF NECESSITY A SUBROUTINE.
/SUBROUTINE ENTRY TABLE
SUBR	JMS	INTADD	/INTEGER ADD		OPCODE 00
	JMS	DINTAD	/DOUBLE INTEGER
	JMS	ADDRL	/REAL
	JMS	ADDBL	/DOUBLE PRECISION
	JMS	ADDCPX	/COMPLEX
	JMS	ADDDCP	/DOUBLE INTEGER
	JMP	LOGOR	/LOGICAL OR
	JMP	ERROR	/TEMPORARY AC
	JMS	INTSUB	/SUBTRACT		OPCODE 01
	JMS	DINTSB
	JMS	SUBRL
	JMS	SUBDBL
	JMP	SUBCPX
	JMP	SUBDPX
	JMP	LOGORN	/ OR NEGATIVE
	JMP	ERROR
	JMP	INTRSB	/REVERSE SUBTRACT	OPCODE 02
	JMP	DINTRS
	JMP	RSBRL
	JMP	RSBDBL
	JMP	RSBCPX
	JMP	RSBDPX
	JMP	LORORN	/ REVERSE OR NEGATIVE
	JMP	ERROR
	JMP	INTMUL	/MULTIPLY		OPCODE 03
	JMP	DINTML
	JMP	MULRL
	JMP	MULBL
	JMS	MULCPX
	JMS	MULDCP
	JMP	LOGAND	/LOGICAL AND
	JMP	ERROR
DENTRY	JMP	INTDIV	/DIVIDE			OPCODE 04
	JMP	DINTDV
	JMP	DIVRL
	JMP	DIVBL
	JMS	DIVCPX
	JMS	DIVDCP
	JMP	ERROR
	JMP	ERROR
	JMP	RINTDI	/REVERSE DIVIDE		OPCODE 05
	JMP	RDINTD
	JMP	RDIVRL
	JMP	RDIVDB
	JMP	RDIVCX
	JMP	RDIVDC
	JMP	ERROR
	JMP	ERROR
	JMP	INTEXP	/EXP			OPCODE 06
	JMP	DNTEXP
	JMP	RELEXP
	JMP	DBLEXP
	JMP	ERROR
	JMP	ERROR
	JMP	ERROR
	JMP	ERROR
	JMP	RINTXP	/REXP			OPCODE 07
	JMP	RDNTXP
	JMP	RRELXP
	JMP	RDBLXP
	JMP	ERROR
	JMP	ERROR
	JMP	ERROR
	JMP	ERROR
	JMP	INTXPN	/EXPN			OPCODE 10
	JMP	DNTXPN
	JMP	RELXPN
	JMP	DBLXPN
	JMP	ERROR
	JMP	ERROR
	JMP	ERROR
	JMP	ERROR
	JMP	RINTXN	/REXPN			OPCODE 11
	JMP	RDNTXN
	JMP	RRELXN
	JMP	RDBLXN
	JMP	ERROR
	JMP	ERROR
	JMP	ERROR
	JMP	ERROR
	JMP	NINTXP	/NEXP			OPCODE 12
	JMP	NDNTXP
	JMP	NRELXP
	JMP	NDBLXP
	JMP	ERROR
	JMP	ERROR
	JMP	ERROR
	JMP	ERROR
	JMP	RNINTX	/RNEXP			OPCODE 13
	JMP	RNDNTX
	JMP	RNRELX
	JMP	RNDBLX
	JMP	ERROR
	JMP	ERROR
	JMP	ERROR
	JMP	ERROR
	JMP	NINTXN	/NEXPN			OPCODE 14
	JMP	NDNTXN
	JMP	NRELXN
	JMP	NDBLXN
	JMP	ERROR
	JMP	ERROR
	JMP	ERROR
	JMP	ERROR
	JMP	RNINXN	/RNEXPN			OPCODE 15
	JMP	RNDNXN
	JMP	RNREXN
	JMP	RNDBXN
	JMP	ERROR
	JMP	ERROR
	JMP	ERROR
	JMP	ERROR
GTN	JMP	GREAT	/GTN ROUTINES		OPCODE 16
	JMP	GREAT
	JMP	GREAT
	JMP	GREAT
	JMP	ERROR
	JMP	ERROR
	JMP	ERROR
	JMP	ERROR
	JMP	GREAT	/GT ROUTINES		OPCODE 17
	JMP	GREAT
	JMP	GREAT
	JMP	GREAT
	JMP	ERROR
	JMP	ERROR
	JMP	ERROR
	JMP	GREAT	/ CHARACTER
LTN	JMP	LESS	/LTN ROUTINES		OPCODE 20
	JMP	LESS
	JMP	LESS
	JMP	LESS
	JMP	ERROR
	JMP	ERROR
	JMP	ERROR
	JMP	ERROR
	JMP	LESS	/LT ROUTINES		OPCODE 21
	JMP	LESS
	JMP	LESS
	JMP	LESS
	JMP	ERROR
	JMP	ERROR
	JMP	ERROR
	JMP	LESS	/    - CHARACTER
EQN	JMP	EQUAL	/EQN ROUTINES		OPCODE 22
	JMP	EQUAL
	JMP	EQUAL
	JMP	EQUAL
	JMP	ERROR
	JMP	ERROR
	JMP	ERROR
	JMP	ERROR
	JMP	EQUAL	/EQ ROUTINES		OPCODE 23
	JMP	EQUAL
	JMP	EQUAL
	JMP	EQUAL
	JMP	ERROR
	JMP	ERROR
	JMP	ERROR
	JMP	EQUAL	/    - CHARACTER
.LOADS	JMS	LDINT	/LOAD			OPCODE 24
	JMS	LDBINT
	JMS	LDREAL
	JMS	LDDBL
	JMS	LDCPLS
	JMS	LDCPLD
	JMP	LDLOGC
	JMP	LDCHAR
/
	JMS	LNINT	/LOAD NEGATIVE. MUST BE IMMEDIATELY AFTER .LOADS
	JMS	LNBINT	/ (SEE YANKIT IN DO)	OPCODE 25
	JMP	LNREAL
	JMP	LNDBL
	JMP	LNCPLS
	JMP	LNCPLD
	JMP	LNLOGC
	JMP	ERROR
	JMP*	.RTRN2	/ 'RETURN N'		OPCODE 26
	JMP*	.RTRN4	/ (N IS A VARIABLE)
	JMP	ERROR
	JMP	ERROR
	JMP	ERROR
	JMP	ERROR
	JMP	ERROR
	JMP	ERROR
LOADIT	JMP	LOAD2	/ DUMMY OPCODE 27 USED BY '.FETCH'
	JMP	LOAD2
	JMP	LOAD2
	JMP	LOAD2
	JMP	LOAD2
	JMP	LOAD2
	JMP	LOAD2
	JMP	LOAD2
/
LOAD2	CMA
	ADD	(XCT  LOADIT	/ GET MODE BITS IN AC
	CMA
	XCT*	FET.X	/ AND RETURN TO .FETCH IN .INTRP
	.EJECT
/
/ THE ARITHMETIC ROUTINES START HERE
/
/ LOGICAL 'AND'
LOGAND	LAC*	AUTO2	/PICK UP ARGUMENT
	SNA
	DAC	LOGACC
	JMP	.NEXT
/LOGICAL INCLUSIVE OR
LOGORN	LAC*	AUTO2
	CMA!SKP
LOGOR	LAC*	AUTO2	/PICK UP ARGUMENT
	SZA
	DAC	LOGACC
	JMP	.NEXT
LORORN	LAC	LOGACC
	CMA
	DAC	LOGACC
	JMP	LOGOR
	.EJECT
/
/ THE LOAD ROUTINES START HERE*******************************
/SINGLE INTEGER
/
/ SINGLE INTEGER
LDINT	XX
	LAC*	AUTO2	/PICK UP INTEGER
	DAC	INT2
	SPA!CLA		/EXTEND TO DOUBLE WORD
	CMA
	DAC	INT1
	DZM	MODEA	/MARK AS INTEGER
	JMP*	LDINT
/DOUBLE INTEGER
LDBINT	XX
	LAC*	AUTO2
	DAC	INT1
	LAC*	AUTO2
	DAC	INT2
	DZM	MODEA
	JMP*	LDBINT
/REAL VARIABLE
LDREAL	XX
	LAC	(200000	/ MARK AS REAL
	DAC	MODEA
LDTIE	LAC	SIGNB
	DAC	SIGNA
	LAC	EXPB
	DAC	EXPA
	LAC	MOSTB
	DAC	MOSTA
	LAC	LEASTB
	DAC	LEASTA
	JMP*	LDREAL
/DOUBLE PRECISION VARIABLE
LDDBL	XX
	LAC	(300000	/ MARK AS DOUBLE REAL
	DAC	MODEA
	LAC	LDDBL
DLDTIE	DAC	LDREAL
	LAC	B3
	DAC	A3
	LAC	B4
	DAC	A4
	JMP	LDTIE
/ COMPLEX VARIABLE
LDCPLS	XX
	LAC	(400000
	DAC	MODEA
	JMS	MVIMA
	LAC	LDCPLS
	JMP	DLDTIE
	.EJECT
/COMPLEX(DOUBLE PRECISION)
LDCPLD	XX
	LAC	(500000
	DAC	MODEA
	JMS	MVIMA
	LAC	LDCPLD
	JMP	DLDTIE
/LOGICAL
/ LOAD LOGICAL NEGATIVE
LNLOGC	LAC*	AUTO2
	CMA!SKP
/ LOAD LOGICAL
LDLOGC	LAC*	AUTO2
	DAC	LOGACC
	LAC	(600000
	DAC	MODEA
	JMP	.NEXT
/LOAD NEGATIVE ROUTINES
/LOAD INTEGER NEGATIVE
LNINT	XX
	LAC*	AUTO2
	CMA
	TAD	(1
	DAC	INT2
	SPA!CLA
	CMA
	DAC	INT1
	DZM	MODEA
	JMP*	LNINT
/LOAD DOUBLE INTEGER NEGATIVE
LNBINT	XX
	LAC*	AUTO2
	CMA
	DAC	INT1
	LAC*	AUTO2
	CMA!CLL
	TAD	(1
	DAC	INT2
	SZL
	ISZ	INT1
	DZM	MODEA
	JMP*	LNBINT
/LOAD REAL NEGATIVE
LNREAL	JMS	LDREAL
NSIGN	LAC	SIGNA
	XOR	(400000
	DAC	SIGNA
	JMP	.NEXT
/LOAD DOUBLE NEGATIVE
LNDBL	JMS	LDDBL
	JMP	NSIGN
	.EJECT
/LOAD SINGLE COMPLEX NEGATIVE
LNCPLS	JMS	LDCPLS
NSIGNI	LAC	SIGNIA
	XOR	(400000
	DAC	SIGNIA
	JMP	NSIGN
/LOAD DOUBLE COMPLEX NEGATIVE
LNCPLD	JMS	LDCPLD
	JMP	NSIGNI
/ LOAD CHARACTER VARIABLE
LDCHAR	LAC	SIGNB
	DAC	SIGNA	/CHARACTER COUNT
	LAC*	(AUTO2
	DAC*	(AUTO3
	LAC	(700000
	DAC	MODEA
	JMP	.NEXT
/
	.EJECT
/
/ THE ADDITION ROUTINES FOLLOW*******************************
/ADD REAL NUMBER TO ACCUMULATOR
/
ADDRL	XX
	LAC	MODEA	/GET MODE OF ACCUMULATOR
	SPA!RTL
	JMP	X1	/COMPLEX OR ILLEGAL
	SNL
	JMP	INTG1	/INTEGER
X1	SPA
	JMP	DOUBL1	/DOUBLE PRECISION
	JMS	SPRADD
	JMP*	ADDRL	/RETURN
INTG1	JMS	.FLOTA	/CONVERT TO REAL OR DOUBLE
	JMP	ADDRL+2	/REPEAT WITH CONVERTED ACCUM.
DOUBL1	DZM	B3	/EXTEND FRACTION LENGTH IN ACC B
	DZM	B4
	JMS	DPRADD	/DOUBLE PRECISION ADD ROUTINE
	JMP*	ADDRL	/RETURN
/ADD DOUBLE PRECISION NUMBER TO ACCUMULATOR
ADDBL	XX
	LAC	MODEA
	SPA!RTL
	JMP	X2
	SNL
	JMP	INTG2
X2	SMA
	JMP	REAL1
ADDB2	JMS	DPRADD
	JMP*	ADDBL
INTG2	JMS	.FLOTA	/CONVERT TO REAL OR DOUBLE
	JMP	ADDBL+2	/REPEAT WITH CONVERTED ACCUM.
REAL1	DZM	A3	/EXTEND FRACTION OF REAL PART
	DZM	A4
	DZM	AI3	/EXTEND FRACTION OF IMAG. PART
	DZM	AI4
	JMP	ADDB2	/DO DOUBLE PRECISION ADD
/ADD COMPLEX NUMBER TO ACCUMULATOR
ADDCPX	XX
	JMS	ADDRL	/ADD REAL PARTS
	LAC	MODEA
	SPA
	JMP	CMPLX3	/ACCUM. IS CMPLEX- PERFORM IMAG. ADD
	XOR	(600000
	DAC	MODEA
	JMS	MVIMA
	DZM	AI3
	DZM	AI4
	JMP*	ADDCPX
CMPLX3	JMS	SWAPA	/SAVE REAL PART, IMAG TO REAL
	JMS	ADDRL	/REAL ADD
	JMS	SWAPUS	/REAL TO IMAG, RESTORE REAL PART
	JMS	.SPBIA
	JMP*	ADDCPX	/RETURN
/ADD DOUBLE COMPLEX NUMBER TO ACCUMULATOR
ADDDCP	XX
	JMS	ADDBL
	LAC	MODEA
	SPA
	JMP	CMPLX4
	XOR	(600000
	DAC	MODEA
	JMS	MVIMA	/ ACCUMULATOR IS REAL, MOVE IN IMAG PART
	LAC	BI3
	DAC	AI3
	LAC	BI4
	DAC	AI4
	JMP*	ADDDCP
CMPLX4	JMS	SWAPA
	JMS	ADDBL
	JMS	SWAPUS
	JMS	.SPBIA
	JMP*	ADDDCP
/MOVE IMAG PART OF B TO IMAG PART OF A
MVIMA	XX
	LAC	EXPIB
	DAC	EXPIA
	LAC	SIGNIB
	DAC	SIGNIA
	LAC	MOSTIB
	DAC	MOSTIA
	LAC	LESTIB
	DAC	LESTIA
	LAC	MODEA
	RTL
	SMA
	JMP*	MVIMA
	LAC	BI3
	DAC	AI3
	LAC	BI4
	DAC	AI4
	JMP*	MVIMA
	.EJECT
/BI TO B, A TO BI, AI TO A
SWAPA	XX
	JMS	SWAPIB
	JMS	SWAPBI
	JMS	SWAPIT
	JMP*	SWAPA
/
/ BI TO B
/
SWAPIB	XX
	LAC	EXPIB
	DAC	EXPB
	LAC	SIGNIB
	DAC	SIGNB
	LAC	MOSTIB
	DAC	MOSTB
	LAC	LESTIB
	DAC	LEASTB
	LAC	BI3
	DAC	B3
	LAC	BI4
	DAC	B4
	JMP*	SWAPIB
/
/ A TO BI
/
SWAPBI	XX
	LAC	EXPA
	DAC	EXPIB
	LAC	SIGNA
	DAC	SIGNIB
	LAC	MOSTA
	DAC	MOSTIB
	LAC	LEASTA
	DAC	LESTIB
	LAC	A3
	DAC	BI3
	LAC	A4
	DAC	BI4
	JMP*	SWAPBI
	.EJECT
/ BI TO A
/
.SPBIA	XX
	LAC	EXPIB
	DAC	EXPA
	LAC	SIGNIB
	DAC	SIGNA
	LAC	MOSTIB
	DAC	MOSTA
	LAC	LESTIB
	DAC	LEASTA
	LAC	BI3
	DAC	A3
	LAC	BI4
	DAC	A4
	JMP*	.SPBIA
/
/ A TO AI
SWAPUS	XX
	LAC	EXPA
	DAC	EXPIA
	LAC	SIGNA
	DAC	SIGNIA
	LAC	MOSTA
	DAC	MOSTIA
	LAC	LEASTA
	DAC	LESTIA
	LAC	A3
	DAC	AI3
	LAC	A4
	DAC	AI4
	JMP*	SWAPUS
	.EJECT
/
/THIS SUBROUTINE ASSUMES SINGLE PRECISION REAL, DOUBLE PREC-
/ ISION REAL, OR DOUBLE PRECISION COMPLEX BASED ON THE INCLUS-
/ IVE OR OF THE MODE BITS WHEN SWITCHING ACC'S A & B FOR
/ REVERSE OPERATIONS.
/
REVRSG	XX
	LAC	(MODEA-1	/ ACC A POINTERS
	DAC*	(AUTO5
	DAC*	(AUTO6
	LAC	(MODEB-1	/ ACC B POINTERS
	DAC*	(AUTO3
	DAC*	(AUTO4
	LAC	MODEA
	LMQ
	LAC	MODEB
	OMQ		/ OR OF MODE IN AC
	SMA!RCL		/ AC -5 FOR REAL,-7 FOR DOUBLE,-15 FOR COMPLEX
	SKP!RAL
	LAW	-3
	SPA!RCL
	TAD	(-2
	TAD	(-5
	DAC	MOVCNT	/ SAVE WORD COUNT
REVR2	LAC*	AUTO5	/ START SWITCHING
	LMQ		/ SAVE IN MQ
	LAC*	AUTO3
	DAC*	AUTO6
	LACQ
	DAC*	AUTO4
	ISZ	MOVCNT
	JMP	REVR2	/ L=1 IF COMPLEX
	JMP*	REVRSG
/
/
/ADD SINGLE INTEGER TO ACCUMULATOR
INTADD	XX
	LAC	MODEA	/IS AC AN INTEGER
	SZA
	JMP	MIXEA	/MIXED MODE
	LAC*	AUTO2	/GET INTEGER
	SMA!CLL		/TEST SIGN
	JMP	TIEPNT	/POSITIVE NUMBER
NEG	TAD	INT2	/NEG NUMBER ONLY
	DAC	INT2	/ADD LEAST SIGNIFIGANT PART
	SZL!CLA!CMA	/SET AC TO 777777,TEST FOR CARRY
	JMP*	INTADD	/RETURN IF CARRY OCCURS
	TAD	INT1	/ADD MOST SIGNIFIGANT PART
	DAC	INT1
	JMP*	INTADD	/RETURN
/
/
MIXERS	LAC	SIGNA	/CHANGE SIGN OF FLOATING ACC
	XOR	(400000
	DAC	SIGNA
MIXEA	JMS	PICK1	/GET INTEGER
	JMS	.FLOTB	/CONVERT TO REAL NUMBER
SINGAD	JMS	ADDRL	/DO REAL ADDITION
	JMP*	INTADD	/RETURN
	.EJECT
/
/ THE SUBTRACTION ROUTINES FOLLOW
/
/SUBTRACT SINGLE INTEGER FROM ACCUMULATOR
INTSUB	XX
	LAC	INTSUB	/SET UP RETURN ADDRESS
	DAC	INTADD
	LAC	MODEA
	SZA!CLL!CML!CMA  /SKIP IF ACC IS INT.GET READY FOR 2'S COMP
	JMP	MIXES	/MIXED MODE
	TAD*	AUTO2	/PICK UP &2'S COMP INTEGER
	SMA!CMA!CLL		/TEST SIGN TO SPLIT INTO +AND-
	SAD	(400000
	JMP	TIEPNT	/POSITIVE
	JMP	NEG	/NEGATIVE
MIXES	JMS	PICK1	/GET INTEGER
	JMP	MIXAB
/REVERSE SUBTRACT SINGLE INTEGER
INTRSB	LAC	(.NEXT	/SET UP RETURN ADDRESS
	DAC	INTADD
	LAC	MODEA
	SZA!CLL!CML	/SKIP IF INTEGER SET LINK
	JMP	MIXERS	/MIXED MODE
	RAL		/AC IS 1
	TAD	INT1	/COMPLEMENT OF INT1+777777
	CMA!CML
	DAC	INT1
	LAC*	AUTO2	/GET INTEGER
	SMA!CMA!CLL
	ISZ	INT1	/777777 WAS A MISTAKE-RESCIND
	NOP
	TAD	INT2	/FORM DIFFERENCE
	CMA!CML
	JMP	TIEPN2
/ADD DOUBLEINTEGER TO ACC
DINTAD	XX
	LAC	DINTAD	/SET UP RETURN ADDR
	DAC	INTADD
	LAC	MODEA	/TEST AC MODE
	SZA
	JMP	MIXDAD	/MIXED
	LAC*	AUTO2
	TAD	INT1
	DAC	INT1	/MOST SIGNIF PART
	CLL
	LAC*	AUTO2
TIEPNT	TAD	INT2
TIEPN2	DAC	INT2	/LEAST SIG PART
	SZL
	ISZ	INT1	/PROPAGATE CARRY
	JMP*	INTADD
	JMP*	INTADD
	.EJECT
MIXDRS	LAC	SIGNA
	XOR	(400000	/REVERSE SIGN OF FLOATING NUMBER
	DAC	SIGNA
MIXDAD	JMS	PICK2	/GET INTEGER
	JMS	.FLOTB	/CGNVERT TO FLOATING
MIXAB2	SAD	(200000
	JMP	SINGAD	/RETURN HERE IF SINGLE
	JMS	ADDBL	/AND HERE IF DOUBLE
	JMP*	INTADD	/RETURN
/SUBTRACT DOUBLE INTEGER FROM ACCUMULATOR
DINTSB	XX
	LAC	DINTSB	/SET RETURN ADDRESS
	DAC	INTADD
	LAC	MODEA
	SZA
	JMP	MIXDSB	/MIXED
	LAC*	AUTO2
	CMA		/COMPLEMENT FIRST WORD
	TAD	INT1	/ADD TO MOST SIGN WORD
	DAC	INT1
	CLL!CLA!CMA	/GENERATE 2'S COMPLEMENT OF 2ND WORD
	TAD*	AUTO2
	CML!CMA
	JMP	TIEPNT	/GO TO COMPLETE OPERATION
MIXDSB	JMS	PICK2	/GET INTEGER
MIXAB	JMS	.FLOTB	/CONVERT TO FLOAT
	JMS	COMPLB
	LAC	MODEB
	JMP	MIXAB2
/REVERSE SUBTRACT DOUBLE INTEGER FROM ACCUMULATOR
DINTRS	LAC	(.NEXT	/SET RETURN ADDRESS
	DAC	INTADD	
	LAC	MODEA
	SZA
	JMP	MIXDRS	/MIXED MODE
	LAC	INT1
	CMA
	TAD*	AUTO2
	DAC	INT1	/MOST SIG. WORD
	CLL!CLA!CMA	/GENERATE 2'S CMP OF INT2
	TAD	INT2
	CML!CMA
	TAD*	AUTO2
	JMP	TIEPN2
/ SUBTRACT REAL
SUBRL	XX
	JMS	COMPLB
	JMS	ADDRL
	JMP*	SUBRL
	.EJECT
/REVERSE SUBTRACT REAL
RSBRL	JMS	COMPLA
	JMS	ADDRL
	JMP	.NEXT
/ SUBTRACT DOUBLE
SUBDBL	XX
	JMS	COMPLB
	JMS	ADDBL
	JMP*	SUBDBL
/REVERSE SUBTRACT DOUBLE
RSBDBL	JMS	COMPLA
	JMS	ADDBL
	JMP	.NEXT
/ SUBTRACT SINGLE COMPLEX
SUBCPX	JMS	COMPLB
	LAC	(400000
	XOR	SIGNIB
	DAC	SIGNIB
	SKP
/REVERSE SUBTRACT SINGLE COMPLEX
RSBCPX	JMS	COMPLA
	JMS	ADDCPX
	JMP	.NEXT
/SUBTRACT DOUBLE COMPLEX
SUBDPX	JMS	COMPLB
	LAC	(400000
	XOR	SIGNIB
	DAC	SIGNIB
	SKP
/REVERSE SUBTRACT DOUBLE COMPLEX
RSBDPX	JMS	COMPLA
	JMS	ADDDCP
	JMP	.NEXT
/COMPLEMENT ROUTINE FOR REVERSE SUBTRACT-IF AC IS INTEGER ,
/CONVERTS TO FLOAT
COMPLA	XX
	LAC	MODEA
	SNA!RAL
	JMP	INTS	/INTEGER AC.
CPTIE	SZL!CLL!CML!CLA	/SKIP IF REAL,AC=0,L=1
	JMP	CPLXS	/COMPLEX
INTIE	RAR		/AC=400000,L=0
	XOR	SIGNA
	DAC	SIGNA	/REVERSE SIGN
	JMP*	COMPLA
CPLXS	RAR		/AC=400000,L=0
	XOR	SIGNIA
	DAC	SIGNIA	/REVERSE SIGN
	JMP	CPTIE	/L=0 STILL
INTS	JMS	.FLOTA	/CONVERT TO FLOAT
	CLL!CML		/L=1
	JMP	INTIE
	.EJECT
/COMPLEMENT ROUTINE FOR SUBTRACT
COMPLB	XX
	LAC	(400000
	XOR	SIGNB
	DAC	SIGNB
	JMP*	COMPLB
/
/ SINGLE AND DOUBLE INTEGER LOAD FOR .FLOTB
/
PICK1	XX
	LAC*	AUTO2	/PICK UP INTEGER
	DAC	INT2
	SPA!CLA		/EXTEND TO DOUBLE WORD
	CMA
	DAC	INT1
	JMP*	PICK1
/
/
PICK2	XX
	LAC*	AUTO2
	DAC	INT1
	LAC*	AUTO2
	DAC	INT2
	JMP*	PICK2
/
/
/CONVERT INTEGER ACCUMULATOR TO FLOATING POINT IN ACC A
.FLOTA	XX
	LAC	(MODEA
	JMS	FLOATX
	DAC	MODEA
	JMP*	.FLOTA
/
/ FLOAT INTEGER ACCUMULATOR INTO ACCUMULATOR B
.FLOTB	XX
	LAC	(MODEB
	JMS	FLOATX
	DAC	MODEB
	JMP*	.FLOTB
	.EJECT
/
/ CONVERT INTEGER ACCUMULATOR INTO FLOATING POINT
/ GENERALIZED FLOAT ROUTINE
FLOATX	XX
	DAC*	(AUTO6
	LAC	INT1
	GSM
	DAC	INT1
	CLA!RAR
	DAC*	AUTO6	/ SET SIGN
	SMA!CLL!CLA!CMA
	JMP	FLTA
	TAD	INT2
	SKP!CML!CMA
FLTA	LAC	INT2
	LMQ
	GLK
	TAD	INT1
	SZA!CLL
	JMP	FNORMA
	LACQ
	SNA!CLA
	JMP	FZEROA
FNORMA	NORM
	DAC	INT1
	LAW	17700
	OSC
	CMA
	DAC*	AUTO6	/ STORE EXPONENT
	DAC	INT2
	LAC	INT1
	LLS	1
	DAC*	AUTO6	/ STORE MOST SIGNIFICANT BITS
	LACQ
	DAC*	AUTO6	/ STORE LEAST SIGNIFICANT BITS
	LAW	-33
	TAD	INT2
	SPA!CLL
	JMP	FSNGLA
	DZM*	AUTO6
	DZM*	AUTO6
	LAC	(300000	/SET MODE TO DOUBLE
	JMP*	FLOATX	/RETURN
FZEROA	LAC	(400000
	DAC*	AUTO6
	DZM*	AUTO6
	DZM*	AUTO6
FSNGLA	LAC	(200000	/SET MODE TO REAL
	JMP*	FLOATX
	.EJECT
/SINGLE PRECISION REAL ADD
SPRADD	XX
	LAC	EXPB	/DIFFERENCE OF EXPONENTS
	CMA!CLL
	ADD	EXPA	/DIFFERENCE OF EXPONENTS
	SZA!SMA!SNL!CMA	/TEST AND COMPLIMENT
	JMP	ALARGE	/EXPA LARGER
	SZA!SMA!SNL	/TEST AGAIN
	JMP	BLARGE	/EXPB LARGE
	SZL
	JMP	HUGE	/DIFFERENCE GREATER THAN 2**17-1
	LAC	SIGNA	/WE NOW HAVE EQUAL EXPONENTS
	XOR	SIGNB
	SPA!CLL
	JMP	DIFF	/DIFFERENT SIGNS
	LAC	LEASTA
JOIN	TAD	LEASTB
JOIN2	DAC	LEASTA
	GLK		/CARRY FROM FIRST ADD
	TAD	MOSTA
	TAD	MOSTB
	DAC	MOSTA	/ASSUME NORM NOT NEEDED
	SNL!RAR		/TEST FOR OVERFLOW AND ROTATE RIGHT
	JMP*	SPRADD	/NO OVERFLOW- EXIT
	DAC	MOSTA	/STORE NORMALIZED FIRST WORD
	LAC	LEASTA	/GET SECOND WORD
	RAR		/ROTATE TO CONCATENATE WITH BIT IN LINK
	DAC	LEASTA	/STORE IT
JOINSD	ISZ	EXPA	/INCREMENT EXPONENT
	SKP!CLA!STL
	JMP	.-2	/WE DID -0 TO +0, TRY AGAIN
	RAR		/ SET AC _ 400000
	SAD	EXPA	/TEST IF OVERFLOW, 377777 TO 400000
	SKP!CLA		/ WE HAVE INFINITY BY ADDITION
	JMP*	SPRADD	/EXIT
	JMS*	.ERROR	/ERROR 0 EXPONENT OVERFLOW
	JMS	INFIN	/ SET TO INFINITY
	JMP*	SPRADD
ALARGE	CMA		/COMP. OF SHIFT IS IN AC
	XOR	(LRS	/CONSTRUCT SHIFT INSTRUCTION
	DAC	SHIFTA
	XOR	(LRS	/RECOVER COUNT
	ADD	(-44
	SMA!SZA!CLL	/IS DIFFERENCE MORE THAN 2**36
	JMP*	SPRADD	/YES- EXIT LEAVING A UNCHANGED
	LAC	LEASTB	/NORMALIZE BY SHIFTING AC.MQ
	LMQ
	LAC	MOSTB
SHIFTA	XX
	DAC	MOSTB	/PUT MOST SIGN. WORD BACK
	LAC	SIGNA	/TEST SIGNS
	XOR	SIGNB
	GS!LACQ		/GET LEAST SIGN. WORD INTO AC
	SZL!CLL		/AND TEST SIGN CONDITION
	JMP	BSMALL	/DIFFERENT SIGNS FORM A-B
	TAD	LEASTA	/SAME SIGNS FORMA+B
	JMP	JOIN2
	.EJECT
BLARGE	XOR	(LRS
	DAC	SHIFTB
	XOR	(LRS
	ADD	(-44
	SMA!SZA!CLL
	JMP	SWOP	/B>>A SWAP THEM
	LAC	EXPB
	DAC	EXPA
	LAC	LEASTA
	LMQ
	LAC	MOSTA
SHIFTB	XX
	DAC	MOSTA
	LAC	SIGNA
	XOR	SIGNB
	GS!LACQ
	SNL!CLL
	JMP	JOIN	/SAME SIGN ADD THEM
	CMA!CLL
	TAD	LEASTB	/FORM B-A ON LEAST SIGN. PARTS
	TAD	(1
	DAC	LEASTA
	LAC	SIGNB
	DAC	SIGNA
	LAC	MOSTA
	SZL!CMA!CLL
	TAD	(1
	TAD	MOSTB
	JMP	NORMLZ
HUGE	LAC	EXPA	/WHICH IS THE LARGER EXPONENT
	SMA
	JMP*	SPRADD	/A IS BIGGER-EXIT
SWOP	LAC	SPRADD
	DAC	LDREAL
	JMP	LDTIE
	.EJECT
/SUBTRACTING EQUAL EXPONENT NUMBERS. TRY A-B FIRST AND IF IT GIVES
/A NEGATIVE RESULT,COMPLEMENT IT .SUBTRACTION WITH B SHIFTED ENTERS
/BSMALL . IF THE SUBTRACTION DEVELOPES MORE THAN ONE
/LEADING ZERO,RESULT IS ROUNDED TO 27 BITS BEFORE NORMALIZING.
DIFF	LAC	LEASTB
BSMALL	CMA!CLL		/-B+A
	TAD	(1
	TAD	LEASTA
	DAC	LEASTA
	LAC	MOSTB
	SZL!CMA!CLL	/TEST FOR CARRY
	TAD	(1	/CARRY
	TAD	MOSTA
	SZL
	JMP	NORMLZ	/TRUE RESULT
	DAC	MOSTA
	LAC	SIGNB	/NO COMPLEMENT IT
	DAC	SIGNA
	LAC	LEASTA
	CMA!CLL
	TAD	(1
	DAC	LEASTA
	LAC	MOSTA
	SZL!CMA
	TAD	(1
NORMLZ	DAC	MOSTA
	SPA!CLL!RAL	/WAS LEADING ZERO FORMED
	JMP*	SPRADD	/NO EXIT
/IF ONLY 1 LEADING ZERO, ROTATE WILL HAVE REMOVED IT
	SMA		/IS THERE STILL AZERO
	JMP	GRIND	/YES-GO NORMALIZE IT
	DAC	MOSTA	/STORE WORD ONE, BIT 17 = 0
	LAC	LEASTA	/GET NEXT WORD
	RAL		/GET BIT ZERO INTO LINK
	DAC	LEASTA	/STORE IT BACK
	LAW	-2	/EXPONENT ADJUSTMENT INITIALIZATION
EXPADJ	SZL!CLL		/WAS MBIT ZERO OF 2ND WORD A 1
	ISZ	MOSTA	/YES-ADD 1 TO 1ST WORD
	ADD	EXPA	/ADJUST EXPONENT
	SAD	(777777	/ CHECK FOR -0
	CMA
	DAC	EXPA
	SZL
ZEROS	JMS	ZERVAL	/ FORM REAL ZERO. NO UNDERFLOW ERROR INDICATED
	JMP*	SPRADD	/ SINCE CORRECT VALUE MAY BE ZERO;  EXIT
	.EJECT
/ROUTINE TO NORMALIZE NUMBERS WITH MORE THAN ONE LEADING ZERO.
/ROUNDS TO 27 BITS.
GRIND	LAC	LEASTA
	TAD	(400	/ROUND TO 27 BITS
	AND	(777000	/CHOP OFF TRASH
	LMQ
	GLK		/ CARRY FROM ROUNDING
	TAD	MOSTA
	NORM		/GET RID OF ALL BUT ONE LEADING ZERO
	RAL		/GET RID OF LEADING ZERO
	DAC	MOSTA	/LAST BIT = ZERO
	LACQ		/GET 2ND WORD
	RAL		/FIRST BIT INTO LINK
	DAC	LEASTA	/FIRST BIT REMAINS IN LINK
	LACS		/GET STOP COUNTER AND
	TAD	(777745	/FORM ONE'S COMPLIMENT
	SMA!CMA!CML	/COMPLIMENTARY LINK REPAIRS DAMAGE OF TAD
	JMP	EXPADJ	/FIX UP EXPONENT
	JMP	ZEROS	/SHIFT OF 36, ALL ZEROS
	.EJECT
/ THE DOUBLE PRECISION ROUTINES FOLLOW
/
/DOUBLE PRECISION REAL ADD
DPRADD	XX
	LAC	EXPB	/DETERMINE WHETHER EXPONENTS ARE
	CMA!CLL		/EQUAL, OR WHICH ONE IS LARGER
	ADD	EXPA
	SZA!SMA!SNL!CMA
	JMP	ALGE	/A IS LARGER
	SZA!SMA!SNL
	JMP	BLGE	/B IS LARGER
	SZL
	JMP	IMMENS	/DIFFERENCE OF EXPONENTS IS VERY BIG
DBLEQL	LAC	SIGNA	/EQUAL EXPONENTS NOW
	XOR	SIGNB	/TEST SIGNS
	SMA!CLL
	JMP	DBLSAM	/SAME SIGNS
	LAC	B4	/ASSUME A IS LARGER
	CMA!CLL
	TAD	(1
	TAD	A4
	DAC	A4
	LAC	B3
	SZL!CMA!CLL
	TAD	(1
	TAD	A3
	DAC	A3
	LAC	LEASTB
	SZL!CMA!CLL
	TAD	(1
	TAD	LEASTA
	DAC	LEASTA
	LAC	MOSTB
	SZL!CMA!CLL
	TAD	(1
	TAD	MOSTA
	DAC	MOSTA
	SNL		/WAS A LARGER
	JMS	DBLCMP	/NO-COMPLEMENT RESULT
	SMA		/DOES IT NEED NORMALIZING
	JMS	.DBNRM	/YES-NORMALIZE
	JMP*	DPRADD
	.EJECT
DBLSAM	LAC	A4	/SIGNS ARE SAME-ADD A AND B
	TAD	B4
	DAC	A4
	GLK
	TAD	A3
	TAD	B3
	DAC	A3
	GLK
	TAD	LEASTA
	TAD	LEASTB
	DAC	LEASTA
	GLK
	TAD	MOSTA
	TAD	MOSTB
	DAC	MOSTA
	SNL!RAR
	JMP*	DPRADD
	DAC	MOSTA
	LAC	LEASTA
	RAR
	DAC	LEASTA
	LAC	A3
	RAR
	DAC	A3
	LAC	A4
	RAR
	DAC	A4
	LAC	DPRADD	/SET UP RETURN ADDRESS
	DAC	SPRADD
	JMP	JOINSD
DBLCMP	XX		/COMPLIMENT RESULT OF A-B
	LAC	SIGNA
	XOR	(400000
	DAC	SIGNA
	LAC	A4
	CMA!CLL
	TAD	(1
	DAC	A4
	LAC	A3
	SZL!CMA!CLL
	TAD	(1
	DAC	A3
	LAC	LEASTA
	SZL!CMA!CLL
	TAD	(1
	DAC	LEASTA
	LAC	MOSTA
	SZL!CMA!CLL
	TAD	(1
	DAC	MOSTA
	JMP*	DBLCMP
	.EJECT
/ DOUBLE PRECISION NORMALIZE ROUTINE
.DBNRM	XX
	LAW	-4
	DAC	BOXX
DGRNM	LAC	MOSTA
	SZA!CLL
	JMP	DNRM
	LAW	-23
	ADD	EXPA
	DAC	EXPA
	SZL		/ CHECK FOR UNDERFLOW
	JMP	UNDER
	ISZ	BOXX	/ CHECK FOR ALL ZEROS
	SKP
	JMP	DZERO	/ SET ACC TO ZERO
	LAC	LEASTA
	DAC	MOSTA
	LAC	A3
	DAC	LEASTA
	LAC	A4
	DAC	A3
	DZM	A4
	JMP	DGRNM
/ NORMALIZE NUMBER, ONLY IF LEADING BIT ZERO
DNRM	SPA!STL		/ NOTE: LINK IS SET
	JMP*	.DBNRM	/ NO SHIFT NESCESSARY
	NORM
	LAW	17700
	OSC
	TAD	(LLS	45	/NOTE: THIS CLEARS LINK
	DAC	DSHL1
	XOR	(LLS\777777	/ REMOVE LLS AND GET 1'S COMP OF # OF SHIFTS
	ADD	EXPA
	DAC	EXPA
	SNL!CLL		/TEST FOR EXPONENT UNDERFLOW
	JMP	DSHIFT
UNDER	LAW	1
	JMS*	.ERROR	/ ERROR UNDERFLOW, ISSUE ERROR AND RETURN
/ UNDERFLOW AND ZERO CASES COME HERE
DZERO	JMS	ZERVAL	/GENERATE DOUBLE PRECISION ZERO, NO ERROR
	JMP*	DPRADD	/EXIT
	.EJECT
/ PERFORM THE REQUIRED SHIFTING
DSHIFT	LAC	LEASTA	/NORMALIZE BY LONG LEFT SHIFTS
	LMQ
	LAC	MOSTA
DSHL1	XX		/MOSTA.LEASTA
	DAC	MOSTA
	LAC	A3
	LMQ
	LAC	LEASTA
	XCT	DSHL1	/LEASTA.A3
	DAC	LEASTA
	LAC	A4
	LMQ
	LAC	A3
	XCT	DSHL1	/A3.A4
	DAC	A3
	LACQ
	DAC	A4
	JMP*	.DBNRM
/
/
/ EXPONENT OF A IS LARGER
ALGE	CMA		/ENTER WITH COMPLEMENT OF SHIFT IN AC
	DAC	BOXX
	ADD	(-110
	SMA!SZA!CLL
	JMP*	DPRADD	/A MUCH GREATER THAN B
ALGE1	LAC	BOXX	/SHIFT RIGHT BY WORDS IF POSSIBLE
	TAD	(-22
	SPA!CLL
	JMP	DRSHFT
	DAC	BOXX
	LAC	B3
	DAC	B4
	LAC	LEASTB
	DAC	B3
	LAC	MOSTB
	DAC	LEASTB
	DZM	MOSTB
	JMP	ALGE1
DRSHFT	LAC	BOXX	/NOW SHIFT RIGHT IN PAIRS BY LRS
	XOR	(LRS
	DAC	DRSH1
	LAC	B4
	LMQ
	LAC	B3
DRSH1	XX
	LACQ
	DAC	B4
	LAC	B3
	LMQ
	LAC	LEASTB
	XCT	DRSH1
	LACQ
	DAC	B3
	LAC	LEASTB
	LMQ
	LAC	MOSTB
	XCT	DRSH1
	DAC	MOSTB
	LACQ
	DAC	LEASTB
	JMP	DBLEQL	/EXPONENTS ARE EQUAL NOW
/
/
/ B EXPONENT IS LARGER
BLGE	DAC	BOXX
	ADD	(-110
	SMA!SZA!CLL
	JMP	DBLSWP	/B MUCH GREATER THAN A
	LAC	EXPB	/SWAP EXPB INTO EXPA
	DAC	EXPA
BLGE1	LAC	BOXX	/SHIFT RIGHT BY WORDS IF POSSIBLE
	TAD	(-22
	SPA!CLL
	JMP	DRSHF2
	DAC	BOXX
	LAC	A3
	DAC	A4
	LAC	LEASTA
	DAC	A3
	LAC	MOSTA
	DAC	LEASTA
	DZM	MOSTA
	JMP	BLGE1
DRSHF2	LAC	BOXX	/SHIFT RIGHT IN PAIRS BY LRS
	XOR	(LRS
	DAC	DRSH4
	LAC	A4
	LMQ
	LAC	A3
DRSH4	XX
	LACQ
	DAC	A4
	LAC	A3
	LMQ
	LAC	LEASTA
	XCT	DRSH4
	LACQ
	DAC	A3
	LAC	LEASTA
	LMQ
	LAC	MOSTA
	XCT	DRSH4
	DAC	MOSTA
	LACQ
	DAC	LEASTA
	JMP	DBLEQL	/EXPONENTS ARE EQUAL NOW
/
/
IMMENS	LAC	EXPA	/TEST DIFFERENCE OF EXPONENTS
	SMA
	JMP*	DPRADD	/A MUCH LARGER THAN B-EXIT
DBLSWP	LAC	DPRADD
	JMP	DLDTIE
	.EJECT
/
/ THE MULTIPLY ROUTINES START HERE
/
/SINGLE PRECISION INTEGER MULTIPLY
INTMUL	LAC	MODEA
	SZA
	JMP	MIXEMI	/MIXED MODE
	LAC*	AUTO2	/GET INTEGER
	SNA		/TEST FOR ZERO
	JMP	INTMZ2	/ZERO-GO TO ZERO ROUTINE
	GSM		/FORM 2'S COMP. IF NEGATIVE
	SZL
	TAD	(1
	DZM	INTMA	/EXPAND LEFT WITH ZEROS
	JMS	INTMPY	/PERFORM MULT.
	JMP	.NEXT
MIXEMI	JMS	PICK1	/GET INTEGER
	JMS	.FLOTB	/FLOAT IT
	JMP	MULRL	/PERFORM REAL MULTIPLY
INTMZ2	DZM	INT1	/ SET INTEGER TO ZERO
	DZM	INT2
	JMP	.NEXT
/
/DOUBLE PRECISION INTEGER MULTIPLY
DINTML	LAC	MODEA
	SZA
	JMP	MIXEM2	/MIXED MODE
	LAC*	AUTO2	/GET FIRST WORD
	GSM		/GET SIGN AND MAGNITUDE
	DAC	INTMA	/STORE IT
	LAC*	AUTO2	/GET SECOND WORD
	SNL		/IS IT NEGATIVE
	JMP	DMLT	/NO-BYPASS COMPLEMENTING
	CMA!CLL		/YES-COMPLEMENT
	TAD	(1
	SZL!CLL!CML	/TEST FOR CARRY AND SET LINK
	ISZ	INTMA	/PROPAGATE CARRY
DMLT	JMS	INTMPY	/PERFORM MULTIPLICATION
	JMP	.NEXT
MIXEM2	JMS	PICK2	/MIXED MODE - PICK UP INTEGER
	JMS	.FLOTB	/FLOAT IT
	SAD	(200000
	JMP	MULRL	/SINGLE PRECISION MULTIPLY
	JMS	MULBL	/DOUBLE PRECISION MULTIPLY
/MULTIPLY ROUTINE FOR INTEGERS
INTMPY	XX
	DAC	INTMB	/STORE SECOND HALF OF INTEGER
	CLA!RAR		/STORE SIGN OF MULTIPLIER
	DAC	BOXX
	LAC	INT1	/GET FIRST WORD OF MULTIPLICAND
	SMA		/TEST SIGN AND SET LINK=0 FOR POS.
	JMP	MIPOS	/POSITIVE - BYPASS COMPLIMENTING
	JMS	INTACP	/COMPLEMENT INTEGER
	LAC	(400000	/GET SIGN
	XOR	BOXX	/DEVELOP RESULT SIGN
	DAC	BOXX
	LAC	INT1	/TEST FOR PRECISION AND FOR ZERO
MIPOS	SZA
	JMP	IDBL1	/ACCUM A IS DOUBLE, B NOT KNOWN
	LAC	INTMA
	SZA!CLL
	JMP	IDBL2	/ACCUM B IS DOUBLE IS SINGLE
	LAC	INT2
	SNA
	JMP*	INTMPY	/ACCUM A IS ZERO-RETURN
	LAC	INTMB
	SNA!CLL
	JMP	INTMZ	/ACCUM B IS ZERO - GO TO ZERO RETURN
	DAC	.+3	/SET UP MULTIPLIER
	LAC	INT2	/SET UP MULTIPLICAND
	MUL		/MULTIPLY
	XX
	DAC	INT1	/STORE RESULT
	LACQ
	DAC	INT2
INTMTS	LAC	BOXX	/SIGN RESULT
	SZA
	JMS	INTACP
	JMP*	INTMPY
INTMZ	DZM	INT1	/ZERO ROUTINE-SET ACCUM A TO ZERO
	DZM	INT2
	JMP*	INTMPY
IDBL1	LAC	INTMA	/SEE IF ACCUM B IS ALSO DOUBLE
	SNA!CLL
	JMP	IDBL2	/NOT DOUBLE - PROCEED
I0VFLM	LAW	2	/OVERFLOW WILL OCCUR IN MULT.
	JMS*	.ERROR
	LAC	BOXX	/ LOAD AC WITH SIGN
	JMS	LARGEI	/ ON OVERFLOW SET TO LARGEST + OR -
	JMP*	INTMPY	/ INTEGER
IDBL2	LAC	INT2	/DEVELOP AR*BR
	DAC	.+3
	LAC	INTMB
	MUL
	XX
	DAC	INTM3	/STORE IT
	LACQ
	DAC	INTM4
	LAC	INT1	/DEVELOP AL*BR*2**18
	DAC	.+3
	LAC	INTMB
	MUL
	XX
	SZA
	JMP	I0VFLM	/OVERFLOW DURING MULT.
	LACQ
	TAD	INTM3	/ADD TO PREVIOUS RESULT
	SZL!CLL
	JMP	I0VFLM	/OVERFLOW ON ADDING
	DAC	INTM3
	LAC	INT2	/DEVELOP AR*BL*2**18
	DAC	.+3
	LAC	INTMA
	MUL
	XX
	SZA
	JMP	I0VFLM	/OVERFLOW ON MULTIPLYING
	LACQ
	TAD	INTM3	/ADD TO PREVIOUS RESULT
	SZL!CLL
	JMP	I0VFLM	/OVERFLOW ON ADDING
	SPA
	JMP	I0VFLM	/OVERFLOW INTO SIGN BIT OCCURED
	DAC	INT1	/STORE INTO ACCUMULATOR A
	LAC	INTM4
	DAC	INT2
	JMP	INTMTS	/GO BACK TO PICK UP SIGN
/MULTIPLY ACCUMULATOR BY REAL NUMBER
MULRL	LAC	MODEA	/GET MODE OF ACC.
	SPA!RTL
	JMP	COMPMS
	SNL
	JMP	INTGM1
	SPA
	JMP	DOUBM1
MULS	JMS	SPRMUL
	JMP	.NEXT
INTGM1	JMS	.FLOTA	/CONVERT TO FLOAT
	SAD	(200000
	JMP	MULS	/SINGLE PRECISION MULTIPLY
	JMP	MULBL2	/DOUBLE PRECISION MULTIPLY
DOUBM1	DZM	B3	/EXTEND FRACTION LENGTH
	DZM	B4
	JMP	MULBL2	/DOUBLE PRECISION MULTIPLY
COMPMS	JMS	ZEROIB
	JMS	MULCPX	/DO COMPLEX MULT.
	JMP	.NEXT
/MULTIPLY ACCUMULATOR BY DOUBLE PRECISION NUMBER
MULBL	LAC	MODEA
	SPA!RTL
	JMP	COMPMD	/COMPLEX
	SNL
	JMP	INTGM2	/INTEGER
	SMA
	JMP	REALM2	/REAL
MULBL2	JMS	DPRMUL	/DOUBLE
	JMP	.NEXT
INTGM2	JMS	.FLOTA	/CONVERT TO FLOAT
	SAD	(300000
	JMP	MULBL2	/DOUBLE
REALM2	DZM	A3	/EXTEND FRACTION LENGTH
	DZM	A4
	JMP	MULBL2	/DOUBLE PRECISION MULTIPLY
COMPMD	JMS	ZEROIB
	JMS	MULDCP
	JMP	.NEXT
/MULTIPLY ACCUMULATOR BY SINGLE PRECISION COMPLEX
MULCPX	XX
	LAC	MULCPX
	DAC	MULDCP
	LAC	MODEA	/IS AC COMPLEX
	SMA!RTL
	JMS	MKCPX	/MAKE ACC A COMPLEX
	SPA
	JMP	MCPX2	/YES-MAKE B DOUBLE
	LAC	(JMS	SPARST
	DAC	CM0
	LAC	(JMS   SPRMUL	/NO SET UP FOR SINGLE OPERATIONS
	DAC	CM1
	LAC	(JMS	SPARLD
	DAC	CM2
	LAC	(JMS   SPRADD
CXMTIE	DAC	CM3
	JMP	MDCP3
MCPX2	DZM	BI3
	DZM	BI4
	DZM	B3
	DZM	B4
MDCP2	LAC	(JMS	DPARST
	DAC	CM0
	LAC	(JMS   DPRMUL	/SET UP FOR DOUBLE OPERATIONS
	DAC	CM1
	LAC	(JMS	DPARLD
	DAC	CM2
	LAC	(JMS   DPRADD
	JMP	CXMTIE
/MULTIPLY ACC BY DOUBLE PRECISION COMPLEX
/
MULDCP	XX
	LAC	MODEA	/IS ACC COMPLEX
	SMA!RTL
	JMS	MKCPX	/MAKE ACC A COMPLEX
	SPA
	JMP	MDCP2
	DZM	A3	/NO-MAKE IT DOUBLE
	DZM	A4
	JMP	MDCP2
MDCP3	LAC	(SIGNS
CM0	XX		/SAVE A
CM1	XX		/GET A*B
	LAC	(SIGNH
	XCT	CM0	/STORE A*B
	JMS	SWAPIT	/AI TO A
	XCT	CM1	/GET B*AI
	LAC	(SIGNS	/A TO ACC B
CM2	XX
	LAC	(SIGNS	/STORE B*AI
	XCT	CM0
	JMS	.SPBIA	/BI TO A
	XCT	CM1	/GET A*BI
	LAC	(SIGNS
	XCT	CM2	/B*AI TO ACC B
CM3	XX		/GET A*BI + B*AI
	JMS	SWAPA	/BI TO B,A TO BI,AI TO A
	XCT	CM1	/GET AI*BI
	LAC	SIGNA	/ (DO NOT WORRY ABOUT GENERATING -0 HERE
	XOR	(400000	/  SINCE THE ADDER HANDLES IT )
	DAC	SIGNA	/COMPLEMENT SIGNA
	LAC	(SIGNH
	XCT	CM2	/A*B TO ACC B
	XCT	CM3	/A*B - (AI*BI)
	LAC	MODEA
	XOR	(600000
	DAC	MODEA	/RESTORE COMPLEX MODE
	JMS	MVIMA	/BI TO AI
	JMP*	MULDCP
/
/SINGLE PRECISION REAL MULTIPLY
SPRMUL	XX
	LAC	(200000
	DAC	MODEA	/SET MODE TO SINGLE
	LAC	MOSTA
	SNA!CLL
	JMP*	SPRMUL	/ ANSWER WILL BE ZERO
	DAC	SPM1	/ STORE FOR MULT'S
	DAC	SPM3
	LAC	MOSTB	/CHECK FOR ACC B = 0
	SNA
	JMP	SPMZER
	DAC	SPM2
	LAC	EXPA	/ CALC NEW EXP
	ADD	EXPB
	DAC	EXPA
	SZL!CLL
	JMP	SPMEXP
	LAC	SIGNA	/ GET NEW SIGN
	XOR	SIGNB
	DAC	SIGNA
	LAC	LEASTB
	MUL
SPM1	XX
	DAC	INTMB	/ STORE TEMP
	LAC	LEASTA
	MUL
SPM2	XX
	TAD	INTMB
	DAC	LEASTA
	GLK		/ GET CARRY
	DAC	INTMA	/ TEMP STORAGE
	LAC	MOSTB	/ CALC MOST SIGNIF.
	MUL
SPM3	XX		/ MOSTA
	TAD	INTMA
	DAC	MOSTA
	LACQ		/ GET LEAST SIGNIF PART
	TAD	LEASTA
	DAC	LEASTA
	GLK		/ GET CARRY
	TAD	MOSTA
	DAC	MOSTA
	SPA!CLL!RAL	/ IS IT NORM?  SHIFT TO NORM
	JMP*	SPRMUL	/ ANSWER WAS FINE
	DAC	MOSTA
	LAC	LEASTA
	CLL!RAL
	DAC	LEASTA
	SZL!CLL
	ISZ	MOSTA
	LAW	-2	/ DECREMENT EXP BY 1
	ADD	EXPA
	SZL!CLL!CMA	/ANY OVER OR UNDER FLOW
	JMP	SPMEXP	/ YES
	SNA!CMA		/ IF ACC 0 THEN EXP =  -0
	CLA		/ MAKE  +0
	DAC	EXPA
	JMP*	SPRMUL
SPMZER	JMS	ZERVAL	/ MAKE ACC A 0
	JMP*	SPRMUL
SPMEXP	LAC	SPRMUL	/ MOVE RETURN ADDRESS
	DAC	DPRMUL	/ USE DPRMUL'S ERROR ROUTINE
	JMP	DPMEXP
/
/DOUBLE PRECISION REAL MULTIPLY
DPRMUL	XX
	LAC	(300000	/SET MODE TO DOUBLE
	DAC	MODEA
	LAC	MOSTA
	SNA
	JMP*	DPRMUL
	LAC	MOSTB
	SNA
	JMP	DPMZER
	DZM	BOXX
	DZM	SIZE
	DZM	INTMA
	DZM	INTMB
	DZM	INTM3
	DZM	INTM4
	LAC	(LAC   A4
	DAC	DPLM1	/SET UP FOR FIRST MULTIPLY
	LAC	(LAC   MOSTB	/OF FIRST LOOP
	DAC	DPLM2
	LAW	-4
	DAC	MOVCNT
DPLM1	XX		/SET UP MULTIPLIER
	DAC	.+4
DPLM2	XX		/SET UP MULTIPLICAND
	CLL
	MUL
	XX
	TAD	INTM4	/ADD TO WORD 4
	DAC	INTM4	/MQ PORTION IS LOST ANYWAY
	SZL!CLL		/PROPOGATE CARRY INTO WORD 3
	ISZ	INTM3
	ISZ	DPLM2	/INCREMENT TO NEXT MULTIPLICAND
	LAW	-1	/DECREMENT TO NEXT MULTIPLIER
	TAD	DPLM1
	DAC	DPLM1
	ISZ	MOVCNT	/TEST FOR END OF LOOP
	JMP	DPLM1	/REPEAT FWITH NEXT PAIR
	LAC	(LAC   A3	/SET UP FOR FIRST MULTIPLY
	DAC	DPLM3		/OF SECOND LOOP
	LAC	(LAC   MOSTB
	DAC	DPLM4
	LAW	-3
	DAC	MOVCNT
DPLM3	XX
	DAC	.+4	/MULTIPLY
DPLM4	XX
	CLL
	MUL
	XX
	TAD	INTM3	/ADD RESULT TO WORK AREA
	DAC	INTM3
	SZL!CLL
	ISZ	INTMB
	LACQ
	TAD	INTM4
	DAC	INTM4
	SZL!CLL
	ISZ	SIZE
	ISZ	DPLM4	/MODIFY ADDRESSES
	LAW	-1
	TAD	DPLM3
	DAC	DPLM3
	ISZ	MOVCNT	/TEST FOR END OF LOOP
	JMP	DPLM3
	LAC	(LAC   LEASTA	/SET UP FOR FIRST MUL.
	DAC	DPLM5		/OF THIRD LOOP
	LAC	(LAC   MOSTB
	DAC	DPLM6
	LAW	-2
	DAC	MOVCNT
DPLM5	XX
	DAC	.+4	/MULTIPLY
DPLM6	XX
	CLL
	MUL
	XX
	TAD	INTMB	/ADD RESULT TO WORK AREA
	DAC	INTMB
	SZL!CLL
	ISZ	INTMA
	LACQ
	TAD	INTM3
	DAC	INTM3
	SZL!CLL
	ISZ	BOXX
	ISZ	DPLM6	/MODIFY ADDRESSES
	LAW	-1
	TAD	DPLM5
	DAC	DPLM5
	ISZ	MOVCNT	/TEST FOR END OF LOOP
	JMP	DPLM5
	LAC	MOSTA	/DO LAST MUL.
	DAC	.+4
	LAC	MOSTB
	CLL
	MUL
	XX
	TAD	INTMA	/ADD TO WORK AREA
	DAC	INTMA
	LAC	INTM3
	TAD	SIZE	/ START ADDING IN CARRIES
	DAC	INTM3
	SZL!CLL
	ISZ	BOXX
	LACQ		/ GET INTMB FROM MQ
	TAD	INTMB
	SZL!CLL
	ISZ	INTMA
	TAD	BOXX
	DAC	INTMB
	SZL!CLL
	ISZ	INTMA
	LAC	EXPA	/COMPUTE EXPONENT
	ADD	EXPB
	SZL!CLL
	JMP	DPMEXP	/OVERFLOW OR UNDERFLOW?
	SAD	(777777
	CMA		/ GENERATE+0
	DAC	EXPA
	LAC	SIGNA	/SIGN OF RESULT
	XOR	SIGNB
	DAC	SIGNA
	LAC	INTMA	/IS IT NORMALIZED
	DAC	MOSTA
	SPA!RAL!CLL
	JMP	DPMMVR	/YES-MOVE TO ACCUM A
	DAC	MOSTA	/NORMALIZE BY ROTATING
	LAC	INTM4	/AT MOST ONE LEADING ZERO
	CLL!RAL		/SHIFT ONE LEFT
	DAC	A4
	LAC	INTM3
	RAL
	DAC	A3
	LAC	INTMB
	RAL
	DAC	LEASTA
	SZL!CLL
	ISZ	MOSTA	/ CARRY TO MOSTA
	LAW	-2	/ -1 IN 1'S COMP
	ADD	EXPA	/ ADJUST EXP
	SZL!CLL
	JMP	DPMXUN	/EXPONENT UNDERFLOW
	SAD	(777777
	CMA
	DAC	EXPA
	JMP*	DPRMUL	/RETURN
DPMMVR	LAC	INTMB	/MOVE RESULT TO ACCUM A
	DAC	LEASTA
	LAC	INTM3
	DAC	A3	/MOVE RESULT TO ACCUM A
	LAC	INTM4
	DAC	A4
	JMP*	DPRMUL	/RETURN
/ROUTINE TO DETERMINE WHETHER UNDER OR OVERFLOW OCCURRED
/
/
	/AND DO SOMETHING ABOUT IT
DPMEXP	LAC	EXPA
	SPA!CLA
	JMP	DPMXUN	/UNDERFLOW
	JMS*	.ERROR	/ERROR 0: EXPONENT OVERFLOW
	JMS	INFIN	/AET A TO INFINITY
	JMP*	DPRMUL	/RETURN
DPMXUN	LAW	1	/UNDERFLOW
	JMS*	.ERROR
DPMZER	JMS	ZERVAL	/SET A TO ZERO
	JMP*	DPRMUL
/INFINITY ROUTINE
INFIN	XX
	CLA!CMA!CLL
	DAC	MOSTA
	DAC	LEASTA
	DAC	A3
	DAC	A4
	RAR		/ = LAC   (377777
	DAC	EXPA
	JMP*	INFIN
/ZERO ROUTINE
ZERVAL	XX
	DZM	MOSTA
	DZM	LEASTA
	DZM	A3
	DZM	A4
	LAC	(400000
	DAC	EXPA
	DZM	SIGNA
	JMP*	ZERVAL
/
/ ZERO IA
ZEROIA	XX
	DZM	MOSTIA
	DZM	LESTIA
	DZM	AI3
	DZM	AI4
	LAC	(400000
	DAC	EXPIA
	DZM	SIGNIA
	JMP*	ZEROIA
/
/ ZERO IB
ZEROIB	XX
	DZM	MOSTIB
	DZM	LESTIB
	DZM	BI3
	DZM	BI4
	LAC	(400000
	DAC	EXPIB
	DZM	SIGNIB
	JMP*	ZEROIB
/
	.EJECT
/
/
/****************************************************************
/
/ STORE ROUTINES.
/  NOTE:  1) ANY MIXED ARITHMETIC IS ALLOWED. WARNINGS ARE ISSUED
/            IF COMPLEX IS STORED INTO INTEGER OR REAL.
/         2) LOGICAL MAY ONLY BE STORED IN LOGICAL
/         3) CHARACTER MAY BE STORED IN ANYTHING.
 /        5) INTO CHARACTER MAY ONLY BE STORED CHARACTER
/         6) TEMPORARY ACC'S ARE DESTINATIONS ONLY.
/
/****************************************************************
/
/
.STORE	XX
STOAGN	LAC*	BOX	/CHECK DESTINATION MODE
	SPA!RAL
	JMP	STOCLC	/COMPLEX,LOGICAL,TEMPORARY, OR CHARACTER
	SPA!RTL		/ PRECISION BIT IN LINK NOW
	JMP	STORL	/ DESTINATION IS REAL
/
/ DESTINATION IS INTEGER
STOINT	LAC	MODEA
	SZA
	JMP	STONIN	/ ACC A NOT INTEGER
/ DESTINATION INTEGER, ACC A INTEGER. (DESTINATION TEMP, ACC A INTEGER
/ COMES HERE ALSO).
/ STORE SINGLE AND DOUBLE INTEGER AND CHECK FOR OVERFLOW
/ ON SINGLE INTEGER
STOTIN	LAC	INT1
	SZL
	JMP	DTSTOR	/ GO STORE DOUBLE
/ HAVE A SINGLE INTEGER DESTINATION
	SPA
	JMP	NEGINT	/ ACCUMULATOR IS NEG
/ ACCUMULATOR IS POSITIVE
POSINT	SZA
	JMP	POSOVF
	LAC	INT2
	SPA
	JMP	POSOVF
STSIN	DAC*	AUTO2	/ SINGLE INTEGER IS IN RANGE, STORE IT
	JMP*	.STORE
/
/ ACCUMULATOR IS NEGATIVE
NEGINT	ISZ	INT1
	JMP	NEGOVF	/ INT1 NOT 777777
	LAC	INT2
	SPA
	JMP	STSIN
/
/ NEGATIVE INTEGER TOO LARGE
NEGOVF	LAC	(400000
	SKP
/ POSITIVE INTEGER TOO LARGE
POSOVF	LAC	(377777
	DAC*	AUTO2
	LAW	2
	JMS*	.ERROR
	JMP*	.STORE
/
/ HAVE A DOUBLE INTEGER DESTINATION, STORE IT.
DTSTOR	DAC*	AUTO2
	LAC	INT2
	DAC*	AUTO2
	JMP*	.STORE
/ DESTINATION INTEGER, ACC A NOT INTEGER
STONIN	SMA!RAL
	JMP	STORIN	/ ACC A REAL
	SPA!RAL
	JMP	STALCH	/ ACC A IS LOGICAL OR CHARACTER
	LAW	10
	JMS*	.ERROR	/ COMPLEX INTO INTEGER, ISSUE WARNING
/ DESTINATION INTEGER, ACC A REAL OR COMPLEX
STORIN	LAC	MODEA
	JMS	ROUND
	DZM	MODEA
	JMS	.FIX	/ MAKE ACC A INTEGER
	JMP	STOAGN	/ GO GET PRECISION BIT IN LINK AGAIN
/
/
/ DESTINATION REAL
STORL	LAC	MODEA	/DESTINATION IS REAL, WHAT IS ACC A
	SNA
	JMS	.FLOTA	/FLOAT IF INTEGER
	SPA!RTL
	JMP	STOLCC	/ACC A IS COMPLEX,LOGICAL OR CHARACTER
/ DESTINATION IS REAL, ACC A IS REAL
STOMTA	LAC*	BOX
	JMS	ROUND
	JMS	STORE1	/STORE SINGLE OR DOUBLE PRECISION
	JMP*	.STORE
/ DESTINATION IS REAL, ACC A IS COMPLEX, LOGICAL, OR CHARACTER
STOLCC	SZL
	JMP	STALCH	/ ACC A IS LOGICAL OR CHARACTER
/ DESTINATION IS REAL, ACC A IS COMPLEX
	LAW	10
	JMS*	.ERROR
	JMP	STOMTA	/ GO STORE REAL PART
/
/
/
/ DESTINATION IS COMPLEX, LOGICAL, TEMPORARY, OR CHARACTER
/
STOCLC	SMA!RAL
	JMP	STOCPX	/ COMPLEX
	SMA
	JMP	STOLOG	/ LOGICAL
/ DESTINATION TEMPORARY, OR CHARACTER IF ACC A IS CHARACTER THEN 
/ SO IS THE DESTINATION.
	LAC	MODEA
	SAD	(700000
	JMP	STOCK2	/ DESTINATION CHARACTER, ACC A CHARACTER
/
/
/
/ DESTINATION IS TEMPORARY
	DAC*	AUTO2	/STORE MODE WORD
	SPA!RAL
	JMP	STOTCL	/ ACC A IS COMPLEX, OR LOGICAL
	SMA!RTL		/ PRECISION BIT TO LINK
	JMP	STOTIN	/ ACC A  IS INTEGER
/ DESTINATION TEMPORARY, ACC A REAL, OR COMPLEX
STOTCX	LAC	SIGNA
	DAC*	AUTO2
	LAC	EXPA
	DAC*	AUTO2
	LAC	MOSTA
	DAC*	AUTO2
	LAC	LEASTA
	DAC*	AUTO2
	SNL		/TEST PRECISION BIT
	JMP	TESTC	/SINGLE
	LAC	A3	/DOUBLE
	DAC*	AUTO2
	LAC	A4
	DAC*	AUTO2
TESTC	LAC	MODEA	/CHECK FOR COMPLEX
	SMA
	JMP*	.STORE	/NON-COMPLEX, EXIT
	LAC	SIGNIA	/STORE COMPLEX PART
	DAC*	AUTO2
	LAC	EXPIA
	DAC*	AUTO2
	LAC	MOSTIA
	DAC*	AUTO2
	LAC	LESTIA
	DAC*	AUTO2
	SNL		/TEST PRECISION BIT
	JMP*	.STORE	/SINGLE, EXIT
	LAC	AI3	/DOUBLE, STORE REMAINDER
	DAC*	AUTO2
	LAC	AI4
	DAC*	AUTO2
	JMP*	.STORE
/
/ DESTINATION TEMPORARY, ACC A COMPLEX OR LOGICAL
STOTCL	SMA!RTL		/ PRECISION BIT TO LINK
	JMP	STOTCX	/COMPLEX
	JMP	ERR11	/ LOGICAL INTO THESE TEMPORARYS IS ILLEGAL
/
/
/
/ DESTINATION COMPLEX
STOCPX	LAC	MODEA
	SNA
	JMS	.FLOTA	/ FLOAT IF INTEGER
	SPA!RTL
	JMP	STCLCC	/ ACC A IS COMPLEX, LOGICAL, OR CHARACTER
/ DESTINATION IS COMPLEX, ACC A IS REAL
	LAC*	BOX
	JMS	ROUND
	JMS	STORE1
	LAC	(777400	/ SET IMAGINARY PART TO ZERO SNEAKY LIKE
	DAC	EXPA
	DZM	SIGNA
	JMS	STORE1
	JMP*	.STORE
/ DESTINATION COMPLEX, ACC A IS COMPLEX, LOGICAL, OR CHARACTER
STCLCC	SZL
	JMP	STALCH	/ ACC A IS LOGICAL OR CHARACTER
/DESTINATION IS COMPLEX, ACC A IS COMPLEX
	LAC*	BOX
	JMS	ROUND
	JMS	STORE1
	JMS	SWAPIT	/ AI TO A
	JMP	STOMTA	/ GO STORE IMAGINARY PART
/
/
/
/ DESTINATION IS LOGICAL
STOLOG	LAC	MODEA
	SAD	(600000
	SKP
	JMP	STLCHK	/ ACC A IS NOT LOGICAL
/ DESTINATION IS LOGICAL, ACC A IS LOGICAL
	LAC	LOGACC
	DAC*	AUTO2
	JMP*	.STORE
/ DESTINATION IS LOGICAL, ACC A IS ARITHMETIC OR CHARACTER
STLCHK	SAD	(700000
	JMP	STACH	/ ACC A IS CHARACTER
	JMP	ERR11	/ ERROR - NON LOGICAL OR CHAR INTO LOGICAL
/
/
/
/ DESTINATION IS ARITHMETIC, ACC A IS LOGICAL OR CHARACTER
STALCH	SPA
	JMP	STACH	/ ACC A IS CHARACTER
ERR11	LAW	11	/ ERROR - ILLEGAL STORE
	JMP*	.NERR
/
/
/
/ DESTINATION IS ANYTHING, ACC A IS CHARACTER
STACH	LAC*	BOX
	JMS	.CHRGT
	DAC	SIGNB
	JMP	STOCK3
/
/ GET NUMBER OF CHARACTERS IN VARIABLE ELEMENT
.CHRGT	XX
	CLL
	SPA!RTL
	JMP	CHRG2	/COMPLEX OR LOGICAL
	XOR	(12
CHRG3	SMA
	LRS	1	/I*2,R*4,C*4
	SNL
	RAR		/I*2,I*4,C*4,C*8
	AND	(77
	JMP*	.CHRGT
CHRG2	SZL
	LAW	53	/ LOGICAL
	XOR	(51	/COMPLEX
	JMP	CHRG3
/
/
/ DESTINATION CHARACTER, ACC A IS ALSO CHARACTER
/
STOCK2	LAC*	AUTO2
	CLL!RAL
	RTL
	JMS	GETCNT	/ GET SIZE OF DESTINATION IN SIGNB
/
/ MOVE (SIGNB) CHARACTERS TO (AUTO2)
/ FROM (SIGNA) CHARACTERS AT (AUTO1)
/
STOCK3	LAC	SIGNB	/CALCULATE NUMBER OF WORDS TO BE MOVED
	TAD	(2
	JMS	WORDS
	DAC	COUNT2	/-WORDS-1
/
	LAC	SIGNA	/GET SMALLER OF (SIGNA) AND (SIGNB)
	CMA
	TAD	SIGNB
	SPA!CMA
	CLA
	TAD	SIGNB
	JMS	MOVCHR
	JMP*	.STORE
/
/ SUBROUTINE TO MOVE CHARACTERS
MOVCHR	XX
	JMS	WORDS	/SPLIT WORD COUNT INTO THOSE BEFORE
	DAC	COUNT
	LACQ
	TAD	COUNT2	/AND THOSE AFTER
	DAC	COUNT2
	JMP	LOOP2	/SPACE INSERTIONS
/
WORDS	XX
	CLL!RAL		/MULTIPLY BY 2
	IDIV
		5
	RTL		/MULTIPLY REMAINDER BY 4
	TAD	(JMP	EVEN	/SET SPACE INSERTIONS ENTRY POINT
	DAC	LOOP3	/BASED ON REMAINDER
	LACQ
	CMA
	JMP*	WORDS
/
LOOP4	DAC*	AUTO2	/MOVE CONTIGUOUS BLOCK OF CHARACTERS
LOOP2	LAC*	AUTO3
	ISZ	COUNT
	JMP	LOOP4
LOOP3	XX
/
/ WARNING: THE LABELS EVEN,X3,XX1,X4,XX2 MUST OCCUR IN THAT ORDER
/ WITH A SPACING OF FOUR WORDS BECAUSE THEY ARE ENTERED BY A
/ CALCULATED JMP.
/
B1	XOR	SPAC	/ROUTINE TO PAD BALANCE OF
	DAC*	AUTO2	/VARIABLE WITH 5/7 ASCII SPACES
	ISZ	COUNT2
	SKP!CLA
	JMP*	MOVCHR
B2	XOR	SPAC+1
	DAC*	AUTO2
EVEN	ISZ	COUNT2
	SKP!CLA
	JMP*	MOVCHR
	JMP	B1
X3	XOR	SPAC+1	/KEEP LAST HALF OF THIRD CHARACTER
	AND	(700000	/AND FILL THE REST WITH SPACES
	ISZ	COUNT2
	JMP	B2
XX1	XOR	SPAC	/KEEP ONE CHARACTER AND FILL
	AND	(774000	/THE REST WITH SPACES
	ISZ	COUNT2
	JMP	B1
X4	XOR	SPAC+1	/KEEP FOURTH CHARACTER AND FILL THE REST
	AND	(777400	/WITH SPACES
	ISZ	COUNT2
	JMP	B2
XX2	XOR	SPAC	/KEEP SECOND CHARACTER AND FILL
	AND	(777760	/THE REST WITH SPACES
	ISZ	COUNT2
	JMP	B1
/
SPAC	.ASCII	'     '	/5 SPACES FOR PADDING
COUNT;COUNT2
/
/
/  SUBROUTINE TO STORE SINGLE OR
/ DOUBLE FLOATING POINT NUMBER
/
STORE1	XX
	LAC	SIGNA
	CLL!RAL		/PUT SIGN INTO LINK
	LAC	MOSTA
	SNA		/ IF ACC A IS ZERO
	CLL		/ MAKE SURE IT IS STORED AS +0.0
	RAL		/CHOP MOST SIG BIT;SIGN INTO AC 17
	DAC*	AUTO2	/STORE FIRST WORD
	LACQ		/GET PRECISION INDICATOR FROM ROUND
	SZA
	JMP	SDOUBL
	LAC	EXPA
	GSM
	RAL
	XOR	LEASTA
RET	DAC*	AUTO2	/STORE LAST WORD
	JMP*	STORE1
SDOUBL	LAC	LEASTA
	DAC*	AUTO2
	LAC	A3
	DAC*	AUTO2
	LAC	EXPA
	GSM
	RAL
	XOR	A4
	JMP	RET
/
/ ROUNDING ROUTINE TO ROUND ACC A TO PRECISION DEMANDED BY LINK
/ DOUBLE IF 1 , SINGLE IF 0
/
ROUND	XX
	AND	(100000	/GET PRECISION OF DESTINATION
	LMQ		/SAVE IT FOR STORE1
	SZA!CLL
	JMP	R2	/ROUND DOUBLE
/
	LAC	(400
	TAD	LEASTA
	AND	(777000	/PERFORM ROUND OFF
	DAC	LEASTA
	SZL!CLA!RAR
	JMP	R3	/CARRY OCCURRED
/
R5	LAC	EXPA
R7	GSM		/CHECK THAT ABS (EXPA) < 377
	TAD	(-377
	SPA
	JMP*	ROUND
/
	SZL!CLA		/ZERO AC
	JMP	R9	/OVERFLOW
	SAD	MOSTA	/CHECK IF MOSTA =0
	JMP	R8	/ZERO RESULT
	LAW	4	/ISSUE STORAGE EXPONENT UNDERFLOW
	JMS*	.ERROR
R8	LAC	(777400	/ONLY EXPONENT MATTERS
R10	DAC	EXPA	/ON UNDER AND OVERFLOW
	JMP*	ROUND
/
R2	AND	MODEA	/CHECK IF WE ARE TRYING DOUBLE
	SNA		/PRECISION ROUND ON R*4 DATA
	JMP	R6
/
	LAC	(400
	TAD	A4
	AND	(777000
	DAC	A4
	SNL!CLA!RAR	/400000 TO AC
	JMP	R5	/NO CARRY
	ISZ	A3
	JMP	R5
	ISZ	LEASTA
	JMP	R5
R3	ISZ	MOSTA
	JMP	R5
	DAC	MOSTA	/RESET TO 400000
/
	RTL
	ADD	EXPA	/ADD 1 TO EXPONENT
	DAC	EXPA
	SNL		/TEST FOR OVERFLOW
	JMP	R7	/GO CHECK EXPONENT RANGE
/
R9	LAW	3
	JMS*	.ERROR	/OVERFLOW ERROR=0
	LAC	(377	/SET EXPONENT TO MAXIMUM
	JMP	R10
/
R6	DZM	A3	/EXTEND R*4 TO R*8
	DZM	A4
	JMP	R5
/
/ AI TO A
/
SWAPIT	XX
	LAC	EXPIA
	DAC	EXPA
	LAC	SIGNIA
	DAC	SIGNA
	LAC	MOSTIA
	DAC	MOSTA
	LAC	LESTIA
	DAC	LEASTA
	LAC	AI3
	DAC	A3
	LAC	AI4
	DAC	A4
	JMP*	SWAPIT
/
/  CONVERT FLOATING POINT TO DOUBLE INTEGER
/  SHIFT MOSTA+LEASTA BY THE AMOUNT SPECIFIED IN THE
/  EXPONENT
/
.FIX	XX
	LAC	EXPA
	SPA!SNA		/BOTH MUST BE SATISFIED
	JMP	FIX1	/NEGATIVE EXPONENT OR ZERO EXP
	TAD	(-44
	SMA
	JMP	FIX2	/GREATER THAN 2**44
	SNA
	JMP	FIX3	/EQUAL TO 2**44
	CMA
	TAD	(1
	TAD	(LRS	/LRS +N=44
	DAC	FIXIT	/EQUIVIVALENT TO MOVING
	CLL		/DECIMAL POINT TO RIGHT
	LAC	LEASTA	/N PLACES
	LMQ
	LAC	MOSTA
FIXIT	XX
	DAC	INT1
	LACQ
	DAC	INT2
	LAC	SIGNA
	SPA
	JMS	INTACP
	JMP*	.FIX	/POSITIVE NUMBER EXIT
FIX1	DZM	INT1
	DZM	INT2
	JMP*	.FIX
FIX2	LAC	SIGNA	/ GENERATE +- LARGEST INTEGER
	JMS	LARGEI
	LAW	2	/ISSUE INTEGER OVERFLOW
	JMS*	.ERROR
	JMP*	.FIX
FIX3	LAC	(NOP
	DAC	FIXIT
	JMP	FIXIT-3
/
/
LARGEI	XX		/ INTEGER OVERFLOW SIGN IN AC
	SMA
	LAC	(377777
	DAC	INT1
	SMA!CLA
	CMA
	DAC	INT2
	JMP*	LARGEI
/
/
/  STORE NEGATIVE ROUTINE  COMPLEMENT NUMBER
/  AND CALL STORE
/
.STORN	LAC	MODEA
	SAD	(600000
	JMP	STORN2	/ ITS LOGICAL
	JMS	.CMPIT	/ COMPLIMENT THE NUMBER
.STORP	JMS	.STORE
	JMP	.NEXT
STORN2	LAC	LOGACC
	CMA
	DAC	LOGACC
	JMP	.STORP	/ GO DO A STORE NOW
	.EJECT
/
/ THE FOLLOWING ROUTINES PERFORM THE GT,GTN,LT,LTN,EQ, AND EQN
/ OPERATIONS BETWEEN ALL INTEGER(*2 AND *4) AND REAL(*4 AND *8)
/ VARIABLES. THE APPROACH IS TO CONVERT THE XCT USED TO ENTER
/ THIS ROUTINE INTO A CALL TO THE APPROPRIATE ADD OR SUBTRACT
/ AND THEN ANALYSE THE RESULTS.
/
GREAT	TAD	(SUBR-GTN	/SUB_GT,ADD_GTN
	JMS	SPLITR
	NOP		/LEAVE AC FOR + OR -
	CLA		/SET AC=0 FOR 0.0
/
LESS	TAD	(SUBR-LTN	/SUB_LT,ADD_LTN
	JMS	SPLITR
	CMA		/COMPLEMENT AC FOR + OR -
	CLA		/SET AC=0 FOR 0.0
/
EQUAL	TAD	(SUBR-EQN	/SUB_EQ,ADD_EQN
	JMS	SPLITR
	CLA		/SET AC=0 FOR + OR -1
	CLA!CMA		/SET AC=-1 FOR 0.0
/
/
SPLITR	XX
	DAC	SPLTOP
	LAC	MODEA
	SAD	(700000
	JMP	CHRS	/ EXIT FOR CHARACTER
SPLTOP	XX		/DO ADD/SUBTRACT
	LAC	MODEA
	SPA!RAL
	JMP	ERR17	/INVALID RESULT,COMPLEX
	SMA
	JMP	SPLIT1	/INTEGER RESULT
	LAC	MOSTA
	SMA
	JMP	SPLIT4	/0.0 RESULT
	LAC	SIGNA
	SPA!CLA!CMA	/SET AC=-1 FOR +
SPLIT2	CLA		/SET AC=0 FOR -
SPLIT3	XCT*	SPLITR	/ADJUST IT
	DAC	LOGACC	/STORE LOGICAL RESULT
	LAC	(600000
	DAC	MODEA	/SET MODE
	JMP	.NEXT
/
SPLIT1	LAC	INT1
	SPA
	JMP	SPLIT2	/NEGATIVE VALUE
	SZA!CLA!CMA
	JMP	SPLIT3	/POSITIVE VALUE
	LAC	INT2
	SNA!CLA!CMA	/SKIP IF POSITIVE
SPLIT4	ISZ	SPLITR	/ZERO RESULT
	JMP	SPLIT3
/
ERR17	LAW	17	/COMPLEX VARIABLE WITH RELATIONAL OPERATOR
	JMP*	.NERR
/
/ THE CHARACTER COMPARE ROUTINES FOLLOW
CHRS	LAC*	BOX
	SPA
	JMP	CJOIN1	/ MUST BE CHAR. COMPLEX & LOGIC ILLEGAL
	.AND	(077777
	DAC*	(AUTO4
	.LACI	BOX
	AND	(700000
	JMS	.CHRGT
	DAC	SIGNB
CJOIN2	LAC*	(AUTO3
	DAC*	(AUTO5
CJOIN3	LAW	-5
	TAD	SIGNA
	SPA
	JMP	A.LT.5
	DAC	SIGNA
AAA	LAW	-5
	TAD	SIGNB
	SPA
	JMP	B.LT.5
	DAC	SIGNB
BBB	STL!CLA!CMA
	TAD*	AUTO5
	CMA!CML
	TAD*	AUTO4
	SZA!CMA!CML
	JMP	CJOIN4
	TAD*	AUTO5
	CMA!CML
	TAD*	AUTO4
	SNA!CML
	JMP	CJOIN3
CJOIN4	SZL!CLA!CMA
	JMP	SPLIT2
	JMP	SPLIT3
/
CJOIN1	LAC*	(AUTO2
	DAC*	(AUTO4
	JMP	CJOIN2
/
A.LT.5	TAD	SIGNB
	SAD	(-5
	JMP	SPLIT4	/ EQUAL
	LAC*	(AUTO5
	DAC*	(AUTO3
	LAC	(MOSTA-1
	DAC*	(AUTO5
	DAC*	(AUTO2
	LAW	-3
	DAC	COUNT2
	LAC	SIGNA
	DZM	SIGNA
	JMS	MOVCHR
	JMP	AAA
/
B.LT.5	LAC*	(AUTO4
	DAC*	(AUTO3
	LAC	(MOSTB-1
	DAC*	(AUTO4
	DAC*	(AUTO2
	LAW	-3
	DAC	COUNT2
	LAC	SIGNB
	DZM	SIGNB
	JMS	MOVCHR
	JMP	BBB
	.EJECT
/
/
/
/SINGLE PRECISION INTEGER DIVIDE
INTDIV	LAC	MODEA	/GET MODE
	SZA
	JMP	MXD1	/MIXED MODE
	LAC*	AUTO2
	GSM		/FORM 2S COMPLEMENT IF NEGATIVE
	SZL
	TAD	(1
	DZM	INTMA	/EXPAND LEFT WITH ZEROS
	JMS	INTDVD	/PERFORM INTEGER DIVIDE
	JMP	.NEXT	/RETURN
MXD1	JMS	PICK1	/GET INTEGER
	JMS	.FLOTB	/FLOAT IT
	JMP	DIVRL	/PERFORM REAL DIVIDE
/ DOUBLE PRECISION INTEGER DIVIDE
DINTDV	LAC	MODEA	/GET MODE
	SZA
	JMP	MIXD2	/MIXED MODE
	LAC*	AUTO2	/GET FIRST WORD
	GSM
	DAC	INTMA	/STORE IT
	LAC*	AUTO2	/GET NEXT WORD
	SNL		/ IF NEGATIVE, FORM 2S COMPLEMENT
	JMP	DDIV
	CMA!CLL
	TAD	(1
	SZL!CLL!CML	/PROPOGATE CARRY
	ISZ	INTMA
DDIV	JMS	INTDVD	/PERFORM INTEGER DIVIDE
	JMP	.NEXT	/RETURN
MIXD2	JMS	PICK2	/ GET DOUBLE INTEGER
	JMS	.FLOTB	/FLOAT IT
	SAD	(200000
	JMP	DIVRL	/SINGLE
	JMP	DIVBL	/PERFORM DOUBLE PRECISION DIVIDE
/DIVIDE ACCUMULATOR BY REAL NUMBER
DIVRL	LAC	MODEA	/GET MODE OF ACCUM
	SPA!RTL
	JMP	COMPDS	/COMPLEX
	SNL
	JMP	INTGD1	/INTEGER
	SPA
	JMP	DOUBD1	/DOUBLE
DIVS	JMS	SPRDIV	/DO REAL DIVIDE
	JMP	.NEXT	/RETURN
INTGD1	JMS	.FLOTA	/FLOAT IT
	SAD	(200000
	JMP	DIVS	/SINGLE
DOUBD1	DZM	B3	/MAKE IT DOUBLE
	DZM	B4
	JMP	DIVBL2	/DO DOUBLE PRECISION DIVIDE
COMPDS	JMS	ZEROIB	/MAKE IT COMPLEX
	JMS	DIVCPX	/DO COMPLEX DIVIDE
	JMP	.NEXT
/
/DIVIDE ACCUMULATOR BY DOUBLE PRECISION NUMBER
/
DIVBL	LAC	MODEA	/CHECK MODE OF ACCUM
	SPA!RTL
	JMP	COMPDD	/COMPLEX
	SNL
	JMP	INTGD2	/INTEGER
	SMA
	JMP	REALD2	/REAL
DIVBL2	JMS	DPRDIV	/DOUBLE PRECISION DIVIDE
	JMP	.NEXT	/RETURN
INTGD2	JMS	.FLOTA	/INTEGER - MAKE REAL
	SAD	(300000
	JMP	DIVBL2	/DOUBLE
REALD2	DZM	A3	/MAKE DOUBLE
	DZM	A4
	JMP	DIVBL2	/GO TO DOUBLE DIVIDE
COMPDD	JMS	ZEROIB	/MAKE ACC B COMPLEX
	JMS	DIVDCP	/GO TO COMPLEX DIVIDE
	JMP	.NEXT
/
/DIVDE ACCUMULATOR BY SINGLE PRECISION COMPLEX NUMBER
/
DIVCPX	XX
	LAC	DIVCPX
	DAC	DIVDCP	/SET UP RETURN
	LAC	MODEA	/GET ACCUM MODE
	SMA!RTL
	JMS	MKCPX	/MAKE COMPLEX
	SMA
	JMP	SETSGL	/SET UP FOR SINGLE PRECISION
	DZM	BI3	/MAKE DOUBLE
	DZM	BI4
	DZM	B3
	DZM	B4
	JMP	SETDBL	/SET UP FOR DOUBLE PRECISION
/
/DIVIDE ACCUMULATOR BY DOUBLE PRECISION COMPLEX
/
DIVDCP	XX
	LAC	MODEA	/GET MODE
	SMA!RTL
	JMS	MKCPX	/MAKE COMPLEX
	SPA
	JMP	SETDBL
	DZM	A3	/MAKE A DOUBLE
	DZM	A4
SETDBL	LAC	(JMS	DPARST	/SET UP FOR DOUBLE PRECISION
	DAC	CD1
	LAC	(JMS	DPRMUL
	DAC	CD2
	LAC	(JMS	LDDBL
	DAC	CD3
	LAC	(JMS	DPARLD
	DAC	CD4
	LAC	(JMS	DPRADD
	DAC	CD5
	LAC	(JMS	DPRDIV
	JMP	CDXTIE
SETSGL	LAC	(JMS	SPARST	/SET UP FOR SINGLE PRECISION
	DAC	CD1
	LAC	(JMS	SPRMUL
	DAC	CD2
	LAC	(JMS	LDREAL
	DAC	CD3
	LAC	(JMS	SPARLD
	DAC	CD4
	LAC	(JMS	SPRADD
	DAC	CD5
	LAC	(JMS	SPRDIV
CDXTIE	DAC	CD6
	LAC	(SIGNH
CD1	XX		/STORE A
CD2	XX		/GET A*B
	LAC	(SIGNS
	XCT	CD1	/SAVE A*B
	JMS	SWAPIT	/AI TO A
	XCT	CD2	/GET B*AI
	LAC	(SIGND
	XCT	CD1	/SAVE B*AI
CD3	XX		/B TO ACC A
	XCT	CD2	/GET B*B
	LAC	(SIGNE
	XCT	CD1	/SAVE B*B
	JMS	SWAPIB	/BI TO B
	JMS	.SPBIA	/BI TO A
	XCT	CD2	/GET BI*BI
	LAC	(SIGNE
CD4	XX		/B*B TO ACC B
CD5	XX		/ADD
	LAC	(SIGNE
	XCT	CD1	/SAVE B*B + BI*BI
	JMS	.SPBIA	/BI TO ACC A
	LAC	(SIGNH
	XCT	CD4	/A TO ACC B
	XCT	CD2	/GET A*BI
	LAC	SIGNA
	XOR	(400000
	DAC	SIGNA	/COMPLEMENT ACC A
	LAC	(SIGND
	XCT	CD4	/B*AI TO ACC B
	XCT	CD5	/GET -A*BI + B*AI
	LAC	(SIGNE
	XCT	CD4	/B*B + BI*BI TO ACC B
CD6	XX		/DIVIDE
	JMS	SWAPA	/BI TO B,A TO BI,AI TO A
	XCT	CD2	/GET AI*BI
	LAC	(SIGNS
	XCT	CD4	/A*B TO ACC B
	XCT	CD5	/ADD
	LAC	(SIGNE
	XCT	CD4	/B*B + BI*BI TO ACC B
	XCT	CD6	/DIVIDE
	LAC	MODEA
	XOR	(600000
	DAC	MODEA	/RESTORE COMPLEX MODE
	JMS	MVIMA	/BI TO AI
	JMP*	DIVDCP
/
MKCPX	XX		/MAKE ACC A COMPLEX AND
	SNL
	JMS	.FLOTA	/FLOAT IF INTEGER
	JMS	ZEROIA	/ GET MODE OF A INTO ACCUMULATOR
	LAC	MODEA	/ FOR NEXT TEST
	RTL
	JMP*	MKCPX
/
/ SETUP FOR A REVERSE DIVIDE-  A_B/A
/ REVERSE DIVIDE SWITCHS ACC'S A & B AND BASED ON THE INITIAL
/ MODEA XCT'S THE APPROPRIATE DIVIDE THUS SIMULATING A NORMAL
/ DIVIDE ENTRY. SINCE THE LOAD ROUTINE DO NOT STORE MODEB MUST SET
/ IT UP.
/
RDINTD	LAC	(JMS	PICK2
	DAC	RDIV2
	LAC	(JMS  LDBINT	/ LOAD DOUBLE INT.
	JMP	RDIVER
RINTDI	LAC	(JMS	PICK1
	DAC	RDIV2
	LAC	(JMS  LDINT	/ LOAD SINGLE INT.
RDIVER	DAC	RDIV0
	LAC	MODEA
	SZA!CLL
	JMP	RDIV2	/ MIXED MODE
	LAC	INT1	/ ACC A TO B
	DAC	INTMA
	LAC	INT2
	DAC	INTMB
RDIV0	XX		/ LOAD ACC A
	LAC	INTMA	/ SIGN & MAG. OF INTDVD
	GSM
	DAC	INTMA
	LAC	INTMB
	SNL
	JMP	RDIV1
	CMA!CLL
	TAD	(1
	SZL!STL
	ISZ	INTMA
RDIV1	JMS	INTDVD
	JMP	.NEXT
RDIV2	XX
	JMS	.FLOTB
	JMP	RDIVMX
/
RDIVDC	LAC	(500000
	JMP	RDIVDE
RDIVCX	LAC	(400000
	JMP	RDIVDE
RDIVDB	LAC	(300000
	JMP	RDIVDE
RDIVRL	LAC	(200000
RDIVDE	DAC	MODEB	/ MODEB NOW ESTABLISHED
RDIVMX	LAC	MODEA
	SNA
	JMS	.FLOTA	/ MIXED MODE
	CLL
	RTL; RTL
	TAD	(XCT	DENTRY	/ GET ENTRY TO DIVIDE
	DAC	.+2
	JMS	REVRSG
	XX
	JMP	.NEXT	/IN CASE DIVIDE IS COMPLEX (JMS IN SUBR TABLE)
/
/DIVIDE ROUTINE FOR INTEGERS
INTDVD	XX
	DAC	INTMB	/STORE SECOND HALF DIVISOR
	CLA!RAR		/ GET SIGN AND STORE
	DAC	BOXX
	LAC	INT1	/GET FIRST WORD OF DIVIDEND
	SMA		/TEST SIGN ANDSET LINK=0 FOR POS
	JMP	DIPOS	/POSITIVE BYPASS COMPLEMENTING
	JMS	INTACP	/COMPLEMENT DIVIDEND
	LAC	(400000
	XOR	BOXX
	DAC	BOXX	/FINAL SIGN NOW OBTAINED
	LAC	INT1	/IS DIVIDEND DOUBLE
DIPOS	SZA
	JMP	IDVBL1	/YES
	LAC	INTMA	/ IS DIVISOR DOUBLE
	SZA
	JMP	IDVBL2	/ YES
	LAC	INTMB	/ IS DIVISOR ZERO
	SNA
	JMP	INTDZ	/ DIVIDE BY ZERO ERROR
	DAC	INTDDD	/ STORE FOR DIVIDE
	LAC	INT2	/ IS DIVIDEND ZERO
	SNA
	JMP*	INTDVD	/ LEAVE AS ZERO
	IDIV		/DIVIDE
INTDDD	XX
	LACQ		/GET RESULT INTO AC
	DAC	INT2	/PUT RESULT BACK
	DZM	INT1
INTDTS	LAC	BOXX	/SIGN THE RESULT
	SZA
	JMS	INTACP
	JMP*	INTDVD
INTDZ	LAW	5	/DIVIDING BY ZERO
	JMS*	.ERROR	/COMPLAIN
	LAC	BOXX
	JMS	LARGEI	/ GENERATE LARGE INTEGER
	JMP*	INTDVD
IDVBL1	LAC	INTMB
	DAC	.+4	/DIVIDE DOUBLE BY SINGLE
	DAC	.+13
	LAC	INT1	/GET FIRST WORD
	IDIV		/DIVIDE 18 BITS ,DIVIDE IN TWO STEPS
	XX		/AVOIDS ANY POSSIBLE OVERFLOW
	DAC	INTMA	/SAVE REMAINDER
	LACQ		/STORE FIRST WORD OF QUOTIENT
	DAC	INT1
	LAC	INT2	/GET SECOND WORD
	LMQ		/PUT INTO MQ AND
	LAC	INTMA	/GET REMAINDER INTO AC
	DIV		/DIVIDE 36 BITS
	XX
	LACQ		/STORE SECOND WORD OF QUOTIENT
	DAC	INT2
	JMP	INTDTS
/
IDVBL2	DAC	IDVSR1	/ INTMA=C STILL IN ACC
	DAC	IDVSR2	/ STORE FOR FUTURE DIVIDES
	DAC	IDVSR4
	CMA		/ WILL ANSWER BE 0
	TAD	(1
	TAD	INT1	/ IS C>A ?
	SMA!CLL
	JMP	.+4
	DZM	INT1	/ YES
	DZM	INT2
	JMP*	INTDVD	/ RETURN
	LAC	INTMB	/ SETUP FOR * , D
	DAC	IDVSR3
	LAC	INT1
	MUL		/ A*D
IDVSR3	XX
	DAC	INTMA
	LACQ
	DAC	INTMB
	LAC	INTMA	/ START  X/C FOR A*D/C
	IDIV		/ LINK=0
IDVSR1	XX
	DAC	IDVSR1	/ SAVE REMAINDER
	LACQ
	CMA!CLL		/ GENERATE -(A*D)/C
	DAC	INTMA
	LAC	INTMB
	LMQ
	LAC	IDVSR1	/ RESTORE REMAINDER
	DIV		/ FINISH DIVIDE BY C
IDVSR2	XX
	LACQ
	CMA!CLL		/ MAKE LEAST -(A*D)/C
	TAD	(1	/ GENERATE POSSIBLE CARRY
	SZL!CLL
	ISZ	INTMA	/ PROPAGATE CARRY
	NOP
	TAD	INT2	/ ADD  B GEN CARRY & DROP REST
	GLK
	TAD	INTMA	/ A+(B-(A*D)/C)
	TAD	INT1
	CLL
	IDIV
IDVSR4	XX		/ ANSWER IS ALWAYS < 2**18
	LACQ
	DAC	INT2
	DZM	INT1
	JMP	INTDTS
/
/
/ SINGLE PRECISION DIVIDE
/
SPRDIV	XX		/  T = 133 MICROSECONDS
	LAC	MOSTB	/SET UP DIVISOR
	SZA
	JMP	.+4
DIVSZ	LAW	5	/DIVIDE BY ZERO -ERROR
	JMS*	.ERROR
	JMP	DOVER	/ GENERATE INFINITY
	DAC	RDVDR1	/STORING C FOR FUTURE DIVIDES
	DAC	RDVDR2
	DAC	RDVDR3
	LAC	LEASTB
	DAC	RMPYR1	/  D
	LAC	MOSTA	/ MAKE NUMERATOR SMALLER THEN DEN
	SNA!CLL!RAR	/TO AVOID DIVIDE OVERFLOW
	JMP*	SPRDIV	/ ANSWER WILL BE ZERO-RETURN
	DAC	MOSTA
	LAC	LEASTA
	RAR
	DAC	LEASTA
	LAC	MOSTA	/A
	CLL
	MUL
RMPYR1	XX		/(A*D)
	DIV
RDVDR1	XX		/((A*D)/C)
	LACQ		/SMASH REMAINDER SINCE IT IS LOST
	CMA!CLL		/ ANY WAY
	TAD	(1	/GET -((A*D)/C)
	TAD	LEASTA	/ADD B
	LMQ		/STORE IN MQ FOR DIVIDE
	SZL!CLA!CMA!CLL	/ALL 0'S TO ALL 1'S ON TWO'S COMP
	CLA		/TO ALL 0'S IF CARRY FROM ADDITION
	TAD	MOSTA	/A+(B-((A*D)/C) ADD A
	CLL
	DIV
RDVDR2	XX		/DIVIDE A BY C
	DAC	RDVDR2	/STORE REMAINDER
	LACQ
	DAC	MOSTA
	LAC	RDVDR2
	FRDIV
RDVDR3	XX		/ANSWER IN AC & MQ AFTER NEXT INSTR.
	LAC	MOSTA	/(A+(B-((A*D)/C)))/C
	SMA!STL		/IF NO SHIFT-L_0,ASSUME L_1
	LLSS+1		/L_0 , SHIFT TO NORMALIZE
	DAC	MOSTA	/STORE RESULT
	LACQ
	DAC	LEASTA
	LAC	SIGNA	/DETERMINE RESULT SIGN
	XOR	SIGNB
	DAC	SIGNA
	GLK		/ NO SHIFT THEN INCR EXPA
	ADD	EXPA
	CMA		/ GET NEG.
	ADD	EXPB	/ = -(FINAL EXPA VALUE)
	SZL		/ ANY OVER OR UNDER FLOW
	JMP	DVOVUN	/ YES
	SNA!CMA		/ CORRECT EXPA SIGN ; -0?
	CLA		/ -0 TO +0
	DAC	EXPA
	JMP*	SPRDIV
DVOVUN	LAC	EXPB	/OVERFLOW OR UNDERFLOW
	SMA!CLA
	JMP	DVUN	/UNDERFLOW
	JMS*	.ERROR
DOVER	JMS	INFIN	/MAKE INFINITY
	JMP*	SPRDIV	/RETURN
DVUN	LAW	1	/UNDERFLOW -COMPLAIN
	JMS*	.ERROR
	JMS	ZERVAL	/MAKE ZERO
	JMP*	SPRDIV	/RETURN
/
/
/DOUBLE PRECISION DIVIDE IS OBTAINED BY CALCULATING
/ 1/B USING A SINGLE PRECISION DIVIDE AND IMPROVING BY ONE
/ ITERATION OF NEWTON RAPHASON ROUTINE AND THEN MULTIPLYING
/ BY A.
/
/ IF WE LET  F(XI) = B-1/XI
/
/ THEN IF F(XI)=0  THEN XI = 1/B
/
/  X(I+1)= X(I)*(2-B*X(I)
/
/ SINCE X(I+1) = X(I) -  F(X(I))/F'(X(I))
/
/  THE FINAL ANSWER IS   A*X(I+1)
/
/
/
DPRDIV	XX
	LAC	MOSTB	/ IS ANSWER INFINITY
	SZA
	JMP	DPRNZ
	LAC	DPRDIV	/ TRANSFER RETURN ADDRESS
	DAC	SPRDIV
	JMP	DIVSZ	/ CONNECT TO ERROR POINT
DPRNZ	LAC	MOSTA	/ WILL ANSWER BE ZERO
	SNA
	JMP*	DPRDIV
	LAC	(DPDSTA	/  STORE ACC A TEMP
	JMS	DPARST
	JMS	.LOAD1	/SET ACC A TO 1.0
	JMS	SPRDIV	/ GET SPRDIV XI = 1/B
	LAC	(SIGNH	/ STORE XI
	JMS	SPARST
	DZM	A3	/ MAKE XI DOUBLE
	DZM	A4
	JMS	DPRMUL	/ GET B*XI
	LAC	(400000	/ B*XI .GE. 0
	DAC	MOSTB
	DAC	SIGNA	 /GET -( B*XI)
	DZM	SIGNB	/ PUT 2 IN ACC B
	LAC	(2
	DAC	EXPB
	DZM	LEASTB	/ EXTEND TO DOUBLE PREC.
	DZM	B3
	DZM	B4
	JMS	DPRADD	/ GET (2-B*XI)
	LAC	(SIGNH	/ XI TO ACC B
	JMS	SPARLD
	JMS	DPRMUL	/ XI*(2-B*XI)
	LAC	(DPDSTA	/  LOAD ACC A FROM STORE TO ACC B
	JMS	DPARLD
	JMS	DPRMUL	/ ANS=A*(1/B)
	JMP*	DPRDIV
/
/
	.EJECT
/
/  WATRAN EXPONENTIATION PACKAGE
/
/
/
/ -(ACC A) ** SINGLE INTEGER
/
NINTXP	JMS	IRSEPX
	JMS	.CMPIT
/
/ ACC A ** SINGLE INTEGER
/
INTEXP	LAC*	AUTO2	/LOAD INTEGER INTO EXPONENT STORAGE
	DAC	LEASTN
	SPA!CLA
	CMA
	DAC	MOSTN
TOINT	JMS	ITEXP	/DO INTEGER EXPONENTIATION
	JMP	.NEXT
/
/ -(ACC A) ** DOUBLE INTEGER
/
NDNTXP	JMS	IRSEPX
	JMS	.CMPIT
/
/ ACC A ** DOUBLE INTEGER
/
DNTEXP	LAC*	AUTO2	/LOAD DOUBLE INTEGER INTO EXPONENT STORAGE
	DAC	MOSTN
	LAC*	AUTO2
	DAC	LEASTN
	JMP	TOINT	/INTEGER EXPONENTIATION
/
/ -(ACC A) ** SINGLE PRECISION REAL
/
NRELXP	JMS	COMPLA
	JMP	RELEXP
/
/ -(ACC A) ** -(SINGLE PRECISION REAL)
/
NRELXN	JMS	COMPLA
/
/ ACC A ** -(SINGLE PRECISION REAL)
/
RELXPN	JMS	COMPLB
/
/ ACC A ** SINGLE PRECISION REAL
/
RELEXP	JMS	MODCHK	/ENSURE ACC A IS REAL
	SAD	(300000	/AC CONTAINS MODEA
	STL		/SET LINK IF DOUBLE PRECISION
	LAC	(200000	/ SET UP MODE OF B AS REAL
	DAC	MODEB
	JMS	REVRSG	/ SWAP ACC'S
	SNL		/TEST LINK
	JMP	SPEXP	/ACC A IS SINGLE PRECISION,DO REAL**REAL
	JMP	DBLAD
/
/ -(ACC A) ** DOUBLE PRECISION REAL
/
NDBLXP	JMS	COMPLA
	JMP	DBLEXP
/
/ -(ACC A) ** -(DOUBLE PRECISION REAL)
/
NDBLXN	JMS	COMPLA
/
/ ACC A ** -(DOUBLE PRECISION REAL)
/
DBLXPN	JMS	COMPLB
/
/ ACC A ** DOUBLE PRECISION REAL
/
DBLEXP	JMS	MODCHK	/ENSURE ACC A IS REAL
	SAD	(300000	/AC CONTAINS MODEA
	STL		/SET LINK IF DOUBLE REAL
	LAC	(300000	/ SET UP MODE OF B AS DOUBLE REAL
	DAC	MODEB
	JMS	REVRSG	/SWAP ACC'S
	SNL		/TEST LINK
	JMP	DBLAR	/ACC A IS SINGLE REAL
	JMP	DPEXP	/DO DOUBLE ** DOUBLE
/
/ SINGLE INTEGER ** ACC A
/
RINTXP	JMS	IRSEPX
	SPA		/SKIP IF ACC A IS INTEGER
	JMP	RIXPRL
	JMS	LDEXPI	/LOAD ACC A INTEGER INTO EXPONENT STORAGE
	JMS	LDINT	/LOAD INTEGER INTO ACC A
	JMP	TOINT	/DO INTEGER EXPONENTIATION
RIXPRL	JMS	LDINT
	JMP	BRNEXP	/ACC A IS REAL; DO REAL**REAL OR DOUBLE ** DOUBLE
/
/ DOUBLE INTEGER ** ACC A
/
RDNTXP	JMS	IRSEPX
	SPA		/SKIP IF INTEGER
	JMP	RDXPRL
	JMS	LDEXPI	/LAOD ACC A INTEGER INTO EXPONENT STORAGE
	JMS	LDBINT	/LOAD DOUBLE INTEGER
	JMP	TOINT
RDXPRL	JMS	LDBINT
	JMP	BRNEXP	/ACC A REAL; DO REAL ** REAL OR DOUBLE ** DOUBLE
/
/ -(SINGLE PRECISION REAL) ** ACC A
/
RNRELX	JMS	COMPLB
	JMP	RRELXP
/
/ -(SINGLE PRECISION REAL) ** -(ACC A)
/
RNREXN	JMS	COMPLB
/
/ SINGLE PRECISION REAL ** -(ACC A)
/
RRELXN	JMS	.CMPIT
/
/ SINGLE PRECISION REAL ** ACC A
/
RRELXP	LAC	MODEA
	SZA
	JMP	RTOR
	JMS	LDEXPI	/INT ACC A TO EXPONENT
	JMS	LDREAL	/BASE TO ACC A
	JMP	TOINT
RTOR	JMS	MODCHK	/ENSURE ACC A IS REAL
	SAD	(200000	/AC CONTAINS MODEA
	JMP	SPEXP	/ACC A IS SP; DO REAL ** REAL
DBLAR	DZM	B3	/ACC A IS DOUBLE; SET ACC B TO DP
	DZM	B4
	JMP	DPEXP	/DO DOUBLE ** DOUBLE
/
/ -(DOUBLE PRECISION REAL) ** ACC A
/
RNDBLX	JMS	COMPLB
	JMP	RDBLXP
/
/ -(DOUBLE PRECISION REAL) ** -(ACC A)
/
RNDBXN	JMS	COMPLB
/
/ DOUBLE PRECISION REAL ** -(ACC A)
/
RDBLXN	JMS	.CMPIT
/
/ DOUBLE PRECISION ** ACC A
/
RDBLXP	LAC	MODEA
	SZA
	JMP	DTOR
	JMS	LDEXPI	/INT ACC A TO EXPONENT
	JMS	LDDBL	/BASE TO ACC A
	JMP	TOINT
DTOR	JMS	MODCHK	/ENSURE ACC A IS REAL
	SAD	(300000	/AC CONTAINS MODEA
	JMS	DPEXP	/DO DOUBLE ** DOUBLE
DBLAD	DZM	A3	/ACC A IS SINGLE; SET TO DOUBLE
	DZM	A4
	LAC	(300000
	DAC	MODEA
	JMP	DPEXP
/
/ -(ACC A) ** -(SINGLE INTEGER)
/
NINTXN	JMS	IRSEPX
	JMS	.CMPIT
/
/ ACC A ** -(SINGLE INTEGER)
/
INTXPN	LAW	-1	/LOAD INTEGER COMPLEMENT INTO EXPONENT STORAGE
	TAD*	AUTO2
	CMA
	DAC	LEASTN
	SPA!CLA
	CMA
	DAC	MOSTN
	JMP	TOINT	/DO INTEGER EXPONTIATION
/
/ -(ACC A) ** -(DOUBLE INTEGER)
/
NDNTXN	JMS	IRSEPX
	JMS	.CMPIT
/
/ ACC A ** -(DOUBLE INTEGER)
/
DNTXPN	LAC*	AUTO2	/LOAD INTEGER COMPLEMENT INTO EXPONENT STORAGE
	CMA
	DAC	MOSTN
	LAC*	AUTO2
	CMA!CLL
	TAD	(1
	DAC	LEASTN
	SZL
	ISZ	MOSTN
	JMP	TOINT	/DO INTEGER EXPONENTIATION
/
/  SINGLE INTEGER ** -(ACC A)
/
RINTXN	JMS	IRSEPX
	SPA		/SKIP ON INTEGER ACC A
	JMP	RIXNRL
	JMS	INTACP	/COMPLEMENT INTEGER ACC A
	JMS	LDEXPI	/LOAD EXPONENT STORAGE FROM INTEGER ACC
	JMS	LDINT	/LOAD INTEGER
	JMP	TOINT	/DO INTEGER EXPONENTIATION
RIXNRL	JMS	COMPLA	/ACC A REAL; COMPLEMENT IT
	JMS	LDINT	/LOAD INTEGER BASE
	JMP	BRNEXP	/DO APPROPRIATE REAL EXPONENTIATION
/
/  DOUBLE INTEGER ** -(ACC A)
/
RDNTXN	JMS	IRSEPX
	SPA		/SKIP ON INTEGER ACC A
	JMP	RDXNRL
	JMS	INTACP	/COMPLIMENT INTEGER ACC
	JMS	LDEXPI	/LOAD ACC INTO EXPONENT STORAGE
	JMS	LDBINT	/LOAD DOUBLE INTEGER INTO ACC
	JMP	TOINT	/DO INTEGER EXPONENTIATION
RDXNRL	JMS	COMPLA	/ACC A REAL; COMPLEMENT IT
	JMS	LDBINT	/LOAD DOUBLE INTEGER
	JMP	BRNEXP	/DO APPROPRIATE REAL EXPONENTIATION
/
/  -(SINGLE INTEGER) ** ACC A
/
RNINTX	JMS	IRSEPX
	SPA		/SKIP IF ACC A INTEGER
	JMP	RNIXRL
	JMS	LDEXPI	/LOAD EXPONENT FROM ACC A INTEGER
	JMS	LNINT	/LOAD NEGATIVE INTEGER
	JMP	TOINT	/DO INTEGER EXPONENTIATE
RNIXRL	JMS	LNINT	/LOAD NEGATIVE INTEGER
	JMP	BRNEXP	/DO APPROPRIATE REAL EXPONENTIATE
/
/  -(DOUBLE INTEGER) ** ACC A
/
RNDNTX	JMS	IRSEPX
	SPA		/SKIP IF INTEGER
	JMP	RNDXRL
	JMS	LDEXPI	/LOAD EXPONENT FROM INTEGER ACC A
	JMS	LNBINT	/LOAD NEGATIVE DOUBLE INTEGER
	JMP	TOINT
RNDXRL	JMS	LNBINT	/LOAD NEGATIVE DOUBLE INTEGER
	JMP	BRNEXP	/DO REAL EXPONENTIATE
/
/  -(SINGLE INTEGER) ** -(ACC A)
/
RNINXN	JMS	IRSEPX
	SPA		/SKIP IF ACC A INTEGER
	JMP	RNINRL
	JMS	INTACP	/COMPLEMENT INTEGER ACC A
	JMS	LDEXPI	/LOAD EXPONENT FROM INTEGER ACC A
	JMS	LNINT	/LOAD NEGATIVE SINGLE INTEGER
	JMP	TOINT	/INTEGER EXPONENTIATE
RNINRL	JMS	COMPLA
	JMS	LNINT	/LOAD NEGATIVE INTEGER
	JMP	BRNEXP	/REAL EXPONENTIATE
/
/  -(DOUBLE INTEGER) ** -(ACC A)
/
RNDNXN	JMS	IRSEPX
	SPA		/SKIP IF ACC A INTEGER
	JMP	RNDNRL
	JMS	INTACP	/COMPLEMENT INTEGER ACC A
	JMS	LDEXPI	/LOAD EXPONENT FROM INTEGER ACC A
	JMS	LNBINT	/LOAD NEGATIVE DOUBLE INTEGER
	JMP	TOINT	/INTEGER EXPONENTIATE
RNDNRL	JMS	COMPLA	/COMPLEMENT ACC A
	JMS	LNBINT	/LOAD NEGATIVE DOUBLE INTEGER
	JMP	BRNEXP	/REAL EXPONENTIATE
/
/ BRNEXP IS USED IN REVERSE EXPONENTIATE WHEN AN INTEGER
/ IS RAISED TO A REAL POWER. IT FLOATS THE INTEGER AND THEN
/ BRANCHES TO EITHER REAL ** REAL OR DOUBLE ** DOUBLE.
/
BRNEXP	JMS	.FLOTB	/FLOAT INTEGER ACC A INTO ACC B
	LAC	ADDR1	/RESTORE MODEA WHICH WAS DESTROYED
	DAC	MODEA	/WHEN THE INTEGER WAS LOADED.
	LAC	MODEB	/CHECK FOR SINGLE OR DOUBLE PRECISION ACC B
	RTL
	SPA		/SKIP ON SINGLE PRECISION
	JMP	RDBLXP
	JMP	RRELXP	/REVERSE REAL EXPONENTIATE
/
/
IRSEPX	XX
	LAC	MODEA
	DAC	ADDR1
	SPA!RAL
	JMP	EXPERR	/EXPONENT COMPLEX,LOGICAL,OR CHARACTER
	JMP*	IRSEPX
/
EXPERR	LAW	20	/ILLEGAL MODE MIXING
	JMP*	.NERR
/
/  COMPLEMENT INTEGER ACC A
/
INTACP	XX
	LAC	INT2
	CMA!CLL
	TAD	(1
	DAC	INT2
	LAC	INT1
	CMA!SZL
	TAD	(1
	DAC	INT1
	JMP*	INTACP
/
/  LOAD INTEGER ACC A INTO EXPONENT
/
LDEXPI	XX
	LAC	INT1
	DAC	MOSTN
	LAC	INT2
	DAC	LEASTN
	JMP*	LDEXPI
/
/  CHECK MODEA; FLOAT IF INTEGER, ISSUE ERROR IF COMPLEX,LOGICAL
/  OR CHARACTER. RETURN WITH MODEA IN AC UNLESS ERROR.
/  IF ERROR THE EXPONENTIATION IS NOT PERFORMED.
/
MODCHK	XX
	LAC	MODEA
	SPA!RCL
	JMP	EXPERR	/ACC A IS COMPLEX,LOGICAL, OR CHARACTER
	SMA!RAR
	JMS	.FLOTA
	JMP*	MODCHK
/
/ THIS ROUTINE COMPLEMENTS ACC A WHETHER IT'S REAL OR INTEGER
/
.CMPIT	XX
	LAC	MODEA
	SZA
	JMP	EXREAL	/ ITS REAL
	JMS	INTACP	/ COMPLIMENT INTEGER
	JMP*	.CMPIT
EXREAL	JMS	COMPLA	/ COMPLIMENT REAL
	JMP*	.CMPIT
/
/ ACC A ** INTEGER
/
ITEXP	XX
	LAC	MOSTN	/EXPONENT IN MOSTN,LEASTN
	SMA!CMA		/COMPLEMENT IF NEGATIVE
	JMP	EXPOS
	DAC	MOSTN
	LAC	LEASTN
	CMA!CLL
	TAD	(1
	SZL
	ISZ	MOSTN
	DAC	LEASTN
	CLC!SKP
EXPOS	CLA
	DAC	SIGNEN	/STORE EXPONENT SIGN
	LAC	MODEA	/CHECK MODE OF BASE
	SPA!RCL
	JMP	CCLI	/COMPLEX,LOGICAL OR CHARACTER
	SMA!RAL
	JMP	INTSET	/INTEGER
	SPA
	JMP	DBLSET	/DOUBLE PRECISION REAL
/
	LAC	(JMS	SPARST	/SINGLE PRECISION REAL SET UP.
	DAC	OP0
	LAC	(JMS	SPARLD
	DAC	OP1
	LAC	(JMS	SPRMUL
	DAC	OP2
	LAC	(JMS	SPRDIV
	DAC	OP3
	LAC	(JMS	.LODBS
EXPI	DAC	OP4
/
/ INTEGER EXPONENTIATION
/
	LAC	MOSTN
	SZA!STL
	JMP	MODGOT	/ EXPONENT IS NEITHER 0 NOR 1
	SAD	LEASTN
	JMP	EXPZRO	/ EXPONENT IS ZERO
	RAL		/ SET AC TO 1
	SAD	LEASTN
	JMP	EXPONE	/ EXPONENT IS ONE
/
MODGOT	LAC	LEASTN	/EXPONENT TO AC,MQ
	LMQ
	LAC	MOSTN
	NORMS		/NORMALIZE
	DAC	MOSTN
	LAW	17700
	OSC
	TAD	(2
	DAC	SESS	/SET UP SHIFT COUNTER
	LAC	MOSTN
	LLS	1	/STORE NEW EXPONENT
	DAC	MOSTN
	LACQ
	DAC	LEASTN
	LAC	(ADDR1
OP0	XX		/STORE ACC A
OP4	XX		/LOAD ACC B FROM ACC A
OP2	XX		/MULTIPLY TO FORM SQUARE OF ORIGINAL ACC A
	LAC	LEASTN	/EXPONENT TO AC,MQ
	LMQ
	LAC	MOSTN
	LLS	1
	DAC	MOSTN
	LACQ
	DAC	LEASTN
	LAC	MOSTN
	SMA
	JMP	XTAG	/IF NEXT BIT 0, INCREMENT COUNTER AND REPEAT
	LAC	(ADDR1	/IF 1, MULTIPLY BY ORIGINAL ACC A
OP1	XX
	XCT	OP2
XTAG	ISZ	SESS	/INCREMENT SHIFT COUNTER
	JMP	OP4	/ANSWER NOT YET COMPLETE
	LAC	MODEA
	SNA		/CHECK FOR INTEGER MODE
	JMP	INVINT
INVERT	LAC	SIGNEN	/IF EXPONENT WAS NEGATIVE,INVERT IT
	SNA
	JMP*	ITEXP
	LAC	MODEA
	SMA
	JMP	ANSRL	/REAL
	LAC	MOSTIA	/COMPLEX
	SZA!CLA
	JMP	LONE
ANSRL	LAC	MOSTA
	SNA!CLA
	JMP	EXWRN	/ERROR: 0.0**X WHERE X.LE.0
LONE	XCT	OP4	/ACC A TO ACC B
	JMS	.LOAD1	/1.0 TO ACC A
	JMS	ZEROIA	/ZERO AI
OP3	XX		/DIVIDE
	JMP*	ITEXP
/
EXWRN	JMS	INFIN
WRNXIT	LAW	22
	JMS*	.ERROR
	JMP*	ITEXP
/
INVINT	LAC	SIGN	/CHECK IF ANSWER SHOULD BE COMPLEMENTED
	SZA
	JMS	INTACP
	JMP*	ITEXP
/
/ BASE IS DOUBLE PRECISION REAL
/
DBLSET	LAC	(JMS	DPARST
	DAC	OP0
	LAC	(JMS	DPARLD
	DAC	OP1
	LAC	(JMS	DPRMUL
	DAC	OP2
	LAC	(JMS	DPRDIV
	DAC	OP3
	LAC	(JMS	LOADBD
	JMP	EXPI
/
/ BASE IS INTEGER
/
INTSET	LAC	SIGNEN	/CHECK EXPONENT SIGN
	SMA!CLA!STL
	JMP	CHKSGN	/EXPONENT IS POSITIVE
	SAD	INT1
	SKP
	JMP	ENTERI
	SAD	INT2
	JMP	IEXWRN	/0**I WHERE I.LT.0
ENTERI	SAD	INT1	/MINUS EXPONENT. IF BASE IS 1 ANSWER IS 1
	RAL!SKP		/IF NOT 1 ANSWER IS 0
	JMP	ZERINT
	SAD	INT2
	JMP*	ITEXP
ZERINT	DZM	INT1
	DZM	INT2
	JMP*	ITEXP
CHKSGN	LAC	INT1
	SMA!CLA		/CHECK FOR NEGATIVE BASE
	JMP	SETSGN
	JMS	INTACP
	LAC	LEASTN
	RCR
	SZL!CLA
	CMA
SETSGN	DAC	SIGN	/SIGN=-1 IF BASE IS NEGATIVE AND EXPONENT IS ODD.
	LAC	(JMS	INARST
	DAC	OP0
	LAC	(JMS	INARLD
	DAC	OP1
	LAC	(JMS	INTMPY
	DAC	OP2
	LAC	(JMS	LOADBI
	JMP	EXPI
/
IEXWRN	JMS	LARGEI
	JMP	WRNXIT
/
/ BASE IS COMPLEX,LOGICAL OR CHARACTER
/
CCLI	SPA!RAL
	JMP	EXPERR	/LOGICAL OR CHARACTER
	SPA
	JMP	CDXSET
/
/ BASE IS SINGLE PRECISION COMPLEX
/
	LAC	(JMS	CXARST
	DAC	OP0
	LAC	(JMS	CXARLD
	DAC	OP1
	LAC	(JMS	MULCPX
	DAC	OP2
	LAC	(JMS	DIVCPX
	DAC	OP3
	LAC	(JMS	LOADCX
	JMP	EXPI
/
/ BASE IS DOUBLE PRECISION COMPLEX
/
CDXSET	LAC	(JMS	CDARST
	DAC	OP0
	LAC	(JMS	CDARLD
	DAC	OP1
	LAC	(JMS	MULDCP
	DAC	OP2
	LAC	(JMS	DIVDCP
	DAC	OP3
	LAC	(JMS	LOADDX
	JMP	EXPI
/
/ EXPONENT IS ZERO
/
EXPZRO	LAC	MODEA
	SZA		/SEPARATE INTEGER
	JMP	CKRELZ
	LAC	INT1
	SAD	INT2
	SZA
	SKP!CLA!STL
	JMP	IEXERR	/0**0
	DAC	INT1
	RAL
	DAC	INT2	/I**0=1
	JMP*	ITEXP
/
CKRELZ	SMA
	JMP	CKRS	/BASE IS REAL
	LAC	MOSTIA	/BASE IS COMPLEX OR ILLEGAL
	SNA
	JMP	CKRS
	JMS	ZEROIA
	JMP	CKNZ
CKRS	LAC	MOSTA
	SNA
	JMP	IEXERR	/ERROR 0.0**0
CKNZ	JMS	.LOAD1	/X**0=1.0
	JMP*	ITEXP
/
IEXERR	LAW	21
	JMS*	.ERROR
/
/ EXPONENT IS ONE
/
EXPONE	LAC	MODEA
	SZA		/SEPARATE INTEGER
	JMP	INVERT
	LAC	SIGNEN
	SNA!CLA!STL
	JMP*	ITEXP
	JMP	ENTERI
/
/ LOAD SINGLE PRECISION REAL FROM ACC A INTO ACC B
/
.LODBS	XX
	LAC	SIGNA
	DAC	SIGNB
	LAC	EXPA
	DAC	EXPB
	LAC	MOSTA
	DAC	MOSTB
	LAC	LEASTA
	DAC	LEASTB
	JMP*	.LODBS
/
/ LOAD DOUBLE PRECISION REAL FROM ACC A INTO ACC B
/
LOADBD	XX
	JMS	.LODBS
	LAC	A3
	DAC	B3
	LAC	A4
	DAC	B4
	JMP*	LOADBD
/
/ LOAD SINGLE PRECISION COMPLEX FROM ACC A INTO ACC B
/
LOADCX	XX
	JMS	.LODBS
	LAC	SIGNIA
	DAC	SIGNIB
	LAC	EXPIA
	DAC	EXPIB
	LAC	MOSTIA
	DAC	MOSTIB
	LAC	LESTIA
	DAC	LESTIB
	JMP*	LOADCX
/
/ LOAD DOUBLE PRECISION COMPLEX FROM ACC A INTO ACC B
/
LOADDX	XX
	JMS	LOADCX
	LAC	A3
	DAC	B3
	LAC	A4
	DAC	B4
	LAC	AI3
	DAC	BI3
	LAC	AI4
	DAC	BI4
	JMP*	LOADDX
/
/ LOAD INTEGER FROM ACC A IO INTEGER WORK SPACE
/
LOADBI	XX
	LAC	INT1
	DAC	INTMA
	LAC	INT2
	JMP*	LOADBI
/
/ TEMPORARY INTEGER STORE
/
INARST	XX
	LAC	INT1
	DAC	ADDR1
	LAC	INT2
	DAC	ADDR1+1
	JMP*	INARST
/
/ TEMPORARY INTEGER LOAD
/
INARLD	XX
	LAC	ADDR1
	DAC	INTMA
	LAC	ADDR1+1
	JMP*	INARLD
/
/ TEMPORARY SINGLE PRECISION COMPLEX STORE
/
CXARST	XX
	JMS	SPARST
	LAC	MOSTIA
	STL
	SZA!RAR
	LAC	EXPIA
	DAC*	AUTO6
	LAC	SIGNIA
	CLL!RAL
	LAC	MOSTIA
	RAL
	DAC*	AUTO6
	LAC	LESTIA
	DAC*	AUTO6
	JMP*	CXARST
/
/ TEMPORARY SINGLE PRECISION COMPLEX LOAD
/
CXARLD	XX
	JMS	SPARLD
	LAC*	AUTO6
	SAD	(400000
	JMP	ZERCX
	DAC	EXPIB
	STL
	LAC*	AUTO6
	RAR
	DAC	MOSTIB
	CLA!RAR
	DAC	SIGNIB
	LAC*	AUTO6
	DAC	LESTIB
	JMP*	CXARLD
ZERCX	JMS	ZEROIB
	JMP*	CXARLD
/
/ TEMPORARY DOUBLE PRECISION COMPLEX STORE
/
CDARST	XX
	JMS	CXARST
	LAC	A3
	DAC*	AUTO6
	LAC	A4
	DAC*	AUTO6
	LAC	AI3
	DAC*	AUTO6
	LAC	AI3
	DAC*	AUTO6
	JMP*	CDARST
/
/ TEMPORARY DOUBLE PRECISION COMPLEX LOAD
/
CDARLD	XX
	JMS	CXARLD
	LAC	(400000
	SAD	EXPB
	JMP	CDCHIB
	LAC*	AUTO6
	DAC	B3
	LAC*	AUTO6
	DAC	B4
	LAC	(400000
CDCHIB	SAD	EXPIB
	JMP*	CDARLD
	LAC*	AUTO6
	DAC	BI3
	LAC*	AUTO6
	DAC	BI4
	JMP*	CDARLD
/
/ ROUTINE TO LOAD 1.0 INTO ACC A
/
.LOAD1	XX
	JMS	ZERVAL
	DAC	MOSTA
	LAC	(1
	DAC	EXPA
	JMP*	.LOAD1
/
/  REAL ** REAL
/
SPEXP	JMS	CHEKIT
	LAC	(SAVEY
	JMS	SPARST
	JMS	LDREAL
	JMS	.SPLG2
	LAC	(SAVEY
	JMS	SPARLD
	JMS	SPRMUL
	JMS	.SPXP2
	JMP	.NEXT
/
/  DOUBLE ** DOUBLE
/
DPEXP	JMS	CHEKIT
	LAC	(SAVEY
	JMS	DPARST
	JMS	LDDBL
	JMS	.DPLG2
	LAC	(SAVEY
	JMS	DPARLD
	JMS	DPRMUL
	JMS	.DPXP2
	JMP	.NEXT
/
/ ROUTINE TO CHECK SPECIAL EXPONENTIATION CASES
/
CHEKIT	XX
	LAC	MOSTB
	SZA
	JMP	BNOT
	LAC	SIGNA
	SZA
	JMP	RWRN	/0**X WHERE X IS NEGATIVE
	LAC	MOSTA
	SNA
	JMP	IEXERR	/0**0
	JMS	ZERVAL	/0**X WHERE X.GT.0, RESULT IS ZERO
	JMP	.NEXT
BNOT	LAC	MOSTA
	SZA
	JMP*	CHEKIT
	JMS	.LOAD1	/X**0=1
	JMP	.NEXT
/
RWRN	LAC	(.NEXT
	DAC	ITEXP
	JMP	EXWRN
/
/  MISCELLANEOUS STORAGE
/
SESS;MOSTN;LEASTN;SIGNEN
LARGE;SIGN
/
/
	.EJECT
/
.IABS	XX
	JMS	.IFIX	/ CHECK MODE
	LAC	INT1
	SPA
	JMS	INTACP	/ INTEGER IS NEGATIVE , COMPLIMENT IT.
	JMP*	.IABS
/
/
.FLOAT	XX
	CLL!RAL
	SZL
	JMP	ILMODE	/ COMPLEX MODE,ERROR
	SMA!RAR
	JMS	.FLOTA	/ INTEGER MODE,FLOAT IT
	JMP*	.FLOAT
/
.IFIX	XX
	CLL!RAL
	SZL
	JMP	ILMODE	/ COMPLEX MODE,ERROR
	SPA!RAR
	JMS	.FIX	/ REAL MODE, FIX IT
	DZM	MODEA	/ MARK AS INTEGER
	JMP*	.IFIX
/
/ NON COMPLEX TO SINGLE REAL
.SNGL	XX
	JMS	.FLOAT
	LAC	(200000
	DAC	MODEA	/ MARK AS REAL MODE
	JMP*	.SNGL
/
/
/ ALOG10 CALCULATES LOG X TO BASE 10
/
.ALG10	XX
        JMS     .SNGL   /CHECK MODE
        JMS     .SPLG2  /CALCULATE LOG X TO BASE 2
        LAC     .LOG2
        JMS     SPARLD
        JMS     SPRMUL  /MULTIPLY BY LOG 2 TO BASE 10
        JMP*    .ALG10
/
ILMODE	LAW	24
	JMP*	.NERR
	.EJECT
/
/ SINGLE PRECISION LOG ROUTINES
/
/ .SPLG2 CALCULATES LOG X TO BASE 2
.SPLG2  XX
        LAC     SIGNA
        SZA
	JMP	ILLARG	/NEGATIVE ARGUMENT
	LAC	MOSTA
	SNA
	JMP	ILLARG	/ZERO ARGUMENT
        LAC     EXPA
	SPA
	TAD	(1
	DAC	INT2	/SAVE EXPONENT
	SPA!CLA
	CMA
	DAC	INT1
        DZM     EXPA
        LAC     (ADDR1
        JMS     SPARST  /SAVE FRACTION IN ADDR1
        LAC     .MPT63
        JMS     SPARLD
        JMS     SPADD	/SUBTRACT 0.63
        LAC     SIGNA
        SZA
        JMP     FIRST
        LAC     .MPT16
        JMS     SPARLD
        JMS     SPADD	/SUBTRACT 0.16
        LAC     SIGNA
        SZA
        JMP     SECOND
        LAC     (6	/SET POINTER TO THIRD GROUP
        JMP     .+3
FIRST   SKP!CLA         /SET POINTER TO FIRST GROUP
SECOND  LAC     (3      /SET POINTER TO SECOND GROUP
        DAC     PNTR
        LAC     (ADDR1
        JMS     SPARLD  /LOAD F
        JMS     LDREAL  /INTO ACC A
        LAC     PNTR
        TAD     .S
        JMS     SPARLD
        JMS     SPADD	/F+S(F)
        LAC     (ADDR2
        JMS     SPARST  /STORE F+S(F)
        LAC     PNTR
        TAD     .S
        JMS     SPARLD
        JMS     COMPLB
        JMS     LDREAL
        LAC     (ADDR1
        JMS     SPARLD
        JMS     SPADD	/F-S(F)
        LAC     (ADDR2
        JMS     SPARLD  /LOAD F+S(F)
        JMS     SPRDIV  /R IN ACC A
        LAC     (ADDR1
        JMS     SPARST  /STORE R
	JMS	.LODBS
        JMS     SPRMUL  /FORM R**2
        LAC     .C
        JMS     SPARLD
        JMS     SPADD	/C+R**2 IN ACC A
        LAC     .B
        JMS     SPARLD
        LAC     (200000
        DAC     MODEB   /SET MODEB BEFORE CALLING REVRSG
        JMS     REVRSG
        JMS     SPRDIV  /B/(C+R**2)
        LAC     .A
        JMS     SPARLD
        JMS     SPADD	/A+B/(C+R**2)
	LAC	(ADDR1
	JMS	SPARLD
	JMS	SPRMUL	/R*(A+B/(C+R**2))
        LAC     .T
        TAD     PNTR
        JMS     SPARLD  /-T(F) IN ACC B
        JMS     SPADD	/A+B/(C+R**2)-T(F)
        JMS     .FLOTB  /FLOAT EXPONENT INTO ACC B
        JMS     SPADD	/CALCULATE FULL LOG
        JMP*    .SPLG2  /NORMAL EXIT
ILLARG	LAW	7
	JMS*	.ERROR	/ISSUE ERROR
	LAC     (400000 /ZERO OR NEGATIVE ARGUMENT
        DAC     SIGNA
	JMS	INFIN	/SET ACC A TO - INFINITY
        JMP*    .SPLG2
/
/ SINGLE PRECISION EXPONENTIAL ROUTINES
/
/ .SPXP2 CALCULATES 2**X
.SPXP2  XX
        LAC     (ADDR1
        JMS     SPARST
	LAC	SIGNA
	JMS	.LDPT5
        JMS     SPADD	/ADD 0.5
        JMS     .FIX     /VALUE M IN INT1,INT2
	LAC	INT1
	SZA
	CMA
	SZA!CLA		/AC MUST NOW BE ZERO TO PREVENT FUTURE 
	JMP	OVFL	/EXPONENT OVERFLOW
	LAC	INT2
	DAC	LARGE	/SAVE INT2 AS IT WILL BE DESTROYED BY FLOAT
        JMS     .FLOTA  /FLOAT M AND PLACE IN ACC A
        LAC     (ADDR1
        JMS     SPARLD  /LOAD X INTO ACC B
        JMS     COMPLA  /COMPLEMENT ACC A AND
        JMS     SPADD	/ADD TO PRODUCE R
        LAC     (ADDR1
        JMS     SPARST  /STORE R IN ADDR1
	JMS	.LODBS
        JMS     SPRMUL  /R**2 IN ACC A
        LAC     (ADDR2
        JMS     SPARST  /STORE R**2 IN ADDR2
        LAC     .C4
        JMS     SPARLD
        JMS     SPRADD  /C4+R**2 IN ACC A
        LAC     (ADDR1
        JMS     SPARLD  /R IN ACC B
        JMS     SPRMUL  /(C4+R**2)*R
        LAC     .C3
        JMS     SPARLD
        JMS     SPRMUL  /(C4+R**2)*R*C3=B(R)
        LAC     (ADDR1
        JMS     SPARST  /B(R) IN ADDR1
        LAC     .C2
        JMS     SPARLD
        JMS     LDREAL  /C2 IN ACC A
        LAC     (ADDR2
        JMS     SPARLD
        JMS     SPRADD  /C2+R**2
        LAC     (ADDR2
        JMS     SPARLD
        JMS     SPRMUL  /(C2+R**2)*R**2
        LAC     .C1
        JMS     SPARLD  /C1 IN ACC B
        JMS     SPRADD  /(C2+R**2)*R**2+C1=A(R)
        LAC     (ADDR2
        JMS     SPARST  /A(R) IN ADDR2
        LAC     (ADDR1
        JMS     SPARLD  /B(R) IN ACC B
        JMS     COMPLB
        JMS     SPADD	/A(R)-B(R) IN ACC A
        LAC     (ADDR1
        JMS     SPARLD
        LAC     (ADDR1
        JMS     SPARST  /STORE A(R)-B(R)
        JMS     LDREAL
        LAC     (ADDR2
        JMS     SPARLD
        JMS     SPADD	/A(R)+B(R)
        LAC     (ADDR1
        JMS     SPARLD  /A(R)-B(R) IN ACC B
        JMS     SPRDIV  /DIVIDE,RESULT=2**R
	LAC	LARGE	/GET M
	SPA
	TAD	(-1	/2'S COMPLEMENT TO 1'S COMPLEMENT
	CLL
        ADD     EXPA
        DAC     EXPA    /MULTIPLY RESULT BY 2**M
        SNL!CLA
        JMP*    .SPXP2  /NORMAL EXIT
OVFL	JMS*	.ERROR	/ OVERFLOW ISSUE ERROR
	JMS	INFIN	/ GENERATE INFINITY
        JMP*    .SPXP2  /AND EXIT
/
/ TEMPORARY STORAGE FOR Y
SAVEY   .BLOCK  5
/
ADDR1	.BLOCK	5
ADDR2	.BLOCK	5	/ TEMPORARY STORAGE LOCATIONS
.CNTR;PNTR
	.EJECT
/
/
/  ROUTINE TO CALCULATE  DP LOG X TO BASE 2
/  X IN ACC A
/
.DPLG2	XX
	LAC	.DPLG2
	DAC	.SPLG2	/RETURN ADDRESS IN CASE OF ERROR
	LAC	SIGNA
	SZA!STL
	JMP	ILLARG	/NEGATIVE ARGUMENT ILLEGAL
	LAC	MOSTA
	SNA!RAR		/AC=400000
	JMP	ILLARG	/ZERO ARGUMENT
	LAC	EXPA
	SPA
	TAD	(1	/1'S COMPLEMENT TO 2' COMPLEMENT
	DAC	INT2
	SPA!CLA
	CMA
	DAC	INT1	/SAVE K IN INTEGER ACC A
	DZM	EXPA
	LAC	(ADDR1	/STORE M
	JMS	DPARST
	LAC	.MSQ2O2	/GET -SQRT(2)/2
	JMS	DPARLD
	DZM	SIGNB	/+SQRT(2)/2
	JMS	DPRADD	/DENOMINATOR OF Y
	LAC	(ADDR2	/STORE DENOMINATOR
	JMS	DPARST
	LAC	(ADDR1	/GET M
	JMS	DPARLD
	JMS	LDDBL	/M IN ACC A
	LAC	.MSQ2O2	/-SQRT(2)/2
	JMS	DPARLD
	JMS	DPRADD	/CALCULATE NUMERATOR OF Y
	LAC	(ADDR2	/GET DENOMINATOR
	JMS	DPARLD
	JMS	DPRDIV	/Y NOW IN ACC A
	LAC	(ADDR1	/STORE Y
	JMS	DPARST
	LAC	(ADDR1	/GET Y
	JMS	DPARLD
	JMS	DPRMUL	/ACC A=Y*Y
	LAC	(ADDR2	/STORE Y*Y
	JMS	DPARST
	LAW	-14	/SET UP COUNTER FOR SERIES CALCULATION
	DAC	.CNTR
	LAC	.CE25
	JMS	DPSER
	LAC	(ADDR1
	JMS	DPARLD
	JMS	DPRMUL	/LOG Y IN ACC A
	LAC	(400000
	JMS	.LDPT5	/LOAD -0.5
	JMS	DPRADD	/CALCULATE LOG M
	JMS	.FLOTB	/FLOAT K INTO ACC B
	DZM	B3
	DZM	B4	/ZERO OUT EXTENSION
	JMS	DPRADD
	JMP*	.DPLG2	/EXIT WITH LOG IN ACC A
/
/
/  SUBROUTINE TO CALCULATE 2**X WHERE X IS DOUBLE PRECISION
/  AND IN ACC A
/
.DPXP2	XX
	LAC	.DPXP2
	DAC	.SPXP2	/RETURN ADDRESS IN CASE OF ERROR
	LAC	MOSTA
	SNA
	JMP	EXIT1	/2**0=1
	LAC	SIGNA	/SAVE SIGN
	DAC	SIGN
	DZM	SIGNA	/TAKE ABSOLUTE VALUE
	LAC	EXPA	/START ARGUMENT SEPARATION
	ADD	(4
	DAC	EXPA	/MULTIPLY X BY 16
	JMS	.FIX	/FIX TO OBTAIN K+F1 IN INT1,INT2
	LAC	INT1
	SZA
	CMA
	SZA!CLA
	JMP	OVFL	/IF INT1 NON-ZERO, OVERFLOW WILL OCCUR
	LAC	INT2
	DAC	LARGE	/SAVE INT2 AS FLOAT WILL DESTROY IT
	JMS	.FLOTB
	DZM	B3	/ZERO OUT EXTENSION
	DZM	B4
	JMS	COMPLB
	JMS	DPRADD
	LAW	-5
	ADD	EXPA
	DAC	EXPA	/ACC A=F2/LN 2
	LAC	.LN2
	JMS	DPARLD
	JMS	DPRMUL
	LAC	(ADDR2	/STORE F2
	JMS	DPARST
	LAW	-10	/START SETUP FOR SERIES
	DAC	.CNTR
	LAC	.DC8
	JMS	DPSER
	LAC	(SAVEY	/SAVE 2**F2
	JMS	DPARST
	LAC	LARGE	/START RETRIEVING F1
	AND	(17	/EXTRACT F1
	DAC	LEASTN	/PREPARE FOR REAL**I
	DZM	MOSTN
	LAC	.RT216	/LOAD SIXTEENTH ROOT OF 2
	JMS	DPARLD
	JMS	LDDBL	/INTO ACC A
	JMS	ITEXP
	LAC	(SAVEY	/GET 2**F2
	JMS	DPARLD
	JMS	DPRMUL	/ACC A=2**(F1+F2)
	LAC	LARGE
	SPA
	TAD	(-1	/2'S COMPLEMENT TO 1'S COMPLEMENT
	LRSS	4	/RETRIEVE K
	ADD	EXPA
	DAC	EXPA
	SZL!CLA
	JMP	OVFL
	LAC	SIGN	/GET SIGN
	SMA!CLA
	JMP*	.DPXP2	/SIGN POSITIVE; EXIT
	JMS	LOADBD	
	JMS	.LOAD1	/1.0 TO ACC A
	JMS	DPRDIV
	JMP*	.DPXP2
/
EXIT1	JMS	.LOAD1
	JMP*	.DPXP2
/
/  ROUTINE TO EVALUATE DOUBLE PRECISION SERIES
/
DPSER	XX
	DAC	PNTR
	JMS	DPARLD
	JMS	DPRMUL
	LAC	PNTR
	TAD	(5
	DAC	PNTR
	JMS	DPARLD
	JMS	DPRADD
	LAC	(ADDR2
	ISZ	.CNTR
	JMP	DPSER+2
	JMP*	DPSER
/
/
/SINGLE PRECISION ADD, NO TRUNCATION
/
SPADD	XX
	LAC	(SKP
	DAC	GRIND+1
	JMS	SPRADD
	LAC	TAG
	DAC	GRIND+1
	JMP*	SPADD
TAG	TAD	(400
/
/
/ SINGLE PRECISION TEMPORARY LOAD AND STORE ROUTINES
SPARST  XX              /STORE ACC A IN ADDRESS SPECIFIED BY AC
        TAD     (-1
        DAC*    (AUTO6
	LAC	MOSTA
	STL
	SZA!RAR
        LAC     EXPA
        DAC*    AUTO6
	LAC	SIGNA
	CLL!RAL
        LAC     MOSTA
	RAL
        DAC*    AUTO6
        LAC     LEASTA
        DAC*    AUTO6
        JMP*    SPARST
/
SPARLD  XX              /LOADS ACC B FROM ADDRESS SPECIFIED BY AC
        TAD     (-1
        DAC*    (AUTO6
        LAC*    AUTO6
	SAD	(400000
	JMP	ZEROLD
        DAC     EXPB
	STL
        LAC*    AUTO6
	RAR
        DAC     MOSTB
	CLA!RAR
	DAC	SIGNB
        LAC*    AUTO6
        DAC     LEASTB
        JMP*    SPARLD
ZEROLD	STL
	JMS	ZERINF
	CMA
	DAC	EXPB	/GENERATE ZERO IN ACC B
	DZM	SIGNB	/ MAKE SURE ITS +0
	JMP*	SPARLD
/
/  DOUBLE PRECISION LOAD AND STORE
/
DPARST	XX
	JMS	SPARST
	LAC	A3
	DAC*	AUTO6
	LAC	A4
	DAC*	AUTO6
	JMP*	DPARST
/
DPARLD	XX
	JMS	SPARLD
	LAC	MOSTB
	SNA
	JMP*	DPARLD
	LAC*	AUTO6
	DAC	B3
	LAC*	AUTO6
	DAC	B4
	JMP*	DPARLD
/
/ ROUTINE TO LOAD 0.5 INTO ACCUMULATOR B
/
.LDPT5	XX
	DAC	SIGNB
	LAC	(400000
	DAC	MOSTB
	DZM	LEASTB
	DZM	EXPB
	DZM	B3
	DZM	B4
	JMP*	.LDPT5
/
/ EQUIVALENCES FOR GLOBALED ITEMS
.SPRML=SPRMUL;.SPRDV=SPRDIV;.SPADD=SPADD;.SPRST=SPARST;.SPRLD=SPARLD
.DPRML=DPRMUL;.DPRDV=DPRDIV;.DPADD=DPRADD;.DPRST=DPARST;.DPRLD=DPARLD
.LDREL=LDREAL;.LDDBL=LDDBL;.LODBD=LOADBD;.DPSER=DPSER
.CMPLA=COMPLA;.CMPLB=COMPLB;.RVRSG=REVRSG;.ZRVAL=ZERVAL;.ZROIA=ZEROIA
.PICK1=PICK1;.PICK2=PICK2
.SWPIT=SWAPIT;.SWPUS=SWAPUS;.SWPBI=SWAPBI;.SWPIB=SWAPIB
.MVIMA=MVIMA;.ILMDE=ILMODE
.ADDR1=ADDR1;.ADDR2=ADDR2
/
	.END
