09       .OPT NO LIST
10 ;  SAVE #D1:FLOAT2.M65
20 ;
30 ;
40 ;  LOAD #D1:CHARSET1.M65
50        LIST  
056320 NORM LDX #0   for add norm  B
056322   STX FRE     shift in a 0
056324 NORM1 LDX #4
056326   LDA FR0     get exponent
056328   BEQ ?NDONE  done if 0
056330 ?NORM2 LDA FR0+1 get 1st mantissa
056332   BNE ?TSTBIG if not 0, no shift
056334   LDY #0
056336 ?NSH LDA FR0+2,Y
056339   STA FR0+1,Y
056342   INY 
056343   CPY #5
056345   BCC ?NSH
056347   DEC FR0     decr exponent
056349   DEX 
056350   BNE ?NORM2
056352   LDA FR0+1   mantissa still 0?
056354   BNE ?TSTBIG see if too big
056356   STA FR0     else clear exponent
056358   CLC 
056359   RTS 
056360 ?TSTBIG LDA FR0 get absolute
056362   AND #$7F    exponent
056364   CMP #49+$40 less than 49+64?
056366   BCC ?TSTUND Yes, test underflow
056368   RTS 
056369 ?TSTUND CMP #-49+$40 done if >=
056371   BCS ?NDONE  ; -49+$40
056373   JSR ZFR0    Else number = 0
056376 ?NDONE CLC 
056377   RTS 
056378 RSHFT0 LDX #FR0 Point to Fr0
056380   BNE ?RSH
056382 RSHFT1 LDX #FR1 Point to Fr1
056384 ?RSH STX ZTEMP3 Save fr pointer
056386   STA ZTEMP4  Save # bytes to shift
056388   STA ZTEMP4+1 save for later
056390 ?RSH2 LDY #4  Get # bytes to move
056392 ?RSH1 LDA 4,X Get char
056394   STA 5,X     Store char
056396   DEX         Point to next
056397   DEY         Dec loop control
056398   BNE ?RSH1   If more repeat
056400   LDA #0      Get first byte
056402   STA 5,X     store it
056404   LDX ZTEMP3  Get Fr pointer
056406   DEC ZTEMP4  Do we need to repeat?
056408   BNE ?RSH2   If yes do it
056410   LDA 0,X     Get exponent
056412   CLC 
056413   ADC ZTEMP4+1 Sub # of shifts
056415   STA 0,X     save new exponent
056417   RTS 
056418 RSHF0E LDX #5*2 Get loop control
056420 ?NXTB1 LDA FR0,X Get a byte
056422   STA FR0+1,X Move it over one
056424   DEX         Dec counter
056425   BPL ?NXTB1  Move next byte
056427   LDA #0      Get 0
056429   STA FR0     Shift it in
056431   RTS 
056432 ?CVFR0 STA ZTEMP4 Save decimal position
056434   LDX #0      Set index into mantissa
056436   LDY #0      Set index into output
056438 ?CVBYTE JSR ?TSTDP Put in DP now?
056441   SEC         Dec DP position
056442   SBC #1
056444   STA ZTEMP4  Save it
056446   LDA FR0+1,X Get from Fr0
056448   LSR A       Shift out low order bits
056449   LSR A       To get 1st digit
056450   LSR A
056451   LSR A
056452   JSR ?STNUM  Go put number in buffer
056455   LDA FR0+1,X Do second digit
056457   AND #$0F    Strip high bits
056459   JSR ?STNUM  Store in buffer
056462   INX         Incr pointer
056463   CPX #5      Done?
056465   BCC ?CVBYTE If not do more
056467 ?TSTDP LDA ZTEMP4 Get DP position
056469   BNE ?TST1   If not 0, return
056471   LDA #'.     Get ascii DP
056473   JSR ?STCHAR Put in buffer
056476 ?TST1 RTS 
056477 ?STNUM ORA #'0 Convert to ascii
056479 ?STCHAR STA LBUFF,Y Put in Lbuff
056482   INY         Incr. pointer
056483   RTS 
056484 ?FNZERO LDX #10 Point to last char in lbuff
056486 ?FN3 LDA LBUFF,X Get character
056489   CMP #'.     Is it a DP?
056491   BEQ ?FN1    If yes, go
056493   CMP #'0     Is it a 0?
056495   BNE ?FN2    Go if not
056497   DEX         Decr. index
056498   BNE ?FN3    Go always
056500 ?FN1 DEX      Decr. buffer index
056501   LDA LBUFF,X Get last char
056504 ?FN2 RTS 
056505 ?GETDIG JSR NIBSH0 Shift Fr0 left one nybble
056508   LDA FRX     Get byte containing shifted nybble
056510   AND #$0F    Strip high order bits
056512   RTS 
056513 ?DECINB SEC   Subtract one from inbuff
056514   LDA INBUFF
056516   SBC #1
056518   STA INBUFF
056520   LDA INBUFF+1
056522   SBC #0
056524   STA INBUFF+1
056526   RTS 
056527 MDESUP LDA FR0 Get FR0 exponent
056529   EOR FR1     Get Fr1 exponent
056531   AND #$80    Strip all but sign bit
056533   STA FRSIGN  Save sign
056535   ASL FR1     Shift out sign in Fr1 exponent
056537   LSR FR1     Restore Fr1 less sign
056539   LDA FR0     Get Fr0 exponent
056541   AND #$7F    Strip sign bit
056543   RTS 
056544 MDSUP ORA FRSIGN Or in sign bit
056546   STA EEXP    Save exponent
056548   LDA #0      Clear a
056550   STA FR0     and Fr0
056552   STA FR1     and Fr1
056554   JSR MVFR12  Move Fr1 to Fr2
056557   JSR NIBSH2  Shift Fr2 one nybble left
056560   LDA FRX     Get shifted nybble
056562   AND #$0F    Strip high order bits
056564   STA FR2     Store to finish shift
056566   LDA #5      Set loop control
056568   STA ZTEMP1
056570   JSR MVFR0E  Move Fr0 to Fre
056573   JSR ZFR0    Clear Fr0
056576   RTS 
056577 FRA10 LDX #FR0+5 Point to last byte of sum
056579   BNE ?F1
056581 FRA20 LDX #FR0+5
056583   BNE ?F2
056585 FRA1E LDX #FRE+5
056587 ?F1 LDY #FR1+5
056589   BNE ?FRA
056591 FRA2E LDX #FRE+5
056593 ?F2 LDY #FR2+5
056595 ?FRA LDA #5   Set loop control
056597   STA ZTEMP4
056599   CLC 
056600   SED         Decimal mode
056601 ?FRA1 LDA 0,X Get 1st byte
056603   ADC 0,Y     add
056606   STA 0,X     store
056608   DEX 
056609   DEY 
056610   DEC ZTEMP4  Decr loop control
056612   BPL ?FRA1   til done
056614   CLD         Clear decimal
056615   RTS 
056616 MVFR12 LDY #5 Move Fr1 to Fr2
056618 ?MV2 LDA FR1,Y
056621   STA FR2,Y
056624   DEY 
056625   BPL ?MV2
056627   RTS 
056628 MVFR0E LDY #5 Move Fr0 to Fre
056630 ?MV1 LDA FR0,Y
056633   STA FRE,Y
056636   DEY 
056637   BPL ?MV1
056639   RTS 
056640 PLYEVL STX FPTR2 save pointer to coefs B
056642   STY FPTR2+1
056644   STA PLYCNT
056646   LDX # <PLYARG
056648   LDY # >PLYARG
056650   JSR FST0R   Save arg
056653   JSR FMOVE   Arg->Fr1
056656   LDX FPTR2
056658   LDY FPTR2+1
056660   JSR FLD0R   Coeff->Fr0 (init sum)
056663   DEC PLYCNT  Done?
056665   BEQ ?PLYOUT
056667 ?PLYEV1 JSR FMUL sum*arg
056670   BCS ?PLYOUT Overflow
056672   CLC 
056673   LDA FPTR2   bump coeff pointer
056675   ADC #FPREC
056677   STA FPTR2
056679   BCC ?PLYEV2
056681   LDA FPTR2+1 across page
056683   ADC #0
056685   STA FPTR2+1
056687 ?PLYEV2 LDX FPTR2
056689   LDY FPTR2+1
056691   JSR FLD1R   Get next coeff
056694   JSR FADD    sum*arg+coef
056697   BCS ?PLYOUT overflow
056699   DEC PLYCNT
056701   BEQ ?PLYOUT
056703   LDX # <PLYARG
056705   LDY # >PLYARG
056707   JSR FLD1R   Get arg again
056710   BMI ?PLYEV1 Go always
056712 ?PLYOUT RTS 
056713 FLD0R STX FLPTR Set Flptr B
056715   STY FLPTR+1
056717 FLD0P LDY #5  ; # bytes
056719 FLD01 LDA (FLPTR),Y Move them
056721   STA FR0,Y
056724   DEY 
056725   BPL FLD01
056727   RTS 
056728 FLD1R STX FLPTR B
056730   STY FLPTR+1
056732 FLD1P LDY #5
056734 FLD11 LDA (FLPTR),Y Copy (Flptr)
056736   STA FR1,Y   to Fr1
056739   DEY 
056740   BPL FLD11
056742   RTS 
056743 FST0R STX FLPTR B
056745   STY FLPTR+1
056747 FST0P LDY #5
056749 FST01 LDA FR0,Y
056752   STA (FLPTR),Y
056754   DEY 
056755   BPL FST01
056757   RTS 
056758 FMOVE LDX #5  aka MV0TO1  B
056760 FMOVE1 LDA FR0,X Copy Fr0 to Fr1
056762   STA FR1,X
056764   DEX 
056765   BPL FMOVE1
056767   RTS 
056768 EXP LDX # <LOG10E e^x=10^(x^ln(10)) B
056770   LDY # >LOG10E
056772   JSR FLD1R
056775   JSR FMUL
056778   BCS EXPERR
056780 EXP10 LDA #0  ;10^x B
056782   STA XFMFLG  Clear transform flag
056784   LDA FR0
056786   STA SGNFLG  Remember arg sign
056788   AND #$7F    and make +ve
056790   STA FR0
056792   SEC 
056793   SBC #$40
056795   BMI EXP1    x<1 so use series directly
056797   CMP #4
056799   BPL EXPERR  arg to big
056801   LDX # <FPSCR
056803   LDY # >FPSCR
056805   JSR FST0R   save arg
056808   JSR FPI     make integer
056811   LDA FR0
056813   STA XFMFLG  save multiplier exponent
056815   LDA FR0+1   check msb
056817   BNE EXPERR  should be none
056819   JSR IFP     Back to floating point
056822   JSR FMOVE
056825   LDX # <FPSCR
056827   LDY # >FPSCR
056829   JSR FLD0R   Get arg back
056832   JSR FSUB    Arg-integer=fraction
056835 EXP1 LDA #NPCOEF coefficients
056837   LDX # <P10COF
056839   LDY # >P10COF
056841   JSR PLYEVL  p(x)
056844   JSR FMOVE
056847   JSR FMUL    p(x)*p(x)
056850   LDA XFMFLG  did we transform arg
056852   BEQ EXPSGN  No, leave result alone
056854   CLC         i/2
056855   ROR A
056856   STA FR1
056858   LDA #1      Get mantissa byte
056860   BCC EXP2    Check bit shifted out of a
056862   LDA #$10    i was odd, mantissa=10
056864 EXP2 STA FR1+1
056866   LDX #4
056868   LDA #0
056870 EXP3 STA FR1+2,X Clear rest of mantissa
056872   DEX 
056873   BPL EXP3
056875   LDA FR1     back to exponent
056877   CLC 
056878   ADC #$40    bias it
056880   BCS EXPERR  Too big
056882   BMI EXPERR
056884   STA FR1     Fr1=10^i
056886   JSR FMUL    (10^i)*(10^f)
056889 EXPSGN LDA SGNFLG arg<0?
056891   BPL EXPOUT  No, done
056893   JSR FMOVE   Yes, invert result
056896   LDX # <FONE
056898   LDY # >FONE
056900   JSR FLD0R
056903   JSR FDIV
056906 EXPOUT RTS    Done
056907 EXPERR SEC    Flag error
056908   RTS         Quit
056909 P10COF .BYTE $3D,$17,$94,$19,0,0
056910 ; .FLOAT 0.0000179419
056915   .BYTE $3D,$57,$33,$05,0,0
056916 ; .FLOAT 0.0000573305
056921   .BYTE $3E,$05,$54,$76,$62,0
056922 ; .FLOAT 0.0005547662
056927   .BYTE $3E,$32,$19,$62,$27,0
056928 ; .FLOAT 0.0032176227
056933   .BYTE $3F,$01,$68,$60,$30,$36
056934 ; .FLOAT 0.0168603036
056939   .BYTE $3F,$07,$32,$03,$27,$41
056940 ; .FLOAT 0.0732032741
056945   .BYTE $3F,$25,$43,$34,$56,$75
056946 ; .FLOAT 0.02543345675
056951   .BYTE $3F,$66,$27,$37,$30,$50
056952 ; .FLOAT 0.66273730505
056957   .BYTE $40,$01,$15,$12,$92,$55
056958 ; .FLOAT 1.15129255555
056963   .BYTE $3F,$99,$99,$99,$99,$99
056964 ; .FLOAT 0,99999999999
056965 NPCOEF = [*-P10COF]/6
056969 LOG10E .BYTE $3F,$43,$42,$94,$48,$19
056970 ; .FLOAT 0.43429448190 log(e)
056975 FONE .BYTE $40,1,0,0,0,0
056976 ; .FLOAT 1
056981 XFORM STX FPTR2 z=(x-c)/(x+c) B
056983   STY FPTR2+1
056985   LDX # <PLYARG
056987   LDY # >PLYARG
056989   JSR FST0R   x to plyarg
056992   LDX FPTR2
056994   LDY FPTR2+1
056996   JSR FLD1R
056999   JSR FADD    x+c
057002   LDX # <FPSCR
057004   LDY # >FPSCR
057006   JSR FST0R
057009   LDX # <PLYARG
057011   LDY # >PLYARG
057013   JSR FLD0R
057016   LDX FPTR2
057018   LDY FPTR2+1
057020   JSR FLD1R
057023   JSR FSUB    x-c
057026   LDX # <FPSCR
057028   LDY # >FPSCR
057030   JSR FLD1R
057033   JSR FDIV    (x-c)/(x+c)=z
057036   RTS 
057037 LOG LDA #1    ln(x) B
057039   BNE LOGBTH
057041 LOG10 LDA #0  log(x)  B
057043 LOGBTH STA SGNFLG Use sign to remember entry
057045   LDA FR0
057046 ; -----------
057047   BEQ LOGERR  different from
057049   BMI LOGERR  book
057051   JMP LOG1    jump patch
057052 ;
057054 LOGERR SEC    Address = book+5
057055   RTS         ;-----------
057056 ?XPATCH SBC #$40 Addreses match
057058   ASL A       book again
057059   STA XFMFLG  Remember y
057061   LDA FR0+1
057063   AND #$F0
057065   BNE LOG2
057067   LDA #1
057069   BNE LOG3
057071 LOG2 INC XFMFLG bump y
057073   LDA #$10
057075 LOG3 STA FR1+1 Set mantissa
057077   LDX #4      Clear rest
057079   LDA #0
057081 LOG4 STA FR1+2,X
057083   DEX 
057084   BPL LOG4
057086   JSR FDIV
057089 FLOG10 LDX # <SQR10 log(x) 1>=x<=10
057091   LDY # >SQR10
057093   JSR XFORM   z=(x-c)/(x+c) c*c=10
057096   LDX # <FPSCR
057098   LDY # >FPSCR
057100   JSR FST0R   save z
057103   JSR FMOVE
057106   JSR FMUL    z*z
057109   LDA #NLCOEF
057111   LDX # <LGCOEF
057113   LDY # >LGCOEF
057115   JSR PLYEVL  p(z*z)
057118   LDX # <FPSCR
057120   LDY # >FPSCR
057122   JSR FLD1R
057125   JSR FMUL    z*p(z*z)
057128   LDX # <FHALF
057130   LDY # >FHALF
057132   JSR FLD1R
057135   JSR FADD    0.5+z*p(z*z)
057138   JSR FMOVE
057141   LDA #0
057143   STA FR0+1
057145   LDA XFMFLG
057147   STA FR0
057149   BPL LOG6
057151   EOR #$FF    flip sign
057153   CLC 
057154   ADC #1
057156   STA FR0
057158 LOG6 JSR IFP  leaves Fr1 alone
057161   BIT XFMFLG
057163   BPL LOG7
057165   LDA #$80    Flip again
057167   ORA FR0
057169   STA FR0
057171 LOG7 JSR FADD ln(x)=ln(x)+y
057174 LOGOUT LDA SGNFLG
057176   BEQ LOGDON  was log, not ln
057178   LDX # <LOG10E ln(x)/log(e)
057180   LDY # >LOG10E
057181 ; .FLOAT 3.16227766  sqr(10)
057182   JSR FLD1R
057185   JSR FDIV
057188 LOGDON CLC 
057189   RTS 
057190 SQR10 .BYTE $40,$03,$16,$22,$77,$66
057196 FHALF .BYTE $3F,$50,0,0,0,0 B
057197 ; .FLOAT 0.5
057202 LGCOEF .BYTE $3F,$49,$15,$57,$11,$08
057203 ; .FLOAT 0.4915571108
057208   .BYTE $BF,$51,$70,$49,$47,$08
057209 ; .FLOAT -0.5170494708
057214   .BYTE $3F,$39,$20,$57,$61,$95
057215 ; .FLOAT 0.3920576195
057220   .BYTE $BF,$04,$39,$63,$03,$55
057221 ; .FLOAT -0.0439630355
057226   .BYTE $3F,$10,$09,$30,$12,$64
057227 ; .FLOAT 0.1009301264
057229 ; .FLOAT 0.7853981634
057230 ; pi/4=arctan(1.0)
057232   .BYTE $3F,$09,$39,$08,$04,$60
057233 ; .FLOAT 0.0939080460
057238   .BYTE $3F,$12,$42,$58,$47,$42
057239 ; .FLOAT 0.1242584742
057244   .BYTE $3F,$17,$37,$12,$06,$08
057245 ; .FLOAT 0.1737120608
057250   .BYTE $3F,$28,$95,$29,$71,$17
057251 ; .FLOAT 0.2895297117
057256   .BYTE $3F,$86,$85,$88,$96,$44
057257 ; .FLOAT 0.8685889644
057258 NLCOEF = [*-LGCOEF]/FPREC
057262 ATCOEF .BYTE $3E,$16,$05,$44,$49,$00 B
057263 ; .FLOAT 0.0016054449
057268   .BYTE $BE,$95,$68,$38,$45,$00
057269 ; .FLOAT -0.00956834500
057274   .BYTE $3F,$02,$68,$79,$94,$16
057275 ; .FLOAT 0.0268799416
057280   .BYTE $BF,$04,$92,$78,$90,$80
057281 ; .FLOAT -0.0492789080
057286   .BYTE $3F,$07,$03,$15,$20,$00
057287 ; .FLOAT 0.0703152000
057292   .BYTE $BF,$08,$92,$29,$12,$44
057293 ; .FLOAT -0.0892291244
057298   .BYTE $3F,$11,$08,$40,$09,$11
057299 ; .FLOAT 0.1108400911
057304   .BYTE $BF,$14,$28,$31,$56,$04
057305 ; .FLOAT -0.1428315604
057310   .BYTE $3F,$19,$99,$98,$77,$44
057311 ; .FLOAT 0.1999987744
057316   .BYTE $BF,$33,$33,$33,$31,$13
057317 ; .FLOAT -0.3333333113
057322 FP9S .BYTE $3F,$99,$99,$99,$99,$99 B
057323 ; .FLOAT 0.9999999999
057324 NATCF = [*-ATCOEF]/FPREC
057328 PIOV4 .BYTE $3F,$78,$53,$98,$16,$34 B
057334 LOG1 LDA FR0  Patch inserted
057336   STA FR1     to make space in
057338   SEC         log to check for
057339   JMP ?XPATCH log(0) or ln(0)
057342   .BYTE 0,0   unused
