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 >
Wrap
Text File
|
1984-04-29
|
12KB
|
578 lines
NAME FPINT
CSEG
;
;
; LINK TO EXTERNAL REFERENCES
;
EXTRN FSTOR,FLOAD,FADD,FTEST,FZERO,FABS,FMUL,FDIV
EXTRN FFLOAT,FFIX,FCHS,FSUB
EXTRN OVER
EXTRN OVERF,ACC2,ACCE
EXTRN SEED
PUBLIC IDV,FCOSH,FSQRT,FSIN,FCOS,FATAN,FSINH,FEXP,FLOG
PUBLIC RAND
;
; ENTRY IDV - INVERSE FDIVIDE
;
; STORAGE IN SCRATCH PAD
SCRT: DS 25
IDVT EQU SCRT + 00H
;
IDV: PUSH H
CALL FTEST ;FLOATING POINT ACCUMULATOR TO REGISTERS
LXI H,IDVT
CALL FSTOR ;FDIVISOR TO STORAGE
POP H
CALL FLOAD ;FDIVIDEND TO FLOATING POINT ACCUMULATOR
LXI H,IDVT
JMP FDIV ;RETURN THROUGH DIV ROUTINE
;
;
;
; FLOATING POINT SQUARE ROOT ROUTINE BY NEWTONIAN ITERATION
;
; THE SQUARE ROOT OF THE FABSOLUTE VALUE OF THE
; CONTENTS OF THE FLOATING POINT ACCUMULATOR IS
; RETURNED IN THE FLOATING POINT ACCUMULATOR.
;
;
; STORAGE IN SCRATCH BANK
FSQRN EQU SCRT + 00H
FSQRX EQU SCRT + 04H
;
FSQRT: CALL FABS ;FORCE ARGUMENT POSITIVE, SET ZERO FLAG
RZ ;RETURN ON ZERO
LXI H,FSQRN
CALL FSTOR
ANA A ;RESET CARRY BIT
RAR ;HALVE THE EXPONENT
ADI 40H ;RESTORE THE OFFSET
LXI H,FSQRX
CALL FSTOR
MVI D,5 ;ITERATION COUNT
PUSH D ;STACKED
FSQRL: LXI H,FSQRN
CALL FLOAD
LXI H,FSQRX
CALL FDIV
LXI H,FSQRX
CALL FADD
SUI 1 ;HALVE THE RESULT
LXI H,FSQRX
CALL FSTOR
POP D ;RESTORE ITERATION COUNT
DCR D ;TALLY
JZ FSQRE ;EXIT WHEN COUNT EXHAUSTED
PUSH D ;SAVE IT OTHERWISE
JMP FSQRL ;TO NEXT ITERATION
FSQRE: LXI H,FSQRX ;RESULT TO ACCUMULATOR
CALL FLOAD
RET
;
; EVALUATION OF ELEMENTARY FUNCTION MACLAURIN SERIES
;
;
; ENTRY FMACE FOR EXPONENTIAL TYPE SERIES, E.G.
; SINH(Z) = Z/1 + Z^3/6 + Z^5/120 + ...
; S(I-1) = (1. + X*S(I)/A(I)), S(N) = 1.
;
; ENTRY FMACL FOR LOGARITHMIC TYPE SERIES, E.G.
; ARCTAN(Z) = Z/1 - Z^3/3 + Z^5/5 - ...
; S(I-1) = (1./A(I) + X*S(I)), S(N) = 0.
;
; IN BOTH SERIES DEL^2(A(I)) MUST BE CONSTANT.
; ENTER WITH X IN FMACX, A(N) IN D, D(A(N-1)) IN C,
; D^2(A(1)) IN B.
; RESULT IN FMACS, WHEN A(I) <= 0.
;
; STORAGE IN SCRATCH BANK
FMACX EQU SCRT+00H
FMACS EQU SCRT+04H
FMACT EQU SCRT+08H
FMACG EQU SCRT+0CH
;
; TWO SUBROUTINE LEVELS USED
;
FMACL: XRA A ;CLEAR A REGISTER FOR LOG TYPE SERIES
LXI H,FMACS ;POINT TO SIGMA
MOV M,A ;ZERO STORED
LXI H,FMACB ;PRESET BRANCH B
JMP FMACC ;JOINT CODE
FMACE: LHLD FONE ;MOVE 1.0 TO SIGMA FOR EXP TYPE SERIES
SHLD FMACS
LHLD FONE+2
SHLD FMACS+2
LXI H,FMACA ;PRESET BRANCH A
FMACC: SHLD FMACG ;STORE PRESET BRANCH
MVI E,32 ;COUNT FOR THE FLOATING OF A(I)
FMACD: PUSH B ;CHAIN RULE LOOP
PUSH D ;SAVE A(I), D(A(I)), D^2(A(1))
XRA A ;ZERO THE LEAD POSITIONS OF A(I)
MOV B,A
MOV C,A
CALL FFLOAT ;FLOAT A(I)
LXI H,FMACT
CALL FSTOR
LXI H,FMACX
CALL FLOAD
LXI H,FMACS
CALL FMUL
LHLD FMACG ;CHOOSE THE BRANCH
PCHL
FMACA: LXI H,FMACT
CALL FDIV
LXI H,FONE ;POINTS TO 1.0
JMP FMACF ;REJOIN COMMON CODE
FMACB: LXI H,FMACS
CALL FSTOR ;X*SIGMA
LXI H,FONE ;LOAD 1.0
CALL FLOAD
LXI H,FMACT
CALL FDIV ;1/A(I)
LXI H,FMACS
FMACF: CALL FADD
LXI H,FMACS
CALL FSTOR
POP D ;A(I) AND 32
POP B ;D(A) AND D^2(A)
MOV A,D
SUB C
RZ ;DONE IF ZERO
RC ;OR NEGATIVE
MOV D,A ;A(I-1)
MOV A,C ;D(A(I-1))
SUB B
MOV C,A ;D(A(I-2))
JMP FMACD ;NEXT ITERATION
FONE: DB 81H,0,0,0 ;CAN BE IN ROM
FPIV2: DB 81H,49H,0FH,0DCH;PI/2
FLN2: DB 80H,31H,72H,18H;LN 2
;
;
; SINE-COSINE ROUTINE USING MACLAURIN SERIES
;
;
; ENTRY FSIN FOR SIN(X)
; ENTRY FCOS FOR COS(X)
; ENTER WITH X IN RADIANS IN FLOATING POINT ACCUMULATOR
; RETURNS WITH FUNCTION IN FLOATIG POINT ACCUMULATOR
; (IF FABS(X) >= 2^24*PI, OVERFLOW FLAG IS SET)
;
; STORAGE IN SCRATCH BANK
FSINX EQU SCRT+10H
;
; THREE LEVELS OF SUBROUTINES USED
;
FCOS: CALL FCHS ;COMPLEMENT THE ANGLE
LXI H,FPIV2
CALL FADD
FSIN: CALL FTEST ;FETCH ARGUMENT
LXI H,FSINX
CALL FSTOR
LXI H,FPIV2 ;REDUCE X TO REVOLUTIONS*4
CALL FDIV
MVI E,26 ;REVOLUTIONS AT BINARY SCALE 24
CALL FFIX
JC OVERF ;QUIT IF ANGLE TO LARGE
MVI E,26
MVI D,0 ;WIPE OUT FRACTIONAL REVOLUTIONS
CALL FFLOAT ;INTEGER PART OF REVOLUTIONS
LXI H,FPIV2 ;TO RADIANS
CALL FMUL
CALL FCHS
FSINA: LXI H,FSINX
CALL FADD
LXI H,FSINX
CALL FSTOR
CALL FABS ;FORCE ANGLE INTO REDUCED RANGE
LXI H,FPIV2
CALL FSUB
JM FSINB ;IF NEGATIVE OR ZERO
JZ FSINB ;THEN ANDGLE IS REDUCED
LXI H,FPIV2 ;FABS(X)-PI
CALL FSUB
MOV E,A ;SAVE A REGISTER
LXI H,FSINX+1
MOV A,M
ANI 80H ;SIGN OF X
XRI 80H ;INVERTED
XRA B ;-SIGN(X)*(FABS(X)-PI)
MOV B,A
MOV A,E ;RESTORE A REGISTER
DCX H ;POINT TO FSINX
CALL FSTOR ;REDUCED X
CALL FZERO ;CLEAR ACCUMULATOR
JMP FSINA ;REPEAT UNTIL FABS(X) <= PI/2
;
FSINB: LXI H,FSINX
CALL FLOAD
LXI H,FSINX
CALL FMUL
CALL FCHS ;-X^2
LXI H,FMACX
CALL FSTOR ;TO MACLAURIN SERIES
MVI D,72 ;9*8, 11 TERM DISCARDED, 18 BITS PRECISION
MVI C,30 ;9*8 - 7*6
MVI B,8 ;(9*8 - 7*6) - (7*6 - 5*4)
CALL FMACE
LXI H,FMACS
CALL FLOAD
LXI H,FSINX
CALL FMUL
CPI 81H ;SEE IF TAIL NEEDS CLEANING
JC FSINC ;NO, MAGNITUDE IS < 1.0
LXI H,ACC2
XRA A
MOV M,A
INR L
MOV M,A
FSINC: CALL FTEST ;RESTORE FLAGS AND REGISTERS FOR EXIT
RET
;
;
; ARCTAN ROUTINE USING MACLAURIN SERIES
;
;
;
; ENTRY FATAN FOR ARCTAN(X), WITH X IN FLOATING POINT ACCUMULATOR
; RESULT RETURNED IN FLOATING POINT ACCUMULATOR
;
; STORAGE IN SCRATCH BANK
FATNT EQU SCRT+10H
FATNU EQU SCRT+14H
;
; FOUR LEVELS OF STACK USED
;
FATAN: CALL FTEST ;GET F.P. ACC. INTO REGISTERS
RZ
CPI 81H ;TEST EXPONENT
JC FATN1 ;RETURN TO CALLER FROM FATN1
LXI H,FONE ;1.0
CALL IDV ;1.0/X
CALL FATN1 ;ARCTAN(1/X)
LXI H,FATNU
CALL FSTOR
LXI H,FPIV2 ;PI/2
CALL FLOAD
MOV E,A ;SAVE A REGISTER
LXI H,FATNU+1 ;SIGN(T)
MOV A,M ;TO A REGISTER
ANI 80H
ORA B ;ATTACH TO PI/2
MOV B,A
MOV A,E ;RESTORE A REGISTER
LXI H,FATNT
CALL FSTOR
LXI H,FATNT
CALL FLOAD
LXI H,FATNU ;-SIGN(T)*(PI/S-FABS(T))
CALL FSUB ;=SIGN(T)*FABS(T) = T
RET
;
; EVALUATE ARCTAN OF ARGUMENTS < 1.0
FATN1: LXI H,FATNT ;POINT TO TEMP
CALL FSTOR ;TAN(T)
LXI H,FATNT
CALL FMUL ;TAN(T)^2
LXI H,FONE ;1.0
CALL FADD
CALL FSQRT
LXI H,FONE
CALL FADD ;1.0+SQRT(TAN(T)^2+1.0)
LXI H,FATNT
CALL IDV ;TAN(T/2)
LXI H,FATNT
CALL FSTOR
LXI H,FATNU
INR A ;2*TAN(T/2)
CALL FSTOR
LXI H,FATNT
CALL FMUL
CALL FCHS ;-TAN(T/2)^2
LXI H,FMACX
CALL FSTOR
MVI D,11 ;TERM 13 DISCARDED, 16 BITS PRECISION IN RANGE
MVI C,2 ;(11-9)
MVI B,0 ;(11-9)-(9-7)
CALL FMACL
LXI H,FMACS
CALL FLOAD
LXI H,FATNU
CALL FMUL
RET
;
;
;
; HYPERBOLIC COSINE ROUTINE USING MACLAURIN SERIES
;
;
;
; ENTRY FCOSH FOR COSH(X), WITH X IN THE FLOATING POINT ACCUMULATOR
; THE RESULT IS RETURNED IN THE F.P. ACCUMULATOR.
; IF FABS(X) > 88.0 THE OVERFLOW FLAG IS SET.
;
; STORAGE IN SCRATCH BANK
FCSHD EQU SCRT+0EH ;DOUBLING COUNTER
;
; THREE LEVELS OF STACK USED
;
FCOSH: CALL FTEST ;GET ARGUMENT INTO REGISTERS
LXI H,FMACX
CALL FSTOR
LXI H,FCSHD
MVI M,0
SUI 80H ;REMOVE EXPONENT OFFSET
JM FCSHA ;DOUBLING COUNT AND X ARE OK
CPI 8 ;ELIMINATE OVERSIZE DOUBLING COUNT
JP OVERF ;RETURN THROUGH OVERFLOW ROUTINE
MOV M,A ;SAVE THE DOUBLING COUNT
LXI H,FMACX
MVI M,80H
CALL FLOAD ;PUT X INTO ACC
FCSHA: LXI H,FMACX
CALL FMUL ;X^2
LXI H,FMACX
CALL FSTOR
MVI D,56 ;8*7, 10 TERM DISCARDED, 21 BITS PRECISION
MVI C,26 ;(8*7-6*5)
MVI B,8 ;(8*7-6*5) - (6*5-4*3)
CALL FMACE
FCSHB: LXI H,FCSHD ;ADDRESS THE DOUBLING COUNT
DCR M ;TALLY AT LOOP TOP
JM FCSHC ;DONE WHEN COUNT IS NEGATIVE
LXI H,FMACS ;FETCH COSH(X/2)
CALL FLOAD
LXI H,FMACS
CALL FMUL ;COSH(X/2)^2
LXI H,ACCE
INR M ;2*COSH(X/2)^2
LXI H,FONE ;-1.0
CALL FSUB ;=COSH(X)
LXI H,FMACS
CALL FSTOR
JMP FCSHB ;TEST DOUBLING COUNT
FCSHC: CALL FTEST ;RESTORE REGISTERS AND FLAGS
RET
;
;
;
; EXPONENTIAL AND HYPERBOLIC SIN ROUTINE
;
;
; SCRATCH BANK STORAGE
FSNHD EQU SCRT+0EH
FEXOV EQU SCRT+0FH
FSNHX EQU SCRT+10H
;
;
; ENTRY FEXP FOR EXP(X)
; ENTRY SSINH FOR SINH(X)
; ENTRY WITH X IN FP ACCUMULATOR
; RETURNS WITH FUNCTION IN FP ACCUMULATOR.
; IF FUNCTION EXCEEDS 2^127M OVERFLOW FLAG WILL BE SET
;
FSINH: CALL FTEST ;FETCH FP ACCUMULATOR
LXI H,FSNHX ;SAVE ARGUMENT
CALL FSTOR
LXI H,FSNHD ;ADDRESS DOUBLING COUNTER
MVI M,0
SUI 80H ;REMOVE OFFSET FROM A
JM FSNHA ;DOUBLING COUNT AND X ARE OK
CPI 8 ;ELIMINATE OVERSIZE DOUBLING COUNT
JP OVERF ;RETURN THROUGH OVERFLOW ROUTINE
MOV M,A ;SAVE DOUBLING COUNT
LXI H,FSNHX ;BRING ARGUMENT INTO RANGE
MVI M,80H
CALL FLOAD ;PUT X INTO FLOATING ACCUMULATOR
FSNHA: LXI H,FSNHX
CALL FMUL ;X^2
LXI H,FMACX
CALL FSTOR
MVI D,42 ;7*6, 9 TERM DISCARDED, 18 BITS PRECISION
MVI C,22 ;7*6-5*4
MVI B,8 ;(7*6-5*4)-(F*4-3*2)
CALL FMACE
LXI H,FMACS
CALL FLOAD
LXI H,FSNHX
CALL FMUL
LXI H,FSNHX ;SINH(X)
CALL FSTOR
LXI H,FSNHX ;SINH(X)^2
CALL FMUL
LXI H,FONE ;+1.0
CALL FADD
CALL FSQRT ;COSH(X) FOR DOUBLINE AND FOR EXP(X9
LXI H,FMACX ;TEMP
CALL FSTOR
FSNHB: LXI H,FSNHD ;ADDRESS DOUBLING COUNT
DCR M ;TALLY AT LOOP TOP
JM FSNHC ;DONE WHEN NEGATIVE
LXI H,FMACX ;COSH(X/2)
CALL FLOAD
LXI H,FSNHX ;SINH(X/2)
CALL FMUL
INR A ;2.*SINH(X/2)*COSH(X/2)
LXI H,FSNHX ;SINH(X)
CALL FSTOR
LXI H,FMACX ;COSH(X/2)
CALL FLOAD
LXI H,FMACX
CALL FMUL
LXI H,ACCE ;2.*COSH(X/2)^2
INR M
LXI H,FONE ;-1
CALL FSUB
LXI H,FMACX ;=COSH(X)
CALL FSTOR
JMP FSNHB ;TEST THE DOUBLING COUNT
FSNHC: LXI H,FSNHX
CALL FLOAD
RET
FEXP: CALL FTEST
JP FEXPP
LXI H,OVER ;SAVE OVERFLOW FLAG
MOV E,M
MVI M,0
LXI H,FEXOV
MOV M,E ;OLD FLAG TO SAVE CELL
CALL FABS
CALL FEXPP ;EXP(-X) IN ACC
LXI H,FEXOV ;GET OLD OVERFLOW FLAG BACK
MOV E,M
LXI H,OVER ;PICK UP NEW ONE TO TEST
MOV A,M
MOV M,E ;RESTORE OLD OVERFLOW FLAG
ANA A ;SET FLAGS
JNZ FZERO ;RECIPROCAL OF OVERFLOW IS ZERO
LXI H,FONE
CALL IDV ;1./EXP(-X) = EXP(X)
RET
FEXPP: CALL FSINH ;SINH(X)
LXI H,FMACX ;+COSH(X)
CALL FADD ;=EXP(X)
RET
;
;
;
; NATURAL LOGARITHM ROUTINE USING MACLAURIN SERIES
;
;
;
;
; ENTRY POINTS IN MACLAURIN SERIES
; STORAGE IN SCRATCH BANK
FLOGE EQU SCRT+0EH
FLOGX EQU SCRT+10H
;
;
; ENTRY FLOG FOR LN(FABS(X)), WITH X IN F.P. ACCUMULATOR
; RESULT IS RETURNED IN FLOATING POINT ACCUMULATOR
; IF X = 0 THE OVERFLOW FLAG IS SET
;
; 3 LEVELS OF SUBROUTINES USED
;
FLOG: CALL FABS ;FORCE ARGUMENT POSITIVE, SET ZERO FLAG
JZ OVERF ;RETURN THROUGH OVERFLOW ROUTINE
SUI 81H ;REMOVE EXPONENT OFFSET
LXI H,FLOGE
MOV M,A
MVI A,81H ;NORMALIZE ARGUMENT
LXI H,FLOGX
CALL FSTOR ;CALL IT X
LXI H,FLOGX
CALL FLOAD
LXI H,FONE
CALL FADD
LXI H,FMACS
CALL FSTOR ;X+1.0
LXI H,FLOGX
CALL FLOAD
LXI H,FONE
CALL FSUB ;X-1.0
LXI H,FMACS
CALL FDIV
LXI H,FLOGX
CALL FSTOR ;(X-1.0)/(X+1.0)
LXI H,FLOGX
CALL FMUL
LXI H,FMACX
CALL FSTOR ;((X-1.0)/(X+1.0))^2
MVI D,9 ;DISCARD 11 TERM FOR 18 BITS PRECISION
MVI C,2 ;9-7
MVI B,0 ;(9-7)-(7-5)
CALL FMACL
LXI H,FMACS
INR M ;DOUBLE THE SUM
CALL FLOAD
LXI H,FLOGX
CALL FMUL ;LOGARITHM OF FRACTIONAL PART
LXI H,FLOGX
CALL FSTOR
LXI H,FLOGE
MOV A,M
MVI B,0
MOV C,B
MOV D,B
MVI E,8 ;BINARY SCALE FACTOR FOR EXPONENT
CALL FFLOAT
LXI H,FLN2
CALL FMUL ;LOGARITHM OF 2^EXPONENT
LXI H,FLOGX ;LOG OF FRACTIONAL PART
CALL FADD
RET
;
; RANDOM NUMBER GENERATOR
;
;
RAND: ;COMPUTE NEXT RANDOM NUMBER, AND LEAVE AT SEED
LXI H,SEED
MOV C,M ;GET LEAST SIGNIFICANT BYTE
INR L
MOV B,M ;X(N) IN B,C
DCR L ;ADDRESS SEED FOR SBR2
CALL AROUT ;CALCUALTE X(N)*2053D
LXI H,CNST ;ADDRESS CONSTANT 13849
CALL SBR2
LXI H,SEED ;ADDRESS SEED AGAIN
MOV M,C ;STORE NEW SEED
INR L
MOV M,B
RET ;WITH SEED SET TO RANDOM NUMBER
;
CNST: DW 13849
;
AROUT: ;COMPUTE X(N)*2053D TO B,C
MVI D,9 ;X(N)*2**9
CALL SBR1
CALL SBR2 ;X(N)+X(N)*2**9
MVI D,2 ;2**2*(X(N)+X(N)*2**9)
CALL SBR1
CALL SBR2 ;ADD TO X(N)
RET
;
SBR1: ;FORMS (B AND C)*2**D
SUB A ;CLEAR A AND CARRY
MOV A,C ;SHIFT C LEFT
RAL
MOV C,A
MOV A,B ;SHIFT B LEFT
RAL
MOV B,A
DCR D ;TEST D=0
RZ ;IF YES, RETURN
JMP SBR1 ;NO, SHIFT AGAIN
;
SBR2: ;16-BIT ADD OF B,C TO M(H,L), RESULT TO B,C
SUB A ;CLEAR A AND CARRY
MOV A,M ;LOAD LOW BYTE
ADD C ;M(H,L)+C
MOV C,A
INR L ;M(H,L+1)
MOV A,M
ADC B
MOV B,A
DCR L ;RESTORE H,L FOR NEXT OPERATION
RET
END