home *** CD-ROM | disk | FTP | other *** search
/ ftp.barnyard.co.uk / 2015.02.ftp.barnyard.co.uk.tar / ftp.barnyard.co.uk / cpm / walnut-creek-CDROM / SIMTEL / CPMUG / CPMUG029.ARK / TRAN.SRC < prev    next >
Text File  |  1984-04-29  |  12KB  |  578 lines
  1.     NAME    FPINT
  2.     CSEG
  3. ;
  4. ;
  5. ;    LINK TO EXTERNAL REFERENCES
  6. ;
  7.     EXTRN    FSTOR,FLOAD,FADD,FTEST,FZERO,FABS,FMUL,FDIV
  8.     EXTRN    FFLOAT,FFIX,FCHS,FSUB
  9.     EXTRN    OVER
  10.     EXTRN    OVERF,ACC2,ACCE
  11.     EXTRN    SEED
  12.     PUBLIC    IDV,FCOSH,FSQRT,FSIN,FCOS,FATAN,FSINH,FEXP,FLOG
  13.     PUBLIC    RAND
  14. ;
  15. ;    ENTRY IDV - INVERSE FDIVIDE
  16. ;
  17. ;    STORAGE IN SCRATCH PAD
  18.     SCRT:    DS    25
  19. IDVT    EQU    SCRT + 00H
  20. ;
  21. IDV:    PUSH    H
  22.     CALL    FTEST    ;FLOATING POINT ACCUMULATOR TO REGISTERS
  23.     LXI    H,IDVT
  24.     CALL    FSTOR    ;FDIVISOR TO STORAGE
  25.     POP    H
  26.     CALL    FLOAD    ;FDIVIDEND TO FLOATING POINT ACCUMULATOR
  27.     LXI    H,IDVT
  28.     JMP    FDIV    ;RETURN THROUGH DIV ROUTINE
  29. ;
  30. ;
  31. ;
  32. ;    FLOATING POINT SQUARE ROOT ROUTINE BY NEWTONIAN ITERATION
  33. ;
  34. ;    THE SQUARE ROOT OF THE FABSOLUTE VALUE OF THE
  35. ;    CONTENTS OF THE FLOATING POINT ACCUMULATOR IS
  36. ;    RETURNED IN THE FLOATING POINT ACCUMULATOR.
  37. ;
  38. ;
  39. ;    STORAGE IN SCRATCH BANK
  40. FSQRN    EQU    SCRT + 00H
  41. FSQRX    EQU    SCRT + 04H
  42. ;
  43. FSQRT:    CALL    FABS    ;FORCE ARGUMENT POSITIVE, SET ZERO FLAG
  44.     RZ        ;RETURN ON ZERO
  45.     LXI    H,FSQRN
  46.     CALL    FSTOR
  47.     ANA    A    ;RESET CARRY BIT
  48.     RAR        ;HALVE THE EXPONENT
  49.     ADI    40H    ;RESTORE THE OFFSET
  50.     LXI    H,FSQRX
  51.     CALL    FSTOR
  52.     MVI    D,5    ;ITERATION COUNT
  53.     PUSH    D    ;STACKED
  54. FSQRL:    LXI    H,FSQRN
  55.     CALL    FLOAD
  56.     LXI    H,FSQRX
  57.     CALL    FDIV
  58.     LXI    H,FSQRX
  59.     CALL    FADD
  60.     SUI    1    ;HALVE THE RESULT
  61.     LXI    H,FSQRX
  62.     CALL    FSTOR
  63.     POP    D    ;RESTORE ITERATION COUNT
  64.     DCR    D    ;TALLY
  65.     JZ    FSQRE    ;EXIT WHEN COUNT EXHAUSTED
  66.     PUSH    D    ;SAVE IT OTHERWISE
  67.     JMP    FSQRL    ;TO NEXT ITERATION
  68. FSQRE:    LXI    H,FSQRX    ;RESULT TO ACCUMULATOR
  69.     CALL    FLOAD
  70.     RET
  71. ;
  72. ;    EVALUATION OF ELEMENTARY FUNCTION MACLAURIN SERIES
  73. ;
  74. ;
  75. ;    ENTRY FMACE FOR EXPONENTIAL TYPE SERIES, E.G.
  76. ;    SINH(Z) = Z/1 + Z^3/6 + Z^5/120 + ...
  77. ;        S(I-1) = (1. + X*S(I)/A(I)), S(N) = 1.
  78. ;
  79. ;    ENTRY FMACL FOR LOGARITHMIC TYPE SERIES, E.G.
  80. ;    ARCTAN(Z) = Z/1 - Z^3/3 + Z^5/5 - ...
  81. ;        S(I-1) = (1./A(I) + X*S(I)), S(N) = 0.
  82. ;
  83. ;    IN BOTH SERIES DEL^2(A(I)) MUST BE CONSTANT.
  84. ;    ENTER WITH X IN FMACX, A(N) IN D, D(A(N-1)) IN C,
  85. ;        D^2(A(1)) IN B.
  86. ;    RESULT IN FMACS, WHEN A(I) <= 0.
  87. ;
  88. ;    STORAGE IN SCRATCH BANK
  89. FMACX    EQU    SCRT+00H
  90. FMACS    EQU    SCRT+04H
  91. FMACT    EQU    SCRT+08H
  92. FMACG    EQU    SCRT+0CH
  93. ;
  94. ;    TWO SUBROUTINE LEVELS USED
  95. ;
  96. FMACL:    XRA    A    ;CLEAR A REGISTER FOR LOG TYPE SERIES
  97.     LXI    H,FMACS    ;POINT TO SIGMA
  98.     MOV    M,A    ;ZERO STORED
  99.     LXI    H,FMACB    ;PRESET BRANCH B
  100.     JMP    FMACC    ;JOINT CODE
  101. FMACE:    LHLD    FONE    ;MOVE 1.0 TO SIGMA FOR EXP TYPE SERIES
  102.     SHLD    FMACS
  103.     LHLD    FONE+2
  104.     SHLD    FMACS+2
  105.     LXI    H,FMACA    ;PRESET BRANCH A
  106. FMACC:    SHLD    FMACG    ;STORE PRESET BRANCH
  107.     MVI    E,32    ;COUNT FOR THE FLOATING OF A(I)
  108. FMACD:    PUSH    B    ;CHAIN RULE LOOP
  109.     PUSH    D    ;SAVE A(I), D(A(I)), D^2(A(1))
  110.     XRA    A    ;ZERO THE LEAD POSITIONS OF A(I)
  111.     MOV    B,A
  112.     MOV    C,A
  113.     CALL    FFLOAT    ;FLOAT A(I)
  114.     LXI    H,FMACT
  115.     CALL    FSTOR
  116.     LXI    H,FMACX
  117.     CALL    FLOAD
  118.     LXI    H,FMACS
  119.     CALL    FMUL
  120.     LHLD    FMACG    ;CHOOSE THE BRANCH
  121.     PCHL
  122. FMACA:    LXI    H,FMACT
  123.     CALL    FDIV
  124.     LXI    H,FONE    ;POINTS TO 1.0
  125.     JMP    FMACF    ;REJOIN COMMON CODE
  126. FMACB:    LXI    H,FMACS
  127.     CALL    FSTOR    ;X*SIGMA
  128.     LXI    H,FONE    ;LOAD 1.0
  129.     CALL    FLOAD
  130.     LXI    H,FMACT
  131.     CALL    FDIV    ;1/A(I)
  132.     LXI    H,FMACS
  133. FMACF:    CALL    FADD
  134.     LXI    H,FMACS
  135.     CALL    FSTOR
  136.     POP    D    ;A(I) AND 32
  137.     POP    B    ;D(A) AND D^2(A)
  138.     MOV    A,D
  139.     SUB    C
  140.     RZ    ;DONE IF ZERO
  141.     RC    ;OR NEGATIVE
  142.     MOV    D,A    ;A(I-1)
  143.     MOV    A,C    ;D(A(I-1))
  144.     SUB    B
  145.     MOV    C,A    ;D(A(I-2))
  146.     JMP    FMACD    ;NEXT ITERATION
  147. FONE:    DB    81H,0,0,0    ;CAN BE IN ROM
  148. FPIV2:    DB    81H,49H,0FH,0DCH;PI/2
  149. FLN2:    DB    80H,31H,72H,18H;LN 2
  150. ;
  151. ;
  152. ;    SINE-COSINE ROUTINE USING MACLAURIN SERIES
  153. ;
  154. ;
  155. ;    ENTRY FSIN FOR SIN(X)
  156. ;    ENTRY FCOS FOR COS(X)
  157. ;    ENTER WITH X IN RADIANS IN FLOATING POINT ACCUMULATOR
  158. ;    RETURNS WITH FUNCTION IN FLOATIG POINT ACCUMULATOR
  159. ;    (IF FABS(X) >= 2^24*PI, OVERFLOW FLAG IS SET)
  160. ;
  161. ;    STORAGE IN SCRATCH BANK
  162. FSINX    EQU    SCRT+10H
  163. ;
  164. ;    THREE LEVELS OF SUBROUTINES USED
  165. ;
  166. FCOS:    CALL    FCHS    ;COMPLEMENT THE ANGLE
  167.     LXI    H,FPIV2
  168.     CALL    FADD
  169. FSIN:    CALL    FTEST    ;FETCH ARGUMENT
  170.     LXI    H,FSINX
  171.     CALL    FSTOR
  172.     LXI    H,FPIV2    ;REDUCE X TO REVOLUTIONS*4
  173.     CALL    FDIV
  174.     MVI    E,26    ;REVOLUTIONS AT BINARY SCALE 24
  175.     CALL    FFIX
  176.     JC    OVERF    ;QUIT IF ANGLE TO LARGE
  177.     MVI    E,26
  178.     MVI    D,0    ;WIPE OUT FRACTIONAL REVOLUTIONS
  179.     CALL    FFLOAT    ;INTEGER PART OF REVOLUTIONS
  180.     LXI    H,FPIV2    ;TO RADIANS
  181.     CALL    FMUL
  182.     CALL    FCHS
  183. FSINA:    LXI    H,FSINX
  184.     CALL    FADD
  185.     LXI    H,FSINX
  186.     CALL    FSTOR
  187.     CALL    FABS    ;FORCE ANGLE INTO REDUCED RANGE
  188.     LXI    H,FPIV2
  189.     CALL    FSUB
  190.     JM    FSINB    ;IF NEGATIVE OR ZERO
  191.     JZ    FSINB    ;THEN ANDGLE IS REDUCED
  192.     LXI    H,FPIV2    ;FABS(X)-PI
  193.     CALL    FSUB
  194.     MOV    E,A    ;SAVE A REGISTER
  195.     LXI    H,FSINX+1
  196.     MOV    A,M
  197.     ANI    80H    ;SIGN OF X
  198.     XRI    80H    ;INVERTED
  199.     XRA    B    ;-SIGN(X)*(FABS(X)-PI)
  200.     MOV    B,A
  201.     MOV    A,E    ;RESTORE A REGISTER
  202.     DCX    H    ;POINT TO FSINX
  203.     CALL    FSTOR    ;REDUCED X
  204.     CALL    FZERO    ;CLEAR ACCUMULATOR
  205.     JMP    FSINA    ;REPEAT UNTIL FABS(X) <= PI/2
  206. ;
  207. FSINB:    LXI    H,FSINX
  208.     CALL    FLOAD
  209.     LXI    H,FSINX
  210.     CALL    FMUL
  211.     CALL    FCHS    ;-X^2
  212.     LXI    H,FMACX
  213.     CALL    FSTOR    ;TO MACLAURIN SERIES
  214.     MVI    D,72    ;9*8, 11 TERM DISCARDED, 18 BITS PRECISION
  215.     MVI    C,30    ;9*8 - 7*6
  216.     MVI    B,8    ;(9*8 - 7*6) - (7*6 - 5*4)
  217.     CALL    FMACE
  218.     LXI    H,FMACS
  219.     CALL    FLOAD
  220.     LXI    H,FSINX
  221.     CALL    FMUL
  222.     CPI    81H    ;SEE IF TAIL NEEDS CLEANING
  223.     JC    FSINC    ;NO, MAGNITUDE IS < 1.0
  224.     LXI    H,ACC2
  225.     XRA    A
  226.     MOV    M,A
  227.     INR    L
  228.     MOV    M,A
  229. FSINC:    CALL    FTEST    ;RESTORE FLAGS AND REGISTERS FOR EXIT
  230.     RET
  231. ;
  232. ;
  233. ;    ARCTAN ROUTINE USING MACLAURIN SERIES
  234. ;
  235. ;
  236. ;
  237. ;    ENTRY FATAN FOR ARCTAN(X), WITH X IN FLOATING POINT ACCUMULATOR
  238. ;    RESULT RETURNED IN FLOATING POINT ACCUMULATOR
  239. ;
  240. ;    STORAGE IN SCRATCH BANK
  241. FATNT    EQU    SCRT+10H
  242. FATNU    EQU    SCRT+14H
  243. ;
  244. ;    FOUR LEVELS OF STACK USED
  245. ;
  246. FATAN:    CALL    FTEST    ;GET F.P. ACC. INTO REGISTERS
  247.     RZ
  248.     CPI    81H    ;TEST EXPONENT
  249.     JC    FATN1    ;RETURN TO CALLER FROM FATN1
  250.     LXI    H,FONE    ;1.0
  251.     CALL    IDV    ;1.0/X
  252.     CALL    FATN1    ;ARCTAN(1/X)
  253.     LXI    H,FATNU
  254.     CALL    FSTOR
  255.     LXI    H,FPIV2    ;PI/2
  256.     CALL    FLOAD
  257.     MOV    E,A    ;SAVE A REGISTER
  258.     LXI    H,FATNU+1    ;SIGN(T)
  259.     MOV    A,M    ;TO A REGISTER
  260.     ANI    80H
  261.     ORA    B    ;ATTACH TO PI/2
  262.     MOV    B,A
  263.     MOV    A,E    ;RESTORE A REGISTER
  264.     LXI    H,FATNT
  265.     CALL    FSTOR
  266.     LXI    H,FATNT
  267.     CALL    FLOAD
  268.     LXI    H,FATNU    ;-SIGN(T)*(PI/S-FABS(T))
  269.     CALL    FSUB    ;=SIGN(T)*FABS(T) = T
  270.     RET
  271. ;
  272. ;    EVALUATE ARCTAN OF ARGUMENTS < 1.0
  273. FATN1:    LXI    H,FATNT    ;POINT TO TEMP
  274.     CALL    FSTOR    ;TAN(T)
  275.     LXI    H,FATNT
  276.     CALL    FMUL    ;TAN(T)^2
  277.     LXI    H,FONE    ;1.0
  278.     CALL    FADD
  279.     CALL    FSQRT
  280.     LXI    H,FONE
  281.     CALL    FADD    ;1.0+SQRT(TAN(T)^2+1.0)
  282.     LXI    H,FATNT
  283.     CALL    IDV    ;TAN(T/2)
  284.     LXI    H,FATNT
  285.     CALL    FSTOR
  286.     LXI    H,FATNU
  287.     INR    A    ;2*TAN(T/2)
  288.     CALL    FSTOR
  289.     LXI    H,FATNT
  290.     CALL    FMUL
  291.     CALL    FCHS    ;-TAN(T/2)^2
  292.     LXI    H,FMACX
  293.     CALL    FSTOR
  294.     MVI    D,11    ;TERM 13 DISCARDED, 16 BITS PRECISION IN RANGE
  295.     MVI    C,2    ;(11-9)
  296.     MVI    B,0    ;(11-9)-(9-7)
  297.     CALL    FMACL
  298.     LXI    H,FMACS
  299.     CALL    FLOAD
  300.     LXI    H,FATNU
  301.     CALL    FMUL
  302.     RET
  303. ;
  304. ;
  305. ;
  306. ;    HYPERBOLIC COSINE ROUTINE USING MACLAURIN SERIES
  307. ;
  308. ;
  309. ;
  310. ;    ENTRY FCOSH FOR COSH(X), WITH X IN THE FLOATING POINT ACCUMULATOR
  311. ;    THE RESULT IS RETURNED IN THE F.P. ACCUMULATOR.
  312. ;    IF FABS(X) > 88.0 THE OVERFLOW FLAG IS SET.
  313. ;
  314. ;    STORAGE IN SCRATCH BANK
  315. FCSHD    EQU    SCRT+0EH    ;DOUBLING COUNTER
  316. ;
  317. ;    THREE LEVELS OF STACK USED
  318. ;
  319. FCOSH:    CALL    FTEST    ;GET ARGUMENT INTO REGISTERS
  320.     LXI    H,FMACX
  321.     CALL    FSTOR
  322.     LXI    H,FCSHD
  323.     MVI    M,0
  324.     SUI    80H    ;REMOVE EXPONENT OFFSET
  325.     JM    FCSHA    ;DOUBLING COUNT AND X ARE OK
  326.     CPI    8    ;ELIMINATE OVERSIZE DOUBLING COUNT
  327.     JP    OVERF    ;RETURN THROUGH OVERFLOW ROUTINE
  328.     MOV    M,A    ;SAVE THE DOUBLING COUNT
  329.     LXI    H,FMACX
  330.     MVI    M,80H
  331.     CALL    FLOAD    ;PUT X INTO ACC
  332. FCSHA:    LXI    H,FMACX
  333.     CALL    FMUL    ;X^2
  334.     LXI    H,FMACX
  335.     CALL    FSTOR
  336.     MVI    D,56    ;8*7, 10 TERM DISCARDED, 21 BITS PRECISION
  337.     MVI    C,26    ;(8*7-6*5)
  338.     MVI    B,8    ;(8*7-6*5) - (6*5-4*3)
  339.     CALL    FMACE
  340. FCSHB:    LXI    H,FCSHD    ;ADDRESS THE DOUBLING COUNT
  341.     DCR    M    ;TALLY AT LOOP TOP
  342.     JM    FCSHC    ;DONE WHEN COUNT IS NEGATIVE
  343.     LXI    H,FMACS    ;FETCH COSH(X/2)
  344.     CALL    FLOAD
  345.     LXI    H,FMACS
  346.     CALL    FMUL    ;COSH(X/2)^2
  347.     LXI    H,ACCE
  348.     INR    M    ;2*COSH(X/2)^2
  349.     LXI    H,FONE    ;-1.0
  350.     CALL    FSUB    ;=COSH(X)
  351.     LXI    H,FMACS
  352.     CALL    FSTOR
  353.     JMP    FCSHB    ;TEST DOUBLING COUNT
  354. FCSHC:    CALL    FTEST    ;RESTORE REGISTERS AND FLAGS
  355.     RET
  356. ;
  357. ;
  358. ;
  359. ;    EXPONENTIAL AND HYPERBOLIC SIN ROUTINE
  360. ;
  361. ;
  362. ;    SCRATCH BANK STORAGE
  363. FSNHD    EQU    SCRT+0EH
  364. FEXOV    EQU    SCRT+0FH
  365. FSNHX    EQU    SCRT+10H
  366. ;
  367. ;
  368. ;    ENTRY FEXP FOR EXP(X)
  369. ;    ENTRY SSINH FOR SINH(X)
  370. ;        ENTRY WITH X IN FP ACCUMULATOR
  371. ;        RETURNS WITH FUNCTION IN FP ACCUMULATOR.
  372. ;        IF FUNCTION EXCEEDS 2^127M OVERFLOW FLAG WILL BE SET
  373. ;
  374. FSINH:    CALL    FTEST    ;FETCH FP ACCUMULATOR
  375.     LXI    H,FSNHX    ;SAVE ARGUMENT
  376.     CALL    FSTOR
  377.     LXI    H,FSNHD    ;ADDRESS DOUBLING COUNTER
  378.     MVI    M,0
  379.     SUI    80H    ;REMOVE OFFSET FROM A
  380.     JM    FSNHA    ;DOUBLING COUNT AND X ARE OK
  381.     CPI    8    ;ELIMINATE OVERSIZE DOUBLING COUNT
  382.     JP    OVERF    ;RETURN THROUGH OVERFLOW ROUTINE
  383.     MOV    M,A    ;SAVE DOUBLING COUNT
  384.     LXI    H,FSNHX    ;BRING ARGUMENT INTO RANGE
  385.     MVI    M,80H
  386.     CALL    FLOAD    ;PUT X INTO FLOATING ACCUMULATOR
  387. FSNHA:    LXI    H,FSNHX
  388.     CALL    FMUL    ;X^2
  389.     LXI    H,FMACX
  390.     CALL    FSTOR
  391.     MVI    D,42    ;7*6, 9 TERM DISCARDED, 18 BITS PRECISION
  392.     MVI    C,22    ;7*6-5*4
  393.     MVI    B,8    ;(7*6-5*4)-(F*4-3*2)
  394.     CALL    FMACE
  395.     LXI    H,FMACS
  396.     CALL    FLOAD
  397.     LXI    H,FSNHX
  398.     CALL    FMUL
  399.     LXI    H,FSNHX    ;SINH(X)
  400.     CALL    FSTOR
  401.     LXI    H,FSNHX    ;SINH(X)^2
  402.     CALL    FMUL
  403.     LXI    H,FONE    ;+1.0
  404.     CALL    FADD
  405.     CALL    FSQRT    ;COSH(X) FOR DOUBLINE AND FOR EXP(X9
  406.     LXI    H,FMACX    ;TEMP
  407.     CALL    FSTOR
  408. FSNHB:    LXI    H,FSNHD    ;ADDRESS DOUBLING COUNT
  409.     DCR    M    ;TALLY AT LOOP TOP
  410.     JM    FSNHC    ;DONE WHEN NEGATIVE
  411.     LXI    H,FMACX    ;COSH(X/2)
  412.     CALL    FLOAD
  413.     LXI    H,FSNHX    ;SINH(X/2)
  414.     CALL    FMUL
  415.     INR    A    ;2.*SINH(X/2)*COSH(X/2)
  416.     LXI    H,FSNHX    ;SINH(X)
  417.     CALL    FSTOR
  418.     LXI    H,FMACX    ;COSH(X/2)
  419.     CALL    FLOAD
  420.     LXI    H,FMACX
  421.     CALL    FMUL
  422.     LXI    H,ACCE    ;2.*COSH(X/2)^2
  423.     INR    M
  424.     LXI    H,FONE    ;-1
  425.     CALL    FSUB
  426.     LXI    H,FMACX    ;=COSH(X)
  427.     CALL    FSTOR
  428.     JMP    FSNHB    ;TEST THE DOUBLING COUNT
  429. FSNHC:    LXI    H,FSNHX
  430.     CALL    FLOAD
  431.     RET
  432. FEXP:    CALL    FTEST
  433.     JP    FEXPP
  434.     LXI    H,OVER    ;SAVE OVERFLOW FLAG
  435.     MOV    E,M
  436.     MVI    M,0
  437.         LXI    H,FEXOV
  438.     MOV    M,E    ;OLD FLAG TO SAVE CELL
  439.     CALL    FABS
  440.     CALL    FEXPP    ;EXP(-X) IN ACC
  441.     LXI    H,FEXOV    ;GET OLD OVERFLOW FLAG BACK
  442.     MOV    E,M
  443.     LXI    H,OVER    ;PICK UP NEW ONE TO TEST
  444.     MOV    A,M
  445.     MOV    M,E    ;RESTORE OLD OVERFLOW FLAG
  446.     ANA    A    ;SET FLAGS
  447.     JNZ    FZERO    ;RECIPROCAL OF OVERFLOW IS ZERO
  448.     LXI    H,FONE
  449.     CALL    IDV    ;1./EXP(-X) = EXP(X)
  450.     RET
  451. FEXPP:    CALL    FSINH    ;SINH(X)
  452.     LXI    H,FMACX    ;+COSH(X)
  453.     CALL    FADD    ;=EXP(X)
  454.     RET
  455. ;
  456. ;
  457. ;
  458. ;    NATURAL LOGARITHM ROUTINE USING MACLAURIN SERIES
  459. ;
  460. ;
  461. ;
  462. ;
  463. ;    ENTRY POINTS IN MACLAURIN SERIES
  464. ;    STORAGE IN SCRATCH BANK
  465. FLOGE    EQU    SCRT+0EH
  466. FLOGX    EQU    SCRT+10H
  467. ;
  468. ;
  469. ;    ENTRY FLOG FOR LN(FABS(X)), WITH X IN F.P. ACCUMULATOR
  470. ;    RESULT IS RETURNED IN FLOATING POINT ACCUMULATOR
  471. ;    IF X = 0 THE OVERFLOW FLAG IS SET
  472. ;
  473. ;    3 LEVELS OF SUBROUTINES USED
  474. ;
  475. FLOG:    CALL    FABS    ;FORCE ARGUMENT POSITIVE, SET ZERO FLAG
  476.     JZ    OVERF    ;RETURN THROUGH OVERFLOW ROUTINE
  477.     SUI    81H    ;REMOVE EXPONENT OFFSET
  478.     LXI    H,FLOGE
  479.     MOV    M,A
  480.     MVI    A,81H    ;NORMALIZE ARGUMENT
  481.     LXI    H,FLOGX
  482.     CALL    FSTOR    ;CALL IT X
  483.     LXI    H,FLOGX
  484.     CALL    FLOAD
  485.     LXI    H,FONE
  486.     CALL    FADD
  487.     LXI    H,FMACS
  488.     CALL    FSTOR    ;X+1.0
  489.     LXI    H,FLOGX
  490.     CALL    FLOAD
  491.     LXI    H,FONE
  492.     CALL    FSUB    ;X-1.0
  493.     LXI    H,FMACS
  494.     CALL    FDIV
  495.     LXI    H,FLOGX
  496.     CALL    FSTOR    ;(X-1.0)/(X+1.0)
  497.     LXI    H,FLOGX
  498.     CALL    FMUL
  499.     LXI    H,FMACX
  500.     CALL    FSTOR    ;((X-1.0)/(X+1.0))^2
  501.     MVI    D,9    ;DISCARD 11 TERM FOR 18 BITS PRECISION
  502.     MVI    C,2    ;9-7
  503.     MVI    B,0    ;(9-7)-(7-5)
  504.     CALL    FMACL
  505.     LXI    H,FMACS
  506.     INR    M    ;DOUBLE THE SUM
  507.     CALL    FLOAD
  508.     LXI    H,FLOGX
  509.     CALL    FMUL    ;LOGARITHM OF FRACTIONAL PART
  510.     LXI    H,FLOGX
  511.     CALL    FSTOR
  512.     LXI    H,FLOGE
  513.     MOV    A,M
  514.     MVI    B,0
  515.     MOV    C,B
  516.     MOV    D,B
  517.     MVI    E,8    ;BINARY SCALE FACTOR FOR EXPONENT
  518.     CALL    FFLOAT
  519.     LXI    H,FLN2
  520.     CALL    FMUL    ;LOGARITHM OF 2^EXPONENT
  521.     LXI    H,FLOGX    ;LOG OF FRACTIONAL PART
  522.     CALL    FADD
  523.     RET
  524. ;
  525. ;    RANDOM NUMBER GENERATOR
  526. ;
  527. ;
  528. RAND:    ;COMPUTE NEXT RANDOM NUMBER, AND LEAVE AT SEED
  529.     LXI    H,SEED
  530.     MOV    C,M    ;GET LEAST SIGNIFICANT BYTE
  531.     INR    L
  532.     MOV    B,M    ;X(N) IN B,C
  533.     DCR    L    ;ADDRESS SEED FOR SBR2
  534.     CALL    AROUT    ;CALCUALTE X(N)*2053D
  535.     LXI    H,CNST    ;ADDRESS CONSTANT 13849
  536.     CALL    SBR2
  537.     LXI    H,SEED    ;ADDRESS SEED AGAIN
  538.     MOV    M,C    ;STORE NEW SEED
  539.     INR    L
  540.     MOV    M,B
  541.     RET        ;WITH SEED SET TO RANDOM NUMBER
  542. ;
  543. CNST:    DW    13849
  544. ;
  545. AROUT:    ;COMPUTE X(N)*2053D TO B,C
  546.     MVI    D,9    ;X(N)*2**9
  547.     CALL    SBR1
  548.     CALL    SBR2    ;X(N)+X(N)*2**9
  549.     MVI    D,2    ;2**2*(X(N)+X(N)*2**9)
  550.     CALL    SBR1
  551.     CALL    SBR2    ;ADD TO X(N)
  552.     RET
  553. ;
  554. SBR1:    ;FORMS (B AND C)*2**D
  555.     SUB    A    ;CLEAR A AND CARRY
  556.     MOV    A,C    ;SHIFT C LEFT
  557.     RAL
  558.     MOV    C,A
  559.     MOV    A,B    ;SHIFT B LEFT
  560.     RAL
  561.     MOV    B,A
  562.     DCR    D    ;TEST D=0
  563.     RZ        ;IF YES, RETURN
  564.     JMP    SBR1    ;NO, SHIFT AGAIN
  565. ;
  566. SBR2:    ;16-BIT ADD OF B,C TO M(H,L), RESULT TO B,C
  567.     SUB    A    ;CLEAR A AND CARRY
  568.     MOV    A,M    ;LOAD LOW BYTE
  569.     ADD    C    ;M(H,L)+C
  570.     MOV    C,A
  571.     INR    L    ;M(H,L+1)
  572.     MOV    A,M
  573.     ADC    B
  574.     MOV    B,A
  575.     DCR    L    ;RESTORE H,L FOR NEXT OPERATION
  576.     RET
  577.     END
  578.