*
*
*    THIS PROGRAM IS A FOUR FUNCTION FLOATING POINT BCD
*    MATH PACKAGE.
*
* EACH FUNCTION MAY BE EXPRESSED AS: BC=DE # HL
*
*     <BC> = ADDRESS OF RESULT
*     <DE> = ADDRESS OF 1ST ARGUMENT
*     <HL> = ADDRESS OF 2ND ARGUMENT
*       #    IS ONE OF THE FUNCTIONS: +,-,X,/,^
*
* ALL ADDRESSES ON ENTRY, POINT TO THE EXPONENT PART OF
* THE FLOATING POINT NUMBER.
*
* EACH FLOATING POINT NUMBER CONSISTS OF (2*DIGIT) PACKED
* DECIMAL DIGITS, A SIGN AND A BIASED BINARY EXPONENT.  THE
* EXPONENT RANGE IS 10**-127 TO 10**127.
*
* THE NUMBER ZERO IS REPRESENTED BY THE EXPONENT 0.
* THE NUMBERS ARE STORED IN MEMORY AS (DIGIT) BYTES OF
* OF DECIMAL DIGITS STARTING AT THE LOW ORDER ADDRESS.
*
* ALL NUMBERS ARE ASSUMED TO BE NORMALIZED.  THAT IS EACH
* NUMBER CAN BE REPRESENTED AS  F**E.
*    WHERE  .1<=F<1.0 AND E IS THE EXPONENT
*
*
*
*
*
*        FLOATING POINT ADDITION
*
FADD PUSH B  SAVE RESULT ADDRESS
FADD1 CALL EXPCK  FETCH AND ALIGN ARGUMENTS.
*  THE NUMBER WITH THE LARGER EXPONENT IS POINTED TO BY DE.
*  THE # WITH THE SMALLER EXP IS IN BUF AND SIGN.
 MVI C,0  DON'T CARE IF ARGUMENTS ARE REVERSED.
*
ADSUM DCX D  MOVE TO SIGN OF LARGER NUMBER.
 XCHG
 LDA SIGN  SIGN OF SMALLER NUMBER.
 XRA M  DETERMINE WHETHER WE ADD OR SUBTRACT. 0-ADD;1-SUB.
 MOV B,A
 MOV A,M  SIGN OF RESULT IS SIGN OF LARGER # EXCEPT WHEN
 XCHG .  SUBTRACTING AND THE ARGUMENTS WERE REVERSED, I.E.
 DCX D  SMALLER MINUS LARGER.  THEN SIGN OF RESULT IS THE
 XRA C  OPPOSITE OF THE SIGN OF THE LARGER NUMBER.
 STA SIGN  REMEMBER THAT.
*
 MOV A,B  GET THE OPERATION INDICATOR.
 ORA A  TEST IT.
 JNZ ADS1  GO SUBTRACT.
*
*  THE ADD
*
 CALL ADD  CARRY IS CLEAR ON ENTRY; INDICATES CARRY OUT ON EXIT.
 JNC ADS8  RESULT FIT IN DIGIT*2 BYTES.
*
*  SINCE THERE WAS A CARRY OUT OF THE LEFT END FROM ADDING,
*  WE HAVE TO SHIFT THE RESULT RIGHT 1 DIGIT, USE THE DIGIT
*  WE ARE LOSING FOR ROUNDING, AND ADJUST THE EXPONENT.
*
ADS8A LDA BUF+DIGIT-1  GET THE DIGIT ABOUT TO BE SHIFTED AWAY.
 STA RDIGI  SAVE IT FOR LATER ROUNDING.
 MVI A,1  MAKE A FLAG TO INDICATE THAT
 STA RCTRL  ROUNDING DIGIT IS IN THE LOW NIBBLE OF RDIGI.
*
 LXI B,4*256+DIGIT+1  B <= 4 (NUMBER OF BITS TO SHIFT RIGHT)
*                     C <= DIGIT+1 (COUNT OF BYTES FOR RIGHT)
 CALL RIGH1  THIS ENTRY TO RIGHT ASSUMES C IS SET. (QUICKER)
 LXI H,EXP  ADJUST EXPONENT UP SINCE WE DECREASE THE # BY SHIFT
 INR M
 JZ OVER  IF NUMBER GOT TOO BIG.
*
ADS8 CALL SETROUND  SETS CARRY IF ROUNDING DIGIT >= 5.
 JNC ADS2  NO ROUNDING SO THE ADD IS DONE!
*
*  WE NEED TO ROUND SO INCREMENT RESULT STARTING AT RIGHT END.
*
 LXI H,BUF+DIGIT-1  POINT TO END OF RESULT.
 MVI B,DIGIT  COUNT OF BYTES TO PARTICIPATE.
*
*  CARRY IS SET FROM SETROUND AND GETS ADDED IN TO THE RESULT.
*
ADS8B MOV A,M  GET A BYTE OF THE RESULT.
 ACI 0  ADD IN THE CARRY FROM LAST ROUND.
 DAA .  KEEP IT NICE.  POSSIBLY SET CARRY FOR NEXT TIME.
 MOV M,A  PUT THE NEW ANSWER BACK.
 DCX H  POINT TO NEXT BYTE.
 DCR B  ARE WE DONE YET?
 JNZ ADS8B  LOOP UNTIL ALL DIGIT BYTES ARE DONE.
 JNC ADS2  NO OVERFLOW FOR ROUNDING SO DONE.
*
 INR M  ROUNDING OVERFLOW SO PUT 1 IN BYTE ABOVE BUF.
 JMP ADS8A  GO ADJUST AGAIN.
*
ADS2 POP B  GET RESULT ADDRESS
*
*    STORE RESULT IN RESULT ADDRESS
*
STORE LXI H,EXP
STORO MVI E,DIGIT+2
STOR1 MOV A,M
 STAX B
 DCX H
 DCX B
 DCR E
 JNZ STOR1
 RET .  EXIT FROM ROUTINES
*
*
*     CLEAN UP STACK--ZERO SIGN AND EXPONENT
*
*
*
ZERE0 POP H  RESULT ADDRESS
ZEX MVI C,DIGIT+2  NUMBER TO CLEAR
*
CLEAR XRA A
CLER1 MOV M,A
 DCX H
 DCR C
 JNZ CLER1
 RET
*
*
*
*   ADD ROUTINE
*
ADD LXI H,BUF+DIGIT-1
 MVI B,DIGIT
*
ADD1 LDAX D
 ADC M
 DAA
 MOV M,A
 DCX H
 DCX D
 DCR B
 JNZ ADD1
 RNC
 INR M
 RET
*
*
*          FLOATING POINT SUBTRACTION
*
FSUB PUSH B
FSUB1 CALL EXPCK  GET ARGUMENTS
 LDA SIGN
 XRI 1  COMPLEMENT SIGN
 STA SIGN
 JMP ADSUM
*
ADS1 CALL SETROUND  SET THE CARRY IF THE ROUNDING DIGIT >=5.
 CMC .  IN SUBTRACTION THE BORROW (CARRY) HAS THE REVERSE SENSE.
* SUB
 LXI H,BUF+DIGIT-1
 LXI B,DIGIT*256+99H
*
SUB1 MOV A,C
 ACI 0
 SUB M
 XCHG
 ADD M
 DAA
 XCHG
 MOV M,A
 DCX H
 DCX D
 DCR B
 JNZ SUB1
 JC ADS4
 LXI H,SIGN
 MOV A,M  GET SIGN
 XRI 1  COMPLEMENT
 MOV M,A
*
 DCX H
 LXI B,DIGIT*256+9AH
*
ADS3 MOV A,C  GET 9AH
 SBB M  COMPLEMENT RESULT
 ADI 0
 DAA
 MOV M,A
 DCX H
 DCR B
 CMC
 JNZ ADS3
*
ADS4 LXI H,BUF
 LXI B,DIGIT
 JMP ADS5
*
*
ADS5A INX H
 INR B
 INR B
 DCR C
 JZ ZERE0
*
ADS5 MOV A,M
 ORA A
 JZ ADS5A
 CPI 10H
 JNC ADS9
 INR B
*
ADS9 LXI H,EXP
 MOV A,M
 SUB B
 JZ ZERE0
 JC ZERE0
 MOV M,A
 MOV A,B
 RLC
 RLC
 MOV B,A
 CALL LEFT
 JMP ADS2
*
*
*
*            FLOATING POINT MULTIPLY
*
FMUL PUSH B
FMULH MOV A,M
 ORA A  ARGUMENT = 0?
 JZ ZERE0
 LDAX D
 ORA A  ARGUMENT = 0?
 JZ ZERE0
 DCR A
 ADD M  FORM RESULT EXPONENT
 JC FMOVR
 JP ZERE0
 JMP FMUL1
FMOVR JM OVER
*
FMUL1 SUI 128-1  REMOVE EXCESS BIAS
 STA EXP  SAVE EXPONENT
 DCX D
 DCX H
 LDAX D
 XRA M  FORM RESULT SIGN
 DCX H
 DCX D
 PUSH H
 LXI H,SIGN  GET SIGN ADDRESS
 MOV M,A  SAVE SIGN
 DCX H
 XRA A
 LXI B,DIGIT+2*256+DIGIT
*
FMUL2 MOV M,A  ZERO WORKING BUFFER
 DCX H
 DCR B
 JNZ FMUL2
 LXI H,HOLD1+DIGIT
*
* GET MULTIPLIER INTO HOLDING REGISTER
*
FMUL3 LDAX D
 MOV M,A  PUT IN REGISTER
 DCX H
 DCX D
 DCR C
 JNZ FMUL3
*
 MOV M,C
 DCX H
 MVI B,250  SET LOOP COUNT
*
FMUL4 LXI D,DIGIT+1
 MOV C,E
 DAD D
 XCHG
 DAD D  H,L=NEXT HOLDING REGISTER
 INR B
 JP FMUL8  FINISHED
*
FMUL5 LDAX D  GET DIGITS
 ADC A  TIMES 2
 DAA
 MOV M,A  PUT IN HOLDING REGISTER
 DCX D
 DCX H
 DCR C
 JNZ FMUL5
*
 INR B  INCREMENT LOOP COUNT
 JNZ FMUL4
*
* FORM 10X BY ADDING 8X AND 2X
* FIRST GET 8X
*
 INX H
 LXI D,HOLD5  NEXT HOLDING REGISTER
 LXI B,DIGIT+1*256+DIGIT+1
*
FMUL6 MOV A,M
 STAX D
 INX H
 INX D
 DCR C
 JNZ FMUL6
*
 LXI H,HOLD2+DIGIT  GET 2X
 DCX D
*
FMUL7 LDAX D
 ADC M  FORM 10X
 DAA
 STAX D
 DCX D
 DCX H
 DCR B
 JNZ FMUL7
*
 MVI B,249
 XCHG
 JMP FMUL4
*---------------------------------------------------------------
*   THIS IS THE FAKE CODE FOR THE COPYRIGHT TEXT
*
CRM DB 'C'-OFFSET
XX0 DB 'O'-OFFSET
    DB 'P'-OFFSET
    DB 'Y'-OFFSET
    DB 'R'-OFFSET
    DB 'I'-OFFSET
    DB 'G'-OFFSET
    DB 'H'-OFFSET
    DB 'T'-OFFSET
    DB ' '-OFFSET
*
XX1 DB '('-OFFSET
    DB 'C'-OFFSET
    DB ')'-OFFSET
    DB ' '-OFFSET
*
XX2 DB '1'-OFFSET
    DB '9'-OFFSET
    DB '7'-OFFSET
    DB '7'-OFFSET
    DB ' '-OFFSET
*
XX3 DB 'P'-OFFSET
    DB 'r'-OFFSET
    DB 'o'-OFFSET
    DB 'c'-OFFSET
    DB 'e'-OFFSET
    DB 's'-OFFSET
    DB 's'-OFFSET
    DB 'o'-OFFSET
    DB 'r'-OFFSET
    DB ' '-OFFSET
*
XX4 DB 'T'-OFFSET
    DB 'e'-OFFSET
    DB 'c'-OFFSET
    DB 'h'-OFFSET
    DB 'n'-OFFSET
    DB 'o'-OFFSET
    DB 'l'-OFFSET
    DB 'o'-OFFSET
    DB 'g'-OFFSET
    DB 'y'-OFFSET
    DB ' '-OFFSET
*
XX5 DB 'C'-OFFSET
    DB 'o'-OFFSET
    DB 'r'-OFFSET
    DB 'p'-OFFSET
    DB '.'-OFFSET
*
CRML EQU $-CRM  COPYRIGHT MESSAGE LENGTH
*---------------------------------------------------------------
*
*
FMUL8 XCHG
 INX H
 MVI M,DIGIT+1  SET NEXT LOOP COUNT
 JMP FMUL9
*
*  ROTATE RIGHT 1 BYTE
*
FMU12 LXI B,8*256+DIGIT+1
 CALL RIGH1
*
*   PERFORM ACCUMULATION OF PRODUCT
*
FMUL9 POP B  GET MULTIPLIER
 LXI H,HOLD8+DIGIT+1
 DCR M  DECREMENT LOOP COUNT
 JZ FMU14  FINISHED
 LDAX B
 DCX B
 PUSH B
 DCX H
 XCHG
 JMP FMU10
*
*
FMU11 MOV C,A
 ORA A  CLEAR CARRY
 CALL ADD  ACCUMULATE PRODUCT
 LDAX D
 ADD M
 DAA
 MOV M,A
 MOV A,C
 DCX D
*
*
FMU10 ADD A  CHECK FOR BIT IN CARRY
 JC FMU11  FOUND A BIT
 JZ FMU12  ZERO - FINISHED THIS DIGIT
 LXI H,-DIGIT-1
 DAD D  POINT TO NEXT HOLDING REGISTER
 XCHG
 JMP FMU10
*
*
*
FMU14 LDA BUF
 ANI 0F0H  CHECK IF NORMALIZED
 JZ  FMU17
 MOV A,D
 ANI 0F0H
 LXI H,SIGN-1
 JMP FMU18
*
FMU17 LXI B,4*256+DIGIT+1
 LXI H,EXP
 DCR M
 JZ ZERE0
 CALL LEFTA  NORMALIZE
 MOV A,D  GET DIGIT SHIFTED OFF
*
* PERFORM ROUNDING
*
 RRC
 RRC
 RRC
 RRC
FMU18 CPI 50H
 JC FMU16
 INR A
 ANI 0FH
 MVI C,DIGIT
*
FMU15 ADC M
 DAA
 MOV M,A
 MVI A,0
 DCX H
 DCR C
 JNZ FMU15
*
* CHECK FOR ROUNDING OVERFLOW
*
 JNC CHKEXP  NO OVERFLOW
 INX H
 MVI M,10H
 LXI H,EXP
 INR M
 JMP CHKEXP
*
* ROUNDING NOT NEEDED
*
FMU16 ANI 0FH
 ADD M
 MOV M,A
*
CHKEXP LDA EXP  SEE IF THERE WAS AN OVERFLOW.
 ORA A  TEST FOR EXPONENT OF ZERO.
 JNZ ADS2  IF NOT THEN NO OVERFLOW.
 JMP OVER  TOO BAD.
*
*
*           FLOATING POINT DIVISION
*
FDIV PUSH B
FDIVH MOV A,M  FETCH DIVISOR EXP
 ORA A  DIVIDE BY 0?
 JZ  DZERR
 MOV B,A  SAVE THE DIVISOR EXP.
 LDAX D
 ORA A  DIVIDEND = 0?
 JZ  ZERE0
 DCR B
 SUB B
 JC  DIVUN
 JM  OVER
 JMP FDI1
DIVUN JP ZERE0
*
FDI1 ADI 128  FORM QUOTIENT EXP
 JZ ZERE0
 STA EXPD
 XCHG
 PUSH D
 CALL LOAD  FETCH DIVIDEND
 POP D
 XCHG
 LDA SIGN
 DCX H
 XRA M  FORM QUOTIENT SIGN
 STA XSIGND  REMEMBER IT IN TEMPORARY SIGN LOCATION.
 XCHG
 DCX D
 LXI B,HOLD1
DIV0 MVI L,DIGIT+DIGIT+1  1 EXTRA FOR ROUNDING DIGIT.
*
DIV1 PUSH B
 PUSH H
 MVI C,0  QUOTIENT DIGIT = 0
*
DIV3 STC .  SET CARRY
 LXI H,BUF+DIGIT-1
 MVI B,DIGIT
*
DIV4 MVI A,99H
 ACI 0
 XCHG
 SUB M
 XCHG
 ADD M
 DAA
 MOV M,A
 DCX H
 DCX D
 DCR B
 JNZ DIV4
*
 MOV A,M
 CMC
 SBI 0
 MOV M,A
 RAR
 LXI H,DIGIT
 DAD D
 XCHG
 INR C  INCREMENT QUOTIENT
 RAL
 JNC DIV3
*
 ORA A  CLEAR CARRY
 CALL ADD  RESTORE DIVIDEND
 LXI H,DIGIT
 DAD D
 XCHG
 PUSH B
 LXI B,4*256+DIGIT+1
 CALL LEFTA  SHIFT DIVIDEND
 POP B
 DCR C
 POP H
 MOV H,C
 POP B
 MOV A,L
 JNZ DIV5
*
 CPI DIGIT+DIGIT+1
 JNZ DIV5
*
 LXI H,EXPD
 DCR M
 JNZ DIV0
 JMP ZERE0
*
*
*
DIV5 RAR  WHICH NIBBLE DOES THIS QUOTIENT DIGIT GO IN?
 MOV A,H
 JC DIV6  THIS ASSUMES THAT THE L COUNTER (2*DIGIT+1) WAS ODD.
 LDAX B
 RLC
 RLC
 RLC
 RLC
 ADD H
 STAX B  STORE QUOTIENT
 INX B
 JMP DIV7
*
DIV6 STAX B  STORE QUOTIENT
*
DIV7 DCR L  DECREMENT DIGIT COUNT
 JNZ DIV1
*
 CPI 5  THE LAST QUOTIENT DIGIT WILL BE USED FOR ROUNDING.
 JC DIV8  NO ROUNDING NECESSARY.
 LXI H,HOLD1+DIGIT-1  WHERE THE CURRENT QUOTIENT IS.
 CALL INCREMENT  ROUND BY ADDING 1 TO RIGHTMOST DIGIT.
*
DIV8 LDA XSIGND  PUT THE SIGN WHERE IT BELONGS.
 STA SIGND
*
 LXI H,EXPD  POINT TO EXPONENT OF QUOTIENT.
 POP B  ADDRESS OF RESULT.
 JMP STORO  COPY QUOTIENT TO RESULT AND RETURN.
*
*
 COPY BSM:RAND/1  RANDOM NUMBER FUNCTION.
*
 COPY BSM:FSQR/1  SQUARE ROOT FUNCTION.
*
*
*
* FETCH AND ALIGN ARGUMENTS FOR
* ADDITION AND SUBTRACTION
*
EXPCK LDAX D  FOR ADD & SUBTRACT ENTRY
 SUB M  DIFFERENCE OF EXPS
 MVI C,0
 JNC EXPC1
 INR C  INDICATE THAT THE ARGUMENTS WERE REVERSED.
 XCHG
 CMA .  SINCE THE ARGS WERE REVERSED, THE DIFFERENCE= - DIFF.
 INR A
*
EXPC1 MOV B,A  SAVE THE DIFFERENCE OF THE EXPONENTS.
 LDAX D  GET EXP OF LARGER #.
 STA EXP  BECOMES THE EXP OF THE RESULT.
*
 PUSH B  SAVE C, THE REVERSAL INDICATOR.
 PUSH D  SAVE ADDRESS OF EXP OF LARGER #.
 CALL LOAD  PUT THE SMALLER # IN BUF AND SIGN.  B UNCHANGED.
*
 MOV A,B  GET THE DIFFERENCE OF THE EXPS BACK.
 CPI DIGIT+DIGIT+1  DIGIT+DIGIT IS THE MAX WE CAN SHIFT TO ALIGN
 JC  EXPC2  DIFFERENCE WAS <= DIGIT+DIGIT.
*
*  SINCE DIFFERENCE WAS GREATER THAN # OF DIGITS, NO ROUNDING
*
 XRA A  MAKE A ZERO TO INDICATE
 STA RCTRL  (NONEXISTENT) ROUNDING DIGIT IN HIGH NIBBLE OF RDIGI
*  RDIGI WAS SET TO 00 BY LOAD.
 MVI B,2*DIGIT*4  HOW MANY BITS TO SHIFT SMALLER #. CLEARS IT.
 JMP EXPC3  SKIP FINDING THE ROUNDING DIGIT.  GO SHIFT.
*
EXPC2 RLC .  MULTIPLY EXP DIFF BY 4. CONVERT NIBBLES TO BITS.
 RLC
 MOV B,A  B NOW HAS # OF BITS TO SHIFT SMALLER # RIGHT.
 ANI 4
 STA RCTRL  SET ROUNDING CONTROL, 1 IF ROUNDING DIGIT WILL BE IN
*            THE LOW NIBBLE OF RDIGI.
*
*  THIS CODE FINDS WHERE THE DIGIT THAT GETS SHIFTED JUST OFF
*  THE END IS, AND STORES IT IN RDIGI FOR LATER ROUNDING.
*
 MVI A,8*DIGIT+16
 SUB B
 CPI 8*DIGIT+16
 JZ  EXPC3  WILL BE NO SHIFTING, SO NO DIGITS LOST.
 ANI 0F8H  CONVERT BITS REMAINING TO BYTES.
 RAR
 RAR
 RAR
 ADD E
 MOV E,A  MAKE THE ADDRESS OF THE DIGIT THAT WILL BE LOST.
 MOV A,D
 ACI 0
 MOV D,A
 LDAX D   GET ROUNDING DIGIT
 STA RDIGI  SAVE
*
*
EXPC3 CALL RIGHT  ALIGN VALUES
 POP D  DE RETURNED UNCHANGED FROM EXPCK.
 POP B  C=1 IF ARGUMENTS WERE REVERSED.
 RET
*
*
*  DETERMINE IF WE SHOULD ROUND FOR FADD OR FSUB
*  SET THE CARRY IF THE ROUNDING DIGIT IS >= 5.
*
SETROUND LDA RCTRL  DETERMINE WHICH NIBBLE THE DIGIT IS IN.
 ORA A  IF 0 THEN HIGH (LEFT) NIBBLE.
 LDA RDIGI  THE ROUNDING DIGIT (AND SOME OTHER NIBBLE).
 JZ SETR1  THE DIGIT IS IN THE RIGHT PLACE.
*
 RLC .  ROTATE THE CORRECT DIGIT TO THE HIGH NIBBLE.
 RLC .  WE DON'T CARE WHAT HAPPENS TO THE LOW NIBBLE.
 RLC .  ONE MORE.
 RLC .  4 SHIFTS SWAPS NIBBLES.
*
SETR1 ADI 0B0H  THIS SETS CARRY IF HIGH NIBBLE IS >=5.
 RET .  THAT'S WHAT WE WANTED.
*
*
*  ROUTINE TO ADD 1 TO THE RIGHTMOST DIGIT (AND PROPAGATE CARRY)
*  USEFUL FOR ROUNDING.
*
INCREMENT MVI B,DIGIT  # OF BYTES TO PROPAGATE CARRY THROUGH.
 STC .  THIS IS THE 1 THAT GETS ADDED IN.
*
INCLOOP  MOV A,M  GET A DIGIT PAIR OF THE NUMBER.
 ACI 0  ADD IN THE CARRY.
 DAA .  KEEP IT NICE.
 MOV M,A  PUT IT BACK.
 DCX H  MOVE BACK TO NEXT DIGIT PAIR.
 DCR B  ARE WE DONE?
 JNZ INCLOOP  CONTINUE THROUGH DIGIT DIGITS.
*
 RNC .  NO CARRY OUT OF HIGH DIGIT.
*
 INR M  INDICATE CARRY OUT BY ADJUSTING NEXT DIGIT UP.
 RET .  CARRY IS SET.
*
*
*   LOAD ARGUMENT INTO BUFFER
*
LOAD LXI D,SIGN
 MVI C,DIGIT+1
 DCX H
*
LOAD1 MOV A,M
 STAX D
 DCX H
 DCX D
 DCR C
 JNZ LOAD1
*
 XRA A
 STAX D
 DCX D
 STAX D
 STA RDIGI  ZERO ROUNDING DIGIT
 RET
*
*
RIGH3 MOV B,A  SHIFT RIGHT ONE BYTE
 XRA A
RIGH4 MOV D,M
 MOV M,A
 MOV A,D
 INX H
 DCR C
 JNZ RIGH4
*
*
*   SHIFT RIGHT B/4 DIGITS
*
RIGHT MVI C,DIGIT+1
RIGH1 LXI H,BUF-1
 MOV A,B
 SUI 8  CHECK IF BYTE CAN BE SHIFTED
 JNC RIGH3
 DCR B
 RM
 ORA A
*
RIGH2 MOV A,M
 RAR
 MOV M,A
 INX H
 DCR C
 JNZ RIGH2
 JMP RIGHT
*
*
LEF3 MOV B,A  SHIFT LEFT ONE BYTE
 XRA A
LEF4 MOV D,M
 MOV M,A
 MOV A,D
 DCX H
 DCR C
 JNZ LEF4
*
*
* SHIFT LEFT NUMBER OF DIGITS
* IN B/4
*
LEFT MVI C,DIGIT+1
LEFTA LXI H,SIGN-1
*
LEF1 MOV A,B
 SUI 8
 JNC LEF3
 DCR B
 RM
 ORA A
*
LEF2 MOV A,M
 RAL
 MOV M,A
 DCX H
 DCR C
 JNZ LEF2
 JMP LEFT
*
*
*   SET FLAGS FOR OVERFLOW, AND UNDERFLOW
*
OVER LXI B,'FP'
 JMP ERROR
*
*
*
*
*     PERFORM UNSIGNED 16 BIT INTEGER MULTIPLY
*     BC AND DE ARE ARGUMENTS TO MULTIPLY
*     HL RETURNS RESULT
*     OVERFLOW CAUSES OBERR
*
*
IMUL CALL DIMUL
 MOV A,D
 ORA E
 JNZ OBERR
 RET
*
*  32 BIT BINARY MULTIPLY
*  DE.HL=BC*DE
*
DIMUL LXI H,0  INIT PART PROD TO 0 IN HL
 MVI A,16  INIT COUNT
IMUL0 DAD H  LEFT SHIFT INTO CARRY
 XCHG .
 JC IMUL1
 DAD H  MULTIPLIER TO CARRY
 JMP IMUL2
IMUL1 DAD H  SHFT MULT LEFT
 INX H  ADD INCREMENT
IMUL2 XCHG .  POINT TO PART PROD
 JNC IMUL3  JMP IF NO ADD (MULT BIT [CARRY] IS ZERO)
 DAD B  ADD MULTIPLICAND TO PART PROD
 JNC IMUL3
 INX D  CARRY OUT OF PART PROD, ACCUMULATE
IMUL3 DCR A
 JNZ IMUL0
 RET
*
*
*
*    24 BIT BINARY DIVIDE
*
*    DE.HL=A.DE/HL
*    |  |  |    |-DIVISOR
*    |  |  |-HIGH PART OF 24 BIT NUMBER IN A AND DE
*    |  |-REMAINDER
*    |-INTEGER PART
*
DIDIV SHLD XA
 STA XC
 LXI H,XB
 MVI M,17+8
 LXI B,0
 PUSH B
*
IDIV1 MOV A,E  ROTATE A.DE LEFT INTO CARRY
 RAL
 MOV E,A
 MOV A,D
 RAL
 MOV D,A
 LDA XC  HAS A
 RAL
 STA XC
*
 DCR M  DEC ITERATION COUNT
 POP H  GET ACCUMULATED REMAINDER
 RZ .  ITER. COUNT ZERO, DONE
*
 MVI A,0  GET CARRY OUT OF ABOVE ROTATE
 ACI 0
 DAD H  SHIFT CURRENT REMAINDER LEFT
*
 MOV B,H  B GETS H, A GETS L+CARRY
 ADD L
*
 LHLD XA  SUBTRACT XA FROM B.A
 SUB L
 MOV C,A
 MOV A,B
 SBB H
 MOV B,A
*
 PUSH B
 JNC IDIV2
 DAD B  IFF OVERFLOW, ADD BACK
 XTHL
IDIV2 LXI H,XB  ADDR OF ITERATION COUNT
 CMC
 JMP IDIV1
*
*
*
*     FLOATING  POINT  CONSTANTS
*
ONE DB 10H,00,00   THIS MUCH ONLY FOR 6-DIGIT PRECISION.
 IF PRECISION-6
 DB 00H  FOR 8+ DIGITS OF PRECISION.
 IF PRECISION-8
 DB 00H  FOR 10+ DIGITS.
 IF PRECISION-10
 DB 00H  FOR 12+.
 IF PRECISION-12
 DB 00H  14+
 IF PRECISION-14
 DB 00H  16.
 IF PRECISION-16
 DB 0,0,0,0,0,0,0,0,0,0,0,0  40 DIGITS!
 ENDF
 ENDF
 ENDF
 ENDF
 ENDF
 ENDF
 DB 00H,81H  SIGN AND EXPONENT FOR +1.
FPONE EQU ONE+FPBYT+1
*
NONE DB 10H,00H,00H
 IF PRECISION-6
 DB 00H  FOR 8+ DIGITS OF PRECISION.
 IF PRECISION-8
 DB 00H  FOR 10+
 IF PRECISION-10
 DB 00H  12+
 IF PRECISION-12
 DB 00H  FOR 14+
 IF PRECISION-14
 DB 00H  16.
 IF PRECISION-16
 DB 0,0,0,0,0,0,0,0,0,0,0,0  40 DIGITS!
 ENDF
 ENDF
 ENDF
 ENDF
 ENDF
 ENDF
 DB 01H,81H  THE SIGN AND EXPONENT FOR -1.
FPNONE EQU NONE+FPBYT+1
*
*
*     FLOATING  POINT  WORK  SPACE
*
FPRAM EQU $
*
HOLD1 DS DIGIT+1
HOLD2 DS DIGIT+1
HOLD3 DS DIGIT+1
HOLD4 DS DIGIT+1
HOLD5 DS DIGIT+1
HOLD6 DS DIGIT+1
HOLD7 DS DIGIT+1
HOLD8 DS DIGIT+1
 DS 2
BUF DS DIGIT
SIGN DS 1
EXP DS 1
*
RCTRL DS 1
RDIGI DS 1
*
SIGND EQU HOLD1+DIGIT
EXPD EQU SIGND+1
XSIGND EQU EXPD+1  HOLDS SIGN WHILE SIGND IS USED FOR ROUNDING.
*
SINK DS FPSIZ-1
FPSINK DS 1
*
XA DS 2
XB DS 2
XC DS 2
XS DS 2
*
MENT DS 1  MATRIX ENTRY FLAG
*
 COPY BSM:FUNS/1  THE EXTENDED FUNCTION STORAGE
*
EOFPRAM EQU $
*
*    FAKE CALLS
*
 ORG FPRAM
XXX8 ADI 0B0H
 MOV A,B
 RAR
 JC XX0
 RAL .
 CALL ADD
 JNC XX3
 LXI B,DIGIT*256+DIGIT+1
 CALL XX0
 LXI H,EXP
 INR M
 JZ OVER
XXX2 POP B
XXXXE LXI H,EXP
XXXXO MVI E,DIGIT+2
XXXX1 MOV A,M
 STAX B
 DCX H
 DCX B
 DCR E
 JNZ XXXX1
 JMP XX2
 ORG EOFPRAM