;                      change log
;      added KOLUNP anf KOLPK                     5 Nov 2018
;
    TTL   bptm2d
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R0  RN     0
R1  RN     1
R2  RN     2
R3  RN     3
R4  RN     4
;
    AREA   |C$$code|,CODE,READONLY
    EXPORT bptm2d_;(BM,R8,M,N) convert N binary.M to REAL*8
;                   BM and R8 may not be the same array
    DCB    "bptm2d_",0,8,0,0,255
bptm2d_
    MOV    ip,sp
    STMDB  sp!,{R0-R4,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R2,[R2]         ;M (= # binary places in 32-bit word)
    RSB    R2,R2,#&400     ;subtract it from exponent bias
    ADD    R2,R2,#&1E 
    LDR    R3,[R3]         ;N (assumed >0)
lp1 LDR    lr,[R0],#4      ;get Binary.M
    ANDS   R4,lr,#&80000000;get sign bit
    RSBNE  lr,lr,#0        ;|Binary.M|
    CMP    lr,#0
    MOVEQ  ip,#0
    BEQ    pt1             ;zero
    MOV    ip,R2,LSL#20    ;initial exponent
lp2 ADDS   lr,lr,lr        ;multiply by 2
    SUBCC  ip,ip,#&100000  ;and subtract 1 from exponent
    BCC    lp2             ;until m.s. bit is moved out
    ORR    ip,ip,lr,LSR#12 ;add mantissa to exponent
    ORR    ip,ip,R4        ;add sign
    MOV    lr,lr,LSL#20    ;less significant half
pt1 STMIA  R1!,{ip,lr}     ;store REAL*8
    SUBS   R3,R3,#1
    BGT    lp1             ;loop over the N words
    LDMDB  fp,{R4,fp,sp,pc} 
    END
;
    TTL   bptm2r
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R0  RN     0
R1  RN     1
R2  RN     2
R3  RN     3
R4  RN     4
;
    AREA   |C$$code|,CODE,READONLY
    EXPORT bptm2r_;(BM,R4,M,N) convert N binary.M to REAL*4
;                   BM and R4 may be the same array
    DCB    "bptm2r_",0,8,0,0,255
bptm2r_
    MOV    ip,sp
    STMDB  sp!,{R0-R4,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R2,[R2]         ;M (= # binary places in 32-bit word)
    RSB    R2,R2,#158      ;subtract it from exponent bias
    LDR    R3,[R3]         ;N (assumed >0)
lp1 LDR    lr,[R0],#4      ;get Binary.M
    ANDS   R4,lr,#2,2      ;get sign bit
    RSBNE  lr,lr,#0        ;|Binary.M|
    CMP    lr,#0
    BEQ    pt1             ;zero
    MOV    ip,R2,LSL#23    ;initial exponent
lp2 ADDS   lr,lr,lr        ;multiply by 2
    SUBCC  ip,ip,#&800000  ;and subtract 1 from exponent
    BCC    lp2             ;until m.s. bit is moved out
    ORRS   lr,ip,lr,LSR#9  ;add mantissa to exponent and set C for rounding
    ADC    lr,lr,R4        ;add sign and round
pt1 STR    lr,[R1],#4      ;store REAL*4
    SUBS   R3,R3,#1
    BGT    lp1             ;loop over the N words
    LDMDB  fp,{R4,fp,sp,pc} 
    END
;
    TTL   bvdist
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
sl  RN    10
R0  RN     0
R1  RN     1
R2  RN     2
R3  RN     3
;
    AREA   |C$$code|,CODE,READONLY
    IMPORT bvmod_
    IMPORT __rt_stkovf_split_big
    EXPORT bvdist_;(X1,X2,N) finds the length of the N-vector X2-X1
;          X1 and X2 have the same arbitrary binary point;
;          returned value has the same binary point;
;          overflows will give the wrong answer.
    DCB    "bvdist_",0,8,0,0,255
bvdist_
    MOV    ip,sp
    STMDB  sp!,{R0-R2,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R2,[R2]        ;N
    SUB    ip,sp,R2,LSL#2 ;bottom of stack to request
    CMP    ip,sl
    BLLT   __rt_stkovf_split_big
lp3 LDR    ip,[R0],#4     ;find X2 - X1
    LDR    lr,[R1],#4
    SUB    ip,ip,lr
    STR    ip,[sp,#-4]!   ;store on stack
    SUBS   R2,R2,#1
    BGT    lp3
    MOV    R0,sp
    LDR    R1,[fp,#-16]   ;(N)
    BL     bvmod_
    LDMDB  fp,{fp,sp,pc}  ;return
    END
;
    TTL   bvdst2
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
sl  RN    10
R0  RN     0
R1  RN     1
R2  RN     2
R3  RN     3
;
    AREA   |C$$code|,CODE,READONLY
    IMPORT bvmod2_
    IMPORT __rt_stkovf_split_big
    EXPORT bvdst2_;(X1,X2,N) finds the squared length of the N-vector X2-X1
;          X1 and X2 have the same arbitrary binary point;
;          returned value has the sum of the binary points;
;          overflows will give the wrong answer.
    DCB    "bvdst2_",0,8,0,0,255
bvdst2_
    MOV    ip,sp
    STMDB  sp!,{R0-R2,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R2,[R2]        ;N
    SUB    ip,sp,R2,LSL#2 ;bottom of stack to request
    CMP    ip,sl
    BLLT   __rt_stkovf_split_big
lp3 LDR    ip,[R0],#4     ;find X2 - X1
    LDR    lr,[R1],#4
    SUB    ip,ip,lr
    STR    ip,[sp,#-4]!   ;store on stack
    SUBS   R2,R2,#1
    BGT    lp3
    MOV    R0,sp
    LDR    R1,[fp,#-16]   ;(N)
    BL     bvmod2_
    LDMDB  fp,{fp,sp,pc}  ;return
    END
;
    TTL   bvcros
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R0  RN     0
R1  RN     1
R2  RN     2
R3  RN     3
R4  RN     4
R5  RN     5
R6  RN     6
R7  RN     7
R8  RN     8
R9  RN     9
;
    AREA   |C$$code|,CODE,READONLY
    EXPORT bvcros_;(A,B,C) calculates C = vector product (AxB)
;           A, B assumed binary.30 (direction cosines)
;
    DCB    "bvcros_",0,8,0,0,255
bvcros_
    MOV    ip,sp
    STMDB  sp!,{R0-R2,R4-R7,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R3,[R0,#4]
    LDR    R4,[R1,#8]
    BL     mult            ;A(2)*B(3)
    MOV    R7,R3           ;save
    LDR    R3,[R0,#8]
    LDR    R4,[R1,#4]
    BL     mult            ;A(3)*B(2)
    SUB    R7,R7,R3
    STR    R7,[R2],#4      ;C(1) = A(2)*B(3) - A(3)*B(2)
;
    LDR    R3,[R0,#8]
    LDR    R4,[R1,#0]
    BL     mult            ;A(3)*B(1)
    MOV    R7,R3           ;save
    LDR    R3,[R0,#0]
    LDR    R4,[R1,#8]
    BL     mult            ;A(1)*B(3)
    SUB    R7,R7,R3
    STR    R7,[R2],#4      ;C(2) = A(3)*B(1) - A(1)*B(3)
;
    LDR    R3,[R0,#0]
    LDR    R4,[R1,#4]
    BL     mult            ;A(1)*B(2)
    MOV    R7,R3           ;save
    LDR    R3,[R0,#4]
    LDR    R4,[R1,#0]
    BL     mult            ;A(2)*B(1)
    SUB    R7,R7,R3
    STR    R7,[R2],#4      ;C(3) = A(1)*B(2) - A(2)*B(1)
;
    LDMDB fp,{R4-R7,fp,sp,pc} ;return
;
mult;  multiply R3 by R4 with result in R3 shifted left 2 places
;        destroys R3, R4, R5, R6, ip (uses lr for return)
    MOV    R5,R3,ASR#16    ;m.s. R3
    MOV    R6,R4,ASR#16    ;m.s. R4
    BIC    R3,R3,R5,LSL#16 ;l.s. R3
    BIC    R4,R4,R6,LSL#16 ;l.s. R4
;       find product
    MUL    ip,R3,R4        ;least sig 32 bits
    MUL    R4,R5,R4        ;mid sig(1)
    MUL    R3,R6,R3        ;mid sig(2)
    MUL    R5,R6,R5        ;most sig 32 bits
    ADDS   ip,ip,R4,LSL#16
    ADC    R5,R5,R4,ASR#16
    ADDS   ip,ip,R3,LSL#16
    ADC    R5,R5,R3,ASR#16
    MOVS   ip,ip,LSR#30    ;prepare for Binary.30
    ADC    R3,ip,R5,LSL#2  ;result shifted up 2 bits (for binary.30)
    MOV    pc,lr
    END
;
    TTL   bvmod
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R0  RN     0
R1  RN     1
R2  RN     2
R3  RN     3
;
    AREA   |C$$code|,CODE,READONLY
    EXPORT bvmod_;(X,N) finds the length of the N-vector X
;          X has arbitrary binary point;
;          returned value has the same binary point;
;          overflows will give the wrong answer.
    DCB    "bvmod_",0,0,8,0,0,255
bvmod_
    MOV    ip,sp
    STMDB  sp!,{R0-R1,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R1,[R1]        ;N
    MOV    R2,#0          ;clear accumulator
    MOV    R3,#0
    CMP    R1,#0
    BLE    sqt            ;finished
lp1 LDR    ip,[R0],#4     ;get X
    CMP    ip,#0
    RSBLT  ip,ip,#0       ;|X|
    MOV    lr,ip,LSR#16   ;m.s. 16 bits of X
    BIC    ip,ip,lr,LSL#16;l.s. 16 bits of X
    MLA    R3,lr,lr,R3    ;add m.s. 32 bits of product to upper sum
    MUL    lr,ip,lr       ;middle 32 bits of product
    ADDS   R2,R2,lr,LSL#17;add this to lower sum
    ADC    R3,R3,lr,LSR#15;and to upper sum
    MUL    lr,ip,ip       ;l.s. 32-bits of product
    ADDS   R2,R2,lr       ;add to lower sum
    ADDCS  R3,R3,#1       ;add carry to upper sum
    SUBS   R1,R1,#1
    BGT    lp1
sqt;    get square root
    MVN    R1,#&10000     ;bits for digit pairs
    MOV    R0,#0          ;result
    MOV    ip,#0          ;initial remainder
lp2 MOV    ip,ip,LSL#2
    ORR    ip,ip,R3,LSR#30;add next 2 bits to remainder
    MOV    R3,R3,LSL#2    ;move up the numerator 2 places
    RSBS   lr,ip,R0,LSL#2
    SBCCC  ip,ip,R0,LSL#2 ;subtract (4*result+1)      15/10/2001
    ADD    R0,R0,R0       ;double result
    ADDCC  R0,R0,#1       ;(and add 1)                15/10/2001
    MOVS   R1,R1,LSL#1
    MOVCC  R3,R2          ;use l.s. 32-bits when m.s. 32 bits finished
    BNE    lp2
    CMP    ip,R0
    ADDGT  R0,R0,#1       ;round
    LDMDB  fp,{fp,sp,pc}  ;return
    END
;
    TTL   bvmod2
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R0  RN     0
R1  RN     1
R2  RN     2
R3  RN     3
;
    AREA   |C$$code|,CODE,READONLY
    EXPORT bvmod2_;(X,N) finds the length of the N-vector X
;          X has arbitrary binary point;
;          returned value has the same binary point;
;          overflows will give the wrong answer.
    DCB    "bvmod2_",0,8,0,0,255
bvmod2_
    MOV    ip,sp
    STMDB  sp!,{R0-R1,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R1,[R1]        ;N
    MOV    R2,#0          ;clear accumulator
    MOV    R3,#0
    CMP    R1,#0
    BLE    res            ;finished
lp1 LDR    ip,[R0],#4     ;get X
    CMP    ip,#0
    RSBLT  ip,ip,#0       ;|X|
    MOV    lr,ip,LSR#16   ;m.s. 16 bits of X
    BIC    ip,ip,lr,LSL#16;l.s. 16 bits of X
    MLA    R3,lr,lr,R3    ;add m.s. 32 bits of product to upper sum
    MUL    lr,ip,lr       ;middle 32 bits of product
    ADDS   R2,R2,lr,LSL#17;add this to lower sum
    ADC    R3,R3,lr,LSR#15;and to upper sum
    MUL    lr,ip,ip       ;l.s. 32-bits of product
    ADDS   R2,R2,lr       ;add to lower sum
    ADDCS  R3,R3,#1       ;add carry to upper sum
    SUBS   R1,R1,#1
    BGT    lp1
res ADDS   R2,R2,#&80000000; generate 'C' for rounding
    ADC    R0,R3,#0       ;store result rounded
    LDMDB  fp,{fp,sp,pc}  ;return
    END
;
    TTL   bvunit
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R0  RN     0
R1  RN     1
R2  RN     2
R3  RN     3
R4  RN     4
;
    AREA   |C$$code|,CODE,READONLY
    IMPORT bvmod_
    EXPORT bvunit_;(A,X,N) set X = A/|A|
;          A and X are N-vectors in fixed point format
;          X is returned in binary.30
;          the binary point position of A is not relevant
;
    DCB    "bvunit_",0,8,0,0,255
bvunit_
    MOV    ip,sp
    STMDB  sp!,{R0-R2,R4,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R4,[R2]    ;N
    MOV    R1,R2
    BL     bvmod_     ;find |A| (in R0)
    CMP    R0,#16     ;allow for rounding
    MOVLE  R0,#0
    LDMLEDB fp,{R4,fp,sp,pc}  ;return .false. if |A|=0
    LDMIA  sp,{R1-R2} ;retrieve (A),(X)
lp1 LDR    R3,[R1],#4 ;Ai
    MOVS   ip,R3      ;save sign
    RSBMI  R3,R3,#0   ;|Ai|
    MOV    lr,#2      ;bit count for result in binary.30
lp2 CMP    R3,R0      ;divide R3 by R0
    SUBCS  R3,R3,R0
    ADD    R3,R3,R3
    ADCS   lr,lr,lr   ;result in lr
    BCC    lp2
    CMP    R3,R0
    ADDCS  lr,lr,#1   ;round
    CMP    ip,#0
    RSBLT  lr,lr,#0
    STR    lr,[R2],#4 ;store Xi
    SUBS   R4,R4,#1
    BGT    lp1
    MOV    R0,#1
    LDMDB  fp,{R4,fp,sp,pc}  ;return .true.
    END
;
    TTL   d2bptm
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R0  RN     0
R1  RN     1
R2  RN     2
R3  RN     3
R4  RN     4
R5  RN     5
R6  RN     6
;
    AREA   |C$$code|,CODE,READONLY
    EXPORT d2bptm_;(R8,BM,M,N) convert N REAL*8 to binary.M (32-bits)
;                   R8 and BM may be the same array
;                   overflows are ignored and will give the wrong answer
    DCB    "d2bptm_",0,8,0,0,255
d2bptm_
    MOV    ip,sp
    STMDB  sp!,{R0-R6,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R2,[R2]         ;M (= # binary places in 32-bit word)
    LDR    R3,[R3]         ;N (assumed >0)
lp3 LDMIA  R0!,{R5,R6}     ;get real*8
    MOV    R4,R5,ASR#31    ;save sign
    MOV    R5,R5,LSL#1     ;move exponent into m.s. byte
    MOV    ip,R5,LSR#21    ;get exponent
    MOV    R5,R5,LSL#10    ;clear exponent
    ORR    R5,R5,#2,2      ;restore most significant bit
    ORR    R5,R5,R6,LSR#21 ;include extra bits from l.s.word
    RSB    ip,ip,#1056     ;1023=bias, 31=required shift for binary.0
    SUB    ip,ip,R2        ;subtract M to get required right shift
    CMP    ip,#30
    MOVGE  R5,#0
    SUBS   ip,ip,#2
    MOVGES R5,R5,LSR ip    ;right shift and set C for rounding
    ADDCS  R5,R5,#1        ;round
    CMP    R4,#0
    RSBNE  R5,R5,#0        ;set sign
    STR    R5,[R1],#4      ;store Binary.M
    SUBS   R3,R3,#1
    BGT    lp3             ;loop over the N words
    LDMDB  fp,{R4-R6,fp,sp,pc} 
    END
;
    TTL   dotvb
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R0  RN     0
R1  RN     1
R2  RN     2
R3  RN     3
R4  RN     4
R5  RN     5
R6  RN     6
R7  RN     7
F0  FN     0
;
    AREA   |C$$code|,CODE,READONLY
    EXPORT dotvb_;(IV1,IV2) returns dot product of IV1 and IV2
;          arguments in binary.30 (direction cosines)
;          REAL result in the range -1.0 to 1.0
    DCB    "dotvb_",0,0,8,0,0,255
dotvb_
    MOV    ip,sp
    STMDB  sp!,{R0-R1,R4-R7,fp,ip,lr,pc}
    SUB    fp,ip,#4
    MOV    R3,#0          ;flag for floating result
dot LDMIA  R0,{R2,R7,ip}  ;get IV1 vector
    LDMIA  R1,{R0,R1,lr}  ;get IV2 vector
    MOV    R4,R2,ASR#16   ;16 m.s. bits IV1(1)
    BIC    R2,R2,R4,LSL#16;16 l.s. bits
    MOV    R5,R0,ASR#16   ;16 m.s. bits IV2(1)
    BIC    R0,R0,R5,LSL#16;16 l.s. bits
    MUL    R6,R0,R2       ;l.s. bits of product
    MUL    R2,R5,R2       ;middle bits of product
    MUL    R0,R4,R0
    MUL    R4,R5,R4       ;m.s. bits of product
    ADDS   R6,R6,R2,LSL#16;add bottom of middle to l.s
    ADC    R4,R4,R2,ASR#16;add top of middle to m.s
    ADDS   R6,R6,R0,LSL#16;add bottom of middle to l.s
    ADC    R4,R4,R0,ASR#16;add top of middle to m.s
;
    MOV    R0,R7,ASR#16   ;16 m.s. bits IV1(2)
    BIC    R7,R7,R0,LSL#16;16 l.s. bits
    MOV    R5,R1,ASR#16   ;16 m.s. bits IV2(2)
    BIC    R1,R1,R5,LSL#16;16 l.s. bits
    MUL    R2,R1,R7       ;l.s. bits of product
    MUL    R7,R5,R7       ;middle bits of product
    MUL    R1,R0,R1
    MUL    R0,R5,R0       ;m.s. bits of product
    ADDS   R6,R6,R2       ;add in new l.s. half
    ADC    R4,R4,R0       ;and m.s. half
    ADDS   R6,R6,R7,LSL#16;add bottom of middle to l.s
    ADC    R4,R4,R7,ASR#16;add top of middle to m.s
    ADDS   R6,R6,R1,LSL#16;add bottom of middle to l.s
    ADC    R4,R4,R1,ASR#16;add top of middle to m.s
;
    MOV    R0,ip,ASR#16   ;16 m.s. bits IV1(3)
    BIC    ip,ip,R0,LSL#16;16 l.s. bits
    MOV    R5,lr,ASR#16   ;16 m.s. bits IV2(3)
    BIC    lr,lr,R5,LSL#16;16 l.s. bits
    MUL    R2,lr,ip       ;l.s. bits of product
    MUL    ip,R5,ip       ;middle bits of product
    MUL    lr,R0,lr
    MUL    R0,R5,R0       ;m.s. bits of product
    ADDS   R6,R6,R2       ;add in new l.s. half
    ADC    R4,R4,R0       ;and m.s. half
    ADDS   R6,R6,ip,LSL#16;add bottom of middle to l.s
    ADC    R4,R4,ip,ASR#16;add top of middle to m.s
    ADDS   R6,R6,lr,LSL#16;add bottom of middle to l.s
    ADC    R4,R4,lr,ASR#16;add top of middle to m.s
    CMP    R3,#0
    BNE    dotb60         ;result in binary.60
    ORRS   lr,R6,R4
    BEQ    vd2            ;result is zero
;          answer is now binary.60 in R4,R6
    ANDS   R0,R4,#2,2     ;sign
    ORR    R1,R0,#4,4     ;initial exponent (should be 1027)
    ORR    R1,R1,#3,12    ;initial exponent (is now 1027)
    BPL    vd1            ;positive
    RSBS   R6,R6,#0       ;take modulus
    RSC    R4,R4,#0
vd1 ADDS   R6,R6,R6
    ADCS   R4,R4,R4
    SUB    R1,R1,#1,12
    BCC    vd1            ;normalise
    MOVS   R6,R6,LSR#12
    ADCS   R6,R6,R4,LSL#20;make less sig word
    ADC    R4,R1,R4,LSR#12;add top of mantissa to exponent and sign
vd2 STMFD  sp!,{R4,R6}
    LDFD   F0,[sp]        ;move to result register
    LDMDB  fp,{R4-R7,fp,sp,pc} 
;
    EXPORT visibl_;(XYZ,DC,IPSFAC) returns .TRUE. if face is visible
    DCB    "visibl_",0,8,0,0,255
visibl_
    LDR    R3,[R2]        ;IPSFAC
    CMP    R3,#0          ;IF perspective
    MOVNE  ip,sp          ;  compare IPSFAC*(XYZ.DC) with DC(3)
    STMNEDB sp!,{R0-R2,R4-R7,fp,ip,lr,pc}
    SUBNE  fp,ip,#4
    BNE    dot            ;  go get XYZ.DC
    LDR    R0,[R1,#8]     ;ELSE get DC(3)
    CMP    R0,#&100       ; check it is definitely positive
    MOVGT  R0,#1          ; .TRUE. if it is definitely positive
    MOVLE  R0,#0          ; otherwise .FALSE.
    MOV    pc,lr          ; return
dotb60;     result returned as binary.(62 - 32 + 26) for XYZ in b.26 in R4,R6
    MOVS   R6,R6,LSR#30
    ADC    R4,R6,R4,LSL#2 ;restore to b.26 in R4
    MOV    R1,R4,ASR#16   ;16 m.s. bits
    BIC    R2,R4,R1,LSL#16;16 l.s. bits
    MOV    R5,R3,ASR#16   ;16 m.s. bits IPSFAC
    BIC    R6,R3,R5,LSL#16;16 l.s. bits
    MUL    R0,R6,R2       ;l.s. bits of product
    MUL    R2,R5,R2       ;middle bits of product
    MUL    R6,R1,R6
    MUL    R4,R1,R5       ;m.s. bits of product
    ADDS   R0,R0,R2,LSL#16;add bottom of middle to l.s
    ADC    R4,R4,R2,ASR#16;add top of middle to m.s
    ADDS   R0,R0,R6,LSL#16;add bottom of middle to l.s
    ADC    R4,R4,R6,ASR#16;add top of middle to m.s
    MOVS   R0,R0,LSR#18
    ADC    R4,R0,R4,LSL#14;make b.30 from b.48
    LDR    R1,[sp,#4]     ;(DC)
    LDR    R0,[R1,#8]     ;DC(3)
    SUB    R0,R4,R0
    MOV    R0,R0,LSR#31   ;.TRUE. if DC(3) > IPSFAC*(XYZ.DC)
    LDMDB  fp,{R4-R7,fp,sp,pc} 
    END
;
    TTL   ibcoma
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R0  RN     0
R1  RN     1
R2  RN     2
R3  RN     3
R4  RN     4
tol EQU   &80000
;
    AREA   |C$$code|,CODE,READONLY
    EXPORT ibcoma_;(A,B,M,N) returns I if A=+-B(I) for I=1,N
;               A and B are M-vectors
    DCB    "ibcoma_",0,8,0,0,255
ibcoma_
    MOV    ip,sp
    STMDB  sp!,{R0-R7,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R2,[R2]         ;M
    LDR    R3,[R3]         ;N
    MOV    R5,#0
    MOV    lr,#0
lp1;   find maximum element of |A(I)|, I=1,N
    LDR    ip,[R0,R5,LSL#2]
    CMP    ip,#0
    RSBLT  ip,ip,#0
    CMP    ip,lr
    MOVGE  lr,ip
    MOVGE  R4,R5
    ADD    R5,R5,#1
    CMP    R5,R2
    BLT    lp1
    SUB    R6,R3,#1
;        loop over elements
lp2 CMP    R6,#0
    SUBGES R7,R2,#1
    MOVLT  R0,#0
    LDMLTDB fp,{R4-R7,fp,sp,pc}  ;return zero
;        get sign of difference
    LDR    ip,[R0,R4,LSL#2]
    LDR    lr,[R1,R4,LSL#2]
    EOR    ip,ip,lr
    MOV    R5,ip,ASR#31
;       now check for same
lp3 LDR    ip,[R0,R7,LSL#2]
    LDR    lr,[R1,R7,LSL#2]
    EOR    ip,ip,R5
    SUBS   ip,ip,lr
    RSBLT  ip,ip,#0
    SUBS   ip,ip,#tol
    SUBGT  R6,R6,#1
    ADDGT  R1,R1,R2,LSL#2
    BGT    lp2                  ;fail; go check next vector
    SUBS   R7,R7,#1
    BGE    lp3
    SUB    R0,R3,R6             ;calculate and return I
    CMP    R5,#0
    RSBLT  R0,R0,#0             ;set sign of result
    LDMDB  fp,{R4-R7,fp,sp,pc}  ;return
    END
;
;
    TTL   ibcoms
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R0  RN     0
R1  RN     1
R2  RN     2
R3  RN     3
R4  RN     4
tol EQU   &40000
;
    AREA   |C$$code|,CODE,READONLY
    EXPORT ibcoms_;(A,B,M,N) returns I if A=+B(I) for I=1,N
;               A and B are M-vectors
    DCB    "ibcoms_",0,8,0,0,255
ibcoms_
    MOV    ip,sp
    STMDB  sp!,{R0-R7,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R2,[R2]         ;M
    LDR    R3,[R3]         ;N
    MOV    R5,#0
    MOV    lr,#0
lp1;   find maximum element of |A(I)|, I=1,N
    LDR    ip,[R0,R5,LSL#2]
    CMP    ip,#0
    RSBLT  ip,ip,#0
    CMP    ip,lr
    MOVGE  lr,ip
    MOVGE  R4,R5
    ADD    R5,R5,#1
    CMP    R5,R2
    BLT    lp1
    SUB    R6,R3,#1
;        loop over elements
lp2 CMP    R6,#0
    SUBGES R7,R2,#1
    MOVLT  R0,#0
    LDMLTDB fp,{R4-R7,fp,sp,pc}  ;return zero
;       now check for same
lp3 LDR    ip,[R0,R7,LSL#2]
    LDR    lr,[R1,R7,LSL#2]
    SUBS   ip,ip,lr
    RSBLT  ip,ip,#0
    SUBS   ip,ip,#tol
    SUBGT  R6,R6,#1
    ADDGT  R1,R1,R2,LSL#2
    BGT    lp2                  ;fail; go check next vector
    SUBS   R7,R7,#1
    BGE    lp3
    SUB    R0,R3,R6             ;calculate and return I
    LDMDB  fp,{R4-R7,fp,sp,pc}  ;return
    END
;
    TTL   kolpk
pc  RN    15
lr  RN    14
ip  RN    12
R3  RN    3
R2  RN    2
R1  RN    1
R0  RN    0
    AREA |C$$Code|,CODE,READONLY
    EXPORT kolpk_; (IR,IG,IB,KOL) zeros the l.s.byte
    EXPORT kolpk1_; (IR,IG,IB,KOL) leaves the l.s.byte
;    packs colour constituents to its word
kolpk_
    MOV   ip,#0
    STR   ip,[R3]
kolpk1_
    LDR   ip,[R0]
    STRB  ip,[R3,#1]
    LDR   ip,[R1]
    STRB  ip,[R3,#2]
    LDR   ip,[R2]
    STRB  ip,[R3,#3]
    MOV   pc,lr
    END
;
    TTL   kolunp
pc  RN    15
lr  RN    14
ip  RN    12
R3  RN    3
R2  RN    2
R1  RN    1
R0  RN    0
    AREA |C$$Code|,CODE,READONLY
    EXPORT kolunp_; (KOL,IR,IG,IB)
;    unpacks colour word to its constituents
kolunp_
    LDRB  ip,[R0,#1]
    STR   ip,[R1]
    LDRB  ip,[R0,#2]
    STR   ip,[R2]
    LDRB  ip,[R0,#3]
    STR   ip,[R3]
    MOV   pc,lr
    END
;
    TTL   pspecb
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R0  RN     0
R1  RN     1
R2  RN     2
R3  RN     3
R4  RN     4
R5  RN     5
;
    AREA   |C$$code|,CODE,READONLY
    EXPORT pspecb_;(X,ALPHA,X1,M) X1(Y1)=X(Y)/(1-Z*ALPHA) / 2**M
;      This is for transforming from stored (X,Y,Z) to screen (X1,Y1)
;      ALPHA is the reciprocal of the eye distance in units of (X,Y,Z).
;      If ALPHA=0 there is no perspective and it is simple scaling,
;      otherwise ALPHA must in binary.(48-K) when Z is in binary.K
;      |Z|*ALPHA should be much less than 1.0 and ALPHA must be >=0
;      E.g. with Z in binary.28, alpha (in binary.20) must be
;      much less than 1/maximum value of |Z|, where 20 = 48 - 28
;      Choose a good value for M such the result (X1,Y1) is of
;      suitable integer size for direct plotting on the screen.
    DCB    "pspecb_",0,8,0,0,255
pspecb_
    MOV    ip,sp
    STMDB  sp!,{R0-R5,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    ip,[R3]         ;M
    LDR    lr,[R1]         ;alpha
    LDMIA  R0,{R3-R5}      ;X,Y,Z
    CMP    lr,#0           ;check for alpha=0
    MOVGT  R1,lr,LSR#16    ;m.s. ALPHA
    BICGT  lr,lr,R1,LSL#16 ;l.s. ALPHA
    MOVGT  R0,R5,ASR#16    ;m.s. Z
    BICGT  R5,R5,R0,LSL#16 ;l.s. Z
    MULGT  lr,R0,lr
    MLAGT  R5,R1,R5,lr     ;l.s. bits
    MULGT  lr,R1,R0        ;m.s. bits
    ADDGT  R5,lr,R5,ASR#16 ;ALPHA*Z
    MULGT  lr,R5,R5        ;calculate 2nd order correction
    MOVGT  lr,lr,LSR#16
    ADDGT  R5,R5,lr        ;apply 2nd order correction
    MULGT  lr,R5,lr        ;calculate 3rd & 4th order corrections
    ADDGT  R5,R5,lr,ASR#16 ;apply 3rd & 4th order corrections
    MOVGT  lr,R3,ASR#16    ;m.s. X
    MULGT  lr,R5,lr        ;X*(alpha*Z)
    ADDGT  R3,R3,lr        ;X*(1+alpha*Z)
    MOVGT  lr,R4,ASR#16    ;m.s. Y
    MULGT  lr,R5,lr        ;Y*(alpha*Z)
    ADDGT  R4,R4,lr        ;Y*(1+alpha*Z)
    MOVS   R3,R3,ASR ip    ;scale x' by 2**-M
    ADC    R3,R3,#0        ;round
    MOVS   R4,R4,ASR ip    ;scale y' by 2**-M
    ADC    R4,R4,#0        ;round
    STMIA  R2,{R3,R4}      ;store (X',Y')
    LDMDB  fp,{R4-R5,fp,sp,pc} 
    END
;
    TTL   r2bptm
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R0  RN     0
R1  RN     1
R2  RN     2
R3  RN     3
R4  RN     4
;
    AREA   |C$$code|,CODE,READONLY
    EXPORT r2bptm_;(R4,BM,M,N) convert N REAL*4 to binary.M
;                   R4 and BM may be the same array
;                   overflows are ignored and will give the wrong answer
    DCB    "r2bptm_",0,8,0,0,255
r2bptm_
    MOV    ip,sp
    STMDB  sp!,{R0-R4,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R2,[R2]         ;M (= # binary places in 32-bit word)
    LDR    R3,[R3]         ;N (assumed >0)
lp3 LDR    lr,[R0],#4      ;get real*4
    MOV    R4,lr,ASR#31    ;save sign
    MOV    lr,lr,LSL#1     ;move exponent into m.s. byte
    MOV    ip,lr,LSR#24    ;get exponent
    BIC    lr,lr,#255,8    ;clear exponent
    ORR    lr,lr,#1,8      ;restore most significant bit
    RSB    ip,ip,#127+24   ;127=bias, 24=required shift for binary.0
    SUBS   ip,ip,R2        ;subtract M to get required right shift
    RSBLT  ip,ip,#0        ;negative shift
    MOVLT  lr,lr,LSL ip    ;left shift (C not set)
    MOVEQS ip,ip,LSL#1     ;clear C (ip remains zero, Z remains set)
    MOVGTS lr,lr,LSR ip    ;right shift and set C for rounding
    ADDCS  lr,lr,#1        ;round
    CMP    R4,#0
    RSBNE  lr,lr,#0        ;set sign
    STR    lr,[R1],#4      ;store Binary.M
    SUBS   R3,R3,#1
    BGT    lp3             ;loop over the N words
    LDMDB  fp,{R4,fp,sp,pc} 
    END
;
    TTL   rotatb
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R0  RN     0
R1  RN     1
R2  RN     2
R3  RN     3
R4  RN     4
R5  RN     5
R6  RN     6
R7  RN     7
R8  RN     8
R9  RN     9
F0  FN     0
F1  FN     1
;
    AREA   |C$$code|,CODE,READONLY
    EXPORT b_trans
    EXPORT rotatb_;(X,Y,THETA,N) rotates (X,Y) by REAL*4 THETA (degrees)
;           (X,Y) in arbitrary fixed point
;           X and Y are assumed to be parts of an array of 3-vectors, e.g.
;           DIMENSION XYZ(3,M)
;           then N elements of this matrix will receive the same
;           2-dimensional rotation
;
    DCB    "rotatb_",0,8,0,0,255
rotatb_
    MOV    ip,sp
    STMDB  sp!,{R0-R9,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R3,[R3]         ;N
    SUBS   R3,R3,#1        ;N-1
    LDMLTDB fp,{R4-R9,fp,sp,pc} ;return if N.LE.0
    ADD    ip,R3,R3,LSL#1  ;3*(N-1)
;       load COS and SIN
    LDFS   F0,[R2]         ;THETA in degrees
    LDFD   F1,d2r          ;PI/180
    MUFD   F1,F0,F1        ;THETA in radians
    COSD   F0,F1           ;COS(THETA)
    BL     b_trans         ;transform to binary.30
    MOV    R4,R0,ASR#16    ;m.s. COS
    BIC    R5,R0,R4,LSL#16 ;l.s. COS
    SIND   F0,F1           ;SIN(THETA)
    BL     b_trans         ;transform to binary.30
    MOV    R6,R0,ASR#16    ;m.s. SIN
    BIC    R7,R0,R6,LSL#16 ;l.s. SIN
    LDMIA  sp,{R1-R2}      ;(X) and (Y)
;       loop over points: I=N,1,-1
lp4 LDR    R8,[R1,ip,LSL#2];get X(I)
    LDR    R9,[R2,ip,LSL#2];get Y(I)
;       split words into 16-bit parts
    MOV    R0,R8,ASR#16    ;m.s. X
    BIC    R1,R8,R0,LSL#16 ;l.s. X
    MOV    R2,R9,ASR#16    ;m.s. Y
    BIC    R3,R9,R2,LSL#16 ;l.s. Y
;       find X*COS
    MUL    lr,R1,R5        ;least sig 32 bits
    MUL    R8,R0,R5        ;mid sig(1)
    MUL    R9,R0,R4        ;most sig 32 bits
    ADDS   lr,lr,R8,LSL#16
    ADC    R9,R9,R8,ASR#16
    MUL    R8,R1,R4        ;mid sig(2)
    ADDS   lr,lr,R8,LSL#16
    ADC    R9,R9,R8,ASR#16
    MOVS   lr,lr,LSR#30    ;prepare for Binary.30
    ADC    R9,lr,R9,LSL#2  ;X*COS rounded
;       find X*SIN
    MUL    lr,R1,R7        ;least sig 32 bits
    MUL    R8,R0,R7        ;mid sig(1)
    MUL    R1,R6,R1        ;mid sig(2)
    MUL    R0,R6,R0        ;most sig 32 bits
    ADDS   lr,lr,R8,LSL#16
    ADC    R0,R0,R8,ASR#16
    ADDS   lr,lr,R1,LSL#16
    ADC    R1,R0,R1,ASR#16
    MOVS   lr,lr,LSR#30    ;prepare for Binary.30
    ADC    R1,lr,R1,LSL#2  ;X*SIN rounded
;       find Y*SIN
    MUL    lr,R3,R7        ;least sig 32 bits
    MUL    R8,R2,R7        ;mid sig(1)
    MUL    R0,R2,R6        ;most sig 32 bits
    ADDS   lr,lr,R8,LSL#16
    ADC    R0,R0,R8,ASR#16
    MUL    R8,R3,R6        ;mid sig(2)
    ADDS   lr,lr,R8,LSL#16
    ADC    R0,R0,R8,ASR#16
    MOVS   lr,lr,LSR#30    ;prepare for Binary.30
    ADC    R0,lr,R0,LSL#2  ;Y*SIN rounded
;       find Y*COS
    MUL    lr,R3,R5        ;least sig 32 bits
    MUL    R8,R2,R5        ;mid sig(1)
    MUL    R3,R4,R3        ;mid sig(2)
    MUL    R2,R4,R2        ;most sig 32 bits
    ADDS   lr,lr,R8,LSL#16
    ADC    R2,R2,R8,ASR#16
    ADDS   lr,lr,R3,LSL#16
    ADC    R3,R2,R3,ASR#16
    MOVS   lr,lr,LSR#30    ;prepare for Binary.30
    ADC    R3,lr,R3,LSL#2  ;Y*COS rounded
;       save results
    SUB    R8,R9,R0        ;X'=X*COS-Y*SIN
    ADD    R9,R3,R1        ;Y'=Y*COS+X*SIN
    LDMIA  sp,{R1-R2}      ;(X) and (Y)
    STR    R8,[R1,ip,LSL#2];store X'
    STR    R9,[R2,ip,LSL#2];store Y'
    SUBS   ip,ip,#3        ;decrement count
    BGE    lp4             ;loop over points
    LDMDB  fp,{R4-R9,fp,sp,pc} ;return
;
d2r DCFD   1.745329251994329577E-2 ; PI/180
;
b_trans;       transform F0 (modulus not greater than 1) to R0 in binary.30
    STFD   F0,[sp,#-8]!    ;store REAL*8 on stack
    LDMIA  sp!,{R0,R1}     ;get it back as two integer words
    AND    R8,R0,#2,2      ;save sign
    MOV    R0,R0,LSL#1     ;move sign out & exponent into 31-21
    MOV    R2,R0,LSR#21    ;get exponent
    MOV    R0,R0,LSL#10    ;shift out exponent
    ORR    R0,R0,#2,2      ;and restore most significant bit
    RSB    R2,R2,#1024     ;shift for binary.30
    TST    R2,#&FC0        ;check that no shift bits are lost
    MOVNE  R2,#32          ;if so, ensure that answer is zero
    ADD    R3,R2,#21       ;shift for less sig part
    MOVS   R1,R1,LSR R3    ;less sig part
    ADC    R0,R1,R0,LSR R2 ;add more sig part with rounding
    CMP    R8,#0
    RSBNE  R0,R0,#0        ;fix sign
    MOV    pc,lr
    END
;
    TTL   rotvb
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R0  RN     0
R1  RN     1
R2  RN     2
R3  RN     3
R4  RN     4
R5  RN     5
R6  RN     6
R7  RN     7
R8  RN     8
R9  RN     9
F0  FN     0
F1  FN     1
;
    AREA   |C$$code|,CODE,READONLY
    IMPORT b_trans ;  converts REAL*8 to binary.30
    EXPORT rotvb_;(XYZ,AXIS,THETA,N) rotates N vectors of XYZ
;           by REAL*4 THETA (degrees)
;           about AXIS (assumed binary.30 direction cosines)
;           XYZ in arbitrary fixed point, DIMENSION XYZ(3,N)
;
    DCB    "rotvb_",0,0,8,0,0,255
rotvb_
    MOV    ip,sp
    STMDB  sp!,{R0-R9,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R9,[R3]         ;N
    CMP    R9,#0
    LDMLEDB fp,{R4-R9,fp,sp,pc} ;return if N.LE.0
;       load COS and SIN
    LDFS   F0,[R2]         ;THETA in degrees
    LDFD   F1,d2r          ;PI/180
    MUFD   F1,F0,F1        ;THETA in radians
    COSD   F0,F1           ;COS(THETA)
    BL     b_trans         ;transform to binary.30
    MOV    R4,R0           ;COS in R4
    SIND   F0,F1           ;SIN(THETA)
    BL     b_trans         ;transform to binary.30; SIN in R0
;       create rotation matrix
    LDR    R1,[sp,#4]      ;restore (AXIS)
    MOV    R2,#2           ;outer loop (I = 2,-1,0
lr1 MOV    R3,#2           ;inner loop (J = 2,-1,0)
    RSB    R0,R0,#0        ;SIN = -SIN
lr2 LDR    R5,[R1,R2,LSL#2];AXIS(I)
    LDR    R6,[R1,R3,LSL#2];AXIS(J)
    BL     mult
    RSB    R6,R4,#&1,2     ;1-COS
    CMP    R6,#&2,2        ;check for (1-COS) = +2
    MOVEQ  R5,R5,LSL#1     ;because +2 does not exist in binary.30
    BLNE   mult            ;basic matrix element = (1-COS)*AXIS(I)*AXIS(J)
    CMP    R2,R3           ;if I=J then
    ADDEQ  R5,R5,R4        ; add COS to matrix element
    STR    R5,[sp,#-4]!    ;(store matrix element on stack)
    BEQ    RB1
    ADD    R7,R2,R3        ;else
    RSB    R7,R7,#3
    LDR    R5,[R1,R7,LSL#2]; AXIS(3-I-J)
    MOV    R6,R0           ; SIN
    BL     mult
    LDR    R6,[sp]
    ADD    R6,R6,R5
    STR    R6,[sp]         ; add SIN*AXIS(3-I-J) to matrix element
    RSB    R0,R0,#0        ; SIN = -SIN
RB1 SUBS   R3,R3,#1        ;endif
    BGE    lr2             ;loop over J
    SUBS   R2,R2,#1
    BGE    lr1             ;loop over I
    LDR    R0,[sp,#36]     ;restore (XYZ)
;       rotate points
lr3 LDR    R1,[sp,#40]     ;restore (AXIS)
    CMP    R1,R0
    ADDEQ  R0,R0,#12
    BEQ    pt1             ;skip rotating AXIS          15/10/2001
    MOV    R2,#2           ;prepare for loop I=2,0,-1
    ADD    R1,sp,#36       ;pointer to 3x3 rotation matrix
lr5 MOV    R3,#2           ;prepare for loop J=2,0,-1
    MOV    R4,#0           ;accumulator
lr6 LDR    R5,[R0,R3,LSL#2];XYZ(J)
    LDR    R6,[R1,#-4]!    ;R(I,J)
    BL     mult
    ADD    R4,R4,R5        ;sum XYZ(J)*R(I,J)
    SUBS   R3,R3,#1
    BGE    lr6
    STR    R4,[sp,#-4]!    ;store XYZ'(I)
    SUBS   R2,R2,#1
    BGE    lr5             ;loop over X,Y,Z
    LDMIA  sp!,{R5-R7}
    STMIA  R0!,{R5-R7}     ;store XYZ' back in XYZ
pt1 SUBS   R9,R9,#1
    BGT    lr3             ;loop over points
    LDMDB  fp,{R4-R9,fp,sp,pc} ;return
;
d2r DCFD   1.745329251994329577E-2 ; PI/180
;
mult;  multiply R5 by R6 with result in R5 shifted left 2 places
;        destroys R5, R6, R7, R8, ip (uses lr for return)
    MOV    R7,R5,ASR#16    ;m.s. R5
    MOV    R8,R6,ASR#16    ;m.s. R6
    BIC    R5,R5,R7,LSL#16 ;l.s. R5
    BIC    R6,R6,R8,LSL#16 ;l.s. R6
;       find product
    MUL    ip,R5,R6        ;least sig 32 bits
    MUL    R6,R7,R6        ;mid sig(1)
    MUL    R5,R8,R5        ;mid sig(2)
    MUL    R7,R8,R7        ;most sig 32 bits
    ADDS   ip,ip,R6,LSL#16
    ADC    R7,R7,R6,ASR#16
    ADDS   ip,ip,R5,LSL#16
    ADC    R7,R7,R5,ASR#16
    MOVS   ip,ip,LSR#30    ;prepare for Binary.30
    ADC    R5,ip,R7,LSL#2  ;result shifted up 2 bits (for binary.30)
    MOV    pc,lr
    END
;
    TTL   scaleb
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R0  RN     0
R1  RN     1
R2  RN     2
R3  RN     3
R4  RN     4
R5  RN     5
R6  RN     6
R7  RN     7
R8  RN     8
R9  RN     9
;
    AREA   |C$$code|,CODE,READONLY
    EXPORT scaleb_;(X,SCALE,X1,N) X1(I)=X(I)*SCALE, I=1,N
;           X and X1 are in Binary.M format (M is arbitrary)
;           SCALE in REAL*4
;           overflows are ignored!
    DCB    "scaleb_",0,8,0,0,255
scaleb_
    MOV    ip,sp
    STMDB  sp!,{R0-R9,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R5,[R1]         ;SCALE
    MOV    R6,R5,ASR#31    ;sign of SCALE
    MOV    R5,R5,LSL#1     ;take off sign
    MOV    R1,R5,LSR#24    ;exponent
    RSBS   R1,R1,#151      ;binary point position
    LDMLTDB fp,{R4-R9,fp,sp,pc} ;scale is too big!
    BIC    R5,R5,#255,8    ;take off exponent
    ORR    R5,R5,#1,8      ;restore m.s. bit
    SUBS   ip,R1,#32       ;check if binary point is off end
    MOVGT  R5,R5,LSR ip    ;then move scale down appropriately
    MOVGT  R1,#32
    RSB    ip,R1,#32       ;complementary shift
    CMP    R6,#0
    RSBNE  R5,R5,#0        ;fix sign of SCALE
    MOV    R4,R5,ASR#16    ;m.s. SCALE
    BIC    R5,R5,R4,LSL#16 ;l.s. SCALE
    LDR    R3,[R3]         ;N
;        loop over points
lp7 LDR    R7,[R0],#4      ;get X
    MOV    R6,R7,ASR#16    ;m.s. X
    BIC    R7,R7,R6,LSL#16 ;l.s. X
    MUL    lr,R5,R7        ;l.s. word
    MUL    R7,R4,R7        ;mid bits 1
    MUL    R8,R6,R5        ;mid bits 2
    MUL    R6,R4,R6        ;m.s. word
    ADDS   lr,lr,R7,LSL#16 ;add top of middle to l.s.
    ADC    R6,R6,R7,ASR#16 ;add bottom of middle to m.s.
    ADDS   lr,lr,R8,LSL#16 ;add top of middle to l.s.
    ADC    R6,R6,R8,ASR#16 ;add bottom of middle to m.s.
    MOVS   lr,lr,LSR R1    ;bottom bits
    ADC    R6,lr,R6,LSL ip ;add top bits and round
    STR    R6,[R2],#4      ;store X'
    SUBS   R3,R3,#1
    BGT    lp7             ;loop over I=1,N
    LDMDB  fp,{R4-R9,fp,sp,pc} 
    END
;
      TTL   bcross
pc    RN    15
lr    RN    14
sp    RN    13
ip    RN    12
fp    RN    11
R9    RN    9
R8    RN    8
R7    RN    7
R6    RN    6
R5    RN    5
R4    RN    4
R3    RN    3
R2    RN    2
R1    RN    1
R0    RN    0
chk   EQU   8       ;toterance on subtractions: |A-B| > (A >> chk)
      AREA |C$$Code|,CODE,READONLY
      EXPORT bcross_;(A1,B1,A2,B2,C1,C2,DZ,FAIL,ISIZE)
;          find how (x,y) line A1,B1 crosses A2,B2
;          ISIZE is the rightshift required
;          returns Cn as -1, 0, +1 if crossing is before first point,
;          between points or after second point of line n
;          returns DZ as -1, 0, +1 if crossing point on line 1 is behind,
;          same or in front of point on line 2
;          FAIL is 0 if OK, 1 if lines are parallel
      DCB "bcross_",0,8,0,0,255
bcross_
    MOV    ip,sp
    STMDB  sp!,{R0-R9,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDMIA  R1,{R4,R5,ip} ;B1
    LDMIA  R2,{R6,R7,lr} ;A2
    LDMIA  R3,{R2,R3,R8} ;B2
    LDMIA  R0,{R0,R1,R9} ;A1
;              calculate lengths
    SUB    R4,R4,R0
    SUB    R5,R5,R1      ;L1 (vector length of A1,B1)
    SUB    R2,R2,R6
    SUB    R3,R3,R7      ;L2 (vector length of A2,B2)
    SUB    R6,R6,R0
    SUB    R7,R1,R7      ;Delta (separation of A2,A1 with sign of Y inverted)
    SUB    ip,R9,ip      ;-dz1
    SUB    R8,R8,lr      ;dz2
    SUB    R9,lr,R9      ;Z2-Z1
;              renormalize
    LDR    R0,[fp,#20]
    LDR    R1,[R0]       ;get shift
    MOV    R4,R4,ASR R1
    MOV    R5,R5,ASR R1
    MOV    R2,R2,ASR R1
    MOV    R3,R3,ASR R1
    MOV    R6,R6,ASR R1
    MOV    R7,R7,ASR R1
    MUL    R0,R4,R3    ;dx1*dy2
    MUL    R1,R5,R2    ;dy1*dx2
    SUBS   R0,R0,R1    ;get denominator => R0
    BEQ    err         ;failed because lines are parallel
;             find ALPHA1
    MULS   lr,R6,R3
    MLA    R1,R7,R2,lr ;DeltaX*dy2 - DeltaY*dx2 => R1 (C1=R1/R0)
;          check that the subtraction is not too inaccurate
    RSBMI  lr,lr,#0
    MOV    lr,lr,LSR#chk
    ADDS   R3,R1,#0
    RSBLT  R3,R3,#0
    CMP    lr,R3
    BGT    err
;
    MULS   lr,R6,R5
    MLA    R2,R7,R4,lr ;DeltaX*dy1 - DeltaY*dx1 => R2 (C2=R2/R0)
;          check that the subtraction is not too inaccurate
    RSBMI  lr,lr,#0
    MOV    lr,lr,LSR#chk
    ADDS   R3,R2,#0
    RSBLT  R3,R3,#0
    CMP    lr,R3
    BGT    err
;               make a slightly smaller denominator for testing
bod EQU    9           ;sides made smaller by 2**(-9) or ~0.2%
    MOV    R5,R0,ASR#bod
    RSBLT  R5,R5,#0    ;|R0|/2**9
    CMP    R5,#&4000
    MOVLT  R5,#&4000   ;or make R0 smaller by &4000
    CMP    R0,#0
    BLT    ng1
    SUBS   R4,R0,R5
    BLT    err
    CMP    R1,R4       ;denominator is +ve
    MOVGT  R3,#+1      ;numerator > denominator
    MOVLE  R3,#0
    CMP    R1,R5
    MOVLT  R3,#-1      ;numerator <0
    B      al2
ng1 ADDS   R4,R0,R5
    BGT    err
    CMP    R1,R4
    MOVLT  R3,#+1
    MOVGE  R3,#0
    CMN    R1,R5
    MOVGT  R3,#-1      ;R3 contains C1
;             find ALPHA2
al2 CMP    R0,#0
    BLT    ng2
    CMP    R2,R4       ;denominator is +ve
    MOVGT  R4,#+1      ;numerator > denominator
    MOVLE  R4,#0
    CMP    R2,R5
    MOVLT  R4,#-1      ;numerator <0
    B      al3
ng2 CMP    R2,R4
    MOVLT  R4,#+1
    MOVGE  R4,#0
    CMN    R2,R5
    MOVGT  R4,#-1      ;R4 contains C2
al3 MOVS   R0,R0,ASR#4
    MOVPL  R5,R0
    RSBMI  R5,R0,#0
    MOVS   R1,R1,ASR#4
    ORRPL  R5,R5,R1
    RSBMI  lr,R1,#0
    ORRMI  R5,R5,lr 
    MOVS   R2,R2,ASR#4
    ORRPL  R5,R5,R2
    RSBMI  lr,R2,#0
    ORRMI  R5,R5,lr
;         find sufficient shift for R0,1,2
lp1 MOV    R5,R5,LSR#1
    MOV    R0,R0,ASR#1
    MOV    R1,R1,ASR#1
    MOV    R2,R2,ASR#1
    CMP    R5,#&4000
    BGE    lp1
;             now find the difference in Z
    MOV    R8,R8,ASR#10
    MOV    R9,R9,ASR#10
    MOV    ip,ip,ASR#10
    MOVS   R5,R8
    RSBMI  R5,R5,#0
    MOVS   lr,R9
    RSBMI  lr,lr,#0
    ORR    R5,R5,lr
    MOVS   lr,ip
    RSBMI  lr,lr,#0
    ORR    R5,R5,lr
    MOVS   R5,R5,LSR#15
lp2 MOVNE  R8,R8,ASR#1
    MOVNE  R9,R9,ASR#1
    MOVNE  ip,ip,ASR#1
    MOVS   R5,R5,LSR#1
    BNE    lp2
    MUL    R6,R0,R9
    MLAS   R5,ip,R1,R6
    RSBMI  ip,R5,#0
    MOVPL  ip,R5
    MLAS   R6,R8,R2,R5
;           check that subtraction is accurate
    MOVPL  R7,R6
    RSBMI  R7,R6,#0
    CMP    R7,ip,LSR#chk
    BLT    err
;
    EORS   R5,R6,R0
    MOVPL  R5,#-1
    MOVMI  R5,#1       ;R5 contains DZ
    CMP    R0,#0
    RSBLT  R0,R0,#0
;    CMP    R7,R0,LSL#4 ; 19/05/1999
    CMP    R7,R0,LSL#9 ; 29/05/1999
    CMPGE  R0,#&80
    MOVLT  R5,#0
    MOV    ip,#0
er1 LDMIB  fp,{R6-R9}  ;get return argument addresses
    STR    R3,[R6]
    STR    R4,[R7]
    STR    R5,[R8]
    STR    ip,[R9]
    LDMDB  fp,{R4-R9,fp,sp,pc} 
err MOV    ip,#1
    B      er1
    END
;
      TTL   bover
pc    RN    15
lr    RN    14
sp    RN    13
ip    RN    12
fp    RN    11
R9    RN    9
R8    RN    8
R7    RN    7
R6    RN    6
R5    RN    5
R4    RN    4
R3    RN    3
R2    RN    2
R1    RN    1
R0    RN    0
      AREA |C$$Code|,CODE,READONLY
      EXPORT bover_;(XYZ,XYP,N,ISZ)
;          returns .TRUE. if XYP lies over N-gon
      DCB "bover_",0,0,8,0,0,255
bover_
    MOV    ip,sp
    STMDB  sp!,{R0-R9,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDMIA  R1,{R8,R9}   ;XYP
    LDR    R4,[R3]      ;ISZ
    LDR    R3,[R2]      ;N
    MOV    lr,R3        ;count
    MOV    ip,sp        ;save stack pointer
lp1 LDR    R6,[R0],#4   ;XYZ(1,JIND(I))
    LDR    R7,[R0],#8   ;XYZ(2,JIND(I))
    SUB    R6,R6,R8
    SUB    R7,R7,R9
    MOV    R6,R6,ASR R4
    MOV    R7,R7,ASR R4
    STMFD  sp!,{R6,R7}   ;store dx,dy on stack
    SUBS   lr,lr,#1
    BGT    lp1           ;loop over points
    MOV    R0,#0         ;initialize BOVER = .FALSE.
;         loop through sides
lp2 RSB    R4,R6,#0      ;X(I-1) = - old X(I)
    MOV    R5,R7         ;Y(I-1) = old Y(I)
    LDMDB  ip!,{R6,R7}   ;X(I),Y(I)
    TEQ    R5,R7         ;compare Y values (V flag is not set)
    BGT    pt2           ;y's have same sign
    BLT    pt1           ;y's have opposite sign
;         line parallel to x-axis
    CMP   R5,#0
    BNE   pt2            ;not on the axis
    TEQ   R4,R6
    BPL   onl            ;on a line
    CMP   R6,#0
    RSBGT R0,R0,#1       ;swap BOVER if to the right
    B     pt2
pt1;      Y's with opposite sign
    SUB   R8,R5,R7       ;denominator = Y(I-1) - Y(I)
    MULS  lr,R6,R5       ;X(I)*Y(I-1)
    MLA   R5,R7,R4,lr    ;-Y(I)*X(I-1) = numerator
    RSBMI lr,lr,#0
    TEQ   R5,R8
    RSBPL R0,R0,#1       ;swap BOVER if to the right
    CMP   R5,#0
    RSBLT R5,R5,#0
    CMP   R5,lr,LSR#4    ;tolerance (5) detemined by W112
    BLE   onl
pt2 SUBS  R3,R3,#1
    BGT   lp2
    LDMDB  fp,{R4-R9,fp,sp,pc} 
onl;   on a line so return .TRUE.
    MOV   R0,#1
    LDMDB  fp,{R4-R9,fp,sp,pc} 
    END
