MATH1.ASM

; [ This translation created 10-Feb-83 by Version 4.3 ]

	.RADIX	8		; To be safe

CSEG	SEGMENT PUBLIC 'CODESG'
	ASSUME	CS:CSEG

INCLUDE OEM.H

	TITLE MATH86 8086 MATH PACK

	.SALL
	.RADIX	8

SIXDIG=0			;Floating pnt output 6 bit S.P. numbers

	PUBLIC	ABSFN,ATN,COS,DADD
	PUBLIC	DDIV,DMULT,EXP,FINDBL,FIN,FOUT,FRCDBL
	PUBLIC	FRCINT,FRCSNG,INEG,INEG2,INT,LOG,LOPFND,NEG
	PUBLIC	PUFOUT,RND,SIGN,SIN,SQR,TAN
	PUBLIC	VALINT,VINT,VNEG,ZERO,$CDS,$CSD,$CSI
	PUBLIC	$DCMPA,$DIV0S,$DZERO,$EXPCN,$FADDS,$FCOMP,$FDIVS
	PUBLIC	$FI,$FLT,$FMULS,$FOUTH,$FOUTO,$FOUT2,$FPWR
	PUBLIC	$FSUBD,$FSUBS,$FS,$GETYP,$LOGP,$MOVFA,$MOVFM
	PUBLIC	$MOVFR,$MOVMF,$MOVRF,$NEG,$NORMD,$NORMS,$POPA
	PUBLIC	$SIGNS,$VINT,$VPSHF

	PUBLIC	SIGNS,DCXBRT,FADD,VSIGN,MOVFR,ISIGN,INEG2
	PUBLIC	IMOD,GETBCD,ISUB,FPWRQ,INRART,MOVRF,DCOMP
	PUBLIC	VDFACS,MOVFM,FDIVT,ICOMP,VMOVAF,UMULT,FOUTH,FSUB
	PUBLIC	ICMPA,VMOVFA,IDIV,VMOVFM,IMULT,RNDMN2,BLTU,FMULT
	PUBLIC	FRCSTR,POPHRT,MOVE,MOVMF,CONIA,VMOVE,RNDMON,CHKSTR
	PUBLIC	LOPFD1,INPRT,MAKINT,FDIV,SGN,SIGNC,FCOMP,INXHRT
	PUBLIC	IADD,FOUTO,DSUB,VALSNG,BLTUC,FIXER,MOVRM
	PUBLIC	FADDS,LINPRT,MOVE1,CONSIH,PUSHF,VMOVMF

	PUBLIC	STROUT
	EXTRN	CRFIN:NEAR,OUTDO:NEAR


	EXTRN	ARYEXT:NEAR,BSERR:NEAR,CHRGTR:NEAR,DV0ERR:NEAR,FRQINT:NEAR
	EXTRN	INTXT:NEAR,NOTFDD:NEAR,NOTFNS:NEAR,OVERR:NEAR
	EXTRN	REASON:NEAR,STROUI:NEAR,TMERR:NEAR
	EXTRN	$CATTY:NEAR,$CLROV:NEAR,$DIV0M:NEAR,$FLGOC:NEAR
	EXTRN	$OHCNS:NEAR,$OVERR:NEAR,$OVMSG:NEAR,$FCERR:NEAR
	EXTRN	$SNERR:NEAR,$STPRN:NEAR,$TMERR:NEAR

DSEG	SEGMENT PUBLIC 'DATASG'
	ASSUME DS:DSEG
	EXTRN	ARYTA2:WORD,NAMBUF:WORD,NAMCNT:WORD,ONELIN:WORD
	EXTRN	STREND:WORD,TEMP3:WORD,VALTYP:WORD
	EXTRN	$ARG:WORD,$ARGLO:WORD,$DBUFF:WORD,$DFACL:WORD
	EXTRN	$DPADR:WORD,$FAC:WORD,$FACLO:WORD,$FACM1:WORD,$FBUFF:WORD
	EXTRN	$FLGOV:WORD,$FMTAL:WORD,$FMTAX:WORD,$FMTCX:WORD,$RNDX:WORD
	EXTRN	$VALTP:WORD,$ZLO:WORD,$Z1LO:WORD,$Z1:WORD
DSEG	ENDS


	SUBTTL	 $FOTCI  CONVERT INTEGER IN (FACLO) TO ASCII DIGITS
;*************************************************************
;
;       $FOTCI  CONVERT THE INTEGER IN (FACLO)-TWO BYTES TO
;               ASCII DIGITS.
;       CALLING SEQUENCE:       CALL    $FOTCI
;               WITH DECIMAL POINT AND COMMA COUNTS IN (CX)
;       $FOUTO  CONVERT INTEGER IN $FACLO:FACLO+1 TO OCTAL
;       $FOUTH  CONVERT INTEGER IN $FACLO:FACLO+1 TO HEXIDECIMAL
;       CALLING SEQUENCE:       CALL    $FOUTO/$FOUTH
;               WITH $FACLO:FACLO+1 CONTAINING INTEGER TO BE
;               PRINTED. RETURNS WITH (BX) POINTING TO $FBUFF
;
;**************************************************************
	PUBLIC	$FOTCI
$FOTCI: MOV	AH,LOW 5	;MAX DIGITS TO CONVERT
	MOV	BP,OFFSET $FOITB
$FCI4:				;ENTRY FOR FOTCV SO WE WILL ONLY CONVERT 4 DIGITS
FCI10:	CALL	$FOTED		;CHECK FOR NEEDED D.P. OR ","
				;TABLE IN CODE SEGMENT
	MOV	DX,WORD PTR CS:0[BP]	;FETCH POWER OF TEN TO DX
	INC	BP		;POINT (BP) TO NEXT PWR 10
	INC	BP
	MOV	SI,WORD PTR $FACLO	;FETCH INTEGER TO BE CONVERTED
	MOV	AL,LOW OFFSET "0"-1     ;WILL BUILD DIGIT IN (AL)
FCI20:	INC	AL
	SUB	SI,DX		;SUBTRACT OUT POWER OF TEN
	JNB	FCI20		;CONTINUE UNTIL DIGIT FORMED
	ADD	SI,DX		;SUBTRACTED OUT ONE TOO MANY
	MOV	BYTE PTR 0[BX],AL	;MOVE DIGIT TO BUFFER
	INC	BX		;POINT (BX) TO NEXT BUFF POS.
	MOV	WORD PTR $FACLO,SI	;SAVE UPDATED INTEGER
	DEC	AH		;LOOP TILL DIGITS FORMED
	JNZ	FCI10
	CALL	$FOTED		;SEE IF DECIMAL POINT NEEDED
	MOV	BYTE PTR 0[BX],LOW 0	;AND PUT BINARY
	RET			;ZERO AFTER.
$FOUTO:			;OCTAL OUTPUT OF INTEGER IN $FACLO:FACLO+1
	MOV	CX,OFFSET 3*400+1	;WILL PROCESS 3 BITS AT A TIME
	MOV	SI,6		;OCTAL DIGITS
	JMP	SHORT FTH10
$FOUTH:			;HEXIDECIMAL OUTPUT OF INTEGER IN FACLO:FACLO+1
	MOV	CX,OFFSET 4*400+4	;WILL PROCESS 4 BITS AT A TIME
	MOV	SI,4		;HEX DIGITS
FTH10:	MOV	DI,OFFSET $FBUFF	;POINT DI TO OUTPUT LOCATION
	CLD			;SO SUBSEQUENT STOC WILL INC
	MOV	BX,OFFSET $NUMB
	MOV	DX,WORD PTR $FACLO	;FETCH INTEGER
	PUSH	SI		;SAVE FOR ZERO SUPPRESS CODE
FTH20:	MOV	AL,DH		;GET INTEGER
	XOR	AH,AH		;CLEAR UPPER AX
	SHL	AX,CL		;SHIFT HIGH ORDER BITS INTO AH
	XCHG	AH,AL		;NOW IN AL
				;LOOK FROM CODE SEGMENT
?CSLAB:			; Code segment dummy label
	XLAT	BYTE PTR ?CSLAB ;LOOK-UP ASCII
	STOSB
	SHL	DX,CL		;SHIFT NUMBER
	MOV	CL,CH		;GET NO. BITS TO SHIFT
	DEC	SI		;DECREMENT NO. OF DIGITS
	JNZ	FTH20
	MOV	BYTE PTR 0[DI],LOW 0	;DENOTE END OF NO.
	MOV	BX,OFFSET $FBUFF
	POP	CX		;RECALL FOR ZERO SUPPRESS
	DEC	CL		;CAN'T DELETE ALL THE ZEROS
FTH40:	CMP	BYTE PTR 0[BX],LOW "0"  ;DO ZERO SUPPRESS
	JNZ	FTH50		;NO MORE SUPPRESS
	INC	BX
	LOOP	FTH40
FTH50:	RET

	SUBTTL	 $PUFXE  PRINT USING FIX-UP CODE
;****************************************************************
;
;       $PUFXE  THIS CODE IS CALLED ONCE PRINT-USING ROUTINES
;               HAVE BUILT THE NUMBER IN THE OUTPUT BUFFER (FBUFF)
;               ITS JOB IS TO ASSURE THE NUMBER MEETS OUTPUT
;               SPECIFICATIONS. IF THE NUMBER TRULY OVERFLOWS THE
;               OUTPUT BUFFER A "%" SIGN WILL BE INSERTED AS THE
;               LEADING CHARACTER.
;       CALLING SEQUENCE:       CALL    $PUFXE
;               WITH $FBUFF CONTAINING THE FORMATTED NUMBER
;
;*****************************************************************

	CURNCY="$"	      ;Default floating currency is dollars.
$PUFXE: PUSH	BX		;SAVE END OF BUFFER POINTER
	CALL	$FOTZS		;DO ZERO SUPPRESSION
				;$FOTZS WILL LEAVE ZF=0 IF THERE IS
				;TO BE A TRAILING SIGN AND THE SIGN
				;WILL BE LEFT IN (CH)
	POP	BX		;RECALL END-OF-BUFFER POINTER
	JZ	PFX10		;IF NO TRAILING SIGN PROCEED
	MOV	BYTE PTR 0[BX],CH	;PUT IN TRAILING SIGN
	INC	BX		;MUST NOW PUT IN BINARY ZERO
PFX10:	MOV	BYTE PTR 0[BX],LOW 0	;TO SIGNIFY END OF PRINT
	MOV	BX,OFFSET $FBUFF	;FETCH START OF BUFFER ADDRESS
PFX20:	INC	BX		;INCREMENT (BX) TO NEXT BUFFER POSITION
PFX30:	MOV	DI,WORD PTR $DPADR	;GET DECIMAL POINT ADDRESS
	MOV	DX,WORD PTR $FMTCX	;FETCH DECIMAL POINT INFO.
	MOV	AL,BYTE PTR $FMTCX+1	;FETCH NO. DIGITS TO LEFT OF D.P.
	XOR	AH,AH		;(AX) = DIGITS LEFT OF DECIMAL POINT
	SUB	DI,BX		;WILL FORM THE SUBTRACTION:
	SUB	DI,AX		;D.P. ADDR.-BUFF PTR-DIGITS LEFT OF D.P
	JZ	PFX90		;RETURN IF ALL IS OK.
;********************************************************************
;FIELD IS CURRENTLY TOO LARGE. WE CAN SHORTEN THE FIELD BY ELIMINATING
;LEADING " " AND "*" CHARACTERS AND A LEADING "0" IF THE CHARACTER
;FOLLOWING THE DECIMAL POINT IS A NUMERIC DIGIT. DOING THIS ANALYSIS
;WILL BE WHAT THE FOLLOWING SONG & DANCE IS ALL ABOUT
;THE INCREMENT OF (BX) AT PFX20 IN EFFECT SHORTENS THE FIELD BECAUSE
;(BX) WILL POINT TO THE STARTING LOCATION FOR PRINTOUT UPON RETURN
;FROM THIS ROUTINE.
;******************************************************************
	MOV	AL,BYTE PTR 0[BX]	;FETCH NEXT CHARACTER IN BUFFER
	CMP	AL,LOW " "      ;SPACE?
	JZ	PFX20		;IF SO ELIMINATE AND SEE IF NOW OK
	CMP	AL,LOW "*"      ;IF ASTERISK FILL THEN ASTERISK?
	JZ	PFX20
	MOV	AH,LOW 1	;TO SIGNAL END OF CHARACTERS IN
				;THE FOLLOWING CODE
	DEC	BX		;BECAUSE $CHRGT WILL DO INC BX FIRST
	PUSH	BX		;SAVE THIS LOCATION FOR POSSIBLE "%"
PFX40:	PUSH	AX
	CALL	$CHRGT		;GET NEXT CHARACTER( NOTE THAT THIS
				;RE-FETCHES THE PREVIOUS FAILING
				;CHARACTER THE FIRST TIME THROUGH)
	XOR	AH,AH		;CLEAR (AH)
	CMP	AL,LOW "-"      ;IF EQUAL NEED TO SAVE THIS GUY
	JZ	PFX40		;GO SAVE AND GET NEXT CHAR.
	CMP	AL,LOW "+"
	JZ	PFX40		;GO SAVE THIS GUY IF EQUAL
	CMP	AL,LOW OFFSET CURNCY
	JZ	PFX40		;GO SAVE IF EQUAL
	CMP	AL,LOW "0"      ;IF EQUAL POSSIBLE TO ELIMINATE
	JNZ	PFX70		;MUST GIVE UP AND PUT LEADING "%"
;**************************************************************
;AT THIS POINT WE HAVE A LEADING ZERO. IT CAN BE ELIMINATED
;ONLY IF THERE ARE DIGITS BEYOND THE DECIMAL POINT. IF THIS
;IS THE CASE WE HAVE POSITIONED TO THE CORRECT PLACE AND
;HAVE CHARACTERS TO MOVE DOWN IN THE STACK AND CAN ELIMINATE
;THE ZERO BY NOT PUSHING IT ON THE STACK SINCE ALL
;CHARACTERS TO BE RE-INSERTED WILL COME FROM THE STACK.
;***************************************************************
	INC	BX		;THIS WILL CAUSE ELIMINATION OF "0"
	CALL	$CHRGT		;GET CHARACTER AFTER DECIMAL POINT
	JNB	PFX70		;NO HOPE GIVE UP AND PUT IN "%"
	DEC	BX		;(BX) NOW POINTS TO DECIMAL POINT
	JMP	SHORT PFX60
PFX50:	DEC	BX		;NEXT CHARACTER POSITION TO MOVE INTO
	MOV	BYTE PTR 0[BX],AL	;MOVE IT IN
PFX60:	POP	AX		;FETCH CHARACTER OFF THE STACK
	OR	AH,AH		;ONCE (AH)=1 IS REACHED CHARS.
				;HAVE BEEN RE-ENSTATED
	JZ	PFX50		;KEEP GOING IF (AH)=0
	ADD	SP,2		;GET OLD START OF BUFFER ADDRESS OFF
				;THE STACK
	JMP	SHORT PFX30	;AND SEE IF WE NOW FIT INTO THE
				;REQUIRED SPACE
PFX70:
;******************************************************************
;WE COULD NOT FIT THE NUMBER INTO THE BUFFER DESPITE OUR VALIENT
;EFFORTS WE MUST POP ALL THE CHARACTERS BACK OFF THE STACK AND
;POP OFF THE BEGINNING BUFFER PRINT LOCATION AND INPUT A "%" SIGN
;THERE
;******************************************************************
	POP	AX		;GET CHARACTER OFF THE STACK
	OR	AH,AH		;IF ZF=1 AFTER THIS-MORE CHARS.
	JZ	PFX70
	POP	BX		;GET BEGINNING BUFFER POINTER
	MOV	BYTE PTR 0[BX],LOW "%"  ;INSERT OVERFLOW FLAG
PFX90:	RET

	SUBTTL	 $FOTZS  ZERO SUPRESSION UPON OUTPUT ROUTINE
;*************************************************************
;
;       $FOTZS  THIS ROUTINE WILL LOOK AT THE OUTPUT GENERATED
;               BY THE REST OF THE PUFOT ROUTINES AND SUPRESS
;               LEADING ZEROES.
;       CALLING SEQUENCE:       CALL    $FOTZS
;               ONLY PREREQUISITE IS THAT OTHER PUFOT ROUTINES
;               HAVE EXECUTED TO PROVIDE FOTZS WITH $FBUFF
;               CONTAINING OUTPUT TEXT.
;
;       $FOTZ   THIS ROUTINE PUTS IN (AL) LEADING ZEROS
;       CALLING SEQUENCE:       CALL    $FOTZ
;               WITH (AL) SET TO NO. OF LEADING ZEROS DESIRED
;       $FOTZC  THIS ROUTINE PUTS IN (AL) LEADING ZEROS AND
;               PAYS ATTENTION TO DECIMAL POINT AND COMMA COUNTS
;               AND FURTHER PUTS IN COMMAS AND A D.P. AS NECESSARY
;       CALLING SEQUENCE:       CALL    $FOTZC
;               WITH (CX) SET TO NO. PLACES TO LEFT/RIGHT OF D.P.
;               AND (AL) TO NO. LEADING ZEROS
;*************************************************************


	CURNCY="$"	      ;Default floating currency is dollars.

$FOTZS: MOV	BX,OFFSET $FBUFF+1	;ADDRESS OF SIGN(IF LEADING)
	MOV	CH,BYTE PTR 0[BX]	;FETCH LEADING CHARACTER
	MOV	CL,LOW " "      ;SPACE TO CL
	MOV	AH,BYTE PTR $FMTAL	;FETCH FORMAT SPECIFICATIONS
				;BIT    76543210        OF AH
				;       ABCDEFGH        WHERE
				;A=FREE FORMAT FLAG
				;B=GROUP INTEGER DIGITS IN 3'S AND
				;  SEPARATE WITH COMMAS
				;C=FILL LEADING SPACES WITH "*"
				;D=OUTPUT WITH FLOATING "$"
				;E=PRINT SIGN WITH "+" INSTEAD OF" "
				;F=PRINT SIGN AS TRAILING
				;G=UNUSED
				;H=USE SCIENTIFIC NOTATION
	TEST	AH,LOW 40	;WILL TEST FOR LEADING "*" FIRST
	JZ	FZ10		;LEADING ASTERISKS NOT DESIRED IF JMP
	CMP	CH,CL		;SPACE?
	MOV	CL,LOW "*"      ;SINCE IT'S ASTERISK FILL DESIRED
	JNZ	FZ10		;JUMP IF NOT SPACE
	TEST	AH,LOW 4	;WILL NOW CHECK FOR TRAILING SIGN
	JNZ	FZ10
	MOV	CH,CL
FZ10:	MOV	BYTE PTR 0[BX],CL	;REPLACE SIGN AS NECESSARY
	CALL	$CHRGT		;GET NEXT CHARACTER AND SET CONDITION
	JZ	FZ50		;CODES. JUMP IF END OF NUMBER
	MOV	BP,OFFSET $FINCH+11
FZ20:
	CMP	AL,BYTE PTR CS:0[BP]	;SEE IF SPECIAL CHARACTER
	JZ	FZ30		;
	CMP	BP,OFFSET $FINCH	;SEE IF         SEARCHED ALL TABLE
	JZ	FZ60		;IF SO GO CHECK FOR FLOATING "$"
	DEC	BP		;POINT TO NEXT SPECIAL CHARACTER
	JMP	SHORT FZ20	;AND CONTINUE   SEARCH
FZ30:	SUB	BP,OFFSET $FINCH	;CALCULATE TABLE OFFSET
	SHL	BP,1		;TO ACCOUNT FOR 2 BYTE TABLE ENTRY
				;ADD BASE ADDRESS (BP) NOW HAS ADDR.
FZ40:
				;CODE SEGMENT OVERRIDE
	JMP	 WORD PTR CS:FZ45[BP]
FZ45  LABEL WORD
	DW	OFFSET FZ50	;"."
	DW	OFFSET FZ50	;"E"
	DW	OFFSET FZ60	;"E"+40
	DW	OFFSET FZ60	;"%"
	DW	OFFSET FZ60	;"#"
	DW	OFFSET FZ60	;"!"
	DW	OFFSET FZ50	;"D"
	DW	OFFSET FZ60	;"D"+40
	DW	OFFSET FZ10	;","
	DW	OFFSET FZ10	;"0"
FZ50:	DEC	BX		;NEED TO PUT IN LEADING "0"
	MOV	BYTE PTR 0[BX],LOW "0"
FZ60:	MOV	AH,BYTE PTR $FMTAL	;GET FORMAT SPECS AGAIN
	TEST	AH,LOW 20	;TEST FOR FLOATING "$"
				;FLOATING "$" DESIRED?
	JZ	FZ70		;IF NOT PROCEED
	DEC	BX		;
	MOV	BYTE PTR 0[BX],LOW OFFSET CURNCY	;PUT IN FLOATING "$"
FZ70:	TEST	AH,LOW 4	;RECALL FORMAT SPECS
				;SEE IF TRAILING SIGN
	JNZ	FZ90		;IF SO RETURN
	DEC	BX
	MOV	BYTE PTR 0[BX],CH	;PUT IN SIGN
	XOR	CH,CH		;MUST RETURN ZF=1 IF NOT TRAILING
				;SIGN.
FZ90:	RET
$FOTZ:				;PUT (AL) LEADING ZEROS IN BUFFER POINTED TO BY (BX)
	OR	AL,AL		;SEE IF FURTHER WORK TO DO
	JMP	SHORT FTZ15
FTZ10:	MOV	BYTE PTR 0[BX],LOW "0"  ;PUT IN LEADING ZERO
	INC	BX		;NEXT BUFFER POSITION
	DEC	AL
FTZ15:	JNZ	FTZ10
	RET

FTZC10: CALL	$FOTED		;PUT IN COMMA AND DECIMAL POINT AS
				;NECESSARY
$FOTZC: MOV	BYTE PTR 0[BX],LOW "0"  ;PUT IN LEADING ZERO
	INC	BX		;NEXT BUFFER POSITION
	DEC	AL		;
	JNZ	FTZC10
	RET


	SUBTTL	 $PUFE	 PRINT USING FLOATING IN "E" TYPE FORMAT
;************************************************************
;
;       $PUFE   THIS ROUTINE IS CALLED TO FORMAT A SINGLE
;               OR DOUBLE PRECISION NUMBER WITH A DESIRED
;               "E" TYPE OUTPUT FORMAT. FURTHER SPECIFICATIONS
;               CAN BE THE NUMBER DESIRED PRINT POSITIONS
;               TO THE LEFT AND RIGHT OF THE DECIMAL POINT.
;       CALLING SEQUENCE:       CALL    $PUFE
;               WITH (BX) POINTING TO THE CURRENT OUTPUT POSITION
;               AND ZF=1 IF THE OUTPUT NUMBER IS SINGLE
;               PRECISION, ZF=0 IF DOUBLE PRECISION.
;
;*************************************************************

$PUFE:	CALL	$GETYP		;SET CONDITION CODES ACCORDING TO TYPE


	MOV	AH,LOW 7	;7 print positions if single precision

	JB	PFE10		;AND JUMP IF SINGLE PRECISION
	MOV	AH,LOW 20	;IT'S DOUBLE
PFE10:	CALL	$SIGNS		;SET COND CODES ACCORDING TO NO.
	POP	BX		;GET BUFFER PTR IN CASE NO. IS ZERO
	STC			;CF WILL BE OUR FLAG TO REMEMBER
	JZ	PFE20		;IF THE NO. WAS ZERO SINCE $FOTNV
				;WILL RETURN WITH CF=0
	PUSH	BX		;SAVE BUFFER PTR
	PUSH	AX		;SAVE NO. DIGITS IN NUMBER
	CALL	$FOTNV		;BRACKET NO. SO DIGITS TO PRINT ARE
				;IN THE INTEGER PART
	POP	DX		;$FOTNV ALSO RETURNS WITH EXPONENT
				;IN (AL)
	POP	BX		;CF=0
	MOV	AH,DH		;(AH)=NO DIGITS RETURNED FROM $FOTNV
PFE20:	PUSHF			;SAVE CF FLAG IN CASE NO. IS ZERO
	PUSH	AX		;SAVE EXP. AND NO. SIG. DIGITS
	MOV	DX,WORD PTR $FMTCX	;DIG LEFT/RT.OF D.P.
	OR	DH,DH		;WILL NEED TO KNOW IF SIGN DESIRED
	PUSHF
	OR	DL,DL		;SEE IF DECIMAL POINT DESIRED.
	JZ	PFE30		;IF NOT PROCEED
	DEC	DL		;
PFE30:	ADD	DH,DL		;NO. DIGITS DESIRED
	POPF			;SEE IF SIGN DESIRED
	JZ	PFE40		;JUMP IF NOT DESIRED
	TEST	BYTE PTR $FMTAX,LOW 4	;SEE IF TRAILING SIGN DESIRED
	JNZ	PFE40		;IF SO PROCEED
	DEC	DH		;MUST USE ONE PRINT POSITION FOR SIGN
PFE40:	SUB	DH,AH		;MUST SEE IF HAVE EXCESS DIGITS AVAIL.
	MOV	AH,DH		;IF TO MANY WE MUST DIVIDE NO BY
				;10 UNTIL CORRECT DIGITS .
	PUSH	AX		;SAVE COMPAREISON OF DESIRED-AVAILABLE
				;DIGITS. AH IS GREATER THAN 0 IF
				;TRAILING ZEROS.
	JS	PFE45
	JMP	PFE65		;IF NO INTERNAL ROUNDING PROCEED
;*********************************************************************
;WHAT IS HAPPENING HERE IS THAT IF WE HAVE MORE DIGITS THAN REQUIRED
;WE MUST DIVIDE OUT THE EXCESS DIGITS SO THAT WE CAN ROUND AT THE
;CORRECT PRINT POSITION. ONCE WE HAVE PERFORMED THIS DIVISION WE
;WILL NEED TO CALCULATE THE CORRECT DECIMAL POINT POSITION BY ADDING
;THE DESIRED PRINT POSITIONS TO THE LEFT TO THE NUMBER OF POSITIONS
;WE SHIFTED OUT. THE REASON FOR THIS IS THAT REGARDLESS OF THE SIZE
;OF THE NUMBER WE GO TO $FOTCV WITH , A FIXED NUMBER OF DIGITS
;WILL BE PLACED IN THE OUTPUT BUFFER. FOR EXAMPLE, SAY WE REQUESTED
;A PRINT LIKE ##.###^^^^  FOR A SINGLE PRECISION NUMBER. $FOTNV WILL
;PRODUCE AN INTEGER OF 7 DIGITS SAY AXXXXXX WHERE A IS NON-ZERO
;USING THE LEADING POSITION FOR THE SIGN WE NEED ONLY FOUR DIGITS
;PRINTED SO WE NEED IT ROUNDED AT THE FOURTH POSITION. TO DO THIS WE
;DIVIDE THE AXXXXXX BY 10 THREE TIMES TO GET AXXX.XXX  ,  WHEN
;WE GO TO $FOTCV , HE WILL ROUND THIS NUMBER AND PRODUCE AN OUTPUT
; OF   000AXXX  IN THE OUTPUT BUFFER. THE CORRECT PRINT POSITION
;FOR THE DECIMAL POINT IS BETWEEN "A" AND "X". THIS IS CALCULATED
;AS  PRINT POSITION= POSITIONS TO LEFT+SIGN+NO. POSITIONS DIVIDED
;OFF.
;*****************************************************************
PFE45:	PUSH	BX		;SAVE BUFFER PTR.
	PUSH	AX		;SAVE NO TIMES TO DIVIDE
PFE50:	PUSH	AX		;SAVE DIVIDE COUNT
	CALL	$DIV10		;SHIFT NO TO GET CORRECT ROUNDING
	POP	AX		;RECALL DIVIDE COUNT
	INC	AH		;INCREMENT TO REFLECT DIVIDE
	JNZ	PFE50		;CONTINUE UNTIL GET CORRECT NO.
	CALL	$VADDH		;ROUND UP AT THE CORRECT POSITION
	CALL	$VINT		;AND MAKE INTEGER
	POP	AX		;RECALL NO. DIVIDES
	PUSH	AX		;SAVE # DIVIDES
	MOV	CX,3		;WILL SHIFT AH 3 BITS LEFT
	SHL	AH,CL		;BECAUSE DP TABLE IS 8 BYTES/ENTRY
	CALL	$GETYP		;DETERMINE TYPE
	JB	PFE55		;JUMP IF SINGLE PRECISION
	MOV	AL,AH		;WILL CONVERT AH TO WORD IN AX
	CBW
	MOV	BX,OFFSET $DP16 ;ADDRESS OF 10^16
	ADD	BX,AX		;FAC SHOULD BE LESS THAN NO. POINTED
	CALL	$MOVBF		;MOVE CODE SEG NO. TO DBUFF
	CALL	$DCMPM		;TO BY BX
	JMP	SHORT PFE57
PFE55:


	MOV	BX,OFFSET $DP07+4	;address of 10^7

	MOV	AL,AH		;WILL CONVERT AH TO WORD IN AX
	CBW
	ADD	BX,AX		;FAC SHOULD BE LESS THAN THIS NO
	CALL	$MOVBS		;MOVE CODE SEG NO. TO DBUFF
	CALL	$COMPM		;UNLESS ROUND UP HAS OCCURRED
PFE57:	POP	AX		;RECALL NO. DIVIDES. WE MAY NEED
	POP	BX		;GET BUFFER PTR BACK
	JS	PFE66		;ROUND-UP DID NOT OCCUR
	POP	AX		;MUST GET TO ORIGINAL COPY
	POP	CX		;EXPONENT NOW IN CL
	INC	CL		;MUST INCREMENT EXPONENT
	PUSH	CX		;SAVE EXP ON STACK
	PUSH	AX		;SAVE FOR POSSIBLE TRAILING ZEROS
	PUSH	BX		;SAVE BUFFER PTR
	PUSH	AX		;SAVE DIVIDED OUT DIGITS & EXPONENT
	CALL	$DIV10		;SO CORRECT DIGITS TO RIGHT OF
	POP	AX
	POP	BX		;DECIMAL POINT ARE PRINTED
	JMP	SHORT PFE66
PFE65:	XOR	AH,AH		;NO DIVIDES
PFE66:	NEG	AH		;IF PREVIOUSLY NEGATIVE MAKE POSITIVE
	MOV	AL,BYTE PTR $FMTCX+1	;GET DESIRED PLACES TO LEFT OF DEC. PT.
	ADD	AH,AL		;NEW TOTAL
	INC	AH		;BECAUSE FOTED DECREMENTS AT FIRST
	OR	AL,AL		;SEE IF PLACES LEFT DESIRED
	JZ	PFE70
	TEST	BYTE PTR $FMTAX,LOW 4	;SEE IF TRAILING SIGN
	JNZ	PFE70		;IF TRAILING SIGN PROCEED
	DEC	AH		;ALLOW PRINT POSITION FOR SIGN
PFE70:	MOV	CH,AH		;SET DECIMAL POINT POSITION
	XOR	CL,CL		;NO COMMAS FOR EXPONENTIAL PRINTOUT
	POP	AX		;RECALL SIG. DIGIT COMPARISON
	PUSH	WORD PTR $FMTCX ;SAVE FORMAT SPECS
	PUSH	AX		;SAVE SIG. DIGIT COMPARISON
	MOV	BYTE PTR $FMTCX+1,CH	;UPDATE DIGITS TO LEFT
	CALL	$FOTCV		;CONVERT TO ASCII DIGITS
	POP	AX		;RECALL SIG. DIGIT COMPARISON
	OR	AH,AH		;WILL SET SF=0 IF TRAILING ZEROS
	JLE	PFE80		;IF TRAILING ZEROS NOT REQ. JUMP
	MOV	AL,AH		;NO. TRAILING ZEROS TO AL
	CALL	$FOTZC		;put in trailing zeros
	CALL	$FOTED		;put in decimal point (if necessary)
PFE80:	POP	AX		;FETCH DIGITS TO LEFT/RT. OF D.P.
	MOV	WORD PTR $FMTCX,AX	;KEEP COPY FORMAT SPECS
	OR	AL,AL		;SEE IF DECIMAL POINT DESIRED
	JNZ	PFE100		;IF SO PROCEED
	DEC	BX		;NOT DESIRED SEE IF CAN ELIMINATE
	MOV	AL,BYTE PTR 0[BX]	;FETCH LAST PRINT POSITION
	CMP	AL,LOW "."      ;DECIMAL POINT?
	JZ	PFE90		;IF SO THIS JUMP WILL ELIMINATE
	INC	BX		;MUST RETAIN AS IS
PFE90:	MOV	WORD PTR $DPADR,BX	;SAVE ADDRESS OF DECIMAL POINT
PFE100: POP	AX		;RECALL EXPONENT
	POPF			;RECALL CF (=1 IF NO. IS ZERO)
	JB	PFE110		;JUMP IF NO. IS ZERO
	ADD	AL,AH		;ADD EXP. AND NO SIG. DIGITS
	MOV	AH,BYTE PTR $FMTCX+1	;SUBTRACT OUT DIGITS TO LEFT OF D.P.
	SUB	AL,AH		;SUBTRACT DIGITS TO LEFT
	OR	AH,AH		;IF NONE THEN NO SIGN
	JZ	PFE110
	TEST	BYTE PTR $FMTAX,LOW 4	;IF SO WILL NEED TO INCREMENT AL
	JNZ	PFE110
	INC	AL		;MUST ACCOUNT FOR SIGN POSITION
PFE110: OR	AL,AL
	CALL	$PUEXP		;PUT EXPONENT IN BUFFER
				;$PUEXP IS LOCATED IN THE FILE WITH
				;$FOFMT. WHEN HE FINISHES BUILDING
				;THE EXPONENT IN $FBUFF HE LEAVES
				;THE END-OF-BUFFER POINTER IN CX
				;AND START OF BUFFER IN BX.
	MOV	BX,CX		;MUST GO TO PUFXE WITH END OF
				;BUFFER PTR. IN BX
	JMP	$PUFXE		;DO FIX-UP

	SUBTTL	 CON86	 8086 BASIC CONSTANTS
;*****************************************************************
;
;       THIS FILE CONTAINS 8086 CONSTANT TABLES
;
;*****************************************************************
$FOTB:
	.RADIX	10
	DB	38,38,38,38,38,38,38,38
	DB	38,38,38,38,38,38,38,38
	DB	38,38,38,38,38,38,38,38
	DB	38,37,37,37,36,36,36,35
	DB	35,35,34,34,34,34,33,33
	DB	33,32,32,32,31,31,31,31
	DB	30,30,30,29,29,29,29,28
	DB	28,28,27,27,27,26,26,26
	DB	25,25,25,25,24,24,24,23
	DB	23,23,23,22,22,22,22,21
	DB	21,21,20,20,20,19,19,19
	DB	19,18,18,18,17,17,17,16
	DB	16,16,16,15,15,15,14,14
	DB	14,13,13,13,13,12,12,12
	DB	11,11,11,10,10,10,10,09
	DB	09,09,08,08,08,07,07,07
	DB	06,06,06,06,05,05,05,04
	DB	04,04,03,03,03,03,02,02
	DB	02,01,01,01,00,00,00,00
	DB	-01,-01,-01,-02,-02,-02,-03,-03
	DB	-03,-03,-04,-04,-04,-05,-05,-05
	DB	-06,-06,-06,-06,-07,-07,-07,-08
	DB	-08,-08,-09,-09,-09,-09,-10,-10
	DB	-10,-11,-11,-11,-12,-12,-12,-12
	DB	-13,-13,-13,-14,-14,-14,-15,-15
	DB	-15,-15,-16,-16,-16,-17,-17,-17
	DB	-18,-18,-18,-18,-19,-19,-19,-20
	DB	-20,-20,-21,-21,-21,-21,-22,-22
	DB	-22,-23,-23,-23,-24,-24,-24,-25
	DB	-25,-25,-25,-26,-26,-26,-27,-27
	DB	-27,-28,-28,-28,-28,-29,-29,-29
	DB	-30,-30,-30,-31,-31,-31,-31,-32
;****************************************************************
;
;TABLE DXX CONTAINS DOUBLE PRECISION POWERS OF TEN
;FROM -38 TO +38
;
; 20-May-82 / MLC - Most of the negative powers of ten have been
; removed.  Routines which used to multiply by these negative powers of
; ten have been changed to divide by the corresponding positive power
; of ten.  ($FINE and $FOTNV)
;
;*************************************************************
	.RADIX	8
$DPM01: DB	315,314,314,314,314,314,114,175 ;10^-01
$DP00:	DB	000,000,000,000,000,000,000,201 ;10^00
$DP01:	DB	000,000,000,000,000,000,040,204 ;10^01
	DB	000,000,000,000,000,000,110,207 ;10^02
	DB	000,000,000,000,000,000,172,212 ;10^03
	DB	000,000,000,000,000,100,034,216 ;10^04
	DB	000,000,000,000,000,120,103,221 ;10^05
$DP06:	DB	000,000,000,000,000,044,164,224 ;10^06
$DP07:	DB	000,000,000,000,200,226,030,230 ;10^07
	DB	000,000,000,000,040,274,076,233 ;10^08
$DP09:	DB	000,000,000,000,050,153,156,236 ;10^09
	DB	000,000,000,000,371,002,025,242 ;10^10
	DB	000,000,000,100,267,103,072,245 ;10^11
	DB	000,000,000,020,245,324,150,250 ;10^12
	DB	000,000,000,052,347,204,021,254 ;10^13
	DB	000,000,200,364,040,346,065,257 ;10^14
	DB	000,000,240,061,251,137,143,262 ;10^15
$DP16:	DB	000,000,004,277,311,033,016,266 ;10^16
	DB	000,000,305,056,274,242,061,271 ;10^17
	DB	000,100,166,072,153,013,136,274 ;10^18
	DB	000,350,211,004,043,307,012,300 ;10^19
	DB	000,142,254,305,353,170,055,303 ;10^20
	DB	200,172,027,267,046,327,130,306 ;10^21
	DB	220,254,156,062,170,206,007,312 ;10^22
	DB	264,127,012,077,026,150,051,315 ;10^23
	DB	241,355,314,316,033,302,123,320 ;10^24
	DB	205,024,100,141,121,131,004,324 ;10^25
	DB	246,031,220,271,245,157,045,327 ;10^26
	DB	017,040,364,047,217,313,116,332 ;10^27
	DB	012,224,370,170,071,077,001,336 ;10^28
	DB	014,271,066,327,007,217,041,341 ;10^29
	DB	117,147,004,315,311,362,111,344 ;10^30
	DB	043,201,105,100,174,157,174,347 ;10^31
	DB	266,160,053,250,255,305,035,353 ;10^32
	DB	343,114,066,022,031,067,105,356 ;10^33
	DB	034,340,303,126,337,204,166,361 ;10^34
	DB	021,154,072,226,013,023,032,365 ;10^35
	DB	026,007,311,173,316,227,100,370 ;10^36
	DB	333,110,273,032,302,275,160,373 ;10^37
	DB	211,015,265,120,231,166,026,377 ;10^38
$DHALF:			;DOUBLE PRECISION .5D00
	DB	000		;.5D00
	DB	000
	DB	000
	DB	000
$SHALF:			;SINGLE PRECISION .5E00
	DB	000		;.5E00
	DB	000
	DB	000
	DB	200
$SQRH:	DB	361		;SQR(.5)
	DB	004
	DB	065
	DB	200
;**********************************************************
;FOR LOG CALCULATIONS HART ALGORITHM 2524 WILL BE USED
;IN THIS ALGORITHM WE WILL CALCULATE BASE 2 LOG AS FOLLOWS
;LOG(X)=P(X)/Q(X)
;***************************************************************
$LOGP:	DB	4
	DB	232		;4.8114746
	DB	367
	DB	031
	DB	203
	DB	044		;6.105852
	DB	143
	DB	103
	DB	203
	DB	165		;-8.86266
	DB	315
	DB	215
	DB	204
	DB	251		;-2.054667
	DB	177
	DB	203
	DB	202
$LOGQ:	DB	4
	DB	000		;1.
	DB	000
	DB	000
	DB	201
	DB	342		;6.427842
	DB	260
	DB	115
	DB	203
	DB	012		;4.545171
	DB	162
	DB	021
	DB	203
	DB	364		;.3535534
	DB	004
	DB	065
	DB	177
;LOG BASE E OF 2.0
$LN2:	DB	030
	DB	162
	DB	061
	DB	200
$FINCH:			;SPECIAL CHARACTERS FOR INPUT/OUTPUT
	DB	"."
	DB	OFFSET "E"+40   ;LOWER CASE "E"
	DB	"E"
	DB	"%"
	DB	"#"
	DB	"!"
	DB	"D"
	DB	OFFSET "D"+40   ;LOWER CASE "D"
	DB	54		;COMMA
	DB	"0"
$FODTB: DB	000		; 1D15
	DB	200
	DB	306
	DB	244
	DB	176
	DB	215
	DB	003
	DB	000		; 1D14
	DB	100
	DB	172
	DB	020
	DB	363
	DB	132
	DB	000
	DB	000		; 1D13
	DB	240
	DB	162
	DB	116
	DB	030
	DB	011
	DB	000
	DB	000		; 1D12
	DB	020
	DB	245
	DB	324
	DB	350
	DB	000
	DB	000
	DB	000		; 1D11
	DB	350
	DB	166
	DB	110
	DB	027
	DB	000
	DB	000
	DB	000		; 1D10
	DB	344
	DB	013
	DB	124
	DB	002
	DB	000
	DB	000
	DB	000		; 1D9
	DB	312
	DB	232
	DB	073
	DB	000
	DB	000
	DB	000
	DB	000		; 1D8
	DB	341
	DB	365
	DB	005
	DB	000
	DB	000
	DB	000
	DB	200		; 1D7
	DB	226
	DB	230
	DB	000
	DB	000
	DB	000
	DB	000
	DB	100		; 1D6
	DB	102
	DB	017
	DB	000
	DB	000
	DB	000
	DB	000
;SINGLE PRECISION POWER OF TEN TABLE
$FOSTB: DB	100		;1,000,000
	DB	102
	DB	017
	DB	240		; 1E5
	DB	206
	DB	001
	DB	020		; 1E4
	DB	047
	DB	000
;INTEGER POWER OF TEN TABLE
$FOITB: DB	020		; 10000
	DB	047
	DB	350		; 1000
	DB	003
	DB	144		; 100
	DB	000
	DB	012		; 10
	DB	000
	DB	001		; 1
	DB	000
$S32KM: DB	000		;SINGLE PRECISION -32768
	DB	000
	DB	200
	DB	220
$INFPD: DB	377		;DOUBLE PRECISION +INFINITY
	DB	377
	DB	377
	DB	377
	DB	377		;SINGLE PREC. +INFINITY
	DB	377
	DB	177
	DB	377

$INFMD: DB	377		;DOUBLE PRECISION -INFINITY
	DB	377
	DB	377
	DB	377
	DB	377		;SINGLE PREC. -INFINITY
	DB	377
	DB	377
	DB	377
$LG2E:	DB	073		;LOG BASE 2 OF E
	DB	252
	DB	070
	DB	201
;*********************************************************
;$EXPCN CONTAINS THE COEFFICIENTS FOR POLYNOMIAL EVALUATION
;OF LOG BASE 2 OF X WHERE .5.LE.X.LE.1
;THE COEFFICIENTS ARE FROM HART #1302
;***********************************************************
$EXPCN: DB	7		;DEGREE + 1
	DB	174		;.00020745577403-
	DB	210
	DB	131
	DB	164
	DB	340		;.00127100574569-
	DB	227
	DB	046
	DB	167
	DB	304		;.00965065093202+
	DB	035
	DB	036
	DB	172
	DB	136		;.05549656508324+
	DB	120
	DB	143
	DB	174
	DB	032		;.24022713817633-
	DB	376
	DB	165
	DB	176
	DB	030		;.69314717213716+
	DB	162
	DB	061
	DB	200
	DB	000		;1.0
	DB	000
	DB	000
	DB	201
$SINCN:
;       COEFFICIENTS FOR SINE FUNCTION
;       SEE HART'S #3341
;       RELATIVE ERROR 8.27

	DB	5		;NUMBER OF CONSTANTS
	DB	373		;39.71091766+
	DB	327
	DB	036
	DB	206
	DB	145		;-76.57498378-
	DB	046
	DB	231
	DB	207
	DB	130		;81.60223119+
	DB	064
	DB	043
	DB	207
	DB	341		;-41.34167747+
	DB	135
	DB	245
	DB	206
	DB	333		;6.283185272+
	DB	017
	DB	111
	DB	203
$ATNC1:			;CONSTANTS FOR ARCTANGENT RANGE REDUCTION
	DB	2
	DB	327		;SQR(3)
	DB	263
	DB	135
	DB	201
	DB	000		;-1.0
	DB	000
	DB	200
	DB	201
$ATNC2:			;HART ALGORITHM 4940 COEFFICIENTS
	DB	4
	DB	142		;-.1281333
	DB	065
	DB	203
	DB	176
	DB	120		;.1993573
	DB	044
	DB	114
	DB	176
	DB	171		;-.3333324
	DB	251
	DB	252
	DB	177
	DB	000		;1.0
	DB	000
	DB	000
	DB	201
;************************************************************
;THE FOLLOWING CONSTANT LABELED $IN2PI IS USED FOR RANGE
;REDUCTION IN SIN,COS, & TAN. THE LOW ORDER BYTES ARE PURPOSELY
;ZERO TO PROVIDE A MORE ACCURATE REDUCTION OF SINGLE PRECISION
;NUMBERS. THIS CONSTANT SHOULD NOT BE USED WITH ORDINARY DOUBLE
;PRECISION NUMBERS.
;************************************************************
$IN2PI: DB	013		;1/(2*PI)
	DB	104
	DB	116
	DB	156
	DB	203
	DB	371
	DB	042
	DB	176
;***********************************************************
;CONSTANTS FOR THE RANDOM NUMBER GENERATOR FOLLOW
;DO NOT CHANGE THESE WITHOUT CONSULTING KNUTH VOL 2
;CHAPTER 3 FIRST
;************************************************************
$RNDA:	DB	375		;214013
	DB	103
	DB	003
$RNDC:	DB	303		;2531011
	DB	236
	DB	046
$RND0:	DB	001
	DB	000		;1
	DB	000
$NUMB:	DB	"0"	      ;TABLE FOR OCTAL/HEX OUTPUT
	DB	"1"
	DB	"2"
	DB	"3"
	DB	"4"
	DB	"5"
	DB	"6"
	DB	"7"
	DB	"8"
	DB	"9"
	DB	"A"
	DB	"B"
	DB	"C"
	DB	"D"
	DB	"E"
	DB	"F"

	SUBTTL	 $SIN	 SINGLE PRECISION SINE/COSINE/TANGENT/ARCTANGENT
;****************************************************************
;
;       $SIN,$COS,$TAN  CALCULATE THE SINE/COSINE/TAN OF NO.
;                       IN THE $FAC.USES HART POLYNOMIAL EVALUATION
;                       WITH COEFFICIENTS FROM #3341
;       CALLING SEQUENCE:       CALL    $SIN
;                       OR      CALL    $COS
;                       OR      CALL    $TAN
;                       WITH ARGUMENT IN THE $FAC
;
;       $ATAN           CALCULATE THE ARCTANGENT OF THE VALUE IN THE
;                       FAC. USES COEFFICIENTS FROM HART 4940
;       CALLING SEQUENCE:       CALL    $ATAN
;                       WITH THE ARGUMENT IN THE FAC
;
;       Changed COS to double precision range reduction 24-JUN-82/NGT
;
;******************************************************************


COS:
$COS:
	AND	BYTE PTR $FACM1,LOW 177O	;clear sign bit ( cos(-x) = cos(x) )
	CALL	RR		; Do range reduction, FAC=REM(FAC/2pi)
	CALL	ONEARG		; Zero the accumulator
	MOV	BYTE PTR $ARG,LOW 177O	; ARG = DP 1/4
	CALL	$FADDD		; FAC = reduced angle + PI/2
	CALL	RR1		; Make sure we are still in 0 - 2*PI
	JMP	SHORT SIN30

SIN:
$SIN:				;Will now take advantage of identity SIN(-X)=-SIN(X)
	MOV	AX,WORD PTR $FAC-1	;FETCH SIGN BYTE
	CMP	AH,LOW 167O	;IF EXP SMALLER THEN RETURN X
	JNB	SIN10
	RET
SIN10:
	OR	AL,AL
	JNS	SIN20
;(FAC) is negative will make positive and push neg on stack
	AND	AL,LOW 177O	;CLEAR SIGN BYTE
	MOV	BYTE PTR $FAC-1,AL
	MOV	AX,OFFSET $NEG	;FETCH ADDRESS OF NEG
	PUSH	AX		;AND PUSH ON STACK
SIN20:
	CALL	RR		; Do DP range reduction
;
; At this point the FAC has the remainder of the angle / 2*PI
;
SIN30:
	MOV	AL,LOW OFFSET $FAC
	OR	AL,AL
	JZ	SIN31
	ADD	BYTE PTR $FAC,LOW 2	; FAC = FAC*4 = Reduce angle / PI/2
SIN31:
	CALL	RR3		;ARG= INT(FAC)
;
; Now we have the reduced angle mod PI/2, so that we can find what quadrant
; it's in.  The FAC should have a value in the range 0-3 corresponding to
; the quadrant.  If the value is 2 or 3, corresponding to the interval
; PI - 2*PI, we must return a negative value for the Sine.  If the value is
; in quadrants 1 or 3, we must subtract the reduced angle from 1 (PI/2).
; Algorithm:
;       FAC = (angle / (2*PI))*4      ; Yields number in 0.LE.FAC.LT.4
;       Save FAC
;       ARG = INT( FAC )            ; ARG = quadrant 0-3
;       Restore FAC
;       FAC = (FAC - ARG)/4         ; FAC = angle in range 0 - PI/2
;       IF quadrant = 1 or 3 THEN
;           FAC = 1 - FAC           ; FAC = PI/2 - angle
;       Calculate polynomial
;       IF quadrant = 2 or 3 THEN
;           Negate result           ; Negative for PI - 2*PI
;
;         LOW              HIGH (octal bytes)
; D.P. 0 = 0,0,0,0,0,0,000,000
; D.P. 1 = 0,0,0,0,0,0,000,201
; D.P. 2 = 0,0,0,0,0,0,000,202      ; Which implies that FAC = 202 for 2 and 3
; D.P. 3 = 0,0,0,0,0,0,100,202
;
	MOV	AX,WORD PTR $ARG-1
	CMP	AH,LOW 202O	; ARG now has quadrant information
	PUSHF			; Z set if we need to negate when done
	TEST	AH,LOW 1	; Now set NZ if in quadrant 1
	JNZ	SIN40
	TEST	AL,LOW 100O	; Set NZ if in quadrant 3
SIN40:
	PUSHF			; NZ if we must subtract from 1
	CALL	RR2		; FAC = X-INT(X) = angle MOD PI/2
	POPF
	JZ	SIN50		; Nothing more to do, calculate the SIN
	MOV	BX,OFFSET $DP00 ; Point to a D.P. 1 (10^0)
	CALL	$MOVAC		; ARG = 1
	CALL	$FSUBD		; FAC = 1 - FAC = PI/2 - angle MOD PI/2
SIN50:
	SUB	BYTE PTR $FAC,LOW 2	; FAC = FAC/4 = ( angle / 2*PI )
	JNB	SIN51
	CALL	$DZERO		;Return 0 if Underflow
SIN51:
	CALL	$CSD		; Convert DP reduced angle back to SP
	MOV	AL,BYTE PTR $FAC	;WILL SEE IF SMALL ENOUGH
				;SUCH THAT X=SIN(X)
	CMP	AL,LOW 164O	;IF FAC SMALLER THAN THIS JUST
	JNB	SIN60
	MOV	DX,7733O	;2*PI
	MOV	BX,101511O
	CALL	$FMULS
	JMP	SHORT SIN65	; Go set sign properly
SIN60:
	MOV	BX,OFFSET $SINCN	;POINT TO HART 3341 COEFFS.
	CALL	$POLYX		;EVALUATE THE POLYNOMIAL
SIN65:
	POPF			;RECALL SIGN
	JNZ	SIN70
	XOR	BYTE PTR $FAC-1,LOW 200O	;FLIP SIGN
SIN70:
	RET
;
; Converts FAC to double precision and reduces the result to a
; value in the range 0 - 2*PI.
; The RR1 entry point can be used to extract the fractional part of the FAC.
;DOUBLE PRECISION REDUCTION OF RANGE BY 2*PI
;
RR:
	MOV	BX,OFFSET $IN2PI	;POINT TO 1/(2*PI)
	CALL	$MOVAC		;MOVE TO ARG
	CALL	$CDS		;CONVERT TO DOUBLE
	CALL	$FMULD		;X
RR1:
	CALL	RR3
RR2:
	CALL	$FSUBD		;INT(X)-X
	JMP	$NEG		;X-INT(X)
RR3:
	CALL	$VPSHF		;SAVE X
	CALL	$DINT		;($FAC)=INT(X)
	CALL	$MOVAF		;SAVE IN ARG
	CALL	$VPOPF		;FETCH X
	RET
ONEARG:
	MOV	BX,OFFSET $DP00
	JMP	$MOVAC



;
; Tangent Code
;
TAN:
$TAN:	PUSH	WORD PTR $FACM1 ;SAVE ARG
	PUSH	WORD PTR $FACLO
	CALL	$SIN		;CALCULATE SINE
	POP	DX		;RECALL ARGUMENT
	POP	BX
	PUSH	WORD PTR $FACLO ;SAVE SIN(X)
	PUSH	WORD PTR $FACM1
	CALL	$MOVFR		;MOVE ORIGINAL ARG TO FAC
	CALL	$COS		;CALCULATE COSINE
	POP	BX		;RECALL SIN(X)
	POP	DX
	JMP	$FDIVS		;GO DIVIDE TO EFFECT TANGENT
ATN:
$ATAN:				;(FAC)=ARCTANGENT(FAC)
	MOV	AX,WORD PTR $FAC-1	;WANT ONLY POSITIVE X
	OR	AL,AL
	JNS	ATN10
	MOV	DI,OFFSET $NEG	;TAKE ADVANTAGE OF IDENTITY
	PUSH	DI		;ATAN(X)=-ATAN(-X)
	AND	AL,LOW 177	;CLEAR SIGN
	MOV	BYTE PTR $FAC-1,AL
ATN10:	CMP	AH,LOW 201	;SEE IF X .GT. TAN(PI/4)
	JB	ATN20		;IF NOT PROCEED
	MOV	DI,OFFSET ATN100	;WILL WANT TO FORM
	PUSH	DI		;PI/2-(FAC) AT THE END
	XOR	DX,DX		;WILL SET (BXDX)=1.0
	MOV	BX,100400
	CALL	$FDIVS		;THIS PUTS 1/X IN FAC
ATN20:	MOV	DX,30242	;FETCH TAN(PI/12)
	MOV	BX,77411
	CALL	$FCOMP		;SEE IF LARGER
	JS	ATN30		;IF NOT PROCEED
	MOV	DI,OFFSET ATN200	;WILL WANT (FAC)=(FAC)+PI/6
	PUSH	DI		;AT THE END
	PUSH	WORD PTR $FACLO ;SAVE X
	PUSH	WORD PTR $FACM1
	MOV	DX,131727	;FETCH SQR(3)
	MOV	BX,100535
	CALL	$FADDS		;(FAC)=X+SQR(3)
	POP	BX
	POP	DX		;FETCH X BACK
	PUSH	WORD PTR $FACLO ;SAVE X+SQR(3)
	PUSH	WORD PTR $FACM1
	CALL	$MOVFR		;X TO FAC
	MOV	BX,OFFSET $ATNC1
	CALL	$POLY		;FORM X*SQR(3)-1
	POP	BX
	POP	DX		;RECALL X+SQR(3)
	PUSH	WORD PTR $FACLO ;PUSH X*SQR(3)-1 ON STACK
	PUSH	WORD PTR $FACM1
	CALL	$MOVFR		;X+SQR(3) TO FAC
	POP	BX
	POP	DX		;RECALL X*SQR(3)-1
	CALL	$FDIVS		;FORM (X+SQR(3)-1)/(X+SQR(3))
ATN30:	MOV	BX,OFFSET $ATNC2	;PREPARE FOR HART 4940
	JMP	$POLYX
ATN100: MOV	DX,7733	;FETCH PI/2
	MOV	BX,100511
	JMP	$FSUBS		;(FAC)=PI/2-(FAC)

ATN200: MOV	DX,5222	;FETCH PI/6
	MOV	BX,100006
	JMP	$FADDS		;ADD PI/6 TO FAC

	SUBTTL	 $FINE	 ROUTINE TO ADJUST INPUT NUMBER FOR EXPONENT
;****************************************************************
;
;       $FINE   THIS ROUTINE MODIFIES THE CURRENT FAC WHICH HAS
;               THE INPUT SIGNIFICANT DIGITS SO THAT THE EXPONENT
;               IS REFLECTED IN THE NUMBER. FOR EXAMPLE, IF THE
;               NUMBER INPUT IS 1.9876E-17 THEN THE FAC CURRENTLY
;               HAS THE NUMBER 19876. IT MUST BE MULTIPLIED BY
;               10^-21 TO CORRECTLY REFLECT THE INPUT NUMBER.
;               IT IS THE JOB OF THIS ROUTINE TO DETERMINE THE
;               CORRECT MULTIPLIER AND PERFORM THE MULTIPLICATION
;       CALLING SEQUENCE        CALL    $FINE
;               WITH (SI) CONTAINING 0 IF POSITIVE EXPONENT
;               ALL BITS SET IF NEGATIVE EXPONENT. (DX) CONTAINS
;               THE INPUT EXPONENT(FOR THE EXAMPLE ABOVE =17)
;               AND (DI) CONTAINS THE NUMBER PLACES TO THE RIGHT
;               OF THE DECIMAL POINT.
;
;*****************************************************************

$FINE:	OR	SI,SI		;SEE IF DX SHOULD BE NEGATED
	JNS	FIN05		;IF NOT PROCEED
	NEG	DX		;NEGATE
FIN05:	SUB	DX,DI		;SUBTRACT OUT DIGITS TO RIGHT OF DP.
	JO	FIN80		;UNDERFLOW IF OVERFLOW FLAG SET
	JZ	FIN55		;NUMBER COMPLETE AS IS
;***************************************************************
;HERE WE HAVE THE EXPONENT IN DX. WE HAVE MULTIPLIERS RANGING
;FROM (10^-38,10^38) TO USE IN DETERMINING THE CORRECT FAC. WE
;MAY NEED TO DO SEVERAL MULTIPLIES TO CORRECTLY FORM THE NUMBER.
;FOR EXAMPLE IF THE NUMBER INPUT WAS 1234567.E-40 DX WOULD
;HAVE -40. IF THIS WERE THE CASE WE NEED TO DO A MULTIPLY BY 10^-38
;THEN A MULTIPLY BY 10^-2 TO GET THE RIGHT NUMBER.
;  All calculations are done in double precision and then converted
;back to the original type.  Integers are converted to single precision.
;****************************************************************
MDPTEN:
	PUSH	BX		; Preserve text pointer
	CALL	$GETYP		; Get the current type,
	PUSHF			; And save, so that we can convert back
	JNB	FIN20		; If already D.P., no conversion necessary
	CALL	FRCDBL		; Force result to be double precision
FIN20:	OR	DX,DX		; Test sign of exponent
	JS	FIN30		;IF NEGATIVE EXPONENT JUMP
;********************************************************************
;POSITIVE EXPONENT . IF GREATER THAN D^38 THEN WE HAVE OVERFLOW
; Unless the number is zero, in which case just return zero.
;********************************************************************
	TEST	BYTE PTR $FAC,LOW 377O	;Is the number zero?
	JZ	FIN80		;Yes, just return zero then.
	CMP	DX,39D
	JB	FIN40		;OK PROCEED
	POPF			; Get back type flags
	JNB	FIN25		; Already D.P., nothing to convert
	CALL	$CSD		; Convert double to single
FIN25:	POP	BX		; Restore text pointer
	JMP	$OVFLS		;OVERFLOW
;
; Negative exponent.
; Might require two divisions since highest table entry is 10^38.
;
FIN30:	CMP	DX,-38D	;Will one pass be enough?
	JGE	FIN40		;Yes.
	ADD	DX,38D		;No, will two divisions get it?
	CMP	DX,-38D
	JL	FIN80		;No, underflow - return zero.
	CALL	MDP10		;Yes, do the first one
	MOV	DX,-38D	;Then divide by 10^38.
FIN40:	CALL	MDP10		; Do the division
FIN45:	POPF			; Get back type flags
	JNB	FIN50		; Already D.P., nothing to convert
	CALL	$CSD		; Convert double to single

; At this point the number is restored to its original type, with the
; exception of integers being converted to single precision.

FIN50:	POP	BX		; Restore text pointer
FIN55:	RET

FIN80:	CALL	$ZERO		;UNDERFLOW!
	JMP	SHORT FIN45	; Restore proper type

;
; Multiply or divide by double precision power of ten.
; On entry DX contains the exponent.
; If the exponent is postive, multiply.
; If exponent is negaive, divide.
;

MDP10:
	OR	DX,DX		;Is the exponent negative?
	PUSHF			;Remember whether to multiply or
				;divide.
	JNS	POSEXP		;Positive exponent.
	NEG	DX		;Negative exponent, make it positive.
POSEXP: MOV	CX,3		;DX:=DX*8 to get offset into powers
	SHL	DX,CL		;of ten table.
	ADD	DX,OFFSET $DP00 ;DX:=pointer to power of ten.
	XCHG	BX,DX		;Move it to BX.
	CALL	$MOVAC		;MOVE D.P. NO. TO ARG
	POPF			;Divide?
	JS	DBLDIV		;Yes.
	JMP	$FMULD		;No, multiply and return to caller
DBLDIV: JMP	DDIVFA		;Double precision divide; FAC=FAC/ARG,
				; Return to caller.


	SUBTTL	 $OVFLS  OVERFLOW CODE
;***********************************************************
;
;       $OVFLS  PLACES CORRECT INFINITY IN THE FAC AND PRINTS
;               OVERFLOW MESSAGE
;
;       $DIV0S  PLACES CORRECT INFINITY IN THE FAC AND PRINTS
;               DIVIDE-BY-ZERO MESSAGE
;
;***********************************************************

$OVFLS: PUSH	BX
	CALL	OVFLS		;DO THE OVERFLOW CODE
	POP	BX		;RESTORE TEXT POINTER
	RET
OVFLS:	CALL	DOINF		;PUT IN APPROPRIATE INFINITY
	MOV	AX,OFFSET OVERR ;Error trapping routine adr
	MOV	BX,OFFSET $OVMSG	;ADDRESS APPROPRIATE ERROR MESSAGE
	JMP	SHORT DV010	;GO PRINT MESSAGE
$DIV0S: PUSH	BX		;SAVE TEXT POINTER
	CALL	DIV0S		;DO THE DIVIDE OVERFLOW CODE
	POP	BX
	RET			;RETURN WITH TEXT POINTER SAVED
DIV0S:	CALL	DOINF		;PUT IN APPROPRIATE INFINITY
	MOV	AX,OFFSET DV0ERR	;Error trapping routine adr
	MOV	BX,OFFSET $DIV0M	;AND ERROR MESSAGE
DV010:	CALL	TRAPER		;Trap error if error trapping enabled
	CMP	BYTE PTR $FLGOV,LOW 1	;IF 0,1 PRINT, IF 1 MAKE 2
	JS	DV015		;PRINT IF 0
	JNZ	DV020		;DON'T PRINT IF 2
	MOV	BYTE PTR $FLGOV,LOW 2	;MAKE 2 IF 1
DV015:	CALL	$STPRN
	MOV	AL,LOW 15	;CARRIAGE RETURN
	CALL	$CATTY		;SEND IT
	MOV	AL,LOW 12	;LINE FEED
	CALL	$CATTY		;SEND IT
DV020:	RET

DOINF:				;PUT CORRECT INFINITY IN THE FAC
	CLD			;CLEAR THE DIRECTION FLAG "DF"
	OR	BH,BH		;SEE IF ZERO TO A NEG POWER
	MOV	SI,OFFSET $INFPD	;ASSUME POSITIVE
	JZ	INF10		;POSITIVE INFINITY FOR ZERO^-X
	TEST	BYTE PTR $FAC+1,LOW 200 ;NEGATIVE?
	JNS	INF10		;IF NOT PROCEED
	MOV	SI,OFFSET $INFMD	;NEGATIVE INFINITY
INF10:	CALL	$GETYP		;SET CODES ACCORDING TO TYPE
	JB	INF20
;***********************************************************
;IT'S DOUBLE PRECISION
;***********************************************************
	MOV	DI,OFFSET $DFACL	;RECEIPIENT
	MOV	CX,4		;4 WORDS FOR DOUBLE PRECISION
	JMP	SHORT INF30
INF20:				;SINGLE PRECISION
	ADD	SI,4		;SO WE POINT TO SINGLE PRECISION NO.
	MOV	DI,OFFSET $FACLO
	MOV	CX,2		;2 WORDS FOR SINGLE
INF30:				;MUST FETCH FROM CODE SEGMENT
	MOVS	?CSLAB,WORD PTR ?CSLAB	;TO FAC
	LOOP	INF30
	RET

TRAPER: PUSH	AX		;save Error trapping routine adr
	MOV	AX,WORD PTR ONELIN
	OR	AX,AX		;see if we are trapping errors
	JNZ	TRAPIT		;branch if errors are being trapped
	POP	AX		;discard Error trapping routine adr
TRAPIT: RET			;return to caller or Error trap routine

	SUBTTL	 $FOFMT  FLOATING FORMAT OF NUMBER IN THE FAC
;**************************************************************
;
;       $FOFMT  FORMAT THE NUMBER IN THE FAC. IF THE NUMBER CAN BE
;               AS ACCURATELY REPRESENTED IN FIXED FORMAT AS
;               SCIENTIFIC THEN USE FIXED OUTPUT.
;       CALLING SEQUENCE:       CALL    $FOFMT
;               WITH (BX) POINTING TO CURRENT OUTPUT POSITION
;               IN THE OUTPUT BUFFER $FBUFF AND CONDITION CODES
;               SET AS IF $GETYP WAS JUST CALLED
;
;*****************************************************************

$FOFMT: PUSH	BX		;SAVE BUFFER POINTER


	MOV	AL,LOW 8D	;assume single precision - print 7 digits

	JB	FFM10		;JUMP IF SINGLE PRECISION
	MOV	AL,LOW 17D	;DOUBLE PRECISION POSSIBLE DIGITS
FFM10:	MOV	CH,AL		;WILL SAVE A SECOND COPY FOR LATER
	MOV	CL,AL
	PUSH	CX		;SAVE FOR LATER
	PUSHF			;SAVE TYPE
	CALL	$FOTNV		;BRACKET THE NUMBER SO THAT SIGNIFICANT
				;DIGITS ARE IN THE INTEGER PART AND
				;THE NECESSARY EXPONENT IS IN (AL)
	OR	AL,AL		;IF POSITIVE DON'T CALL SIGD
	JZ	FFM11
	JNS	FFM15
FFM11:	POPF			;RECALL TYPE FOR TEST TO SEE IF SIGD
				;CALLED. IF S.P. AND (AL) SMALLER THAN
				;-7 MUST CALL SIG, IF D.P. AND (AL)
				;SMALLER THAN -16 THEN MUST CALL SIGD.
				;IF (AL) POSITIVE SIGD WILL NOT BE
				;CALLED. PURPOSE OF SIGD IS TO
				;DETERMINE WHETHER WE CAN PRINT NO. IN
				;FIXED FORMAT W/O LOSING SIGNIFICANT
				;DIGITS.
	POP	CX		;RECALL POSIBLE SIGNIFICANT SIGITS
	PUSH	AX		;SAVE EXP.
	JPO	FFM16		;SINGLE PREC.
	ADD	AL,LOW 16D	;THIS MUST MAKE POSITIVE TO NOT CALL
	POP	AX
	JNS	FFM18		;POP AX AND DO FIXED OUTPUT
	JMP	SHORT FFM17	;MUST CALL SIGD
FFM15:
	POPF			;RECALL TYPE FLAG
	POP	CX		;RECALL CX
	JMP	SHORT FFM20
FFM16:
	ADD	AL,LOW 7
	POP	AX
	JNS	FFM18
FFM17:
	PUSH	AX		;SAVE NECESSARY EXPONENT IN (AL)
	CALL	$SIGD		;INCREMENT (CL) FOR EACH ZERO DIGIT
				;BEGINNING FROM THE RIGHT
	POP	AX		;RECALL NECESSARY EXPONENT
	MOV	AH,AL		;WILL PERFORM FIRST TEST ON AH
	ADD	AH,CL		;IF SF=1 AFTER THIS THEN USE "E" FORMAT
	JLE	FFM20		;JUMP IF TOO SMALL
	ADD	CH,AL
	JMP	SHORT FFM19
FFM18:	ADD	AL,CH
	INC	CH
	CMP	CH,AL
	MOV	CH,LOW 3	;TO FLAG "E" FORMAT IF NECESSARY
	JB	FFM30
	MOV	CH,AL
FFM19:	INC	CH		;(CH)= NUMBER DIGITS+2
	MOV	AL,LOW 2	;THIS WILL CAUSE ZF=1 IN LATER CALC
				;AND WILL SIGNAL FIXED OUTPUT
	JMP	SHORT FFM30
FFM20:	ADD	AL,CH
	MOV	CH,LOW 3	;SIGNALS "E" TYPE FORMAT
FFM30:	DEC	AL		;(AL) 2 TOO LARGE
	DEC	AL
	POP	BX		;RECALL BUFFER POINTER
	PUSH	AX		;SAVE EXPONENT
	PUSHF			;SAVE CONDITION CODES
	XOR	CL,CL		;(CL)=0  (NO COMMAS AFTER EACH 3 DIGITS
	CALL	$FOTAN		;PUT IN DECIMAL POINT AND LEADING
				;ZEROS AS NECESSARY
	MOV	BYTE PTR 0[BX],LOW "0"  ;ZF=1 IF THIS "0" NECESSARY
	JNZ	FFM40
	INC	BX
FFM40:	CALL	$FOTCV		;CONVERT THE FAC TO DECIMAL DIGITS
				;AND PUT IN DECIMAL POINT AS NECESSARY
FFM50:	DEC	BX		;WILL NOW SEE IF THERE ARE TRAILING
	CMP	BYTE PTR 0[BX],LOW "0"  ;ZEROS TO SUPPRESS. WE KNOW ZEROS WE
	JZ	FFM50		;FIND HERE ARE TRAILING BECAUSE $FOTCV
	CMP	BYTE PTR 0[BX],LOW "."  ;PUTS IN DECIMAL POINT
	JZ	FFM60		;CAN WE DELETE THE DECIMAL POINT ALSO?
	INC	BX		;
FFM60:	POPF			;LET'S HAVE A LOOK AT THE POSSIBLE
				;EXPONENT
	POP	AX
	JZ	FFM100		;IF NO EXPONENT JUST CLEAN-UP AND RET
$PUEXP: PUSHF			;SAVE SF( IF =1 NEGATIVE EXPONENT)
	PUSH	AX		;SAVE EXPONENT
	CALL	$GETYP		;SET COND. CODES FOR TYPE NUMBER
	MOV	AH,LOW "E"      ;ASSUME SINGLE PRECISION
	JPO	FFM70		;IF S.P. PROCEED
	MOV	AH,LOW "D"      ;IT'S DOUBLE PRECISION
FFM70:	MOV	BYTE PTR 0[BX],AH	;PUT IN EXPONENT DESIGNATOR
	INC	BX		;POINT TO NEXT BUFFER POSITION
	POP	AX		;RECALL EXPONENT
	POPF			;NOW TO SEE IF POSITIVE OR NEGATIVE
	MOV	BYTE PTR 0[BX],LOW "+"  ;ASSUME POSITIVE EXPONENT
	JNS	FFM80		;AND JUMP IF SO
	MOV	BYTE PTR 0[BX],LOW "-"
	NEG	AL		;MUST MAKE EXPONENT POSITIVE
FFM80:	MOV	AH,LOW OFFSET "0"-1     ;WILL BUILD DIGIT IN (AL)
FFM90:	INC	AH		;INCREMENT TO NEXT DIGIT
	SUB	AL,LOW 10D	;
	JNB	FFM90
	ADD	AL,LOW OFFSET "0"+10D   ;ADD TO DETERMINE SECOND DIGIT
	INC	BX		;POINT TO NEXT BUFFER POSITION
	XCHG	AL,AH		;PREPARE FOR WORD STORE
	MOV	WORD PTR 0[BX],AX	;STORE 2 DIGITS OF EXPONENT
	INC	BX		;INCREMENT TO NEXT BUFFER POSITION
	INC	BX
FFM100: MOV	BYTE PTR 0[BX],LOW 0	;SIGNAL END OF BUFFER DATA
	XCHG	BX,CX		;END-OF-BUFFER PTR. IN (CX)
	MOV	BX,OFFSET $FBUFF+1	;START IN (BX)
	RET

	SUBTTL	 UTILS	   UTILITY ROUTINES



;string printer must fetch from code segment
STOULP: CALL	OUTDO		;send char
	CMP	AL,LOW 13D	;carriage return?
	JNZ	STROUT		;no
	CALL	CRFIN		;force carriage back to left
STROUT:			;fetch from code segment
	MOV	AL,BYTE PTR CS:0[BX]	;get char
	INC	BX		;point at next one
	OR	AL,AL		;end of string?
	JNZ	STOULP		;no print char until done
	RET
$DZERO:			;DOUBLE PRECISION ZERO
	MOV	DI,OFFSET $DFACL
	MOV	CX,4
	MOV	AX,0
	CLD
 REP	STOSW
	RET

ZERO:
$ZERO:				;ZERO THE FAC
	MOV	AX,0
	MOV	WORD PTR $FACLO,AX	;ZERO LOWER 2 BYTES
	MOV	WORD PTR $FAC-1,AX	;ZERO UPPER TWO BYTES
	RET

SIGN:
$SIGNS:			;DETERMINE SIGN OF FAC
				;ZF=1 IF ($FAC)=0, SF=1 IF ($FAC) .LT.0, NEITHER OF
				;THESE FLAGS SET IF ($FAC).GT.0
	CALL	$GETYP		;IF NOT INTEGER CAN LOOK AT FAC:FAC-1
	JNE	SIS01
	JMP	TMERR		;Strings illegal 9-Mar-82/ngt
SIS01:
	JNS	SIS05		;NOT INTEGER PROCEED
	MOV	AX,WORD PTR $FACLO	;FETCH INTEGER
	OR	AX,AX		;DETERMINE SIGN
	JZ	SIS10
	MOV	AL,LOW 1
	JNS	SIS10
	NEG	AL
	RET
SIS05:
	MOV	AL,BYTE PTR $FAC	;FIRST CHECK FOR ZERO
	OR	AL,AL
	JZ	SIS10		;IF ZERO JUST RETURN
	MOV	AL,BYTE PTR $FAC-1	;FETCH SIGN BYTE
SIGNAL: OR	AL,AL		;SIGNSET NOW
	JZ	SIS07		;MUST MAKE AL=1 AND ZF=0
	MOV	AL,LOW 1
	JNS	SIS10
	NEG	AL
	RET
SIS07:	OR	AL,LOW 1	;KNOW POSITIVE NON-ZERO
SIS10:	RET

;
; Set cond. codes according to type value.
;   S, C = Integer
;   Z, C = String
;      C = Single Precision
;   None = Double Precision
;
$GETYP:
	MOV	AL,BYTE PTR $VALTP	;FETCH TYPE VARIABLE
	CMP	AL,LOW 10	;CF=1 EXCEPT FOR DOUBLE PREC.
	DEC	AL		;WILL SUBTRACT 3 WITH DECBREMENTS
	DEC	AL
	DEC	AL
	RET			;ZF=1 IF STRING,SF=1 IF INTEGER
				;PO=1 IF SINGLE PREC

$VADDH:			;ADD .5 ACCORDING TO TYPE
	CALL	$GETYP		;SET CODES ACCORDING TO TYPE
	JB	$FADDH
$DADDH:			;DOUBLE PRECISION ADD .5
	PUSH	BX
	MOV	BX,OFFSET $DHALF
	CALL	$MOVAC		;MOVE TO ARG
	CALL	$FADDD		;ADD TO FAC
	POP	BX
	RET
$FADDH:			;SINGLE PRECISION ADD .5
	XOR	DX,DX		;WILL SET (BXDX)=.5
	MOV	BX,100000
	CALL	$FADDS		;ADD .5 TO FAC
	RET
$DIV10:			;DIVIDE FAC BY 10
	CALL	$GETYP
	MOV	BX,OFFSET $DPM01	;ADDRESS .1
	JB	ML10
	JMP	SHORT ML05	;MULTIPLY

$MUL10:			;MULTIPLY THE FAC BY 10
	CALL	$GETYP		;SEE IF SINGLE OR DOUBLE PREC
	MOV	BX,OFFSET $DP01 ;ADDRESS OF DOUBLE PREC 10.
	JB	ML10		;JUMP IF SINGLE
ML05:	CALL	$MOVAC		;MOVE 10. TO ARG
	CALL	$FMULD		;MULTIPLY
	RET
ML10:				;MULTIPLY SINGLE PREC. FAC BY NO. POINTED TO BY BX
$MLSP:
	PUSH	WORD PTR $FACM1 ;PUSH FAC ON THE STACK
	PUSH	WORD PTR $FACLO
	MOV	BYTE PTR $VALTP,LOW 10	;SET UP D.P.
	CALL	$MOVFC		;MOVE DOUBLE PREC. 10 TO FAC
	CALL	$CSD		;CONVERT TO SINGLE PRECISION
	POP	DX		;GET LOW MANTISSA BITS
	POP	BX		;EXP SIGN AND HIGH MATISSA BITS
	CALL	$FMULS		;MULTIPLY
	RET


$RDL:	MOV	CX,4		;WILL SHIFT 4 WORDS LEFT
RDL120: RCL	WORD PTR 0[BX],1	;SHIFT  LEFT 1 BIT SHIFTING IN CF
	INC	BX
	INC	BX
	LOOP	RDL120
	RET
$SHDR:	MOV	CX,4		;DO DOUBLE PRECISION RIGHT SHIFT
$SHRM:				;SHIFT NO. POINTED TO BY (BX) , (CX) WDS RT.
	RCR	WORD PTR 0[BX],1	;SHIFT 1 WD. RT. THRU CF
	DEC	BX
	DEC	BX		;TO NEXT WD.
	LOOP	$SHRM		;DO THIS (CX) TIMES
	RET
SHST:	OR	BYTE PTR 2[BX],LOW 40	;"OR" IN ST BIT
	LOOP	$SHRA
	RET
$SHRA:				;SHIFT $ARG RIGHT (CX) BITS
	MOV	BX,OFFSET $ARG-2
	CMP	CL,LOW 10	;CAN I DO A BYTE MOVE
	JB	SHRA30		;IF NOT PROCEED AS NORMAL
;*************************************************************
;FOR SPEED PURPOSES WE WILL DO A BYTE MOVE TO THE RIGHT
;*************************************************************
	PUSH	CX		;SAVE BITS TO SHIFT
	MOV	CX,7		;7 BYTE MOVE
	MOV	BX,OFFSET $ARGLO-1
	MOV	AH,BYTE PTR 0[BX]	;FETCH OVERFLOW BYTE
SHRA11: MOV	AL,BYTE PTR 1[BX]
	MOV	BYTE PTR 0[BX],AL
	INC	BX
	LOOP	SHRA11
	XOR	AL,AL
	MOV	BYTE PTR 0[BX],AL
	POP	CX		;RECALL BIT COUNT
	SUB	CL,LOW 10
	AND	AH,LOW 40	;WILL NEED TO RE-ESTABLISH ST
	JZ	$SHRA		;NO-ST JUST PROCEED
	OR	BYTE PTR $ARGLO-1,AH
	JMP	$SHRA
SHRA30:
	OR	CL,CL
	JZ	SHRA40		;JUMP IF DONE
	PUSH	CX		;SAVE NO. BITS TO SHIFT
	CLC			;DON'T WANT THE CARRY SHIFTED IN
	CALL	$SHDR
	POP	CX
	TEST	BYTE PTR 2[BX],LOW 20	;SEE IF SHIFTED THRU "ST"
	JNZ	SHST		;MUST "OR" ST BIT IN IF NON-ZERO
	LOOP	$SHRA
SHRA40: RET


$XCGAF: MOV	SI,OFFSET $DFACL	;WILL EXCHANGE FAC AND ARG (D.P.)
	MOV	DI,OFFSET $ARGLO
	CLD			;SO MOVW WILL INCREMENT INDICES
	MOV	CX,4		;WILL MOVE 4 WORDS (8 BYTES)
XCG10:	MOV	AX,WORD PTR 0[DI]	;FETCH DESTINATION WORD
	MOVSW			;MOVE FAC TO ARG & INCREMENT INDICES
	MOV	WORD PTR -2[SI],AX	;ARG TO FAC
	LOOP	XCG10		;CONTINUE
	RET

;*********************************************************************
;       SPECIAL MOVE ROUTINES FOR HANDLING CONSTANTS FROM THE CODE
;       SEGMENT
;*********************************************************************
$MOVBS:			;THIS ROUTINE IS USED TO MOVE A SINGLE PRECISION NO. FROM THE
				;CODE SEGMENT TO $DBUFF. THE NO. IS POINTED TO BY (BX)
	MOV	DI,OFFSET $DBUFF+4
	MOV	CX,2
	JMP	SHORT MBF10
$MOVBF:			;THIS ROUTINE IS USED TO MOVE A DOUBLE PRECISION NO. FROM THE
				;CODE SEGMENT TO $DBUFF. THE NO. IS POINTED TO BY (BX)
	MOV	DI,OFFSET $DBUFF
MBF05:	MOV	CX,4
MBF10:	CLD
	MOV	SI,BX		;SO WE CAN USE A LODW
MBF20:
	LODS	WORD PTR ?CSLAB ;FETCH FROM CS
	STOSW			;STORE IN DBUFF
	LOOP	MBF20		;CONTINUE WITH MOVE
	MOV	BX,DI		;UPDATE (BX)
	SUB	BX,2		;GET POINTER CORRECT
	RET

$MOVAC:			;ROUTINE TO MOVE A DOUBLE PRECISION NO. POINTED TO BY (BX)
				;FROM THE CODE SEGMENT TO ARG
	MOV	DI,OFFSET $ARGLO
	JMP	SHORT MBF05

$MOVFC:			;ROUTINE USED TO MOVE A DOUBLE PRECISION NO. FROM THE CODE
				;SEGMENT TO THE FAC. NO. IS POINTED TO BY (BX)
	MOV	DI,OFFSET $DFACL
	JMP	SHORT MBF05

MOVAM:				;MOVE NO. POINTED TO BY BX TO ARG
	MOV	DI,OFFSET $ARGLO	;LOW ADDRESS OF ARG
	MOV	CX,4		;MOVE DOUBLE PREC NO. POINTED TO
				;BY (BX) TO DOUBLE PREC NO. POINTED TO
				;BY (DI)
MOVEM:				;MOVE NO. POINTED TO BY (BX) TO NO. POINTED TO BY (DI)
				;FOR (CX) WORDS
	XCHG	BX,SI		;SO MOVW CAN BE USED
	CLD			;SO MOVW WILL INC
		     ;DO MOVE (CX) TIMES
 REP	MOVSW			;MOVE "FROM" TO "TO"
	XCHG	BX,SI		;GET REGISTERS STRAIGHT
	RET

$MOVAF:			;MOVE THE $FAC TO $ARG
	PUSH	CX		;SAVE CX,BX,DI
	PUSH	BX
	PUSH	DI
	MOV	BX,OFFSET $DFACL	;"FROM" ADDRESS
	MOV	DI,OFFSET $ARGLO	;"TO" ADDRESS
MAF05:	MOV	CX,4		;4 16-BIT QUANTITIES TO MOVE
	CALL	MOVEM		;DO THE MOVE
	POP	DI
	POP	BX
	POP	CX		;REGISTERS RESTORED
	RET



$MOVFA:			;MOVE THE $ARG TO THE FAC
	PUSH	CX
	PUSH	BX
	PUSH	DI		;SAVE REGISTERS
	MOV	BX,OFFSET $ARGLO	;"FROM" ADDRESS
	MOV	DI,OFFSET $DFACL	;"TO" ADDRESS
	JMP	SHORT MAF05	;GO MOVE
;**************************************************************
;SINGLE PRECISION MOVE ROUTINES
;***************************************************************
$MOVFR:			;MOVE (BXDX) TO FAC
	MOV	WORD PTR $FACLO,DX
	MOV	WORD PTR $FAC-1,BX
	RET

$MOVRF:			;MOVE THE FAC INTO REGISTERS (BXDX)
	MOV	DX,WORD PTR $FACLO
	MOV	BX,WORD PTR $FAC-1
	RET
	PAGE
;
; ZCMPCK is called by the comparison routines to handle the
; cases where the exponent of either or both of the numbers
; is zero.  These must be treated as special cases because
; a number whose exponent is zero is zero regardless of the
; garbage that might be in the mantissa.
;
; On entry -    BH=exponent of comperand
;               Bit 7 of BL=sign of comperand
;
; On exit -     Carry clear - caller must continue comparison.
;
;               Carry set - comparison is finished.
;               A=1, Z=0, S=0 for FAC .GT. comperand
;               A=0, Z=1 for FAC .EQ. comperand
;               A=377 octal, Z=0, S=1 for FAC .LT. comperand
;

ZCMPCK: OR	BH,BH		;Is the comperand zero?
	JNZ	NZCOMP		;No.
	CALL	SIS05		;Yes, result is the sign of the FAC.
	STC			;Set carry to say comparison is done
	RET			;and return.

NZCOMP: MOV	AL,BYTE PTR $FAC	;Is the FAC zero?
	OR	AL,AL		;(Also clear carry.)
	JNZ	ZCMPRT		;No, return with carry clear to tell
				;the caller he must continue.
	MOV	AL,BL		;Yes, the result is the opposite
	NOT	AL		;of the sign of the comperand.
	CALL	SIGNAL
	STC			;Set carry to say comparison is
ZCMPRT: RET			;finished and return.

;
; ZCMPBX performs the special zero check for the case where
; BX points to the comperand.
;

ZCMPBX: PUSH	BX		;Preserve the comperand pointer.
	MOV	BX,WORD PTR 0[BX]	;BH:=exponent, BL bit 7:=sign for
				;ZCMPCK.
	CALL	ZCMPCK		;Check for the zero cases.
	POP	BX		;Retrieve the comperand pointer
	RET			;and return.
	PAGE

$VCOMP:			;DETERMINE IF SINGLE OR DOUBLE PRECISION AND COMPARE ACCORDINGLY
	CALL	$GETYP		;SET CODES ACCORDING TO TYPE
	JB	$COMPM		;DO S.P. COMPARE
	JMP	$DCMPM		;GO DO D.P. COMPARE

$FCOMP:			;SINGLE PRECISION COMPARE OF ($FAC) AND (BXDX)
				;(AL)=1 AND ZF=0,SF=0,CF=0 IF ($FAC).GT.(BXDX)
				;(AL)=0 AND ZF=1 IF ($FAC)=(BXDX)
				;(AL)=377 AND ZF=0,SF=1,CF=1 IF ($FAC).LT.(BXDX)

	CALL	ZCMPCK		;Check for zero exponent cases.
	JB	ZEREXP		;All done if carry set.
	PUSH	BX
	PUSH	DI		;
	MOV	AL,BL		;SIGN OF (BXDX) TO (AL)
	XOR	AL,BYTE PTR $FAC-1	;SET CODES FOR SIGNS
	JS	CPM05
	OR	BL,BL
	JS	UFC10		;NEGATIVE NOS.
	MOV	AX,WORD PTR $FAC-1	;SIGNS SAME MUST COMPARE
	SUB	AX,BX		;SUBTRACT HIGH WORD
	JB	CPM10		;($FAC) SMALLER
	JNZ	CPM06		;($FAC) LARGER
	MOV	AX,WORD PTR $FACLO	;MUST COMPARE LOW WORD
	SUB	AX,DX		;
	JMP	SHORT TSTFLG	;return comparison result based on flags
UFC10:	MOV	AX,BX		;SINCE NEGATIVE LARGER MAGNITUDE IS
	SUB	AX,WORD PTR $FAC-1	;SMALLER NO.
	JB	CPM10
	JNZ	CPM06		;(BXDX) SMALLER
	MOV	AX,DX		;MUST COMPARE LOW WORD
	SUB	AX,WORD PTR $FACLO
TSTFLG: JB	CPM10		;branch if FAC is smaller than comperand
	JNZ	CPM06		;branch if FAC is larger than comperand
	XOR	AL,AL		;FAC is equal to comperand
	JMP	SHORT CPM80

;One of the exponents was zero (meaning the number=0).
; Set Carry flag if [AL]=377 (if FAC is less than comperand)
;
ZEREXP: INC	AL		;Map AL from (377, 0, 1) to (0, 1, 2)
	SUB	AL,LOW 1	;Map it back, setting Flags appropriately
	RET

$COMPM:			;COMPARE FAC TO NUMBER POINTED TO BY (BX)
;       (BX) MUST BE POINTING TO SIGN BYTE OF NO.
				;SET (AL)=1,ZF=0,SF=0,CF=0 IF (FAC).GT.[BX]
				;    (AL)=0,ZF=1 IF (FAC)=[BX]
				;    (AL)=377,ZF=0,SF=1,CF=1 IF (FAC).LT.[BX]

	CALL	ZCMPBX		;Check for zero exponent cases.
	JB	ZEREXP		;All done if carry set.
	PUSH	BX		;SAVE INITIAL ADDRESS
	PUSH	DI		;SAVE DI
	MOV	DI,OFFSET $FAC-1
	MOV	AX,WORD PTR 0[BX]	;FETCH SIGN BYTE INTO AL
	XOR	AL,BYTE PTR $FAC-1	;SF=1 IF SIGNS DIFFERENT
	JNS	CPM20
;*****************************************************************
;SIGNS ARE DIFFERENT , THE ONE WITH POS. SIGN IS BIGGER
;******************************************************************
CPM05:	MOV	AH,BYTE PTR $FAC-1	;FETCH FAC SIGN
	OR	AH,AH
	JS	CPM10		;FAC IS SMALLER MUST SET (AL)=377
CPM06:	MOV	AL,LOW 1
	OR	AL,AL		;MIGHT HAVE GOTTEN A ZF=1 ON LAST "OR"
	JMP	SHORT CPM80
CPM10:	MOV	AL,LOW 377	;KNOW SF=1
	STC			;WANT CF=1 IF FAC SMALLER
	JMP	SHORT CPM80
CPM20:
;******************************************************************
;SIGNS ARE THE SAME MUST DO ACTUAL COMPARE
;******************************************************************
	PUSH	CX		;WILL USE (CX) FOR LOOP CONTROL
	MOV	CX,2
CPM22:	XCHG	BX,SI		;SO CMPW CAN BE USED
	MOV	AL,BYTE PTR $FAC-1	;IF NEGATIVE NO. NEED TO REVERSE CMP
	OR	AL,AL
	JNS	CPM25
	XCHG	SI,DI		;WILL CAUSE CORRECT COMPARE FOR NEG.
CPM25:
	STD			;SO CMPW WILL DECREMENT
CPM30:	CMPSW			;FORM CODES FOR (.SI)-(.DI)
	JNZ	CPM50
	LOOP	CPM30		;CONTINUE THRU VALUES
	MOV	AL,LOW 0	;ZF=1 ALREADY SET
	JMP	SHORT CPM70
CPM50:	JNB	CPM60		;MEMORY VALUE LARGER
	MOV	AL,LOW 1	;FAC LARGER SF=0,ZF=0
	OR	AL,AL
	JMP	SHORT CPM70
CPM60:				;MEMORY IS LARGER MUST SET SF=1 AND (AL)=377
	MOV	AL,LOW 377
	OR	AL,AL
	STC			;WANT CF=1 IF MEMORY VALUE LARGER
CPM70:	POP	CX		;RESTORE CX REGISTER
CPM80:
	POP	DI
	POP	BX
	RET

$DCMPA:			;DOUBLE PRECISION COMPARE OF ($FAC) AND ($ARG)
	MOV	BX,OFFSET $ARG-1

$DCMPM:			;DOUBLE PRECISION COMPARE OF ($FAC) AND ((BX))
				;(AL)=1 AND ZF=0,SF=0,CF=0 IF ($FAC).GT.((BX))
				;(AL)=0 AND ZF=1 IF ($FAC)=((BX))
				;(AL)=377 AND ZF=0,SF=1,CF=1 IF ($FAC).LT.((BX))

	CALL	ZCMPBX		;Check for zero exponent cases.
	JB	ZEREXP		;All done if carry set.
	PUSH	BX
	PUSH	DI		;SAVE REGISTERS
	MOV	DI,OFFSET $FAC-1	;D.P. HIGH FAC WORD
	MOV	AL,BYTE PTR 0[DI]	;WILL FIRST SEE IF SIGNS DIFFERENT
	XOR	AL,BYTE PTR 0[BX]
	JNS	DC10		;PROCEED IF NOT DIFFERENT
	JMP	SHORT CPM05	;SIGNS DIFFERENT SET CODES ACCORDINGLY
DC10:	PUSH	CX
	MOV	CX,4		;FOUR WORDS TO COMPARE
	JMP	SHORT CPM22	;GO COMPARE


$CONI2:			;CHECK FAC FOR -32768 SINGLE PRECISION AND IF
				;EQUAL CONVERT TO INTEGER
	MOV	BX,OFFSET $S32KM	;ADDRESS OF S.P. -32768
	CALL	$MOVBS		;MOVE IT OUT TO DBUFF FOR COMPARISON
	CALL	$COMPM		;ONLY INTERESTED IN ZF
	JNZ	CON10		;IF NOT EQUAL JUST RETURN
	MOV	BYTE PTR $VALTP,LOW 2	;TO INDICATE INTEGER
	MOV	WORD PTR $FACLO,OFFSET 200*400	;-32768
CON10:	RET


$RSUBM:			;SUBTRACT NO POINTED TO BY (BP) FROM (BLDX)
				;NUMBER POINTED TO BY (BP) IS PRESUMED TO BE IN
				;THE CODE SEGMENT
	SUB	DX,WORD PTR CS:0[BP]	;FIRST 16 BITS
	SBB	BL,BYTE PTR CS:2[BP]
	RET			;COND. FLAGS ALL SET

;*********************************************************
;THE "V" UTILITIES FOLLOW. THESE UTILITIES HAVE ONE THING IN
;COMMON: THEY MUST FIRST ASCERTAIN WHAT TYPE OF VARIABLE
;THEY ARE TO WORK ON BEFORE PERFORMING THEIR TASK.
;************************************************************
ABSFN:
$VABS:				;ABSOLUTE VALUE ROUTINE
	CALL	$GETYP		;SEE WHAT TYPE VARIABLE
	JS	$IABS		;IF INTEGER PROCEED
	MOV	AL,BYTE PTR $FAC-1
	OR	AL,AL		;SEE IF CURRENTLY NEGATIVE
	JS	$NEG		;AND IF SO NEGATE
	RET
$IABS:	MOV	AX,WORD PTR $FACLO	;FETCH INTEGER
	OR	AX,AX		;AND SEE IF ALREADY POS.
	JS	VN15
	RET			;RETURN IF POSITIVE

VNEG:
$VNEG:				;NEGATE THE VALUE IN THE FAC
	CALL	$GETYP		;SET COND. CODES ACCORDING TO TYPE
	JS	$INEG		;IT'S INTEGER MUST COMPLEMENT
;************************************************************
;IT'S SINGLE OR DOUBLE PRECISION MUST FLIP THE SIGN BIT
;************************************************************
NEG:
$NEG:
	XOR	BYTE PTR $FAC-1,LOW 200 ;FLIP SIGN OF FAC
	RET
INEG:
$INEG:	MOV	AX,WORD PTR $FACLO	;WILL CHECK FOR -32768
VN15:	CMP	AX,100000	;SEE IF -32768
	JNZ	VN20		;IF NOT JUST NEGATE
	PUSH	BX		;PRESERVE BX
	CALL	$CSI		;CONVERT TO SINGLE PRECISION
	POP	BX		;RECALL BX
	JMP	$NEG		;GO NEGATE
VN20:	NEG	WORD PTR $FACLO ;NEGATE
	RET

$SETDB:			;MOVE FAC TO DBUFF FOR MULT. AND ZERO FAC
	MOV	BX,OFFSET $DBUFF+1	;
	CALL	$VMVMF		;MOVE FAC TO DBUFF
	MOV	DI,OFFSET $DFACL-10	;WILL NOW ZERO 16 BYTES OF FAC
	MOV	CX,10
	MOV	AX,0
	CLD
 REP	STOSW			;STORES (AX) INTO LOCATIONS
	MOV	BYTE PTR $DBUFF,AL	;ZERO OVERFLOW BYTE
	MOV	BYTE PTR $ARGLO-1,AL	;ZERO OVERFLOW BYTE OF ARG
	RET

$VMVAM:			;MOVE THE VALUE POINTED TO BY (BX) TO (BXDX) IF SINGLE
				;PRECISION, TO $ARG IF DOUBLE PRECISION
	CALL	$GETYP		;SET CODES ACCORDING TO TYPE
	JB	VM10		;JUMP IF SINGLE PRECISION
	JMP	MOVAM		;MOVE THE VALUE TO THE ARG
VM10:	MOV	DX,WORD PTR 0[BX]	;FETCH LOW MANTISSA BITS
	MOV	BX,WORD PTR 2[BX]	;FETCH HIGH MANTISSA AND EXPONENT
	RET


$VMOVM:			;MOVE THE VARIABLE POINTED TO BY (BX) TO THE ONE POINTED
				;TO BY (DI)
	MOV	CX,4		;ASSUME DOUBLE PRECISION
	CALL	$GETYP
	JB	VMM10		;IT'S SINGLE PREC JUMP
	JMP	MOVEM		;GO DO MOVE
VMM10:	MOV	CX,2
	JMP	MOVEM		;GO DO MOVE

$VMVMF:			;MOVE THE FAC TO THE NO. POINTED TO BY (BX)
	MOV	CX,4		;ASSUME DOUBLE PREC.
	XCHG	DI,BX		;(DI)=DESTINATION,(BX)=ORIGIN
	MOV	BX,OFFSET $DFACL
	CALL	$GETYP		;SET COND. CODES ACCORDING TO $VALTP
	JB	VMVM1		;JUMP IF S.P.
	JMP	MOVEM		;GO DO MOVE
VMVM1:	XCHG	BX,DI
$MOVMF: MOV	CX,2
	MOV	DI,OFFSET $FACLO
	XCHG	DI,BX
	JMP	MOVEM		;GO DO MOVE

$VMVFM:			;MOVE TO FAC THE NO POINTED TO BY (BX)
	MOV	CX,4		;ASSUME DOUBLE PREC
	MOV	DI,OFFSET $DFACL
	CALL	$GETYP
	JB	$MOVFM
	JMP	MOVEM
$MOVFM: MOV	CX,2
	MOV	DI,OFFSET $FACLO
	JMP	MOVEM		;GO DO MOVE

$VCMPM:			;COMPARE FAC TO NO. POINTED TO BY (BX)
	CALL	$GETYP
	JB	VCMP10
	JMP	$DCMPM		;DO DOUBLE PREC COMPARE
VCMP10: JMP	$COMPM		;SINGLE PREC COMPARE

$VPSHF:			;PUSH THE FAC ON THE STACK ACCORDING TO TYPE
	CALL	$GETYP		;SET COND CODES ACCORDING TO $VALTP
	MOV	CX,4		;FOR DOUBLE PRECISION
	JNB	VPS10		;IF DOUBLE PREC PROCEED
$PUSHF:			;PUSH SINGLE PRECISION FAC ON THE STACK
	MOV	CX,2
VPS10:	POP	BP		;GET RETURN ADDRESS OFF STACK
	MOV	DI,OFFSET $FAC-1
VPS20:	PUSH	WORD PTR 0[DI]
	DEC	DI
	DEC	DI
	LOOP	VPS20
	PUSH	BP		;GET RETURN ADDRESS RIGHT
	RET			;AND RETURN
$POPA:				;POP STACK INTO ARG
	MOV	DI,OFFSET $ARGLO
	MOV	CX,4
	JMP	SHORT VPO17
$VPOPF:			;POP EITHER 4 OR 8 BYTES OFF THE STACK
	CALL	$GETYP		;SET CODES ACCORDING TO $VALTP
	MOV	DI,OFFSET $DFACL
	MOV	CX,4
	JNB	VPO17		;JUMP IF DOUBLE PRECISION
	MOV	DI,OFFSET $FACLO
	MOV	CX,2
VPO17:	POP	AX		;GET RETURN ADDRESS OFF STACK
VPO20:	POP	WORD PTR 0[DI]
	INC	DI
	INC	DI
	LOOP	VPO20
	PUSH	AX		;PUSH RETURN ADDRESS ON STACK
	RET
VINT:
$VINT:				;DO INT ACCORDING TO TYPE (SINGLE OR DOUBLE PRECISION)
	CALL	$GETYP		;SET CODES ACCORDING TO TYPE
	JNS	VIN05
	RET			;RETURN IF INTEGER ALREADY
VIN05:
	JB	VIN10		;JUMP IF SINGLE PRECISION
	JMP	$DINT		;GO DO DOUBLE PRECISION
VIN10:	JMP	$INT

	SUBTTL	 $FIN	 NUMERIC INPUT ROUTINE
;****************************************************************
;
;       $FIN    GIVEN A TEXT POINTER, $FIN WILL BUILD AN INPUT
;               NUMBER IN THE FAC. AS NECESSARY (OR IF FORCED)
;               $FIN WILL GO TO NEXT HIERARCHY OF NUMBERS
;               I.E. TRANSITIONS FROM INTEGER-SINGLE PRECISION-
;               DOUBLE PRECISION CAN EITHER BE FORCED OR DICTATED
;               BY THE INPUT NUMBERS.
;       CALLING         SEQUENCE:       CALL    $FIN
;               WITH (BX) POINTING TO TEXT CONTAINING THE NUMBER
;               TO BE CONVERTED FROM ASCII.
;
;******************************************************************



FIN:
$FIN:	XOR	AL,AL		;LET INPUT NUMBER DETERMINE TYPE
	JMP	SHORT FN20
FINDBL:
$FINDB:			;FORCE DOUBLE PRECISION ENTRY POINT
	MOV	AL,LOW 1	;FLAG TO INDICATE D.P.
	MOV	BYTE PTR $VALTP,LOW 10	;SET TO DOUBLE PRECISION
FN20:
	MOV	BYTE PTR $FLGOV,LOW 1	;SET ONCE-ONLY OVERFLOW MODE
	MOV	SI,OFFSET $FLGOC	;ADDRESS OF INPUT OVERFLOW CODE
	PUSH	SI		;PUSH ON STACK SO RETURN IS HERE
	XOR	DI,DI		;DIGITS PAST DECIMAL POINT
	MOV	CX,DI		;DECIMAL POINT FLAG
	MOV	SI,DI		;(SI) WILL FLAG POS/NEG EXPONENT
	NOT	CX		;SET ALL BITS
	PUSH	AX
	CALL	$ZERO		;(FAC)=0
	POP	AX
	OR	AL,AL		;MUST SEE IF $VALTP SHOULD START AT
	JNZ	FN30		;INTEGER OR NOT.
	MOV	BYTE PTR $VALTP,LOW 2	;SET TO INTEGER
FN30:	MOV	AL,BYTE PTR 0[BX]	;FETCH 1ST CHARACTER FROM TEXT
	CMP	AL,LOW "&"      ;SIGNIFIES SPECIAL INPUT NO.
	JNZ	FN40		;IF NOT, PROCEED
	JMP	$OHCNS		;OTHERWISE GO PROCESS OCT. OR HEX
FN40:	CMP	AL,LOW "-"      ;NEGATIVE NUMBER?
	PUSHF			;WILL SAVE ZF FOR POSSIBLE NEGATION
	JZ	FN50		;ONCE NUMBER IS FORMED POSITIVE
	CMP	AL,LOW "+"      ;NEED TO ADVANCE TEXT POINTER FOR
	JZ	FN50		;LEADING SIGN
	DEC	BX		;
FN50:	CALL	$CHRGT		;GET NEXT CHARACTER OF NUMBER
	JNB	FN60		;IF NOT DIGIT GO EXAMINE FURTHER
FN55:	CALL	$FIDIG		;MUL FAC BY TEN AND ADD IN THE DIGIT
	JMP	SHORT FN50
FN60:
	MOV	BP,OFFSET $FINCH+7
	XOR	DX,DX		;MUST SET EXPONENT TO ZERO
	MOV	SI,DX		;FOR SUBSEQUENT CALL TO FINE
FN70:
	CMP	AL,BYTE PTR CS:0[BP]	;CODE SEGMENT
	JZ	FN80		;FOUND SPEC CH (.,D,D+40,!,#,%,E,E+40)
	CMP	BP,OFFSET $FINCH	;IF EQUAL NONE OF THE SPECIAL CHARS.
	JZ	FN96		;GO FNISH UP NUMBER NON-RECOG. CHAR.
	DEC	BP		;PROCEED TO NEXT CHARACTER
	JMP	SHORT FN70	;IF NOT FNISHED LOOK AT NEXT CHAR.
FN80:	SUB	BP,OFFSET $FINCH	;
	SHL	BP,1		; BRANCH TABLE ENTRIES 2 BYTES EA
FN90:
				;CODE SEGMENT OVERRIDE PREFIX
	JMP	 WORD PTR CS:FN95[BP]
FN95  LABEL WORD
	DW	OFFSET FN100
	DW	OFFSET FN200
	DW	OFFSET FN200
	DW	OFFSET FN400
	DW	OFFSET FN500
	DW	OFFSET FN600
	DW	OFFSET FN92
	DW	OFFSET FN92
FN92:				;IT WAS A "D"
	XOR	AL,AL		;SET CONDITION CODES CORRECTLY
FN94:	CALL	$FINEX		;CALCULATE EXPONENT
FN96:	CALL	$FINE		;MODIFY NUMBER TO REFLECT EXPONENT
	JMP	SHORT FINF	;CLEAN UP, NEGATE AS NECESSARY
FN100:				;IT WAS A "."
	INC	CX		;TO DENOTE DECIMAL POINT DETECTED
	JNZ	FN96		;GO FINISH UP NO.-2ED DECIMAL PT. SEEN!
	CALL	$GETYP		;IF SNG OR DOUBLE JUST RETURN
	JNS	FN50
	PUSH	CX
	PUSH	BX
	PUSH	DI
	CALL	$CSI		;CONVERT TO SINGLE PRECISION
	POP	DI
	POP	BX
	POP	CX
	JMP	FN50		;GO PROCESS NEXT CHAR.
FN200:				;IT WAS AN "E" OR  "E"+40 (LOWER CASE E)
	CALL	$CHKEL		;MAKE SURE WE DON'T HAVE AN "ELSE"
	JZ	FN96		;IT WAS AN "ELSE" OR "EQV"
	JMP	SHORT FN94	;GO DETERMINE EXPONENT
FN400:				;IT WAS A "%" (INTEGER)
	INC	BX		;Eat the percent sign.
	JMP	SHORT FN96	;Call $FINE since could be working
				;on a floating point.

FN500:				;IT WAS A "#" (DOUBLE PRECISION)
	CALL	$FIND
	JMP	SHORT FINF	;GO FINISH UP
FN600:				;IT WAS A "!"    (SINGLE PRECISION)
	XOR	AL,AL		;FLAG AS SINGLE
	CALL	$FINS		;FORCE TO SINGLE PRECISION
FINF:	POPF			;RECALL SIGN FLAG
	JNZ	FN990		;RETURN IF NOT NEGATIVE NO.
	CALL	$VNEG		;NEGATE NUMBER
	CALL	$GETYP		;SET CONDITION CODES ACCORDING TO TYPE
	JPE	FN990		;IF NOT SINGLE PRECISION RETURN
	PUSH	BX		;SAVE TEXT POINTER
	CALL	$CONI2		;CHECK FOR -32768 AND CONVERT TO INT.
	POP	BX		;RECALL TEXT POINTER
				;IF FOUND
FN990:	RET

	SUBTTL	 $FPWR/$SQR	 INVOLUTION/SQUARE RT. OF SINGLE PRECISION NOS.
;***********************************************************
;
;       $FPWR   CALCULATES X^Y BY X^Y=EXP(Y*LOG(X))
;
;       CALLING SEQUENCE:       CALL    $FPWR
;               WITH Y IN THE $FAC, X IN (BXDX)
;       $SQR    ENTRY POINT TO PROVIDE SQUARE ROOT FUNCTION
;       CALLING SEQUENCE:       CALL    $SQR
;               WITH ARGUMENT IN $FAC
;
;************************************************************

;SQUARE ROOT FUNCTION (FAC)=SQR(FAC)
SQR:
$SQR:
	MOV	DX,WORD PTR $FAC-2
	OR	DH,DH		;Test sign bit
	JS	NEGNUM
	MOV	AL,BYTE PTR $FAC	;Get exponent
	OR	AL,AL
	JZ	DONE		;SQR(0)=0
	MOV	BH,BYTE PTR $FAC-3
	MOV	BL,LOW 0
	OR	DH,LOW 128D	;Set implied bit
	SHR	AL,1		;Divide exponent by two
	JNB	EVENEX		;
	SHR	DX,1		;HALF MANTISSA IF EXP ODD
	RCR	BX,1
	STC			;RESTORE CARRY FOR ROUND UP
EVENEX:
	ADC	AL,LOW 100O	;ADD BACK 1/2 OF BIAS
	MOV	BYTE PTR $FAC,AL	;SAVE FINAL EXPONENT
	MOV	CX,25D		;24 BITS PLUS 1 FOR ROUNDING
	XOR	BP,BP		;CLEAR SOME REGISTERS
	MOV	SI,BP
	MOV	DI,BP
	MOV	AX,BP
RTLP:
	SHL	BX,1		;64 BIT LEFT SHIFT OF INPUT
	RCL	DX,1
	RCL	DI,1
	RCL	BP,1
	SHL	BX,1		;SHIFT IT TWICE
	RCL	DX,1
	RCL	DI,1
	RCL	BP,1
	STC			;ROTATE IN TEST BIT
	RCL	SI,1		;32-BIT SHIFT OF PARTIAL RESULT
	RCL	AX,1
	SUB	DI,SI		;TRY TEST BIT
	SBB	BP,AX
	JNB	ROOTBT		;JUMP OUT IF IT FIT
	ADD	DI,SI		;RESTORE IF IT DIDN'T
	ADC	BP,AX
	DEC	SI
	LOOP	RTLP
	JMP	SHORT FPWRND
ROOTBT:
	INC	SI		;HERE IF TEST BIT FIT
	LOOP	RTLP		;SET REAL RESULT BIT AND CONTINUE
FPWRND:
	SHR	AX,1		;HALF TO A 25-BIT RESULT
	RCR	SI,1
	SHR	AX,1		;TO A 24-BIT RESULT
	RCR	SI,1
	ADC	SI,0		;ROUND IF A 1 SHIFTED OUT
	ADC	AX,0		;AND PROPAGATE CARRY
	MOV	WORD PTR $FAC-3,SI	;STORE RESULT
	AND	AL,LOW 177O	;CLEAR SIGN BIT
	MOV	BYTE PTR $FAC-1,AL	;AND STORE
DONE:	RET

NEGNUM: JMP	$FCERR

$FPWR:				;INVOLUTION ($FAC):=(BXDX)^($FAC)
				;OR         (FAC)=X^Y
	MOV	DI,OFFSET $CLROV
	PUSH	DI
	MOV	DI,OFFSET $FLGOV
	MOV	BYTE PTR 0[DI],LOW 1	;ONCE-ONLY OVERFLOW MODE
	CALL	$SIGNS		;SEE IF Y IS ZERO
	JNZ	FP10
	JMP	$EXP		;ANS IS 1 IF Y=0
FP10:	JNS	FP20		;IF NEGATIVE POTENTIAL OVERFLOW
	OR	BH,BH		;IF X IS ZERO
	JNZ	FP25
	JMP	$DIV0S		;DIVIDE-BY-ZERO CODE
FP20:	OR	BH,BH		;SEE IF ZERO TO POWER
	JNZ	FP25
	JMP	$ZERO		;ANS IS ZERO
FP25:				;WE KNOW AT THIS POINT THAT X IS NON-ZERO. IF X IS NEGATIVE
				;THEN Y MUST BE AN INTEGRAL POWER OR WE HAVE A FUNCTION
				;CALL ERROR
	OR	BL,BL		;IS X NEGATIVE?
	JNS	FP30		;IF NOT PROCEED
	CMP	BYTE PTR $FAC,LOW 231	;SEE IF Y TOO LARGE TO DETERMINE SIGN
				;OF INVOLUTION RESULT
	JB	FP27		;JUMP IF OK TO COMPUTE
	JMP	$FCERR
FP27:
	PUSH	DX		;SAVE X ON THE STACK
	PUSH	BX
	PUSH	WORD PTR $FACLO ;PUSH Y ON THE STACK
	PUSH	WORD PTR $FACM1
	CALL	$INT		;MAKE Y AN INTEGER
	POP	BX		;Y TO THE REGISTERS
	POP	DX
	CALL	$FCOMP		;SEE IF Y IS AN INTEGER
	CALL	$MOVFR		;MOVE ORIGINAL Y BACK TO FAC
	POP	BX		;RECALL X
	POP	DX
	JZ	FP30		;PROCEED IF Y IS AN INTEGER
	JMP	$FCERR		;OTHERWISE WE HAVE FCN CALL ERROR
FP30:	MOV	AL,BYTE PTR $FAC-1	;NEED TO KNOW IF Y IS NEGATIVE
	OR	AL,AL
	JNS	FP30A		;Y POSITIVE
	AND	AL,LOW 177	;Y is negative - will invert when
	MOV	BYTE PTR $FAC-1,AL	;finished.  Clear the sign bit of Y.
	PUSH	BX		;Save the sign of X.
	PUSH	WORD PTR $FACM1 ;Save Y.
	PUSH	WORD PTR $FACLO
	CALL	FP30A		;FAC:=X^positive Y.
	TEST	BYTE PTR $FAC,LOW 377O	;Did it underflow?
	JNZ	INVERT		;No, go invert it.
	POP	WORD PTR $FACLO ;Yes, pop Y into the FAC.
	POP	WORD PTR $FACM1
	CALL	$QINT		;Get least significant byte of Y
				;into DL.
	POP	BX		;Get sign of X into BL bit 7.
	ROR	DL,1		;Set sign bit of FAC if X is negative
	AND	BL,DL		;and Y is odd.
	MOV	BYTE PTR $FAC+1,BL
	MOV	BH,LOW 377O	;Make BH nonzero for DOINF routine
				;(which is called by $OVFLS) so it uses
				;$FAC+1 to determine the sign of the
				;inifinity to use.
	JMP	$OVFLS		;Give Overflow error with and return
				;appropriate (negative or positive)
				;inifinity based on the sign just
				;put into the FAC.

INVERT: ADD	SP,6		;Pop off the garbage.
	MOV	DX,0		;BXDX:=1.0.
	MOV	BX,100400
	JMP	$FDIVS		;Invert the result and return.

FP30A:
	PUSH	BX		;SAVE X ON THE STACK
	PUSH	DX
	OR	BL,LOW 177	;SET CODES TO REFLECT SIGNS OF X
	PUSHF			;SAVE X POS/NEG INFORMATION
	PUSH	WORD PTR $FACM1 ;PUSH Y ON THE STACK
	PUSH	WORD PTR $FACLO
	CALL	$INT		;MUST DETERMINE IF Y IS AN INTEGER
	POP	DX		;RECALL ORIGINAL Y
	POP	BX
	CALL	$FCOMP		;ZF=1 IF Y IS AN INTEGER
	JNZ	FP34		;IF NOT INTEGER PROCEED AS NORMAL
	PUSH	DX		;SAVE Y
	PUSH	BX
	MOV	DX,0		;WILL MAKE (BXDX) 32768.
	MOV	BX,110000
	CALL	$FCOMP		;SEE IF TOO LARGE
	POP	BX		;RECALL Y
	POP	DX
	JNS	FP34		;AND IF SO COMPUTE WITH LOG & EXP
	POPF			;GET X POS/NEG INFO OFF STACK
	POP	DX		;GET X TO REGISTERS
	POP	BX
	JMP	XTON		;AND COMPUTE X^N

FP34:	POPF			;GET X POS/NEG INFORMATION
	JNS	FP40		;NO PROBS IF X IS POSITIVE
	PUSH	BX		;SAVE Y ON THE STACK
	PUSH	DX
	CALL	$QINT		;NEED EVEN-ODD INFORMATION
	MOV	AL,DL		;GET LOW BYTE OF INTEGER
	CALL	$NORMS		;($FAC)=INT(Y)
	POP	DX		;RECALL Y
	POP	BX
	RCR	AL,1		;CF=1 IF ODD
FP40:	POP	WORD PTR $FACLO ;GET X TO FAC
	POP	WORD PTR $FACLO+2
	LAHF			;SAVE EVEN/ODD INFO
	AND	BYTE PTR $FACM1,LOW 177 ;CLEAR ANY SIGN BIT
	SAHF			;GET EVEN/ODD INFO
	JNB	FP60
	MOV	DI,OFFSET $NEG
	PUSH	DI		;WILL NEGATE AT THE END IF CF=1
FP60:	PUSH	BX		;SAVE Y AGAIN
	PUSH	DX
	CALL	$LOG		;LOG(X)
	POP	DX		;RECALL Y
	POP	BX
	CALL	$FMULS		;($FAC)=Y*LOG(X)
	JMP	$EXP		;COMPLETE CALCULATION
;**************************************************************
;       ($FAC)=($FAC)^(BXDX)
;WHERE (BXDX) IS AN INTEGER SUCH THAT 0.LT.(BXDX).LE.32767
;
;OR AS IN KNUTH X**N IS AS FOLLOWS
;THE ALGORITHM IS TAKEN FROM KNUTH VOL2 P400
;A1.Y=1, Z=X
;A2.HALVE N AND DETERMINE IF N WAS EVEN OR ODD. IF N WAS EVEN
;   THEN JUMP TO A4.
;A3.Y=Y*Z
;A4.IF N = 0 FINISHED WITH Y THE ANSWER
;A5.Z=Z*Z AND RETURN TO A2
;***************************************************************
XTON:				;($FAC):=(BXDX)^($FAC)
	PUSH	BX		;SAVE X ON STACK
	PUSH	DX
	CALL	$QINT		;CONVERT TO INTEGER
	MOV	WORD PTR $ARG,DX	;N TO $ARG
	MOV	WORD PTR $FACLO,0	;WILL MOVE 1.0 TO FAC
	MOV	WORD PTR $FACM1,100400	;
XTON10: SHR	WORD PTR $ARG,1 ;SHIFT RIGHT 1 BIT
	JNB	XTON20		;IF NO MULTIPLY THEN Z=Z**2
	POP	DX		;FETCH Z
	POP	BX
	PUSH	BX		;AND PUT IT BACK ON STACK
	PUSH	DX
	CALL	$FMULS		;Y=Y*Z
XTON20: TEST	WORD PTR $ARG,177777	;SEE IF N HAS GONE TO ZERO
	JZ	XTON30		;GET OUT IF FINISHED
	POP	DX		;FETCH Z TO REGISTERS
	POP	BX
	CALL	$PUSHF		;Y TO STACK
	CALL	$MOVFR		;Z TO FAC
	CALL	$FMULS		;Z=Z*Z
	POP	DX		;FETCH Y
	POP	BX
	CALL	$PUSHF		;NEW Z TO STACK
	CALL	$MOVFR		;Y TO FAC
	JMP	SHORT XTON10	;TRY AGAIN
XTON30: POP	DX		;GET STACK CLEAR OF Z
	POP	BX
	RET

	SUBTTL	 F4  MAP BETWEEN 8080-8086 CONVERTED F3 TO 8086 MATHPK



$CHRGT: JMP	CHRGTR
DSUB:
	XOR	BYTE PTR $FAC-1,LOW 200 ;WILL FLIP SIGNS OF EACH ARGUMENT
	XOR	BYTE PTR $ARG-1,LOW 200
	JMP	$FSUBD
FADD:
	XCHG	BX,CX
	JMP	$FADDS
FSUB:
	XCHG	BX,CX
	JMP	$FSUBS
FDIV:	XCHG	BX,CX
	JMP	$FDIVS
CONSIH:
	MOV	WORD PTR $FACLO,BX
	JMP	$CSI
FLOAT:
	PUSH	DX
	CBW
	MOV	DX,AX
	CALL	$FLT
	POP	DX
	RET
FMULT:
	XCHG	BX,CX
	JMP	$FMULS
FPWR:
	XCHG	BX,CX
	JMP	$FPWR

;*************************************************************
;INTEGER ARITHMETIC FOLLOWS
;*************************************************************
ISUB:				;(BX)=(DX)-(BX)
	CMP	BX,100000	;CHECK FOR -32768
	JNZ	IS10		;PROCEED IF NOT
	CALL	$FLT		;FLOAT DX
	XOR	DX,DX		;WILL SET (BXDX)=-32768.0
	MOV	BX,110200
	CALL	$FSUBS		;DO SUBTRACT
	CALL	$NEG		;NEGATE
	JMP	$FI
IS10:
	NEG	BX		;NEGATE AND FALL INTO ADD

IADD:				;(BX)=(DX)+(BX)
	PUSH	BX		;SAVE 1ST ARG
	ADD	BX,DX
	JO	IAD10		;IF OVERFLOW JUMP
	POP	AX		;CLEAR STACK
	JMP	MAKINT
IAD10:
	CALL	$FLT		;FLOAT 2ED ARG
	POP	DX		;RECALL FIRST ARG
	PUSH	WORD PTR $FACLO
	PUSH	WORD PTR $FAC-1 ;FAC PUSHED ON THE STACK
	CALL	$FLT		;FLOAT 2ED ARG
	POP	BX
	POP	DX		;GET 2ED ARG TO (BXDX)
	JMP	$FADDS		;GO ADD FLOATING

IMULT:				;(BX)=(BX)*(DX)
	MOV	AX,BX
	PUSH	DX		;SAVE 2ED ARG
	IMUL	DX		;PERFORM MULTIPLICATION
	POP	DX		;RECALL 2ED ARG
	JB	IM10		;MUST FLOAT ARGS IF CF=1
	MOV	BX,AX
	JMP	MAKINT
IM10:
	PUSH	BX		;SAVE FIRST ARG
	CALL	$FLT		;FLOAT 2ED ARG
	POP	DX		;RECALL 1ST ARG
	PUSH	WORD PTR $FACLO
	PUSH	WORD PTR $FAC-1
	CALL	$FLT		;FLOAT 1ST ARG
	POP	BX
	POP	DX		;GET 2ED ARG TO (BXDX)
	JMP	$FMULS		;GO MULTIPLY FLOATING

IDIV:				;(BX)=(DX)/(BX)
	OR	BX,BX		;MAKE SURE ITS NON-ZERO
	JNZ	IDIV10
	MOV	BYTE PTR $FAC+1,DH	;FOR CORRECT SIGN
	INC	BH		; Hack for DOINF to work
	MOV	BYTE PTR $VALTP,LOW 4
	JMP	$DIV0S
IDIV10:
	CMP	DX,100000	;CHECK FOR -32768
	JNZ	IDIV15		;PROCEED IF NOT
	CMP	BX,177777	;Check for special case of -32768\-1
	JNE	IDIV11
	CALL	$FLT		;FLOAT DX
	CALL	$NEG
	RET
IDIV11:
	CMP	BX,1		;Other special case
	JNE	IDIV15
	MOV	BX,DX		;Put -32768\1 = -32768 in BX so we can ...
	JMP	MAKINT		;Return it as an Int. (IDIV doesn't work)
IDIV15:
	MOV	WORD PTR $FACLO,BX	;WILL PERFORM (DX:AX)/(FAC)
	MOV	AX,0
	MOV	WORD PTR $FACM1,AX
	XCHG	AX,DX		;GET NO RT. ADJUSTED IN AX
	OR	AX,AX
	JNS	IDV20
	MOV	DX,177777	;SIGN EXTEND INTO DX
IDV20:	OR	BX,BX		;SEE IF DENOMINATOR NEEDS SIGN EXT
	JNS	IDV30
	MOV	WORD PTR $FACM1,177777
IDV30:	IDIV	WORD PTR $FACLO ;16 BIT DIVIDE
	MOV	BX,AX
	JMP	MAKINT

MOVFR:	XCHG	BX,CX
	CALL	$MOVFR		;MOVE TO FAC
	XCHG	BX,CX		;GET REGISTERS RIGHT
	RET
MOVFM:	PUSH	BX
	CALL	$MOVFM
	POP	BX
	ADD	BX,4
	RET
MOVRF:	MOV	DX,WORD PTR $FACLO
	MOV	CX,WORD PTR $FAC-1
	RET
MOVMF:	PUSHF
	PUSH	BX
	CALL	$MOVMF
	POP	BX
	ADD	BX,4
	POPF
	RET
FOUTO:	CALL	FRQINT
	MOV	WORD PTR $FACLO,BX
	JMP	$FOUTO
FOUTH:	CALL	FRQINT
	MOV	WORD PTR $FACLO,BX
	JMP	$FOUTH
FADDS:				;ADD NO. POINTED TO BY (BX) TO (FAC)
	MOV	DX,WORD PTR 0[BX]
	MOV	BX,WORD PTR 2[BX]
	JMP	$FADDS
PUSHF:	POP	SI		;GET OUR RETURN ADDRESS OFF STACK
	PUSH	WORD PTR $FACLO
	PUSH	WORD PTR $FAC-1
	JMP	SI
FCOMP:
	XCHG	BX,CX
	CALL	$FCOMP
	XCHG	BX,CX
	RET
FRCSTR:
CHKSTR: CALL	$GETYP		;WANT TO ASSURE STRING
	JZ	CH10
	JMP	TMERR
CH10:	RET
INEG2:	XCHG	BX,DX
	CALL	VALSNG
	XOR	AL,AL
INEGAD: MOV	CH,LOW 230
FLOATR:
	MOV	BX,OFFSET $FAC
	MOV	CL,AL
	MOV	BYTE PTR 0[BX],CH
	MOV	CH,LOW 0	;ZERO OVERFLOW BYTE
	INC	BX
	MOV	BYTE PTR 0[BX],CH
	RCL	AL,1
FADFLT:
	JNB	FL10
	CALL	NEGR
FL10:	MOV	AH,CH		;OVERFLOW BYTE TO AH
	MOV	BL,CL		;BL IS HIGH MANTISSA BIT
	JMP	$NORMS
RNDMON: CALL	$CHRGT
RNDMN2: PUSH	BX
	XOR	BX,BX		;WILL SET FAC TO 1.0
	MOV	WORD PTR $FACLO,BX
	MOV	BH,LOW 201
	MOV	WORD PTR $FACM1,BX
	MOV	BYTE PTR $VALTP,LOW 4	;SET CORRECT TYPE
	CALL	$RND
	POP	BX
	MOV	BYTE PTR $VALTP,LOW 4
	RET
UMULT:	MOV	AX,CX		;WILL FORM (DX)=(CX)*(DX)
	MUL	DX
	XCHG	AX,DX
	JNB	UM10
	JMP	BSERR
UM10:	RET
VMOVFA: MOV	BX,OFFSET $ARGLO
VMOVFM: MOV	DX,OFFSET MOVVFM
	JMP	VMVVFM
VMOVAF: MOV	BX,OFFSET $ARGLO
VMOVMF: MOV	DX,OFFSET VMOVE
VMVVFM: PUSH	DX
VDFACS: MOV	DX,OFFSET $FACLO
	CALL	$GETYP
	JB	VD15
VD10:	MOV	DX,OFFSET $DFACL
VD15:	RET
MOVE1:	MOV	CL,CH
	XOR	CH,CH
	JMP	SHORT F4VM10	;MOVE FOR BASIC INTERPRETER
MOVVFM: XCHG	BX,DX
VMOVE:	MOV	AL,BYTE PTR $VALTP
	CBW
	MOV	CX,AX
F4VM10: CLD			;SO WE WILL INCREMENT
	MOV	SI,DX
	MOV	DI,BX
 REP	MOVSB
	MOV	DX,SI
	MOV	BX,DI
	RET

;
; THIS IS THE BLOCK TRANSFER ROUTINE
; IT MAKES SPACE BY SHOVING EVERYTHING FORWARD
;
; BX = DESTINATION OF HIGH ADDRESS
; DX = LOW ADDRESS TO BE TRANSFERRED
; CX = HIGH ADDRESS TO BE TRANSFERRED
;
; A CHECK IS MADE TO MAKE SURE A REASONABLE AMOUNT
; OF SPACE REMAINS BETWEEN THE TOP OF THE STACK AND
; THE HIGHEST LOCATION TRANSFERRED INTO
;
; ON EXIT BX=DX=LOW CX=LOCATION LOW WAS MOVED INTO
;
BLTU:	CALL	REASON		;CHECK DESTINATION TO MAKE SURE
				;STRING SPACE WONT BE OVERWRITTEN
BLTUC:	MOV	SI,CX		;SET UP HIGH ADDRESS
	MOV	DI,BX		;SET UP DESTINATION OF HIGH ADDRESS
	STD			;MOVE DOWN
	SUB	CX,DX		;GET COUNT OF BYTES TO TRANSFER
	INC	CX		;ALWAYS MOVE ONE BYTE
 REP	MOVSB			;MOVE BYTES
	MOV	BX,DX		;BX=LOW
	MOV	CX,DI		;CX=DESTINATION OF LOW
	INC	CX		;CORRECT AS DECREMENTED ONE TOO MANY
	CLD			;SET DIRECTION BIT TO UP
	RET

DCXBRT: PUSHF
	DEC	CX
	POPF
	RET
VSIGN:	CALL	$GETYP		;DETERMINE TYPE
	JNZ	VS10		;IF NOT STRING PROCEED
	JMP	TMERR
VS10:
	JS	ISI10
	JMP	$SIGNS		;SINGLE OR DOUBLE PRECISION
ISI10:	MOV	AX,WORD PTR $FACLO	;GET THE INTEGER
	OR	AX,AX		;SET SIGNS CORRECTLY
	JZ	ISIGN1
ISI15:	MOV	AL,LOW 1
	JNS	ISIGN1
	MOV	AL,LOW 377
ISIGN1: RET
ISIGN:	XOR	AX,AX		;IN CASE (BX) IS ZERO
	OR	BX,BX		;NEED SIGN OF (BX)
	JNZ	ISI15
	RET
POPHRT: POP	BX
	RET
CONIA:				;CONVERT NO. IN A TO AN INTEGER
	CBW
	MOV	BX,AX
MAKINT: MOV	BYTE PTR $VALTP,LOW 2	;MAKE INTEGER
	MOV	WORD PTR $FACLO,BX	;STORE INTEGER IN $FAC
	RET
VALSNG: MOV	BYTE PTR $VALTP,LOW 4
	RET
SGN:	CALL	VSIGN
	JMP	CONIA
FDIVT:
	POP	BX
	POP	DX
	JMP	$FDIVS
FPWRQ:	CALL	$FS		;FORCE FAC TO SP
FPWRT:	POP	BX
	POP	DX
	JMP	$FPWR
MOVE:	MOV	CX,4
	JMP	F4VM10
MOVRM:	PUSHF
	MOV	DL,BYTE PTR 0[BX]
	INC	BX
	POPF
GETBCD: PUSHF
	MOV	DH,BYTE PTR 0[BX]
	INC	BX
	MOV	CX,WORD PTR 0[BX]
	INC	BX
	POPF
INXHRT: PUSHF
	INC	BX
	POPF
	RET
INPRT:	PUSH	BX
	MOV	BX,OFFSET INTXT
	CALL	STROUT
	POP	BX
LINPRT: MOV	CX,OFFSET STROUI
	PUSH	CX
LINOUT: CALL	MAKINT
	XOR	AL,AL
FOUINI:
	MOV	BYTE PTR TEMP3,AL
	MOV	BX,OFFSET $FBUFF+1
	MOV	BYTE PTR 0[BX],LOW " "
	OR	AL,BYTE PTR 0[BX]
	INC	BX
	MOV	BYTE PTR 0[BX],LOW "0"
	JMP	$FOUT2
SIGNC:
	MOV	AL,BYTE PTR $FAC-1
	JMP	SHORT ICOMPS
DCOMP:
	CALL	$DCMPA
	JZ	SG15
	NOT	AL
ICOMPS: SAL	AL,1
SIGNS:	SBB	AL,AL
	JZ	INRART
SG15:	RET
NEGR:
	XOR	BYTE PTR $FAC+1,LOW 200 ;FLIP SIGN
	XOR	BX,BX		;WILL NEED THIS ZERO REGISTER
	NEG	CH
	MOV	AX,BX
	SBB	AX,DX		;DO MIDDLE BYTES
	MOV	DX,AX		;AND REPLACE
	MOV	AL,BL
	SBB	AL,CL
	MOV	CL,AL
NG10:	RET
FIXER:
	CALL	$GETYP
	JS	NG10
	CALL	$SIGNS
	JS	F4FX20
	JMP	$VINT
F4FX20: CALL	$NEG
	CALL	$VINT
	JMP	$NEG
ICOMP:				;COMPARE (DX) AND (BX)
				;(AL)=1 IF (DX) .LT. (BX)
				;(AL)=0 IF (DX) = (BX)
				;(AL)=-1 IF (DX) .GT. (BX)
	MOV	AX,BX		;SO WE CAN HAVE SEPARATE ENTRY FOR AX
ICMPA:	SUB	AX,DX		;COMPARISONS
	JZ	IC40		;ALL OK , JUST EXIT
	JO	IC20		;IF SF=1 ADDITIONALLY THEN AX LARGER
	JS	IC30		;DX DEFINITELY LARGER
IC10:	XOR	AL,AL		;(AX) LARGER
INRART: INC	AL		;(AL)=1
IC15:	RET
IC20:	JS	IC10
IC30:	STC
	SBB	AL,AL		;(AL)=377
IC40:	RET
IMOD:	CMP	BX,DX		;IF EQUAL RETURN ZERO
	JNZ	IMD10
IMD05:	XOR	BX,BX
	JMP	IMD40
IMD10:				;(BX)= (DX) MOD (BX)
	CMP	DX,100000	;CHECK FOR -32768
	JNZ	IMD15		;PROCEED IF NOT
	CMP	BX,177777	;Check for special case of -32768 MOD -1
	JE	IMD05
	CMP	BX,1		;Also for -32768 MOD 1
	JE	IMD05
IMD15:
	MOV	AX,DX
	MOV	WORD PTR $FACLO,BX
	OR	BX,BX
	JNZ	IMD17		; Trying to divide by zero?
	MOV	BYTE PTR $FAC+1,DH	; Yep, set up correct sign
	INC	BH		; Hack for DOINF to work
	MOV	BYTE PTR $VALTP,LOW 4
	JMP	$DIV0S
IMD17:
	MOV	WORD PTR $FAC-1,0
	JNS	IMD20
	MOV	WORD PTR $FAC-1,177777
IMD20:	OR	AX,AX
	MOV	DX,0
	JNS	IMD30
	MOV	DX,177777
IMD30:	IDIV	WORD PTR $FACLO
	MOV	BX,DX		;MOVE MOD TO BX
IMD40:	MOV	WORD PTR $FACLO,BX
	RET


; THIS IS THE INNER LOOP OF SYMBOL TABLE SEARCHING FOR NON-SUBSCRIPTED
; VARIABLES.
;
; Note 9-Aug-82/MLC - Entry is made at LOPFND, which does a CLD.
; Want this code to be fast so don't only do this one CLD for the
; entire piece of code.
;

LOPTOP: LODSW			;GET VALTYP IN [AL], 1ST CHAR IN [AH]
	CMP	AH,CL		;SAME 2ND CHAR?
	JZ	ISIT		;YES MAY BE VAR WERE LOOKING FOR
NOTIT1: INC	SI		;POINT AT LENGTH OF REST OF VAR CHARS
	ADD	AL,BYTE PTR 0[SI]	;ADD FURTHUR OFFSET
	INC	AL		;PLUS ONE
NOTIT0: CBW			;SIGN EXTEND IT
	ADD	SI,AX		;MOVE TO NEXT VARIABLE
NOTIT2: CMP	SI,BP		;DONE WITH SYMBOL TABLE SEARCH?
	JNZ	LOPTOP		;NO, KEEP LOOKING
	MOV	DX,SI		;POINT AFTER VAR
	JMP	NOTFNS		;SEE IF SEARCHED ALL TABLES

ISIT:	CMP	AL,BYTE PTR VALTYP	;VALTYP'S THE SAME?
	JNZ	NOTIT1		;NO, LOOK AT NEXT VAR
	CMP	CH,BYTE PTR 0[SI]	;2ND CHAR OF VAR THE SAME?
	JNZ	NOTIT1		;NO, KEEP LOOKING
	INC	SI		;POINT TO VALTYP
	MOV	DL,AL		;GET IN IN [DL]
	LODSB			;GET VALTYP IN [AL]
	CMP	AL,BYTE PTR NAMCNT	;SAME AS VAR WERE LOOKING FOR?
	JZ	LENMAT		;LENGTHS MATCH!
	ADD	AL,DL		;ADD SAVED VALTYP AND LENGTH OF VAR
	JMP	SHORT NOTIT0	;GO TO NEXT VAR

LENMAT: OR	AL,AL		;LENGTH ZERO?
	JZ	FNDITV		;YES, FOUND IT!
	CBW			;MAKE LENGTH A WORD
	XCHG	CX,AX		;SAVE 2 CHARS OF VAR, PUT LENGTH IN CX
	MOV	DI,OFFSET NAMBUF	;POINT TO NAME BUFFER
		     ;COMPARE TWO VAR NAMES
 REP	CMPSB			;WITH SPECIAL INSTR
	XCHG	AX,CX		;FLIP BACK
	JZ	FNDITV		;FOUND IT
	ADD	SI,AX		;ADD CHARS LEFT, CC'S SHOULD BE NON-ZERO
	MOV	AL,DL		;GET BACK SAVED VALTYP
	JMP	SHORT NOTIT0	;PROCEED WITH FAILED SEARCH
FNDITV: MOV	DX,SI		;GET POINTER TO VAR IN [DX]
	POP	BX		;RESTORE TEXT POINTER
	RET			;ALL DONE!!!

LOPFND: MOV	SI,BX		;START SEARCHING HERE
	MOV	BP,WORD PTR ARYTA2	;LIMIT OF VARIABLE SEARCH
	CLD			;INCREMENT
	JMP	SHORT NOTIT2	;START LOOKING


; THIS IS THE CORRESPONDING CODE FOR ARRAY SEARCHES
; Note 9-Aug-82/MLC - This code is supposed to be fast so only a
; single CLD is done here for the entire piece of code.
;

LOPFD1: MOV	SI,BX		;INITIALIZE POINTER TO SYMBOL TABLE
	MOV	BP,WORD PTR STREND	;GET LIMIT OF SEARCH
	CLD			;SET DIRECTION RIGHT
	JMP	LOPFDI		;START SEARCHING
LOPFD0: LODSW			;GET VALTYP AND 1ST CHAR OF VAR
	CMP	AH,CL		;ARE FIRST CHARS THE SAME?
	JZ	ISARY		;YES, COULD BE RIGHT ONE
NMARY1: INC	SI		;POINT TO LENGTH OF VAR
NMARY2: LODSB			;GET LENGTH OF IT
NMARY3: CBW			;EXTEND SIGN
	ADD	SI,AX		;ADD OFFSET
NMARY4: LODSW			;GET OFFSET TO ARRAY
	ADD	SI,AX		;POINT TO NEXT ARRAY
LOPFDI: CMP	BP,SI		;AT END OF ARRAYS?
	JNZ	LOPFD0		;NO, KEEP GOING
	MOV	BX,SI		;AT END
	JMP	NOTFDD		;RETURN TO MAIN-LINE CODE IN BIPTRG.MAC

ISARY:	CMP	AL,BYTE PTR VALTYP	;TYPE OF VARS THE SAME?
	JNZ	NMARY1		;NO, LOOK AT NEXT ONE
	CMP	CH,BYTE PTR 0[SI]	;2ND CHARS THE SAME?
	JNZ	NMARY1		;NO
	INC	SI		;POINT AT EXTRA CHARS
	LODSB			;FETCH NUMBER OF THEM
	CMP	AL,BYTE PTR NAMCNT	;SAME AS WHAT WE WANT?
	JNZ	NMARY3		;NO, LOOK AT NEXT VAR
	OR	AL,AL		;NO CHARS LEFT?
	JZ	CNOMAT		;YES, MATCH, ALL DONE
	CBW			;MAKE WORD
	XCHG	AX,CX		;PUT CHAR COUNT IN CX, SAVE FIRST TWO VAR CHARS
	MOV	DI,OFFSET NAMBUF	;POINT AT VAR BUFFER
		     ;COMPARE TWO VAR NAMES
 REP	CMPSB
	XCHG	AX,CX		;GET BACK 2 CHARS TO MATCH IN [CX]
				;REMAINING CHARS IN NAME IN [AX]
	JZ	CNOMAT		;VARS MATCHED
	ADD	SI,AX		;ADD REST OF CHARS TO WHERE WE ARE
	JMP	SHORT NMARY4	;LOOK AT NEXT VAR

CNOMAT: LODSW			;GET OFFSET TO END OF ARRAY
	MOV	DX,AX		;PROBOBALLY NOT USED
	MOV	BX,SI		;POINT TO NUMBER OF DIMENSIONS
	JMP	ARYEXT		;GO BACK


	SUBTTL	 $AEXPS  SINGLE AND DOUBLE PRECISION ADD/SUBTRACT OF EXPONENTS
;*************************************************************
;
;       $AEXPS,$SEXPS   WILL PERFORM THE ADDITION/SUBTRACTION
;               OF SINGLE OR DOUBLE PRECISION EXPONENTS.
;       CALLING SEQUENCE:       CALL    $AEXPS
;               OR              CALL    $SEXPS
;               WITH THE SINGLE PRECISION NUMERATOR(MULTIPLIER)
;               IN (BXDX) OR THE DOUBLE PRECISION NUMERATOR
;               (MULTIPLIER) IN ($ARG) AND THE DENOMINATOR
;               (MULTIPLICAND) IN THE ($FAC)
;               FOR DOUBLE PRECISION OPERATIONS THE $ARG  EXPONENT
;               AND HIGH MANTISSA BYTE MUST BE IN BH:BL PRIOR
;               TO A $SEXPS,$AEXPS CALL
;
;**************************************************************


$AEXPS: STC			;CF=1
	JMP	SHORT SES00
$SEXPS: CLC			;CF=0
SES00:	MOV	SI,BX		;WILL NEED FOR LATER
	PUSHF			;SAVE MULTIPLY/DIVIDE FLAG
	MOV	CX,WORD PTR $FAC-1	;(CH)=$FAC:(CL)=$FAC-1
	MOV	AL,BL		;FETCH (BXDX) SIGN BYTE
	XOR	AL,CL		;CORRECT SIGN IN AL
	MOV	BYTE PTR $FAC+1,AL	;MOVE TO $FAC+1
	MOV	AL,BH		;GET (BXDX) EXPONENT
	XOR	AH,AH		;WILL USE 16-BIT ARITHEMETIC
	MOV	BL,CH		;TO CALCULATE EXPONENTS
	XOR	BH,BH
	POPF			;SEE IF ADD OR SUBTRACT OF EXPONENTS
	JNB	SES05		;JUMP IF SUBTRACT
	ADD	AX,BX		;HAVE IN TWO BIASES
	SUB	AX,401		;NOW HAVE RAW SUM LESS 1
	JMP	SHORT SES07	;GO CHECK FOR OVERFLOW/UNDERFLOW
SES05:	SUB	AX,BX		;BIASES CANCEL OUT
SES07:	OR	AH,AH		;
	JS	SES10		;MUST GO CHECK FOR UNDERFLOW
	CMP	AX,200		;CF=0 IF OVERFLOW
	JB	SES20		;PROCEED IF OK
	MOV	BX,SI		;GET (BX) OFF STACK
	ADD	SP,2		;GET $SEXPS RETURN ADDRESS OFF STACK
	JMP	$OVFLS		;GO DO OVERFLOW CODE
SES10:				;POTENTIAL UNDERFLOW
	ADD	AX,200		;BIAS MUST BRING IT IN POSITIVE
	JNS	SES30		;IF IT IS POSITIVE PROCEED
	MOV	BX,SI		;BET (BX) OFF STACK
	ADD	SP,2		;GET $SEXPS RETURN ADDRESS OFF STACK
	JMP	$ZERO		;GO ZERO THE FAC AND RETURN
SES20:	ADD	AX,200		;ADD IN THE BIAS
SES30:	MOV	BYTE PTR $FAC,AL	;PUT CORRECT EXPONENT IN $FAC
	MOV	BX,OFFSET $FAC-1	;ADDRESS OF HIGH MANTISSA BITS
	OR	BYTE PTR 0[BX],LOW 200	;OR IN THE HIDDEN "1"
	MOV	BX,SI		;GET (BXDX) HIGH MANTISSA BITS
	XOR	BH,BH		;CLEAR SUPERFLUOUS BITS
	OR	BL,LOW 200	;RESTORE HIDDEN "1"
	RET

	SUBTTL	 $CHKEL  SUBROUTINE TO $FIN FOR CHECKING "ELSE" AND "EQV"
;*****************************************************************
;
;       $CHKEL  CHECKS AN INPUT STREAM FOR POSSIBLE "ELSE" OR "EQV"
;               CONSTRUCTS ONCE AN "E" HAS BEEN DETECTED. IF ONE OF
;               THESE CONSTRUCTS IS DETECTED ZF=1 WILL BE RETURNED
;               OTHERWISE ZF=0 WILL BE RETURNED.
;       CALLING SEQUENCE:       CALL    $CHKEL
;               WITH (BX) POINTING TO THE CURRENT POSITION IN THE
;               INPUT CHARACTER STREAM.
;
;******************************************************************
$CHKEL: PUSH	BX		;SAVE TEXT POINTER
	CALL	$CHRGT		;GET NEXT CHARACTER INTO (AL)
	CMP	AL,LOW OFFSET "L"+40    ;LOWER CASE "L"?
	JZ	CK10		;RETURN WITH ZF=1
	CMP	AL,LOW "L"      ;UPPER CASE "L"?
	JZ	CK10		;RETURN WITH ZF=1
	CMP	AL,LOW OFFSET "Q"+40    ;LOWER CASE "Q"?
	JZ	CK10		;RETURN WITH ZF=1
	CMP	AL,LOW "Q"      ;UPPER CASE "Q"?
;****************************************************************
;THAT LAST CMPBI WILL SET ZF APPROPRIATELY SO WE'LL EXIT NOW
;****************************************************************
CK10:	POP	BX		;GET TEXT POINTER BACK
	RET

	SUBTTL	 $EXP	 SINGLE PRECISION EXPONENTIAL FUNCTION
;*************************************************************
;
;THE FUNCTION EXP(X) CALCULATES e^X WHERE e=2.718282
;       THE TECHNIQUE USED IS TO EMPLOY A COUPLE
;       OF FUNDAMENTAL IDENTITIES THAT ALLOWS US TO
;       USE THE BASE 2 THROUGH THE DIFFICULT PORTIONS OF
;       THE CALCULATION:
;
;               (1)e^X=2^y  WHERE y=X*LOG2(e) [LOG2(e) IS
;                                               LOG BASE 2
;                                               OF e ]
;
;               (2) 2^y=2^[ INT(y)+(y-INT(y)]
;               (3) IF Ny=INT(y) THEN
;                   2^(Ny+y-Ny)=[2^Ny]*[2^(y-Ny)]
;
;       NOW, SINCE 2^Ny IS EASY TO COMPUTE (AN EXPONENT
;       CALCULATION WITH MANTISSA BITS OF ZERO) THE DIFFICULT
;       PORTION IS TO COMPUTE 2^(Y-Ny) WHERE 0.LE.(Y-Ny).LT.1
;       THIS IS ACCOMPLISHED WITH A POLYNOMIAL APPROXIMATION
;       TO 2^Z WHERE 0.LE.Z.LT.1  . ONCE THIS IS COMPUTED WE
;       HAVE TO EFFECT THE MULTIPLY BY 2^Ny .
;
;**************************************************************
;***********************************************************
;THIS IS EXPONENTIAL EVALUATION BY HART POLYNOMIAL EVALUATION
;USING COEFFICIENTS FROM #1302
;************************************************************
EXP:
$EXP:	MOV	DX,125073	;LOG2(e)
	MOV	BX,100470
	CALL	$FMULS		;y=FAC*LOG2(e)
	MOV	AL,BYTE PTR $FAC	;MUST SEE IF TOO LARGE
	CMP	AL,LOW 210	;ABS.GT.128?
	JNB	EXP110		;Yes, too big.  Go decide between
				;overflow and underflow.
	CMP	AL,LOW 150	;SEE IF TOO SMALL(ANS. OF 1.)
	JB	EXP200
	PUSH	WORD PTR $FACLO ;SAVE y
	PUSH	WORD PTR $FACLO+2
	CALL	$QINT		;Determine integer power of 2.
	MOV	AH,DL
	ADD	AH,LOW 201	;THIS WILL CALCULATE THE EXPONENT
				;FOR INTEGER POWER OF 2 FLOATING
				;POINT . WE USE 201 BECAUSE WE HAVE
				;A BIAS OF 200 AND THE UNDERSTOOD
				;1 OF FLOATING POINT NUMBERS IS TO
				;THE RIGHT OF THE BINARY POINT
	JZ	EXP100		;JUMP IF OVERFLOW
	PUSH	AX
	TEST	BYTE PTR $FAC+1,LOW 200O	;Set SF if negative.  ($QINT saved
				;the sign in $FAC+1.)
	CALL	NGBLDX		;Negate if necessary.
	XOR	AH,AH		;Clear overflow for $NORMS.
	CALL	$NORMS		;This will make the FAC INT(y).
	POP	AX
	POP	BX
	POP	DX		;RECALL y
	PUSH	AX		;SAVE EXPONENT
	CALL	$FSUBS		;WANT THE FRACTIONAL PART SO WE
				;CAN USE HART #1302 TO CALCULATE
				;2^y OF IT .(WE ALREADY
				;KNOW 2^Ny OF THE INTEGER PART
				;FROM THE ABOVE)
	MOV	BX,OFFSET $EXPCN	;POINT TO COEFFICIENTS
	CALL	$POLY		;DO THE CALCULATION
	POP	BX		;RECALL EXPONENT OF INTEGER 2^y
	XOR	DX,DX		;
	MOV	BL,DL		;WE NOW HAVE 2^Ny OF INTEGER
				;PART IN (BXDX) AND FRACTIONAL PART
				;IN THE $FAC. TO CALCULATE THE ANSWER
				;NEED ONLY TO MULTIPLY THESE VALUES
	JMP	$FMULS
EXP100:			;OVERFLOW WITH VALUES ON THE STACK
	ADD	SP,4
EXP110: AND	BYTE PTR $FAC-1,LOW 200O	;Is it positively too big?
	JZ	EXP115		;Yes, overflow.
	JMP	$ZERO		;No, underflow for negative.

EXP115: XOR	AH,AH		;OVERFLOW WITH STACK CLEAR
	MOV	BYTE PTR $FAC+1,AH	;MAKE SURE SIGN IS POSITIVE
				;to get postive infinity.
	JMP	$OVFLS		;GO DO OVERFLOW CODE

EXP200:			;WE HAVE DETERMINED THAT THE EXPONENT IS SO SMALL
				;THAT WE SHOULD RETURN 1. AS AN ANSWER
	MOV	DI,OFFSET $FACLO
	XOR	AX,AX		;.0
	CLD			;SO STOW WILL INCREMENT DI
	STOSW			;
	MOV	WORD PTR 0[DI],100400	;1.0
	RET

	SUBTTL	 $FADDD  DOUBLE PRECISION FLOATING POINT ADDITION
;************************************************************
;
;       $FADDD  THIS ROUTINE PERFORMS DOUBLE PRECISION FLOATING
;               POINT ADDITION/SUBTRACTION,I.E.
;               (FAC)=(FAC)+-(ARG)
;               THE LARGER NO. WILL BE PLACED IN THE FAC, THE SMALLER
;               NO. IN THE ARG WILL BE SHIFTED RIGHT UNTIL THEIR
;               BINARY POINTS ALIGN AND THE TWO WILL BE ADDED/
;               SUBTRACTED. IF IT TURNS OUT THAT THE EXPONENTS WERE
;               EQUAL AND THE OPERATION WAS A SUBTRACTION THEN
;               A CARRY OUT OF THE HIGH BYTE  CAN OCCUR.
;               IF THIS IS THE CASE, OUR CHOICE AS TO WHICH WAS THE
;               LARGER NO. WAS INCORRECT AND WE HAVE TO NEGATE
;               OUR MANTISSA AND COMPLEMENT THE SIGN OF THE RESULT.
;
;       CALLING SEQUENCE        CALL    $FADDD
;               WITH THE NOS. TO BE ADDED/SUBTRACTED IN THE DOUBLE
;               PRECISION FAC AND ARG
;THE FORMAT OF DOUBLE PRECISION NUMBERS IS AS FOLLOWS
;;
;BIT:
;66665555 55555544 44444444 33333333 33222222 22221111 11111100 00000000
;32109876 54321098 76543210 98765432 10987654 32109876 54321098 76543210
;AAAAAAAA BCCCCCCC CCCCCCCC CCCCCCCC CCCCCCCC CCCCCCCC CCCCCCCC CCCCCCCC
;[$FAC  ] [$FAC-1] [$FAC-2] [$FACLO] [$DFACL  [$DFACL  [$DFACL  [$DFACL]
;                                       +3  ]    +2  ]    +1  ]
;
;WHERE A=EXPONENT BIASED 128
;      B=SIGN(1=NEGATIVE,0=POSITIVE) OF NUMBER
;      C=BITS 2-56 OF MANTISSA (BIT 1 IS UNDERSTOOD 1)
;        (ALSO BIT 54 IS HIGH ORDER BIT)
;NOTE:THE BINARY POINT IS TO THE LEFT OF THE UNDERSTOOD 1
;
;****************************************************************

FADDX1: CALL	$MOVFA		;MOVE DOUBLE PREC ARG TO FAC
FADDX2: RET
$FSUBD:			;($FAC):=($ARG)-($FAC)
	MOV	AX,WORD PTR $FAC-1
	OR	AH,AH		;IF ZF=1 ARG IS ANSWER
	JZ	FADDX1
	XOR	BYTE PTR $FAC-1,LOW 200 ;FLIP SIGN OF FAC
DADD:
$FADDD:			;($FAC):=($ARG)+($FAC)
	MOV	AL,LOW 0	;WANT TO ZERO OVERFLOW BYTES
	MOV	BYTE PTR $DFACL-1,AL
	MOV	BYTE PTR $ARGLO-1,AL
	MOV	AL,BYTE PTR $ARG	;IF ($ARG)=0 THEN JUST RET
	OR	AL,AL		;
	JZ	FADDX2		;RETURN
	MOV	AX,WORD PTR $FAC-1	;
	OR	AH,AH		;IF EXPONENT=0, NO. IS ZERO
	JZ	FADDX1		;ARG IS THE ANSWER
	MOV	BX,WORD PTR $ARG-1	;FETCH SIGN AND EXPONENT
	OR	BYTE PTR $FAC-1,LOW 200 ;RESTORE HIDDEN 1 MANTISSA BIT
	OR	BYTE PTR $ARG-1,LOW 200
	MOV	CL,AH		;WILL FORM SHIFT COUNT IN (CL)
	SUB	CL,BH		;
	MOV	BYTE PTR $FAC+1,AL	;ASSUME SIGN OF FAC
	JZ	FDD25		;PROCEED IF EXPONENTS EQUAL
	JNB	FDD20		;IF FAC LARGER (OR EQUAL) JUMP
;********************************************************************
; $ARG HAS THE LARGER EXPONENT SO WE MUST EXCHANGE FAC AND ARG AND
;USE SIGN OF THE ARG
;********************************************************************
	XCHG	AL,BL		;HIGH MANTISSA BYTE EXCHANGE
	NEG	CL		;NED POS. SHIFT COUNT
	MOV	BYTE PTR $FAC+1,AL	;ADAPT ARG SIGN
	MOV	BYTE PTR $FAC,BH	;ADAPT ARG EXPONENT
	PUSH	AX		;SAVE ARG MANTISSA BITS
	PUSH	CX		;WILL NEED AS COUNT FOR LOOP
	CALL	$XCGAF		;EXCHANGE ARG AND FAC
	POP	CX		;RECALL OLD CX
	POP	AX		;GET MANTISSA BYTES BACK
FDD20:				;WE NOW HAVE THE SUSPECTED LARGER NO IN THE FAC, WE NEED
				;TO KNOW IF WE ARE TO SUBTRACT (SIGNS ARE DIFFERENT) AND
				;WE NEED TO RESTORE THE HIDDEN MANTISSA BIT
				;FURTHER, IF THERE IS TO BE MORE THAN 56 BITS SHIFTED
				;TO ALIGN THE BINARY POINTS THEN THE LESSOR NO. IS
				;INSIGNIFICANT IN COMPARISON TO THE LARGER NO. SO WE
				;CAN JUST RETURN AND CALL THE LARGER NO. THE ANSWER.
	CMP	CL,LOW 57D	;THIS MUST SET CF TO CONTINUE
	JNB	FDD95		;RETURN IF CF=0
	PUSH	BX		;SAVE MANTISSA BITS
	CLC			;SO WE DON'T GET CF IN THERE
	CALL	$SHRA		;SHIFT ARG RIGHT (CL) BITS
	MOV	AL,BYTE PTR $FAC+1	;RECALL SIGN (AL DESTROYED
				;BY $SHRA)
	POP	BX
FDD25:	XOR	AL,BL		;WILL NOW DETERMINE IF ADD/SUB
	MOV	BX,OFFSET $DFACL-1
	MOV	SI,OFFSET $ARGLO-1
	MOV	CX,4		;4 SIXTEEN BIT OPERATIONS
	CLC			;CF=0
;****************************************************************
;WE ARE NOW STAGED TO DO THE ADD/SUBTRACT. IT WILL BE DONE AS 4
;SIXTEEN BIT OPERATIONS.
;****************************************************************
	CLD			;SO LODW WILL INCB
				;Note 9-Aug-82/MLC - This CLD is
				;for the LODWs at both FDD30 and
				;FDD50.
	JS	FDD50		;IF SF=1 GO SUBTRACT
FDD30:	LODSW			;FETCH NEXT BYTE ARG
				;Note 9-Aug-82/MLC - CLD is outside
				;loop above.
	ADC	WORD PTR 0[BX],AX	;ADD IT TO FAC
	INC	BX
	INC	BX
	LOOP	FDD30
	JNB	FDD40		;GO ROUND IF CF=0
;*************************************************************
;WE HAD OVERFLOW OUT OF THE HIGH MANTISSA BIT. WE MUST INCREMENT
;THE EXPONENT AND SHIFT THE OVERFLOW BIT BACK INTO THE FAC BY
;SHIFTING THE FAC RIGHT 1 BIT.
;*************************************************************
FDD35:	MOV	BX,OFFSET $FAC	;FETCH ADDRESS OF EXPONENT
	INC	BYTE PTR 0[BX]	;INCREMENT THE EXPONENT
	JZ	FDD90		;IF ZF=1 - OVERFLOW
	DEC	BX
	DEC	BX		;BX POINTS TO $FAC-2
	MOV	CX,4		;4 SIXTEEN BIT SHIFTS
;**************************************************************
;WE ARE NOW SET TO SHIFT THE FAC RIGHT 1 BIT. RECALL WE GOT HERE
;WITH CF=1. THE INSTRUCTIONS SINCE WE GOT HERE HAVEN'T AFFECTED
;CF SO WHEN WE SHIFT RIGHT WE WILL SHIFT CF INTO THE HIGH MANTISSA
;BIT.
;*************************************************************
FDD37:	RCR	WORD PTR 0[BX],1
	DEC	BX
	DEC	BX
	LOOP	FDD37
FDD40:	JMP	$ROUND		;GO ROUND THE RESULT
FDD50:
;**************************************************************
;TO GET HERE THE SIGNS OF THE FAC AND ARG WERE DIFFERENT THUS
;IMPLYING A DESIRED SUBTRACT.
;**************************************************************
	LODSW			;FETCH NEXT WORD OF ARG
				;Note 9-Aug-82/MLC - The CLD is
				;just above FDD30.
	SBB	WORD PTR 0[BX],AX	;SUBTRACT FROM FAC
	INC	BX
	INC	BX
	LOOP	FDD50
	JNB	FDD80		;GO NORMALIZE AND ROUND
;************************************************************
;TO GET HERE FAC TURNED OUT SMALLER THAN THE ARG. TO CORRECT
;THE ANSWER IN THE FAC WE MUST NEGATE THE MANTISSA BITS
;AND THE SIGN IN $FAC+1
;***********************************************************
	NOT	BYTE PTR 1[BX]	;COMPLEMENT SIGN
	MOV	CX,4		;4 SIXTEEN BIT COMPLEMENTS
FDD60:	DEC	BX
	DEC	BX
	NOT	WORD PTR 0[BX]	;COMPLEMENT FAC
	LOOP	FDD60
;***********************************************************
;MUST NOW ADD 1 FOR 2'S COMPLEMENT ARITH.
;***********************************************************
	MOV	CX,4
FDD70:	INC	WORD PTR 0[BX]	;IF ZF=1 THEN CARRY
	JNZ	FDD80		;SINCE THEY DON'T SET CF
	INC	BX
	INC	BX
	LOOP	FDD70
	JZ	FDD35		;IF ZF=1 MUST INCREMENT EXP
FDD80:	JMP	$NORMD		;GO NORMALIZE
FDD90:	JMP	$OVFLS		;OVERFLOW!
FDD95:	JMP	$ROUNX		;PUT IN THE SIGN AND DONE

	SUBTTL	 $FADDS  SINGLE PRECISION FLOATING POINT ADD/SUB
;*********************************************************
;
;       $FADDS  FLOATING POINT ADDITION FOR SINGLE PRECISION
;               $FADDS FORMS THE SUM OF (BXDX) AND ($FAC) AND
;               LEAVES THE RESULT IN THE ($FAC).
;
;       CALLING SEQUENCE:       CALL    $FADDS
;       $FSUBS  FLOATING POINT SUBTRACTION FOR SINGLE PRECISION
;               $FSUBS FORMS THE DIFFERENCE (BXDX)-(FAC) AND
;               LEAVES THE RESULT IN THE (FAC).
;       CALLING SEQUENCE:       CALL    $FSUBS
;
;**********************************************************

FEXIT1: MOV	WORD PTR $FAC-1,BX	;MOV (BXDX) TO $FAC
	MOV	WORD PTR $FACLO,DX
EXIT2:	RET
$FSUBS: MOV	AX,WORD PTR $FAC-1	;FETCH FAC
	OR	AH,AH		;IF ZF=1 (BXDX) IS ANSWER
	JZ	FEXIT1		;(BXDX) IS THE ANSWER
	XOR	BYTE PTR $FAC-1,LOW 200 ;FLIP SIGN
$FADDS:			;($FAC)=(BXDX)+($FAC)
	OR	BH,BH		;WILL FIRST CHECK EXPONENT OF (BXDX)
	JZ	EXIT2		;ANS ALREADY IN $FAC
	MOV	AX,WORD PTR $FAC-1	;WILL NOW CHECK $FAC AND IF ZERO
	OR	AH,AH		;ANSWER IN (BXDX) AND MUST MOVE
	JZ	FEXIT1		;MOVE (BXDX) TO FAC
				;****************************************************
				;KNOW AT THIS POINT THAT NEITHER (BXDX) NOR THE
				;$FAC ARE ZERO. THE SUM WILL BE PERFORMED BY EXAMINATION
				;OF THE EXPONENTS, PLACING THE NUMBER WITH THE LARGER
				;EXPONENT IN THE $FAC,AND SHIFTING THE SMALLER NUMBER RIGHT
				;UNTIL BINARY POINTS ALIGN, THEN ADDING THE MANTISSAS
				;IF THE SIGNS ARE THE SAME OR SUBTRACTING THE MANTISSAS
				;IF THE SIGNS ARE DIFFERENT. THE EXPONENT OF THE ANSWER
				;IS THE EXPONENT OF THE LARGER NUMBER. THE FORMAT OF
				;FLOATING POINT NUMBERS IS AS FOLLOWS:
				;
				;BIT    33222222 22221111 11111100 00000000
				;       10987654 32109876 54321098 76543210
				;       AAAAAAAA BCCCCCCC CCCCCCCC CCCCCCCC
				;BYTE   [ $FAC ] [$FAC-1] [$FAC-2] [$FAC-3]
				;                                  [$FACLO]
				;
				;WHERE  A=BITS OF EXPONENT BIASED BY 128
				;       B=0 IF NUMBER IS POSITIVE,1 IF NEGATIVE
				;       C=BITS 2-24 OF MANTISSA(BIT 1 IS UNDERSTOOD 1)
				;NOTE:THE BINARY POINT IS TO THE LEFT OF THE UNDERSTOOD 1
				;
				;******************************************************

	XOR	CX,CX		;(CX)=0
	MOV	SI,WORD PTR $FACLO	;(SI)=($FAC-2,$FACLO)
	MOV	BYTE PTR $FAC+1,AL	;ASSUME SIGN OF $FAC
	MOV	CL,AH		;SINCE ASSUME $FAC LARGER
	SUB	CL,BH		;CL WILL HOLD SHIFT COUNT
	JNB	FA20		;JUMP IF $FAC EXP EQUAL OR LARGER
	NEG	CL		;NEED POS. SHIFT COUNT
	XCHG	BL,BH
	MOV	WORD PTR $FAC,BX	;SINCE (BXDX) LARGER MAGNITUDE
	XCHG	BL,BH		;GET EXP/SGN CORRECT AGAIN
	XCHG	BX,AX		;WILL EXCHANGE (BXDX) AND (AXSI)
	XCHG	DX,SI		;
FA20:				;********************************************************
				;AT THIS POINT SUSPECTED LARGER NUMBER IS IN (AXSI) WITH
				;SMALLER IN (BXDX). THIS WILL BE THE CASE UNLESS THE EXPONENTS
				;WERE EQUAL. IF THE EXPONENTS WERE EQUAL AND THIS IS
				;TO BE A SUBTRACTION A NEGATIVE MANTISSA COULD RESULT. IF THIS
				;HAPPENS, WE MUST COMPLEMENT THE MANTISSA AND THE SIGN OF THE
				;RESULT.
				;********************************************************
	MOV	AH,AL		;WILL NOW DETERMINE IF ADD OR
	XOR	AH,BL		;SUBTRACT
	PUSHF			;SF=1 IF SUBTRACT
	MOV	AH,LOW 200	;WILL REPLACE UNDERSTOOD 1
	OR	AL,AH
	OR	BL,AH
	XOR	AH,AH		;(AH) WILL BE OVERFLOW BYTE
	MOV	BH,AH		;(AH)=(BH)=0
FA22:	OR	CX,CX		;ZF=1 IF EXPONENTS THE SAME
	JZ	FA40		;IF EXPONENTS SAME JUMP
	CMP	CX,31		;MUST SEE IF WITHIN 24 BITS
	JB	FA23		;IF SO PROCEED
;*************************************************************
;THE NUMBERS WE ARE TRYING TO ADD/SUBTRACT ARE OF SUCH DIFFERENCE
;IN MAGNITUDE THAT THE SMALLER IS NEGLIGIBLE WITH RESPECT TO THE
;LARGER. OUR ANSWER THEREFORE IS THE NUMBER WITH THE ABSOLUTE
;LARGER MAGNITUDE. THE MANTISSA OF THIS NO. IS IN (AL:SI)
;**************************************************************
	POPF			;CLEAR SUBTRACT/ADD FLAG
	MOV	WORD PTR $FACLO,SI	;RESTORE LOWER MANTISSA BITS
	MOV	AH,BYTE PTR $FAC+1	;FETCH SIGN
	AND	AX,100177	;CLEAR SIGN IN AH, ALL BUT SIGN IN AL
	OR	AL,AH		;RESTORE SIGN
	MOV	BYTE PTR $FAC-1,AL	;$FAC NOW CORRECTLY BUILT
	RET
FA23:
				;WILL TRY FOR BYTE MOVES
	CMP	CL,LOW 10	;NEED AT LEAST 8 BITS
	JB	FA27		;IF NOT PROCEED AS NORMAL
	MOV	DI,AX		;WILL WANT TO CHECK THIS FOR ST
	MOV	AH,DL		;SHIFT OVERFLOW BITS
	TEST	DI,177400O	;DID WE SHIFT THROUGH ST?
	JZ	FA24
	OR	AH,LOW 40	;PUT ST BACK IN
FA24:
	MOV	DL,DH
	MOV	DH,BL
	XOR	BL,BL		;CLEAR UPPER BITS
	SUB	CL,LOW 10
	TEST	AH,LOW 37	;SHIFT THRU ST
	JZ	FA22		;IF NOT TRY AGAIN
	OR	AH,LOW 40
	JMP	SHORT FA22
FA25:	OR	AH,LOW 40	;"OR" IN ST BIT
	LOOP	FA30		;CONTINUE LOOP
	JMP	SHORT FA40	;IF FINISHED JUMP
FA27:	CLC			;MAKE SURE CARRY CLEAR BEFORE SHIFT
FA30:	RCR	BL,1
	RCR	DX,1
	RCR	AH,1		;SHIFT (BLDXAH)RIGHT ONE BIT
	TEST	AH,LOW 20	;SEE IF ST SET
	JNZ	FA25
				;CARRY INTO HIGH BIT
	LOOP	FA30		;LOOP UNTIL (CX)=0
FA40:	POPF			;IF SF=1 WE MUST SUBTRACT MANTISSAS
	JNS	FA50		;IF SF=0 GO ADD MANTISSAS
	SUB	CL,AH		;SUBTRACT UNDERFLOW BYTE
	MOV	AH,CL		;MUST GO TO NORMS WITH MANT. IN (BLDXCL)
	SBB	SI,DX
	MOV	DX,SI
	SBB	AL,BL		;IF CARRY (CF) NOT SET THEN
	MOV	BL,AL
	JNB	FA90		;ASSUMPTION OF $FAC LARGER VALID
	NOT	BYTE PTR $FAC+1 ;MUST USE OTHER SIGN $FAC WASN'T
	NOT	AH		;LARGER
	NOT	DX
	NOT	BL
	INC	AH		;INCREMENT BY ONE AND SET CARRY
	JNZ	FA90		;IF ZF=0 GO NORMALIZE
	INC	DX		;INCREMENT BY ONE
	JNZ	FA90		;IF ZF=0 GO NORMALIZE
	INC	BL		;INCREMENT BY ONE
	JNZ	FA90		;IF ZF=0 GO NORMALIZE
	JMP	SHORT FA60
FA50:
;************************************************************
;SIGNS OF THE NUMBERS WERE THE SAME SO WE ADD MANTISSAS HERE
;*************************************************************
	ADD	DX,SI		;ADDITION OF LOW BITS
	ADC	BL,AL		;ADDITION OF HIGH BITS
	JNB	FA70
FA60:				;HERE WHEN WE HAVE OVERFLOWED THE HIGH MANTISSA BYTE
				;AND MUST INCREMENT THE EXPONENT
	INC	BYTE PTR $FAC	;INCREMENT THE EXPONENT
	JZ	FA80		;OVERFLOW!
	RCR	BL,1		;MUST SHIFT RIGHT ONE BIT
	RCR	DX,1
	RCR	AH,1
FA70:	JMP	$ROUNS
FA80:	JMP	$OVFLS		;DO OVERFLOW CODE
FA90:	JMP	$NORMS		;GO NORMALIZE

	SUBTTL	 DDIV	 DOUBLE PRECISION DIVIDE (FAC)=(ARG)/(FAC)
;*****************************************************************
;
;       $FDIVD  THIS ROUTINE DIVIDES THE ARG BY THE FAC LEAVING THE
;               QUOTIENT IN THE FAC
;       CALLING SEQUENCE:       CALL    $FDIVD
;
;*******************************************************************

EXIT1:	JMP	$DZERO		;ZERO THE FAC
DOVCKJ: JNS	EXIT1
	JMP	$OVFLS
DDIV:
DDIVFA: MOV	SI,OFFSET $DFACL
	MOV	DI,OFFSET $ARGLO
	JMP	SHORT $DDIV
$FDIVD:
	MOV	SI,OFFSET $ARGLO
	MOV	DI,OFFSET $DFACL
$DDIV:
	MOV	AX,WORD PTR 6[SI]	;High half of numerator
	MOV	CX,WORD PTR 6[DI]	;High half of denominator
	XOR	AL,CL		;Compute sign
	MOV	BYTE PTR $FAC+1,AL	;and store in $FAC
	OR	CH,CH		;Denominator zero?
	JZ	DDIV0
	OR	AH,AH		;Numerator zero?
	JZ	EXIT1
	SUB	AH,LOW 128D	;Remove bias from exponents
	SUB	CH,LOW 128D
	SUB	AH,CH		;Compute result exponent
	JO	DOVCKJ

;AH has the (tentative) true exponent of the result. It is correct if the
;result needs normalizing one bit. If not, 1 will be added to it. A true
;exponent of -128, not normally allowed except to represent zero, is OK
;here because of this possible future incrementing.

	CLD			;9-Aug-82/MLC - Good for the LODC,
				;LODW, LODW, and LODW which follow.
	ADD	AH,LOW 128D	;Put bias back
	PUSH	AX		;SAVE sign and exponent
	LODSB			;Load up dividend
	MOV	CH,AL
	XOR	CL,CL
	LODSW
	XCHG	AX,BX
	LODSW
	XCHG	AX,DX
	LODSW
	OR	AH,LOW 200O	;Set implied bit
	XCHG	AX,DX		;Divisor in DX:AX:BX:CX

;Move divisor to FAC so we can get at it easily. More importantly, get it in
;the necessary form - extended to 64 bits with zeros, implied bit set.
;The form we want it in will have the mantissa MSB where the exponent usually
;is, so by moving high to low we will not destroy the divisor even if it is
;already in the FAC.

	MOV	SI,DI
	ADD	SI,5		;Point to high end of divisor
	MOV	DI,OFFSET $FAC-1
	STD			;Direction DOWN
	MOVSW			;Move divisor to FAC
	MOVSW
	MOVSW
	INC	SI
	INC	DI
	MOVSB
	CLD			;DRESTR direction
	MOV	BYTE PTR 0[DI],LOW 0	;Extend to 64 bits with a zero
	OR	BYTE PTR $FAC,LOW 200O	;Set implied bit

;Now we're all set:
;       DX:AX:BX:CX has dividend
;       FAC has divisor (not in normal format)
;Both are extended to 64 bits with zeros and have implied bit set.
;Top of stack has sign and tentative exponent.

	SHR	DX,1		;Make sure dividend is smaller than divisor
	RCR	AX,1		;   by dividing it by two
	RCR	BX,1
	RCR	CX,1
	CALL	DDIV16		;Get a quotient digit
	PUSH	DI
	CALL	DDIV16
	PUSH	DI
	CALL	DDIV16
	PUSH	DI
	CALL	DDIV16
	OR	AX,BX		;Remainder zero?
	OR	AX,CX
	OR	AX,DX
	MOV	DX,DI		;Get lowest word in position
	JZ	DNSTK1
	OR	DL,LOW 1	;Set sticky bit if not
DNSTK1:
	POP	CX		;Recover quotient digits
	POP	BX
	POP	DI
	JMP	DNRMCHK

DDIV0:	MOV	BYTE PTR $FAC+1,AL
	JMP	$DIV0S

DDIV16:
	MOV	SI,WORD PTR $DFACL+6	;Get high word of divisor
	XOR	DI,DI		;Initialize quotient digit to zero
	CMP	DX,SI		;Will we overflow?
	JAE	DMXQUO		;If so, go handle special
	OR	DX,DX		;Is dividend small?
	JNZ	DODIV
	CMP	SI,AX		;Will divisor fit at all?
	JA	ZERQUO		;No - quotient is zero
DODIV:
	DIV	SI		;AX is our digit "guess"
	PUSH	DX		;SAVE remainder
	XCHG	AX,DI		;Quotient digit in DI
	XOR	BP,BP		;Initialize quotient * divisor
	MOV	SI,BP
	MOV	AX,WORD PTR $DFACL
	OR	AX,AX		;If zero, SAVE multiply time
	JZ	REM2
	MUL	DI		;Begin computing quotient * divisor
	MOV	SI,DX
REM2:
	PUSH	AX		;SAVE lowest word of quotient * divisor
	MOV	AX,WORD PTR $DFACL+2
	OR	AX,AX
	JZ	REM3
	MUL	DI
	ADD	SI,AX
	ADC	BP,DX
REM3:
	MOV	AX,WORD PTR $DFACL+4
	OR	AX,AX
	JZ	REM4
	MUL	DI
	ADD	BP,AX
	ADC	DX,0
	XCHG	AX,DX
REM4:				;Quotient * divisor in AX:BP:SI:[SP]
	POP	DX		;Recover lowest word of quotient * divisor
	NEG	DX		;Subtract from dividend
	SBB	CX,SI
	SBB	BX,BP
	POP	BP		;Remainder from DIV
	SBB	BP,AX
	XCHG	AX,BP
ZERQUO:			;Remainder in AX:BX:CX:DX
	XCHG	AX,DX
	XCHG	AX,CX
	XCHG	AX,BX
	JNB	RETRES		;Remainder in DX:AX:BX:CX
DRESTR:
	DEC	DI		;Drop quotient since it didn't fit
	ADD	CX,WORD PTR $DFACL	;Add divisor back in until remainder goes +
	ADC	BX,WORD PTR $DFACL+2
	ADC	AX,WORD PTR $DFACL+4
	ADC	DX,WORD PTR $DFACL+6
	JNB	DRESTR
RETRES: RET

DMXQUO:
	DEC	DI		;DI=FFFF=2**16-1
	SUB	CX,WORD PTR $DFACL
	SBB	BX,WORD PTR $DFACL+2
	SBB	AX,WORD PTR $DFACL+4
	ADD	CX,WORD PTR $DFACL+2
	ADC	BX,WORD PTR $DFACL+4
	ADC	AX,DX
	MOV	DX,WORD PTR $DFACL
	CMC
	JMP	SHORT ZERQUO
DNRMCHK:
	POP	AX		;Get exp. and sign back
	OR	DI,DI		;See if normalized
	JS	DINCEX		;Yes - increment exponent
	SHL	DX,1		;Normalize
	RCL	CX,1
	RCL	BX,1
	RCL	DI,1
	OR	AH,AH
	JNZ	DDRND
	JMP	$DZERO
DINCEX:
	INC	AH
	JZ	DDOVFL
$DROUND:
DDRND:
	CMP	DL,LOW 200O	;Check extended bits
	JA	FPRNDUP
	JB	DDSV
;Extended bits equal exactly one-half LSB, so round even
	TEST	DH,LOW 1	;Already even?
	JZ	DDSV
FPRNDUP:
	ADD	DH,LOW 1
	ADC	CX,0
	ADC	BX,0		;Propagate carry
	ADC	DI,0
	JNB	DDSV		;Overflow?
;If we overflowed, DI:BX:CX:DH must now be zero, so we can leave it that way.
	INC	AH		;Increment exponent
	JNZ	DDSV
DDOVFL: JMP	$OVFLS
DDSV:
	AND	AL,LOW 200O	;Strip to sign bit
	XCHG	BX,DI
	AND	BH,LOW 177O	;Mask off implied bit
	OR	AL,BH		;Combine sign with mantissa
	MOV	WORD PTR $DFACL+6,AX
	MOV	BYTE PTR $FAC-2,BL
	MOV	BX,DI
	MOV	DI,OFFSET $DFACL
	MOV	AL,DH
	CLD
	STOSB
	XCHG	AX,CX
	STOSW
	XCHG	AX,BX
	STOSW
	RET

	SUBTTL	 SDIV	 SINGLE PRECISION FLOATING POINT DIVIDE
;****************************************************************
;
;       $FDIVS  THIS ROUTINE FORMS THE QUOTIENT (BXDX)/(FAC)
;               AND RETURNS IT TO THE FAC
;
;******************************************************************

;$DIV0S IS THE DIVIDE BY ZERO ENTRY INTO OVERFLOW CODE
;$SIGNS WILL SET THE CONDITION CODES ACCORDING TO THE VALUE OF THE
;       FAC,I.E. ZF=1 IF (FAC)=0, SF=1 IF FAC NEGATIVE, AND NEITHER
;       OF THESE IF (FAC) GREATER THAN 0
;$ZERO CLEARS THE 4 BYTES OF THE FAC
$FDIVS: CALL	$SIGNS		;MUST BE SURE (FAC) NOT ZERO
	JNZ	FDS00
	MOV	BYTE PTR $FAC+1,BL	;PUT IN FOR CORRECT OVERFLOW SIGN
	JMP	$DIV0S		;IF SO OVERFLOW!
FDS00:
	OR	BH,BH		;IF (BXDX)=0 ANSWER IS ZERO
	JNZ	FDS10		;PROCEED IF (BXDX) NON-ZERO
FDS05:	JMP	$ZERO
FDS10:
	MOV	WORD PTR $DFACL,DX	;WILL PUT NUMERATOR IN $DFAC
	MOV	WORD PTR $DFACL+2,BX
	MOV	SI,OFFSET $DFACL
	MOV	DI,OFFSET $FACLO
;***  $SDIV - Single precision divide
;
; Inputs:
;       SI = Address of Dividend (Numerator)
;       DI = Address of Divisor (Denominator)
; Function:
;       FAC = 0(.SI) / 0(.DI)
; Outputs:
;       Result in FAC.
; Registers:
;       All except BP destroyed.

$SDIV:
	MOV	CX,WORD PTR 2[DI]	;Exponent and sign of denominator
	MOV	AX,WORD PTR 2[SI]	;Exponent and sign of numerator
	XOR	AL,CL		;Compute sign
	MOV	BYTE PTR $FAC+1,AL	;Save sign in case OVERFLOW
	SUB	AH,LOW 128D	;Remove bias from exponents
	SUB	CH,LOW 128D
	SUB	AH,CH		;Compute result exponent
	JO	OVCHKJ

;AH has the (tentative) true exponent of the result. It is correct if the
;result needs normalizing one bit. If not, 1 will be added to it. A true
;exponent of -128, not normally allowed except to represent zero, is OK
;here because of this possible future incrementing.

	ADD	AH,LOW 128D	;Put bias back
	PUSH	AX		;Save sign and exponent
	OR	CL,LOW 200O	;Set implied bit
	MOV	DX,WORD PTR 1[SI]	;Most significant part of numerator mantissa
	MOV	AH,BYTE PTR 0[SI]	;Least significant part
	XOR	AL,AL		;Extend with zero
	OR	DH,LOW 200O	;And set implied bit
	MOV	BX,WORD PTR 1[DI]	;Load denominator into BX:CX
	MOV	CH,BYTE PTR 0[DI]
	XOR	CL,CL
	OR	BH,LOW 200O

;Now we have the following configuration:
;       Numerator in DX:AX
;       Denominator in BX:CX
; Both are extended to 32 bits with trailing zeros and have implied bit set
;       Result will go in BX:DX
;
;The algorithm used here is similar to Algorithm D, p.237, Knuth vol. 2.
;It is basically just ordinary long division, except the base is 2^16. This
;means we are dividing two 2-digit numbers, where each "digit" takes a whole
;word. We "guess" at a quotient digit, multiply it by the divisor, and subtract
;from the current dividend to get a remainder. This remainder could be
;negative, so we try a quotient digit one smaller.
;
;The "guess" at the quotient digit simply uses the 8086 DIV instruction.
;Computing the remainder takes advantage of the remainder from this divide. If
;the remainder comes out negative, new quotient digits are tried by repeated
;addition, rather than another multiply. Theorem B on p.237 of Knuth vol. 2
;guarantees that this repeated addition will happen no more than twice.

	SHR	DX,1
	RCR	AX,1		;Ensure DX<BX so divide won't OVERFLOW
	CALL	DIV16		;Get first 16 bits of quotient
	PUSH	SI		;Save high half of quotient on stack
	CALL	CDIV16		;Get second 16 bits of quotient
	OR	AX,DX		;Remainder 0?
	MOV	DX,SI		;Want low half of result in DX
	JZ	NSTK1
	OR	DL,LOW 1	;Set sticky bit if remainder not zero
NSTK1:
	POP	BX		;Recover high half of result
	JMP	NORMCHK

OVCHKJ:
	JNS	FDS05		;ZERO THE FAC
SDIVOVFL:
	JMP	$OVFLS		;OVERFLOW
DIV0:	JMP	$DIV0S

CDIV16:
	CMP	DX,BX		;Will we OVERFLOW on divide?
	JAE	MAXQUO		;Special code for maximum quotient
DIV16:
	DIV	BX		;32 by 16 bit division
	XCHG	AX,SI		;Put 16-bit quotient in SI
	XOR	AX,AX		;DX:AX has remainder
	JCXZ	RETJ		;Is this complete result?
	MOV	DI,DX		;Save remainder while we multiply
	MOV	AX,SI
	MUL	CX		;Low half of divisor times quotient
	NEG	AX		;Subtract from remainder, whose low half is 0
	SBB	DI,DX
	MOV	DX,DI		;Remainder again in DX:AX
	JNB	RETJ		;If not negative, divide was good
RESTORE:
	DEC	SI		;Quotient is too big
	ADD	AX,CX		;And remainder too small (negative)
	ADC	DX,BX		;So add divisor back in till positive
	JNB	RESTORE
RETJ:	RET
NORMCHK:
	POP	AX		;Get exp. and sign back
	OR	BH,BH		;See if normalized
	JS	INCEXP		;Yes-increment exponent
	SHL	DX,1		;Normalize
	RCL	BX,1
	OR	AH,AH		;test exponent
	JNZ	ROUND		;brif exponent not zero
	JMP	$ZERO		;underflow if exponent zero

INCEXP:
	INC	AH
	JZ	SDIVOVFL
$SRND:
;Round single precision and store in $FACLO

ROUND:
	CMP	DL,LOW 200O	;Check extended bits
	JA	ROUNDUP
	JB	SAVE
;Extended bits equal exactly one-half LSB, so round even
	TEST	DH,LOW 1	;Already even?
	JZ	SAVE
ROUNDUP:
	ADD	DH,LOW 1
	ADC	BX,0		;Propagate carry
	JNB	SAVE		;OVERFLOW?
;If we OVERFLOWed, BX:DH must now be zero, so we can leave it that way.
	INC	AH		;Increment exponent
	JZ	SDIVOVFL
SAVE:
	AND	AL,LOW 200O	;Strip to sign bit
	AND	BH,LOW 177O	;Mask off implied bit
	OR	AL,BH		;Combine sign with mantissa
	MOV	WORD PTR $FACLO+2,AX
	MOV	AH,BL
	MOV	AL,DH
	MOV	WORD PTR $FACLO,AX	;Save lower part of mantissa
	RET
MAXQUO:
;Come here if divide instruction would OVERFLOW. This must mean that DX=BX,
;i.e., the high half of the divisor and dividend are equal. Assume a result
;of (2^16)-1, which will give us a remainder equal to divisor plus (low half
;of dividend minus low half of divisor, times 2^16).

	MOV	SI,-1		;Quotient of (2^16)-1
	SUB	AX,CX		;Dividend - divisor (always negative)
	ADD	DX,AX		;Add to high half of divisor
	MOV	AX,CX
	JNB	RESTORE	;Carry means it's not negative any more
	RET