1010 *--------------------------------
1020 *      ADD 0.5 TO FAC
1030 *--------------------------------
1040 FADDH  LDA #CON.HALF     FAC+1/2 -> FAC
1050        LDY /CON.HALF
1060        JMP FADD
1070 *--------------------------------
1080 *      FAC = (Y,A) - FAC
1090 *--------------------------------
1100 FSUB   JSR LOAD.ARG.FROM.YA
1110 *--------------------------------
1120 *      FAC = ARG - FAC
1130 *--------------------------------
1140 FSUBT  LDA FAC.SIGN   COMPLEMENT FAC AND ADD
1150        EOR #$FF
1160        STA FAC.SIGN
1170        EOR ARG.SIGN   FIX SGNCPR TOO
1180        STA SGNCPR
1190        LDA FAC        MAKE STATUS SHOW FAC EXPONENT
1200        JMP FADDT      JOIN FADD
1210 *--------------------------------
1220 *      SHIFT SMALLER ARGUMENT MORE THAN 7 BITS
1230 *--------------------------------
1240 FADD.1 JSR SHIFT.RIGHT   ALIGN RADIX BY SHIFTING
1250        BCC FADD.3   ...ALWAYS
1260 *--------------------------------
1270 *      FAC = (Y,A) + FAC
1280 *--------------------------------
1290 FADD   JSR LOAD.ARG.FROM.YA
1300 *--------------------------------
1310 *      FAC = ARG + FAC
1320 *--------------------------------
1330 FADDT  BNE .1       FAC IS NON-ZERO
1340        JMP COPY.ARG.TO.FAC   FAC = 0 + ARG
1350 .1     LDX FAC.EXTENSION
1360        STX ARG.EXTENSION
1370        LDX #ARG     SET UP TO SHIFT ARG
1380        LDA ARG      EXPONENT
1390 *--------------------------------
1400 FADD.2 TAY
1410        BEQ RTS.10   IF ARG=0, WE ARE FINISHED
1420        SEC
1430        SBC FAC      GET DIFFNCE OF EXP
1440        BEQ FADD.3   GO ADD IF SAME EXP
1450        BCC .1       ARG HAS SMALLER EXPONENT
1460        STY FAC      EXP HAS SMALLER EXPONENT
1470        LDY ARG.SIGN
1480        STY FAC.SIGN
1490        EOR #$FF     COMPLEMENT SHIFT COUNT
1500        ADC #0       CARRY WAS SET
1510        LDY #0
1520        STY ARG.EXTENSION
1530        LDX #FAC     SET UP TO SHIFT FAC
1540        BNE .2       ...ALWAYS
1550 .1     LDY #0
1560        STY FAC.EXTENSION
1570 .2     CMP #$F9     SHIFT MORE THAN 7 BITS?
1580        BMI FADD.1      YES
1590        TAY          INDEX TO # OF SHIFTS
1600        LDA FAC.EXTENSION
1610        LSR 1,X      START SHIFTING...
1620        JSR SHIFT.RIGHT.4  ...COMPLETE SHIFTING
1630 FADD.3 BIT SGNCPR   DO FAC AND ARG HAVE SAME SIGNS?
1640        BPL FADD.4   YES, ADD THE MANTISSAS
1650        LDY #FAC     NO, SUBTRACT SMALLER FROM LARGER
1660        CPX #ARG     WHICH WAS ADJUSTED?
1670        BEQ .1       IF ARG, DO FAC-ARG
1680        LDY #ARG     IF FAC, DO ARG-FAC
1690 .1     SEC          SUBTRACT SMALLER FROM LARGER (WE HOPE)
1700        EOR #$FF     (IF EXPONENTS WERE EQUAL, WE MIGHT BE
1710        ADC ARG.EXTENSION  SUBTRACTING LARGER FROM SMALLER)
1720        STA FAC.EXTENSION
1730        LDA 4,Y
1740        SBC 4,X
1750        STA FAC+4
1760        LDA 3,Y
1770        SBC 3,X
1780        STA FAC+3
1790        LDA 2,Y
1800        SBC 2,X
1810        STA FAC+2
1820        LDA 1,Y
1830        SBC 1,X
1840        STA FAC+1
1850 *--------------------------------
1860 *      NORMALIZE VALUE IN FAC
1870 *--------------------------------
1880 NORMALIZE.FAC.1
1890        BCS NORMALIZE.FAC.2
1900        JSR COMPLEMENT.FAC
1910 *--------------------------------
1920 NORMALIZE.FAC.2
1930        LDY #0       SHIFT UP SIGNIF DIGIT
1940        TYA          START A=0, COUNT SHIFTS IN A-REG
1950        CLC
1960 .1     LDX FAC+1    LOOK AT MOST SIGNIFICANT BYTE
1970        BNE NORMALIZE.FAC.4   SOME 1-BITS HERE
1980        LDX FAC+2    HI-BYTE OF MANTISSA STILL ZERO,
1990        STX FAC+1         SO DO A FAST 8-BIT SHUFFLE
2000        LDX FAC+3
2010        STX FAC+2
2020        LDX FAC+4
2030        STX FAC+3
2040        LDX FAC.EXTENSION
2050        STX FAC+4
2060        STY FAC.EXTENSION  ZERO EXTENSION BYTE
2070        ADC #8       BUMP SHIFT COUNT
2080        CMP #32      DONE 4 TIMES YET?
2090        BNE .1       NO, STILL MIGHT BE SOME 1'S
2100 *                   YES, VALUE OF FAC IS ZERO
2110 *--------------------------------
2120 *      SET FAC = 0
2130 *      (ONLY NECESSARY TO ZERO EXPONENT AND SIGN CELLS)
2140 *--------------------------------
2150 ZERO.FAC
2160        LDA #0
2170 *--------------------------------
2180 STA.IN.FAC.SIGN.AND.EXP
2190        STA FAC
2200 *--------------------------------
2210 STA.IN.FAC.SIGN
2220        STA FAC.SIGN
2230        RTS
2240 *--------------------------------
2250 *      ADD MANTISSAS OF FAC AND ARG INTO FAC
2260 *--------------------------------
2270 FADD.4 ADC ARG.EXTENSION
2280        STA FAC.EXTENSION
2290        LDA FAC+4
2300        ADC ARG+4
2310        STA FAC+4
2320        LDA FAC+3
2330        ADC ARG+3
2340        STA FAC+3
2350        LDA FAC+2
2360        ADC ARG+2
2370        STA FAC+2
2380        LDA FAC+1
2390        ADC ARG+1
2400        STA FAC+1
2410        JMP NORMALIZE.FAC.5
2420 *--------------------------------
2430 *      FINISH NORMALIZING FAC
2440 *--------------------------------
2450 NORMALIZE.FAC.3
2460        ADC #1       COUNT BITS SHIFTED
2470        ASL FAC.EXTENSION
2480        ROL FAC+4
2490        ROL FAC+3
2500        ROL FAC+2
2510        ROL FAC+1
2520 *--------------------------------
2530 NORMALIZE.FAC.4
2540        BPL NORMALIZE.FAC.3    UNTIL TOP BIT = 1
2550        SEC
2560        SBC FAC      ADJUST EXPONENT BY BITS SHIFTED
2570        BCS ZERO.FAC UNDERFLOW, RETURN ZERO
2580        EOR #$FF
2590        ADC #1       2'S COMPLEMENT
2600        STA FAC      CARRY=0 NOW
2610 *--------------------------------
2620 NORMALIZE.FAC.5
2630        BCC RTS.11   UNLESS MANTISSA CARRIED
2640 *--------------------------------
2650 NORMALIZE.FAC.6
2660        INC FAC      MANTISSA CARRIED, SO SHIFT RIGHT
2670        BEQ OVERFLOW      OVERFLOW IF EXPONENT TOO BIG
2680        ROR FAC+1
2690        ROR FAC+2
2700        ROR FAC+3
2710        ROR FAC+4
2720        ROR FAC.EXTENSION
2730 RTS.11 RTS
2740 *--------------------------------
2750 *      2'S COMPLEMENT OF FAC
2760 *--------------------------------
2770 COMPLEMENT.FAC
2780        LDA FAC.SIGN
2790        EOR #$FF
2800        STA FAC.SIGN
2810 *--------------------------------
2820 *      2'S COMPLEMENT OF FAC MANTISSA ONLY
2830 *--------------------------------
2840 COMPLEMENT.FAC.MANTISSA
2850        LDA FAC+1
2860        EOR #$FF
2870        STA FAC+1
2880        LDA FAC+2
2890        EOR #$FF
2900        STA FAC+2
2910        LDA FAC+3
2920        EOR #$FF
2930        STA FAC+3
2940        LDA FAC+4
2950        EOR #$FF
2960        STA FAC+4
2970        LDA FAC.EXTENSION
2980        EOR #$FF
2990        STA FAC.EXTENSION
3000        INC FAC.EXTENSION START INCREMENTING MANTISSA
3010        BNE RTS.12
3020 *--------------------------------
3030 *      INCREMENT FAC MANTISSA
3040 *--------------------------------
3050 INCREMENT.FAC.MANTISSA
3060        INC FAC+4   ADD CARRY FROM EXTRA
3070        BNE RTS.12
3080        INC FAC+3
3090        BNE RTS.12
3100        INC FAC+2
3110        BNE RTS.12
3120        INC FAC+1
3130 RTS.12 RTS
3140 *--------------------------------
3150 OVERFLOW
3160        LDX #ERR.OVERFLOW
3170        JMP ERROR
3180 *--------------------------------
3190 *      SHIFT 1,X THRU 5,X RIGHT
3200 *      (A) = NEGATIVE OF SHIFT COUNT
3210 *      (X) = POINTER TO BYTES TO BE SHIFTED
3220 *
3230 *      RETURN WITH (Y)=0, CARRY=0, EXTENSION BITS IN A-REG
3240 *--------------------------------
3250 SHIFT.RIGHT.1
3260        LDX #RESULT-1     SHIFT RESULT RIGHT
3270 SHIFT.RIGHT.2
3280        LDY 4,X           SHIFT 8 BITS RIGHT
3290        STY FAC.EXTENSION
3300        LDY 3,X
3310        STY 4,X
3320        LDY 2,X
3330        STY 3,X
3340        LDY 1,X
3350        STY 2,X
3360        LDY SHIFT.SIGN.EXT   $00 IF +, $FF IF -
3370        STY 1,X
3380 *--------------------------------
3390 *      MAIN ENTRY TO RIGHT SHIFT SUBROUTINE
3400 *--------------------------------
3410 SHIFT.RIGHT
3420        ADC #8
3430        BMI SHIFT.RIGHT.2 STILL MORE THAN 8 BITS TO GO
3440        BEQ SHIFT.RIGHT.2 EXACTLY 8 MORE BITS TO GO
3450        SBC #8            UNDO ADC ABOVE
3460        TAY               REMAINING SHIFT COUNT
3470        LDA FAC.EXTENSION
3480        BCS SHIFT.RIGHT.5 FINISHED SHIFTING
3490 SHIFT.RIGHT.3
3500 L      ASL 1,X           SIGN -> CARRY (SIGN EXTENSION)
3510        BCC .1            SIGN +
3520        INC 1,X           PUT SIGN IN LSB
3530 .1     ROR 1,X          RESTORE VALUE, SIGN STILL IN CARRY
3540        ROR 1,X           START RIGHT SHIFT, INSERTING SIGN
3550 *--------------------------------
3560 *      ENTER HERE FOR SHORT SHIFTS WITH NO SIGN EXTENSION
3570 *--------------------------------
3580 SHIFT.RIGHT.4
3590        ROR 2,X
3600        ROR 3,X
3610        ROR 4,X
3620        ROR               EXTENSION
3630        INY               COUNT THE SHIFT
3640        BNE SHIFT.RIGHT.3
3650 SHIFT.RIGHT.5
3660        CLC               RETURN WITH CARRY CLEAR
3670        RTS
3680 *--------------------------------