;                    updates
;
    TTL    KERNGT
;  ***   you must update 'fmt' (below) with every change  ****
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R2  RN     2
R1  RN     1
R0  RN     0
;
    AREA   |C$$code|,CODE,READONLY
    EXPORT kerngt_;(LUN) print library version number
    IMPORT io_start_we
    IMPORT io_end
    DCB    "kerngt_",0,8,0,0,255
kerngt_
    MOV    ip,sp
    STMDB  sp!,{R0,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R0,[R0]    ;LUN
    CMP    R0,#0
    MOVLE  R0,#6      ;set to 6 if zero
    ADR    R1,fmt     ;format
    BL     io_start_we
    BL     io_end
    LDMDB  fp,{fp,sp,pc}  ;return
fmt DCB    "(' KERNGT. KERNLIB from: KERNARC 1.02 990823 1100')",0
    END
;
    TTL    ABEND
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R1  RN     1
R0  RN     0
;
    AREA   |C$$code|,CODE,READONLY
    EXPORT abend_;for abnormal end
    IMPORT traceq_;(LUN,N) print traceback of depth N
    IMPORT io_start_we
    IMPORT io_end
    IMPORT fortran_exit
    DCB    "abend_",0,0,8,0,0,255
abend_
    MOV    ip,sp
    STMDB  sp!,{fp,ip,lr,pc}
    SUB    fp,ip,#4
    MOV    R0,#6        ;stream #
    ADR    R1,fmt
    BL     io_start_we  ;Print 'Abnormal end'
    BL     io_end
    ADR    R0,traceargs
    ADD    R1,R0,#4
    BL     traceq_      ;make traceback
    MOV    R0,#1
    B      fortran_exit ;kill
fmt DCB    "(/' Abnormal end'/)",0
traceargs
    DCD    0,100
    END
;
    TTL    ALGAMA
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
F0  FN     0
F1  FN     1
F2  FN     2
F3  FN     3
R0  RN     0
R1  RN     1
R2  RN     2
    AREA   |C$$code|,CODE,READONLY
    EXPORT algama_ ;(X) => ALOG(Gamma function)
    EXPORT dlgama_ ;(X) => DLOG(Gamma function)
    EXPORT alogam_ ;(X) => ALOG(Gamma function)
    EXPORT dlogam_ ;(X) => DLOG(Gamma function)
;
    DCB    "algama_",0,8,0,0,255
algama_
alogam_
    MOV    ip,sp
    STMDB  sp!,{R0,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDFS   F0,[R0]        ;X
    B      gm1
;
    DCB    "dlgama_",0,8,0,0,255
dlgama_
dlogam_
    MOV    ip,sp
    STMDB  sp!,{R0,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDFD   F0,[R0]        ;X
gm1 CMFE   F0,#0
    MVFLED F0,#0
    LDMLEDB fp,{fp,sp,pc} ;fail if X <= 0
    CMFE   F0,#1
    CMFNE  F0,#2
    MVFEQD F0,#0
    LDMEQDB fp,{fp,sp,pc} ;return 0 if X=1 or 2
    ADR    R1,wp1
    ADR    R2,wq1
    CMFE   F0,#0.5
    BGT    LM1
;       0 < X <= 0.5
    ADFE   F0,F0,#1     ;Y=X+1
    BL     sums
    SUFD   F2,F0,#1     ;restore X
    LGND   F3,F2
    MUFD   F0,F2,F1
    SUFD   F0,F0,F3     ;result= X*AP/AQ-LOG(X)
    LDMDB  fp,{fp,sp,pc} 
LM1 LDFS   F1,=1.5
    CMFE   F0,F1
    BGT    LM2
;      0.5 < X <= 1.5
    BL     sums
    SUFD   F0,F0,#1
    MUFD   F0,F0,F1     ;result=(X-1)*AP/AQ
    LDMDB  fp,{fp,sp,pc} 
LM2 CMFE   F0,#4
    BGT    LM3
;      1.5 < X <= 4
    ADR    R1,wp2
    ADR    R2,wq2
    BL     sums
    SUFD   F0,F0,#2
    MUFD   F0,F0,F1     ;result=(X-2)*AP/AQ
    LDMDB   fp,{fp,sp,pc} 
LM3 LDFS   F1,=12.0
    CMFE   F0,F1
    BGT    LM4
;      4 < X <= 12
    ADR    R1,wp3
    ADR    R2,wq3
    BL     sums
    MVFD   F0,F1        ;result=AP/AQ
    LDMDB  fp,{fp,sp,pc} 
;      X > 12
LM4 MUFD   F1,F0,F0
    RDFD   F1,F1,#1     ;Y=1/X**2
    LDFD   F2,cc1+16
    MUFD   F3,F2,F1     ;Y*C(3)
    LDFD   F2,cc1+8
    ADFD   F2,F3,F2     ;C(2)+Y*C(3)
    MUFD   F3,F2,F1     ;Y*(C(2)+Y*C(3))
    LDFD   F2,cc1
    ADFD   F2,F3,F2     ;C(1)+Y*(C(2)+Y*C(3))
    LDFD   F3,cc1+32
    ADFD   F3,F3,F1     ;C(5)+Y
    MUFD   F3,F3,F0     ;(C(5)+Y)*X
    DVFD   F2,F2,F3     ;(C(1)+Y*(C(2)+Y*C(3)))/((C(5)+Y)*X)
    LDFD   F3,cc1+24
    ADFD   F2,F2,F3     ;C(4)+(C(1)+Y*(C(2)+Y*C(3)))/((C(5)+Y)*X)
    SUFD   F2,F2,F0     ;-X+C(4)+(C(1)+Y*(C(2)+Y*C(3)))/((C(5)+Y)*X)
    SUFD   F1,F0,#0.5   ;X-0.5
    LGND   F3,F0        ;LOGe(X)
    MUFD   F0,F1,F3     ;(X-0.5)*LOGe(X)
    ADFD   F0,F0,F2
    LDMDB  fp,{fp,sp,pc} 
;
sums;    make partial sums
    LDFD   F2,[R1],#8   ;AP
    MVFD   F3,#1        ;AQ
    MOV    ip,#6        ;always 6 terms
lps LDFD   F1,[R1],#8   ;P(I)
    MUFD   F2,F2,F0
    ADFD   F2,F2,F1     ;AP=P(I)+AP*X
    LDFD   F1,[R2],#8
    MUFD   F3,F3,F0
    ADFD   F3,F3,F1     ;AQ=Q(I)+AQ*X
    SUBS   ip,ip,#1
    BGT    lps
    DVFD   F1,F2,F3     ;result is AP/AQ
    MOV    pc,lr
;
wp1 DCFD  +3.842873656745991E+0
    DCFD  +5.270689375300983E+1
    DCFD  +5.558404572351531E+1
    DCFD  -2.151351357372570E+2
    DCFD  -2.458726172229242E+2
    DCFD  -5.750089360304123E+1
    DCFD  -2.335909894951284E+0
wq1; DCFD  +1.0
    DCFD  +3.373304790707074E+1
    DCFD  +1.938778403437713E+2
    DCFD  +3.088295497342428E+2
    DCFD  +1.500683906489095E+2
    DCFD  +2.010685134433395E+1
    DCFD  +4.571742028250299E-1
wp2 DCFD  +4.8740201396838636E+0
    DCFD  +2.4884525168574076E+2
    DCFD  +2.1797366058895915E+3
    DCFD  +3.7975124011525118E+3
    DCFD  -1.9778070769841646E+3
    DCFD  -3.6929834005591282E+3
    DCFD  -5.6017773537803877E+2
wq2; DCFD  +1.0
    DCFD  +9.5099917418208938E+1
    DCFD  +1.5612045277928635E+3
    DCFD  +7.2340087928948071E+3
    DCFD  +1.0459576594058959E+4
    DCFD  +4.1699415153200231E+3
    DCFD  +2.7678583623804101E+2
wp3 DCFD  -6.880624009459425E+3
    DCFD  -4.306996981957098E+5
    DCFD  -4.750459465343956E+6
    DCFD  -2.942344593032234E+6
    DCFD  +3.632180493154257E+7
    DCFD  -3.356778281454576E+6
    DCFD  -2.480436948828593E+7
wq3; DCFD  +1.0
    DCFD  -1.421682983965146E+3
    DCFD  -1.555289028085353E+5
    DCFD  -3.415251710801107E+6
    DCFD  -2.096962325580444E+7
    DCFD  -3.454417509334395E+7
    DCFD  -9.160558286371317E+6
cc1 DCFD  +1.1224921356561E-1
    DCFD  +7.9591692961204E-2
    DCFD  -1.7087794611020E-3
    DCFD  +9.1893853320467E-1
    DCFD  +1.3469905627879E+0
    END
;
    TTL    AMAXMU
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R4  RN     4
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
F0  FN     0
;
    AREA   |C$$code|,CODE,READONLY
    EXPORT amaxmu_;(A,IDO,IW,NA) find |max| of scattered vector
    DCB    "amaxmu_",0,8,0,0,255
amaxmu_
    MOV    ip,sp
    STMDB  sp!,{R0-R4,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R1,[R1]    ;IDO
    LDR    R2,[R2]    ;IW
    LDR    R3,[R3]    ;NA
    MOV    R4,#0      ;initialise maximum
    SUB    R3,R3,R2   ;#words to skip
wl1 MOV    ip,R2      ;# words to check
wl2 LDR    lr,[R0],#4
    BIC    lr,lr,#2,2 ;take absolute value
    CMP    lr,R4
    MOVGT  R4,lr
    SUBS   ip,ip,#1
    BGT    wl2
    ADD    R0,R0,R3,LSL#2
    SUBS   R1,R1,#1
    BGT    wl1
    STR    R4,[sp,#-4]!
    LDFS   F0,[sp],#4
    LDMDB  fp,{R4,fp,sp,pc}  ;return
    END
;
    TTL   ATG
pc  RN    15
lr  RN    14
R0  RN    0
R1  RN    1
F0  FN    0
F1  FN    1
    AREA   |C$$code|,CODE,READONLY
    EXPORT atg_;(Y,X) PROXIM(ATAN2(Y,X),PI)
atg_
    LDFS   F0,[R0]       ;X
    LDFS   F1,[R1]       ;Y
    CMFE   F0,#0         ;test sign of Y
    POLS   F0,F1,F0      ;ATAN2(Y,X)
    LDFLTS F1,=6.2831853 ;ADD 2*PI if negative
    ADFLTS F0,F0,F1
    MOV    pc,lr
    END
;
    TTL    BESI0
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
F1  FN    1
F2  FN    2
F3  FN    3
F4  FN    4
F5  FN    5
F6  FN    6
F7  FN    7
    AREA   |C$$code|,CODE,READONLY
    EXPORT besi0_;(X) modified Bessel Function I0(X)
    EXPORT besi1_;(X) modified Bessel Function I1(X)
    EXPORT dbesi0_;(X) REAL*8 modified Bessel Function I0(X)
    EXPORT dbesi1_;(X) REAL*8 modified Bessel Function I1(X)
    EXPORT ebesi0_;(X) EXP(-|X|) * BESI0(X)
    EXPORT ebesi1_;(X) EXP(-|X|) * BESI1(X)
    EXPORT debsi0_;(X) DEXP(-|X|) * DBESI0(X)
    EXPORT debsi1_;(X) DEXP(-|X|) * DBESI1(X)
;
    DCB    "besi0_",0,0,8,0,0,255
besi0_
    MOV    ip,sp
    STMDB  sp!,{R0,R4-R7,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDFS   F0,[R0]       ;X
    B      si1
;
    DCB    "dbesi0_",0,8,0,0,255
dbesi0_
    MOV    ip,sp
    STMDB  sp!,{R0,R4-R7,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDFD   F0,[R0]
si1 MOV    ip,#0         ;BES type
    MOV    R1,#0         ;besi0
    B      stari
;
    DCB    "besi1_",0,0,8,0,0,255
besi1_
    MOV    ip,sp
    STMDB  sp!,{R0,R4-R7,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDFS   F0,[R0]       ;X
    B      si2
;
    DCB    "dbesi1_",0,8,0,0,255
dbesi1_
    MOV    ip,sp
    STMDB  sp!,{R0,R4-R7,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDFD   F0,[R0]       ;X
si2 MOV    ip,#0         ;BES type
    MOV    R1,#1         ;besi1
    B      stari
;
    DCB    "ebesi0_",0,8,0,0,255
ebesi0_
    MOV    ip,sp
    STMDB  sp!,{R0,R4-R7,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDFS   F0,[R0]       ;X
    B      si3
;
    DCB    "debsi0_",0,8,0,0,255
debsi0_
    MOV    ip,sp
    STMDB  sp!,{R0,R4-R7,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDFD   F0,[R0]       ;X
si3 MOV    R1,#0         ;besi0
    B      stari
;
    DCB    "ebesi1_",0,8,0,0,255
ebesi1_
    MOV    ip,sp
    STMDB  sp!,{R0,R4-R7,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDFS   F0,[R0]       ;X
    B      si4
;
ci0;(0:24)
    DCFD +1.008279205458740032
    DCFD +0.008445122624920943
    DCFD +0.000172700630777567
    DCFD +0.000007247591099959
    DCFD +0.000000513587726878
    DCFD +0.000000056816965808
    DCFD +0.000000008513091223
    DCFD +0.000000001238425364
    DCFD +0.000000000029801672
    DCFD -0.000000000078956698
    DCFD -0.000000000033127128
    DCFD -0.000000000004497339
    DCFD +0.000000000001799790
    DCFD +0.000000000000965748
    DCFD +0.000000000000038604
    DCFD -0.000000000000104039
    DCFD -0.000000000000023950
    DCFD +0.000000000000009554
    DCFD +0.000000000000004443
    DCFD -0.000000000000000859
    DCFD -0.000000000000000709
    DCFD +0.000000000000000087
    DCFD +0.000000000000000112
    DCFD -0.000000000000000012
    DCFD -0.000000000000000018
ci1;(0:24)
    DCFD +0.975800602326285926
    DCFD -0.024467442963276385
    DCFD -0.000277205360763829
    DCFD -0.000009732146728020
    DCFD -0.000000629724238640
    DCFD -0.000000065961142154
    DCFD -0.000000009613872919
    DCFD -0.000000001401140901
    DCFD -0.000000000047563167
    DCFD +0.000000000081530681
    DCFD +0.000000000035408148
    DCFD +0.000000000005102564
    DCFD -0.000000000001804409
    DCFD -0.000000000001023594
    DCFD -0.000000000000052678
    DCFD +0.000000000000107094
    DCFD +0.000000000000026120
    DCFD -0.000000000000009561
    DCFD -0.000000000000004713
    DCFD +0.000000000000000829
    DCFD +0.000000000000000743
    DCFD -0.000000000000000080
    DCFD -0.000000000000000117
    DCFD +0.000000000000000011
    DCFD +0.000000000000000019
;
    DCB    "debsi1_",0,8,0,0,255
debsi1_
    MOV    ip,sp
    STMDB  sp!,{R0,R4-R7,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDFD   F0,[R0]       ;X
si4 MOV    R1,#1         ;besi1
stari;
    STFE   F4,[sp,#-12]! ;save floating registers
    STFE   F5,[sp,#-12]!
    STFE   F6,[sp,#-12]!
    STFE   F7,[sp,#-12]!
    ABSD   F2,F0         ;V=|X|
    LDFS   F1,C8
    CMF    F2,F1
    BLT    loi           ;small X
    MOV    R2,#24        ;24 terms in sum
    CMP    R1,#0
    ADREQ  R3,ci0+24*8
    ADRNE  R3,ci1+24*8
    BL     sums          ;do Chebyshev sum
    LDFD   F1,rpi2       ;1/2pi
    DVFD   F3,F1,F2
    SQTD   F1,F3
    CMP    R1,#0
    CMFNE  F0,#0
    MUFD   F0,F1,F4
    MNFLTD F0,F0
    CMP    ip,#0
    EXPEQD F2,F2
    MUFEQD F0,F0,F2
;
ret LDFE   F7,[sp],#12
    LDFE   F6,[sp],#12
    LDFE   F5,[sp],#12
    LDFE   F4,[sp],#12
    LDMDB  fp,{R4-R7,fp,sp,pc} ;return
;
C8   DCFS  8.0
rpi2 DCFD  0.159154943091895335 ;1/2pi
;
loi;   BESIx with arg <8
    STFD   F0,[sp,#-8]!  ;save X   [sp+56]
    MUFD   F1,F2,#0.5
    MUFD   F7,F1,F1      ;Y=(V/2)**2
    FLTD   F6,R1         ;nu
    MVFD   F0,#1         ;A0=1
    STFD   F0,[sp,#-8]!  ;save A0  [sp+48]
    ADFD   F1,F6,#3      ;XL+1 ; XL=NU+2
    ADFD   F2,F6,#1      ;XL-1
    MUFD   F3,F1,F2      ;(XL+1)*(XL-1)
    DVFD   F4,F7,F3
    ADFD   F5,F4,F4
    ADFD   F0,F5,#1      ;A1=1+2Y/((XL+1)*(XL-1))
    STFD   F0,[sp,#-8]!  ;save A1  [sp+40]
    ADFD   F4,F6,#4      ;XL+2
    ADFD   F5,F6,#2      ;XL
    ADFD   F3,F6,#5      ;XL+3 (=W1)
    MUFD   F5,F5,F4      ;XL*(XL+2)
    MUFD   F0,F3,F2      ;(XL+3)*(XL-1)
    DVFD   F5,F7,F5      ;Y/(XL*(XL+2))
    MUFD   F5,F5,#3      ;3*Y/(XL*(XL+2))
    ADFD   F5,F5,#4      ;4+3*Y/(XL*(XL+2))
    DVFD   F5,F5,F0      ;(4+3*Y/(XL*(XL+2)))/((XL+3)*(XL-1))
    MUFD   F0,F5,F7
    ADFD   F0,F0,#1      ;A2=1+Y*(4+3*Y/(XL*(XL+2)))/((XL+3)*(XL-1)
    STFD   F0,[sp,#-8]!  ;save A2  [sp+32]
    MVFD   F0,#1
    STFD   F0,[sp,#-8]!  ;save B0  [sp+24]
    DVFD   F5,F7,F1      ;Y/(XL+1)
    RSFD   F0,F5,#1      ;B1=1-Y/(XL+1)
    STFD   F0,[sp,#-8]!  ;save B1  [sp+16]
    ADFD   F5,F4,F4      ;2*(XL+2)
    DVFD   F0,F7,F5      ;Y/(2*(XL+2))
    RSFD   F5,F0,#1      ;1-Y/(2*(XL+2))
    DVFD   F0,F5,F3      ;(1-Y/(2*(XL+2)))/(XL+3)
    MUFD   F5,F0,F7      ;Y*(1-Y/(2*(XL+2)))/(XL+3)
    RSFD   F0,F5,#1      ;B2=1-Y*(1-Y/(2*(XL+2)))/(XL+3)
    STFD   F0,[sp,#-8]!  ;save B2  [sp+8]
    MVFD   F0,#0         ;C
    STFD   F0,[sp,#-8]!  ;save C   [sp]
    MVFD   F5,#2         ;FN(=N)
l1i;       iterative loop: F3=W1, F5=FN, F6=NU, F7=Y
    ADFD   F5,F5,#1      ;N=N+1
    ADFD   F3,F5,F5
    ADFD   F3,F3,F6
    ADFD   F3,F3,#1      ;W1=2*N+1+NU
    SUFD   F4,F3,#3      ;W4
    MUFD   F2,F5,F4      ;U1=FN*W4
    SUFD   F0,F3,#2      ;W3
    SUFD   F1,F5,#1
    ADFD   F4,F1,F6      ;V3
    MUFD   F0,F0,F2      ;(U1*W3)
    MUFD   F1,F4,F7      ;Y*V3
    DVFD   F1,F1,F0      ;U2=Y*V3/(U1*W3)
    MUFD   F2,F2,F3      ;U1*W1
    SUFD   F0,F5,#1
    SUFD   F0,F0,F6      ;V1
    MUFD   F0,F0,F7
    DVFD   F0,F0,F2      ;Y*V1/(U1*W1)
    ADFD   F2,F0,#1      ;f1=1+Y*V1/(U1*W1)
;         now we also have U2 in F1, V3 in F4 and f1 in F2
    SUFD   F0,F3,#1      ;W2
    MUFD   F4,F4,F0
    SUFD   F0,F3,#4      ;W5
    MUFD   F4,F4,F0      ;(V3*W2*W5)
    ADFD   F0,F6,F6
    ADFD   F0,F0,F5      ;V2
    DVFD   F4,F0,F4      ;V2/(V3*W2*W5)
    MUFD   F0,F4,F7      ;Y*V2/(V3*W2*W5)
    ADFD   F4,F0,#1      ;1+Y*V2/(V3*W2*W5)
    MUFD   F4,F4,F1      ;f2=(1+Y*V2/(V3*W2*W5))*U2
;         now we also have U2 in F1, f1 in F2 and f2 in F4
    SUFD   F0,F3,#3      ;W4
    DVFD   F1,F1,F0      ;U2/(W4)
    SUFD   F0,F3,#4      ;W5
    MUFD   F0,F0,F0
    DVFD   F1,F1,F0      ;U2/(W4*W5*W5)
    SUFD   F0,F3,#5      ;W6
    DVFD   F1,F1,F0      ;U2/(W4*W5*W5*W6)
    MUFD   F1,F1,F7
    MUFD   F1,F1,F7      ;-f3=Y*Y*U2/(W4*W5*W5*W6)
;         now we also have -f3 in F1, f1 in F2 and f2 in F4
;         but we can now use F3 and F0
;         A0 in sp+48, A1 in sp+40, A2 in sp+32
    LDFD   F3,[sp,#48]   ;A0
    MUFD   F0,F3,F1      ;-f3*A0
    LDFD   F3,[sp,#40]   ;A1
    MUFD   F3,F3,F4
    SUFD   F0,F3,F0      ;f2*A1+f3*A0
    LDFD   F3,[sp,#32]   ;A2
    MUFD   F3,F3,F2
    ADFD   F3,F3,F0      ;A=f1*A2+f2*A1+f3*A0
;         B0 in sp+24, B1 in sp+16, B2 in sp+8
    LDFD   F0,[sp,#24]   ;B0
    MUFD   F1,F1,F0      ;-f3*B0
    LDFD   F0,[sp,#16]   ;B1
    MUFD   F4,F4,F0
    SUFD   F4,F4,F1      ;f2*B1+f3*B0
    LDFD   F0,[sp,#8]    ;B2
    MUFD   F2,F2,F0
    ADFD   F2,F2,F4      ;B=f1*B2+f2*B1+f3*B0
    DVFD   F0,F3,F2      ;C=A/B
    LDFD   F1,[sp]       ;C0
    STFD   F0,[sp]       ;store new C0=C
    SUFD   F1,F1,F0
    ABSD   F4,F0         ;|C|
    LDFD   F0,eps
    ABSD   F1,F1         ;|C-C0|
    MUFD   F4,F4,F0      ;eps*|C|
    CMF    F4,F1
    LDFLES F1,C29
    CMFLE  F5,F1
    ADDLE  R2,sp,#8      ;address of B2
    LDMLEIA R2,{R4-R7}   ;B2,B1 in [R4,R5], [R6,R7]
    STFLED F2,[R2],#8    ;B2'=B
    STMLEIA R2!,{R4-R7}  ;B1'=B2, B0'=B1
    LDMLEIA R2,{R4-R7}   ;A2,A1 in [R4,R5], [R6,R7]
    STFLED F3,[R2],#8    ;A2'=A
    STMLEIA R2,{R4-R7}   ;A1'=A2, A0'=A1
    BLE    l1i           ;loop until converged
    LDFD   F0,[sp],#56   ;restore answer
    LDFD   F1,[sp],#8    ;restore X
    CMP    R1,#1         ;is NU=1?
    MUFEQD F2,F1,#0.5
    MUFEQD F0,F0,F2      ;then multiply by X/2
    CMP    ip,#0         ;check for ebes type, then
    ABSNED F1,F1         ;restore V
    EXPNED F1,F1
    DVFNED F0,F0,F1      ;multiply answer by EXP(-V)
    B      ret
;
C29 DCFS   29.0
;
    EXPORT besk0_;(X) modified Bessel Function K0(X)
    EXPORT besk1_;(X) modified Bessel Function K1(X)
    EXPORT dbesk0_;(X) REAL*8 modified Bessel Function K0(X)
    EXPORT dbesk1_;(X) REAL*8 modified Bessel Function K1(X)
    EXPORT ebesk0_;(X) EXP(|X|) * BESK0(X)
    EXPORT ebesk1_;(X) EXP(|X|) * BESK1(X)
    EXPORT debsk0_;(X) DEXP(|X|) * DBESK0(X)
    EXPORT debsk1_;(X) DEXP(|X|) * DBESK1(X)
;
    DCB    "besk0_",0,0,8,0,0,255
besk0_
    MOV    ip,sp
    STMDB  sp!,{R0,R4-R7,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDFS   F0,[R0]       ;X
    B      sk1
;
    DCB    "dbesk0_",0,8,0,0,255
dbesk0_
    MOV    ip,sp
    STMDB  sp!,{R0,R4-R7,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDFD   F0,[R0]
sk1 MOV    ip,#0         ;BES type
    MOV    R1,#0         ;besk0
    B      stark
;
    DCB    "besk1_",0,0,8,0,0,255
besk1_
    MOV    ip,sp
    STMDB  sp!,{R0,R4-R7,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDFS   F0,[R0]       ;X
    B      sk2
;
    DCB    "dbesk1_",0,8,0,0,255
dbesk1_
    MOV    ip,sp
    STMDB  sp!,{R0,R4-R7,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDFD   F0,[R0]       ;X
sk2 MOV    ip,#0         ;BES type
    MOV    R1,#1         ;besk1
    B      stark
;
    DCB    "ebesk0_",0,8,0,0,255
ebesk0_
    MOV    ip,sp
    STMDB  sp!,{R0,R4-R7,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDFS   F0,[R0]       ;X
    B      sk3
;
    DCB    "debsk0_",0,8,0,0,255
debsk0_
    MOV    ip,sp
    STMDB  sp!,{R0,R4-R7,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDFD   F0,[R0]       ;X
sk3 MOV    R1,#0         ;besk0
    B      stark
;
    DCB    "ebesk1_",0,8,0,0,255
ebesk1_
    MOV    ip,sp
    STMDB  sp!,{R0,R4-R7,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDFS   F0,[R0]       ;X
    B      sk4
;
ck0;(0:16)
    DCFD +0.988408174230825800
    DCFD -0.011310504646928281
    DCFD +0.000269532612762724
    DCFD -0.000011106685196665
    DCFD +0.000000632575108500
    DCFD -0.000000045047337641
    DCFD +0.000000003792996456
    DCFD -0.000000000364547179
    DCFD +0.000000000039043756
    DCFD -0.000000000004579936
    DCFD +0.000000000000580811
    DCFD -0.000000000000078832
    DCFD +0.000000000000011360
    DCFD -0.000000000000001727
    DCFD +0.000000000000000275
    DCFD -0.000000000000000046
    DCFD +0.000000000000000008
ck1;(0:16)
    DCFD +1.035950858772358331
    DCFD +0.035465291243331114
    DCFD -0.000468475028166889
    DCFD +0.000016185063810053
    DCFD -0.000000845172048124
    DCFD +0.000000057132218103
    DCFD -0.000000004645554607
    DCFD +0.000000000435417339
    DCFD -0.000000000045757297
    DCFD +0.000000000005288133
    DCFD -0.000000000000662613
    DCFD +0.000000000000089048
    DCFD -0.000000000000012726
    DCFD +0.000000000000001921
    DCFD -0.000000000000000305
    DCFD +0.000000000000000050
    DCFD -0.000000000000000009
;
eps DCFD  1.0E-15
;
    DCB    "debsk1_",0,8,0,0,255
debsk1_
    MOV    ip,sp
    STMDB  sp!,{R0,R4-R7,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDFD   F0,[R0]       ;X
sk4 MOV    R1,#1         ;besk1
stark;
    CMF    F0,#0
    MVFLED F0,#0
    LDMLEDB fp,{R4-R7,fp,sp,pc} ;return with 0 if X<=0
    STFE   F4,[sp,#-12]! ;save floating registers
    STFE   F5,[sp,#-12]!
    STFE   F6,[sp,#-12]!
    STFE   F7,[sp,#-12]!
    MVFD   F1,#5
    CMF    F0,F1
    BLE    lok           ;X<=5
    MOV    R2,#16        ;#terms in sum
    CMP    R1,#0
    ADREQ  R3,ck0+16*8   ;[CK(16,0)]
    ADRNE  R3,ck1+16*8   ;[CK(16,1)]
    MVFD   F2,F0
    BL     sums
    CMP    ip,#0
    EXPEQD F1,F0         ;EXP(X)
    LDFD   F2,pih
    DVFD   F2,F2,F0
    SQTD   F2,F2         ;SQRT(pi/2X)
    MUFD   F0,F2,F4      ;result=SQRT(pi/2X)*(B0-H*B2)
    DVFEQD F0,F0,F1      ;divide by EXP(X) if BES not EBES
    B      ret
;
pih DCFD  1.570796326794896619 ;pi/2
wce DCFD -0.577215664901532861 ;-d(GAMMA(X))/dX at X=1
;
lok;     iterate to find answers for X<=5
    CMF    F0,#1
    BGE    mdk           ;middling values 1<=X<=5
    MUFD   F4,F0,#0.5    ;B=X/2
    MUFD   F1,F4,F4      ;D=B**2
    STFD   F1,[sp,#-8]!  ;save D
    STFD   F0,[sp,#-8]!  ;save X
    LGND   F2,F4
    LDFD   F3,wce
;         initialise variables
    SUFD   F0,F3,F2      ;BK=-(LOG(B)+CE)
    MVFD   F6,#0.5       ;BK1=0.5
    MVFD   F5,#0.5       ;P=0.5
    MVFD   F4,#0.5       ;Q=0.5
    MVFD   F3,#1         ;C=1
    MVFD   F2,F0         ;F=BK
    MOV    R2,#1         ;N=1
;         loop
lk1 FLTD   F7,R2         ;FN
    RDFD   F1,F7,#1      ;RFN
    MUFD   F5,F5,F1      ;P=P/N
    MUFD   F4,F4,F1      ;Q=Q/N
    ADFD   F2,F2,F5
    ADFD   F2,F2,F4
    MUFD   F2,F2,F1      ;F=(F+P+Q)/N
    MUFD   F3,F3,F1      ;C/N
    LDFD   F1,[sp,#8]    ;D
    MUFD   F3,F3,F1      ;C=C*D/N
    MUFD   F1,F2,F7      ;N*F
    SUFD   F7,F5,F1      ;P-N*F
    MUFD   F1,F7,F3      ;G=C*(P-N*F)
    MUFD   F7,F3,F2      ;H=C*F
    ADFD   F6,F6,F1      ;BK1=BK1+G
    ADFD   F0,F0,F7      ;BK=BK+H
    ADD    R2,R2,#1      ;increment N
    CMP    R2,#16
    ABSLTD F1,F1         ;|G|
    MUFLTD F7,F6,F7      ;BK1*H
    MUFLTD F1,F1,F0      ;BK*|G|
    ADFLTD F7,F7,F1      ;BK1*H+BK*|G|
    LDFLTD F1,eps
    MUFLTD F1,F1,F6
    MUFLTD F1,F1,F0      ;eps*BK*BK1
    CMFLT  F1,F7
    BLT    lk1           ;loop if N<16 and eps*BK*BK1 < BK1*H+BK*|G|
    LDFD   F1,[sp],#16   ;restore X
    CMP    R1,#1         ;is nu 1?
    ADFEQD F0,F6,F6
    DVFEQD F0,F0,F1      ;then answer is 2*BK1/X
    CMP    ip,#0         ;is it ebes type?
    EXPNED F1,F1
    MUFNED F0,F0,F1      ;then multiply by EXP(X)
    B      ret
C16 DCFS   16.0
C23 DCFS   23.0
C62 DCFS   62.0
C129 DCFS  129.0
mdk;      solution for 1<=X<=5
    STFD   F0,[sp,#-8]!  ;save X in [sp+56]
    CMP    R1,#0
    MVFEQD F7,#0
    MVFNED F7,#4         ;XN=4*NU
    MVFD   F6,#5
    ADFEQD F6,F6,#4      ;A=9-XN
    LDFS   F5,C16
    MUFD   F4,F5,#3      ;48.0
    MUFD   F3,F4,F5      ;768.0
    ADFD   F5,F5,F6      ;B=25-XN
    MUFD   F3,F3,F0      ;768*X
    MUFD   F4,F4,F0      ;C0=48*X
    MUFD   F3,F3,F0      ;C=768*X**2
    MVFD   F1,#1         ;A0=1
    STFD   F1,[sp,#-8]!  ;save in [sp+48]
    ADFD   F2,F7,#5
    ADFD   F2,F2,#2      ;XN+7
    LDFS   F1,C16
    MUFD   F1,F1,F0      ;16*X
    ADFD   F2,F2,F1
    DVFD   F1,F2,F6      ;A1=(16*X+XN+7)/A
    STFD   F1,[sp,#-8]!  ;save in [sp+40]
    LDFS   F2,C62
    LDFS   F1,C23
    ADFD   F2,F2,F7      ;XN+62
    ADFD   F1,F1,F7      ;XN+23
    MUFD   F2,F2,F7      ;XN*(XN+62)
    MUFD   F1,F1,F4      ;C0*(XN+23)
    ADFD   F2,F2,F3      ;C+XN*(XN+62)
    ADFD   F1,F1,F2      ;C+XN*(XN+62)+C0*(XN+23)
    LDFS   F2,C129
    ADFD   F1,F1,F2      ;C+XN*(XN+62)+C0*(XN+23)+129
    MUFD   F2,F5,F6      ;A*B
    DVFD   F1,F1,F2      ;A2=(C+XN*(XN+62)+C0*(XN+23)+129)/(A*B)
    STFD   F1,[sp,#-8]!  ;save in [sp+32]
    MVFD   F1,#1         ;B0=1
    STFD   F1,[sp,#-8]!  ;save in [sp+24]
    LDFS   F1,C16
    DVFD   F0,F0,F6      ;X/A
    MUFD   F0,F0,F1
    ADFD   F1,F0,#1      ;B1=16*X/A + 1
    STFD   F1,[sp,#-8]!  ;save in [sp+16]
    MUFD   F0,F4,F5      ;C0*B
    ADFD   F0,F0,F3      ;(C+C0*B)
    DVFD   F3,F0,F2      ;(C+C0*B)/(A*B)
    ADFD   F1,F3,#1      ;B2=(C+C0*B)/(A*B)+1
    STFD   F1,[sp,#-8]!  ;save in [sp+8]
    MVFD   F3,#0         ;initialise C0
    STFD   F3,[sp,#-8]!  ;save in [sp]
    MOV    R3,#3         ;initialise N
lk2;      loop over N=3,30   (XN in F7)
    FLTD   F6,R3         ;FN=N
    ADFD   F2,F6,F6      ;FN2=2*FN
    SUFD   F1,F2,#1      ;FN1=FN2-1
    SUFD   F0,F2,#3
    DVFD   F3,F1,F0      ;FN3=FN1/(FN2-3)
    MUFD   F0,F2,F2
    MUFD   F0,F0,#3      ;12*FN**2
    SUFD   F4,F0,#1
    ADFD   F4,F4,F7      ;FN4=12*FN**2-(1-XN)
    LDFS   F0,C16
    LDFD   F5,[sp,#56]   ;X
    MUFD   F1,F0,F1      ;16*FN1
    MUFD   F5,F5,F1      ;FN5=16*FN1*X
    ADFD   F6,F2,F2      ;4*FN
    MUFD   F0,F6,#5      ;20*FN
    SUFD   F1,F4,F0      ;FN4-20*FN
    MUFD   F1,F1,F3
    ADFD   F1,F1,F5      ;f1=FN3*(FN4-20*FN)+FN5
    SUFD   F6,F6,#4      ;4*FN-4
    ADFD   F6,F6,F6      ;8*FN-8
    ADFD   F6,F6,F0      ;28*FN-8
    SUFD   F0,F5,F4      ;FN5-FN4
    ADFD   F6,F6,F0      ;f2=28*FN-FN4-8+FN5
    SUFD   F4,F2,#5
    MUFD   F5,F4,F4      ;(FN2-5)**2
    SUFD   F0,F5,F7
    MUFD   F3,F3,F0      ;f3=FN3*((FN2-5)**2-XN)
    ADFD   F2,F2,#1
    MUFD   F0,F2,F2
    SUFD   F2,F0,F7      ;1/RAN=((FN2+1)**2-XN)
;          now we have f1,f2,f3 in F1,F6,F3 and RAN in F2
;          F0,F4,F5 are available
;          A0,A1,A2 on stack at 48,40,32
    LDFD   F0,[sp,#48]   ;A0
    LDFD   F4,[sp,#40]   ;A1
    LDFD   F5,[sp,#32]   ;A2
    MUFD   F0,F0,F3      ;f3*A0
    MUFD   F4,F4,F6      ;f2*A1
    MUFD   F5,F5,F1      ;f1*A2
    ADFD   F0,F0,F4
    ADFD   F5,F5,F0      ;f1*A2+f2*A1+f3*A0
    DVFD   F5,F5,F2      ;A=(f1*A2+f2*A1+f3*A0)*RAN
;          B0,B1,B2 on stack at 24,16,8
    LDFD   F0,[sp,#24]   ;B0
    LDFD   F4,[sp,#16]   ;B1
    MUFD   F0,F0,F3      ;f3*B0
    LDFD   F3,[sp,#8]    ;B2
    MUFD   F4,F4,F6      ;f2*B1
    MUFD   F3,F3,F1      ;f1*B2
    ADFD   F0,F0,F4
    ADFD   F3,F3,F0      ;f1*B2+f2*B1+f3*B0
    DVFD   F6,F3,F2      ;B=(f1*B2+f2*B1+f3*B0)*RAN
    DVFD   F4,F5,F6      ;C=A/B
    ADD    R3,R3,#1
    CMP    R3,#30
    LDFLED F3,[sp]       ;restore C0
    ABSLED F0,F4         ;|C|
    LDFLED F1,eps
    SUFLED F2,F3,F4
    MUFLED F1,F1,F0      ;eps*|C|
    ABSLED F2,F2         ;|C-C0|
    CMFLE  F1,F2
    STFLED F4,[sp]       ;store new C0
    ADDLE  R2,sp,#8      ;pointer to B2
    LDMLEIA R2,{R4-R7}   ;get old B2 and B1
    STFLED F6,[R2],#8    ;B2'=B
    STMLEIA R2!,{R4-R7}  ;B1'=B2, B0'=B1
    LDMLEIA R2,{R4-R7}   ;get old A2 and A1
    STFLED F5,[R2],#8    ;A2'=A
    STMLEIA R2!,{R4-R7}  ;A1'=A2, A0'=A1
    BLE    lk2           ;loop
    LDFD   F1,[sp,#56]   ;restore X
    LDFD   F2,rpih       ;2/pi
    ADD    sp,sp,#64     ;restore stack
    MUFD   F3,F1,F2
    SQTD   F5,F3
    DVFD   F0,F4,F5      ;answer=C/SQRT(2X/pi)
    CMP    ip,#0         ;if check for BES type
    EXPEQD F1,F1
    DVFEQD F0,F0,F1      ;and multiply by EXP(-X)
    B      ret
;
    LTORG
rpih DCFD  0.636619772367581343 ;2/pi
;
sums;      do Chebyshev polynonial evaluation
    ADFD   F4,F1,F1      ;=16.0 or =10.0
    DVFD   F5,F4,F2
    SUFD   F3,F5,#1      ;H=16/V-1
    ADFD   F7,F3,F3      ;ALFA=2*H
    LDFD   F6,[R3],#-8   ;initial B1
    MVFD   F5,#0         ;initial B2
lps LDFD   F4,[R3],#-8   ;Cx(I)
    SUFD   F4,F4,F5      ;C-B2
    MVFD   F5,F6         ;B2'=B1
    MUFD   F6,F6,F7      ;ALFA*B1
    ADFD   F6,F4,F6      ;B1'=B0=C+ALFA*B1-B2
    SUBS   R2,R2,#1
    BGT    lps
    MUFD   F4,F5,F3      ;H*B2
    SUFD   F4,F6,F4      ;B0-H*B2
    MOV    pc,lr         ;return with B0-H*B2 in F4, B0 in F6, B2 in F5
    END
;
    TTL    BESJ0
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R0  RN    0
R1  RN    1
R2  RN    2
F0  FN    0
F1  FN    1
F2  FN    2
F3  FN    3
F4  FN    4
F5  FN    5
F6  FN    6
F7  FN    7
    AREA   |C$$code|,CODE,READONLY
    EXPORT besj0_;(X) Bessel function J0(X)
    EXPORT dbesj0_;(X) REAL*8 Bessel function J0(X)
;
    DCB    "besj0_",0,0,8,0,0,255
besj0_
    MOV    ip,sp
    STMDB  sp!,{R0,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDFS   F0,[R0]       ;X
    B      be1
;
    DCB    "dbesj0_",0,8,0,0,255
dbesj0_
    MOV    ip,sp
    STMDB  sp!,{R0,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDFD   F0,[R0]       ;X
be1 STFE   F4,[sp,#-12]! ;save floating registers
    STFE   F5,[sp,#-12]!
    STFE   F6,[sp,#-12]!
    STFE   F7,[sp,#-12]!
    ABSD   F0,F0         ;V=|X|
    LDFD   F1,eight
    CMF    F0,F1
    BGE    be2
;         calculation if |X|<8
    DVFD   F2,F0,F1      ;Y=|X|/8
    MOV    R2,#15        ;16 terms
    ADR    R1,wc1+15*8   ;address of C1(15)
    BL     sums          ;returns B0-H*B2 in F4
    MVFD   F0,F4
    B      ret           ;ans=B0-H*B2
;
be2;      calculation for |X|>=8 (V(=|X|) is in F0)
    DVFD   F2,F1,F0      ;Y=8/V
    MOV    R2,#9         ;10 terms in sum
    ADR    R1,wc2+9*8    ;address of C2(9)
    BL     sums          ;returns B0-H*B2 in F4
    MVFD   F1,F4         ;save P
    MOV    R2,#9         ;10 terms in sum
    ADR    R1,wc3+9*8    ;address of C3(9)
    BL     sum2          ;returns B0-H*B2 in F4
    MUFD   F7,F4,F2      ;Q=Y*(B0-H*B2)
    LDFD   F6,pi2
    SQTD   F2,F0         ;1/SQRT(R)
    SUFD   F6,F0,F6      ;Theta=V-pi/4
    COSD   F4,F6
    SIND   F5,F6
    MUFD   F4,F4,F1      ;P*COS(T)
    MUFD   F5,F5,F7      ;Q*SIN(T)
    LDFD   F0,pi1
    SUFD   F1,F4,F5
    DVFD   F0,F0,F2
    MUFD   F0,F0,F1      ;pi1*SQRT(R)*(P*COS(T)-Q*SINT(T))
ret;
    LDFE   F7,[sp],#12   ;restore floating registers
    LDFE   F6,[sp],#12
    LDFE   F5,[sp],#12
    LDFE   F4,[sp],#12
    LDMDB  fp,{fp,sp,pc} ;return
;
    EXPORT besj1_;(X) Bessel function J1(X)
    EXPORT dbesj1_;(X) REAL*8 Bessel function J1(X)
;
    DCB    "besj1_",0,0,8,0,0,255
besj1_
    MOV    ip,sp
    STMDB  sp!,{R0,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDFS   F0,[R0]       ;X
    B      be3
;
    DCB    "dbesj1_",0,8,0,0,255
dbesj1_
    MOV    ip,sp
    STMDB  sp!,{R0,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDFD   F0,[R0]       ;X
be3 STFE   F4,[sp,#-12]! ;save floating registers
    STFE   F5,[sp,#-12]!
    STFE   F6,[sp,#-12]!
    STFE   F7,[sp,#-12]!
    ABSD   F1,F0         ;V=|X|
    LDFD   F2,eight
    CMF    F1,F2
    BGE    be4
;         calculate for |X|<8
    DVFD   F2,F0,F2      ;Y=X/8
    MOV    R2,#14        ;15 terms in sum
    ADR    R1,wd1+14*8   ;address of D1(14)
    BL     sums          ;returns with B0-H*B2 in F4, B0 in F6, B2 in F5
    SUFD   F4,F6,F5
    MUFD   F0,F4,F2      ;result is Y*(B0-B2)
    B      ret
be4;      calculate for |X|>=8
    DVFD   F2,F2,F1      ;Y=8*R
    MOV    R2,#9         ;10 terms
    ADR    R1,wd2+9*8    ;address D2(9)
    BL     sums          ;returns with B0-H*B2 in F4, B0 in F6, B2 in F5
    MVFD   F0,F4         ;save P=(B0-H*B2)
    MOV    R2,#8         ;9 terms
    ADR    R1,wd3+8*8    ;address D3(8)
    BL     sum2          ;returns with B0-H*B2 in F4, B0 in F6, B2 in F5
    LDFD   F5,pi3
    MUFD   F7,F4,F2      ;Q=Y*(B0-H*B2)
    SUFD   F6,F1,F5      ;theta=V-3pi/4
    SQTD   F2,F1         ;1/SQRT(R)
    COSD   F4,F6
    SIND   F5,F6
    LDFD   F1,pi1
    MUFD   F4,F4,F0      ;P*COS(theta)
    MUFD   F5,F5,F7      ;Q*SIN(theta)
    DVFD   F2,F1,F2      ;pi1*SQRT(R)
    SUFD   F4,F4,F5
    MUFD   F0,F2,F4      ;answer= pi1*SQRT(R)*(PCOS(T)-Q*SIN(T))
    LDR    R1,[R0]
    TST    R1,#&8,4      ;check sign of X
    MNFNED F0,F0         ;give it sign of X
    B      ret
;
wc1; (0:15)
    DCFD +0.15772797147489011956
    DCFD -0.00872344235285222129
    DCFD +0.26517861320333680987
    DCFD -0.37009499387264977903
    DCFD +0.15806710233209726128
    DCFD -0.03489376941140888516
    DCFD +0.00481918006946760450
    DCFD -0.00046062616620627505
    DCFD +0.00003246032882100508
    DCFD -0.00000176194690776215
    DCFD +0.00000007608163592419
    DCFD -0.00000000267925353056
    DCFD +0.00000000007848696314
    DCFD -0.00000000000194383469
    DCFD +0.00000000000004125321
    DCFD -0.00000000000000075885
wc2; (0:9)
    DCFD +0.99946034934751866537
    DCFD -0.00053652204681321174
    DCFD +0.00000307518478751947
    DCFD -0.00000005170594537606
    DCFD +0.00000000163064646352
    DCFD -0.00000000007864091377
    DCFD +0.00000000000516826239
    DCFD -0.00000000000043045789
    DCFD +0.00000000000004326596
    DCFD -0.00000000000000506903
wc3; (0:9)
    DCFD -0.01555585460533700910
    DCFD +0.00006838519942611650
    DCFD -0.00000074144984110606
    DCFD +0.00000001797245724797
    DCFD -0.00000000072719159369
    DCFD +0.00000000004220121905
    DCFD -0.00000000000320674742
    DCFD +0.00000000000030061451
    DCFD -0.00000000000003336328
    DCFD +0.00000000000000425523
;
eight DCFD  8.0E0
pi1 DCFD  0.797884560802865356 ;SQRT(2/PI)
pi2 DCFD  0.785398163397448310 ;pi/4
pi3 DCFD  2.356194490192344929 ;3pi/4
pi4 DCFD  0.636619772367581343 ;2/pi
wce DCFD  0.577215664901532861 ; d(GAMMA(X))/dX at X=1
;
wd1;(0:14)
    DCFD +0.05245819033465648458
    DCFD +0.04809646915823037394
    DCFD +0.31327508236156718380
    DCFD -0.24186740844740748475
    DCFD +0.07426679621678703781
    DCFD -0.01296762731173517510
    DCFD +0.00148991289666763839
    DCFD -0.00012227868505432427
    DCFD +0.00000756263022969605
    DCFD -0.00000036613085523363
    DCFD +0.00000001427732438731
    DCFD -0.00000000045857003076
    DCFD +0.00000000001235174811
    DCFD -0.00000000000028317735
    DCFD +0.00000000000000559509
wd2;(0:9)
    DCFD +1.00090304086001369989
    DCFD +0.00089898983308594085
    DCFD -0.00000398728430048891
    DCFD +0.00000006177633960644
    DCFD -0.00000000187189074911
    DCFD +0.00000000008816898660
    DCFD -0.00000000000570486364
    DCFD +0.00000000000046991955
    DCFD -0.00000000000004684224
    DCFD +0.00000000000000545267
wd3;(0:8)
    DCFD +0.04677778706953532524
    DCFD -0.00009627723549157079
    DCFD +0.00000091386152579555
    DCFD -0.00000002095978138408
    DCFD +0.00000000082291933277
    DCFD -0.00000000004686363688
    DCFD +0.00000000000351521879
    DCFD -0.00000000000032643157
    DCFD +0.00000000000003596777
;
    EXPORT besy0_;(X) Bessel function Y0(X)
    EXPORT dbesy0_;(X) REAL*8 Bessel function Y0(X)
;
    DCB    "besy0_",0,0,8,0,0,255
besy0_
    MOV    ip,sp
    STMDB  sp!,{R0,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDFS   F0,[R0]       ;X
    B      be5
;
    DCB    "dbesy0_",0,8,0,0,255
dbesy0_
    MOV    ip,sp
    STMDB  sp!,{R0,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDFD   F0,[R0]       ;X
be5 CMF    F0,#0
    MVFLED F0,#0
    LDMLEDB fp,{fp,sp,pc} ;error return if X<=0
    STFE   F4,[sp,#-12]! ;save floating registers
    STFE   F5,[sp,#-12]!
    STFE   F6,[sp,#-12]!
    STFE   F7,[sp,#-12]!
    LDFD   F1,eight
    CMF    F0,F1
    BGE    be6
;         calculation for X<8
    DVFD   F2,F0,F1      ;Y=X/8
    MOV    R2,#14        ;15 terms in sum
    ADR    R1,wc1+14*8   ;address if C1(14)
    BL     sums
    MVFD   F1,F4         ;save P=(B0-H*B2)
    MOV    R2,#15        ;16 terms in sum
    ADR    R1,we2+15*8   ;address of E2(15)
    BL     sum2
    MUFD   F0,F0,#0.5
    LDFD   F5,wce
    LGND   F0,F0
    LDFD   F6,pi4
    ADFD   F0,F0,F5
    MUFD   F0,F0,F1
    MUFD   F0,F0,F6
    ADFD   F0,F0,F4       ;ans=(2/pi)*(ce+LOG(X/2))*P+B0-H*B2
    B      ret
be6;      calculation for X>=8
    DVFD   F2,F1,F0       ;Y=8/X
    MOV    R2,#9          ;10 terms in sum
    ADR    R1,wc2+9*8     ;address of E3(9)
    BL     sums
    MVFD   F1,F4          ;save P
    MOV    R2,#8          ;9 terms in sum
    ADR    R1,wc3+8*8     ;address of E4(8)
    BL     sum2
    LDFD   F5,pi2
    SQTD   F6,F0          ;1/SQRT(R)
    MUFD   F4,F4,F2       ;Q=Y*(B0-H*B2)
    SUFD   F0,F0,F5       ;theta=X-pi/4
    LDFD   F7,pi1
    COSD   F2,F0
    SIND   F3,F0
    MUFD   F2,F2,F4       ;Q*COS(T)
    MUFD   F3,F3,F1       ;P*SIN(T)
    DVFD   F7,F7,F6       ;pi1*SQRT(R)
    ADFD   F2,F2,F3
    MUFD   F0,F2,F7       ;ans=pi1*SQRT(R)*(Q*COS(T)+P*SIN(T))
    B      ret
;
    EXPORT besy1_;(X) Bessel function Y1(X)
    EXPORT dbesy1_;(X) REAL*8 Bessel function Y1(X)
;
    DCB    "besy1_",0,0,8,0,0,255
besy1_
    MOV    ip,sp
    STMDB  sp!,{R0,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDFS   F0,[R0]       ;X
    B      be7
;
    DCB    "dbesy1_",0,8,0,0,255
dbesy1_
    MOV    ip,sp
    STMDB  sp!,{R0,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDFD   F0,[R0]       ;X
be7 CMF    F0,#0
    MVFLED F0,#0
    LDMLEDB fp,{fp,sp,pc} ;error return if X<=0
    STFE   F4,[sp,#-12]! ;save floating registers
    STFE   F5,[sp,#-12]!
    STFE   F6,[sp,#-12]!
    STFE   F7,[sp,#-12]!
    LDFD   F1,eight
    CMF    F0,F1
    BGE    be8
;         calculation for X<8
    DVFD   F2,F0,F1     ;Y=X/8
    MOV    R2,#13       ;14 terms in sum
    ADR    R1,wd1+13*8  ;address of F1(13)
    BL     sums         ;returns with B0-H*B2 in F4, B0 in F6, B2 in F5
    SUFD   F6,F6,F5
    MUFD   F1,F6,F2     ;save P=Y*(B0-B2)
    MOV    R2,#14       ;15 terms in sum
    ADR    R1,wf2+14*8  ;address of F2(14)
    BL     sum2         ;returns with B0-H*B2 in F4, B0 in F6, B2 in F5
    SUFD   F6,F6,F5
    MUFD   F4,F0,#0.5   ;X/2
    MUFD   F2,F6,F2     ;Q=Y*(B0-B2)
    LDFD   F3,wce
    LGND   F4,F4        ;LOG(X/2)
    LDFD   F5,pi4       ;2/pi
    ADFD   F4,F4,F3
    DVFD   F6,F5,F0     ;2/(pi*X)
    MUFD   F4,F4,F5
    SUFD   F2,F2,F6
    MUFD   F4,F4,F1
    ADFD   F0,F4,F2     ;ans=(2/pi)*(ce+LOG(X/2))*P-2/(pi*X)+Q
    B      ret
be8;      calculation for X>8
    DVFD   F2,F1,F0     ;Y=8/X
    MOV    R2,#7        ;8 terms
    ADR    R1,wd2+7*8   ;address F3(7)
    BL     sums
    MVFD   F1,F4        ;save P
    MOV    R2,#8        ;9 terms
    ADR    R1,wd3+8*8   ;address F4(8)
    BL     sum2
    LDFD   F5,pi3       ;3pi/4
    MUFD   F2,F2,F4     ;Q=Y*(B0-H*B2)
    SUFD   F4,F0,F5     ;X-3pi/4
    SQTD   F0,F0        ;1/SQRT(R)
    LDFD   F5,pi1
    COSD   F6,F4
    SIND   F7,F4
    MUFD   F6,F6,F2
    MUFD   F7,F7,F1
    DVFD   F5,F5,F0     ;pi1*SQRT(R)
    ADFD   F6,F6,F7
    MUFD   F0,F5,F6     ;ans=pi1*SQRT(R)*(Q*COS(T)+P*(SIN(T)))
    B      ret
we2;(0:15)
    DCFD -0.02150511144965755061
    DCFD -0.27511813304351879146
    DCFD +0.19860563470255415556
    DCFD +0.23425274610902180210
    DCFD -0.16563598171365041312
    DCFD +0.04462137954066928217
    DCFD -0.00693228629152318829
    DCFD +0.00071911740375230309
    DCFD -0.00005392507972293939
    DCFD +0.00000307649328810848
    DCFD -0.00000013845718123009
    DCFD +0.00000000505105436909
    DCFD -0.00000000015258285043
    DCFD +0.00000000000388286747
    DCFD -0.00000000000008442875
    DCFD +0.00000000000000158748
wf2;(0:14)
    DCFD -0.04017294654441407579
    DCFD -0.44444714763055806261
    DCFD -0.02271924442841773587
    DCFD +0.20664454101749051976
    DCFD -0.08667169705694852366
    DCFD +0.01763670300316313441
    DCFD -0.00223561929448509524
    DCFD +0.00019706230270154078
    DCFD -0.00001288585329924086
    DCFD +0.00000065284795235852
    DCFD -0.00000002645073717479
    DCFD +0.00000000087803011712
    DCFD -0.00000000002434327870
    DCFD +0.00000000000057261216
    DCFD -0.00000000000001157794
;
sums;      do Chebyshev polynonial evaluation
    MUFD   F4,F2,F2
    ADFD   F5,F4,F4
    SUFD   F3,F5,#1      ;H=2*Y**2-1
    ADFD   F7,F3,F3      ;ALPHA=2H
sum2 LDFD   F6,[R1],#-8   ;initial B1
    MVFD   F5,#0         ;initial B2
lps LDFD   F4,[R1],#-8   ;Cx(I)
    SUFD   F4,F4,F5      ;C-B2
    MVFD   F5,F6         ;B2'=B1
    MUFD   F6,F6,F7      ;ALFA*B1
    ADFD   F6,F4,F6      ;B1'=B0=C+ALFA*B1-B2
    SUBS   R2,R2,#1
    BGT    lps
    MUFD   F4,F5,F3      ;H*B2
    SUFD   F4,F6,F4      ;B0-H*B2
    MOV    pc,lr         ;return with B0-H*B2 in F4, B0 in F6, B2 in F5
    END
;
    TTL    BINSIZ
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
F0  FN    0
F1  FN    1
F2  FN    2
F3  FN    3
F4  FN    4
F5  FN    5
F6  FN    6
F7  FN    7
    AREA   |C$$code|,CODE,READONLY
    EXPORT binsiz_;(A1,A2,NAA,BL,BH,NB,BWID) determines good histogram bins
;           INPUT:
;    A1: absolute lower bound
;    A2: absolute upper bound
;   NAA: desired maximum number of bins (uses input BWID if this is -1)
;           OUTPUT
;    BL: suggested lower bound
;    BH: suggested upper bound
;    NB: number of bins
;  BWID: bin width
    DCB    "binsiz_",0,8,0,0,255
binsiz_
    MOV    ip,sp
    STMDB  sp!,{R0-R6,fp,ip,lr,pc}
    SUB    fp,ip,#4
    STFE   F4,[sp,#-12]! ;save extra floating registers
    STFE   F5,[sp,#-12]!
    LDMIB  fp,{R4-R6}    ;addresses of BH,NB,BWID
    LDFS   F4,[R0]       ;A1 (probably AL)
    LDFS   F5,[R1]       ;A2 (probably AH)
    CMF    F4,F5
    LDFGTS F4,[R1]       ;AL
    LDFGTS F4,[R0]       ;AH
    ADFEQS F5,F4,#1      ;AH>AL
    LDR    R2,[R2]       ;NAA
    RSBS   lr,R2,#0
    LDFGTS F3,[R6]       ;get BWID if NAA<0
    CMFGT  F3,#0
    BGT    pt3           ;go to get # bins from BWID
    SUBS   R0,R2,#1
    MOVLE  R0,#1         ;NA=MAX(1,NAA-1)
pt1 SUFS   F2,F5,F4      ;AH-AL
    FLTS   F3,R0         ;FLOAT(NA)
    FDVS   F2,F2,F3      ;AWID=(AH-AL)/NA
    LOGS   F3,F2         ;LOG10(AWID)
    FIXM   lr,F3         ;LOG=INT(LOG10(AWID)) rounded down algebraically
    FLTS   F3,lr         ;(RND does not always do the expected thing)
    RPWS   F3,F3,#10
    FDVS   F1,F2,F3      ;SIGFIG=AWID*(10.0**(-LOG))
    CMF    F1,#2
    MVFLES F1,#2         ;IF SIGFIG LE 2, set it to 2
    BLE    pt2
    LDFS   F2,C25
    CMF    F1,F2
    MVFLES F1,F2         ;ELSE IF SIGFIG LE 2.5, set it to 2.5
    BLE    pt2
    CMF    F1,#5
    MVFLES F1,#5         ;ELSE IF SIGFIG LE 5, set it to 5
    MVFGTS F1,#1
    FMLGTS F3,F3,#10     ;ELSE set it to 1 and add 1 to LOG
pt2 FMLS   F3,F3,F1      ;BWID=SIGFIG*10.0**LOG
pt3 FDVS   F0,F4,F3      ;ALB=AL/BWID
    FIX    ip,F0         ;LWID=ALB rounded to nearest
    FLTS   F0,ip
    FMLS   F0,F0,F3      ;BL=BWID*LWID
    FDVS   F1,F5,F3
    FIX    R1,F1         ;KWID=ALB rounded to nearest
    FLTS   F1,R1
    FMLS   F1,F1,F3      ;BH=BWID*KWID
    SUB    ip,R1,ip      ;NB=KWID-LWID
    CMP    R2,#5
    BGT    pt4
    CMP    R2,#-1
    CMPNE  ip,#1
    CMPNE  R2,#2         ;if NAA.NE.-1 AND NB.NE.1 AND NAA.LT.2 then
    ADFLTS F3,F3,F3      ;double BWID
    MOVLT  ip,#1         ;and set NB to 1
ret;         store results
    STFS   F0,[R3]       ;BL
    STFS   F1,[R4]       ;BH
    STR    ip,[R5]       ;NB
    STFS   F3,[R6]       ;BWID
    LDFE   F5,[sp],#12   ;restore extra floating registers
    LDFE   F4,[sp],#12
    LDMDB  fp,{R4-R6,fp,sp,pc} 
pt4 ADD    lr,ip,ip      ;2*NB
    CMP    lr,R2
    BNE    ret
    ADD    R0,R0,#1
    B      pt1
C25 DCFS   2.5
    END
;
;          BITPOS see UBITS
;
    TTL    BLOW
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 blow_  ;(IN,OUT,NBYTES,NBITS) unpacks small integers from array
;
    DCB    "blow_",0,0,0,8,0,0,255
blow_
    MOV    ip,sp
    STMDB  sp!,{R0-R6,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R2,[R2]        ;NBYTES
    LDR    R3,[R3]        ;NBITS
    CMP    R2,#1
    CMPGE  R3,#1
    RSBGES ip,R3,#32
    LDMLTDB fp,{R4-R6,fp,sp,pc} ;return if NBYTES<1 or NBITS<1 or NBITS>32
    MOV    ip,#-1
    MOV    lr,#0          ;first bit
lp1 CMP    lr,#0
    LDRLE  R4,[R0],#4     ;get new input word
    MOVLE  lr,#32         ;start at bit 32
    SUBS   lr,lr,R3
    MOVGE  R5,R4,LSR lr   ;store bits from current word
    RSBLT  R6,lr,#0
    MOVLT  R5,R4,LSL R6
    LDRLT  R4,[R0],#4     ;get next word
    ADDLT  lr,lr,#32
    ORRLT  R5,R5,R4,LSR lr;store rest of bits
    BIC    R5,R5,ip,LSL R3;mask off unneeded bits
    STR    R5,[R1],#4     ;store byte
    SUBS   R2,R2,#1
    BGT    lp1            ;loop over bytes
    LDMDB  fp,{R4-R6,fp,sp,pc} 
    END
;
    TTL    BUNCH
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 bunch_  ;(IN,OUT,NBYTES,NBITS) packs small integers into array
;
    DCB    "bunch_",0,0,8,0,0,255
bunch_
    MOV    ip,sp
    STMDB  sp!,{R0-R6,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R2,[R2]        ;NBYTES
    LDR    R3,[R3]        ;NBITS
    CMP    R2,#1
    CMPGE  R3,#1
    RSBGES ip,R3,#32
    LDMLTDB fp,{R4-R6,fp,sp,pc} ;return if NBYTES<1 or NBITS<1 or NBITS>32
    MOV    ip,#-1
    MOV    lr,#32         ;first bit
    MOV    R5,#0          ;accumulator
lp1 LDR    R4,[R0],#4     ;get byte
    BIC    R4,R4,ip,LSL R3;mask off excess bits
    SUBS   lr,lr,R3       ;account for bits in output
    ORRGE  R5,R5,R4,LSL lr
    RSBLT  R6,lr,#0
    ORRLT  R5,R5,R4,LSR R6
    STRLE  R5,[R1],#4     ;store full word
    ADDLE  lr,lr,#32
    MOVLE  R5,R4,LSL lr
    SUBS   R2,R2,#1
    BGT    lp1
    CMP    lr,#32
    STRLT  R5,[R1]        ;store final (partial) word
    LDMDB  fp,{R4-R6,fp,sp,pc} 
    END
;
    TTL   caldat
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 caldat_;(IINDEX,CHREP,BINREP,RETC) converts date representations
    IMPORT __rt_sdiv
    IMPORT datime_
    DCB    "caldat_",0,8,0,0,255
caldat_
    MOV    ip,sp
    STMDB  sp!,{R0-R9,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    ip,[R0]        ;IINDEX
    CMP    ip,#0
    MOVLT  ip,#4
    BLT    err            ;error 4 for negative index
    BGT    CT1
    SUB    sp,sp,#8       ;space for DATIME results
    MOV    R0,sp          ;address of result K
    ADD    R1,sp,#4       ;address of result I (unused)
    BL     datime_        ;returns current YY*10000 +  MM*100 + DD
    LDR    R1,[sp],#8     ;get K and restore stack
    MOV    R0,#100
    BL     __rt_sdiv     ;R0 now has YY*100 + MM, R1 has DD
    MOV    R4,R1          ;DAY
    MOV    R1,R0
    MOV    R0,#100
    BL     __rt_sdiv     ;R0 now has YY, R1 has MM
    MOV    R5,R1          ;MONTH
    MOV    R6,R0          ;YEAR
    B      dmyy           ;go to common section with DD/MM/YY
;
CT1 CMP    ip,#14
    BGT    intinp         ;not character input
    BLT    CT2
    ADD    R1,R1,#108     ;(CHREP(109:))
    MOV    R2,#2
    BL     read
    MOV    R6,R0          ;YEAR
    MOV    R2,#3
    BL     read
    MOV    R7,R0          ;day-in-year
    B      diyyy          ;go to common section with DIY/YY
;
CT2 CMP    ip,#2
    BGE    q02
    LDRB   R3,[R1,#2]     ;format 1: e.g. '16. APRIL 1982'
    CMP    R3,#"."        ;character 3 must be '.'
    LDREQB R3,[R1,#3]
    CMPEQ  R3,#" "        ;character 4 must be ' '
    LDREQB R3,[R1,#9]
    CMPEQ  R3,#" "        ;character 10 must be ' '
    BNE    er1            ;otherwise error 1001
    MOV    R2,#2
    BL     read
    MOV    R4,R0          ;DAY
    ADD    R1,R1,#8       ;(CHREP(11:))
    MOV    R2,#4
    BL     read
    MOV    R6,R0          ;YEAR
    MOV    R5,#0          ;get month
    SUB    R1,R1,#6      ;(CHREP(9:))
    ADR    R0,monnl
lp1 MOV    R2,#4
    ADD    R5,R5,#1       ;count months
    MOV    R8,#0          ;found flag
lp2 LDRB   R7,[R1,-R2]    ;check this month
    LDRB   R3,[R0],#1     ;with list
    CMP    R7,R3
    MOVNE  R8,#1          ;fail flag
    SUBS   R2,R2,#1
    BGE    lp2            ;loop over 5 characters
    CMP    R8,#0
    BEQ    dmyyyy         ;go to common section with DD/MM/YYYY
    CMP    R5,#12
    BLT    lp1
    B      er1            ;month not found
;
q02 ADD    R1,R1,#14      ;account for length of DMY14
    BGT    q03
    LDRB   lr,[R1,#2]     ;format DMY11; e.g. "16 APR 1992"
    CMP    lr,#" "        ;character 3 must be ' '
    LDREQB lr,[R1,#6]
    CMPEQ  lr,#" "        ;character 7 must be ' '
    BNE    er1            ;otherwise error 1002
    MOV    R2,#2
    BL     read
    MOV    R4,R0          ;DAY
    ADD    R1,R1,#5       ;(CHREP(8:))
    MOV    R2,#4
    BL     read
    MOV    R6,R0          ;YEAR
    MOV    R5,#0          ;get month
    SUB    R1,R1,#6       ;(CHREP(6:))
    ADR    R0,mons
lp3 MOV    R2,#2
    MOV    R7,#0          ;found flag
    ADD    R5,R5,#1       ;count months
lp4 LDRB   lr,[R1,-R2]    ;check this month
    LDRB   R3,[R0],#1     ;with list
    CMP    lr,R3
    MOVNE  R7,#1
    SUBS   R2,R2,#1
    BGE    lp4            ;loop over 3 characters
    CMP    R7,#0
    BEQ    dmyyyy         ;go to common section with DD/MM/YYYY
    CMP    R5,#12
    BLT    lp3
    B      er1            ;month not found
;
q03 ADD    R1,R1,#11      ;account for length of DMY11
    CMP    ip,#4
    BGE    q04
    LDRB   lr,[R1,#2]     ;format DMY9; e.g. "16 APR 92"
    CMP    lr,#" "        ;character 3 must be ' '
    LDREQB lr,[R1,#6]
    CMPEQ  lr,#" "        ;character 7 must be ' '
    BNE    er1            ;otherwise error 1003
    MOV    R2,#2
    BL     read
    MOV    R4,R0          ;DAY
    ADD    R1,R1,#5       ;(CHREP(8:))
    BL     read
    MOV    R6,R0          ;YEAR
    MOV    R5,#0          ;get month
    SUB    R1,R1,#4       ;(CHREP(6:))
    ADR    R0,mons
lp5 MOV    R2,#2
    MOV    R7,#0          ;found flag
    ADD    R5,R5,#1       ;count months
lp6 LDRB   lr,[R1,-R2]    ;check this month
    LDRB   R3,[R0],#1     ;with list
    CMP    lr,R3
    MOVNE  R7,#1
    SUBS   R2,R2,#1
    BGE    lp6            ;loop over 3 characters
    CMP    R7,#0
    BEQ    dmyy           ;go to common section with DD/MM/YY
    CMP    R5,#12
    BLT    lp5
    B      er1            ;month not found
;
q04 ADD    R1,R1,#9       ;account for length of DMY9
    BGT    q05
    MOV    R2,#2          ;format DMY10; e.g. "16. 4.1982"
    BL     read
    MOV    R4,R0          ;DAY
    LDRB   lr,[R1],#1
    CMP    lr,#"."        ;character 3 must be '.'
    BNE    er1            ;otherwise error 1004
    BL     read
    MOV    R5,R0          ;MONTH
    LDRB   lr,[R1],#1
    CMP    lr,#"."        ;character 6 must be '.'
    BNE    er1            ;otherwise error 1004
    MOV    R2,#4
    BL     read
    MOV    R6,R0          ;YEAR
    B      dmyyyy         ;go to common section with DD/MM/YYYY
;
q05 ADD    R1,R1,#10      ;account for length of DMY10
    MOV    R2,#2          ;length are now all 2
    CMP    ip,#6
    ADDGE  R1,R1,#8       ;account for length of DMY8A
    BGT    q07
    MOVLT  R9,#"."        ;separator is '.' for DMY8A, e.g "16. 4.92"
    MOVEQ  R9,#"/"        ;separator is '/' for DMY8B, e.g "16/04/92"
    BL     read
    MOV    R4,R0          ;DAY
    LDRB   lr,[R1],#1
    CMP    lr,R9          ;check character 3
    BNE    er1            ;otherwise error 1005 or 1006
    BL     read
    MOV    R5,R0          ;MONTH
    LDRB   lr,[R1],#1
    CMP    lr,R9          ;check character 6
    BNE    er1            ;otherwise error 1005 or 1006
    BL     read
    MOV    R6,R0          ;YEAR
    B      dmyy           ;go to common section with DD/MM/YY
;
q07 ADD    R1,R1,#8       ;account for length of DMY8B
    CMP    ip,#8
    BGE    CT3
    BL     read           ;format DMY6, e.g. "160482"
    MOV    R4,R0          ;DAY
    BL     read
    MOV    R5,R0          ;MONTH
    BL     read
    MOV    R6,R0          ;YEAR
    B      dmyy           ;go to common section with DD/MM/YY
;
CT3 ADD    R1,R1,#6       ;account for length of DMY6
    BGT    q09
    BL     read           ;format YMD8; e.g. "82/04/16"
    MOV    R6,R0          ;YEAR
    LDRB   lr,[R1],#1
    CMP    lr,#"/"        ;character 3 must be '/'
    BNE    er1            ;otherwise error 1008
    BL     read
    MOV    R5,R0          ;MONTH
    LDRB   lr,[R1],#1
    CMP    lr,#"/"        ;character 6 must be '/'
    BNE    er1            ;otherwise error 1008
    BL     read
    MOV    R4,R0          ;DAY
    B      dmyy           ;go to common section with DD/MM/YY
;
q09 ADD    R1,R1,#8       ;account for length of YMD8
    CMP    ip,#10
    BGE    CT4
    BL     read           ;format YMD6, e.g. "820416"
    MOV    R6,R0          ;YEAR
    BL     read
    MOV    R5,R0          ;MONTH
    BL     read
    MOV    R4,R0          ;DAY
    B      dmyy           ;go to common section with DD/MM/YY
;
CT4 ADD    R1,R1,#6       ;account for length of YMD6
    BGT    qd6
    BL     read           ;format MDY8; e.g. "04/16/82"
    MOV    R5,R0          ;MONTH
    LDRB   lr,[R1],#1
    CMP    lr,#"/"        ;character 3 must be '/'
    BNE    er1            ;otherwise error 1010
    BL     read
    MOV    R4,R0          ;DAY
    LDRB   lr,[R1],#1
    CMP    lr,#"/"        ;character 6 must be '/'
    BNE    er1            ;otherwise error 1010
    BL     read
    MOV    R6,R0          ;YEAR
    B      dmyy           ;go to common section with DD/MM/YY
;
qd6 ADD    R1,R1,#8       ;account for length of MDY8
    CMP    ip,#12
    BGE    CT5
    BL     read           ;format MDY6, e.g. "041682"
    MOV    R5,R0          ;MONTH
    BL     read
    MOV    R4,R0          ;DAY
    BL     read
    MOV    R6,R0          ;YEAR
    B      dmyy           ;go to common section with DD/MM/YY
;
CT5 ADD    R1,R1,#6       ;account for length of MDY6
    BGT    qdy
    MOV    R2,#2
    BL     read           ;format YDM8; e.g. "82/16/04"
    MOV    R6,R0          ;YEAR
    LDRB   lr,[R1],#1
    CMP    lr,#"/"        ;character 3 must be '/'
    BNE    er1            ;otherwise error 1012
    BL     read
    MOV    R4,R0          ;DAY
    LDRB   lr,[R1],#1
    CMP    lr,#"/"        ;character 6 must be '/'
    BNE    er1            ;otherwise error 1012
    BL     read
    MOV    R5,R0          ;MONTH
    B      dmyy           ;go to common section with DD/MM/YY
;
qdy ADD    R1,R1,#8       ;account for length of YDM8
    BL     read           ;format YDM6, e.g. "821604"
    MOV    R6,R0          ;YEAR
    BL     read
    MOV    R4,R0          ;DAY
    BL     read
    MOV    R5,R0          ;MONTH
    B      dmyy           ;go to common section with DD/MM/YY
;
intinp;     test for integer input
    CMP    ip,#101
    MOVLT  ip,#8
    BLT    err            ;illegal character index
;
    LDMEQIA R2,{R4-R6}    ;IINDEX=101, load DAY,MONTH,YEAR from BINREP
    BEQ    dmyyyy         ;go to common section with DD/MM/YYYY
;
    CMP    ip,#103
    BGT    q104
    BEQ    CT6
    LDR    R7,[R2,#12]    ;IINDEX=102, load day-in-year from BINREP(4)
    SUB    sp,sp,#8       ;space for DATIME results
    MOV    R0,sp          ;address of result K
    ADD    R1,sp,#4       ;address of result I (unused)
    BL     datime_        ;returns current YY*10000 +  MM*100 + DD
    LDR    R1,[sp],#8     ;get K and restore stack
    LDR    R0,=10000
    BL     __rt_sdiv     ;R0 now has YY
    MOV    R6,R0
    B      diyyy          ;go to common section with DIY/YY
;
CT6 LDR    R0,[R2,#16]    ;IINDEX=103, packed decimal 00YYDDDc
    AND    R1,R0,#15      ;last hex digit
    CMP    R1,#&C
    CMPNE  R1,#&E
    TSTEQ  R0,#&FF000000
    BNE    er1            ;not C or E, or top two nibbles set
    MOV    R6,R0,LSR#20   ;upper digit of year
    ADD    R6,R6,R6,LSL#2 ; * 5
    MOV    R3,#15         ;nibble mask
    AND    R1,R3,R0,LSR#16;lower digit of year
    ADD    R6,R1,R6,LSL#1 ;
    MOV    R2,#12         ;pointer to top d-i-y digit in R0
    MOV    R7,#0          ;initialize d-i-y
lp7 AND    R1,R3,R0,LSR R2;get digit
    ADD    R7,R7,R7,LSL#2
    ADD    R7,R1,R7,LSL#1 ;accumulate d-i-y
    SUBS   R2,R2,#4
    BGT    lp7            ;loop over 3 digits
    B      diyyy          ;go to common section with DIY/YY
;
    LTORG
;
monnl
    DCB    "JAN. FEB. MARCHAPRILMAY  JUNE JULY AUG. SEPT.OCT. NOV. DEC. "
;
q104;       Julian date in BINREP(6)
    CMP    ip,#105
    BGE    q105
    LDR    R8,[R2,#20]    ;JULIAN
    MOV    R1,#400
    LDR    R0,=146097
    MUL    R1,R8,R1
    BL     __rt_sdiv
    LDR    R1,=365
    ADD    R6,R0,#1       ;1st approximation to YEAR =(JULIAN*400)/146097+1
    MUL    R1,R0,R1
    SUB    R7,R8,R0,LSR#2
    SUB    R7,R7,R1       ;JULIAN - 365*(YEAR-1) - (YEAR-1)/4
    MOV    R1,R0
    MOV    R0,#100
    BL     __rt_sdiv
    ADD    R7,R7,R0
    SUBS   R7,R7,R0,LSR#2 ;DIY=JULIAN-(YEAR-1)*(365+1/4-1/100+1/400)
    BLE    fixs
fixp;   fix year if too many days
    BL     cleap
    ADD    R0,R0,#364     ;days in year
    CMP    R7,R0          ;check year is not too small
    BLE    diyyyyy
    SUB    R7,R7,R0
    ADD    R6,R6,#1       ;move up a year
    B      fixp
;
fixs;   fix year if too few days
    SUB    R6,R6,#1       ;decrement year
    BL     cleap
    ADD    R0,R0,#364     ;days in year
    ADDS   R7,R7,R0       ;add # days in year
    BLE    fixs           ;check d-i-y is positive
    B      diyyyyy
;
mons
    DCB    "JANFEBMARAPRMAYJUNJULAUGSEPOCTNOVDEC"
;
q105
    MOVGT  ip,#12
    BGT    err            ;IINDEX>105
    LDR    R6,[R2,#8]     ;YEAR
    LDR    R7,[R2,#12]    ;DIY
    B      diyyyyy
;
diyyy
    CMP    R6,#48
    ADD    R6,R6,#2000    ;YY -> 20YY
    SUBGT  R6,R6,#100      ;or YY -> 19YY
diyyyyy
    CMP    R6,#0
    MOVLE  ip,#24
    BLE    err
    BL     cleap
    ADD    R1,R0,#364     ;days in year
    CMP    R7,#1
    CMPGE  R1,R7
    MOVLT  ip,#16
    BLT    err            ;d-i-y outside allowed range
    BL     cdmon          ;get day & month from d-i-y
    B      julian         ;have DMY and d-i-y, go get Julian day
;
dmyy
    CMP    R6,#48
    ADD    R6,R6,#2000    ;YY -> 20YY
    SUBGT  R6,R6,#100      ;or YY -> 19YY
dmyyyy
    CMP    R6,#0          ;check for positive year
    MOVLE  ip,#24
    BLE    err
    BL     cleap
    CMP    R0,#1
    ADREQ  R1,daytab
    ADRNE  R1,daytab+12   ;pointer to days in month
    RSBS   lr,R5,#12      ;check month is between 1 and 12
    SUBGES lr,R5,#1
    CMPGE  R4,#1          ;day is positive and...
    LDRGEB R2,[R1,lr]
    CMPGE  R2,R4          ;not greater than the days in the month
    MOVLT  ip,#20
    BLT    err
    MOV    R7,R4          ;initialise d-i-y
    SUBS   R0,R5,#1       ;# months to add
lp8 LDRGTB lr,[R1],#1     ;days in month
    ADDGT  R7,R7,lr       ;add to total
    SUBS   R0,R0,#1
    BGT    lp8
;
julian;          have D,M,Y,d-i-y in R4-R7, calculate Julian day
    SUB    R1,R6,#1       ;year-1
    ADD    R8,R7,R1,LSR#2 ;DIY + (YEAR-1)/4
    LDR    R0,=365
    MLA    R8,R0,R1,R8    ;DIY + (YEAR-1)*(365 + 1/4)
    MOV    R0,#100
    BL     __rt_sdiv
    SUB    R8,R8,R0       ;DIY + (YEAR-1)*(365 + 1/4 - 1/100)
    ADD    R8,R8,R0,LSR#2 ;JULIAN=DIY + (YEAR-1)*(365 + 1/4 - 1/100 + 1/400)
;
;            output results !
;
    LDR    R9,[sp,#8]     ;restore address of BINREP
    STMIA  R9,{R4-R7}     ;store DAY,MONTH,YEAR,DIY in BINREP(1 to 4)
    STR    R8,[R9,#20]    ;store JULIAN in BINREP(6)
    SUB    R1,R8,#1
    MOV    R0,#7
    BL     __rt_sdiv
    STR    R1,[R9,#24]    ;store day in the week in BINREP(7)
    STR    R1,[sp,#-4]!   ;save for later use in printing
    SUB    R1,R7,R1
    ADD    R1,R1,#9
    MOV    R0,#7
    BL     __rt_sdiv
    STR    R0,[R9,#28]    ;store week in the year in BINREP(8)
;       build up packed decimal for BINREP(5)
    STR    R7,[sp,#-4]!   ;save DIY
    MOV    R1,R7          ;DIY
    MOV    R7,#12         ;&C
    MOV    R0,#100
    BL     __rt_sdiv
    ORR    R7,R7,R0,LSL#12
    MOV    R0,#10
    BL     __rt_sdiv
    ORR    R7,R7,R1,LSL#4
    ORR    R7,R7,R0,LSL#8 ;&DDDC
    MOV    R1,R6
    MOV    R0,#100
    BL     __rt_sdiv
    MOV    R8,R1          ;keep MOD(YEAR,100)
    MOV    R0,#10
    BL     __rt_sdiv
    ORR    R7,R7,R0,LSL#20
    ORR    R7,R7,R1,LSL#16;&YYDDDC
    STR    R7,[R9,#16]    ;store packed DEC in BINREP(5)
;
;          now output the character string
;
    LDR    R9,[sp,#12]     ;address of CHREP
;
    MOV    R0,R4          ;write DMY14: e.g. '16. APRIL 1982'
    MOV    R2,#2
    BL     write
    MOV    R7,#"."
    STRB   R7,[R9],#1
    MOV    ip,#" "
    STRB   ip,[R9],#1
    ADR    R0,monnl
    SUB    R5,R5,#1       ;reduce month by 1 temorarily
    ADD    R0,R0,R5
    ADD    R0,R0,R5,LSL#2
    MOV    R2,#5
    BL     writec
    STRB   ip,[R9],#1
    MOV    R0,R6
    MOV    R2,#4
    BL     write
;
    MOV    R0,R4          ;write DMY11: e.g. '16 APR 1982'
    MOV    R2,#2
    BL     write
    MOV    ip,#" "
    STRB   ip,[R9],#1
    ADR    R0,mons
    ADD    R0,R0,R5
    ADD    R0,R0,R5,LSL#1
    MOV    R2,#3
    BL     writec
    STRB   ip,[R9],#1
    MOV    R0,R6
    MOV    R2,#4
    BL     write
;
    MOV    R0,R4          ;write DMY9: e.g. '16 APR 82'
    MOV    R2,#2
    BL     write
    MOV    ip,#" "
    STRB   ip,[R9],#1
    ADR    R0,mons
    ADD    R0,R0,R5
    ADD    R0,R0,R5,LSL#1
    ADD    R5,R5,#1       ;restore month by adding 1
    MOV    R2,#3
    BL     writec
    STRB   ip,[R9],#1
    MOV    R0,R8
    MOV    R2,#2
    BL     write
;
    MOV    R0,R4          ;write DMY10.: e.g. '16. 4.1982'
    MOV    R2,#2
    BL     write
    STRB   R7,[R9],#1
    MOV    R0,R5
    BL     write
    STRB   R7,[R9],#1
    MOV    R0,R6
    MOV    R2,#4
    BL     write
;
    MOV    R0,R4          ;write DMY8A: e.g. '16. 4.82'
    MOV    R2,#2
    BL     write
    STRB   R7,[R9],#1
    MOV    R0,R5
    BL     write
    STRB   R7,[R9],#1
    MOV    R0,R8
    BL     write
;
    MOV    R0,R4          ;write DMY8A: e.g. '16/04/82'
    BL     write0
    MOV    R7,#"/"
    STRB   R7,[R9],#1
    MOV    R0,R5
    BL     write0
    STRB   R7,[R9],#1
    MOV    R0,R8
    BL     write0
;
    MOV    R0,R4          ;write DMY6: e.g. '160482'
    BL     write0
    MOV    R0,R5
    BL     write0
    MOV    R0,R8
    BL     write0
;
    MOV    R0,R8          ;write YMD8: e.g. '82/04/16'
    BL     write0
    STRB   R7,[R9],#1
    MOV    R0,R5
    BL     write0
    STRB   R7,[R9],#1
    MOV    R0,R4
    BL     write0
;
    MOV    R0,R8          ;write YMD6: e.g. '820416'
    BL     write0
    MOV    R0,R5
    BL     write0
    MOV    R0,R4
    BL     write0
;
    MOV    R0,R5          ;write MDY8: e.g. '04/16/82'
    BL     write0
    STRB   R7,[R9],#1
    MOV    R0,R4
    BL     write0
    STRB   R7,[R9],#1
    MOV    R0,R8
    BL     write0
;
    MOV    R0,R5          ;write MDY6: e.g. '041682'
    BL     write0
    MOV    R0,R4
    BL     write0
    MOV    R0,R8
    BL     write0
;
    MOV    R0,R8          ;write YDM8: e.g. '82/16/04'
    BL     write0
    STRB   R7,[R9],#1
    MOV    R0,R4
    BL     write0
    STRB   R7,[R9],#1
    MOV    R0,R5
    BL     write0
;
    MOV    R0,R8          ;write YDM6: e.g. '821604'
    BL     write0
    MOV    R0,R4
    BL     write0
    MOV    R0,R5
    BL     write0
;
    MOV    R0,R8          ;write YD5: e.g. '82106'
    BL     write0
    LDR    R0,[sp],#4     ;DIY
    MOV    R2,#3
    BL     write0
;
    LDR    R4,[sp],#4     ;day in week (0=monday)
    ADR    R0,day
    ADD    R0,R0,R4,LSL#2
    ADD    R0,R0,R4,LSL#1
    MOV    R2,#6
    BL     writec         ;write long & short day names: e.g. 'FRI.FR'
    MOV    ip,#0
    B      fin
;
daytab
    DCB    31,28,31,30,31,30,31,31,20,31,30,31
    DCB    31,29,31,30,31,30,31,31,20,31,30,31
;
day;    4+2 letters for each day
    DCB    "MON.MOTUE.TUWED.WETHURTHFRI.FRSAT.SASUN.SU",0,0
;
er1 ADD    ip,ip,#1000    ;error detected (error number -1000 in ip)
err MOV    R4,#118        ;error detected (error number in ip)
    MOV    lr,#"*"
    LDMIB  sp,{R1-R2}     ;restore pointers to CHREP,BINREP
le1 STRB   lr,[R1,R4]
    SUBS   R4,R4,#1
    BGE    le1
    LDR    lr,=&81818181
    MOV    R4,#7
le2 STR    lr,[R2,R4,LSL#2]
    SUBS   R4,R4,#1
    BGE    le2
fin LDR    R3,[sp,#12]    ;pointer to RETC
    STR    ip,[R3]        ;store error number
    LDMDB  fp,{R4-R9,fp,sp,pc} ;return
;
read;    utility to read integer from R1, length R2
;        returns answer in R0, R1 pointing to next character
    STMFD  sp!,{R2,R3,lr}
    MOV    R0,#0        ;initialise accumulator
lr1 LDRB   R3,[R1],#1   ;get character
    SUBS   R3,R3,#" "
    BEQ    rp1          ;treat ' ' as zero
    RSBS   R3,R3,#"9"-" "
    RSBGES R3,R3,#9
    BLT    er1          ;not digit
rp1 ADD    R0,R0,R0,LSL#2
    ADD    R0,R3,R0,LSL#1;accumulate
    SUBS   R2,R2,#1
    BGT    lr1
    LDMFD  sp!,{R2,R3,pc} 
;
write;     utility to write integers to R9, value from R0, length R2
;          blank fill (c.f. write0), updates R9 to next position, R2 preserved.
    STMFD  sp!,{R2,R4-R5,lr}
    SUB    R5,R2,#1   ;blank fill before this
pw1 MOV    R4,R2      ;length
lw1 MOVS   R1,R0
    BEQ    lw2        ;skip if no more to print
    MOV    R0,#10
    BL     __rt_sdiv
    ADD    R1,R1,#"0" ;make into ASCII digit
    SUBS   R4,R4,#1
    STRB   R1,[R9,R4] ;store digit
    BGT    lw1        ;loop over digits
    B      ret
lw2; no more to print but space left
    CMP    R4,R5
    MOVGT  R1,#"0"
    MOVLE  R1,#" "
    SUBS   R4,R4,#1
    STRB   R1,[R9,R4] ;store spacer
    BGT    lw2        ;loop over spacers
ret LDR    R2,[sp],#4 ;restore length
    ADD    R9,R9,R2   ;update buffer pointer
    LDMFD  sp!,{R4-R5,pc} 
;
write0;    utility to write integers to R9, value from R0, length R2
;          zero fill (c.f. write), updates R9 to next position, R2 preserved.
    STMFD  sp!,{R2,R4-R5,lr}
    MOV    R5,#0
    B      pw1
;
writec;    utility to write character string from R0 to R9, length R2.
;          R9 updated, R0,R1,R2 are destroyed.
lw3 LDRB   R1,[R0],#1
    STRB   R1,[R9],#1
    SUBS   R2,R2,#1
    BGT    lw3
    MOV    pc,lr
;
cleap;    check R6 for leap year
;         return R0=1 for normal year, 2 for leap year
    STMFD  sp!,{R1,lr}
    TST    R6,#3
    MOVNE  R0,#1          ;not divisible by 4 so ordinary year
    LDMNEFD sp!,{R1,pc}   ;and return
    MOV    R1,R6
    MOV    R0,#100
    BL     __rt_sdiv     ;R0=YEAR/100, R1=MOD(YEAR,100)
    CMP    R1,#0
    MOVNE  R0,#2
    LDMNEFD sp!,{R1,pc}   ;return leap-year if not century
    TST    R0,#3
    MOVEQ  R0,#2          ;leap-year every 400 years
    MOVNE  R0,#1          ;not leap-year on other centuries
    LDMFD  sp!,{R1,pc}    ;and return
;
cdmon;   given LEAP and DIY in R0,R7 returns MONTH, DAY in R5,R4
    CMP    R0,#1
    ADREQ  R0,daytab
    ADRNE  R0,daytab+12  ;pointer to # days in month
    MOV    R4,R7
    MOV    R5,#0         ;month
lc1 ADD    R5,R5,#1
    LDRB   R1,[R0],#1    ;#days in month
    SUBS   R4,R4,R1
    BGT    lc1
    ADD    R4,R4,R1
    MOV    pc,lr
    END
;
    TTL    CBYT
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R4  RN     4
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT cbyt_;(IA,JA,IX,J,NBITS) copies byte JA of IA to J of IX
    DCB    "cbyt_",0,0,0,8,0,0,255
cbyt_
    MOV    ip,sp
    STMDB  sp!,{R0-R4,fp,ip,lr,pc}
    SUB    fp,ip,#4
    MOV    ip,R2      ;store ans in IX
    B      ws5
;
    EXPORT mcbyt_;(IA,JA,IX,J,NBITS) => IW with byte at J replaced by JA of IA
    DCB    "mcbyt_",0,0,8,0,0,255
mcbyt_
    MOV    ip,sp
    STMDB  sp!,{R0-R4,fp,ip,lr,pc}
    SUB    fp,ip,#4
    MOV    ip,#0
ws5 LDR    lr,[R0]     ;IA
    LDR    R1,[R1]     ;JA
    LDR    R0,[R2]     ;IX
    LDR    R3,[R3]     ;J
    LDR    R2,[fp,#4]  ;address of NBITS
    LDR    R2,[R2]     ;NBITS
    MOV    R4,#-1
    BIC    R4,R4,R4,LSL R2;mask
    SUBS   R1,R1,#1    ;JA-1
    ANDGE  lr,R4,lr,LSR R1 ;get byt of IA
    SUBGES R3,R3,#1    ;J-1
    BICGE  R0,R0,R4,LSL R3 ;mask byt
    ORRGE  R0,R0,lr,LSL R3 ;insert byt
    CMP    ip,#0       ;if 'CBYT' then
    STRGT  R0,[ip]     ;store answer
    LDMDB  fp,{R4,fp,sp,pc} ;return
    END
;
    TTL    CCMMPY
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
F6  FN     6
F5  FN     5
F4  FN     4
F3  FN     3
F2  FN     2
F1  FN     1
F0  FN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT ccmmpy_;(M,N,X11,X12,X21,Y1,Y2,Z1,Z2)  Zi = + X'ijYj
    DCB    "ccmmpy_",0,8,0,0,255
ccmmpy_
    MOV    ip,sp
    STMDB  sp!,{R0-R9,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R0,[R0]     ;m
    LDR    R1,[R1]     ;n
    CMP    R0,#0
    CMPGT  R1,#0
    LDMLEDB fp,{R4-R9,fp,sp,pc} ;return
    STFE   F4,[sp,#-12]!
    STFE   F5,[sp,#-12]!
    STFE   F6,[sp,#-12]!
    LDMIB  fp,{R4-R8}  ;arg addresses
    SUB    R3,R3,R2    ; Xj step
    SUB    R4,R2,R4
    MLA    R4,R3,R1,R4 ;-Xi step
    SUB    R6,R6,R5    ; Yj step
    SUB    R8,R8,R7    ; Zi step
lp1 MOV    ip,R1       ;j count
    MOV    R9,R5       ;(Y1)
    MVFE   F0,#0       ;R(Zi)
    MVFE   F1,F0       ;I(Zi)
lp2 LDFS   F2,[R9]     ;R(Yj)
    LDFS   F3,[R9,#4]  ;I(Yj)
    ADD    R9,R9,R6
    LDFS   F4,[R2]     ;R(Xij)
    LDFS   F5,[R2,#4]  ;I(Xij)
    ADD    R2,R2,R3
    MUFE   F6,F2,F5    ;R(y)I(x)
    MUFE   F2,F4,F2    ;R(y)R(x)
    MUFE   F5,F3,F5    ;I(y)I(x)
    MUFE   F3,F4,F3    ;I(y)R(x)
    ADFE   F2,F2,F5    ;R(z)
    SUFE   F3,F3,F6
    ADFE   F0,F0,F2
    ADFE   F1,F1,F3
    SUBS   ip,ip,#1
    BGT    lp2         ;loop over j
    STFS   F0,[R7]     ;store Zi
    STFS   F1,[R7,#4]
    ADD    R7,R7,R8
    SUB    R2,R2,R4
    SUBS   R0,R0,#1
    BGT    lp1          ;loop over i
    LDFE   F6,[sp],#12
    LDFE   F5,[sp],#12
    LDFE   F4,[sp],#12
    LDMDB  fp,{R4-R9,fp,sp,pc} ;return
    END
;
    TTL    CCOPIV
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT ccopiv_;(FR,TO,NCH) copies CHARACTER FR to TO in reverse order
    DCB    "ccopiv_",0,8,0,0,255
ccopiv_
    MOV    ip,sp
    STMDB  sp!,{R0-R2,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R2,[R2]     ;NCH
    CMP    R2,#0
    LDMLEDB fp,{fp,sp,pc} ;return if NCH is not positive
    ADD    R3,R0,R2    ;(FR(NCH+1))
    ADD    R2,R1,R2    ;(TO(NCH+1))
wy1 LDRB   ip,[R0],#1  ;first character of FR
    LDRB   lr,[R3,#-1]!;last character of FR
    CMP    R3,R0
    STRB   lr,[R1],#1  ;to first character of TO
    STRB   ip,[R2,#-1]!;to last character of TO
    BGT    wy1
    LDMDB  fp,{fp,sp,pc} ;return
    END
;
    TTL    CCOPYL
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R2  RN     2
R1  RN     1
R0  RN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT ccopyl_;(FR,TO,NCH) copies CHARACTER FR to TO starting at 1
    DCB    "ccopyl_",0,8,0,0,255
ccopyl_
    MOV    ip,sp
    STMDB  sp!,{R0-R2,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R2,[R2]    ;nch
yy1 SUBS   R2,R2,#1
    LDRGEB ip,[R0],#1
    STRGEB ip,[R1],#1
    BGT    yy1
    LDMDB  fp,{fp,sp,pc} ;return
    END
;
    TTL    CCOPYR
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R2  RN     2
R1  RN     1
R0  RN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT ccopyr_;(FR,TO,NCH) copies CHARACTER FR to TO starting at NCH
    DCB    "ccopyr_",0,8,0,0,255
ccopyr_
    MOV    ip,sp
    STMDB  sp!,{R0-R2,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R2,[R2]     ;nch
wy2 SUBS   R2,R2,#1
    LDRGEB ip,[R0,R2]
    STRGEB ip,[R1,R2]
    BGT    wy2
    LDMDB  fp,{fp,sp,pc} ;return
    END
;
    TTL    CCOSUB
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   slate__,COMMON,NOINIT
    %      160
    AREA   |C$$code|,CODE,READONLY
    EXPORT ccosub_;(FROM,NFR,TO,JL,JR,TOKEN,SUB) copy with string substitution
    DCB    "ccosub_",0,8,0,0,255
ccosub_
    MOV    ip,sp
    STMDB  sp!,{R0-R9,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDMIB  fp,{R4-R9,ip} ;get addresses of JR,TOKEN,SUB & lengths of 4 strings
    LDR    R1,[R1]       ;NFR
    LDR    R3,[R3]       ;JL
    MOV    R7,#0
    STMDB  sp!,{R3,R7}   ;save JL and flag on stack
    LDR    R4,[R4]       ;JR
    SUB    R2,R2,#1      ;(TO)-1
lp1 MOV    R7,#0         ;position in TOKEN
lp2 SUBS   R1,R1,#1
    BLT    fin           ;no more characters to read
    LDRB   lr,[R0],#1    ;character of FROM
    LDRB   R8,[R5,R7]    ;character of TOKEN
    CMP    lr,R8
    BNE    nott
    ADD    R7,R7,#1
    CMP    R7,R9
    BLT    lp2           ;loop checking for all of TOKEN
;          found token, substitute SUB
    STR    R7,[sp,#4]    ;flag on stack
    MOV    R7,#0         ;count of SUB
lp3 LDRB   lr,[R6,R7]
    STRB   lr,[R2,R3]
    ADD    R7,R7,#1
    ADD    R3,R3,#1
    CMP    R3,R4         ;check if TO is full
    BGT    done
    CMP    R7,ip
    BLT    lp3           ;loop over SUB
    B      lp1           ;go get more input
nott;      not part of token
    CMP    R7,#0         ;check we have not lost part of token
    BGT    fn1
    STRB   lr,[R2,R3]
    ADD    R3,R3,#1
    CMP    R3,R4         ;check if TO is full
    BLE    lp2
done;                all done, now tidy up
    MOVGT  R4,#1         ;flag TO is overfull
    MOVLE  R4,#0         ;flag TO is not overfull
    LDMIA  sp!,{R0,R5}   ;restore JL and substitution flag
    SUB    R2,R3,R0      ;# characters stored
    LDR    ip,slpt
    STMIA  ip,{R2-R5}    ;store ND,NE,NF,NG
    LDMDB  fp,{R4-R9,fp,sp,pc} ;return
fin;        no more characters to read, check not in middle of token
    CMP    R7,#0
    BEQ    done
fn1 LDRB   lr,[R5]
    STRB   lr,[R2,R3]    ;store first character of token
    ADD    R3,R3,#1
    CMP    R3,R4         ;check if TO is full
    BGT    done
    SUB    R7,R7,#1
    SUB    R0,R0,R7
    ADD    R1,R1,R7      ;restore pointers of FROM
    B      lp1
slpt DCD    slate__
    END
;
    TTL    CCUMPY
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
F6  FN     6
F5  FN     5
F4  FN     4
F3  FN     3
F2  FN     2
F1  FN     1
F0  FN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT ccumpy_;(N,U11,U12,U22,Y1,Y2,Z1,Z2)    Zj =  sum(U'jk * Yk) k=j,n
    DCB    "ccumpy_",0,8,0,0,255
ccumpy_
    MOV    ip,sp
    STMDB  sp!,{R0-R9,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R0,[R0]     ;N
    CMP    R0,#0
    LDMLEDB fp,{R4-R9,fp,sp,pc} ;return if N<1
    STFE   F4,[sp,#-12]!
    STFE   F5,[sp,#-12]!
    STFE   F6,[sp,#-12]!
    LDMIB  fp,{R5-R8}  ;arg addresses
    SUB    ip,R3,R1    ; Ujj step
    SUB    R3,R2,R1    ; U.k step
    SUB    R6,R6,R5    ; Yk step
    SUB    R8,R8,R7    ; Zj step
lp1 MOV    R4,R0       ;k-count (=N-J+1)
    MVFS   F0,#0       ;initialise R(Zj)
    MVFS   F1,F0       ;initialise I(Zj)
    MOV    R2,R1       ;(j,k) = (j,j)
    MOV    R9,R5       ;(k)
lp2 LDFS   F2,[R9]     ;R(Yj)
    LDFS   F3,[R9,#4]  ;I(Yj)
    ADD    R9,R9,R6
    LDFS   F4,[R2]     ;R(Xij)
    LDFS   F5,[R2,#4]  ;I(Xij)
    ADD    R2,R2,R3
    MUFE   F6,F2,F5    ;R(y)I(x)
    MUFE   F2,F4,F2    ;R(y)R(x)
    MUFE   F5,F3,F5    ;I(y)I(x)
    MUFE   F3,F4,F3    ;I(y)R(x)
    ADFE   F2,F2,F5    ;R(z)
    SUFE   F3,F3,F6
    ADFE   F0,F0,F2    ;R(sum)
    ADFE   F1,F1,F3    ;I(sum)
    SUBS   R4,R4,#1
    BGT    lp2         ;loop over k
    STFS   F0,[R7]     ;store R(Zj)
    STFS   F1,[R7,#4]  ;store I(Zj)
    ADD    R7,R7,R8
    ADD    R1,R1,ip
    ADD    R5,R5,R6
    SUBS   R0,R0,#1
    BGT    lp1         ;loop over j
    LDFE   F6,[sp],#12
    LDFE   F5,[sp],#12
    LDFE   F4,[sp],#12
    LDMDB  fp,{R4-R9,fp,sp,pc} ;return
    END
;
    TTL    CENVIR
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
XOS_ReadVarVal  EQU &20023
    AREA   slate__,COMMON,NOINIT
    %      160
    AREA   |C$$code|,CODE,READONLY
    EXPORT cenvir_;(FROM,NFR,TO,JL,JR,IFLAG) copy with global variable subs.
    DCB    "cenvir_",0,8,0,0,255
cenvir_
    MOV    ip,sp
    STMDB  sp!,{R0-R9,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDMIB  fp,{R4-R5}    ;get addresses of JR and IFLAG
    LDR    R1,[R1]       ;NFR
    LDR    R3,[R3]       ;JL
    LDR    R4,[R4]       ;JR
    LDR    R5,[R5]       ;IFLAG
    SUB    R2,R2,#1      ;(TO)-1
    MOV    ip,R3         ;save JL
    MOV    R9,#0         ;substitution flag
    MOV    R8,#0         ;error flag (NF)
lp1 SUBS   R1,R1,#1
    BLT    done          ;no more characters to read
    LDRB   lr,[R0],#1    ;character of FROM
    CMP    lr,#"$"
    BEQ    dollar        ;found possible environment variable
pt1 STRB   lr,[R2,R3]
    ADD    R3,R3,#1
pt2 CMP    R3,R4         ;check if TO is full
    BLE    lp1
done;                all done, now tidy up
    ORRGT  R8,R8,#4      ;flag TO is overfull
don1 SUB    R2,R3,ip      ;# characters stored
    LDR    ip,slpt
    STMIA  ip,{R2,R3,R8,R9} ;store ND,NE,NF,NG
    LDMDB  fp,{R4-R9,fp,sp,pc} ;return
dollar;     found dollar
    CMP    R1,#1
    LDRGEB R7,[R0]       ;check next character
    CMPGE  R7,#"{"
    BNE    pt1           ;not "{"
    ADD    R0,R0,#1
    SUB    R1,R1,#1
    LDR    R6,slpt
lp2 SUBS   R1,R1,#1
    ORRLT  R8,R8,#2      ;flag for no "}"
    BLT    don1
    LDRB   lr,[R0],#1
    SUBS   R7,lr,#"}"
    STREQ  R7,[R6]       ;null terminator
    STRNE  lr,[R6],#1    ;transfer to temp
    BNE    lp2
    STMFD  sp!,{R0-R4}   ;save registers
    LDR    R0,slpt       ;pointer to name
    ADD    R1,R2,R3      ;place for output
    SUB    R2,R4,R3
    ADD    R2,R2,#1      ;length of O/P
    MOV    R3,#0
    MOV    R4,#0
    SWI    XOS_ReadVarVal;get variable
    MOVS   lr,R2         ;length of variable
    LDMFD  sp!,{R0-R4}   ;restore variables
    BVS    badvar
    BEQ    badvar
    ADD    R3,R3,lr
    MOV    R9,#1         ;flag variable transferred
    B      pt2
badvar;    no variable stored
    ORR    R8,R8,#1      ;flag not found
    CMP    R5,#0
    BEQ    lp1           ;skip if IFLAG=0
    LDR    lr,slpt
    SUB    lr,R6,lr      ;length of variable without ${}
    ADD    lr,lr,#2      ;length of variable without $
    SUB    R0,R0,lr
    ADD    R1,R1,lr      ;restore I/P buffer
    B      pt2
slpt DCD    slate__
    END
;
    TTL    CEQINV
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R0  RN     0
R3  RN     3
R4  RN     4
R5  RN     5
R6  RN     6
R7  RN     7
R8  RN     8
    AREA   |C$$code|,CODE,READONLY
    EXPORT ceqinv_;(N,A,IDIM,IR,IFAIL,K,B) sets A=1/A, finds X=B/A
    IMPORT cfact_
    IMPORT cfeqn_
    IMPORT cfinv_
    DCB    "ceqinv_",0,8,0,0,255
ceqinv_
    MOV    ip,sp
    STMDB  sp!,{R0-R8,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDMIB  fp,{R4,R7,R8}   ;addresses of IFAIL,K,B
    SUB    sp,sp,#12       ;space for DET and JFAIL
    MOV    R5,sp           ;address for DET
    ADD    R6,R5,#8        ;address for JFAIL
    STMFD  sp!,{R4-R6}     ;addresses of IFAIL,DET,JFAIL
    BL     cfact_
    ADD    sp,sp,#24       ;restore stack
    LDMIA  sp,{R0-R3}      ;restore N,A,IDIM,R
    LDR    ip,[R4]
    CMP    ip,#0           ;test IFAIL
    LDMNEDB fp,{R4-R8,fp,sp,pc} ;return
    STMFD   sp!,{R7,R8}    ;if OK, store addresses of K,B
    BL     cfeqn_          ;call CFEQN
    ADD    sp,sp,#8        ;and restore stack
    LDMIA  sp,{R0-R3}     ;restore N,A,IDIM,R
    BL     cfinv_          ;call CFINV if OK
    LDMDB  fp,{R4-R8,fp,sp,pc} ;return
    END
;
    TTL    CEQN
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R0  RN     0
R3  RN     3
R4  RN     4
R5  RN     5
R6  RN     6
R7  RN     7
R8  RN     8
    AREA   |C$$code|,CODE,READONLY
    EXPORT ceqn_;(N,A,IDIM,IR,IFAIL,K,B) solves X=B/A, A is any non-singular matrix
    IMPORT cfact_
    IMPORT cfeqn_
    DCB    "ceqn_",0,0,0,8,0,0,255
ceqn_
    MOV    ip,sp
    STMDB  sp!,{R0-R8,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDMIB  fp,{R4,R7,R8}   ;addresses of IFAIL,K,B
    SUB    sp,sp,#12        ;space for DET and JFAIL
    MOV    R5,sp           ;address for DET
    ADD    R6,R5,#8        ;address for JFAIL
    STMFD  sp!,{R4-R6}     ;addresses of IFAIL,DET,JFAIL
    BL     cfact_
    ADD    sp,sp,#24       ;restore stack
    LDR    ip,[R4]         ;get IFAIL
    CMP    ip,#0
    LDMEQFD sp!,{R0-R3}    ;restore N,A,IDIM,R
    STMEQFD sp!,{R7,R8}    ;if OK, store addresses of K,B
    BLEQ   cfeqn_          ;call CFEQN
    LDMDB  fp,{R4-R8,fp,sp,pc} ;return
    END
;
    TTL    CFACT
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
F2  FN     2
F3  FN     3
F4  FN     4
F5  FN     5
F6  FN     6
F7  FN     7
    AREA   |C$$code|,CODE,READONLY
    EXPORT cfact_;(N,A,IDIM,IR,IFAIL,DET,JFAIL) set A and R for DFEQN and DFINV
    DCB    "cfact_",0,0,8,0,0,255
cfact_
    MOV    ip,sp
    STMDB  sp!,{R0-R9,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R0,[R0]          ;N
    LDR    R2,[R2]          ;IDIM
    CMP    R0,#1
    CMPGE  R2,R0
    LDRLT  R1,[fp,#4]       ;address of IFAIL
    MOVLT  R0,#1
    STRLT  R0,[R1]
    LDMLTDB  fp,{R4-R9,fp,sp,pc} ;return IFAIL=1 if dimensions bad
    STFE   F7,[sp,#-12]!    ;save floating registers
    STFE   F6,[sp,#-12]!
    STFE   F5,[sp,#-12]!
    STFE   F4,[sp,#-12]!
;         initialise variables
    MVFS   F6,#1            ;DET=1
    MVFS   F7,#0
    MOV    ip,#0            ;initialise JFAIL
    SUB    R4,R1,#8         ;(J-1,J) J=1
    MOV    R5,#0            ;J="1"
;         main loop over J=1,N
lpj MOV    R9,#0            ;max |pivot| value
    MOV    R6,#-1           ;initialise K
    SUB    R7,R0,R5         ;I count (=N-J+1)
    ADD    R8,R4,#8         ;(I,J) I=J
wl1 LDR    lr,[R8],#4       ;R(Aij)
    BIC    lr,lr,#&80000000
    CMP    lr,R9
    MOVGT  R9,lr            ;find maximum
    SUBGT  R6,R0,R7         ;set K to index of max
    LDR    lr,[R8],#4       ;I(Aij)
    BIC    lr,lr,#&80000000
    CMP    lr,R9
    MOVGT  R9,lr            ;find maximum
    SUBGT  R6,R0,R7         ;set K to index of max
    SUBS   R7,R7,#1
    BGT    wl1              ;loop over I=J,N
    CMP    R6,R5            ;K should be >= J
    BLT    fail             ;singular if not
;         swap pivot columns if K>J
    MNFGTE F6,F6            ;change DET sign
    MNFGTE F7,F7
    ADDGT  R7,R6,R5,LSL#12  ;pack J,K
    STRGT  R7,[R3,#4]!      ;store in IR
    ADDGT  R7,R1,R5,LSL#3   ;(j,1)
    ADDGT  R8,R1,R6,LSL#3   ;(k,1)
    MOVGT  R6,R0            ;counter
wl2 LDRGT  R9,[R7,#4]
    LDRGT  lr,[R8,#4]
    STRGT  R9,[R8,#4]
    STRGT  lr,[R7,#4]
    LDRGT  R9,[R7]
    LDRGT  lr,[R8]
    STRGT  R9,[R8],R2,LSL#3
    STRGT  lr,[R7],R2,LSL#3 ;swap columns
    SUBGTS R6,R6,#1
    BGT    wl2              ;loop over rows
    LDFS   F0,[R4,#8]!      ;R(Ajj)
    LDFS   F1,[R4,#4]       ;I(Ajj)
    MUFE   F2,F0,F6         ;R(a)R(d)
    MUFE   F3,F1,F7         ;I(a)I(d)
    MUFE   F4,F0,F7         ;R(a)I(d)
    MUFE   F5,F1,F6         ;I(a)R(d)
    SUFE   F6,F2,F3         ;DET=DET*A(J,J)
    ADFE   F7,F4,F5
    MUFE   F2,F0,F0
    MUFE   F3,F1,F1
    ADFE   F2,F2,F3         ;|Ajj|^2
    DVFE   F0,F0,F2         ;1/Ajj
    DVFE   F1,F1,F2
    MNFE   F1,F1
    STFS   F0,[R4]          ;A(J,J)=1/A(J,J)
    STFS   F1,[R4,#4]
;         check DET is within bounds
    ABSS   F0,F6
    ABSS   F1,F7
    CMF    F0,F1
    MVFLTS F0,F1
    LDFS   F1,CSMA
    CMF    F0,F1
    MVFLEE F6,#0            ;too small, set to 0
    MVFLEE F7,#0
    CMPLES ip,#0
    MOVEQ  ip,#-1           ;set jfail = -1
    LDFS   F1,CBIG
    CMF    F0,F1
    MVFGEE F6,#1            ;too big, set to 1
    MVFGEE F7,#0
    CMPGES ip,#0
    MOVEQ  ip,#1            ;set jfail = +1
;         now factorise matrix
    ADD    R5,R5,#1         ;virtual increment j
    SUBS   R6,R0,R5         ;K count = N-J
    BLE    finish           ;done when J=N
    ADD    R7,R4,R2,LSL#3   ;(J,K) K=J+1
    ADD    R8,R7,#8         ;(K,J+1) K=J+1
;         loop K = J+1 to N
wl3 LDFS   F1,[R7,#4]
    LDFS   F0,[R7],#-8      ;-s11=A(J,K) : R7=(I,K) I=J-1
    SUB    lr,R4,R2,LSL#3   ;(J,I) I=J-1
    SUBS   R9,R5,#1         ;I-count
;         loop I = J-1,1,-1
wl4 LDFGTS F3,[R7,#4]       ;I(Aik)
    LDFGTS F2,[R7],#-8      ;R(Aik) : (I-1,K)
    LDFGTS F4,[lr]          ;R(Aji)
    MUFGTE F5,F2,F4         ;R.R
    SUFGTE F0,F0,F5         ;-s11=-s11-Aik.Aji
    MUFGTE F5,F3,F4         ;I.R
    SUFGTE F1,F1,F5
    LDFGTS F4,[lr,#4]       ;I(Aji)
    SUBGT  lr,lr,R2,LSL#3   ;(J,I-1)
    MUFGTE F5,F2,F4         ;R.I
    SUFGTE F1,F1,F5
    MUFGTE F5,F3,F4         ;I.I
    ADFGTE F0,F0,F5
    SUBS   R9,R9,#1
    BGT    wl4              ;loop over I
    LDFS   F2,[R4]          ;R(Ajj)
    LDFS   F3,[R4,#4]       ;I(Ajj)
    MUFE   F4,F0,F2         ;R.R
    MUFE   F5,F1,F3         ;I.I
    SUFE   F4,F4,F5
    ADD    R7,R7,R5,LSL#3   ;restore (J,K)
    STFS   F4,[R7]          ;R(Ajk) = R(-s11.Ajj)
    MUFE   F4,F0,F3         ;R.I
    MUFE   F5,F1,F2         ;I.R
    ADFE   F5,F5,F4
    STFS   F5,[R7,#4]       ;I(Ajk) = I(-s11.Ajj)
    LDFS   F0,[R8]          ;-s12=A(K,J+1)
    LDFS   F1,[R8,#4]
    ADD    R9,R4,R2,LSL#3   ;(I,J+1) I=J
    SUB    R0,R8,R2,LSL#3   ;(K,I) I=J
    MOV    lr,R5            ;I-count
;           loop over I=J,1,-1
wl5 LDFS   F3,[R9,#4]       ;I(Ai,j+1)
    LDFS   F2,[R9],#-8      ;R(Ai,j+1) : (I-1,J+1)
    LDFS   F4,[R0]          ;R(Aki)
    MUFE   F5,F2,F4         ;R.R
    SUFE   F0,F0,F5         ;-s12=-s12-A(i,j+1).Aki
    MUFE   F5,F3,F4         ;I.R
    SUFE   F1,F1,F5
    LDFS   F4,[R0,#4]       ;I(Aki)
    SUB    R0,R0,R2,LSL#3   ;(K,I-1)
    MUFE   F5,F2,F4         ;R.I
    SUFE   F1,F1,F5
    MUFE   F5,F3,F4         ;I.I
    ADFE   F0,F0,F5
    SUBS   lr,lr,#1
    BGT    wl5              ;loop over I
    ADD    R7,R7,R2,LSL#3   ;(J,K+1)
    STFS   F0,[R8],#4
    STFS   F1,[R8],#4       ;A(K,J+1)=-s12 : (K+1,J+1)
    SUBS   R6,R6,#1
    BGT    wl3              ;loop over K
    LDR    R0,[sp,#48]
    LDR    R0,[R0]          ;restore R0 to N
    ADD    R4,R4,R2,LSL#3   ;(J,J+1)
    B      lpj              ;loop over J
fail;    singular matrix, IFAIL (R6) =-1
    MVFS   F6,#0            ;determinant is zero
    MVFS   F7,#0
    MOV    ip,#0            ;and JFAIL=0
finish;         done, so tidy up
    LDR    R7,[sp,#60]      ;address of IR
    SUB    R3,R3,R7         ;length of IR
    STR    R3,[R7]          ;store last IR used
    LDMIB  fp,{R7,R8,R9}    ;addresses of IFAIL,DET,JFAIL
    STR    R6,[R7]          ;store IFAIL
    STFS   F6,[R8]          ;store DET
    STFS   F7,[R8,#4]
    STR    ip,[R9]          ;store JFAIL
    LDFE   F4,[sp],#12      ;restore floating registers
    LDFE   F5,[sp],#12
    LDFE   F6,[sp],#12
    LDFE   F7,[sp],#12
    LDMDB  fp,{R4-R9,fp,sp,pc} ;return
CSMA DCFS  1.0E-19
CBIG DCFS  1.0E+19
    END
;
    TTL    CFEQN
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
F2  FN     2
F3  FN     3
F4  FN     4
F5  FN     5
F6  FN     6
F7  FN     7
    AREA   |C$$code|,CODE,READONLY
    EXPORT cfeqn_;(N,A,IDIM,IR,K,B) solves X=B/A, A prepared by CFACT
    DCB    "cfeqn_",0,0,8,0,0,255
cfeqn_
    MOV    ip,sp
    STMDB  sp!,{R0-R9,fp,ip,lr,pc}
    SUB    fp,ip,#4
;         initialise variables
    LDR    R0,[R0]         ;N
    LDR    R2,[R2]         ;IDIM
    LDMIB  fp,{R4,R5}      ;extra arg addresses
    LDR    R4,[R4]         ;K
    CMP    R0,#1
    CMPGE  R4,#1
    CMPGE  R2,R0
    LDMLTDB fp,{R4-R9,fp,sp,pc} ;return if N<1 or IDIM<N or K<1
    STFE   F7,[sp,#-12]!    ;save floating registers
    STFE   F6,[sp,#-12]!
    STFE   F5,[sp,#-12]!
    STFE   F4,[sp,#-12]!
;         first do row swapping
    LDR    R7,[R3]
    ADD    R7,R7,R3        ;last swap entry
    CMP    R3,R7
    BGE    wm3             ;skip if none
;         loop over entries
wm1 LDR    R8,[R3,#4]!
    MOV    R9,R8,LSR#12    ;I
    BIC    R8,R8,R9,LSL#12 ;J
    ADD    R9,R5,R9,LSL#3  ;(I,1)
    ADD    R8,R5,R8,LSL#3  ;(J,1)
    MOV    lr,R4           ;L count
;         loop over L=1,K
wm2 LDR    R6,[R8,#4]      ;swap columns
    LDR    ip,[R9,#4]
    STR    R6,[R9,#4]
    STR    ip,[R8,#4]
    LDR    R6,[R8]
    LDR    ip,[R9]
    STR    R6,[R9],R2,LSL#3
    STR    ip,[R8],R2,LSL#3
    SUBS   lr,lr,#1
    BGT    wm2             ;loop over L rows
    CMP    R3,R7
    BLT    wm1             ;loop over entries
;         loop over columns of B (L=1,K)
wm3 SUB    R8,R5,#8        ;(I-1,L) I=1
    SUB    R7,R1,R2,LSL#3  ;(I,I-1) I=1
    MOV    R9,R0           ;I count (=N)
;         loop over I=1,N
wm4 LDFS   F0,[R8,#8]!     ;-s21=B(I,L)
    LDFS   F1,[R8,#4]
    SUBS   lr,R0,R9        ;J count (=I-1)
    ADDGT  R6,R1,lr,LSL#3  ;(I,J) J=1
    MOVGT  ip,R5           ;(J,L) J=1
;         loop over J=1,I-1
wm5 LDFGTS F2,[R6]         ;R(Aij)
    LDFGTS F3,[R6,#4]      ;I(Aij)
    ADDGT  R6,R6,R2,LSL#3  ;(I,J+1)
    LDFGTS F4,[ip],#4      ;R(Bjl)
    LDFGTS F5,[ip],#4      ;I(Bjl) : (J+1,L)
    MUFGTE F6,F2,F4        ;R(a)R(b)
    MUFGTE F7,F3,F5        ;I(a)I(b)
    SUFGTE F0,F0,F6
    ADFGTE F0,F0,F7
    MUFGTE F6,F2,F5        ;R(a)I(b)
    MUFGTE F7,F3,F4        ;I(a)R(b)
    SUFGTE F1,F1,F6
    SUFGTE F1,F1,F7        ;-s21=-s21-A(I,J)*B(J,L)
    SUBGTS lr,lr,#1
    BGT    wm5             ;loop over J
    ADD    R7,R7,R2,LSL#3  ;(I,I)
    LDFS   F2,[R7],#4
    LDFS   F3,[R7],#4      ;A(I,I) : (I+1,I)
    MUFE   F4,F0,F2
    MUFE   F5,F1,F3
    SUFE   F4,F4,F5
    STFS   F4,[R8]         ;R(Bil) = -R(Aii*s21)
    MUFE   F4,F0,F3
    MUFE   F5,F1,F2
    ADFE   F4,F4,F5
    STFS   F4,[R8,#4]      ;I(Bil) = -I(Aii*s21)
    SUBS   R9,R9,#1
    BGT    wm4             ;loop over I
    SUBS   R9,R0,#1        ;I count (N-1)
    BEQ    wm8
;         loop over I=N-1,1,-1
wm6 LDFS   F0,[R8,#-8]!    ;-s22=B(I,L)
    LDFS   F1,[R8,#4]
    SUB    R6,R0,R9        ;J count (=N-I)
    SUB    R7,R7,#8        ;(I+1,N)
    SUB    lr,R7,#8        ;(I,J) J=N
    ADD    ip,R5,R0,LSL#3  ;(J+1,L) J=N
;         loop over J=N,I+1,-1
wm7 LDFS   F2,[lr]         ;R(Aij)
    LDFS   F3,[lr,#4]      ;I(Aij)
    SUB    lr,lr,R2,LSL#3  ;(I,J-1)
    LDFS   F4,[ip,#-8]!    ;R(Bjl)
    LDFS   F5,[ip,#4]      ;I(Bjl)
    MUFGTE F6,F2,F4        ;R(a)R(b)
    MUFGTE F7,F3,F5        ;I(a)I(b)
    SUFGTE F0,F0,F6
    ADFGTE F0,F0,F7
    MUFGTE F6,F2,F5        ;R(a)I(b)
    MUFGTE F7,F3,F4        ;I(a)R(b)
    SUFGTE F1,F1,F6
    SUFGTE F1,F1,F7        ;-s22=-s22-A(I,J)*B(J,L)
    SUBS   R6,R6,#1
    BGT    wm7             ;loop over J
    STFS   F0,[R8]         ;B(I,L)=-s22
    STFS   F1,[R8,#4]
    SUBS   R9,R9,#1
    BGT    wm6             ;loop over I
wm8 ADD    R5,R5,R2,LSL#3  ;(1,L+1)
    SUBS   R4,R4,#1
    BGT    wm3             ;loop over L
    LDFE   F4,[sp],#12      ;restore floating registers
    LDFE   F5,[sp],#12
    LDFE   F6,[sp],#12
    LDFE   F7,[sp],#12
    LDMDB  fp,{R4-R9,fp,sp,pc} ;return
    END
;
    TTL   CFFT
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
F0  FN    0
F1  FN    1
F2  FN    2
F3  FN    3
F4  FN    4
F5  FN    5
F6  FN    6
F7  FN    7
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 cfft_  ;(A,MSIGN) Complex Fast Fourier Transform
;
    DCB    "cfft_",0,0,0,8,0,0,255
cfft_
    MOV    ip,sp
    STMDB  sp!,{R0,R1,R4-R9,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R1,[R1]       ;MSIGN
    MOVS   R2,R1
    LDMEQDB fp,{R4-R9,fp,sp,pc} ;return if MSIGN=0
    STFE   F4,[sp,#-12]!
    STFE   F5,[sp,#-12]!
    STFE   F6,[sp,#-12]!
    STFE   F7,[sp,#-12]!
    RSBLT  R2,R1,#0      ;M=IABS(MSIGN)
    MOV    R3,#1
    MOV    R3,R3,LSL R2  ;N=2**M
    MOV    R4,R3,LSR#1   ;NV2=N/2
    SUB    R5,R3,#1      ;NM1=N-1
    ADD    R5,R0,R5,LSL#3;[A(N)]
    MOV    R6,R0         ;J=1
    MOV    R7,R0         ;I=1
lp1 CMP    R7,R6
;        if I<J swap A(I) for A(J)
    LDMLTIA R6,{R8,R9}
    LDMLTIA R7,{ip,lr}
    STMLTIA R7,{R8,R9}
    STMLTIA R6,{ip,lr}
    MOV    R8,R4         ;K=NV2
pt1 ADD    ip,R0,R8,LSL#3
    CMP    ip,R6         ;IF(K.LT.J) THEN
    SUBLE  R6,R6,R8,LSL#3;  J=J-K
    MOVLE  R8,R8,LSR#1   ;  K=K/2
    BLE    pt1           ;  GO TO pt1
    ADD    R6,R6,R8,LSL#3;J=J+K
    ADD    R7,R7,#8      ;I=I+1
    CMP    R7,R5
    BLT    lp1           ;loop over I=1,NM1
;
    MOV    R7,R0         ;I=1
lp2 LDFS   F0,[R7,#8]
    LDFS   F1,[R7,#12]   ;T=A(I+1)
    LDFS   F2,[R7]
    LDFS   F3,[R7,#4]    ;A(I)
    SUFS   F4,F2,F0
    SUFS   F5,F3,F1
    STFS   F4,[R7,#8]
    STFS   F5,[R7,#12]   ;A(I+1)=A(I)-T
    ADFS   F4,F2,F0
    ADFS   F5,F3,F1
    STFS   F4,[R7]
    STFS   F5,[R7,#4]    ;A(I)=A(I)+T
    ADD    R7,R7,#16
    CMP    R7,R5
    BLT    lp2           ;loop over I=1,N,2
;
    SUBS   R2,R2,#1      ;M=M-1
    BLE    ret           ;done if M=1
    MVFD   F0,#0         ;Cos (theta)
    CMP    R1,#0
    MVFGTD F1,#1
    MNFLTD F1,#1         ;Sin(theta) = ISIGN(1,MSIGN)
    MOV    R6,#2         ;LE=2
;
lp3 ADFD   F0,F0,#1      ;calculate Cos and Sin as theta -> theta/2
    FMLD   F0,F0,#0.5
    SQTD   F0,F0         ;C=SQRT(C*0.5+0.5)
    ADFD   F2,F0,F0
    FDVD   F1,F1,F2      ;S=AIMAG(W)/(C+C)
    MOV    R7,R6         ;LE1=LE
    ADD    R6,R7,R7      ;LE=LE1+LE1
    ADD    R8,R0,R7,LSL#3;[A(LE1+1)]
    MOV    R9,R0         ;[A(1)]
    MOV    ip,R3         ;N
;
lp4 LDFS   F6,[R8]
    LDFS   F7,[R8,#4]    ;T=A(IP)  (IP=I+LE1: I=1,N,LE)
    LDFS   F4,[R9]
    LDFS   F5,[R9,#4]    ;A(I)
    SUFS   F2,F4,F6
    SUFS   F3,F5,F7
    STFS   F2,[R8]
    STFS   F3,[R8,#4]    ;A(IP)=A(I)-T
    ADFS   F2,F4,F6
    ADFS   F3,F5,F7
    STFS   F2,[R9]
    STFS   F3,[R9,#4]    ;A(I)=A(I)+T
    ADD    R9,R9,R6,LSL#3;I=I+LE
    ADD    R8,R8,R6,LSL#3;IP=IP+LE
    SUBS   ip,ip,R6
    BGT    lp4           ;loop over I=1,N,LE
    MVFS   F2,F0
    MVFS   F3,F1         ;U=W=CMPLX(C,S)
    MOV    R1,#1         ;J='2'
;
lp5 SUB    R4,R3,R1      ;N-J+1 (for count)
    ADD    R8,R1,R7
    ADD    R8,R0,R8,LSL#3;(IP)=(I+LE1)
    ADD    R9,R0,R1,LSL#3;(I)
;
lp6 LDFS   F4,[R8]
    LDFS   F5,[R8,#4]    ;A(IP)
    FMLS   F6,F4,F2
    FMLS   F7,F5,F3
    SUFS   F6,F6,F7      ;R(T)=R(A(I)*U)
    FMLS   F7,F4,F3
    FMLS   F5,F5,F2
    ADFS   F7,F5,F7      ;I(T)=I(A(I)*U)
    LDFS   F4,[R9]       ;R(A(I))
    SUFS   F5,F4,F6
    STFS   F5,[R8]       ;R(A(IP))=R(A(I))-R(T)
    ADFS   F5,F4,F6
    STFS   F5,[R9]       ;R(A(I))=R(A(I))+R(T)
    LDFS   F4,[R9,#4]    ;I(A(I))
    SUFS   F5,F4,F7
    STFS   F5,[R8,#4]    ;I(A(IP))=I(A(I))-I(T)
    ADFS   F5,F4,F7
    STFS   F5,[R9,#4]    ;I(A(I))=I(A(I))+I(T)
    ADD    R8,R8,R6,LSL#3;(IP)=(IP+LE)
    ADD    R9,R9,R6,LSL#3;(I)=(I+LE)
    SUBS   R4,R4,R6
    BGT    lp6           ;loop over I=J,N,LE
    ADD    R1,R1,#1
    CMP    R1,R7         ;check for 'J'=LE1
    FMLLTS F4,F2,F0
    FMLLTS F5,F3,F1
    FMLLTS F6,F3,F0
    FMLLTS F7,F2,F1
    SUFLTS F2,F4,F5
    ADFLTS F3,F6,F7      ;U=U*W
    BLT    lp5           ;loop over J=2,LE1
    SUBS   R2,R2,#1
    BGT    lp3           ;loop over L=2,M
ret LDFE   F7,[sp],#12
    LDFE   F6,[sp],#12
    LDFE   F5,[sp],#12
    LDFE   F4,[sp],#12
    LDMDB  fp,{R4-R9,fp,sp,pc} 
    END
;
    TTL    CFILL
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT cfill_;(CHI,LINE,JL,JR) fills LINE(JL:JR) with copies of CHI
    DCB    "cfill_",0,0,8,0,0,255
cfill_
    MOV    ip,sp
    STMDB  sp!,{R0-R3,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    ip,[ip]     ;get length of chi
    LDR    R2,[R2]     ;JL
    LDR    R3,[R3]     ;JR
    SUB    R1,R1,#1
    ADD    R2,R2,R1    ;(LINE(JL:JL))
    ADD    R3,R3,R1    ;(LINE(JR:JR))
    MOV    lr,ip
wl1 ADD    lr,lr,#1    ;cycle over CHI
    CMP    lr,ip
    MOVGE  lr,#0       ;start at beginning of CHI
    CMP    R2,R3
    LDRLEB R1,[R0,lr]  ;get byte of CHI
    STRLEB R1,[R2],#1  ;store byte in LINE
    BLT    wl1         ;loop over bytes of LINE
    LDMDB  fp,{fp,sp,pc} ;return
    END
;
    TTL    CFINV
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
F2  FN     2
F3  FN     3
F4  FN     4
F5  FN     5
F6  FN     6
F7  FN     7
    AREA   |C$$code|,CODE,READONLY
    EXPORT cfinv_;(N,A,IDIM,IR) puts A=1/A (A prepared by CFACT)
    DCB    "cfinv_",0,0,8,0,0,255
cfinv_
    MOV    ip,sp
    STMDB  sp!,{R0-R9,fp,ip,lr,pc}
    SUB    fp,ip,#4
;         initialise variables
    LDR    R0,[R0]         ;N
    LDR    R2,[R2]         ;IDIM
;         check for trivial case: N=1
    CMP    R0,#2
    CMPGE  R2,R0           ;ensure NDIM >= N
    LDMLTDB fp,{R4-R9,fp,sp,pc} ;return
    STFE   F7,[sp,#-12]!    ;save floating registers
    STFE   F6,[sp,#-12]!
    STFE   F5,[sp,#-12]!
    STFE   F4,[sp,#-12]!
    SUB    R0,R0,#1        ;N-1
    MOV    R4,#1           ;"I-1"
    MOV    R5,R1           ;(I-1,I-1)
;         loop over I = 2,N
wn1 ADD    R6,R5,#8        ;(I,I-1)
    ADD    R5,R6,R2,LSL#3  ;(I,I)
    ADD    R7,R1,R4,LSL#3  ;(I,J) J=1
    SUB    R8,R5,R4,LSL#3  ;(J,I) J=1
;         loop over J=1,I-1
wn2 MVFS   F0,#0           ;-s31=0
    MVFS   F1,F0
    LDFS   F2,[R8]         ;s32=A(J,I)
    LDFS   F3,[R8,#4]
    SUB    ip,R7,#8        ;(K,J) K=I-1
    MOV    R9,R6           ;(I,K) K=I-1
    SUB    lr,R8,R2,LSL#3  ;(J,K) K=I-1
    SUB    R3,R5,#8        ;(K,I) K=I-1
;         loop over K=I-1,J,-1
wn3 LDFS   F5,[ip,#4]      ;I(Akj)
    LDFS   F4,[ip],#-8     ;R(Akj) : (K-1,J)
    LDFS   F6,[R9]         ;R(Aik)
    MUFE   F7,F4,F6        ;R.R
    SUFE   F0,F0,F7
    MUFE   F7,F5,F6        ;I.R
    SUFE   F1,F1,F7
    LDFS   F6,[R9,#4]      ;I(Aik)
    MUFE   F7,F4,F6        ;R.I
    SUFE   F1,F1,F7
    MUFE   F7,F5,F6        ;I.I
    ADFE   F0,F0,F7        ;-s31=-s31-A(K,J)*A(I,K)
    SUB    R9,R9,R2,LSL#3  ;(I,K-1)
    CMP    R9,R7           ;(I,K') <=> (I,J)
    LDFGES F4,[lr]         ;R(Ajk)
    LDFGES F5,[lr,#4]      ;I(Ajk)
    SUBGE  lr,lr,R2,LSL#3  ;(J,K-1)
    LDFGES F6,[R3,#4]      ;I(Aki)
    MUFGEE F7,F4,F6        ;R.I
    ADFGEE F3,F3,F7
    MUFGEE F7,F5,F6        ;I.I
    SUFGEE F2,F2,F7
    LDFGES F6,[R3],#-8     ;R(Aki) : (K-1,I)
    MUFGEE F7,F4,F6        ;R.R
    ADFGEE F2,F2,F7
    MUFGEE F7,F5,F6        ;I.R
    ADFGEE F3,F3,F7        ;s32=s32+A(J,K)*A(K,I)
    BGE    wn3             ;loop over K
    LDFS   F4,[R5]         ;R(Aii)
    LDFS   F5,[R5,#4]      ;I(Aii)
    MUFE   F6,F4,F0
    MUFE   F7,F5,F1
    SUFE   F6,F6,F7
    STFS   F6,[R7]
    MUFE   F7,F5,F0
    MUFE   F6,F4,F1
    ADFE   F6,F6,F7
    STFS   F6,[R7,#4]      ;A(I,J)=-s31*A(I,I)
    ADD    R7,R7,R2,LSL#3  ;(I,J+1)
    MNFE   F3,F3
    MNFE   F2,F2
    STFS   F2,[R8],#4      ;A(J,I)=-s32 : (J+1,I)
    STFS   F3,[R8],#4
    CMP    R7,R6           ;(I,J') <=> (I,I-1)
    BLE    wn2             ;loop over J
    ADD    R4,R4,#1        ;increment "I-1"
    CMP    R4,R0           ;compare with N-1
    BLE    wn1             ;loop over "I-1"
;
    SUB    R6,R5,R0,LSL#3  ;(I,N) I=1
    MOV    R5,R1           ;(I,1) I=1
    MOV    R4,R0           ;I count (=N-I)
;         loop over I = 1,N-1
wn4 MOV    R7,R5           ;(I,J) J=1
    ADD    R8,R1,R0,LSL#3  ;(N,J) J=1
    MOV    lr,R0           ;J count (=N-J)
;         loop over J = 1,N
wn5 MOV    ip,R8           ;(K,J) K=N
    MOV    R9,R6           ;(I,K) K=N
    CMP    lr,R4           ;compare N-J with N-I
    LDFGES F0,[R7]         ;s=A(I,J) if J<=I
    LDFGES F1,[R7,#4]
    MVFLTE F0,#0           ;s=0 if J>I
    MVFLTE F1,#0
    MOVGE  R3,R4           ;K count = N-I if J<=I
    ADDLT  R3,lr,#1        ;K count = N-J+1 if J>I
;         loop over K
wn6 LDFS   F3,[ip,#4]
    LDFS   F2,[ip],#-8     ;A(K,J) : (K-1,J)
    LDFS   F4,[R9]         ;A(I,K)
    LDFS   F5,[R9,#4]      ;A(I,K)
    SUB    R9,R9,R2,LSL#3  ;(I,K-1)
    MUFE   F6,F2,F4
    MUFE   F7,F2,F5
    ADFE   F0,F0,F6
    ADFE   F1,F1,F7
    MUFE   F6,F3,F4
    MUFE   F7,F3,F5
    ADFE   F1,F1,F6
    SUFE   F0,F0,F7
    SUBS   R3,R3,#1
    BGT    wn6             ;loop over K
    STFS   F0,[R7]         ;A(I,J)=s
    STFS   F1,[R7,#4]      ;A(I,J)=s
    ADD    R8,R8,R2,LSL#3  ;(N,J+1)
    ADD    R7,R7,R2,LSL#3  ;(I,J+1)
    SUBS   lr,lr,#1
    BGE    wn5             ;loop over J, N times
    ADD    R5,R5,#8        ;(I+1,1)
    ADD    R6,R6,#8        ;(I+1,N)
    SUBS   R4,R4,#1
    BGT    wn4             ;loop over I N-1 times
    LDFE   F4,[sp],#12     ;restore floating registers
    LDFE   F5,[sp],#12
    LDFE   F6,[sp],#12
    LDFE   F7,[sp],#12
;         now exchange columns
    LDR    R3,[sp,#12]     ;restore address of IR
    LDR    R4,[R3]
    ADD    R4,R4,R3        ;end of list
;         loop over exchanges
wn7 CMP    R4,R3
    LDMLEDB fp,{R4-R9,fp,sp,pc} ;return
    LDR    R5,[R4],#-4
    MOV    R6,R5,LSR#12    ;I
    BIC    R5,R5,R6,LSL#12 ;J
    MUL    R6,R2,R6
    MUL    R5,R2,R5
    ADD    R6,R1,R6,LSL#3  ;(1,I)
    ADD    R5,R1,R5,LSL#3  ;(1,J)
    MOV    R7,R0
wn8 LDMIA  R6,{R8,R9}      ;swap rows
    LDMIA  R5,{ip,lr}
    STMIA  R6!,{ip,lr}
    STMIA  R5!,{R8,R9}
    SUBS   R7,R7,#1
    BGE    wn8             ;loop N times
    B      wn7
    END
;
    TTL    CFIO
R0  RN 0
R1  RN 1
R2  RN 2
R3  RN 3
R4  RN 4
R5  RN 5
fp  RN 11
ip  RN 12
sp  RN 13
lr  RN 14
pc  RN 15
XOS_Find    EQU &2000D
XOS_Args    EQU &20009
XOS_GBPB    EQU &2000C
    AREA   |C$$code|,CODE,READONLY
    EXPORT cfopen_;(LUNDES,MED,NWREC,MODE,NBUF,NAME,ISTAT) open CFIO stream
    DCB    "cfopen_",0,8,0,0,255
cfopen_
    MOV    ip,sp
    STMDB  sp!,{R0-R3,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R1,[R1]          ;MED
    CMP    R1,#0
    MOVNE  lr,#1
    BNE    er1              ;MED must be zero
    LDR    R1,[fp,#20]      ;length of NAME
    SUB    sp,sp,R1
    SUB    sp,sp,#1
    BIC    sp,sp,#3         ;space for null terminated name
    LDR    R2,[fp,#8]       ;(NAME)
    MOV    lr,#0
lp1 STRB   lr,[sp,R1]       ;move CHNAME
    SUBS   R1,R1,#1
    LDRGEB lr,[R2,R1]
    BGE    lp1
    LDRB   ip,[R3]          ;get first character of CHMODE
    CMP    ip,#"a"
    ADDLT  ip,ip,#32        ;convert to lower case
    LDR    R1,[fp,#16]      ;length of MODE
    CMP    R1,#1
    LDRGTB R1,[R3,#1]       ;load "+" if it exists
    CMP    ip,#"r"
    CMPNE  ip,#"w"
    CMPNE  ip,#"a"
    BNE    er1               ;not "r", "w" or "a"
    MOV    R0,#&4F
    CMP    R1,#"+"
    MOVEQ  R0,#&CF
    MOV    R1,sp             ;pointer to name
    SWI    XOS_Find
    BVC    ok1               ;file opened correctly
    CMP    ip,#"w"
    BNE    er1               ;error because not creating file
    MOV    R0,#&8F
    MOV    R1,sp             ;pointer to name
    SWI    XOS_Find
    BVS    er1               ;can not open new file either
ok1 LDR    R2,[fp,#-28]      ;(LUNDES)
    STR    R0,[R2]           ;store file handle
    CMP    ip,#"a"           ;check for append
    MOV    R1,R0
    MOVNE  R0,#3
    MOVNE  R2,#0
    BNE    CN1
    MOV    R0,#2
    SWI    XOS_Args          ;get length of file
    MOV    R0,#1
CN1 CMP    ip,#"r"
    SWINE  XOS_Args          ;move to end of file or set extent to zero
    MOV    lr,#0
er1 LDR    R0,[fp,#12]       ;(ISTAT)
    STR    lr,[R0]           ;store ISTAT
    LDMDB  fp,{fp,sp,pc} 
;
    EXPORT cfget_;(LUNDES,MEDIUM,NWREC,NWTAK,MBUF,ISTAT) get record from file
    DCB    "cfget_",0,0,8,0,0,255
cfget_
    MOV    ip,sp
    STMDB  sp!,{R0-R4,fp,ip,lr,pc}
    SUBS   fp,ip,#4         ;clear V
    LDR    R3,[R3]          ;NWTAK
    MOVS   R3,R3,LSL#2      ;# bytes to read (clear C if >=0)
    MOVLTS R3,#0,2          ;don't let it be negative (clear C if <0)
    MOV    ip,R3            ;save it
    LDRGT  R2,[fp,#4]       ;address to read to
    LDR    R1,[R0]          ;file handle
    MOVGT  R0,#4            ;read from current pointer
    SWIGT  XOS_GBPB         ;read bytes
    MOVVS  lr,#1
    BVS    er2              ;can not read
    SUB    ip,ip,R3         ;actual # bytes read (>=0)
    LDMIB  sp,{R0,R2,R3}    ;junk, (NWREC),(NWTAK)
    MOV    R0,ip,LSR#2
    STR    R0,[R3]          ;store # words read in NWTAK
    BCS    cg1              ;skip if e-o-f found
    LDR    R2,[R2]          ;NWREC
    SUBS   lr,R2,R0         ;# extra unused words to read
    BEQ    er2
    MOVS   R0,#0,2          ;clear C
    SWI    XOS_Args         ;find file pointer
    ADD    R2,R2,lr,LSL#2   ;add extra unused length (may be negative!)
    MOV    R0,#1
    SWI    XOS_Args         ;set file pointer
    MOVCC  lr,#0
cg1 MOVCS  lr,#-1
er2 LDR    R4,[fp,#8]       ;(ISTAT)
    STR    lr,[R4]          ;store ISTAT
    LDMDB  fp,{R4,fp,sp,pc} 
;
    EXPORT cfput_;(LUNDES,MEDIUM,NWREC,MBUF,ISTAT) put record on file
    DCB    "cfput_",0,0,8,0,0,255
cfput_
    MOV    ip,sp
    STMDB  sp!,{R0-R4,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R1,[R2]          ;NWREC
    ADDS   R2,R3,#0         ;address to write from (clear V)
    MOVS   R3,R1,LSL#2      ;#bytes to write = NWREC*4
    LDRGT  R1,[R0]          ;file handle
    MOVGT  R0,#2            ;write to current file
    SWIGT  XOS_GBPB         ;write bytes
    MOVVS  lr,#1
    MOVVC  lr,#0
    LDR    R1,[fp,#4]
    STR    lr,[R1]          ;store ISTAT
    LDMDB  fp,{R4,fp,sp,pc} 
;
    IMPORT __rt_sdiv; R0 = R1/R0  (and R1=|remainder|)
    EXPORT cfsize_;(LUNDES,MEDIUM,NWREC,NRECT,ISTAT) get # records in file
    DCB    "cfsize_",0,8,0,0,255
cfsize_
    MOV    ip,sp
    STMDB  sp!,{R0-R4,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R1,[R0]          ;file handle
    MOV    R0,#2
    SWI    XOS_Args         ;find extent
    MOVVC  R0,#1
    SWIVC  XOS_Args         ;move to end of file!
cf1 MOV    lr,#1
    BVS    cf2
    LDMIB  sp,{R0,R1,R4}    ;junk, (NWREC),(NRECT)
    LDR    R0,[R1]          ;NWREC
    MOVS   R0,R0,LSL#2      ;#bytes in record (check it is positive)
    BLE    cf2
    MOV    R1,R2            ;#bytes in file
    BL     __rt_sdiv
    STR    R0,[R4]          ;store NRECT
    MOV    lr,#0
cf2 LDR    R4,[fp,#4]
    STR    lr,[R4]          ;store ISTAT
    LDMDB  fp,{R4,fp,sp,pc} 
;
    EXPORT cftell_;(LUNDES,MEDIUM,NWREC,NRECC,ISTAT) get current record number
    DCB    "cftell_",0,8,0,0,255
cftell_
    MOV    ip,sp
    STMDB  sp!,{R0-R4,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R1,[R0]          ;file handle
    MOV    R0,#0
    SWI    XOS_Args         ;find file pointer
    B      cf1              ;rest is the same as cfsize
;
    EXPORT cfseek_;(LUNDES,MEDIUM,NWREC,NRECC,ISTAT) set current record number
    DCB    "cfseek_",0,8,0,0,255
cfseek_
    MOV    ip,sp
    STMDB  sp!,{R0-R3,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R2,[R2]          ;NWREC
    LDR    R3,[R3]          ;NRECC
    MUL    R1,R2,R3
    MOVS   R2,R1,LSL#2      ;pointer = 4*NWREC*NRECC
    MOVMI  R2,#0            ;ensure not negative
    LDR    R1,[R0]          ;file handle
    MOV    R0,#1            ;to set file pointer
    SWI    XOS_Args
    MOVVS  lr,#1
    MOVVC  lr,#0
    LDR    R1,[fp,#4]
    STR    lr,[R1]          ;store ISTAT
    LDMDB  fp,{fp,sp,pc} 
;
    EXPORT cfrew_;(LUNDES,MEDIUM) rewind disc file
    DCB    "cfrew_",0,0,8,0,0,255
cfrew_
    MOV    ip,sp
    STMDB  sp!,{R0,R1,fp,ip,lr,pc}
    SUB    fp,ip,#4
    MOV    R2,#0            ;file pointer 0
    LDR    R1,[R0]          ;file handle
    MOV    R0,#1            ;to set file pointer
    SWI    XOS_Args
    LDMDB  fp,{fp,sp,pc} 
;
    EXPORT cfclos_;(LUNDES,MEDIUM) close disc file
    DCB    "cfclos_",0,8,0,0,255
cfclos_
    MOV    ip,sp
    STMDB  sp!,{R0,R1,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R1,[R0]          ;file handle
    MOV    R0,#0            ;to close the file
    SWI    XOS_Find
    LDMDB  fp,{fp,sp,pc} 
;
    EXPORT cfperm_;(IPERM) set permissions for future disc access
cfperm_
    MOV    pc,lr            ;there is no concept of different types of user
;
    EXPORT cfweof_;(LUNDES,MEDIUM,NEOF) dummy (write NEOF ends-of-file)
    DCB    "cfweof_",0,8,0,0,255
cfweof_
    MOV    ip,sp
    STMDB  sp!,{R0-R2,fp,ip,lr,pc}
    SUB    fp,ip,#4
    MOV    R0,#0
    STR    R0,[R2]          ;set NEOF=0
    LDMDB  fp,{fp,sp,pc} 
    END
;
    TTL    CFROMI
pc  RN    15
lr  RN    14
ip  RN    12
R2  RN     2
R1  RN     1
R0  RN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT cfromi_;(IPACK) -> CHARACTER*4
cfromi_
    LDR    R2,[R2]    ;I
lp1 MOVS   ip,R2,LSR#24
    MOVEQ  ip,#" "
    MOV    R2,R2,LSL#8
    SUBS   R1,R1,#1
    STRGEB ip,[R0],#1
    BGT    lp1
    MOV    pc,lr
    END
;
    TTL    CGAMMA
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
F0  FN     0
F1  FN     1
F2  FN     2
F3  FN     3
F4  FN     4
F5  FN     5
F6  FN     6
F7  FN     7
R0  RN     0
R1  RN     1
R2  RN     2
R3  RN     3
    AREA   |C$$code|,CODE,READONLY
    EXPORT cgamma_ ;(Z) COMPLEX gamma function
    EXPORT wgamma_ ;(Z) COMPLEX*16 gamma function
;
    DCB    "cgamma_",0,8,0,0,255
cgamma_
    MOV    ip,sp
    STMDB  sp!,{R0-R1,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDFS   F0,[R1]
    LDFS   F1,[R1,#4]
    MOV    ip,#0        ;flag COMPLEX*8 result needed
    B      pt1
;
    DCB    "wgamma_",0,8,0,0,255
wgamma_
    MOV    ip,sp
    STMDB  sp!,{R0-R1,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDFD   F0,[R1]
    LDFD   F1,[R1,#8]
;
pt1 CMF    F1,#0         ;IF(Y.EQ.0 .AND.
    RNDEQD F2,F0
    ABSEQD F3,F0
    CNFEQ  F3,F2         ;-ABS(X) .EQ. AINT(X)) THEN
    MVFEQD F2,#0         ;  failure
    MVFEQD F3,#0         ;  set result to 0 & return
    BEQ    res           ;ENDIF
    STFE   F4,[sp,#-12]! ;save floating registers
    STFE   F5,[sp,#-12]!
    STFE   F6,[sp,#-12]!
    STFE   F7,[sp,#-12]!
    CMF    F0,#1         ;if X.GE.1
    MVFGED F2,#1         ;F=1, V=Z
    MVFGED F3,#0
    BGE    pt2
    CMF    F0,#0         ;else if X.GE.0
    MUFGED F2,F0,F0
    MUFGED F3,F1,F1
    ADFGED F4,F2,F3
    MNFGED F5,F1
    DVFGED F2,F0,F4      ;F=1/Z
    DVFGED F3,F5,F4
    ADFGED F0,F0,#1      ;& V=Z+1
    MVFLTD F2,#1         ;else F=1
    MVFLTD F3,#0
    MNFLTD F1,F1
    RSFLTD F0,F0,#1      ;& V=1-Z
pt2 STFD   F3,[sp,#-8]!  ;save F
    STFD   F2,[sp,#-8]!
    MVFD   F2,#1         ;H=1
    MVFD   F3,#0
    ADR    R2,wc0
    LDFD   F4,[R2],#8    ;S=C(0)
    MVFD   F5,#0
    STFD   F1,[sp,#-8]!  ;save V
    STFD   F0,[sp,#-8]!
    MOV    R3,#1         ;K for loop
lp1 FLTD   F7,R3         ;DFLOAT(K)
    ADFD   F6,F0,F7
    SUFD   F0,F0,F7      ;R(V-K) [I(V-K) is in F1]
    SUFD   F6,F6,#1      ;R(V+K-1)  [I(V+K-1) is in F1]
    STFE   F4,[sp,#-12]! ;save R(S)
    MUFD   F4,F1,F1
    MUFD   F7,F6,F6
    ADFD   F4,F4,F7      ;|V+(K-1)|**2
    SUFD   F7,F6,F0
    MUFD   F6,F6,F0
    MUFD   F7,F7,F1
    MUFD   F1,F1,F1
    ADFD   F6,F6,F1
    DVFD   F7,F7,F4      ;(V-K)/(V+(K-1))
    DVFD   F6,F6,F4
    MUFD   F0,F3,F7
    MUFD   F1,F2,F6
    MUFD   F6,F6,F3
    MUFD   F7,F7,F2
    SUFD   F2,F1,F0      ;H=(V-K)/(V+(K-1))*H
    ADFD   F3,F6,F7
    LDFE   F4,[sp],#12   ;restore R(S)
    LDFD   F0,[R2],#8    ;C0(K)
    MUFD   F6,F2,F0      ;H*C0(K)
    MUFD   F7,F3,F0
    ADFE   F4,F4,F6      ;S=S+H*C0(K)
    ADFE   F5,F5,F7
    LDFD   F0,[sp]       ;restore V
    LDFD   F1,[sp,#8]
    ADD    R3,R3,#1
    CMP    R3,#15
    BLE    lp1           ;loop over K=1,15
    ADD    sp,sp,#16     ;remove V from stack
    SUFD   F0,F0,#0.5    ;V-0.5
    ADFD   F2,F0,#5      ;R(H)=R(V)+4.5 [I(H)=I(V)=F1]
;        find LN(H)
    MUFD   F6,F2,F2
    MUFD   F3,F1,F1
    POLD   F7,F2,F1      ;I(LN(H))=ARG(H)
    ADFD   F6,F6,F3
    LGND   F6,F6
    MUFD   F6,F6,#0.5    ;R(LN(H))=LN(ABS(H))
    MUFD   F3,F1,F7
    MUFD   F7,F7,F0
    MUFD   F0,F0,F6
    MUFD   F6,F6,F1
    ADFD   F7,F7,F6      ;I((V-0.5)*LN(H))
    SUFD   F6,F0,F3      ;R((V-0.5)*LN(H))
    SUFD   F7,F7,F1      ;subtract H
    SUFD   F6,F6,F2
    COSD   F0,F7
    EXPD   F6,F6
    SIND   F1,F7
    MUFD   F0,F0,F6      ;EXP((V-0.5)*LN(H)-H)
    MUFD   F1,F1,F6
    MUFD   F6,F0,F4
    MUFD   F7,F1,F5
    MUFD   F3,F0,F5
    MUFD   F4,F4,F1
    LDFD   F2,rtp
    SUFD   F0,F6,F7      ;EXP((V-0.5)*LN(H)-H)*S
    ADFD   F1,F3,F4
    MUFD   F6,F0,F2      ;H=SQRT(2pi)*EXP((V-0.5)*LN(H)-H)*S
    MUFD   F7,F1,F2
    CMP    ip,#0
    LDFEQS F0,[R1]       ;restore Z
    LDFEQS F1,[R1,#4]
    LDFNED F0,[R1]
    LDFNED F1,[R1,#8]
    CMF    F0,#0         ;check for X negative
    BGE    pt3
    LDFD   F5,wpi
    MUFD   F0,F0,F5      ;Z*PI
    MUFD   F1,F1,F5
    COSD   F2,F0         ;COS(pi*x)
    SIND   F3,F0         ;SIN(pi*x)
    EXPD   F4,F1         ;EXP(pi*y)
    RDFD   F1,F4,#1      ;EXP(-pi*y)
    ADFD   F0,F1,F4      ;2*COSH(pi*y)
    SUFD   F1,F4,F1      ;2*SINH(pi*y)
    MUFD   F0,F0,F3      ;2*R(SIN(pi*Z))
    MUFD   F1,F1,F2      ;2*I(SIN(pi*Z))
    MUFD   F2,F0,F6
    MUFD   F3,F1,F7
    MUFD   F0,F0,F7
    MUFD   F1,F1,F6
    SUFD   F2,F2,F3      ;2*SIN(pi*Z)*H
    ADFD   F3,F0,F1
    MUFD   F0,F2,F2
    MUFD   F1,F3,F3
    ADFD   F5,F5,F5      ;2*pi
    ADFD   F0,F0,F1
    DVFD   F5,F5,F0
    MNFD   F3,F3
    MUFD   F6,F2,F5      ;H=pi/(SIN(pi*Z)*H)
    MUFD   F7,F3,F5
pt3 LDFD   F2,[sp],#8    ;restore F
    LDFD   F3,[sp],#8
    MUFD   F0,F2,F6
    MUFD   F1,F3,F7
    MUFD   F4,F2,F7
    MUFD   F5,F3,F6
    SUFD   F2,F0,F1      ;result=F*H
    ADFD   F3,F4,F5
    LDFE   F7,[sp],#12
    LDFE   F6,[sp],#12
    LDFE   F5,[sp],#12
    LDFE   F4,[sp],#12
res CMP    ip,#0
    STFEQS F2,[R0]       ;store COMPLEX result
    STFEQS F3,[R0,#4]
    STFNED F2,[R0]       ;store COMPLEX*16 result
    STFNED F3,[R0,#8]
    LDMDB  fp,{fp,sp,pc} ;return
;
wpi DCFD    3.14159265358979324
rtp DCFD    2.50662827463100050  ;SQRT(2pi)
;
wc0 DCFD   41.624436916439068
    DCFD  -51.224241022374774
    DCFD   11.338755813488977
    DCFD   -0.747732687772388
    DCFD    0.008782877493061
    DCFD   -0.000001899030264
    DCFD    0.000000001946335
    DCFD   -0.000000000199345
    DCFD    0.000000000008433
    DCFD    0.000000000001486
    DCFD   -0.000000000000806
    DCFD    0.000000000000293
    DCFD   -0.000000000000102
    DCFD    0.000000000000037
    DCFD   -0.000000000000014
    DCFD    0.000000000000006
    END
;
    TTL    CHARN
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R6  RN     6
R5  RN     5
R4  RN     4
R2  RN     2
R1  RN     1
R0  RN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT charn_;(I) -> right adjusted decimal ASCII
    IMPORT __rt_sdiv
    DCB    "charn_",0,0,8,0,0,255
charn_
    MOV    ip,sp
    STMFD  sp!,{R0-R2,R4-R6,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDMIA  sp,{R4,R5}      ;address and length for CHARN
    LDR    R0,[R2]         ;I
    MOVS   R6,R0           ;get sign
    RSBLT  R0,R0,#0        ;|I|
    CMP    R0,#10
    ADDLT  ip,R0,#" "      ;convert to digit
    BLT    pt1
lp1 MOV    R1,R0
    MOV    R0,#10
    BL     __rt_sdiv      ;R0 = R1/10, R1=remainder
    ADD    ip,R1,#"0"      ;convert to digit
pt1 SUBS   R5,R5,#1
    STRGEB ip,[R4,R5]      ;store result in CHARN
    BLT    err
    CMP    R0,#10
    BGE    lp1
    CMP    R0,#0
    ADDGT  ip,R0,#"0"
    MOVGT  R0,#0
    BGT    pt1
    CMP    R6,#0
    BGE    pt2
    MOV    R0,#"-"
    SUBS   R5,R5,#1
    STRGEB R0,[R4,R5]      ;store sign
pt2 MOV    R0,#" "
lp2 CMP    R5,#0
    SUBGT  R5,R5,#1
    STRGTB R0,[R4,R5]      ;blank fill
    BGT    lp2
    LDMEQDB fp,{R4-R6,fp,sp,pc} ;return if OK
err LDMIA  sp,{R4,R5}      ;address and length for CHARN
    MOV    R0,#"*"
lp3 SUBS   R5,R5,#1
    STRGEB R0,[R4],#1
    BGT    lp3
    LDMDB  fp,{R4-R6,fp,sp,pc} ;return with CHARN='*****'
    END
;
    TTL    CHTOI
pc  RN    15
lr  RN    14
ip  RN    12
R1  RN     1
R0  RN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT chtoi_;(CHAR,INTGR,*label) convert 1 character to integer
chtoi_
    LDRB   R0,[R0]    ;CHAR
    CMP    R0,#32     ;check >31
    RSBGES ip,R0,#126 ;and <127
    MOVLT  R0,#0      ;output zero if no good
    STR    R0,[R1]    ;store INTGR
    MOVGE  R0,#0      ;return OK
    MOVLT  R0,#1      ;return bad
    MOV    pc,lr
    END
;
    TTL    CINV
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R0  RN     0
R3  RN     3
R4  RN     4
R5  RN     5
R6  RN     6
    AREA   |C$$code|,CODE,READONLY
    EXPORT cinv_;(N,A,IDIM,R,IFAIL) finds 1/A, A is any non-singular matrix
    IMPORT cfact_
    IMPORT cfinv_
    DCB    "cinv_",0,0,0,8,0,0,255
cinv_
    MOV    ip,sp
    STMDB  sp!,{R0-R6,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R4,[fp,#4]      ;address of IFAIL
    SUB    sp,sp,#12        ;space for DET and JFAIL
    MOV    R5,sp
    ADD    R6,R5,#8        ;addresses for DET and JFAIL
    STMFD  sp!,{R4-R6}
    BL     cfact_
    ADD    sp,sp,#24       ;restore stack
    LDMFD  sp!,{R0-R3}     ;restore addresses of N,A,IDIM,R
    LDR    ip,[R4]
    CMP    ip,#0           ;test IFAIL
    BLEQ   cfinv_          ;call CFINV if OK
    LDMDB  fp,{R4-R6,fp,sp,pc} ;return
    END
;
    TTL    CIO
R0  RN 0
R1  RN 1
R2  RN 2
R3  RN 3
R4  RN 4
R5  RN 5
fp  RN 11
ip  RN 12
sp  RN 13
lr  RN 14
pc  RN 15
XOS_Find    EQU &2000D
XOS_Args    EQU &20009
XOS_GBPB    EQU &2000C
    AREA   |C$$code|,CODE,READONLY
    EXPORT ciopen_;(LUNDES,CHMODE,CHNAME,ISTAT) open UNIX style stream
    DCB    "ciopen_",0,8,0,0,255
ciopen_
    MOV    ip,sp
    STMDB  sp!,{R0-R5,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDMIA  ip,{R4,R5}       ;lengths of CHMODE and CHNAME
    SUB    sp,sp,R5
    SUB    sp,sp,#1
    BIC    sp,sp,#3         ;space for null terminated name
    MOV    lr,#0
lp1 STRB   lr,[sp,R5]       ;move CHNAME
    SUBS   R5,R5,#1
    LDRGEB lr,[R2,R5]
    BGE    lp1
    LDRB   ip,[R1]          ;get first character of CHMODE
    CMP    ip,#"a"
    ADDLT  ip,ip,#32        ;convert to lower case
    CMP    R4,#1
    LDRGTB R4,[R1,#1]       ;load "+" if it exists
    CMP    ip,#"r"
    CMPNE  ip,#"w"
    CMPNE  ip,#"a"
    MOV    lr,#1
    BNE    er1               ;not "r", "w" or "a"
    MOV    R0,#&4F
    CMP    R4,#"+"
    MOVEQ  R0,#&CF
    MOV    R1,sp             ;pointer to name
    SWI    XOS_Find
    BVC    ok1               ;file opened correctly
    CMP    ip,#"w"
    BNE    er1               ;error because not creating file
    MOV    R0,#&8F
    MOV    R1,sp             ;pointer to name
    SWI    XOS_Find
    BVS    er1               ;can not open new file either
ok1 LDR    R2,[fp,#-36]      ;(LUNDES)
    STR    R0,[R2]           ;store file handle
    CMP    ip,#"a"           ;check for append
    MOV    R1,R0
    MOVNE  R0,#3
    MOVNE  R2,#0
    BNE    CN1
    MOV    R0,#2
    SWI    XOS_Args          ;get length of file
    MOV    R0,#1
CN1 CMP    ip,#"r"
    SWINE  XOS_Args          ;move to end of file or set extent to zero
    MOV    lr,#0
er1 LDR    R0,[fp,#-24]      ;(ISTAT)
    STR    lr,[R0]           ;store ISTAT
    LDMDB  fp,{R4,R5,fp,sp,pc} 
;
    EXPORT ciget_;(LUNDES,CHBUF,NBDO,NBDONE,ISTAT) get bytes from disc file
    DCB    "ciget_",0,0,8,0,0,255
ciget_
    MOV    ip,sp
    STMDB  sp!,{R0-R4,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R3,[R2]          ;NBDO
    MOV    ip,R3
    MOV    R2,R1            ;address to read to
    LDR    R1,[R0]          ;file handle
    MOV    R0,#4            ;read from current pointer
    SWI    XOS_GBPB         ;read bytes
    MOVVS  lr,#1
    BVS    er2              ;can not read
    SUB    ip,ip,R3         ;actual # bytes read
    LDR    R3,[fp,#-20]     ;(NBDONE)
    STR    ip,[R3]
    MOVCC  lr,#0
    MOVCS  lr,#-1
er2 LDR    R4,[fp,#4]       ;(ISTAT)
    STR    lr,[R4]          ;store ISTAT
    LDMDB  fp,{R4,fp,sp,pc} 
;
    EXPORT cigetw_;(LUNDES,MBUF,NWDO,NWDONE,ISTAT) get words from disc file
    DCB    "cigetw_",0,8,0,0,255
cigetw_
    MOV    ip,sp
    STMDB  sp!,{R0-R4,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R3,[R2]          ;NWDO
    MOV    R3,R3,LSL#2      ;number of bytes
    MOV    ip,R3
    MOV    R2,R1            ;address to read to
    LDR    R1,[R0]          ;file handle
    MOV    R0,#4            ;read from current pointer
    SWI    XOS_GBPB         ;read bytes
    MOVVS  lr,#1
    BVS    er3              ;can not read
    SUB    ip,ip,R3         ;actual # bytes read
    MOV    ip,ip,LSR#2
    LDR    R3,[fp,#-20]     ;(NWDONE)
    STR    ip,[R3]
    MOVCC  lr,#0
    MOVCS  lr,#-1
er3 LDR    R4,[fp,#4]
    STR    lr,[R4]          ;store ISTAT
    LDMDB  fp,{R4,fp,sp,pc} 
;
    EXPORT ciput_;(LUNDES,CHBUF,NBDO,ISTAT) send bytes to disc file
    DCB    "ciput_",0,0,8,0,0,255
ciput_
    MOV    ip,sp
    STMDB  sp!,{R0-R4,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R3,[R2]          ;NBDO
    MOV    R2,R1            ;address to read to
    LDR    R1,[R0]          ;file handle
    MOV    R0,#2            ;write to current file
    SWI    XOS_GBPB         ;write bytes
    MOVVS  lr,#1
    MOVVC  lr,#0
    LDR    R4,[fp,#-20]
    STR    lr,[R4]          ;store ISTAT
    LDMDB  fp,{R4,fp,sp,pc} 
;
    EXPORT ciputw_;(LUNDES,MBUF,NWDO,ISTAT) send words to disc file
    DCB    "ciputw_",0,8,0,0,255
ciputw_
    MOV    ip,sp
    STMDB  sp!,{R0-R4,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R3,[R2]          ;NWDO
    MOV    R3,R3,LSL#2
    MOV    R2,R1            ;address to read to
    LDR    R1,[R0]          ;file handle
    MOV    R0,#2            ;write to current file
    SWI    XOS_GBPB         ;write bytes
    MOVVS  lr,#1
    MOVVC  lr,#0
    LDR    R4,[fp,#-20]
    STR    lr,[R4]          ;store ISTAT
    LDMDB  fp,{R4,fp,sp,pc} 
;
    EXPORT cisize_;(LUNDES,NBYTT,ISTAT) get size of disc file
    DCB    "cisize_",0,8,0,0,255
cisize_
    MOV    ip,sp
    STMDB  sp!,{R0-R2,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R1,[R0]          ;file handle
    MOV    R0,#2
    SWI    XOS_Args         ;find extent
    MOVVC  R0,#1
    SWIVC  XOS_Args         ;move to end of file!
    MOVVS  lr,#1
    MOVVC  lr,#0
    LDMIB  sp,{R0,R1}
    STR    lr,[R1]          ;store ISTAT
    STRVC  R2,[R0]          ;store NBYTT
    LDMDB  fp,{fp,sp,pc} 
;
    EXPORT citell_;(LUNDES,NBYTC,ISTAT) get pointer in disc file
    DCB    "citell_",0,8,0,0,255
citell_
    MOV    ip,sp
    STMDB  sp!,{R0-R2,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R1,[R0]          ;file handle
    MOV    R0,#0            ;to find file pointer
    SWI    XOS_Args
    MOVVS  lr,#1
    MOVVC  lr,#0
    LDMIB  sp,{R0,R1}
    STR    lr,[R1]          ;store ISTAT
    STRVC  R2,[R0]          ;store NBYTC
    LDMDB  fp,{fp,sp,pc} 
;
    EXPORT ciseek_;(LUNDES,NBYTC,ISTAT) set pointer in disc file
    DCB    "ciseek_",0,8,0,0,255
ciseek_
    MOV    ip,sp
    STMDB  sp!,{R0-R2,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R2,[R1]          ;NBYTC
    LDR    R1,[R0]          ;file handle
    MOV    R0,#1            ;to set file pointer
    SWI    XOS_Args
    MOVVS  lr,#1
    MOVVC  lr,#0
    LDR    R1,[fp,#-16]
    STR    lr,[R1]          ;store ISTAT
    LDMDB  fp,{fp,sp,pc} 
;
    EXPORT cirew_;(LUNDES) rewind disc file
    DCB    "cirew_",0,0,8,0,0,255
cirew_
    MOV    ip,sp
    STMDB  sp!,{R0,fp,ip,lr,pc}
    SUB    fp,ip,#4
    MOV    R2,#0            ;file pointer 0
    LDR    R1,[R0]          ;file handle
    MOV    R0,#1            ;to set file pointer to zero
    SWI    XOS_Args
    LDMDB  fp,{fp,sp,pc} 
;
    EXPORT ciclos_;(LUNDES) close disc file
    DCB    "ciclos_",0,8,0,0,255
ciclos_
    MOV    ip,sp
    STMDB  sp!,{R0,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R1,[R0]          ;file handle
    MOV    R0,#0            ;to close the file
    SWI    XOS_Find
    LDMDB  fp,{fp,sp,pc} 
;
    EXPORT ciperm_;(IPERM) set permissions for future disc access
ciperm_
    MOV    pc,lr            ;there is no concept of different types of user
    END
;
    TTL    CKRACK
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
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
F3  FN     3
F2  FN     2
F1  FN     1
F0  FN     0
    AREA   slate__,COMMON,NOINIT
    %      160
    AREA   |C$$code|,CODE,READONLY
    EXPORT ckrack_;(LINE,JL,JR,IFLD) reads INTEGER or REAL from LINE(JL:JR)
    DCB    "ckrack_",0,8,0,0,255
ckrack_
    MOV    ip,sp
    STMDB  sp!,{R0-R3,R5-R9,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R7,[R1]     ;JL
    LDR    R2,[R2]     ;JR
    SUB    R0,R0,#1    ;(LINE(0))
    MOV    R6,#0       ;initialize results
    MOV    R8,#0
    MOV    R9,#0
wl2 LDRB   ip,[R0,R7]
    CMP    ip,#" "
    BNE    wl3
    ADD    R7,R7,#1
    CMP    R7,R2
    BLE    wl2         ;loop over blanks
    B      l15         ;all blanks
wl3 CMP    ip,#"#"     ;check for bit pattern
    BNE    wl5
    ADD    R7,R7,#1
    CMP    R7,R2
    BGT    l11         ;no identifier
    LDRB   ip,[R0,R7]
    CMP    ip,#96
    SUBGT  ip,ip,#32
    MOV    R5,#1       ;bits/character
    CMP    ip,#"B"
    MOVNE  R5,#3
    CMPNE  ip,#"O"
    CMPNE  ip,#"0"
    MOVNE  R5,#4
    CMPNE  ip,#"X"
    BNE    l11         ;not legal identifier
    MOV    R8,#1       ;number is bit pattern
    MOV    lr,#0       ;accumulator
wl4 ADD    R7,R7,#1
    CMP    R7,R2
    BGT    l14
    LDRB   ip,[R0,R7]  ;get digit
    CMP    ip,#" "
    BEQ    l14         ;blank terminator
    CMP    ip,#96
    SUBGT  ip,ip,#32   ;make letters upper case
    SUB    ip,ip,#48
    CMP    ip,#9
    SUBGT  ip,ip,#7    ;convert to binary
    MOVS   R1,ip,LSR R5;check legality
    BNE    l12         ;illegal, so terminate
    ORR    lr,ip,lr,LSL R5;accumulate
    ADD    R6,R6,#1    ;increment digit count
    B      wl4         ;and loop
wl5 CMP    ip,#"-"
    MVFNEE F3,#1       ;sign positive
    MNFEQE F3,#1       ;negative
    CMPNE  ip,#"+"
    SUBNE  R7,R7,#1    ;go back if not sign
    MOV    R8,#2       ;assume integer
    MOV    R1,#0       ;decimal digits
    MVFE   F0,#0       ;accumulator
    MOV    lr,#1       ;exponent sign
    MOV    R5,#0       ;exponent magnitude
wl6 ADD    R7,R7,#1
    CMP    R7,R2
    BGT    l13         ;finished
    LDRB   ip,[R0,R7]  ;get character
    CMP    ip,#" "     ;check for blank
    BEQ    l13         ;normal termination
    CMP    ip,#"."     ;check for decimal point
    BEQ    wl8         ;yes
    CMP    ip,#"9"
    BGT    wl9         ;not number, check for E or D
    SUBS   ip,ip,#"0"  ;make binary
    BLT    l12         ;abnormal terminator
    MUFE   F0,F0,#10
    FLTGTE F1,ip
    ADFGTE F0,F0,F1    ;accumulate
    ADD    R6,R6,#1    ;increment digit count
    CMP    R8,#3
    ADDEQ  R1,R1,#1    ;decimal count
    B      wl6         ;and loop
wl8 CMP    R8,#3       ;found "."
    BEQ    l11         ;fail if already "."
    MOV    R8,#3       ;floating word
    B      wl6
wl9 CMP    ip,#96      ;found probable letter
    SUBGT  ip,ip,#32   ;make upper case
    CMP    ip,#"D"
    CMPNE  ip,#"E"
    BNE    l12         ;abnormal terminator
    RSB    R8,ip,#"H"  ;make NF 3 for E, 4 for D
    ADD    R7,R7,#1
    CMP    R7,R2
    BGT    l13         ;normal termination
    LDRB   ip,[R0,R7]
    CMP    ip,#"-"
    MOVEQ  lr,#-1      ;negative
    CMPNE  ip,#"+"
    ADDEQ  R7,R7,#1    ;skip sign
l10 CMP    R7,R2
    BGT    l13         ;normal termination
    LDRB   ip,[R0,R7]
    CMP    ip,#" "
    BEQ    l13
    RSBS   ip,ip,#"9"
    RSBGES ip,ip,#9
    BLT    l12         ;abnormal terminator
    ADD    R5,R5,R5,LSL#2
    ADD    R5,ip,R5,LSL#1;accumulate
    ADD    R7,R7,#1
    CMP    R5,#400     ;check for obvious overflow
    BLT    l10         ;OK
l11 MOV    R8,#-1      ;fail
l12 MOV    R9,#1       ;abnormal terminator
l13 CMP    R8,#3
    BLT    l14         ;integer
    MUL    R5,lr,R5    ;fix sign of exponent
    SUB    R5,R5,R1    ;subtract the number of decimals
    ADDS   ip,R5,R6    ;approximate final exponent
    RSBLT  ip,ip,#0
    LDR    R3,[R3]
    CMP    R3,#0
    MOVGT  R8,#4       ;force double precision
    MOVLT  R8,#3       ;force single precision
    CMP    R8,#3
    CMPGT  ip,#304
    CMPEQ  ip,#37
    BGT    l11         ;exponent out of range
    FLTE   F2,R5
    RPWE   F1,F2,#10
    MUFE   F0,F1,F0    ;multiply by exponent
l14 CMP    R6,#0
    MOVEQ  R8,#-1
l15 LDR    R0,slpt
    STMIA  R0!,{R6-R9} ;store pointers
    CMP    R8,#1
    STREQ  lr,[R0]     ;store bit pattern
    LDMLEDB  fp,{R5-R9,fp,sp,pc} ;return if nf <=1
    MUFE   F0,F3,F0    ;correct sign
    CMP    R8,#3
    FIXLT  R1,F0
    STRLT  R1,[R0]     ;store integer
    STFEQS F0,[R0]     ;store REAL*4
    STFGTD F0,[R0]     ;store REAL*8
    LDMDB  fp,{R5-R9,fp,sp,pc} ;return
slpt DCD    slate__
    END
;
    TTL    CLEFT
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R7  RN     7
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
    AREA   slate__,COMMON,NOINIT
    %      160
;
    AREA   |C$$code|,CODE,READONLY
    EXPORT cleft_;(LINE,JL,JR) squeezes blanks in LINE(JL:JR) to right
    DCB    "cleft_",0,0,8,0,0,255
cleft_
    MOV    ip,sp
    STMDB  sp!,{R0-R2,R7,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R1,[R1]     ;JL
    LDR    R2,[R2]     ;JR
    MOV    R3,R1       ;copy of JL
    MOV    R7,R1       ;pointer to first blank
    MOV    lr,#" "
    SUB    R0,R0,#2    ;(LINE(-1:-1))
wt1 ADD    R3,R3,#1    ;inc total count
    LDRB   ip,[R0,R3]
    CMP    ip,#" "     ;is byte blank?
    ADDNE  R7,R7,#1    ;inc count of non-blank
    CMPNE  R3,R7
    STRNEB ip,[R0,R7]  ;pack in non-blank
    STRNEB lr,[R0,R3]  ;fill with blank
    CMP    R3,R2
    BLE    wt1         ;loop until > JR
    LDR    R0,slpt
    SUB    R1,R7,R1
    STMIA  R0,{R1,R7}  ;store ND,NE
    LDMDB  fp,{R7,fp,sp,pc} ;return
slpt DCD    slate__
    END
;
    TTL   CLOGAM
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
F0  FN     0
F1  FN     1
F2  FN     2
F3  FN     3
F4  FN     4
F5  FN     5
F6  FN     6
F7  FN     7
R0  RN     0
R1  RN     1
R2  RN     2
R3  RN     3
    AREA   |C$$code|,CODE,READONLY
    EXPORT clgama_ ;(Z) COMPLEX gamma function
    EXPORT wlgama_ ;(Z) COMPLEX*16 gamma function
    EXPORT clogam_ ;(Z) COMPLEX gamma function
    EXPORT wlogam_ ;(Z) COMPLEX*16 gamma function
;
    DCB    "clgama_",0,8,0,0,255
clgama_
clogam_
    MOV    ip,sp
    STMDB  sp!,{R0-R1,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDFS   F0,[R1]
    LDFS   F1,[R1,#4]
    MOV    ip,#0        ;flag COMPLEX*8 result needed
    B      pt1
;
    DCB    "wlgama_",0,8,0,0,255
wlgama_
wlogam_
    MOV    ip,sp
    STMDB  sp!,{R0-R1,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDFD   F0,[R1]
    LDFD   F1,[R1,#8]
;
pt1 CMF    F1,#0         ;IF(Y.EQ.0 .AND.
    RNDEQD F2,F0
    ABSEQD F3,F0
    CNFEQ  F3,F2         ;-ABS(X) .EQ. AINT(X)) THEN
    MVFEQD F2,#0         ;  failure
    MVFEQD F3,#0         ;  set result to 0 & return
    BEQ    res           ;ENDIF
    STFE   F4,[sp,#-12]! ;save floating registers
    STFE   F5,[sp,#-12]!
    STFE   F6,[sp,#-12]!
    STFE   F7,[sp,#-12]!
    ABSD   F1,F1         ;Y=|Y|
    CMF    F0,#0
    RSFLTD F0,F0,#1      ;if X<0 set Z=1-Z
    MNFLTD F1,F1
    FIXZ   R3,F0
    RSBS   R3,R3,#6      ;if X>6 then
    MVFLTD F2,#0         ;  set H=0
    MVFLTD F3,#0
    POLGED F7,F0,F1      ;A=ARG(Z)
    MVFGED F2,F0         ;H=U
    MVFGED F3,F1
lp1 ADFGTE F0,F0,#1      ;Z=Z+1
    MUFGTE F4,F0,F2
    MUFGTE F5,F1,F3
    MUFGTE F6,F1,F2
    MUFGTE F3,F0,F3
    SUFGTE F2,F4,F5      ;H=H*U
    ADFGTE F3,F3,F6
    POLGTE F6,F0,F1
    ADFGTE F7,F7,F6      ;A=A+ARG(Z)
    SUBGTS R3,R3,#1
    BGT    lp1
    MUFGED F2,F2,F2
    MUFGED F4,F3,F3
    MVFGED F3,F7
    ADFGED F2,F2,F4
    LGNGED F4,F2
    MUFGED F2,F4,#0.5
    ADFGED F0,F0,#1
    STFD   F2,[sp,#-8]!  ;save H
    STFD   F3,[sp,#-8]!
    MUFD   F2,F0,F0
    MUFD   F3,F1,F1
    MUFD   F4,F0,F1
    ADFD   F5,F2,F3
    STFD   F5,[sp,#-8]!  ;|U|**2
    MNFD   F7,F4
    SUFD   F6,F2,F3
    MUFD   F5,F5,F5
    ADFD   F7,F7,F7
    DVFD   F6,F6,F5      ;R=1/Z**2
    DVFD   F7,F7,F5
    ADR    R3,wc0+8*9    ;(C0(10))
    LDFD   F2,[R3],#-8   ;C0(10)
    MUFD   F4,F6,F2      ;P=R*C(10)
    MUFD   F5,F7,F2
    MOV    R2,#8         ;loop count (I=9,2,-1)
lp2 LDFD   F2,[R3],#-8   ;C0(I)
    ADFE   F4,F4,F2      ;P+C(I)
    MUFE   F3,F4,F7
    MUFE   F4,F4,F6
    MUFE   F2,F5,F7
    MUFE   F5,F5,F6
    SUFE   F4,F4,F2      ;P=R*(P+C(I))
    ADFE   F5,F5,F3
    SUBS   R2,R2,#1
    BGT    lp2
    LDFD   F2,[R3]       ;C0(1)
    ADFD   F4,F4,F2      ;P+C(1)
    MUFD   F3,F4,F1
    MUFD   F4,F4,F0
    MUFD   F2,F5,F1
    MUFD   F5,F5,F0
    ADFD   F4,F4,F2
    SUFD   F5,F5,F3
    LDFD   F2,[sp],#8    ;|U|**2
    DVFD   F4,F4,F2      ;(P+C(1))/U
    DVFD   F5,F5,F2
    LGND   F2,F2
    POLD   F3,F0,F1      ;ARG(U)
    MUFD   F2,F2,#0.5    ;LOG(|U|)
    SUFD   F4,F4,F0      ;(P+C(1))/U-U
    SUFD   F5,F5,F1
    SUFD   F0,F0,#0.5    ;U-0.5
    MUFD   F6,F1,F3
    MUFD   F7,F1,F2
    MUFD   F2,F2,F0
    MUFD   F3,F3,F0
    SUFD   F2,F2,F6      ;(U-0.5)*LOG(U)
    ADFD   F3,F3,F7
    ADFD   F0,F2,F4      ;(U-0.5)*LOG(U)-U+(P+C(1))/U
    ADFD   F1,F3,F5
    LDFD   F7,wc1
    LDFD   F3,[sp],#8    ;restore H
    LDFD   F2,[sp],#8
    ADFD   F0,F0,F7      ;C1+(U-0.5)*LOG(U)-U+(P+C(1))/U
    SUFD   F3,F1,F3      ;H=C1+(U-0.5)*LOG(U)-U+(P+C(1))/U-H
    SUFD   F2,F0,F2
    CMP    ip,#0
    LDFEQS F0,[R1]       ;restore Z
    LDFEQS F1,[R1,#4]
    LDFNED F0,[R1]
    LDFNED F1,[R1,#8]
    CMF    F0,#0
    BGE    pt2           ;skip if X>0
    STFD   F2,[sp,#-8]!  ;save H
    STFD   F3,[sp,#-8]!
    FIXZ   R3,F0         ;try FIXDM and no SUB sometime
    SUB    R3,R3,#1
    FLTD   F2,R3         ;UR=INT(X)-1
    LDFD   F7,wpi
    SUFD   F3,F0,F2      ;X-UR
    ABSD   F0,F1         ;|Y|
    MUFD   F4,F3,F7      ;UI=PI*(X-UR)
    MUFD   F0,F0,F7      ;X=PI*|Y|
    MUFD   F2,F2,F7      ;UR*PI
    ADFD   F7,F0,F0
    SIND   F5,F4         ;A=SIN(UI)
    MNFD   F7,F7         ;-2*X
    COSD   F4,F4         ;COS(UI)
    EXPD   F7,F7         ;T=EXP(-2*X)
    ADFD   F6,F7,#1      ;1+T
    RSFD   F3,F7,#1      ;1-T
    MUFD   F7,F7,F5      ;T*A
    DVFD   F6,F3,F6      ;TANH(X)
    MUFD   F3,F3,#0.5    ;(1-T)/2
    MUFD   F4,F4,F6      ;COS(UI)*TANH(X)
    MUFD   F7,F7,F5      ;T*A**2
    MUFD   F3,F3,F3      ;((1-T)/2)**2
    POLD   F5,F5,F4      ;ATAN2(COS(UI)*TANH(X),A)
    ADFD   F7,F7,F3      ;T*A**2+((1-T)/2)**2
    SUFD   F5,F5,F2      ;A=ATAN2(COS(UI)*TANH(X),A)-UR*PI
    LGND   F4,F7         ;LOG(T*A**2+((1-T)/2)**2)
    LDFD   F3,[sp],#8    ;restore H
    LDFD   F2,[sp],#8
    MUFD   F4,F4,#0.5
    LDFD   F7,wc2
    ADFD   F4,F4,F0      ;T=X+0.5*LOG(T*A**2+((1-T)/2)**2)
    SUFD   F2,F7,F2
    ADFD   F3,F3,F5
    SUFD   F2,F2,F4      ;H=C2-(T,A)-H
    MNFD   F3,F3
pt2 CMF    F1,#0
    MNFLTD F3,F3         ;take conjugate if y<0
    LDFE   F7,[sp],#12   ;restore floating registers
    LDFE   F6,[sp],#12
    LDFE   F5,[sp],#12
    LDFE   F4,[sp],#12
res CMP    ip,#0
    STFEQS F2,[R0]       ;store COMPLEX result
    STFEQS F3,[R0,#4]
    STFNED F2,[R0]       ;store COMPLES*16 result
    STFNED F3,[R0,#8]
    LDMDB  fp,{fp,sp,pc} ;return
;
wpi DCFD   3.14159265358979324
wc1 DCFD   0.918938533204672742
wc2 DCFD   1.14472988584940017
wc0 DCFD   0.0833333333333333333
    DCFD  -0.00277777777777777778
    DCFD   0.000793650793650793651
    DCFD  -0.000595238095238095238
    DCFD   0.000841750841750841751
    DCFD  -0.00191752691752691753
    DCFD   0.00641025641025641026
    DCFD  -0.0295506535947712418
    DCFD   0.179644372368830573
    DCFD  -1.39243221690590112
    END
;
    TTL    CLTOU
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT cltou_;(STR) converts lower case letters in STR to upper case
    DCB    "cltou_",0,0,8,0,0,255
cltou_
    MOV    ip,sp
    STMDB  sp!,{R0,R1,fp,ip,lr,pc}
    SUB    fp,ip,#4
wu1 LDRB   R2,[R0],#1
    CMP    R2,#"a"     ;check for lower case
    SUBGE  R2,R2,#32   ;convert to upper
    RSBGES R3,R2,#"Z"
    STRGEB R2,[R0,#-1]
    SUBS   R1,R1,#1
    BGT    wu1         ;loop over string
    LDMDB  fp,{fp,sp,pc} ;return
    END
;
    TTL    CMADD
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
F1  FN     1
F0  FN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT cmadd_;(M,N,X11,X12,X21,Y11,Y12,Y21,Z11,Z12,Z21)  z= x+ y
    DCB    "cmadd_",0,0,8,0,0,255
cmadd_
    MOV    ip,sp
    STMDB  sp!,{R0-R9,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R0,[R0]     ;m
    LDR    R1,[R1]     ;n
    CMP    R0,#0
    CMPGT  R1,#0
    LDMLEDB fp,{R4-R9,fp,sp,pc} ;return
    LDMIB  fp,{R4-R9,ip};arg addresses (X21 to Z21)
    SUB    R3,R3,R2    ; Xj step
    SUB    R4,R2,R4
    MLA    R4,R3,R1,R4 ;-Xi step
    SUB    R6,R6,R5    ; Yj step
    SUB    R7,R5,R7
    MLA    R7,R6,R1,R7 ;-Yi step
    SUB    R9,R9,R8    ; Zj step
    SUB    ip,R8,ip
    MLA    ip,R9,R1,ip ;-Zi step
wa1 MOV    lr,R1       ;j - count
wb1 LDFS   F0,[R2]     ;Xij
    LDFS   F1,[R5]     ;Yij
    ADFS   F0,F0,F1
    STFS   F0,[R8]     ;Zij = Xij + Yij
    LDFS   F0,[R2,#4]  ;Xij
    LDFS   F1,[R5,#4]  ;Yij
    ADFS   F0,F0,F1
    STFS   F0,[R8,#4]  ;Zij = Xij + Yij
    ADD    R2,R2,R3
    ADD    R5,R5,R6
    ADD    R8,R8,R9
    SUBS   lr,lr,#1
    BGT    wb1         ;loop over j
    SUB    R2,R2,R4
    SUB    R5,R5,R7
    SUB    R8,R8,ip
    SUBS   R0,R0,#1
    BGT    wa1         ;loop over i
    LDMDB  fp,{R4-R9,fp,sp,pc} ;return
    END
;
    TTL    CMBIL
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
F7  FN     7
F6  FN     6
F5  FN     5
F4  FN     4
F3  FN     3
F2  FN     2
F1  FN     1
F0  FN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT cmbil_;(N,V1,V2,X11,X12,X21,Y1,Y2)    Vk * Xkj * Yj => funct
    DCB    "cmbil_",0,0,8,0,0,255
cmbil_
    MOV    ip,sp
    STMDB  sp!,{R0-R9,fp,ip,lr,pc}
    SUB    fp,ip,#4
    MVFE   F0,#0       ;total accumulator
    MVFE   F1,F0
    LDR    R1,[R1]     ;N
    CMP    R1,#1
    BLT    ret         ;return if N<1
    STFE   F4,[sp,#-12]!;save floating registers
    STFE   F5,[sp,#-12]!
    STFE   F6,[sp,#-12]!
    STFE   F7,[sp,#-12]!
    LDMIB  fp,{R4-R8}  ;arg addresses
    SUB    R3,R3,R2    ;V step
    SUB    R8,R8,R7    ;Y step
    SUB    R5,R5,R4    ; Xj step
    SUB    R6,R4,R6
    MLA    R6,R5,R1,R6 ;-Xk step
    MOV    ip,R1       ;k-count
wa2 MOV    lr,R1       ;j-count
    MVFE   F2,#0       ;row accumulator
    MVFE   F3,F2
    MOV    R9,R7       ;(Yj)
wb2 LDFS   F4,[R4]     ;R(Xkj)
    LDFS   F5,[R9]     ;R(Yj)
    LDFS   F6,[R9,#4]  ;I(Yj)
    MUFE   F7,F4,F5    ;R(x)R(y)
    ADFE   F2,F2,F7
    MUFE   F7,F4,F6    ;R(x)I(y)
    ADFE   F3,F3,F7
    LDFS   F4,[R4,#4]  ;I(Xkj)
    MUFE   F7,F4,F5    ;I(x)R(y)
    ADFE   F3,F3,F7
    MUFE   F7,F4,F6    ;I(x)I(y)
    SUFE   F2,F2,F7
    ADD    R4,R4,R5
    ADD    R9,R9,R8
    SUBS   lr,lr,#1
    BGT    wb2         ;loop over j
    LDFS   F4,[R2]     ;R(Vk)
    LDFS   F5,[R2,#4]  ;I(Vk)
    MUFE   F6,F4,F2
    MUFE   F7,F5,F3
    ADFE   F0,F0,F6    ;sum R(total)
    SUFE   F0,F0,F7
    MUFE   F6,F4,F3
    MUFE   F7,F5,F2
    ADFE   F1,F1,F6    ;sum I(total)
    ADFE   F1,F1,F7
    ADD    R2,R2,R3
    SUB    R4,R4,R6
    SUBS   ip,ip,#1
    BGT    wa2
    LDFE   F7,[sp],#12 ;restore floating registers
    LDFE   F6,[sp],#12
    LDFE   F5,[sp],#12
    LDFE   F4,[sp],#12
ret STFS   F0,[R0]     ;store R(ans)
    STFS   F1,[R0,#4]  ;store I(ans)
    LDMDB  fp,{R4-R9,fp,sp,pc} ;return
    END
;
    TTL    CMCPY
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
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 cmcpy_;(M,N,X11,X12,X21,Z11,Z12,Z21)  z   = x
    DCB    "cmcpy_",0,0,8,0,0,255
cmcpy_
    MOV    ip,sp
    STMDB  sp!,{R0-R7,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R0,[R0]     ;m
    LDR    R1,[R1]     ;n
    CMP    R0,#0
    CMPGT  R1,#0
    LDMLEDB fp,{R4-R7,fp,sp,pc} ;return
    LDMIB  fp,{R4-R7}  ;arg addresses
    SUB    R3,R3,R2    ; Xj step
    SUB    R4,R2,R4
    MLA    R4,R3,R1,R4 ;-Xi step
    SUB    R6,R6,R5    ; Zj step
    SUB    R7,R5,R7
    MLA    R7,R6,R1,R7 ;-Zi step
wa3 MOV    ip,R1       ;j - count
wb3 LDR    lr,[R2,#4]  ;copy X'ij
    STR    lr,[R5,#4]  ;to Z'ij
    LDR    lr,[R2],R3  ;copy Xij
    STR    lr,[R5],R6  ;to Zij
    SUBS   ip,ip,#1
    BGT    wb3         ;loop over j
    SUB    R2,R2,R4
    SUB    R5,R5,R7
    SUBS   R0,R0,#1
    BGT    wa3         ;loop over i
    LDMDB  fp,{R4-R7,fp,sp,pc} ;return
    END
;
    TTL    CMDMP
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
F5  FN     5
F4  FN     4
F3  FN     3
F2  FN     2
F1  FN     1
F0  FN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT cmdmp_;(M,N,D1,D2,X11,X12,X21,Z11,Z12,Z21)  Zij = Di * Xij
    DCB    "cmdmp_",0,0,8,0,0,255
cmdmp_
    MOV    ip,sp
    STMDB  sp!,{R0-R9,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R0,[R0]     ;m
    LDR    R1,[R1]     ;n
    CMP    R0,#0
    CMPGT  R1,#0
    LDMLEDB fp,{R4-R9,fp,sp,pc} ;return
    STFE   F4,[sp,#-12]!
    STFE   F5,[sp,#-12]!
    LDMIB  fp,{R4-R9}  ;arg addresses
    SUB    R3,R3,R2    ; Di step
    SUB    R5,R5,R4    ; Xj step
    SUB    R6,R4,R6
    MLA    R6,R5,R1,R6 ;-Xi step
    SUB    R8,R8,R7    ; Zj step
    SUB    R9,R7,R9
    MLA    R9,R8,R1,R9 ;-zi step
wae LDFS   F0,[R2]     ;R(Di)
    LDFS   F1,[R2,#4]  ;I(Di)
    MOV    ip,R1       ;j-count
wbe LDFS   F2,[R4]     ;R(Xij)
    LDFS   F3,[R4,#4]  ;I(Xij)
    FMLS   F4,F2,F0    ;R(x)R(d)
    FMLS   F5,F3,F1    ;I(x)I(d)
    SUFS   F4,F4,F5
    STFS   F4,[R7]     ;R(Zij)
    FMLS   F4,F2,F1    ;R(x)I(d)
    FMLS   F5,F3,F0    ;I(x)R(d)
    ADFS   F4,F4,F5
    STFS   F4,[R7,#4]  ;I(Zij)
    ADD    R4,R4,R5
    ADD    R7,R7,R8
    SUBGTS ip,ip,#1
    BGT    wbe         ;loop over j
    SUB    R4,R4,R6
    SUB    R7,R7,R9
    ADD    R2,R2,R3
    SUBEQS R0,R0,#1
    BGT    wae         ;loop over i
    LDFE   F5,[sp],#12
    LDFE   F4,[sp],#12
    LDMDB  fp,{R4-R9,fp,sp,pc} ;return
    END
;
    TTL    CMM_MULT
pc  RN    15
lr  RN    14
sp  RN    13
fp  RN    11
R8  RN     8
R7  RN     7
R6  RN     6
R4  RN     4
R3  RN     3
R1  RN     1
F6  FN     6
F5  FN     5
F4  FN     4
F3  FN     3
F2  FN     2
F1  FN     1
F0  FN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT cmm_mult
cmm_mult
    STMFD  sp!,{lr}
    MOV    lr,R1       ;initialise j to n
    SUB    R6,R6,R7    ;(Y(1,l))
    MLA    R3,R4,R1,R3 ;(X(i,n+1))
    MLA    R6,R8,R1,R6 ;(Y(n+1,l))
wc1 SUB    R3,R3,R4    ;(X(i,j))
    SUB    R6,R6,R8    ;(Y(j,l))
    LDFS   F2,[R3]     ;get R(Xij)
    LDFS   F3,[R3,#4]  ;get I(Xij)
    LDFS   F4,[R6]     ;get R(Yjl)
    LDFS   F5,[R6,#4]  ;get I(Yjl)
    MUFE   F6,F2,F4    ;R(x)R(y)
    MUFE   F2,F5,F2    ;R(x)I(y)
    MUFE   F5,F3,F5    ;I(x)I(y)
    MUFE   F3,F4,F3    ;I(x)R(y)
    ADFE   F3,F3,F2
    SUFE   F2,F6,F5
    ADFE   F0,F0,F2    ;R(sum)
    ADFE   F1,F1,F3    ;I(sum)
    SUBS   lr,lr,#1
    BGT    wc1         ;loop over j=n,1,-1
    LDMFD  sp!,{pc} 
    END
;
    TTL    CMMLA
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
F6  FN     6
F5  FN     5
F4  FN     4
F3  FN     3
F2  FN     2
F1  FN     1
F0  FN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT cmmla_;(M,N,K,X11,X12,X21,Y11,Y12,Y21,Z11,Z12,Z21)  z = xy + z
    IMPORT cmm_mult
    DCB    "cmmla_",0,0,8,0,0,255
cmmla_
    MOV    ip,sp
    STMDB  sp!,{R0-R9,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R0,[R0]     ;m
    LDR    R1,[R1]     ;n
    LDR    R2,[R2]     ;k
    CMP    R0,#0       ;check m>0
    CMPGT  R1,#0       ;check n>0
    CMPGT  R2,#0       ;check k>0
    LDMLEDB fp,{R4-R9,fp,sp,pc} ;return if not
    STFE   F6,[sp,#-12]!
    STFE   F5,[sp,#-12]!
    STFE   F4,[sp,#-12]!
    LDMIB  fp,{R4-R9,ip,lr} ;arg addresses
    SUB    R4,R4,R3    ;X(i,j) :jstep
    SUB    R5,R5,R3    ;X(i,j) :istep
    SUB    R7,R7,R6    ;Y(j,l) :lstep
    SUB    R8,R8,R6    ;Y(j,l) :jstep
    SUB    ip,ip,R9    ;Z(i,l) :lstep
    SUB    lr,lr,R9    ;Z(i,l) :istep
wa1 STMFD  sp!,{R0,lr} ;save m and istep(Z)
    MOV    R0,R2       ;initialise l to k
    MLA    R6,R7,R2,R6 ;(Y(1,k+1))
    MLA    R9,ip,R2,R9 ;(Z(i,k+1))
wb1 SUB    R9,R9,ip    ;(Z(i,l))
    LDFS   F0,[R9]     ;initialise from +Z(i,l)
    LDFS   F1,[R9,#4]
    BL     cmm_mult    ;add (Xij)(Yjl):j=1,n
    STFS   F0,[R9]     ;store R(Zil)
    STFS   F1,[R9,#4]  ;store I(Zil)
    SUBS   R0,R0,#1
    BGT    wb1         ;loop over l=k,1,-1
    LDMFD  sp!,{R0,lr} ;restore m and istep(Z)
    ADD    R3,R3,R5    ;(X(i+1,1))
    ADD    R9,R9,lr    ;(Z(i+1,1))
    SUBS   R0,R0,#1
    BGT    wa1         ;loop over i=1,m
    LDFE   F4,[sp],#12
    LDFE   F5,[sp],#12
    LDFE   F6,[sp],#12
    LDMDB  fp,{R4-R9,fp,sp,pc} ;return
    END
;
    TTL    CMMLS
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
F6  FN     6
F5  FN     5
F4  FN     4
F3  FN     3
F2  FN     2
F1  FN     1
F0  FN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT cmmls_;(M,N,K,X11,X12,X21,Y11,Y12,Y21,Z11,Z12,Z21)  z = xy - z
    IMPORT cmm_mult
    DCB    "cmmls_",0,0,8,0,0,255
cmmls_
    MOV    ip,sp
    STMDB  sp!,{R0-R9,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R0,[R0]     ;m
    LDR    R1,[R1]     ;n
    LDR    R2,[R2]     ;k
    CMP    R0,#0       ;check m>0
    CMPGT  R1,#0       ;check n>0
    CMPGT  R2,#0       ;check k>0
    LDMLEDB fp,{R4-R9,fp,sp,pc} ;return if not
    STFE   F6,[sp,#-12]!
    STFE   F5,[sp,#-12]!
    STFE   F4,[sp,#-12]!
    LDMIB  fp,{R4-R9,ip,lr} ;arg addresses
    SUB    R4,R4,R3    ;X(i,j) :jstep
    SUB    R5,R5,R3    ;X(i,j) :istep
    SUB    R7,R7,R6    ;Y(j,l) :lstep
    SUB    R8,R8,R6    ;Y(j,l) :jstep
    SUB    ip,ip,R9    ;Z(i,l) :lstep
    SUB    lr,lr,R9    ;Z(i,l) :istep
wa1 STMFD  sp!,{R0,lr} ;save m and istep(Z)
    MOV    R0,R2       ;initialise l to k
    MLA    R6,R7,R2,R6 ;(Y(1,k+1))
    MLA    R9,ip,R2,R9 ;(Z(i,k+1))
wb1 SUB    R9,R9,ip    ;(Z(i,l))
    LDFS   F0,[R9]     ;initialise from -Z(i,l)
    MNFS   F0,F0
    LDFS   F1,[R9,#4]
    MNFS   F1,F1
    BL     cmm_mult    ;add (Xij)(Yjl):j=1,n
    STFS   F0,[R9]     ;store R(Zil)
    STFS   F1,[R9,#4]  ;store I(Zil)
    SUBS   R0,R0,#1
    BGT    wb1         ;loop over l=k,1,-1
    LDMFD  sp!,{R0,lr} ;restore m and istep(Z)
    ADD    R3,R3,R5    ;(X(i+1,1))
    ADD    R9,R9,lr    ;(Z(i+1,1))
    SUBS   R0,R0,#1
    BGT    wa1         ;loop over i=1,m
    LDFE   F4,[sp],#12
    LDFE   F5,[sp],#12
    LDFE   F6,[sp],#12
    LDMDB  fp,{R4-R9,fp,sp,pc} ;return
    END
;
    TTL    CMMLT
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
F6  FN     6
F5  FN     5
F4  FN     4
F3  FN     3
F2  FN     2
F1  FN     1
F0  FN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT cmmlt_;(M,N,K,X11,X12,X21,Y11,Y12,Y21,Z11,Z12,Z21,T)  Z = XY
    DCB    "cmmlt_",0,0,8,0,0,255
    IMPORT cmm_mult
cmmlt_
    MOV    ip,sp
    STMDB  sp!,{R0-R9,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R0,[R0]     ;m
    LDR    R1,[R1]     ;n
    LDR    R2,[R2]     ;k
    CMP    R0,#0       ;check m>0
    CMPGT  R1,#0       ;check n>0
    CMPGT  R2,#0       ;check k>0
    LDMLEDB fp,{R4-R9,fp,sp,pc} ;return if not
    STFE   F6,[sp,#-12]!
    STFE   F5,[sp,#-12]!
    STFE   F4,[sp,#-12]!
    LDMIB  fp,{R4-R9,ip,lr} ;arg addresses except T
    SUB    R4,R4,R3    ;X(i,j) :jstep
    SUB    R5,R5,R3    ;X(i,j) :istep
    SUB    R7,R7,R6    ;Y(j,l) :lstep
    SUB    R8,R8,R6    ;Y(j,l) :jstep
    SUB    ip,ip,R9    ;Z(i,l) :lstep
    SUB    lr,lr,R9    ;Z(i,l) :istep
    CMP    R3,R9
    BEQ    wxz         ;(Z) = (X)
    CMP    R6,R9
    BEQ    wyz         ;(Z) = (Y)
    CMP    R3,R6
    CMPEQ  R0,R2       ;check that Y = X'
    CMPEQ  R5,R7
    CMPEQ  R4,R8
    BEQ    wxy         ;Y = X' not overlapping Z
;        standard multiplication: Z = XY
wa3 STMFD  sp!,{R0,lr} ;save m and istep(Z)
    MOV    R0,R2       ;l-count
    MLA    R6,R7,R2,R6
    MLA    R9,ip,R2,R9
wb3 SUB    R9,R9,ip
    MVFE   F0,#0       ;initialise to zero
    MVFE   F1,F0
    BL     cmm_mult    ;add (Xij)(Yjl):j=1,n
    STFS   F0,[R9]     ;store R(Zil)
    STFS   F1,[R9,#4]  ;store I(Zil)
    SUBS   R0,R0,#1
    BGT    wb3         ;loop over l
    LDMFD  sp!,{R0,lr} ;restore m and istep(Z)
    ADD    R3,R3,R5
    ADD    R9,R9,lr
    SUBS   R0,R0,#1
    BGT    wa3         ;loop over i
    B      ret         ;return
;      here we have Y = X' not overlapping Z (R3=R6,R0=R2,R5=R7,R4=R8)
wxy MOV    R2,#1       ;initialise i
    STMFD  sp!,{R0,lr} ;save m and istep(Z)
wd3; MOV    R0,R0       ;initialise l to m
    MLA    R6,R7,R0,R6 ;(Y(1,m+1))
    MLA    R9,ip,R0,R9 ;(Z(i,m+1))
    MOV    R8,R4       ;retore R8 for cmm_mult
we3 SUB    R9,R9,ip    ;(Z(i,l))
    MVFE   F0,#0       ;initialise to zero
    MVFE   F1,F0
    BL     cmm_mult    ;add (Xij)(Yjl):j=1,n
    STFS   F0,[R9]     ;store R(Zil)
    STFS   F1,[R9,#4]  ;store I(Zil)
    SUBS   R0,R0,#1
    CMP    R0,R2
    BGE    we3         ;loop over l=m,i,-1
    MOV    R5,R9       ;(Z(i,i))
    LDR    lr,[sp,#4]  ;restore istep(Z)
wh3 SUBS   R0,R0,#1
    SUBGE  R6,R6,R7    ;(Y(1,l))
    LDRGE  R8,[R5,-lr]!;copy R(Zli)
    STRGE  R8,[R9,-ip]!;to R(Zil)
    LDRGE  R8,[R5,#4]  ;copy I(Zli)
    STRGE  R8,[R9,#4]  ;to I(Zil)
    BGT    wh3         ;loop over l=i-1,1,-1
    LDR    R0,[sp]     ;restore m
    ADD    R3,R3,R7    ;(X(i+1,1))
    ADD    R9,R9,lr    ;(Z(i+1,1))
    ADD    R2,R2,#1
    CMP    R2,R0
    BLE    wd3         ;loop over i=1,m
    ADD    sp,sp,#8    ;restore stack
    B      ret         ;return
;
wxz; (X) = (Z),(R3=R9), check if Y = X'
    CMP    R3,R6
    BEQ    xyz         ;X = Y'
wi3 STMFD  sp!,{R0}    ;save M
    LDR    R0,[fp,#36] ;address of T
    MOV    ip,R2       ;initialise l to k
    MLA    R6,R7,R2,R6 ;(Y(1,k+1))
wj3 MVFE   F0,#0       ;initialise answer
    MVFE   F1,F0
    BL     cmm_mult    ;add (Xij)(Yjl):j=1,n
    STFS   F0,[R0],#4  ;store answer in T
    STFS   F1,[R0],#4
    SUBS   ip,ip,#1
    BGT    wj3         ;loop over l=k,1,-1
    MOV    R9,R3       ;(Z(i,1))
    MOV    ip,R2       ;initialise l count
wl3 LDR    lr,[R0,#-4]!;get I(Tl)
    STR    lr,[R9,#4]  ;store in I(Zil)
    LDR    lr,[R0,#-4]!;get R(Tl)
    STR    lr,[R9],R4  ;store in R(Zil)
    SUBS   ip,ip,#1
    BGT    wl3         ;loop over l=1,k
    LDMFD  sp!,{R0}    ;restore M
    ADD    R3,R3,R5    ;(X(i+1,1)) and (Z(i+1,1))
    SUBS   R0,R0,#1
    BGT    wi3         ;loop over i=1,m
    B      ret         ;return
;
wyz; (Y) = (Z) but not (X)
    MOV    R6,R3       ;make Y = X'
    MOV    R7,R5
    MOV    R8,R4
    MOV    R3,R9       ;make X = Z'(= old Y')
    MOV    R4,lr
    MOV    R5,ip
    MOV    R9,R0       ;exchange m and k
    MOV    R0,R2
    MOV    R2,R9
    B      wi3         ;now form Z' = Y'X'
;
xyz;  (Z) = (X = Y')(R3=R6=R9)(ip=R4=R8)(lr=R5=R7)
    LDR    R5,[fp,#36] ;address of T
    MOV    R9,R3       ;(Z(1,i))
    MOV    R2,R0       ;initialise i count to m
wm3 MOV    ip,R2       ;initialise l count to m-i+1
    MLA    R6,R7,R2,R3 ;(Y(1,m+1))
    MOV    R8,R4       ;restore Y j-step
wn3 MVFE   F0,#0       ;initialise answer
    MVFE   F1,F0
    BL     cmm_mult    ;add (Xij)(Yjl):j=1,n
    STFS   F0,[R5],#4  ;store answer in T
    STFS   F1,[R5],#4
    SUBS   ip,ip,#1
    BGT    wn3         ;loop over l=m,i,-1
    MOV    lr,R3       ;(Z(i,1))
    MOV    R6,R9       ;(Z(1,i))
    MOV    ip,R0       ;initialise l count to m
wp3 CMP    ip,R2
    LDRGT  R8,[R6,#4]  ;move I(Zli)
    LDRLE  R8,[R5,#-4]!;or I(Tl)
    STR    R8,[lr,#4]  ;to I(Zil)
    LDRGT  R8,[R6],R7  ;move R(Zli)
    LDRLE  R8,[R5,#-4]!;or R(Tl)
    STR    R8,[lr],R4  ;to R(Zil)
    SUBS   ip,ip,#1
    BGT    wp3         ;for l=1,m
    ADD    R3,R3,R7    ;(X(i+1,1)), (Z(i+1,1)) & (Y(1,i+1))
    ADD    R9,R9,R4    ;(Z(1,i+1))
    SUBS   R2,R2,#1
    BGT    wm3         ;loop over i=1,m
ret LDFE   F4,[sp],#12
    LDFE   F5,[sp],#12
    LDFE   F6,[sp],#12
    LDMDB  fp,{R4-R9,fp,sp,pc} ;return
    END
;
    TTL    CMMLTC
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
F6  FN     6
F5  FN     5
F4  FN     4
F3  FN     3
F2  FN     2
F1  FN     1
F0  FN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT cmmltc_;(M,N,K,X11,X12,X21,Y11,Y12,Y21,Z11,Z12,Z21,T)  Z = XY'
    DCB    "cmmltc_",0,8,0,0,255
cmmltc_
    MOV    ip,sp
    STMDB  sp!,{R0-R9,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R0,[R0]     ;m
    LDR    R1,[R1]     ;n
    LDR    R2,[R2]     ;k
    CMP    R0,#0       ;check m>0
    CMPGT  R1,#0       ;check n>0
    CMPGT  R2,#0       ;check k>0
    LDMLEDB fp,{R4-R9,fp,sp,pc} ;return if not
    STFE   F6,[sp,#-12]!
    STFE   F5,[sp,#-12]!
    STFE   F4,[sp,#-12]!
    LDMIB  fp,{R4-R9,ip,lr} ;arg addresses except T
    SUB    R4,R4,R3    ;X(i,j) :jstep
    SUB    R5,R5,R3    ;X(i,j) :istep
    SUB    R7,R7,R6    ;Y(j,l) :lstep
    SUB    R8,R8,R6    ;Y(j,l) :jstep
    SUB    ip,ip,R9    ;Z(i,l) :lstep
    SUB    lr,lr,R9    ;Z(i,l) :istep
    CMP    R3,R9
    BEQ    wxz         ;(Z) = (X)
    CMP    R6,R9
    BEQ    wyz         ;(Z) = (Y)
    CMP    R3,R6
    CMPEQ  R0,R2       ;check that Y = X'
    CMPEQ  R5,R7
    CMPEQ  R4,R8
    BEQ    wxy         ;Y = X' not overlapping Z
;        standard multiplication: Z = XY
wa3 STMFD  sp!,{R0,lr} ;save m and istep(Z)
    MOV    R0,R2       ;l-count
    MLA    R6,R7,R2,R6
    MLA    R9,ip,R2,R9
wb3 SUB    R9,R9,ip
    SUB    R6,R6,R7    ;(Y(1,l))
    BL     ccm_mult    ;sum (Xij)(Y'jl):j=1,n
    STFS   F0,[R9]     ;store R(Zil)
    STFS   F1,[R9,#4]  ;store I(Zil)
    SUBS   R0,R0,#1
    BGT    wb3         ;loop over l
    LDMFD  sp!,{R0,lr} ;restore m and istep(Z)
    ADD    R3,R3,R5
    ADD    R9,R9,lr
    SUBS   R0,R0,#1
    BGT    wa3         ;loop over i
    B      ret         ;return
;      here we have Y = X not overlapping Z
wxy MOV    R2,#1       ;initialise i
    STMFD  sp!,{R0,lr} ;save m and istep(Z)
wd3; MOV    R0,R0       ;initialise l to m
    MLA    R6,R7,R0,R6 ;(Y(1,m+1))
    MLA    R9,ip,R0,R9 ;(Z(i,m+1))
    MOV    R8,R4       ;restore R8 for ccm_mult
we3 SUB    R9,R9,ip    ;(Z(i,l))
    SUB    R6,R6,R7    ;(Y(1,l))
    BL     ccm_mult    ;sum (Xij)(Y'jl):j=1,n
    STFS   F0,[R9]     ;store R(Zil)
    STFS   F1,[R9,#4]  ;store I(Zil)
    SUB    R0,R0,#1
    CMP    R0,R2
    BGE    we3         ;loop over l=m,i,-1
    MOV    R5,R9       ;(Z(i,i))
    LDR    lr,[sp,#4]  ;restore istep(Z)
wh3 SUBS   R0,R0,#1
    SUBGE  R6,R6,R7    ;(Y(1,l))
    LDRGE  R8,[R5,-lr]!;copy R(Zli)
    STRGE  R8,[R9,-ip]!;to R(Zil)
    LDRGE  R8,[R5,#4]  ;copy -I(Zli)
    EORGE  R8,R8,#&80000000
    STRGE  R8,[R9,#4]  ;to I(Zil)
    BGT    wh3         ;loop over l=i-1,1,-1
    LDR    R0,[sp]     ;restore m
    ADD    R3,R3,R7    ;(X(i+1,1))
    ADD    R9,R9,lr    ;(Z(i+1,1))
    ADD    R2,R2,#1
    CMP    R2,R0
    BLE    wd3         ;loop over i=1,m
    ADD    sp,sp,#8    ;restore stack
    B      ret         ;return
;
wxz; (X) = (Z),(R3=R9), check if Y = X'
    CMP    R3,R6
    BEQ    xyz         ;X = Y'
wi3 STMFD  sp!,{R0}    ;save M
    LDR    R0,[fp,#36] ;address of T
    MOV    ip,R2       ;initialise l to k
    MLA    R6,R7,R2,R6 ;(Y(1,k+1))
wj3 SUB    R6,R6,R7    ;(Y(1,l))
    BL     ccm_mult    ;sum (Xij)(Y'jl):j=1,n
    STFS   F0,[R0],#4  ;store answer in T
    STFS   F1,[R0],#4
    SUBS   ip,ip,#1
    BGT    wj3         ;loop over l=k,1,-1
    MOV    R9,R3       ;(Z(i,1))
    MOV    ip,R2       ;initialise l count
wl3 LDR    lr,[R0,#-4]!;get I(Tl)
    STR    lr,[R9,#4]  ;store in I(Zil)
    LDR    lr,[R0,#-4]!;get R(Tl)
    STR    lr,[R9],R4  ;store in R(Zil)
    SUBS   ip,ip,#1
    BGT    wl3         ;loop over l=1,k
    LDMFD  sp!,{R0}    ;restore M
    ADD    R3,R3,R5    ;(X(i+1,1)) and (Z(i+1,1))
    SUBS   R0,R0,#1
    BGT    wi3         ;loop over i=1,m
    B      ret         ;return
;
wyz; (Y) = (Z) but not (X) (R6=R9)(R7=ip)(R8=lr)
wu3 STMFD  sp!,{R2}    ;save K
    MOV    ip,R0       ;initialise l to m
    LDR    R2,[fp,#36] ;address of T
    MLA    R3,R5,ip,R3 ;X(m+1,1)
wv3 SUB    R3,R3,R5    ;(Xl1)
    BL     ccm_mult    ;sum (Xlj)(Y'ji):j=1,n
    STFS   F0,[R2],#4  ;store answer in T
    STFS   F1,[R2],#4
    SUBS   ip,ip,#1
    BGT    wv3         ;loop over l=m,1,-1
    MOV    R9,R6       ;(Z(1,i))
    MOV    ip,R0       ;initialise l count to m
ww3 LDR    lr,[R2,#-4]!;get I(Tl)
    STR    lr,[R9,#4]  ;store in I(Zil)
    LDR    lr,[R2,#-4]!;get R(Tl)
    STR    lr,[R9],R8  ;store in R(Zil)
    SUBS   ip,ip,#1
    BGT    ww3         ;loop over l=1,m
    LDMFD  sp!,{R2}    ;restore M
    ADD    R6,R6,R7    ;(Y(1,i+1)) and (Z(1,i+1))
    SUBS   R2,R2,#1
    BGT    wu3         ;loop over i=1,k
    B      ret         ;return
;
yxz;  (Z) = (X' = Y)(R3=R6=R9)(lr=R4=R8)(ip=R5=R7)(R0=R2)
wq3 MOV    ip,R2       ;initialise l count to m-i+1
    MLA    R6,R7,R2,R3 ;(Y(1,m+1))
    MOV    R8,R4       ;restore Y j-step
ws3 SUB    R6,R6,R7    ;(Y(1,l))
    BL     ccm_mult    ;sum (Xij)(Y'jl):j=1,n
    STFS   F0,[R5],#4  ;store answer in T
    STFS   F1,[R5],#4
    SUBS   ip,ip,#1
    BGT    ws3         ;loop over l=m,i,-1
    MOV    lr,R3       ;(Z(i,1))
    MOV    R6,R9       ;(Z(1,i))
    MOV    ip,R0       ;initialise l count to m
wt3 CMP    ip,R2
    LDRGT  R8,[R6,#4]  ;move -I(Zli)
    LDRLE  R8,[R5,#-4]!;or -I(Tl)
    EOR    R8,R8,#&80000000
    STR    R8,[lr,#4]  ;to I(Zil)
    LDRGT  R8,[R6],R7  ;move R(Zli)
    LDRLE  R8,[R5,#-4]!;or R(Tl)
    STR    R8,[lr],R4  ;to R(Zil)
    SUBS   ip,ip,#1
    BGT    wt3         ;for l=1,m
    ADD    R3,R3,R7    ;(X(i+1,1)), (Z(i+1,1)) & (Y(1,i+1))
    ADD    R9,R9,R4    ;(Z(1,i+1))
    SUBS   R2,R2,#1
    BGT    wq3         ;loop over i=1,m
    B      ret
;
xyz;  (Z) = (X = Y')(R3=R6=R9)(ip=R4=R8)(lr=R5=R7)(R0=R2)
    LDR    R5,[fp,#36] ;address of T
    MOV    R9,R3       ;(Z(1,i))
    MOV    R2,R0       ;initialise i count to m
    CMP    ip,R4
    BNE    yxz         ;do x'=xx' which is different from x=x'x
wm3 MOV    ip,R2       ;initialise l count to m-i+1
    MLA    R6,R7,R2,R3 ;(Y(1,m+1))
    MOV    R8,R4       ;restore Y j-step
wn3 SUB    R6,R6,R7    ;(Y(1,l))
    BL     ccm_mult    ;sum (Xij)(Y'jl):j=1,n
    STFS   F0,[R5],#4  ;store answer in T
    STFS   F1,[R5],#4
    SUBS   ip,ip,#1
    BGT    wn3         ;loop over l=m,i,-1
    MOV    lr,R3       ;(Z(i,1))
    MOV    R6,R9       ;(Z(1,i))
    MOV    ip,R0       ;initialise l count to m
wp3 CMP    ip,R2
    LDRGT  R8,[R6,#4]  ;move -I(Zli)
    EORGT  R8,R8,#&80000000
    LDRLE  R8,[R5,#-4]!;or I(Tl)
    STR    R8,[lr,#4]  ;to I(Zil)
    LDRGT  R8,[R6],R7  ;move R(Zli)
    LDRLE  R8,[R5,#-4]!;or R(Tl)
    STR    R8,[lr],R4  ;to R(Zil)
    SUBS   ip,ip,#1
    BGT    wp3         ;for l=1,m
    ADD    R3,R3,R7    ;(X(i+1,1)), (Z(i+1,1)) & (Y(1,i+1))
    ADD    R9,R9,R4    ;(Z(1,i+1))
    SUBS   R2,R2,#1
    BGT    wm3         ;loop over i=1,m
ret LDFE   F4,[sp],#12
    LDFE   F5,[sp],#12
    LDFE   F6,[sp],#12
    LDMDB  fp,{R4-R9,fp,sp,pc} ;return
;
ccm_mult
    STMFD  sp!,{lr}
    MVFE   F0,#0       ;initialise to zero
    MVFE   F1,F0
    MOV    lr,R1       ;initialise j to n
    MLA    R3,R4,R1,R3 ;(X(i,n+1))
    MLA    R6,R8,R1,R6 ;(Y(n+1,l))
wc1 SUB    R3,R3,R4    ;(X(i,j))
    SUB    R6,R6,R8    ;(Y(j,l))
    LDFS   F2,[R3]     ;get R(Xij)
    LDFS   F3,[R3,#4]  ;get I(Xij)
    LDFS   F4,[R6]     ;get R(Yjl)
    LDFS   F5,[R6,#4]  ;get I(Yjl)
    MUFE   F6,F2,F4    ;R(x)R(y)
    MUFE   F2,F5,F2    ;R(x)I(y)
    MUFE   F5,F3,F5    ;I(x)I(y)
    MUFE   F3,F4,F3    ;I(x)R(y)
    SUFE   F3,F3,F2
    ADFE   F2,F6,F5
    ADFE   F0,F0,F2    ;R(sum)
    ADFE   F1,F1,F3    ;I(sum)
    SUBS   lr,lr,#1
    BGT    wc1         ;loop over j=n,1,-1
    LDMFD  sp!,{pc} 
    END
;
    TTL    CMMNA
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
F6  FN     6
F5  FN     5
F4  FN     4
F3  FN     3
F2  FN     2
F1  FN     1
F0  FN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT cmmna_;(M,N,X11,X12,X21,Y1,Y2,Z1,Z2)  Zi = - XijYj + Zi
    IMPORT cm_mult
    DCB    "cmmna_",0,0,8,0,0,255
cmmna_
    MOV    ip,sp
    STMDB  sp!,{R0-R9,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R0,[R0]     ;m
    LDR    R1,[R1]     ;n
    CMP    R0,#0
    CMPGT  R1,#0
    LDMLEDB fp,{R4-R9,fp,sp,pc} ;return
    STFE   F4,[sp,#-12]!
    STFE   F5,[sp,#-12]!
    STFE   F6,[sp,#-12]!
    LDMIB  fp,{R4-R8}  ;arg addresses
    SUB    R3,R3,R2    ; Xj step
    SUB    R4,R2,R4
    MLA    R4,R3,R1,R4 ;-Xi step
    SUB    R6,R6,R5    ; Yj step
    SUB    R8,R8,R7    ; Zi step
wa4 MOV    ip,R1       ;j count
    MOV    R9,R5       ;(Y1)
    LDFS   F0,[R7]     ;R(Zi)
    LDFS   F1,[R7,#4]  ;I(Zi)
    BL     cm_mult
    SUFE   F0,F0,F2
    SUFE   F1,F1,F3
    SUBS   ip,ip,#1
    BGT    cm_mult     ;loop over j
    STFS   F0,[R7]     ;store Zi
    STFS   F1,[R7,#4]
    ADD    R7,R7,R8
    SUB    R2,R2,R4
    SUBS   R0,R0,#1
    BGT    wa4         ;loop over i
    LDFE   F6,[sp],#12
    LDFE   F5,[sp],#12
    LDFE   F4,[sp],#12
    LDMDB  fp,{R4-R9,fp,sp,pc} ;return
    END
;
    TTL    CMMNS
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
F6  FN     6
F5  FN     5
F4  FN     4
F3  FN     3
F2  FN     2
F1  FN     1
F0  FN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT cmmns_;(M,N,X11,X12,X21,Y1,Y2,Z1,Z2)  Zi = - XijYj - Zi
    IMPORT cm_mult
    DCB    "cmmns_",0,0,8,0,0,255
cmmns_
    MOV    ip,sp
    STMDB  sp!,{R0-R9,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R0,[R0]     ;m
    LDR    R1,[R1]     ;n
    CMP    R0,#0
    CMPGT  R1,#0
    LDMLEDB fp,{R4-R9,fp,sp,pc} ;return
    STFE   F4,[sp,#-12]!
    STFE   F5,[sp,#-12]!
    STFE   F6,[sp,#-12]!
    LDMIB  fp,{R4-R8}  ;arg addresses
    SUB    R3,R3,R2    ; Xj step
    SUB    R4,R2,R4
    MLA    R4,R3,R1,R4 ;-Xi step
    SUB    R6,R6,R5    ; Yj step
    SUB    R8,R8,R7    ; Zi step
wa5 MOV    ip,R1       ;j count
    MOV    R9,R5       ;(Y1)
    LDFS   F0,[R7]     ;R(Zi)
    LDFS   F1,[R7,#4]  ;I(Zi)
    MNFE   F0,F0       ;-Zi
    MNFE   F1,F1
    BL     cm_mult
    SUFE   F0,F0,F2
    SUFE   F1,F1,F3
    SUBS   ip,ip,#1
    BGT    cm_mult     ;loop over j
    STFS   F0,[R7]     ;store Zi
    STFS   F1,[R7,#4]
    ADD    R7,R7,R8
    SUB    R2,R2,R4
    SUBS   R0,R0,#1
    BGT    wa5         ;loop over i
    LDFE   F6,[sp],#12
    LDFE   F5,[sp],#12
    LDFE   F4,[sp],#12
    LDMDB  fp,{R4-R9,fp,sp,pc} ;return
    END
;
    TTL    CM_MULT
pc  RN    15
lr  RN    14
R9  RN     9
R6  RN     6
R3  RN     3
R2  RN     2
F6  FN     6
F5  FN     5
F4  FN     4
F3  FN     3
F2  FN     2
    AREA   |C$$code|,CODE,READONLY
    EXPORT cm_mult;
cm_mult
    LDFS F2,[R9]     ;R(Yj)
    LDFS F3,[R9,#4]  ;I(Yj)
    LDFS F4,[R2]     ;R(Xij)
    LDFS F5,[R2,#4]  ;I(Xij)
    MUFE F6,F2,F5    ;R(y)I(x)
    MUFE F2,F4,F2    ;R(y)R(x)
    MUFE F5,F3,F5    ;I(y)I(x)
    MUFE F3,F4,F3    ;I(y)R(x)
    SUFE F2,F2,F5    ;R(z)
    ADFE F3,F3,F6
    ADD  R9,R9,R6
    ADD  R2,R2,R3
    MOV  pc,lr
    END
;
    TTL    CMMPA
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
F6  FN     6
F5  FN     5
F4  FN     4
F3  FN     3
F2  FN     2
F1  FN     1
F0  FN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT cmmpa_;(M,N,X11,X12,X21,Y1,Y2,Z1,Z2)  Zi = + XijYj + Zi
    IMPORT cm_mult
    DCB    "cmmpa_",0,0,8,0,0,255
cmmpa_
    MOV    ip,sp
    STMDB  sp!,{R0-R9,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R0,[R0]     ;m
    LDR    R1,[R1]     ;n
    CMP    R0,#0
    CMPGT  R1,#0
    LDMLEDB fp,{R4-R9,fp,sp,pc} ;return
    STFE   F4,[sp,#-12]!
    STFE   F5,[sp,#-12]!
    STFE   F6,[sp,#-12]!
    LDMIB  fp,{R4-R8}  ;arg addresses
    SUB    R3,R3,R2    ; Xj step
    SUB    R4,R2,R4
    MLA    R4,R3,R1,R4 ;-Xi step
    SUB    R6,R6,R5    ; Yj step
    SUB    R8,R8,R7    ; Zi step
wa6 MOV    ip,R1       ;j count
    MOV    R9,R5       ;(Y1)
    LDFS   F0,[R7]     ;R(Zi)
    LDFS   F1,[R7,#4]  ;I(Zi)
    BL     cm_mult
    ADFE   F0,F0,F2
    ADFE   F1,F1,F3
    SUBS   ip,ip,#1
    BGT    cm_mult     ;loop over j
    STFS   F0,[R7]     ;store Zi
    STFS   F1,[R7,#4]
    ADD    R7,R7,R8
    SUB    R2,R2,R4
    SUBS   R0,R0,#1
    BGT    wa6         ;loop over i
    LDFE   F6,[sp],#12
    LDFE   F5,[sp],#12
    LDFE   F4,[sp],#12
    LDMDB  fp,{R4-R9,fp,sp,pc} ;return
    END
;
    TTL    CMMPS
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
F6  FN     6
F5  FN     5
F4  FN     4
F3  FN     3
F2  FN     2
F1  FN     1
F0  FN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT cmmps_;(M,N,X11,X12,X21,Y1,Y2,Z1,Z2)  Zi = + XijYj - Zi
    IMPORT cm_mult
    DCB    "cmmps_",0,0,8,0,0,255
cmmps_
    MOV    ip,sp
    STMDB  sp!,{R0-R9,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R0,[R0]     ;m
    LDR    R1,[R1]     ;n
    CMP    R0,#0
    CMPGT  R1,#0
    LDMLEDB fp,{R4-R9,fp,sp,pc} ;return
    STFE   F4,[sp,#-12]!
    STFE   F5,[sp,#-12]!
    STFE   F6,[sp,#-12]!
    LDMIB  fp,{R4-R8}  ;arg addresses
    SUB    R3,R3,R2    ; Xj step
    SUB    R4,R2,R4
    MLA    R4,R3,R1,R4 ;-Xi step
    SUB    R6,R6,R5    ; Yj step
    SUB    R8,R8,R7    ; Zi step
wa7 MOV    ip,R1       ;j count
    MOV    R9,R5       ;(Y1)
    LDFS   F0,[R7]     ;R(Zi)
    LDFS   F1,[R7,#4]  ;I(Zi)
    MNFE   F0,F0       ;-Zi
    MNFE   F1,F1
    BL     cm_mult
    ADFE   F0,F0,F2
    ADFE   F1,F1,F3
    SUBS   ip,ip,#1
    BGT    cm_mult     ;loop over j
    STFS   F0,[R7]     ;store Zi
    STFS   F1,[R7,#4]
    ADD    R7,R7,R8
    SUB    R2,R2,R4
    SUBS   R0,R0,#1
    BGT    wa7         ;loop over i
    LDFE   F6,[sp],#12
    LDFE   F5,[sp],#12
    LDFE   F4,[sp],#12
    LDMDB  fp,{R4-R9,fp,sp,pc} ;return
    END
;
    TTL    CMMPY
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
F6  FN     6
F5  FN     5
F4  FN     4
F3  FN     3
F2  FN     2
F1  FN     1
F0  FN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT cmmpy_;(M,N,X11,X12,X21,Y1,Y2,Z1,Z2)  Zi = + XijYj
    IMPORT cm_mult
    DCB    "cmmpy_",0,0,8,0,0,255
cmmpy_
    MOV    ip,sp
    STMDB  sp!,{R0-R9,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R0,[R0]     ;m
    LDR    R1,[R1]     ;n
    CMP    R0,#0
    CMPGT  R1,#0
    LDMLEDB fp,{R4-R9,fp,sp,pc} ;return
    STFE   F4,[sp,#-12]!
    STFE   F5,[sp,#-12]!
    STFE   F6,[sp,#-12]!
    LDMIB  fp,{R4-R8}  ;arg addresses
    SUB    R3,R3,R2    ; Xj step
    SUB    R4,R2,R4
    MLA    R4,R3,R1,R4 ;-Xi step
    SUB    R6,R6,R5    ; Yj step
    SUB    R8,R8,R7    ; Zi step
wa8 MOV    ip,R1       ;j count
    MOV    R9,R5       ;(Y1)
    MVFE   F0,#0       ;R(Zi)
    MVFE   F1,F0       ;I(Zi)
    BL     cm_mult
    SUBS   ip,ip,#1
    ADFE   F0,F0,F2
    ADFE   F1,F1,F3
    BGT    cm_mult     ;loop over j
    STFS   F0,[R7]     ;store Zi
    STFS   F1,[R7,#4]
    ADD    R7,R7,R8
    SUB    R2,R2,R4
    SUBS   R0,R0,#1
    BGT    wa8         ;loop over i
    LDFE   F6,[sp],#12
    LDFE   F5,[sp],#12
    LDFE   F4,[sp],#12
    LDMDB  fp,{R4-R9,fp,sp,pc} ;return
    END
;
    TTL    CMMPYC
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
F6  FN     6
F5  FN     5
F4  FN     4
F3  FN     3
F2  FN     2
F1  FN     1
F0  FN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT cmmpyc_;(M,N,X11,X12,X21,Y1,Y2,Z1,Z2)  Zi = + XijY'j
    DCB    "cmmpyc_",0,8,0,0,255
cmmpyc_
    MOV    ip,sp
    STMDB  sp!,{R0-R9,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R0,[R0]     ;m
    LDR    R1,[R1]     ;n
    CMP    R0,#0
    CMPGT  R1,#0
    LDMLEDB fp,{R4-R9,fp,sp,pc} ;return
    STFE   F4,[sp,#-12]!
    STFE   F5,[sp,#-12]!
    STFE   F6,[sp,#-12]!
    LDMIB  fp,{R4-R8}  ;arg addresses
    SUB    R3,R3,R2    ; Xj step
    SUB    R4,R2,R4
    MLA    R4,R3,R1,R4 ;-Xi step
    SUB    R6,R6,R5    ; Yj step
    SUB    R8,R8,R7    ; Zi step
lp1 MOV    ip,R1       ;j count
    MOV    R9,R5       ;(Y1)
    MVFE   F0,#0       ;R(Zi)
    MVFE   F1,F0       ;I(Zi)
lp2 LDFS   F2,[R9]     ;R(Yj)
    LDFS   F3,[R9,#4]  ;I(Yj)
    ADD    R9,R9,R6
    LDFS   F4,[R2]     ;R(Xij)
    LDFS   F5,[R2,#4]  ;I(Xij)
    ADD    R2,R2,R3
    MUFE   F6,F2,F5    ;R(y)I(x)
    MUFE   F2,F4,F2    ;R(y)R(x)
    MUFE   F5,F3,F5    ;I(y)I(x)
    MUFE   F3,F4,F3    ;I(y)R(x)
    ADFE   F2,F2,F5    ;R(z)
    SUFE   F3,F6,F3
    ADFE   F0,F0,F2
    ADFE   F1,F1,F3
    SUBS   ip,ip,#1
    BGT    lp2         ;loop over j
    STFS   F0,[R7]     ;store Zi
    STFS   F1,[R7,#4]
    ADD    R7,R7,R8
    SUB    R2,R2,R4
    SUBS   R0,R0,#1
    BGT    lp1          ;loop over i
    LDFE   F6,[sp],#12
    LDFE   F5,[sp],#12
    LDFE   F4,[sp],#12
    LDMDB  fp,{R4-R9,fp,sp,pc} ;return
    END
;
    TTL    CMNMA
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
F6  FN     6
F5  FN     5
F4  FN     4
F3  FN     3
F2  FN     2
F1  FN     1
F0  FN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT cmnma_;(M,N,K,X11,X12,X21,Y11,Y12,Y21,Z11,Z12,Z21)  z = -xy + z
    IMPORT cmm_mult
    DCB    "cmnma_",0,0,8,0,0,255
cmnma_
    MOV    ip,sp
    STMDB  sp!,{R0-R9,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R0,[R0]     ;m
    LDR    R1,[R1]     ;n
    LDR    R2,[R2]     ;k
    CMP    R0,#0       ;check m>0
    CMPGT  R1,#0       ;check n>0
    CMPGT  R2,#0       ;check k>0
    LDMLEDB fp,{R4-R9,fp,sp,pc} ;return if not
    STFE   F6,[sp,#-12]!
    STFE   F5,[sp,#-12]!
    STFE   F4,[sp,#-12]!
    LDMIB  fp,{R4-R9,ip,lr} ;arg addresses
    SUB    R4,R4,R3    ;X(i,j) :jstep
    SUB    R5,R5,R3    ;X(i,j) :istep
    SUB    R7,R7,R6    ;Y(j,l) :lstep
    SUB    R8,R8,R6    ;Y(j,l) :jstep
    SUB    ip,ip,R9    ;Z(i,l) :lstep
    SUB    lr,lr,R9    ;Z(i,l) :istep
wa1 STMFD  sp!,{R0,lr} ;save m and istep(Z)
    MOV    R0,R2       ;initialise l to k
    MLA    R6,R7,R2,R6 ;(Y(1,k+1))
    MLA    R9,ip,R2,R9 ;(Z(i,k+1))
wb1 SUB    R9,R9,ip    ;(Z(i,l))
    LDFS   F0,[R9]     ;initialise from -Z(i,l)
    MNFS   F0,F0
    LDFS   F1,[R9,#4]
    MNFS   F1,F1
    BL     cmm_mult    ;add (Xij)(Yjl):j=1,n
    MNFS   F0,F0
    STFS   F0,[R9]     ;store R(Zil)
    MNFS   F1,F1
    STFS   F1,[R9,#4]  ;store I(Zil)
    SUBS   R0,R0,#1
    BGT    wb1         ;loop over l=k,1,-1
    LDMFD  sp!,{R0,lr} ;restore m and istep(Z)
    ADD    R3,R3,R5    ;(X(i+1,1))
    ADD    R9,R9,lr    ;(Z(i+1,1))
    SUBS   R0,R0,#1
    BGT    wa1         ;loop over i=1,m
    LDFE   F4,[sp],#12
    LDFE   F5,[sp],#12
    LDFE   F6,[sp],#12
    LDMDB  fp,{R4-R9,fp,sp,pc} ;return
    END
;
    TTL    CMNMS
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
F6  FN     6
F5  FN     5
F4  FN     4
F3  FN     3
F2  FN     2
F1  FN     1
F0  FN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT cmnms_;(M,N,K,X11,X12,X21,Y11,Y12,Y21,Z11,Z12,Z21)  z = xy - z
    IMPORT cmm_mult
    DCB    "cmnms_",0,0,8,0,0,255
cmnms_
    MOV    ip,sp
    STMDB  sp!,{R0-R9,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R0,[R0]     ;m
    LDR    R1,[R1]     ;n
    LDR    R2,[R2]     ;k
    CMP    R0,#0       ;check m>0
    CMPGT  R1,#0       ;check n>0
    CMPGT  R2,#0       ;check k>0
    LDMLEDB fp,{R4-R9,fp,sp,pc} ;return if not
    STFE   F6,[sp,#-12]!
    STFE   F5,[sp,#-12]!
    STFE   F4,[sp,#-12]!
    LDMIB  fp,{R4-R9,ip,lr} ;arg addresses
    SUB    R4,R4,R3    ;X(i,j) :jstep
    SUB    R5,R5,R3    ;X(i,j) :istep
    SUB    R7,R7,R6    ;Y(j,l) :lstep
    SUB    R8,R8,R6    ;Y(j,l) :jstep
    SUB    ip,ip,R9    ;Z(i,l) :lstep
    SUB    lr,lr,R9    ;Z(i,l) :istep
wa1 STMFD  sp!,{R0,lr} ;save m and istep(Z)
    MOV    R0,R2       ;initialise l to k
    MLA    R6,R7,R2,R6 ;(Y(1,k+1))
    MLA    R9,ip,R2,R9 ;(Z(i,k+1))
wb1 SUB    R9,R9,ip    ;(Z(i,l))
    LDFS   F0,[R9]     ;initialise from +Z(i,l)
    LDFS   F1,[R9,#4]
    BL     cmm_mult    ;add (Xij)(Yjl):j=1,n
    MNFS   F0,F0
    STFS   F0,[R9]     ;store -R(Zil)
    MNFS   F1,F1
    STFS   F1,[R9,#4]  ;store -I(Zil)
    SUBS   R0,R0,#1
    BGT    wb1         ;loop over l=k,1,-1
    LDMFD  sp!,{R0,lr} ;restore m and istep(Z)
    ADD    R3,R3,R5    ;(X(i+1,1))
    ADD    R9,R9,lr    ;(Z(i+1,1))
    SUBS   R0,R0,#1
    BGT    wa1         ;loop over i=1,m
    LDFE   F4,[sp],#12
    LDFE   F5,[sp],#12
    LDFE   F6,[sp],#12
    LDMDB  fp,{R4-R9,fp,sp,pc} ;return
    END
;
    TTL    CMRAN
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R7  RN     7
R6  RN     6
R5  RN     5
R4  RN     4
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
F4  FN     4
F3  FN     3
F2  FN     2
F1  FN     1
F0  FN     0
    AREA   RNDMDAT,DATA
    DCD    12345       ;seed
    DCD    69069       ;multplier for random seq
    AREA   |C$$code|,CODE,READONLY
    EXPORT cmran_;(M,N,A,B,Z11,Z12,Z21)  Zij = random in range [A,B]
    DCB    "cmran_",0,0,8,0,0,255
cmran_
    MOV    ip,sp
    STMDB  sp!,{R0-R7,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R0,[R0]     ;m
    LDR    R1,[R1]     ;n
    CMP    R0,#0
    CMPGT  R1,#0
    LDMLEDB fp,{R4-R7,fp,sp,pc} ;return
    STFE   F4,[sp,#-12]!
    LDMIB  fp,{R4-R6}  ;arg addresses
    LDFS   F1,[R2]     ;R(a)
    LDFS   F2,[R3]     ;R(b)
    SUFE   F2,F2,F1    ;R(b-a)
    LDFS   F0,norm     ;2**-31
    MUFE   F2,F0,F2
    LDFS   F3,[R2,#4]  ;I(a)
    LDFS   F4,[R3,#4]  ;I(b)
    SUFE   F4,F4,F3
    MUFE   F4,F0,F4
    SUB    R5,R5,R4    ; Zj step
    SUB    R6,R4,R6
    MLA    R6,R5,R1,R6 ;-Zi step
    LDR    R7,aptr
    LDMIA  R7,{R2,R3}  ;seed and multiplier
wa9 MOV    ip,R1       ;j count
wb9 MUL    R2,R3,R2    ;new seed
    MOV    lr,R2,LSR#1
    FLTE   F0,lr
    MUFE   F0,F0,F2
    ADFE   F0,F0,F1
    STFS   F0,[R4]     ;store R(Xij)
    MUL    R2,R3,R2    ;new seed
    MOV    lr,R2,LSR#1
    FLTE   F0,lr
    MUFE   F0,F0,F4
    ADFE   F0,F0,F3
    STFS   F0,[R4,#4]  ;store I(Xij)
    ADD    R4,R4,R5
    SUBS   ip,ip,#1
    BGT    wb9         ;loop over j
    SUB    R4,R4,R6
    SUBEQS R0,R0,#1
    BGT    wa9         ;loop over i
    STR    R2,[R7]     ;restore seed
    LDFE   F4,[sp],#12
    LDMDB  fp,{R4-R7,fp,sp,pc} ;return
norm DCFS  4.65661287E-10;2**-31
aptr DCD    RNDMDAT
    END
;
    TTL    CMSCL
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
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
F5  FN     5
F4  FN     4
F3  FN     3
F2  FN     2
F1  FN     1
F0  FN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT cmscl_;(M,N,S,X11,X12,X21,Z11,Z12,Z21)  Zij = S * Xij
    DCB    "cmscl_",0,0,8,0,0,255
cmscl_
    MOV    ip,sp
    STMDB  sp!,{R0-R8,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R0,[R0]     ;m
    LDR    R1,[R1]     ;n
    CMP    R0,#0
    CMPGT  R1,#0
    LDMLEDB fp,{R4-R8,fp,sp,pc} ;return
    STFE   F4,[sp,#-12]!
    STFE   F5,[sp,#-12]!
    LDMIB  fp,{R4-R8}  ;arg addresses
    LDFS   F0,[R2]     ;R(s)
    LDFS   F1,[R2,#4]  ;I(s)
    SUB    R4,R4,R3    ; Xj step
    SUB    R5,R3,R5
    MLA    R5,R4,R1,R5 ;-Xi step
    SUB    R7,R7,R6    ; Zj step
    SUB    R8,R6,R8
    MLA    R8,R7,R1,R8 ;-Zi step
waa MOV    ip,R1       ;j count
wba SUBS   ip,ip,#1
    LDFS   F2,[R3]     ;R(x)
    LDFS   F3,[R3,#4]  ;I(x)
    FMLS   F4,F0,F2    ;R(s)R(x)
    FMLS   F2,F1,F2    ;I(s)R(x)
    FMLS   F5,F1,F3    ;I(s)I(x)
    FMLS   F3,F0,F3    ;R(s)I(x)
    SUFS   F4,F4,F5
    STFS   F4,[R6]
    ADFS   F2,F2,F3    ;R(z)
    STFS   F2,[R6,#4]  ;I(z)
    ADD    R3,R3,R4
    ADD    R6,R6,R7
    BGT    wba         ;loop over j
    SUB    R3,R3,R5
    SUB    R6,R6,R8
    SUBEQS R0,R0,#1
    BGT    waa         ;loop over i
    LDFE   F5,[sp],#12
    LDFE   F4,[sp],#12
    LDMDB  fp,{R4-R8,fp,sp,pc} ;return
    END
;
    TTL    CMSET
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
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 cmset_;(M,N,S,Z11,Z12,Z21) z = s
    DCB    "cmset_",0,0,8,0,0,255
cmset_
    MOV    ip,sp
    STMDB  sp!,{R0-R6,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDMIB  fp,{R4-R6}  ;arg addresses
    LDR    R0,[R0]     ;m
    LDR    R1,[R1]     ;n
    LDMIA  R2,{R2,R6}  ;s
    SUB    R4,R4,R3    ; Zj step
    SUB    R5,R3,R5
    MLA    R5,R4,R1,R5 ;-Zi step
    CMP    R0,#1
wab MOV    ip,R1       ;j - count
wbb SUBGES ip,ip,#1
    STRGE  R6,[R3,#4]  ;to Z'ij
    STRGE  R2,[R3],R4  ;to Zij
    BGT    wbb         ;loop over j
    SUB    R3,R3,R5
    SUBEQS R0,R0,#1
    BGT    wab         ;loop over i
    LDMDB  fp,{R4-R6,fp,sp,pc} ;return
    END
;
    TTL    CMSUB
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
F1  FN     1
F0  FN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT cmsub_;(M,N,X11,X12,X21,Y11,Y12,Y21,Z11,Z12,Z21)  z = x - y
    DCB    "cmsub_",0,0,8,0,0,255
cmsub_
    MOV    ip,sp
    STMDB  sp!,{R0-R9,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R0,[R0]     ;m
    LDR    R1,[R1]     ;n
    CMP    R0,#0
    CMPGT  R1,#0
    LDMLEDB fp,{R4-R9,fp,sp,pc} ;return
    LDMIB  fp,{R4-R9,ip};arg addresses (X21 to Z21)
    SUB    R3,R3,R2    ; Xj step
    SUB    R4,R2,R4
    MLA    R4,R3,R1,R4 ;-Xi step
    SUB    R6,R6,R5    ; Yj step
    SUB    R7,R5,R7
    MLA    R7,R6,R1,R7 ;-Yi step
    SUB    R9,R9,R8    ; Zj step
    SUB    ip,R8,ip
    MLA    ip,R9,R1,ip ;-Zi step
wa1 MOV    lr,R1       ;j - count
wb1 LDFS   F0,[R2]     ;R(Xij)
    LDFS   F1,[R5]     ;R(Yij)
    SUFS   F0,F0,F1
    STFS   F0,[R8]     ;R(Zij) = R(Xij) + R(Yij)
    LDFS   F0,[R2,#4]  ;I(Xij)
    LDFS   F1,[R5,#4]  ;I(Yij)
    SUFS   F0,F0,F1
    STFS   F0,[R8,#4]  ;I(Zij) = I(Xij) + I(Yij)
    ADD    R2,R2,R3
    ADD    R5,R5,R6
    ADD    R8,R8,R9
    SUBS   lr,lr,#1
    BGT    wb1         ;loop over j
    SUB    R2,R2,R4
    SUB    R5,R5,R7
    SUB    R8,R8,ip
    SUBS   R0,R0,#1
    BGT    wa1         ;loop over i
    LDMDB  fp,{R4-R9,fp,sp,pc} ;return
    END
;
    TTL    COMBI
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT combi_;(IA,N,J) generate possible combinations
    DCB    "combi_",0,0,8,0,0,255
combi_
    MOV    ip,sp
    STMDB  sp!,{R0-R2,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R1,[R1]       ;N
    LDR    R2,[R2]       ;J
    CMP    R1,#0
    CMPGT  R2,#0
    LDMLEDB fp,{fp,sp,pc} ;return if N or J <=0
    CMP    R2,R1
    MOVGT  ip,#0
    STRGT  ip,[R0]
    LDMGTDB fp,{fp,sp,pc} ;return with IA(1)=0 if J>N
    LDR    ip,[R0],#-4   ;IA(1), (IA(0))
    ADD    R3,R0,R2,LSL#2;(IA(J))
    CMP    ip,#0
    BEQ    init          ;initialise if IA(1)=0
    LDR    lr,[R0,#4]!   ;IA(1), (IA(1))
    MOV    R2,#1         ;I=1
lp1 ADD    ip,lr,#1      ;IA(I)+1
    LDR    lr,[R0,#4]!   ;IA(I+1)
    CMP    ip,lr
    BNE    pt1
    STR    R2,[R0,#-4]   ;IA(I) = I
    ADD    R2,R2,#1
    CMP    R2,R1
    BLE    lp1           ;loop over I=1,N
pt1 STR    ip,[R0,#-4]   ;IA(I) = IA(I) + 1
    LDR    lr,[R3]       ;IA(J)
    ADD    R1,R1,#1      ;N+1
    SUBS   R1,R1,lr
    LDREQ  R0,[sp]       ;(IA(1))
    STREQ  R1,[R0]       ;IA(1)=0 if IA(J)=N+1
    LDMDB  fp,{fp,sp,pc} ;return
init;    initialise
    MOV    lr,#0
    STR    lr,[R3,#4]    ;IA(J+1)=0
lp2 STR    R2,[R3],#-4   ;IA(I)=I
    SUBS   R2,R2,#1
    BGT    lp2           ;loop over I=J,1,-1
    LDMDB  fp,{fp,sp,pc} ;return
    END
;
    TTL   CPLNML
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
F0  FN     0
F1  FN     1
F2  FN     2
F3  FN     3
F4  FN     4
F5  FN     5
F6  FN     6
R0  RN     0
R1  RN     1
R2  RN     2
R3  RN     3
    AREA   |C$$code|,CODE,READONLY
    EXPORT cplnml_ ;(X,N,C,MODE) make polynomial sum
;
    DCB    "cplnml_",0,8,0,0,255
cplnml_
    MOV    ip,sp
    STMDB  sp!,{R0-R3,fp,ip,lr,pc}
    SUB    fp,ip,#4
    STFE   F4,[sp,#-12]!
    STFE   F5,[sp,#-12]!
    STFE   F6,[sp,#-12]!
    LDFS   F2,[R1]       ;X
    LDFS   F3,[R1,#4]    ;Y
    LDR    R2,[R2]       ;N
    LDR    R1,[fp,#4]    ;(mode)
    LDR    R1,[R1]       ;mode
    CMP    R1,#0
    MOVLT  R1,#8         ;step size
    MOVGE  R1,#-8
    ADDGE  R3,R3,R2,LSL#3;pointer to relevant end of array (0 or N)
    MVFD   F0,#0         ;real accumulator
    MVFD   F1,#0         ;imag accumulator
wlp MUFD   F4,F0,F2      ;multiply sum by Z
    MUFD   F5,F1,F3
    MUFD   F6,F0,F3
    SUFD   F0,F4,F5
    MUFD   F5,F1,F2
    LDFS   F4,[R3]       ;get coefficient
    ADFD   F1,F5,F6
    LDFS   F5,[R3,#4]
    ADD    R3,R3,R1
    SUBS   R2,R2,#1
    ADFD   F0,F0,F4      ;add R(coefficient)
    ADFD   F1,F1,F5      ;add I(coefficient)
    BGE    wlp           ;loop N+1 times
    STFS   F0,[R0]       ;store result
    STFS   F1,[R0,#4]
    LDFE   F6,[sp],#12
    LDFE   F5,[sp],#12
    LDFE   F4,[sp],#12
    LDMDB  fp,{fp,sp,pc} ;return
    END
;
    TTL    CMUTL
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
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 cmutl_;(N,X11,X12,X21) Xjk = Xkj   (j>k)
    DCB    "cmutl_",0,0,8,0,0,255
cmutl_
    MOV    ip,sp
    STMDB  sp!,{R0-R6,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R0,[R0]     ;n
    SUB    R2,R2,R1    ;j step
    SUB    R3,R3,R1    ;k step
    ADD    R5,R2,R3    ;k+j step
    SUBS   R0,R0,#1
wad MOV    R4,R0       ;count
    ADD    R6,R1,R2
    ADD    lr,R1,R3
wbd LDRGT  ip,[R6,#4]  ;I(Xkj)
    STRGT  ip,[lr,#4]  ;to I(Xjk)
    LDRGT  ip,[R6],R2  ;R(Xkj)
    STRGT  ip,[lr],R3  ;to R(Xjk)
    SUBGTS R4,R4,#1
    BGT    wbd         ;loop over j
    ADD    R1,R1,R5
    SUBS   R0,R0,#1
    BGT    wad         ;loop over k
    LDMDB  fp,{R4-R6,fp,sp,pc} ;return
    END
;
    TTL    CORGEN
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
sl  RN    10
F0  FN     0
F1  FN     1
F2  FN     2
F3  FN     3
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
    AREA   |C$$code|,CODE,READONLY
    EXPORT corgen_ ;(C,X,N) generates random n-vectors in X according to
;                   matrix C(N,N) created by CORSET
    EXPORT corset_ ;(V,C,N) creates C(N,N) from error matrix V(N,N)
    IMPORT rnorml_ ;(Z,NP) returns vector of NP random Gaussian normal numbers
    IMPORT __rt_stkovf_split_big
;
    DCB    "corgen_",0,8,0,0,255
corgen_
    MOV    ip,sp
    STMDB  sp!,{R0-R2,fp,ip,lr,pc}
    SUB    fp,ip,#4
    MOV    R1,R2         ;(N)
    LDR    R2,[R2]       ;N
;             reserve space for normal random numbers
    SUB    ip,sp,R2,LSL#2
    CMP    ip,sl
    BLLT   __rt_stkovf_split_big
    SUB    sp,sp,R2,LSL#2
    MOV    R0,sp         ;address for random vector
    BL     rnorml_
    SUB    ip,fp,#12
    LDMDB  ip,{R0-R2}    ;restore arguments
    LDR    R2,[R2]       ;N
    MOV    R3,#0         ;count (I=1,N)
lp1 MVFS   F0,#0         ;initialise accumulator
    ADD    ip,R3,#1      ;inner count (J=1,I)
    ADD    lr,R0,R3,LSL#2;(C(I,1))
lp2 LDFS   F1,[lr]       ;C(I,J)
    LDFS   F2,[sp],#4    ;Z(J)
    ADD    lr,lr,R2,LSL#2
    FMLS   F3,F1,F2
    SUBS   ip,ip,#1
    ADFS   F0,F0,F3      ;sum C(I,J)*Z(J)
    BGT    lp2           ;loop over J
    ADD    R3,R3,#1
    SUB    sp,sp,R3,LSL#2;restore stack pointer
    STFS   F0,[R1],#4    ;store result
    CMP    R3,R2
    BLT    lp1
    LDMDB fp,{fp,sp,pc} 
;
    DCB    "corset_",0,8,0,0,255
corset_;(V,C,N)
    MOV    ip,sp
    STMDB  sp!,{R0-R2,R4-R8,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R2,[R2]       ;N
;               Compute C = square root of matrix V
    MOV    R3,#0         ;initialize J (really 1)
    MOV    R4,#0         ;initialize (J,J)
lp3 MVFS   F0,#0         ;CK=0.
    MOVS   ip,R3         ;count for loop K=1,J-1
    ADDGT  lr,R1,R3,LSL#2;(C(J,1))
lp4 LDFGTS F1,[lr]       ;C(J,K)
    ADDGT  lr,lr,R2,LSL#2
    FMLGTS F2,F1,F1
    ADFGTS F0,F0,F2      ;CK = CK + C(J,K)*C(J,K)
    SUBS   ip,ip,#1
    BGT    lp4           ;loop over K (J-1 times)
    ADD    R6,R0,R4      ;(V(J,J))
    LDFS   F1,[R6]
    ADD    R8,R1,R4      ;(C(J,J))
    SUFS   F0,F1,F0      ;V(J,J) - CK
    ABSS   F0,F0
    SQTS   F0,F0
    STFS   F0,[R8]       ;C(J,J) = SQRT(ABS(V(J,J) - CK))
;             off diagonal terms
    ADD    R7,R3,#1      ;I=J+1
    CMP    R7,R2
    LDMGEDB fp,{R4-R8,fp,sp,pc} 
lp5 MVFS   F1,#0         ;CK=0.
    MOVS   ip,R3         ;count for loop K=1,J-1
    ADDGT  R5,R1,R3,LSL#2;(C(J,1))
    ADDGT  lr,R1,R7,LSL#2;(C(I,1))
lp6 LDFGTS F2,[R5]       ;C(J,K)
    LDFGTS F3,[lr]       ;C(I,K)
    ADDGT  R5,R5,R2,LSL#2
    FMLGTS F2,F2,F3
    ADDGT  lr,lr,R2,LSL#2
    ADFGTS F1,F1,F2      ;CK = CK + C(I,K)*C(J,K)
    SUBGTS ip,ip,#1
    BGT    lp6
    LDFS   F2,[R6,#4]!   ;V(I,J)
    SUFS   F2,F2,F1
    FDVS   F3,F2,F0      ;(V(I,J) - CK) /C(J,J)
    STFS   F3,[R8,#4]!   ;store in C(I,J)
    ADD    R7,R7,#1
    CMP    R7,R2
    BLT    lp5           ;loop over I= J+1, N
    ADD    R4,R4,#4
    ADD    R4,R4,R2,LSL#2;increment (J,J)
    ADD    R3,R3,#1      ;J = J + 1
    B      lp3           ;loop over J=1,N
    END
;
    TTL    CRIGHT
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R7  RN     7
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
    AREA   slate__,COMMON,NOINIT
    %      160
;
    AREA   |C$$code|,CODE,READONLY
    EXPORT cright_;(LINE,JL,JR) squeezes blanks in LINE(JL:JR) to left
    DCB    "cright_",0,8,0,0,255
cright_
    MOV    ip,sp
    STMDB  sp!,{R0-R2,R7,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R1,[R1]     ;JL
    LDR    R2,[R2]     ;JR
    MOV    R3,R2       ;copy of JR
    MOV    R7,R2       ;initialize NE to JR
    MOV    lr,#" "
wt2 SUB    R3,R3,#1    ;dec total count
    LDRB   ip,[R0,R3]
    CMP    ip,#" "     ;is byte blank?
    SUBNE  R7,R7,#1    ;dec count of non-blank
    CMPNE  R3,R7
    STRNEB ip,[R0,R7]  ;pack in non-blank
    STRNEB lr,[R0,R3]
    CMP    R3,R1
    BGE    wt2         ;loop until < JL
    LDR    R0,slpt
    SUB    R2,R2,R7
    STMIA  R0,{R2,R7}  ;store ND,NE
    LDMDB  fp,{R7,fp,sp,pc} ;return
slpt DCD    slate__     ;pointer to COMMON/SLATE/
    END
;
    TTL    CROSS
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R2  RN     2
R1  RN     1
R0  RN     0
F7  FN     7
F6  FN     6
F5  FN     5
F4  FN     4
F3  FN     3
F2  FN     2
F1  FN     1
F0  FN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT cross_;(A,B,C) C = vector A x B
    DCB    "cross_",0,0,8,0,0,255
cross_
    MOV    ip,sp
    STMDB  sp!,{R0-R2,fp,ip,lr,pc}
    SUB    fp,ip,#4
    STFE   F4,[sp,#-12]! ;save floating registers
    STFE   F5,[sp,#-12]!
    STFE   F6,[sp,#-12]!
    STFE   F7,[sp,#-12]!
    LDFS   F0,[R0]     ;A(1)
    LDFS   F1,[R0,#4]  ;A(2)
    LDFS   F2,[R0,#8]  ;A(3)
    LDFS   F3,[R1]     ;B(1)
    LDFS   F4,[R1,#4]  ;B(2)
    LDFS   F5,[R1,#8]  ;B(3)
    FMLS   F6,F1,F5    ;A(2)*B(3)
    FMLS   F7,F2,F4    ;A(3)*B(2)
    FMLS   F2,F2,F3    ;A(3)*B(1)
    FMLS   F5,F5,F0    ;A(1)*B(3)
    FMLS   F4,F4,F0    ;A(1)*B(2)
    FMLS   F3,F3,F1    ;A(2)*B(1)
    SUFS   F0,F6,F7
    SUFS   F1,F2,F5
    SUFS   F2,F4,F3
    STFS   F0,[R2]     ;C(1) = A(2)*B(3) - A(3)*B(2)
    STFS   F1,[R2,#4]  ;C(2) = A(3)*B(1) - A(1)*B(3)
    STFS   F2,[R2,#8]  ;C(3) = A(1)*B(2) - A(2)*B(1)
    LDFE   F7,[sp],#12 ;restore floating registers
    LDFE   F6,[sp],#12
    LDFE   F5,[sp],#12
    LDFE   F4,[sp],#12
    LDMDB  fp,{fp,sp,pc} 
    END
;
    TTL    CSETDI
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
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
    AREA   slate__,COMMON,NOINIT
    %      160
;
    AREA   |C$$code|,CODE,READONLY
    EXPORT csetdi_;(INT,LINE,JL,JR) stores integer INT in decimal LINE(JL:JR)
    DCB    "csetdi_",0,8,0,0,255
csetdi_
    MOV    ip,sp
    STMDB  sp!,{R0-R3,R6-R9,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R0,[R0]     ;INT
    LDR    R2,[R2]     ;JL
    LDR    R7,[R3]     ;initialise NE to JR
    MOVS   R9,R0
    RSBMI  R9,R9,#0    ;|int|
    MOV    R6,R7       ;initialize ND to NE
wi1 MOV    R3,#32      ;divide ng by 10
    MOV    lr,#0
wi2 CMP    lr,#5
    SUBCS  lr,lr,#5
    ADCS   R9,R9,R9
    ADC    lr,lr,lr
    SUBS   R3,R3,#1
    BGT    wi2         ;loop over bits
    ADD    lr,lr,#"0"
    CMP    R7,R2       ;check for space
    SUB    R7,R7,#1
    STRB   lr,[R1,R7]  ;store digit
    CMPGT  R9,#0       ;if not full, check for more digits
    BGT    wi1         ;loop over digits
    SUB    R6,R6,R7    ;#digits set
    MOV    R8,R7       ;initialise NF
    TEQ    R0,#&80000000;check for -ve int
    CMPPL  R8,R2       ;if -ve,check for space
    MOVPL  R3,#"-"
    SUBPL  R8,R8,#1
    STRPLB R3,[R1,R8]  ;store "-"
    TEQMI  R0,#0
    MOVMI  R9,R2       ;flag overflow
    LDR    R0,slpt     ;pointer to /SLATE/
    STMIA  R0,{R6-R9}  ;store ND,NE,NF,NG
    LDMDB  fp,{R6-R9,fp,sp,pc} ;return
slpt DCD    slate__
    END
;
    TTL    CSETHI
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
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
    AREA   slate__,COMMON,NOINIT
    %      160
;
    AREA   |C$$code|,CODE,READONLY
    EXPORT csethi_;(INT,LINE,JL,JR) stores integer INT in hex LINE(JL:JR)
    DCB    "csethi_",0,8,0,0,255
csethi_
    MOV    ip,sp
    STMDB  sp!,{R0-R3,R6-R9,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R9,[R0]     ;INT
    LDR    R2,[R2]     ;JL
    LDR    R3,[R3]     ;JR
    MOV    R7,R3       ;initialise NE = JR
wh1 AND    ip,R9,#15   ;get nibble in ip
    ADD    ip,ip,#"0"
    CMP    ip,#"9"
    ADDGT  ip,ip,#7    ;correct '10' to 'A' etc
    CMP    R7,R2       ;check for space
    SUBGE  R7,R7,#1
    STRGEB ip,[R1,R7]  ;store digit
    MOVGTS R9,R9,LSR#4 ;if not full, check for more digits
    BGT    wh1         ;loop over digits
    SUB    R6,R3,R7    ;#digits set (ND)
    MOV    R8,R7       ;NF = NE
    LDR    R0,slpt     ;pointer to /SLATE/
    STMIA  R0,{R6-R9}  ;store ND,NE,NF,NG
    LDMDB  fp,{R6-R9,fp,sp,pc} ;return
slpt DCD    slate__
    END
;
    TTL    CSETOI
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
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
    AREA   slate__,COMMON,NOINIT
    %      160
;
    AREA   |C$$code|,CODE,READONLY
    EXPORT csetoi_;(INT,LINE,JL,JR) stores integer INT in octal LINE(JL:JR)
    DCB    "csetoi_",0,8,0,0,255
csetoi_
    MOV    ip,sp
    STMDB  sp!,{R0-R3,R6-R9,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R9,[R0]     ;INT
    LDR    R2,[R2]     ;JL
    LDR    R3,[R3]     ;JR
    MOV    R7,R3       ;initialise NE = JR
wh2 AND    ip,R9,#7    ;get nibble in ip
    ADD    ip,ip,#"0"
    CMP    R7,R2       ;check for space
    SUBGE  R7,R7,#1
    STRGEB ip,[R1,R7]  ;store digit
    MOVGTS R9,R9,LSR#3 ;if not full, check for more digits
    BGT    wh2         ;loop over digits
wj1 SUB    R6,R3,R7    ;#digits set (ND)
    MOV    R8,R7       ;NF = NE
wj2 LDR    R0,slpt     ;pointer to /SLATE/
    STMIA  R0,{R6-R9}  ;store ND,NE,NF,NG
    LDMDB  fp,{R6-R9,fp,sp,pc} ;return
slpt DCD    slate__     ;pointer to COMMON/SLATE/
    END
;
    TTL    CSETVI
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   slate__,COMMON,NOINIT
    %      160
;
    AREA   |C$$code|,CODE,READONLY
    EXPORT csetvi_;(NI,INTV,NBIAS,LINE,JL,JR,NCOL,IFLSQ) vector of integers to characters
    DCB    "csetvi_",0,8,0,0,255
csetvi_
    MOV    ip,sp
    STMDB  sp!,{R0-R9,fp,ip,lr,pc}
    SUB    fp,ip,#4
    MOV    ip,#1       ;flag for CSETVI
    B      wz1
;
    EXPORT csetvm_;(NI,INC ,IGO  ,LINE,JL,JR,NCOL,IFLSQ) generated integers to characters
    DCB    "csetvm_",0,8,0,0,255
csetvm_
    MOV    ip,sp
    STMDB  sp!,{R0-R9,fp,ip,lr,pc}
    SUB    fp,ip,#4
    MOV    ip,#-1      ;flag for CSETVM
wz1 LDMIB  fp,{R4-R6,R8};addresses of JL to IFLSQ
    LDR    R0,[R0]     ;NI
    STR    R0,[sp,#-4]!;save on stack
    LDR    R2,[R2]     ;NBIAS or IGO
    CMP    ip,#0
    LDRLT  R7,[R1]     ;INC
    SUBLT  lr,R2,R7    ;initialise number to IGO - INC
    MOVLT  R2,R7       ;INC or NBIAS
    LDR    R4,[R4]     ;JL
    LDR    R5,[R5]     ;JR
    LDR    R6,[R6]     ;NCOL
    LDR    R8,[R8]     ;IFLSQ
    SUB    R4,R4,#1    ;JL' = JL - 1
    ADD    R3,R3,R4    ;(LINE(JL)
zz1 ADD    R4,R4,R6    ;JL' = JL' + NCOL
    CMP    R4,R5
    BGT    ii5         ;overflow LINE
    CMP    ip,#0
    LDRGT  lr,[R1],#4
    ADD    lr,lr,R2    ;add BIAS or INC
    STMFD  sp!,{R2,R5}
    MOVS   R9,lr       ;get INT
    RSBMI  R9,R9,#0    ;|INT|
    SUB    R7,R6,#1    ;initialize count of digits
ii1 MOV    R2,#32      ;divide R9 by 10
    MOV    R5,#0
ii2 CMP    R5,#5
    SUBCS  R5,R5,#5
    ADCS   R9,R9,R9
    ADC    R5,R5,R5
    SUBS   R2,R2,#1
    BGT    ii2         ;loop over bits
    ADD    R5,R5,#"0"
    STRB   R5,[R3,R7]  ;store digit
    SUBS   R7,R7,#1    ;count digits
    CMPGT  R9,#0       ;if not full, check for more digits
    BGT    ii1         ;loop over digits
    CMP    lr,#-1
    MOVLE  R2,#"-"
    STRLEB R2,[R3,R7]  ;store "-"
    SUBLES R7,R7,#1
    RSBGTS R9,R9,#1
    ADDLE  sp,sp,#8    ;restore stack
    BLE    ii5         ;overflow field
    MOV    R2,#" "
    MOV    R9,R7
ii3 STRB   R2,[R3,R7]  ;fill with blanks
    SUBS   R7,R7,#1
    BGE    ii3
    CMP    R8,#0       ;check IFLSQ
    CMPNE  R9,#0
    ADDEQ  R3,R3,R6    ;(LINE(JL+NCOL))
    SUBNE  R4,R4,R9
    SUBNE  R7,R6,R9
ii4 LDRNEB R5,[R3,R9]
    STRNEB R2,[R3,R9]
    STRNEB R5,[R3],#1
    SUBNES R7,R7,#1
    BGT    ii4
    LDMFD  sp!,{R2,R5}
    SUBS   R0,R0,#1
    BGT    zz1         ;loop over integers
ii5 LDR    ip,slpt
    STR    R4,[ip,#4]  ;store NE
    SUBS   R2,R0,#1
    LDRGE  R1,[sp]     ;get NI
    SUBGE  R0,R1,R2
    STR    R0,[ip,#12] ;store NG
    LDMDB  fp,{R4-R9,fp,sp,pc} ;return
slpt DCD    slate__
    END
;
;          CSETVM see CSETVI
;
    TTL    CSQMBL
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
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
    AREA   slate__,COMMON,NOINIT
    %      160
;
    AREA   |C$$code|,CODE,READONLY
    EXPORT csqmbl_;(LINE,JL,JR) squeeze multiple blanks from LINE(JL:JR)
    DCB    "csqmbl_",0,8,0,0,255
csqmbl_
    MOV    ip,sp
    STMDB  sp!,{R0-R3,R6-R9,fp,ip,lr,pc}
    SUB    fp,ip,#4
    MOV    ip,#" "     ;squeeze blanks
    LDR    R3,[R2]     ;JR
    LDR    R2,[R1]     ;JL
    SUB    R1,R0,#2    ;(LINE(-1:-1))
    B      wb1
;
    EXPORT csqmch_;(CH,LINE,JL,JR) squeeze multiple characters from LINE(JL:JR)
    DCB    "csqmch_",0,8,0,0,255
csqmch_
    MOV    ip,sp
    STMDB  sp!,{R0-R3,R6-R9,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDRB   ip,[R0]     ;CH
    SUB    R1,R1,#2    ;(LINE(-1:-1))
    LDR    R2,[R2]     ;JL
    LDR    R3,[R3]     ;JR
wb1 MOV    R7,R2       ;initialize NE to JL
    MOV    R0,R2       ;copy of JL
    MOV    R8,#" "     ;blank for filling
    MOV    R9,#0       ;count of consecutive CH
wb2 ADD    R2,R2,#1
    LDRB   lr,[R1,R2]
    CMP    lr,ip
    ADDEQ  R9,R9,#1    ;count CH
    MOVNE  R9,#0
    CMP    R9,#1
    ADDLE  R7,R7,#1
    STRLEB lr,[R1,R7]
    CMP    R7,R2
    STRLTB R8,[R1,R2]  ;fill space with blanks
    CMP    R2,R3
    BLE    wb2         ;loop over string
    CMP    lr,ip
    SUBEQ  R7,R7,#1
    LDR    lr,slpt     ;/SLATE/
    SUB    R6,R7,R0
    STMIA  lr,{R6,R7}  ;store ND,NE
    LDMDB  fp,{R6-R9,fp,sp,pc} ;return
slpt DCD    slate__     ;pointer to COMMON/SLATE/
    END
;
;          CSQMCH see CSQMBL
;
    TTL    CTRANS
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT ctrans_;(CHOLD,CHNEW,LINE,JL,JR) change CHOLD to CHNEW in LINE(JL:JR)
    DCB    "ctrans_",0,8,0,0,255
ctrans_
    MOV    ip,sp
    STMDB  sp!,{R0-R3,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDRB   R0,[R0]     ;CHOLD
    LDRB   R1,[R1]     ;CHNEW
    LDR    R3,[R3]     ;JL
    LDR    ip,[ip]
    LDR    ip,[ip]     ;JR
    ADD    R2,R2,ip    ;(LINE(JR+1:JR+1))
    SUBS   ip,ip,R3    ;count
wb4 LDRGEB R3,[R2,#-1]!
    CMPGE  R3,R0
    STREQB R1,[R2]     ;substitute CHNEW
    SUBS   ip,ip,#1
    BGE    wb4
    LDMDB  fp,{fp,sp,pc} ;return
    END
;
    TTL    CUMNA
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
F6  FN     6
F5  FN     5
F4  FN     4
F3  FN     3
F2  FN     2
F1  FN     1
F0  FN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT cumna_;(N,U11,U12,U22,Y1,Y2,Z1,Z2)    Zj =  Zj - sum(Ujk * Yk) k=j,n
    IMPORT cm_mult
    DCB    "cumna_",0,0,8,0,0,255
cumna_
    MOV    ip,sp
    STMDB  sp!,{R0-R9,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R0,[R0]     ;N
    CMP    R0,#0
    LDMLEDB fp,{R4-R9,fp,sp,pc} ;return if N<1
    STFE   F4,[sp,#-12]!
    STFE   F5,[sp,#-12]!
    STFE   F6,[sp,#-12]!
    LDMIB  fp,{R5-R8}  ;arg addresses
    SUB    ip,R3,R1    ; Ujj step
    SUB    R3,R2,R1    ; U.k step
    SUB    R6,R6,R5    ; Yk step
    SUB    R8,R8,R7    ; Zj step
lp1 MOV    R4,R0       ;k-count (=N-J+1)
    LDFS   F0,[R7]     ;initialise R(Zj)
    LDFS   F1,[R7,#4]  ;initialise I(Zj)
    MOV    R2,R1       ;(j,k) = (j,j)
    MOV    R9,R5       ;(k)
    BL     cm_mult
    SUFE   F0,F0,F2    ;-R(sum)
    SUFE   F1,F1,F3    ;-I(sum)
    SUBS   R4,R4,#1
    BGT    cm_mult     ;loop over k
    STFS   F0,[R7]     ;store R(Zj)
    STFS   F1,[R7,#4]  ;store I(Zj)
    ADD    R7,R7,R8
    ADD    R1,R1,ip
    ADD    R5,R5,R6
    SUBS   R0,R0,#1
    BGT    lp1         ;loop over j
    LDFE   F6,[sp],#12
    LDFE   F5,[sp],#12
    LDFE   F4,[sp],#12
    LDMDB  fp,{R4-R9,fp,sp,pc} ;return
    END
;
    TTL    CUMNS
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
F6  FN     6
F5  FN     5
F4  FN     4
F3  FN     3
F2  FN     2
F1  FN     1
F0  FN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT cumns_;(N,U11,U12,U22,Y1,Y2,Z1,Z2)    Zj =  -Zj - sum(Ujk * Yk) k=j,n
    IMPORT cm_mult
    DCB    "cumns_",0,0,8,0,0,255
cumns_
    MOV    ip,sp
    STMDB  sp!,{R0-R9,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R0,[R0]     ;N
    CMP    R0,#0
    LDMLEDB fp,{R4-R9,fp,sp,pc} ;return if N<1
    STFE   F4,[sp,#-12]!
    STFE   F5,[sp,#-12]!
    STFE   F6,[sp,#-12]!
    LDMIB  fp,{R5-R8}  ;arg addresses
    SUB    ip,R3,R1    ; Ujj step
    SUB    R3,R2,R1    ; U.k step
    SUB    R6,R6,R5    ; Yk step
    SUB    R8,R8,R7    ; Zj step
lp1 MOV    R4,R0       ;k-count (=N-J+1)
    LDFS   F0,[R7]
    MNFS   F0,F0       ;initialise R(Zj)
    LDFS   F1,[R7,#4]
    MNFS   F1,F1       ;initialise I(Zj)
    MOV    R2,R1       ;(j,k) = (j,j)
    MOV    R9,R5       ;(k)
    BL     cm_mult
    SUFE   F0,F0,F2    ;-R(sum)
    SUFE   F1,F1,F3    ;-I(sum)
    SUBS   R4,R4,#1
    BGT    cm_mult     ;loop over k
    STFS   F0,[R7]     ;store R(Zj)
    STFS   F1,[R7,#4]  ;store I(Zj)
    ADD    R7,R7,R8
    ADD    R1,R1,ip
    ADD    R5,R5,R6
    SUBS   R0,R0,#1
    BGT    lp1         ;loop over j
    LDFE   F6,[sp],#12
    LDFE   F5,[sp],#12
    LDFE   F4,[sp],#12
    LDMDB  fp,{R4-R9,fp,sp,pc} ;return
    END
;
    TTL    CUMPA
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
F6  FN     6
F5  FN     5
F4  FN     4
F3  FN     3
F2  FN     2
F1  FN     1
F0  FN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT cumpa_;(N,U11,U12,U22,Y1,Y2,Z1,Z2)    Zj =  Zj + sum(Ujk * Yk) k=j,n
    IMPORT cm_mult
    DCB    "cumpa_",0,0,8,0,0,255
cumpa_
    MOV    ip,sp
    STMDB  sp!,{R0-R9,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R0,[R0]     ;N
    CMP    R0,#0
    LDMLEDB fp,{R4-R9,fp,sp,pc} ;return if N<1
    STFE   F4,[sp,#-12]!
    STFE   F5,[sp,#-12]!
    STFE   F6,[sp,#-12]!
    LDMIB  fp,{R5-R8}  ;arg addresses
    SUB    ip,R3,R1    ; Ujj step
    SUB    R3,R2,R1    ; U.k step
    SUB    R6,R6,R5    ; Yk step
    SUB    R8,R8,R7    ; Zj step
lp1 MOV    R4,R0       ;k-count (=N-J+1)
    LDFS   F0,[R7]     ;initialise R(Zj)
    LDFS   F1,[R7,#4]  ;initialise I(Zj)
    MOV    R2,R1       ;(j,k) = (j,j)
    MOV    R9,R5       ;(k)
    BL     cm_mult
    ADFE   F0,F0,F2    ;R(sum)
    ADFE   F1,F1,F3    ;I(sum)
    SUBS   R4,R4,#1
    BGT    cm_mult     ;loop over k
    STFS   F0,[R7]     ;store R(Zj)
    STFS   F1,[R7,#4]  ;store I(Zj)
    ADD    R7,R7,R8
    ADD    R1,R1,ip
    ADD    R5,R5,R6
    SUBS   R0,R0,#1
    BGT    lp1         ;loop over j
    LDFE   F6,[sp],#12
    LDFE   F5,[sp],#12
    LDFE   F4,[sp],#12
    LDMDB  fp,{R4-R9,fp,sp,pc} ;return
    END
;
    TTL    CUMPS
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
F6  FN     6
F5  FN     5
F4  FN     4
F3  FN     3
F2  FN     2
F1  FN     1
F0  FN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT cumps_;(N,U11,U12,U22,Y1,Y2,Z1,Z2)    Zj = -Zj + sum(Ujk * Yk) k=j,n
    IMPORT cm_mult
    DCB    "cumps_",0,0,8,0,0,255
cumps_
    MOV    ip,sp
    STMDB  sp!,{R0-R9,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R0,[R0]     ;N
    CMP    R0,#0
    LDMLEDB fp,{R4-R9,fp,sp,pc} ;return if N<1
    STFE   F4,[sp,#-12]!
    STFE   F5,[sp,#-12]!
    STFE   F6,[sp,#-12]!
    LDMIB  fp,{R5-R8}  ;arg addresses
    SUB    ip,R3,R1    ; Ujj step
    SUB    R3,R2,R1    ; U.k step
    SUB    R6,R6,R5    ; Yk step
    SUB    R8,R8,R7    ; Zj step
lp1 MOV    R4,R0       ;k-count (=N-J+1)
    LDFS   F0,[R7]
    MNFS   F0,F0       ;initialise R(Zj)
    LDFS   F1,[R7,#4]
    MNFS   F1,F1       ;initialise I(Zj)
    MOV    R2,R1       ;(j,k) = (j,j)
    MOV    R9,R5       ;(k)
    BL     cm_mult
    ADFE   F0,F0,F2    ;R(sum)
    ADFE   F1,F1,F3    ;I(sum)
    SUBS   R4,R4,#1
    BGT    cm_mult     ;loop over k
    STFS   F0,[R7]     ;store R(Zj)
    STFS   F1,[R7,#4]  ;store I(Zj)
    ADD    R7,R7,R8
    ADD    R1,R1,ip
    ADD    R5,R5,R6
    SUBS   R0,R0,#1
    BGT    lp1         ;loop over j
    LDFE   F6,[sp],#12
    LDFE   F5,[sp],#12
    LDFE   F4,[sp],#12
    LDMDB  fp,{R4-R9,fp,sp,pc} ;return
    END
;
    TTL    CUMPY
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
F6  FN     6
F5  FN     5
F4  FN     4
F3  FN     3
F2  FN     2
F1  FN     1
F0  FN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT cumpy_;(N,U11,U12,U22,Y1,Y2,Z1,Z2)    Zj =  sum(Ujk * Yk) k=j,n
    IMPORT cm_mult
    DCB    "cumpy_",0,0,8,0,0,255
cumpy_
    MOV    ip,sp
    STMDB  sp!,{R0-R9,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R0,[R0]     ;N
    CMP    R0,#0
    LDMLEDB fp,{R4-R9,fp,sp,pc} ;return if N<1
    STFE   F4,[sp,#-12]!
    STFE   F5,[sp,#-12]!
    STFE   F6,[sp,#-12]!
    LDMIB  fp,{R5-R8}  ;arg addresses
    SUB    ip,R3,R1    ; Ujj step
    SUB    R3,R2,R1    ; U.k step
    SUB    R6,R6,R5    ; Yk step
    SUB    R8,R8,R7    ; Zj step
lp1 MOV    R4,R0       ;k-count (=N-J+1)
    MVFS   F0,#0       ;initialise R(Zj)
    MVFS   F1,F0       ;initialise I(Zj)
    MOV    R2,R1       ;(j,k) = (j,j)
    MOV    R9,R5       ;(k)
    BL     cm_mult
    ADFE   F0,F0,F2    ;R(sum)
    ADFE   F1,F1,F3    ;I(sum)
    SUBS   R4,R4,#1
    BGT    cm_mult     ;loop over k
    STFS   F0,[R7]     ;store R(Zj)
    STFS   F1,[R7,#4]  ;store I(Zj)
    ADD    R7,R7,R8
    ADD    R1,R1,ip
    ADD    R5,R5,R6
    SUBS   R0,R0,#1
    BGT    lp1         ;loop over j
    LDFE   F6,[sp],#12
    LDFE   F5,[sp],#12
    LDFE   F4,[sp],#12
    LDMDB  fp,{R4-R9,fp,sp,pc} ;return
    END
;
    TTL    CUMPYC
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
F6  FN     6
F5  FN     5
F4  FN     4
F3  FN     3
F2  FN     2
F1  FN     1
F0  FN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT cumpyc_;(N,U11,U12,U22,Y1,Y2,Z1,Z2)    Zj =  sum(Ujk * Y'k) k=j,n
    DCB    "cumpyc_",0,8,0,0,255
cumpyc_
    MOV    ip,sp
    STMDB  sp!,{R0-R9,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R0,[R0]     ;N
    CMP    R0,#0
    LDMLEDB fp,{R4-R9,fp,sp,pc} ;return if N<1
    STFE   F4,[sp,#-12]!
    STFE   F5,[sp,#-12]!
    STFE   F6,[sp,#-12]!
    LDMIB  fp,{R5-R8}  ;arg addresses
    SUB    ip,R3,R1    ; Ujj step
    SUB    R3,R2,R1    ; U.k step
    SUB    R6,R6,R5    ; Yk step
    SUB    R8,R8,R7    ; Zj step
lp1 MOV    R4,R0       ;k-count (=N-J+1)
    MVFS   F0,#0       ;initialise R(Zj)
    MVFS   F1,F0       ;initialise I(Zj)
    MOV    R2,R1       ;(j,k) = (j,j)
    MOV    R9,R5       ;(k)
lp2 LDFS   F2,[R9]     ;R(Yj)
    LDFS   F3,[R9,#4]  ;I(Yj)
    ADD    R9,R9,R6
    LDFS   F4,[R2]     ;R(Xij)
    LDFS   F5,[R2,#4]  ;I(Xij)
    ADD    R2,R2,R3
    MUFE   F6,F2,F5    ;R(y)I(x)
    MUFE   F2,F4,F2    ;R(y)R(x)
    MUFE   F5,F3,F5    ;I(y)I(x)
    MUFE   F3,F4,F3    ;I(y)R(x)
    ADFE   F2,F2,F5    ;R(z)
    SUFE   F3,F6,F3
    ADFE   F0,F0,F2    ;R(sum)
    ADFE   F1,F1,F3    ;I(sum)
    SUBS   R4,R4,#1
    BGT    lp2         ;loop over k
    STFS   F0,[R7]     ;store R(Zj)
    STFS   F1,[R7,#4]  ;store I(Zj)
    ADD    R7,R7,R8
    ADD    R1,R1,ip
    ADD    R5,R5,R6
    SUBS   R0,R0,#1
    BGT    lp1         ;loop over j
    LDFE   F6,[sp],#12
    LDFE   F5,[sp],#12
    LDFE   F4,[sp],#12
    LDMDB  fp,{R4-R9,fp,sp,pc} ;return
    END
;
    TTL    CUTOL
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT cutol_;(STR) converts upper case letters in STR to lower case
    DCB    "cutol_",0,0,8,0,0,255
cutol_
    MOV    ip,sp
    STMDB  sp!,{R0,R1,fp,ip,lr,pc}
    SUB    fp,ip,#4
wu2 LDRB   R2,[R0],#1
    CMP    R2,#"A"     ;check for upper case
    ADDGE  R2,R2,#32   ;convert to lower
    RSBGES R3,R2,#"z"
    STRGEB R2,[R0,#-1]
    SUBS   R1,R1,#1
    BGT    wu2         ;loop over string
    LDMDB  fp,{fp,sp,pc} ;return
    END
;
    TTL    CVADD
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R6  RN     6
R5  RN     5
R4  RN     4
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
F1  FN     1
F0  FN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT cvadd_;(N,X1,X2,Y1,Y2,Z1,Z2) Zi = Xi + Yi, i=1,N
    DCB    "cvadd_",0,0,8,0,0,255
cvadd_
    MOV    ip,sp
    STMDB  sp!,{R0-R6,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDMIB  fp,{R4-R6} ;get addresses of Y2,Z1,Z2
    LDR    R0,[R0]    ;N
    SUB    R2,R2,R1   ;X step
    SUB    R4,R4,R3   ;Y step
    SUB    R6,R6,R5   ;Z step
wl1 SUBS   R0,R0,#1
    LDFGES F0,[R1]    ;real part
    LDFGES F1,[R3]
    ADFGES F1,F0,F1
    STFGES F1,[R5]
    LDFGES F0,[R1,#4] ;imaginary part
    LDFGES F1,[R3,#4]
    ADFGES F1,F0,F1
    STFGES F1,[R5,#4]
    ADDGT  R1,R1,R2
    ADDGT  R3,R3,R4
    ADDGT  R5,R5,R6
    BGT    wl1
    LDMDB  fp,{R4-R6,fp,sp,pc} ;return
    END
;
    TTL    CVCPY
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT cvcpy_;(N,X1,X2,Z1,Z2) Zi = Xi, i=1,N
    DCB    "cvcpy_",0,0,8,0,0,255
cvcpy_
    MOV    ip,sp
    STMDB  sp!,{R0-R3,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    ip,[ip]    ;address of Z2
    LDR    R0,[R0]    ;n
    SUB    R2,R2,R1   ;x step
    SUB    ip,ip,R3   ;z step
wl1 SUBS   R0,R0,#1
    LDRGE  lr,[R1,#4] ;imaginary part
    STRGE  lr,[R3,#4]
    LDRGE  lr,[R1],R2 ;real part
    STRGE  lr,[R3],ip
    BGT    wl1
    LDMDB  fp,{fp,sp,pc} ;return
    END
;
    TTL    CVDIV
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R7  RN     7
R6  RN     6
R5  RN     5
R4  RN     4
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
F5  FN     5
F4  FN     4
F3  FN     3
F2  FN     2
F1  FN     1
F0  FN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT cvdiv_;(N,X1,X2,Y1,Y2,Z1,Z2,IFAIL) Zi = Xi/Yi, i=1,N
    DCB    "cvdiv_",0,0,8,0,0,255
cvdiv_
    MOV    ip,sp
    STMDB  sp!,{R0-R7,fp,ip,lr,pc}
    SUB    fp,ip,#4
    STFE   F5,[sp,#-12]!;save floating registers
    STFE   F4,[sp,#-12]!
    LDMIB  fp,{R4-R7} ;addresses of Y2 to IFAIL
    LDR    R0,[R0]    ;n
    SUB    R2,R2,R1   ;x step
    SUB    R4,R4,R3   ;y step
    SUB    R6,R6,R5   ;z step
    ADD    lr,R0,#1   ;ifail
    CMP    R0,#0
    BLE    wp1
wl1 LDFS   F0,[R1]    ;R(x)
    LDFS   F2,[R1,#4] ;I(x)
    LDFS   F1,[R3]    ;R(y)
    LDFS   F3,[R3,#4] ;I(y)
    FMLS   F4,F1,F1
    FMLS   F5,F3,F3
    ADFE   F5,F5,F4   ;y*y'
    CMF    F5,#0      ;check for divide by 0
    BEQ    wp2
    FMLS   F4,F0,F1   ;R(x)R(y)
    FMLS   F0,F3,F0   ;R(x)I(y)
    FMLS   F3,F2,F3   ;I(x)I(y)
    FMLS   F2,F1,F2   ;I(x)R(y)
    ADFS   F4,F4,F3   ;R(x)R(y)+I(x)I(y)
    SUFS   F2,F2,F0   ;I(x)R(y)-R(x)I(y)
    FDVS   F4,F4,F5   ;R(z)
    FDVS   F2,F2,F5   ;I(z)
    STFS   F4,[R5]
    STFS   F2,[R5,#4]
    ADD    R1,R1,R2
    ADD    R3,R3,R4
    ADD    R5,R5,R6
    SUBS   R0,R0,#1
    BGT    wl1
wp1 MOV    lr,R0
wp2 SUB    lr,lr,R0
    STR    lr,[R7]    ;store ifail
    LDFE   F4,[sp],#12;restore floating registers
    LDFE   F5,[sp],#12
    LDMDB  fp,{R4-R7,fp,sp,pc} ;return
    END
;
    TTL    CVMPA
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R6  RN     6
R5  RN     5
R4  RN     4
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
F6  FN     6
F5  FN     5
F4  FN     4
F3  FN     3
F2  FN     2
F1  FN     1
F0  FN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT cvmpa_;(N,X1,X2,Y1,Y2,S) => S + sum(Xi,Yi), i=1,N
    IMPORT cv_mult
    DCB    "cvmpa_",0,0,8,0,0,255
cvmpa_
    MOV    ip,sp
    STMDB  sp!,{R0-R6,fp,ip,lr,pc}
    SUB    fp,ip,#4
    STFE   F6,[sp,#-12]!;save floating registers
    STFE   F5,[sp,#-12]!
    STFE   F4,[sp,#-12]!
    MOV    R6,R0      ;result address
    LDR    R0,[R1]    ;n
    MOV    R1,R2      ;(X1)
    SUB    R2,R3,R2   ;x step
    LDMIB  fp,{R3-R5} ;addresses of Y1,Y2 and S
    SUB    R4,R4,R3   ;y step
    LDFS   F5,[R5]    ;R(s)
    LDFS   F6,[R5,#4] ;I(s)
    CMP    R0,#0
    BLE    CA1
    BL     cv_mult
    ADFE   F5,F5,F0   ;S(R)
    ADFE   F6,F6,F1   ;S(I)
    SUBS   R0,R0,#1
    BGT    cv_mult
CA1 STFS   F5,[R6]    ;store R(result)
    STFS   F6,[R6,#4] ;store I(result)
    LDFE   F4,[sp],#12  ;restore floating registers
    LDFE   F5,[sp],#12
    LDFE   F6,[sp],#12
    LDMDB  fp,{R4-R6,fp,sp,pc} ;return
    END
;
    TTL    CVMPAC
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R4  RN     4
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
F6  FN     6
F5  FN     5
F4  FN     4
F3  FN     3
F2  FN     2
F1  FN     1
F0  FN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT cvmpac_;(N,X1,X2,Y1,Y2,S) => S + sum(Xi,Y'i), i=1,N
    DCB    "cvmpac_",0,8,0,0,255
cvmpac_
    MOV    ip,sp
    STMDB  sp!,{R0-R4,fp,ip,lr,pc}
    SUB    fp,ip,#4
    STFE   F6,[sp,#-12]!;save floating registers
    STFE   F5,[sp,#-12]!
    STFE   F4,[sp,#-12]!
    LDMIB  fp,{R4,ip,lr} ;addresses of Y1, Y2 and S
    LDFS   F0,[lr]    ;R(s)
    LDFS   F1,[lr,#4] ;I(s)
    LDR    R1,[R1]    ;n
    SUB    R3,R3,R2   ;x step
    SUB    ip,ip,R4   ;y step
wl1 SUBS   R1,R1,#1
    LDFGES F2,[R2]    ;R(x)
    LDFGES F3,[R2,#4] ;I(x)
    LDFGES F4,[R4]    ;R(y)
    LDFGES F5,[R4,#4] ;I(y)
    MUFGEE F6,F2,F4   ;R(x)R(y)
    MUFGEE F2,F5,F2   ;R(x)I(y)
    MUFGEE F5,F3,F5   ;I(x)I(y)
    MUFGEE F3,F4,F3   ;I(x)R(y)
    ADFGEE F6,F6,F5   ;R
    SUFGEE F2,F3,F2   ;I
    ADFGEE F0,F0,F6   ;S(R)
    ADFGEE F1,F1,F2   ;S(I)
    ADDGT  R2,R2,R3
    ADDGT  R4,R4,ip
    BGT    wl1
    STFS   F0,[R0]    ;store R(result)
    STFS   F1,[R0,#4] ;store I(result)
    LDFE   F4,[sp],#12  ;restore floating registers
    LDFE   F5,[sp],#12
    LDFE   F6,[sp],#12
    LDMDB  fp,{R4,fp,sp,pc} ;return
    END
;
    TTL    CVMPY
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R5  RN     5
R4  RN     4
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
F6  FN     6
F5  FN     5
F4  FN     4
F3  FN     3
F2  FN     2
F1  FN     1
F0  FN     0
    AREA   |C$$code|,CODE,READONLY
    IMPORT cv_mult
    EXPORT cvmpy_;(N,X1,X2,Y1,Y2) => sum(xi*yi) i=1,N
    DCB    "cvmpy_",0,0,8,0,0,255
cvmpy_
    MOV    ip,sp
    STMDB  sp!,{R0-R5,fp,ip,lr,pc}
    SUB    fp,ip,#4
    STFE   F6,[sp,#-12]!;save floating registers
    STFE   F5,[sp,#-12]!
    STFE   F4,[sp,#-12]!
    MOV    R5,R0      ;result address
    LDR    R0,[R1]    ;n
    MOV    R1,R2      ;(X1)
    SUB    R2,R3,R2   ;x step
    LDMIB  fp,{R3-R4} ;addresses of Y1,Y2
    SUB    R4,R4,R3   ;y step
    MVFE   F5,#0      ;R(s)
    MVFE   F6,F5      ;I(s)
    CMP    R0,#0
    BLE    CY1
    BL     cv_mult
    ADFE   F5,F5,F0   ;S(R)
    ADFE   F6,F6,F1   ;S(I)
    SUBS   R0,R0,#1
    BGT    cv_mult
CY1 STFS   F5,[R5]    ;store R(result)
    STFS   F6,[R5,#4] ;store I(result)
    LDFE   F4,[sp],#12  ;restore floating registers
    LDFE   F5,[sp],#12
    LDFE   F6,[sp],#12
    LDMDB  fp,{R4-R5,fp,sp,pc} ;return
    END
;
    TTL    CVMPYC
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
F6  FN     6
F5  FN     5
F4  FN     4
F3  FN     3
F2  FN     2
F1  FN     1
F0  FN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT cvmpyc_;(N,X1,X2,Y1,Y2) => sum(xi*y'i) i=1,N
    DCB    "cvmpyc_",0,8,0,0,255
cvmpyc_
    MOV    ip,sp
    STMDB  sp!,{R0-R3,fp,ip,lr,pc}
    SUB    fp,ip,#4
    STFE   F6,[sp,#-12]!;save floating registers
    STFE   F5,[sp,#-12]!
    STFE   F4,[sp,#-12]!
    LDMIB  fp,{ip,lr} ;addresses of Y1 and Y2
    LDR    R1,[R1]    ;n
    SUB    R3,R3,R2   ;x step
    SUB    lr,lr,ip   ;y step
    MVFE   F0,#0      ;accumulator
    MVFE   F1,F0
wl1 SUBS   R1,R1,#1
    LDFGES F2,[R2]    ;R(x)
    LDFGES F3,[R2,#4] ;I(x)
    LDFGES F4,[ip]    ;R(y)
    LDFGES F5,[ip,#4] ;I(y)
    MUFGEE F6,F2,F4   ;R(x)R(y)
    MUFGEE F2,F5,F2   ;R(x)I(y)
    MUFGEE F5,F3,F5   ;I(x)I(y)
    MUFGEE F3,F4,F3   ;I(x)R(y)
    ADFGEE F6,F6,F5   ;R
    SUFGEE F2,F3,F2   ;I
    ADFGEE F0,F0,F6   ;S(R)
    ADFGEE F1,F1,F2   ;S(I)
    ADDGT  R2,R2,R3
    ADDGT  ip,ip,lr
    BGT    wl1
    STFS   F0,[R0]    ;store R(result)
    STFS   F1,[R0,#4] ;store I(result)
    LDFE   F4,[sp],#12  ;restore floating registers
    LDFE   F5,[sp],#12
    LDFE   F6,[sp],#12
    LDMDB  fp,{fp,sp,pc} ;return
    END
;
    TTL    CVMUL
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R6  RN     6
R5  RN     5
R4  RN     4
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
F4  FN     4
F3  FN     3
F2  FN     2
F1  FN     1
F0  FN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT cvmul_;(N,X1,X2,Y1,Y2,Z1,Z2) Zi = Xi * Yi, i=1,N
    IMPORT cv_mult
    DCB    "cvmul_",0,0,8,0,0,255
cvmul_
    MOV    ip,sp
    STMDB  sp!,{R0-R6,fp,ip,lr,pc}
    SUB    fp,ip,#4
    STFE   F4,[sp,#-12]!;save F4
    LDMIB  fp,{R4-R6} ;get addresses of Y2,Z1,Z2
    LDR    R0,[R0]    ;N
    SUB    R2,R2,R1   ;X step
    SUB    R4,R4,R3   ;Y step
    SUB    R6,R6,R5   ;Z step
    CMP    R0,#0
    BLE    CL1
    BL     cv_mult
    STFS   F0,[R5]
    STFS   F1,[R5,#4]
    ADD    R5,R5,R6
    SUBS   R0,R0,#1
    BGT    cv_mult
CL1 LDFE   F4,[sp],#12;restore F4
    LDMDB  fp,{R4-R6,fp,sp,pc} ;return
    END
;
    TTL     CV_MULT
pc  RN    15
lr  RN    14
R4  RN     4
R3  RN     3
R2  RN     2
R1  RN     1
F4  FN     4
F3  FN     3
F2  FN     2
F1  FN     1
F0  FN     0
    AREA |CV$$mult|,CODE,READONLY
    EXPORT cv_mult
cv_mult
    LDFS F0,[R1]    ;R(x)
    LDFS F2,[R1,#4] ;I(x)
    ADD  R1,R1,R2
    LDFS F1,[R3]    ;R(y)
    LDFS F3,[R3,#4] ;I(y)
    ADD  R3,R3,R4
    FMLS F4,F0,F1   ;R(x)R(y)
    FMLS F0,F3,F0   ;R(x)I(y)
    FMLS F3,F2,F3   ;I(x)I(y)
    FMLS F2,F1,F2   ;I(x)R(y)
    ADFS F1,F0,F2   ;I(z)
    SUFS F0,F4,F3   ;R(z)
    MOV  pc,lr
    END
;
    TTL    CVMULA
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R6  RN     6
R5  RN     5
R4  RN     4
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
F4  FN     4
F3  FN     3
F2  FN     2
F1  FN     1
F0  FN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT cvmula_;(N,X1,X2,Y1,Y2,Z1,Z2) Zi = Zi + Xi*Yi, i=1,N
    IMPORT cv_mult
    DCB    "cvmula_",0,8,0,0,255
cvmula_
    MOV    ip,sp
    STMDB  sp!,{R0-R6,fp,ip,lr,pc}
    SUB    fp,ip,#4
    STFE   F4,[sp,#-12]!;save F4
    LDMIB  fp,{R4-R6} ;get addresses of Y2,Z1,Z2
    LDR    R0,[R0]    ;N
    SUB    R2,R2,R1   ;X step
    SUB    R4,R4,R3   ;Y step
    SUB    R6,R6,R5   ;Z step
    CMP    R0,#0
    BLE    CA1
    BL     cv_mult
    LDFS   F2,[R5]
    ADFS   F2,F2,F0   ;R(z')
    STFS   F2,[R5]
    LDFS   F3,[R5,#4]
    ADFS   F3,F3,F1   ;I(z')
    STFS   F3,[R5,#4]
    ADD    R5,R5,R6
    SUBS   R0,R0,#1
    BGT    cv_mult
CA1 LDFE   F4,[sp],#12;restore F4
    LDMDB  fp,{R4-R6,fp,sp,pc} ;return
    END
;
    TTL    CVMUNA
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R6  RN     6
R5  RN     5
R4  RN     4
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
F4  FN     4
F3  FN     3
F2  FN     2
F1  FN     1
F0  FN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT cvmuna_;(N,X1,X2,Y1,Y2,Z1,Z2) Zi = Zi - Xi*Yi, i=1,N
    IMPORT cv_mult
    DCB    "cvmuna_",0,8,0,0,255
cvmuna_
    MOV    ip,sp
    STMDB  sp!,{R0-R6,fp,ip,lr,pc}
    SUB    fp,ip,#4
    STFE   F4,[sp,#-12]!;save F4
    LDMIB  fp,{R4-R6} ;get addresses of Y2,Z1,Z2
    LDR    R0,[R0]    ;N
    SUB    R2,R2,R1   ;X step
    SUB    R4,R4,R3   ;Y step
    SUB    R6,R6,R5   ;Z step
    CMP    R0,#0
    BLE    CA1
    BL     cv_mult
    LDFS   F2,[R5]
    SUFS   F2,F2,F0   ;R(z')
    STFS   F2,[R5]
    LDFS   F3,[R5,#4]
    SUFS   F3,F3,F1   ;I(z')
    STFS   F3,[R5,#4]
    ADD    R5,R5,R6
    SUBS   R0,R0,#1
    BGT    cv_mult
CA1 LDFE   F4,[sp],#12;restore F4
    LDMDB  fp,{R4-R6,fp,sp,pc} ;return
    END
;
    TTL    CVRAN
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R4  RN     4
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
F4  FN     4
F3  FN     3
F2  FN     2
F1  FN     1
F0  FN     0
    AREA   seed,DATA
    DCD    12345
    DCD    69069      ;multiplier for random sequencs
    AREA   |C$$code|,CODE,READONLY
    EXPORT cvran_;(N,A,B,Z1,Z2) Zi = random[A to B], i=1,N
    DCB    "cvran_",0,0,8,0,0,255
cvran_
    MOV    ip,sp
    STMDB  sp!,{R0-R4,fp,ip,lr,pc}
    SUB    fp,ip,#4
    STFE   F4,[sp,#-12]!;save F4
    LDR    ip,[ip]    ;address of Z2
    LDR    R0,[R0]    ;n
    LDFS   F1,[R1]    ;R(a)
    LDFS   F2,[R2]    ;R(b)
    SUFE   F2,F2,F1   ;R(b-a)
    LDFS   F0,norm    ;2**-31
    MUFE   F2,F2,F0
    LDFS   F3,[R1,#4] ;I(a)
    LDFS   F4,[R2,#4] ;I(b)
    SUFE   F4,F4,F3   ;I(b-a)
    MUFE   F4,F4,F0
    SUB    ip,ip,R3   ;z step
    LDR    R4,sptr
    LDMIA  R4,{R1,R2} ;random seed & multiplier
wl7 SUBS   R0,R0,#1
    MULGE  R1,R2,R1   ;new seed
    MOVGE  lr,R1,LSR#1
    FLTGEE F0,lr
    MUFGEE F0,F0,F2
    ADFGEE F0,F0,F1
    STFGES F0,[R3]    ;R(z)
    MULGE  R1,R2,R1   ;new seed
    MOVGE  lr,R1,LSR#1
    FLTGEE F0,lr
    MUFGEE F0,F0,F4
    ADFGEE F0,F0,F3
    STFGES F0,[R3,#4] ;I(z)
    ADDGT  R3,R3,ip
    BGT    wl7
    STR    R1,[R4]    ;restore seed
    LDFE   F4,[sp],#12;restore F4
    LDMDB  fp,{R4,fp,sp,pc} ;return
norm DCFS   4.65661287E-10;2**-31
sptr DCD    seed
    END
;
    TTL    CVSCA
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
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
F5  FN     5
F4  FN     4
F3  FN     3
F2  FN     2
F1  FN     1
F0  FN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT cvsca_;(N,S,X1,X2,Y1,Y2,Z1,Z2) Zi = S*Xi + Yi, i=1,N
    DCB    "cvsca_",0,0,8,0,0,255
cvsca_
    MOV    ip,sp
    STMDB  sp!,{R0-R7,fp,ip,lr,pc}
    SUB    fp,ip,#4
    STFE   F5,[sp,#-12]!; save F5
    STFE   F4,[sp,#-12]!; save F4
    LDMIB  fp,{R4-R7} ;xtra arg addresses
    LDR    R0,[R0]    ;n
    LDFS   F2,[R1]    ;R(s)
    LDFS   F3,[R1,#4] ;I(s)
    SUB    R3,R3,R2   ;x step
    SUB    R5,R5,R4   ;y step
    SUB    R7,R7,R6   ;z step
wl1 SUBS   R0,R0,#1
    LDFGES F0,[R2]    ;R(x)
    LDFGES F1,[R2,#4] ;I(x)
    FMLGES F4,F0,F2   ;R(x)R(s)
    FMLGES F5,F1,F3   ;I(x)I(s)
    FMLGES F0,F3,F0   ;R(x)I(s)
    FMLGES F1,F2,F1   ;I(x)R(s)
    SUFGES F4,F4,F5
    ADFGES F5,F0,F1
    LDFGES F0,[R4]    ;R(y)
    LDFGES F1,[R4,#4] ;I(y)
    ADFGES F0,F0,F4   ;R(z)
    STFGES F0,[R6]
    ADFGES F1,F1,F5   ;I(z)
    STFGES F1,[R6,#4]
    ADDGT  R2,R2,R3
    ADDGT  R4,R4,R5
    ADDGT  R6,R6,R7
    BGT    wl1
    LDFE   F4,[sp],#12;restore F4
    LDFE   F5,[sp],#12;restore F5
    LDMDB  fp,{R4-R7,fp,sp,pc} ;return
    END
;
    TTL    CVSCL
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
F5  FN     5
F4  FN     4
F3  FN     3
F2  FN     2
F1  FN     1
F0  FN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT cvscl_;(N,S,X1,X2,Z1,Z2) Zi = S*Xi, i=1,N
    DCB    "cvscl_",0,0,8,0,0,255
cvscl_
    MOV    ip,sp
    STMDB  sp!,{R0-R3,fp,ip,lr,pc}
    SUB    fp,ip,#4
    STFE   F5,[sp,#-12]!; save F5
    STFE   F4,[sp,#-12]!; save F4
    LDFS   F2,[R1]    ;R(s)
    LDFS   F3,[R1,#4] ;I(s)
    LDMIB  fp,{R1,ip} ;addresses of Z1 & Z2
    LDR    R0,[R0]    ;n
    SUB    R3,R3,R2   ;x step
    SUB    ip,ip,R1   ;z step
wl1 SUBS   R0,R0,#1
    LDFGES F0,[R2]    ;R(x)
    LDFGES F1,[R2,#4] ;I(x)
    FMLGES F4,F0,F2   ;R(x)R(s)
    FMLGES F5,F1,F3   ;I(x)I(s)
    FMLGES F0,F3,F0   ;R(x)I(s)
    FMLGES F1,F2,F1   ;I(x)R(s)
    SUFGES F4,F4,F5
    ADFGES F5,F0,F1
    STFGES F4,[R1]    ;R(z)
    STFGES F5,[R1,#4] ;I(z)
    ADDGT  R2,R2,R3
    ADDGT  R1,R1,ip
    BGT    wl1
    LDFE   F4,[sp],#12;restore F4
    LDFE   F5,[sp],#12;restore F5
    LDMDB  fp,{fp,sp,pc} ;return
    END
;
    TTL    CVSCS
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R7  RN     7
R6  RN     6
R5  RN     5
R4  RN     4
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
F5  FN     5
F4  FN     4
F3  FN     3
F2  FN     2
F1  FN     1
F0  FN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT cvscs_;(N,S,X1,X2,Y1,Y2,Z1,Z2) Zi = S*Xi - Yi, i=1,N
    DCB    "cvscs_",0,0,8,0,0,255
cvscs_
    MOV    ip,sp
    STMDB  sp!,{R0-R7,fp,ip,lr,pc}
    SUB    fp,ip,#4
    STFE   F5,[sp,#-12]!; save F5
    STFE   F4,[sp,#-12]!; save F4
    LDMIB  fp,{R4-R7} ;xtra arg addresses
    LDR    R0,[R0]    ;n
    LDFS   F2,[R1]    ;R(s)
    LDFS   F3,[R1,#4] ;I(s)
    SUB    R3,R3,R2   ;x step
    SUB    R5,R5,R4   ;y step
    SUB    R7,R7,R6   ;z step
wl1 SUBS   R0,R0,#1
    LDFGES F0,[R2]    ;R(x)
    LDFGES F1,[R2,#4] ;I(x)
    FMLGES F4,F0,F2   ;R(x)R(s)
    FMLGES F5,F1,F3   ;I(x)I(s)
    FMLGES F0,F3,F0   ;R(x)I(s)
    FMLGES F1,F2,F1   ;I(x)R(s)
    SUFGES F4,F4,F5
    ADFGES F5,F0,F1
    LDFGES F0,[R4]    ;R(y)
    LDFGES F1,[R4,#4] ;I(y)
    SUFGES F0,F4,F0   ;R(z)
    STFGES F0,[R6]
    SUFGES F1,F5,F1   ;I(z)
    STFGES F1,[R6,#4]
    ADDGT  R2,R2,R3
    ADDGT  R4,R4,R5
    ADDGT  R6,R6,R7
    BGT    wl1
    LDFE   F4,[sp],#12;restore F4
    LDFE   F5,[sp],#12;restore F5
    LDMDB  fp,{R4-R7,fp,sp,pc} ;return
    END
;
    TTL    CVSET
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT cvset_;(N,S,Z1,Z2) Zi = S, i=1,N
    DCB    "cvset_",0,0,8,0,0,255
cvset_
    MOV    ip,sp
    STMDB  sp!,{R0-R3,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R0,[R0]    ;n
    LDMIA  R1,{ip,lr} ;s
    SUB    R3,R3,R2   ;z step
wl1 SUBS   R0,R0,#1
    STMGEIA R2,{ip,lr}
    ADDGE  R2,R2,R3
    BGT    wl1
    LDMDB  fp,{fp,sp,pc} ;return
    END
;
    TTL    CVSUB
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R6  RN     6
R5  RN     5
R4  RN     4
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
F1  FN     1
F0  FN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT cvsub_;(N,X1,X2,Y1,Y2,Z1,Z2) Zi = Xi - Yi, i=1,N
    DCB    "cvsub_",0,0,8,0,0,255
cvsub_
    MOV    ip,sp
    STMDB  sp!,{R0-R6,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDMIB  fp,{R4-R6} ;get addresses of Y2,Z1,Z2
    LDR    R0,[R0]    ;N
    SUB    R2,R2,R1   ;X step
    SUB    R4,R4,R3   ;Y step
    SUB    R6,R6,R5   ;Z step
wl1 SUBS   R0,R0,#1
    LDFGES F0,[R1]
    LDFGES F1,[R3]
    SUFGES F1,F0,F1
    STFGES F1,[R5]
    LDFGES F0,[R1,#4]
    LDFGES F1,[R3,#4]
    SUFGES F1,F0,F1
    STFGES F1,[R5,#4]
    ADDGT  R1,R1,R2
    ADDGT  R3,R3,R4
    ADDGT  R5,R5,R6
    BGT    wl1
    LDMDB  fp,{R4-R6,fp,sp,pc} ;return
    END
;
    TTL    CVSUM
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
F2  FN     2
F1  FN     1
F0  FN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT cvsum_;(N,X1,X2) => sum(Xi), i=1,N
    DCB    "cvsum_",0,0,8,0,0,255
cvsum_
    MOV    ip,sp
    STMDB  sp!,{R0-R3,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R1,[R1]    ;n
    SUB    R3,R3,R2   ;x step
    MVFE   F0,#0      ;accumulator
    MVFE   F1,F0
wlf SUBS   R1,R1,#1
    LDFGES F2,[R2]
    ADFGEE F0,F2,F0
    LDFGES F2,[R2,#4]
    ADFGEE F1,F2,F1
    ADDGE  R2,R2,R3
    BGT    wlf
    STFS   F0,[R0]    ;store R(result)
    STFS   F1,[R0,#4] ;store I(result)
    LDMDB  fp,{fp,sp,pc} ;return
    END
;
    TTL    CVXCH
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R8  RN     8
R7  RN     7
R6  RN     6
R5  RN     5
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT cvxch_;(N,X1,X2,Y1,Y2) Xi = Yi while Yi = Xi, i=1,N
    DCB    "cvxch_",0,0,8,0,0,255
cvxch_
    MOV    ip,sp
    STMDB  sp!,{R0-R3,R5-R8,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    ip,[ip]    ;address of Y2
    LDR    R0,[R0]    ;n
    SUB    R2,R2,R1   ;x step
    SUB    ip,ip,R3   ;y step
wl1 SUBS   R0,R0,#1
    LDMGEIA  R1,{R5,R6}
    LDMGEIA  R3,{R7,R8}
    STMGEIA  R3,{R5,R6}
    STMGEIA  R1,{R7,R8}
    ADDGE  R1,R1,R2
    ADDGE  R3,R3,ip
    BGT    wl1
    LDMDB  fp,{R5-R8,fp,sp,pc} ;return
    END
;
    TTL   dadapt
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
R4  RN     4
R5  RN     5
R6  RN     6
R7  RN     7
R8  RN     8
R9  RN     9
F0  FN     0
F1  FN     1
F2  FN     2
F3  FN     3
F4  FN     4
F5  FN     5
F6  FN     6
F7  FN     7
;
ndim EQU 100   ; maximum number of interpolation points
       ^     -4,R9
nter #     4
xlo  #     8*ndim
xhi  #     8*ndim
tval #     8*ndim
ters #     8*ndim
;
    AREA   |C$$data|,DATA
     DCD   0         ;NTER
stor %     8*ndim    ;XLO(NDIM)
     %     8*ndim    ;XHI(NDIM)
     %     8*ndim    ;TVAL(NDIM)
     %     8*ndim    ;TERS(NDIM)
;
    AREA   |C$$code|,CODE,READONLY
    IMPORT dgs56p_
    EXPORT dadapt_;(F,A,B,NSEG,RELTOL,ABSTOL,RES,ERR) DP Gaussian quadrature
;               variables are DOUBLE PRECISION
;     RES = Estimated Integral of F from A to B,
;     ERR = Estimated absolute error on RES.
;     NSEG  specifies how the adaptation is to be done:
;        =0   means use previous binning,
;        =1   means fully automatic, adapt until tolerance attained.
;        =n>1 means first split interval into n equal segments,
;             then adapt as necessary to attain tolerance.
;     The specified tolerances are:
;            relative: RELTOL ;  absolute: ABSTOL.
;        It stops when one OR the other is satisfied, or number of
;        segments exceeds NDIM.  Either TOLA or TOLR (but not both!)
;        can be set to zero, in which case only the other is used.
    DCB    "dadapt_",0,8,0,0,255
dadapt_
    MOV    ip,sp
    STMDB  sp!,{R0-R9,fp,ip,lr,pc}
    SUB    fp,ip,#4
    SFMFD  F4,4,[sp]!      ;save fp registers 4 to 7
    SUB    R7,sp,#8        ;arg's address
    STR    R7,[sp,#-12]!   ;store on stack with space for 1 dp word
    MOV    R5,R0           ;save address of F
    LDR    R9,ptr          ;point R9 to saved data store
    LDR    R6,[R3]         ;NSEG
    CMP    R6,#0
    BGT    pt1
    LDR    R6,nter         ;NTER
    CMP    R6,#0
    MOVEQ  R6,#1           ;NSEGD=1
    BEQ    pt2
    MVFD   F6,#0           ;initialize TVALS = 0.
    MVFD   F7,#0           ;initialize TERSS = 0.
    ADR    R8,tval
lp1 MOV    R0,R5           ;(F)
    SUB    R1,R8,#16*ndim  ;(XLO(I))
    SUB    R2,R8,#8*ndim   ;(XHI(I))
    MOV    R3,R8           ;(TVAL(I))
    BL     dgs56p_         ;CALL DGS56P(F,XLO(I),XHI(I),TVAL(I),TE)
    LDFD   F0,[R7]         ;TE
    LDFD   F1,[R8]         ;TVAL(I)
    MUFD   F0,F0,F0
    ADFD   F6,F6,F1        ;TVALS = TVALS + TVAL(I)
    STFD   F0,[R8,#8*ndim] ;store TERS(I) = TE**2
    ADFD   F7,F7,F0        ;TERSS = TERSS + TERS(I)
    ADD    R8,R8,#8        ;I = I + 1
    SUBS   R6,R6,#1
    BGT    lp1             ;loop over I=1,NTER
    ADFD   F7,F7,F7
    SQTD   F7,F7           ;ROOT = SQRT(2*TERSS)
ret LDR    R6,[fp,#12]     ;(RES)
    LDR    R7,[fp,#16]     ;(ERR)
    STFD   F6,[R6]         ;store TVALS in RES
    STFD   F7,[R7]         ;store ROOT on ERR
    ADD    sp,sp,#12       ;restore stack
    LFMFD  F4,4,[sp]!      ;restore fp registers
    LDMDB  fp,{R4-R9,fp,sp,pc} ;return
;
pt1 CMP    R6,#ndim
    MOVGT  R6,#ndim        ;NSEGD = MIN(NSEG,NDIM)
pt2 LDFD   F7,[R1]         ;XHIB = A
    LDFD   F6,[R2]         ;B
    FLTD   F0,R6           ;FLOAT(NSEGD)
    SUFD   F5,F6,F7        ;B-A
    DVFD   F5,F5,F0        ;BIN = (B-A)/NSEGD
    ADR    R8,xhi          ;address of xhi
    SUBS   R4,R6,#1        ;loop count = NSEGD
lp2 STFD   F7,[R8,#-8*ndim];XLO(I) = XHIB
    MVFEQD F7,F6
    ADFGTD F7,F7,F5        ;XHIB' = XHIB + BIN (or B on last point)
    STFD   F7,[R8]         ;XHI(I) = XHIB'
    MOV    R0,R5           ;(F)
    SUB    R1,R8,#8*ndim   ;(XLO(I))
    MOV    R2,R8           ;(XHI(I))
    ADD    R3,R8,#8*ndim   ;(TVAL(I))
    BL     dgs56p_         ;CALL DGS56P(F,XLO(I),XHI(I),TVAL(I),TE)
    LDFD   F0,[R7]         ;TE
    MUFD   F0,F0,F0
    ADD    R0,R8,#16*ndim
    STFD   F0,[R0]         ;store TERS(I) = TE**2
    ADD    R8,R8,#8
    SUBS   R4,R4,#1
    BGE    lp2             ;loop over I=1,NSEGD
    LDMIB  fp,{ip,lr}      ;(RELTOL), (ABSTOL)
    LDFD   F4,[ip]         ;RELTOL
    LDFD   F5,[lr]         ;ABSTOL
;        start iteration loop
lp3 ADR    R8,ters
    LDFD   F6,[R8,#-8*ndim];initialize TVALS = TVAL(1)
    LDFD   F7,[R8],#8      ;initialize TERSS = TERS(1)
    SUBS   R0,R6,#1        ;count NTER-1
lp4 LDFGTD F0,[R8,#-8*ndim];TVAL(I)
    LDFGTD F1,[R8],#8      ;TERS(I)
    ADFGTD F6,F6,F0        ;TVALS = TVALS + TVAL(I)
    ADFGTD F7,F7,F1        ;TERSS = TERSS + TERS(I)
    SUBGTS R0,R0,#1
    BGT    lp4             ;loop over I=2,NTER
    ADFD   F7,F7,F7
    SQTD   F7,F7           ;ROOT = SQRT(2*TERSS)
    CMF    F7,F5           ;IF(ROOT.LE.ABSTOL .OR.
    ABSGTD F0,F6
    MUFGTD F0,F0,F4
    CMFGT  F7,F0           ; ROOT.LE.RELTOL*ABS(TVALS) .OR.
    RSBGTS lr,R6,#ndim     ; NTER.GE.NDIM
    STRLE  R6,nter         ; THEN store NTER
    BLE    ret             ; and all done
    ADR    R8,ters         ;otherwise, find biggest error
    LDFD   F0,[R8],#8      ;BIGE = TERS(1)
    SUB    R4,R8,#8+8*ndim ;IBIG = 1
    SUBS   R0,R6,#1        ;count NTER-1
lp5 LDFGTD F1,[R8],#8      ;TERS(I)
    CMFGT  F1,F0           ;IF (TERS(I).GT.BIGE) THEN
    MVFGTD F0,F1           ; BIGE = TERS(I)
    SUBGT  R4,R8,#8+8*ndim ; IBIG = I
    SUBS   R0,R0,#1
    BGT    lp5             ;loop over I=2,NTER
    ADR    R8,tval
    ADD    R8,R8,R6,LSL#3  ;(TVAL(NTER+1))
    ADD    R6,R6,#1        ;NTER = NTER + 1
    LDFD   F0,[R4,#-8*ndim]!;XHI(IBIG)
    STFD   F0,[R8,#-8*ndim]!;XHI(NTER) = XHI(IBIG)
    LDFD   F1,[R4,#-8*ndim];XLO(IBIG)
    ADFD   F1,F1,F0
    MUFD   F1,F1,#0.5      ;XNEW = 0.5*(XLO(IBIG)+XHI(IBIG))
    STFD   F1,[R4],#8*ndim ;XHI(IBIG) = XNEW
    STFD   F1,[R8,#-8*ndim];XLO(NTER) = XNEW
    ADD    R8,R8,#8*ndim   ;(TVAL(NTER))
    MOV    R0,R5           ;(F)
    SUB    R1,R4,#16*ndim  ;(XLO(IBIG))
    SUB    R2,R4,#8*ndim   ;(XHI(IBIG))
    MOV    R3,R4           ;(TVAL(IBIG))
    BL     dgs56p_         ;CALL DGS56P(F,XLO(IBIG),XHI(IBIG),TVAL(IBIG),TE)
    LDFD   F0,[R7]         ;TE
    MUFD   F0,F0,F0
    STFD   F0,[R4,#8*ndim] ;TERS(IBIG)=TE**2
    MOV    R0,R5           ;(F)
    SUB    R1,R8,#16*ndim  ;(XLO(NTER))
    SUB    R2,R8,#8*ndim   ;(XHI(NTER))
    MOV    R3,R8           ;(TVAL(NTER))
    BL     dgs56p_         ;CALL DGS56P(F,XLO(NTER),XHI(NTER),TVAL(NTER),TE)
    LDFD   F0,[R7]         ;TE
    MUFD   F0,F0,F0
    STFD   F0,[R8,#8*ndim] ;TERS(NTER)=TE**2
    B      lp3             ;loop
;
ptr DCD    stor
    END
;
    TTL    DATIME
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R4  RN     4
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
OS_Word  EQU  &07
    AREA   slate__,COMMON,NOINIT
    %      160
;
    AREA   |C$$code|,CODE,READONLY
    EXPORT datime_;(ID,IT) get date and time in BCD
    DCB    "datime_",0,8,0,0,255
datime_
    MOV    ip,sp
    STMDB  sp!,{R0,R1,R4,fp,ip,lr,pc}
    SUB    fp,ip,#4
    MOV    R2,R0   ;address of ID
    MOV    R3,R1   ;address of IT
    LDR    R1,ptr  ;address of buffer
    MOV    R0,#1
    STR    R0,[R1]
    MOV    R0,#14
    SWI    OS_Word        ;get date & time
    LDRB   R0,[R1,#4]     ;hours
    BL     h2d            ;translate to decimal
    STR    R0,[R1,#12]    ;store in SLATE
    ADD    R0,R0,R0,LSL#2 ;x 5
    ADD    ip,R0,R0,LSL#2 ;x 5
    LDRB   R0,[R1,#5]     ;minutes
    BL     h2d            ;translate to decimal
    STR    R0,[R1,#16]    ;store in SLATE
    ADD    R0,R0,ip,LSL#2 ;hours*100 + min
    STR    R0,[R3]        ;store in IT
    LDRB   R0,[R1,#6]     ;seconds
    BL     h2d            ;translate to decimal
    STR    R0,[R1,#20]    ;store in SLATE
    LDRB   R0,[R1]        ;year
    BL     h2d            ;translate to decimal
    MOV    R3,R0          ;save for slate
    ADD    R0,R0,R0,LSL#2 ;x 5
    ADD    ip,R0,R0,LSL#2 ;x 5
    LDRB   R0,[R1,#1]     ;month
    BL     h2d            ;translate to decimal
    STR    R0,[R1,#4]     ;store in SLATE
    ADD    R0,R0,ip,LSL#2 ;add 100*year
    ADD    R0,R0,R0,LSL#2 ;x 5
    ADD    ip,R0,R0,LSL#2 ;x 5
    LDRB   R0,[R1,#2];day
    BL     h2d            ;translate to decimal
    STR    R0,[R1,#8]     ;store in SLATE
    ADD    R0,R0,ip,LSL#2 ;add (100*year+month)*100
    STR    R0,[R2]        ;store date
    CMP    R3,#90
    ADD    R3,R3,#2000
    SUBGT  R3,R3,#100     ;add 1900 or 2000 to year
    STR    R3,[R1]        ;store in SLATE
    LDMDB  fp,{R4,fp,sp,pc} ;return
ptr DCD    slate__
h2d;   translate hex to decimal
    MOV    R4,R0,LSR#4    ;second nibble = second decimal digit
    ADD    R4,R4,R4,LSL#1 ;3*second nibble
    SUB    R0,R0,R4,LSL#1 ;original word -6*second nibble
    MOV    pc,lr
    END
;
    TTL    DATIMH
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
OS_Word  EQU  &07
OS_ConvertDateAndTime EQU &C1
    AREA   time_date,DATA
    %      24
;
    AREA   |C$$code|,CODE,READONLY
    EXPORT datimh_;(ND,NT) get date and time in ASCII
    DCB    "datimh_",0,8,0,0,255
datimh_
    MOV    ip,sp
    STMDB  sp!,{R0,R1,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R1,ptr         ;pointer to 5-byte time
    MOV    R0,#3
    STR    R0,[R1]
    MOV    R0,#14
    SWI    OS_Word        ;OSWORD 14,3 to get time
    MOV    R0,R1
    ADD    R1,R0,#5      ;location of temporary buffer
    MOV    R2,#19        ;length of buffer (only 17 used)
    ADR    R3,fdat       ;format
    SWI    OS_ConvertDateAndTime
    MOV    R2,#16        ;16 bytes to move
    LDR    R3,[sp]       ;address of ND
gt1 LDRB   R1,[R0],#1    ;move 8 bytes from temporary
    STRB   R1,[R3],#1    ;to result buffer
    CMP    R2,#9
    LDREQ  R3,[sp,#4]    ;start moving to NT
    SUBS   R2,R2,#1
    BGT    gt1
    LDMDB  fp,{fp,sp,pc} ;return
ptr DCD    time_date
fdat DCB    "%DY/%MN/%YR","%24:%MI:%SE",0,0
    END
;
    TTL   DEQINV
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R0  RN     0
R3  RN     3
R4  RN     4
R5  RN     5
R6  RN     6
R7  RN     7
R8  RN     8
    AREA   |C$$code|,CODE,READONLY
    EXPORT deqinv_;(N,A,IDIM,IR,IFAIL,K,B) sets A=1/A, finds X=B/A
    IMPORT dfact_
    IMPORT dfeqn_
    IMPORT dfinv_
    DCB    "deqinv_",0,8,0,0,255
deqinv_
    MOV    ip,sp
    STMDB  sp!,{R0-R8,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDMIB  fp,{R4,R7,R8}   ;addresses of IFAIL,K,B
    SUB    sp,sp,#12       ;space for DET and JFAIL
    MOV    R5,sp           ;address for DET
    ADD    R6,R5,#8        ;address for JFAIL
    STMFD  sp!,{R4-R6}     ;addresses of IFAIL,DET,JFAIL
    BL     dfact_
    ADD    sp,sp,#24       ;restore stack
    LDMIA  sp,{R0-R3}      ;restore N,A,IDIM,R
    LDR    ip,[R4]
    CMP    ip,#0           ;test IFAIL
    LDMNEDB fp,{R4-R8,fp,sp,pc} ;return
    STMFD  sp!,{R7,R8}     ;if OK, store addresses of K,B
    BL     dfeqn_          ;call DFEQN
    ADD    sp,sp,#8        ;and restore stack
    LDMIA  sp,{R0-R3}      ;restore N,A,IDIM,R
    BL     dfinv_          ;call DFINV if OK
    LDMDB  fp,{R4-R8,fp,sp,pc} ;return
    END
;
    TTL   DEQN
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R0  RN     0
R3  RN     3
R4  RN     4
R5  RN     5
R6  RN     6
R7  RN     7
R8  RN     8
    AREA   |C$$code|,CODE,READONLY
    EXPORT deqn_;(N,A,IDIM,IR,IFAIL,K,B) solves X=B/A, A is any non-singular matrix
    IMPORT dfact_
    IMPORT dfeqn_
    DCB    "deqn_",0,0,0,8,0,0,255
deqn_
    MOV    ip,sp
    STMDB  sp!,{R0-R8,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDMIB  fp,{R4,R7,R8}   ;addresses of IFAIL,K,B
    SUB    sp,sp,#12        ;space for DET and JFAIL
    MOV    R5,sp           ;address for DET
    ADD    R6,R5,#8        ;address for JFAIL
    STMFD  sp!,{R4-R6}     ;addresses of IFAIL,DET,JFAIL
    BL     dfact_
    ADD    sp,sp,#24       ;restore stack
    LDR    ip,[R4]         ;get IFAIL
    CMP    ip,#0
    LDMNEDB fp,{R4-R8,fp,sp,pc} ;returnon error
    LDMFD  sp!,{R0-R3}    ;restore N,A,IDIM,R
    STMFD  sp!,{R7,R8}    ;if OK, store addresses of K,B
    BL     dfeqn_          ;call DFEQN
    LDMDB  fp,{R4-R8,fp,sp,pc} ;return
    END
;
    TTL   DFACT
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
F2  FN     2
F3  FN     3
F4  FN     4
F5  FN     5
F6  FN     6
F7  FN     7
    AREA   |C$$code|,CODE,READONLY
    EXPORT dfact_;(N,A,IDIM,IR,IFAIL,DET,JFAIL) set A and R for DFEQN and DFINV
    DCB    "dfact_",0,0,8,0,0,255
dfact_
    MOV    ip,sp
    STMDB  sp!,{R0-R9,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R0,[R0]          ;N
    LDR    R2,[R2]          ;IDIM
    CMP    R0,#1
    CMPGE  R2,R0
    LDRLT  R1,[fp,#4]       ;address of IFAIL
    MOVLT  R0,#1
    STRLT  R0,[R1]
    LDMLTDB  fp,{R4-R9,fp,sp,pc} ;return IFAIL=1 if dimensions bad
    STFE   F7,[sp,#-12]!    ;save floating registers
    STFE   F6,[sp,#-12]!
    STFE   F5,[sp,#-12]!
    STFE   F4,[sp,#-12]!
;         initialise variables
    MVFE   F7,#1            ;DET=1
    LDFS   F5,CSMA          ;minimum DET
    LDFS   F6,CBIG          ;maximum DET
    MOV    ip,#0            ;initialise JFAIL
    SUB    R4,R1,#8         ;(J-1,J) J=1
    MOV    R5,#0            ;J="1"
;         main loop over J=1,N
lpj MVFD   F1,#0            ;max |pivot| value
    MOV    R6,#-1           ;initialise K
    SUB    R7,R0,R5         ;I count (=N-J+1)
    ADD    R8,R4,#8         ;(I,J)' I=J
wl1 LDFD   F0,[R8],#8       ;A(I,J)
    ABSD   F0,F0
    CMF    F0,F1
    MVFGTD F1,F0            ;find maximum
    SUBGT  R6,R0,R7         ;set K to index of max
    SUBS   R7,R7,#1
    BGT    wl1              ;loop over I
    CMP    R6,R5            ;K should be >= J
    BLT    fail             ;singular if not
;         swap pivot columns if K>J
    MNFGTE F7,F7            ;change DET sign
    ADDGT  R7,R6,R5,LSL#12  ;pack J,K
    STRGT  R7,[R3,#4]!      ;store in IR
    ADDGT  R7,R1,R5,LSL#3   ;(j,1)
    ADDGT  R8,R1,R6,LSL#3   ;(k,1)
    MOVGT  R6,R0            ;counter
wl2 LDRGT  R9,[R7,#4]
    LDRGT  lr,[R8,#4]
    STRGT  R9,[R8,#4]
    STRGT  lr,[R7,#4]
    LDRGT  R9,[R7]
    LDRGT  lr,[R8]
    STRGT  R9,[R8],R2,LSL#3
    STRGT  lr,[R7],R2,LSL#3 ;swap columns
    SUBGTS R6,R6,#1
    BGT    wl2              ;loop over rows
    LDFD   F4,[R4,#8]!      ;get A(J,J)
    MUFE   F7,F7,F4         ;DET=DET*A(J,J)
    RDFE   F4,F4,#1
    STFD   F4,[R4]          ;A(J,J)=1/A(J,J)
;         check DET is within bounds
    ABSD   F0,F7
    CMF    F0,F5
    MVFLEE F7,#0            ;too small, set to 0
    CMPLES ip,#0
    MOVEQ  ip,#-1           ;set jfail = -1
    CMF    F0,F6
    MVFGEE F7,#1            ;too big, set to 1
    CMPGES ip,#0
    MOVEQ  ip,#1            ;set jfail = +1
;         now factorise matrix
    ADD    R5,R5,#1         ;virtual increment j
    SUBS   R6,R0,R5         ;K count = N-J
    BLE    finish           ;done when J=N
    ADD    R7,R4,R2,LSL#3   ;(J,K) K=J+1
    ADD    R8,R7,#8         ;(K,J+1) K=J+1
;         loop K = J+1 to N
wl3 LDFD   F0,[R7],#-8      ;-s11=A(J,K) : R7=(I,K) I=J-1
    SUB    lr,R4,R2,LSL#3   ;(J,I) I=J-1
    SUBS   R9,R5,#1         ;I-count
;         loop I = J-1,1,-1
wl4 LDFGTD F2,[R7],#-8      ;A(I,K)
    LDFGTD F3,[lr]          ;A(J,I)
    SUBGT  lr,lr,R2,LSL#3   ;(J,I-1)
    MUFGTE F2,F2,F3
    SUFGTE F0,F0,F2         ;-s11=-s11-A(I-1,K)*A(J,I-1)
    SUBS   R9,R9,#1
    BGT    wl4              ;loop over I
    MUFE   F0,F0,F4         ;-s11=-s11*A(J,J) ... gives overflow
    ADD    R7,R7,R5,LSL#3   ;restore (J,K)
    STFD   F0,[R7]          ;A(J,K)=-s11
    LDFD   F1,[R8]          ;-s12=A(K,J+1)
    ADD    R9,R4,R2,LSL#3   ;(I,J+1) I=J
    SUB    R0,R8,R2,LSL#3   ;(K,I) I=J
    MOV    lr,R5            ;I-count
;           loop over I=J,1,-1
wl5 LDFD   F2,[R9],#-8      ;A(I,J+1) : (I-1,J+1)
    LDFD   F3,[R0]          ;A(K,I)
    SUB    R0,R0,R2,LSL#3   ;(K,I-1)
    MUFE   F2,F2,F3
    SUFE   F1,F1,F2         ;-s12=-s12-A(I,J+1)*A(K,I)
    SUBS   lr,lr,#1
    BGT    wl5              ;loop over I
    ADD    R7,R7,R2,LSL#3   ;(J,K+1)
    STFD   F1,[R8],#8       ;A(K,J+1)=-s12 : (K+1,J+1)
    SUBS   R6,R6,#1
    BGT    wl3              ;loop over K
    LDR    R0,[sp,#48]
    LDR    R0,[R0]          ;restore R0 to N
    ADD    R4,R4,R2,LSL#3   ;(J,J+1)
    B      lpj              ;loop over J
fail;    singular matrix, IFAIL (R6) =-1
    MVFD   F7,#0            ;determinant is zero
    MOV    ip,#0            ;and JFAIL=0
finish;         done, so tidy up
    LDR    R7,[sp,#60]      ;address of IR
    SUB    R3,R3,R7         ;length of IR
    STR    R3,[R7]          ;store last IR used
    LDMIB  fp,{R7,R8,R9}    ;addresses of IFAIL,DET,JFAIL
    STR    R6,[R7]          ;store IFAIL
    STFD   F7,[R8]          ;store DET
    STR    ip,[R9]          ;store JFAIL
    LDFE   F4,[sp],#12      ;restore floating registers
    LDFE   F5,[sp],#12
    LDFE   F6,[sp],#12
    LDFE   F7,[sp],#12
    LDMDB  fp,{R4-R9,fp,sp,pc} ;return
CSMA DCFS  1.0E-19
CBIG DCFS  1.0E+19
    END
;
    TTL   DFEQN
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
F2  FN     2
F3  FN     3
    AREA   |C$$code|,CODE,READONLY
    EXPORT dfeqn_;(N,A,IDIM,IR,K,B) solves X=B/A, A prepared by DFACT
    DCB    "dfeqn_",0,0,8,0,0,255
dfeqn_
    MOV    ip,sp
    STMDB  sp!,{R0-R9,fp,ip,lr,pc}
    SUB    fp,ip,#4
;         initialise variables
    LDR    R0,[R0]         ;N
    LDR    R2,[R2]         ;IDIM
    LDMIB  fp,{R4,R5}      ;extra arg addresses
    LDR    R4,[R4]         ;K
    CMP    R0,#1
    CMPGE  R4,#1
    CMPGE  R2,R0
    LDMLTDB fp,{R4-R9,fp,sp,pc} ;return if N<1 or IDIM<N or K<1
;         first do row swapping
    LDR    R7,[R3]
    ADD    R7,R7,R3        ;last swap entry
    CMP    R3,R7
    BGE    wm3             ;skip if none
;         loop over entries
wm1 LDR    R8,[R3,#4]!
    MOV    R9,R8,LSR#12    ;I
    BIC    R8,R8,R9,LSL#12 ;J
    ADD    R9,R5,R9,LSL#3  ;(I,1)
    ADD    R8,R5,R8,LSL#3  ;(J,1)
    MOV    lr,R4           ;L count
;         loop over L=1,K
wm2 LDR    R6,[R8,#4]      ;swap columns
    LDR    ip,[R9,#4]
    STR    R6,[R9,#4]
    STR    ip,[R8,#4]
    LDR    R6,[R8]
    LDR    ip,[R9]
    STR    R6,[R9],R2,LSL#3
    STR    ip,[R8],R2,LSL#3
    SUBS   lr,lr,#1
    BGT    wm2             ;loop over L rows
    CMP    R3,R7
    BLT    wm1             ;loop over entries
;         loop over columns of B (L=1,K)
wm3 SUB    R8,R5,#8        ;(I-1,L) I=1
    SUB    R7,R1,R2,LSL#3  ;(I,I-1) I=1
    MOV    R9,R0           ;I count (=N)
;         loop over I=1,N
wm4 LDFD   F0,[R8,#8]!     ;-s21=B(I,L)
    SUBS   lr,R0,R9        ;J count (=I-1)
    ADDGT  R6,R1,lr,LSL#3  ;(I,J) J=1
    MOVGT  ip,R5           ;(J,L) J=1
;         loop over J=1,I-1
wm5 LDFGTD F1,[R6]         ;A(I,J)
    ADDGT  R6,R6,R2,LSL#3  ;(I,J+1)
    LDFGTD F2,[ip],#8      ;B(J,L) : (J+1,L)
    MUFGTE F1,F1,F2
    SUFGTE F0,F0,F1        ;-s21=-s21-A(I,J)*B(J,L)
    SUBGTS lr,lr,#1
    BGT    wm5             ;loop over J
    ADD    R7,R7,R2,LSL#3  ;(I,I)
    LDFD   F1,[R7],#8      ;A(I,I) : (I+1,I)
    MUFE   F0,F0,F1
    STFD   F0,[R8]         ;B(I,L)=-A(I,I)*s21
    SUBS   R9,R9,#1
    BGT    wm4             ;loop over I
    SUBS   R9,R0,#1        ;I count (N-1)
    BEQ    wm8
;         loop over I=N-1,1,-1
wm6 LDFD   F0,[R8,#-8]!    ;-s22=B(I,L)
    SUB    R6,R0,R9        ;J count (=N-I)
    SUB    R7,R7,#8        ;(I+1,N)
    SUB    lr,R7,#8        ;(I,J) J=N
    ADD    ip,R5,R0,LSL#3  ;(J+1,L) J=N
;         loop over J=N,I+1,-1
wm7 LDFD   F1,[lr]         ;A(I,J)
    SUB    lr,lr,R2,LSL#3  ;(I,J-1)
    LDFD   F2,[ip,#-8]!    ;B(J,L)
    MUFE   F1,F1,F2
    SUFE   F0,F0,F1        ;-s22=-s22-A(I,J)*B(J,L)
    SUBS   R6,R6,#1
    BGT    wm7             ;loop over J
    STFD   F0,[R8]         ;B(I,L)=-s22
    SUBS   R9,R9,#1
    BGT    wm6             ;loop over I
wm8 ADD    R5,R5,R2,LSL#3  ;(1,L+1)
    SUBS   R4,R4,#1
    BGT    wm3             ;loop over L
    LDMDB  fp,{R4-R9,fp,sp,pc} ;return
    END
;
    TTL   DFINV
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
F2  FN     2
F3  FN     3
F4  FN     4
    AREA   |C$$code|,CODE,READONLY
    EXPORT dfinv_;(N,A,IDIM,IR) puts A=1/A (A prepared by DFACT)
    DCB    "dfinv_",0,0,8,0,0,255
dfinv_
    MOV    ip,sp
    STMDB  sp!,{R0-R9,fp,ip,lr,pc}
    SUB    fp,ip,#4
;         initialise variables
    LDR    R0,[R0]         ;N
    LDR    R2,[R2]         ;IDIM
;         check for trivial case: N=1
    CMP    R0,#2
    CMPGE  R2,R0           ;ensure NDIM >= N
    LDMLTDB fp,{R4-R9,fp,sp,pc} ;return
    STFE   F4,[sp,#-12]!
    SUB    R0,R0,#1        ;N-1
    MOV    R4,#1           ;"I-1"
    MOV    R5,R1           ;(I-1,I-1)
;         loop over I = 2,N
wn1 ADD    R6,R5,#8        ;(I,I-1)
    ADD    R5,R6,R2,LSL#3  ;(I,I)
    LDFD   F4,[R5]         ;A(I,I)
    ADD    R7,R1,R4,LSL#3  ;(I,J) J=1
    SUB    R8,R5,R4,LSL#3  ;(J,I) J=1
;         loop over J=1,I-1
wn2 MVFE   F0,#0           ;-s31=0
    LDFD   F1,[R8]         ;s32=A(J,I)
    SUB    ip,R7,#8        ;(K,J) K=I-1
    MOV    R9,R6           ;(I,K) K=I-1
    SUB    lr,R8,R2,LSL#3  ;(J,K) K=I-1
    SUB    R3,R5,#8        ;(K,I) K=I-1
;         loop over K=I-1,J,-1
wn3 LDFD   F2,[ip],#-8     ;A(K,J) : (K-1,J)
    LDFD   F3,[R9]         ;A(I,K)
    SUB    R9,R9,R2,LSL#3  ;(I,K-1)
    MUFE   F2,F2,F3
    SUFE   F0,F0,F2        ;-s31=-s31-A(K,J)*A(I,K)
    CMP    R9,R7           ;(I,K') <=> (I,J)
    LDFGED F2,[lr]         ;A(J,K)
    SUBGE  lr,lr,R2,LSL#3  ;(J,K-1)
    LDFGED F3,[R3],#-8     ;A(K,I) : (K-1,I)
    MUFGEE F2,F2,F3
    ADFGEE F1,F1,F2        ;s32=s32+A(J,K)*A(K,I)
    BGE    wn3             ;loop over K
    MUFE   F0,F0,F4
    STFD   F0,[R7]         ;A(I,J)=-s31*A(I,I)
    ADD    R7,R7,R2,LSL#3  ;(I,J+1)
    MNFE   F1,F1
    STFD   F1,[R8],#8      ;A(J,I)=-s32 : (J+1,I)
    CMP    R7,R6           ;(I,J') <=> (I,I-1)
    BLE    wn2             ;loop over J
    ADD    R4,R4,#1        ;increment "I-1"
    CMP    R4,R0           ;compare with N-1
    BLE    wn1             ;loop over "I-1"
;
    SUB    R6,R5,R0,LSL#3  ;(I,N) I=1
    MOV    R5,R1           ;(I,1) I=1
    MOV    R4,R0           ;I count (=N-I)
;         loop over I = 1,N-1
wn4 MOV    R7,R5           ;(I,J) J=1
    ADD    R8,R1,R0,LSL#3  ;(N,J) J=1
    MOV    lr,R0           ;J count (=N-J)
;         loop over J = 1,N
wn5 MOV    ip,R8           ;(K,J) K=N
    MOV    R9,R6           ;(I,K) K=N
    CMP    lr,R4           ;compare N-J with N-I
    LDFGED F0,[R7]         ;s=A(I,J) if J<=I
    MVFLTE F0,#0           ;s=0 if J>I
    MOVGE  R3,R4           ;K count = N-I if J<=I
    ADDLT  R3,lr,#1        ;K count = N-J+1 if J>I
;         loop over K
wn6 LDFD   F1,[ip],#-8     ;A(K,J) : (K-1,J)
    LDFD   F2,[R9]         ;A(I,K)
    SUB    R9,R9,R2,LSL#3  ;(I,K-1)
    MUFE   F1,F1,F2
    ADFE   F0,F0,F1        ;s=s+A(K,J)*A(I,K)
    SUBS   R3,R3,#1
    BGT    wn6             ;loop over K
    STFD   F0,[R7]         ;A(I,J)=s
    ADD    R8,R8,R2,LSL#3  ;(N,J+1)
    ADD    R7,R7,R2,LSL#3  ;(I,J+1)
    SUBS   lr,lr,#1
    BGE    wn5             ;loop over J, N times
    ADD    R5,R5,#8        ;(I+1,1)
    ADD    R6,R6,#8        ;(I+1,N)
    SUBS   R4,R4,#1
    BGT    wn4             ;loop over I N-1 times
;         now exchange columns
    LDFE   F4,[sp],#12     ;restore F4
    LDR    R3,[sp,#12]     ;restore address of IR
    LDR    R4,[R3]
    ADD    R4,R4,R3        ;end of list
;         loop over exchanges
wn7 CMP    R4,R3
    LDMLEDB fp,{R4-R9,fp,sp,pc} ;return
    LDR    R5,[R4],#-4
    MOV    R6,R5,LSR#12    ;I
    BIC    R5,R5,R6,LSL#12 ;J
    MUL    R6,R2,R6
    MUL    R5,R2,R5
    ADD    R6,R1,R6,LSL#3  ;(1,I)
    ADD    R5,R1,R5,LSL#3  ;(1,J)
    MOV    R7,R0
wn8 LDMIA  R6,{R8,R9}      ;swap rows
    LDMIA  R5,{ip,lr}
    STMIA  R6!,{ip,lr}
    STMIA  R5!,{R8,R9}
    SUBS   R7,R7,#1
    BGE    wn8             ;loop N times
    B      wn7
    END
;
    TTL   dgs56p
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
R4  RN     4
R5  RN     5
R6  RN     6
R7  RN     7
F0  FN     0
F1  FN     1
F2  FN     2
F3  FN     3
F4  FN     4
F5  FN     5
F6  FN     6
F7  FN     7
;
    AREA   |C$$code|,CODE,READONLY
    IMPORT __rt_stkovf_split_big
    EXPORT dgs56p_;(F,A,B,RES,ERR) Gaussian quadrature with 5&6 points
;               variables are DOUBLE PRECISION
;               F is the REAL*8 function to integrate from A to B
;               returns the integral RES and an estimate of the error ERR
    DCB    "dgs56p_",0,8,0,0,255
dgs56p_
    MOV    ip,sp
    STMDB  sp!,{R0-R7,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDFD   F0,[R1]         ;A
    LDFD   F1,[R2]         ;B
    MOV    R4,#1           ;DP = .TRUE.
    B      stt             ;go start
;
    EXPORT rgs56p_;(F,A,B,RES,ERR) Gaussian quadrature with 5&6 points
;               variables are REAL
;               F is the REAL*4 function to integrate from A to B
;               returns the integral RES and an estimate of the error ERR
    DCB    "rgs56p_",0,8,0,0,255
rgs56p_
    MOV    ip,sp
    STMDB  sp!,{R0-R7,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDFS   F0,[R1]         ;A
    LDFS   F1,[R2]         ;B
    MOV    R4,#0           ;DP = .FALSE.
stt SUB    ip,sp,#56       ;extra stack space: 48 for fp registers, 8 for arg
    CMP    ip,sl           ;check for space on stack
    BLLT   __rt_stkovf_split_big
    SFMFD  F4,4,[sp]!      ;save fp regisrers 4 to 7
    MOV    R5,R0           ;save address of F
    MVFD   F4,F0           ;save A
    SUFD   F5,F1,F0        ;RANG = B - A
    MVFD   F6,#0           ;initialise E5
    MVFD   F7,#0           ;initialise E6
    MOV    R6,#11          ;5+6 -point count
    ADR    R7,xw           ;start of constants
    SUB    sp,sp,#8        ;space for argument
lp1 LDFD   F0,[R7],#8      ;x5,6(I)
    MUFD   F0,F0,F5
    ADFD   F0,F0,F4        ;A+RANG*X5(I)
    CMP    R4,#0
    STFNED F0,[sp]         ;store argument for F
    STFEQS F0,[sp]
    MOV    R0,sp           ;address of argument
    ADR    lr,rp1
    MOV    pc,R5           ;call F
rp1 LDFD   F1,[R7],#8      ;w5,6(I)
    MUFD   F1,F1,F0
    TST    R6,#1
    ADFEQD F6,F6,F1        ;E5 = E5 + W5(I)*F(A+RANG*X5(I))
    ADFNED F7,F7,F1        ;E6 = E6 + W6(I)*F(A+RANG*X6(I))
    SUBS   R6,R6,#1
    BGT    lp1             ;loop over 11 points
    ADD    sp,sp,#8        ;restore stack
    ADFD   F0,F6,F7
    MUFD   F0,F0,#0.5
    MUFD   F0,F0,F5        ;RES = 0.5*(E6+E5)*RANG
    SUFD   F1,F6,F7
    MUFD   F1,F1,F5
    ABSD   F1,F1           ;ERR = |(E6-E5)*RANG|
    LFMFD  F4,4,[sp]!      ;restore fp registers
    LDR    R3,[fp,#-32]    ;address of RES
    LDR    R5,[fp,#4]      ;address of ERR
    CMP    R4,#0           ;test DP
    STFNED F0,[R3]         ;store RES
    STFEQS F0,[R3]
    STFNED F1,[R5]         ;store ERR
    STFEQS F1,[R5]
    LDMDB  fp,{R4-R7,fp,sp,pc} ;return
;
xw  DCFD  3.3765242898423989E-02, 8.5662246189585178E-02 ;xw6(1)
    DCFD  4.6910077030668004E-02, 1.1846344252809454E-01 ;xw5(1)
    DCFD  1.6939530676686775E-01, 1.8038078652406930E-01 ;xw6(2)
    DCFD  2.3076534494715846E-01, 2.3931433524968324E-01 ;xw5(2)
    DCFD  3.8069040695840155E-01, 2.3395696728634552E-01 ;xw6(3)
    DCFD  5.0000000000000000E-01, 2.8444444444444444E-01 ;xw5(3)
    DCFD  6.1930959304159845E-01, 2.3395696728634552E-01 ;xw6(4)
    DCFD  7.6923465505284154E-01, 2.3931433524968324E-01 ;xw5(4)
    DCFD  8.3060469323313225E-01, 1.8038078652406930E-01 ;xw6(5)
    DCFD  9.5308992296933200E-01, 1.1846344252809454E-01 ;xw5(5)
    DCFD  9.6623475710157601E-01, 8.5662246189585178E-02 ;xw6(6)
    END
;
    TTL   DINV
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R0  RN     0
R3  RN     3
R4  RN     4
R5  RN     5
R6  RN     6
    AREA   |C$$code|,CODE,READONLY
    EXPORT dinv_;(N,A,IDIM,R,IFAIL) finds 1/A, A is any non-singular matrix
    IMPORT dfact_
    IMPORT dfinv_
    DCB    "dinv_",0,0,0,8,0,0,255
dinv_
    MOV    ip,sp
    STMDB  sp!,{R0-R6,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R4,[fp,#4]      ;address of IFAIL
    SUB    sp,sp,#12        ;space for DET and JFAIL
    MOV    R5,sp
    ADD    R6,R5,#8        ;addresses for DET and JFAIL
    STMFD  sp!,{R4-R6}
    BL     dfact_
    ADD    sp,sp,#24       ;restore stack
    LDMFD  sp!,{R0-R3}     ;restore addresses of N,A,IDIM,R
    LDR    ip,[R4]
    CMP    ip,#0           ;test IFAIL
    BLEQ   dfinv_          ;call DFINV if OK
    LDMDB  fp,{R4-R6,fp,sp,pc} ;return
    END
;
    TTL   divdif
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
F0  FN     0
F1  FN     1
F2  FN     2
F3  FN     3
MMAX   EQU 10; maximum degree of interpolating polynomial
;
    AREA   |C$$code|,CODE,READONLY
    EXPORT divdif_;(F,A,NN,X,MM) tabular interpolation
    DCB    "divdif_",0,8,0,0,255
divdif_
    MOV    ip,sp
    STMDB  sp!,{R0-R8,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R2,[R2]      ;NN
    LDR    R4,[fp,#4]   ;(MM)
    LDR    R4,[R4]      ;MM
    CMP    R4,R2
    SUBGE  R4,R2,#1
    CMP    R4,#MMAX
    MOVGT  R4,#MMAX     ;M=MIN(MM,MMAX,N-1)
    CMP    R4,#1
    MVFLTS F0,#0
    LDMLTDB fp,{R4-R8,fp,sp,pc} ;return 0 if NN<2 or MM<1
    MOV    R5,#0        ;IX = 0
    ADD    R6,R2,#1     ;IY = N+1
    LDR    R3,[R3]      ;X
    TST    R3,#8,4      ;correct sign
    RSBNE  R3,R3,#8,4
    LDR    ip,[R1],#-4  ;A(1); (A(1)) -> (A(0))
    LDR    lr,[R1,R2,LSL#2];A(N)
    TST    ip,#8,4      ;correct signs
    RSBNE  ip,ip,#8,4
    TST    lr,#8,4
    RSBNE  lr,lr,#8,4
    SUB    ip,lr,ip    ;A(N)-A(1) (for direction of A)
lp1 ADD    R7,R5,R6
    MOV    R7,R7,LSR#1 ;MID = (IX+IY)/2
    LDR    lr,[R1,R7,LSL#2] ;A(MID)
    TST    lr,#8,4     ;correct for sign
    RSBNE  lr,lr,#8,4
    SUBS   lr,R3,lr    ;X-A(MID)
    EORNES lr,lr,ip
    MOVMI  R6,R7       ;IY=MID
    MOVPL  R5,R7       ;or IX=MID
    SUB    lr,R6,R5
    CMP    lr,#1
    BGT    lp1         ;loop while IY-IX>1
;       copy reordered interpolation points to stack
    ORR    R3,R4,#1    ;NPTS = M + 1 - MOD(M,2)
    MOV    R6,#0       ;IP = 0
    MOV    R7,#0       ;L = 0
    SUB    R0,R0,#4    ;F(0)
lp2 ADD    R8,R5,R7    ;ISUB = IX + L
    CMP    R8,#1
    CMPGE  R2,R8       ;IF(ISUB.GE.1 .AND. N.GE.ISUB) THEN
    LDRGE  ip,[R1,R8,LSL#2];A(ISUB)
    LDRGE  lr,[R0,R8,LSL#2];F(ISUB)
    ADDGE  R6,R6,#1    ;  IP = IP + 1
    STMGEFD sp!,{ip,lr};  store F(ISUB),A(ISUB) on stack as D(IP), T(IP)
    MOVLT  R3,R4       ;ELSE NPTS = M
    RSBS   R7,R7,#0    ;L = -L
    ADDGE  R7,R7,#1
    CMP    R6,R3
    BLE    lp2         ;loop while IP.LE.NPTS
    SUB    R3,R3,R4    ;EXTRA = NPTS-M (0 or +1)
;        replace D by leading diagonal of a divided difference table
    MOV    R2,R4       ;initialise L-count (M)
    ADD    R5,sp,R3,LSL#3;(T(L+1))
lp3 ADD    R5,R5,#8    ;(T(L))
    ADD    R6,sp,#12   ;(D(NPTS))
    MOV    R7,sp       ;(T(NPTS+1))
    CMP    R3,#0       ;check if NPTS>M
    LDFGTS F0,[R6,#-8] ;D(NPTS+1) (NPTS = M+1)
    LDFGTS F1,[R6,#8]! ;D(NPTS-1) (NPTS = M+1); (D(M))
    LDFGTS F2,[R7],#8  ;T(NPTS+1) (NPTS = M+1); (T(M+1))
    LDFGTS F3,[R5]     ;T(L)
    SUFGTS F0,F0,F1    ;D(M+2) - D(M)
    SUFGTS F2,F2,F3    ;T(M+2) - T(L)
    MOV    lr,R2       ;initialise I-count (L) (J=M)
    FDVGTS F1,F0,F2
    MOV    ip,R5       ;(T(I)) (I=L)
    STFGTS F1,[R6,#-16];D(M+2) = (D(M+2) - D(M))/(T(M+2) - T(L))
lp4 LDFS   F0,[R6,#-8] ;D(J+1)
    LDFS   F1,[R6],#8  ;D(J), (J) -> (J-1)
    LDFS   F2,[R7],#8  ;T(J+1), (J) -> (J-1)
    LDFS   F3,[ip],#8  ;T(I), (I) -> (I-1)
    SUFS   F0,F0,F1    ;D(J+1) - D(J)
    SUFS   F2,F2,F3    ;T(J+1) - T(L)
    FDVS   F0,F0,F2
    SUBS   lr,lr,#1
    STFS   F0,[R6,#-16];D(J+1) = (D(J+1) - D(J))/(T(J+1) - T(L))
    BGT    lp4         ;loop L times
    SUBS   R2,R2,#1
    BGT    lp3         ;loop M times
;       evaluate the Newton interpolation
    LDFS   F0,[sp,#4]! ;D(M+1) or (M+2)
    CMP    R3,#0
    LDFGTS F1,[sp,#8]! ;D(M+1)
    ADFGTS F2,F1,F0
    FMLGTS F0,F2,#0.5
    LDR    R3,[fp,#-36];restore (X)
    LDFS   F3,[R3]     ;X
lp5 LDFS   F1,[sp,#4]! ;T(L)
    LDFS   F2,[sp,#4]! ;D(L)
    SUFS   F1,F3,F1
    FMLS   F1,F1,F0
    SUBS   R4,R4,#1
    ADFS   F0,F2,F1    ;SUM = D(L) + (X - T(L))*SUM
    BGT    lp5         ;loop M times
    LDMDB  fp,{R4-R8,fp,sp,pc} 
    END
;
    TTL    DMADD
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
F1  FN     1
F0  FN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT dmadd_;(M,N,X11,X12,X21,Y11,Y12,Y21,Z11,Z12,Z21)  z= x+ y
    DCB    "dmadd_",0,0,8,0,0,255
dmadd_
    MOV    ip,sp
    STMDB  sp!,{R0-R9,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDMIB  fp,{R4-R9,ip};arg addresses (X21 to Z21)
    LDR    R0,[R0]     ;m
    LDR    R1,[R1]     ;n
    SUB    R3,R3,R2    ; Xj step
    SUB    R4,R2,R4
    MLA    R4,R3,R1,R4 ;-Xi step
    SUB    R6,R6,R5    ; Yj step
    SUB    R7,R5,R7
    MLA    R7,R6,R1,R7 ;-Yi step
    SUB    R9,R9,R8    ; Zj step
    SUB    ip,R8,ip
    MLA    ip,R9,R1,ip ;-Zi step
    CMP    R0,#1
wa1 MOV    lr,R1       ;j - count
wb1 SUBGES lr,lr,#1
    LDFGED F0,[R2]     ;Xij
    LDFGED F1,[R5]     ;Yij
    ADFGED F0,F0,F1
    STFGED F0,[R8]     ;Zij = Xij + Yij
    ADDGE  R2,R2,R3
    ADDGE  R5,R5,R6
    ADDGE  R8,R8,R9
    BGT    wb1         ;loop over j
    SUB    R2,R2,R4
    SUB    R5,R5,R7
    SUB    R8,R8,ip
    SUBEQS R0,R0,#1
    BGT    wa1         ;loop over i
    LDMDB  fp,{R4-R9,fp,sp,pc} ;return
    END
;
    TTL    DMBIL
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
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
F3  FN     3
F2  FN     2
F1  FN     1
F0  FN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT dmbil_;(N,V1,V2,X11,X12,X21,Y1,Y2)    Vk * Xkj * Yj => funct
    DCB    "dmbil_",0,0,8,0,0,255
dmbil_
    MOV    ip,sp
    STMDB  sp!,{R0-R8,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDMIB  fp,{R4-R7}  ;arg addresses
    LDR    R0,[R0]     ;n
    SUB    R2,R2,R1    ;V step
    SUB    R7,R7,R6    ;Y step
    SUB    R4,R4,R3    ; Xj step
    SUB    R5,R3,R5
    MLA    R5,R4,R0,R5 ;-Xk step
    MVFE   F0,#0       ;total accumulator
    ADDS   ip,R0,#0    ;k-count
wa2 MOV    lr,R0       ;j-count
    MVFGTE F1,#0       ;row accumulator
    MOV    R8,R6       ;(Yj)
wb2 LDFGTD F2,[R3]     ;Xkj
    LDFGTD F3,[R8]     ;Yj
    MUFGTE F2,F2,F3
    ADFGTE F1,F1,F2    ;sum row
    ADD    R3,R3,R4
    ADD    R8,R8,R7
    SUBS   lr,lr,#1
    BGT    wb2         ;loop over j
    LDFGED F2,[R1]     ;Vk
    MUFGEE F1,F1,F2    ;multiply by row
    ADFGEE F0,F0,F1    ;sum total
    ADD    R1,R1,R2
    SUB    R3,R3,R5
    SUBS   ip,ip,#1
    BGT    wa2
    LDMDB  fp,{R4-R8,fp,sp,pc} ;return
    END
;
    TTL    DMDMP
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
F1  FN     1
F0  FN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT dmdmp_;(M,N,D1,D2,X11,X12,X21,Z11,Z12,Z21)  Zij = Di * Xij
    DCB    "dmdmp_",0,0,8,0,0,255
dmdmp_
    MOV    ip,sp
    STMDB  sp!,{R0-R9,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDMIB  fp,{R4-R9}  ;arg addresses
    LDR    R0,[R0]     ;m
    LDR    R1,[R1]     ;n
    SUB    R3,R3,R2    ; Di step
    SUB    R5,R5,R4    ; Xj step
    SUB    R6,R4,R6
    MLA    R6,R5,R1,R6 ;-Xi step
    SUB    R8,R8,R7    ; Zj step
    SUB    R9,R7,R9
    MLA    R9,R8,R1,R9 ;-zi step
    CMP    R0,#0
wae LDFGTD F0,[R2]     ;Di
    MOVGTS ip,R1       ;j-count
wbe LDFGTD F1,[R4]     ;Xij
    MUFGTD F1,F1,F0
    STFGTD F1,[R7]     ;Zij = Di * Xij
    ADD    R4,R4,R5
    ADD    R7,R7,R8
    SUBGTS ip,ip,#1
    BGT    wbe         ;loop over j
    SUB    R4,R4,R6
    SUB    R7,R7,R9
    ADD    R2,R2,R3
    SUBEQS R0,R0,#1
    BGT    wae         ;loop over i
    LDMDB  fp,{R4-R9,fp,sp,pc} ;return
    END
;
    TTL    DMINMAX
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
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 lvsdmi_;(DA,N,INC) find location of minimum in REAL*8 DA(I) I=1,N*INC
    DCB    "lnsdmi_",0,8,0,0,255
lvsdmi_
    MOV    ip,sp
    STMDB  sp!,{R0-R2,R4-R8,fp,ip,lr,pc}
    SUB    fp,ip,#4
    MVN    ip,#0         ;find minimum
    B      wd1
;
    EXPORT lvsdmx_;(DA,N,INC) find location of maximum in REAL*8 DA(I) I=1,N*INC
    DCB    "lvsdmx_",0,8,0,0,255
lvsdmx_
    MOV    ip,sp
    STMDB  sp!,{R0-R2,R4-R8,fp,ip,lr,pc}
    SUB    fp,ip,#4
    MOV    ip,#0         ;find maximum
wd1 LDR    R1,[R1]       ;N
    CMP    R1,#0
    MOVLE  R0,#0
    LDMLEDB fp,{R4-R8,fp,sp,pc} ;return if N<=0
    LDR    R2,[R2]       ;INC
    MOV    R4,#&80000000 ;m.s. half of max
    MOV    R5,#0         ;l.s. half of max
    MVN    R3,R4         ;mask
    SUB    R8,R0,R2,LSL#3;index
wd2 LDR    R6,[R8,R2,LSL#3]! ;m.s. half of test word
    LDR    R7,[R8,#4]    ;l.s. half of test word
    TST    R6,#&80000000
    EORMI  R6,R6,R3      ;fix up floating point sign
    MVNMI  R7,R7
    EOR    R6,R6,ip      ;flip if looking for minimum
    EOR    R7,R7,ip
    CMP    R6,R4         ;compare full REAL*8 word
    CMPEQ  R7,R5
    MOVGT  R4,R6         ;save maximum
    MOVGT  R5,R7
    SUBGT  lr,R8,R0      ;save index of maximum
    SUBS   R1,R1,#1
    BGT    wd2           ;loop n times
    MOV    R0,lr,LSR#3
    ADD    R0,R0,#1      ;calculate fortran index
    LDMDB fp,{R4-R8,fp,sp,pc} ;return
    END
;
    TTL    DMCPY
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
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 dmcpy_;(M,N,X11,X12,X21,Z11,Z12,Z21)  z   = x
    DCB    "dmcpy_",0,0,8,0,0,255
dmcpy_
    MOV    ip,sp
    STMDB  sp!,{R0-R7,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDMIB  fp,{R4-R7}  ;arg addresses
    LDR    R0,[R0]     ;m
    LDR    R1,[R1]     ;n
    SUB    R3,R3,R2    ; Xj step
    SUB    R4,R2,R4
    MLA    R4,R3,R1,R4 ;-Xi step
    SUB    R6,R6,R5    ; Zj step
    SUB    R7,R5,R7
    MLA    R7,R6,R1,R7 ;-Zi step
    CMP    R0,#1
wa3 MOV    ip,R1       ;j - count
wb3 SUBGES ip,ip,#1
    LDRGE  lr,[R2,#4]  ;copy X'ij
    STRGE  lr,[R5,#4]  ;to Z'ij
    LDRGE  lr,[R2],R3  ;copy Xij
    STRGE  lr,[R5],R6  ;to Zij
    BGT    wb3         ;loop over j
    SUB    R2,R2,R4
    SUB    R5,R5,R7
    SUBEQS R0,R0,#1
    BGT    wa3         ;loop over i
    LDMDB  fp,{R4-R7,fp,sp,pc} ;return
    END
;
    TTL   DMINFC
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
F0  FN    0
F1  FN    1
F2  FN    2
F3  FN    3
F4  FN    4
F5  FN    5
F6  FN    6
F7  FN    7
    AREA   |C$$code|,CODE,READONLY
    EXPORT dminfc_;(F,A,B,EPS,DELTA,X,Y,LLM) finds local minimum of function
    DCB    "dminfc_",0,8,0,0,255
dminfc_
    MOV    ip,sp
    STMDB  sp!,{R0-R8,fp,ip,lr,pc}
    SUB    fp,ip,#4
    STFE   F4,[sp,#-12]! ;save floating registers
    STFE   F5,[sp,#-12]!
    STFE   F6,[sp,#-12]!
    STFE   F7,[sp,#-12]!
    SUB    sp,sp,#lsk    ;space for variables
    MOV    R4,R0         ;(F)
    LDFD   F6,[R1]       ;C=A
    LDFD   F7,[R2]       ;D=B
    CMF    F6,F7
    LDFGTD F6,[R2]       ;C=MIN(A,B)
    LDFGTD F7,[R1]       ;D=MAX(A,B]
    BEQ    ret
    SUFD   F1,F7,F6
    LDFD   F0,[R3]       ;EPS
    DVFD   F2,F1,F0
    LGND   F0,F2
    LDFS   F1,=2.08
    MUFD   F2,F0,F1
    FIX    R5,F2
    CMP    R5,#0
    BLT    ret
    MOV    R6,#3         ;LLT=.TRUE., LGE=.TRUE. (bits 1 and 0)
lp1 SUFD   F1,F7,F6      ;D-C
    LDFD   F0,hv         ;HV
    TST    R6,#1
    MUFNED F5,F0,F1      ;H=HV*(D-C)
    TST    R6,#2         ;IF(LLT) THEN
    BEQ    DC1
    MUFD   F4,F0,F1      ;H=HV*(D-C)
    ADFD   F2,F6,F4
    STFD   F2,vv         ;V=C+H
    ADR    R0,vv
    BL     func
    MVFD   F4,F0         ;FV=F(V)
DC1 TST    R6,#1         ;IF(LLE) THEN
    BEQ    DC2
    SUFD   F2,F7,F5
    STFD   F2,ww         ;W=D-H
    ADR    R0,ww
    BL     func
    MVFD   F5,F0         ;FW=F(W)
DC2 ADR    R0,ww
    CMF    F4,F5         ;IF(FV.LT.FW) THEN
    MOVLT  R6,#2         ;  LLT=.TRUE., LGE=.FALSE.
    LDFLTD F7,ww         ;  D=W
    MVFLTD F5,F4         ;  FW=FV
    LDMLTDB R0,{R1,R2}   ;  W=V
    STMLTIA R0,{R1,R2}   ;ELSE
    MOVGE  R6,#1         ;  LLT=.FALSE., LGE=.TRUE.
    LDFGED F6,vv         ;  C=V
    MVFGED F4,F5         ;  FV=FW
    LDMGEIA R0,{R1,R2}   ;  V=W
    STMGEDB R0,{R1,R2}
    SUBS   R5,R5,#1
    BGE    lp1           ;loop N+1 times
;
ret ADFD   F0,F6,F7
    MUFD   F6,F0,#0.5
    LDMIB  fp,{R5-R8}    ;(DELTA),(X),(Y),(LLM)
    STFD   F6,[R6]       ;X=0.5*(C+D)
    MOV    R0,R6
    BL     func
    STFD   F0,[R7]       ;Y=F(X)
    LDR    R0,[fp,#-44]  ;(A)
    LDR    R1,[fp,#-40]  ;(B)
    LDFD   F0,[R0]       ;A
    LDFD   F1,[R1]       ;B
    SUFD   F0,F0,F6      ;A-X
    SUFD   F1,F1,F6      ;B-X
    LDFD   F2,[R5]       ;DELTA
    ABSD   F0,F0
    ABSD   F1,F1
    CMF    F0,F2
    CMFGT  F1,F2
    MOVGT  R0,#-1        ;.TRUE. if |A-X|>DELTA AND |B-X|>DELTA
    MOVLE  R0,#0         ;.FALSE. otherwise
    STR    R0,[R8]       ;store LLM
    LDFE   F7,[sp,#0+lsk];restore floating registers
    LDFE   F6,[sp,#12+lsk]
    LDFE   F5,[sp,#24+lsk]
    LDFE   F4,[sp,#36+lsk]
    LDMDB  fp,{R4-R8,fp,sp,pc} ;return
;
func MOV   pc,R4         ;call F
;
hv  DCFD   0.3819660112501051518; (3-root(5))/2 = 2-tau
;
    ^      0,sp        ;do not change the order of these, just add to them
vv  #     8            ;V
ww  #     8            ;W
lsc #     0
;
lsk EQU  lsc-vv
    END
;
;
    TTL    DMMLA
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
F2  FN     2
F1  FN     1
F0  FN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT dmmla_;(M,N,K,X11,X12,X21,Y11,Y12,Y21,Z11,Z12,Z21)  z = xy + z
    DCB    "dmmla_",0,0,8,0,0,255
dmmla_
    MOV    ip,sp
    STMDB  sp!,{R0-R9,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R0,[R0]     ;m
    LDR    R1,[R1]     ;n
    LDR    R2,[R2]     ;k
    CMP    R0,#0       ;check m>0
    CMPGT  R1,#0       ;check n>0
    CMPGT  R2,#0       ;check k>0
    LDMLEDB fp,{R4-R9,fp,sp,pc} ;return if not
    LDMIB  fp,{R4-R9,ip,lr} ;arg addresses
    SUB    R4,R4,R3    ;X(i,j) :jstep
    SUB    R5,R5,R3    ;X(i,j) :istep
    SUB    R7,R7,R6    ;Y(j,l) :lstep
    SUB    R8,R8,R6    ;Y(j,l) :jstep
    SUB    ip,ip,R9    ;Z(i,l) :lstep
    SUB    lr,lr,R9    ;Z(i,l) :istep
wa1 STMFD  sp!,{R0,lr} ;save m and istep(Z)
    MOV    R0,R2       ;initialise l to k
    MLA    R6,R7,R2,R6 ;(Y(1,k+1))
    MLA    R9,ip,R2,R9 ;(Z(i,k+1))
wb1 MOV    lr,R1       ;initialise j to n
    SUB    R6,R6,R7    ;(Y(1,l))
    SUB    R9,R9,ip    ;(Z(i,l))
    MLA    R3,R4,R1,R3 ;(X(i,n+1))
    MLA    R6,R8,R1,R6 ;(Y(n+1,l))
    LDFD   F0,[R9]     ;initialise from +Z(i,l)
wc1 SUB    R3,R3,R4    ;(X(i,j))
    SUB    R6,R6,R8    ;(Y(j,l))
    LDFD   F1,[R3]     ;get X(i,j)
    LDFD   F2,[R6]     ;get Y(j,l)
    MUFE   F1,F1,F2
    ADFE   F0,F0,F1    ;sum their products
    SUBS   lr,lr,#1
    BGT    wc1         ;loop over j=n,1,-1
    STFD   F0,[R9]     ;store Z(i,l)
    SUBS   R0,R0,#1
    BGT    wb1         ;loop over l=k,1,-1
    LDMFD  sp!,{R0,lr} ;restore m and istep(Z)
    ADD    R3,R3,R5    ;(X(i+1,1))
    ADD    R9,R9,lr    ;(Z(i+1,1))
    SUBS   R0,R0,#1
    BGT    wa1         ;loop over i=1,m
    LDMDB  fp,{R4-R9,fp,sp,pc} ;return
    END
;
    TTL    DMMLS
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
F2  FN     2
F1  FN     1
F0  FN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT dmmls_;(M,N,K,X11,X12,X21,Y11,Y12,Y21,Z11,Z12,Z21)  z = xy - z
    DCB    "dmmls_",0,0,8,0,0,255
dmmls_
    MOV    ip,sp
    STMDB  sp!,{R0-R9,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R0,[R0]     ;m
    LDR    R1,[R1]     ;n
    LDR    R2,[R2]     ;k
    CMP    R0,#0       ;check m>0
    CMPGT  R1,#0       ;check n>0
    CMPGT  R2,#0       ;check k>0
    LDMLEDB fp,{R4-R9,fp,sp,pc} ;return if not
    LDMIB  fp,{R4-R9,ip,lr} ;arg addresses
    SUB    R4,R4,R3    ;X(i,j) :jstep
    SUB    R5,R5,R3    ;X(i,j) :istep
    SUB    R7,R7,R6    ;Y(j,l) :lstep
    SUB    R8,R8,R6    ;Y(j,l) :jstep
    SUB    ip,ip,R9    ;Z(i,l) :lstep
    SUB    lr,lr,R9    ;Z(i,l) :istep
wa1 STMFD  sp!,{R0,lr} ;save m and istep(Z)
    MOV    R0,R2       ;initialise l to k
    MLA    R6,R7,R2,R6 ;(Y(1,k+1))
    MLA    R9,ip,R2,R9 ;(Z(i,k+1))
wb1 MOV    lr,R1       ;initialise j to n
    SUB    R6,R6,R7    ;(Y(1,l))
    SUB    R9,R9,ip    ;(Z(i,l))
    MLA    R3,R4,R1,R3 ;(X(i,n+1))
    MLA    R6,R8,R1,R6 ;(Y(n+1,l))
    LDFD   F0,[R9]
    MNFE   F0,F0       ;initialise from -Z(i,l)
wc1 SUB    R3,R3,R4    ;(X(i,j))
    SUB    R6,R6,R8    ;(Y(j,l))
    LDFD   F1,[R3]     ;get X(i,j)
    LDFD   F2,[R6]     ;get Y(j,l)
    MUFE   F1,F1,F2
    ADFE   F0,F0,F1    ;sum their products
    SUBS   lr,lr,#1
    BGT    wc1         ;loop over j=n,1,-1
    STFD   F0,[R9]     ;store Z(i,l)
    SUBS   R0,R0,#1
    BGT    wb1         ;loop over l=k,1,-1
    LDMFD  sp!,{R0,lr} ;restore m and istep(Z)
    ADD    R3,R3,R5    ;(X(i+1,1))
    ADD    R9,R9,lr    ;(Z(i+1,1))
    SUBS   R0,R0,#1
    BGT    wa1         ;loop over i=1,m
    LDMDB  fp,{R4-R9,fp,sp,pc} ;return
    END
;
    TTL    DMMLT
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
F2  FN     2
F1  FN     1
F0  FN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT dmmlt_;(M,N,K,X11,X12,X21,Y11,Y12,Y21,Z11,Z12,Z21,T)  Z = XY
    DCB    "dmmlt_",0,0,8,0,0,255
dmmlt_
    MOV    ip,sp
    STMDB  sp!,{R0-R9,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R0,[R0]     ;m
    LDR    R1,[R1]     ;n
    LDR    R2,[R2]     ;k
    CMP    R0,#0       ;check m>0
    CMPGT  R1,#0       ;check n>0
    CMPGT  R2,#0       ;check k>0
    LDMLEDB fp,{R4-R9,fp,sp,pc} ;return if not
    LDMIB  fp,{R4-R9,ip,lr} ;arg addresses except T
    SUB    R4,R4,R3    ;X(i,j) :jstep
    SUB    R5,R5,R3    ;X(i,j) :istep
    SUB    R7,R7,R6    ;Y(j,l) :lstep
    SUB    R8,R8,R6    ;Y(j,l) :jstep
    SUB    ip,ip,R9    ;Z(i,l) :lstep
    SUB    lr,lr,R9    ;Z(i,l) :istep
    CMP    R3,R9
    BEQ    wxz         ;(Z) = (X)
    CMP    R6,R9
    BEQ    wyz         ;(Z) = (Y)
    CMP    R3,R6
    CMPEQ  R0,R2       ;check that Y = X'
    CMPEQ  R5,R7
    CMPEQ  R4,R8
    BEQ    wxy         ;Y = X' not overlapping Z
;        standard multiplication: Z = XY
wa3 STMFD  sp!,{R0,lr} ;save m and istep(Z)
    MOV    R0,R2       ;l-count
    MLA    R6,R7,R2,R6
    MLA    R9,ip,R2,R9
wb3 MOV    lr,R1       ;j-count
    SUB    R6,R6,R7
    SUB    R9,R9,ip
    MLA    R3,R4,R1,R3
    MLA    R6,R8,R1,R6
    MVFE   F0,#0       ;initialise to zero
wc3 SUB    R3,R3,R4
    SUB    R6,R6,R8
    LDFD   F1,[R3]     ;get X(i,j)
    LDFD   F2,[R6]     ;get Y(j,l)
    MUFE   F1,F1,F2
    ADFE   F0,F0,F1
    SUBS   lr,lr,#1
    BGT    wc3         ;loop over j
    STFD   F0,[R9]     ;store Z(i,l)
    SUBS   R0,R0,#1
    BGT    wb3         ;loop over l
    LDMFD  sp!,{R0,lr} ;restore m and istep(Z)
    ADD    R3,R3,R5
    ADD    R9,R9,lr
    SUBS   R0,R0,#1
    BGT    wa3         ;loop over i
    LDMDB  fp,{R4-R9,fp,sp,pc} ;return
;      here we have Y = X' not overlapping Z
wxy MOV    R2,#1       ;initialise i
    STMFD  sp!,{R0,lr} ;save m and istep(Z)
wd3; MOV    R0,R0       ;initialise l to m
    MLA    R6,R5,R0,R6 ;(Y(1,m+1))
    MLA    R9,ip,R0,R9 ;(Z(i,m+1))
we3 MOV    lr,R1      ;initialise j to n
    SUB    R6,R6,R5    ;(Y(1,l))
    SUB    R9,R9,ip    ;(Z(i,l))
    MLA    R3,R4,R1,R3 ;(X(i,n+1))
    MLA    R6,R4,R1,R6 ;(Y(n+1,l))
    MVFE   F0,#0       ;initialise to zero
wg3 SUB    R3,R3,R4    ;(X(i,j))
    SUB    R6,R6,R4    ;(Y(j,l))
    LDFD   F1,[R3]     ;get X(i,j)
    LDFD   F2,[R6]     ;get Y(j,l)
    MUFE   F1,F1,F2
    ADFE   F0,F0,F1    ;sum their products
    SUBS   lr,lr,#1
    BGT    wg3         ;loop over j=n,1,-1
    STFD   F0,[R9]     ;store Z(i,l)
    SUBS   R0,R0,#1
    CMP    R0,R2
    BGE    we3         ;loop over l=m,i,-1
    MOV    R7,R9       ;(Z(i,i))
    LDR    lr,[sp,#4]  ;restore istep(Z)
wh3 SUBS   R0,R0,#1
    SUBGE  R6,R6,R5    ;(Y(1,l))
    LDRGE  R8,[R7,-lr]!;copy Z(l,i)
    STRGE  R8,[R9,-ip]!;to Z(i,l)
    LDRGE  R8,[R7,#4]  ;copy Z'(l,i)
    STRGE  R8,[R9,#4]  ;to Z'(i,l)
    BGT    wh3         ;loop over l=i-1,1,-1
    LDR    R0,[sp]     ;restore m
    ADD    R3,R3,R5    ;(X(i+1,1))
    ADD    R9,R9,lr    ;(Z(i+1,1))
    ADD    R2,R2,#1
    CMP    R2,R0
    BLE    wd3         ;loop over i=1,m
    LDMDB  fp,{R4-R9,fp,sp,pc} ;return
;
wxz; (X) = (Z), check if Y = X'
    CMP    R3,R6
    BEQ    xyz         ;X = Y'
wi3 STMFD  sp!,{R0,R5}
    LDR    R0,[fp,#36] ;address of T
    MOV    ip,R2       ;initialise l to k
    MLA    R6,R7,R2,R6 ;(Y(1,k+1))
wj3 MOV    R5,R1       ;initialise j to n
    SUB    R6,R6,R7    ;(Y(1,l))
    MLA    R3,R4,R1,R3 ;(X(i,n+1))
    MLA    R6,R8,R1,R6 ;(Y(n+1,l))
    MVFE   F0,#0       ;initialise answer
wk3 SUB    R3,R3,R4    ;(X(i,j))
    SUB    R6,R6,R8    ;(Y(j,l))
    LDFD   F1,[R3]     ;get X(i,j)
    LDFD   F2,[R6]     ;get Y(j,l)
    MUFE   F1,F1,F2
    ADFE   F0,F0,F1    ;sum their products
    SUBS   R5,R5,#1
    BGT    wk3         ;loop over j=n,1,-1
    STFD   F0,[R0],#8  ;store answer in T
    SUBS   ip,ip,#1
    BGT    wj3         ;loop over l=k,1,-1
    MOV    R9,R3       ;(Z(i,1))
    MOV    ip,R2       ;initialise l count
wl3 LDR    lr,[R0,#-4]!;get T'(l)
    STR    lr,[R9,#4]  ;store in Z'(i,l)
    LDR    lr,[R0,#-4]!;get T(l)
    STR    lr,[R9],R4  ;store in Z(i,l)
    SUBS   ip,ip,#1
    BGT    wl3         ;loop over l=1,k
    LDMFD  sp!,{R0,R5}
    ADD    R3,R3,R5    ;(X(i+1,1)) and (Z(i+1,1))
    SUBS   R0,R0,#1
    BGT    wi3         ;loop over i=1,m
    LDMDB  fp,{R4-R9,fp,sp,pc} ;return
;
wyz; (Y) = (Z) but not (X)
    MOV    R6,R3       ;make Y = X'
    MOV    R7,R5
    MOV    R8,R4
    MOV    R3,R9       ;make X = Z'(= old Y')
    MOV    R4,lr
    MOV    R5,ip
    MOV    R9,R0       ;exchange m and k
    MOV    R0,R2
    MOV    R2,R9
    B      wi3         ;now form Z' = Y'X'
;
xyz;  (Z) = (X = Y')
    LDR    R7,[fp,#36] ;address of T
    MOV    R8,R3       ;(Z(1,i))
    MOV    R2,R0       ;initialise i count to m
wm3 MOV    ip,R2       ;initialise l count to m-i+1
    MLA    R6,R5,R2,R3 ;(Y(1,m+1))
wn3 MOV    lr,R1       ;initialise j to n
    SUB    R6,R6,R5    ;(Y(1,l))
    MLA    R3,R4,R1,R3 ;(X(i,n+1))
    MLA    R6,R4,R1,R6 ;(Y(n+1,l))
    MVFE   F0,#0       ;initialise answer
wo3 SUB    R3,R3,R4    ;(X(i,j))
    SUB    R6,R6,R4    ;(Y(j,l))
    LDFD   F1,[R3]     ;get X(i,j)
    LDFD   F2,[R6]     ;get Y(j,l)
    MUFE   F1,F1,F2
    ADFE   F0,F0,F1    ;sum their products
    SUBS   lr,lr,#1
    BGT    wo3         ;loop over j=n,1,-1
    STFD   F0,[R7],#8  ;store answer in T
    SUBS   ip,ip,#1
    BGT    wn3         ;loop over l=m,i,-1
    MOV    R9,R3       ;(Z(i,1))
    MOV    R6,R8       ;(Z(1,i))
    MOV    ip,R0       ;initialise l count to m
wp3 CMP    ip,R2
    LDRGT  lr,[R6,#4]  ;move Z'(l,i)
    LDRLE  lr,[R7,#-4]!;or T'(l)
    STR    lr,[R9,#4]  ;to Z'(i,l)
    LDRGT  lr,[R6],R5  ;move Z(l,i)
    LDRLE  lr,[R7,#-4]!;or T(l)
    STR    lr,[R9],R4  ;to Z(i,l)
    SUBS   ip,ip,#1
    BGT    wp3         ;for l=1,m
    ADD    R3,R3,R5    ;(X(i+1,1)), (Z(i+1,1)) & (Y(1,i+1))
    ADD    R8,R8,R4    ;(Z(1,i+1))
    SUBS   R2,R2,#1
    BGT    wm3         ;loop over i=1,m
    LDMDB  fp,{R4-R9,fp,sp,pc} ;return
    END
;
    TTL    DMMNA
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
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
F2  FN     2
F1  FN     1
F0  FN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT dmmna_;(M,N,X11,X12,X21,Y1,Y2,Z1,Z2)  Zi = - XijYj + Zi
    DCB    "dmmna_",0,0,8,0,0,255
dmmna_
    MOV    ip,sp
    STMDB  sp!,{R0-R8,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDMIB  fp,{R4-R8}  ;arg addresses
    LDR    R0,[R0]     ;m
    LDR    R1,[R1]     ;n
    SUB    R3,R3,R2    ; Xj step
    SUB    R4,R2,R4
    MLA    R4,R3,R1,R4 ;-Xi step
    SUB    R6,R6,R5    ; Yj step
    SUB    R8,R8,R7    ; Zi step
    CMP    R0,#1
wa4 MOV    ip,R1       ;j count
    MOV    lr,R5       ;(Y1)
    LDFGED F0,[R7]     ;Zi
wb4 SUBGES ip,ip,#1
    LDFGED F1,[lr]     ;Yj
    ADDGE  lr,lr,R6
    LDFGED F2,[R2]     ;Xij
    ADDGE  R2,R2,R3
    MUFGEE F1,F1,F2
    SUFGEE F0,F0,F1
    BGT    wb4         ;loop over j
    STFEQD F0,[R7]     ;store Zi
    ADD    R7,R7,R8
    SUB    R2,R2,R4
    SUBEQS R0,R0,#1
    BGT    wa4         ;loop over i
    LDMDB  fp,{R4-R8,fp,sp,pc} ;return
    END
;
    TTL    DMMNS
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
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
F2  FN     2
F1  FN     1
F0  FN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT dmmns_;(M,N,X11,X12,X21,Y1,Y2,Z1,Z2)  Zi = - XijYj - Zi
    DCB    "dmmns_",0,0,8,0,0,255
dmmns_
    MOV    ip,sp
    STMDB  sp!,{R0-R8,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDMIB  fp,{R4-R8}  ;arg addresses
    LDR    R0,[R0]     ;m
    LDR    R1,[R1]     ;n
    SUB    R3,R3,R2    ; Xj step
    SUB    R4,R2,R4
    MLA    R4,R3,R1,R4 ;-Xi step
    SUB    R6,R6,R5    ; Yj step
    SUB    R8,R8,R7    ; Zi step
    CMP    R0,#1
wa5 MOV    ip,R1       ;j count
    MOV    lr,R5       ;(Y1)
    LDFGED F0,[R7]     ;Zi
    MNFGEE F0,F0       ;-Zi
wb5 SUBGES ip,ip,#1
    LDFGED F1,[lr]     ;Yj
    ADDGE  lr,lr,R6
    LDFGED F2,[R2]     ;Xij
    ADDGE  R2,R2,R3
    MUFGEE F1,F1,F2
    SUFGEE F0,F0,F1
    BGT    wb5         ;loop over j
    STFEQD F0,[R7]     ;store Zi
    ADD    R7,R7,R8
    SUB    R2,R2,R4
    SUBEQS R0,R0,#1
    BGT    wa5         ;loop over i
    LDMDB  fp,{R4-R8,fp,sp,pc} ;return
    END
;
    TTL    DMMPA
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
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
F2  FN     2
F1  FN     1
F0  FN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT dmmpa_;(M,N,X11,X12,X21,Y1,Y2,Z1,Z2)  Zi = + XijYj + Zi
    DCB    "dmmpa_",0,0,8,0,0,255
dmmpa_
    MOV    ip,sp
    STMDB  sp!,{R0-R8,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDMIB  fp,{R4-R8}  ;arg addresses
    LDR    R0,[R0]     ;m
    LDR    R1,[R1]     ;n
    SUB    R3,R3,R2    ; Xj step
    SUB    R4,R2,R4
    MLA    R4,R3,R1,R4 ;-Xi step
    SUB    R6,R6,R5    ; Yj step
    SUB    R8,R8,R7    ; Zi step
    CMP    R0,#1
wa6 MOV    ip,R1       ;j count
    MOV    lr,R5       ;(Y1)
    LDFGED F0,[R7]     ;Zi
wb6 SUBGES ip,ip,#1
    LDFGED F1,[lr]     ;Yj
    ADDGE  lr,lr,R6
    LDFGED F2,[R2]     ;Xij
    ADDGE  R2,R2,R3
    MUFGEE F1,F1,F2
    ADFGEE F0,F0,F1
    BGT    wb6         ;loop over j
    STFEQD F0,[R7]     ;store Zi
    ADD    R7,R7,R8
    SUB    R2,R2,R4
    SUBEQS R0,R0,#1
    BGT    wa6         ;loop over i
    LDMDB  fp,{R4-R8,fp,sp,pc} ;return
    END
;
    TTL    DMMPS
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
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
F2  FN     2
F1  FN     1
F0  FN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT dmmps_;(M,N,X11,X12,X21,Y1,Y2,Z1,Z2)  Zi = + XijYj - Zi
    DCB    "dmmps_",0,0,8,0,0,255
dmmps_
    MOV    ip,sp
    STMDB  sp!,{R0-R8,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDMIB  fp,{R4-R8}  ;arg addresses
    LDR    R0,[R0]     ;m
    LDR    R1,[R1]     ;n
    SUB    R3,R3,R2    ; Xj step
    SUB    R4,R2,R4
    MLA    R4,R3,R1,R4 ;-Xi step
    SUB    R6,R6,R5    ; Yj step
    SUB    R8,R8,R7    ; Zi step
    CMP    R0,#1
wa7 MOV    ip,R1       ;j count
    MOV    lr,R5       ;(Y1)
    LDFGED F0,[R7]     ;Zi
    MNFGEE F0,F0       ;-Zi
wb7 SUBGES ip,ip,#1
    LDFGED F1,[lr]     ;Yj
    ADDGE  lr,lr,R6
    LDFGED F2,[R2]     ;Xij
    ADDGE  R2,R2,R3
    MUFGEE F1,F1,F2
    ADFGEE F0,F0,F1
    BGT    wb7         ;loop over j
    STFEQD F0,[R7]     ;store Zi
    ADD    R7,R7,R8
    SUB    R2,R2,R4
    SUBEQS R0,R0,#1
    BGT    wa7         ;loop over i
    LDMDB  fp,{R4-R8,fp,sp,pc} ;return
    END
;
    TTL    DMMPY
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
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
F2  FN     2
F1  FN     1
F0  FN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT dmmpy_;(M,N,X11,X12,X21,Y1,Y2,Z1,Z2)  Zi = + XijYj
    DCB    "dmmpy_",0,0,8,0,0,255
dmmpy_
    MOV    ip,sp
    STMDB  sp!,{R0-R8,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDMIB  fp,{R4-R8}  ;arg addresses
    LDR    R0,[R0]     ;m
    LDR    R1,[R1]     ;n
    SUB    R3,R3,R2    ; Xj step
    SUB    R4,R2,R4
    MLA    R4,R3,R1,R4 ;-Xi step
    SUB    R6,R6,R5    ; Yj step
    SUB    R8,R8,R7    ; Zi step
    CMP    R0,#1
wa8 MOV    ip,R1       ;j count
    MOV    lr,R5       ;(Y1)
    MVFGEE F0,#0       ;init accumulator
wb8 SUBGES ip,ip,#1
    LDFGED F1,[lr]     ;Yj
    ADDGE  lr,lr,R6
    LDFGED F2,[R2]     ;Xij
    ADDGE  R2,R2,R3
    MUFGEE F1,F1,F2
    ADFGEE F0,F0,F1
    BGT    wb8         ;loop over j
    STFEQD F0,[R7]     ;store Zi
    ADD    R7,R7,R8
    SUB    R2,R2,R4
    SUBEQS R0,R0,#1
    BGT    wa8         ;loop over i
    LDMDB  fp,{R4-R8,fp,sp,pc} ;return
    END
;
    TTL    DMNMA
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
F2  FN     2
F1  FN     1
F0  FN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT dmnma_;(M,N,K,X11,X12,X21,Y11,Y12,Y21,Z11,Z12,Z21)  z = -xy + z
    DCB    "dmnma_",0,0,8,0,0,255
dmnma_
    MOV    ip,sp
    STMDB  sp!,{R0-R9,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R0,[R0]     ;m
    LDR    R1,[R1]     ;n
    LDR    R2,[R2]     ;k
    CMP    R0,#0       ;check m>0
    CMPGT  R1,#0       ;check n>0
    CMPGT  R2,#0       ;check k>0
    LDMLEDB fp,{R4-R9,fp,sp,pc} ;return if not
    LDMIB  fp,{R4-R9,ip,lr} ;arg addresses
    SUB    R4,R4,R3    ;X(i,j) :jstep
    SUB    R5,R5,R3    ;X(i,j) :istep
    SUB    R7,R7,R6    ;Y(j,l) :lstep
    SUB    R8,R8,R6    ;Y(j,l) :jstep
    SUB    ip,ip,R9    ;Z(i,l) :lstep
    SUB    lr,lr,R9    ;Z(i,l) :istep
wa1 STMFD  sp!,{R0,lr} ;save m and istep(Z)
    MOV    R0,R2       ;initialise l to k
    MLA    R6,R7,R2,R6 ;(Y(1,k+1))
    MLA    R9,ip,R2,R9 ;(Z(i,k+1))
wb1 MOV    lr,R1       ;initialise j to n
    SUB    R6,R6,R7    ;(Y(1,l))
    SUB    R9,R9,ip    ;(Z(i,l))
    MLA    R3,R4,R1,R3 ;(X(i,n+1))
    MLA    R6,R8,R1,R6 ;(Y(n+1,l))
    LDFD   F0,[R9]     ;initialise from +Z(i,l)
wc1 SUB    R3,R3,R4    ;(X(i,j))
    SUB    R6,R6,R8    ;(Y(j,l))
    LDFD   F1,[R3]     ;get X(i,j)
    LDFD   F2,[R6]     ;get Y(j,l)
    MUFE   F1,F1,F2
    SUFE   F0,F0,F1    ;subtract their products
    SUBS   lr,lr,#1
    BGT    wc1         ;loop over j=n,1,-1
    STFD   F0,[R9]     ;store Z(i,l)
    SUBS   R0,R0,#1
    BGT    wb1         ;loop over l=k,1,-1
    LDMFD  sp!,{R0,lr} ;restore m and istep(Z)
    ADD    R3,R3,R5    ;(X(i+1,1))
    ADD    R9,R9,lr    ;(Z(i+1,1))
    SUBS   R0,R0,#1
    BGT    wa1         ;loop over i=1,m
    LDMDB  fp,{R4-R9,fp,sp,pc} ;return
    END
;
    TTL    DMNMS
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
F2  FN     2
F1  FN     1
F0  FN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT dmnms_;(M,N,K,X11,X12,X21,Y11,Y12,Y21,Z11,Z12,Z21)  z = -xy - z
    DCB    "dmnms_",0,0,8,0,0,255
dmnms_
    MOV    ip,sp
    STMDB  sp!,{R0-R9,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R0,[R0]     ;m
    LDR    R1,[R1]     ;n
    LDR    R2,[R2]     ;k
    CMP    R0,#0       ;check m>0
    CMPGT  R1,#0       ;check n>0
    CMPGT  R2,#0       ;check k>0
    LDMLEDB fp,{R4-R9,fp,sp,pc} ;return if not
    LDMIB  fp,{R4-R9,ip,lr} ;arg addresses
    SUB    R4,R4,R3    ;X(i,j) :jstep
    SUB    R5,R5,R3    ;X(i,j) :istep
    SUB    R7,R7,R6    ;Y(j,l) :lstep
    SUB    R8,R8,R6    ;Y(j,l) :jstep
    SUB    ip,ip,R9    ;Z(i,l) :lstep
    SUB    lr,lr,R9    ;Z(i,l) :istep
wa1 STMFD  sp!,{R0,lr} ;save m and istep(Z)
    MOV    R0,R2       ;initialise l to k
    MLA    R6,R7,R2,R6 ;(Y(1,k+1))
    MLA    R9,ip,R2,R9 ;(Z(i,k+1))
wb1 MOV    lr,R1       ;initialise j to n
    SUB    R6,R6,R7    ;(Y(1,l))
    SUB    R9,R9,ip    ;(Z(i,l))
    MLA    R3,R4,R1,R3 ;(X(i,n+1))
    MLA    R6,R8,R1,R6 ;(Y(n+1,l))
    LDFD   F0,[R9]
    MNFE   F0,F0       ;initialise from -Z(i,l)
wc1 SUB    R3,R3,R4    ;(X(i,j))
    SUB    R6,R6,R8    ;(Y(j,l))
    LDFD   F1,[R3]     ;get X(i,j)
    LDFD   F2,[R6]     ;get Y(j,l)
    MUFE   F1,F1,F2
    SUFE   F0,F0,F1    ;subtract their products
    SUBS   lr,lr,#1
    BGT    wc1         ;loop over j=n,1,-1
    STFD   F0,[R9]     ;store Z(i,l)
    SUBS   R0,R0,#1
    BGT    wb1         ;loop over l=k,1,-1
    LDMFD  sp!,{R0,lr} ;restore m and istep(Z)
    ADD    R3,R3,R5    ;(X(i+1,1))
    ADD    R9,R9,lr    ;(Z(i+1,1))
    SUBS   R0,R0,#1
    BGT    wa1         ;loop over i=1,m
    LDMDB  fp,{R4-R9,fp,sp,pc} ;return
    END
;
    TTL    DMRAN
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R7  RN     7
R6  RN     6
R5  RN     5
R4  RN     4
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
F2  FN     2
F1  FN     1
F0  FN     0
    AREA   RNDMDAT,DATA
    DCD    12345       ;seed
    DCD    69069       ;multplier for random seq
    AREA   |C$$code|,CODE,READONLY
    EXPORT dmran_;(M,N,A,B,Z11,Z12,Z21)  Zij = random in range [A,B]
    DCB    "dmran_",0,0,8,0,0,255
dmran_
    MOV    ip,sp
    STMDB  sp!,{R0-R7,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDMIB  fp,{R4-R6}  ;arg addresses
    LDR    R0,[R0]     ;m
    LDR    R1,[R1]     ;n
    LDFD   F1,[R2]     ;a
    LDFD   F2,[R3]     ;b
    SUFE   F2,F2,F1    ;b-a
    LDFD   F0,norm     ;2**-31
    MUFE   F2,F2,F0
    SUB    R5,R5,R4    ; Zj step
    SUB    R6,R4,R6
    MLA    R6,R5,R1,R6 ;-Zi step
    LDR    R7,aptr
    LDMIA  R7,{R2,R3}  ;seed and multiplier
    CMP    R0,#1
wa9 MOV    ip,R1       ;j count
wb9 SUBGES ip,ip,#1
    MULGE  R2,R3,R2    ;new seed
    MOVGE  lr,R2,LSR#1
    FLTGEE F0,lr
    MUFGEE F0,F0,F2
    ADFGEE F0,F0,F1
    STFGED F0,[R4]     ;store Xij
    ADDGE  R4,R4,R5
    BGT    wb9         ;loop over j
    SUB    R4,R4,R6
    SUBEQS R0,R0,#1
    BGT    wa9         ;loop over i
    STR    R2,[R7]     ;restore seed
    LDMDB  fp,{R4-R7,fp,sp,pc} ;return
norm DCFD  4.65661287307739258E-10;2**-31
aptr DCD    RNDMDAT
    END
;
    TTL    DMSCL
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
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
F1  FN     1
F0  FN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT dmscl_;(M,N,S,X11,X12,X21,Z11,Z12,Z21)  Zij = S * Xij
    DCB    "dmscl_",0,0,8,0,0,255
dmscl_
    MOV    ip,sp
    STMDB  sp!,{R0-R8,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDMIB  fp,{R4-R8}  ;arg addresses
    LDR    R0,[R0]     ;m
    LDR    R1,[R1]     ;n
    LDFD   F0,[R2]     ;s
    SUB    R4,R4,R3    ; Xj step
    SUB    R5,R3,R5
    MLA    R5,R4,R1,R5 ;-Xi step
    SUB    R7,R7,R6    ; Zj step
    SUB    R8,R6,R8
    MLA    R8,R7,R1,R8 ;-Zi step
    CMP    R0,#1
waa MOV    ip,R1       ;j count
wba SUBGES ip,ip,#1
    LDFGED F1,[R3]
    MUFGED F1,F1,F0
    STFGED F1,[R6]
    ADDGE  R3,R3,R4
    ADDGE  R6,R6,R7
    BGT    wba         ;loop over j
    SUB    R3,R3,R5
    SUB    R6,R6,R8
    SUBEQS R0,R0,#1
    BGT    waa         ;loop over i
    LDMDB  fp,{R4-R8,fp,sp,pc} ;return
    END
;
    TTL    DMSET
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
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 dmset_;(M,N,S,Z11,Z12,Z21) z = s
    DCB    "dmset_",0,0,8,0,0,255
dmset_
    MOV    ip,sp
    STMDB  sp!,{R0-R6,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDMIB  fp,{R4-R6}  ;arg addresses
    LDR    R0,[R0]     ;m
    LDR    R1,[R1]     ;n
    LDMIA  R2,{R2,R6}  ;s
    SUB    R4,R4,R3    ; Zj step
    SUB    R5,R3,R5
    MLA    R5,R4,R1,R5 ;-Zi step
    CMP    R0,#1
wab MOV    ip,R1       ;j - count
wbb SUBGES ip,ip,#1
    STRGE  R6,[R3,#4]  ;to Z'ij
    STRGE  R2,[R3],R4  ;to Zij
    BGT    wbb         ;loop over j
    SUB    R3,R3,R5
    SUBEQS R0,R0,#1
    BGT    wab         ;loop over i
    LDMDB  fp,{R4-R6,fp,sp,pc} ;return
    END
;
    TTL    DMSUB
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
F1  FN     1
F0  FN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT dmsub_;(M,N,X11,X12,X21,Y11,Y12,Y21,Z11,Z12,Z21)  z = x - y
    DCB    "dmsub_",0,0,8,0,0,255
dmsub_
    MOV    ip,sp
    STMDB  sp!,{R0-R9,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDMIB  fp,{R4-R9,lr}  ;arg addresses
    LDR    R0,[R0]     ;m
    LDR    R1,[R1]     ;n
    SUB    R3,R3,R2    ; Xj step
    SUB    R4,R2,R4
    MLA    R4,R3,R1,R4 ;-Xi step
    SUB    R6,R6,R5    ; Yj step
    SUB    R7,R5,R7
    MLA    R7,R6,R1,R7 ;-Yi step
    SUB    R9,R9,R8    ; Zj step
    SUB    lr,R8,lr
    MLA    lr,R9,R1,lr;-Zi step
    CMP    R0,#1
wac MOV    ip,R1      ;j - count
wbc SUBGES ip,ip,#1
    LDFGED F0,[R2]     ;Xij
    LDFGED F1,[R5]     ;Yij
    SUFGED F0,F0,F1
    STFGED F0,[R8]     ;Zij = Xij - Yij
    ADDGE  R2,R2,R3
    ADDGE  R5,R5,R6
    ADDGE  R8,R8,R9
    BGT    wbc         ;loop over j
    SUB    R2,R2,R4
    SUB    R5,R5,R7
    SUB    R8,R8,lr
    SUBEQS R0,R0,#1
    BGT    wac         ;loop over i
    LDMDB  fp,{R4-R9,fp,sp,pc} ;return
    END
;
    TTL    DMUTL
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
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 dmutl_;(N,X11,X12,X21) Xjk = Xkj   (j>k)
    DCB    "dmutl_",0,0,8,0,0,255
dmutl_
    MOV    ip,sp
    STMDB  sp!,{R0-R6,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R0,[R0]     ;n
    SUB    R2,R2,R1    ;j step
    SUB    R3,R3,R1    ;k step
    ADD    R5,R2,R3    ;k+j step
    SUBS   R0,R0,#1
wad MOV    R4,R0       ;count
    ADD    R6,R1,R2
    ADD    lr,R1,R3
wbd LDRGT  ip,[R6,#4]  ;X'kj
    STRGT  ip,[lr,#4]  ;to X'jk
    LDRGT  ip,[R6],R2  ;Xkj
    STRGT  ip,[lr],R3  ;to Xjk
    SUBGTS R4,R4,#1
    BGT    wbd         ;loop over j
    ADD    R1,R1,R5
    SUBS   R0,R0,#1
    BGT    wad         ;loop over k
    LDMDB  fp,{R4-R6,fp,sp,pc} ;return
    END
;
    TTL    DOTI
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R2  RN     2
R1  RN     1
R0  RN     0
F2  FN     2
F1  FN     1
F0  FN     0
;
    AREA   |C$$code|,CODE,READONLY
    EXPORT doti_;(A,B) 4-vector dot product
    DCB    "doti_",0,0,0,8,0,0,255
doti_
    MOV    ip,sp
    STMDB  sp!,{R0,R1,fp,ip,lr,pc}
    SUB    fp,ip,#4
    MOV    R2,#4
    MVFE   F0,#0      ;init sum
wx6 LDFS   F1,[R0],#4 ;A(i)
    LDFS   F2,[R1],#4 ;B(i)
    MUFE   F1,F2,F1
    SUBS   R2,R2,#1
    ADFGTE F0,F0,F1   ;sum(Ai*Bi)
    SUFEQE F0,F0,F1   ;subtract(A4*B4)
    BGT    wx6
    LDMDB  fp,{fp,sp,pc}  ;return
    END
;
    TTL   DPLNML
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
F0  FN     0
F1  FN     1
F2  FN     2
R0  RN     0
R1  RN     1
R2  RN     2
R3  RN     3
    AREA   |C$$code|,CODE,READONLY
    EXPORT dplnml_ ;(X,N,C,MODE) make polynomial sum
;
    DCB    "dplnml_",0,8,0,0,255
dplnml_
    MOV    ip,sp
    STMDB  sp!,{R0-R3,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDFD   F1,[R0]       ;X
    LDR    R1,[R1]       ;N
    LDR    R3,[R3]       ;mode
    CMP    R3,#0
    MOVLT  R3,#8         ;step size
    MOVGE  R3,#-8
    ADDGE  R2,R2,R1,LSL#3;pointer to relevant end of array (0 or N)
    MVFE   F0,#0         ;accumulator
wlp LDFD   F2,[R2]       ;get coefficient
    MUFE   F0,F0,F1      ;multiply sum by X
    ADD    R2,R2,R3
    SUBS   R1,R1,#1
    ADFE   F0,F0,F2      ;add coefficient
    BGE    wlp           ;loop N+1 times
    LDMDB  fp,{fp,sp,pc} ;return
    END
;
    TTL   DRKSTP
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
F1  FN    1
F2  FN    2
F3  FN    3
F6  FN    6
F7  FN    7
    AREA   |C$$code|,CODE,READONLY
    EXPORT drkstp_;(N,H,X,Y,SUB,W) differential equations (Runge-Kutta)
    DCB    "drkstp_",0,8,0,0,255
drkstp_
    MOV    ip,sp
    STMDB  sp!,{R0-R7,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R6,[R0]      ;N
    CMP    R6,#1
    LDMLTDB fp,{R4-R7,fp,sp,pc} ;return if N<1
    STFE   F6,[sp,#-12]!;save floating registers
    STFE   F7,[sp,#-12]!
    SUB    sp,sp,#lsk   ;space for variables
    LDMIA  ip,{R4,R5}   ;(SUB),(W)
    LDFD   F7,[R1]      ;H
    LDFD   F0,[R2]      ;X
    MUFD   F6,F7,#0.5   ;H2 = H/2
    ADFD   F1,F0,F7
    ADFD   F2,F0,F6
    STFD   F1,xh        ;XH = X+H
    STFD   F2,xh2       ;XH2= X+H/2
    MOV    R0,R2
    MOV    R1,R3
    MOV    R2,R5
    BL     sub          ;CALL SUB(X,Y,W(1,1))
    MOV    lr,R6        ;loop count
    LDR    R0,[fp,#-32] ;(Y(1))
    MOV    R1,R5        ;(W(1,1))
    ADD    R2,R5,R6,LSL#3;(W(1,2))
lp1 LDFD   F0,[R1],#8   ;W(J,1)
    LDFD   F1,[R0],#8   ;Y(J)
    MUFD   F0,F0,F6
    ADFD   F0,F0,F1
    STFD   F0,[R2],#8   ;W(J,2) = Y(J) + H2*W(J,1)
    SUBS   lr,lr,#1
    BGT    lp1          ;loop over J
    MOV    R7,#2        ;do next bit twice
lp2 ADR    R0,xh2
    ADD    R1,R5,R6,LSL#3
    ADD    R2,R1,R6,LSL#3
    BL     sub          ;CALL SUB(XH2,W(1,2),W(1,3))
    LDR    R0,[fp,#-32] ;(Y(1))
    MOV    R1,R5        ;(W(1,1))
    ADD    R2,R5,R6,LSL#3;(W(1,2))
    ADD    R3,R2,R6,LSL#3;(W(1,3))
    MOV    lr,R6        ;loop count
lp3 LDFD   F0,[R3],#8   ;W(J,3)
    LDFD   F2,[R1]      ;W(J,1)
    LDFD   F1,[R0],#8   ;Y(J)
    ADFD   F3,F0,F0     ;2*W(J,3)
    MUFD   F0,F0,F6     ;H2*W(J,3)
    ADFD   F3,F3,F2
    ADFD   F1,F1,F0
    STFD   F3,[R1],#8   ;W(J,1) = W(J,1) + 2*W(J,3)
    STFD   F1,[R2],#8   ;W(J,2) = Y(J) + H2*W(J,3)
    SUBS   lr,lr,#1
    BGT    lp3          ;loop over J
    SUBS   R7,R7,#1
    MVFGTD F6,F7        ;use H rather than H2 for second time
    BGT    lp2
    ADR    R0,xh
    ADD    R1,R5,R6,LSL#3
    ADD    R2,R1,R6,LSL#3
    BL     sub          ;CALL SUB(XH,W(1,2),W(1,3))
    LDFD   F0,sth
    LDR    R0,[fp,#-32] ;(Y(1))
    ADD    R3,R5,R6,LSL#4;(W(1,3))
    MOV    lr,R6        ;loop count
    MUFD   F6,F0,F7     ;H6=H/6
lp4 LDFD   F1,[R5],#8   ;W(J,1)
    LDFD   F3,[R3],#8   ;W(J,3)
    LDFD   F0,[R0]      ;Y(J)
    ADFD   F1,F1,F3
    MUFD   F1,F1,F6
    ADFD   F0,F1,F0
    STFD   F0,[R0],#8   ;Y(J) = Y(J) + H6*(W(J,1)+W(J,3))
    SUBS   lr,lr,#1
    BGT    lp4
    LDFD   F0,xh
    LDR    R0,[fp,#-36] ;(X)
    STFD   F0,[R0]      ;X = XH
    LDFE   F7,[sp,#0+lsk];restore floating registers
    LDFE   F6,[sp,#12+lsk]
    LDMDB  fp,{R4-R7,fp,sp,pc} ;return
sth DCFD   0.166666666666666667E0
;
sub MOV   pc,R4        ;CALL SUB
;
    ^      0,sp        ;do not change the order of these, just add to them
xh2 #     8            ;XH2
xh  #     8            ;XH
lsc #     0
;
lsk EQU  lsc-xh2
    END
;
    TTL   DSEQN
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 dseqn_;(N,A,IDIM,IFAIL,K,B) solves X=B/A, A becomes lower triangular
    IMPORT dsfact_
    IMPORT dsfeqn_
    DCB    "dseqn_",0,0,8,0,0,255
dseqn_
    MOV    ip,sp
    STMDB  sp!,{R0-R3,fp,ip,lr,pc}
    SUB    fp,ip,#4
    SUB    sp,sp,#12      ;space for DET & JFAIL
    MOV    ip,sp         ;address for DET
    ADD    lr,ip,#8      ;address for JFAIL
    STMFD  sp!,{ip,lr}
    BL     dsfact_
    ADD    sp,sp,#20     ;restore stack
    LDMFD  sp!,{R0-R3}   ;restore arguments
    LDR    ip,[R3]       ;get IFAIL
    CMP    ip,#0         ;test if OK
    LDMEQIB fp,{R3,ip}   ;address of K in R3
    STREQ  ip,[sp,#-4]!  ;address of B on stack
    BLEQ   dsfeqn_       ;call RSFEQN if OK
    LDMDB  fp,{fp,sp,pc} ;return
    END
;
    TTL   DSFACT
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
F2  FN     2
F3  FN     3
F5  FN     5
F6  FN     6
F7  FN     7
    AREA   |C$$code|,CODE,READONLY
    EXPORT dsfact_;(N,A,IDIM,IFAIL,DET,JFAIL) form lower triangular matrix
    DCB    "dsfact_",0,8,0,0,255
dsfact_
    MOV    ip,sp
    STMDB  sp!,{R0-R9,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R0,[R0]        ;N
    LDR    R2,[R2]        ;IDIM
    CMP    R0,#1
    CMPGE  R2,R0
    MOVLT  R0,#1
    STRLT  R0,[R3]        ;set IFAIL to 1 if N<1 or N>IDIM
    LDMLTDB fp,{R4-R9,fp,sp,pc} ;and return
    STFE   F7,[sp,#-12]!
    STFE   F6,[sp,#-12]!
    STFE   F5,[sp,#-12]!
;         initialise variables
    MVFE   F7,#1          ;DET=1
    LDFS   F5,CSMA        ;minimum DET
    LDFS   F6,CBIG        ;maximum DET
    MOV    R3,#0          ;initialise JFAIL
    MOV    R4,#0          ;J="1"
;         main loop over J=1,N
wl1 LDFD   F3,[R1]        ;A(J,J)
    CMF    F3,#0
    BLE    npd            ;not positive definite
    MUFE   F7,F7,F3       ;DET=DET*A(J,J)
    RDFE   F3,F3,#1
    STFD   F3,[R1],#8     ;A(J,J)=1/A(J,J) : (J+1,J)
    ADD    R1,R1,R2,LSL#3 ;(J+1,J+1)
    ABSD   F0,F7
    CMF    F0,F5
    MVFLEE F7,#0          ;too small, set to 0
    CMPLES R3,#0
    MOVEQ  R3,#-1         ;set jfail = -1
    CMF    F0,F6
    MVFGEE F7,#0          ;too big, set to 0
    CMPGES R3,#0
    MOVEQ  R3,#1          ;set jfail = +1
;         now factorise matrix
    ADD    R4,R4,#1       ;virtual increment j
    SUBS   R5,R0,R4       ;L count = N-J
    BLE    finish         ;done when J=N
    MOV    R7,R1          ;(L,J+1) L=J+1
    SUB    R6,R1,#8       ;(J,L) L=J+1
;         loop L = J+1 to N
wl2 SUB    R8,R7,R2,LSL#3 ;(L,I) I=J
    LDFD   F0,[R8]        ;A(L,J)
    MUFE   F0,F0,F3
    STFD   F0,[R6]        ;A(J,L)=A(J,J)*A(L,J)
    LDFD   F0,[R7]        ;-s1=A(L,J+1)
    SUB    R9,R1,#8       ;(I,J+1) I=J
    MOV    ip,R4          ;I count
;         loop over I=J,1,-1
wl3 LDFD   F1,[R8]        ;A(L,I)
    SUB    R8,R8,R2,LSL#3 ;(L,I-1)
    LDFD   F2,[R9],#-8    ;A(I,J+1) : (I-1,J+1)
    MUFE   F1,F1,F2
    SUFE   F0,F0,F1       ;-s1=-s1-A(L,I)*A(I,J+1)
    SUBS   ip,ip,#1
    BGT    wl3            ;loop over I
    STFD   F0,[R7],#8     ;A(L,J+1)=-s1 : (L+1,J+1)
    ADD    R6,R6,R2,LSL#3 ;(J,L+1)
    SUBS   R5,R5,#1
    BGT    wl2            ;loop over L
    B      wl1            ;loop over J
npd MOV    R5,#-1         ;not positive definite, IFAIL=-1
    MOV    R3,#-2         ;JFAIL=-2
finish;         done, so tidy up
    LDR    R7,[sp,#48]    ;address of IFAIL
    LDMIB  fp,{R8,R9}     ;addresses of DET,JFAIL
    STR    R5,[R7]        ;store IFAIL
    STFD   F7,[R8]        ;store DET
    STR    R3,[R9]        ;store JFAIL
    LDFE   F5,[sp],#12
    LDFE   F6,[sp],#12
    LDFE   F7,[sp],#12
    LDMDB  fp,{R4-R9,fp,sp,pc} ;return
CSMA DCFS  1.0E-19
CBIG DCFS  1.0E+19
    END
;
    TTL   DSFEQN
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
F0  FN     0
F1  FN     1
F2  FN     2
F3  FN     3
    AREA   |C$$code|,CODE,READONLY
    EXPORT dsfeqn_;(N,A,IDIM,K,B) solves X=B/A (A is lower triangular)
    DCB    "dsfeqn_",0,8,0,0,255
dsfeqn_
    MOV    ip,sp
    STMDB  sp!,{R0-R8,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    ip,[fp,#4]      ;address of B
    LDR    R0,[R0]         ;N
    LDR    R2,[R2]         ;IDIM
    LDR    R3,[R3]         ;K
    CMP    R2,R0
    SUBGES R0,R0,#1        ;N-1
    CMPGE  R3,#1
    LDMLTDB fp,{R4-R8,fp,sp,pc} ;return if IDIM<N, N<1 or K<1
;         loop over columns of B (L=1,K)
wl4 SUB    R8,ip,#8        ;(I-1,L) I=1
    SUB    R7,R1,R2,LSL#3  ;(I,I-1) I=1
    MOV    R5,R0           ;I count
;         loop over I=1,N
wl5 LDFD   F0,[R8,#8]!     ;-s21=B(I,L) : (I+1,L)
    MOV    R4,R7           ;(I,J) J=I-1
    MOV    R6,R8           ;(J+1,L) J=I-1
    CMP    R4,R1           ;check J>0
;         loop over J=I-1,1,-1
wl6 LDFGED F1,[R4]         ;A(I,J)
    SUBGE  R4,R4,R2,LSL#3  ;(I,J-1)
    LDFGED F2,[R6,#-8]!    ;B(J,L)
    MUFGEE F1,F1,F2
    SUFGEE F0,F0,F1        ;-s21=-s21-A(I,J)*B(J,L)
    CMP    R4,R1
    BGE    wl6             ;loop over J
    ADD    R7,R7,R2,LSL#3  ;(I,I)
    LDFD   F1,[R7],#8      ;A(I,I) : (I+1,I)
    MUFE   F0,F0,F1
    STFD   F0,[R8]         ;B(I,L)=-A(I,I)*s21
    SUBS   R5,R5,#1
    BGE    wl5             ;loop over I
    CMP    R0,#0
    BEQ    wp3             ;skip if N=1
;         loop over I=N-1,1,-1
wl7 LDFD   F0,[R8,#-8]!    ;-s22=B(I,L)
    SUB    R7,R7,#8        ;(I+1,N)
    SUB    R4,R7,#8        ;(I,J) J=N
    ADD    R6,ip,R0,LSL#3  ;(J,L) J=N
;         loop over J=N,I+1,-1
wl8 LDFD   F1,[R4]         ;A(I,J)
    SUB    R4,R4,R2,LSL#3  ;(I,J-1)
    LDFD   F2,[R6],#-8     ;B(J,L) : (J-1,L)
    MUFE   F1,F1,F2
    SUFE   F0,F0,F1        ;-s22=-s22-A(I,J)*B(J,L)
    CMP    R6,R8           ;(J',L) <=> (I,L)
    BGT    wl8             ;loop over J
    STFD   F0,[R8]         ;B(I,L)=-s22
    CMP    R8,ip
    BGT    wl7             ;loop over I
wp3 ADD    ip,ip,R2,LSL#3  ;(1,L+1)
    SUBS   R3,R3,#1
    BGT    wl4             ;loop over L
    LDMDB  fp,{R4-R8,fp,sp,pc} ;return
    END
;
    TTL   DSFINV
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
F0  FN     0
F1  FN     1
F2  FN     2
F3  FN     3
    AREA   |C$$code|,CODE,READONLY
    EXPORT dsfinv_;(N,A,IDIM) solves A = 1/A (A originally lower triangular)
    DCB    "dsfinv_",0,8,0,0,255
dsfinv_
    MOV    ip,sp
    STMDB  sp!,{R0-R2,R4-R7,fp,ip,lr,pc}
    SUB    fp,ip,#4
;         initialise variables
    LDR    R0,[R0]        ;N
    LDR    R2,[R2]        ;IDIM
    CMP    R2,R0
;         check for trivial case: N=1
    SUBGES R0,R0,#1       ;N-1
    LDMLEDB fp,{R4-R7,fp,sp,pc} ;return
    MOV    ip,#1          ;J-1 , J=2
    MOV    R4,R1          ;(J-1,J-1), J=2
;         loop over J = 2,N
wla ADD    R5,R4,#8       ;(J,J-1)
    ADD    R4,R5,R2,LSL#3 ;(J,J)
    LDFD   F3,[R4]        ;A(J,J)
    ADD    R6,R1,ip,LSL#3 ;(J,K) K=1
    SUB    R7,R4,ip,LSL#3 ;(K,J) K=1
;         loop over K=1,J-1
wlb LDFD   F0,[R7]        ;s31=A(K,J)
    SUB    lr,R7,R2,LSL#3 ;(K,I+1) I=J-2
    SUB    R3,R4,#8       ;(I+1,J) I=J-2
    CMP    R3,R7          ;check (I+1,J) > (K,J)
;         loop over I=J-2,K,-1
wlc LDFGTD F1,[R3],#-8    ;A(I+1,J) : (I,J)
    LDFGTD F2,[lr]        ;A(K,I+1)
    SUBGT  lr,lr,R2,LSL#3 ;(K,I)
    MUFGTE F1,F1,F2
    ADFGTE F0,F0,F1       ;s31=s31+A(K,I+1)*A(I+1,J)
    CMP    R3,R7          ;(I',J) <=> (K,J)
    BGT    wlc            ;loop over I
    MNFE   F0,F0          ;-s31
    STFD   F0,[R7],#8     ;A(K,J)=-s31 : (K+1,J)
    MUFE   F0,F0,F3
    STFD   F0,[R6]        ;A(J,K)=-s31*A(J,J)
    ADD    R6,R6,R2,LSL#3 ;(J,K+1)
    CMP    R6,R5          ;(J,K') <=> (J,J-1)
    BLE    wlb            ;loop over K
    ADD    ip,ip,#1       ;increment "J-1"
    CMP    ip,R0          ;compare with N-1
    BLE    wla            ;loop over "J-1"
;
    MOV    R4,R1          ;(J,J) J=1
    MOV    ip,#1          ;initialise J
;         loop over J = 1,N-1
wld ADD    R5,R4,R2,LSL#3 ;(J,I) I=J+1
    LDFD   F0,[R4]        ;s33=A(J,J)
    ADD    R6,R4,#8       ;(I,J) I=J+1
    SUB    R7,R0,ip       ;I count (=N-J)
;         loop over I = J+1,N
wle LDFD   F1,[R5]        ;A(J,I)
    ADD    R5,R5,R2,LSL#3 ;(J,I+1)
    LDFD   F2,[R6],#8     ;A(I,J) : (I+1,J)
    MUFE   F1,F1,F2
    ADFE   F0,F0,F1       ;s33=s33+A(J,I)*A(I,J)
    SUBS   R7,R7,#1
    BGE    wle            ;loop over I
    STFD   F0,[R4],#8     ;A(J,J)=s33 : (J+1,J)
    ADD    R4,R4,R2,LSL#3 ;(J+1,J+1)
    SUB    R5,R4,ip,LSL#3 ;(K,J+1) K=1
    ADD    R6,R1,ip,LSL#3 ;(J+1,K) K=1
;         loop over K=1,J
wlf MVFE   F0,#0          ;s32=0
    MOV    lr,R5          ;(K,I) I=J+1
    MOV    R3,R4          ;(I,J+1) I=J+1
    SUB    R7,R0,ip       ;I count (=N-J)
;         loop over I=J+1,N
wlg LDFD   F1,[lr]        ;A(K,I)
    ADD    lr,lr,R2,LSL#3 ;(K,I+1)
    LDFD   F2,[R3],#8     ;A(I,J+1) : (I+1,J+1)
    MUFE   F1,F1,F2
    ADFE   F0,F0,F1       ;s32=s32+A(K,I)*A(I,J+1)
    SUBS   R7,R7,#1
    BGE    wlg
    STFD   F0,[R5],#8     ;A(K,J+1)=s32 : (K+1,J+1)
    STFD   F0,[R6]        ;A(J+1,K)=s32
    ADD    R6,R6,R2,LSL#3 ;(J+1,K+1)
    CMP    R5,R4          ;(K',J+1) <=> (J+1,J+1)
    BLT    wlf            ;loop over K
    ADD    ip,ip,#1
    CMP    ip,R0
    BLE    wld            ;loop over J
    LDMDB  fp,{R4-R7,fp,sp,pc} ;return
    END
;
    TTL   DSINV
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 dsinv_;(N,A,IDIM,IFAIL) finds A=1/A (symmetric)
    IMPORT dsfact_
    IMPORT dsfinv_
    DCB    "dsinv_",0,0,8,0,0,255
dsinv_
    MOV    ip,sp
    STMDB  sp!,{R0-R3,fp,ip,lr,pc}
    SUB    fp,ip,#4
    SUBS   sp,sp,#12      ;space for DET and JFAIL
    MOV    ip,sp         ;address for DET
    ADD    lr,ip,#8      ;address for JFAIL
    STMFD  sp!,{ip,lr}
    BL     dsfact_
    ADD    sp,sp,#20     ;restore stack
    LDMFD  sp!,{R0-R3}
    LDR    ip,[R3]
    CMP    ip,#0         ;test IFAIL
    BLEQ   dsfinv_       ;call RSFINV if OK
    LDMDB  fp,{fp,sp,pc} ;return
    END
;
    TTL    DUMNA
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
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
F2  FN     2
F1  FN     1
F0  FN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT dumna_;(N,U11,U12,U22,Y1,Y2,Z1,Z2)    Zj =  Zj - sum(Ujk * Yk) k=j,n
    DCB    "dumna_",0,0,8,0,0,255
dumna_
    MOV    ip,sp
    STMDB  sp!,{R0-R8,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDMIB  fp,{R4-R7}  ;arg addresses
    LDR    R0,[R0]     ;n
    SUB    R2,R2,R1    ; Uk step
    SUB    R3,R3,R1    ; Ujj step
    SUB    R5,R5,R4    ; Yk step
    SUB    R7,R7,R6    ; Zj step
waf ADDS   R8,R0,#0    ;k-count
    LDFGTD F0,[R6]     ;initialise Zj
    MOV    ip,R1       ;(j,k) = (j,j)
    MOV    lr,R4       ;(k)
wbf LDFGTD F1,[ip]     ;Ujk
    LDFGTD F2,[lr]     ;Yk
    MUFGTE F1,F1,F2
    SUFGTE F0,F0,F1    ;-sum
    ADD    ip,ip,R2
    ADD    lr,lr,R5
    SUBS   R8,R8,#1
    BGT    wbf         ;loop over k
    STFGED F0,[R6]     ;store Zj
    ADD    R6,R6,R7
    ADD    R1,R1,R3
    ADD    R4,R4,R5
    SUBS   R0,R0,#1
    BGT    waf         ;loop over j
    LDMDB  fp,{R4-R8,fp,sp,pc} ;return
    END
;
    TTL    DUMNS
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
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
F2  FN     2
F1  FN     1
F0  FN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT dumns_;(N,U11,U12,U22,Y1,Y2,Z1,Z2)    Zj = -Zj - sum(Ujk * Yk) k=j,n
    DCB    "dumns_",0,0,8,0,0,255
dumns_
    MOV    ip,sp
    STMDB  sp!,{R0-R8,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDMIB  fp,{R4-R7}  ;arg addresses
    LDR    R0,[R0]     ;n
    SUB    R2,R2,R1    ; Uk step
    SUB    R3,R3,R1    ; Ujj step
    SUB    R5,R5,R4    ; Yk step
    SUB    R7,R7,R6    ; Zj step
wag ADDS   R8,R0,#0    ;k-count
    LDFGTD F0,[R6]
    MNFGTE F0,F0       ;initialise Zj
    MOV    ip,R1       ;(j,k)
    MOV    lr,R4       ;(k)
wbg LDFGTD F1,[ip]     ;Ujk
    LDFGTD F2,[lr]     ;Yk
    MUFGTE F1,F1,F2
    SUFGTE F0,F0,F1    ;-sum
    ADD    ip,ip,R2
    ADD    lr,lr,R5
    SUBS   R8,R8,#1
    BGT    wbg         ;loop over k
    STFGED F0,[R6]     ;store Zj
    ADD    R6,R6,R7
    ADD    R1,R1,R3
    ADD    R4,R4,R5
    SUBS   R0,R0,#1
    BGT    wag         ;loop over j
    LDMDB  fp,{R4-R8,fp,sp,pc} ;return
    END
;
    TTL    DUMPA
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
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
F2  FN     2
F1  FN     1
F0  FN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT dumpa_;(N,U11,U12,U22,Y1,Y2,Z1,Z2)    Zj =  Zj + sum(Ujk * Yk) k=j,n
    DCB    "dumpa_",0,0,8,0,0,255
dumpa_
    MOV    ip,sp
    STMDB  sp!,{R0-R8,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDMIB  fp,{R4-R7}  ;arg addresses
    LDR    R0,[R0]     ;n
    SUB    R2,R2,R1    ; Uk step
    SUB    R3,R3,R1    ; Ujj step
    SUB    R5,R5,R4    ; Yk step
    SUB    R7,R7,R6    ; Zj step
wah ADDS   R8,R0,#0    ;k-count
    LDFGTD F0,[R6]     ;initialise Zj
    MOV    ip,R1       ;(j,k)
    MOV    lr,R4       ;(k)
wbh LDFGTD F1,[ip]     ;Ujk
    LDFGTD F2,[lr]     ;Yk
    MUFGTE F1,F1,F2
    ADFGTE F0,F0,F1    ;sum
    ADD    ip,ip,R2
    ADD    lr,lr,R5
    SUBS   R8,R8,#1
    BGT    wbh         ;loop over k
    STFGED F0,[R6]     ;store Zj
    ADD    R6,R6,R7
    ADD    R1,R1,R3
    ADD    R4,R4,R5
    SUBS   R0,R0,#1
    BGT    wah         ;loop over j
    LDMDB  fp,{R4-R8,fp,sp,pc} ;return
    END
;
    TTL    DUMPS
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
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
F2  FN     2
F1  FN     1
F0  FN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT dumps_;(N,U11,U12,U22,Y1,Y2,Z1,Z2)   Zj = -Zj + sum(Ujk * Yk) k=j,n
    DCB    "dumps_",0,0,8,0,0,255
dumps_
    MOV    ip,sp
    STMDB  sp!,{R0-R8,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDMIB  fp,{R4-R7}  ;arg addresses
    LDR    R0,[R0]     ;n
    SUB    R2,R2,R1    ; Uk step
    SUB    R3,R3,R1    ; Ujj step
    SUB    R5,R5,R4    ; Yk step
    SUB    R7,R7,R6    ; Zj step
wai ADDS   R8,R0,#0    ;k-count
    LDFGTD F0,[R6]
    MNFGTE F0,F0       ;initialise Zj
    MOV    ip,R1       ;(j,k)
    MOV    lr,R4       ;(k)
wbi LDFGTD F1,[ip]     ;Ujk
    LDFGTD F2,[lr]     ;Yk
    MUFGTE F1,F1,F2
    ADFGTE F0,F0,F1    ;sum
    ADD    ip,ip,R2
    ADD    lr,lr,R5
    SUBS   R8,R8,#1
    BGT    wbi         ;loop over k
    STFGED F0,[R6]     ;store Zj
    ADD    R6,R6,R7
    ADD    R1,R1,R3
    ADD    R4,R4,R5
    SUBS   R0,R0,#1
    BGT    wai         ;loop over j
    LDMDB  fp,{R4-R8,fp,sp,pc} ;return
    END
;
    TTL    DUMPY
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
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
F2  FN     2
F1  FN     1
F0  FN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT dumpy_;(N,U11,U12,U22,Y1,Y2,Z1,Z2)    Zj = sum(Ujk * Yk) k=j,n
    DCB    "dumpy_",0,0,8,0,0,255
dumpy_
    MOV    ip,sp
    STMDB  sp!,{R0-R8,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDMIB  fp,{R4-R7}  ;arg addresses
    LDR    R0,[R0]     ;n
    SUB    R2,R2,R1    ; Uk step
    SUB    R3,R3,R1    ; Ujj step
    SUB    R5,R5,R4    ; Yk step
    SUB    R7,R7,R6    ; Zj step
waj ADDS   R8,R0,#0    ;k-count
    MVFGTE F0,#0       ;initialise Zj
    MOV    ip,R1       ;(j,k)
    MOV    lr,R4       ;(k)
wbj LDFGTD F1,[ip]     ;Ujk
    LDFGTD F2,[lr]     ;Yk
    MUFGTE F1,F1,F2
    ADFGTE F0,F0,F1    ;sum
    ADD    ip,ip,R2
    ADD    lr,lr,R5
    SUBS   R8,R8,#1
    BGT    wbj         ;loop over k
    STFGED F0,[R6]     ;store Zj
    ADD    R6,R6,R7
    ADD    R1,R1,R3
    ADD    R4,R4,R5
    SUBS   R0,R0,#1
    BGT    waj         ;loop over j
    LDMDB  fp,{R4-R8,fp,sp,pc} ;return
    END
;
    TTL    DVADD
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R6  RN     6
R5  RN     5
R4  RN     4
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
F1  FN     1
F0  FN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT dvadd_;(N,X1,X2,Y1,Y2,Z1,Z2) Zi = Xi + Yi, i=1,N
    DCB    "dvadd_",0,0,8,0,0,255
dvadd_
    MOV    ip,sp
    STMDB  sp!,{R0-R6,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDMIB  fp,{R4-R6} ;get addresses of Y2,Z1,Z2
    LDR    R0,[R0]    ;N
    SUB    R2,R2,R1   ;X step
    SUB    R4,R4,R3   ;Y step
    SUB    R6,R6,R5   ;Z step
wl1 SUBS   R0,R0,#1
    LDFGED F0,[R1]
    LDFGED F1,[R3]
    ADFGED F1,F0,F1
    STFGED F1,[R5]
    ADDGT  R1,R1,R2
    ADDGT  R3,R3,R4
    ADDGT  R5,R5,R6
    BGT    wl1
    LDMDB  fp,{R4-R6,fp,sp,pc} ;return
    END
;
    TTL    DVCPY
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT dvcpy_;(N,X1,X2,Z1,Z2) Zi = Xi, i=1,N
    DCB    "dvcpy_",0,0,8,0,0,255
dvcpy_
    MOV    ip,sp
    STMDB  sp!,{R0-R3,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    ip,[ip]    ;address of Z2
    LDR    R0,[R0]    ;n
    SUB    R2,R2,R1   ;x step
    SUB    ip,ip,R3   ;z step
wl1 SUBS   R0,R0,#1
    LDRGE  lr,[R1,#4]
    STRGE  lr,[R3,#4]
    LDRGE  lr,[R1],R2
    STRGE  lr,[R3],ip
    BGT    wl1
    LDMDB  fp,{fp,sp,pc} ;return
    END
;
    TTL    DVDIV
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R7  RN     7
R6  RN     6
R5  RN     5
R4  RN     4
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
F1  FN     1
F0  FN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT dvdiv_;(N,X1,X2,Y1,Y2,Z1,Z2,IFAIL) Zi = Xi/Yi, i=1,N
    DCB    "dvdiv_",0,0,8,0,0,255
dvdiv_
    MOV    ip,sp
    STMDB  sp!,{R0-R7,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDMIB  fp,{R4-R7} ;addresses of Y2 to IFAIL
    LDR    R0,[R0]    ;n
    SUB    R2,R2,R1   ;x step
    SUB    R4,R4,R3   ;y step
    SUB    R6,R6,R5   ;z step
    ADD    lr,R0,#1   ;ifail
    CMP    R0,#0
    BLE    wp1
wl1 LDFD   F0,[R1]
    LDFD   F1,[R3]
    CMF    F1,#0      ;check for divide by 0
    BEQ    wp2
    DVFD   F1,F0,F1
    STFD   F1,[R5]
    ADD    R1,R1,R2
    ADD    R3,R3,R4
    ADD    R5,R5,R6
    SUBS   R0,R0,#1
    BGT    wl1
wp1 MOV    lr,R0
wp2 SUB    lr,lr,R0
    STR    lr,[R7]    ;store ifail
    LDMDB  fp,{R4-R7,fp,sp,pc} ;return
    END
;
    TTL    DVMPY
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
F2  FN     2
F1  FN     1
F0  FN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT dvmpy_;(N,X1,X2,Y1,Y2) => sum(xi*yi) i=1,N
    DCB    "dvmpy_",0,0,8,0,0,255
dvmpy_
    MOV    ip,sp
    STMDB  sp!,{R0-R3,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    ip,[ip]    ;address of Y2
    LDR    R0,[R0]    ;n
    SUB    R2,R2,R1   ;x step
    SUB    ip,ip,R3   ;y step
    MVFE   F0,#0      ;accumulator
wl1 SUBS   R0,R0,#1
    LDFGED F2,[R1]
    LDFGED F1,[R3]
    MUFGEE F1,F2,F1
    ADFGEE F0,F0,F1
    ADDGT  R1,R1,R2
    ADDGT  R3,R3,ip
    BGT    wl1
    LDMDB  fp,{fp,sp,pc} ;return
    END
;
    TTL    DVMPA
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
F2  FN     2
F1  FN     1
F0  FN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT dvmpa_;(N,X1,X2,Y1,Y2,S) => S + sum(Xi,Yi), i=1,N
    DCB    "dvmpa_",0,0,8,0,0,255
dvmpa_
    MOV    ip,sp
    STMDB  sp!,{R0-R3,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    ip,[fp,#8] ;address of S
    LDFD   F0,[ip]    ;S
    LDR    ip,[fp,#4] ;address of Y2
    LDR    R0,[R0]    ;n
    SUB    R2,R2,R1   ;x step
    SUB    ip,ip,R3   ;y step
wl1 SUBS   R0,R0,#1
    LDFGED F2,[R1]
    LDFGED F1,[R3]
    MUFGEE F1,F2,F1
    ADFGEE F0,F0,F1
    ADDGT  R1,R1,R2
    ADDGT  R3,R3,ip
    BGT    wl1
    LDMDB  fp,{fp,sp,pc} ;return
    END
;
    TTL    DVMUL
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R6  RN     6
R5  RN     5
R4  RN     4
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
F1  FN     1
F0  FN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT dvmul_;(N,X1,X2,Y1,Y2,Z1,Z2) Zi = Xi * Yi, i=1,N
    DCB    "dvmul_",0,0,8,0,0,255
dvmul_
    MOV    ip,sp
    STMDB  sp!,{R0-R6,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDMIB  fp,{R4-R6} ;get addresses of Y2,Z1,Z2
    LDR    R0,[R0]    ;N
    SUB    R2,R2,R1   ;X step
    SUB    R4,R4,R3   ;Y step
    SUB    R6,R6,R5   ;Z step
wl1 SUBS   R0,R0,#1
    LDFGED F0,[R1]
    LDFGED F1,[R3]
    MUFGED F1,F0,F1
    STFGED F1,[R5]
    ADDGT  R1,R1,R2
    ADDGT  R3,R3,R4
    ADDGT  R5,R5,R6
    BGT    wl1
    LDMDB  fp,{R4-R6,fp,sp,pc} ;return
    END
;
    TTL    DVMULA
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R6  RN     6
R5  RN     5
R4  RN     4
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
F1  FN     1
F0  FN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT dvmula_;(N,X1,X2,Y1,Y2,Z1,Z2) Zi = Zi + Xi*Yi, i=1,N
    DCB    "dvmula_",0,8,0,0,255
dvmula_
    MOV    ip,sp
    STMDB  sp!,{R0-R6,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDMIB  fp,{R4-R6} ;get addresses of Y2,Z1,Z2
    LDR    R0,[R0]    ;N
    SUB    R2,R2,R1   ;X step
    SUB    R4,R4,R3   ;Y step
    SUB    R6,R6,R5   ;Z step
wl1 SUBS   R0,R0,#1
    LDFGED F0,[R1]
    LDFGED F1,[R3]
    MUFGED F1,F0,F1
    LDFGED F0,[R5]
    ADFGED F1,F0,F1
    STFGED F1,[R5]
    ADDGT  R1,R1,R2
    ADDGT  R3,R3,R4
    ADDGT  R5,R5,R6
    BGT    wl1
    LDMDB  fp,{R4-R6,fp,sp,pc} ;return
    END
;
    TTL    DVMUNA
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R6  RN     6
R5  RN     5
R4  RN     4
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
F1  FN     1
F0  FN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT dvmuna_;(N,X1,X2,Y1,Y2,Z1,Z2) Zi = Zi - Xi*Yi, i=1,N
    DCB    "dvmuna_",0,8,0,0,255
dvmuna_
    MOV    ip,sp
    STMDB  sp!,{R0-R6,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDMIB  fp,{R4-R6} ;get addresses of Y2,Z1,Z2
    LDR    R0,[R0]    ;N
    SUB    R2,R2,R1   ;X step
    SUB    R4,R4,R3   ;Y step
    SUB    R6,R6,R5   ;Z step
wl1 SUBS   R0,R0,#1
    LDFGED F0,[R1]
    LDFGED F1,[R3]
    MUFGED F1,F0,F1
    LDFGED F0,[R5]
    SUFGED F1,F0,F1
    STFGED F1,[R5]
    ADDGT  R1,R1,R2
    ADDGT  R3,R3,R4
    ADDGT  R5,R5,R6
    BGT    wl1
    LDMDB  fp,{R4-R6,fp,sp,pc} ;return
    END
;
    TTL    DVRAN
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R4  RN     4
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
F2  FN     2
F1  FN     1
F0  FN     0
    AREA   seed,DATA
    DCD    12345
    DCD    69069      ;multiplier for random sequencs
    AREA   |C$$code|,CODE,READONLY
    EXPORT dvran_;(N,A,B,Z1,Z2) Zi = random[A to B], i=1,N
    DCB    "dvran_",0,0,8,0,0,255
dvran_
    MOV    ip,sp
    STMDB  sp!,{R0-R4,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    ip,[ip]    ;address of Z2
    LDR    R0,[R0]    ;n
    LDFD   F1,[R1]    ;a
    LDFD   F2,[R2]    ;b
    SUFE   F2,F2,F1   ;b-a
    LDFD   F0,norm    ;2**-31
    MUFE   F2,F2,F0
    SUB    ip,ip,R3   ;z step
    LDR    R4,sptr
    LDMIA  R4,{R1,R2} ;random seed & multiplier
wl7 SUBS   R0,R0,#1
    MULGE  R1,R2,R1   ;new seed
    MOVGE  lr,R1,LSR#1
    FLTGEE F0,lr
    MUFGEE F0,F0,F2
    ADFGEE F0,F0,F1
    STFGED F0,[R3]
    ADDGT  R3,R3,ip
    BGT    wl7
    STR    R1,[R4]    ;restore seed
    LDMDB  fp,{R4,fp,sp,pc} ;return
norm DCFD  4.65661287307739258E-10;2**-31
sptr DCD    seed
    END
;
    TTL    DVSCA
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
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
F2  FN     2
F1  FN     1
F0  FN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT dvsca_;(N,S,X1,X2,Y1,Y2,Z1,Z2) Zi = S*Xi + Yi, i=1,N
    DCB    "dvsca_",0,0,8,0,0,255
dvsca_
    MOV    ip,sp
    STMDB  sp!,{R0-R7,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDMIB  fp,{R4-R7} ;xtra arg addresses
    LDR    R0,[R0]    ;n
    LDFD   F2,[R1]    ;s
    SUB    R3,R3,R2   ;x step
    SUB    R5,R5,R4   ;y step
    SUB    R7,R7,R6   ;z step
wl1 SUBS   R0,R0,#1
    LDFGED F0,[R2]
    LDFGED F1,[R4]
    MUFGED F0,F0,F2
    ADFGED F0,F0,F1
    STFGED F0,[R6]
    ADDGT  R2,R2,R3
    ADDGT  R4,R4,R5
    ADDGT  R6,R6,R7
    BGT    wl1
    LDMDB  fp,{R4-R7,fp,sp,pc} ;return
    END
;
    TTL    DVSCL
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
F2  FN     2
F1  FN     1
F0  FN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT dvscl_;(N,S,X1,X2,Z1,Z2) Zi = S*Xi, i=1,N
    DCB    "dvscl_",0,0,8,0,0,255
dvscl_
    MOV    ip,sp
    STMDB  sp!,{R0-R3,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDFD   F2,[R1]    ;s
    LDMIB  fp,{R1,ip} ;addresses of Z1 & Z2
    LDR    R0,[R0]    ;n
    SUB    R3,R3,R2   ;x step
    SUB    ip,ip,R1   ;z step
wl1 SUBS   R0,R0,#1
    LDFGED F0,[R2]
    MUFGED F0,F0,F2
    STFGED F0,[R1]
    ADDGT  R2,R2,R3
    ADDGT  R1,R1,ip
    BGT    wl1
    LDMDB  fp,{fp,sp,pc} ;return
    END
;
    TTL    DVSCS
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R7  RN     7
R6  RN     6
R5  RN     5
R4  RN     4
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
F2  FN     2
F1  FN     1
F0  FN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT dvscs_;(N,S,X1,X2,Y1,Y2,Z1,Z2) Zi = S*Xi - Yi, i=1,N
    DCB    "dvscs_",0,0,8,0,0,255
dvscs_
    MOV    ip,sp
    STMDB  sp!,{R0-R7,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDMIB  fp,{R4-R7} ;xtra arg addresses
    LDR    R0,[R0]    ;n
    LDFD   F2,[R1]    ;s
    SUB    R3,R3,R2   ;x step
    SUB    R5,R5,R4   ;y step
    SUB    R7,R7,R6   ;z step
wl1 SUBS   R0,R0,#1
    LDFGED F0,[R2]
    LDFGED F1,[R4]
    MUFGED F0,F0,F2
    SUFGED F0,F0,F1
    STFGED F0,[R6]
    ADDGT  R2,R2,R3
    ADDGT  R4,R4,R5
    ADDGT  R6,R6,R7
    BGT    wl1
    LDMDB  fp,{R4-R7,fp,sp,pc} ;return
    END
;
    TTL    DVSET
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT dvset_;(N,S,Z1,Z2) Zi = S, i=1,N
    DCB    "dvset_",0,0,8,0,0,255
dvset_
    MOV    ip,sp
    STMDB  sp!,{R0-R3,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R0,[R0]    ;n
    LDMIA  R1,{ip,lr} ;double word S
    SUB    R3,R3,R2   ;z step
wl1 SUBS   R0,R0,#1
    STMGEIA R2,{ip,lr}
    ADDGE  R2,R2,R3
    BGT    wl1
    LDMDB  fp,{fp,sp,pc} ;return
    END
;
    TTL    DVSUB
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R6  RN     6
R5  RN     5
R4  RN     4
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
F1  FN     1
F0  FN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT dvsub_;(N,X1,X2,Y1,Y2,Z1,Z2) Zi = Xi - Yi, i=1,N
    DCB    "dvsub_",0,0,8,0,0,255
dvsub_
    MOV    ip,sp
    STMDB  sp!,{R0-R6,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDMIB  fp,{R4-R6} ;get addresses of Y2,Z1,Z2
    LDR    R0,[R0]    ;N
    SUB    R2,R2,R1   ;X step
    SUB    R4,R4,R3   ;Y step
    SUB    R6,R6,R5   ;Z step
wl1 SUBS   R0,R0,#1
    LDFGED F0,[R1]
    LDFGED F1,[R3]
    SUFGED F1,F0,F1
    STFGED F1,[R5]
    ADDGT  R1,R1,R2
    ADDGT  R3,R3,R4
    ADDGT  R5,R5,R6
    BGT    wl1
    LDMDB  fp,{R4-R6,fp,sp,pc} ;return
    END
;
    TTL    DVSUM
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R2  RN     2
R1  RN     1
R0  RN     0
F1  FN     1
F0  FN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT dvsum_;(N,X1,X2) => sum(Xi), i=1,N
    DCB    "dvsum_",0,0,8,0,0,255
dvsum_
    MOV    ip,sp
    STMDB  sp!,{R0-R2,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R0,[R0]    ;n
    SUB    R2,R2,R1   ;x step
    MVFE   F0,#0      ;accumulator
wlf SUBS   R0,R0,#1
    LDFGED F1,[R1]
    ADFGEE F0,F1,F0
    ADDGE  R1,R1,R2
    BGT    wlf
    LDMDB  fp,{fp,sp,pc} ;return
    END
;
    TTL    DVXCH
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R8  RN     8
R7  RN     7
R6  RN     6
R5  RN     5
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT dvxch_;(N,X1,X2,Y1,Y2) Xi = Yi while Yi = Xi, i=1,N
    DCB    "dvxch_",0,0,8,0,0,255
dvxch_
    MOV    ip,sp
    STMDB  sp!,{R0-R3,R5-R8,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    ip,[ip]    ;address of Y2
    LDR    R0,[R0]    ;n
    SUB    R2,R2,R1   ;x step
    SUB    ip,ip,R3   ;y step
wl1 SUBS   R0,R0,#1
    LDMGEIA R1,{R5,R6}
    LDMGEIA R3,{R7,R8}
    STMGEIA R3,{R5,R6}
    STMGEIA R1,{R7,R8}
    ADDGE  R1,R1,R2
    ADDGE  R3,R3,ip
    BGT    wl1
    LDMDB  fp,{R5-R8,fp,sp,pc} ;return
    END
;
    TTL   dzero
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
R4  RN     4
R5  RN     5
R6  RN     6
R7  RN     7
R8  RN     8
R9  RN     9
F0  FN     0
F1  FN     1
F2  FN     2
F3  FN     3
F4  FN     4
F5  FN     5
F6  FN     6
F7  FN     7
;
    AREA   |C$$code|,CODE,READONLY
    EXPORT dzero_;(A,B,X0,R,EPS,MXF,F) finds zero of REAL*8 function
    DCB    "dzero_",0,0,8,0,0,255
dzero_
    MOV    ip,sp
    STMDB  sp!,{R0-R9,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDMIB  fp,{R4-R6}   ;addresses of EPS, MXF and F
    STFE   F4,[sp,#-12]!;save F4
    STFE   F5,[sp,#-12]!;save F5
    STFE   F6,[sp,#-12]!;save F6
    STFE   F7,[sp,#-12]!;save F7
    SUB    sp,sp,#lstk  ;work space
    LDFD   F0,[R0]      ;A
    LDFD   F1,[R1]      ;B
    LDR    R5,[R5]      ;MXF
    MOV    R8,R2        ;(X0)
    MOV    R9,R3        ;(R)
    CMF    F0,F1
    STFGTD F1,XA        ;XA = MIN(A,B)
    STFLED F0,XA
    STFGTD F0,XB        ;XB = MAX(A,B)
    STFLED F1,XB
    ADR    R0,XA
    ADR    R1,ONE
    BL     fun
    STFD   F0,VA        ;FA = F(XA,1)
    ADR    R0,XB
    ADR    R1,TWO
    BL     fun
    STFD   F0,VB        ;FB = F(XB,1)
    LDFD   F1,VA
    MUFD   F2,F0,F1
    CMF    F2,#0
    BGT    er1          ;FA & FB have same sign and neither are zero
;
pt1 LDFD   F6,XA        ;X1 = XA
    LDFD   F7,XB        ;X2 = XB
    LDFD   F2,[R4]      ;EPS
    ADFD   F1,F6,F7
    MUFD   F5,F1,#0.5   ;X0 = 0.5*(XA+XB)
    SUFD   F0,F5,F6     ;R = X0 - XA
    ABSD   F3,F5
    ADFD   F3,F3,#1     ;ABS(X0)+1
    MUFD   F4,F3,F2     ;EE = EPS*(ABS(X0)+1)
    CMF    F0,F4
    BLE    pt4          ;all done if R is sufficiently small
    LDMIA  sp,{R0-R3}
    ADR    ip,V1
    STMIA  ip,{R0-R3}   ;F1 = FA, F2 = FB
;
pt2 STFD   F5,[R8]
    MOV    R0,R8
    ADR    R1,TWO
    BL     fun
    LDFD   F1,VA
    STFD   F0,VX        ;FX = F(X0,2)
    MUFD   F1,F1,F0
    SUBS   R5,R5,#1
    BLT    er2          ;too many function calls
    CMF    F1,#0        ;IF(FA*FX.GT.0) THEN
    STFGTD F0,VA        ;  FA = FX
    STFGTD F5,XA        ;  XA = X0
    STFLED F0,VB        ;ELSE
    STFLED F5,XB        ;  FB = FX; XB = X0
;
pt3 SUFD   F2,F6,F7     ;U2 = X1 - X2
    CMF    F2,#0
    SUFNED F4,F7,F5     ;U4 = X2 - X0
    CMFNE  F4,#0
    BEQ    pt1          ;skip if at the end
    LDFD   F0,V2
    LDFD   F1,V1
    LDFD   F3,VX
    SUFD   F1,F1,F0     ;U1 = F1 - F2
    STFD   F3,V3        ;F3 = FX
    SUFD   F3,F0,F3     ;U3 = F2 - FX
    STFD   F5,X3        ;X3 = X0
    DVFD   F1,F1,F2     ;U1 = U1/U2
    DVFD   F2,F3,F4     ;U2 = U3/U4
    SUFD   F0,F1,F2     ;CA = U1 - U2
    ADFD   F3,F6,F7
    ADFD   F4,F5,F7
    MUFD   F1,F1,F4     ;U1*(X0+X2)
    MUFD   F2,F2,F3     ;U2*(X1+X2)
    SUFD   F4,F6,F5     ;(X1-X0)
    SUFD   F1,F2,F1     ;CB = U2*(X1+X2) - U1*(X0+X2)
    MUFD   F3,F6,F0     ;X1*CA
    LDFD   F2,V1
    ADFD   F3,F3,F1     ;X1*CA + CB
    MUFD   F2,F2,F4     ;F1*(X1-X0)
    MUFD   F3,F3,F6     ;X1*(X1*CA + CB)
    CMF    F0,#0
    SUFD   F2,F2,F3     ;CC = F1*(X1-X0) - X1*(X1*CA + CB)
    CMFEQ  F1,#0
    BEQ    pt1
    CMF    F0,#0
    DVFEQD F5,F2,F1
    MVFEQD F5,F5        ;IF CA.EQ.0 X0 = -CC/CB
    BEQ    ptx
    DVFD   F3,F1,F0
    DVFD   F2,F2,F0
    MUFD   F3,F3,#0.5   ;U3 = 0.5*CB/CA
    MUFD   F4,F3,F3
    SUFD   F4,F4,F2     ;U4 = U3*U3 - CC/CA
    CMF    F4,#0
    BLT    pt1          ;imaginary solution
    SQTD   F4,F4
    CNFE   F5,F3
    MNFLTD F4,F4
    SUFD   F5,F4,F3     ;X0 = -U3 +- SQRT(U3**2 -CC/CA)
ptx LDFD   F0,XA
    LDFD   F1,XB
    CMF    F5,F0
    CMFGE  F1,F5
    BLT    pt1          ;skip if X0 < XA or > XB
;
    LDFD   F3,X3
    LDFD   F2,[R4]      ;EPS
    ABSD   F4,F5
    SUFD   F0,F5,F3     ;X0-X3
    SUFD   F1,F5,F7     ;X0-X2
    ADFD   F4,F4,#1     ;ABS(X0)+1
    ABSD   F0,F0
    ABSD   F1,F1
    MUFD   F4,F4,F2     ;EE = EPS*(ABS(X0)+1)
    CMF    F0,F1
    MVFGTD F0,F1        ;R = MIN(ABS(X0-X3), ABS(X0-X2))
    CMF    F0,F4        ;IF(R.GT.EE) THEN
    MVFGTD F6,F7        ;  X1 = X2
    MVFGTD F7,F3        ;  X2 = X3
    ADRGT  ip,V2        ;  (F2)
    LDMGTIA ip,{R0-R3}
    ADRGT  ip,V1        ;  (F1)
    STMGTIA ip,{R0-R3}  ;  F1=F2 & F2=F3
    BGT    pt2          ;take another step
    STFD   F5,[R8]      ;store X0
    MOV    R0,R8
    ADR    R1,TWO
    BL     fun          ;CALL F(X0,2)
    STFD   F0,VX        ;store FX
    LDFD   F1,VA
    CMF    F0,#0
    BEQ    pt4          ;all done with exact answer
    MUFD   F1,F1,F0
    CMF    F1,#0
    BGE    pty          ;IF(FX*FA.LT.0) THEN
    LDFD   F1,XA
    SUFD   F0,F5,F4     ;  XX = X0 - EE
    CMF    F0,F1
    BLE    pt4          ;  all done if XX <= XA
    STFD   F0,XB        ;  XB = XX
    BL     fun2
    STFD   F0,VB        ;  FB = FF = F(XX,2)
    B      ptz          ;ELSE
pty LDFD   F1,XB
    ADFD   F0,F5,F4     ;  XX = X0 + EE
    CMF    F0,F1
    BGE    pt4          ;  all done if XX >= XB
    STFD   F0,XA        ;  XA = XX
    BL     fun2
    STFD   F0,VA        ;  FA = FF = F(XX,2)
ptz LDFD   F1,VX
    MUFD   F2,F0,F1
    CMF    F2,#0
    BLE    pt4          ;zero spanned so done
    SUBS   R5,R5,#2     ;count calls to F
    BLT    er2          ;too many calls
    LDFD   F2,V3
    LDFD   F6,X3        ;X1 = X3
    STFD   F2,V1        ;F1 = F3
    MVFD   F7,F5        ;X2 = X0
    STFD   F1,V2        ;F2 = FX
    LDFD   F5,XX        ;X0 = XX
    STFD   F0,VX        ;FX = FF
    B      pt3          ;do next step
;
pt4 STFD   F4,[R9]      ;store R(=EE)
    STFD   F5,[R8]      ;store X0
    MOV    R0,R8
    ADR    R1,THR
    BL     fun          ;CALL F(X0,3)
fin LDFE   F7,[fp,#-100];restore F7
    LDFE   F6,[fp,#-88] ;restore F6
    LDFE   F5,[fp,#-76] ;restore F5
    LDFE   F4,[fp,#-64] ;restore F4
    LDMDB  fp,{R4-R9,fp,sp,pc} ;return
;
er1 MNFD   F4,#2        ;-2.0
erx LDFD   F0,XA
    LDFD   F1,XB
    SUFD   F0,F0,F1
    ABSD   F0,F0        ;|XA-XB|
    MUFD   F0,F0,F4
    STFD   F0,[R9]      ;store R = -(2 or 0.5)*|XA-XB|
    MOV    R0,#0
    STR    R0,[R8]      ;store X0=0
    B      fin
;
er2 MNFD   F4,#0.5      ;-0.5
    B      erx
;
fun2;   find F(XX,2)
    STFD   F0,XX
    ADR    R0,XX
    ADR    R1,TWO
fun MOV    pc,R6        ;call F
;
ONE DCD    1
TWO DCD    2
THR DCD    3
;
    ^      0,sp         ;do not change the order of these, just add to them
VA    #    8            ;FA
VB    #    8            ;FB
VX    #    8            ;FX
V1    #    8            ;F1
V2    #    8            ;F2
V3    #    8            ;F3
X3    #    8            ;X3
XA    #    8            ;XA
XB    #    8            ;XB
XX    #    8            ;XX
lstc  #    0
;
lstk  EQU  lstc-VA
    END
;
    TTL   ERF
pc  RN  15
lr  RN  14
sp  RN  13
ip  RN  12
fp  RN  11
F0  FN   0
F1  FN   1
F2  FN   2
F3  FN   3
F4  FN   4
R0  RN   0
R1  RN   1
R2  RN   2
R3  RN   3
    AREA   |C$$code|,CODE,READONLY
    EXPORT erf_  ;(RX) => Error function
    EXPORT erfc_ ;(RX) => 1 - Error function
    EXPORT derf_ ;(RX) => Double Precision Error function
    EXPORT derfc_;(RX) => 1 - Double Precision Error function
;
    DCB    "erf_",0,0,0,0,8,0,0,255
erf_
    MOV    ip,sp
    STMDB  sp!,{R0,fp,ip,lr,pc}
    SUB    fp,ip,#4       ;ip<>0
    LDFS   F0,[R0]        ;RX
    B      de1
;
    DCB    "derf_",0,0,0,8,0,0,255
derf_
    MOV    ip,sp
    STMDB  sp!,{R0,fp,ip,lr,pc}
    SUB    fp,ip,#4       ;ip<>0
    LDFD   F0,[R0]        ;RX
de1 ABSD   F1,F0          ;A
    LDFS   F2,xunit
    CMF    F1,F2
    BLE    pt1
    DVFD   F0,F0,F1       ;result indistinguishable from 1
    LDMDB  fp,{fp,sp,pc} 
;
    DCB    "erfc_",0,0,0,8,0,0,255
erfc_
    MOV    ip,sp
    STMDB  sp!,{R0,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDFS   F0,[R0]        ;RX
    B      de2
;
    DCB    "derfc_",0,0,8,0,0,255
derfc_
    MOV    ip,sp
    STMDB  sp!,{R0,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDFD   F0,[R0]        ;RX
de2 MOV    ip,#0          ;flag ERFC with ip=0
    LDFS   F2,xunit
    CNFE   F0,F2
    MVFLTD F0,#2
    LDMLTDB fp,{fp,sp,pc} 
    LDFS   F3,xmax
    CMF    F0,F3
    MVFGTD F0,#0
    LDMGTDB fp,{fp,sp,pc} 
    ABSD   F1,F0
;
pt1 MUFD   F2,F0,F0        ;RX**2
    LDFS   F3,acut
    CMF    F1,F3
    BGT    pt2             ;use erfc instead
;        calculate erf
    ADR    R1,wp1+24       ;[p1(4)]
    ADR    R2,wq1+16       ;[q1(3)]
    MVFD   F1,F2           ;RX**2
    MOV    R3,#3           ;3 terms in sums
    BL     sums
    MUFD   F0,F3,F0
    CMP    ip,#0
    RSFEQD F0,F0,#1        ;subtract it from 1 for erfc
    LDMDB  fp,{fp,sp,pc} 
;
sums;
    STFE   F4,[sp,#-12]!   ;save F4
    LDFD   F4,[R1],#-8     ;initialise numerator
    MVFD   F3,F1           ;initialise denominator
lp1 LDFD   F2,[R2],#-8
    MUFD   F4,F4,F1
    ADFD   F3,F3,F2
    LDFD   F2,[R1],#-8
    SUBS   R3,R3,#1
    MUFGTD F3,F3,F1
    ADFD   F4,F4,F2
    BGT    lp1
    DVFD   F3,F4,F3
    LDFE   F4,[sp],#12     ;restore F4
    MOV    pc,lr
;
pt2 CMF    F1,#4
    BGT    pt3
    EXPD   F0,F2
    ADR    R1,wp2+56       ;[p2(8)]
    ADR    R2,wq2+48       ;[q2(7)]
    MOV    R3,#7           ;7 terms in sum
    BL     sums
    B      pt4
;
pt3 EXPD   F0,F2
    MUFD   F0,F1,F0        ;|RX|*EXP(RX**2)
    RDFD   F1,F2,#1        ;U=1/RX**2
    ADR    R1,wp3+32       ;[p3(5)]
    ADR    R2,wq3+24       ;[q3(4)]
    MOV    R3,#4           ;4 terms in sum
    BL     sums
    MUFD   F3,F3,F1
    LDFD   F2,const
    ADFD   F3,F3,F2
pt4 DVFD   F0,F3,F0
    LDR    R1,[R0]         ;RX
    CMP    ip,#0
    BEQ    pt5
    RSFD   F0,F0,#1
    CMP    R1,#0
    MNFLTD F0,F0
    LDMDB  fp,{fp,sp,pc} 
pt5 CMP    R1,#0
    RSFLTD F0,F0,#2
    LDMDB  fp,{fp,sp,pc} 
;
acut DCFS  0.46875
;     ( ACUT AND 4.0 ARE CHANGE-OVER POINTS FOR THE RATIONAL APPROXIM-
;     ATIONS. )
const DCFD 0.5641895835477563
;     ( CONST=SQRT(1/PI). )
xmax DCFS  8.9
;     ( XMAX=SQRT(-ALOG(RMIN)-10.0), WHERE RMIN IS THE SMALLEST NORMAL-
;     IZED REPRESENTABLE NUMBER.  ERFC(XMAX) IS CLOSE TO THE UNDERFLOW
;     THRESHOLD. )
xunit DCFS 5.9
;     ( XUNIT=SQRT(-ALOG(RELPR)+1.0), WHERE RELPR IS THE SMALLEST NUMBER
;     FOR WHICH 1.0+RELPR DIFFERS FROM 1.0.  ERF(XUNIT) IS INDISTIN-
;     GUISHABLE FROM 1.0. )
wp1 DCFD   2.426679552305318E+2
    DCFD   2.197926161829415E+1
    DCFD   6.996383488619136
    DCFD  -3.560984370181538E-2
wq1 DCFD   2.150588758698612E+2
    DCFD   9.116490540451490E+1
    DCFD   1.508279763040779E+1
wp2 DCFD   3.004592610201616E+2
    DCFD   4.519189537118729E+2
    DCFD   3.393208167343437E+2
    DCFD   1.529892850469404E+2
    DCFD   4.316222722205674E+1
    DCFD   7.211758250883094
    DCFD   5.641955174789740E-1
    DCFD  -1.368648573827167E-7
wq2 DCFD   3.004592609569833E+2
    DCFD   7.909509253278980E+2
    DCFD   9.313540948506096E+2
    DCFD   6.389802644656312E+2
    DCFD   2.775854447439876E+2
    DCFD   7.700015293522947E+1
    DCFD   1.278272731962942E+1
wp3 DCFD  -2.996107077035422E-3
    DCFD  -4.947309106232507E-2
    DCFD  -2.269565935396869E-1
    DCFD  -2.786613086096478E-1
    DCFD  -2.231924597341847E-2
wq3 DCFD   1.062092305284679E-2
    DCFD   1.913089261078298E-1
    DCFD   1.051675107067932
    DCFD   1.987332018171353
    END
;
    TTL ffread
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
R4  RN   4
R5  RN   5
R6  RN   6
R7  RN   7
R8  RN   8
R9  RN   9
F0  FN   0
F1  FN   1
fixwd EQU 14
fixbt EQU fixwd*4
    AREA   |C$$code|,CODE,READONLY
    IMPORT io_start_re
    IMPORT io_start_we
    IMPORT io_do_single
    IMPORT io_end
    IMPORT __rt_stkovf_split_small
;
    EXPORT ffinit_;(NW) initialise 'ffread' with common length NW words
    DCB    "ffinit_",0,8,0,0,255
ffinit_
    MOV    ip,sp
    STMDB  sp!,{R0,R4-R9,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R0,[R0]      ;NW
    CMP    R0,#fixwd+200
    MOVLT  R0,#fixwd+200;minimum storage of 200 words (=50 entries)
    MOV    R1,#4        ;#characters/key
    MOV    R2,#3        ;#words/key
    MOV    R3,#0        ;#keys defined
    MOV    R4,#fixwd    ;no space in IWORDS used yet
    MOV    R5,#80       ;line length
    MOV    R6,#5        ;default input
    MOV    R7,#6        ;default output
    MOV    R8,#0        ;no input stack
    LDR    R9,cmn
    STMIA  R9,{R0-R8}   ;set up defaults
    LDMDB  fp,{R4-R9,fp,sp,pc} 
;
    EXPORT ffset_;(CHOPT,IVALUE) set optional values for 'ffread'
    DCB    "ffset_",0,0,8,0,0,255
ffset_
    MOV    ip,sp
    STMDB  sp!,{R0-R2,R4-R9,fp,ip,lr,pc}
    SUB    fp,ip,#4
    ADR    R4,vset
    MOV    R5,#4
    BL     find_key4
    LDR    R1,[R1]
    CMP    R0,#1
    LDMLTIA sp,{R0-R2}
    STMLTFD sp!,{R0,R2}
    BLT    bad_keyword
    BGT    st1
    CMP    R1,#72
    RSBGES lr,R1,#132
    STRGE  R1,LINPUT
    LDMGEDB fp,{R4-R9,fp,sp,pc} 
;
wrong_val; illegal value input to FFSET
    LDR    R0,LUNOUT
    ADR    R1,fmtss1
    BL     io_start_we
    LDR    R0,[fp,#-44]
    MOV    R1,#4
    BL     io_do_single
    LDR    R0,[fp,#-48]
    LDR    R1,[fp,#-40]
    BL     io_do_single
    BL     io_end
    LDMDB  fp,{R4-R9,fp,sp,pc} 
;
vset DCB   "LENG","LINP","LOUT","SIZE"
fmtss1 DCB "(' Invalid value:',I6,' for ',A,' sent to FFSET (ignored)')",0
;
wrong_time; wrong time to call FFSET('SIZE'
    LDR    R0,LUNOUT
    ADR    R1,fmtss3
    BL     io_start_we
    BL     io_end
    LDMDB  fp,{R4-R9,fp,sp,pc} 
fmtss3 DCB "(54H FFSET('SIZE', must be called between FFINIT and FFKEY)",0
;
bad_keyword; unknown keyword (addr. & length on stack)
    LDR    R0,LUNOUT
    ADR    R1,fmtss2
    BL     io_start_we
    LDMFD  sp!,{R0,R1}
    BL     io_do_single
bk0 LDR    R0,[fp]
    BIC    R0,R0,#&FF,6
bk1 LDR    R1,[R0,#-4]!
    CMP    R1,#&FF000000
    BCC    bk1
    AND    R1,R1,#&FF
    SUB    R0,R0,R1
bk2 SUB    R1,R1,#1
    LDRB   lr,[R0,R1]
    CMP    lr,#0
    BEQ    bk2
    ADD    R1,R1,#1
    BL     io_do_single
    BL     io_end
    LDMDB  fp,{R4-R9,fp,sp,pc} 
fmtss2 DCB "(' Unknown keyword: ',A,' sent to ',A,' (ignored)')",0
;
st1 CMP    R0,#3
    BGT    st4
    LDREQ  lr,LUNIN
    LDRNE  lr,LUNOUT
    RSB    ip,R0,#8     ;6 for LINP, 5 for LOUT
    CMP    R1,lr        ;check new I/O valuue against current O/I
    CMPNE  R1,ip        ;compare with standard unit (6,5)
    CMPNE  R1,#0        ;check for range 1 to
    RSBGTS lr,R1,#100   ;99
    BLE    wrong_val
    ADR    ip,LUNIN-8
    STR    R1,[ip,R0,LSL#2]
    LDMDB  fp,{R4-R9,fp,sp,pc} 
;
st4 LDR    R0,NKEYS     ;there should be no calls to FFKEY
    CMP    R0,#0
    BGT    wrong_time   ;wrong time to call FFSET('SIZE'
    CMP    R1,#4        ;SIZE <- # significant keyword characters
    RSBGES lr,R1,#32
    BLT    wrong_val    ;must be between 4 and 32
    ADD    R2,R1,#11
    MOV    R2,R2,LSR#2
    STMIB  R9,{R1,R2}   ;store #sig. characters and #words /key
    LDMDB  fp,{R4-R9,fp,sp,pc} 
;
find_key4;  entry for 4-byte list
    MOV    R6,#4
    MOV    R7,#1
find_key;   find keyword index in list at R4, #entries in R5, length in R6
;          separation of keywords in R7, answer returned in R0
;          answer is index if keyword found otherwise -(next keyword)
    STMFD  sp!,{R1-R3,lr}
    BL     test_init
    MOV    R1,R5          ;count of keywords
gk1 SUBS   R1,R1,#1
    SUBLT  R0,R1,R5
    LDMLTFD sp!,{R1-R3,pc} ;return failure
    MOV    R2,#0
gk2 LDRB   lr,[R0,R2]     ;input keyword
    CMP    lr,#"a"
    SUBGE  lr,lr,#32      ;convert to upper case
    LDRB   ip,[R4,R2]     ;test keyword
    CMP    lr,ip          ;test for equality
    ADDGT  R4,R4,R7,LSL#2
    BGT    gk1            ;fail
    SUBLT  R0,R1,R5
    LDMLTFD sp!,{R1-R3,pc} ;
    ADD    R2,R2,#1
    CMP    R2,R6
    BLT    gk2
    SUB    R0,R5,R1       ;all succeed
    LDMFD  sp!,{R1-R3,pc} 
;
cmn DCD    cfread__
;
test_init; check FFINIT has been called
    LDR    R9,cmn
    LDR    ip,NWORDS
    CMP    ip,#0
    MOVGT  pc,lr
    MOV    R0,#6
    ADR    R1,fmtti1
    BL     io_start_we
    B      bk0
fmtti1 DCB "(' FFINIT must be called before ',A)",0,0,0,0
;
vget DCB   "LENG","LINP","LOUT","NBCH","NBIT","NCHK","NCHW"
;
    EXPORT ffget_;(CHOPT,IVALUE) interrogate internal parameters of 'ffread'
    DCB    "ffget_",0,0,8,0,0,255
ffget_
    MOV    ip,sp
    STMDB  sp!,{R0-R2,R4-R9,fp,ip,lr,pc}
    SUB    fp,ip,#4
    ADR    R4,vget
    MOV    R5,#7
    BL     find_key4
    CMP    R0,#1
    LDMLTIA sp,{R0-R2}
    STMLTFD sp!,{R0,R2}
    BLT    bad_keyword
    LDREQ  ip,LINPUT     ;LENG -> line length
    CMP    R0,#2
    LDREQ  ip,LUNIN      ;LINP -> input stream
    CMP    R0,#3
    LDREQ  ip,LUNOUT     ;LOUT -> output stream
    CMP    R0,#4
    MOVEQ  ip,#8         ;NBCH -> # bits/character
    CMP    R0,#5
    MOVEQ  ip,#32        ;NBIT -> # bits/word
    CMP    R0,#6
    LDREQ  ip,NCHKEY     ;NCHK -> # significant key characters
    MOVGT  ip,#4         ;NCHW -> # characters/word
    STR    ip,[R1]       ;store IVALUE
    LDMDB  fp,{R4-R9,fp,sp,pc} 
;
    EXPORT ffkey_;(KEY, ADDRESS, LENGTH, CHTYPE) defines keywords for 'ffread'
    DCB    "ffkey_",0,0,8,0,0,255
ffkey_
    MOV    ip,sp
    STMDB  sp!,{R0-R9,fp,ip,lr,pc}
    SUB    fp,ip,#4
    BL     test_init
    ADR    R4,IWORDS   ;start of KEYs list
    LDR    R5,NKEYS    ;# keys already stored
    LDR    R6,NCHKEY   ;# significant characters in keyword
    LDR    R7,NWDKEY
    BL     find_key
    CMP    R0,#0
    BLE    FY1
    LDR    R0,LUNOUT   ;key already exists
    ADR    R1,fmtky1
    BL     io_start_we ;so complain
    MOV    R0,R4
    MOV    R1,R6
    BL     io_do_single
    BL     io_end
    LDMDB fp,{R4-R9,fp,sp,pc} ;and return
FY1 LDR    R1,NWORDS
    LDR    R2,IPOINT
    ADD    R3,R2,R7
    CMP    R1,R3
    BGE    FY2
    LDR    R0,LUNOUT   ;insufficient space so complain
    ADR    R1,fmtky2
    BL     io_start_we
    BL     io_end
    LDMDB  fp,{R4-R9,fp,sp,pc} 
FY2 STR    R3,IPOINT   ;new end pointer
    ADD    R5,R5,#1
    STR    R5,NKEYS    ;new # keys
    ADD    R2,R9,R2,LSL#2;address of old end
ky1 CMP    R2,R4
    LDRGT  lr,[R2,#-4]!
    STRGT  lr,[R2,R7,LSL#2]
    BGT    ky1         ;move up list
    LDMIA  sp,{R0-R3}  ;restore arguments
    LDR    ip,[fp,#4]  ;length of KEY
ky2 LDRB   lr,[R0],#1
    CMP    lr,#"a"
    SUBGE  lr,lr,#32
    STRB   lr,[R4],#1  ;transfer keyword
    SUBS   R6,R6,#1
    SUBGTS ip,ip,#1
    BGT    ky2
    MOV    lr,#" "
ky3 SUBS   R6,R6,#1
    STRGEB lr,[R4],#1
    BGT    ky3
ky4 TST    R4,#3
    STRNEB lr,[R4],#1
    BNE    ky4
    MOV    R0,R3
    MOV    R3,R4
    ADR    R4,vkey
    MOV    R5,#3
    BL     find_key4   ;get type 1:integer, 2:logical, 3:real, -4:unknown
    LDR    R2,[R2]
    ORR    R2,R2,R0,LSL#30;pack type into top 2 bits of length
    STMIA  R3,{R1-R2}  ;store address, length+type
    LDMDB  fp,{R4-R9,fp,sp,pc} 
vkey   DCB "INTE","LOGI","REAL"
fmtky1 DCB "(' Key ',A,' is already defined. This one ingnored')",0,0,0,0
fmtky2 DCB "(' No more room for FFKEYs')",0,0,0,0
fmtgos DCB "(12X,'User''s directives to run this job'/12X,33(1H-)/)",0
;
    EXPORT ffgo_;()reads data cards for 'ffread'
    IMPORT ckrack_;(LINE,JL,JR,IFLG)
    IMPORT ffuser_;(KEY)
    DCB    "ffgo_",0,0,0,8,0,0,255
ffgo_
    MOV    ip,sp
    STMDB  sp!,{R4-R9,fp,ip,lr,pc}
    SUB    fp,ip,#4
    BL     test_init
    CMP    sp,sl
    BLLT   __rt_stkovf_split_small
    LDR    R0,LUNOUT    ;print heading
    ADR    R1,fmtgos
    BL     io_start_we
    BL     io_end
    LDR    R5,LINPUT
    SUB    sp,sp,R5     ;space for input card
    BIC    sp,sp,#3
    MOV    R8,#"'"      ;flags: HOLL(0-7), LIST(8), KEYS(9), USER(10,11)
go1 BIC    R8,R8,#&400  ;clear possible 'USER' flag
    LDR    R5,LINPUT
    LDR    R0,LUNIN
    ORR    R0,R0,#4,4   ;END=
    ADR    R1,fmtgo1
    BL     io_start_re
    MOV    R0,sp
    MOV    R1,R5
    BL     io_do_single
    BL     io_end
    CMP    R0,#0
    BNE    eof          ;end of file found
go2 SUBS   R5,R5,#1
    LDRGEB lr,[sp,R5]
    CMPGE  lr,#" "
    BEQ    go2
    ADDS   R5,R5,#1
    ADDEQ  R5,R5,#1    ;R5 is now length (at least 1)
    TST    R8,#&100    ;test for "LIST"
    BEQ    FO1
    LDR    R0,LUNOUT
    ADR    R1,fmtgo2
    BL     io_start_we
    MOV    R0,sp
    MOV    R1,R5
    BL     io_do_single
    BL     io_end
FO1 SUB    R4,sp,#1
go3 LDRB   ip,[R4,#1]!
    RSBS   ip,ip,#" "
    SUBGES R5,R5,#1
    BGT    go3
    BEQ    go1          ;blank card
;       first useful character at R4, length in R5
    LDRB   ip,[R4]      ;check for comment
    MOV    R2,R4
    MOV    R3,R5
    CMP    ip,#"C"
    CMPNE  ip,#"c"
    CMPNE  ip,#"*"
    BNE    go4          ;not a comment
    SUBS   R3,R5,#1
    LDRGTB lr,[R4,#1]   ;test next character
    CMPGT  lr,#"-"
    BLE    go1          ;this is a comment card
    CMP    ip,#"*"
    ORREQ  R8,R8,#&400  ;set user flag
    ADDEQ  R2,R4,#1     ;and skip "*"
    ADDNE  R3,R3,#1     ;"C" is significant
go4 MOV    R0,R2
    ADR    R4,gal
    MOV    R5,#4
    BL     find_key4
    CMP    R0,#0
    BGT    sys          ;system keyword
    MOV    R0,R2
    ADR    R4,IWORDS
    LDR    R5,NKEYS
    LDR    R6,NCHKEY
    LDR    R7,NWDKEY
    BL     find_key
    MOV    R7,R8,LSR#12;current address of key info
    CMP    R0,#0
    BLE    go6         ;not key word
    BL     user        ;possible call to FFUSER from previous keyword
    BIC    R8,R8,R7,LSL#12;new keyword so clear old one from R8
    SUB    R0,R4,R9    ;address of keyword in COMMON/CFREAD/
    ADD    R7,R0,R6    ;end of keyword
    ADD    R7,R7,#3
    MOV    R7,R7,LSR#2 ;word address of keyword info
    ORR    R8,R8,R7,LSL#12;store in R8
go5 SUBS   R3,R3,#1
    LDRGEB lr,[R2],#1
    CMPGE  lr,#33
    BGE    go5          ;skip over keyword
go6 CMP    R7,#0
    BLE    gox          ;failed to find initial keyword
    ADD    R7,R9,R7,LSL#2;address of keyword info: address, length+type
    LDMIA  R7,{R5,R6}   ;address, length+type
    MOV    R7,R6,LSR#30 ;type
    ADD    R6,R5,R6,LSL#2;end address
;        get entry from R2, length R3
    MOV    R4,R5        ;current address
    CMP    R3,#0        ;check for no argument
    BGT    go7
    CMP    R7,#2        ;if not, then set first result
    MOVLE  ip,#1        ;to 1 (TRUE) if integer (logical)
    LDRGT  ip,ONE       ;or 1.0 if REAL
    STR    ip,[R5]
    B      go1
ONE DCFS   1.0
fmtgo2 DCB "('**** DATA CARD CONTENT   ',A)",0
;
go7;   try to find count for position
    MOV    R0,#0
go8 MOV    R1,#0
go9 MOV    ip,R3        ;remember count
goa LDRB   lr,[R2],#1
    SUBS   R3,R3,#1
    BLT    gob
    CMP    lr,#" "
    CMPEQ  R1,#0
    BEQ    go9          ;ignore leading blanks
    RSBS   lr,lr,#"9"
    RSBGES lr,lr,#9     ;convert to binary
    ADDGE  R1,R1,R1,LSL#2
    ADDGE  R1,lr,R1,LSL#1;accumulate integer
    BGE    goa
    LDRB   lr,[R2,#-1]  ;restore character
    CMP    R1,#1
    BLT    gob          ;no count so skip
    CMP    lr,#"="
    CMPEQ  R0,#0
    ADDEQ  R4,R5,R1,LSL#2;set up new current address with "nn="
    SUBEQ  R4,R4,#4
    MOVEQ  R0,#1        ;don't want two positions
    BEQ    go8          ;next try for "nn*"
    CMP    lr,#"*"
gob;     not count so recover position
    MOVNE  R1,#1        ;no multiple entries
    SUBNE  R2,R2,ip
    ADDNE  R2,R2,R3     ;restore buffer pointer
    MOVNE  R3,ip        ;restore byte count
    CMP    R3,#0
    CMPGT  R6,R4
    BLE    go1          ;no space or only blanks left
    AND    ip,R8,#255
    CMP    ip,lr
    BEQ    hdt          ;hollerith data
    CMP    R7,#2
    BEQ    ldt          ;logical data
;        read numeric data item
    STMFD  sp!,{R1-R3}  ;save buffer pointers
    MOV    R0,R2        ;'LINE'
    ADR    R1,JL        ;(JL)  = 1
    ADD    R2,sp,#8     ;(JR) the original R3
    ADR    R3,JFG       ;(JFG) = -1
    BL     ckrack_      ;CALL CKRACK(LINE,1,JR,-1)
    LDMFD  sp!,{R1-R3}  ;restore buffer pointers
    LDR    ip,slt       ;pointer to COMMON/SLATE/
    LDR    R0,NF        ;word type
    CMP    R0,#1
    BLE    gox          ;illegal type
    LDR    lr,NG
    CMP    lr,#0
    BNE    gox          ;read failure
    LDR    lr,NE        ;index of terminating character
    ADD    R2,R2,lr
    SUB    R3,R3,lr     ;update pointers for possible next word
    LDR    lr,RESULT    ;get result assuming integer
    LDFS   F0,RESULT    ;and assuming floating
    CMP    R7,#1
    BGT    flt          ;expecting real
    CMPEQ  R0,#2
    FIXGTZ lr,F0       ;Fix if expecting integer and result is floating
    STR    lr,[R4],#4   ;store result
    B      goc
flt CMP    R0,#2
    FLTGTS F0,lr        ;Float if expecting real and result is integer
    STFS   F0,[R4]
    LDR    lr,[R4],#4
goc CMP    R6,R4
    SUBGTS R1,R1,#1
    STRGT  lr,[R4],#4   ;store multiples
    BGT    goc
    B      go7          ;get next word(s)
ldt;    logical data to read
    LDRB   lr,[R2]
    CMP    lr,#"F"
    BEQ    lfs          ;false
    CMP    lr,#"T"
    BEQ    ltr          ;true
    CMP    lr,#"O"
    BNE    gox          ;illegal data
    LDRB   lr,[R2,#1]
    CMP    lr,#"N"
    BEQ    ltr
    CMP    lr,#"F"
    BNE    gox
lfs MOV    lr,#0
    B      ld2
ltr MOV    lr,#1
ld2 STR    lr,[R4],#4   ;store result
ld3 SUBS   R3,R3,#1     ;skip rest of word
    LDRB   ip,[R2],#1
    CMPGT  ip,#" "
    BGT    ld3
    B      goc
fmtgo1 DCB "(A)",0
hdt;     hollerith data to read
    SUB    R3,R3,#1
    ADD    R2,R2,#1     ;skip deliminator
hd2 SUBS   R3,R3,#1
    BLT    hd4          ;field not complete on this card
    LDRB   lr,[R2],#1
    CMP    lr,ip
    STRNEB lr,[R4],#1
    CMPNE  R4,R6
    BLT    hd2
    MOV    lr,#" "
hd3 TST    R4,#3
    STRNEB lr,[R4],#1
    BNE    hd3          ;blank fill word
    B      go7
hd4 LDR    R0,LUNIN
    ORR    R0,R0,#4,4   ;END=
    ADR    R1,fmtgo1
    BL     io_start_re
    MOV    R0,sp
    LDR    R1,LINPUT
    BL     io_do_single
    BL     io_end
    CMP    R0,#0
    BNE    eof          ;end of file found
    MOV    R2,sp
    LDR    R3,LINPUT
hd5 SUBS   R3,R3,#1
    LDRGEB lr,[sp,R3]
    CMPGE  lr,#" "
    BEQ    hd5
    ADDS   R3,R3,#1
    ADDEQ  R3,R3,#1     ;R3 is now length (at least 1)
    B      hd2          ;continue on next card
;
JL  DCD    1
JFG DCD    -1
ptk DCD    keywrd
slt DCD    slate__
gal    DCB "END ","HOLL","KEYS","LIST","NOLI","READ","STOP","WRIT"
sys;     system keyword read
    BL     user
    MOV    lr,#-1
    BIC    R8,R8,lr,LSL#12;clear the 'address' for keyword
sy1 LDRB   lr,[R2,#1]!
    CMP    lr,#" "
    SUBGTS R3,R3,#1
    BGT    sy1
    CMP    R0,#2
    BEQ    hol          ;"HOLL"
    BGT    sy2
    LDR    R2,ISTACK    ;"END " reduce stack
    SUBS   R2,R2,#1
    BLT    eof1
    STR    R2,ISTACK
    ADR    R1,LUNS
    LDRB   R3,[R1,R2]   ;get old unit
    STR    R3,LUNIN
    B      go1
sy2 CMP    R0,#3
    ORREQ  R8,R8,#&200  ;"KEYS" flag
    BEQ    go1
    CMP    R0,#5
    ORRLT  R8,R8,#&100  ;"LIST"
    BICEQ  R8,R8,#&100  ;"NOLI"
    BLE    go1
    CMP    R0,#7
    BEQ    eof1         ;"STOP"
;       "READ" or "WRIT"e
    MOV    R7,#0        ;zero accumulator
rd1 SUBS   R3,R3,#1
    BLE    rd2          ;no more input
    LDRB   ip,[R2],#1
    CMP    ip,#" "
    CMPEQ  R7,#0
    BEQ    rd1          ;skip initial blanks
    RSBS   ip,ip,#"9"
    RSBGES ip,ip,#9
    ADDGE  R7,R7,R7,LSL#2
    ADDGE  R7,ip,R7,LSL#1;accumulate
    BGE    rd1
rd2 ADD    lr,R7,R0,LSR#1
    CMP    lr,#9        ;ensure not READ 6 or WRITe 5
    CMPNE  R7,#0
    RSBGTS lr,R7,#100
    BGT    FO2
    LDR    R0,LUNOUT
    ADR    R1,fmtgo4
    BL     io_start_we
    MOV    R0,R4
    MOV    R1,#4
    BL     io_do_single
    BL     io_end
    B      go1
FO2 CMP    R0,#7
    ADRLT  R0,LUNS      ;"READ", get new unit
    LDRLT  R2,ISTACK
    LDRLT  R3,LUNIN
    STRLTB R3,[R0,R2]   ;put old unit on stack
    ADDLT  R2,R2,#1
    STRLT  R2,ISTACK
    STRLT  R7,LUNIN     ;LUNIN = new input unit
    STRGT  R7,LUNOUT    ;LUNOUT = new output unit
    B      go1
hol ADR    R1,newhol    ;"HOLL"
hl1 SUBS   R3,R3,#1
    BLT    gox
    LDRB   lr,[R2],#1
    MOV    R0,#6
hl2 LDRB   ip,[R1,R0]
    CMP    ip,lr
    BICEQ  R8,R8,#255   ;found suitable character [=$()"/']
    ORREQ  R8,R8,ip
    BEQ    go1
    SUBS   R0,R0,#1
    BGE    hl2
    B      hl1
;       unknown keyword
gox TST    R8,#&100     ;print problem?
    BEQ    go1
    LDR    R0,LUNOUT
    ADR    R1,fmtgo3
    BL     io_start_we
    BL     io_end
    B      go1
;
user;   possible call to ffuser
    STMFD  sp!,{R0,R2,R3,R5,lr}
    LDR    R5,ptk       ;pointer to address of last keyword
    TST    R8,#&800     ;test for real USER flag
    BEQ    us1
    LDR    R0,[R5]      ;address of last keyword
    CMP    R8,#&1000    ;check if it was user keyword
    LDRGE  R1,NCHKEY    ;length of user keyword
    MOVLT  R1,#4        ;length of system keyword
    BL     ffuser_      ;CALL FFUSER(KEY)
us1 TST    R8,#&400
    BICEQ  R8,R8,#&800  ;reset flag
    ORRNE  R8,R8,#&800  ;if possible USER, set true USER
    STRNE  R4,[R5]      ;store pointer to keyword for FFUSER
    LDMFD  sp!,{R0,R2,R3,R5,pc} 
;
newhol DCB "=$$()""/'",0
fmtgo3 DCB "(20X,'----- DATA CARD ERROR -----')",0
fmtgo4 DCB "(20X,'---- ILLEGAL ',A,' UNIT ---')",0
fmtef1 DCB "(/' User keywords ',8(1X,A)/(15X,8(1X,A)))",0,0
;
eof;   end of input
    BL     user
eof1;  normal end from "END " or "STOP"
    TST    R8,#&200
    LDMEQDB fp,{R4-R9,fp,sp,pc} ;return if KEYS not selected
    LDMIB  R9,{R4-R6}   ;key list characteristics
    ADD    R7,R9,#fixbt ;address of 1st keyword
    CMP    R4,#9
    MOVGT  R4,#9        ;limit length
    LDR    R0,LUNOUT
    ADR    R1,fmtef1
    BL     io_start_we
ef2 SUBS   R6,R6,#1     ;count down keywords
    BLT    FO3
    MOV    R0,R7
    MOV    R1,R4
    BL     io_do_single
    ADD    R7,R7,R5,LSL#2
    B      ef2          ;loop over keywords to print
FO3 BL     io_end
    LDMDB  fp,{R4-R9,fp,sp,pc} ;return if KEYS not selected
;
    ^     0,ip          ;layout of COMMON/SLATE/ with base ip
ND     #    4
NE     #    4
NF     #    4
NG     #    4
RESULT #    4
;
    ^     0,R9         ;layout of COMMON/CFREAD/ with base R9
NWORDS #    4          ;# words in IWORDS
NCHKEY #    4          ;# characters/key (default 4)
NWDKEY #    4          ;# words/key (default 1)
NKEYS  #    4          ;# keys defined
IPOINT #    4          ;# pointer to next word in IWORDS
LINPUT #    4          ;# significant characters on a card(80)
LUNIN  #    4          ;unit number for reading(5)
LUNOUT #    4          ;unit number for output(6)
ISTACK #    4          ;stack pointer into LUNS
LUNS   #   20          ;stack of input units
IWORDS #  800          ;storage for keys
    AREA |C$$data|,DATA
keywrd % 4             ;pointer to keyword for FFKEY(KEY)
    AREA cfread__,DATA,COMMON
    %    2112
    AREA slate__,DATA,COMMON
    %    160
    END
;
    TTL ffuser
pc  RN  15
lr  RN  14
    AREA   |C$$code|,CODE,READONLY
    EXPORT ffuser_;(KEY) dummy
ffuser_
    MOV    pc,lr
    END
;
    TTL   fint
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
R4  RN     4
R5  RN     5
R6  RN     6
R7  RN     7
R8  RN     8
R9  RN     9
F0  FN     0
F1  FN     1
F2  FN     2
F3  FN     3
MMAX   EQU 10; maximum degree of interpolating polynomial
;
    AREA   |C$$code|,CODE,READONLY
    EXPORT fint_;(NARG,ARG,NENT,ENT,TABLE) multidim. linear interpolation
    IMPORT __rt_stkovf_split_big
    DCB    "fint_",0,0,0,8,0,0,255
fint_
    MOV    ip,sp
    STMDB  sp!,{R0-R9,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R0,[R0]       ;NARG
    CMP    R0,#1
    RSBGES lr,R0,#5
    MVFLTS F0,#0         ;FINT = 0.0
    LDMLTDB fp,{R4-R9,fp,sp,pc} ;return if NARGS <1 or >5
    SUB    ip,sp,#268
    CMP    ip,sl
    BLLT   __rt_stkovf_split_big
    MOV    R4,#0         ;LMAX
    MOV    R5,#1         ;ISTEP
    MOV    R6,#1         ;KNOTS
    MVFS   F0,#1
    STFS   F0,[sp,#-256]!;WEIGT(1) = 1.0
    STR    R6,[sp,#128]  ;INDEX(1) = 1
lp1 LDFS   F3,[R1],#4    ;X=ARG(N)
    LDR    R7,[R2],#4    ;NDIM = NENT(N)
    ADD    R8,R4,#1      ;LMIN = LMAX + 1
    ADD    R4,R4,R7      ;LMAX = LMAX + NDIM
    CMP    R7,#2
    BLT    pt6           ;NDIM <2
    STMFD  sp!,{R0-R2}   ;push registers on stack
    BGT    pt1           ;NDIM >2
;       case NDIM=2
    ADD    lr,R3,R8,LSL#2;(ENT(LMIN+1))
    LDFS   F1,[lr,#-4]   ;ENT(LMIN)
    SUFS   F2,F3,F1      ;H = X - ENT(LMIN)
    CMF    F2,#0
    BEQ    pt5           ;H = 0.
    MOV    R9,R5         ;ISHIFT = ISTEP
    LDFS   F0,[lr]       ;ENT(LMIN+1)
    CMF    F0,F3
    BEQ    pt4           ;X=ENT(LMIN+1)
    SUFS   F0,F0,F1      ;ENT(LMIN+1) - ENT(LMIN)
    MOV    R9,#0         ;ISHIFT = 0
    DVFS   F2,F2,F0      ;ETA = H/(ENT(LMIN+1) - ENT(LMIN))
    B      pt2
;       case NDIM>2
pt1 SUB    R0,R8,#1      ;LOCA = LMIN - 1
    ADD    R1,R4,#1      ;LOCB = LMAX + 1
lp2 ADD    R2,R0,R1
    MOV    R2,R2,ASR#1   ;LOCC = (LOCA+LOCB)/2
    ADD    lr,R3,R2,LSL#2;(ENT(LOCC+1))
    LDFS   F2,[lr,#-4]   ;ENT(LOCC)
    CMF    F3,F2         ;IF(X-ENT(LOCC))
    BEQ    pt3
    MOVLT  R1,R2         ;LOCB = LOCC
    MOVGT  R0,R2         ;LOCA = LOCC
    SUB    lr,R1,R0
    CMP    lr,#1
    BGT    lp2           ;loop to find spanning range
    CMP    R0,R8
    MOVLT  R0,R8         ;LOCA = MAX(LOCA,LMIN)
    CMP    R0,R4
    SUBGE  R0,R4,#1      ;LOCA = MIN(LOCA,LMAX-1)
    SUB    lr,R0,R8
    MUL    R9,lr,R5      ;ISHIFT = (LOCA-LMIN)*ISTEP
    ADD    lr,R3,R0,LSL#2;(ENT(LOCA+1))
    LDFS   F0,[lr,#-4]   ;ENT(LOCA)
    LDFS   F1,[lr]       ;ENT(LOCA+1)
    SUFS   F2,F3,F0      ;X - ENT(LOCA)
    SUFS   F1,F1,F0      ;ENT(LOCA+1) - ENT(LOCA)
    FDVS   F2,F2,F1      ;ETA = (X - ENT(LOCA))/(ENT(LOCA+1) - ENT(LOCA))
pt2 MOV    R8,R6         ;K-count (KNOTS)
    ADD    R1,sp,#12     ;(WEIGHT(1))
    ADD    R0,R1,#128    ;(INDEX(1))
    ADD    R2,R1,R6,LSL#2;(WEIGHT(KNOTS+1))
lp3 LDR    lr,[R0]       ;INDEX(K)
    LDFS   F0,[R1]       ;WEIGHT(K)
    ADD    lr,lr,R9      ;INDEX(K) + ISHIFT
    FMLS   F1,F0,F2      ;WEIGHT(K) * ETA
    ADD    ip,lr,R5      ;INDEX(K) + ISHIFT + ISTEP
    STFS   F1,[R2],#4    ;WEIGHT(K+KNOTS) = WEIGHT(K) * ETA
    STR    ip,[R0,R6,LSL#2];INDEX(K+KNOTS) = INDEX(K) + ISHIFT + ISTEP
    SUFS   F0,F0,F1      ;WEIGHT(K) - WEIGHT(K+KNOTS)
    STR    lr,[R0],#4    ;INDEX(K) = INDEX(K) + ISHIFT
    STFS   F0,[R1],#4    ;WEIGHT(K) = WEIGHT(K) - WEIGHT(K+KNOTS)
    SUBS   R8,R8,#1
    BGT    lp3           ;loop while K<KNOTS
    MOV    R6,R6,LSL#1   ;KNOTS = KNOTS*2
    B      pt5
pt3 SUB    lr,R2,R8
    MUL    R9,lr,R5      ;ISHIFT = (LOCC-LMIN)*ISTEP
pt4 MOV    R8,R6         ;K-count (KNOTS)
    ADD    R0,sp,#140    ;(INDEX(1))
lp4 LDR    lr,[R0]       ;INDEX(K)
    ADD    lr,lr,R9
    STR    lr,[R0],#4    ;INDEX(K) = INDEX(K) + ISHIFT
    SUBS   R8,R8,#1
    BGT    lp4
pt5 MUL    R5,R7,R5      ;ISTEP = ISTEP*NDIM
    LDMFD  sp!,{R0-R2}   ;restore vital registers
pt6 SUBS   R0,R0,#1
    BGT    lp1           ;loop over N
;      now calculate FINT
    MVFS   F0,#0         ;FINT = 0
    LDR    R4,[fp,#4]    ;(TABLE)
lp5 LDR    R0,[sp,#128]  ;INDEX(K)
    LDFS   F1,[sp],#4    ;WEIGHT(K)
    ADD    R0,R4,R0,LSL#2;(TABLE(INDEX(K)+1))
    LDFS   F2,[R0,#-4]   ;TABLE(INDEX(K))
    FMLS   F1,F1,F2
    SUBS   R6,R6,#1
    ADFS   F0,F0,F1      ;FINT = FINT + WEIGHT(K)*TABLE(INDEX(K))
    BGT    lp5
    LDMDB  fp,{R4-R9,fp,sp,pc} ;return
    END
;
    TTL   FLPSOR
;                     from utils library
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
    AREA   Utils_,CODE,READONLY
    EXPORT flpsor_;(A,N) sorts floating array A, length N
    DCB    "flpsor_",0,8,0,0,255
flpsor_
    MOV    ip,sp
    STMDB  sp!,{R0,R1,R4-R7,fp,ip,lr,pc}
    SUB    fp,ip,#4
;       initialise variables
    LDR    R1,[R1]           ;N
    SUB    R1,R1,#1
    ADD    R2,R0,R1,LSL#2    ;R = address of A(N) (L is address of A(1))
    MOV    R4,sp             ;pointer to top of stack
    MOV    R7,#&7FFFFFFF     ;sign mask
;          main loop over sections
wl1 CMP    R2,R0             ;check if range to sort is bigger than 1
    CMPLE  R4,sp             ;or that there are more ranges to sort
    LDMLEDB fp,{R4-R7,fp,sp,pc} ; return if finished
    CMP    R2,R0             ;check if range to sort is bigger than 1
    LDMLEFD sp!,{R0,R2}       ;retrieve new L,R from stack
    MOV    R1,R0             ;I=L
    MOV    R3,R2             ;J=R
    SUB    ip,R2,R0
    MOV    ip,ip,LSR#3       ;M=(R-L)/2
    LDR    ip,[R0,ip,LSL#2]  ;X = A(L+M)
    CMP    ip,#0
    EORLT  ip,ip,R7          ;fix sign
wl2 LDR    R5,[R1]           ;A(I)
    MOVS   lr,R5
    EORMI  lr,lr,R7          ;fix sign
    CMP    lr,ip
    ADDLT  R1,R1,#4          ;I=I+1
    BLT    wl2
wl3 LDR    R6,[R3]           ;A(J)
    MOVS   lr,R6
    EORMI  lr,lr,R7          ;fix sign
    CMP    lr,ip
    SUBGT  R3,R3,#4          ;J=J-1
    BGT    wl3
    CMP    R1,R3
    STRLE  R6,[R1],#4
    STRLE  R5,[R3],#-4       ;swop A(I) with A(J); I=I+1; J=J-1
    CMPLE  R1,R3
    BLE    wl2
;
    SUB    R5,R2,R1          ;R-I
    SUB    R6,R3,R0          ;J-L
    CMP    R5,R6
    STMLTFD sp!,{R0,R3}       ;store L,J on stack
    MOVLT  R0,R1             ;L=I
    CMPGE  R5,#0
    STMGTFD sp!,{R1,R2}       ;or store I,R on stack
    MOVGE  R2,R3             ;and set R=J
    B      wl1
    END
;
    TTL    FLOARG
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
F0  FN     0
R0  RN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT floarg_;(WORD) returns WORG in floating format
    DCB    "floarg_",0,8,0,0,255
floarg_
    MOV    ip,sp
    STMDB  sp!,{R0,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    lr,[R0]     ;word
    MOVS   ip,lr,ASR#23;get exponent & sign
    MVNMIS ip,ip       ;make positive
    FLTEQS F0,lr       ;float if integer
    LDFNES F0,[R0]     ;just transmit it if floating
    LDMDB  fp,{fp,sp,pc} ;return
    END
;
    TTL   FREQ
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
F0  FN     0
F1  FN     1
F2  FN     2
F3  FN     3
R0  RN     0
    AREA   |C$$code|,CODE,READONLY
    IMPORT derf_ ;(RX)
    IMPORT derfc_;(RX)
    EXPORT freq_ ;(RX) => Normal frequency function
    EXPORT dfreq_;(RX) => Double Precision Normal frequency function
;
    DCB    "freq_",0,0,0,8,0,0,255
freq_
    MOV    ip,sp
    STMDB  sp!,{R0,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDFS   F0,[R0]      ;RX
    B      pt1
;
    DCB    "dfreq_",0,0,8,0,0,255
dfreq_
    MOV    ip,sp
    STMDB  sp!,{R0,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDFD   F0,[R0]      ;RX
;
pt1 LDFD   F1,const
    MUFD   F2,F1,F0
    LDFD   F3,xmax
    CMF    F2,F3
    MVFLTD F0,#0
    LDMLTDB fp,{fp,sp,pc} 
    ABSD   F1,F2
    STFD   F1,[sp,#-8]!
    MOV    R0,sp
    CMF    F2,#0
    BLT    DQ1
    BL     derf_
    MUFD   F0,F0,#0.5
    ADFD   F0,F0,#0.5
    LDMDB  fp,{fp,sp,pc} 
DQ1 BL     derfc_
    MUFD   F0,F0,#0.5
    LDMDB  fp,{fp,sp,pc} 
const DCFD 0.707106781186548
;     ( CONST=SQRT(1/2). )
xmax DCFS -8.9
;     ( XMAX=-SQRT(-ALOG(RMIN)-10.0), WHERE RMIN IS THE SMALLEST NORMAL-
;     IZED REPRESENTABLE NUMBER.  ERFC(XMAX) IS CLOSE TO THE UNDERFLOW
;     THRESHOLD. )
    END
;
    TTL   funlux
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
R4  RN     4
R5  RN     5
R6  RN     6
R7  RN     7
R8  RN     8
R9  RN     9
F0  FN     0
F1  FN     1
F2  FN     2
F3  FN     3
F4  FN     4
F5  FN     5
F6  FN     6
F7  FN     7
    AREA   |C$$code|,CODE,READONLY
    EXPORT funlux_;(ARRAY,XRAN,LEN) XRAN returns LEN random numbers according to ARRAY
    EXPORT funlxp_;(F,XFC,X2L,X2H) prepares user function F for FUNLUX
    IMPORT __rt_stkovf_split_big
    IMPORT radapt_
    IMPORT io_start_we
    IMPORT io_end
    IMPORT ranlux_
;              
    DCB    "funlux_",0,8,0,0,255
funlux_
    MOV    ip,sp
    STMDB  sp!,{R0-R2,fp,ip,lr,pc}
    SUB    fp,ip,#4
    MOV    R0,R1
    MOV    R1,R2
    BL     ranlux_       ;CALL RANLUX(XRAN,LEN)
    LDMIA  sp,{R0-R2}    ;restore arguments
    LDR    R2,[R2]       ;LEN count for loop IBUF=1,LEN
lp8 LDFS   F0,[R1]       ;X = XRAN(IBUF)
    LDFS   F1,gapinv
    FMLS   F1,F1,F0
    FIXM   R3,F1
    ADD    R3,R3,#1      ;J = INT(X*GAPINV) + 1
    LDFS   F1,gapins
    CMP    R3,#3
    BGE    pt4           ;skip if J>=3
;        code for J < 3
    FMLS   F2,F1,F0
    FIXM   ip,F2         ;J1 = INT(X*GAPINS)
    ADD    R3,ip,#101    ;J=J1+101
    CMP    R3,#102
    MOVLT  R3,#102       ;J=MAX(J,102)
    CMP    R3,#148
    MOVGT  R3,#148       ;J=MIN(J,148)
    LDFS   F2,gaps
    B      clc           ;go do calculation
;
pt4 CMP    R3,#97
    BLE    pt5
;         code for J > 97
    LDFS   F2,bright
    SUFS   F0,F0,F2      ;X = X - BRIGHT
    FMLS   F2,F1,F0
    FIXM   ip,F2         ;J1 = INT((X-BRIGHT)*GAPINS)
    ADD    R3,ip,#151    ;J = J1 + 151
    CMP    R3,#152
    MOVLT  R3,#152       ;J = MAX(J,152)
    CMP    R3,#198
    MOVGT  R3,#198       ;J = MIN(J,198)
    LDFS   F2,gaps
    B      clc           ;go do interpolation
pt5;     code for 3 <= J <= 97
    MOV    ip,R3         ;J1 = J
    LDFS   F2,gap
    LDFS   F1,gapinv
clc SUB    ip,ip,#1      ;J1-1
    FLTS   F3,ip
    FMLS   F3,F3,F2      ;GAPs*(J1-1)
    SUFS   F0,F0,F3      ;X-GAPs*(J1-1)
    FMLS   F0,F0,F1      ;P = (X-GAPs*(J1-1))*GAPINvs
    ADD    R3,R0,R3,LSL#2;(ARRAY(J+1))
    LDFS   F1,[R3,#4]    ;ARRAY(J+2)
    ADFS   F2,F0,#1
    LDFS   F3,[R3,#-8]   ;ARRAY(J-1)
    FMLS   F1,F1,F2      ;(P+1)*ARRAY(J+2)
    SUFS   F2,F0,#2
    FMLS   F2,F2,F3      ;(P-2)*ARRAY(J-1)
    SUFS   F1,F1,F2      ;A=(P+1)*ARRAY(J+2) - (P-2)*ARRAY(J-1)
    LDFS   F2,[R3,#-4]   ;ARRAY(J)
    SUFS   F3,F0,#1
    FMLS   F2,F2,F3      ;(P-1)*ARRAY(J)
    LDFS   F3,[R3]       ;ARRAY(J+1)
    FMLS   F3,F0,F3      ;P*ARRAY(J+1)
    SUFS   F2,F2,F3      ;B=(P-1)*ARRAY(J) - P*ARRAY(J+1)
    SUFS   F3,F0,#1
    FMLS   F1,F1,F0      ;A*P
    FMLS   F1,F1,F3      ;A*P*(P-1)
    LDFS   F3,inv6
    FMLS   F1,F1,F3      ;A*P*(P-1)/6
    ADFS   F3,F0,#1
    FMLS   F2,F2,F3      ;B*(P+1)
    SUFS   F3,F0,#2
    FMLS   F2,F2,F3
    FMLS   F2,F2,#0.5    ;B*(P+1)*(P-2)/2
    ADFS   F0,F1,F2      ;A*P*(P-1)/6 + B*(P+1)*(P-2)/2
    STFS   F0,[R1],#4    ;store XRAN(IBUF)
    SUBS   R2,R2,#1
    BGT    lp8           ;loop over IBUF=1,LEN  
    LDMDB  fp,{fp,sp,pc} ;return
;
gap    DCFS 0.01010101   ;1/99
gapinv DCFS 99.0
bright DCFS 0.97979798   ;97/99
gaps   DCFS 4.1228613E-4 ;2/99/49
gapins DCFS 2425.5       ;99*49/2
inv6   DCFS 0.16666667   ;1/6
;
maxz   EQU  20
nitmax EQU  6
      ^    0,sp          ;storage in sp
ststk  #   0
x      #   4
x1     #   4
tpctil #   4
tz     #   4
tcmax  #   4
tzmax  #   4
xhigh  #   4
fmin   #   4
xincr  #   4
rtpct  #   4
tpart2 #   4
uncert #   4
endstk #   0
lstack   EQU  endstk-ststk  ;length of temporary storage
;
;   begin funpct_;(F,XL,XH,XFCUM,NLO,NB,TFT,IERR) fills XFCUM for FUNLUX
;              
    DCB    "funpct_",0,8,0,0,255
funpct_
    MOV    ip,sp
    STMDB  sp!,{R0-R9,fp,ip,lr,pc}
    SUB    fp,ip,#4
    SUB    ip,sp,#lstack+64
    CMP    ip,sl
    BLLT   __rt_stkovf_split_big
    SFMFD  F4,4,[sp]!    ;save fp registers
    SUB    sp,sp,#lstack ;make space on stack for temporary variables
    MOV    R4,R0         ;(F)
    LDMIB  fp,{R6-R9}    ;(NLO),(NB),(TFT),(IERR)
    LDR    R7,[R7]       ;NBins
    LDR    R0,[R1]       ;XLOW
    STR    R0,x          ;X=XLOW
    LDFS   F0,[R8]       ;TFTOT
    FLTS   F1,R7
    FDVS   F2,F0,F1      ;TPCTIL = TFTOT/NBINS
    LDFS   F0,rteps
    FMLS   F1,F0,F2
    STFS   F1,rtpct      ;store RTEPS*TPCTIL
    STFS   F2,tpctil     ;store TPCTIL
    FDVS   F3,F2,#10     ;TZ = TPCTIL/NZ  (NZ=10)
    STFS   F3,tz         ;save TZ
    FDVS   F0,F3,#10     ;0.01*TPCTIL
    SUFS   F0,F2,F0      ;0.99*TPCTIL
    STFS   F0,tcmax      ;TCMAX = TPCTIL*0.99
    ADFS   F3,F3,F3
    STFS   F3,tzmax      ;TZMAX = TZ*2
    LDR    ip,[R6]       ;NLO
    ADD    R5,R3,ip,LSL#2;(XFCUM(NLO+1))  ... where to start results
    STR    R0,[R5,#-4]!  ;XFCUM(1') = XLOW where 1' is NLO
    LDR    R1,[R2]       ;XHIGH
    ADD    R0,R5,R7,LSL#2
    STR    R1,[R0]       ;XFCUM(1'+NBINS) = XHIGH
    STR    R1,xhigh      ;save XHIGH
    BL     func          ;F(X)
    CMF    F0,#0
    BLT    er1           ;F must be >= 0
    SUB    R7,R7,#1      ;count of bins to fill (2 to NBINS)
lp1;      start loop over bins to fill
    MVFS   F4,#0         ;initialize accumulation of T (TCUM)
    LDFS   F5,x          ;X1=X
    MVFS   F6,F0         ;F1=F
    LDFS   F1,xhigh
    SUFS   F2,F1,F5      ;XHIGH-X
    LDFS   F1,tz
    FRDS   F3,F2,#10     ;1/DXMAX = 1/((XHIGH -X) / NZ)
    FMLS   F7,F3,F1      ;FMINZ = TZ/((XHIGH -X) / NZ)
    STFS   F7,fmin       ;save FMIN=FMINZ
    MOV    R6,#maxz      ;count for loop
;      in this loop: F4=TCUM, F5=X1, F6='F1', F7=FMINZ
lp2 LDFS   F1,tz
    LDFS   F2,fmin
    CMF    F6,F2
    MVFGTS F2,F6
    CMF    F7,F2
    MVFGTS F2,F7         ;MAX(F1,FMIN,FMIN1)
    FDVS   F3,F1,F2      ;XINCR = TZ/MAX(F1,FMIN,FMIN1)
pt1 STFS   F3,xincr      ;save XINCR
    ADFS   F0,F3,F5
    STFS   F0,x          ;X = X1 + XINCR
    BL     func
    CMF    F0,#0         ;check function is not negative
    BLT    er1
    LDFS   F1,xincr
    FMLS   F3,F1,#0.5     ;0.5*XINCR
    ADFS   F2,F6,F0       ;F+F1
    FMLS   F2,F2,F3       ;TINCR = (X-X1) * 0.5 * (F+F1)
    LDFS   F1,tzmax
    CMF    F2,F1
    BGE    pt1            ;iterate with halved XINCR
;
    ADFS   F4,F4,F2       ;TCUM = TCUM + TINCR
    LDFS   F2,tcmax       ;0.99*TPCTIL
    CMF    F2,F4          ;IF(TCUM .LT. TPCTIL*0.99) THEN
    LDFGTS F3,tpctil
    SUFGTS F1,F3,F4       ;  TPCTIL-TCUM
    LDFGTS F2,tz
    FMLGTS F3,F2,F0       ;  TX*F
    FDVGTS F7,F3,F1       ;  FMINZ = TZ*F/(TPCTIL-TCUM)
    MVFGTS F6,F0          ;  F1 = F
    LDFGTS F5,x           ;  X1 = X
    SUBGTS R6,R6,#1
    BGT    lp2            ;  loop over IZ=1,MAXZ
;         END OF TRAPEZOID LOOP
;         Adjust interval using Gaussian integration with
;             Newton corrections since F is the derivative
;    in this loop F4=XBEST, F5=DTBEST, F6=TPART, F7 = XINCR
    LDFS   F4,x            ;XBEST = X
    LDFS   F5,tpctil       ;DTBEST = TPCTIL
    MVFS   F6,F5           ;TPART = TPCTIL
    MOV    R6,#nitmax      ;count for loop
lp3 LDFS   F1,tpctil
    LDFS   F2,fmin
    SUFS   F1,F1,F6        ;TPCTIL - TPART
    CMF    F0,F2
    MVFGTS F2,F0           ;MAX(FMIN,F)
    FDVS   F7,F1,F2        ;XINCR = (TPCTIL-TPART) / MAX(F,FMIN)
pt2 ADFS   F1,F4,F7
    STFS   F1,x            ;X = XBEST + XINCR
    CMP    R6,#nitmax-1
    CMFLE  F7,#0
    BEQ    pt3             ;skip if XINCR=0 on subsequent iterations
    ADR    R0,rteps
    ADR    R1,zero
    ADR    R2,tpart2
    ADR    R3,uncert
    STMFD  sp!,{R0-R3}     ;store args on stack
    MOV    R0,R4           ;(F)
    MOV    R1,R5           ;(XFCUM(IBIN))
    ADR    R2,x+16         ;(X2=X)  (+16 because stack has been extended)
    ADR    R3,one
    BL     radapt_
    ADD    sp,sp,#16       ;restore stack
    LDFS   F0,tpart2
    LDFS   F1,tpctil
    SUFS   F0,F0,F1 
    ABSS   F0,F0           ;DTABS = ABS(TPART2 - TPCTIL)
    CMF    F0,F5
    LDFGES F1,x
    LDFGES F2,precis
    ABSGES F1,F1
    ABSGES F3,F7           ;ABS(XINCR)
    ADFGES F1,F1,F2        ;ABS(X)+PRECIS
    FMLGES F1,F1,F2        ;PRECIS*(ABS(X)+PRECIS)
    CMFGE  F3,F1           ;IF(DTABS.GE.DTBEST .AND. 
;                                 ABS(XINCR).GE.PRECIS*(ABS(X)+PRECIS)) THEN
    FMLGES F7,F7,#0.5      ;  XINCR = 0.5*XINCR
    BGE    pt2             ;  iterate
;
    MVFS   F5,F0           ;DTBEST = DTABS
    LDFS   F4,x            ;XBEST = X
    LDFS   F6,tpart2       ;TPART = TPART2
    BL     func            ;F(X)
    CMF    F0,#0
    BLT    er1             ;error if F(X) < 0
    LDFS   F1,rtpct
    CMF    F5,F1           ;IF(DTABS.GT.RTEPS*TPCTIL) THEN
    SUBGTS R6,R6,#1
    BGT    lp3             ; loop IHOME=1,NITMAX
;
pt3 LDFS   F1,fmin
    LDFS   F2,tpctil
    CMF    F0,F1
    MVFGTS F1,F0           ;MAX(F,FMIN)
    SUFS   F2,F2,F6        ;TPCTIL-TPART
    FDVS   F2,F2,F1        ;XINCR = (TPCTIL-TPART) / MAX(F,FMIN)
    ADFS   F3,F2,F4        ;X = XBEST + XINCR
    STFS   F3,[R5,#4]!     ;XFCUM(IBIN+1) = X
    STFS   F3,x
    BL     func
    CMF    F0,#0
    BLT    er1
    SUBS   R7,R7,#1
    BGT    lp1            ;loop over bins  
    MOV    R0,#0
rt1 STR    R0,[R9]         ;store IERR
    ADD    sp,sp,#lstack   ;restore stack
    LFMFD  F4,4,[sp]!
    LDMDB  fp,{R4-R9,fp,sp,pc} ;return
;
er1;   error, write message
    MOV    R0,#6
    ADR    R1,fmt
    BL     io_start_we
    BL     io_end
    MOV    R0,#1             ;IERR=1
    B      rt1
;
rteps  DCFS 0.005
precis DCFS 1.0E-6
zero   DCD  0
one    DCD  1
fmt DCB  "(' FUNLUX fatal error in FUNPCT: function negative')"
    ALIGN
;   calculate maximum stack requirement
    IF lstack+64 > 96
tstack  EQU lstack+110
    ELSE
tstack  EQU 96
    ENDIF 
;
    DCB    "funlxp_",0,8,0,0,255
funlxp_
    MOV    ip,sp
    STMDB  sp!,{R0-R3,fp,ip,lr,pc}
    SUB    fp,ip,#4
    SUB    ip,sp,#52+tstack  ;52 for funlxp, tstack for max(funlz,funpct)
    CMP    ip,sl
    BLLT   __rt_stkovf_split_big
    SUBS   sp,sp,#52     ;space for XLOW,XHIGH,TFTOT,UNCERT,IERR,X2,TFTOT1
;                        TFTOT2  & 5 arg addresses
    MOV    R1,R2         ;(X2L)
    MOV    R2,R3         ;(X2H)
    ADD    R3,sp,#20     ;(XLOW)
    ADD    ip,sp,#24     ;(XHIGH)
    STR    ip,[sp]
    BL     funlz_        ;CALL FUNLZ(F,X2L,X2H,XLOW,XHIGH)
    LDFS   F0,[sp,#20]   ;XLOW
    LDFS   F1,[sp,#24]   ;XHIGH
    CMF    F1,F0
    BLE    err           ;XHIGH <= XLOW
    ADR    R0,rtep1
    ADR    R1,zero
    ADD    R2,sp,#28     ;(TFTOT)
    ADD    R3,sp,#32     ;(UNCERT)
    STMIA  sp,{R0-R3}
    LDR    R0,[sp,#52]   ;(F)
    ADD    R1,sp,#20     ;(XLOW)
    ADD    R2,sp,#24     ;(XHIGH)
    ADR    R3,one
    BL     radapt_       ;CALL RADAPT(F,XLOW,XHIGH,1,RTEPS,0.,TFTOT,UNCERT)
    ADR    R0,one
    ADR    R1,i99
    ADD    R2,sp,#28     ;(TFTOT)
    ADD    R3,sp,#32     ;(IERR)
    STMIA  sp,{R0-R3}
    LDR    R0,[sp,#52]   ;(F)
    ADD    R1,sp,#20     ;(XLOW)
    ADD    R2,sp,#24     ;(XHIGH)
    LDR    R3,[sp,#56]   ;(XFC)
    BL     funpct_       ;CALL FUNPCT(F,XLOW,XHIGH,XFCUM,1,99,TFTOT,IERR)
    LDR    R0,[sp,#32]   ;IERR
    CMP    R0,#0
    BGT    err           ;IERR>0
    LDR    R0,[sp,#56]   ;(XFC)
    LDR    R1,[R0,#8]    ;XFC(3)
    STR    R1,[sp,#36]   ;X2 = XFC(3)
    ADR    R0,rtep1
    ADR    R1,zero
    ADD    R2,sp,#40     ;(TFTOT1)
    ADD    R3,sp,#32     ;(UNCERT)
    STMIA  sp,{R0-R3}
    LDR    R0,[sp,#52]   ;(F)
    ADD    R1,sp,#20     ;(XLOW)
    ADD    R2,sp,#36     ;(X2)
    ADR    R3,one
    BL     radapt_       ;CALL RADAPT(F,XLOW,X2,1,RTEPS,0.,TFTOT1,UNCERT)
    ADR    R0,i101
    ADR    R1,i49
    ADD    R2,sp,#40     ;(TFTOT1)
    ADD    R3,sp,#32     ;(IERR)
    STMIA  sp,{R0-R3}
    LDR    R0,[sp,#52]   ;(F)
    ADD    R1,sp,#20     ;(XLOW)
    ADD    R2,sp,#36     ;(X2)
    LDR    R3,[sp,#56]   ;(XFC)
    BL     funpct_       ;CALL FUNPCT(F,XLOW,X2,XFCUM,101,49,TFTOT1,IERR)
    LDR    R0,[sp,#32]   ;IERR
    CMP    R0,#0
    BGT    err           ;IERR>0
    LDR    R0,[sp,#56]   ;(XFC)
    LDR    R1,[R0,#388]  ;XFC(98)
    STR    R1,[sp,#44]   ;X3 = XFC(98)
    ADR    R0,rtep1
    ADR    R1,zero
    ADD    R2,sp,#48     ;(TFTOT2)
    ADD    R3,sp,#32     ;(UNCERT)
    STMIA  sp,{R0-R3}
    LDR    R0,[sp,#52]   ;(F)
    ADD    R1,sp,#44     ;(X3)
    ADD    R2,sp,#24     ;(XHIGH)
    ADR    R3,one
    BL     radapt_       ;CALL RADAPT(F,X3,XHIGH,1,RTEPS,0.,TFTOT2,UNCERT)
    ADR    R0,i151
    ADR    R1,i49
    ADD    R2,sp,#48     ;(TFTOT2)
    ADD    R3,sp,#32     ;(IERR)
    STMIA  sp,{R0-R3}
    LDR    R0,[sp,#52]   ;(F)
    ADD    R1,sp,#44     ;(X3)
    ADD    R2,sp,#24     ;(XHIGH)
    LDR    R3,[sp,#56]   ;(XFC)
    BL     funpct_       ;CALL FUNPCT(F,X3,XHIGH,XFCUM,151,49,TFTOT2,IERR)
    LDR    R0,[sp,#32]   ;IERR
    CMP    R0,#0
    LDMLEDB  fp,{fp,sp,pc} ;return
err; error, write message
    MOV    R0,#6
    ADR    R1,fm2
    BL     io_start_we
    BL     io_end
    LDMDB  fp,{fp,sp,pc} ;return
;
i49 DCD    49
i99 DCD    99
i101 DCD   101
i151 DCD   151
rtep1 DCFS 0.0002
;
;
;   begin funlz_;(F,X2L,X2H,XL,XH) finds range where F>0
;              
    DCB    "funlz_",0,0,8,0,0,255
funlz_
    MOV    ip,sp
    STMDB  sp!,{R0-R6,fp,ip,lr,pc}  ;       (44)
    SUB    fp,ip,#4
    SFMFD  F4,4,[sp]!    ;save fp registers (48)
    MOV    R4,R0         ;(F)
    LDFS   F4,[R1]       ;XL = X2L
    LDFS   F5,[R2]       ;XH = X2H
    MVFS   F6,F4         ;XMID = XL
    STFS   F4,[sp,#-4]!  ;                   (04)
    BL     func          ;CALL FUNC(XL)
    CMF    F0,#0
    BGT    p120          ;FUNC(XL) > 0
    MVFS   F6,F5         ;XMID = XH
    STFS   F5,[sp]
    BL     func          ;CALL FUNC(XH)
    CMF    F0,#0
    BGT    p50           ;FUNC(XH) > 0
;         function is zero at both ends
    MOV    R6,#2         ;NSLICE = 2**1
    SUFS   F7,F5,F4      ;XW = XH - XL
lp4 MOV    R5,#1
    FLTS   F0,R6
    FDVS   F7,F7,F0      ;(XH-XL)/NSLICE
lp5 FLTS   F0,R5
    FMLS   F0,F0,F7
    ADFS   F6,F4,F0      ;XMID = XL + I*(XH-XL)/NSLICE
    STFS   F6,[sp]
    BL     func          ;CALL FUNC(XMID)
    CMF    F0,#0
    BGT    p50           ;FUNC(XMID) > 0
    ADD    R5,R5,#2
    CMP    R5,R6
    BLE    lp5           ;loop I=1,NSLICE,2
    ADD    R6,R6,R6      ;NSLICE = 2*NSLICE
    CMP    R6,#128
    BLE    lp4           ;loop NSLICE=2**L, L=1,7
; error, write message
    MOV    R0,#6
    ADR    R1,fm1
    BL     io_start_we
    BL     io_end
    MVFS   F4,#0
    MVFS   F5,#0
    B      ret
;
p50;    delete leading zero range
    MOV    R5,#20         ;loop count
    MVFS   F7,F4          ;XM = XL
    MVFS   F4,F6          ;XL = XMID
lp6 ADFS   F1,F4,F7
    FMLS   F1,F1,#0.5     ;XNEW = 0.5*(XL+XM)
    STFS   F1,[sp]
    BL     func          ;CALL FUNC(XNEW)
    CMF    F0,#0
    LDFLES F7,[sp]       ;XM = XNEW
    LDFGTS F4,[sp]       ;or XL = XNEW
    SUBS   R5,R5,#1
    BGT    lp6
p120; come here when FUNC(XL) > 0
    STFS   F5,[sp]
    BL     func          ;CALL FUNC(XH)
    CMF    F0,#0
    BGT    ret           ;also FUNC(XH) > 0
;       delete trailing zero range
    MOV    R5,#20         ;loop count
    MVFS   F7,F5          ;XM = XH
    MVFS   F5,F6          ;XH = XMID
lp7 ADFS   F1,F5,F7
    FMLS   F1,F1,#0.5     ;XNEW = 0.5*(XM+XH)
    STFS   F1,[sp]
    BL     func          ;CALL FUNC(XNEW)
    CMF    F0,#0
    LDFLES F7,[sp]       ;XM = XNEW
    LDFGTS F5,[sp]       ;or XH = XNEW
    SUBS   R5,R5,#1
    BGT    lp7
;    
ret LDR    R3,[sp,#64]        ;(XL)
    LDR    R4,[fp,#4]         ;(XH)
    STFS   F4,[R3]            ;store XL
    STFS   F5,[R4]            ;store XH
    ADD    sp,sp,#4
    LFMFD  F4,4,[sp]!
    LDMDB  fp,{R4-R6,fp,sp,pc} ;return
;
func;    CALLS F(X) where (X) is in [sp] and (F) is in R4
    MOV   R0,sp         ;(X)
    MOV   pc,R4
;
fm2 DCB  "(' Fatal error in FUNLXP. FUNLUX will not work.')"
fm1 DCB  "('0 cannot find non-zero function value')"
    END
;
;        FUNLXP see FUNLUX
;
    TTL     GAMMA
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
F0  FN     0
F1  FN     1
F2  FN     2
F3  FN     3
F4  FN     4
F5  FN     5
F6  FN     6
R0  RN     0
R1  RN     1
R2  RN     2
    AREA   |C$$code|,CODE,READONLY
    EXPORT gamma_  ;(X) => Gamma function
    EXPORT gammf_  ;(X) => Gamma function
    EXPORT dgamma_ ;(X) => Double precision Gamma function
    EXPORT dgammf_ ;(X) => Double precision Gamma function
;
    DCB    "gamma_",0,0,8,0,0,255
gamma_
gammf_
    MOV    ip,sp
    STMDB  sp!,{R0,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDFS   F0,[R0]        ;X
    B      gm1
;
    DCB    "dgamma_",0,8,0,0,255
dgamma_
dgammf_
    MOV    ip,sp
    STMDB  sp!,{R0,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDFD   F0,[R0]        ;X
gm1 MVFD   F3,F0          ;save initial value
    CMF    F0,#0
    RSFLED F0,F0,#1
    RNDLED F1,F0
    CMFLE  F1,F0
    MVFEQD F0,#0          ;fail for non-positive integer
    LDMEQDB fp,{fp,sp,pc} 
    STFE   F4,[sp,#-12]!
    STFE   F5,[sp,#-12]!
    STFE   F6,[sp,#-12]!
    MVFD   F1,#1          ;F=1
;        normalize to get 3 <= X <= 4
    CMF    F0,#3
    BGE    gm2
    RSFD   F2,F0,#4
    FIXZ   R2,F2          ;INT(4.0-X)  (must be >0)
lp1 DVFD   F1,F1,F0
    ADFD   F0,F0,#1
    SUBS   R2,R2,#1
    BGT    lp1
    B      gm3
gm2 SUFD   F2,F0,#3
    FIXZ   R2,F2          ;INT(X-3.0)  (may be zero)
lp2 SUBS   R2,R2,#1
    SUFGED F0,F0,#1
    MUFGED F1,F1,F0
    BGT    lp2
gm3 SUFD   F0,F0,#3
    ADFD   F2,F0,F0
    SUFD   F2,F2,#1       ;H=2X-1
    ADFD   F6,F2,F2       ;ALFA=2H
    ADR    R2,cc1+120     ;[c(15)]
    LDFD   F0,[R2],#-8    ;initialize B0
    MVFD   F4,#0          ;initialize B2
    MOV    R1,#15         ;15 terms in sum
lp3 MUFD   F5,F6,F0
    SUFD   F5,F5,F4
    MVFD   F4,F0
    LDFD   F0,[R2],#-8
    ADFD   F0,F0,F5
    SUBS   R1,R1,#1
    BGT    lp3
    MUFD   F4,F4,F2
    SUFD   F0,F0,F4
    MUFD   F0,F0,F1
    LDFE   F6,[sp],#12
    LDFE   F5,[sp],#12
    LDFE   F4,[sp],#12
    CMF    F3,#0          ;check for initial negative argument
    LDFLED F1,wpi         ;PI
    MUFLED F3,F3,F1
    SINLED F3,F3          ;Sine(pi*X)
    MUFLED F3,F3,F0
    DVFLED F0,F1,F3       ;gamma=pi/(Sine(pi*X)*gamma')
    LDMDB  fp,{fp,sp,pc} 
;
wpi DCFD 3.14159265358979324
cc1 DCFD 3.65738772508338244
    DCFD 1.95754345666126827
    DCFD 3.3829711382616039E-1
    DCFD 4.208951276557549E-2
    DCFD 4.28765048212909E-3
    DCFD 3.6521216929462E-4
    DCFD 2.740064222642E-5
    DCFD 1.81240233365E-6
    DCFD 1.0965775866E-7
    DCFD 5.98718405E-9
    DCFD 3.0769081E-10
    DCFD 1.431793E-11
    DCFD 6.5109E-13
    DCFD 2.596E-14
    DCFD 1.11E-15
    DCFD 4.E-17
    END
;
    TTL    gather
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT gather_;(NW,A,B,INDX) A(I) = B(INDX(I)), I=1,NW
    DCB    "gather_",0,8,0,0,255
gather_
    MOV    ip,sp
    STMDB  sp!,{R0-R3,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R0,[R0]     ;NW
    SUB    R2,R2,#4    ;(B(0))
lp1 SUBS   R0,R0,#1
    LDRGE  ip,[R3,R0,LSL#2] ;INDX(I)
    LDRGE  lr,[R2,ip,LSL#2] ;B(INDX(I))
    STRGE  lr,[R1,R0,LSL#2] ;-> A(I)
    BGT    lp1
    LDMDB  fp,{fp,sp,pc} 
    END
;
    TTL    GAUSIN
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
F0  FN     0
F1  FN     1
F2  FN     2
F3  FN     3
F4  FN     4
F5  FN     5
R0  RN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT dgausn_;(P) => inverse Gaussian (REAL*8)
    EXPORT gausin_;(P) => inverse Gaussian (REAL*4)
    IMPORT dfreq_
;
    DCB    "dgausn_",0,8,0,0,255
dgausn_
    MOV    ip,sp
    STMDB  sp!,{R0,fp,ip,lr,pc}
    SUB    fp,ip,#4
    STFE   F4,[sp,#-12]!;save floating registers
    LDFD   F4,[R0]      ;P
    B      pg1
;
    DCB    "gausin_",0,8,0,0,255
gausin_
    MOV    ip,sp
    STMDB  sp!,{R0,fp,ip,lr,pc}
    SUB    fp,ip,#4
    STFE   F4,[sp,#-12]!;save floating registers
    LDFS   F4,[R0]      ;P
;
pg1 MVFD   F0,#0
    CMF    F4,#0
    BLE    rt4          ;error if P<=0
    CMF    F4,#1
    BGE    rt4          ;error if P>=1
    CMF    F4,#0.5
    BEQ    rt4          ;zero if P=0.5
    STFE   F5,[sp,#-12]!
    MVFLTD F5,F4        ;X=P
    RSFGTD F5,F4,#1     ;or X=1-P (such that X<0.5)
    LGND   F0,F5
    MNFD   F0,F0
    ADFD   F0,F0,F0
    SQTD   F5,F0        ;X = SQRT(-2.0*LOG(X))
    LDFS   F0,ca1       ;7.47395
    LDFS   F1,cb1       ;117.9407
    LDFS   F2,ca2       ;494.877
    MUFD   F0,F0,F5
    ADFD   F1,F1,F5
    ADFD   F0,F0,F2
    LDFS   F3,cb2       ;908.401
    LDFS   F2,ca3       ;1637.720
    MUFD   F1,F1,F5
    MUFD   F0,F0,F5
    ADFD   F1,F1,F3
    LDFS   F3,cb3       ;659.935
    ADFD   F0,F0,F2
    MUFD   F1,F1,F5
    ADFD   F1,F1,F3
    DVFD   F0,F0,F1     ;X=X-((7.47395*X+494.877)*X+1637.720)/
    SUFD   F5,F5,F0     ;  (((X+117.9407)*X+908.401)*X+659.935)
    MNFLTD F5,F5        ;IF(P.LT.0.5) X=-X
    STFD   F5,[sp,#-8]! ;X on stack
    MOV    R0,sp
    BL     dfreq_       ;DFREQ(X)
    ADD    sp,sp,#8     ;restore stack pointer
    SUFD   F4,F4,F0     ;P-DFREQ(X)
    MUFD   F3,F5,F5     ;S=X**2
    MUFD   F2,F3,#0.5
    LDFD   F0,r2p       ; SQRT(2pi)
    EXPD   F2,F2        ;EXP(0.5*S)
    MUFD   F4,F4,F2
    MUFD   F4,F4,F0     ;Z=SQRT(2pi)*(P-DFREQ(X))*EXP(0.5*S)
    LDFS   F0,cc1       ;3/4
    LDFS   F1,cc2       ;7/8
    MUFD   F3,F3,F0     ;(3/4)*S
    ADFD   F3,F3,F1     ;+(7/8)
    DVFD   F2,F4,#3
    MUFD   F3,F3,F4     ;*Z
    ADFD   F3,F3,F5     ;+X
    MUFD   F3,F3,F5     ;*X
    MUFD   F1,F5,#0.5
    ADFD   F3,F3,#0.5   ;+(1/2)
    MUFD   F3,F3,F2     ;*Z/3
    ADFD   F3,F3,F1     ;+(1/2)*X
    MUFD   F3,F3,F4     ;*Z
    ADFD   F3,F3,#1     ;+1
    MUFD   F3,F3,F4     ;*Z
    ADFD   F0,F3,F5     ;+X
    LDFE   F5,[sp],#12
rt4 LDFE   F4,[sp],#12
    LDMDB  fp,{fp,sp,pc} 
ca1 DCFS   7.47395
cb1 DCFS   117.9407
ca2 DCFS   494.877
cb2 DCFS   908.401
ca3 DCFS   1637.720
cb3 DCFS   659.935
r2p DCFD   2.50662827463100050; SQRT(2pi)
cc1 DCFS   0.75
cc2 DCFS   0.875
    END
;
    TTL    GETBIT
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R2  RN     2
R1  RN     1
R0  RN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT getbit_;(I,M,L) finds value of a bit in a bit string
    DCB    "getbit_",0,8,0,0,255
getbit_
    MOV    ip,sp
    STMDB  sp!,{R0-R2,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R0,[R0]     ;get i
    SUBS   R0,R0,#1
    MOVGE  ip,R0,LSR#5 ;word #
    LDRGE  R1,[R1,ip,LSL#2];get word
    ANDGE  R0,R0,#31    ;bit #
    MOVGE  R1,R1,LSL R0;move bit to m.s.
    MOVGE  R1,R1,LSR#31;move bit to l.s.
    STRGE  R1,[R2]     ;store in l
    LDMDB  fp,{fp,sp,pc} ;return
    END
;
    TTL    GETBYT
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT getbyt_;(ADDR,IBEG,ILEN,IRES) extracts byte from bit string
    DCB    "getbyt_",0,8,0,0,255
getbyt_
    MOV    ip,sp
    STMDB  sp!,{R0-R3,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R1,[R1]     ;get ibeg
    LDR    R2,[R2]     ;get ilen
    SUBS   R1,R1,#1
    CMPGES R2,#1
    LDMLTDB fp,{fp,sp,pc} ;return if IBEG or ILEN<=0
    MOV    ip,R1,LSR#5 ;word #
    AND    R1,R1,#31   ;bit #
    LDR    ip,[R0,ip,LSL#2]!;get 1st word
    MOV    ip,ip,LSL R1;shift left
    RSB    R1,R1,#32   ;# bits remaining
    CMP    R1,R2       ;is byt all in 1 word?
    LDRLT  lr,[R0,#4]  ;no, get next word
    ORRLT  ip,ip,lr,LSR R1;add new bits
    RSB    R2,R2,#32   ;32 - ilen
    MOV    ip,ip,LSR R2;move to l.s. end
    STR    ip,[R3]     ;store in ires
    LDMDB  fp,{fp,sp,pc} ;return
    END
;
    TTL    GETARG
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
OS_GetEnv EQU &10
    AREA   |C$$code|,CODE,READONLY
    EXPORT getarg_;(IARG,GOTEXT) returns the command line arguments
    EXPORT iargc_;() returns # arguments
    DCB    "getarg_",0,8,0,0,255
getarg_
    MOV    ip,sp
    STMDB  sp!,{R0-R2,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R3,[R0]       ;IARG
    SWI    OS_GetEnv     ;get exec string
lp1 SUBS   R3,R3,#1
    BLGE   next
    CMP    R3,#0
    BGT    lp1
    LDMIB  sp,{R1,R2}    ;restore address and length of GOTEXT
lp2 LDRB   lr,[R0]
    CMP    lr,#" "
    MOVLT  lr,#" "
    ADDGT  R0,R0,#1
    STRB   lr,[R1],#1
    SUBS   R2,R2,#1
    BGT    lp2
    LDMDB  fp,{fp,sp,pc} ;return
;
iargc_
    MOV    ip,sp
    STMDB  sp!,{fp,ip,lr,pc}
    SUB    fp,ip,#4
    SWI    OS_GetEnv     ;get exec string
    MOV    R3,#0         ;initialise count
lp3 BL     next
    LDRB   ip,[R0]
    CMP    ip,#" "
    ADDGT  R3,R3,#1      ;count args
    BGT    lp3
    MOV    R0,R3
    LDMDB  fp,{fp,sp,pc} ;return
;
next;      find beginning of next argument
    LDRB   ip,[R0,#1]!
    CMP    ip,#" "
    BGT    next
    MOVLT  pc,lr       ;end of string found
lpn LDRB   ip,[R0,#1]!
    CMP    ip,#" "     ;search for next non-blank
    BEQ    lpn
    MOV    pc,lr
    END
;
    TTL    ICDECI
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R8  RN     8
R7  RN     7
R6  RN     6
R5  RN     5
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
    AREA   slate__,COMMON,NOINIT
    %      160
    AREA   |C$$code|,CODE,READONLY
;
    EXPORT ncdeci_;(CHV) returns integer from decimal CHV
    DCB    "ncdeci_",0,8,0,0,255
ncdeci_
    MOV    ip,sp
    STMDB  sp!,{R0,R1,R5-R8,fp,ip,lr,pc}
    SUB    fp,ip,#4
    MOV    R3,#1       ;first character in chv
    B      icd1        ;length is in R1
;
    EXPORT icdeci_;(LINE,JL,JR) returns integer from decimal LINE(JL:JR)
    DCB    "icdeci_",0,8,0,0,255
icdeci_
    MOV    ip,sp
    STMDB  sp!,{R0-R2,R5-R8,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R3,[R1]     ;JL
    LDR    R1,[R2]     ;JR
icd1 SUB    R0,R0,#1    ;(LINE(0:0))
    SUB    R7,R3,#1    ;initialize NE = JL-1
    MOV    R2,#0       ;accumulator
    MOV    R5,#1       ;initialise sign
    MOV    R6,#0
wi3 ADD    R7,R7,#1
    CMP    R7,R1
    BGT    wi5
    LDRB   ip,[R0,R7]
    CMP    ip,#" "
    BEQ    wi3         ;skip leading blanks
    CMP    ip,#"-"
    MOVEQ  R5,#-1      ;set sign -ve
    CMPNE  ip,#"+"
    ADDEQ  R7,R7,#1    ;skip leading "+" or "-"
    CMP    R7,R1
    BGT    wi5
wi4 LDRB   ip,[R0,R7]
    RSBS   R3,ip,#"9"
    RSBGES R3,R3,#9
    ADDGE  R2,R2,R2,LSL#2;multiply by 5
    ADDGE  R2,R3,R2,LSL#1;multiply by 2 & accumulate
    ADDGE  R6,R6,#1
    ADDGE  R7,R7,#1
    CMPGE  R1,R7
    BGE    wi4
wi5 MUL    R0,R5,R2    ;correct the sign
    SUB    R8,ip,#" "  ;ng = 0 if blank terminator
    CMP    R7,R1
    MOVGT  R8,#0       ;or number fills string
    LDR    R2,slpt     ;pointer to /SLATE/
    STMIA  R2,{R6,R7}  ;store ND,NE
    STR    R8,[R2,#12] ;store NG
    LDMDB  fp,{R5-R8,fp,sp,pc} ;return
slpt DCD    slate__     ;pointer to COMMON/SLATE/
    END
;
    TTL    ICEQU
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT icequ_;(CHA,CHB,N) returns comparison of  strings CHA and CHB
    DCB    "icequ_",0,0,8,0,0,255
icequ_
    MOV    ip,sp
    STMDB  sp!,{R0-R2,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R2,[R2]      ;N
    MOV    R3,#0
lp1 CMP    R3,R2
    MOVEQ  R0,#0        ;return zero if finished
    LDMEQDB fp,{fp,sp,pc} 
    LDRB   lr,[R0,R3]
    LDRB   ip,[R1,R3]
    ADD    R3,R3,#1
    CMP    ip,lr
    BEQ    lp1
    MOV    R0,R3        ;return character number at difference
    LDMDB  fp,{fp,sp,pc} 
    END
;
    TTL    ICFILA
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
    AREA   slate__,COMMON,NOINIT
    %      160
;
    AREA   |C$$code|,CODE,READONLY
    EXPORT icfila_;(CHIS,LINE,JL,JR) find last occurence of CHIS in LINE(JL:JR)
    DCB    "icfila_",0,8,0,0,255
icfila_
    MOV    ip,sp
    STMDB  sp!,{R0-R3,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDRB   ip,[R0]     ;CHIS
    LDR    R0,[R3]     ;initialize JX to JR
    SUB    R1,R1,#1    ;(LINE(0:0))
    LDR    R2,[R2]     ;JL
    SUB    R2,R2,#1    ;JL-1
    ADD    lr,R0,#1    ;JR+1
wd2 LDRB   R3,[R1,R0]
    CMP    R3,ip
    SUBNE  R0,R0,#1
    CMPNE  R2,R0
    BLT    wd2
    SUBS   R1,R0,R2    ;if failed to find,
    MOVEQ  R0,lr       ;set answer to JR+1
    LDR    ip,slpt     ;pointer to /SLATE/
    STRNE  R0,[ip,#12] ;store NG=JX
    STREQ  R1,[ip,#12] ;store NG=0
    LDMDB  fp,{fp,sp,pc} ;return
slpt DCD    slate__     ;pointer to COMMON/SLATE/
    END
;
    TTL    ICFIND
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
    AREA   slate__,COMMON,NOINIT
    %      160
;
    AREA   |C$$code|,CODE,READONLY
    EXPORT icfind_;(CHIS,LINE,JL,JR) find first occurence of CHIS in LINE(JL:JR)
    DCB    "icfind_",0,8,0,0,255
icfind_
    MOV    ip,sp
    STMDB  sp!,{R0-R2,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDRB   ip,[R0]     ;CHIS
    SUB    R1,R1,#1    ;(LINE(0:0))
    LDR    R0,[R2]     ;initialize JX = JL
    LDR    R3,[R3]
    ADD    R3,R3,#1    ;JR+1
wd1 LDRB   R2,[R1,R0]
    CMP    R2,ip
    ADDNE  R0,R0,#1
    CMPNE  R0,R3
    BLT    wd1
    SUBS   R1,R0,R3
    LDR    R3,slpt     ;/SLATE/
    STRNE  R0,[R3,#12] ;store NG=JX
    STREQ  R1,[R3,#12] ;store NG=0
    LDMDB  fp,{fp,sp,pc} ;return
slpt DCD    slate__     ;pointer to COMMON/SLATE/
    END
;
    TTL    ICFMUL
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R9  RN     9
R6  RN     6
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
    AREA   slate__,COMMON,NOINIT
    %      160
;
    AREA   |C$$code|,CODE,READONLY
    EXPORT icfmul_;(CHI,LINE,JL,JR) finds any character of CHI in LINE(JL:JR)
    DCB    "icfmul_",0,8,0,0,255
icfmul_
    MOV    ip,sp
    STMDB  sp!,{R0-R3,R6,R9,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    ip,[ip]     ;length of CHI
    SUB    R0,R0,#1    ;(CHI(0:0))
    SUB    R1,R1,#1    ;(line(0:0))
    LDR    R9,[R2]     ;initialize NG to jl
    LDR    R3,[R3]     ;jr
    ADD    R3,R3,#1    ;jr+1
wd3 LDRB   lr,[R1,R9]
    MOV    R6,ip       ;length of CHI
wd4 LDRB   R2,[R0,R6]  ;get byte of CHI
    CMP    R2,lr
    SUBNES R6,R6,#1
    BNE    wd4
    CMP    R2,lr
    ADDNE  R9,R9,#1
    CMPNE  R9,R3
    BNE    wd3
    MOV    R0,R9       ;store answer JX
    CMP    R9,R3
    MOVGE  R9,#0       ;set NG=0 if not found
    LDR    lr,slpt     ;/SLATE/
    STRLT  R6,[lr]     ;store ND (if found)
    STR    R9,[lr,#12] ;store NG
    LDMDB  fp,{R6,R9,fp,sp,pc} ;return
slpt DCD    slate__     ;pointer to COMMON/SLATE/
    END
;
    TTL    ICFNBL
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
    AREA   slate__,COMMON,NOINIT
    %      160
;
    AREA   |C$$code|,CODE,READONLY
    EXPORT icfnbl_;(LINE,JL,JR) finds first non-blank in LINE(JL:JR)
    DCB    "icfnbl_",0,8,0,0,255
icfnbl_
    MOV    ip,sp
    STMDB  sp!,{R0-R2,fp,ip,lr,pc}
    SUB    fp,ip,#4
    SUB    R0,R0,#1    ;(line(0:0))
    LDR    R1,[R1]     ;initialize NG = JL
    LDR    R2,[R2]     ;JR
wd5 CMP    R1,R2       ;loop until NG>JR
    BGT    wd6
    LDRB   R3,[R0,R1]
    CMP    R3,#" "     ;check for blank
    ADDEQ  R1,R1,#1
    BEQ    wd5
wd6 MOV    R0,R1       ;store answer JX
    CMP    R1,R2
    MOVGT  R1,#0       ;set ng=0 if all blanks
    LDR    R2,slpt     ;/SLATE/
    STR    R1,[R2,#12] ;store NG
    LDMDB  fp,{fp,sp,pc} ;return
slpt DCD    slate__     ;pointer to COMMON/SLATE/
    END
;
    TTL    ICHARN
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT icharn_;(STRING) -> integer (converted from decimal ASCII)
    DCB    "icharn_",0,8,0,0,255
icharn_
    MOV    ip,sp
    STMDB  sp!,{R0,R1,fp,ip,lr,pc}
    SUB    fp,ip,#4
    MOV    R2,#1        ;sign
    MOV    R3,#0        ;accumulator
lp1 SUBS   R1,R1,#1
    MULLT  R0,R2,R3
    LDMLTDB fp,{fp,sp,pc} ;return if finished
    LDRB   ip,[R0],#1
    CMP    ip,#"-"
    MOVEQ  R2,#-1
    RSBS   ip,ip,#"9"
    RSBGES ip,ip,#9
    ADDGE  R3,R3,R3,LSL#2
    ADDGE  R3,ip,R3,LSL#1;acculumlate
    B      lp1
    END
;
    TTL    ICINQ
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
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 icinq_;(TEXT,POSS,NPOSS) searches POSS(NPOSS) for TEXT
    DCB    "icinq_",0,0,8,0,0,255
icinq_
    MOV    ip,sp
    STMDB  sp!,{R0-R6,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    ip,[R2]     ;NPOSS
    LDR    R2,[fp,#4]  ;length of POSS
    MOV    lr,ip       ;copy of NPOSS
    SUB    R1,R1,R2    ;(POSS(0))
wp1 SUBS   lr,lr,#1    ;count of POSS
    MOVLT  R0,#0
    LDMLTDB fp,{R4-R6,fp,sp,pc} ;failed, return zero
    MOV    R5,#0       ;character count
    ADD    R1,R1,R2    ;address of current POSS
    LDRB   R6,[R1]     ;first byte of POSS
wp2 LDRB   R4,[R0,R5]  ;byte of TEXT
    CMP    R4,#"*"
    BEQ    wp3
    CMP    R6,R4
    BNE    wp1         ;match failed
    ADD    R5,R5,#1    ;increment count
    CMP    R5,R2       ;check if end of POSS
    BGE    wp4         ;found match
    LDRB   R6,[R1,R5]  ;get next byte from POSS
    CMP    R6,#" "     ;check for " "
    BEQ    wp5
    CMP    R5,R3
    BNE    wp2         ;check more TEXT
    B      wp1         ;failed, try next POSS
wp3;      first '*' seen on TEXT
    ADD    R5,R5,#1    ;increment count
    CMP    R5,R3       ;check if end of TEXT
    BGE    wp4
    LDRB   R4,[R0,R5]  ;byte of TEXT
    CMP    R4,#"*"
    CMPNE  R4,#" "
    BEQ    wp4
    CMP    R4,R6
    BNE    wp1
    CMP    R5,R2
    BGE    wp4
    LDRB   R6,[R1,R5]  ;get next byte from POSS
    CMP    R6,#" "     ;check for " "
    BNE    wp3
wp4 SUB    R0,ip,lr    ;finished, calculate index
    LDMDB  fp,{R4-R6,fp,sp,pc} ;return
wp5;     POSS blank terminated
    CMP    R5,R3       ;check if end of TEXT
    BGE    wp4
    LDRB   R4,[R0,R5]  ;byte of TEXT
    CMP    R4,#"*"
    CMPNE  R4,#" "
    BEQ    wp4
    B      wp1
    END
;
    TTL    ICINQL
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
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 icinql_;(TEXT,POSS,NPOSS) searches POSS(NPOSS) for TEXT (lower case)
    DCB    "icinql_",0,8,0,0,255
icinql_
    MOV    ip,sp
    STMDB  sp!,{R0-R7,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    ip,[R2]     ;NPOSS
    LDR    R2,[fp,#4]  ;length of POSS
    MOV    lr,ip       ;copy of NPOSS
    SUB    R1,R1,R2    ;(POSS(0))
wp1 SUBS   lr,lr,#1    ;count of POSS
    MOVLT  R0,#0
    LDMLTDB fp,{R4-R7,fp,sp,pc} ;failed, return zero
    MOV    R5,#0       ;character count
    ADD    R1,R1,R2    ;address of current POSS
    LDRB   R6,[R1]     ;first byte of POSS
wp2 LDRB   R4,[R0,R5]  ;byte of TEXT
    CMP    R4,#"*"
    BEQ    wp3
    CMP    R4,#"A"
    RSBGES R7,R4,#"Z"
    ADDGE  R4,R4,#32   ;convert TEXT to lower case
    CMP    R6,R4
    BNE    wp1         ;match failed
    ADD    R5,R5,#1    ;increment count
    CMP    R5,R2       ;check if end of POSS
    BGE    wp4         ;found match
    LDRB   R6,[R1,R5]  ;get next byte from POSS
    CMP    R6,#" "     ;check for " "
    BEQ    wp5
    CMP    R5,R3
    BNE    wp2         ;check more TEXT
    B      wp1         ;failed, try next POSS
wp3;      first '*' seen on TEXT
    ADD    R5,R5,#1    ;increment count
    CMP    R5,R3       ;check if end of TEXT
    BGE    wp4
    LDRB   R4,[R0,R5]  ;byte of TEXT
    CMP    R4,#"*"
    CMPNE  R4,#" "
    BEQ    wp4
    CMP    R4,#"A"
    RSBGES R7,R4,#"Z"
    ADDGE  R4,R4,#32   ;convert TEXT to lower case
    CMP    R4,R6
    BNE    wp1
    CMP    R5,R2
    BGE    wp4
    LDRB   R6,[R1,R5]  ;get next byte from POSS
    CMP    R6,#" "     ;check for " "
    BNE    wp3
wp4 SUB    R0,ip,lr    ;finished, calculate index
    LDMDB  fp,{R4-R7,fp,sp,pc} ;return
wp5;     POSS blank terminated
    CMP    R5,R3       ;check if end of TEXT
    BGE    wp4
    LDRB   R4,[R0,R5]  ;byte of TEXT
    CMP    R4,#"*"
    CMPNE  R4,#" "
    BEQ    wp4
    B      wp1
    END
;
    TTL    ICINQU
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
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 icinqu_;(TEXT,POSS,NPOSS) searches POSS(NPOSS) for TEXT (upper case)
    DCB    "icinqu_",0,8,0,0,255
icinqu_
    MOV    ip,sp
    STMDB  sp!,{R0-R7,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    ip,[R2]     ;NPOSS
    LDR    R2,[fp,#4]  ;length of POSS
    MOV    lr,ip       ;copy of NPOSS
    SUB    R1,R1,R2    ;(POSS(0))
wp1 SUBS   lr,lr,#1    ;count of POSS
    MOVLT  R0,#0
    LDMLTDB fp,{R4-R7,fp,sp,pc} ;failed, return zero
    MOV    R5,#0       ;character count
    ADD    R1,R1,R2    ;address of current POSS
    LDRB   R6,[R1]     ;first byte of POSS
wp2 LDRB   R4,[R0,R5]  ;byte of TEXT
    CMP    R4,#"*"
    BEQ    wp3
    CMP    R4,#"a"
    RSBGES R7,R4,#"z"
    SUBGE  R4,R4,#32   ;convert TEXT to upper case
    CMP    R6,R4
    BNE    wp1         ;match failed
    ADD    R5,R5,#1    ;increment count
    CMP    R5,R2       ;check if end of POSS
    BGE    wp4         ;found match
    LDRB   R6,[R1,R5]  ;get next byte from POSS
    CMP    R6,#" "     ;check for " "
    BEQ    wp5
    CMP    R5,R3
    BNE    wp2         ;check more TEXT
    B      wp1         ;failed, try next POSS
wp3;      first '*' seen on TEXT
    ADD    R5,R5,#1    ;increment count
    CMP    R5,R3       ;check if end of TEXT
    BGE    wp4
    LDRB   R4,[R0,R5]  ;byte of TEXT
    CMP    R4,#"*"
    CMPNE  R4,#" "
    BEQ    wp4
    CMP    R4,#"a"
    RSBGES R7,R4,#"z"
    SUBGE  R4,R4,#32   ;convert TEXT to upper case
    CMP    R4,R6
    BNE    wp1
    CMP    R5,R2
    BGE    wp4
    LDRB   R6,[R1,R5]  ;get next byte from POSS
    CMP    R6,#" "     ;check for " "
    BNE    wp3
wp4 SUB    R0,ip,lr    ;finished, calculate index
    LDMDB  fp,{R4-R7,fp,sp,pc} ;return
wp5;     POSS blank terminated
    CMP    R5,R3       ;check if end of TEXT
    BGE    wp4
    LDRB   R4,[R0,R5]  ;byte of TEXT
    CMP    R4,#"*"
    CMPNE  R4,#" "
    BEQ    wp4
    B      wp1
    END
;
    TTL    ICHEXI
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R4  RN     4
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
    AREA   slate__,COMMON,NOINIT
    %      160
;
    AREA   |C$$code|,CODE,READONLY
    EXPORT nchexi_;(CHV) returns integer from hex CHV
    DCB    "nchexi_",0,8,0,0,255
nchexi_
    MOV    ip,sp
    STMDB  sp!,{R0,R1,R4,fp,ip,lr,pc}
    SUB    fp,ip,#4
    MOV    R3,#1       ;first character in chv
    B      ich1        ;length is in R1
;
    EXPORT ichexi_;(LINE,JL,JR) returns integer from hex LINE(JL:JR)
    DCB    "ichexi_",0,8,0,0,255
ichexi_
    MOV    ip,sp
    STMDB  sp!,{R0-R2,R4,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R3,[R1]     ;initialize NE = jl
    LDR    R1,[R2]     ;jr
ich1 SUB    lr,R0,#1    ;(line(0:0))
    MOV    R0,#0       ;accumulator
    MOV    R2,#0       ;initialise ND
wh3 LDRB   ip,[lr,R3]
    CMP    ip,#" "
    BNE    wh5
    ADD    R3,R3,#1
    CMP    R3,R1
    BLE    wh3         ;skip leading blanks
    B      wh6
wh4 LDRB   ip,[lr,R3]
wh5 SUBS   ip,ip,#"0"  ;convert to number
    BLT    wh6
    CMP    ip,#48      ;check for lower case letter
    SUBGT  ip,ip,#32   ;make upper case
    CMP    ip,#22
    BGT    wh6         ; > "F"
    CMP    ip,#9
    SUBGT  ip,ip,#7    ;convert "A" to 10 etc
    RSBGTS R4,ip,#10
    BGT    wh6         ;between "9" and "A"
    ORR    R0,ip,R0,LSL#4
    ADD    R2,R2,#1
    ADD    R3,R3,#1
    CMP    R3,R1
    BLE    wh4
wh6 ADD    R4,ip,#16   ;ng = 0 if blank terminator
    CMP    R3,R1
    MOVGT  R4,#0       ;or number fills string
    LDR    R1,slpt     ;pointer to /SLATE/
    STMIA  R1,{R2,R3}  ;store ND,NE
    STR    R4,[R1,#12] ;store NG
    LDMDB  fp,{R4,fp,sp,pc} ;return
slpt DCD    slate__     ;pointer to COMMON/SLATE/
    END
;
    TTL    ICLOC
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R5  RN     5
R4  RN     4
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT icloc_;(CHI,NI,LINE,JL,JR) is INDEX(LINE(JL:JR),CHI(1:NI))
    DCB    "icloc_",0,0,8,0,0,255
icloc_
    MOV    ip,sp
    STMDB  sp!,{R0-R5,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    ip,[ip]     ;address of JR
    LDR    R1,[R1]     ;NI
    LDR    R3,[R3]     ;JL
    LDR    ip,[ip]     ;JR
    SUB    ip,ip,R3    ;# chars in LINE - 1
    SUB    R2,R2,#1    ;(LINE(0:0))
    ADD    R3,R2,R3    ;(LINE(JL:JL))
    ADD    ip,ip,#2
    SUBS   ip,ip,R1    ;useful length
    BLE    wc3
wc1 SUB    R4,R1,#1    ;ni-1
wc2 LDRB   R5,[R0,R4]
    LDRB   lr,[R3,R4]
    CMP    R5,lr
    BNE    wc3
    SUBS   R4,R4,#1
    BGE    wc2         ;loop over bytes of chi
    SUB    R0,R3,R2    ;store answer
    LDMDB  fp,{R4,R5,fp,sp,pc} ;return
wc3 ADD    R3,R3,#1
    SUBS   ip,ip,#1
    BGT    wc1
    MOV    R0,#0       ;return zero if not found
    LDMDB  fp,{R4,R5,fp,sp,pc} ;return
    END
;
    TTL    ICLOCL
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R5  RN     5
R4  RN     4
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT iclocl_;(CHI,NI,LINE,JL,JR) finds CHI(1:NI) in LINE(JL:JR) converted
    DCB    "iclocl_",0,8,0,0,255
iclocl_
    MOV    ip,sp
    STMDB  sp!,{R0-R5,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    ip,[ip]     ;address of JR
    LDR    R1,[R1]     ;NI
    LDR    R3,[R3]     ;JL
    LDR    ip,[ip]     ;JR
    SUB    ip,ip,R3    ;# chars in LINE - 1
    SUB    R2,R2,#1    ;(LINE(0:0))
    ADD    R3,R2,R3    ;(LINE(JL:JL))
    ADD    ip,ip,#2
    SUBS   ip,ip,R1    ;useful length
    BLE    wc6
wc4 SUB    R4,R1,#1    ;ni-1
wc5 LDRB   lr,[R3,R4]
    CMP    lr,#"A"
    RSBGES R5,lr,#"Z"
    ADDGE  lr,lr,#32   ;convert to lower case
    LDRB   R5,[R0,R4]
    CMP    R5,lr
    BNE    wc6
    SUBS   R4,R4,#1
    BGE    wc5         ;loop over bytes of chi
    SUB    R0,R3,R2    ;store answer
    LDMDB  fp,{R4,R5,fp,sp,pc} ;return
wc6 ADD    R3,R3,#1
    SUBS   ip,ip,#1
    BGT    wc4
    MOV    R0,#0       ;return zero if not found
    LDMDB  fp,{R4,R5,fp,sp,pc} ;return
    END
;
    TTL    ICLOCU
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R5  RN     5
R4  RN     4
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT iclocu_;(CHI,NI,LINE,JL,JR) finds CHI(1:NI) in LINE(JL:JR) converted
    DCB    "iclocu_",0,8,0,0,255
iclocu_
    MOV    ip,sp
    STMDB  sp!,{R0-R5,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    ip,[ip]     ;address of JR
    LDR    R1,[R1]     ;NI
    LDR    R3,[R3]     ;JL
    LDR    ip,[ip]     ;JR
    SUB    ip,ip,R3    ;# chars in LINE - 1
    SUB    R2,R2,#1    ;(LINE(0:0))
    ADD    R3,R2,R3    ;(LINE(JL:JL))
    ADD    ip,ip,#2
    SUBS   ip,ip,R1    ;useful length
    BLE    wc9
wc7 SUB    R4,R1,#1    ;ni-1
wc8 LDRB   lr,[R3,R4]
    CMP    lr,#"a"
    RSBGES R5,lr,#"z"
    SUBGE  lr,lr,#32   ;convert to upper case
    LDRB   R5,[R0,R4]
    CMP    R5,lr
    BNE    wc9
    SUBS   R4,R4,#1
    BGE    wc8         ;loop over bytes of chi
    SUB    R0,R3,R2    ;store answer
    LDMDB  fp,{R4,R5,fp,sp,pc} ;return
wc9 ADD    R3,R3,#1
    SUBS   ip,ip,#1
    BGT    wc7
    MOV    R0,#0       ;return zero if not found
    LDMDB  fp,{R4,R5,fp,sp,pc} ;return
    END
;
    TTL    ICLUNS
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT icluns_;(LINE,JL,JR) finds first non-printing character in LINE(JL:JR
    DCB    "icluns_",0,8,0,0,255
icluns_
    MOV    ip,sp
    STMDB  sp!,{R0-R2,fp,ip,lr,pc}
    SUB    fp,ip,#4
    SUB    R3,R0,#1    ;(LINE(0:0))
    LDR    R0,[R1]     ;JX = JL
    LDR    R2,[R2]     ;JR
wu3 LDRB   R1,[R3,R0]
    CMP    R1,#32      ;check for " "
    RSBGES R1,R1,#126  ;check for "~"
    ADDGE  R0,R0,#1
    CMPGE  R2,R0
    BGE    wu3         ;loop until JX>JR
    CMP    R2,R0
    MOVLT  R0,#0       ;no "unseen" chars
    LDMDB  fp,{fp,sp,pc} ;return
    END
;
    TTL    ICNEXT
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
    AREA   slate__,COMMON,NOINIT
    %      160
;
    AREA   |C$$code|,CODE,READONLY
    EXPORT icnext_;(LINE,JL,JR) finds first non-blank & subsequent blank in LINE
    DCB    "icnext_",0,8,0,0,255
icnext_
    MOV    ip,sp
    STMDB  sp!,{R0-R2,fp,ip,lr,pc}
    SUB    fp,ip,#4
    SUB    R3,R0,#1    ;(LINE(0:0))
    LDR    R0,[R1]     ;JX = JL
    LDR    R2,[R2]     ;JR
    ADD    ip,R2,#1    ;initialize NE = JR+1
wn1 CMP    R0,R2
    BGT    wn4         ;loop until JX>JR
    LDRB   R1,[R3,R0]
    CMP    R1,#" "     ;check for " "
    ADDEQ  R0,R0,#1
    BEQ    wn1         ;loop over blanks
wn2 MOV    ip,R0
wn3 ADD    ip,ip,#1
    CMP    ip,R2
    BGT    wn4         ;end of line
    LDRB   R1,[R3,ip]
    CMP    R1,#" "
    BNE    wn3         ;look for next blank
wn4 LDR    R1,slpt     ;/SLATE/
    SUB    R3,ip,R0    ;calculate ND(=NE-JX)
    STMIA  R1,{R3,ip}  ;store ND,NE
    LDMDB  fp,{fp,sp,pc} ;return
slpt DCD    slate__     ;pointer to COMMON/SLATE/
    END
;
    TTL    ICNTH
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
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 icnth_;(TEXT,POSS,NPOSS) searches POSS(NPOSS) for TEXT
    DCB    "icnth_",0,0,8,0,0,255
icnth_
    MOV    ip,sp
    STMDB  sp!,{R0-R6,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    ip,[R2]     ;NPOSS
    LDR    R2,[fp,#4]  ;length of POSS
    MOV    lr,ip       ;copy of NPOSS
    SUB    R1,R1,R2    ;(POSS(0))
wp1 SUBS   lr,lr,#1    ;count of POSS
    MOVLT  R0,#0
    LDMLTDB fp,{R4-R6,fp,sp,pc} ;failed, return zero
    MOV    R5,#0
    ADD    R1,R1,R2    ;address of current POSS
    LDRB   R6,[R1,R5]  ;first byte of POSS
wp2 LDRB   R4,[R0,R5]  ;byte of TEXT
    CMP    R6,R4
    BNE    wp1         ;match failed
    ADD    R5,R5,#1    ;increment count
    CMP    R5,R2       ;check if end of POSS
    BEQ    wp4         ;found match
    LDRB   R6,[R1,R5]  ;get next byte from POSS
    CMP    R6,#"*"     ;check for "*"
    BEQ    wp5
    CMP    R6,#" "     ;test for blank
    BEQ    wp3
    CMP    R5,R3
    BNE    wp2         ;check more TEXT
    B      wp1         ;failed, try next POSS
wp3 CMP    R5,R3       ;if there is more TEXT
    LDRNEB R4,[R0,R5]
    CMPNE  R4,#" "     ;make sure it is blank
    BNE    wp1         ;if not, failed, try next POSS
wp4 SUB    R0,ip,lr    ;finished, calculate index
    LDMDB  fp,{R4-R6,fp,sp,pc} ;return
wp5 CMP    R5,R3       ;come here on "*" in POSS
    LDRNEB R4,[R0,R5]  ;get next byte of TEXT if any
    CMPNE  R4,#" "     ;OK if blank
    ADDNE  R5,R5,#1
    CMPNE  R5,R2       ;OK if no more POSS
    LDRNEB R6,[R1,R5]  ;get next POSS byte
    CMPNE  R6,#"*"
    BEQ    wp4         ;OK if "*"
    CMP    R6,R4
    BEQ    wp5         ;extended POSS and TEXT agree
    B      wp1         ;failed, try next POSS
    END
;
    TTL    ICNTHL
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
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 icnthl_;(TEXT,POSS,NPOSS) searches POSS(NPOSS) (lower case) for TEXT
    DCB    "icnthl_",0,8,0,0,255
icnthl_
    MOV    ip,sp
    STMDB  sp!,{R0-R7,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    ip,[R2]     ;NPOSS
    LDR    R2,[fp,#4]  ;length of POSS
    MOV    lr,ip       ;copy of NPOSS
    SUB    R1,R1,R2
wq1 SUBS   lr,lr,#1    ;count of POSS
    MOVLT  R0,#0
    LDMLTDB fp,{R4-R7,fp,sp,pc} ;failed, return zero
    MOV    R5,#0
    ADD    R1,R1,R2    ;address of current POSS
    LDRB   R6,[R1,R5]  ;first byte of POSS
wq2 LDRB   R4,[R0,R5]  ;byte of TEXT
    CMP    R4,#"A"
    RSBGES R7,R4,#"Z"
    ADDGE  R4,R4,#32   ;convert to lower case
    CMP    R6,R4
    BNE    wq1         ;match failed
    ADD    R5,R5,#1    ;increment count
    CMP    R5,R2       ;check if end of POSS
    BEQ    wq4         ;found match
    LDRB   R6,[R1,R5]  ;get next byte from POSS
    CMP    R6,#"*"     ;check for "*"
    BEQ    wq5
    CMP    R6,#" "     ;test for blank
    BEQ    wq3
    CMP    R5,R3
    BNE    wq2         ;check more TEXT
    B      wq1         ;failed, try next POSS
wq3 CMP    R5,R3       ;if there is more TEXT
    LDRNEB R4,[R0,R5]
    CMPNE  R4,#" "     ;make sure it is blank
    BNE    wq1         ;if not, failed, try next POSS
wq4 SUB    R0,ip,lr    ;finished, calculate index
    LDMDB  fp,{R4-R7,fp,sp,pc} ;return
wq5 CMP    R5,R3       ;come here on "*" in POSS
    LDRNEB R4,[R0,R5]  ;get next byte of TEXT if any
    CMPNE  R4,#" "     ;OK if blank
    ADDNE  R5,R5,#1
    CMPNE  R5,R2       ;OK if no more POSS
    LDRNEB R6,[R1,R5]  ;get next POSS byte
    CMPNE  R6,#"*"
    BEQ    wq4         ;OK if "*"
    CMP    R4,#"A"
    RSBGES R7,R4,#"Z"
    ADDGE  R4,R4,#32   ;convert to lower case
    CMP    R6,R4
    BEQ    wq5         ;extended POSS and TEXT agree
    B      wq1         ;failed, try next POSS
    END
;
    TTL    ICNTHU
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
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 icnthu_;(TEXT,POSS,NPOSS) searches POSS(NPOSS) (upper case) for TEXT
    DCB    "icnthu_",0,8,0,0,255
icnthu_
    MOV    ip,sp
    STMDB  sp!,{R0-R7,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    ip,[R2]     ;NPOSS
    LDR    R2,[fp,#4]  ;length of POSS
    MOV    lr,ip       ;copy of NPOSS
    SUB    R1,R1,R2
wr1 SUBS   lr,lr,#1    ;count of POSS
    MOVLT  R0,#0
    LDMLTDB fp,{R4-R7,fp,sp,pc} ;failed, return zero
    MOV    R5,#0
    ADD    R1,R1,R2    ;address of current POSS
    LDRB   R6,[R1,R5]  ;first byte of POSS
wr2 LDRB   R4,[R0,R5]  ;byte of TEXT
    CMP    R4,#"a"
    RSBGES R7,R4,#"z"
    SUBGE  R4,R4,#32   ;convert to upper case
    CMP    R6,R4
    BNE    wr1         ;match failed
    ADD    R5,R5,#1    ;increment count
    CMP    R5,R2       ;check if end of POSS
    BEQ    wr4         ;found match
    LDRB   R6,[R1,R5]  ;get next byte from POSS
    CMP    R6,#"*"     ;check for "*"
    BEQ    wr5
    CMP    R6,#" "     ;test for blank
    BEQ    wr3
    CMP    R5,R3
    BNE    wr2         ;check more TEXT
    B      wr1         ;failed, try next POSS
wr3 CMP    R5,R3       ;if there is more TEXT
    LDRNEB R4,[R0,R5]
    CMPNE  R4,#" "     ;make sure it is blank
    BNE    wr1         ;if not, failed, try next POSS
wr4 SUB    R0,ip,lr    ;finished, calculate index
    LDMDB  fp,{R4-R7,fp,sp,pc} ;return
wr5 CMP    R5,R3       ;come here on "*" in POSS
    LDRNEB R4,[R0,R5]  ;get next byte of TEXT if any
    CMPNE  R4,#" "     ;OK if blank
    ADDNE  R5,R5,#1
    CMPNE  R5,R2       ;OK if no more POSS
    LDRNEB R6,[R1,R5]  ;get next POSS byte
    CMPNE  R6,#"*"
    BEQ    wr4         ;OK if "*"
    CMP    R4,#"a"
    RSBGES R7,R4,#"z"
    SUBGE  R4,R4,#32   ;convert to upper case
    CMP    R6,R4
    BEQ    wr5         ;extended POSS and TEXT agree
    B      wr1         ;failed, try next POSS
    END
;
    TTL    ICNUM
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
    AREA   slate__,COMMON,NOINIT
    %      160
    AREA   |C$$code|,CODE,READONLY
;
    EXPORT icnum_;(LINE,JL,JR) finds first non-numeric character in LINE(JL:JR)
    DCB    "icnum_",0,0,8,0,0,255
icnum_
    MOV    ip,sp
    STMDB  sp!,{R0-R2,fp,ip,lr,pc}
    SUB    fp,ip,#4
    SUB    R3,R0,#1    ;(LINE(0:0))
    LDR    R0,[R1]     ;JX = JL
    LDR    R2,[R2]     ;JR
    MOV    R1,#-1      ;init ND
wm1 LDRB   ip,[R3,R0]
    CMP    ip,#" "
    ADDNE  R1,R1,#1
    SUBNES ip,ip,#"0"  ;check for numeric
    RSBGTS ip,ip,#9
    BLT    wm2         ;not numeric & not blank
    ADD    R0,R0,#1
    CMP    R0,R2
    BLE    wm1
    ADD    R1,R1,#1
wm2 LDR    R3,slpt     ;/SLATE/
    STR    R1,[R3]     ;store ND
    MOVGT  R1,#0       ;all numeric
    MOVLT  R1,R0       ;first non-numeric
    STR    R1,[R3,#12] ;store NG
    LDMDB  fp,{fp,sp,pc} ;return
slpt DCD    slate__     ;pointer to COMMON/SLATE/
    END
;
    TTL    ICNUMA
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
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
    AREA   slate__,COMMON,NOINIT
    %      160
;
    AREA   |C$$code|,CODE,READONLY
    EXPORT icnuma_;(LINE,JL,JR) finds first non-alphanumeric in LINE(JL:JR)
    DCB    "icnuma_",0,8,0,0,255
icnuma_
    MOV    ip,sp
    STMDB  sp!,{R0-R2,R6-R9,fp,ip,lr,pc}
    SUB    fp,ip,#4
    SUB    R3,R0,#1    ;(LINE(0:0))
    LDR    R0,[R1]     ;JX = JL
    LDR    R2,[R2]     ;JR
    MOV    R6,#0       ;ND
    MOV    R7,#0       ;NE
    MOV    R8,#0       ;NF
    MOV    R9,#0       ;NG
wm3 LDRB   R1,[R3,R0]
    CMP    R1,#" "
    BEQ    wm5         ;blank
    CMP    R1,#"0"
    BLT    wm6         ; <"0"
    CMP    R1,#"9"
    CMPLE  R7,#0
    MOVLE  R7,R0       ;set NE if 1st numeral
    CMP    R1,#"9"
    BLE    wm4         ;skip the rest if numeral
    CMP    R1,#"A"
    BLT    wm6         ; >"9" AND <"A"
    CMP    R1,#"Z"
    RSBGTS ip,R1,#"a"
    BGT    wm6         ; >"Z" AND <"a"
    CMP    R1,#"z"
    BGT    wm6         ; >"z"
    CMP    R8,#0
    MOVLE  R8,R0       ;set NF for 1st alpabetic
wm4 ADD    R6,R6,#1
wm5 ADD    R0,R0,#1
    CMP    R0,R2
    BLE    wm3
    MOV    R9,R0       ;NG will be 0
wm6 LDR    R1,slpt     ;/SLATE/
    SUB    R9,R0,R9    ;calculate NG
    STMIA  R1,{R6-R9}  ;store ND,NE,NF,NG
    LDMDB  fp,{R6-R9,fp,sp,pc} ;return
slpt DCD    slate__     ;pointer to COMMON/SLATE/
    END
;
    TTL    ICNUMU
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
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
    AREA   slate__,COMMON,NOINIT
    %      160
;
    AREA   |C$$code|,CODE,READONLY
    EXPORT icnumu_;(LINE,JL,JR) finds first non-(alphanumeric or _) in LINE
    DCB    "icnumu_",0,8,0,0,255
icnumu_
    MOV    ip,sp
    STMDB  sp!,{R0-R2,R6-R9,fp,ip,lr,pc}
    SUB    fp,ip,#4
    SUB    R3,R0,#1    ;(LINE(0:0))
    LDR    R0,[R1]     ;JX = JL
    LDR    R2,[R2]     ;JR
    MOV    R6,#0       ;ND
    MOV    R7,#0       ;NE
    MOV    R8,#0       ;NF
    MOV    R9,#0       ;NG
wm2 LDRB   R1,[R3,R0]
    CMP    R1,#" "
    BEQ    wm5         ;blank
    CMP    R1,#"_"
    BEQ    wm3         ;underscore is "alphabetic"
    CMP    R1,#"0"
    BLT    wm6         ; <"0"
    CMP    R1,#"9"
    CMPLE  R7,#0
    MOVLE  R7,R0       ;set NE if 1st numeral
    CMP    R1,#"9"
    BLE    wm4         ;skip the rest if numeral
    CMP    R1,#"A"
    BLT    wm6         ; >"9" AND <"A"
    CMP    R1,#"Z"
    RSBGTS ip,R1,#"a"
    BGT    wm6         ; >"Z" AND <"a"
    CMP    R1,#"z"
    BGT    wm6         ; >"z"
wm3 CMP    R8,#0
    MOVLE  R8,R0       ;set NF for 1st alpabetic
wm4 ADD    R6,R6,#1
wm5 ADD    R0,R0,#1
    CMP    R0,R2
    BLE    wm2
    MOV    R9,R0       ;NG will be 0
wm6 LDR    R1,slpt     ;/SLATE/
    SUB    R9,R0,R9    ;calculate NG
    STMIA  R1,{R6-R9}  ;store ND,NE,NF,NG
    LDMDB  fp,{R6-R9,fp,sp,pc} ;return
slpt DCD    slate__     ;pointer to COMMON/SLATE/
    END
;
    TTL    ICOCTI
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
    AREA   slate__,COMMON,NOINIT
    %      160
;
    AREA   |C$$code|,CODE,READONLY
    EXPORT ncocti_;(CHV) returns integer from octal CHV
    DCB    "ncocti_",0,8,0,0,255
ncocti_
    MOV    ip,sp
    STMDB  sp!,{R0,R1,fp,ip,lr,pc}
    SUB    fp,ip,#4
    MOV    R3,#1       ;first character in chv
    B      ico1
;
    EXPORT icocti_;(LINE,JL,JR) returns integer from octal LINE(JL:JR)
    DCB    "icocti_",0,8,0,0,255
icocti_
    MOV    ip,sp
    STMDB  sp!,{R0-R2,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R3,[R1]     ;initialize NE = JL
    LDR    R1,[R2]     ;JR
ico1 SUB    lr,R0,#1    ;(LINE(0:0))
    MOV    R0,#0       ;accumulator
    MOV    R2,#0       ;initialise ND
wo3 LDRB   ip,[lr,R3]
    CMP    ip,#" "
    BNE    wo5
    ADD    R3,R3,#1
    CMP    R3,R1
    BLE    wo3         ;skip leading blanks
    B      wo6
wo4 LDRB   ip,[lr,R3]
wo5 RSBS   ip,ip,#"7"  ;subtract from "7"
    RSBGES ip,ip,#7    ;check <=7
    ORRGE  R0,ip,R0,LSL#3
    ADDGE  R2,R2,#1
    ADDGE  R3,R3,#1
    CMPGE  R1,R3
    BGE    wo4
wo6 SUB    ip,ip,#" "  ;NG = 0 if blank terminator
    CMP    R3,R1
    MOVGT  ip,#0       ;or number fills string
    LDR    R1,slpt     ;pointer to /SLATE/
    STMIA  R1,{R2,R3}  ;store ND,NE
    STR    ip,[R1,#12] ;store NG
    LDMDB  fp,{fp,sp,pc} ;return
slpt DCD    slate__     ;pointer to COMMON/SLATE/
    END
;
    TTL    ICTYPE
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R1  RN     1
R0  RN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT ictype_;(CHIS) finds the type of a single character
    DCB    "ictype_",0,8,0,0,255
ictype_
    MOV    ip,sp
    STMDB  sp!,{R0,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDRB   R1,[R0]     ;CHIS
    MOV    R0,#0       ;init JX=0
    CMP    R1,#" "
    MOVGE  R0,#1
    CMP    R1,#"0"
    MOVGE  R0,#2       ;numeric
    CMP    R1,#"9"
    MOVGT  R0,#1
    CMP    R1,#"A"
    MOVGE  R0,#4       ;upper case
    CMP    R1,#"Z"
    MOVGT  R0,#1
    CMP    R1,#"a"
    MOVGE  R0,#3       ;lower case
    CMP    R1,#"z"
    MOVGT  R0,#1
    CMP    R1,#127
    MOVGE  R0,#0
    LDMDB  fp,{fp,sp,pc} ;return
    END
;
    TTL    IFROMC
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 ifromc_;(STRING*4) -> packed integer
ifromc_
    MOV    R2,#0        ;accumulator
    MOV    R3,#4        ;count
lp1 SUBS   R1,R1,#1
    LDRGEB ip,[R0],#1
    MOVLT  ip,#" "
    ORR    R2,ip,R2,LSL#8
    SUBS   R3,R3,#1
    BGT    lp1
    MOV    R0,R2
    MOV    pc,lr
    END
;
    TTL    iilz
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT iilz_;(NW,A,INC) => # leading zeros in A(1+I*INC), I=0,NW-1
    DCB    "iilz_",0,0,0,8,0,0,255
iilz_
    MOV    ip,sp
    STMDB  sp!,{R0-R2,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R3,[R0]     ;NW
    LDR    R2,[R2]     ;INC
    MOV    R0,#0       ;count => IILZ
lp1 SUBS   R3,R3,#1
    LDRCS  lr,[R1],R2,LSL#2
    CMPCS  lr,#0
    ADDEQ  R0,R0,#1    ;accumulate count of zeros
    BEQ    lp1
    LDMDB  fp,{fp,sp,pc} 
    END
;
    TTL    ilsum
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT ilsum_;(NW,LA,INC) => # .TRUE. elements in LA(1+I*INC), I=0,NW-1
    DCB    "ilsum_",0,0,8,0,0,255
ilsum_
    MOV    ip,sp
    STMDB  sp!,{R0-R2,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R3,[R0]     ;NW
    LDR    R2,[R2]     ;INC
    MOV    R0,#0       ;count => ILSUM
lp1 SUBS   R3,R3,#1
    LDMLTDB fp,{fp,sp,pc} 
    LDR    lr,[R1],R2,LSL#2
    CMP    lr,#0
    ADDNE  R0,R0,#1    ;accumulate count of truths
    B      lp1
    END
;
    TTL    IMINMAX
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R5  RN     5
R4  RN     4
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
;
    AREA   |C$$code|,CODE,READONLY
    EXPORT lvsimi_;(IA,N,INC) find location of minimum in IA(I) I=1,N*INC,INC
    DCB    "lvsimi_",0,8,0,0,255
lvsimi_
    MOV    ip,sp
    STMDB  sp!,{R0-R2,R4-R5,fp,ip,lr,pc}
    SUB    fp,ip,#4
    MVN   ip,#0
    B     wi1           ;find minimum
;
    EXPORT lvsimx_;(IA,N,INC) find location of maximum in IA(I) I=1,N*INC,INC
    DCB    "lvsimx_",0,8,0,0,255
lvsimx_
    MOV    ip,sp
    STMDB  sp!,{R0-R2,R4-R5,fp,ip,lr,pc}
    SUB    fp,ip,#4
    MOV   ip,#0         ;find maximum
wi1 LDR   R1,[R1]       ;n
    CMP   R1,#0
    MOVLE R0,#0
    LDMLEDB fp,{R4-R5,fp,sp,pc} ;skip if n is 0
    LDR   R2,[R2]       ;inc
    MOV   R3,#&80000000 ;init max value
    SUB   R4,R0,R2,LSL#2;index
wi2 LDR   R5,[R4,R2,LSL#2]!
    EOR   R5,R5,ip      ;min or max
    CMP   R5,R3
    MOVGT R3,R5         ;store max value
    SUBGT lr,R4,R0      ;store index of max
    SUBS  R1,R1,#1
    BGT   wi2           ;loop over values
    MOV   R0,lr,LSR#2
    ADD   R0,R0,#1      ;calculate fortran index
    LDMDB  fp,{R4-R5,fp,sp,pc} ;return
    END
;
    TTL    INCBYT
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
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 incbyt_;(INC,X,JX,MPACK) increments a packed histogram bin
    DCB    "incbyt_",0,8,0,0,255
incbyt_
    MOV    ip,sp
    STMDB  sp!,{R0-R6,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R2,[R2]    ;jx
    SUB    R2,R2,#1   ;jx-1
    LDMIA  R3,{R3-R5} ;nbits,inword,max
    MOV    R6,#-1
    BIC    R6,R6,R6,LSL R3;mask
ws1 SUBS   R2,R2,R4
    ADDGE  R1,R1,#4
    BGE    ws1        ;move to word
    ADD    R2,R2,R4
    MUL    R2,R3,R2   ;pointer to byt
    LDR    lr,[R1]    ;load word
    AND    ip,R6,lr,LSR R2;get byt
    LDR    R4,[R0]    ;inc
    ADD    ip,ip,R4   ;add to byt
    SUBS   R0,ip,R5   ;overflow
    MOVLE  R0,#0      ;no overflow
    MOVGT  ip,R5      ;remainder
    BIC    lr,lr,R6,LSL R2
    ORR    lr,lr,ip,LSL R2
    STR    lr,[R1]    ;replace word
    LDMDB  fp,{R4-R6,fp,sp,pc} ;return
    END
;
    TTL    INDEXA
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT indexa_;(STR) ==> location of first alpabetic character
    DCB    "indexa_",0,8,0,0,255
indexa_
    MOV    ip,sp
    STMDB  sp!,{R0,R1,fp,ip,lr,pc}
    SUB    fp,ip,#4
    MOV    R2,R0       ;save address of str
wi1 LDRB   R3,[R0],#1  ;get character
    CMP    R3,#"a"
    SUBGE  R3,R3,#32   ;convert to "upper case"
    CMP    R3,#"Z"
    RSBLES R3,R3,#"A"  ;check for upper case
    SUBGTS R1,R1,#1
    BGT    wi1         ;loop over str
    CMP    R1,#0
    SUBNE  R0,R0,R2
    MOVEQ  R0,#0
    LDMDB  fp,{fp,sp,pc} ;return
    END
;
    TTL    INDEXB
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R4  RN     4
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT indexb_;(STR,SSTR) ==> location of last ocurrence of SSTR in STR
    DCB    "indexb_",0,8,0,0,255
indexb_
    MOV    ip,sp
    STMDB  sp!,{R0-R4,fp,ip,lr,pc}
    SUB    fp,ip,#4
    SUB    R2,R2,R3     ;extra length of str
    ADD    R2,R0,R2     ;where to start in str
    SUB    R0,R0,#1
wi2 SUB    R4,R3,#1
wi3 LDRB   ip,[R2,R4]
    LDRB   lr,[R1,R4]
    CMP    ip,lr
    BNE    wi5
    SUBS   R4,R4,#1
    BGE    wi3
wi4 SUB    R0,R2,R0
    LDMDB  fp,{R4,fp,sp,pc} ;return
wi5 SUB    R2,R2,#1
    CMP    R2,R0
    BGT    wi2
    B      wi4
    END
;
    TTL    INDEXC
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R5  RN     5
R4  RN     4
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT indexc_;(STR,SSTR) ==> first location where SSTR .NE. STR
    DCB    "indexc_",0,8,0,0,255
indexc_
    MOV    ip,sp
    STMDB  sp!,{R0-R5,fp,ip,lr,pc}
    SUB    fp,ip,#4
    SUB    R2,R2,R3    ;extra length of STR
    ADD    R2,R0,R2
    SUB    R5,R0,#1
wi6 SUB    R4,R3,#1
wi7 LDRB   ip,[R0,R4]  ;get byte from str
    LDRB   lr,[R1,R4]  ;get byte from sstr
    CMP    ip,lr
    BNE    wi8         ;found mismatch
    SUBS   R4,R4,#1
    BGE    wi7         ;loop over sstr
    ADD    R0,R0,#1
    CMP    R0,R2
    BLT    wi6         ;loop over str
    MOV    R0,R5
wi8 SUB    R0,R0,R5    ;correct index
    LDMDB  fp,{R4,R5,fp,sp,pc} ;return
    END
;
    TTL    INDEXN
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT indexn_;(STR) ==> location of first numeric digit in STR
    DCB    "indexn_",0,8,0,0,255
indexn_
    MOV    ip,sp
    STMDB  sp!,{R0,R1,fp,ip,lr,pc}
    SUB    fp,ip,#4
    MOV    R2,R0       ;save address of str
wi9 LDRB   R3,[R0],#1  ;get character
    CMP    R3,#"9"
    RSBLES R3,R3,#"0"  ;check numeral
    SUBGTS R1,R1,#1
    BGT    wi9         ;loop over str
    CMP    R1,#0
    SUBNE  R0,R0,R2
    MOVEQ  R0,#0
    LDMDB  fp,{fp,sp,pc} ;return
    END
;
    TTL    INDEXS
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT indexs_;(STR) ==> location of first non-alphanumeric on STR
    DCB    "indexs_",0,8,0,0,255
indexs_
    MOV    ip,sp
    STMDB  sp!,{R0,R1,fp,ip,lr,pc}
    SUB    fp,ip,#4
    MOV    R2,R0       ;save address of str
wn1 LDRB   R3,[R0],#1  ;get character
    CMP    R3,#"a"
    SUBGE  R3,R3,#32   ;make "upper case"
    CMP    R3,#"Z"
    BGT    wn2         ;> "Z"
    CMP    R3,#"0"
    BLT    wn2         ;< "0"
    CMP    R3,#"A"-1
    RSBLES R3,R3,#"9"+1
    SUBGTS R1,R1,#1
    BGT    wn1         ;loop over str
wn2 SUBNE  R0,R0,R2    ;calculate index
    LDMDB  fp,{fp,sp,pc} ;return
    END
;
    TTL    INDXAC
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT indxac_;(STR) ==> location of first non-alphabetic character in STR
    DCB    "indxac_",0,8,0,0,255
indxac_
    MOV    ip,sp
    STMDB  sp!,{R0,R1,fp,ip,lr,pc}
    SUB    fp,ip,#4
    MOV    R2,R0       ;save address of str
wn3 LDRB   R3,[R0],#1  ;get character
    CMP    R3,#"a"
    SUBGE  R3,R3,#32   ;make "upper case"
    CMP    R3,#"A"-1
    RSBGT  R3,R3,#"Z"+1;GT set if alphabetic
    SUBGTS R1,R1,#1
    BGT    wn3         ;loop over str
    CMP    R1,#0
    SUBNE  R0,R0,R2
    MOVEQ  R0,#0
    LDMDB  fp,{fp,sp,pc} ;return
    END
;
    TTL    INDXBC
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R4  RN     4
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT indxbc_;(STR,SSTR) ==> last location where SSTR .NE. STR
    DCB    "indxbc_",0,8,0,0,255
indxbc_
    MOV    ip,sp
    STMDB  sp!,{R0-R4,fp,ip,lr,pc}
    SUB    fp,ip,#4
    SUB    R2,R2,R3    ;extra length of STR
    ADD    R2,R0,R2
    SUB    R0,R0,#1
wn4 SUB    R4,R3,#1
wn5 LDRB   ip,[R2,R4]  ;char of str
    LDRB   lr,[R1,R4]  ;char of sstr
    CMP    ip,lr
    BNE    wn6
    SUBS   R4,R4,#1    ;chars agree
    BGE    wn5         ;loop over sstr
    SUB    R2,R2,#1
    CMP    R2,R0
    BGT    wn4         ;loop down str
wn6 SUB    R0,R2,R0
    LDMDB  fp,{R4,fp,sp,pc} ;return
    END
;
    TTL    INDXNC
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT indxnc_;(STR) ==> location of first non-numeric character in STR
    DCB    "indxnc_",0,8,0,0,255
indxnc_
    MOV    ip,sp
    STMDB  sp!,{R0,R1,fp,ip,lr,pc}
    SUB    fp,ip,#4
    MOV    R2,R0       ;save address of str
wn7 LDRB   R3,[R0],#1  ;get character
    CMP    R3,#"0"-1
    RSBGTS R3,R3,#"9"+1;GT set if numeric
    SUBGTS R1,R1,#1
    BGT    wn7         ;loop over str
    CMP    R1,#0
    SUBNE  R0,R0,R2
    MOVEQ  R0,#0
    LDMDB  fp,{fp,sp,pc} ;return
    END
;
;          IRNDM see RNDM
;
    TTL    INTARG
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R0  RN     0
F0  FN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT intarg_;(WORD) returns WORD in INTEGER format
    DCB    "intarg_",0,8,0,0,255
intarg_
    MOV    ip,sp
    STMDB  sp!,{R0,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    lr,[R0]     ;word
    MOVS   ip,lr,ASR#23;get exponent & sign
    MVNMIS ip,ip       ;make positive
    LDFNES F0,[R0]
    FIXNEZ R0,F0      ;fix if floating
    MOVEQ  R0,lr       ;just transmit it if integer
    LDMDB  fp,{fp,sp,pc} ;return
    END
;
    TTL    INTRAC
pc  RN    15
lr  RN    14
R0  RN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT intrac_;returns .TRUE. showing session is interactive
intrac_
    MOV    R0,#1   ;.TRUE.
    MOV    pc,lr   ;return
    END
;
    TTL    INTSOR
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   Utils_,CODE,READONLY
    EXPORT intsor_;(IA,N) sorts integer array IA, length N
    DCB    "intsor_",0,8,0,0,255
intsor_
    MOV    ip,sp
    STMDB  sp!,{R0,R1,R4-R6,fp,ip,lr,pc}
    SUB    fp,ip,#4
;          initialise variables
    LDR    R1,[R1]           ;N
    SUB    R1,R1,#1
    ADD    R2,R0,R1,LSL#2    ;R = address of IA(N) (L is address of IA(1))
    MOV    R4,sp             ;pointer to top of stack
;           main loop over sections
wl1 CMP    R2,R0             ;check if range to sort is bigger than 1
    CMPLE  R4,sp             ;or that there are more ranges to sort
    LDMLEDB fp,{R4-R6,fp,sp,pc} ; return if finished
    CMP    R2,R0             ;check if range to sort is bigger than 1
    LDMLEFD sp!,{R0,R2}       ;retrieve new L,R from stack
    MOV    R1,R0             ;I=L
    MOV    R3,R2             ;J=R
    SUB    ip,R2,R0
    MOV    ip,ip,LSR#3       ;M=(R-L)/2
    LDR    ip,[R0,ip,LSL#2]  ;IX = IA(L+M)
wl2 LDR    R5,[R1]           ;IA(I)
    CMP    R5,ip
    ADDLT  R1,R1,#4          ;I=I+1
    BLT    wl2
wl3 LDR    R6,[R3]           ;IA(J)
    CMP    R6,ip
    SUBGT  R3,R3,#4          ;J=J-1
    BGT    wl3
    CMP    R1,R3
    STRLE  R6,[R1],#4
    STRLE  R5,[R3],#-4       ;swop IA(I) with IA(J); I=I+1; J=J-1
    CMPLE  R1,R3
    BLE    wl2
;
    SUB    R5,R2,R1          ;R-I
    SUB    R6,R3,R0          ;J-L
    CMP    R5,R6
    STMLTFD sp!,{R0,R3}       ;store L,J on stack
    MOVLT  R0,R1             ;L=I
    CMPGE  R5,#0
    STMGTFD sp!,{R1,R2}       ;or store I,R on stack
    MOVGE  R2,R3             ;and set R=J
    B      wl1
    END
;
    TTL    ISCAN
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R5  RN     5
R4  RN     4
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT iscan_;(STR,SET) ==> first location in STR of any character in SET
    DCB    "iscan_",0,0,8,0,0,255
iscan_
    MOV    ip,sp
    STMDB  sp!,{R0-R5,fp,ip,lr,pc}
    SUB    fp,ip,#4
    ADD    R4,R2,#1    ;1+ length of str
wn8 SUB    R5,R3,#1    ;length of set -1
    LDRB   ip,[R0],#1  ;character from str
wn9 LDRB   lr,[R1,R5]
    CMP    ip,lr
    BEQ    wna
    SUBS   R5,R5,#1
    BGE    wn9         ;loop over sstr
    SUBS   R2,R2,#1
    BGT    wn8         ;loop over str
    MOV    R2,R4       ;not found, set ans to 0
wna SUB    R0,R4,R2    ;character position in str
    LDMDB  fp,{R4,R5,fp,sp,pc} ;return
    END
;
    TTL    ISHFTC
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT ishftc_;(M,K,IC) returns least sig. IC bits of M rotated left K bits
    DCB    "ishftc_",0,8,0,0,255
ishftc_
    MOV    ip,sp
    STMDB  sp!,{R0-R2,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R0,[R0]        ;M
    LDR    R1,[R1]        ;K
    LDR    R2,[R2]        ;IC
    MOV    R3,#-1
    BIC    R3,R3,R3,LSL R2;mask
    AND    ip,R0,R3       ;active piece of M
    BIC    R0,R0,R3       ;passive piece of M
    CMP    R1,#0          ;check sign
    ADDLT  R1,R2,R1       ;invert if right shift
    AND    R3,R3,ip,LSL R1
    SUBNE  R1,R2,R1
    ORRNE  R3,R3,ip,LSR R1
    ORR    R0,R0,R3       ;restore active piece
    LDMDB  fp,{fp,sp,pc} ;return
    END
;
    TTL    ITOCH
pc  RN    15
lr  RN    14
ip  RN    12
R1  RN     1
R0  RN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT itoch_;(INTGR,CHAR,*label) converts integer to single character
itoch_
    LDR    R0,[R0]    ;INTGR
    CMP    R0,#32     ;check >31
    RSBGES ip,R0,#126 ;and <127
    MOVLT  R0,#"?"    ;output ? if no good
    STRB   R0,[R1]    ;store CHAR
    MOVGE  R0,#0      ;return OK
    MOVLT  R0,#1      ;return bad
    MOV    pc,lr
    END
;
    TTL    IUBACK
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R4  RN     4
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
    AREA   slate__,COMMON,NOINIT
    %      160
;
    AREA   |C$$code|,CODE,READONLY
    EXPORT iuback_;(CH,JL,JR) reads integer from end CH(JL,JR)
    DCB    "iuback_",0,8,0,0,255
iuback_
    MOV    ip,sp
    STMDB  sp!,{R0-R2,R4,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R3,[R2]     ;jr
    LDR    R2,[R1]     ;jl
    MOV    lr,R3       ;JR
    SUB    R1,R0,#4    ;(ch(0))
wg1 LDRB   ip,[R1,lr,LSL#2]
    CMP    ip,#" "
    CMPNE  ip,#"0"     ;compare with "0"
    RSBGES ip,ip,#"9"  ;compare with "9"
    SUBGE  lr,lr,#1    ;non-numeric
    CMPGE  lr,R2
    BGE    wg1
    MOV    R0,#0       ;accumulator
    MOV    R4,#0       ;count of digits
    MOV    R2,lr
wg2 ADD    R2,R2,#1
    CMP    R2,R3
    BGT    fin
    LDRB   ip,[R1,R2,LSL#2]
    CMP    ip,#" "
    BEQ    wg2
    RSBS   ip,ip,#"9"  ;9-digit
    RSBGES ip,ip,#9    ;digit
    ADDGE  R0,R0,R0,LSL#2;multiply by 5
    ADDGE  R0,ip,R0,LSL#1;multiply by 2 & accumulate
    ADDGE  R4,R4,#1    ;count digits
    B      wg2
fin LDR    R1,slpt
    STMIA  R1,{R4,lr}  ;store pointers
    LDMDB  fp,{R4,fp,sp,pc} ;return
slpt DCD    slate__     ;pointer to COMMON/SLATE/
    END
;
    TTL    IUBIN
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R4  RN     4
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
F2  FN     2
F1  FN     1
F0  FN     0
;
    AREA   |C$$code|,CODE,READONLY
    EXPORT iubin_;(X,PAR,SPILL) finds histogram channel
    DCB    "iubin_",0,0,8,0,0,255
iubin_
    MOV    ip,sp
    STMDB  sp!,{R0-R2,R4,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDFS   F1,[R1,#4]        ;DX
    FRDS   F1,F1,#1          ;1/DX
    B      iuh1
;
    EXPORT iuchan_;(X,PAR,SPILL) finds histogram channel
    DCB    "iuchan_",0,8,0,0,255
iuchan_
    MOV    ip,sp
    STMDB  sp!,{R0-R2,R4,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDFS   F1,[R2]           ;DX
    FRDS   F1,F1,#1          ;1/DX
    LDFS   F2,[R1]           ;XLOW
    LDR    R3,[R3]           ;NX
    MOV    R2,#0             ;flag for no spill
    B      iuh2
;
    EXPORT iuhist_;(X,PAR,SPILL) finds histogram channel
    DCB    "iuhist_",0,8,0,0,255
iuhist_
    MOV    ip,sp
    STMDB  sp!,{R0-R2,R4,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDFS   F1,[R1,#4]        ;1/DX
iuh1 LDR    R3,[R1]           ;NX
    LDFS   F2,[R1,#8]        ;XLOW
iuh2 LDFS   F0,[R0]           ;X
    SUFS   F0,F0,F2
    FMLS   F0,F0,F1
    LDFS   F2,eps
    ADFS   F0,F0,F2
    FIXM   R1,F0
    ADDS   R0,R1,#1
    MOVLT  R0,#0             ;set underflow bin
    CMP    R0,R3
    ADDGT  R0,R3,#1          ;set overflow bin
    CMP    R2,#0
    LDMEQDB fp,{R4,fp,sp,pc} ;return if IUCHAN
    MOV    R1,#0
    CMP    R0,#1
    CMPGE  R3,R0
    MOVLT  R1,#1
    STR    R1,[R2]           ;store spill
    LDMDB  fp,{R4,fp,sp,pc}  ;return
eps DCFS   0.00001
    END
;
;       IUCHAN see IUBIN
;
    TTL    IUCOLA
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
;
    AREA   |C$$code|,CODE,READONLY
    EXPORT iucola_;(IT,IVEC,N) finds the last word in IVEC equal to IT
    DCB    "iucola_",0,8,0,0,255
iucola_
    MOV    ip,sp
    STMDB  sp!,{R0-R2,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R3,[R0]     ;IT
    LDR    R0,[R2]     ;N
    CMP    R0,#0
    ADDGT  R1,R1,R0,LSL#2;end of IVEC
la1 LDRGT  R2,[R1,#-4]!
    CMPGT  R2,R3
    SUBNES R0,R0,#1
    BGT    la1
    LDMDB  fp,{fp,sp,pc} ;return
    END
;
    TTL    IUCOMH
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
;
    AREA   |C$$code|,CODE,READONLY
    EXPORT iucomh_;(CH1,CH2,N) compares string 1 with string 2
    DCB    "iucomh_",0,8,0,0,255
iucomh_
    MOV    ip,sp
    STMDB  sp!,{R0-R2,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R2,[R2]   ;N
wi1 LDRB   ip,[R0],#1
    LDRB   R3,[R1],#1
    CMP    ip,R3
    BNE    wi2
    SUBS   R2,R2,#1
    BGT    wi1
    MOVS   R0,#0
wi2 CMPNE  ip,R3
    MOVGT  R0,#1
    MOVLT  R0,#-1
    LDMDB  fp,{fp,sp,pc} ;return
    END
;
    TTL    IUCOMP
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
;
    AREA   |C$$code|,CODE,READONLY
    EXPORT iucomp_;(IT,IVEC,N) finds the first word in IVEC equal to IT
    DCB    "iucomp_",0,8,0,0,255
iucomp_
    MOV    ip,sp
    STMDB  sp!,{R0-R2,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R0,[R0]     ;IT
    LDR    R2,[R2]     ;N
    ADDS   R3,R2,#0    ;copy of N
lu1 LDRGT  ip,[R1],#4
    CMPGT  ip,R0
    SUBNES R2,R2,#1
    BGT    lu1
    SUBS   R2,R2,#1
    MOVLT  R0,#0         ;not found
    SUBGE  R0,R3,R2
    LDMDB  fp,{fp,sp,pc} ;return
    END
;
    TTL    IUEND
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R2  RN     2
R1  RN     1
R0  RN     0
    AREA   slate__,COMMON,NOINIT
    %      160
    AREA   |C$$code|,CODE,READONLY
    EXPORT iuend_;(NDA) returns ND in NDA and NE in IUEND
    DCB    "iuend_",0,0,8,0,0,255
iuend_
    MOV    ip,sp
    STMDB  sp!,{R0,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R1,slpt
    LDR    R2,[R1]       ;ND
    STR    R2,[R0]       ;store in NDA
    LDR    R0,[R1,#4]    ;NE
    LDMDB  fp,{fp,sp,pc} ;return
slpt DCD    slate__
    END
;
    TTL    IUFILA
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
;
    AREA   |C$$code|,CODE,READONLY
    EXPORT iufila_;(IT,IVEC,JL,JR) finds the last word in IVEC(JL,JR) = IT
    DCB    "iufila_",0,8,0,0,255
iufila_
    MOV    ip,sp
    STMDB  sp!,{R0-R3,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    ip,[R0]     ;IT
    LDR    R2,[R2]     ;JL
    LDR    R0,[R3]     ;JR
    ADD    R1,R1,R0,LSL#2;(IVEC(JR+1))
    ADD    R0,R0,#1    ;JR+1
    SUB    lr,R2,#1    ;JL-1
    SUBS   R2,R0,R2    ;length to search
    BLE    la4
la3 LDR    R3,[R1,#-4]!
    CMP    R3,ip
    SUBNES R2,R2,#1
    BNE    la3
    CMP    R3,ip
    ADDEQ  R0,R2,lr    ;found, calculate index
la4 LDMDB  fp,{fp,sp,pc} ;return
    END
;
    TTL    IUFIND
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
;
    AREA   |C$$code|,CODE,READONLY
    EXPORT iufind_;(IT,IVEC,JL,JR) finds the first word in IVEC(JL,JR) = IT
    DCB    "iufind_",0,8,0,0,255
iufind_
    MOV    ip,sp
    STMDB  sp!,{R0-R3,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    ip,[R0]     ;IT
    LDR    R2,[R2]     ;JL
    LDR    R0,[R3]     ;JR
    SUB    R2,R2,#1    ;JL-1
    ADD    R1,R1,R2,LSL#2;(IVEC(JL))
    SUBS   R2,R0,R2    ;length to search
    ADD    R0,R0,#1    ;JR+1
    LDMLEDB fp,{fp,sp,pc} ;skip if JR<JL
lu3 LDR    R3,[R1],#4
    CMP    R3,ip
    SUBNES R2,R2,#1
    BNE    lu3
    SUB    R0,R0,R2    ;calculate index
    LDMDB  fp,{fp,sp,pc} ;return
    END
;
    TTL    IUFNBL
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT iufnbl_;(CH,JL,JR) finds the first non-blank in CH(JL,JR)
    DCB    "iufnbl_",0,8,0,0,255
iufnbl_
    MOV    ip,sp
    STMDB  sp!,{R0-R2,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R3,[R2]     ;jr
    SUB    R2,R0,#4    ;(ch(0))
    LDR    R0,[R1]     ;jx = jl
wn1 CMP    R0,R3
    LDMGTDB fp,{fp,sp,pc} ;no more to check
    LDRB   R1,[R2,R0,LSL#2]
    CMP    R1,#" "
    ADDEQ  R0,R0,#1    ;inc jx
    BEQ    wn1
    LDMDB  fp,{fp,sp,pc} ;return
    END
;
    TTL    IUFORW
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
    AREA   slate__,COMMON,NOINIT
    %      160
;
    AREA   |C$$code|,CODE,READONLY
    EXPORT iuforw_;(CH,JL,JR) reads the integer from beginning of CH(JL,JR)
    DCB    "iuforw_",0,8,0,0,255
iuforw_
    MOV    ip,sp
    STMDB  sp!,{R0-R2,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    lr,[R1]     ;set ne = jl
    MOV    ip,lr       ;initialise nd
    LDR    R2,[R2]     ;jr
    SUB    R1,R0,#4    ;(ch(0))
    MOV    R0,#0       ;accumulator
wf1 LDRB   R3,[R1,lr,LSL#2]
    CMP    R3,#" "
    ADDEQ  ip,ip,#1
    BEQ    wf2
    RSBS   R3,R3,#"9"
    RSBGES R3,R3,#9
    ADDGE  R0,R0,R0,LSL#2;multiply by 5
    ADDGE  R0,R3,R0,LSL#1;multiply by 2 & accumulate
wf2 ADDGE  lr,lr,#1
    CMPGE  R2,lr
    BGE    wf1
    SUB    ip,lr,ip    ;calculate nd
    LDR    R1,slpt
    STMIA  R1,{ip,lr}  ;store pointers
    LDMDB  fp,{fp,sp,pc} ;return
slpt DCD    slate__     ;pointer to COMMON/SLATE/
    END
;
;       IUHIST see IUBIN
;
    TTL    IUHUNT
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
;
    AREA   |C$$code|,CODE,READONLY
    EXPORT iuhunt_;(IT,IVEC,N,INC) finds IT in IVEC(I), I=1,N,INC
    DCB    "iuhunt_",0,8,0,0,255
iuhunt_
    MOV    ip,sp
    STMDB  sp!,{R0-R3,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R0,[R0]     ;IT
    LDR    R2,[R2]     ;N
    LDR    R3,[R3]     ;INC
    ADDS   lr,R2,#0    ;copy of N
lh1 LDRGT  ip,[R1],R3,LSL#2
    CMPGT  ip,R0
    SUBNES R2,R2,R3
    BGT    lh1
    SUBS   R2,R2,#1
    MOVLT  R0,#0       ;not found
    SUBGE  R0,lr,R2
    LDMDB  fp,{fp,sp,pc} ;return
    END
;
    TTL    IULAST
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
;
    AREA   |C$$code|,CODE,READONLY
    EXPORT iulast_;(IT,IVEC,N) finds last word in IVEC not equal to IT
    DCB    "iulast_",0,8,0,0,255
iulast_
    MOV    ip,sp
    STMDB  sp!,{R0-R2,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    ip,[R0]       ;IT
    LDR    R0,[R2]       ;N
    CMP    R0,#0
    MOVLE  R0,#0
    BLE    ll2
    ADD    R1,R1,R0,LSL#2;(IVEC(N+1))
ll1 LDR    R3,[R1,#-4]!
    CMP    R3,ip
    BNE    ll2
    SUBS   R0,R0,#1
    BNE    ll1
ll2 LDMDB  fp,{fp,sp,pc} ;return
    END
;
    TTL    IULOOK
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT iulook_;(N,CH,JL,JR) returns first N characters of CH(JL,JR) as nH
    DCB    "iulook_",0,8,0,0,255
iulook_
    MOV    ip,sp
    STMDB  sp!,{R0-R3,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    ip,[R0]     ;n
    CMP    ip,#4
    MOVGT  ip,#4       ;limit n to 4
    LDR    R2,[R2]     ;jl
    SUB    R2,R2,#1    ;jl-1
    ADD    R1,R1,R2,LSL#2;(ch(jl))
    LDR    R3,[R3]     ;jr
    SUB    R3,R3,R2    ;count
    LDR    R0,blnk     ;initialise answer
wk1 LDRB   R2,[R1],#4
    CMP    R2,#" "
    ORRNE  R0,R2,R0,LSL#8;insert byte
    SUBNE  ip,ip,#1    ;count bytes stored
    SUBS   R3,R3,#1    ;check for more input
    CMPGT  ip,#0       ;check for more output
    BGT    wk1         ;loop over ch
    MOV    ip,ip,LSL#3
    MOV    R0,R0,ROR ip
    LDMDB  fp,{fp,sp,pc} ;return
blnk DCB    "    "
    END
;
    TTL    IUMODE
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R0  RN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT iumode_;(WORD) returns 0 for integer, nonzero otherwise
    DCB    "iumode_",0,8,0,0,255
iumode_
    MOV    ip,sp
    STMDB  sp!,{R0,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R0,[R0]     ;word
    MOVS   R0,R0,ASR#23;get exponent & sign
    MVNMIS R0,R0       ;make positive
    MOVNE  R0,#1       ;return 1 for floating
    LDMDB  fp,{fp,sp,pc} ;return
    END
;
    TTL    IUNEXT
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
;
    AREA   |C$$code|,CODE,READONLY
    EXPORT iunext_;(CH,JL) returns the first entry in CH(JL...) not blank
    DCB    "iunext_",0,8,0,0,255
iunext_
    MOV    ip,sp
    STMDB  sp!,{R0-R2,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R1,[R1]        ;JL
    SUB    R0,R0,#4       ;(CH(0))
    LDR    R2,blnk        ;blank word for test
lp1 LDR    R3,[R0,R1,LSL#2]
    CMP    R3,R2
    ADDEQ  R1,R1,#1
    BEQ    lp1
    MOV    R0,R1
    LDMDB  fp,{fp,sp,pc}  ;return
blnk DCB    "    "
    END
;
    TTL    IUSAME
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
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 iusame_;(VECT,JL,JR,MIN,JSAME) finds set of identical words
    DCB    "iusame_",0,8,0,0,255
iusame_
    MOV    ip,sp
    STMDB  sp!,{R0-R6,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    ip,[ip]     ;address of JSAME
    LDR    R1,[R1]     ;JL
    LDR    R2,[R2]     ;JR
    LDR    R3,[R3]     ;MIN
    SUB    R4,R0,#4    ;(VECT(0))
    LDR    R6,[R4,R1,LSL#2]; get 1st
ws1 MOV    R0,#1       ;count of identical words
    MOV    R5,R6       ;word for comparison
    MOV    lr,R1       ;index of 1st word of string
ws2 CMP    R1,R2
    BGE    ws3         ;end of VECT
    ADD    R1,R1,#1
    LDR    R6,[R4,R1,LSL#2]; get next word
    CMP    R5,R6
    ADDEQ  R0,R0,#1    ;count identical words
    BEQ    ws2         ;try next word
ws3 CMP    R0,R3       ;check if long enough
    CMPLT  R1,R2       ;if not, is vect finished
    BLT    ws1         ;neither, try again
    CMP    R0,R3       ;finished, is string long enough
    MOVLT  R0,#0       ;no, set ans = 0
    ADDLT  lr,R2,#1    ;set JSAME to JR + 1
    STR    lr,[ip]     ;store JSAME
    LDMDB  fp,{R4-R6,fp,sp,pc} ;return
    END
;
    TTL    JBIT
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R1  RN     1
R0  RN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT jbit_;(IW,J) gets bit J from IW (l.s. is bit 1)
    DCB    "jbit_",0,0,0,8,0,0,255
jbit_
    MOV    ip,sp
    STMDB  sp!,{R0,R1,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R0,[R0]     ;IW
    LDR    R1,[R1]     ;J
    MOV    R0,R0,ROR R1
    MOV    R0,R0,LSR#31
    LDMDB  fp,{fp,sp,pc} ;return
    END
;
    TTL    JBYT
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT jbyt_;(IW,J,NBITS) gets byte length NBITS from IW (l.s. is bit 1)
    DCB    "jbyt_",0,0,0,8,0,0,255
jbyt_
    MOV    ip,sp
    STMDB  sp!,{R0-R2,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R0,[R0]     ;IW
    LDR    R1,[R1]     ;J
    LDR    R2,[R2]     ;NBITS
    SUBS   R1,R1,#1    ;J-1
    MOV    R3,#-1
    MOVGE  R0,R0,LSR R1;shift IW down j-1
    BICGE  R0,R0,R3,LSL R2 ;mask off byt
    LDMDB  fp,{fp,sp,pc} ;return
    END
;
    TTL    JBYTET
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT jbytet_;(IA,IW,J,NBITS) => AND of IA and byte J of IW
    DCB    "jbytet_",0,8,0,0,255
jbytet_
    MOV    ip,sp
    STMDB  sp!,{R0-R3,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R0,[R0]     ;IA
    LDR    R1,[R1]     ;IW
    LDR    R2,[R2]     ;J
    LDR    R3,[R3]     ;NBITS
    MOV    ip,#-1
    SUBS   R2,R2,#1    ;J-1
    ANDGE  R0,R0,R1,LSR R2
    BIC    R0,R0,ip,LSL R3
    LDMDB  fp,{fp,sp,pc} ;return
    END
;
    TTL    JBYTOR
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT jbytor_;(IA,IW,J,NBITS) => OR of IA and byte J of IW
    DCB    "jbytor_",0,8,0,0,255
jbytor_
    MOV    ip,sp
    STMDB  sp!,{R0-R3,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R0,[R0]     ;IA
    LDR    R1,[R1]     ;IW
    LDR    R2,[R2]     ;J
    LDR    R3,[R3]     ;NBITS
    MOV    ip,#-1
    BIC    ip,ip,ip,LSL R3;mask
    SUBS   R2,R2,#1    ;J-1
    ANDGE  R1,ip,R1,LSR R2
    ORRGE  R0,R0,R1
    LDMDB  fp,{fp,sp,pc} ;return
    END
;
    TTL    JBYTPK
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT jbytpk_;(MA,JA,MPACK) => byte JA of packed vector MA
    DCB    "jbytpk_",0,8,0,0,255
jbytpk_
    MOV    ip,sp
    STMDB  sp!,{R0-R2,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R1,[R1]    ;ja
    SUB    R1,R1,#1   ;ja-1
    LDMIA  R2,{R2,R3} ;get nbits,inword
    CMP    R2,#0      ;check for default
    MOVLE  R2,#1      ;default nbits=1
    MOVLE  R3,#32     ;and inword=32
wj1 SUBS   R1,R1,R3
    ADDGE  R0,R0,#4
    BGE    wj1        ;move to word
    ADD    R1,R1,R3
    MUL    R1,R2,R1   ;pointer to byte
    LDR    R0,[R0]    ;get word
    MOV    R0,R0,LSR R1
    MOV    R1,#-1
    BIC    R0,R0,R1,LSL R2
    LDMDB  fp,{fp,sp,pc} ;return
    END
;
    TTL    JRSBYT
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT jrsbyt_;(IA,IX,J,NBITS) => byte J of IX, replaces byte J by IA
    DCB    "jrsbyt_",0,8,0,0,255
jrsbyt_
    MOV    ip,sp
    STMDB  sp!,{R0-R3,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    ip,[R0]     ;IA
    LDR    R0,[R1]     ;IX
    LDR    R2,[R2]     ;J
    LDR    R3,[R3]     ;NBITS
    MOV    lr,#-1
    BIC    lr,lr,lr,LSL R3;mask
    AND    ip,ip,lr    ;byt of IA
    SUBS   R2,R2,#1    ;J-1
    BICGE  R3,R0,lr,LSL R2 ;mask byt
    ORRGE  R3,R3,ip,LSL R2 ;insert byt
    ANDGE  R0,lr,R0,LSR R2 ;get byt of IX
    STR    R3,[R1]     ;store IX
    LDMDB  fp,{fp,sp,pc} ;return
    END
;
    TTL    JUMP
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R0  RN     0
    AREA   ext_add,DATA
    %      4
    AREA   |C$$code|,CODE,READONLY
    EXPORT jumpad_;(TARGET) return address of EXTERNAL routine
jumpad_
    MOV    pc,lr    ;address of target is required answer
;
    EXPORT jumpst_;(IAD) save address of EXTERNAL routine
jumpst_
    LDR    ip,ptr
    LDR    R0,[R0]  ;IAD
    STR    R0,[ip]  ;save it
    MOV    pc,lr
;
    EXPORT jumpx0_;transfer control to the routine defined by JUMPST
    EXPORT jumpx1_;(P1) transfer control with 1 argument
    EXPORT jumpx2_;(P1,P2) transfer control with 2 arguments
jumpx0_
jumpx1_
jumpx2_
    LDR    ip,ptr   ;get transfer address
    LDR    pc,[ip]  ;transfer control
ptr DCD    ext_add
    END
;
    TTL    LENOCC
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT lenocc_;(TXT) faster than LNBLNK for many blanks
    DCB    "lenocc_",0,8,0,0,255
lenocc_
    MOV    ip,sp
    STMDB  sp!,{R0,R1,fp,ip,lr,pc}
    SUB    fp,ip,#4
    ADD    R3,R0,R1    ;end of TXT
    MOV    R0,R1       ;answer in R0
wl1 LDRB   R1,[R3,#-1]!;search byte-by-byte
    CMP    R1,#" "
    LDMNEDB fp,{fp,sp,pc} ;return if not blank
    SUBS   R0,R0,#1
    LDMEQDB fp,{fp,sp,pc} ;return if all blank
    TST    R3,#3
    BNE    wl1
    LDR    R2,blnk
wl2 LDR    R1,[R3,#-4]!;search word-by-word
    EORS   R1,R2,R1
    BNE    wl3
    SUBS   R0,R0,#4
    BGT    wl2
    MOV    R0,#0
    LDMDB  fp,{fp,sp,pc} ;all blank
wl3 TST    R1,#&FF000000
    LDMNEDB fp,{fp,sp,pc} ;return
    MOV    R1,R1,LSL#8
    SUBS   R0,R0,#1
    BGT    wl3
    LDMDB  fp,{fp,sp,pc} ;return
blnk DCB    "    "
    END
;
    TTL   llsq
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
R4  RN     4
R5  RN     5
F0  FN     0
F1  FN     1
F2  FN     2
F3  FN     3
F4  FN     4
F5  FN     5
IDIM   EQU 20; maximum degree of polynomial
;
    AREA   |C$$code|,CODE,READONLY
    EXPORT llsq_;(N,X,Y,A0,A1,IFAIL) least squares fit to a straight line
    DCB    "llsq_",0,0,0,8,0,0,255
llsq_
    MOV    ip,sp
    STMDB  sp!,{R0-R5,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDMIB  fp,{R4,R5}  ;(A1),(IFAIL)
    LDR    R0,[R0]     ;N
    CMP    R0,#2
    MOVLT  ip,#-2
    BLT    err
    STFE   F4,[sp,#-12]!;save F4
    STFE   F5,[sp,#-12]!;save F5
    MVFD   F2,#0        ;XBAR = 0
    MVFD   F3,#0        ;YBAR = 0
    MOV    ip,R0        ;I-count (N)
lp1 LDFS   F0,[R1],#4   ;X(I)
    LDFS   F1,[R2],#4   ;Y(I)
    ADFD   F2,F2,F0
    ADFD   F3,F3,F1
    SUBS   ip,ip,#1
    BGT    lp1          ;sum X and Y
    FLTD   F0,R0        ;DBLE(N)
    MVFD   F4,#0        ;SXX=0
    MVFD   F5,#0        ;SXY=0
    DVFD   F2,F2,F0     ;XBAR
    DVFD   F3,F3,F0     ;YBAR
    MOV    ip,R0        ;I-count (N)
lp2 LDFS   F0,[R1,#-4]! ;X(I)
    LDFS   F1,[R2,#-4]! ;Y(I)
    SUFD   F0,F0,F2     ;XI
    SUFD   F1,F1,F3     ;YI
    MUFD   F1,F0,F1     ;XI*YI
    MUFD   F0,F0,F0     ;XI**2
    ADFD   F5,F5,F1     ;SXY = SXY + X*Y
    ADFD   F4,F4,F0     ;SXX = SXX + X*X
    SUBS   ip,ip,#1
    BGT    lp2          ;sum X*X and X*Y
    CMF    F4,#0
    DVFGTD F5,F5,F4     ;SXY/SXX
    MOVLE  ip,#-1       ;error, all x's the same
    MUFGTD F0,F5,F2
    STFGTS F5,[R4]      ;store A1 = SXY/SXX
    SUFGTD F1,F3,F0
    STFGTS F1,[R3]      ;store A0 = YBAR - XBAR*A1
er1 LDFE   F5,[sp],#12  ;restore F5
    LDFE   F4,[sp],#12  ;restore F4
err STR    ip,[R5]     ;store error
    LDMDB  fp,{R4-R5,fp,sp,pc} ;return
    END
;
    TTL    LNBLNK
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R2  RN     2
R1  RN     1
R0  RN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT lnblnk_;(CHV) find last non-blank in CHV
    DCB    "lnblnk_",0,8,0,0,255
lnblnk_
    MOV    ip,sp
    STMDB  sp!,{R0,R1,fp,ip,lr,pc}
    SUB    fp,ip,#4
    SUB    R0,R0,#1    ;(chv(0:0))
wk1 LDRB   R2,[R0,R1]
    CMP    R2,#" "
    BNE    wk2
    SUBS   R1,R1,#1
    BGT    wk1
wk2 MOV    R0,R1
    LDMDB  fp,{fp,sp,pc} ;return
    END
;
    TTL    LOCATD
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
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 locatd_;(D,N,T) finds where T lies in momotonic real*8 array D
    DCB    "locatd_",0,8,0,0,255
locatd_
    MOV    ip,sp
    STMDB  sp!,{R0-R2,R4-R6,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDMIA  R2,{R2,R3}  ;T
    MOV    ip,R2,ASR#31
    EOR    R2,R2,ip,LSR#1;fiddle negative floating point
    EOR    R3,R3,ip
    LDR    R1,[R1]     ;N
    SUB    R4,R0,#8    ;(D(0))
    MOV    R5,#0       ;below the array
    ADD    R1,R1,#1    ;above the array
lc2 ADD    R0,R1,R5
    MOV    R0,R0,LSR#1 ;middle
    ADD    lr,R4,R0,LSL#3
    LDMIA  lr,{R6,lr}  ;value at middle
    EOR    R6,R6,ip,LSR#1
    EOR    lr,lr,ip
    CMP    R2,R6       ;compare T with value
    BEQ    ptz
    MOVGT  R5,R0       ;too big, move up low
    MOVLT  R1,R0       ;too small, move down high
lc3 SUB    lr,R1,R5
    CMP    lr,#1       ;are there values left?
    BGT    lc2         ;yes
    RSB    R0,R5,#0    ;no, set answer negative
    LDMDB  fp,{R4-R6,fp,sp,pc} ;return
ptz CMP    R3,lr       ;l.s. word is unsigned
    LDMEQDB fp,{R4-R6,fp,sp,pc} ;equal, so return
    MOVHI  R5,R0
    MOVLO  R1,R0
    B      lc3
    END
;
;          LOCATF see LOCATI
;
    TTL    LOCATI
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R4  RN     4
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT locatf_;(A,N,T) finds where T lies in momotonic array A
    EXPORT locatr_;(A,N,T) finds where T lies in momotonic array A
    DCB    "locatr_",0,8,0,0,255
locatf_
locatr_
    MOV    ip,sp
    STMDB  sp!,{R0-R2,R4,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R2,[R2]     ;T
    MOV    ip,R2,ASR#31
    EOR    R2,R2,ip,LSR#1;fiddle negative floating point
    B      lc1
;
    EXPORT locati_;(IA,N,IT) finds where IT lies in momotonic array IA
    DCB    "locati_",0,8,0,0,255
locati_
    MOV    ip,sp
    STMDB  sp!,{R0-R2,R4,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R2,[R2]     ;IT
    MOV    ip,#0       ;no sign bit mask
lc1 LDR    R1,[R1]     ;N
    SUB    R3,R0,#4    ;(IA(0))
    MOV    R4,#0       ;below the array
    ADD    R1,R1,#1    ;above the array
lc2 ADD    R0,R1,R4
    MOV    R0,R0,LSR#1 ;middle
    LDR    lr,[R3,R0,LSL#2];value at middle
    EOR    lr,lr,ip,LSR#1
    CMP    R2,lr       ;compare IT with value
    LDMEQDB fp,{R4,fp,sp,pc} ;equal, so return
    MOVGT  R4,R0       ;too big, move up low
    MOVLT  R1,R0       ;too small, move down high
    SUB    lr,R1,R4
    CMP    lr,#1       ;are there values left?
    BGT    lc2         ;yes
    RSB    R0,R4,#0    ;no, set answer negative
    LDMDB  fp,{R4,fp,sp,pc} ;return
    END
;
;          LOCATR see LOCATI
;
    TTL    LOCBYT
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
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 locbyt_;(IT,VECT,N,INC,L,NBITS) => index of word containing byte
    DCB    "locbyt_",0,8,0,0,255
locbyt_
    MOV    ip,sp
    STMDB  sp!,{R0-R6,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDMIB  fp,{R4,R5} ;get argument addresses
    LDR    lr,[R0]    ;it
    LDR    R2,[R2]    ;n
    LDR    R3,[R3]    ;inc
    LDR    R4,[R4]    ;l
    SUB    R4,R4,#1   ;l-1
    LDR    R5,[R5]    ;nbits
    SUB    R1,R1,#4   ;(vect(0))
    MOV    R6,#-1
    BIC    R6,R6,R6,LSL R5;mask
    RSB    R0,R3,#1   ;initialise j to 1-inc
wl1 ADD    R0,R0,R3   ;j=j+inc
    CMP    R0,R2
    MOVGT  R0,#0
    BGT    wl2        ;finished if j>n
    LDR    ip,[R1,R0,LSL#2]
    AND    ip,R6,ip,LSR R4
    CMP    ip,lr
    BNE    wl1        ;loop if not found
wl2 LDMDB  fp,{R4-R6,fp,sp,pc} ;return
    END
;
    TTL    LOCB
pc  RN    15
lr  RN    14
R0  RN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT locb_;(X) gets address of X
locb_
    MOV    pc,lr
    END
;
    TTL    LOCF
pc  RN    15
lr  RN    14
R0  RN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT locf_;(X) gets 4-byte address of X
locf_
    MOV    R0,R0,LSR#2 ;divide byte address by 4
    MOV    pc,lr
    END
;
    TTL   LOREN
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
F0  FN     0
F1  FN     1
F2  FN     2
F3  FN     3
F4  FN     4
F5  FN     5
R0  RN     0
R1  RN     1
R2  RN     2
R3  RN     3
    AREA   |C$$code|,CODE,READONLY
    EXPORT lorenf_ ;(U,PS,PI,PF) Lorentz transform PI to PS frame -> PF
    EXPORT lorenb_ ;(U,PS,PI,PF) Lorentz transform PI from PS frame -> PF
    EXPORT loren4_ ;(PS,PI,PF) Lorentz transform PI to PS frame -> PF
;
    DCB    "loren4_",0,8,0,0,255
loren4_
    MOV    ip,sp
    STMDB  sp!,{R0-R2,fp,ip,lr,pc}
    SUB    fp,ip,#4
;        calculate the mass of PS
    LDMIA  sp,{R1-R3}   ;addresses of PS,PI,PF
    LDFS   F0,[R1]      ;PSx
    LDFS   F1,[R1,#4]   ;PSy
    LDFS   F2,[R1,#8]   ;PSz
    MUFD   F0,F0,F0     ;PSx**2
    MUFD   F1,F1,F1     ;PSy**2
    MUFD   F2,F2,F2     ;PSz**2
    ADFD   F0,F0,F1
    ADFD   F0,F0,F2     ;PS(3-vect)**2
    LDFS   F1,[R1,#12]  ;PSe
    CMF    F0,#0        ;check for at rest
    BLE    p17
    MUFE   F3,F1,F1     ;PSe**2
    SUFE   F3,F3,F0     ;M**2
    MVFS   F2,F1        ;save PS(4)
    CMF    F3,#0
    SQTGTD F1,F3        ;M
    MVFLED F1,#0        ;set M=0 if imaginary
    LDFS   F0,[R2,#12]
    MNFS   F0,F0        ;PI4=-PI(4)
    B      ln2
p17;     PS is at rest so just transfer PI to PF
    LDMIA  R2,{R0,R1,ip,lr}
    STMIA  R3,{R0,R1,ip,lr}
    LDMDB  fp,{fp,sp,pc} ;return
;
    DCB    "lorenb_",0,8,0,0,255
lorenb_
    MOV    ip,sp
    STMDB  sp!,{R0-R3,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDFS   F0,[R2,#12]   ;PI4=+PI(4)
    B      ln1
;
    DCB    "lorenf_",0,8,0,0,255
lorenf_
    MOV    ip,sp
    STMDB  sp!,{R0-R3,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDFS   F0,[R2,#12]   ;PI(4)
    MNFS   F0,F0         ;PI4=-PI(4)
ln1;    check if at rest
    LDFS   F1,[R0]       ;U
    LDFS   F2,[R1,#12]   ;PS(4)
    CMF    F1,F2         ;check the mass with the energy
    BGE    p17           ;not smaller, -> at rest
ln2;    now start real work with PI4 in F0, M in F1, PS(4) in F2
    STFE   F4,[sp,#-12]! ;save registers
    STFE   F5,[sp,#-12]!
    MUFD   F3,F2,F0      ;PS(4)*PI4
    ADFD   F2,F2,F1      ;M+PS(4)
    LDFS   F4,[R2,#8]
    LDFS   F5,[R1,#8]
    MUFD   F5,F5,F4      ;PI(3)*PS(3)
    LDFS   F4,[R2,#4]
    ADFD   F3,F3,F5      ;PS(4)*PI4+PI(3)*PS(3)
    LDFS   F5,[R1,#4]
    MUFD   F5,F5,F4      ;PI(2)*PS(2)
    LDFS   F4,[R2]
    ADFD   F3,F3,F5      ;PS(4)*PI4+PI(3)*PS(3)+PI(2)*PS(2)
    LDFS   F5,[R1]
    MUFD   F5,F5,F4      ;PI(1)*PS(1)
    ADFD   F3,F3,F5      ;PS(4)*PI4+PI(3)*PS(3)+PI(2)*PS(2)+PI(1)*PS(1)
    DVFD   F3,F3,F1      ;PF4=(PS(4)*PI4+PI(3)*PS(3)+PI(2)*PS(2)+PI(1)*PS(1))/M
    ADFD   F0,F0,F3      ;PI4+PF4
    DVFD   F0,F0,F2      ;FN=(PI4+PF4)/(PS(4)+M)
    MOV    ip,#3
ln3 LDFS   F4,[R1],#4    ;PS(I)
    LDFS   F5,[R2],#4    ;PI(I)
    MUFD   F4,F4,F0
    ADFD   F5,F5,F4
    STFS   F5,[R3],#4    ;PF(I)=PI(I)+FN*PS(I)
    SUBS   ip,ip,#1
    BGT    ln3           ;loop over I=1,3
    ABSS   F3,F3
    STFS   F3,[R3]       ;PF(4)=PF4
    LDFE   F5,[sp],#12   ;restore registers
    LDFE   F4,[sp],#12
    LDMDB  fp,{fp,sp,pc} ;return
    END
;
;          LORENB see LOREN4
;          LORENF see LOREN4
;
    TTL   lsq
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
R4  RN     4
R5  RN     5
R6  RN     6
R7  RN     7
R8  RN     8
R9  RN     9
F0  FN     0
F1  FN     1
F2  FN     2
F3  FN     3
F4  FN     4
F5  FN     5
F6  FN     6
F7  FN     7
IDIM   EQU 20; maximum degree of polynomial
;
    AREA   |C$$code|,CODE,READONLY
    EXPORT lsq_;(N,X,Y,M,A) least squares fit to a polynomial
    IMPORT __rt_stkovf_split_big
    IMPORT llsq_; linear least squares fit
    IMPORT dseqn_; solution of symmetric D.P. linear equations
    DCB    "lsq_",0,0,0,0,8,0,0,255
lsq_
    MOV    ip,sp
    STMDB  sp!,{R0-R9,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R3,[R3]     ;M
    CMP    R3,#2
    LDRNE  R0,[R0]     ;N
    LDRLE  R4,[fp,#4]  ;(A)
    BGE    pt1
;       just find mean y
    CMP    R3,#0
    CMPGT  R0,#0
    BLE    err         ;must have 1 value to 'fit' and some points
    FLTD   F3,R0       ;DFLOAT(N)
    MVFD   F2,#0       ;SUM = 0
lp1 LDFS   F0,[R2],#4  ;Y(I)
    SUBS   R0,R0,#1
    ADFD   F2,F2,F0    ;sum Y
    BGT    lp1
    DVFD   F0,F2,F3
    STFS   F0,[R4]     ;store |Y| in A(1)
    LDMDB  fp,{R4-R9,fp,sp,pc} ;return
;
pt1 BGT    pt2
    MOV    R3,R4
    ADD    R4,R4,#4    ;(A(2))
    SUB    sp,sp,#4    ;space for IFAIL
    MOV    R5,sp       ;(IFAIL)
    STMFD  sp!,{R4,R5} ;last 2 args on stack
    BL     llsq_       ;CALL LLSQ(N,X,Y,A(1),A(2),IFAIL)
    LDR    R0,[sp,#8]  ;IFAIL
    CMP    R0,#0
    BNE    err         ;error if IFAIL.NE.0
    LDMDB  fp,{R4-R9,fp,sp,pc} ;return
;
pt2 CMP    R3,#IDIM
    CMPLE  R3,R0
    BGT    err          ;error if M>IDIM or M>N
    MLA    R4,R3,R3,R3  ;M*M + M  (temporary space for DP words)
    SUB    ip,sp,R4,LSL#3;subtract space for D.P. words and
    SUB    ip,ip,#48    ;space for saving floating registers
    CMP    ip,sl
    BLLT   __rt_stkovf_split_big
    MOV    ip,#0
    MOV    lr,#0
lp2 STMFD  sp!,{ip,lr}  ;zero working space
    SUBS   R4,R4,#1
    BGT    lp2
    ADD    R4,sp,R3,LSL#3;(B)
    STFE   F4,[sp,#-12]!;save F4
    STFE   F5,[sp,#-12]!;save F5
    STFE   F6,[sp,#-12]!;save F6
    STFE   F7,[sp,#-12]!;save F7
    FLTD   F3,R0        ;DFLOAT(N)
    STFD   F3,[R4]      ;B(1,1) = N
    MVFD   F4,#0        ;XBAR=0
    MVFD   F5,#0        ;YBAR=0
    MOV    ip,R0        ;K-count (N)
lp3 LDFS   F0,[R1],#4   ;X(K)
    LDFS   F1,[R2],#4   ;Y(K)
    ADFD   F4,F4,F0
    ADFD   F5,F5,F1
    SUBS   ip,ip,#1
    BGT    lp3
    DVFD   F4,F4,F3     ;XBAR
    DVFD   F5,F5,F3     ;YBAR
    MOV    ip,R0        ;K-count (N)
lp4 LDFS   F0,[R1,#-4]! ;X(K)
    ADD    R5,sp,#48    ;(DA(1))
    LDFS   F1,[R2,#-4]! ;Y(K)
    LDFD   F3,[R5]      ;DA(1)
    SUFD   F0,F0,F4     ;XK = X(K)-XBAR
    SUFD   F1,F1,F5     ;YK = Y(K)-YBAR
    MVFD   F2,#1        ;POWER = 1
    ADFD   F3,F3,F1
    STFD   F3,[R5]      ;DA(1) = DA(1) + YK
    MOV    R6,R4        ;(B(1,1))
    SUB    lr,R3,#1     ;L-count (2,M)
lp5 MUFD   F2,F2,F0     ;POWER = POWER * XK
    LDFD   F6,[R6,#8]!  ;B(L,1)
    LDFD   F7,[R5,#8]!  ;DA(L)
    MUFD   F3,F2,F1     ;POWER*YK
    ADFD   F6,F6,F2
    ADFD   F7,F7,F3
    STFD   F6,[R6]      ;B(L,1) = B(L,1) + POWER
    STFD   F7,[R5]      ;DA(L) = DA(L) + POWER*YK
    SUBS   lr,lr,#1
    BGT    lp5          ;loop over L=2,M
    SUB    lr,R3,#1     ;L-count (2,M)
lp6 MUFD   F2,F2,F0     ;POWER = POWER * XK
    ADD    R6,R6,R3,LSL#3;(B(M,L))
    LDFD   F3,[R6]      ;B(M,L)
    ADFD   F3,F3,F2
    SUBS   lr,lr,#1
    STFD   F3,[R6]      ;B(M,L) = B(M,L) + POWER
    BGT    lp6          ;loop over L=2,M
    SUBS   ip,ip,#1
    BGT    lp4          ;loop over data points (K=1,N)
    SUB    R5,R3,#2     ;I count (3,M)
    ADD    R7,R4,#8     ;(B(I-1,I-2)), I=3
lp7 MOV    R6,R5        ;K count (I,M)
    ADD    R9,R7,R3,LSL#3;(B(K-1,I-1)), K=I
    ADD    R7,R7,#8     ;(B(I,I-2))
    MOV    R8,R7        ;(B(K,I-2)), K=I
lp8 LDMIA  R8!,{ip,lr}
    STMIA  R9!,{ip,lr}  ;B(K-1,I-1) = B(K,I-2)
    SUBS   R6,R6,#1
    BGT    lp8          ;loop over K
    SUBS   R5,R5,#1
    ADD    R7,R7,R3,LSL#3;(B(I,I-1))
    BGT    lp7          ;loop over I
    LDR    R0,[fp,#-40] ;(M)
    MOV    R1,R4        ;(B)
    MOV    R2,R0        ;(IDIM) = (M)
    SUB    sp,sp,#4     ;space for IFAIL
    MOV    R3,sp        ;(IFAIL)
    ADR    R4,ONE       ;(1)
    ADD    R5,sp,#52    ;(DA)
    STMFD  sp!,{R4,R5}  ;args 5 and 6
    BL     dseqn_       ;CALL DSEQN(M,B,IDIM,IFAIL,1,DA)
    ADD    sp,sp,#8     ;restore stack
    LDR    R0,[sp],#4   ;IFAIL
    CMP    R0,#0
    BNE    er1
    MNFD   F4,F4        ;-XBAR
    LDR    R3,[fp,#-40] ;(M)
    LDR    R4,[fp,#4]   ;(A)
    LDR    R3,[R3]      ;M
    MOV    R1,R3        ;I-count (1,M)
lp9 LDFD   F0,[R5],#8   ;XK = DA(I)
    SUBS   R2,R1,#1     ;J-count (I+1,M)
    BLE    pt3
    MVFD   F1,#1        ;POWER = 1.0
    MOV    ip,R5        ;(DA(J)), J=I+1
lpa MUFD   F1,F1,F4     ;POWER = POWER * XBAR
    SUB    R0,R3,R2     ;J-1
    SUB    R6,R1,R2     ;J-I
    FLTD   F2,R0        ;DBLE(J-1)
    FLTD   F3,R6        ;DBLE(J-I)
    MUFD   F1,F1,F2     ;POWER = POWER * (J-1)
    LDFD   F6,[ip],#8   ;DA(J)
    DVFD   F1,F1,F3     ;POWER = POWER / (J-I)
    MUFD   F6,F6,F1
    ADFD   F0,F0,F6     ;XK = XK + DA(J)*POWER
    SUBS   R2,R2,#1
    BGT    lpa          ;loop over J=I+1,M
    CMP    R1,R3
    ADFEQD F0,F0,F5     ;add YBAR to A(1)
pt3 STFS   F0,[R4],#4   ;store A(I)
    SUBS   R1,R1,#1
    BGT    lp9          ;loop over I=1,M
er1 LDFE   F7,[sp],#12 ;restore F7
    LDFE   F6,[sp],#12 ;restore F6
    LDFE   F5,[sp],#12 ;restore F5
    LDFE   F4,[sp],#12 ;restore F4
    LDMEQDB fp,{R4-R9,fp,sp,pc} ;return if no error
err;   found error
    LDR    R3,[fp,#-40];(M)
    MOV    R0,#0
    STR    R0,[R3]     ;M=0
    LDMDB  fp,{R4-R9,fp,sp,pc} ;return
ONE DCD    1
    END
;
;          LVMAX see VMINMAX
;          LVMAXA see VMINMAX
;          LVMIN see VMINMAX
;          LVMINA see VMINMAX
;          LVSDMI see DMINMAX
;          LVSDMX see DMINMAX
;          LVSIMI see DMINMAX
;          LVSIMX see DMINMAX
;          LVSMI see VMINMAX
;          LVSMX see VMINMAX
;
    TTL    MBYTET
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT mbytet_;(IA,IW,J,NBITS) => IW AND IA shifted to byte at J
    DCB    "mbytet_",0,8,0,0,255
mbytet_
    MOV    ip,sp
    STMDB  sp!,{R0-R3,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    ip,[R0]     ;IA
    LDR    R0,[R1]     ;IW
    LDR    R2,[R2]     ;J
    LDR    R3,[R3]     ;NBITS
    MOV    R1,#-1
    RSB    R2,R2,#33   ;33-J
    ORR    ip,ip,R1,LSL R3;fill rest of word
    AND    R0,R0,ip,ROR R2;AND in byt
    LDMDB  fp,{fp,sp,pc} ;return
    END
;
;          MBYTOR see SBYTOR
;          MCBYT see CBYT
;
    TTL   MINVAR
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
F0  FN    0
F1  FN    1
F2  FN    2
F3  FN    3
F4  FN    4
F5  FN    5
F6  FN    6
F7  FN    7
    AREA   |C$$code|,CODE,READONLY
    EXPORT minvar_;(X,Y,R,XEPSI,STEP,MAXFUN,A,B,F) finds min of function
    DCB    "minvar_",0,8,0,0,255
minvar_
    MOV    ip,sp
    STMDB  sp!,{R0-R8,fp,ip,lr,pc}
    SUB    fp,ip,#4
    STFE   F4,[sp,#-12]! ;save floating registers
    STFE   F5,[sp,#-12]!
    STFE   F6,[sp,#-12]!
    STFE   F7,[sp,#-12]!
    LDMIA  ip,{R4-R8}    ;(STEP),(MAXFUN),(A),(B),(F)
    SUB    sp,sp,#lsk    ;space for variables
    LDR    R0,[R0]       ;X
    LDR    R1,[R1]       ;Y
    STR    R0,x3         ;X3 = X
    STMIA  sp,{R0,R1}    ;store X,Y
    LDR    R5,[R5]       ;M=MAXFUN
    LDR    R3,[R3]       ;XEPSI
    LDR    R0,min        ;=1.0E-6
    CMP    R3,R0
    STRLT  R0,eps
    STRGE  R3,eps        ;EPSI = MAX(1.E-5,XEPSI)
    LDFS   F4,[R4]       ;STEP
    STFS   F4,xst        ;XSTEP = STEP
    FMLS   F4,F4,#10
    STFS   F4,stb        ;STEP = BETA*STEP
    ADR    R0,x          ;(X)
    ADR    R1,zero
    BL     func          ;F(X,0)
    STFS   F0,y3         ;-> Y3
    ADR    R6,x2
    ADR    R7,x3
    BL     d509hi        ;returns EQ if converged
    LDR    lr,y3
    STR    lr,y          ;y=y3
    BLE    ret           ;return if converged
    ADR    R6,x1
    ADR    R7,x2
    BL     d509hi
    LDR    ip,x2
    LDR    lr,y2
    STMIA  sp,{ip,lr}    ;X=X2, Y=Y2
    BLE    ret           ;return if converged
;
lp1 LDFS   F1,x1
    LDFS   F2,x2
    LDFS   F3,x3
    SUFS   F0,F1,F2      ;X1-X2
    SUFS   F1,F1,F3      ;X1-X3
    CMF    F0,#0
    CMFNE  F1,#0
    BEQ    pt7           ;skip if either denominator is zero
    LDFS   F5,y1
    LDFS   F6,y2
    LDFS   F7,y3
    SUFS   F4,F5,F6      ;Y1-Y2
    SUFS   F5,F5,F7      ;Y1-Y3
    FDVS   F4,F4,F0      ;(Y1-Y2)/(X1-X2)
    FDVS   F5,F5,F1      ;(Y1-Y3)/(X1-X3)
    SUFS   F0,F2,F3      ;X2-X3
    SUFS   F4,F4,F5      ;D = (Y1-Y2)/(X1-X2) - (Y1-Y3)/(X1-X3)
    ADFS   F2,F2,F3      ;X2+X3
    FMLS   F0,F0,F4      ;D*(X2-X3)
    SUFS   F6,F6,F7      ;Y2-Y3
    CMF    F0,#0
    BLE    pt7
    FDVS   F6,F6,F4      ;(Y2-Y3)/D
    SUFS   F2,F2,F6
    FMLS   F2,F2,#0.5
    STFS   F2,x          ;X=0.5*(X3+X3-(Y2-Y3)/D)
    LDFS   F1,x1
    LDFS   F0,stb        ;STEP*BETA
    SUFS   F1,F1,F2
    ABSS   F1,F1
    CMF    F1,F0
    BGT    pt7           ;bad convergence
    ADR    R6,x
    BL     getf
    LDFS   F1,y1
    CMF    F0,F1
    BGE    pt7           ;Y .GE. Y1
    LDFS   F0,x
    LDFS   F1,x1
    SUFS   F1,F1,F0
    ABSS   F1,F1
    STFS   F1,xst        ;XSTEP = ABS(X-X1)
    ABSS   F0,F0
    ADFS   F0,F0,#1      ;ABS(X)+ETA
    LDFS   F2,eps
    FMLS   F2,F2,F0
    CMF    F1,F2         ;IF(XSTEP.LE.(ABS(X)+ETA)*EPSI)
    BLE    pt6           ;  fail, try a different step
;
pt5 MOV    R1,#3
    ADR    R0,x3
lp2 LDMDB  R0,{R2,R3}    ;move x2,y2
    STMIA  R0,{R2,R3}    ;to   x3,y3
    SUB    R0,R0,#8
    SUBS   R1,R1,#1
    BGT    lp2           ;loop through X2, X1 and x
    B      lp1           ;take another step
;
pt6 ADR    R0,x1
    LDMDB  R0,{R2,R3}    ;move x,y
    STMIA  R0,{R2,R3}    ;to x1,y1
pt7 ADR    R6,x
    ADR    R7,x1
    BL     d509hi
    BGT    pt5
;
ret LDMIA  sp,{R4,R5}    ;X,Y
    SUB    ip,fp,#48
    LDMIA  ip,{R0-R2}    ;(X),(Y),(R)
    STR    R4,[R0]
    STR    R5,[R1]
    LDR    R6,xst
    BIC    R6,R6,#&8,4   ;ABS(XSTEP)
    STR    R6,[R2]       ;R=ABS(XSTEP)
    LDFE   F7,[sp,#0+lsk];restore floating registers
    LDFE   F6,[sp,#12+lsk]
    LDFE   F5,[sp,#24+lsk]
    LDFE   F4,[sp,#36+lsk]
    LDMDB  fp,{R4-R8,fp,sp,pc} ;return
;
zero DCD   0
one DCD    1
min DCFS   1.0E-5
;
getf; compute F, FA or FB ((I = 0 or 1) in R1, (X,Y) in R6)
    STR    lr,lr1        ;save return link
    LDFS   F1,[R6]       ;X
    ADD    R0,fp,#12     ;(A)
    LDFS   F0,[R0]       ;A
    SUFS   F4,F0,F1      ;A-X
    CMF    F4,#0         ;IF(A-X.LE.0.) THEN
    ADR    R1,one
    BGT    MR1
    ADDLE  R0,fp,#16     ;  (B)
    LDFLES F0,[R0]       ;  B
    SUFLES F4,F1,F0      ;  X-B
    CMFLE  F4,#0         ;  IF(X-B.LE.0.) THEN
    MOVLE  R0,R6         ;    (X)
    BGT    MR1
    BL     func          ;get F(X,1) or F(B,1) or F(A,1)
    STFS   F0,[R6,#4]    ;Y=F(X,1) OR Y=F(B,1)+X-B OR Y=F(A,1)+A-X
    LDR    pc,lr1        ;return
MR1 BL     func          ;get F(X,1) or F(B,1) or F(A,1)
    ADFS   F0,F0,F4      ;add X-B or A-X
    STFS   F0,[R6,#4]    ;Y=F(X,1) OR Y=F(B,1)+X-B OR Y=F(A,1)+A-X
    LDR    pc,lr1        ;return 
;
func; call F with R0=(X) and R1=(I)
    SUBS   R5,R5,#1
    BLT    ret           ;too many steps
    MOV    pc,R8         ;call F
;
d509hi; (x,y,x1,y1,xstep,epsi,m,maxfun,f,is,a,b)
;      actually R6 points to (x,y) and R7 to (x1,y1)
    STR    lr,lr2        ;save return address
    LDFS   F1,xst
lp3 LDFS   F0,[R7]
    ADFS   F0,F0,F1
    STFS   F0,[R6]       ;X=X1+XSTEP
    MOV    R4,#2         ;loop count
lp4 BL     getf
    LDFS   F0,[R6,#4]    ;y
    LDFS   F4,[R7,#4]    ;Y1
    CMF    F4,F0
    LDRGT  pc,lr2        ;return 'GT' if Y1>Y
    LDFS   F0,[R7]       ;x1
    LDFS   F1,xst
    SUFS   F3,F0,F1
    STFS   F3,[R6]       ;X=X1-XSTEP
    SUBS   R4,R4,#1
    BGT    lp4
    ABSS   F3,F3         ;|X|
    LDFS   F2,eps
    ADFS   F3,F3,#1
    FMLS   F3,F3,F2
    CMF    F1,F3         ;IF(XSTEP.GT.(ABS(X)+ETA)*EPSI) THEN
    FMLGTS F1,F1,#0.5
    STFGTS F1,xst        ;  XSTEP = 0.5*XSTEP
    BGT    lp3           ;  and try again
    LDMIA  R7,{R0,R1}
    STMIA  R6,{R0,R1}    ;X=X1, Y=Y1
    LDR    pc,lr2        ;return 'LE'
;
    ^      0,sp        ;do not change the order of these, just add to them
x   #     4            ;X
y   #     4            ;Y
x1  #     4            ;X1
y1  #     4            ;Y1
x2  #     4            ;X2
y2  #     4            ;Y2
x3  #     4            ;X3
y3  #     4            ;Y3
eps #     4            ;EPSI
xst #     4            ;XSTEP
stb #     4            ;STEP
lr1 #     4            ;return address 1
lr2 #     4            ;return address 2
lsc #     0
;
lsk EQU  lsc-x
    END
;
;          MSBIT see SBIT
;          MSBIT0 see SBIT0
;          MSBIT1 see SBIT1
;          MSBYT see SBYT
;
    TTL    MVBITS
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT mvbits_;(M,I,LEN,N,J) moves LEN bits from bit I in M to bit J in N
    DCB    "mvbits_",0,8,0,0,255
mvbits_
    MOV    ip,sp
    STMDB  sp!,{R0-R3,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R0,[R0]        ;M
    LDR    R1,[R1]        ;I
    LDR    R2,[R2]        ;LEN
    MOV    ip,#-1
    BIC    ip,ip,ip,LSL R2;mask
    AND    R0,ip,R0,LSR R1;bits of M
    LDR    R1,[R3]        ;N
    LDR    R2,[fp,#4]
    LDR    R2,[R2]        ;J
    BIC    R1,R1,ip,LSL R2;mask out bits of N
    ORR    R1,R1,R0,LSL R2;insert bits of M
    STR    R1,[R3]        ;store in N
    LDMDB  fp,{fp,sp,pc} ;return
    END
;
    TTL   MXML
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
F2  FN     2
    AREA   |C$$code|,CODE,READONLY
    EXPORT mxmlrt_;(A,B,C,NI,NJ) Cil = Aij*Bjk*A'kl
    EXPORT mxmltr_;(A,B,C,NI,NJ) Cil = A'ij*Bjk*Akl
    DCB    "mxmlrt_",0,8,0,0,255
mxmlrt_
    MOV    ip,sp
    STMDB  sp!,{R0-R9,fp,ip,lr,pc}
    SUB    fp,ip,#4
    MOV    R9,#0
    B      start
;    DCB    "mxmltr_",0,8,0,0,255
mxmltr_
    MOV    ip,sp
    STMDB  sp!,{R0-R9,fp,ip,lr,pc}
    SUB    fp,ip,#4
    MOV    R9,#1
;
start
    LDR    R3,[R3]       ;NI
    LDR    R4,[fp,#4]
    LDR    R4,[R4]       ;NJ
    MUL    R5,R3,R3
    SUBS   R3,R3,#1      ;NI-1
    SUBGES R4,R4,#1      ;NJ-1
    LDMLTDB fp,{R4-R9,fp,sp,pc}  ;return if NI or NJ not >0
    MOV    R7,#0
lp1 SUBS   R5,R5,#1
    STRGE  R7,[R2,R5,LSL#2];clear C
    BGT    lp1
    ADD    R5,R3,#1      ;II-count (NI)
lp2 LDR    R6,[fp,#-48]  ;IB1 (base of B)
    LDR    R7,[fp,#-52]  ;JA1 (base of A)
    ADD    R8,R4,#1      ;JJ-count (NJ)
lp3 MOV    ip,R6         ;IB=IB1
    MOV    lr,R0         ;IA=IA1
    ADD    R1,R4,#1      ;KJ-count (NJ)
    MVFD   F0,#0         ;sum = 0
lp4 LDFS   F1,[lr],#4    ;A(IA), IA = IA + 1
    LDFS   F2,[ip],#4    ;B(IB), IB = IB + 1
    ADD    ip,ip,R4,LSL#2;IB = IB + NJ - 1
    TST    R9,#1
    FMLS   F1,F1,F2
    ADDNE  lr,lr,R3,LSL#2;IA = IA + NI - 1 if mxmltr
    SUBS   R1,R1,#1
    ADFD   F0,F0,F1      ;sum = sum + A(IA)*B(IB)
    BGT    lp4           ;loop over KJ
    MOV    ip,R7         ;JA=JA1
    MOV    lr,R2         ;IC=IC1
    ADD    R1,R3,#1      ;KI-count (NI)
lp5 LDFS   F1,[ip],#4    ;A(JA), JA = JA + 1
    LDFS   F2,[lr]       ;C(IC)
    FMLS   F1,F1,F0
    TST    R9,#1
    ADDEQ  ip,ip,R4,LSL#2;JA = JA + NJ - 1 if mxmlrt
    ADFS   F2,F2,F1
    SUBS   R1,R1,#1
    STFS   F2,[lr],#4    ;C(IC) = C(IC) + A(JA)*sum, IC = IC + 1
    BGT    lp5           ;loop over KI
    ADD    R6,R6,#4      ;IB1 = IB1 + 1
    ADD    R7,R7,#4      ;JA1 = JA1 + 1
    TST    R9,#1
    ADDNE  R7,R7,R3,LSL#2;JA1 = JA1 + NI - 1 if mxmltr
    SUBS   R8,R8,#1
    BGT    lp3           ;loop over JJ
    MOV    R2,lr         ;IC1 = IC1 + NI
    ADD    R0,R0,#4      ;IA1 = IA1 + 1
    TST    R9,#1
    ADDEQ  R0,R0,R4,LSL#2;IA1 = IA1 + NJ - 1 if mxmlrt
    SUBS   R5,R5,#1
    BGT    lp2           ;loop over II
    LDMDB  fp,{R4-R9,fp,sp,pc}  ;return
    END
;
    TTL   MXMXXX
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
F2  FN     2
    AREA   |C$$code|,CODE,READONLY
    EXPORT mxmpy_;(A,B,C,NI,NJ,NK) Cik = Aij*Bjk
    EXPORT mxmpy1_;(A,Q,C,NI,NJ,NK) Cik = Aij*Q'kj
    EXPORT mxmpy2_;(P,B,C,NI,NJ,NK) Cik = P'ji*Bjk
    EXPORT mxmpy3_;(P,Q,C,NI,NJ,NK) Cik = P'ji*Q'kj
    EXPORT mxmad_;(A,B,C,NI,NJ,NK) Cik = Aij*Bjk + Cik
    EXPORT mxmad1_;(A,Q,C,NI,NJ,NK) Cik = Aij*Q'kj + Cik
    EXPORT mxmad2_;(P,B,C,NI,NJ,NK) Cik = P'ji*Bjk + Cik
    EXPORT mxmad3_;(P,Q,C,NI,NJ,NK) Cik = P'ji*Q'kj + Cik
    EXPORT mxmub_;(A,B,C,NI,NJ,NK) Cik = Aij*Bjk - Cik
    EXPORT mxmub1_;(A,Q,C,NI,NJ,NK) Cik = Aij*Q'kj - Cik
    EXPORT mxmub2_;(P,B,C,NI,NJ,NK) Cik = P'ji*Bjk - Cik
    EXPORT mxmub3_;(P,Q,C,NI,NJ,NK) Cik = P'ji*Q'kj - Cik
mxmpy_
    MOV    ip,#&00
    B      mxstart
mxmpy1_
    MOV    ip,#&01
    B      mxstart
mxmpy2_
    MOV    ip,#&02
    B      mxstart
mxmpy3_
    MOV    ip,#&03
    B      mxstart
mxmad_
    MOV    ip,#&10
    B      mxstart
mxmad1_
    MOV    ip,#&11
    B      mxstart
mxmad2_
    MOV    ip,#&12
    B      mxstart
mxmad3_
    MOV    ip,#&13
    B      mxstart
mxmub_
    MOV    ip,#&20
    B      mxstart
mxmub1_
    MOV    ip,#&21
    B      mxstart
mxmub2_
    MOV    ip,#&22
    B      mxstart
mxmub3_
    MOV    ip,#&23
    B      mxstart
    DCB    "mxmxxx_",0,8,0,0,255
mxstart
    STR    ip,[sp,#-4]!   ;store flags on stack
    ADD    ip,sp,#4       ;original stack pointer
    STMDB  sp!,{R0-R9,fp,ip,lr,pc}
    SUB    fp,ip,#8
    LDMIB  fp,{R4-R6}     ;flags & addresses of NJ & NK
    LDR    R3,[R3]        ;NI
    LDR    R5,[R5]        ;NJ
    LDR    R6,[R6]        ;NK
    SUBS   R3,R3,#1       ;NI - 1
    SUBGES R6,R6,#1       ;NK - 1
    LDMLTDB fp,{R4-R9,fp,sp,pc}  ;return if NI or NK are not >0
    ADD    R1,R3,#1       ;L-count (NI)
lp1 LDR    R7,[fp,#-48]   ;initialise IB to address of B
    ADD    R8,R6,#1       ;M-count (NK)
lp2 TST    R4,#&30
    MVFEQD F0,#0          ;initialise sum to 0 if MPY etc.
    LDFNES F0,[R2]        ;otherwise to C(IC)
    TST    R4,#&20
    MNFNES F0,F0          ;and to -C(IC) if MUB
    ADDS   R9,R5,#0       ;N-count (NJ)
    BLE    pt1            ;skip if no terms
    MOV    ip,R0          ;JA=IA
    MOV    lr,R7          ;JB=IB
lp3 LDFS   F1,[ip],#4     ;A(JA), JA = JA + 1
    LDFS   F2,[lr],#4     ;B(JB), JB = JB + 1
    TST    R4,#&2
    ADDNE  ip,ip,R3,LSL#2 ;increment JA if Q'
    FMLS   F1,F1,F2
    TST    R4,#&1
    ADDEQ  lr,lr,R6,LSL#2 ;increment JB if not P'
    ADFD   F0,F0,F1       ;sum = sum + A(JA)*B(JB)
    SUBS   R9,R9,#1
    BGT    lp3            ;loop over N
    TST    R4,#&1
    ADDNE  R7,R7,R5,LSL#2 ;increment IB with NB
    ADDEQ  R7,R7,#4       ;  or 1
pt1 STFS   F0,[R2],#4     ;store C(IC), IC = IC + 1
    SUBS   R8,R8,#1
    BGT    lp2            ;loop over M
    TST    R4,#&2
    ADDEQ  R0,R0,R5,LSL#2 ;increment IA with NJ
    ADDNE  R0,R0,#4       ;or 1
    SUBS   R1,R1,#1
    BGT    lp1            ;loop over L
    LDMDB  fp,{R4-R9,fp,sp,pc}  ;return
    END
;
    TTL   MXTRP
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 mxtrp_;(A,B,NI,NJ) Bji = Aij
    DCB    "mxtrp_",0,0,8,0,0,255
mxtrp_
    MOV    ip,sp
    STMDB  sp!,{R0-R5,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R2,[R2]        ;NI
    LDR    R3,[R3]        ;NJ
    MOV    R5,R2          ;i-count
lp1 SUBS   R5,R5,#1
    LDMLTDB fp,{R4,R5,fp,sp,pc}  ;return
    MOV    R4,R1          ;IB
    MOV    ip,R3          ;j-count
lp2 SUBS   ip,ip,#1
    LDRGE  lr,[R0],#4     ;A(J,I), J=J+1
    STRGE  lr,[R4],R2,LSL#2;->B(I,J), J=J+1
    BGT    lp2            ;loop over J
    ADD    R1,R1,#4
    B      lp1
    END
;
    TTL   MXUTY
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 mxuty_;(A,N) A(NxN)= Unity matrix
    DCB    "mxuty_",0,0,8,0,0,255
mxuty_
    MOV    ip,sp
    STMDB  sp!,{R0-R1,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R1,[R1]        ;N
    MOV    ip,#0          ;off diagonal value
    LDR    lr,one         ;on diagonal value
    MOV    R2,R1          ;count of rows
lp1 SUBS   R2,R2,#1
    STRGE  lr,[R0],#4     ;diagonal term
    LDMLEDB fp,{fp,sp,pc} ;return
    MOV    R3,R1          ;count of zeros
lp2 STR    ip,[R0],#4
    SUBS   R3,R3,#1
    BGT    lp2
    B      lp1            ;loop over rows
one DCFS   1.0
    END
;
;          NCDECI see ICDECI
;          NCHEXI see ICHEXI
;          NCOCTI see ICOCTI
;
    TTL    NUMBIT
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R1  RN     1
R0  RN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT numbit_;(X) => number of one-bits in X
    DCB    "numbit_",0,8,0,0,255
numbit_
    MOV    ip,sp
    STMDB  sp!,{R0,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R1,[R0]    ;get X
    MOV    R0,#0      ;bit count
wn1 MOVS   R1,R1,LSR#1
    ADC    R0,R0,#0   ;sum bits set
    BNE    wn1
    LDMDB  fp,{fp,sp,pc} ;return
    END
;
    TTL    PERMU
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT permu_;(IA,N) form permutaions of IA, length N
;
    DCB    "permu_",0,0,8,0,0,255
permu_
    MOV    ip,sp
    STMDB  sp!,{R0,R1,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R1,[R1]        ;N
    SUBS   ip,R1,#1
    STREQ  ip,[R0]        ;set IA(1)=0 if N=1
    LDMLEDB fp,{fp,sp,pc} ;return if N<=1
    LDR    ip,[R0]        ;IA(1)
    CMP    ip,#0
    BEQ    init
    ADD    R2,R0,R1,LSL#2 ;(IA(N+1))
    LDR    ip,[R2,#-4]!   ;IA(K), K=N
    MOV    R3,R2          ;(IA(N')), N'=N
lp1 LDR    lr,[R2,#-4]!   ;IA(K-1), K=K-1
    CMP    lr,ip          ;compare IA(K-1) with IA(K)
    MOVGT  ip,lr
    SUBGES R1,R2,R0
    BGT    lp1            ;loop while IA(K-1)>=IA(K) and K-1>1
    CMP    R1,#0
    STREQ  R1,[R0]        ;set IA(1)=0 and
    LDMEQDB fp,{fp,sp,pc} ;return if sequence terminated
    ADD    R0,R2,#4       ;(IA(K))
    MOV    R1,R3          ;save (IA(N))
lp2 LDR    ip,[R3]        ;IA(N')
    LDR    lr,[R0]        ;IA(K)
    STR    ip,[R0],#4     ;IA'(K) = IA(N'), K=K+1
    STR    lr,[R3],#-4    ;IA'(N') = IA(K), N'=N'-1
    CMP    R3,R0
    BGT    lp2            ;loop while N'>K
    MOV    R0,R2          ;restore (IA(K-1))
    LDR    ip,[R2],#4     ;IA(K-1), L=K
lp3 LDR    lr,[R2],#4     ;IA(L), L=L+1
    CMP    lr,ip          ;compare IA(L) with IA(K-1)
    CMPLE  R2,R1
    BLE    lp3            ;loop if IA(L)<=IA(K-1) and L<=N
    STR    lr,[R0]        ;IA'(K-1) = IA(L)
    STR    ip,[R2,#-4]    ;IA'(L) = IA(K-1)
    LDMDB  fp,{fp,sp,pc} 
init;    initialise array
    SUB    R0,R0,#4        ;(IA(0))
lp4 STR    R1,[R0,R1,LSL#2];IA(I) = I, I=N,1,-1
    SUBS   R1,R1,#1
    BGT    lp4
    LDMDB  fp,{fp,sp,pc} 
    END
;
    TTL    PERMUT
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R5  RN     5
R4  RN     4
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
ifd EQU   12      ;maximum ?
    AREA   |C$$code|,CODE,READONLY
    EXPORT permut_;(NRP,N,IA) form permutaions of IA, length N
    IMPORT __rt_sdiv; R0 = R1/R0  (and R1=|remainder|)
;
    DCB    "permut_",0,8,0,0,255
permut_
    MOV    ip,sp
    STMDB  sp!,{R0-R2,R4-R5,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R4,[R1]        ;N
    SUBS   R4,R4,#1       ;N-1 (=M)
    LDMLTDB fp,{R4-R5,fp,sp,pc} ;return if N<1
    LDR    R1,[R0]        ;NRP
    CMP    R4,#ifd-1
    ADRLS  ip,ifct
    LDRLS  ip,[ip,R4,LSL#2];N!
    CMPLS  R1,ip
    MOVHI  ip,#0
    STRHI  ip,[R2]        ;N>ifd or NRP>N! so set IA(1)=0
    LDMHIDB fp,{R4-R5,fp,sp,pc} ;return if N>ifd or NRP>N!
    ADD    R0,R4,#1       ;N
lp1 STR    R0,[sp,#-4]!   ;IV(I) = I, I=N,1,-1
    SUBS   R0,R0,#1
    BGT    lp1            ;loop over I
    MOV    R5,R2          ;(IA(1))
    SUB    R1,R1,#1       ;IO = NRP-1
;         loop over M(R4)=N-1,1,-1
lp2 ADR    ip,ifct-4      ;(IFCT(0))
    LDR    R0,[ip,R4,LSL#2];IFCT(M)
    BL     __rt_sdiv     ;IO' = MOD(IO,IFCT(M))
    ADD    R0,sp,R0,LSL#2 ;(IV(IN)) (IN=IO/IFCT(M)+1)
    ADD    R2,sp,R4,LSL#2 ;(IV(M+1))
    LDR    ip,[R0],#4     ;(IV(I+1)), I=IN
    STR    ip,[R5],#4     ;IA(N-M) = IV(IN)
lp3 CMP    R0,R2
    LDRLE  lr,[R0],#4
    STRLE  lr,[R0,#-8]    ;IV(I) = IV(I+1)
    BLT    lp3            ;loop over I=IN, M
    SUBS   R4,R4,#1
    BGT    lp2            ;loop over M=N-1, 1, -1
    LDR    lr,[sp]
    STR    lr,[R5]        ;IA(N) = IV(1)
    LDMDB  fp,{R4-R5,fp,sp,pc} 
ifct;  table of factorials
    DCD    1,2,6,24,120,720,5040,40320         ;1! to 8!
    DCD    362880,3628800,39916800,479001600   ;9! to 12!
    END
;
    TTL    PKBYT
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
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 pkbyt_;(IB,X,JX,N,MPACK) packs N words into packed byte array
    DCB    "pkbyt_",0,0,8,0,0,255
pkbyt_
    MOV    ip,sp
    STMDB  sp!,{R0-R6,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R2,[R2]    ;jx
    SUB    R2,R2,#1   ;jx-1
    LDR    R3,[R3]    ;n
    LDR    ip,[fp,#4] ;address of MPACK
    LDMIA  ip,{R4,R5} ;get nbits,inword
    CMP    R4,#0      ;check for default
    MOVLE  R4,#1      ;default nbits=1
    MOVLE  R5,#32     ;and inword=32
wp1 SUBS   R2,R2,R5
    ADDGE  R1,R1,#4
    BGE    wp1        ;move to first word
    ADD    R2,R2,R5
    MUL    R2,R4,R2   ;pointer to first byte
    LDR    ip,[R1]    ;1st output word
    MOV    R6,#-1
    BIC    R6,R6,R6,LSL R4;byte mask
    MUL    R5,R4,R5   ;# bits to use in o/p word
wp2 LDR    lr,[R0],#4 ;get byt
    AND    lr,lr,R6   ;mask off byt
    BIC    ip,ip,R6,LSL R2
    ORR    ip,ip,lr,LSL R2;store byt
    ADD    R2,R2,R4
    CMP    R2,R5      ;check if word is full
    MOVGE  R2,#0      ;initialise for new word
    STRGE  ip,[R1],#4 ;store o/p word
    LDRGE  ip,[R1]    ;initialise next
    SUBS   R3,R3,#1
    BGT    wp2        ;loop over byts
    CMP    R2,#0      ;check if any byts in last word
    STRGT  ip,[R1]    ;store last o/p word
    LDMDB  fp,{R4-R6,fp,sp,pc} ;return
    END
;
    TTL    PKCHAR
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   slate__,COMMON,NOINIT
    %      160
    AREA   |C$$code|,CODE,READONLY
    EXPORT pkchar_;(INT,CHAR,N,IPAR) packs N words into continuous byte string
    DCB    "pkchar_",0,8,0,0,255
pkchar_
    MOV    ip,sp
    STMDB  sp!,{R0-R9,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R2,[R2]     ;n
    LDMIA  R3,{R3-R7}  ; 5 words of ipar
    CMP    R5,#0
    MOVEQ  R5,#32      ;set default zone
    CMP    R4,#0
    MOVEQ  R4,R5       ;default nchar
    STMFD  sp!,{R4,R7} ;save #bytes/zone and fill word
    MOV    R9,#-1
    BIC    R9,R9,R9,LSL R3;byt mask
    MOV    R8,#32      ;start bit
    LDR    R7,[sp,#4]  ;prefill accumulator
    MOV    lr,R3
wp1 SUB    lr,lr,R3;#bits remaining in zone
    CMP    lr,R3       ;check there is space in zone
    SUBGES ip,ip,#1    ;check there are more chars
    SUBLE  R8,R8,lr    ;allow for remaining space in zone
    LDRLE  ip,[sp]     ;remaining chars to store in zone
    SUBLE  lr,R5,R6    ;remaining space in zone
    SUBLES R8,R8,R6    ;skip the ignore space
wp2 STRLE  R7,[R1],#4  ;write out packed word
    LDRLE  R7,[sp,#4]  ;prefill accumulator
    ADDLES R8,R8,#32   ;reset bit pointer
    BLE    wp2         ;loop if still insufficient space
    LDR    R4,[R0],#4  ;get integer
    AND    R4,R4,R9    ;mask it
    SUBS   R8,R8,R3    ;move to next slot
    BICGT  R7,R7,R9,LSL R8
    ORRGT  R7,R7,R4,LSL R8;insert it
    RSBLE  R8,R8,#0
    BICLE  R7,R7,R9,LSR R8
    ORRLE  R7,R7,R4,LSR R8;insert it
    RSBLE  R8,R8,#32   ;reset bit pointer
    STRLE  R7,[R1],#4  ;write out packed word
    LDRLE  R7,[sp,#4]  ;prefill accumulator
    BICLT  R7,R7,R9,LSL R8
    ORRLT  R7,R7,R4,LSL R8;insert remaining bits
    SUBS   R2,R2,#1
    BGT    wp1         ;loop over characters
    CMP    R8,#32      ;finished, check last word
    STRLT  R7,[R1],#4  ;store if neccessary
    LDR    R2,[sp,#12] ;restore (char)
    SUB    R1,R1,R2
    MOV    R1,R1,LSR#2 ;# words written
    LDR    R0,slpt
    STR    R1,[R0]     ;store in /SLATE/
    LDMDB  fp,{R4-R9,fp,sp,pc} ;return
slpt DCD    slate__     ;pointer to COMMON/SLATE/
    END
;
    TTL   polint
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
F0  FN     0
F1  FN     1
F2  FN     2
F3  FN     3
MMAX   EQU 20; maximum degree of interpolating polynomial
;
    AREA   |C$$code|,CODE,READONLY
    EXPORT polint_;(F,ARG,M,Z,SUM) tabular interpolation
    DCB    "polint_",0,8,0,0,255
polint_
    MOV    ip,sp
    STMDB  sp!,{R0-R8,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R2,[R2]       ;M
    CMP    R2,#2
    MVFLTS F0,#0
    BLT    fin           ;no interpolation between <2 points
    CMP    R2,#MMAX
    MOVGT  R2,#MMAX
;        move F to stack
    MOV    ip,R2
lp1 LDR    lr,[R0],#4
    SUBS   ip,ip,#1
    STR    lr,[sp,#-4]!
    BGT    lp1
;        find coefficients
    SUB    R0,R2,#1       ;I-count (M-1)
    ADD    R5,R1,R2,LSL#2 ;(ARG(M+1))
lp2 MOV    R4,R0          ;J-count (I)
    SUB    R5,R5,#4       ;(ARG(I+1)), I=M-1
    MOV    ip,R5          ;(ARG(J+1)), J=I
    MOV    lr,sp          ;(COF(K)), K = M
    ADD    R6,R1,R2,LSL#2 ;(ARG(K+1)), K = M
lp3 LDFS   F0,[lr],#4     ;COF(K) ,K = K-1
    LDFS   F1,[lr]        ;COF(K-1)
    LDFS   F2,[R6,#-4]!   ;ARG(K), K = K-1
    LDFS   F3,[ip,#-4]!   ;ARG(J)
    SUFS   F0,F0,F1
    SUFS   F2,F2,F3
    FDVS   F0,F0,F2
    SUBS   R4,R4,#1
    STFS   F0,[lr,#-4]    ;COF(K)=(COF(K)-COF(K-1))/(ARG(K)-ARG(J))
    BGT    lp3
    SUBS   R0,R0,#1
    BGT    lp2
    LDFS   F0,[sp],#4     ;SUM = COF(M)
    SUBS   R0,R2,#1       ;I-count (M-1)
    ADD    R1,R1,R0,LSL#2 ;(ARG(M))
    LDFS   F3,[R3]        ;Z
lp4 LDFS   F1,[R1,#-4]!   ;ARG(I)
    LDFS   F2,[sp],#4     ;COF(I)
    SUFS   F1,F3,F1       ;Z-ARG(I)
    FMLS   F1,F1,F0       ;SUM*(Z-ARG(I))
    SUBS   R0,R0,#1
    ADFS   F0,F1,F2       ;SUM = SUM*(Z-ARG(I)) + COF(I)
    BGT    lp4
fin LDR    ip,[fp,#4]     ;(SUM)
    STFS   F0,[ip]        ;store SUM
    LDMDB  fp,{R4-R8,fp,sp,pc} 
    END
;
    TTL    PROB
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
F0  FN     0
F1  FN     1
F2  FN     2
F3  FN     3
R0  RN     0
R1  RN     1
R2  RN     2
R3  RN     3
R4  RN     4
    AREA   |C$$code|,CODE,READONLY
    EXPORT prob_;(CHI2,N) => Chisquared probability
    IMPORT erfc_;(Z)
;
    DCB    "prob_",0,0,0,8,0,0,255
prob_
    MOV    ip,sp
    STMDB  sp!,{R4,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDFS   F0,[R0]     ;CHI2
    LDR    R4,[R1]     ;NDF
    CMP    R4,#1
    CMFGE  F0,#0
    MNFLTS F0,#1
    LDMLTDB fp,{R4,fp,sp,pc} ;error if N<1 or Chisq<0
    CMP    R4,#100
    BGT    big
    LDFS   F1,C170
    CMF    F0,F1
    MVFGTS F0,#0
    LDMGTDB fp,{R4,fp,sp,pc} ;Chisq too big
    FMLS   F1,F0,#0.5     ;CHI2/2
    MNFS   F2,F1
    EXPS   F3,F2          ;EXP(-chisq/2)
    TST    R4,#1          ;check parity
    BEQ    PB1
;        N is odd
    SQTS   F1,F1          ;sqrt(chisq/2)
    STFS   F1,[sp,#-4]!
    MOV    R0,sp
    FDVS   F3,F3,F1
    LDFS   F2,RRPI        ;1/SQRT(pi)
    FMLS   F3,F3,F2       ;save TERM
    STFS   F3,[sp,#-4]!   ;save EXP(-chisq/2)/SQRT(chisq/2)/SQRT(pi)
    STFS   F0,[sp,#-4]!   ;save chisq
    BL     erfc_          ;PROB
    LDFS   F1,[sp],#4     ;restore chisq
    LDFS   F3,[sp],#8     ;restore TERM
    MVFS   F2,#1          ;FI
    B      lp1
;        N is even
PB1 MVFS   F1,F0          ;chisq
    MVFS   F0,F3          ;PROB{=TERM=EXP(-chisq/2)}
    MVFS   F2,#2          ;FI
;        now do sum
lp1 SUBS   R4,R4,#2
    FMLGTS F3,F3,F1
    LDMLEDB fp,{R4,fp,sp,pc} 
    FDVS   F3,F3,F2       ;TERM=TERM*chisq/FI
    ADFS   F2,F2,#2       ;FI=FI+2
    ADFS   F0,F0,F3       ;PROB=PROB+TERM
    B      lp1
C170 DCFS  170.0
RRPI DCFS  0.56418958     ;1/SQRT(pi)
C2B9 DCFS  0.22222222
C1B3 DCFS  0.33333333
;
big FLTS   F1,R4
    LDFS   F2,C2B9
    FDVS   F2,F2,F1
    FDVS   F0,F0,F1
    LDFS   F3,C1B3
    POWS   F0,F0,F3       ;CUBEROOT(CHI2/NDF)
    SUFS   F0,F0,#1
    ADFS   F0,F0,F2
    ADFS   F2,F2,F2
    SQTS   F2,F2
    FDVS   F0,F0,F2
    STFS   F0,[sp,#-4]!
    MOVS   R0,sp
    BL     erfc_
    FMLS   F0,F0,#0.5
    LDMDB  fp,{R4,fp,sp,pc} ;finished
    END
;
    TTL    PROBKL
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
F0  FN     0
F1  FN     1
F2  FN     2
F3  FN     3
R0  RN     0
R1  RN     1
R2  RN     2
R3  RN     3
    AREA   |C$$code|,CODE,READONLY
    EXPORT probkl_;(X) => Kolmogorov probability
;
    DCB    "probkl_",0,8,0,0,255
probkl_
    MOV    ip,sp
    STMDB  sp!,{R0,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDFS   F3,[R0]      ;X
    ABSS   F3,F3        ;U=|X|
    LDFS   F2,=0.2
    CMF    F3,F2        ;if U<0.2
    MVFLTD F0,#1        ;return one
    LDMLTDB fp,{fp,sp,pc} 
    LDFS   F2,=6.8116
    CMF    F3,F2        ;if U>=6.8116
    MVFGED F0,#0        ;return zero
    LDMGEDB fp,{fp,sp,pc} 
    LDFS   F1,=0.755
    MUFD   F2,F3,F3     ;V = U**2
    CMF    F3,F1
    BGE    pt1
;         U<0.755
    LDFD   F0,cw1       ;-pi**2/8
    DVFD   F0,F0,F2
    EXPD   F1,F0
    LDFD   F0,cw2       ;-9*pi**2/8
    DVFD   F0,F0,F2
    EXPD   F0,F0
    ADFD   F1,F1,F0
    LDFD   F0,cw3       ;-25*pi**2/8
    DVFD   F0,F0,F2
    EXPD   F0,F0
    ADFD   F1,F1,F0     ;EXP(C1/V)+EXP(C2/V)+EXP(C3/V)
    LDFD   F0,rtp       ;SQRT(2*pi)
    DVFD   F3,F1,F3
    MUFD   F0,F0,F3
    RSFD   F0,F0,#1     ;1-RTP*(EXP(C1/V)+EXP(C2/V)+EXP(C3/V))/U
    LDMDB  fp,{fp,sp,pc} ;finished
;     0.755<=U<6.8116
pt1 MVFD   F0,#3
    DVFD   F0,F0,F3     ;3/U
    FIX    R0,F0        ;NINT(3/U)
    ADFD   F0,F2,F2
    MNFD   F1,F0        ;-2U**2
    EXPD   F0,F1        ;EXP(-2U**2)
    CMP    R0,#2
    MUFGED F2,F0,F0     ;EXP(-4U**2)
    MUFGED F3,F0,F2     ;EXP(-6U**2)
    MUFGED F1,F2,F2     ;EXP(-8U**2)
    SUFGED F0,F0,F1
    MUFGTD F3,F3,F2     ;EXP(-10U**2)
    MUFGTD F1,F1,F3     ;EXP(-18U**2)
    ADFGTD F0,F0,F1
    CMP    R0,#3
    MUFGTD F3,F3,F2     ;EXP(-14U**2)
    MUFGTD F1,F1,F3     ;EXP(-32U**2)
    SUFGTD F0,F0,F1
    ADFD   F0,F0,F0
    LDMDB  fp,{fp,sp,pc} ;finished
;
rtp DCFD   2.50662827463100050  ;SQRT(2pi)
cw1 DCFD   -1.23370055013616983 ;-PI**2/8
cw2 DCFD   -11.10330495122552845;9*CW1
cw3 DCFD   -30.84251375340424568;25*CW1
    END
;
    TTL    PROXIM
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R1  RN     1
R0  RN     0
F3  FN     3
F2  FN     2
F1  FN     1
F0  FN     0
;
    AREA   |C$$code|,CODE,READONLY
    EXPORT proxim_;(B,A) returns angle B (+2nPI) nearest to A
    DCB    "proxim_",0,8,0,0,255
proxim_
    MOV    ip,sp
    STMDB  sp!,{R0-R1,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDFS   F0,[R0]        ;B
    LDFS   F1,[R1]        ;A
    LDFD   F2,pi2         ;2*PI
    SUFD   F3,F1,F0       ;A-B
    DVFD   F1,F3,F2       ;(A-B)/(2PI)
    RNDD   F3,F1          ;integer part of (A-B)/(2PI)
    MUFD   F3,F3,F2       ;2PI*(integer part of (A-B)/(2PI))
    ADFD   F0,F0,F3       ;B+2PI*(integer part of (A-B)/(2PI))
    LDMDB  fp,{fp,sp,pc}  ;return
pi2 DCFD   6.283185307179586
    END
;
    TTL    PSCALE
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
F1  FN     1
F0  FN     0
;
    AREA   |C$$code|,CODE,READONLY
    EXPORT pscale_;(NSC,NMAX,A,NST) finds power of 10 scale for printing
    DCB    "pscale_",0,8,0,0,255
pscale_
    MOV    ip,sp
    STMDB  sp!,{R0-R3,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDFS   F0,[R2]        ;A
    LDR    R1,[R1]        ;NSC = NMAX
    CMF    F0,#0
    BEQ    pt1
    ABSS   F0,F0
    LOGS   F0,F0
    FIXP   R2,F0
    LDR    R3,[R3]        ;NST
    SUB    R2,R3,R2
    CMP    R2,R1
    MOVLT  R1,R2          ;new NSC
pt1 FLTS   F0,R1
    RPWS   F0,F0,#10      ;10.**NSC
    STR    R1,[R0]        ;store NSC
    LDMDB  fp,{fp,sp,pc}  ;return
    END
;
    TTL    QNEXT
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R1  RN     1
R0  RN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT qnext_;dummy calls STOP
    IMPORT _stop
    DCB    "qnext_",0,0,8,0,0,255
qnext_
    MOV    ip,sp
    STMDB  sp!,{fp,ip,lr,pc}
    SUB    fp,ip,#4
    ADR    R0,msg
    MOV    R1,#33
    BL     _stop
    LDMDB  fp,{fp,sp,pc} ;return (should not get here!)
msg DCB    "You must write a SUBROUTINE QNEXT",0,0,0
    END
;
    TTL    QNEXTE
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
sl  RN    10
R9  RN     9
R4  RN     4
R1  RN     1
R0  RN     0
F4  FN     4
F5  FN     5
F6  FN     6
F7  FN     7
    AREA   qn_save,DATA
    DCD    0        ;space for saved frame pointer
    DCD    0        ;space for saved stack pointer
    AREA   |C$$code|,CODE,READONLY
    EXPORT qnexte_;calls QNEXT always at the same level
    IMPORT qnext_,WEAK
    IMPORT __rt_stkovf_split_small
    DCB    "qnext_",0,0,8,0,0,255
qnexte_
    LDR    R1,ptr
    LDR    R0,[R1]
    CMP    R0,#0
    LDMNEIA R1,{fp,sp}  ;load frame and stack pointers
    BNE    pt1          ;and skip if this is subsequent call
    MOV    ip,sp
    STMDB  sp!,{R4-R9,fp,ip,lr,pc}
    STFE   F7,[sp,#-12]!;save floating registers
    STFE   F6,[sp,#-12]!
    STFE   F5,[sp,#-12]!
    STFE   F4,[sp,#-12]!
    SUB    fp,ip,#4
    CMP    sp,sl
    BLLT   __rt_stkovf_split_small ;extend stack if necessary
    STMIA  R1,{fp,sp}   ;store frame and stack pointers
pt1 BL     qnext_       ;CALL QNEXT
    LDR    R1,ptr
    MOV    R0,#0
    STR    R0,[R1]      ;restore initial state
    LDFE   F4,[fp,#-84] ;restore floating registers
    LDFE   F5,[fp,#-72]
    LDFE   F6,[fp,#-60]
    LDFE   F7,[fp,#-48]
    LDMDB  fp,{R4-R9,fp,sp,pc} ;return
ptr DCD    qn_save
    END
;
;
;        RANECQ see RANECU
;
    TTL   radapt
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
R4  RN     4
R5  RN     5
R6  RN     6
R7  RN     7
R8  RN     8
R9  RN     9
F0  FN     0
F1  FN     1
F2  FN     2
F3  FN     3
F4  FN     4
F5  FN     5
F6  FN     6
F7  FN     7
;
ndim EQU 100   ; maximum number of interpolation points
       ^     -4,R9
nter #     4
xlo  #     4*ndim
xhi  #     4*ndim
tval #     4*ndim
ters #     4*ndim
;
    AREA   |C$$data|,DATA
     DCD   0         ;NTER
stor %     4*ndim    ;XLO(NDIM)
     %     4*ndim    ;XHI(NDIM)
     %     4*ndim    ;TVAL(NDIM)
     %     4*ndim    ;TERS(NDIM)
;
    AREA   |C$$code|,CODE,READONLY
    IMPORT rgs56p_
    EXPORT radapt_;(F,A,B,NSEG,RELTOL,ABSTOL,RES,ERR) REAL Gaussian quadrature
;               variables are REAL
;     RES = Estimated Integral of F from A to B,
;     ERR = Estimated absolute error on RES.
;     NSEG  specifies how the adaptation is to be done:
;        =0   means use previous binning,
;        =1   means fully automatic, adapt until tolerance attained.
;        =n>1 means first split interval into n equal segments,
;             then adapt as necessary to attain tolerance.
;     The specified tolerances are:
;            relative: RELTOL ;  absolute: ABSTOL.
;        It stops when one OR the other is satisfied, or number of
;        segments exceeds NDIM.  Either TOLA or TOLR (but not both!)
;        can be set to zero, in which case only the other is used.
    DCB    "radapt_",0,8,0,0,255
radapt_
    MOV    ip,sp
    STMDB  sp!,{R0-R9,fp,ip,lr,pc}
    SUB    fp,ip,#4
    SFMFD  F4,4,[sp]!      ;save fp registers 4 to 7
    SUB    R7,sp,#4        ;arg's address
    STR    R7,[sp,#-8]!    ;store on stack with space for 1 argument
    MOV    R5,R0           ;save address of F
    LDR    R9,ptr          ;point R9 to saved data store
    LDR    R6,[R3]         ;NSEG
    CMP    R6,#0
    BGT    pt1
    LDR    R6,nter         ;NTER
    CMP    R6,#0
    MOVEQ  R6,#1           ;NSEGD=1
    BEQ    pt2
    MVFS   F6,#0           ;initialize TVALS = 0.
    MVFS   F7,#0           ;initialize TERSS = 0.
    ADR    R8,tval
lp1 MOV    R0,R5           ;(F)
    SUB    R1,R8,#8*ndim   ;(XLO(I))
    SUB    R2,R8,#4*ndim   ;(XHI(I))
    MOV    R3,R8           ;(TVAL(I))
    BL     rgs56p_         ;CALL RGS56P(F,XLO(I),XHI(I),TVAL(I),TE)
    LDFS   F0,[R7]         ;TE
    LDFS   F1,[R8]         ;TVAL(I)
    FMLS   F0,F0,F0
    ADFS   F6,F6,F1        ;TVALS = TVALS + TVAL(I)
    STFS   F0,[R8,#4*ndim] ;store TERS(I) = TE**2
    ADFS   F7,F7,F0        ;TERSS = TERSS + TERS(I)
    ADD    R8,R8,#4        ;I = I + 1
    SUBS   R6,R6,#1
    BGT    lp1             ;loop over I=1,NTER
    ADFS   F7,F7,F7
    SQTS   F7,F7           ;ROOT = SQRT(2*TERSS)
ret LDR    R6,[fp,#12]     ;(RES)
    LDR    R7,[fp,#16]     ;(ERR)
    STFS   F6,[R6]         ;store TVALS in RES
    STFS   F7,[R7]         ;store ROOT on ERR
    ADD    sp,sp,#8        ;restore stack
    LFMFD  F4,4,[sp]!      ;restore fp registers
    LDMDB  fp,{R4-R9,fp,sp,pc} ;return
;
pt1 CMP    R6,#ndim
    MOVGT  R6,#ndim        ;NSEGD = MIN(NSEG,NDIM)
pt2 LDFS   F7,[R1]         ;XHIB = A
    LDFS   F6,[R2]         ;B
    FLTS   F0,R6           ;FLOAT(NSEGD)
    SUFS   F5,F6,F7        ;B-A
    FDVS   F5,F5,F0        ;BIN = (B-A)/NSEGD
    ADR    R8,xhi          ;address of xhi
    SUBS   R4,R6,#1        ;loop count = NSEGD
lp2 STFS   F7,[R8,#-4*ndim];XLO(I) = XHIB
    MVFEQS F7,F6
    ADFGTS F7,F7,F5        ;XHIB' = XHIB + BIN (or B on last point)
    STFS   F7,[R8]         ;XHI(I) = XHIB'
    MOV    R0,R5           ;(F)
    SUB    R1,R8,#4*ndim   ;(XLO(I))
    MOV    R2,R8           ;(XHI(I))
    ADD    R3,R8,#4*ndim   ;(TVAL(I))
    BL     rgs56p_         ;CALL RGS56P(F,XLO(I),XHI(I),TVAL(I),TE)
    LDFS   F0,[R7]         ;TE
    FMLS   F0,F0,F0
    STFS   F0,[R8,#8*ndim] ;store TERS(I) = TE**2
    ADD    R8,R8,#4
    SUBS   R4,R4,#1
    BGE    lp2             ;loop over I=1,NSEGD
    LDMIB  fp,{ip,lr}      ;(RELTOL), (ABSTOL)
    LDFS   F4,[ip]         ;RELTOL
    LDFS   F5,[lr]         ;ABSTOL
;        start iteration loop
lp3 ADR    R8,ters
    LDFS   F6,[R8,#-4*ndim];initialize TVALS = TVAL(1)
    LDFS   F7,[R8],#4      ;initialize TERSS = TERS(1)
    SUBS   R0,R6,#1        ;count NTER-1
lp4 LDFGTS F0,[R8,#-4*ndim];TVAL(I)
    LDFGTS F1,[R8],#4      ;TERS(I)
    ADFGTS F6,F6,F0        ;TVALS = TVALS + TVAL(I)
    ADFGTS F7,F7,F1        ;TERSS = TERSS + TERS(I)
    SUBGTS R0,R0,#1
    BGT    lp4             ;loop over I=2,NTER
    ADFS   F7,F7,F7
    SQTS   F7,F7           ;ROOT = SQRT(2*TERSS)
    CMF    F7,F5           ;IF(ROOT.LE.ABSTOL .OR.
    ABSGTS F0,F6
    FMLGTS F0,F0,F4
    CMFGT  F7,F0           ; ROOT.LE.RELTOL*ABS(TVALS) .OR.
    RSBGTS lr,R6,#ndim     ; NTER.GE.NDIM
    STRLE  R6,nter         ; THEN store NTER
    BLE    ret             ; and all done
    ADR    R8,ters         ;otherwise, find biggest error
    LDFS   F0,[R8],#4      ;BIGE = TERS(1)
    SUB    R4,R8,#4+4*ndim ;IBIG = 1
    SUBS   R0,R6,#1        ;count NTER-1
lp5 LDFGTS F1,[R8],#4      ;TERS(I)
    CMFGT  F1,F0           ;IF (TERS(I).GT.BIGE) THEN
    MVFGTS F0,F1           ; BIGE = TERS(I)
    SUBGT  R4,R8,#4+4*ndim ; IBIG = I
    SUBS   R0,R0,#1
    BGT    lp5             ;loop over I=2,NTER
    ADR    R8,tval
    ADD    R8,R8,R6,LSL#2  ;(TVAL(NTER+1))
    ADD    R6,R6,#1        ;NTER = NTER + 1
    LDFS   F0,[R4,#-4*ndim]!;XHI(IBIG)
    STFS   F0,[R8,#-4*ndim]!;XHI(NTER) = XHI(IBIG)
    LDFS   F1,[R4,#-4*ndim];XLO(IBIG)
    ADFS   F1,F1,F0
    FMLS   F1,F1,#0.5      ;XNEW = 0.5*(XLO(IBIG)+XHI(IBIG))
    STFS   F1,[R4],#4*ndim ;XHI(IBIG) = XNEW
    STFS   F1,[R8,#-4*ndim];XLO(NTER) = XNEW
    ADD    R8,R8,#4*ndim   ;(TVAL(NTER))
    MOV    R0,R5           ;(F)
    SUB    R1,R4,#8*ndim   ;(XLO(IBIG))
    SUB    R2,R4,#4*ndim   ;(XHI(IBIG))
    MOV    R3,R4           ;(TVAL(IBIG))
    BL     rgs56p_         ;CALL DGS56P(F,XLO(IBIG),XHI(IBIG),TVAL(IBIG),TE)
    LDFS   F0,[R7]         ;TE
    FMLS   F0,F0,F0
    STFS   F0,[R4,#4*ndim] ;TERS(IBIG)=TE**2
    MOV    R0,R5           ;(F)
    SUB    R1,R8,#8*ndim   ;(XLO(NTER))
    SUB    R2,R8,#4*ndim   ;(XHI(NTER))
    MOV    R3,R8           ;(TVAL(NTER))
    BL     rgs56p_         ;CALL DGS56P(F,XLO(NTER),XHI(NTER),TVAL(NTER),TE)
    LDFS   F0,[R7]         ;TE
    FMLS   F0,F0,F0
    STFS   F0,[R8,#4*ndim] ;TERS(NTER)=TE**2
    B      lp3             ;loop
;
ptr DCD    stor
    END
;
    TTL    RANECU
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R7  RN     7
R6  RN     6
R5  RN     5
R4  RN     4
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
maxseq  EQU  100
;       seeds for 100 sequences
    MACRO
    SEEDS
    DCD        9876,     54321,1058718014,1872605764
    DCD  1814868809, 849641138,1503041326, 998515605
    DCD   628142053, 244439171,1391554630, 846883852
    DCD  1535236638, 154775958,1747133713,1575487760
    DCD   714962706,2107758832,1486824114, 786139113
    DCD  1323688611, 371658774,1570590541, 630312859
    DCD  1555058144, 358976382, 952681104,1242126412
    DCD  1083789165,1890043487, 631749547,1925864168
    DCD  1178945274,1475158130,1009344940,1502757676
    DCD  1933972860,1627514572,1875817978, 567972013
    DCD   446320203, 273324776, 460899131,1527583930
    DCD    35532104, 558897732,2089458455,1339622951
    DCD  1535926201,1918446533, 669734232,1019772931
    DCD   501928827, 285518477, 942354467, 280177956
    DCD   192461969,1576639468,1601863355, 661544549
    DCD  1743728581, 523887323,1703010089,1259731603
    DCD  1643511188, 875622567,1755559262,2142089492
    DCD   114689819, 126275958, 105250298,1127134231
    DCD    79402987,1236641847, 387101667,1706644076
    DCD  1734232502, 664024463,2123161160,1759230139
    DCD  1811169504,1405252309,1766746084, 274705383
    DCD   959435020, 108779126,2062813302,1863432262
    DCD  1691639052,1503605588,1086444145, 158310100
    DCD  2058594463, 810394383,2101564568,1105108539
    DCD   978826660, 617502647,1436276288, 529578818
    DCD   556864235, 606529730,1078146847,1147358663
    DCD  1447193285,1376658008,1006664521,1311015086
    DCD  1837174956, 768046385, 896589370, 260492364
    DCD  1360218380,1414233683,1278625491,1552675421
    DCD  1011812242,1458050027,1754922946,1785085266
    DCD  1343566665, 443288238,1437791085,2078825854
    DCD  2094123993,1341409348,1537730690, 153906788
    DCD  2127544614,   4856371,1004692237, 786489538
    DCD   821800123,1417369188, 312261859, 286397034
    DCD  1519811572, 144643793,   5329351,1263184329
    DCD  1416419532,1842707225,1697860185, 840465352
    DCD  1934192451, 619946463, 170088516,1174161868
    DCD  1304806046, 108470534,1976265015,1714480092
    DCD   783664411, 978542208,1694901962,  55891868
    DCD  1548123234, 424683817,1042788941,1370039022
    DCD  1576822555,1268584439, 831708278,1432924432
    DCD   993848687, 233811113, 745249148, 738800065
    DCD  1947731465,1336392610,1402689657,1392469639
    DCD   311285254,1241207984,1206768222, 887510662
    DCD   762376025,1967748670, 923860508, 824843061
    DCD   755432194,1333575913, 233721957, 126133675
    DCD  1989717210, 691593480,1030990373, 128881640
    DCD  1322807026, 928284400,1169603884,1077182026
    DCD   976273645,1973303129, 530354343,1592879270
    DCD   947509404, 205601315,1840231302,1716122836
    MEND
;
    AREA   ranec1__,DATA,COMDEF
;      pointer to current sequence
    DCD  0,0
;       100 pre-defined seeds
    SEEDS
;
    AREA   |C$$code|,CODE,READONLY
    EXPORT ranecu_;(R,N,KSEQ) sets vector of N random numbers of sequence KSEQ
    DCB    "ranecu_",0,8,0,0,255
ranecu_
    MOV    ip,sp
    STMDB  sp!,{R0-R2,R4-R7,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R3,[R1]        ;N
    LDR    R4,wdd         ;pointer to COMMON/RANEC1/
    LDR    R1,[R2]        ;KSEQ
    CMP    R1,#1
    STRGE  R1,[R4]        ;store new sequence number
    LDRLT  R1,[R4]        ;or get old sequence number
    CMP    R1,#0
    BLE    init           ;initialise random sequence
    ADD    R4,R4,R1,LSL#3 ;pointer to seeds
    LDMIA  R4,{R5,R6}     ;get seeds
lr1;     loop over numbers to be generated
    MOV    R7,R5          ;SEED 1
    LDR    R1,=53668
    BL     div            ;return R7=MOD(ISEED,53668),R2=ISEED/53668
    LDR    R1,=40014
    LDR    lr,=12211
    MUL    R7,R1,R7
    MUL    R2,lr,R2
    SUBS   R5,R7,R2
    LDRMI  R1,=2147483563
    ADDMI  R5,R5,R1       ;new ISEED1
    MOV    R7,R6          ;get ISEED2
    LDR    R1,=52774
    BL     div            ;return R7=MOD(ISEED,52774),R2=ISEED/52774
    LDR    R1,=40692
    LDR    lr,=3791
    MUL    R7,R1,R7
    MUL    R2,lr,R2
    SUBS   R6,R7,R2
    LDRMI  R1,=2147483399
    ADDMI  R6,R6,R1       ;new ISEED1
    SUBS   R7,R5,R6
    LDRMI  R1,=2147483562
    ADDMI  R7,R7,R1
    MOV    R1,#&3F000000  ;initial exponent
    ADD    R7,R7,R7       ;move up into sign bit
lr2 ADDS   R7,R7,R7       ;move up seed 1 bit
    SUBCC  R1,R1,#&800000 ;reduce exponent if no carry
    BCC    lr2            ;test next bit
    ORRS   R7,R1,R7,LSR#9 ;insert exponent
    ADDCS  R7,R7,#1       ;round
    STR    R7,[R0],#4     ;store answer
    SUBS   R3,R3,#1
    BGT    lr1            ;loop over result vector
    STMIA  R4,{R5,R6}     ;store seeds
    LDMDB  fp,{R4-R7,fp,sp,pc}  ;return
;
    LTORG
;
OS_Word  EQU  &07
init;    initialise random sequence
    MOV    R1,#1
    STR    R1,[R4]        ;store sequence number
    ADD    R4,R4,R1,LSL#3 ;pointer to seeds
    SUB    sp,sp,#8       ;space for time
    MOV    R1,sp          ;pointer to 5-byte time
    MOV    R0,#3
    STR    R0,[R1]
    MOV    R0,#14
    SWI    OS_Word        ;OSWORD 14,3 to get time
    LDMIA  sp!,{R5,R6}    ;get time
    ORR    R0,R5,#&FF,8
    BIC    R5,R5,#&FF,8   ;SEED 1 is least sig 24 bits of time
    ADD    R5,R5,#&10000  ;ensure it is not zero
    BIC    R6,R6,#&FF
    ORR    R6,R0,R6,LSL#8 ;SEED 2 is most significant 16 bits of time
    LDR    R0,[sp]        ;restore R0
    B      lr1
;
div;  divide R7 by R1
    MOV    ip,R1          ;copy of denominator
    CMP    ip,R7,LSR#1
dv1 MOVLS  ip,ip,LSL#1
    CMP    ip,R7,LSR#1
    BLS    dv1
    MOV    R2,#0
dv2 CMP    R7,ip
    SUBCS  R7,R7,ip
    ADC    R2,R2,R2
    MOV    ip,ip,LSR#1
    CMP    ip,R1
    BHS    dv2
;       R7 is remainder, R1 is unchanged, R2 is the quotient, ip is destroyed
    MOV    pc,lr
;
wdd DCD    ranec1__
;
    EXPORT ranecq_;(IS1,IS2,ISQ,CH) set or retrieve random seeds
    DCB    "ranecq_",0,8,0,0,255
ranecq_
    MOV    ip,sp
    STMDB  sp!,{R0-R3,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDRB   lr,[R3]        ;CH
    LDR    ip,wdd         ;pointer to COMMON/RANEC1/
    LDR    R3,[R2]        ;ISQ
    CMP    lr,#" "
    BNE    rq1
;        CH=' ' : restore preset seed
    CMP    R3,#1
    RSBGES lr,R3,#maxseq
    MOVLT  R3,#1
    STR    R3,[ip]        ;store current sequence
    ADR    lr,slist-8
    ADD    lr,lr,R3,LSL#3 ;address of prestored seeds
    LDMIA  lr,{R0,R1}     ;get prestored seeds
    ADD    lr,ip,R3,LSL#3
    STMIA  lr,{R0,R1}     ;store seeds in common
    LDMDB  fp,{fp,sp,pc}  ;return
;
rq1 CMP    lr,#"S"
    BNE    rq2
    CMP    R3,#0
    STRGT  R3,[ip]        ;set new sequence number
    LDRLE  R3,[ip]        ;or get old one
    LDR    R0,[R0]        ;IS1
    CMP    R0,#0
    LDRGT  R1,[R1]        ;IS2
    CMPGT  R1,#0
    ADDGT  ip,ip,R3,LSL#3 ;address of seeds
    STMGTIA ip,{R0,R1}    ;store seeds
    LDMDB  fp,{fp,sp,pc}  ;return
;
rq2 CMP    lr,#"R"
    BNE    rq3
    CMP    R3,#0
    LDRLE  R3,[ip]        ;get old sequence if none defined
    STRGT  R3,[ip]        ;or store new one
    LDR    lr,[ip,R3,LSL#3]!;get seed 1
    STR    lr,[R0]        ;store in IS1
    LDR    lr,[ip,#4]     ;get seed 2
    STR    lr,[R1]        ;store in IS2
    LDMDB  fp,{fp,sp,pc}  ;return
;
rq3 CMP    lr,#"Q"
    LDMNEDB fp,{fp,sp,pc} ;not recognised command
    CMP    R3,#1
    RSBGES lr,R3,#maxseq
    ADR    ip,slist       ;standard seeds
    LDRGE  R2,[ip,R3,LSL#3]!
    LDRGE  R3,[ip,#4]
    MOVLT  R2,#0
    MOVLT  R3,#0
    STR    R2,[R0]        ;store the seeds in IS1
    STR    R3,[R1]        ;and IS2
    LDMDB  fp,{fp,sp,pc}  ;return
;        predefined seeds
slist
    SEEDS
    END
;
      TTL  RANLUX
;
;         Subtract-and-borrow random number generator proposed by
;         Marsaglia and Zaman, implemented by F. James with the name
;         RCARRY in 1991, and later improved by Martin Luescher
;         in 1993 to produce "Luxury Pseudorandom Numbers".
;     ARM assembler code by DJCrennell August 1999
;
;   LUXURY LEVELS.
;   ------ ------      The available luxury levels are:
;
;  level 0  (p=24): equivalent to the original RCARRY of Marsaglia
;           and Zaman, very long period, but fails many tests.
;  level 1  (p=48): considerable improvement in quality over level 0,
;           now passes the gap test, but still fails spectral test.
;  level 2  (p=97): passes all known tests, but theoretically still
;           defective.
;  level 3  (p=223): DEFAULT VALUE.  Any theoretically possible
;           correlations have very small chance of being observed.
;  level 4  (p=389): highest possible luxury, all 24 bits chaotic.
;
;!!! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
;!!!  Calling sequences for RANLUX:                                  ++
;!!!      CALL RANLUX (RVEC, LEN)   returns a vector RVEC of LEN     ++
;!!!                   32-bit random floating point numbers between  ++
;!!!                   zero (not included) and one (also not incl.). ++
;!!!      CALL RLUXGO(LUX,INT,K1,K2) initializes the generator from  ++
;!!!               one 32-bit integer INT and sets Luxury Level LUX  ++
;!!!               which is integer between zero and MAXLEV, or if   ++
;!!!               LUX .GT. 24, it sets p=LUX directly.  K1 and K2   ++
;!!!               should be set to zero unless restarting at a break++
;!!!               point given by output of RLUXAT (see RLUXAT).     ++
;!!!      CALL RLUXAT(LUX,INT,K1,K2) gets the values of four integers++
;!!!               which can be used to restart the RANLUX generator ++
;!!!               at the current point by calling RLUXGO.  K1 and K2++
;!!!               specify how many numbers were generated since the ++
;!!!               initialization with LUX and INT.  The restarting  ++
;!!!               skips over  K1+K2*E9   numbers, so it can be long.++
;!!!   A more efficient but less convenient way of restarting is by: ++
;!!!      CALL RLUXIN(ISVEC)    restarts the generator from vector   ++
;!!!                   ISVEC of 25 32-bit integers (see RLUXUT)      ++
;!!!      CALL RLUXUT(ISVEC)    outputs the current values of the 25 ++
;!!!                 32-bit integer seeds, to be used for restarting ++
;!!!      ISVEC must be dimensioned 25 in the calling program        ++
;!!! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
;
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
F2  FN     2
F3  FN     3
maxlev EQU 4
       ^     0,R9
in24   #   4
kount  #   4
mkount #   4
i24    #   4
j24    #   4
carry  #   4
nskip  #   4
inseed #   4
luxlev #   4
ndskip #   4*(maxlev+1)
seeds  #   4*24
;
    AREA   |C$$data|,DATA
ntt DCD    0,0,0 ;in24,kount,mkount
    DCD    24,10 ;i24,j24
    DCFS   0.    ;carry
    DCD    199   ;nskip (originally ndskip(3))
    DCD 314159265;inseed
    DCD    3     ;luxlev
    DCD 0,24,73,199,365; ndskip(0:maxlev)
    DCD &3E7611BC,&3F1763F1,&3D86FEA0,&3F373A3D,&3ED2413A,&3D3DC1C0;seeds
    DCD &3F5DC56E,&3F61F117,&3F5751BE,&3EEA5414,&3EB333F6,&3E9E084E
    DCD &3F1DFE3E,&3E61ACEC,&3F1F0380,&3F2A6695,&3F1AEC05,&3D4E13F0
    DCD &3EA7DF9A,&3F3D71A2,&3D8FF4D0,&3F52814F,&3DA2E628,&3F6AF884
;
    AREA   |C$$code|,CODE,READONLY
    EXPORT ranlux_;(RVEC,LENV) returns a vector RVEC(LENV) of random numbers
    DCB    "ranlux_",0,8,0,0,255
ranlux_
    MOV    ip,sp
    STMDB  sp!,{R0-R1,R4-R9,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R9,lcm        ;define local area
    LDR    R1,[R1]       ;LENV (count)
    LDMIA  R9,{R4-R8}    ;in24,kount,mkount,i24,j24
    LDR    ip,gillion    ;10**9
lp1 SUBS   R1,R1,#1
    STMLTIA R9,{R4-R8}   ;save counts
    LDMLTDB fp,{R4-R9,fp,sp,pc} ;return
    ADD    R2,R9,R8,LSL#2
    ADD    R3,R9,R7,LSL#2
    LDFS   F0,[R2,#seeds-in24-4];seeds(j24)
    LDFS   F1,[R3,#seeds-in24-4];seeds(i24)
    LDFS   F2,carry
    SUFS   F3,F0,F1
    SUFS   F3,F3,F2      ;uni = seeds(j24) - seeds(i24) - carry
    CMF    F3,#0
    ADFLTS F3,F3,#1
;        TWOM24 =&33800000 ,  TWOM12 =&39800000
    MOVLT  lr,#&33800000;FLOAT(2**-24)
    MOVGE  lr,#0
    STR    lr,carry      ;carry = 0. or 2.**-24
    STFS   F3,[R3,#seeds-in24-4];store seeds(i24)
    SUBS   R7,R7,#1      ;j24 = next(j24)
    MOVLE  R7,#24
    SUBS   R8,R8,#1      ;i24 = next(i24)
    MOVLE  R8,#24
    LDFS   F0,twom12     ;2**-12
    CMF    F3,F0
;  small numbers (with less than 12 "significant" bits) are "padded".
    ADDLT  R2,R9,R8,LSL#2
    LDFLTS F1,[R2,#seeds-in24-4];seeds(j24)
    FMLS   F0,F0,F0      ;2**-24
    FMLLTS F1,F0,F1
    ADFLTS F3,F3,F1      ;add seeds(j24)*2**-24
    CMF    F3,#0
; and zero is forbidden in case someone takes a logarithm
    FMLLES F3,F0,F0      ;set to 2**-48 if zero
    STFS   F3,[R0],#4    ;store result
    ADD    R5,R5,#1      ;increment kount
    CMP    R5,ip
    MOVGT  R5,#0
    ADDGT  R6,R6,#1      ;increment mkount
; Skipping to luxury.  As proposed by Martin Luscher.
    ADD    R4,R4,#1      ;in24 = in24 + 1
    CMP    R4,#24
    BNE    lp1           ;loop over random numbers to find
    MOV    R4,#0         ;IF(in24.eq.24) then
    LDR    lr,nskip
lp2 SUBS   lr,lr,#1
    BLT    lp1
    ADD    R2,R9,R8,LSL#2
    ADD    R3,R9,R7,LSL#2
    LDFS   F0,[R2,#seeds-in24-4];seeds(j24)
    LDFS   F1,[R3,#seeds-in24-4];seeds(i24)
    LDFS   F2,carry
    SUFS   F3,F0,F1
    SUFS   F3,F3,F2      ;uni = seeds(j24) - seeds(i24) - carry
    CMF    F3,#0
    ADFLTS F3,F3,#1
    MOVLT  R2,#&33800000;FLOAT(2**-24)
    MOVGE  R2,#0
    STR    R2,carry      ;carry = 0. or 2.**-24
    STFS   F3,[R3,#seeds-in24-4];store seeds(i24)
    SUBS   R7,R7,#1      ;j24 = next(j24)
    MOVLE  R7,#24
    SUBS   R8,R8,#1      ;i24 = next(i24)
    MOVLE  R8,#24
    ADD    R5,R5,#1      ;increment kount
    CMP    R5,ip
    MOVGT  R5,#0
    ADDGT  R6,R6,#1      ;increment mkount
    B      lp2           ;loop nskip times
lcm DCD    ntt
twom12 DCD &39800000     ;2.**-12
twom24 DCD &33800000     ;2.**-24
gillion DCD 1000000000
;
    EXPORT rluxin_;(ISDEXT) restarts RANLUX from 25-vector ISDEXT
    IMPORT __rt_sdiv; R0 = R1/R0  (and R1=|remainder|)
    DCB    "rluxin_",0,8,0,0,255
rluxin_
    MOV    ip,sp
    STMDB  sp!,{R0-R1,R4-R9,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R9,lcm        ;define local area
    ADD    R1,R9,#seeds-in24;(seeds(1))
    LDFS   F1,twom24
    MOV    R7,#24        ;count for loop
lp3 LDR    ip,[R0],#4    ;ISDEXT(I)
    FLTS   F0,ip         ;FLOAT(ISDEXT(I))
    FMLS   F0,F0,F1
    STFS   F0,[R1],#4    ;store FLOAT(ISDEXT(I))*2**-24 in seeds(I)
    SUBS   R7,R7,#1
    BGT    lp3           ;loop I=1,24
    LDR    R1,[R0]       ;ISDEXT(25)
    CMP    R1,#0
    RSBLT  R1,R1,#0      ;|ISDEXT(25)|
    MOVLT  R7,#&33800000 ;2.**-24 (R7 is carry)
    MOV    R0,#100
    BL     __rt_sdiv
    MOV    R5,R1         ;i24
    MOV    R1,R0
    MOV    R0,#100
    BL     __rt_sdiv
    MOV    R6,R1         ;j24
    MOV    R1,R0
    MOV    R0,#100
    BL     __rt_sdiv
    MOV    R2,R1         ;in24 (luxlev in R0)
    CMP    R0,#maxlev
    ADRLE  R1,ndskip
    LDRLE  R8,[R1,R0,LSL#2];nskip = ndskip(luxlev)
    BLE    pt1
    SUBS   R8,R0,#24
    LDRLT  R8,ndskip+maxlev*4
pt1 MOV    ip,#-1        ;inseed
    MOV    lr,R0         ;luxlev
    LDMIB  R9,{R3,R4}    ;keep kount,mkount
;     store in24,kount,mkount,i24,j24,carry,nskip,inseed,luxlev
    STMIA  R9,{R2-R8,ip,lr}
    LDMDB  fp,{R4-R9,fp,sp,pc} ;return from RLUXIN
;
    EXPORT rluxut_;(ISDEXT) extracts state of RANLUX as 25-vector ISDEXT
    DCB    "rluxut_",0,8,0,0,255
rluxut_
    MOV    ip,sp
    STMDB  sp!,{R0-R1,R4-R9,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R9,lcm        ;define local area
    ADD    R1,R9,#seeds-in24;(seeds(1))
    LDFS   F0,twop24
    MOV    lr,#24        ;count
lp4 LDFS   F1,[R1],#4    ;SEEDS(I)
    FMLS   F1,F1,F0
    FIX    ip,F1
    STR    ip,[R0],#4    ;store ISDEXT(I) = SEEDS(I)*2.**24
    SUBS   lr,lr,#1
    BGT    lp4
; get  in24,kount,mkount,i24,j24,carry,nskip,inseed,luxlev
    LDMIA  R9,{R2-R8,ip,lr}
    MOV    ip,#100
    MLA    R1,lr,ip,R2   ;in24+100*luxlev
    MLA    R2,R1,ip,R6   ;j24+100*in24+10000*luxlev
    MLA    R3,R2,ip,R5   ;i24+100*j24+10000*in24+1000000*luxlev
    CMP    R7,#0
    RSBGT  R3,R3,#0      ;change sign if carry>0
    STR    R3,[R0]       ;store ISDEXT(25)
    LDMDB  fp,{R4-R9,fp,sp,pc} ;return from RLUXUT
;
twop24 DCD  &4B800000    ;2.**24
;
    EXPORT rluxat_;(LOUT,INOUT,K1,K2) gets four integer state of RANLUX
    DCB    "rluxat_",0,8,0,0,255
rluxat_
    MOV    ip,sp
    STMDB  sp!,{R0-R9,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R9,lcm        ;define local area
    LDMIB  R9,{R4-R9,ip,lr};load kount,mkount,,,,inseed,luxlev
    STR    lr,[R0]       ;LOUT=LUXLEV
    STR    ip,[R1]       ;INOUT=INSEED
    STR    R4,[R2]       ;K1=KOUNT
    STR    R5,[R3]       ;K2=MKOUNT
    LDMDB  fp,{R4-R9,fp,sp,pc} ;return from RLUXUT
;
    EXPORT rluxgo_;(LUX,INS,K1,K2) restarts RANLUX from four integer state
    DCB    "rluxgo_",0,8,0,0,255
rluxgo_
    MOV    ip,sp
    STMDB  sp!,{R0-R9,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R9,lcm        ;define local area
    ADR    ip,ndskip
    LDR    R8,[R0]       ;LUX
    CMP    R8,#0
    MOVLT  R8,#3         ;set luxlev to 3 if LUX<0
    CMP    R8,#maxlev
    BLE    pt2           ;set luxlev to LUX if in range
    CMP    R8,#24
    RSBGTS lr,R8,#2000
    MOVLT  R8,#maxlev    ;set luxlev to maxlev if LUX is illegal
    BLT    pt2
    MOV    R0,#maxlev    ;count (ilx)
lp5 LDR    lr,[ip,R0,LSL#2];ndskip(ilx)
    ADD    lr,lr,#24
    CMP    R8,lr
    MOVEQ  R8,R0         ;set luxlev to ilx
    SUBS   R0,R0,#1
    BGE    lp5           ;loop over ilx=maxlev,0,-1
pt2 CMP    R8,#maxlev
    LDRLE  R6,[ip,R8,LSL#2]
    SUBGT  R6,R8,#24     ;nskip = ndskip(luxlev) or luxlev-24
    LDR    R1,[R1]       ;JSEED=INS
    CMP    R1,#0
    LDRLE  R1,jsdflt     ;or default
    MOV    R7,R1         ;inseed = JSEED
    LDFS   F0,twom24     ;2**-24
    MOV    R5,#24        ;count
    ADR    R4,seeds      ;(SEEDS(1))
lp6 LDR    R0,b1         ;53668
    BL     __rt_sdiv    ;K=R0=JSEED/53668, R1=MOD(JSEED,53668)
    LDR    R2,b2         ;40014
    LDR    R3,b3         ;-12211
    MUL    ip,R2,R1      ;40014*MOD(JSEED,53668)
    MLA    R1,R3,R0,ip   ;40014*MOD(JSEED,53668) - 12211*[JSEED/53668]
    CMP    R1,#0
    LDRLT  R0,icons
    ADDLT  R1,R0,R1      ;next value of JSEED
    BIC    R0,R1,#&FF000000;l.s. 24 bits
    FLTS   F1,R0         ;float
    FMLS   F1,F1,F0      ;multilpy by 2.**-24
    STFS   F1,[R4],#4    ;store in seeds(i)
    SUBS   R5,R5,#1
    BGT    lp6           ;loop over i=1,24
    MOV    R3,#24        ;I24=24
    MOV    R4,#10        ;J24=10
    MVFS   F3,#0
    CMF    F1,F3
    LDFEQS F3,twom24     ;if seeds(24)=0 set carry to 2.**-24
    LDMIB  sp,{R0-R2}    ;get addresses of INS, K1, K2
    LDR    R1,[R1]       ;kount = K1
    LDR    R2,[R2]       ;mkount = K2
    MOV    R0,#0         ;initialize IN24
    ORRS   lr,R1,R2
    BEQ    pt3           ;skip if no count
    STMIB  R9,{R1,R2}    ;save kount and mkount
    CMP    R1,#0
    LDREQ  R1,gillion
    SUBEQ  R2,R2,#1
    ADR    ip,seeds-4    ;(seeds(0))
lp7 ADD    R5,ip,R3,LSL#2;(seeds(i24))
    ADD    lr,ip,R4,LSL#2;(seeds(j24))
    LDFS   F0,[R5]       ;seeds(i24)
    LDFS   F1,[lr]       ;seeds(j24)
    ADFS   F2,F0,F3
    SUFS   F1,F1,F2      ;seeds(j24)-seeds(i24)-carry
    CMF    F1,#0
    ADFLTS F1,F1,#1
    LDFLTS F3,twom24
    MVFGES F3,#0
    STFS   F1,[R5]       ;store new seeds(i24)
    SUBS   R3,R3,#1
    MOVLE  R3,#24        ;update i24
    SUBS   R4,R4,#1
    MOVLE  R4,#24        ;update j24
    ADD    R0,R0,#1      ;update in24
    CMP    R0,#24
    RSBGE  R0,R6,#0      ;restart in24 at -nskip
    SUBS   R1,R1,#1
    BGT    lp7           ;loop over singles
    LDR    R1,gillion
    SUBS   R2,R2,#1
    BGE    lp7           ;loop over gillions
    LDMIB  R9,{R1,R2}    ;now restore kount and mkount
pt3 STMIA  R9,{R0-R8}    ;store in24,kount,mkount,i24,j24,,nskip,inseed,luxlev
    STFS   F3,carry
    LDMDB  fp,{R4-R9,fp,sp,pc} ;return from RLUXUT
;
jsdflt DCD 314159265
b1  DCD    53668
b2  DCD    40014
b3  DCD    -12211
icons DCD  2147483563
;
    END
;
    TTL   ranmar
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
F2  FN     2
F3  FN     3
;
    AREA   |C$$data|,DATA
fst DCD    1       ;FIRST=.TRUE.
cmn %      412     ;103 words
;
    AREA   |C$$code|,CODE,READONLY
    EXPORT ranmar_;(RVEC,LENV) generate LENV random numbers in RVEC
    EXPORT ran_mar
    DCB    "ranmar_",0,8,0,0,255
ranmar_
    MOV    ip,sp
    STMDB  sp!,{R0,R1,R4-R9,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R4,ptrc
    LDR    R5,[R4,#-4]
    CMP    R5,#1
    LDREQ  R1,=54217137   ;first call without initialisation
    MOVEQ  R6,#0
    MOVEQ  R7,#0
    BEQ    rmar_in        ;go initialise
ran_mar;   entry from RMMAR
    LDR    R1,[R1]        ;get LENV
    LDMIB  R4,{R6-R9}     ;get NTOT,NTOT2,I97,J97
    LDR    lr,modcns
    ADD    R6,R6,R1       ;NTOT = NTOT + LENV
    CMP    R6,lr          ;IF(NTOT.GE.MODCNS) THEN
    ADDGE  R7,R7,#1       ;  NTOT2 = NTOT2 + 1
    SUBGE  R6,R6,lr       ;  NTOT = NTOT - MODCNS
    STMIB  R4,{R6,R7}     ;store NTOT,NTOT2
    LDFS   F0,[R4,#20]    ;C
    LDFS   F3,cd          ;CD
rl1 BL     step
    SUFS   F1,F1,F0       ;UNI = UNI - C
    CMF    F1,#0          ;IF(UNI.LT.0) THEN
    ADFLTS F1,F1,#1       ;  UNI = UNI + 1
    LDFEQS F1,[R4,#28]    ;IF(UNI.EQ.0.) THEN
    LDFEQS F2,twom24
    FMLEQS F1,F1,F2       ;  UNI = 2**-24 * U(2)
    CMFEQ  F1,#0          ;IF(UNI.EQ.0.) THEN
    LDFEQS F1,twom48      ;  UNI = 2**-48
    SUBS   R1,R1,#1
    STFGES F1,[R0],#4     ;store RVEC(I)
    BGT    rl1            ;loop over points
    STFEQS F0,[R4,#20]!   ;store C
    STMEQDB R4,{R8,R9}    ;store I97 and J97
    LDMDB  fp,{R4-R9,fp,sp,pc} 
;
step;  take 1 'random' step
    ADD    R2,R4,R8,LSL#2
    ADD    R3,R4,R9,LSL#2
    LDFS   F1,[R2,#20]    ;U(I97)
    LDFS   F2,[R3,#20]    ;U(J97)
    SUFS   F1,F1,F2       ;UNI = U(I97) - U(J97)
    CMF    F1,#0          ;IF(UNI.LT.0) THEN
    ADFLTS F1,F1,#1       ;  UNI = UNI + 1
    STFS   F1,[R2,#20]    ;U(I97) = UNI
    SUBS   R8,R8,#1       ;I97 = I97 - 1
    MOVEQ  R8,#97         ;IF(I97.EQ.0) I97 = 97
    SUBS   R9,R9,#1       ;J97 = J97 - 1
    MOVEQ  R9,#97         ;IF(J97.EQ.0) J97 = 97
    SUFS   F0,F0,F3       ;C = C - CD
    CMF    F0,#0          ;IF(C.LT.0) THEN
    LDFLTS F2,cm
    ADFLTS F0,F0,F2       ;  C = C + CM
    MOV    pc,lr
;
    LTORG
;
    EXPORT rmarut_;(IJKLUT,NTOTUT,NTO2UT) get state of RANMAR
    DCB    "rmarut_",0,8,0,0,255
rmarut_
    MOV    ip,sp
    STMDB  sp!,{R0-R2,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R3,ptrc
    LDMIA  R3,{R3,ip,lr}  ;get IJKL, NTOT & NTOT2
    STR    R3,[R0]        ;store IJKL
    STR    ip,[R1]        ;store NTOT
    STR    lr,[R2]        ;store NTOT2
    LDMDB  fp,{fp,sp,pc}  ;RETURN
;
ptrc DCD  cmn             ;pointer to RANMA1 data
;
twom24 DCFS 5.960464477539063E-8
twom48 DCFS 3.552713678800501E-15
cd     DCFS 0.456233084201813
cm     DCFS 0.999999821186066
cint   DCFS 2.160286903381348E-2
modcns DCD  1000000000
;
    IMPORT __rt_sdiv; R0 = R1/R0  (and R1=|remainder|)
    EXPORT rmarin_;(IJKLIN,NTOTIN,NTO2IN) initialise random numbers for RANMAR
    EXPORT rmar_in
    DCB    "rmarin_",0,8,0,0,255
rmarin_
    MOV    ip,sp
    STMDB  sp!,{R0-R2,R4-R9,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R4,ptrc
    MOV    R5,#0
    STR    R5,[R4,#-4]    ;ifst=.FALSE.
    LDR    R6,[R1]        ;NTOT = NTOTIN
    LDR    R1,[R0]        ;IJKL = IJKLIN
    LDR    R7,[R2]        ;NTOT2 = NTO2IN
rmar_in;       entry from RANMAR and RMMAQ
    STMIA  R4,{R1,R6,R7}  ;save IJKL, NTOT & NTOT2
    LDR    R0,=30082
    BL     __rt_sdiv     ;get IJ=IJKL/30082 in R0, KL=MOD(IJKL,30082) in R1
    MOV    R6,R0          ;save IJ
    MOV    R0,#169
    BL     __rt_sdiv     ;get KL/169 in R0, L=MOD(KL,169) in R1
    MOV    R9,R1          ;L
    MOV    R1,R0
    MOV    R0,#178
    BL     __rt_sdiv
    ADD    R8,R1,#1       ;K = MOD(KL/169,178) + 1
    MOV    R1,R6          ;IJ
    MOV    R0,#177
    BL     __rt_sdiv
    ADD    R7,R1,#2       ;J = MOD(IJ,177) + 2
    MOV    R1,R0
    MOV    R0,#177
    BL     __rt_sdiv
    ADD    R6,R1,#2       ;I = MOD(IJ/177,177) + 2
    STMFD  sp!,{R4,R5}    ;save R4,R5
    MOV    R4,#1          ;initialise II = 1
ln1 MVFS   F0,#0          ;S=0.
    MVFS   F1,#0.5        ;T = 0.5
    MOV    R5,#24         ;initialise JJ count
ln2 MUL    R1,R6,R7       ;I*J
    MOV    R0,#179
    BL     __rt_sdiv
    MUL    R1,R8,R1
    MOV    R0,#179
    BL     __rt_sdiv     ;M(R1)=MOD(MOD(I*J,179)*K,179)
    MOV    R6,R7          ;I=J
    MOV    R7,R8          ;J=K
    MOV    R8,R1          ;K=M
    MOV    R0,#53
    MUL    R1,R0,R9
    ADD    R1,R1,#1       ;L*53+1
    MOV    R0,#169
    BL     __rt_sdiv
    MOV    R9,R1          ;L = MOD(L*53+1,169)
    MUL    R0,R8,R9
    TST    R0,#&20        ;IF(MOD(K*L,64).GE.32) THEN
    ADFNES F0,F0,F1       ;  S = S + T
    FMLS   F1,F1,#0.5     ;T = T * 0.5
    SUBS   R5,R5,#1
    BGT    ln2            ;loop 24 times
    LDR    R0,[sp]        ;get pointer to common
    ADD    R0,R0,R4,LSL#2
    STFS   F0,[R0,#20]    ;U(II) = S
    ADD    R4,R4,#1
    CMP    R4,#97
    BLE    ln1            ;loop over II = 1,97
    LDMFD  sp!,{R4,R5}    ;restore R4, R5
    LDFS   F0,cint
    LDFS   F3,cd
    MOV    R8,#97         ;initialise I97 to 97
    MOV    R9,#33         ;initialise J97 to 33
    LDR    R7,[R4,#8]     ;NTOT2
ln3 SUBS   R7,R7,#1       ;loop NTOT2+1 times
    LDRGE  R6,modcns      ;inner loop over 1000000000
    LDRLT  R6,[R4,#4]     ;or NTOT for last of NTOT2
    CMP    R6,#0
    BEQ    pn1
ln4 BL     step
    SUBS   R6,R6,#1
    BGT    ln4            ;inner loop
    CMP    R7,#0
    BGE    ln3            ;loop NTOT2+1 times
pn1 MOV    R7,R6
    STMIB  R4,{R6-R9}     ;set NTOT and NTOT2 = 0, store I97 and J97
    STFS   F0,[R4,#20]    ;store C
    SUBS   R5,R5,#1       ;IF(FIRST) THEN
    STREQ  R5,[R4,#-4]    ;  FIRST = .TRUE.
    LDMEQIA sp,{R0,R1}    ;  restore RANMAR arguments
    BEQ    ran_mar        ;  return to RANMAR
    LDMDB  fp,{R4-R9,fp,sp,pc} ; ELSE RETURN
    END
;
;          RANNOR see RNDM
;
    TTL    RCHAR
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
F0  FN     0
F1  FN     1
F2  FN     2
R2  RN     2
R1  RN     1
R0  RN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT rchar_;(STRING) -> REAL from ASCII decimal with optional '.'
    DCB    "rchar_",0,0,8,0,0,255
rchar_
    MOV    ip,sp
    STMDB  sp!,{R0,R1,fp,ip,lr,pc}
    SUB    fp,ip,#4
    MVFE   F1,#1        ;sign
    MVFE   F2,#0        ;accumulator
    MOV    R2,#0        ;decimal flag
lp1 LDRB   ip,[R0],#1   ;get byte of STRING
    CMP    ip,#"-"
    MNFEQE F1,F1        ;change sign on "-"
    CMP    ip,#"."
    MOVEQ  R2,#1        ;start decimal count on "."
    RSBS   ip,ip,#"9"
    RSBGES ip,ip,#9     ;ASCII -> binary digit (GE)
    MUFGEE F2,F2,#10    ;acc = acc * 10
    FLTGEE F0,ip
    CMPGE  R2,#0
    ADFGEE F2,F2,F0     ;acc = acc + digit
    MUFGTE F1,F1,#10    ;account for digits after "."
    SUBS   R1,R1,#1
    BGT    lp1          ;loop over STRING
    DVFD   F0,F2,F1     ;correct for sign and decimal position
    LDMDB  fp,{fp,sp,pc} ;return if finished
    END
;
;          RDMIN see RNDM
;          RDMOUT see RNDM
;
    TTL    REPEAT
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R4  RN     4
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT repeat_;(STR,N) ==> string with n copies of STR
    DCB    "repeat_",0,8,0,0,255
repeat_
    MOV    ip,sp
    STMDB  sp!,{R0-R4,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    ip,[fp,#4]  ;length of STR
    LDR    R4,[R3]     ;n
    MOV    R3,#0       ;pointer in str
wt1 CMP    ip,R3
    MOVLE  R3,#0       ;cycle through str
    SUBLES R4,R4,#1    ;n times
    LDRGTB lr,[R2,R3]
    ADDGT  R3,R3,#1
    STRGTB lr,[R0],#1
    SUBGTS R1,R1,#1
    BGT    wt1         ;loop over chars in answer
    MOV    lr,#" "
    CMP    R1,#0
wt2 STRGTB lr,[R0],#1  ;top-up with blanks
    SUBGTS R1,R1,#1
    BGT    wt2
    LDMDB  fp,{R4,fp,sp,pc} ;return
    END
;
    TTL    REQINV
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R0  RN     0
R3  RN     3
R4  RN     4
R5  RN     5
R6  RN     6
R7  RN     7
R8  RN     8
    AREA   |C$$code|,CODE,READONLY
    EXPORT reqinv_;(N,A,IDIM,IR,IFAIL,K,B) sets A=1/A, finds X=B/A
    IMPORT rfact_
    IMPORT rfeqn_
    IMPORT rfinv_
    DCB    "reqinv_",0,8,0,0,255
reqinv_
    MOV    ip,sp
    STMDB  sp!,{R0-R8,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDMIB  fp,{R4,R7,R8}   ;addresses of IFAIL,K,B
    SUB    sp,sp,#8        ;space for DET and JFAIL
    MOV    R5,sp           ;address for DET
    ADD    R6,R5,#4        ;address for JFAIL
    STMFD  sp!,{R4-R6}     ;addresses of IFAIL,DET,JFAIL
    BL     rfact_
    ADD    sp,sp,#20       ;restore stack
    LDMIA  sp,{R0-R3}      ;restore N,A,IDIM,R
    LDR    ip,[R4]
    CMP    ip,#0           ;test IFAIL
    LDMNEDB fp,{R4-R8,fp,sp,pc} ;return
    STMFD   sp!,{R7,R8}    ;if OK, store addresses of K,B
    BL     rfeqn_          ;call RFEQN
    ADD    sp,sp,#8        ;and restore stack
    LDMIA  sp,{R0-R3}      ;restore N,A,IDIM,R
    BL     rfinv_          ;call RFINV if OK
    LDMDB  fp,{R4-R8,fp,sp,pc} ;return
    END
;
    TTL    REQN
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R0  RN     0
R3  RN     3
R4  RN     4
R5  RN     5
R6  RN     6
R7  RN     7
R8  RN     8
    AREA   |C$$code|,CODE,READONLY
    EXPORT reqn_;(N,A,IDIM,IR,IFAIL,K,B) solves X=B/A, A is any non-singular matrix
    IMPORT rfact_
    IMPORT rfeqn_
    DCB    "reqn_",0,0,0,8,0,0,255
reqn_
    MOV    ip,sp
    STMDB  sp!,{R0-R8,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDMIB  fp,{R4,R7,R8}   ;addresses of IFAIL,K,B
    SUB    sp,sp,#8        ;space for DET and JFAIL
    MOV    R5,sp           ;address for DET
    ADD    R6,R5,#4        ;address for JFAIL
    STMFD  sp!,{R4-R6}     ;addresses of IFAIL,DET,JFAIL
    BL     rfact_
    ADD    sp,sp,#20       ;restore stack
    LDR    ip,[R4]         ;get IFAIL
    CMP    ip,#0
    LDMEQFD sp!,{R0-R3}    ;restore N,A,IDIM,R
    STMEQFD sp!,{R7,R8}    ;if OK, store addresses of K,B
    BLEQ   rfeqn_          ;call RFEQN
    LDMDB  fp,{R4-R8,fp,sp,pc} ;return
    END
;
    TTL    RFACT
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
F2  FN     2
F3  FN     3
F4  FN     4
F5  FN     5
F6  FN     6
F7  FN     7
    AREA   |C$$code|,CODE,READONLY
    EXPORT rfact_;(N,A,IDIM,IR,IFAIL,DET,JFAIL) set A and R for RFEQN and RFINV
    DCB    "rfact_",0,0,8,0,0,255
rfact_
    MOV    ip,sp
    STMDB  sp!,{R0-R9,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R0,[R0]          ;N
    LDR    R2,[R2]          ;IDIM
    CMP    R0,#1
    CMPGE  R2,R0
    LDRLT  R1,[fp,#4]       ;address of IFAIL
    MOVLT  R0,#1
    STRLT  R0,[R1]
    LDMLTDB  fp,{R4-R9,fp,sp,pc} ;return IFAIL=1 if dimensions bad
    STFE   F7,[sp,#-12]!    ;save floating registers
    STFE   F6,[sp,#-12]!
    STFE   F5,[sp,#-12]!
    STFE   F4,[sp,#-12]!
;         initialise variables
    MVFE   F7,#1            ;DET=1
    LDFS   F5,CSMA          ;minimum DET
    LDFS   F6,CBIG       ;maximum DET
    MOV    ip,#0            ;initialise JFAIL
    SUB    R4,R1,#4         ;(J-1,J) J=1
    MOV    R5,#0            ;J="1"
;         main loop over J=1,N
lpj MOV    lr,#0            ;max |pivot| value
    MOV    R6,#-1           ;initialise K
    SUB    R7,R0,R5         ;I count (=N-J+1)
    ADD    R8,R4,#4         ;(I,J) I=J
wl1 LDR    R9,[R8],#4       ;A(I,J)
    BIC    R9,R9,#&80000000
    CMP    R9,lr
    MOVGT  lr,R9            ;find maximum
    SUBGT  R6,R0,R7         ;set K to index of max
    SUBS   R7,R7,#1
    BGT    wl1              ;loop over I
    CMP    R6,R5            ;K should be >= J
    BLT    fail             ;singular if not
;         swap pivot columns if K>J
    MNFGTE F7,F7            ;change DET sign
    ADDGT  R7,R6,R5,LSL#12  ;pack J,K
    STRGT  R7,[R3,#4]!      ;store in IR
    ADDGT  R7,R1,R5,LSL#2   ;(j,1)
    ADDGT  R8,R1,R6,LSL#2   ;(k,1)
    MOVGT  R6,R0            ;counter
wl2 LDRGT  R9,[R7]
    LDRGT  lr,[R8]
    STRGT  R9,[R8],R2,LSL#2
    STRGT  lr,[R7],R2,LSL#2 ;swap columns
    SUBGTS R6,R6,#1
    BGT    wl2              ;loop over rows
    LDFS   F4,[R4,#4]!      ;get A(J,J)
    MUFE   F7,F7,F4         ;DET=DET*A(J,J)
    FRDS   F4,F4,#1
    STFS   F4,[R4]          ;A(J,J)=1/A(J,J)
;         check DET is within bounds
    ABSS   F0,F7
    CMF    F0,F5
    MVFLEE F7,#0            ;too small, set to 0
    CMPLES ip,#0
    MOVEQ  ip,#-1           ;set jfail = -1
    CMF    F0,F6
    MVFGEE F7,#1            ;too big, set to 1
    CMPGES ip,#0
    MOVEQ  ip,#1            ;set jfail = +1
;         now factorise matrix
    ADD    R5,R5,#1         ;virtual increment j
    SUBS   R6,R0,R5         ;K count = N-J
    BLE    finish           ;done when J=N
    ADD    R7,R4,R2,LSL#2   ;(J,K) K=J+1
    ADD    R8,R7,#4         ;(K,J+1) K=J+1
;         loop K = J+1 to N
wl3 LDFS   F0,[R7],#-4      ;-s11=A(J,K) : R7=(I,K) I=J-1
    SUB    lr,R4,R2,LSL#2   ;(J,I) I=J-1
    SUBS   R9,R5,#1         ;I-count
;         loop I = J-1,1,-1
wl4 LDFGTS F2,[R7],#-4      ;A(I,K)
    LDFGTS F3,[lr]          ;A(J,I)
    SUBGT  lr,lr,R2,LSL#2   ;(J,I-1)
    MUFGTE F2,F2,F3
    SUFGTE F0,F0,F2         ;-s11=-s11-A(I-1,K)*A(J,I-1)
    SUBS   R9,R9,#1
    BGT    wl4              ;loop over I
    MUFE   F0,F0,F4         ;-s11=-s11*A(J,J)
    ADD    R7,R7,R5,LSL#2   ;restore (J,K)
    STFS   F0,[R7]          ;A(J,K)=-s11
    LDFS   F1,[R8]          ;-s12=A(K,J+1)
    ADD    R9,R4,R2,LSL#2   ;(I,J+1) I=J
    SUB    R0,R8,R2,LSL#2   ;(K,I) I=J
    MOV    lr,R5            ;I-count
;           loop over I=J,1,-1
wl5 LDFS   F2,[R9],#-4      ;A(I,J+1) : (I-1,J+1)
    LDFS   F3,[R0]          ;A(K,I)
    SUB    R0,R0,R2,LSL#2   ;(K,I-1)
    MUFE   F2,F2,F3
    SUFE   F1,F1,F2         ;-s12=-s12-A(I,J+1)*A(K,I)
    SUBS   lr,lr,#1
    BGT    wl5              ;loop over I
    ADD    R7,R7,R2,LSL#2   ;(J,K+1)
    STFS   F1,[R8],#4       ;A(K,J+1)=-s12 : (K+1,J+1)
    SUBS   R6,R6,#1
    BGT    wl3              ;loop over K
    LDR    R0,[sp,#48]
    LDR    R0,[R0]          ;restore R0 to N
    ADD    R4,R4,R2,LSL#2   ;(J,J+1)
    B      lpj              ;loop over J
fail;    singular matrix, IFAIL (R6) =-1
    MVFS   F7,#0            ;determinant is zero
    MOV    ip,#0            ;and JFAIL=0
finish;         done, so tidy up
    LDR    R7,[sp,#60]      ;address of IR
    SUB    R3,R3,R7         ;length of IR
    STR    R3,[R7]          ;store last IR used
    LDMIB  fp,{R7,R8,R9}    ;addresses of IFAIL,DET,JFAIL
    STR    R6,[R7]          ;store IFAIL
    STFS   F7,[R8]          ;store DET
    STR    ip,[R9]          ;store JFAIL
    LDFE   F4,[sp],#12      ;restore floating registers
    LDFE   F5,[sp],#12
    LDFE   F6,[sp],#12
    LDFE   F7,[sp],#12
    LDMDB  fp,{R4-R9,fp,sp,pc} ;return
CSMA DCFS  1.0E-19
CBIG DCFS  1.0E+19
    END
;
    TTL    RFEQN
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
F2  FN     2
F3  FN     3
    AREA   |C$$code|,CODE,READONLY
    EXPORT rfeqn_;(N,A,IDIM,IR,K,B) solves X=B/A, A prepared by RFACT
    DCB    "rfeqn_",0,0,8,0,0,255
rfeqn_
    MOV    ip,sp
    STMDB  sp!,{R0-R9,fp,ip,lr,pc}
    SUB    fp,ip,#4
;         initialise variables
    LDR    R0,[R0]         ;N
    LDR    R2,[R2]         ;IDIM
    LDMIB  fp,{R4,R5}      ;extra arg addresses
    LDR    R4,[R4]         ;K
    CMP    R0,#1
    CMPGE  R4,#1
    CMPGE  R2,R0
    LDMLTDB fp,{R4-R9,fp,sp,pc} ;return if N<1 or IDIM<N or K<1
;         first do row swapping
    LDR    R7,[R3]
    ADD    R7,R7,R3        ;last swap entry
    CMP    R3,R7
    BGE    wm3             ;skip if none
;         loop over entries
wm1 LDR    R8,[R3,#4]!
    MOV    R9,R8,LSR#12    ;I
    BIC    R8,R8,R9,LSL#12 ;J
    ADD    R9,R5,R9,LSL#2  ;(I,1)
    ADD    R8,R5,R8,LSL#2  ;(J,1)
    MOV    lr,R4           ;L count
;         loop over L=1,K
wm2 LDR    R6,[R8]         ;swap columns
    LDR    ip,[R9]
    STR    R6,[R9],R2,LSL#2
    STR    ip,[R8],R2,LSL#2
    SUBS   lr,lr,#1
    BGT    wm2             ;loop over L rows
    CMP    R3,R7
    BLT    wm1             ;loop over entries
;         loop over columns of B (L=1,K)
wm3 SUB    R8,R5,#4        ;(I-1,L) I=1
    SUB    R7,R1,R2,LSL#2  ;(I,I-1) I=1
    MOV    R9,R0           ;I count (=N)
;         loop over I=1,N
wm4 LDFS   F0,[R8,#4]!     ;-s21=B(I,L)
    SUBS   lr,R0,R9        ;J count (=I-1)
    ADDGT  R6,R1,lr,LSL#2  ;(I,J) J=1
    MOVGT  ip,R5           ;(J,L) J=1
;         loop over J=1,I-1
wm5 LDFGTS F1,[R6]         ;A(I,J)
    ADDGT  R6,R6,R2,LSL#2  ;(I,J+1)
    LDFGTS F2,[ip],#4      ;B(J,L) : (J+1,L)
    MUFGTE F1,F1,F2
    SUFGTE F0,F0,F1        ;-s21=-s21-A(I,J)*B(J,L)
    SUBGTS lr,lr,#1
    BGT    wm5             ;loop over J
    ADD    R7,R7,R2,LSL#2  ;(I,I)
    LDFS   F1,[R7],#4      ;A(I,I) : (I+1,I)
    MUFE   F0,F0,F1
    STFS   F0,[R8]         ;B(I,L)=-A(I,I)*s21
    SUBS   R9,R9,#1
    BGT    wm4             ;loop over I
    SUBS   R9,R0,#1        ;I count (N-1)
    BEQ    wm8
;         loop over I=N-1,1,-1
wm6 LDFS   F0,[R8,#-4]!    ;-s22=B(I,L)
    SUB    R6,R0,R9        ;J count (=N-I)
    SUB    R7,R7,#4        ;(I+1,N)
    SUB    lr,R7,#4        ;(I,J) J=N
    ADD    ip,R5,R0,LSL#2  ;(J+1,L) J=N
;         loop over J=N,I+1,-1
wm7 LDFS   F1,[lr]         ;A(I,J)
    SUB    lr,lr,R2,LSL#2;(I,J-1)
    LDFS   F2,[ip,#-4]!    ;B(J,L)
    MUFE   F1,F1,F2
    SUFE   F0,F0,F1        ;-s22=-s22-A(I,J)*B(J,L)
    SUBS   R6,R6,#1
    BGT    wm7             ;loop over J
    STFS   F0,[R8]         ;B(I,L)=-s22
    SUBS   R9,R9,#1
    BGT    wm6             ;loop over I
wm8 ADD    R5,R5,R2,LSL#2  ;(1,L+1)
    SUBS   R4,R4,#1
    BGT    wm3             ;loop over L
    LDMDB  fp,{R4-R9,fp,sp,pc} ;return
    END
;
    TTL    RFFT
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
F0  FN     0
F1  FN     1
F2  FN     2
F3  FN     3
F4  FN     4
F5  FN     5
F6  FN     6
F7  FN     7
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 rfft_  ;(A,MSIGN) real Fast Fourier Transform
    IMPORT cfft_  ;(A,MSIGN)
;
    DCB    "rfft_",0,0,0,8,0,0,255
rfft_
    MOV    ip,sp
    STMDB  sp!,{R0,R1,R4-R6,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R6,[R1]       ;MSIGN
    ADDS   R4,R6,#0
    LDMEQDB fp,{R4-R6,fp,sp,pc} ;return if MSIGN=0
    SUB    R1,sp,#4      ;pointer to space for (+-)M for CFFT
    STFE   F4,[sp,#-16]! ;extra 4 bytes for (+-)M
    STFE   F5,[sp,#-12]! ;save floating registers
    STFE   F6,[sp,#-12]!
    STFE   F7,[sp,#-12]!
    RSBLT  R4,R4,#0      ;M'=IABS(MSIGN)  (=M+1)
    MOV    R3,#1
    MOV    R3,R3,LSL R4  ;2N=2**M'
    ADD    R5,R0,R3,LSL#2;save (K), K=N+1
    MVFGTD F5,#1
    MNFLTD F5,#1         ;I(U)=ISIGN(1,MSIGN)
    LDFD   F6,TWOPI
    FLTD   F7,R3
    MNFLTD F7,F7
    DVFD   F6,F6,F7      ;ANGL (=(+-)pi/N)
    SIND   F7,F6
    COSD   F6,F6         ;W = rotation vector
    RSBLT  ip,R4,#1      ;-M
    SUBGT  ip,R4,#1      ;+M
    STR    ip,[R1]       ;store +-M on stack for CFFT
    BGT    pt1
;
    FLTS   F4,R3         ;2N
    FRDS   F4,F4,#0.5    ;0.25/N
    BL     cfft_         ;CALL CFFT(A,-M)
    LDR    R0,[sp,#52]   ;restore [A(1)]
    MOV    R2,R0
lp1 LDFS   F0,[R2]
    LDFS   F1,[R2,#4]
    FMLS   F0,F0,F4
    FMLS   F1,F1,F4
    STFS   F0,[R2],#4
    STFS   F1,[R2],#4    ;A(I)=A(I)*0.25/N
    CMP    R2,R5
    BLT    lp1           ;loop until I=K
    LDMIA  R0,{ip,lr}
    STMIA  R5,{ip,lr}    ;A(N+1)=A(1)
;
pt1 MOV    R2,R0         ;(J), J=1
    MVFD   F4,#0         ;R(U)=0
;
lp2 LDFS   F0,[R2]      ;R(A(J))
    LDFS   F1,[R5]      ;R(A(K))
    SUFS   F0,F0,F1     ;R( A(J)-CONJG(A(K)) )
    LDFS   F2,[R2,#4]   ;I(A(J))
    LDFS   F1,[R5,#4]   ;I(A(K))
    ADFS   F1,F1,F2     ;I( A(J)-CONJG(A(K)) )
    FMLS   F2,F1,F5
    FMLLTS F3,F0,F4     ;(F4=0 first time)
    SUFLTS F2,F2,F3     ;-R(T2)
    FMLS   F3,F0,F5
    FMLLTS F1,F1,F4
    ADFLTS F3,F3,F1     ;I(T2)
    LDFS   F0,[R2,#4]   ;I(A(J))
    LDFS   F1,[R5,#4]   ;I(A(K))
    SUFS   F0,F0,F1     ;I(T1), T1=A(J)+CONJG(A(K))
    ADFS   F1,F0,F3
    SUFS   F3,F3,F0
    STFS   F1,[R2,#4]   ;I(A(J))= I(T1+T2)
    STFS   F3,[R5,#4]   ;I(A(K))= I(CONJG(T1-T2))= I(T2-T1)
    LDFS   F0,[R2]      ;R(A(J))
    LDFS   F1,[R5]      ;R(A(K))
    ADFS   F0,F0,F1     ;R(T1)
    SUFS   F1,F0,F2
    ADFS   F3,F0,F2
    STFS   F1,[R2],#8   ;R(A(J))= R(T1+T2), J=J+2
    STFS   F3,[R5],#-8  ;R(A(K))= R(CONJG(T1-T2))=R(T1-T2), K=K-2
    CMP    R2,R5
    MUFLTD F0,F4,F6
    MUFLTD F1,F5,F7
    MUFLTD F2,F4,F7
    MUFLTD F3,F5,F6
    SUFLTD F4,F0,F1
    ADFLTD F5,F2,F3    ;U=U*W
    BLT    lp2
    LDFEQS F1,[R2,#4]
    LDFEQS F0,[R2]
    ADFEQS F1,F1,F1
    ADFEQS F0,F0,F0
    MNFEQS F1,F1
    STFEQS F0,[R2]
    STFEQS F1,[R2,#4]  ;A(N/2)=2*CONJG( A(N/2) )
    CMP    R6,#0
    BLGT   cfft_       ;IF(MSIGN.GT.0) CALL CFFT(A,M)
    LDFE   F7,[sp],#12 ;restore floating registers
    LDFE   F6,[sp],#12
    LDFE   F5,[sp],#12
    LDFE   F4,[sp]
    LDMDB  fp,{R4-R6,fp,sp,pc} 
TWOPI DCFD 6.28318530717958647693
    END
;
    TTL    RFINV
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
F2  FN     2
F3  FN     3
F4  FN     4
    AREA   |C$$code|,CODE,READONLY
    EXPORT rfinv_;(N,A,IDIM,IR) puts A=1/A (A prepared by RFACT)
    DCB    "rfinv_",0,0,8,0,0,255
rfinv_
    MOV    ip,sp
    STMDB  sp!,{R0-R9,fp,ip,lr,pc}
    SUB    fp,ip,#4
;         initialise variables
    LDR    R0,[R0]         ;N
    LDR    R2,[R2]         ;IDIM
;         check for trivial case: N=1
    CMP    R0,#2
    CMPGE  R2,R0           ;ensure NDIM >= N
    LDMLTDB fp,{R4-R9,fp,sp,pc} ;return
    STFE   F4,[sp,#-12]!
    SUB    R0,R0,#1        ;N-1
    MOV    R4,#1           ;"I-1"
    MOV    R5,R1           ;(I-1,I-1)
;         loop over I = 2,N
wn1 ADD    R6,R5,#4        ;(I,I-1)
    ADD    R5,R6,R2,LSL#2  ;(I,I)
    LDFS   F4,[R5]         ;A(I,I)
    ADD    R7,R1,R4,LSL#2  ;(I,J) J=1
    SUB    R8,R5,R4,LSL#2  ;(J,I) J=1
;         loop over J=1,I-1
wn2 MVFE   F0,#0           ;-s31=0
    LDFS   F1,[R8]         ;s32=A(J,I)
    SUB    ip,R7,#4        ;(K,J) K=I-1
    MOV    R9,R6           ;(I,K) K=I-1
    SUB    lr,R8,R2,LSL#2  ;(J,K) K=I-1
    SUB    R3,R5,#4        ;(K,I) K=I-1
;         loop over K=I-1,J,-1
wn3 LDFS   F2,[ip],#-4     ;A(K,J) : (K-1,J)
    LDFS   F3,[R9]         ;A(I,K)
    SUB    R9,R9,R2,LSL#2  ;(I,K-1)
    MUFE   F2,F2,F3
    SUFE   F0,F0,F2        ;-s31=-s31-A(K,J)*A(I,K)
    CMP    R9,R7           ;(I,K') <=> (I,J)
    LDFGES F2,[lr]         ;A(J,K)
    SUBGE  lr,lr,R2,LSL#2  ;(J,K-1)
    LDFGES F3,[R3],#-4     ;A(K,I) : (K-1,I)
    MUFGEE F2,F2,F3
    ADFGEE F1,F1,F2        ;s32=s32+A(J,K)*A(K,I)
    BGE    wn3             ;loop over K
    MUFE   F0,F0,F4
    STFS   F0,[R7]         ;A(I,J)=-s31*A(I,I)
    ADD    R7,R7,R2,LSL#2  ;(I,J+1)
    MNFE   F1,F1
    STFS   F1,[R8],#4      ;A(J,I)=-s32 : (J+1,I)
    CMP    R7,R6           ;(I,J') <=> (I,I-1)
    BLE    wn2             ;loop over J
    ADD    R4,R4,#1        ;increment "I-1"
    CMP    R4,R0           ;compare with N-1
    BLE    wn1             ;loop over "I-1"
;
    SUB    R6,R5,R0,LSL#2  ;(I,N) I=1
    MOV    R5,R1           ;(I,1) I=1
    MOV    R4,R0           ;I count (=N-I)
;         loop over I = 1,N-1
wn4 MOV    R7,R5           ;(I,J) J=1
    ADD    R8,R1,R0,LSL#2  ;(N,J) J=1
    MOV    lr,R0           ;J count (=N-J)
;         loop over J = 1,N
wn5 MOV    ip,R8           ;(K,J) K=N
    MOV    R9,R6           ;(I,K) K=N
    CMP    lr,R4           ;compare N-J with N-I
    LDFGES F0,[R7]         ;s=A(I,J) if J<=I
    MVFLTE F0,#0           ;s=0 if J>I
    MOVGE  R3,R4           ;K count = N-I if J<=I
    ADDLT  R3,lr,#1        ;K count = N-J+1 if J>I
;         loop over K
wn6 LDFS   F1,[ip],#-4     ;A(K,J) : (K-1,J)
    LDFS   F2,[R9]         ;A(I,K)
    SUB    R9,R9,R2,LSL#2  ;(I,K-1)
    MUFE   F1,F1,F2
    ADFE   F0,F0,F1        ;s=s+A(K,J)*A(I,K)
    SUBS   R3,R3,#1
    BGT    wn6             ;loop over K
    STFS   F0,[R7]         ;A(I,J)=s
    ADD    R8,R8,R2,LSL#2  ;(N,J+1)
    ADD    R7,R7,R2,LSL#2  ;(I,J+1)
    SUBS   lr,lr,#1
    BGE    wn5             ;loop over J, N times
    ADD    R5,R5,#4        ;(I+1,1)
    ADD    R6,R6,#4        ;(I+1,N)
    SUBS   R4,R4,#1
    BGT    wn4             ;loop over I N-1 times
;         now exchange columns
    LDFE   F4,[sp],#12     ;restore F4
    LDR    R3,[sp,#12]     ;restore address of IR
    LDR    R4,[R3]
    ADD    R4,R4,R3        ;end of list
;         loop over exchanges
wn7 CMP    R4,R3
    LDMLEDB fp,{R4-R9,fp,sp,pc} ;return
    LDR    R5,[R4],#-4
    MOV    R6,R5,LSR#12    ;I
    BIC    R5,R5,R6,LSL#12 ;J
    MUL    R6,R2,R6
    MUL    R5,R2,R5
    ADD    R6,R1,R6,LSL#2  ;(1,I)
    ADD    R5,R1,R5,LSL#2  ;(1,J)
    MOV    R7,R0
wn8 LDR    R8,[R6]
    LDR    R9,[R5]
    STR    R8,[R5],#4
    STR    R9,[R6],#4
    SUBS   R7,R7,#1
    BGE    wn8             ;loop N times
    B      wn7
    END
;
;        RGS56P  see DGS56P
;
    TTL    RINV
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R0  RN     0
R3  RN     3
R4  RN     4
R5  RN     5
R6  RN     6
    AREA   |C$$code|,CODE,READONLY
    EXPORT rinv_;(N,A,IDIM,R,IFAIL) finds 1/A, A is any non-singular matrix
    IMPORT rfact_
    IMPORT rfinv_
    DCB    "rinv_",0,0,0,8,0,0,255
rinv_
    MOV    ip,sp
    STMDB  sp!,{R0-R6,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R4,[fp,#4]      ;address of IFAIL
    SUB    sp,sp,#8        ;space for DET and JFAIL
    MOV    R5,sp
    ADD    R6,R5,#4        ;addresses for DET and JFAIL
    STMFD  sp!,{R4-R6}
    BL     rfact_
    ADD    sp,sp,#20       ;restore stack
    LDMFD  sp!,{R0-R3}     ;restore addresses of N,A,IDIM,R
    LDR    ip,[R4]
    CMP    ip,#0           ;test IFAIL
    BLEQ   rfinv_          ;call RFINV if OK
    LDMDB  fp,{R4-R6,fp,sp,pc} ;return
    END
;
    TTL   RKSTP
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
F1  FN    1
F2  FN    2
F3  FN    3
F6  FN    6
F7  FN    7
    AREA   |C$$code|,CODE,READONLY
    EXPORT rkstp_;(N,H,X,Y,SUB,W) differential equations (Runge-Kutta)
    DCB    "rkstp_",0,0,8,0,0,255
rkstp_
    MOV    ip,sp
    STMDB  sp!,{R0-R7,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R6,[R0]      ;N
    CMP    R6,#1
    LDMLTDB fp,{R4-R7,fp,sp,pc} ;return if N<1
    STFE   F6,[sp,#-12]!;save floating registers
    STFE   F7,[sp,#-12]!
    SUB    sp,sp,#lsk   ;space for variables
    LDMIA  ip,{R4,R5}   ;(SUB),(W)
    LDFS   F7,[R1]      ;H
    LDFS   F0,[R2]      ;X
    MUFS   F6,F7,#0.5   ;H2 = H/2
    ADFS   F1,F0,F7
    ADFS   F2,F0,F6
    STFS   F1,xh        ;XH = X+H
    STFS   F2,xh2       ;XH2= X+H/2
    MOV    R0,R2
    MOV    R1,R3
    MOV    R2,R5
    BL     sub          ;CALL SUB(X,Y,W(1,1))
    MOV    lr,R6        ;loop count
    LDR    R0,[fp,#-32] ;(Y(1))
    MOV    R1,R5        ;(W(1,1))
    ADD    R2,R5,R6,LSL#2;(W(1,2))
lp1 LDFS   F0,[R1],#4   ;W(J,1)
    LDFS   F1,[R0],#4   ;Y(J)
    MUFS   F0,F0,F6
    ADFS   F0,F0,F1
    STFS   F0,[R2],#4   ;W(J,2) = Y(J) + H2*W(J,1)
    SUBS   lr,lr,#1
    BGT    lp1          ;loop over J
    MOV    R7,#2        ;do next bit twice
lp2 ADR    R0,xh2
    ADD    R1,R5,R6,LSL#2
    ADD    R2,R1,R6,LSL#2
    BL     sub          ;CALL SUB(XH2,W(1,2),W(1,3))
    LDR    R0,[fp,#-32] ;(Y(1))
    MOV    R1,R5        ;(W(1,1))
    ADD    R2,R5,R6,LSL#2;(W(1,2))
    ADD    R3,R2,R6,LSL#2;(W(1,3))
    MOV    lr,R6        ;loop count
lp3 LDFS   F0,[R3],#4   ;W(J,3)
    LDFS   F2,[R1]      ;W(J,1)
    LDFS   F1,[R0],#4   ;Y(J)
    ADFS   F3,F0,F0     ;2*W(J,3)
    MUFS   F0,F0,F6     ;H2*W(J,3)
    ADFS   F3,F3,F2
    ADFS   F1,F1,F0
    STFS   F3,[R1],#4   ;W(J,1) = W(J,1) + 2*W(J,3)
    STFS   F1,[R2],#4   ;W(J,2) = Y(J) + H2*W(J,3)
    SUBS   lr,lr,#1
    BGT    lp3          ;loop over J
    SUBS   R7,R7,#1
    MVFGTS F6,F7        ;use H rather than H2 for second time
    BGT    lp2
    ADR    R0,xh
    ADD    R1,R5,R6,LSL#2
    ADD    R2,R1,R6,LSL#2
    BL     sub          ;CALL SUB(XH,W(1,2),W(1,3))
    LDFS   F0,=0.166666666666666667
    LDR    R0,[fp,#-32] ;(Y(1))
    ADD    R3,R5,R6,LSL#3;(W(1,3))
    MOV    lr,R6        ;loop count
    MUFS   F6,F0,F7     ;H6=H/6
lp4 LDFS   F1,[R5],#4   ;W(J,1)
    LDFS   F3,[R3],#4   ;W(J,3)
    LDFS   F0,[R0]      ;Y(J)
    ADFS   F1,F1,F3
    MUFS   F1,F1,F6
    ADFS   F0,F1,F0
    STFS   F0,[R0],#4   ;Y(J) = Y(J) + H6*(W(J,1)+W(J,3))
    SUBS   lr,lr,#1
    BGT    lp4
    LDFS   F0,xh
    LDR    R0,[fp,#-36] ;(X)
    STFS   F0,[R0]      ;X = XH
    LDFE   F7,[sp,#0+lsk];restore floating registers
    LDFE   F6,[sp,#12+lsk]
    LDMDB  fp,{R4-R7,fp,sp,pc} ;return
;
sub MOV   pc,R4        ;CALL SUB
;
    ^      0,sp        ;do not change the order of these, just add to them
xh2 #     4            ;XH2
xh  #     4            ;XH
lsc #     0
;
lsk EQU  lsc-xh2
    END
;
;      RLUXAT see RANLUX
;      RLUXGO see RANLUX
;      RLUXUT see RANLUX
;
      TTL  RM48
;     Double-precision version of
; Universal random number generator proposed by Marsaglia and Zaman
; in report FSU-SCRI-87-50
;        based on RANMAR, modified by F. James, to generate vectors
;        of pseudorandom numbers RVEC of length LENV, where the numbers
;        in RVEC are numbers with at least 48-bit mantissas.
;   Input and output entry points: RM48IN, RM48UT.
;!!! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
;!!!  Calling sequences for RM48:                                    ++
;!!!      CALL RM48 (RVEC, LEN)     returns a vector RVEC of LEN     ++
;!!!                   64-bit random floating point numbers between  ++
;!!!                   zero and one.                                 ++
;!!!      CALL RM48IN(I1,N1,N2)   initializes the generator from one ++
;!!!                   64-bit integer I1, and number counts N1,N2    ++
;!!!                  (for initializing, set N1=N2=0, but to restart ++
;!!!                    a previously generated sequence, use values  ++
;!!!                    output by RM48UT)                            ++
;!!!      CALL RM48UT(I1,N1,N2)   outputs the value of the original  ++
;!!!                  seed and the two number counts, to be used     ++
;!!!                  for restarting by initializing to I1 and       ++
;!!!                  skipping N2*100000000+N1 numbers.              ++
;!!! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
;
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
F2  FN     2
F3  FN     3
maxlev EQU 4
       ^     0,R9
i97    #   4
j97    #   4
ntot   #   4
ntot2  #   4
ijkl   #   4
c      #   8
cd     #   8
cm     #   8
seeds  #   8*97
;
    AREA   |C$$data|,DATA
ntt                    ;initial valuse are the defaults
    DCD         97     ;i97
    DCD         33     ;j97
    DCD          0     ;ntot
    DCD          0     ;ntot2
    DCD   54217137     ;ijkl
    DCD   &3F961F10,&00000000  ;c
    DCD   &3FDD32EC,&40000000  ;cd  (fixed)
    DCD   &3FEFFFFF,&A0000000  ;cm  (fixed)
    DCD   &3FEA2033,&674FCAA0,&3FE79030,&C45D1140,&3FCA76AF,&09681F80 ;seeds
    DCD   &3FDEBEE7,&68FDE2C0,&3FD02961,&07FE0800,&3FB496E2,&380B2300
    DCD   &3FEBC727,&3D836DA0,&3FE2E0A5,&6435AAA0,&3FAC5EF2,&F7784E00
    DCD   &3FD403F8,&C4111FC0,&3FE022F9,&991AF240,&3F9E9B8A,&7AE8CC00
    DCD   &3F9583E4,&806DA800,&3FE6F9CC,&A84C7BE0,&3FEAB267,&12E0E420
    DCD   &3FD94725,&39708700,&3FC82CAB,&EB1AEC80,&3FE04F38,&09FFFA60
    DCD   &3FE95C3C,&D6D43D40,&3F7740E5,&A4D1A000,&3FE051A7,&D9DBFD40
    DCD   &3FB74948,&AADB3500,&3FEDFC54,&BB2CFF60,&3FAB602D,&DA2A4200
    DCD   &3FEFBFAA,&1F0D2980,&3FB3AEC5,&D61D0000,&3FE44BD1,&F3002820
    DCD   &3FC4E2F3,&26B4FB00,&3FD3F500,&C7A8A200,&3FEE0C2E,&179766E0
    DCD   &3FE8A7AE,&B411B440,&3FE0943C,&5045EB40,&3FEC24C7,&0086EDC0
    DCD   &3FE17797,&A1E31520,&3FD73ECE,&FC86CA80,&3FE22EBA,&468CC640
    DCD   &3FA5AC16,&1487AC00,&3FE84A41,&FA571640,&3FD26EE1,&2534DC80
    DCD   &3FE59A05,&D7267F40,&3FCB992F,&257BCD00,&3FE30862,&584CCDA0
    DCD   &3FEE0C65,&49665100,&3FE04CA2,&3897CC60,&3FDF2524,&6F615F80
    DCD   &3FDF405E,&87BD4200,&3FB210EF,&35052200,&3FEDC973,&1F1655C0
    DCD   &3FEBDC26,&B6B1A820,&3FCBF897,&87A69480,&3FE81484,&F67C0340
    DCD   &3FB862F3,&FA591D00,&3F6DFC40,&76632000,&3FD3F691,&A6AB4200
    DCD   &3FDA9F80,&C6C32440,&3FD528C5,&A77D65C0,&3FCEC826,&E9519180
    DCD   &3FE48D1E,&3B162E00,&3FED78B2,&23BB5900,&3FEFA082,&218EE9C0
    DCD   &3FDA8D6A,&FF936A80,&3FEE4C4F,&3A350500,&3FE78608,&E12BD700
    DCD   &3FC77A5A,&9644B900,&3FD7E1AB,&9A567FC0,&3FD4489B,&0CC1B740
    DCD   &3F655639,&BBD8A000,&3FD60415,&0B944780,&3FCF953D,&A4EDE980
    DCD   &3FE3767C,&697A8D80,&3FEE5423,&32C09880,&3FE42CF5,&F9112680
    DCD   &3FE67700,&6164B3A0,&3FE87051,&7FCFA820,&3FD78878,&AD033340
    DCD   &3FCB0501,&E1891880,&3FD29746,&E34F2E80,&3FD0C075,&F66EB900
    DCD   &3FEC561C,&A88A5700,&3FA176F9,&8BF28400,&3FCD1B77,&B6CCA080
    DCD   &3FEB6D54,&41C26060,&3FE2DB5D,&287A0240,&3FE730FF,&1FE52820
    DCD   &3FE211C3,&67AEF380,&3FDCB440,&3CD94DC0,&3FD669D1,&0D31E880
    DCD   &3FBA5115,&6E218E00,&3FE5708F,&108D1460,&3F939966,&69118C00
    DCD   &3FD79848,&E8F49E80,&3FE80210,&E0B956E0,&3FB23F8F,&9C4C7500
    DCD   &3FDC0C2C,&870EDD40,&3FEE123C,&A5EDBDE0,&3FDB63D2,&A5FF2580
    DCD   &3FED6AE7,&13326C60
;
    AREA   |C$$code|,CODE,READONLY
    EXPORT rm48_;(DVEC,LENV) returns a vector DVEC(LENV) REAL*8 random numbers
    DCB    "rm48_",0,0,0,8,0,0,255
rm48_
    MOV    ip,sp
    STMDB  sp!,{R0-R1,R4-R9,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R9,lcm        ;define local area
    LDR    R1,[R1]       ;LENV (count)
    LDMIA  R9,{R5-R8}    ;load i97,j97,ntot,ntot2
    LDR    ip,gillion    ;10**9
    LDFD   F3,c          ;get C
    LDFD   F2,cd
lp1 SUBS   R1,R1,#1
    STMLTIA R9,{R5-R8}   ;save counts
    STFLTD F3,c          ;save C
    LDMLTDB fp,{R4-R9,fp,sp,pc} ;return
    ADD    R3,R9,R5,LSL#3
    ADD    R4,R9,R6,LSL#3
    LDFD   F0,[R3,#seeds-i97-8];seeds(i97)
    LDFD   F1,[R4,#seeds-i97-8];seeds(j97)
    SUFD   F0,F0,F1        ;uni = seeds(i97)-seeds(j97)
    CMF    F0,#0
    ADFLTD F0,F0,#1        ;add 1 if uni was negative
    STFD   F0,[R3,#seeds-i97-8];store new seeds(i97)
    SUBS   R5,R5,#1        ;update i97
    MOVLE  R5,#97
    SUBS   R6,R6,#1        ;update j97
    MOVLE  R6,#97
    SUFD   F3,F3,F2        ;c = c-cd
    CMF    F3,#0
    LDFLTD F1,cm
    ADFLTD F3,F3,F1        ;ensure c is positive
    SUFD   F0,F0,F3        ;uni = uni-c
    CMF    F0,#0
    ADFLTD F0,F0,#1        ;normalize
    LDFEQD F0,twom49
    STFD   F0,[R0],#8      ;store result
    ADD    R7,R7,#1        ;increment ntot
    CMP    R7,ip
    MOVGE  R7,#0
    ADDGE  R8,R8,#1        ;and possibly ntot2
    B      lp1
;
lcm DCD    ntt
gillion DCD 1000000000
twom49  DCD &3CE00000,&00000000
;
    EXPORT rm48ut_;(I1,N1,N2) returns the initial seed and two counts from RM48
    DCB    "rm48ut_",0,8,0,0,255
rm48ut_
    MOV    ip,sp
    STMDB  sp!,{R0-R2,R9,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R9,lcm           ;define local area
    LDMIB  R9,{R3,R9,ip,lr} ;load j97,ntot,ntot2,ijkl
    STR    lr,[R0]          ;store I1
    STR    R9,[R1]          ;store N1
    STR    ip,[R2]          ;store N2
    LDMDB  fp,{R9,fp,sp,pc} ;return
;
    EXPORT rm48in_;(I1,N1,N2) initializes rm48 from initial seed and two counts
    IMPORT __rt_sdiv; R0 = R1/R0, R1=remainder
;
    DCB    "rm48in_",0,8,0,0,255
rm48in_
    MOV    ip,sp
    STMDB  sp!,{R0-R2,R4-R9,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R1,[R0]          ;ijkl
    LDR    R0,dx
    BL     __rt_sdiv       ;R0=IJ, R1=KL
    MOV    R4,R0            ;IJ = IJKL/30082 (KL=MOD(IJKL,30082))
    MOV    R0,#169
    BL     __rt_sdiv
    MOV    R9,R1            ;L = MOD(KL,169)
    MOV    R1,R0
    MOV    R0,#178
    ADD    R8,R1,#1         ;K = MOD(KL/169,178) + 1
    MOV    R1,R4            ;IJ
    MOV    R0,#177
    BL     __rt_sdiv
    ADD    R7,R1,#2         ;J = MOD(IJ,177) + 2
    MOV    R1,R0
    MOV    R0,#177
    BL     __rt_sdiv
    ADD    R6,R1,#2         ;I = MOD(IJ/177,177) + 2
    MOV    ip,#97           ;count for loop over II
    LDR    R5,lcm
    ADD    R5,R5,#seeds-i97 ;(SEEDS(1))
lp2 STR    ip,[sp,#-4]!     ;save on stack
    MVFD   F3,#0.5          ;initialize T=0.5
    MVFD   F2,#0            ;initialize S=0
    MOV    R4,#48           ;count for loop over JJ
lp3 MUL    R1,R6,R7         ;I*J
    MOV    R0,#179
    BL     __rt_sdiv       ;R1=MOD(I*J,179)
    MUL    R1,R8,R1         ;R1=MOD(I*J,179)*K
    MOV    R0,#179
    BL     __rt_sdiv       ;M=MOD(MOD(I*J,179)*K,179)
    MOV    R6,R7            ;I=J
    MOV    R7,R8            ;J=K
    MOV    R8,R1            ;K=M
    MOV    R0,#53
    MUL    R1,R0,R9         ;53*L
    ADD    R1,R1,#1
    MOV    R0,#169
    BL     __rt_sdiv
    MOV    R9,R1            ;L = MOD(53*L+1,169)
    MUL    R0,R9,R8
    TST    R0,#32           ;IF(MOD(L*M,64).GE.32) THEN
    ADFNED F2,F2,F3         ;  S=S+T
    MUFD   F3,F3,#0.5       ;T=0.5*T
    SUBS   R4,R4,#1
    BGT    lp3              ;loop over JJ=1,48
    STFD   F2,[R5],#8       ;store SEED(II)
    LDR    ip,[sp],#4
    SUBS   ip,ip,#1
    BGT    lp2              ;loop over II=1,97
    MOV    R4,#97           ;i97=97
    MOV    R5,#33           ;j97=33
    LDMIA  sp,{R0-R2}       ;restore original arguments
    LDR    R8,[R0]          ;ijkl
    LDR    R6,[R1]          ;ntot
    LDR    R7,[R2]          ;ntot2
    CMP    R6,#0
    MOVLT  R6,#0            ;ensure ntot not negative
    CMP    R7,#0
    MOVLT  R7,#0            ;ensure ntot2 not negative
    LDR    R9,lcm           ;define local area
    LDFD   F3,ci            ;initialize c to 362436.*2.**-24
    LDFD   F2,cd            ;get cd (=7654321.*2.**-24)
    MOV    R3,R6            ;initialize count to ntot
    MOV    R2,R7
lp4 SUBS   R3,R3,#1
    LDRLT  R3,gillion       ;ntot exhausted, try for another 10**9
    SUBLTS R2,R2,#1
    STMLTIA R9,{R4-R8}      ;store: i97,j97,ntot,ntot2,ijkl
    STFD   F3,c             ;store C
    LDMLTDB fp,{R4-R9,fp,sp,pc} ;return
    ADD    R0,R9,R4,LSL#3
    ADD    R1,R9,R5,LSL#3
    LDFD   F0,[R0,#seeds-i97-8];seeds(i97)
    LDFD   F1,[R1,#seeds-i97-8];seeds(j97)
    SUFD   F0,F0,F1        ;uni = seeds(i97)-seeds(j97)
    CMF    F0,#0
    ADFLTD F0,F0,#1        ;add 1 if uni was negative
    STFD   F0,[R0,#seeds-i97-8];store new seeds(i97)
    SUBS   R4,R4,#1        ;update i97
    MOVLE  R4,#97
    SUBS   R5,R5,#1        ;update j97
    MOVLE  R5,#97
    SUFD   F3,F3,F2        ;C = C - CD
    CMF    F3,#0
    LDFLTD F1,cm
    ADFLTD F3,F3,F1        ;ensure c is positive
    B      lp4             ;loop over random numbers
;
dx  DCD    30082
ci  DCD    &3F961F10,&00000000
    END
;
;       RM48IN see RM48
;       RM48UT see RM48
;
    TTL    RMADD
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
F1  FN     1
F0  FN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT rmadd_;(M,N,X11,X12,X21,Y11,Y12,Y21,Z11,Z12,Z21)  z= x+ y
    DCB    "rmadd_",0,0,8,0,0,255
rmadd_
    MOV    ip,sp
    STMDB  sp!,{R0-R9,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDMIB  fp,{R4-R9,ip};arg addresses (X21 to Z21)
    LDR    R0,[R0]     ;m
    LDR    R1,[R1]     ;n
    SUB    R3,R3,R2    ; Xj step
    SUB    R4,R2,R4
    MLA    R4,R3,R1,R4 ;-Xi step
    SUB    R6,R6,R5    ; Yj step
    SUB    R7,R5,R7
    MLA    R7,R6,R1,R7 ;-Yi step
    SUB    R9,R9,R8    ; Zj step
    SUB    ip,R8,ip
    MLA    ip,R9,R1,ip ;-Zi step
    CMP    R0,#1
wa1 MOV    lr,R1       ;j - count
wb1 SUBGES lr,lr,#1
    LDFGES F0,[R2]     ;Xij
    LDFGES F1,[R5]     ;Yij
    ADFGES F0,F0,F1
    STFGES F0,[R8]     ;Zij = Xij + Yij
    ADDGE  R2,R2,R3
    ADDGE  R5,R5,R6
    ADDGE  R8,R8,R9
    BGT    wb1         ;loop over j
    SUB    R2,R2,R4
    SUB    R5,R5,R7
    SUB    R8,R8,ip
    SUBEQS R0,R0,#1
    BGT    wa1         ;loop over i
    LDMDB  fp,{R4-R9,fp,sp,pc} ;return
    END
;
    TTL    RMBIL
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
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
F3  FN     3
F2  FN     2
F1  FN     1
F0  FN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT rmbil_;(N,V1,V2,X11,X12,X21,Y1,Y2)    Vk * Xkj * Yj => funct
    DCB    "rmbil_",0,0,8,0,0,255
rmbil_
    MOV    ip,sp
    STMDB  sp!,{R0-R8,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDMIB  fp,{R4-R7}  ;arg addresses
    LDR    R0,[R0]     ;n
    SUB    R2,R2,R1    ;V step
    SUB    R7,R7,R6    ;Y step
    SUB    R4,R4,R3    ; Xj step
    SUB    R5,R3,R5
    MLA    R5,R4,R0,R5 ;-Xk step
    MVFE   F0,#0       ;total accumulator
    ADDS   ip,R0,#0    ;k-count
wa2 MOV    lr,R0       ;j-count
    MVFGTE F1,#0       ;row accumulator
    MOV    R8,R6       ;(Yj)
wb2 LDFGTS F2,[R3]     ;Xkj
    LDFGTS F3,[R8]     ;Yj
    MUFGTE F2,F2,F3
    ADFGTE F1,F1,F2    ;sum row
    ADD    R3,R3,R4
    ADD    R8,R8,R7
    SUBS   lr,lr,#1
    BGT    wb2         ;loop over j
    LDFGES F2,[R1]     ;Vk
    MUFGEE F1,F1,F2    ;multiply by row
    ADFGEE F0,F0,F1    ;sum total
    ADD    R1,R1,R2
    SUB    R3,R3,R5
    SUBS   ip,ip,#1
    BGT    wa2
    LDMDB  fp,{R4-R8,fp,sp,pc} ;return
    END
;
    TTL    RMCPY
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
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 rmcpy_;(M,N,X11,X12,X21,Z11,Z12,Z21)  z   = x
    DCB    "rmcpy_",0,0,8,0,0,255
rmcpy_
    MOV    ip,sp
    STMDB  sp!,{R0-R7,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDMIB  fp,{R4-R7}  ;arg addresses
    LDR    R0,[R0]     ;m
    LDR    R1,[R1]     ;n
    SUB    R3,R3,R2    ; Xj step
    SUB    R4,R2,R4
    MLA    R4,R3,R1,R4 ;-Xi step
    SUB    R6,R6,R5    ; Zj step
    SUB    R7,R5,R7
    MLA    R7,R6,R1,R7 ;-Zi step
    CMP    R0,#1
wa3 MOV    ip,R1       ;j - count
wb3 SUBGES ip,ip,#1
    LDRGE  lr,[R2],R3  ;copy Xij
    STRGE  lr,[R5],R6  ;to Zij
    BGT    wb3         ;loop over j
    SUB    R2,R2,R4
    SUB    R5,R5,R7
    SUBEQS R0,R0,#1
    BGT    wa3         ;loop over i
    LDMDB  fp,{R4-R7,fp,sp,pc} ;return
    END
;
    TTL    RMDMP
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
F1  FN     1
F0  FN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT rmdmp_;(M,N,D1,D2,X11,X12,X21,Z11,Z12,Z21)  Zij = Di * Xij
    DCB    "rmdmp_",0,0,8,0,0,255
rmdmp_
    MOV    ip,sp
    STMDB  sp!,{R0-R9,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDMIB  fp,{R4-R9}  ;arg addresses
    LDR    R0,[R0]     ;m
    LDR    R1,[R1]     ;n
    SUB    R3,R3,R2    ; Di step
    SUB    R5,R5,R4    ; Xj step
    SUB    R6,R4,R6
    MLA    R6,R5,R1,R6 ;-Xi step
    SUB    R8,R8,R7    ; Zj step
    SUB    R9,R7,R9
    MLA    R9,R8,R1,R9 ;-zi step
    CMP    R0,#0
wae LDFGTS F0,[R2]     ;Di
    MOVGTS ip,R1       ;j-count
wbe LDFGTS F1,[R4]     ;Xij
    FMLGTS F1,F1,F0
    STFGTS F1,[R7]     ;Zij = Di * Xij
    ADD    R4,R4,R5
    ADD    R7,R7,R8
    SUBGTS ip,ip,#1
    BGT    wbe         ;loop over j
    SUB    R4,R4,R6
    SUB    R7,R7,R9
    ADD    R2,R2,R3
    SUBEQS R0,R0,#1
    BGT    wae         ;loop over i
    LDMDB  fp,{R4-R9,fp,sp,pc} ;return
    END
;
    TTL   RMINFC
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
F0  FN    0
F1  FN    1
F2  FN    2
F3  FN    3
F4  FN    4
F5  FN    5
F6  FN    6
F7  FN    7
    AREA   |C$$code|,CODE,READONLY
    EXPORT rminfc_;(F,A,B,EPS,DELTA,X,Y,LLM) finds local minimum of function
    DCB    "rminfc_",0,8,0,0,255
rminfc_
    MOV    ip,sp
    STMDB  sp!,{R0-R8,fp,ip,lr,pc}
    SUB    fp,ip,#4
    STFE   F4,[sp,#-12]! ;save floating registers
    STFE   F5,[sp,#-12]!
    STFE   F6,[sp,#-12]!
    STFE   F7,[sp,#-12]!
    SUB    sp,sp,#lsk    ;space for variables
    MOV    R4,R0         ;(F)
    LDFS   F6,[R1]       ;C=A
    LDFS   F7,[R2]       ;D=B
    CMF    F6,F7
    LDFGTS F6,[R2]       ;C=MIN(A,B)
    LDFGTS F7,[R1]       ;D=MAX(A,B]
    BEQ    ret
    SUFS   F1,F7,F6
    LDFS   F0,[R3]       ;EPS
    FDVS   F2,F1,F0
    LGNS   F0,F2
    LDFS   F1,=2.08
    FMLS   F2,F0,F1
    FIX    R5,F2
    CMP    R5,#0
    BLT    ret
    MOV    R6,#3         ;LLT=.TRUE., LGE=.TRUE. (bits 1 and 0)
lp1 SUFS   F1,F7,F6      ;D-C
    LDFS   F0,hv         ;HV
    TST    R6,#1
    FMLNES F5,F0,F1      ;H=HV*(D-C)
    TST    R6,#2         ;IF(LLT) THEN
    BEQ    RC1
    FMLS   F4,F0,F1      ;H=HV*(D-C)
    ADFS   F2,F6,F4
    STFS   F2,vv         ;V=C+H
    ADR    R0,vv
    BL     func
    MVFS   F4,F0         ;FV=F(V)
RC1 TST    R6,#1         ;IF(LLE) THEN
    BEQ    RC2
    SUFS   F2,F7,F5
    STFS   F2,ww         ;W=D-H
    ADR    R0,ww
    BL     func
    MVFS   F5,F0         ;FW=F(W)
RC2 CMF    F4,F5         ;IF(FV.LT.FW) THEN
    MOVLT  R6,#2         ;  LLT=.TRUE., LGE=.FALSE.
    LDFLTS F7,ww         ;  D=W
    MVFLTS F5,F4         ;  FW=FV
    LDRLT  R0,vv         ;  W=V
    STRLT  R0,ww         ;ELSE
    MOVGE  R6,#1         ;  LLT=.FALSE., LGE=.TRUE.
    LDFGES F6,vv         ;  C=V
    MVFGES F4,F5         ;  FV=FW
    LDRGE  R0,ww         ;  V=W
    STRGE  R0,vv
    SUBS   R5,R5,#1
    BGE    lp1           ;loop N+1 times
;
ret ADFS   F0,F6,F7
    FMLS   F6,F0,#0.5
    LDMIB  fp,{R5-R8}    ;(DELTA),(X),(Y),(LLM)
    STFS   F6,[R6]       ;X=0.5*(C+D)
    MOV    R0,R6
    BL     func
    STFS   F0,[R7]       ;Y=F(X)
    LDR    R0,[fp,#-44]  ;(A)
    LDR    R1,[fp,#-40]  ;(B)
    LDFS   F0,[R0]       ;A
    LDFS   F1,[R1]       ;B
    SUFS   F0,F0,F6      ;A-X
    SUFS   F1,F1,F6      ;B-X
    LDFS   F2,[R5]       ;DELTA
    ABSS   F0,F0
    ABSS   F1,F1
    CMF    F0,F2
    CMFGT  F1,F2
    MOVGT  R0,#-1        ;.TRUE. if |A-X|>DELTA AND |B-X|>DELTA
    MOVLE  R0,#0         ;.FALSE. otherwise
    STR    R0,[R8]       ;store LLM
    LDFE   F7,[sp,#0+lsk];restore floating registers
    LDFE   F6,[sp,#12+lsk]
    LDFE   F5,[sp,#24+lsk]
    LDFE   F4,[sp,#36+lsk]
    LDMDB  fp,{R4-R8,fp,sp,pc} ;return
;
func MOV   pc,R4         ;call F
;
hv  DCFS   0.38196601
;
    ^      0,sp        ;do not change the order of these, just add to them
vv  #     4            ;V
ww  #     4            ;W
lsc #     0
;
lsk EQU  lsc-vv
    END
;
    TTL   rmmar
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
F2  FN     2
F3  FN     3
;
    AREA   ranma2__,COMMON
jsq DCD    0
cmn %      412     ;103 words
;
    AREA   |C$$code|,CODE,READONLY
    EXPORT rmmar_;(RVEC,LENV,ISEQ) generate LENV random numbers in RVEC
    IMPORT ran_mar; entry in RANMAR
    DCB    "rmmar_",0,0,8,0,0,255
rmmar_
    MOV    ip,sp
    STMDB  sp!,{R0-R2,R4-R9,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R2,[R2]        ;ISEQ
    LDR    R4,ptrc
    CMP    R2,#0          ;IF(ISEQ.GT.0) THEN
    STRGT  R2,[R4,#-4]    ;  JSEQ = ISEQ
    LDRLE  R2,[R4,#-4]    ;  ELSE retrieve JSEQ
    SUBS   R2,R2,#1
    LDMLTDB fp,{R4-R9,fp,sp,pc} ;do nothing if not initialised
    MOV    ip,#412        ;103*4
    MLA    R4,R2,ip,R4    ;get address of block
    B      ran_mar
ptrc DCD   cmn
;
    EXPORT rmmaq_;(ISEED,ISEQ,CHOPT) control for RMMAR
    IMPORT rmar_in; entry in RMARIN
    DCB    "rmmaq_",0,0,8,0,0,255
rmmaq_
    MOV    ip,sp
    STMDB  sp!,{R0-R9,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R4,ptrc       ;pointer to common
    MOV    R5,#0         ;IFIRST=.FALSE. for RMARIN
lm1 SUBS   R3,R3,#1
    LDRGEB ip,[R2],#1
    CMPGE  ip,#" "       ;check for CHOPT=' '
    BEQ    lm1
    LDRLT  R1,=54217137
    MOVLT  R6,#0
    MOVLT  R7,#0
    MOVLT  ip,#1
    STRLT  ip,[R4,#-4]   ;JSEQ = 1
    BLT    rmar_in       ;get 103 words from 3 seed words
    MOV    R9,#"S"
    BL     index         ;is there an 'S' in CHOPT
    LDR    R8,[R1]       ;ISEQ
    BNE    notS          ;no
;       Setting seed here
    CMP    R8,#0         ;IF ISEQ>0 THEN
    STRGT  R8,[R4,#-4]   ;  JSEQ=ISEQ
    LDRLE  R8,[R4,#-4]   ;ELSE use JSEQ
    SUBS   R8,R8,#1
    LDMLTDB fp,{R4-R9,fp,sp,pc} ;do nothing if no sequence number
    MOV    R1,#412
    MLA    R4,R1,R8,R4   ;move to right common area
    MOV    R9,#"V"
    BL     index
    LDMNEIA R0,{R1,R6,R7};V not found so get words for RMARIN
    BNE    rmar_in       ;  get 103 words from 3 seed words
    MOV    ip,#102       ;V found so transfer 103 words from ISEED
lm2 LDR    lr,[R0,ip,LSL#2]
    STR    lr,[R4,ip,LSL#2]
    SUBS   ip,ip,#1
    BGE    lm2
    LDMDB  fp,{R4-R9,fp,sp,pc} ;return
;
notS;  not request for Setting seed
    MOV    R9,#"R"
    BL     index         ;check for Reading seed
    LDMNEDB fp,{R4-R9,fp,sp,pc} ;not Reading either so return
    CMP    R8,#0         ;IF ISEQ>0 THEN
    STRGT  R8,[R4,#-4]   ;  JSEQ = ISEQ
    LDRLE  R8,[R4,#-4]   ;ELSE
    STRLE  R8,[R1]       ;  ISEQ = JSEQ
    SUBS   R8,R8,#1
    LDMLTDB fp,{R4-R9,fp,sp,pc} ;do nothing if no sequence number
    MOV    R1,#412
    MLA    R4,R1,R8,R4   ;move to right common area
    MOV    R9,#"V"
    BL     index
    MOVEQ  ip,#102       ;move 103 words if V
    MOVNE  ip,#2         ;3 words if not V
lm3 LDR    lr,[R4,ip,LSL#2]
    STR    lr,[R0,ip,LSL#2]
    SUBS   ip,ip,#1
    BGE    lm3
    LDMDB  fp,{R4-R9,fp,sp,pc} ;return
;
index;  look for (R9) in CHOPT
    LDR    R2,[sp,#8]    ;(CHOPT)
    LDR    R3,[sp,#12]   ;LEN(CHOPT)
li1 SUBS   R3,R3,#1
    MOVLT  pc,lr         ;return NE if not found
    LDRB   ip,[R2],#1
    CMP    ip,#"a"
    SUBGE  ip,ip,#32     ;convert to upper case
    CMP    ip,R9
    BNE    li1
    MOV    pc,lr         ;return EQ if found
    END
;
    TTL    RMMLA
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
F2  FN     2
F1  FN     1
F0  FN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT rmmla_;(M,N,K,X11,X12,X21,Y11,Y12,Y21,Z11,Z12,Z21)  z = xy + z
    DCB    "rmmla_",0,0,8,0,0,255
rmmla_
    MOV    ip,sp
    STMDB  sp!,{R0-R9,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R0,[R0]     ;m
    LDR    R1,[R1]     ;n
    LDR    R2,[R2]     ;k
    CMP    R0,#0       ;check m>0
    CMPGT  R1,#0       ;check n>0
    CMPGT  R2,#0       ;check k>0
    LDMLEDB fp,{R4-R9,fp,sp,pc} ;return if not
    LDMIB  fp,{R4-R9,ip,lr} ;arg addresses
    SUB    R4,R4,R3    ;X(i,j) :jstep
    SUB    R5,R5,R3    ;X(i,j) :istep
    SUB    R7,R7,R6    ;Y(j,l) :lstep
    SUB    R8,R8,R6    ;Y(j,l) :jstep
    SUB    ip,ip,R9    ;Z(i,l) :lstep
    SUB    lr,lr,R9    ;Z(i,l) :istep
wa1 STMFD  sp!,{R0,lr} ;save m and istep(Z)
    MOV    R0,R2       ;initialise l to k
    MLA    R6,R7,R2,R6 ;(Y(1,k+1))
    MLA    R9,ip,R2,R9 ;(Z(i,k+1))
wb1 MOV    lr,R1       ;initialise j to n
    SUB    R6,R6,R7    ;(Y(1,l))
    SUB    R9,R9,ip    ;(Z(i,l))
    MLA    R3,R4,R1,R3 ;(X(i,n+1))
    MLA    R6,R8,R1,R6 ;(Y(n+1,l))
    LDFS   F0,[R9]     ;initialise from +Z(i,l)
wc1 SUB    R3,R3,R4    ;(X(i,j))
    SUB    R6,R6,R8    ;(Y(j,l))
    LDFS   F1,[R3]     ;get X(i,j)
    LDFS   F2,[R6]     ;get Y(j,l)
    MUFE   F1,F1,F2
    ADFE   F0,F0,F1    ;sum their products
    SUBS   lr,lr,#1
    BGT    wc1         ;loop over j=n,1,-1
    STFS   F0,[R9]     ;store Z(i,l)
    SUBS   R0,R0,#1
    BGT    wb1         ;loop over l=k,1,-1
    LDMFD  sp!,{R0,lr} ;restore m and istep(Z)
    ADD    R3,R3,R5    ;(X(i+1,1))
    ADD    R9,R9,lr    ;(Z(i+1,1))
    SUBS   R0,R0,#1
    BGT    wa1         ;loop over i=1,m
    LDMDB  fp,{R4-R9,fp,sp,pc} ;return
    END
;
    TTL    RMMLS
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
F2  FN     2
F1  FN     1
F0  FN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT rmmls_;(M,N,K,X11,X12,X21,Y11,Y12,Y21,Z11,Z12,Z21)  z = xy - z
    DCB    "rmmls_",0,0,8,0,0,255
rmmls_
    MOV    ip,sp
    STMDB  sp!,{R0-R9,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R0,[R0]     ;m
    LDR    R1,[R1]     ;n
    LDR    R2,[R2]     ;k
    CMP    R0,#0       ;check m>0
    CMPGT  R1,#0       ;check n>0
    CMPGT  R2,#0       ;check k>0
    LDMLEDB fp,{R4-R9,fp,sp,pc} ;return if not
    LDMIB  fp,{R4-R9,ip,lr} ;arg addresses
    SUB    R4,R4,R3    ;X(i,j) :jstep
    SUB    R5,R5,R3    ;X(i,j) :istep
    SUB    R7,R7,R6    ;Y(j,l) :lstep
    SUB    R8,R8,R6    ;Y(j,l) :jstep
    SUB    ip,ip,R9    ;Z(i,l) :lstep
    SUB    lr,lr,R9    ;Z(i,l) :istep
wa1 STMFD  sp!,{R0,lr} ;save m and istep(Z)
    MOV    R0,R2       ;initialise l to k
    MLA    R6,R7,R2,R6 ;(Y(1,k+1))
    MLA    R9,ip,R2,R9 ;(Z(i,k+1))
wb1 MOV    lr,R1       ;initialise j to n
    SUB    R6,R6,R7    ;(Y(1,l))
    SUB    R9,R9,ip    ;(Z(i,l))
    MLA    R3,R4,R1,R3 ;(X(i,n+1))
    MLA    R6,R8,R1,R6 ;(Y(n+1,l))
    LDFS   F0,[R9]
    MNFE   F0,F0       ;initialise from -Z(i,l)
wc1 SUB    R3,R3,R4    ;(X(i,j))
    SUB    R6,R6,R8    ;(Y(j,l))
    LDFS   F1,[R3]     ;get X(i,j)
    LDFS   F2,[R6]     ;get Y(j,l)
    MUFE   F1,F1,F2
    ADFE   F0,F0,F1    ;sum their products
    SUBS   lr,lr,#1
    BGT    wc1         ;loop over j=n,1,-1
    STFS   F0,[R9]     ;store Z(i,l)
    SUBS   R0,R0,#1
    BGT    wb1         ;loop over l=k,1,-1
    LDMFD  sp!,{R0,lr} ;restore m and istep(Z)
    ADD    R3,R3,R5    ;(X(i+1,1))
    ADD    R9,R9,lr    ;(Z(i+1,1))
    SUBS   R0,R0,#1
    BGT    wa1         ;loop over i=1,m
    LDMDB  fp,{R4-R9,fp,sp,pc} ;return
    END
;
    TTL    RMMLT
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
F2  FN     2
F1  FN     1
F0  FN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT rmmlt_;(M,N,K,X11,X12,X21,Y11,Y12,Y21,Z11,Z12,Z21,T)  Z = XY
    DCB    "rmmlt_",0,0,8,0,0,255
rmmlt_
    MOV    ip,sp
    STMDB  sp!,{R0-R9,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R0,[R0]     ;m
    LDR    R1,[R1]     ;n
    LDR    R2,[R2]     ;k
    CMP    R0,#0       ;check m>0
    CMPGT  R1,#0       ;check n>0
    CMPGT  R2,#0       ;check k>0
    LDMLEDB fp,{R4-R9,fp,sp,pc} ;return if not
    LDMIB  fp,{R4-R9,ip,lr} ;arg addresses except T
    SUB    R4,R4,R3    ;X(i,j) :jstep
    SUB    R5,R5,R3    ;X(i,j) :istep
    SUB    R7,R7,R6    ;Y(j,l) :lstep
    SUB    R8,R8,R6    ;Y(j,l) :jstep
    SUB    ip,ip,R9    ;Z(i,l) :lstep
    SUB    lr,lr,R9    ;Z(i,l) :istep
    CMP    R3,R9
    BEQ    wxz         ;(Z) = (X)
    CMP    R6,R9
    BEQ    wyz         ;(Z) = (Y)
    CMP    R3,R6
    CMPEQ  R0,R2       ;check that Y = X'
    CMPEQ  R5,R7
    CMPEQ  R4,R8
    BEQ    wxy         ;Y = X' not overlapping Z
;        standard multiplication: Z = XY
wa3 STMFD  sp!,{R0,lr} ;save m and istep(Z)
    MOV    R0,R2       ;l-count
    MLA    R6,R7,R2,R6
    MLA    R9,ip,R2,R9
wb3 MOV    lr,R1       ;j-count
    SUB    R6,R6,R7
    SUB    R9,R9,ip
    MLA    R3,R4,R1,R3
    MLA    R6,R8,R1,R6
    MVFE   F0,#0       ;initialise to zero
wc3 SUB    R3,R3,R4
    SUB    R6,R6,R8
    LDFS   F1,[R3]     ;get X(i,j)
    LDFS   F2,[R6]     ;get Y(j,l)
    MUFE   F1,F1,F2
    ADFE   F0,F0,F1
    SUBS   lr,lr,#1
    BGT    wc3         ;loop over j
    STFS   F0,[R9]     ;store Z(i,l)
    SUBS   R0,R0,#1
    BGT    wb3         ;loop over l
    LDMFD  sp!,{R0,lr} ;restore m and istep(Z)
    ADD    R3,R3,R5
    ADD    R9,R9,lr
    SUBS   R0,R0,#1
    BGT    wa3         ;loop over i
    LDMDB  fp,{R4-R9,fp,sp,pc} ;return
;      here we have Y = X' not overlapping Z
wxy MOV    R2,#1       ;initialise i
    STMFD  sp!,{R0,lr} ;save m and istep(Z)
wd3; MOV    R0,R0       ;initialise l to m
    MLA    R6,R5,R0,R6 ;(Y(1,m+1))
    MLA    R9,ip,R0,R9 ;(Z(i,m+1))
we3 MOV    lr,R1      ;initialise j to n
    SUB    R6,R6,R5    ;(Y(1,l))
    SUB    R9,R9,ip    ;(Z(i,l))
    MLA    R3,R4,R1,R3 ;(X(i,n+1))
    MLA    R6,R4,R1,R6 ;(Y(n+1,l))
    MVFE   F0,#0       ;initialise to zero
wg3 SUB    R3,R3,R4    ;(X(i,j))
    SUB    R6,R6,R4    ;(Y(j,l))
    LDFS   F1,[R3]     ;get X(i,j)
    LDFS   F2,[R6]     ;get Y(j,l)
    MUFE   F1,F1,F2
    ADFE   F0,F0,F1    ;sum their products
    SUBS   lr,lr,#1
    BGT    wg3         ;loop over j=n,1,-1
    STFS   F0,[R9]     ;store Z(i,l)
    SUBS   R0,R0,#1
    CMP    R0,R2
    BGE    we3         ;loop over l=m,i,-1
    MOV    R7,R9       ;(Z(i,i))
    LDR    lr,[sp,#4]  ;restore istep(Z)
wh3 SUBS   R0,R0,#1
    SUBGE  R6,R6,R5    ;(Y(1,l))
    LDRGE  R8,[R7,-lr]!;copy Z(l,i)
    STRGE  R8,[R9,-ip]!;to Z(i,l)
    BGT    wh3         ;loop over l=i-1,1,-1
    LDR    R0,[sp]     ;restore m
    ADD    R3,R3,R5    ;(X(i+1,1))
    ADD    R9,R9,lr    ;(Z(i+1,1))
    ADD    R2,R2,#1
    CMP    R2,R0
    BLE    wd3         ;loop over i=1,m
    LDMDB  fp,{R4-R9,fp,sp,pc} ;return
;
wxz; (X) = (Z), check if Y = X'
    CMP    R3,R6
    BEQ    xyz         ;X = Y'
wi3 STMFD  sp!,{R0,R5}
    LDR    R0,[fp,#36] ;address of T
    MOV    ip,R2       ;initialise l to k
    MLA    R6,R7,R2,R6 ;(Y(1,k+1))
wj3 MOV    R5,R1       ;initialise j to n
    SUB    R6,R6,R7    ;(Y(1,l))
    MLA    R3,R4,R1,R3 ;(X(i,n+1))
    MLA    R6,R8,R1,R6 ;(Y(n+1,l))
    MVFE   F0,#0       ;initialise answer
wk3 SUB    R3,R3,R4    ;(X(i,j))
    SUB    R6,R6,R8    ;(Y(j,l))
    LDFS   F1,[R3]     ;get X(i,j)
    LDFS   F2,[R6]     ;get Y(j,l)
    MUFE   F1,F1,F2
    ADFE   F0,F0,F1    ;sum their products
    SUBS   R5,R5,#1
    BGT    wk3         ;loop over j=n,1,-1
    STFS   F0,[R0],#4  ;store answer in T
    SUBS   ip,ip,#1
    BGT    wj3         ;loop over l=k,1,-1
    MOV    R9,R3       ;(Z(i,1))
    MOV    ip,R2       ;initialise l count
wl3 LDR    lr,[R0,#-4]!;get T(l)
    STR    lr,[R9],R4  ;store in Z(i,l)
    SUBS   ip,ip,#1
    BGT    wl3         ;loop over l=1,k
    LDMFD  sp!,{R0,R5}
    ADD    R3,R3,R5    ;(X(i+1,1)) and (Z(i+1,1))
    SUBS   R0,R0,#1
    BGT    wi3         ;loop over i=1,m
    LDMDB  fp,{R4-R9,fp,sp,pc} ;return
;
wyz; (Y) = (Z) but not (X)
    MOV    R6,R3       ;make Y = X'
    MOV    R7,R5
    MOV    R8,R4
    MOV    R3,R9       ;make X = Z'(= old Y')
    MOV    R4,lr
    MOV    R5,ip
    MOV    R9,R0       ;exchange m and k
    MOV    R0,R2
    MOV    R2,R9
    B      wi3         ;now form Z' = Y'X'
;
xyz;  (Z) = (X = Y')
    LDR    R7,[fp,#36] ;address of T
    MOV    R8,R3       ;(Z(1,i))
    MOV    R2,R0       ;initialise i count to m
wm3 MOV    ip,R2       ;initialise l count to m-i+1
    MLA    R6,R5,R2,R3 ;(Y(1,m+1))
wn3 MOV    lr,R1       ;initialise j to n
    SUB    R6,R6,R5    ;(Y(1,l))
    MLA    R3,R4,R1,R3 ;(X(i,n+1))
    MLA    R6,R4,R1,R6 ;(Y(n+1,l))
    MVFE   F0,#0       ;initialise answer
wo3 SUB    R3,R3,R4    ;(X(i,j))
    SUB    R6,R6,R4    ;(Y(j,l))
    LDFS   F1,[R3]     ;get X(i,j)
    LDFS   F2,[R6]     ;get Y(j,l)
    MUFE   F1,F1,F2
    ADFE   F0,F0,F1    ;sum their products
    SUBS   lr,lr,#1
    BGT    wo3         ;loop over j=n,1,-1
    STFS   F0,[R7],#4  ;store answer in T
    SUBS   ip,ip,#1
    BGT    wn3         ;loop over l=m,i,-1
    MOV    R9,R3       ;(Z(i,1))
    MOV    R6,R8       ;(Z(1,i))
    MOV    ip,R0       ;initialise l count to m
wp3 CMP    ip,R2
    LDRGT  lr,[R6],R5  ;move Z(l,i)
    LDRLE  lr,[R7,#-4]!;or T(l)
    STR    lr,[R9],R4  ;to Z(i,l)
    SUBS   ip,ip,#1
    BGT    wp3         ;for l=1,m
    ADD    R3,R3,R5    ;(X(i+1,1)), (Z(i+1,1)) & (Y(1,i+1))
    ADD    R8,R8,R4    ;(Z(1,i+1))
    SUBS   R2,R2,#1
    BGT    wm3         ;loop over i=1,m
    LDMDB  fp,{R4-R9,fp,sp,pc} ;return
    END
;
    TTL    RMMNA
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
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
F2  FN     2
F1  FN     1
F0  FN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT rmmna_;(M,N,X11,X12,X21,Y1,Y2,Z1,Z2)  Zi = - XijYj + Zi
    DCB    "rmmna_",0,0,8,0,0,255
rmmna_
    MOV    ip,sp
    STMDB  sp!,{R0-R8,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDMIB  fp,{R4-R8}  ;arg addresses
    LDR    R0,[R0]     ;m
    LDR    R1,[R1]     ;n
    SUB    R3,R3,R2    ; Xj step
    SUB    R4,R2,R4
    MLA    R4,R3,R1,R4 ;-Xi step
    SUB    R6,R6,R5    ; Yj step
    SUB    R8,R8,R7    ; Zi step
    CMP    R0,#1
wa4 MOV    ip,R1       ;j count
    MOV    lr,R5       ;(Y1)
    LDFGES F0,[R7]     ;Zi
wb4 SUBGES ip,ip,#1
    LDFGES F1,[lr]     ;Yj
    ADDGE  lr,lr,R6
    LDFGES F2,[R2]     ;Xij
    ADDGE  R2,R2,R3
    MUFGEE F1,F1,F2
    SUFGEE F0,F0,F1
    BGT    wb4         ;loop over j
    STFEQS F0,[R7]     ;store Zi
    ADD    R7,R7,R8
    SUB    R2,R2,R4
    SUBEQS R0,R0,#1
    BGT    wa4         ;loop over i
    LDMDB  fp,{R4-R8,fp,sp,pc} ;return
    END
;
    TTL    RMMNS
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
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
F2  FN     2
F1  FN     1
F0  FN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT rmmns_;(M,N,X11,X12,X21,Y1,Y2,Z1,Z2)  Zi = - XijYj - Zi
    DCB    "rmmns_",0,0,8,0,0,255
rmmns_
    MOV    ip,sp
    STMDB  sp!,{R0-R8,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDMIB  fp,{R4-R8}  ;arg addresses
    LDR    R0,[R0]     ;m
    LDR    R1,[R1]     ;n
    SUB    R3,R3,R2    ; Xj step
    SUB    R4,R2,R4
    MLA    R4,R3,R1,R4 ;-Xi step
    SUB    R6,R6,R5    ; Yj step
    SUB    R8,R8,R7    ; Zi step
    CMP    R0,#1
wa5 MOV    ip,R1       ;j count
    MOV    lr,R5       ;(Y1)
    LDFGES F0,[R7]     ;Zi
    MNFGEE F0,F0       ;-Zi
wb5 SUBGES ip,ip,#1
    LDFGES F1,[lr]     ;Yj
    ADDGE  lr,lr,R6
    LDFGES F2,[R2]     ;Xij
    ADDGE  R2,R2,R3
    MUFGEE F1,F1,F2
    SUFGEE F0,F0,F1
    BGT    wb5         ;loop over j
    STFEQS F0,[R7]     ;store Zi
    ADD    R7,R7,R8
    SUB    R2,R2,R4
    SUBEQS R0,R0,#1
    BGT    wa5         ;loop over i
    LDMDB  fp,{R4-R8,fp,sp,pc} ;return
    END
;
    TTL    RMMPA
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
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
F2  FN     2
F1  FN     1
F0  FN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT rmmpa_;(M,N,X11,X12,X21,Y1,Y2,Z1,Z2)  Zi = + XijYj + Zi
    DCB    "rmmpa_",0,0,8,0,0,255
rmmpa_
    MOV    ip,sp
    STMDB  sp!,{R0-R8,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDMIB  fp,{R4-R8}  ;arg addresses
    LDR    R0,[R0]     ;m
    LDR    R1,[R1]     ;n
    SUB    R3,R3,R2    ; Xj step
    SUB    R4,R2,R4
    MLA    R4,R3,R1,R4 ;-Xi step
    SUB    R6,R6,R5    ; Yj step
    SUB    R8,R8,R7    ; Zi step
    CMP    R0,#1
wa6 MOV    ip,R1       ;j count
    MOV    lr,R5       ;(Y1)
    LDFGES F0,[R7]     ;Zi
wb6 SUBGES ip,ip,#1
    LDFGES F1,[lr]     ;Yj
    ADDGE  lr,lr,R6
    LDFGES F2,[R2]     ;Xij
    ADDGE  R2,R2,R3
    MUFGEE F1,F1,F2
    ADFGEE F0,F0,F1
    BGT    wb6         ;loop over j
    STFEQS F0,[R7]     ;store Zi
    ADD    R7,R7,R8
    SUB    R2,R2,R4
    SUBEQS R0,R0,#1
    BGT    wa6         ;loop over i
    LDMDB  fp,{R4-R8,fp,sp,pc} ;return
    END
;
    TTL    RMMPS
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
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
F2  FN     2
F1  FN     1
F0  FN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT rmmps_;(M,N,X11,X12,X21,Y1,Y2,Z1,Z2)  Zi = + XijYj - Zi
    DCB    "rmmps_",0,0,8,0,0,255
rmmps_
    MOV    ip,sp
    STMDB  sp!,{R0-R8,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDMIB  fp,{R4-R8}  ;arg addresses
    LDR    R0,[R0]     ;m
    LDR    R1,[R1]     ;n
    SUB    R3,R3,R2    ; Xj step
    SUB    R4,R2,R4
    MLA    R4,R3,R1,R4 ;-Xi step
    SUB    R6,R6,R5    ; Yj step
    SUB    R8,R8,R7    ; Zi step
    CMP    R0,#1
wa7 MOV    ip,R1       ;j count
    MOV    lr,R5       ;(Y1)
    LDFGES F0,[R7]     ;Zi
    MNFGEE F0,F0       ;-Zi
wb7 SUBGES ip,ip,#1
    LDFGES F1,[lr]     ;Yj
    ADDGE  lr,lr,R6
    LDFGES F2,[R2]     ;Xij
    ADDGE  R2,R2,R3
    MUFGEE F1,F1,F2
    ADFGEE F0,F0,F1
    BGT    wb7         ;loop over j
    STFEQS F0,[R7]     ;store Zi
    ADD    R7,R7,R8
    SUB    R2,R2,R4
    SUBEQS R0,R0,#1
    BGT    wa7         ;loop over i
    LDMDB  fp,{R4-R8,fp,sp,pc} ;return
    END
;
    TTL    RMMPY
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
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
F2  FN     2
F1  FN     1
F0  FN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT rmmpy_;(M,N,X11,X12,X21,Y1,Y2,Z1,Z2)  Zi = + XijYj
    DCB    "rmmpy_",0,0,8,0,0,255
rmmpy_
    MOV    ip,sp
    STMDB  sp!,{R0-R8,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDMIB  fp,{R4-R8}  ;arg addresses
    LDR    R0,[R0]     ;m
    LDR    R1,[R1]     ;n
    SUB    R3,R3,R2    ; Xj step
    SUB    R4,R2,R4
    MLA    R4,R3,R1,R4 ;-Xi step
    SUB    R6,R6,R5    ; Yj step
    SUB    R8,R8,R7    ; Zi step
    CMP    R0,#1
wa8 MOV    ip,R1       ;j count
    MOV    lr,R5       ;(Y1)
    MVFGEE F0,#0       ;init accumulator
wb8 SUBGES ip,ip,#1
    LDFGES F1,[lr]     ;Yj
    ADDGE  lr,lr,R6
    LDFGES F2,[R2]     ;Xij
    ADDGE  R2,R2,R3
    MUFGEE F1,F1,F2
    ADFGEE F0,F0,F1
    BGT    wb8         ;loop over j
    STFEQS F0,[R7]     ;store Zi
    ADD    R7,R7,R8
    SUB    R2,R2,R4
    SUBEQS R0,R0,#1
    BGT    wa8         ;loop over i
    LDMDB  fp,{R4-R8,fp,sp,pc} ;return
    END
;
    TTL    RMNMA
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
F2  FN     2
F1  FN     1
F0  FN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT rmnma_;(M,N,K,X11,X12,X21,Y11,Y12,Y21,Z11,Z12,Z21)  z = -xy + z
    DCB    "rmnma_",0,0,8,0,0,255
rmnma_
    MOV    ip,sp
    STMDB  sp!,{R0-R9,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R0,[R0]     ;m
    LDR    R1,[R1]     ;n
    LDR    R2,[R2]     ;k
    CMP    R0,#0       ;check m>0
    CMPGT  R1,#0       ;check n>0
    CMPGT  R2,#0       ;check k>0
    LDMLEDB fp,{R4-R9,fp,sp,pc} ;return if not
    LDMIB  fp,{R4-R9,ip,lr} ;arg addresses
    SUB    R4,R4,R3    ;X(i,j) :jstep
    SUB    R5,R5,R3    ;X(i,j) :istep
    SUB    R7,R7,R6    ;Y(j,l) :lstep
    SUB    R8,R8,R6    ;Y(j,l) :jstep
    SUB    ip,ip,R9    ;Z(i,l) :lstep
    SUB    lr,lr,R9    ;Z(i,l) :istep
wa1 STMFD  sp!,{R0,lr} ;save m and istep(Z)
    MOV    R0,R2       ;initialise l to k
    MLA    R6,R7,R2,R6 ;(Y(1,k+1))
    MLA    R9,ip,R2,R9 ;(Z(i,k+1))
wb1 MOV    lr,R1       ;initialise j to n
    SUB    R6,R6,R7    ;(Y(1,l))
    SUB    R9,R9,ip    ;(Z(i,l))
    MLA    R3,R4,R1,R3 ;(X(i,n+1))
    MLA    R6,R8,R1,R6 ;(Y(n+1,l))
    LDFS   F0,[R9]     ;initialise from +Z(i,l)
wc1 SUB    R3,R3,R4    ;(X(i,j))
    SUB    R6,R6,R8    ;(Y(j,l))
    LDFS   F1,[R3]     ;get X(i,j)
    LDFS   F2,[R6]     ;get Y(j,l)
    MUFE   F1,F1,F2
    SUFE   F0,F0,F1    ;subtract their products
    SUBS   lr,lr,#1
    BGT    wc1         ;loop over j=n,1,-1
    STFS   F0,[R9]     ;store Z(i,l)
    SUBS   R0,R0,#1
    BGT    wb1         ;loop over l=k,1,-1
    LDMFD  sp!,{R0,lr} ;restore m and istep(Z)
    ADD    R3,R3,R5    ;(X(i+1,1))
    ADD    R9,R9,lr    ;(Z(i+1,1))
    SUBS   R0,R0,#1
    BGT    wa1         ;loop over i=1,m
    LDMDB  fp,{R4-R9,fp,sp,pc} ;return
    END
;
    TTL    RMNMS
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
F2  FN     2
F1  FN     1
F0  FN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT rmnms_;(M,N,K,X11,X12,X21,Y11,Y12,Y21,Z11,Z12,Z21)  z = -xy - z
    DCB    "rmnms_",0,0,8,0,0,255
rmnms_
    MOV    ip,sp
    STMDB  sp!,{R0-R9,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R0,[R0]     ;m
    LDR    R1,[R1]     ;n
    LDR    R2,[R2]     ;k
    CMP    R0,#0       ;check m>0
    CMPGT  R1,#0       ;check n>0
    CMPGT  R2,#0       ;check k>0
    LDMLEDB fp,{R4-R9,fp,sp,pc} ;return if not
    LDMIB  fp,{R4-R9,ip,lr} ;arg addresses
    SUB    R4,R4,R3    ;X(i,j) :jstep
    SUB    R5,R5,R3    ;X(i,j) :istep
    SUB    R7,R7,R6    ;Y(j,l) :lstep
    SUB    R8,R8,R6    ;Y(j,l) :jstep
    SUB    ip,ip,R9    ;Z(i,l) :lstep
    SUB    lr,lr,R9    ;Z(i,l) :istep
wa1 STMFD  sp!,{R0,lr} ;save m and istep(Z)
    MOV    R0,R2       ;initialise l to k
    MLA    R6,R7,R2,R6 ;(Y(1,k+1))
    MLA    R9,ip,R2,R9 ;(Z(i,k+1))
wb1 MOV    lr,R1       ;initialise j to n
    SUB    R6,R6,R7    ;(Y(1,l))
    SUB    R9,R9,ip    ;(Z(i,l))
    MLA    R3,R4,R1,R3 ;(X(i,n+1))
    MLA    R6,R8,R1,R6 ;(Y(n+1,l))
    LDFS   F0,[R9]
    MNFE   F0,F0       ;initialise from -Z(i,l)
wc1 SUB    R3,R3,R4    ;(X(i,j))
    SUB    R6,R6,R8    ;(Y(j,l))
    LDFS   F1,[R3]     ;get X(i,j)
    LDFS   F2,[R6]     ;get Y(j,l)
    MUFE   F1,F1,F2
    SUFE   F0,F0,F1    ;subtract their products
    SUBS   lr,lr,#1
    BGT    wc1         ;loop over j=n,1,-1
    STFS   F0,[R9]     ;store Z(i,l)
    SUBS   R0,R0,#1
    BGT    wb1         ;loop over l=k,1,-1
    LDMFD  sp!,{R0,lr} ;restore m and istep(Z)
    ADD    R3,R3,R5    ;(X(i+1,1))
    ADD    R9,R9,lr    ;(Z(i+1,1))
    SUBS   R0,R0,#1
    BGT    wa1         ;loop over i=1,m
    LDMDB  fp,{R4-R9,fp,sp,pc} ;return
    END
;
    TTL    RMRAN
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R7  RN     7
R6  RN     6
R5  RN     5
R4  RN     4
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
F2  FN     2
F1  FN     1
F0  FN     0
    AREA   RNDMDAT,DATA
    DCD    12345       ;seed
    DCD    69069       ;multplier for random seq
    AREA   |C$$code|,CODE,READONLY
    EXPORT rmran_;(M,N,A,B,Z11,Z12,Z21)  Zij = random in range [A,B]
    DCB    "rmran_",0,0,8,0,0,255
rmran_
    MOV    ip,sp
    STMDB  sp!,{R0-R7,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDMIB  fp,{R4-R6}  ;arg addresses
    LDR    R0,[R0]     ;m
    LDR    R1,[R1]     ;n
    LDFS   F1,[R2]     ;a
    LDFS   F2,[R3]     ;b
    SUFE   F2,F2,F1    ;b-a
    LDFS   F0,norm     ;2**-31
    MUFE   F2,F2,F0
    SUB    R5,R5,R4    ; Zj step
    SUB    R6,R4,R6
    MLA    R6,R5,R1,R6 ;-Zi step
    LDR    R7,aptr
    LDMIA  R7,{R2,R3}  ;seed and multiplier
    CMP    R0,#1
wa9 MOV    ip,R1       ;j count
wb9 SUBGES ip,ip,#1
    MULGE  R2,R3,R2    ;new seed
    MOVGE  lr,R2,LSR#1
    FLTGEE F0,lr
    MUFGEE F0,F0,F2
    ADFGEE F0,F0,F1
    STFGES F0,[R4]     ;store Xij
    ADDGE  R4,R4,R5
    BGT    wb9         ;loop over j
    SUB    R4,R4,R6
    SUBEQS R0,R0,#1
    BGT    wa9         ;loop over i
    STR    R2,[R7]     ;restore seed
    LDMDB  fp,{R4-R7,fp,sp,pc} ;return
norm DCFS   4.65661287E-10;2**-31
aptr DCD    RNDMDAT
    END
;
    TTL    RMSCL
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
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
F1  FN     1
F0  FN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT rmscl_;(M,N,S,X11,X12,X21,Z11,Z12,Z21)  Zij = S * Xij
    DCB    "rmscl_",0,0,8,0,0,255
rmscl_
    MOV    ip,sp
    STMDB  sp!,{R0-R8,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDMIB  fp,{R4-R8}  ;arg addresses
    LDR    R0,[R0]     ;m
    LDR    R1,[R1]     ;n
    LDFS   F0,[R2]     ;s
    SUB    R4,R4,R3    ; Xj step
    SUB    R5,R3,R5
    MLA    R5,R4,R1,R5 ;-Xi step
    SUB    R7,R7,R6    ; Zj step
    SUB    R8,R6,R8
    MLA    R8,R7,R1,R8 ;-Zi step
    CMP    R0,#1
waa MOV    ip,R1       ;j count
wba SUBGES ip,ip,#1
    LDFGES F1,[R3]
    FMLGES F1,F1,F0
    STFGES F1,[R6]
    ADDGE  R3,R3,R4
    ADDGE  R6,R6,R7
    BGT    wba         ;loop over j
    SUB    R3,R3,R5
    SUB    R6,R6,R8
    SUBEQS R0,R0,#1
    BGT    waa         ;loop over i
    LDMDB  fp,{R4-R8,fp,sp,pc} ;return
    END
;
    TTL    RMSET
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R5  RN     5
R4  RN     4
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT rmset_;(M,N,S,Z11,Z12,Z21) z = s
    DCB    "rmset_",0,0,8,0,0,255
rmset_
    MOV    ip,sp
    STMDB  sp!,{R0-R5,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDMIB  fp,{R4-R5}  ;arg addresses
    LDR    R0,[R0]     ;m
    LDR    R1,[R1]     ;n
    LDR    R2,[R2]     ;s
    SUB    R4,R4,R3    ; Zj step
    SUB    R5,R3,R5
    MLA    R5,R4,R1,R5 ;-Zi step
    CMP    R0,#1
wab MOV    ip,R1       ;j - count
wbb SUBGES ip,ip,#1
    STRGE  R2,[R3],R4  ;to Zij
    BGT    wbb         ;loop over j
    SUB    R3,R3,R5
    SUBEQS R0,R0,#1
    BGT    wab         ;loop over i
    LDMDB  fp,{R4-R5,fp,sp,pc} ;return
    END
;
    TTL    RMSUB
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
F1  FN     1
F0  FN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT rmsub_;(M,N,X11,X12,X21,Y11,Y12,Y21,Z11,Z12,Z21)  z = x - y
    DCB    "rmsub_",0,0,8,0,0,255
rmsub_
    MOV    ip,sp
    STMDB  sp!,{R0-R9,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDMIB  fp,{R4-R9,lr}  ;arg addresses
    LDR    R0,[R0]     ;m
    LDR    R1,[R1]     ;n
    SUB    R3,R3,R2    ; Xj step
    SUB    R4,R2,R4
    MLA    R4,R3,R1,R4 ;-Xi step
    SUB    R6,R6,R5    ; Yj step
    SUB    R7,R5,R7
    MLA    R7,R6,R1,R7 ;-Yi step
    SUB    R9,R9,R8    ; Zj step
    SUB    lr,R8,lr
    MLA    lr,R9,R1,lr;-Zi step
    CMP    R0,#1
wac MOV    ip,R1      ;j - count
wbc SUBGES ip,ip,#1
    LDFGES F0,[R2]     ;Xij
    LDFGES F1,[R5]     ;Yij
    SUFGES F0,F0,F1
    STFGES F0,[R8]     ;Zij = Xij - Yij
    ADDGE  R2,R2,R3
    ADDGE  R5,R5,R6
    ADDGE  R8,R8,R9
    BGT    wbc         ;loop over j
    SUB    R2,R2,R4
    SUB    R5,R5,R7
    SUB    R8,R8,lr
    SUBEQS R0,R0,#1
    BGT    wac         ;loop over i
    LDMDB  fp,{R4-R9,fp,sp,pc} ;return
    END
;
    TTL    RMUTL
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
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 rmutl_;(N,X11,X12,X21) Xjk = Xkj   (j>k)
    DCB    "rmutl_",0,0,8,0,0,255
rmutl_
    MOV    ip,sp
    STMDB  sp!,{R0-R6,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R0,[R0]     ;n
    SUB    R2,R2,R1    ;j step
    SUB    R3,R3,R1    ;k step
    ADD    R5,R2,R3    ;k+j step
    SUBS   R0,R0,#1
wad MOV    R4,R0       ;count
    ADD    R6,R1,R2
    ADD    lr,R1,R3
wbd LDRGT  ip,[R6],R2  ;Xkj
    STRGT  ip,[lr],R3  ;to Xjk
    SUBGTS R4,R4,#1
    BGT    wbd         ;loop over j
    ADD    R1,R1,R5
    SUBS   R0,R0,#1
    BGT    wad         ;loop over k
    LDMDB  fp,{R4-R6,fp,sp,pc} ;return
    END
;
    TTL   rn2dim
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R0  RN     0
R1  RN     1
R2  RN     2
F0  FN     0
F1  FN     1
F2  FN     2
F3  FN     3
F4  FN     4
;
    AREA   |C$$data|,DATA
ibf2 DCD   20
rbf2 %     20*4
;
    AREA   |C$$code|,CODE,READONLY
    IMPORT ranlux_
    EXPORT rn2dim_;(X,Y,R) gets random point (X,Y) on circle radius R
;              
    DCB    "rn2dim_",0,8,0,0,255
rn2dim_
    MOV    ip,sp
    STMDB  sp!,{R0-R2,R4-R5,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R4,ptr          ;pointer to data
    LDR    R5,[R4]         ;IBF2
pt1 CMP    R5,#20          ;IF(IBF2.GE.20) THEN
    MOVGE  R5,#1           ; IBF2=1 
    ADDGE  R0,R4,#4        ; (RBF2)
    ADRGE  R1,twenty       ; (20)
    BLGE   ranlux_         ; CALL RANLUX(RBF2,20) to get 20 new random numbers
    ADD    ip,R4,R5,LSL#2  ;(RBF2(IBF2))
    LDFS   F0,[ip]         ;RBF2(IBF2)
    LDFS   F1,[ip,#4]      ;RBF2(IBF2+1)
    SUFS   F0,F0,#0.5      ;A=RBF2(IBF2)-0.5
    SUFS   F1,F1,#0.5      ;B=RBF2(IBF2+1)-0.5
    ADD    R5,R5,#2        ;IBF2 = IBF2 + 2
    FMLS   F2,F0,F0
    FMLS   F3,F1,F1
    ADFS   F2,F2,F3        ;R2 = A**2+B**2
    LDFS   F3,quarter
    CMF    F2,F3
    BGT    pt1             ;skip if R2>0.25
    SQTS   F2,F2           ;SQRT(R2)
    LDMIA  sp,{R0-R2}      ;restore arguments
    LDFS   F3,[R2]         ;R
    FDVS   F3,F3,F2        ;RINV = R/SQRT(R2)
    FMLS   F0,F0,F3
    FMLS   F1,F1,F3
    FMLS   F2,F2,F3
    STFS   F0,[R0]         ;X = A*RINV
    STFS   F1,[R1]         ;Y = B*RINV
    STR    R5,[R4]         ;save IBF2
    LDMDB  fp,{R4-R5,fp,sp,pc} ;return
ptr     DCD  ibf2
twenty  DCD  20
quarter DCFS 0.25
    END
;
    TTL   rn3dim
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
F0  FN     0
F1  FN     1
F2  FN     2
F3  FN     3
F4  FN     4
;
    AREA   |C$$data|,DATA
ibf3 DCD   30
rbf3 %     30*4
;
    AREA   |C$$code|,CODE,READONLY
    IMPORT ranlux_
    EXPORT rn3dim_;(X,Y,Z,R) gets random point (X,Y,Z) on sphere radius R
;              
    DCB    "rn3dim_",0,8,0,0,255
rn3dim_
    MOV    ip,sp
    STMDB  sp!,{R0-R5,fp,ip,lr,pc}
    SUB    fp,ip,#4
    STFE   F4,[sp,#-12]!   ;save F4
    LDR    R4,ptr          ;pointer to data
    LDR    R5,[R4]         ;IBF3
pt1 CMP    R5,#30          ;IF(IBF3.GE.30) THEN
    MOVGE  R5,#1           ; IBF3=1 
    ADDGE  R0,R4,#4        ; (RBF3)
    ADRGE  R1,thirty       ; (30)
    BLGE   ranlux_         ; CALL RANLUX(RBF3,30) to get 30 new random numbers
    ADD    ip,R4,R5,LSL#2  ;(RBF3(IBF3))
    LDFS   F0,[ip]         ;RBF3(IBF3)
    LDFS   F1,[ip,#4]      ;RBF3(IBF3+1)
    LDFS   F2,[ip,#8]      ;RBF3(IBF3+2)
    SUFS   F0,F0,#0.5      ;A=RBF3(IBF3)-0.5
    SUFS   F1,F1,#0.5      ;B=RBF3(IBF3+1)-0.5
    SUFS   F2,F2,#0.5      ;C=RBF3(IBF3+2)-0.5
    ADD    R5,R5,#3        ;IBF3 = IBF3 + 3
    FMLS   F4,F0,F0
    FMLS   F3,F1,F1
    ADFS   F4,F4,F3
    FMLS   F3,F2,F2
    ADFS   F4,F4,F3        ;R2 = A**2+B**2+C**2
    LDFS   F3,quarter
    CMF    F4,F3
    BGT    pt1             ;skip if R2>0.25
    SQTS   F4,F4           ;SQRT(R2)
    ADD    ip,sp,#12
    LDMIA  ip,{R0-R3}      ;restore arguments
    LDFS   F3,[R3]         ;R
    FDVS   F3,F3,F4        ;RINV = R/SQRT(R2)
    FMLS   F0,F0,F3
    FMLS   F1,F1,F3
    FMLS   F2,F2,F3
    STFS   F0,[R0]         ;X = A*RINV
    STFS   F1,[R1]         ;Y = B*RINV
    STFS   F2,[R2]         ;Z = C*RINV
    STR    R5,[R4]         ;save IBF3
    LDFE   F4,[sp],#12     ;restore F4
    LDMDB  fp,{R4-R5,fp,sp,pc} ;return
ptr     DCD  ibf3
thirty  DCD  30
quarter DCFS 0.25
    END
;
    TTL    RNDM
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R2  RN     2
R1  RN     1
R0  RN     0
F0  FN     0
F1  FN     1
F2  FN     2
F3  FN     3
    AREA   seed,DATA
    DCD    1234567        ;random seed
    DCD    69069          ;multiplier
    AREA   |C$$code|,CODE,READONLY
    EXPORT rndm_;() returns random real*4 (0.0 <= R < 1.0)
    DCB    "rndm_",0,0,0,8,0,0,255
rndm_
    MOV    ip,sp
    STMDB  sp!,{fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R0,ptr         ;address of seed
    LDMIA  R0,{R1,R2}     ;get seed and multiplier
    MUL    R2,R1,R2
    STR    R2,[R0]        ;store new seed
    BICS   R2,R2,#&FF
    BEQ    wlx
    MOV    R1,#&3F000000  ;initial exponent
wlp ADDS   R2,R2,R2       ;move up seed 1 bit
    SUBCC  R1,R1,#&800000 ;reduce exponent if no carry
    BCC    wlp            ;test next bit
    ORR    R2,R1,R2,LSR#9 ;insert exponent
wlx STR    R2,[sp,#-4]!   ;store answer
    LDFS   F0,[sp],#4     ;load it into result register
    LDMDB  fp,{fp,sp,pc}  ;return
ptr DCD    seed           ;address of seed
;
     EXPORT irndm_;() returns random integer from 1 to 2**31-1
;    BUT.. answers will either be all odd or all even depending on seed
    DCB    "irndm_",0,0,8,0,0,255
irndm_
    MOV    ip,sp
    STMDB  sp!,{fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R0,ptr         ;address of seed
    LDMIA  R0,{R1,R2}     ;get seed and multiplier
    MUL    R2,R1,R2
    STR    R2,[R0]        ;store new seed
    MOV    R0,R2,LSR#1    ;make >0
    LDMDB  fp,{fp,sp,pc}  ;return
;
    EXPORT rdmin_;(ISEED) installs new seed (odd integer)
    DCB    "rdmin_",0,0,8,0,0,255
rdmin_
    MOV    ip,sp
    STMDB  sp!,{R0,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R1,ptr         ;address of seed
    LDR    R0,[R0]        ;new seed
    STR    R0,[R1]        ;store
    LDMDB  fp,{fp,sp,pc}  ;return
;
    EXPORT rdmout_;(ISEED) returns current seed
    DCB    "rdmout_",0,8,0,0,255
rdmout_
    MOV    ip,sp
    STMDB  sp!,{R0,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R1,ptr         ;address of seed
    LDR    R1,[R1]        ;current seed
    STR    R1,[R0]        ;store
    LDMDB  fp,{fp,sp,pc}  ;return
;
    EXPORT rannor_;(A,B) returns random Gaussians
    DCB    "rannor_",0,8,0,0,255
rannor_
    MOV    ip,sp
    STMDB  sp!,{R0,R1,fp,ip,lr,pc}
    SUB    fp,ip,#4
pt1 BL     rndm_
    CMF    F0,#0
    BLE    pt1
    LGNS   F1,F0
    LDFS   F2,TWOPI
    MNFS   F1,F1        ;-LOG(R)
    BL     rndm_
    ADFS   F1,F1,F1     ;-2LOG(R)
    FMLS   F0,F0,F2     ;2pi*R
    SQTS   F1,F1        ;SQRT(-2LOG(R))
    COSS   F2,F0
    SINS   F3,F0
    FMLS   F2,F2,F1
    FMLS   F3,F3,F1
    LDMIA  sp,{R0,R1}   ;addresses of A and B
    STFS   F2,[R0]
    STFS   F3,[R1]
    LDMDB  fp,{fp,sp,pc}  ;return
TWOPI DCFS 6.2831853
    END
;
    TTL   rngama
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R0  RN     0
R1  RN     1
R2  RN     2
R4  RN     4
R5  RN     5
F0  FN     0
F1  FN     1
F2  FN     2
F3  FN     3
F4  FN     4
F5  FN     5
F6  FN     6
F7  FN     7
;
    AREA   |C$$data|,DATA
stor %     4      ;temporary storage
     %     15*4
;
    AREA   |C$$code|,CODE,READONLY
    IMPORT ranlux_
    IMPORT rnormx_
    EXPORT rngama_;(P) returns random value according to GAMMA(P)
;              
    DCB    "rngama_",0,8,0,0,255
rngama_
    MOV    ip,sp
    STMDB  sp!,{R0,R4-R5,fp,ip,lr,pc}
    SUB    fp,ip,#4
    SFMFD  F4,4,[sp]!    ;save fp registers
    LDR    R4,ptr        ;address of storage
    LDFS   F4,[R0]       ;P
    LDFS   F0,v15
    CMF    F4,F0
    BLE    np1
;               P>15 so do approximation; first prepare some constants
    SQTS   F5,F4
    FMLS   F5,F5,#3      ;3*SQRT(P)
    LDFS   F0,vr9        ;1/9
    FDVS   F0,F0,F4      ;1/(9*P)
    RSFS   F6,F0,#1      ;1-1/(9*P)
pt1 MOV    R0,R4         ;(A)
    ADR    R1,one
    LDR    R2,ran
    BL     rnormx_       ;CALL RNORMX(A,1,RANLUX)
    LDFS   F1,[R4]       ;A
    FDVS   F2,F1,F5      ;A/(3*SQRT(P))
    ADFS   F3,F2,F6      ;1-1/(9*P)+A/(3*SQRT(P))
    CMF    F3,#0
    BLE    pt1
    FMLS   F2,F3,F3
    FMLS   F0,F3,F2
    FMLS   F0,F0,F4      ;result = P*(1-1/(9*P)+A/(3*SQRT(P)))**3
ret LFMFD  F4,4,[sp]!    ;restore fp registers
    LDMDB  fp,{R4-R5,fp,sp,pc} ;return
;
np1;       P.LE.15
    FIXM   R5,F4          ;M=P
    FLTS   F0,R5
    SUFS   F5,F4,F0       ;F=P-M
    CMP    R5,#0          ;IF(M.LE.0) THEN
    MVFLES F4,#0          ; SET H=0
    BLE    np2            ; and skip extra terms
    ADD    R0,R4,#4       ;(STOR)
    STR    R5,[R4]
    MOV    R1,R4          ;(M)
    BL     ranlux_
    MVFS   F0,#1          ;initialize X=1
    ADD    R0,R4,#4       ;(STOR)
lp1 LDFS   F1,[R0],#4
    FMLS   F0,F0,F1       ;X = X*STOR(I)
    SUBS   R5,R5,#1
    BGT    lp1            ;loop over I=1,M
    LGNS   F4,F0
    MNFS   F4,F4          ;H = -LOG(X)
np2 LDFS   F0,eps
    CMF    F5,F0
    MVFLTS F0,F4
    BLT    ret            ;skip if F<0.00001
;
    MOV    R0,R4          ;(X)
    ADR    R1,one         ;(1)
    BL     ranlux_        ;get 1 random number in X
    LDFS   F0,[R4]        ;X
    LGNS   F1,F0
    MNFS   F6,F1          ;X1=-LOG(X)
    LDFS   F0,big
    CMF    F5,F0          ;IF(F.GE.0.9999) THEN
    ADFGES F0,F4,F6       ; H = H + X1
    BGE    ret            ; and skip
;
    MOV    R0,R4          ;(X)
    ADR    R1,one         ;(1)
    BL     ranlux_        ;get 1 random number in X
pt3 LDFS   F0,[R4]        ;X
    LGNS   F1,F0
    FDVS   F3,F1,F5       ;WLOG = LOG(X)/F
    LDFS   F0,cen
    CNFE   F3,F0
    MVFLTS F0,F4
    BLT    ret            ;skip if WLOG<-100
    EXPS   F7,F3          ;W1=EXP(WLOG)
    MOV    R0,R4          ;(X)
    ADR    R1,one         ;(1)
    BL     ranlux_        ;get 1 random number in X
    LDFS   F0,[R4]        ;X
    LGNS   F1,F0
    RSFS   F2,F5,#1       ;1-F
    FDVS   F3,F1,F2       ;WLOG = LOG(X)/(1-F)
    LDFS   F0,cen
    CNFE   F3,F0          ;IF(WLOG.LT.-100) THEN
    ADFLTS F0,F4,F6       ; H = H + X1
    BLT    ret            ; and skip
;
    EXPS   F0,F3
    ADFS   F1,F0,F7       ;W=EXP(WLOG)+W1
    CMF    F1,#1
    BGT    pt3            ;try again if W>1
    FMLS   F2,F6,F7       ;X1*W1
    FDVS   F3,F2,F1       ;X1*W1/W
    ADFS   F0,F4,F3       ;H = H + X1*W1/W
    B      ret
;
ptr DCD    stor
one DCD    1
vr9 DCFS   0.11111111
v15 DCFS   15.0
eps DCFS   0.00001
big DCFS   0.9999
cen DCFS   100.
ran DCD    ranlux_
    END
;
;     RNHPRE see RNHRAN
;
    TTL   rnhran
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
F0  FN     0
F1  FN     1
F2  FN     2
F3  FN     3
;
    AREA   |C$$code|,CODE,READONLY
    IMPORT ranlux_
    IMPORT locatr_
    EXPORT rnhran_;(Y,N,XLO,XWID,XRAN) XRAN=random value in histogram Y
;
    DCB    "rnhran_",0,8,0,0,255
rnhran_
    MOV    ip,sp
    STMDB  sp!,{R0-R3,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R3,[R1]          ;N
    ADD    ip,R0,R3,LSL#2
    LDFS   F0,[ip,#-4]      ;Y(N)
    CMF    F0,#1
    BEQ    pt4              ;Y is correctly normalised
;         make normalised cumulative histogram
pt5 MVFS   F3,#0            ;YTOT = 0
    MOV    ip,R0            ;(Y(1))
    MOV    R1,R3            ;loop count of N
lp1 LDFS   F0,[ip]          ;Y(I)
    CMF    F0,#0
    LDMLTDB fp,{fp,sp,pc} ;return on error (Y(I)<0)
    ADFS   F3,F3,F0         ;YTOT = YTOT + Y(I)
    STFS   F3,[ip],#4       ;Y(I) = YTOT
    SUBS   R1,R1,#1
    BGT    lp1              ;loop over I=1,N
    CMF    F3,#0
    LDMLEDB fp,{fp,sp,pc} ;return on error (YTOT<=0)
    FRDS   F2,F3,#1         ;YINV=1/YTOT
    MVFS   F0,#1
    STFS   F0,[ip,#-4]!     ;Y(N) = 1
    SUBS   R1,R3,#1         ;loop count of N-1
lp2 LDFGTS F0,[ip,#-4]!     ;Y(I)
    FMLGTS F0,F0,F2
    STFGTS F0,[ip]          ;Y(I) = Y(I)*YINV
    SUBGTS R1,R1,#1
    BGT    lp2              ;loop over I=N-1,1,-1
    CMP    R2,#0
    LDMEQDB fp,{fp,sp,pc} ;return from RNHPRE
;
pt4 SUB    sp,sp,#4         ;space for YR
    MOV    R0,sp
    ADR    R1,one
    BL     ranlux_          ;get random number
    LDMIB  sp,{R0,R1}       ;(Y),(N)
    MOV    R2,sp            ;(YR)
    BL     locatr_          ;L=LOCATR(Y,N,YR)
    LDFS   F0,[sp],#4       ;YR
    LDMIA  sp,{R1-R3,ip}    ;(Y),(N),(XLO),(XWID)
    LDFS   F2,[R3]          ;XLO
    LDFS   F3,[ip]          ;XWID
    CMP    R0,#0            ;test L
    RSBLT  R0,R0,#0         ;L<0 means in middle of -L'th bin
    ADDLT  R2,R1,R0,LSL#2   ; (Y(L+1))
    LDFLTS F1,[R2,#-4]      ; Y(L)
    SUFLTS F0,F0,F1         ; YR - Y(L)
    LDFLTS F2,[R2]          ; Y(L+1)
    SUFLTS F1,F2,F1         ; Y(L+1) - Y(L)
    FDVLTS F1,F0,F1         ; (YR - Y(L))/(Y(L+1) - Y(L))
    LDFLTS F2,[R3]          ; (restore XLO)
    FLTLTS F0,R0            ; L
    ADFLTS F1,F1,F0         ; form XFRAC=L + (YR-Y(L))/(Y(L+1)-Y(L))
    FLTGTS F1,R0            ;IF L>0 form XFRAC = L
    LDFEQS F1,[R1]          ;IF L=0
    FDVEQS F1,F0,F1         ; form XFRAC = YR/Y(1)
    FMLS   F1,F1,F3
    ADFS   F0,F1,F2         ;XRAN = XLO + XFAC*XWID
    LDR    R0,[fp,#4]       ;(XRAN)
    STFS   F0,[R0]
    LDMDB  fp,{fp,sp,pc} ;return
;
one DCD    1
;
    EXPORT rnhpre_;(Y,N) convert Y histogram to normalised cumulative
;
    DCB    "rnhpre_",0,8,0,0,255
rnhpre_
    MOV    ip,sp
    STMDB  sp!,{R0-R3,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R3,[R1]          ;N
    MOV    R2,#0            ;flag entry from rnhpre
    B      pt5
    END
;
;      RNPSET see RNPSSN
;
    TTL   rnpssn
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
F0  FN     0
F1  FN     1
F2  FN     2
F3  FN     3
;
    AREA   |C$$data|,DATA
emu     %  4
        %  4    ;R
amu0 DCFS  -12345.67
amax DCFS  88.0
    AREA   |C$$code|,CODE,READONLY
    IMPORT ranlux_
    IMPORT rnormx_
    EXPORT rnpssn_;(AMU,N,IERR) returns random poisson N of mean AMU
    DCB    "rnpssn_",0,8,0,0,255
rnpssn_
    MOV    ip,sp
    STMDB  sp!,{R0-R2,R4-R6,fp,ip,lr,pc}
    SUB    fp,ip,#4
    SFMFD  F4,2,[sp]!    ;save fp registers
    LDFS   F4,[R0]       ;AMU
    CMF    F4,#0
    MOVLE  R6,#1
    MOVLE  R0,#0
    BLE    ret           ;error: AMU.LE.0
    MOV    R6,#0
    LDR    R4,ptr
    LDFS   F0,[R4,#12]   ;AMAX
    CMF    F4,F0
    BLE    pt1
;      AMU>AMAX so approximate
    ADD    R0,R4,#4
    ADR    R1,one
    LDR    R2,ran
    BL     rnormx_       ;CALL RNORMX(R,1,RANLUX)
    LDFS   F0,[R4,#4]    ;R
    SQTS   F1,F4
    ADFS   F2,F4,#0.5
    FMLS   F1,F1,F0
    ADFS   F0,F1,F2
    FIXM   R0,F0         ;N=R*SQRT(AMU)+AMU+0.5
    MOV    R2,#0
    B      ret
pt1;    0<AMU<=AMAX
    LDFS   F0,[R4,#8]    ;AMU0
    CMF    F0,F4         ;IF(AMU.NE.AMU0) THEN
    STFNES F4,[R4,#8]    ; AMU0=AMU
    MNFNES F0,F4
    EXPNES F4,F0
    STFNES F4,[R4]       ; EMU = EXP(-AMU)
    LDFEQS F4,[R4]       ;EMU
    MVFS   F5,#1         ;initialize P=1
    MOV    R5,#-1
lp1 ADD    R5,R5,#1
    ADD    R0,R4,#4      ;(R)
    ADR    R1,one
    BL     ranlux_
    LDFS   F0,[R4,#4]    ;R
    FMLS   F5,F5,F0
    CMF    F5,F4
    BGT    lp1           ;loop until P<EMU
    MOV    R0,R5
ret LFMFD  F4,2,[sp]!    ;restore fp registers
    LDMIB  sp,{R1,R2}
    STR    R0,[R1]       ;store N
    STR    R6,[R2]       ;store IERR
    LDMDB  fp,{R4-R6,fp,sp,pc} ;return
;
ptr DCD    emu
one DCD    1
ran DCD    ranlux_
;
    EXPORT rnpset_;(AMX) new minimum for RPSSN approximation
    DCB    "rnpset_",0,8,0,0,255
rnpset_
    MOV    ip,sp
    STMDB  sp!,{R0,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R0,[R0]       ;AMX
    LDR    R2,mina
    CMP    R0,R2
    MOVGT  R0,R2         ;MIN(AMX,88.0)
    LDR    R1,ptr
    STR    R0,[R1,#12]   ;store in AMAX
    LDMDB  fp,{fp,sp,pc} ;return
mina DCFS  88.0
    END
;
    TTL    RNORML
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
F0  FN     0
F1  FN     1
F2  FN     2
F3  FN     3
F4  FN     4
F5  FN     5
F6  FN     6
R0  RN     0
R1  RN     1
    AREA   |C$$code|,CODE,READONLY
    EXPORT rnorml_ ;(D,N) generates random normal distribution n-vector
    IMPORT ranmar_ ;(U,N)
;
    DCB    "rnorml_",0,8,0,0,255
rnorml_
    MOV    ip,sp
    STMDB  sp!,{R0-R1,R4,R5,fp,ip,lr,pc}
    SUB    fp,ip,#4
    SUB    sp,sp,#8      ;space for random numbers
    STFE   F4,[sp,#-12]! ;save floating registers
    STFE   F5,[sp,#-12]!
    STFE   F6,[sp,#-12]!
    LDR    R4,[R1]       ;N
    MOV    R5,R0         ;(D)
lp1 ADD    R0,sp,#36
    ADR    R1,two
    BL     ranmar_       ;get two pseudo-random numbers
    LDFS   F0,[sp,#40]   ;RANDOM(2)
    LDFS   F1,cx         ;1.7156
    SUFS   F0,F0,#0.5
    LDFS   F2,[sp,#36]   ;RANDOM(1)
    FMLS   F0,F0,F1      ;V = 1.7156 * (RANDOM(2) - 0.5)
    LDFS   F3,s
    ABSS   F4,F0         ;|V|
    SUFS   F1,F2,F3      ;X = RANDOM(1) - S
    LDFS   F3,t
    LDFS   F5,a
    SUFS   F4,F4,F3      ;Y = ABS(V) - T
    LDFS   F6,b
    FMLS   F5,F5,F4      ;A*Y
    FMLS   F6,F6,F1      ;B*X
    FMLS   F1,F1,F1      ;X**2
    SUFS   F5,F5,F6      ;A*Y - B*X
    LDFS   F3,qx
    FMLS   F5,F5,F4      ;Y*(A*Y - B*X)
    LDFS   F6,qy
    ADFS   F4,F1,F5      ;Q = X**2 + Y*(A*Y - B*X)
    CMF    F4,F6
    BGT    lp1           ;reject P if outside outer ellipse
    CMF    F4,F3
    BLT    ok            ;accept P if inside inner ellipse
    LGNS   F3,F2         ;LOGe(RANDOM(1))
    FMLS   F4,F2,F2      ;RANDOM(1)**2
    FMLS   F1,F0,F0      ;V**2
    FMLS   F5,F3,F4
    FMLS   F6,F5,#4
    CNFE   F1,F6
    BGT    lp1
ok  FDVS   F0,F0,F2      ;V/RANDOM(1)
    STFS   F0,[R5],#4
    SUBS   R4,R4,#1
    BGT    lp1
    LDFE   F6,[sp],#12   ;restore floating point registers
    LDFE   F5,[sp],#12
    LDFE   F4,[sp],#12
    LDMDB   fp,{R4,R5,fp,sp,pc} 
two DCD    2
cx  DCFS   1.7156
s   DCFS   0.449871
t   DCFS  -0.386595
a   DCFS   0.19600
b   DCFS   0.25472
qx  DCFS   0.27597
qy  DCFS   0.27846
    END
;
    TTL    RNORMX
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
F0  FN     0
F1  FN     1
F2  FN     2
F3  FN     3
F4  FN     4
F5  FN     5
F6  FN     6
R0  RN     0
R1  RN     1
R2  RN     2
    AREA   |C$$code|,CODE,READONLY
    EXPORT rnormx_ ;(D,N,RSUB) generates random normal distribution n-vector
;                       using random generator RSUB
    DCB    "rnormx_",0,8,0,0,255
rnormx_
    MOV    ip,sp
    STMDB  sp!,{R0-R1,R4-R6,fp,ip,lr,pc}
    SUB    fp,ip,#4
    SUB    sp,sp,#8      ;space for random numbers
    STFE   F4,[sp,#-12]! ;save floating registers
    STFE   F5,[sp,#-12]!
    STFE   F6,[sp,#-12]!
    LDR    R4,[R1]       ;N
    MOV    R5,R0         ;(D)
    MOV    R6,R2         ;RSUB
lp1 ADD    R0,sp,#36
    ADR    R1,two
    ADR    R2,zer
    ADR    lr,ret
    MOV    pc,R6         ;get two pseudo-random numbers from RSUB
ret LDFS   F0,[sp,#40]   ;RANDOM(2)
    LDFS   F1,cx         ;1.7156
    SUFS   F0,F0,#0.5
    LDFS   F2,[sp,#36]   ;RANDOM(1)
    FMLS   F0,F0,F1      ;V = 1.7156 * (RANDOM(2) - 0.5)
    LDFS   F3,s
    ABSS   F4,F0         ;|V|
    SUFS   F1,F2,F3      ;X = RANDOM(1) - S
    LDFS   F3,t
    LDFS   F5,a
    SUFS   F4,F4,F3      ;Y = ABS(V) - T
    LDFS   F6,b
    FMLS   F5,F5,F4      ;A*Y
    FMLS   F6,F6,F1      ;B*X
    FMLS   F1,F1,F1      ;X**2
    SUFS   F5,F5,F6      ;A*Y - B*X
    LDFS   F3,qx
    FMLS   F5,F5,F4      ;Y*(A*Y - B*X)
    LDFS   F6,qy
    ADFS   F4,F1,F5      ;Q = X**2 + Y*(A*Y - B*X)
    CMF    F4,F6
    BGT    lp1           ;reject P if outside outer ellipse
    CMF    F4,F3
    BLT    ok            ;accept P if inside inner ellipse
    LGNS   F3,F2         ;LOGe(RANDOM(1))
    FMLS   F4,F2,F2      ;RANDOM(1)**2
    FMLS   F1,F0,F0      ;V**2
    FMLS   F5,F3,F4
    FMLS   F6,F5,#4
    CNFE   F1,F6
    BGT    lp1
ok  FDVS   F0,F0,F2      ;V/RANDOM(1)
    STFS   F0,[R5],#4
    SUBS   R4,R4,#1
    BGT    lp1
    LDFE   F6,[sp],#12   ;restore floating point registers
    LDFE   F5,[sp],#12
    LDFE   F4,[sp],#12
    LDMDB   fp,{R4-R6,fp,sp,pc} 
two DCD    2
zer DCD    0
cx  DCFS   1.7156
s   DCFS   0.449871
t   DCFS  -0.386595
a   DCFS   0.19600
b   DCFS   0.25472
qx  DCFS   0.27597
qy  DCFS   0.27846
    END
;
    TTL    ROT
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R2  RN     2
R1  RN     1
R0  RN     0
F3  FN     3
F2  FN     2
F1  FN     1
F0  FN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT rot_;(A,TH,B) B = A rotated through TH about z-axis
    DCB    "rot_",0,0,0,0,8,0,0,255
rot_
    MOV    ip,sp
    STMDB  sp!,{R0-R2,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDFS   F0,[R1]     ;TH
    SINS   F1,F0       ;SIN(TH)
    COSS   F0,F0       ;COS(TH)
    LDFS   F2,[R0]     ;A(1)
    LDFS   F3,[R0,#4]  ;A(2)
    FMLS   F2,F2,F0    ;A(1)*COS(TH)
    FMLS   F0,F0,F3    ;A(2)*COS(TH)
    FMLS   F3,F3,F1    ;A(2)*SIN(TH)
    SUFS   F2,F2,F3    ;A(1)*COS(TH) - A(2)*SIN(TH)
    LDFS   F3,[R0]     ;A(1)
    FMLS   F3,F3,F1    ;A(1)*SIN(TH)
    ADFS   F1,F3,F0    ;A(1)*SIN(TH) + A(2)*COS(TH)
    STFS   F2,[R2]     ;B(1) = A(1)*COS(TH) - A(2)*SIN(TH)
    STFS   F1,[R2,#4]  ;B(2) = A(1)*SIN(TH) + A(2)*COS(TH)
    LDR    R1,[R0,#8]
    STR    R1,[R2,#8]  ;B(3) = A(3)
    LDMDB  fp,{fp,sp,pc} 
    END
;
    TTL    RPLNML
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
F0  FN     0
F1  FN     1
F2  FN     2
R0  RN     0
R1  RN     1
R2  RN     2
R3  RN     3
    AREA   |C$$code|,CODE,READONLY
    EXPORT rplnml_ ;(X,N,C,MODE) make polynomial sum
;
    DCB    "rplnml_",0,8,0,0,255
rplnml_
    MOV    ip,sp
    STMDB  sp!,{R0-R3,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDFS   F1,[R0]       ;X
    LDR    R1,[R1]       ;N
    LDR    R3,[R3]       ;mode
    CMP    R3,#0
    MOVLT  R3,#4         ;step size
    MOVGE  R3,#-4
    ADDGE  R2,R2,R1,LSL#2;pointer to relevant end of array (0 or N)
    MVFD   F0,#0         ;accumulator
wlp LDFS   F2,[R2]       ;get coefficient
    MUFD   F0,F0,F1      ;multiply sum by X
    ADD    R2,R2,R3
    SUBS   R1,R1,#1
    ADFD   F0,F0,F2      ;add coefficient
    BGE    wlp           ;loop N+1 times
    LDMDB  fp,{fp,sp,pc} ;return
    END
;
    TTL    RSEQN
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 rseqn_;(N,A,IDIM,IFAIL,K,B) solves X=B/A, A becomes lower triangular
    IMPORT rsfact_
    IMPORT rsfeqn_
    DCB    "rseqn_",0,0,8,0,0,255
rseqn_
    MOV    ip,sp
    STMDB  sp!,{R0-R3,fp,ip,lr,pc}
    SUB    fp,ip,#4
    SUB    sp,sp,#8      ;space for DET & JFAIL
    MOV    ip,sp         ;address for DET
    ADD    lr,ip,#4      ;address for JFAIL
    STMFD  sp!,{ip,lr}
    BL     rsfact_
    ADD    sp,sp,#16     ;restore stack
    LDMFD  sp!,{R0-R3}   ;restore arguments
    LDR    ip,[R3]       ;get IFAIL
    CMP    ip,#0         ;test if OK
    LDMEQIB fp,{R3,ip}   ;address of K in R3
    STREQ  ip,[sp,#-4]!  ;address of B on stack
    BLEQ   rsfeqn_       ;call RSFEQN if OK
    LDMDB  fp,{fp,sp,pc} ;return
    END
;
    TTL    RSFACT
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
F2  FN     2
F3  FN     3
F5  FN     5
F6  FN     6
F7  FN     7
    AREA   |C$$code|,CODE,READONLY
    EXPORT rsfact_;(N,A,IDIM,IFAIL,DET,JFAIL) form lower triangular matrix
    DCB    "rsfact_",0,8,0,0,255
rsfact_
    MOV    ip,sp
    STMDB  sp!,{R0-R9,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R0,[R0]        ;N
    LDR    R2,[R2]        ;IDIM
    CMP    R0,#1
    CMPGE  R2,R0
    MOVLT  R0,#1
    STRLT  R0,[R3]        ;set IFAIL to 1 if N<1 or N>IDIM
    LDMLTDB fp,{R4-R9,fp,sp,pc} ;and return
    STFE   F7,[sp,#-12]!
    STFE   F6,[sp,#-12]!
    STFE   F5,[sp,#-12]!
;         initialise variables
    MVFE   F7,#1          ;DET=1
    LDFS   F5,CSMA        ;minimum DET
    LDFS   F6,CBIG        ;maximum DET
    MOV    R3,#0          ;initialise JFAIL
    MOV    R4,#0          ;J="1"
;         main loop over J=1,N
wl1 LDFS   F3,[R1]        ;A(J,J)
    CMF    F3,#0
    BLE    npd            ;not positive definite
    MUFE   F7,F7,F3       ;DET=DET*A(J,J)
    RDFE   F3,F3,#1
    STFS   F3,[R1],#4     ;A(J,J)=1/A(J,J) : (J+1,J)
    ADD    R1,R1,R2,LSL#2 ;(J+1,J+1)
    ABSS   F0,F7
    CMF    F0,F5
    MVFLEE F7,#0          ;too small, set to 0
    CMPLES R3,#0
    MOVEQ  R3,#-1         ;set jfail = -1
    CMF    F0,F6
    MVFGEE F7,#0          ;too big, set to 0
    CMPGES R3,#0
    MOVEQ  R3,#1          ;set jfail = +1
;         now factorise matrix
    ADD    R4,R4,#1       ;virtual increment j
    SUBS   R5,R0,R4       ;L count = N-J
    BLE    finish         ;done when J=N
    MOV    R7,R1          ;(L,J+1) L=J+1
    SUB    R6,R1,#4       ;(J,L) L=J+1
;         loop L = J+1 to N
wl2 SUB    R8,R7,R2,LSL#2 ;(L,I) I=J
    LDFS   F0,[R8]        ;A(L,J)
    MUFE   F0,F0,F3
    STFS   F0,[R6]        ;A(J,L)=A(J,J)*A(L,J)
    LDFS   F0,[R7]        ;-s1=A(L,J+1)
    SUB    R9,R1,#4       ;(I,J+1) I=J
    MOV    ip,R4          ;I count
;         loop over I=J,1,-1
wl3 LDFS   F1,[R8]        ;A(L,I)
    SUB    R8,R8,R2,LSL#2 ;(L,I-1)
    LDFS   F2,[R9],#-4    ;A(I,J+1) : (I-1,J+1)
    MUFE   F1,F1,F2
    SUFE   F0,F0,F1       ;-s1=-s1-A(L,I)*A(I,J+1)
    SUBS   ip,ip,#1
    BGT    wl3            ;loop over I
    STFS   F0,[R7],#4     ;A(L,J+1)=-s1 : (L+1,J+1)
    ADD    R6,R6,R2,LSL#2 ;(J,L+1)
    SUBS   R5,R5,#1
    BGT    wl2            ;loop over L
    B      wl1            ;loop over J
npd MOV    R5,#-1         ;not positive definite, IFAIL=-1
    MOV    R3,#-2         ;JFAIL=-2
finish;         done, so tidy up
    LDR    R7,[sp,#48]    ;address of IFAIL
    LDMIB  fp,{R8,R9}     ;addresses of DET,JFAIL
    STR    R5,[R7]        ;store IFAIL
    STFS   F7,[R8]        ;store DET
    STR    R3,[R9]        ;store JFAIL
    LDFE   F5,[sp],#12
    LDFE   F6,[sp],#12
    LDFE   F7,[sp],#12
    LDMDB  fp,{R4-R9,fp,sp,pc} ;return
CSMA DCFS  1.0E-19
CBIG DCFS  1.0E+19
    END
;
    TTL    RSFEQN
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
F0  FN     0
F1  FN     1
F2  FN     2
F3  FN     3
    AREA   |C$$code|,CODE,READONLY
    EXPORT rsfeqn_;(N,A,IDIM,K,B) solves X=B/A (A is lower triangular)
    DCB    "rsfeqn_",0,8,0,0,255
rsfeqn_
    MOV    ip,sp
    STMDB  sp!,{R4-R8,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    ip,[fp,#4]      ;address of B
    LDR    R0,[R0]         ;N
    LDR    R2,[R2]         ;IDIM
    LDR    R3,[R3]         ;K
    CMP    R2,R0
    SUBGES R0,R0,#1        ;N-1
    CMPGE  R3,#1
    LDMLTDB fp,{R4-R8,fp,sp,pc} ;return if IDIM<N, N<1 or K<1
;         loop over columns of B (L=1,K)
wl4 SUB    R8,ip,#4        ;(I-1,L) I=1
    SUB    R7,R1,R2,LSL#2  ;(I,I-1) I=1
    MOV    R5,R0           ;I count
;         loop over I=1,N
wl5 LDFS   F0,[R8,#4]!     ;-s21=B(I,L) : (I+1,L)
    MOV    R4,R7           ;(I,J) J=I-1
    MOV    R6,R8           ;(J+1,L) J=I-1
    CMP    R4,R1           ;check J>0
;         loop over J=I-1,1,-1
wl6 LDFGES F1,[R4]         ;A(I,J)
    SUBGE  R4,R4,R2,LSL#2  ;(I,J-1)
    LDFGES F2,[R6,#-4]!    ;B(J,L)
    MUFGEE F1,F1,F2
    SUFGEE F0,F0,F1        ;-s21=-s21-A(I,J)*B(J,L)
    CMP    R4,R1
    BGE    wl6             ;loop over J
    ADD    R7,R7,R2,LSL#2  ;(I,I)
    LDFS   F1,[R7],#4      ;A(I,I) : (I+1,I)
    MUFE   F0,F0,F1
    STFS   F0,[R8]         ;B(I,L)=-A(I,I)*s21
    SUBS   R5,R5,#1
    BGE    wl5             ;loop over I
    CMP    R0,#0
    BEQ    wp3             ;skip if N=1
;         loop over I=N-1,1,-1
wl7 LDFS   F0,[R8,#-4]!    ;-s22=B(I,L)
    SUB    R7,R7,#4        ;(I+1,N)
    SUB    R4,R7,#4        ;(I,J) J=N
    ADD    R6,ip,R0,LSL#2  ;(J,L) J=N
;         loop over J=N,I+1,-1
wl8 LDFS   F1,[R4]         ;A(I,J)
    SUB    R4,R4,R2,LSL#2  ;(I,J-1)
    LDFS   F2,[R6],#-4     ;B(J,L) : (J-1,L)
    MUFE   F1,F1,F2
    SUFE   F0,F0,F1        ;-s22=-s22-A(I,J)*B(J,L)
    CMP    R6,R8           ;(J',L) <=> (I,L)
    BGT    wl8             ;loop over J
    STFS   F0,[R8]         ;B(I,L)=-s22
    CMP    R8,ip
    BGT    wl7             ;loop over I
wp3 ADD    ip,ip,R2,LSL#2  ;(1,L+1)
    SUBS   R3,R3,#1
    BGT    wl4             ;loop over L
    LDMDB  fp,{R4-R8,fp,sp,pc} ;return
    END
;
    TTL    RSFINV
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
F0  FN     0
F1  FN     1
F2  FN     2
F3  FN     3
    AREA   |C$$code|,CODE,READONLY
    EXPORT rsfinv_;(N,A,IDIM) solves A = 1/A (A originally lower triangular)
    DCB    "rsfinv_",0,8,0,0,255
rsfinv_
    MOV    ip,sp
    STMDB  sp!,{R0-R2,R4-R7,fp,ip,lr,pc}
    SUB    fp,ip,#4
;         initialise variables
    LDR    R0,[R0]        ;N
    LDR    R2,[R2]        ;IDIM
    CMP    R2,R0
;         check for trivial case: N=1
    SUBGES R0,R0,#1       ;N-1
    LDMLEDB fp,{R4-R7,fp,sp,pc} ;return
    MOV    ip,#1          ;J-1 , J=2
    MOV    R4,R1          ;(J-1,J-1), J=2
;         loop over J = 2,N
wla ADD    R5,R4,#4       ;(J,J-1)
    ADD    R4,R5,R2,LSL#2 ;(J,J)
    LDFS   F3,[R4]        ;A(J,J)
    ADD    R6,R1,ip,LSL#2 ;(J,K) K=1
    SUB    R7,R4,ip,LSL#2 ;(K,J) K=1
;         loop over K=1,J-1
wlb LDFS   F0,[R7]        ;s31=A(K,J)
    SUB    lr,R7,R2,LSL#2 ;(K,I+1) I=J-2
    SUB    R3,R4,#4       ;(I+1,J) I=J-2
    CMP    R3,R7          ;check (I+1,J) > (K,J)
;         loop over I=J-2,K,-1
wlc LDFGTS F1,[R3],#-4    ;A(I+1,J) : (I,J)
    LDFGTS F2,[lr]        ;A(K,I+1)
    SUBGT  lr,lr,R2,LSL#2 ;(K,I)
    MUFGTE F1,F1,F2
    ADFGTE F0,F0,F1       ;s31=s31+A(K,I+1)*A(I+1,J)
    CMP    R3,R7          ;(I',J) <=> (K,J)
    BGT    wlc            ;loop over I
    MNFE   F0,F0          ;-s31
    STFS   F0,[R7],#4     ;A(K,J)=-s31 : (K+1,J)
    MUFE   F0,F0,F3
    STFS   F0,[R6]        ;A(J,K)=-s31*A(J,J)
    ADD    R6,R6,R2,LSL#2 ;(J,K+1)
    CMP    R6,R5          ;(J,K') <=> (J,J-1)
    BLE    wlb            ;loop over K
    ADD    ip,ip,#1       ;increment "J-1"
    CMP    ip,R0          ;compare with N-1
    BLE    wla            ;loop over "J-1"
;
    MOV    R4,R1          ;(J,J) J=1
    MOV    ip,#1          ;initialise J
;         loop over J = 1,N-1
wld ADD    R5,R4,R2,LSL#2 ;(J,I) I=J+1
    LDFS   F0,[R4]        ;s33=A(J,J)
    ADD    R6,R4,#4       ;(I,J) I=J+1
    SUB    R7,R0,ip       ;I count (=N-J)
;         loop over I = J+1,N
wle LDFS   F1,[R5]        ;A(J,I)
    ADD    R5,R5,R2,LSL#2 ;(J,I+1)
    LDFS   F2,[R6],#4     ;A(I,J) : (I+1,J)
    MUFE   F1,F1,F2
    ADFE   F0,F0,F1       ;s33=s33+A(J,I)*A(I,J)
    SUBS   R7,R7,#1
    BGE    wle            ;loop over I
    STFS   F0,[R4],#4     ;A(J,J)=s33 : (J+1,J)
    ADD    R4,R4,R2,LSL#2 ;(J+1,J+1)
    SUB    R5,R4,ip,LSL#2 ;(K,J+1) K=1
    ADD    R6,R1,ip,LSL#2 ;(J+1,K) K=1
;         loop over K=1,J
wlf MVFE   F0,#0          ;s32=0
    MOV    lr,R5          ;(K,I) I=J+1
    MOV    R3,R4          ;(I,J+1) I=J+1
    SUB    R7,R0,ip       ;I count (=N-J)
;         loop over I=J+1,N
wlg LDFS   F1,[lr]        ;A(K,I)
    ADD    lr,lr,R2,LSL#2 ;(K,I+1)
    LDFS   F2,[R3],#4     ;A(I,J+1) : (I+1,J+1)
    MUFE   F1,F1,F2
    ADFE   F0,F0,F1       ;s32=s32+A(K,I)*A(I,J+1)
    SUBS   R7,R7,#1
    BGE    wlg
    STFS   F0,[R5],#4     ;A(K,J+1)=s32 : (K+1,J+1)
    STFS   F0,[R6]        ;A(J+1,K)=s32
    ADD    R6,R6,R2,LSL#2 ;(J+1,K+1)
    CMP    R5,R4          ;(K',J+1) <=> (J+1,J+1)
    BLT    wlf            ;loop over K
    ADD    ip,ip,#1
    CMP    ip,R0
    BLE    wld            ;loop over J
    LDMDB  fp,{R4-R7,fp,sp,pc} ;return
    END
;
    TTL    RSINV
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 rsinv_;(N,A,IDIM,IFAIL) finds A=1/A (symmetric)
    IMPORT rsfact_
    IMPORT rsfinv_
    DCB    "rsinv_",0,0,8,0,0,255
rsinv_
    MOV    ip,sp
    STMDB  sp!,{R0-R3,fp,ip,lr,pc}
    SUB    fp,ip,#4
    SUBS   sp,sp,#8      ;space for DET and JFAIL
    MOV    ip,sp         ;address for DET
    ADD    lr,ip,#4      ;address for JFAIL
    STMFD  sp!,{ip,lr}
    BL     rsfact_
    ADD    sp,sp,#16     ;restore stack
    LDMFD  sp!,{R0-R3}
    LDR    ip,[R3]
    CMP    ip,#0         ;test IFAIL
    BLEQ   rsfinv_       ;call RSFINV if OK
    LDMDB  fp,{fp,sp,pc} ;return
    END
;
    TTL    RUMNA
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
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
F2  FN     2
F1  FN     1
F0  FN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT rumna_;(N,U11,U12,U22,Y1,Y2,Z1,Z2)    Zj =  Zj - sum(Ujk * Yk) k=j,n
    DCB    "rumna_",0,0,8,0,0,255
rumna_
    MOV    ip,sp
    STMDB  sp!,{R0-R8,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDMIB  fp,{R4-R7}  ;arg addresses
    LDR    R0,[R0]     ;n
    SUB    R2,R2,R1    ; Uk step
    SUB    R3,R3,R1    ; Ujj step
    SUB    R5,R5,R4    ; Yk step
    SUB    R7,R7,R6    ; Zj step
waf ADDS   R8,R0,#0    ;k-count
    LDFGTS F0,[R6]     ;initialise Zj
    MOV    ip,R1       ;(j,k) = (j,j)
    MOV    lr,R4       ;(k)
wbf LDFGTS F1,[ip]     ;Ujk
    LDFGTS F2,[lr]     ;Yk
    MUFGTE F1,F1,F2
    SUFGTE F0,F0,F1    ;-sum
    ADD    ip,ip,R2
    ADD    lr,lr,R5
    SUBS   R8,R8,#1
    BGT    wbf         ;loop over k
    STFGES F0,[R6]     ;store Zj
    ADD    R6,R6,R7
    ADD    R1,R1,R3
    ADD    R4,R4,R5
    SUBS   R0,R0,#1
    BGT    waf         ;loop over j
    LDMDB  fp,{R4-R8,fp,sp,pc} ;return
    END
;
    TTL    RUMNS
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
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
F2  FN     2
F1  FN     1
F0  FN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT rumns_;(N,U11,U12,U22,Y1,Y2,Z1,Z2)    Zj = -Zj - sum(Ujk * Yk) k=j,n
    DCB    "rumns_",0,0,8,0,0,255
rumns_
    MOV    ip,sp
    STMDB  sp!,{R0-R8,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDMIB  fp,{R4-R7}  ;arg addresses
    LDR    R0,[R0]     ;n
    SUB    R2,R2,R1    ; Uk step
    SUB    R3,R3,R1    ; Ujj step
    SUB    R5,R5,R4    ; Yk step
    SUB    R7,R7,R6    ; Zj step
wag ADDS   R8,R0,#0    ;k-count
    LDFGTS F0,[R6]
    MNFGTE F0,F0       ;initialise Zj
    MOV    ip,R1       ;(j,k)
    MOV    lr,R4       ;(k)
wbg LDFGTS F1,[ip]     ;Ujk
    LDFGTS F2,[lr]     ;Yk
    MUFGTE F1,F1,F2
    SUFGTE F0,F0,F1    ;-sum
    ADD    ip,ip,R2
    ADD    lr,lr,R5
    SUBS   R8,R8,#1
    BGT    wbg         ;loop over k
    STFGES F0,[R6]     ;store Zj
    ADD    R6,R6,R7
    ADD    R1,R1,R3
    ADD    R4,R4,R5
    SUBS   R0,R0,#1
    BGT    wag         ;loop over j
    LDMDB  fp,{R4-R8,fp,sp,pc} ;return
    END
;
    TTL    RUMPA
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
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
F2  FN     2
F1  FN     1
F0  FN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT rumpa_;(N,U11,U12,U22,Y1,Y2,Z1,Z2)    Zj =  Zj + sum(Ujk * Yk) k=j,n
    DCB    "rumpa_",0,0,8,0,0,255
rumpa_
    MOV    ip,sp
    STMDB  sp!,{R0-R8,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDMIB  fp,{R4-R7}  ;arg addresses
    LDR    R0,[R0]     ;n
    SUB    R2,R2,R1    ; Uk step
    SUB    R3,R3,R1    ; Ujj step
    SUB    R5,R5,R4    ; Yk step
    SUB    R7,R7,R6    ; Zj step
wah ADDS   R8,R0,#0    ;k-count
    LDFGTS F0,[R6]     ;initialise Zj
    MOV    ip,R1       ;(j,k)
    MOV    lr,R4       ;(k)
wbh LDFGTS F1,[ip]     ;Ujk
    LDFGTS F2,[lr]     ;Yk
    MUFGTE F1,F1,F2
    ADFGTE F0,F0,F1    ;sum
    ADD    ip,ip,R2
    ADD    lr,lr,R5
    SUBS   R8,R8,#1
    BGT    wbh         ;loop over k
    STFGES F0,[R6]     ;store Zj
    ADD    R6,R6,R7
    ADD    R1,R1,R3
    ADD    R4,R4,R5
    SUBS   R0,R0,#1
    BGT    wah         ;loop over j
    LDMDB  fp,{R4-R8,fp,sp,pc} ;return
    END
;
    TTL    RUMPS
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
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
F2  FN     2
F1  FN     1
F0  FN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT rumps_;(N,U11,U12,U22,Y1,Y2,Z1,Z2)   Zj = -Zj + sum(Ujk * Yk) k=j,n
    DCB    "rumps_",0,0,8,0,0,255
rumps_
    MOV    ip,sp
    STMDB  sp!,{R0-R8,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDMIB  fp,{R4-R7}  ;arg addresses
    LDR    R0,[R0]     ;n
    SUB    R2,R2,R1    ; Uk step
    SUB    R3,R3,R1    ; Ujj step
    SUB    R5,R5,R4    ; Yk step
    SUB    R7,R7,R6    ; Zj step
wai ADDS   R8,R0,#0    ;k-count
    LDFGTS F0,[R6]
    MNFGTE F0,F0       ;initialise Zj
    MOV    ip,R1       ;(j,k)
    MOV    lr,R4       ;(k)
wbi LDFGTS F1,[ip]     ;Ujk
    LDFGTS F2,[lr]     ;Yk
    MUFGTE F1,F1,F2
    ADFGTE F0,F0,F1    ;sum
    ADD    ip,ip,R2
    ADD    lr,lr,R5
    SUBS   R8,R8,#1
    BGT    wbi         ;loop over k
    STFGES F0,[R6]     ;store Zj
    ADD    R6,R6,R7
    ADD    R1,R1,R3
    ADD    R4,R4,R5
    SUBS   R0,R0,#1
    BGT    wai         ;loop over j
    LDMDB  fp,{R4-R8,fp,sp,pc} ;return
    END
;
    TTL    RUMPY
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
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
F2  FN     2
F1  FN     1
F0  FN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT rumpy_;(N,U11,U12,U22,Y1,Y2,Z1,Z2)    Zj = sum(Ujk * Yk) k=j,n
    DCB    "rumpy_",0,0,8,0,0,255
rumpy_
    MOV    ip,sp
    STMDB  sp!,{R0-R8,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDMIB  fp,{R4-R7}  ;arg addresses
    LDR    R0,[R0]     ;n
    SUB    R2,R2,R1    ; Uk step
    SUB    R3,R3,R1    ; Ujj step
    SUB    R5,R5,R4    ; Yk step
    SUB    R7,R7,R6    ; Zj step
waj ADDS   R8,R0,#0    ;k-count
    MVFGTE F0,#0       ;initialise Zj
    MOV    ip,R1       ;(j,k)
    MOV    lr,R4       ;(k)
wbj LDFGTS F1,[ip]     ;Ujk
    LDFGTS F2,[lr]     ;Yk
    MUFGTE F1,F1,F2
    ADFGTE F0,F0,F1    ;sum
    ADD    ip,ip,R2
    ADD    lr,lr,R5
    SUBS   R8,R8,#1
    BGT    wbj         ;loop over k
    STFGES F0,[R6]     ;store Zj
    ADD    R6,R6,R7
    ADD    R1,R1,R3
    ADD    R4,R4,R5
    SUBS   R0,R0,#1
    BGT    waj         ;loop over j
    LDMDB  fp,{R4-R8,fp,sp,pc} ;return
    END
;
    TTL    RVADD
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R6  RN     6
R5  RN     5
R4  RN     4
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
F1  FN     1
F0  FN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT rvadd_;(N,X1,X2,Y1,Y2,Z1,Z2) Zi = Xi + Yi, i=1,N
    DCB    "rvadd_",0,0,8,0,0,255
rvadd_
    MOV    ip,sp
    STMDB  sp!,{R0-R6,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDMIB  fp,{R4-R6} ;get addresses of Y2,Z1,Z2
    LDR    R0,[R0]    ;N
    SUB    R2,R2,R1   ;X step
    SUB    R4,R4,R3   ;Y step
    SUB    R6,R6,R5   ;Z step
wl1 SUBS   R0,R0,#1
    LDFGES F0,[R1]
    LDFGES F1,[R3]
    ADFGES F1,F0,F1
    STFGES F1,[R5]
    ADDGT  R1,R1,R2
    ADDGT  R3,R3,R4
    ADDGT  R5,R5,R6
    BGT    wl1
    LDMDB  fp,{R4-R6,fp,sp,pc} ;return
    END
;
    TTL    RVCPY
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT rvcpy_;(N,X1,X2,Z1,Z2) Zi = Xi, i=1,N
    DCB    "rvcpy_",0,0,8,0,0,255
rvcpy_
    MOV    ip,sp
    STMDB  sp!,{R0-R3,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    ip,[ip]    ;address of Z2
    LDR    R0,[R0]    ;n
    SUB    R2,R2,R1   ;x step
    SUB    ip,ip,R3   ;z step
wl1 SUBS   R0,R0,#1
    LDRGE  lr,[R1],R2
    STRGE  lr,[R3],ip
    BGT    wl1
    LDMDB  fp,{fp,sp,pc} ;return
    END
;
    TTL    RVDIV
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R7  RN     7
R6  RN     6
R5  RN     5
R4  RN     4
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
F1  FN     1
F0  FN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT rvdiv_;(N,X1,X2,Y1,Y2,Z1,Z2,IFAIL) Zi = Xi/Yi, i=1,N
    DCB    "rvdiv_",0,0,8,0,0,255
rvdiv_
    MOV    ip,sp
    STMDB  sp!,{R0-R7,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDMIB  fp,{R4-R7} ;addresses of Y2 to IFAIL
    LDR    R0,[R0]    ;n
    SUB    R2,R2,R1   ;x step
    SUB    R4,R4,R3   ;y step
    SUB    R6,R6,R5   ;z step
    ADD    lr,R0,#1   ;ifail
    CMP    R0,#0
    BLE    wp1
wl1 LDFS   F0,[R1]
    LDFS   F1,[R3]
    CMF    F1,#0      ;check for divide by 0
    BEQ    wp2
    FDVS   F1,F0,F1
    STFS   F1,[R5]
    ADD    R1,R1,R2
    ADD    R3,R3,R4
    ADD    R5,R5,R6
    SUBS   R0,R0,#1
    BGT    wl1
wp1 MOV    lr,R0
wp2 SUB    lr,lr,R0
    STR    lr,[R7]    ;store ifail
    LDMDB  fp,{R4-R7,fp,sp,pc} ;return
    END
;
    TTL    RVMPY
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
F2  FN     2
F1  FN     1
F0  FN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT rvmpy_;(N,X1,X2,Y1,Y2) => sum(xi*yi) i=1,N
    DCB    "rvmpy_",0,0,8,0,0,255
rvmpy_
    MOV    ip,sp
    STMDB  sp!,{R0-R3,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    ip,[ip]    ;address of Y2
    LDR    R0,[R0]    ;n
    SUB    R2,R2,R1   ;x step
    SUB    ip,ip,R3   ;y step
    MVFE   F0,#0      ;accumulator
wl1 SUBS   R0,R0,#1
    LDFGES F2,[R1]
    LDFGES F1,[R3]
    MUFGEE F1,F2,F1
    ADFGEE F0,F0,F1
    ADDGT  R1,R1,R2
    ADDGT  R3,R3,ip
    BGT    wl1
    LDMDB  fp,{fp,sp,pc} ;return
    END
;
    TTL    RVMPA
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
F2  FN     2
F1  FN     1
F0  FN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT rvmpa_;(N,X1,X2,Y1,Y2,S) => S + sum(Xi,Yi), i=1,N
    DCB    "rvmpa_",0,0,8,0,0,255
rvmpa_
    MOV    ip,sp
    STMDB  sp!,{R0-R3,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    ip,[fp,#8] ;address of S
    LDFS   F0,[ip]    ;S
    LDR    ip,[fp,#4] ;address of Y2
    LDR    R0,[R0]    ;n
    SUB    R2,R2,R1   ;x step
    SUB    ip,ip,R3   ;y step
wl1 SUBS   R0,R0,#1
    LDFGES F2,[R1]
    LDFGES F1,[R3]
    MUFGEE F1,F2,F1
    ADFGEE F0,F0,F1
    ADDGT  R1,R1,R2
    ADDGT  R3,R3,ip
    BGT    wl1
    LDMDB  fp,{fp,sp,pc} ;return
    END
;
    TTL    RVMUL
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R6  RN     6
R5  RN     5
R4  RN     4
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
F1  FN     1
F0  FN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT rvmul_;(N,X1,X2,Y1,Y2,Z1,Z2) Zi = Xi * Yi, i=1,N
    DCB    "rvmul_",0,0,8,0,0,255
rvmul_
    MOV    ip,sp
    STMDB  sp!,{R0-R6,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDMIB  fp,{R4-R6} ;get addresses of Y2,Z1,Z2
    LDR    R0,[R0]    ;N
    SUB    R2,R2,R1   ;X step
    SUB    R4,R4,R3   ;Y step
    SUB    R6,R6,R5   ;Z step
wl1 SUBS   R0,R0,#1
    LDFGES F0,[R1]
    LDFGES F1,[R3]
    FMLGES F1,F0,F1
    STFGES F1,[R5]
    ADDGT  R1,R1,R2
    ADDGT  R3,R3,R4
    ADDGT  R5,R5,R6
    BGT    wl1
    LDMDB  fp,{R4-R6,fp,sp,pc} ;return
    END
;
    TTL    RVMULA
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R6  RN     6
R5  RN     5
R4  RN     4
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
F1  FN     1
F0  FN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT rvmula_;(N,X1,X2,Y1,Y2,Z1,Z2) Zi = Zi + Xi*Yi, i=1,N
    DCB    "rvmula_",0,8,0,0,255
rvmula_
    MOV    ip,sp
    STMDB  sp!,{R0-R6,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDMIB  fp,{R4-R6} ;get addresses of Y2,Z1,Z2
    LDR    R0,[R0]    ;N
    SUB    R2,R2,R1   ;X step
    SUB    R4,R4,R3   ;Y step
    SUB    R6,R6,R5   ;Z step
wl1 SUBS   R0,R0,#1
    LDFGES F0,[R1]
    LDFGES F1,[R3]
    FMLGES F1,F0,F1
    LDFGES F0,[R5]
    ADFGES F1,F0,F1
    STFGES F1,[R5]
    ADDGT  R1,R1,R2
    ADDGT  R3,R3,R4
    ADDGT  R5,R5,R6
    BGT    wl1
    LDMDB  fp,{R4-R6,fp,sp,pc} ;return
    END
;
    TTL    RVMUNA
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R6  RN     6
R5  RN     5
R4  RN     4
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
F1  FN     1
F0  FN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT rvmuna_;(N,X1,X2,Y1,Y2,Z1,Z2) Zi = Zi - Xi*Yi, i=1,N
    DCB    "rvmuna_",0,8,0,0,255
rvmuna_
    MOV    ip,sp
    STMDB  sp!,{R0-R6,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDMIB  fp,{R4-R6} ;get addresses of Y2,Z1,Z2
    LDR    R0,[R0]    ;N
    SUB    R2,R2,R1   ;X step
    SUB    R4,R4,R3   ;Y step
    SUB    R6,R6,R5   ;Z step
wl1 SUBS   R0,R0,#1
    LDFGES F0,[R1]
    LDFGES F1,[R3]
    FMLGES F1,F0,F1
    LDFGES F0,[R5]
    SUFGES F1,F0,F1
    STFGES F1,[R5]
    ADDGT  R1,R1,R2
    ADDGT  R3,R3,R4
    ADDGT  R5,R5,R6
    BGT    wl1
    LDMDB  fp,{R4-R6,fp,sp,pc} ;return
    END
;
    TTL    RVRAN
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R4  RN     4
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
F2  FN     2
F1  FN     1
F0  FN     0
    AREA   seed,DATA
    DCD    12345
    DCD    69069      ;multiplier for random sequencs
    AREA   |C$$code|,CODE,READONLY
    EXPORT rvran_;(N,A,B,Z1,Z2) Zi = random[A to B], i=1,N
    DCB    "rvran_",0,0,8,0,0,255
rvran_
    MOV    ip,sp
    STMDB  sp!,{R0-R4,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    ip,[ip]    ;address of Z2
    LDR    R0,[R0]    ;n
    LDFS   F1,[R1]    ;a
    LDFS   F2,[R2]    ;b
    SUFE   F2,F2,F1   ;b-a
    LDFS   F0,norm    ;2**-31
    MUFE   F2,F2,F0
    SUB    ip,ip,R3   ;z step
    LDR    R4,sptr
    LDMIA  R4,{R1,R2} ;random seed & multiplier
wl7 SUBS   R0,R0,#1
    MULGE  R1,R2,R1   ;new seed
    MOVGE  lr,R1,LSR#1
    FLTGEE F0,lr
    MUFGEE F0,F0,F2
    ADFGEE F0,F0,F1
    STFGES F0,[R3]
    ADDGT  R3,R3,ip
    BGT    wl7
    STR    R1,[R4]    ;restore seed
    LDMDB  fp,{R4,fp,sp,pc} ;return
norm DCFS   4.65661287E-10;2**-31
sptr DCD    seed
    END
;
    TTL    RVSCA
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
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
F2  FN     2
F1  FN     1
F0  FN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT rvsca_;(N,S,X1,X2,Y1,Y2,Z1,Z2) Zi = S*Xi + Yi, i=1,N
    DCB    "rvsca_",0,0,8,0,0,255
rvsca_
    MOV    ip,sp
    STMDB  sp!,{R0-R7,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDMIB  fp,{R4-R7} ;xtra arg addresses
    LDR    R0,[R0]    ;n
    LDFS   F2,[R1]    ;s
    SUB    R3,R3,R2   ;x step
    SUB    R5,R5,R4   ;y step
    SUB    R7,R7,R6   ;z step
wl1 SUBS   R0,R0,#1
    LDFGES F0,[R2]
    LDFGES F1,[R4]
    FMLGES F0,F0,F2
    ADFGES F0,F0,F1
    STFGES F0,[R6]
    ADDGT  R2,R2,R3
    ADDGT  R4,R4,R5
    ADDGT  R6,R6,R7
    BGT    wl1
    LDMDB  fp,{R4-R7,fp,sp,pc} ;return
    END
;
    TTL    RVSCL
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
F2  FN     2
F1  FN     1
F0  FN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT rvscl_;(N,S,X1,X2,Z1,Z2) Zi = S*Xi, i=1,N
    DCB    "rvscl_",0,0,8,0,0,255
rvscl_
    MOV    ip,sp
    STMDB  sp!,{R0-R3,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDFS   F2,[R1]    ;s
    LDMIB  fp,{R1,ip} ;addresses of Z1 & Z2
    LDR    R0,[R0]    ;n
    SUB    R3,R3,R2   ;x step
    SUB    ip,ip,R1   ;z step
wl1 SUBS   R0,R0,#1
    LDFGES F0,[R2]
    FMLGES F0,F0,F2
    STFGES F0,[R1]
    ADDGT  R2,R2,R3
    ADDGT  R1,R1,ip
    BGT    wl1
    LDMDB  fp,{fp,sp,pc} ;return
    END
;
    TTL    RVSCS
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R7  RN     7
R6  RN     6
R5  RN     5
R4  RN     4
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
F2  FN     2
F1  FN     1
F0  FN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT rvscs_;(N,S,X1,X2,Y1,Y2,Z1,Z2) Zi = S*Xi - Yi, i=1,N
    DCB    "rvscs_",0,0,8,0,0,255
rvscs_
    MOV    ip,sp
    STMDB  sp!,{R0-R7,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDMIB  fp,{R4-R7} ;xtra arg addresses
    LDR    R0,[R0]    ;n
    LDFS   F2,[R1]    ;s
    SUB    R3,R3,R2   ;x step
    SUB    R5,R5,R4   ;y step
    SUB    R7,R7,R6   ;z step
wl1 SUBS   R0,R0,#1
    LDFGES F0,[R2]
    LDFGES F1,[R4]
    FMLGES F0,F0,F2
    SUFGES F0,F0,F1
    STFGES F0,[R6]
    ADDGT  R2,R2,R3
    ADDGT  R4,R4,R5
    ADDGT  R6,R6,R7
    BGT    wl1
    LDMDB  fp,{R4-R7,fp,sp,pc} ;return
    END
;
    TTL    RVSET
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT rvset_;(N,S,Z1,Z2) Zi = S, i=1,N
    DCB    "rvset_",0,0,8,0,0,255
rvset_
    MOV    ip,sp
    STMDB  sp!,{R0-R3,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R0,[R0]    ;n
    LDR    R1,[R1]    ;s
    SUB    R3,R3,R2   ;z step
wl1 SUBS   R0,R0,#1
    STRGE  R1,[R2],R3
    BGT    wl1
    LDMDB  fp,{fp,sp,pc} ;return
    END
;
    TTL    RVSUB
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R6  RN     6
R5  RN     5
R4  RN     4
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
F1  FN     1
F0  FN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT rvsub_;(N,X1,X2,Y1,Y2,Z1,Z2) Zi = Xi - Yi, i=1,N
    DCB    "rvsub_",0,0,8,0,0,255
rvsub_
    MOV    ip,sp
    STMDB  sp!,{R0-R6,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDMIB  fp,{R4-R6} ;get addresses of Y2,Z1,Z2
    LDR    R0,[R0]    ;N
    SUB    R2,R2,R1   ;X step
    SUB    R4,R4,R3   ;Y step
    SUB    R6,R6,R5   ;Z step
wl1 SUBS   R0,R0,#1
    LDFGES F0,[R1]
    LDFGES F1,[R3]
    SUFGES F1,F0,F1
    STFGES F1,[R5]
    ADDGT  R1,R1,R2
    ADDGT  R3,R3,R4
    ADDGT  R5,R5,R6
    BGT    wl1
    LDMDB  fp,{R4-R6,fp,sp,pc} ;return
    END
;
    TTL    RVSUM
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R2  RN     2
R1  RN     1
R0  RN     0
F1  FN     1
F0  FN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT rvsum_;(N,X1,X2) => sum(Xi), i=1,N
    DCB    "rvsum_",0,0,8,0,0,255
rvsum_
    MOV    ip,sp
    STMDB  sp!,{R0-R2,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R0,[R0]    ;n
    SUB    R2,R2,R1   ;x step
    MVFE   F0,#0      ;accumulator
wlf SUBS   R0,R0,#1
    LDFGES F1,[R1]
    ADFGEE F0,F1,F0
    ADDGE  R1,R1,R2
    BGT    wlf
    LDMDB  fp,{fp,sp,pc} ;return
    END
;
    TTL    RVXCH
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R6  RN     6
R5  RN     5
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT rvxch_;(N,X1,X2,Y1,Y2) Xi = Yi while Yi = Xi, i=1,N
    DCB    "rvxch_",0,0,8,0,0,255
rvxch_
    MOV    ip,sp
    STMDB  sp!,{R0-R3,R5,R6,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    ip,[ip]    ;address of Y2
    LDR    R0,[R0]    ;n
    SUB    R2,R2,R1   ;x step
    SUB    ip,ip,R3   ;y step
wl1 SUBS   R0,R0,#1
    LDRGE  R5,[R1]
    LDRGE  R6,[R3]
    STRGE  R6,[R1],R2
    STRGE  R5,[R3],ip
    BGT    wl1
    LDMDB  fp,{R5,R6,fp,sp,pc} ;return
    END
;
    TTL   rzero
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
R4  RN     4
R5  RN     5
R6  RN     6
R7  RN     7
R8  RN     8
R9  RN     9
F0  FN     0
F1  FN     1
F2  FN     2
F3  FN     3
F4  FN     4
F5  FN     5
F6  FN     6
F7  FN     7
;
    AREA   |C$$code|,CODE,READONLY
    EXPORT rzero_;(A,B,X0,R,EPS,MXF,F) finds zero of REAL*4 function
    DCB    "rzero_",0,0,8,0,0,255
rzero_
    MOV    ip,sp
    STMDB  sp!,{R0-R9,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDMIB  fp,{R4-R6}   ;addresses of EPS, MXF and F
    STFE   F4,[sp,#-12]!;save F4
    STFE   F5,[sp,#-12]!;save F5
    STFE   F6,[sp,#-12]!;save F6
    STFE   F7,[sp,#-12]!;save F7
    SUB    sp,sp,#lstk  ;work space
    LDFS   F0,[R0]      ;A
    LDFS   F1,[R1]      ;B
    LDR    R5,[R5]      ;MXF
    MOV    R8,R2        ;(X0)
    MOV    R9,R3        ;(R)
    CMF    F0,F1
    STFGTS F1,XA        ;XA = MIN(A,B)
    STFLES F0,XA
    STFGTS F0,XB        ;XB = MAX(A,B)
    STFLES F1,XB
    ADR    R0,XA
    ADR    R1,ONE
    BL     fun
    STFS   F0,VA        ;FA = F(XA,1)
    ADR    R0,XB
    ADR    R1,TWO
    BL     fun
    STFS   F0,VB        ;FB = F(XB,1)
    LDFS   F1,VA
    FMLS   F2,F0,F1
    CMF    F2,#0
    BGT    er1          ;FA & FB have same sign and neither are zero
;
pt1 LDFS   F6,XA        ;X1 = XA
    LDFS   F7,XB        ;X2 = XB
    LDFS   F2,[R4]      ;EPS
    ADFS   F1,F6,F7
    FMLS   F5,F1,#0.5   ;X0 = 0.5*(XA+XB)
    SUFS   F0,F5,F6     ;R = X0 - XA
    ABSS   F3,F5
    ADFS   F3,F3,#1     ;ABS(X0)+1
    FMLS   F4,F3,F2     ;EE = EPS*(ABS(X0)+1)
    CMF    F0,F4
    BLE    pt4          ;all done if R is sufficiently small
    LDMIA  sp,{R0,R1}
    STR    R0,V1        ;F1 = FA
    STR    R1,V2        ;F2 = FB
;
pt2 STFS   F5,[R8]
    MOV    R0,R8
    ADR    R1,TWO
    BL     fun
    STFS   F0,VX        ;FX = F(X0,2)
    SUBS   R5,R5,#1
    BLT    er2          ;too many function calls
    LDMIA  sp,{R0-R2}   ;FA,FB,FX
    EORS   ip,R0,R2     ;IF(FA*FX.GT.0) THEN
    STFPLS F0,VA        ;  FA = FX
    STFPLS F5,XA        ;  XA = X0
    STFMIS F0,VB        ;ELSE
    STFMIS F5,XB        ;  FB = FX; XB = X0
;
pt3 SUFS   F2,F6,F7     ;U2 = X1 - X2
    CMF    F2,#0
    SUFNES F4,F7,F5     ;U4 = X2 - X0
    CMFNE  F4,#0
    BEQ    pt1          ;skip if at the end
    LDFS   F0,V2
    LDFS   F1,V1
    LDFS   F3,VX
    SUFS   F1,F1,F0     ;U1 = F1 - F2
    STFS   F3,V3        ;F3 = FX
    SUFS   F3,F0,F3     ;U3 = F2 - FX
    STFS   F5,X3        ;X3 = X0
    FDVS   F1,F1,F2     ;U1 = U1/U2
    FDVS   F2,F3,F4     ;U2 = U3/U4
    SUFS   F0,F1,F2     ;CA = U1 - U2
    ADFS   F3,F6,F7
    ADFS   F4,F5,F7
    FMLS   F1,F1,F4     ;U1*(X0+X2)
    FMLS   F2,F2,F3     ;U2*(X1+X2)
    SUFS   F4,F6,F5     ;(X1-X0)
    SUFS   F1,F2,F1     ;CB = U2*(X1+X2) - U1*(X0+X2)
    FMLS   F3,F6,F0     ;X1*CA
    LDFS   F2,V1
    ADFS   F3,F3,F1     ;X1*CA + CB
    FMLS   F2,F2,F4     ;F1*(X1-X0)
    FMLS   F3,F3,F6     ;X1*(X1*CA + CB)
    CMF    F0,#0
    SUFS   F2,F2,F3     ;CC = F1*(X1-X0) - X1*(X1*CA + CB)
    CMFEQ  F1,#0
    BEQ    pt1
    CMF    F0,#0
    FDVEQS F5,F2,F1
    MVFEQS F5,F5        ;IF CA.EQ.0 X0 = -CC/CB
    BEQ    ptx
    FDVS   F3,F1,F0
    FDVS   F2,F2,F0
    FMLS   F3,F3,#0.5   ;U3 = 0.5*CB/CA
    FMLS   F4,F3,F3
    SUFS   F4,F4,F2     ;U4 = U3*U3 - CC/CA
    CMF    F4,#0
    BLT    pt1          ;imaginary solution
    SQTS   F4,F4
    CNFE   F5,F3
    MNFLTS F4,F4
    SUFS   F5,F4,F3     ;X0 = -U3 +- SQRT(U3**2 -CC/CA)
ptx LDFS   F0,XA
    LDFS   F1,XB
    CMF    F5,F0
    CMFGE  F1,F5
    BLT    pt1          ;skip if X0 < XA or > XB
;
    LDFS   F3,X3
    LDFS   F2,[R4]      ;EPS
    ABSS   F4,F5
    SUFS   F0,F5,F3     ;X0-X3
    SUFS   F1,F5,F7     ;X0-X2
    ADFS   F4,F4,#1     ;ABS(X0)+1
    ABSS   F0,F0
    ABSS   F1,F1
    FMLS   F4,F4,F2     ;EE = EPS*(ABS(X0)+1)
    CMF    F0,F1
    MVFGTS F0,F1        ;R = MIN(ABS(X0-X3), ABS(X0-X2))
    CMF    F0,F4        ;IF(R.GT.EE) THEN
    MVFGTS F6,F7        ;  X1 = X2
    MVFGTS F7,F3        ;  X2 = X3
    ADRGT  ip,V1        ;  (F1)
    LDMGTIB ip,{R0,R1}
    STMGTIA ip,{R0,R1}  ;  F1=F2 & F2=F3
    BGT    pt2          ;take another step
    STFS   F5,[R8]      ;store X0
    MOV    R0,R8
    ADR    R1,TWO
    BL     fun          ;CALL F(X0,2)
    STFS   F0,VX        ;store FX
    LDMIA  sp,{R0,R1,R7};FA,FB,FX
    CMP    R7,#0
    BEQ    pt4          ;all done with exact answer
    EORS   R0,R0,R7     ;IF(FX*FA.LT.0) THEN
    BPL    pty
    LDFS   F1,XA
    SUFS   F0,F5,F4     ;  XX = X0 - EE
    CMF    F0,F1
    BLE    pt4          ;  all done if XX <= XA
    STFS   F0,XB        ;  XB = XX
    BL     fun2
    STFS   F0,VB        ;  FB = FF = F(XX,2)
    B      ptz          ;ELSE
pty LDFS   F1,XB
    ADFS   F0,F5,F4     ;  XX = X0 + EE
    CMF    F0,F1
    BGE    pt4          ;  all done if XX >= XB
    STFS   F0,XA        ;  XA = XX
    BL     fun2
    STFS   F0,VA        ;  FA = FF = F(XX,2)
ptz LDFS   F1,VX
    FMLS   F2,F0,F1
    CMF    F2,#0
    BLE    pt4          ;zero spanned so done
    SUBS   R5,R5,#2     ;count calls to F
    BLT    er2          ;too many calls
    LDR    R0,V3
    STR    R0,V1        ;F1 = F3
    LDFS   F6,X3        ;X1 = X3
    STR    R7,V2        ;F2 = FX
    MVFS   F7,F5        ;X2 = X0
    LDFS   F5,XX        ;X0 = XX
    STFS   F0,VX        ;FX = FF
    B      pt3          ;do next step
;
pt4 STFS   F4,[R9]      ;store R(=EE)
    STFS   F5,[R8]      ;store X0
    MOV    R0,R8
    ADR    R1,THR
    BL     fun          ;CALL F(X0,3)
fin LDFE   F7,[fp,#-100];restore F7
    LDFE   F6,[fp,#-88] ;restore F6
    LDFE   F5,[fp,#-76] ;restore F5
    LDFE   F4,[fp,#-64] ;restore F4
    LDMDB  fp,{R4-R9,fp,sp,pc} ;return
;
er1 MNFS   F4,#2        ;-2.0
erx LDFS   F0,XA
    LDFS   F1,XB
    SUFS   F0,F0,F1
    ABSS   F0,F0        ;|XA-XB|
    FMLS   F0,F0,F4
    STFS   F0,[R9]      ;store R = -(2 or 0.5)*|XA-XB|
    MOV    R0,#0
    STR    R0,[R8]      ;store X0=0
    B      fin
;
er2 MNFS   F4,#0.5      ;-0.5
    B      erx
;
fun2;   find F(XX,2)
    STFS   F0,XX
    ADR    R0,XX
    ADR    R1,TWO
fun MOV    pc,R6        ;call F
;
ONE DCD    1
TWO DCD    2
THR DCD    3
;
    ^      0,sp         ;do not change the order of these, just add to them
VA    #    4            ;FA
VB    #    4            ;FB
VX    #    4            ;FX
V1    #    4            ;F1
V2    #    4            ;F2
V3    #    4            ;F3
X3    #    4            ;X3
XA    #    4            ;XA
XB    #    4            ;XB
XX    #    4            ;XX
lstc  #    0
;
lstk  EQU  lstc-VA
    END
;
    TTL    SBIT
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT sbit_;(IA,IX,J) sets bit J in IX to IA (l.s. bit is 1)
    DCB    "sbit_",0,0,0,8,0,0,255
sbit_
    MOV    ip,sp
    STMDB  sp!,{R0-R2,fp,ip,lr,pc}
    SUB    fp,ip,#4
    MOV    ip,R1       ;store ans in IX
    B      ws1
;
    EXPORT msbit_;(IA,IX,J) returns IX with bit J set to IA (l.s. bit is 1)
    DCB    "msbit_",0,0,8,0,0,255
msbit_
    MOV    ip,sp
    STMDB  sp!,{R0-R2,fp,ip,lr,pc}
    SUB    fp,ip,#4
    MOV    ip,#0
ws1 LDR    R3,[R0]     ;IA
    LDR    R0,[R1]     ;IX
    LDR    R2,[R2]     ;J
    MOV    R1,#1       ;mask bit
    AND    R3,R3,#1    ;get 1st bit of ia
    SUBS   R2,R2,#1    ;J-1
    BICGE  R0,R0,R1,LSL R2 ;mask bit
    ORRGE  R0,R0,R3,LSL R2 ;insert bit into ix
    CMP    ip,#0       ;if 'SBIT' then
    STRGT  R0,[ip]     ;store answer
    LDMDB  fp,{fp,sp,pc} ;return
    END
;
    TTL    SBIT0
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R2  RN     2
R1  RN     1
R0  RN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT sbit0_;(IX,J)  sets bit J in IX to 0 (l.s. bit is 1)
    DCB    "sbit0_",0,0,8,0,0,255
sbit0_
    MOV    ip,sp
    STMDB  sp!,{R0-R1,fp,ip,lr,pc}
    SUB    fp,ip,#4
    MOV    ip,R0       ;store ans in IX
    B      ws2
;
    EXPORT msbit0_;(IX,J) returns IX with bit J set to 0 (l.s. bit is 1)
    DCB    "msbit0_",0,8,0,0,255
msbit0_
    MOV    ip,sp
    STMDB  sp!,{R0-R1,fp,ip,lr,pc}
    SUB    fp,ip,#4
    MOV    ip,#0
ws2 LDR    R0,[R0]     ;IX
    LDR    R1,[R1]     ;J
    MOV    R2,#1       ;mask bit
    SUBS   R1,R1,#1    ;J-1
    BICGE  R0,R0,R2,LSL R1 ;clear bit
    CMP    ip,#0       ;if 'SBIT0' then
    STRGT  R0,[ip]     ;store new ix
    LDMDB  fp,{fp,sp,pc} ;return
    END
;
    TTL    SBIT1
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R2  RN     2
R1  RN     1
R0  RN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT sbit1_;(IX,J) sets bit J in IX to 1 (l.s. bit is 1)
    DCB    "sbit1_",0,0,8,0,0,255
sbit1_
    MOV    ip,sp
    STMDB  sp!,{R0-R1,fp,ip,lr,pc}
    SUB    fp,ip,#4
    MOV    ip,R0       ;store ans in IX
    B      ws3
;
    EXPORT msbit1_;(IX,J) returns IX with bit J set to 1 (l.s. bit is 1)
    DCB    "msbit1_",0,8,0,0,255
msbit1_
    MOV    ip,sp
    STMDB  sp!,{R0-R1,fp,ip,lr,pc}
    SUB    fp,ip,#4
    MOV    ip,#0
ws3 LDR    R0,[R0]     ;IX
    LDR    R1,[R1]     ;J
    MOV    R2,#1       ;mask bit
    SUBS   R1,R1,#1    ;J-1
    ORRGE  R0,R0,R2,LSL R1 ;set bit
    CMP    ip,#0       ;if 'SBIT1' then
    STRGT  R0,[ip]     ;store new ix
    LDMDB  fp,{fp,sp,pc} ;return
    END
;
    TTL    SBYT
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT sbyt_;(IA,IX,J,NBITS) sets NBITS in IX starting at J to IA (l.s is bi
    DCB    "sbyt_",0,0,0,8,0,0,255
sbyt_
    MOV    ip,sp
    STMDB  sp!,{R0-R3,fp,ip,lr,pc}
    SUB    fp,ip,#4
    MOV    ip,R1       ;store ans in IX
    B      ws4
;
    EXPORT msbyt_;(IA,IX,J,NBITS) returns IX with NBITS at J set to IA (l.s is b
    DCB    "msbyt_",0,0,8,0,0,255
msbyt_
    MOV    ip,sp
    STMDB  sp!,{R0-R3,fp,ip,lr,pc}
    SUB    fp,ip,#4
    MOV    ip,#0
ws4 LDR    lr,[R0]     ;IA
    LDR    R0,[R1]     ;IX
    LDR    R2,[R2]     ;J
    LDR    R3,[R3]     ;NBITS
    MOV    R1,#-1
    BIC    R1,R1,R1,LSL R3;mask
    AND    lr,lr,R1    ;get byt of IA
    SUBS   R2,R2,#1    ;J-1
    BICGE  R0,R0,R1,LSL R2 ;mask byt
    ORRGE  R0,R0,lr,LSL R2 ;insert byt
    CMP    ip,#0       ;if 'SBYT' then
    STRGT  R0,[ip]     ;store answer
    LDMDB  fp,{fp,sp,pc} ;return
    END
;
    TTL    SBYTOR
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT sbytor_;(IA,IX,J,NBITS) ORs IA into byte J of IX
    DCB    "sbytor_",0,8,0,0,255
sbytor_
    MOV    ip,sp
    STMDB  sp!,{R0-R3,fp,ip,lr,pc}
    SUB    fp,ip,#4
    MOV    ip,R1      ;address of IX
    B      ws6
;
    EXPORT mbytor_;(IA,IW,J,NBITS) => IW OR IA shifted to byte at J
    DCB    "mbytor_",0,8,0,0,255
mbytor_
    MOV    ip,sp
    STMDB  sp!,{R0-R3,fp,ip,lr,pc}
    SUB    fp,ip,#4
    MOV    ip,#0
ws6 LDR    lr,[R0]     ;IA
    LDR    R0,[R1]     ;IW
    LDR    R2,[R2]     ;J
    LDR    R3,[R3]     ;NBITS
    MOV    R1,#-1
    BIC    lr,lr,R1,LSL R3;byte of IA
    SUBS   R2,R2,#1    ;J-1
    ORRGE  R0,R0,lr,LSL R2
    CMP    ip,#0       ;if 'SBYTOR' then
    STRGT  R0,[ip]     ;store answer
    LDMDB  fp,{fp,sp,pc} ;return
    END
;
    TTL    SBYTPK
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT sbytpk_;(IT,MX,JX,MPACK) stores IT into byte JX of packed vector MX
    DCB    "sbytpk_",0,8,0,0,255
sbytpk_
    MOV    ip,sp
    STMDB  sp!,{R0-R3,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R2,[R2]    ;jx
    SUB    R2,R2,#1   ;jx-1
    LDMIA  R3,{R3,ip} ;get nbits,inword
    CMP    R3,#0      ;check for default
    MOVLE  R3,#1      ;default nbits=1
    MOVLE  ip,#32     ;and inword=32
ws1 SUBS   R2,R2,ip
    ADDGE  R1,R1,#4
    BGE    ws1        ;move to word
    ADD    R2,R2,ip
    MUL    R2,R3,R2   ;pointer to byte
    MOV    ip,#-1
    BIC    ip,ip,ip,LSL R3 ;mask
    LDR    R0,[R0]
    AND    R0,R0,ip   ;get byt
    LDR    R3,[R1]    ;load word
    BIC    R3,R3,ip,LSL R2;clear byt
    ORR    R3,R3,R0,LSL R2;insert byt
    STR    R3,[R1]    ;restore word
    LDMDB  fp,{fp,sp,pc} ;return
    END
;
    TTL    scatter
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT scatter_;(NW,A,INDX,B) A(INDX(I)) = B(I), I=1,NW
    DCB    "scatter_",0,0,0,0,12,0,0,255
scatter_
    MOV    ip,sp
    STMDB  sp!,{R0-R3,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R0,[R0]     ;NW
    SUB    R1,R1,#4    ;(A(0))
lp1 SUBS   R0,R0,#1
    LDRGE  ip,[R2,R0,LSL#2] ;INDX(I)
    LDRGE  lr,[R3,R0,LSL#2] ;B(I)
    STRGE  lr,[R1,ip,LSL#2] ;-> A(INDX(I))
    BGT    lp1
    LDMDB  fp,{fp,sp,pc} 
    END
;
    TTL    SETBIT
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT setbit_;(I,M,L) sets value of a bit in a bit string
    DCB    "setbit_",0,8,0,0,255
setbit_
    MOV    ip,sp
    STMDB  sp!,{R0-R2,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R0,[R0]     ;get i
    SUBS   R0,R0,#1
    MOVGE  ip,R0,LSR#5 ;get word #
    LDRGE  R3,[R1,ip,LSL#2]!;get word
    ANDGE  R0,R0,#31   ;bit #
    LDRGE  R2,[R2]     ;get l
    MOVGE  R2,R2,LSL#31;move to ms bit
    MOVGE  ip,#&80000000;bit mask
    BICGE  R3,R3,ip,LSR R0;clear bit
    ORRGE  R3,R3,R2,LSR R0;set bit
    STRGE  R3,[R1]     ;store word
    LDMDB  fp,{fp,sp,pc} ;return
    END
;
    TTL    SETBYT
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT setbyt_;(ADDR,IBEG,ILEN,IBYT) sets byte in bit string
    DCB    "setbyt_",0,8,0,0,255
setbyt_
    MOV    ip,sp
    STMDB  sp!,{R0-R3,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R1,[R1]     ;get ibeg
    LDR    R2,[R2]     ;get ilen
    SUBS   R1,R1,#1
    CMPGES R2,#1
    LDMLTDB fp,{fp,sp,pc} ;return if IBEG or ILEN<=0
    MOV    ip,R1,LSR#5 ;word #
    AND    R1,R1,#31   ;bit #
    LDR    R3,[R3]     ;get ibyt
    RSB    R2,R2,#32   ;# bits not used
    MOV    lr,#-1
    MOV    lr,lr,LSL R2;mask left-shifted
    MOV    R3,R3,LSL R2;ibyt l.s.
    LDR    ip,[R0,ip,LSL#2]!;get 1st word
    BIC    ip,ip,lr,LSR R1;mask out bits
    ORR    ip,ip,R3,LSR R1;insert bits
    STR    ip,[R0]     ;store 1st word
    CMP    R1,R2       ;bits in next word?
    LDRGT  ip,[R0,#4]! ;yes, get next word
    RSBGT  R1,R1,#32   ;calculate shift
    BICGT  ip,ip,lr,LSL R1;mask out bits
    ORRGT  ip,ip,R3,LSL R1;insert bits
    STRGT  ip,[R0]     ;store 2nd word
    LDMDB  fp,{fp,sp,pc} ;return
    END
;
    TTL   SORCHA
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   Utils_,CODE,READONLY
    EXPORT sorcha_;(A,ICH1,ICH2,N,ITYP) sorts CHARACTER array A of N elements
    DCB    "sorcha_",0,8,0,0,255
sorcha_
;      using characters ICH1 to ICH2.
;      result is ascending if ITYP is odd, descending if even
    MOV    ip,sp
    STMDB  sp!,{R0-R9,fp,ip,lr,pc}
    SUB    fp,ip,#4
;       initialise variables
    LDR    R9,[fp,#8]       ;LEN (length of element)
    LDR    R8,[R2]          ;ICH2
    LDR    R7,[R1]          ;ICH1
    SUBS   R7,R7,#1         ;offset of ICH1
    SUBGES R8,R8,R7         ;length of range
    LDMLEDB fp,{R4-R9,fp,sp,pc} ; return if ICH1<1 or ICH2<ICH1
    ADD    R7,R7,R0         ;location of A(1)(ICH1:ICH1)
    LDR    R3,[R3]          ;N
    SUB    R3,R3,#1         ;R=N-1
    MOV    R1,#0            ;L=0
    MOV    R5,sp            ;pointer to top of stack
;           main loop over sections
wl1 CMP    R3,R1            ;check if range to sort is bigger than 1
    CMPLE  R5,sp            ;or that there are more ranges to sort
    BLE    fin              ;all done, go check for descending sort
    CMP    R3,R1            ;check if range to sort is bigger than 1
    LDMLEFD sp!,{R1,R3}      ;retrieve new L,R from stack
    MOV    R2,R1            ;I=L
    MOV    R4,R3            ;J=R
    ADD    R6,R3,R1
    MOV    R6,R6,LSR#1      ;M=(L+R)/2
wl2 MOV    ip,R2
    BL     comp             ;compare A(I) with A(M)
    ADDLT  R2,R2,#1         ;I=I+1
    BLT    wl2
wl3 MOV    ip,R4
    BL     comp             ;compare A(J) with A(M)
    SUBGT  R4,R4,#1         ;J=J-1
    BGT    wl3
    CMP    R2,R4
    BGT    SA1
    BL     swop             ;exchange A(I) with A(J); I=I+1; J=J-1
    CMP    R2,R4
    B      wl2
;
SA1 SUB    ip,R3,R2         ;R-I
    SUB    R6,R4,R1         ;J-L
    CMP    ip,R6
    STMLTFD sp!,{R1,R4}      ;store L,J on stack
    MOVLT  R1,R2            ;L=I
    CMPGE  ip,#0
    STMGTFD sp!,{R2,R3}      ;or store I,R on stack
    MOVGE  R3,R4            ;and set R=J
    B      wl1
;
comp;    compare entry 'ip' with entry 'R6' (ip can be destroyed)
    STMFD  sp!,{R1-R2,R8,lr}
    MLA    R1,ip,R9,R7      ;address of entry 'ip'
    MLA    R2,R6,R9,R7      ;address of entry 'R6'
lc1 LDRB   ip,[R1],#1       ;character from 'ip'
    LDRB   lr,[R2],#1       ;character from 'R6'
    CMP    ip,lr
    LDMNEFD sp!,{R1-R2,R8,pc};return with sign of comparison
    SUBS   R8,R8,#1
    BNE    lc1
    LDMFD  sp!,{R1-R2,R8,pc};return EQ
;
swop;    exchange entries R2 and R4; increment R2, decrement R4 (ip free)
    STMFD  sp!,{R1,R3,R9,lr}
    MLA    R1,R2,R9,R0
    MLA    R3,R4,R9,R0
ls1 LDRB   ip,[R1]
    LDRB   lr,[R3]
    STRB   ip,[R3],#1
    STRB   lr,[R1],#1
    SUBS   R9,R9,#1
    BGT    ls1
    CMP    R6,R2
    CMPNE  R6,R4            ; if R6 is one of the entries being swapped
    SUBEQ  R6,R2,R6
    ADDEQ  R6,R6,R4         ; then swap R6 as well: R6 = (R2+R4)-R6
    ADD    R2,R2,#1         ;increment R2
    SUB    R4,R4,#1         ;decrement R4
    LDMFD  sp!,{R1,R3,R9,pc} 
;
fin;      all done, check for descending sort
    LDR    ip,[fp,#4]        ;address of ITYP
    LDR    ip,[ip]
    TST    ip,#1
    LDMNEDB fp,{R4-R9,fp,sp,pc} ; return if finished
;         swap the whole range
    MOV    R2,#0
    LDR    R3,[sp,#12]      ;restore pointer to N
    LDR    R4,[R3]
    SUBS   R4,R4,#1         ;N-1
lf1 BLGT   swop
    CMP    R4,R2
    BGT    lf1
    LDMDB  fp,{R4-R9,fp,sp,pc} ; return if finished
    END
;
    TTL   sortd
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
R4  RN     4
R5  RN     5
R6  RN     6
R7  RN     7
R8  RN     8
R9  RN     9
;
    AREA   |C$$code|,CODE,READONLY
    EXPORT sortd_;(MX,NC,NR,NCS) sort rows of a marix of real*4
    DCB    "sortd_",0,0,8,0,0,255
sortd_
    MOV    ip,sp
    STMDB  sp!,{R0-R9,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R4,[R1]         ;NC
    LDR    R5,[R2]         ;NR
    LDR    R6,[R3]         ;NCS
    MOVS   R7,R6,ASR#31    ;get sort direction
    RSBMI  R6,R6,#0        ;|NCS|
    CMP    R5,#2           ;check for more than 1 row
    CMPGE  R6,#1           ;and that NCS >= 1
    CMPGE  R4,R6           ;and that NC >= NCS
    LDMLTDB fp,{R4-R9,fp,sp,pc} ;otherwise return
    MOV    R6,R6,LSL#3     ;8*R6
    SUB    R0,R0,#8        ;pointer to beginning of 1st row
    MUL    ip,R4,R5
    ADD    R1,R0,ip,LSL#3  ;pointer to end of matrix
lp1 ADD    R5,R0,R4,LSL#3  ;initialise K=J+1
    CMP    R5,R1           ;check if finished
    LDMGEDB fp,{R4-R9,fp,sp,pc} ;return
    MOV    R2,R0           ;LMIN (LMAX)
    ADD    R8,R6,#4        ;pointer to l.s. half word
    LDR    R3,[R0,R6]      ;HMIN(m.s.)
    MVNS   ip,R3           ;test if negative
    ORRPL  R3,ip,#&8,4     ;correct if negative
    EOR    R3,R3,R7        ;correct for sign of sort
    LDR    R9,[R0,R8]      ;HMIN(l.s.)
    MVNPL  R9,R9           ;correct if negative
    EOR    R9,R9,R7        ;correct for sign of sort
lp2 LDR    ip,[R5,R6]      ;A(NCS,K) (m.s.)
    MVNS   lr,ip           ;test if negative
    ORRPL  ip,lr,#&8,4     ;correct if negative
    EOR    ip,ip,R7        ;correct for sign of sort
    LDR    lr,[R5,R8]      ;A(NCS,K) (l.s.)
    MVNPL  lr,lr           ;test if negative
    EOR    lr,lr,R7        ;correct for sign of sort
    CMP    R3,ip           ;compare m.s. part
    CMPEQ  R9,lr           ;if equal, compare l.s. part
    MOVGT  R3,ip           ;new HMIN
    MOVGT  R9,lr
    MOVGT  R2,R5           ;new LMIN
    ADD    R5,R5,R4,LSL#3
    CMP    R5,R1
    BLT    lp2
    CMP    R2,R0
    BEQ    pt2             ;this row is the lowest
    MOV    R5,R2           ;L=LMIN
lp3 LDR    lr,[R5,R6]      ;A(NCS,L) (m.s.)
    LDR    ip,[R0,R6]      ;A(NCS,J) (m.s.)
    CMP    lr,ip
    ADDEQ  R8,R6,#4
    LDREQ  lr,[R5,R8]      ;A(NCS,L) (l.s.)
    LDREQ  ip,[R0,R8]      ;A(NCS,J) (l.s.)
    CMPEQ  lr,ip
    BNE    pt1             ;don't swap these rows
;        swop rows LMIN (R2) and L (R5)
    MOV    R3,R4           ;column count
    ADD    R2,R2,#8
    ADD    R5,R5,#8
lp4 LDMIA  R2,{R8,R9}
    LDMIA  R5,{ip,lr}
    STMIA  R5!,{R8,R9}
    STMIA  R2!,{ip,lr}
    SUBS   R3,R3,#1
    BGT    lp4
    SUB    R5,R5,#8
    SUB    R5,R5,R4,LSL#3  ;restore corrupted L
    MOV    R2,R5           ;LMIN = L
pt1 SUB    R5,R5,R4,LSL#3
    CMP    R5,R0
    BGE    lp3
pt2 ADD    R0,R0,R4,LSL#3
    B      lp1
    END
;
    TTL   sorti
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
R4  RN     4
R5  RN     5
R6  RN     6
R7  RN     7
R8  RN     8
;
    AREA   |C$$code|,CODE,READONLY
    EXPORT sorti_;(MX,NC,NR,NCS) sort rows of a marix of integers
    DCB    "sorti_",0,0,8,0,0,255
sorti_
    MOV    ip,sp
    STMDB  sp!,{R0-R8,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R4,[R1]         ;NC
    LDR    R5,[R2]         ;NR
    LDR    R6,[R3]         ;NCS
    MOVS   R7,R6,ASR#31    ;get sort direction
    RSBMI  R6,R6,#0        ;|NCS|
    CMP    R5,#2           ;check for more than 1 row
    CMPGE  R6,#1           ;and that NCS >= 1
    CMPGE  R4,R6           ;and that NC >= NCS
    LDMLTDB fp,{R4-R8,fp,sp,pc} ;otherwise return
    SUB    R0,R0,#4        ;pointer to beginning of 1st row
    MUL    ip,R4,R5
    ADD    R1,R0,ip,LSL#2  ;pointer to end of matrix
lp1 ADD    R5,R0,R4,LSL#2  ;initialise K=J+1
    CMP    R5,R1           ;check if finished
    LDMGEDB fp,{R4-R8,fp,sp,pc} ;return
    MOV    R2,R0           ;LMIN (LMAX) = J
    LDR    R3,[R0,R6,LSL#2];HMIN
    EOR    R3,R3,R7        ;correct for sign of sort
lp2 LDR    lr,[R5,R6,LSL#2];A(NCS,K)
    EOR    lr,lr,R7        ;correct for sign of sort
    CMP    R3,lr
    MOVGT  R3,lr           ;new HMIN
    MOVGT  R2,R5           ;new LMIN
    ADD    R5,R5,R4,LSL#2
    CMP    R5,R1
    BLT    lp2
    CMP    R2,R0
    BEQ    pt2             ;this row is the lowest
    LDR    R3,[R0,R6,LSL#2];A(NCS,J)
    MOV    R5,R2           ;L=LMIN
lp3 LDR    lr,[R5,R6,LSL#2];A(NCS,L)
    CMP    lr,R3
    BNE    pt1             ;don't swap these rows
;        swop rows LMIN (R2) and L (R5)
    MOV    R8,R4           ;column count
lp4 LDR    ip,[R2,R8,LSL#2]
    LDR    lr,[R5,R8,LSL#2]
    STR    ip,[R5,R8,LSL#2]
    STR    lr,[R2,R8,LSL#2]
    SUBS   R8,R8,#1
    BGT    lp4
    MOV    R2,R5           ;LMIN = L
pt1 SUB    R5,R5,R4,LSL#2
    CMP    R5,R0
    BGE    lp3
pt2 ADD    R0,R0,R4,LSL#2
    B      lp1
    END
;
    TTL   sortr
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
R4  RN     4
R5  RN     5
R6  RN     6
R7  RN     7
R8  RN     8
;
    AREA   |C$$code|,CODE,READONLY
    EXPORT sortr_;(MX,NC,NR,NCS) sort rows of a marix of real*4
    DCB    "sortr_",0,0,8,0,0,255
sortr_
    MOV    ip,sp
    STMDB  sp!,{R0-R8,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R4,[R1]         ;NC
    LDR    R5,[R2]         ;NR
    LDR    R6,[R3]         ;NCS
    MOVS   R7,R6,ASR#31    ;get sort direction
    RSBMI  R6,R6,#0        ;|NCS|
    CMP    R5,#2           ;check for more than 1 row
    CMPGE  R6,#1           ;and that NCS >= 1
    CMPGE  R4,R6           ;and that NC >= NCS
    LDMLTDB fp,{R4-R8,fp,sp,pc} ;otherwise return
    SUB    R0,R0,#4        ;pointer to beginning of 1st row
    MUL    ip,R4,R5
    ADD    R1,R0,ip,LSL#2  ;pointer to end of matrix
lp1 ADD    R5,R0,R4,LSL#2  ;initialise K=J+1
    CMP    R5,R1           ;check if finished
    LDMGEDB fp,{R4-R8,fp,sp,pc} ;return
    MOV    R2,R0           ;LMIN (LMAX)
    LDR    R3,[R0,R6,LSL#2];HMIN
    MVNS   ip,R3           ;test if negative
    ORRPL  R3,ip,#&8,4     ;correct if negative
    EOR    R3,R3,R7        ;correct for sign of sort
lp2 LDR    lr,[R5,R6,LSL#2];A(NCS,K)
    MVNS   ip,lr           ;test if negative
    ORRPL  lr,ip,#&8,4     ;correct if negative
    EOR    lr,lr,R7        ;correct for sign of sort
    CMP    R3,lr
    MOVGT  R3,lr           ;new HMIN
    MOVGT  R2,R5           ;new LMIN
    ADD    R5,R5,R4,LSL#2
    CMP    R5,R1
    BLT    lp2
    CMP    R2,R0
    BEQ    pt2             ;this row is the lowest
    LDR    R3,[R0,R6,LSL#2];A(NCS,J)
    MOV    R5,R2           ;L=LMIN
lp3 LDR    lr,[R5,R6,LSL#2];A(NCS,L)
    CMP    lr,R3
    BNE    pt1             ;don't swap these rows
;        swop rows LMIN (R2) and L (R5)
    MOV    R8,R4           ;column count
lp4 LDR    ip,[R2,R8,LSL#2]
    LDR    lr,[R5,R8,LSL#2]
    STR    ip,[R5,R8,LSL#2]
    STR    lr,[R2,R8,LSL#2]
    SUBS   R8,R8,#1
    BGT    lp4
    MOV    R2,R5           ;LMIN = L
pt1 SUB    R5,R5,R4,LSL#2
    CMP    R5,R0
    BGE    lp3
pt2 ADD    R0,R0,R4,LSL#2
    B      lp1
    END
;
    TTL    SORTZV
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
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 sortzv_;(A,INDEX,N,MODE,NWAY,NSORT) sorts 1-d array of any type
    IMPORT qsortr_
    IMPORT qsorti_
    DCB    "sortzv_",0,8,0,0,255
sortzv_
    MOV    ip,sp
    STMDB  sp!,{R0-R7,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    ip,[fp,#8]  ;address of NSORT
    LDR    ip,[ip]     ;NSORT
    CMP    ip,#0
    BNE    pt2
    LDR    lr,[R2]     ;N
    SUB    ip,R1,#4    ;(INDEX(0))
pt1 STR    lr,[ip,lr,LSL#2];set up INDEX(I) = I
    SUBS   lr,lr,#1
    BGT    pt1
pt2 LDR    R3,[R3]     ;MODE
    CMP    R3,#0
    BEQ    SV1
    BLT    SV2
    BL     qsortr_     ;sort real*4
    B      SV3
SV1 BL     swop        ;swap bytes for Hollerith
    BL     qsorti_     ;sort integers & Hollerith
    LDMFD  sp!,{R0-R3} ;restore addresses
    BL     swop        ;swap back bytes for Hollerith
    B      SV4
SV2 BL     qsorti_
SV3 LDMFD  sp!,{R0-R3} ;restore addresses
SV4 LDR    R4,[fp,#4]  ;(NWAY)
    LDR    R4,[R4]     ;NWAY
    CMP    R4,#0
    LDMEQDB fp,{R4-R7,fp,sp,pc} ;return if NWAY is zero
    LDR    R5,[R2]     ;N
    ADD    R5,R1,R5,LSL#2;(INDEX(N+1))
pt3 LDR    lr,[R5,#-4]!
    LDR    ip,[R1]
    STR    ip,[R5]
    STR    lr,[R1],#4  ;invert order
    CMP    R5,R1
    BGT    pt3
    LDMDB  fp,{R4-R7,fp,sp,pc} ;return
swop;  bytes 1<->4 and 2<->3
    LDR    R5,[R2]          ;N
    SUB    R6,R0,#4         ;(A(0))
    MOV    R7,#255
    ORR    R7,R7,#255,8     ;mask for bytes 1 and 4
pt4 SUBS   R5,R5,#1
    LDRGE  ip,[R1,R5,LSL#2] ;pointer to word
    LDRGE  R3,[R6,ip,LSL#2]
    MOVGE  R4,R3,LSL#24     ;1->4', 0->1',2',3'
    ORRGE  R4,R4,R3,LSR#24  ;4->1'
    ANDGE  R3,R7,R3,ROR#16  ;2->4, 3->1
    ORRGE  R4,R4,R3,LSR#8   ;4->3'
    ORRGE  R4,R4,R3,LSL#8   ;1->2'
    STRGE  R4,[R6,ip,LSL#2] ;store inverted word
    BGT    pt4
    MOV    pc,lr
    END
;
    TTL    SPACES
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
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 spaces_;(STR,NS) ==> STR with blank spaces padded with N blanks
    DCB    "spaces_",0,8,0,0,255
spaces_
    MOV    ip,sp
    STMDB  sp!,{R0-R6,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    ip,[fp,#4]  ;length of STR
    LDR    R4,[R3]     ;ns
    MOV    R3,#0       ;#blanks to insert initially
    MOV    R5,R3
    MOV    lr,#" "
ws1 SUBS   ip,ip,#1
    MOVLT  R5,R1       ;end of STRING
    LDRGEB R6,[R2],#1  ;get next character from str
    CMPGE  R6,#" "
    MOVEQ  R5,R3       ;prepare to insert ns blanks
    BEQ    ws1         ;look for non-blank
    MOV    R3,R4       ;ns blanks next time
ws2 SUBS   R5,R5,#1
    STRGEB lr,[R0],#1  ;insert blanks
    SUBGES R1,R1,#1
    BGT    ws2         ;loop over blanks to fill
    STRLTB R6,[R0],#1  ;store char in answer
    SUBLTS R1,R1,#1
    BGT    ws1
    LDMDB  fp,{R4-R6,fp,sp,pc} ;return
    END
;
    TTL    STRIP
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R5  RN     5
R4  RN     4
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT strip_;(STR,CHOPT,CHD) ==> STR with leading/trailing CHD removed
    DCB    "strip_",0,0,8,0,0,255
strip_
    MOV    ip,sp
    STMDB  sp!,{R0-R5,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDMIB  fp,{R4,R5}  ;(CHD),LEN(STR)
    LDRB   R4,[R4]     ;CHD
    LDRB   R3,[R3]     ;CHOPT
    CMP    R3,#"T"     ;check if only trailing
    MOVEQ  ip,R2       ;where to start
    BEQ    ws2
;        remove leading CHD
    SUB    ip,R2,#1
ws1 SUBS   R5,R5,#1
    LDRGEB lr,[ip,#1]!
    CMPGE  lr,R4
    BEQ    ws1
    ADDS   R5,R5,#1    ;# characters remaining in STR
    CMPNE  R3,#"L"
    BEQ    ws4         ;all characters are CHD or only remove leading CHD
;        remove trailing CHD
ws2 ADD    R2,ip,R5    ;byte after STR
ws3 SUBS   R5,R5,#1
    LDRGEB lr,[R2,#-1]!
    CMPGE  lr,R4
    BEQ    ws3
    ADD    R5,R5,#1
;        copy remains to result
ws4 SUBS   R5,R5,#1
    SUBGES R1,R1,#1
    LDRGEB lr,[ip],#1
    STRGEB lr,[R0],#1
    BGE    ws4
    MOV    lr,#" "
ws5 SUBS   R1,R1,#1
    STRGEB lr,[R0],#1 ;blank fill
    BGE    ws5
    LDMDB  fp,{R4-R5,fp,sp,pc} ;return
    END
;
    TTL    STUDIN
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
F0  FN     0
F1  FN     1
F2  FN     2
F3  FN     3
F4  FN     4
F5  FN     5
F6  FN     6
F7  FN     7
R0  RN     0
R1  RN     1
R4  RN     4
    AREA   |C$$code|,CODE,READONLY
    EXPORT studin_;(F,N) => inverse Student t-distribution
    IMPORT gausin_
;
    DCB    "studin_",0,8,0,0,255
studin_
    MOV    ip,sp
    STMDB  sp!,{R0,R1,R4,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R4,[R1]      ;N
    LDFS   F3,[R0]      ;F
    ADFS   F2,F3,F3     ;P=2.0*F
    CMF    F3,#0.5      ;IF(F.GE.0.5) THEN
    MVFGES F1,#1        ;  RL=1.
    RSFGES F2,F2,#2     ;  P=2.0*(1-F)
    MNFLTS F1,#1        ;ELSE RL=-1.
    MVFS   F0,#0
    CMP    R4,#0
    CMFGT  F2,#0
    LDMLEDB fp,{R4,fp,sp,pc} ;return zero if P<=0 or N<=0
    CMF    F2,#1
    LDMGTDB fp,{R4,fp,sp,pc} ;return zero if P>1
    CMP    R4,#2
    RSFLTS F2,F2,#1
    LDFLTS F0,pb2         ;pi/2
    FMLLTS F0,F0,F2
    TANLTS F0,F0          ;IF N.EQ.1: STUDIN=RL*COT(P*PI/2)
    RSFEQS F0,F2,#2
    FMLEQS F0,F0,F2
    FRDEQS F0,F0,#2       ;2.0/(P*(2.0-P))
    SUFEQS F0,F0,#2
    SQTEQS F0,F0          ;IF N.EQ.2: STUDIN=RL*SQRT(2/(P*(2-P))-2)
    FMLLES F0,F0,F1
    LDMLEDB fp,{R4,fp,sp,pc} ;return zero if N<3
    STFE   F4,[sp,#-12]!;save floating registers
    STFE   F5,[sp,#-12]!
    STFE   F6,[sp,#-12]!
    STFE   F7,[sp,#-12]!
    STFS   F1,[sp,#-4]! ;save RL
    FLTS   F7,R4        ;RN=N
    SUFS   F0,F7,#0.5
    FRDS   F3,F0,#1     ;A=1/(RN-0.5)
    LDFS   F1,cb1       ;48.0
    FMLS   F4,F0,F0
    FMLS   F4,F4,F1     ;B=48.0/A**2
    LDFS   F0,cc1       ;20700.0
    LDFS   F1,cc2       ;98.0
    FMLS   F0,F0,F3
    FDVS   F5,F0,F4
    LDFS   F0,cc3       ;16.0
    SUFS   F5,F5,F1
    FMLS   F5,F5,F3
    SUFS   F5,F5,F0
    LDFS   F1,cc4       ;96.36
    FMLS   F5,F5,F3
    ADFS   F5,F5,F1     ;C=((20700.*A/B-98.)*A-16.)*A+96.36
    LDFS   F0,cd1       ;94.5
    ADFS   F1,F4,F5
    FDVS   F6,F0,F1
    SUFS   F6,F6,#3
    LDFS   F0,pb2       ; pi/2
    FDVS   F6,F6,F4
    FMLS   F1,F0,F3
    ADFS   F6,F6,#1
    SQTS   F0,F1
    FMLS   F6,F6,F7
    FMLS   F6,F6,F0     ;D=((94.5/(B+C)-3.)/B+1.)*SQRT(A*pi/2)*RN
    FMLS   F0,F2,F6     ;X=D*P
    FRDS   F1,F7,#2     ;2/RN
    POWS   F1,F0,F1     ;Y=X**(2/RN)
    LDFS   F0,cy1       ;0.05
    ADFS   F0,F0,F3
    CMF    F1,F0
    BLE    pt5          ;skip if Y <= A+0.05
    FMLS   F0,F2,#0.5
    STFS   F0,[sp,#-4]!
    MOV    R0,sp
    BL     gausin_      ;X=GAUSIN(0.5*P)
    ADD    sp,sp,#4     ;restore stack
    SUBS   R0,R4,#5
    FLTGES F2,R0        ;IF(N.GE.5) THEN
    LDFGES F3,cc5       ;0.6
    ADFGES F2,F2,#0.5   ;  RN-4.5
    FMLGES F1,F3,#0.5   ;  0.3
    ADFGES F3,F3,F0     ;  X+0.6
    FMLGES F1,F1,F2
    FMLGES F1,F1,F3
    ADFGES F5,F5,F1     ;  C = C + 0.3*(RN-4.5)*(X+0.6)
    LDFS   F1,cy1       ;0.05
    FMLS   F2,F6,F0
    FMLS   F1,F1,F2
    SUFS   F1,F1,#5
    LDFS   F2,cc6       ;7.0
    FMLS   F1,F1,F0
    SUFS   F1,F1,F2
    FMLS   F1,F1,F0
    SUFS   F1,F1,#2
    FMLS   F1,F1,F0
    ADFS   F1,F1,F4
    ADFS   F5,F5,F1     ;C=(((0.05*D*X-5.0)*X-7.0)*X-2.0)*X+B+C
    FMLS   F1,F0,F0     ;Y=X*X
    LDFS   F2,cy2       ;0.4
    LDFS   F3,cy3       ;6.3
    FMLS   F6,F2,F1
    LDFS   F2,cy4       ;36.0
    ADFS   F6,F6,F3
    FMLS   F6,F6,F1
    LDFS   F3,cy5       ;94.5
    ADFS   F6,F6,F2
    FMLS   F6,F6,F1
    ADFS   F6,F6,F3
    FDVS   F6,F6,F5
    SUFS   F6,F6,F1
    SUFS   F6,F6,#3
    FDVS   F6,F6,F4
    ADFS   F6,F6,#1
    FMLS   F1,F6,F0    ;Y=(((((0.4*Y+6.3)*Y+36.0)*Y+94.5)/C-Y-3.0)/B+1.0)*X
    SUFS   F0,F7,#0.5
    FMLS   F1,F1,F1
    FDVS   F1,F1,F0    ;Y=Y**2/(RN-0.5)
    EXPS   F1,F1
    SUFS   F1,F1,#1
    B      pt6
pt5 LDFS   F0,cy7       ;6.0
    FMLS   F2,F7,F1
    ADFS   F3,F7,F0
    LDFS   F0,cy8       ;0.089
    FDVS   F3,F3,F2     ;(RN+6)/(RN*Y)
    FMLS   F0,F0,F6
    LDFS   F2,cy9       ;0.822
    SUFS   F3,F3,F0     ;(RN+6)/(RN*Y)-0.089*D
    ADFS   F0,F7,#2
    SUFS   F3,F3,F2     ;(RN+6)/(RN*Y)-0.089*D-0.822
    FMLS   F3,F3,F0
    ADFS   F2,F7,#4
    FMLS   F3,F3,#3     ;((RN+6)/(RN*Y)-0.089*D-0.822)*(RN+2)*3
    FRDS   F2,F2,#0.5
    FRDS   F3,F3,#1     ;Z=1./(((RN+6)/(RN*Y)-0.089*D-0.822)*(RN+2)*3)
    ADFS   F3,F3,F2     ;Z+0.5/(RN+4)
    ADFS   F0,F7,#1
    FMLS   F3,F3,F1
    ADFS   F2,F7,#2
    SUFS   F3,F3,#1
    FMLS   F3,F3,F0     ;((Z+0.5/(RN+4))*Y-1)*(RN+1)
    FRDS   F1,F1,#1
    FDVS   F3,F3,F2     ;((Z+0.5/(RN+4))*Y-1)*(RN+1)/(RN+2)
    ADFS   F1,F1,F3     ;Y=((Z+0.5/(RN+4))*Y-1)*(RN+1)/(RN+2)+1/Y
pt6 FMLS   F0,F1,F7     ;RN*Y
    SQTD   F0,F0
    LDFS   F1,[sp],#4   ;restore RL
    LDFE   F7,[sp],#12  ;restore floating registers
    LDFE   F6,[sp],#12
    LDFE   F5,[sp],#12
    LDFE   F4,[sp],#12
    FMLS   F0,F0,F1     ;STUDIN = SQRT(RN*Y)*RL
    LDMDB  fp,{R4,fp,sp,pc} 
pb2 DCFS   1.5707963    ;pi/2
cb1 DCFS   48.0
cc1 DCFS   20700.0
cc2 DCFS   98.0
cc3 DCFS   16.0
cc4 DCFS   96.36
cd1 DCFS   94.5
cy1 DCFS   0.05
cc5 DCFS   0.6
cc6 DCFS   7.0
cy2 DCFS   0.4
cy3 DCFS   6.3
cy4 DCFS   36.0
cy5 DCFS   94.5
cy7 DCFS   6.0
cy8 DCFS   0.089
cy9 DCFS   0.822
    END
;
    TTL    STUDIS
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
F0  FN     0
F1  FN     1
F2  FN     2
F3  FN     3
F4  FN     4
F5  FN     5
R0  RN     0
R1  RN     1
R2  RN     2
R3  RN     3
    AREA   |C$$code|,CODE,READONLY
    EXPORT studis_;(T,N) => Student t-distribution
;
    DCB    "studis_",0,8,0,0,255
studis_
    MOV    ip,sp
    STMDB  sp!,{R0,R1,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R1,[R1]     ;N
    LDFS   F0,[R0]     ;T
    CMP    R1,#1
    MNFLTS F0,#1       ;error, set studis=-1
    LDFEQS F1,piv      ; 1/pi
    ATNEQS F0,F0
    FMLEQS F0,F0,F1
    ADFEQS F0,F0,#0.5
    LDMLEDB fp,{fp,sp,pc} ;return if N<2
    STFE   F4,[sp,#-12]!;save floating registers
    STFE   F5,[sp,#-12]!
    FLTS   F1,R1        ;FN = N
    SQTS   F2,F1
    FDVS   F5,F0,F2     ;A=T/SQRT(FN)
    FMLS   F0,F0,F0     ;T**2
    ADFS   F0,F0,F1
    FDVS   F4,F1,F0     ;B=FN/(FN+T**2)
    MVFS   F3,#1        ;S=1.0
    SUBS   R2,R1,#4     ;N4 = N-4
    AND    R3,R1,#1     ;N3 = MOD(N,2)
    BLT    pt4          ;N<4
    MVFS   F2,#1        ;C=1.0
    ADD    R1,R3,#2     ;K = 2+N3
    FLTS   F1,R1        ;FK = 2+N3
lp1 SUFS   F0,F1,#1     ;FK-1.0
    FMLS   F0,F0,F4
    FDVS   F0,F0,F1
    FMLS   F2,F0,F2     ;C = C*B*(FK-1.0)/FK
    ADFS   F3,F3,F2     ;S = S + C
    ADFS   F1,F1,#2     ;FK = FK + 2
    SUBS   R2,R2,#2
    BGE    lp1          ;loop (N-2)/2 times
pt4 TST    R3,#1
    SQTEQS F4,F4
    FMLEQS F0,F4,F3
    FMLEQS F0,F0,F5
    FMLEQS F0,F0,#0.5   ;0.5*A*SQRT(B)*S
    ATNNES F0,F5
    FMLNES F5,F5,F4
    FMLNES F5,F5,F3
    ADFNES F0,F0,F5
    LDFNES F1,piv       ; 1/pi
    FMLNES F0,F0,F1     ;(A*B*S+ATAN(A))/pi
    ADFS   F0,F0,#0.5   ;STUDIS = 0.5 + ...
    LDFE   F5,[sp],#12  ;restore floating registers
    LDFE   F4,[sp],#12
    LDMDB  fp,{fp,sp,pc} 
piv DCFS   0.31830989   ; 1/pi
    END
;
;          SUBWORD see WORD
;
    TTL    TCDUMP
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 tcdump_;(LABEL,IA,NW,IND) dumps area of memory to stream 6
    IMPORT io_start_we
    IMPORT io_end
    IMPORT io_do_single
    IMPORT io_do_array
    IMPORT iusame_
    DCB    "tcdump_",0,8,0,0,255
tcdump_
    MOV     ip,sp
    STMDB   sp!,{R0-R9,fp,ip,lr,pc}
    SUB     fp,ip,#4
    SUB     sp,sp,#20       ;space for IA etc
    LDR     R3,[R3]         ;IND
    MOV     R4,#0           ;flags
lp1 AND     lr,R3,#255
    CMP     lr,#"I"
    ORREQ   R4,R4,#1        ;set bit 0 for "I"
    CMP     lr,#"H"
    ORREQ   R4,R4,#2        ;set bit 1 for "H"
    CMP     lr,#"F"
    ORREQ   R4,R4,#4        ;set bit 2 for "F"
    MOVS    R3,R3,LSR#8
    BNE     lp1
    LDR     R5,[R2]         ;NW
    SUB     R6,R1,#4        ;LBASE4 = (IA(0))
    MOV     R0,#6
    ADR     R1,f20
    BL      io_start_we     ;PRINT 9020,LABEL,LOCB(IA)
    LDR     R0,[fp,#-52]    ;(LABEL)
    MOV     R1,#4
    BL      io_do_single
    SUB     R0,fp,#48       ;(LOCB(IA))
    MOV     R1,#4
    BL      io_do_single
    BL      io_end
    ADR     ip,loc
    STR     ip,ploc
    MOV     R8,#0           ;JB = 0
p20 ADD     R7,R8,#1        ;JA = JB + 1
    LDR     R0,[fp,#-48]    ;(IA)
    ADR     R1,ja           ;(JA)
    LDR     R2,[fp,#-44]    ;(NW)
    ADR     R3,fiv
    STR     R7,ja           ;store JA
    BL      iusame_
    LDR     R1,loc
    MOV     R9,R0           ;store N
    CMP     R1,R7
    BGT     p30             ;branch if LOC.GT.JA
;
p25 SUB     R8,R7,#1
lp2 SUBS    R9,R9,#5
    ADDGE   R8,R8,#5        ;JB = JA + [N,5] - 1
    BGT     lp2
    LDR     ip,[R6,R7,LSL#2];IA(JA)
    STMIB   sp,{R7,R8,ip}   ;store ja,jb,IA(J)
    MOV     R0,#6
    ADR     R1,f24
    BL      io_start_we     ;PRINT 9024, ...
    MOV     R0,#3           ;3 words to write
    ADR     R1,ja
    MOV     R2,#4
    BL      io_do_array     ;JA,JB,IA(JA)
    BL      io_end
    CMP     R8,R5
    BLT     p20             ;loop while JB.LT.NW
    LDMDB   fp,{R4-R9,fp,sp,pc} ;return
;
p30 ADD     R0,R7,#4        ;JA+4
    STR     R7,ja
    CMP     R0,R5
    MOVLT   R8,R0
    MOVGE   R8,R5           ;JB = MIN(JA+4, NW)
    MOV     R0,#6
    ADR     R1,f30
    BL      io_start_we     ;PRINT 9030, ...
    ADR     R0,ja
    MOV     R1,#4
    BL      io_do_single    ;JA
    BL      prdmp
    TST     R4,#1
    ADRNE   R1,f31
    BLNE    prdmp1
    TST     R4,#2
    ADRNE   R1,f33
    BLNE    prdmp1
    TST     R4,#4
    ADRNE   R1,f32
    BLNE    prdmp1
    CMP     R8,R5
    LDMGEDB fp,{R4-R9,fp,sp,pc} ;return when JB=NW
    LDR     R0,loc
    ADD     R7,R8,#1        ;JA = JB + 1
    SUBS    R1,R7,R0        ;JA - LOC
    BLT     p30             ;loop until get to identical words
    SUB     R9,R9,R1        ;N = N + LOC - JA
    CMP     R9,#5
    BLT     p20
    B       p25
;
prdmp1;
    STMFD   sp!,{lr}
    MOV     R0,#6
    BL      io_start_we     ;PRINT 9030, ...
    B       pr1
prdmp;    print the rest of ((IA(J),J=JA,JB)
    STMFD   sp!,{lr}
pr1 ADD     R1,R6,R7,LSL#2  ;(IA(JA))
    SUB     R0,R8,R7
    MOV     R2,#4
    ADD     R0,R0,#1        ;# words to print = JB - JA + 1
    BL      io_do_array
    BL      io_end
    LDMFD   sp!,{pc} 
;
fiv DCD   5
f20 DCB   "(/' DUMP',A6,'  from address ',Z8/)",0    ;36
f24 DCB   "(1X,I6,4X,'TO',I7,4X,'ALL CONTAIN',Z14)",0;40
f30 DCB   "(1X,I6,5Z14)",0,0,0,0                     ;16
f31 DCB   "(7X,5I14)",0,0,0                          ;12
f32 DCB   "(7X,5E14.6)",0                            ;12
f33 DCB   "(7X,5A14)",0,0,0                          ;12
    ^      0,sp         ;do not change the order of these, just add to them
ploc  #    4
ja    #    4
jb    #    4
junk  #    4
loc   #    4
      END
;
    TTL    TIMEST
pc  RN    15
lr  RN    14
    AREA   |C$$code|,CODE,READONLY
    EXPORT timest_;dummy
timest_
    MOV    pc,lr
    END
;
    TTL    TIMED
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R0  RN     0
F1  FN     1
F0  FN     0
OS_ReadMonotonicTime EQU &42
    AREA   last_time,DATA
    DCD    0
    AREA   |C$$code|,CODE,READONLY
    EXPORT timed_;(T) returns time since last call to TIMED
    DCB    "timed_",0,0,8,0,0,255
timed_
    MOV    ip,sp
    STMDB  sp!,{R0,fp,ip,lr,pc}
    SUB    fp,ip,#4
    SWI    OS_ReadMonotonicTime; get current time in R0
    LDR    ip,ptr     ;pointer to last time
    LDR    lr,[ip]    ;get last time
    STR    R0,[ip]    ;store current time
    CMP    lr,#0
    SUBNE  lr,R0,lr   ;get time difference
    FLTD   F0,lr      ;float it
    LDFD   F1,cent
    MUFD   F0,F1,F0   ;make into seconds
    LDR    R0,[sp]    ;address of T
    STFS   F0,[R0]    ;store in T
    LDMDB  fp,{fp,sp,pc} ;return
ptr DCD    last_time
cent DCFD  0.01
    END
;
    TTL    TIMEL
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R0  RN     0
F1  FN     1
F0  FN     0
OS_ReadMonotonicTime EQU &42
    AREA   |C$$code|,CODE,READONLY
    EXPORT timel_;(T) execution time remaining
    DCB    "timel_",0,0,8,0,0,255
timel_
    MOV    ip,sp
    STMDB  sp!,{R0,fp,ip,lr,pc}
    SUB    fp,ip,#4
    MOV    ip,R0          ;address of T
    SWI    OS_ReadMonotonicTime; get current time in R0
    RSB    R0,R0,#&80000000
    FLTS   F0,R0
    LDFS   F1,cent
    FMLS   F0,F0,F1       ;'remaining' time in seconds
    STFS   F0,[ip]        ;store in T
    LDMDB  fp,{fp,sp,pc} ;return
cent DCFS  0.01
    END
;
    TTL    TIMEX
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R0  RN     0
F1  FN     1
F0  FN     0
OS_ReadMonotonicTime EQU &42
    AREA   |C$$code|,CODE,READONLY
    EXPORT timex_;(T) execution time so far
    DCB    "timex_",0,0,8,0,0,255
timex_
    MOV    ip,sp
    STMDB  sp!,{R0,fp,ip,lr,pc}
    SUB    fp,ip,#4
    MOV    ip,R0          ;address of T
    SWI    OS_ReadMonotonicTime; get current time in R0
    FLTS   F0,R0
    LDFS   F1,cent
    FMLS   F0,F0,F1       ;elapsed time in seconds
    STFS   F0,[ip]        ;store in T
    LDMDB  fp,{fp,sp,pc} ;return
cent DCFS  0.01
    END
;
    TTL    TKOLMO
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
F0  FN     0
F1  FN     1
F2  FN     2
F3  FN     3
F4  FN     4
F5  FN     5
R0  RN     0
R1  RN     1
R2  RN     2
R3  RN     3
    AREA   |C$$code|,CODE,READONLY
    EXPORT tkolmo_;(A,NA,B,NB,PROB) finds Kolmogorov probablility
    IMPORT probkl_
;
    DCB    "tkolmo_",0,8,0,0,255
tkolmo_
    MOV    ip,sp
    STMDB  sp!,{R0-R3,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R1,[R1]      ;NA
    LDR    R3,[R3]      ;NB
    CMP    R1,#2        ;check both NA & NB >2
    CMPGT  R3,#2
    MNFLES F0,#1
    BLE    fin          ;return error , PROB=-1.0
    STFE   F4,[sp,#-12]!;save floating registers
    STFE   F5,[sp,#-12]!
    FLTD   F4,R1
    FLTD   F5,R3
    RDFD   F4,F4,#1     ;SA=1/NA
    RDFD   F5,F5,#1     ;SB=1/NB
    MVFD   F2,#0        ;RDIFF = 0.0
    MVFD   F3,#0        ;RDMAX = 0.0
    LDFS   F0,[R0],#4   ;A(IA), IA=1
    LDFS   F1,[R2],#4   ;B(IB), IB=1
lp1 CMF    F0,F1        ;IF(A(IA) .LT. B(IB)) THEN
    BGE    pt1
    SUFD   F2,F2,F4     ;  RDIFF = RDIFF - SA
    ABSD   F0,F2
    CMF    F0,F3
    MVFGTD F3,F0        ;  RDMAX = MAX(RDMAX,ABS(RDIFF))
    SUBS   R1,R1,#1     ;  NA = NA - 1: IF(NA.GT.0) THEN
    LDFGTS F0,[R0],#4   ;     A(IA+1): IA = IA + 1
    BGT    lp1          ;     and loop
    B      pt2          ;ELSE
pt1 ADFD   F2,F2,F5     ;  RDIFF = RDIFF + SB
    ABSD   F1,F2
    CMF    F1,F3
    MVFGTD F3,F1        ;  RDMAX = MAX(RDMAX,ABS(RDIFF))
    SUBS   R3,R3,#1     ;  NB = NB - 1: IF(NB.GT.0) THEN
    LDFGTS F1,[R2],#4   ;     B(IB+1): IB = IB + 1
    BGT    lp1          ;     and loop
pt2 ADFD   F0,F4,F5     ;ENDIF
    SQTD   F1,F0
    DVFD   F0,F3,F1     ;Z = RDMAX / SQRT(SA+SB)
    LDFE   F5,[sp],#12
    LDFE   F4,[sp],#12
    STFS   F0,[sp,#-4]!
    MOV    R0,sp
    BL     probkl_      ;call PROBKL(Z)
fin LDR    ip,[fp,#4]   ;(PROB)
    STFS   F0,[ip]      ;store PROB
    LDMDB  fp,{fp,sp,pc} 
    END
;
    TTL   TLERR
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
F2  FN     2
F3  FN     3
    AREA   tlsdim__,DATA,COMMON
    %      20
    ^    0,R4
m1  #      4       ;#constraints
m   #      4       ;#constraints+equations
n   #      4       ;#variables
l   #      4       ;#solutions
ier #      4       ;#parameters solved
;
    AREA   |C$$code|,CODE,READONLY
    EXPORT tlerr_ ;(A,X,AUX,IPIV) gets fitted error matrix for l.s.fit
    IMPORT tluk_  ;(A,IASEP,NR,SIG,BETA)
    IMPORT tlstep_;(A,B,IASEP,IBSEP,NR,NC,BETA)
    DCB    "tlerr_",0,0,8,0,0,255
tlerr_
    MOV    ip,sp
    STMDB  sp!,{R0-R9,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R4,com        ;set base for COMMON/TLSDIM/
    LDMIA  R4,{R5-R9}    ;M1,M,N,L,IER
    CMP    R7,R9
    CMNNE  R7,R9
    BEQ    pt1           ;skip if |IER|=N
    SUB    sp,sp,#24     ;work space
    CMP    R8,R7
    ADDGT  R5,R8,R9
    ADDLE  R5,R7,R9
    ADD    R5,R2,R5,LSL#2;J = MAX(N,L) + IER + 1
    ADD    lr,R7,#1      ;N+1
    MUL    R8,lr,R9
    ADD    R8,R0,R8,LSL#2;IST = IER * (N+1) + 1
    SUB    ip,R6,R9      ;LV = M - IER
    ADD    R6,R3,R9,LSL#2;(IPIV(K)), K=IER+1
lp1 STR    ip,lv         ;store LV
    ADD    R9,R9,#1      ;K = K + 1 (to make it what it ought to be)
    MOV    R0,R8         ;(A(IST))
    ADR    R1,n          ;(N)
    ADR    R2,lv         ;(LV)
    ADR    R3,sig        ;(SIG)
    ADR    ip,beta
    STR    ip,[sp]       ;(BETA)
    BL     tluk_         ;CALL TLUK(A(IST),N,LV,SIG,BETA)
    LDR    ip,sig
    EOR    ip,ip,#&8,4
    STR    ip,[R5],#4    ;AUX(J) = -SIG, J=J+1
    ADR    R0,lv         ;(LV)
    SUB    ip,R7,R9      ;N-K
    STR    ip,nmk
    ADR    R1,nmk        ;(N-K)
    ADR    R2,beta
    STMIA  sp,{R0-R2}    ;(LV,N-K,BETA)
    MOV    R0,R8         ;(A(IST))
    ADD    R1,R8,#4      ;(A(IST+1))
    ADR    R2,n          ;(N)
    ADR    R3,n          ;(N)
    BL     tlstep_       ;CALL TLSTEP(A(IST),A(IST+1),N,N,LV,N-K,BETA)
    STR    R9,[R6],#4    ;IPIV(K) = K, (K) = (K+1)
    LDR    ip,lv
    SUB    ip,ip,#1      ;LV = LV - 1
    ADD    R8,R8,R7,LSL#2
    ADD    R8,R8,#4      ;IST = IST + N + 1
    CMP    R9,R7
    BLT    lp1           ;loop over K = IER+1, N
    ADD    sp,sp,#24     ;remove work space
    LDMIA  sp,{R0-R3}    ;restore arguments
    LDMIA  R4,{R5-R9}    ;restore M1,M,N,L,IER
pt1 CMP    R7,R8
    MOVGT  R8,R7         ;K1 = MAX(L,N)
    ADD    R8,R8,R7
    ADD    R2,R2,R8,LSL#2;(AUX(KAUX)), KAUX = N + MAX(N,L) + 1
    MUL    R8,R7,R7      ;IA = N*N
    MOV    R9,R7         ;initialize KN = N
lp2 SUB    R8,R8,#1      ;IA = IA - 1
    LDFS   F1,[R2,#-4]!  ;KAUX = KAUX - 1, AUX(KAUX)
    STR    R2,[sp,#-4]!  ;save KAUX on stack
    FRDS   F0,F1,#1      ;PIV = 1./AUX(KAUX)
    MUL    R4,R7,R9      ;JK = KN*N
    MLA    R6,R7,R7,R9   ;JL = N*N + KN
    SUB    R6,R6,R7      ;JL = N*N + KN - N
    SUB    R6,R6,#1
    ADD    R6,R1,R6,LSL#2;(X(JL))
    SUBS   R3,R7,R9      ;J-count (N-KN+1)
lp3 CMPEQ  R5,R9
    MVFLTS F1,F0         ;IF 1st of loop and M1<KN, H=PIV
    MVFGES F1,#0         ;otherwise H=0
    SUB    R4,R4,#1      ;JK = JK - 1
    ADD    ip,R1,R4,LSL#2;II = JK
    ADD    lr,R0,R8,LSL#2;I = IA
    SUBS   R2,R7,R9      ;IJ-count (N-KN)
lp4 ADDGT  ip,ip,R7,LSL#2;II = II + N
    LDFGTS F2,[ip]       ;X(II)
    LDFGTS F3,[lr,#4]!   ;I = I + 1, A(I)
    FMLGTS F2,F2,F3
    SUFGTS F1,F1,F2      ;H = H - A(I)*X(II)
    SUBS   R2,R2,#1
    BGT    lp4           ;loop over IJ
    FMLS   F1,F1,F0      ;H = H*PIV
    STFS   F1,[R6]       ;X(JL) = H
    SUB    R6,R6,R7,LSL#2;(JL) = (JL-N)
    SUBS   R3,R3,#1
    BGE    lp3           ;loop over J
    SUBS   R2,R7,R9      ;IJ-count (N-KN)
    BLE    pt2           ;skip if KN>=N
    ADD    lr,R1,R8,LSL#2;JL = IA
    MOV    ip,lr         ;J  = IA
lp5 LDR    R3,[lr,R7,LSL#2]!;JL = JL + N, X(JL)
    STR    R3,[ip,#4]!   ;J = J + 1, -> X(J)
    SUBS   R2,R2,#1
    BGT    lp5           ;loop over IJ
    LDR    R3,[sp,#16]   ;restore (IPIV)
    SUB    R3,R3,#4      ;(IPIV(0))
    LDR    R3,[R3,R9,LSL#2];IPIV(KN)
    SUBS   R3,R3,R9      ;ID = IPIV(KN) - KN
    BEQ    pt2           ;skip if this is the pivot row
    ADD    ip,R1,R8,LSL#2;J = IA
    SUBS   R2,R7,R9      ;IJ-count (N-KN+1)
lp6 LDR    R4,[ip,R3,LSL#2];X(J+ID)    swop pivot rows
    LDR    R6,[ip]       ;X(J)
    STR    R6,[ip,R3,LSL#2];-> X(J+ID)
    STR    R4,[ip],R7,LSL#2;-> X(J), J = J + N
    SUBS   R2,R2,#1
    BGE    lp6           ;loop over IJ
    MUL    R3,R7,R3      ;ID = ID*N
    ADD    ip,R1,R8,LSL#2;J = IA
    SUBS   R2,R7,R9      ;IJ-count (N-KN+1)
lp7 LDR    R4,[ip,R3,LSL#2];X(J+ID)    swop pivot columns
    LDR    R6,[ip]       ;X(J)
    STR    R6,[ip,R3,LSL#2];-> X(J+ID)
    STR    R4,[ip],#4    ;-> X(J), J = J + 1
    SUBS   R2,R2,#1
    BGE    lp7           ;loop over IJ
pt2 LDR    R2,[sp],#4    ;restore KAUX
    SUB    R8,R8,R7      ;IA = IA - N
    SUBS   R9,R9,#1      ;KN = KN - 1
    BGT    lp2
    LDMDB  fp,{R4-R9,fp,sp,pc}  ;return
com DCD    tlsdim__      ;pointer to COMMON/TLSDIM/
      ^    0,sp
arg   #    12    ;3 args for TLSTEP
lv    #    4     ;LV
beta  #    4     ;BETA
sig   #    4     ;SIG
nmk   EQU  sig   ;N-K
    END
;
    TTL   TLRES
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   tlsdim__,DATA,COMMON
    %      20
    ^    0,R4
m1  #      4       ;#constraints
m   #      4       ;#constraints+equations
n   #      4       ;#variables
l   #      4       ;#solutions
ier #      4       ;#parameters solved
;
    AREA   |C$$code|,CODE,READONLY
    EXPORT tlres_ ;(A,B,AUX) gets fitted residuals from l.s.fit
    IMPORT tlstep_;(A,B,IASEP,IBSEP,NR,NC,BETA)
    DCB    "tlres_",0,0,8,0,0,255
tlres_
    MOV    ip,sp
    STMDB  sp!,{R0-R9,fp,ip,lr,pc}
    SUB    fp,ip,#4
    SUB    sp,sp,#20     ;space for 5 words on stack
    LDR    R4,com        ;address of common
    LDMIA  R4,{R5-R9}    ;M1,M,N,L,IER
    CMP    R9,#0
    LDMEQDB fp,{R4-R9,fp,sp,pc}  ;return if IER=0
    RSBLT  R9,R9,#0      ;|IER|
    STR    R9,ier        ;IER = |IER|
    MOV    lr,#0
    MUL    ip,R8,R9      ;count (L*IER)
lp1 SUBS   ip,ip,#1
    STRGE  lr,[R1,ip,LSL#2];clear B
    BGT    lp1
    SUB    R5,R9,R5      ;count (IER - M1)
    SUB    ip,R9,#1      ;IER-1
    SUB    R6,R6,ip      ;LV = M - IER + 1
    STR    R6,lv
    ADD    lr,R7,#1      ;N+1
    MUL    R9,ip,lr
    ADD    R9,R0,R9,LSL#2;(A(IST))
    MUL    R6,ip,R8
    ADD    R6,R1,R6,LSL#2;(B(IB))
    CMP    R7,R8
    ADDGT  ip,ip,R7
    ADDLE  ip,ip,R8
    ADD    R7,R2,ip,LSL#2;(AUX(KN)), KN = MAX(N,L) + IER
    ADR    R0,lv         ;address of LV
    ADR    R1,l          ;address of L
    ADR    R2,beta       ;address of BETA
    STMIA  sp,{R0-R2}    ;store 3 last args for TLSTEP
;    R4: (TLSDIM), R5: count, R6: (B(IB)), R7: (AUX(KN)), R8: L, R9:(A(IST))
lp2 SUBS   R5,R5,#1      ;count down KKSTEP times
    LDMLTDB fp,{R4-R9,fp,sp,pc}  ;return
    MOV    R0,R9         ;(A(IST))
    LDFS   F0,[R7],#-4   ;AUX(KN), KN = KN - 1
    LDFS   F1,[R9],#-4   ;A(IST), IST = IST - 1
    LDR    lr,n          ;N
    SUB    R9,R9,lr,LSL#2;IST = IST - N
    FMLS   F0,F0,F1
    MOV    R1,R6         ;(B(IB))
    SUB    R6,R6,R8,LSL#2;IB = IB - L
    RDFS   F0,F0,#1
    ADR    R2,n          ;(N)
    MNFS   F0,F0
    ADR    R3,l          ;(L)
    STFS   F0,beta       ;BETA = -1./(AUX(KN)*A(IST)
    BL     tlstep_       ;CALL TLSTEP(A(IST),B(IB),N,L,LV,L,BETA)
    LDR    R0,lv
    ADD    R0,R0,#1
    STR    R0,lv         ;LV = LV + 1
    B      lp2           ;loop over KK = 1,KKEND
com DCD    tlsdim__      ;pointer to COMMON/TLSDIM/
      ^    0,sp
arg   #    12    ;3 args for TLSTEP
lv    #    4     ;LV
beta  #    4     ;BETA
    END
;
    TTL   TLS
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
F2  FN     2
F3  FN     3
F4  FN     4
F5  FN     5
F6  FN     6
F7  FN     7
    AREA   tlsdim__,DATA,COMMON
    %      20
    ^    0,R4
m1  #      4       ;#constraints
m   #      4       ;#constraints+equations
n   #      4       ;#variables
l   #      4       ;#solutions
ier #      4       ;#parameters solved
;
    AREA   |C$$code|,CODE,READONLY
    EXPORT tls_   ;(A,B,AUX,IPIV,EPS,X) unconstrained least squares fitting
    IMPORT tluk_  ;(A,IASEP,NR,SIG,BETA)
    IMPORT tlstep_;(A,B,IASEP,IBSEP,NR,NC,BETA)
    IMPORT tlsmsq_;(B,L,M)
    IMPORT tlswop_;(A,AD,N,NR)
    DCB    "tls_",0,0,0,0,8,0,0,255
tls_
    MOV    ip,sp
    STMDB  sp!,{R0-R9,fp,ip,lr,pc}
    SUB    fp,ip,#4
    STFE   F4,[sp,#-12]! ;save F4
    STFE   F5,[sp,#-12]! ;save F5
    STFE   F6,[sp,#-12]! ;save F6
    STFE   F7,[sp,#-12]! ;save F7
    SUB    sp,sp,#36     ;working space
    LDR    ip,adEPS      ;(EPS)
    LDFS   F4,[ip]       ;EPS
    LDR    R4,com        ;set base for COMMON/TLSDIM/
    LDMIB  R4,{R6-R8}    ;M,N,L
    CMP    R6,R7
    CMPGE  R7,#1
    BLT    err           ;skip if M<N or N<1
    CMP    R7,R8
    STRGT  R7,k1
    STRLE  R8,k1         ;K1 = MAX(L,N)
    ADDGT  R5,R2,R7,LSL#2
    ADDLE  R5,R2,R8,LSL#2;K2 = K1 + 1
    MVFD   F5,#0         ;PIV = 0.0
    MOV    R9,#0         ;initialize K='1,N'
lp1 MVFD   F3,#0         ;H = 0.0
    MVFD   F2,#0         ;G = 0.0
    MOV    ip,R0         ;JA = IST
    MOV    lr,R1         ;JB = 1
lp2 LDFS   F0,[ip]       ;A(JA)
    ADD    ip,ip,R7,LSL#2;JA = JA + N
    FMLS   F1,F0,F0
    ADFD   F3,F3,F1      ;H = H + A(JA)*A(JA)
    LDFS   F1,[lr]       ;B(JB)
    ADD    lr,lr,R8,LSL#2;JB = JB + L
    FMLS   F1,F1,F0
    SUBS   R6,R6,#1      ;M = M - 1 (count)
    ADFD   F2,F2,F1      ;G = G + A(JA)*B(JB)
    BGT    lp2
    LDR    R6,m          ;restore M
    ADD    ip,R2,R9,LSL#2;(AUX(K))
    STFS   F3,[ip]       ;AUX(K) = H
    STFS   F2,[R5],#4    ;AUX(K2) = G, K2 = K2 + 1
    MUFD   F2,F2,F2
    DVFD   F2,F2,F3      ;PIVT = G*G/H
    ADD    R9,R9,#1      ;K = K + 1
    CMF    F2,F5         ;IF(PIVT.GT.PIV) THEN
    MVFGTD F5,F2         ;  PIV = PIVT
    STRGT  R9,kpiv       ;  KPIV = K
    ADD    R0,R0,#4      ;IST = IST + 1
    STR    ip,[R3],#4    ;IPIV(K) = K
    CMP    R9,R7
    BLT    lp1           ;loop over K=0,N-1
    CMF    F5,#0
    BLE    err           ;ensure we have a pivot
    STR    R7,ier        ;initialise IER=N
    MOV    R0,R1         ;(B(1))
    ADR    R1,l          ;(L)
    ADR    R2,m          ;(M)
    BL     tlsmsq_       ;F = TLSMSQ(B(1),L,M)
    MVFD   F6,F0
    FMLS   F7,F4,F4      ;TOL = EPS*EPS
    LDR    R5,adA        ;IST
    LDR    R6,adB        ;JB
    MOV    R9,#0         ;initialize K=0,N-1
lp3 LDR    R0,m
    SUB    R0,R0,R9
    STR    R0,lv         ;LV = M - K
    CMF    F5,F7
    CMFLE  F4,#0
    BLT    pt1           ;(EPS.LT.0.0 .AND. PIV.LE.TOL)
    FLTS   F0,R0         ;FLOAT(M-K)
    FMLS   F0,F0,F7      ;TOL*FLOAT(M-K)
    CMF    F0,F6
    CMFGE  F4,#0
    BLE    pt2           ;(EPS.LE.0.0 .OR. TOL*FLOAT(M-K).LT.F)
pt1 CMP    R9,#0         ;check for first time
    MVFEQD F7,#0         ;TOL = 0.0
    RSBEQ  ip,R7,#0
    STREQ  ip,ier        ;IER = -N
    BEQ    pt2
    STR    R9,ier        ;IER = KR
    MUL    ip,R9,R8      ;KR*L
    LDR    lr,adX        ;(X(1))
    ADD    ip,lr,ip,LSL#2;JK
    SUB    lr,R7,R9      ;N-KR
    MUL    lr,R8,lr      ;count
    MOV    R0,#0
lp4 STR    R0,[ip],#4    ;clear X(KR*L+1) to X(N*L)
    SUBS   lr,lr,#1
    BGT    lp4
    B      pt4           ;skip
pt2 SUFD   F6,F6,F5      ;F = F - PIV
    LDR    ip,kpiv
    SUB    ip,ip,#1      ;KPIV - 1
    SUBS   lr,ip,R9      ;I = KPIV - K - 1
    LDRGT  R2,adAUX      ;(AUX(1))
    LDRGT  R0,[R2,R9,LSL#2]
    LDRGT  R1,[R2,ip,LSL#2]
    STRGT  R0,[R2,ip,LSL#2]
    STRGT  R1,[R2,R9,LSL#2];swop AUX(KPIV) and AUX(K+1)
    LDRGT  R3,k1
    ADDGT  ip,ip,R3      ;K1 + KPIV - 1
    ADDGT  R3,R3,R9      ;K1 + K
    LDRGT  R0,[R2,R3,LSL#2]
    LDRGT  R1,[R2,ip,LSL#2]
    STRGT  R0,[R2,ip,LSL#2]
    STRGT  R1,[R2,R3,LSL#2];swop AUX(K1+KPIV) and AUX(K1+K+1)
    MOVGT  R0,R5         ;(A(IST))
    ADDGT  R1,R0,lr,LSL#2;(A(IST+I))
    ADRGT  R2,n          ;(N)
    ADRGT  R3,lv         ;(M-K)
    BLGT   tlswop_       ;CALL TLSWOP(A(IST),A(IST+I),N,M-K)
    MOV    R0,R5         ;(A(IST))
    ADR    R1,n          ;(N)
    ADR    R2,lv         ;(LV)  LV=M-K
    ADR    R3,sig        ;(SIG)
    ADR    ip,beta
    STR    ip,arg5       ;(BETA)
    BL     tluk_         ;CALL TLUK(A(IST),N,LV,SIG,BETA)
    LDR    R2,adAUX      ;(AUX(1))
    LDR    ip,k1
    ADD    R2,R2,ip,LSL#2;(AUX(K1+1))
    LDR    R0,sig
    EOR    R0,R0,#&8,4   ;-SIG
    STR    R0,[R2,R9,LSL#2];AUX(K+K1+1) = -SIG
    LDR    R3,adPIV      ;restore (IPIV)
    LDR    R2,kpiv       ;KPIV
    SUB    R1,R2,#1      ;KPIV-1
    LDR    R0,[R3,R9,LSL#2]
    STR    R0,[R3,R1,LSL#2];IPIV(KPIV) = IPIV(K+1)
    STR    R2,[R3,R9,LSL#2];IPIV(K+1) = KPIV
    SUB    R0,R7,R9
    SUB    R0,R0,#1
    STR    R0,nmk1       ;N-K-1
    ADR    R0,lv
    ADR    R1,nmk1
    ADR    R2,beta
    STMIA  sp,{R0-R2}    ;args 5 to 7
    MOV    R0,R5         ;(A(IST))
    ADD    R1,R0,#4      ;(A(IST+1))
    ADR    R2,n          ;(N)
    ADR    R3,n          ;(N)
    BL     tlstep_       ;CALL TLSTEP(A(IST),A(IST+1),N,N,LV,N-K-1,BETA)
    ADR    R0,l
    STR    R0,arg6
    MOV    R0,R5         ;(A(IST))
    LDR    R1,adB        ;(B(1))
    MUL    ip,R9,R8      ;K*L
    ADD    R1,R1,ip,LSL#2;(B(K*L+1))
    ADR    R2,n          ;(N)
    ADR    R3,l          ;(L)
    BL     tlstep_       ;CALL TLSTEP(A(IST),B(K*L+1),N,L,LV,L,BETA)
    ADD    R3,R9,#2      ;initialise J = K+2,N
    CMP    R3,R7
    BGT    pt3           ;skip loop if no terms
    MVFD   F5,#0         ;PIV = 0.0
    STR    R3,kpiv       ;KPIV = K + 2
    MOV    R2,R5         ;ID = IST
    LDR    R0,adAUX      ;(AUX(1))
    ADD    R1,R0,R9,LSL#2;(AUX(J-1)), J=K+2
    LDR    ip,k1
    ADD    R0,R1,ip,LSL#2;(AUX(K2-1)), K2=K1+KPIV
lp5 LDFS   F0,[R2,#4]!   ;ID = ID + 1, A(ID)
    LDFS   F2,[R1,#4]!   ;AUX(J)
    FMLS   F3,F0,F0
    SUFS   F2,F2,F3      ;H = AUX(J) - A(ID)*A(ID)
    LDFS   F1,[R6]       ;B(JB)
    STFS   F2,[R1]       ;AUX(J) = H
    FMLS   F0,F0,F1
    LDFS   F3,[R0,#4]!   ;K2 = K2 + 1, AUX(K2)
    SUFS   F3,F3,F0      ;G = AUX(K2) - A(ID)*B(JB)
    STFS   F3,[R0]       ;AUX(K2) = G
    FMLS   F0,F3,F3
    FDVS   F1,F0,F2      ;PIVT = G*G/H
    CMF    F1,F5
    MVFGTD F5,F1
    STRGT  R3,kpiv       ;store biggest pivot
    ADD    R3,R3,#1      ;J = J + 1
    CMP    R3,R7
    BLE    lp5           ;loop over J=K+2,N
pt3 ADD    R5,R5,R7,LSL#2
    ADD    R5,R5,#4      ;IST = IST + N + 1
    ADD    R6,R6,R8,LSL#2;JB = JB + L
    ADD    R9,R9,#1
    CMP    R9,R7
    BLT    lp3           ;loop over K=0,N-1
    SUB    R9,R7,#1      ;KR = N - 1
    MUL    R0,R8,R9      ;JK = (N-1)*L
    LDR    R1,adB        ;(B(1))
    LDR    R3,adX        ;(X(1))
    ADD    R1,R1,R0,LSL#2;(B(JK+1))
    ADD    R3,R3,R0,LSL#2;(X(JK+1))
    LDFS   F5,sig
    MNFS   F5,F5
    FRDS   F5,F5,#1      ;PIV = -1.0/SIG
    MOV    R2,R8         ;K-count (L)
lp6 SUBS   R2,R2,#1
    LDFGES F0,[R1],#4    ;B(JK+1), JK = JK + 1
    FMLGES F0,F0,F5
    STFGES F0,[R3],#4    ;X(JK+1) = PIV*B(JK+1), JK = JK + 1
    BGT    lp6
pt4 LDR    R0,adA        ;(A(1))
    MLA    ip,R9,R7,R9   ;KR*N+KR
    ADD    R0,R0,ip,LSL#2;(A(JST-1)), JST = KR*N+KR+2
    LDR    ip,k1
    ADD    ip,ip,R9      ;K1 + KR
    LDR    R2,adAUX      ;(AUX(1))
    ADD    R2,R2,ip,LSL#2;(AUX(K1+KR+1))
    LDR    R3,adPIV      ;(IPIV(1))
    ADD    R3,R3,R9,LSL#2;(IPIV(KR+1))
lp7 SUB    R0,R0,R7,LSL#2;JST = JST - N
    LDFS   F0,[R2,#-4]!  ;AUX(K1+J)
    FRDS   F5,F0,#1      ;PIV = 1.0/AUX(K1+J)
    LDR    R5,[R3,#-4]!  ;IPIV(J)
    SUB    R5,R5,R9      ;ID = IPIV(J) - J
    MUL    R5,R8,R5      ;ID*L
    SUB    lr,R9,#1
    MUL    R6,lr,R8      ;KST = (J-1)*L
    MOV    R1,R8         ;K-count (L)
lp8 LDR    ip,adB        ;(B(1))
    ADD    ip,ip,R6,LSL#2;(B(KST+1))
    LDFS   F4,[ip]       ;H = B(KST+1)
    LDR    R4,adX        ;(X(1))
    ADD    R4,R4,R6,LSL#2;(X(II)), II = KST+1
    MOV    ip,R0         ;(A(IA)), IA = JST
    SUB    lr,R7,R9      ;I-count (N-J)
lp9 ADD    R4,R4,R8,LSL#2;II = II + L
    LDFS   F0,[ip],#4    ;A(IA), IA = IA + 1
    LDFS   F1,[R4]       ;X(II)
    FMLS   F0,F0,F1
    SUBS   lr,lr,#1
    SUFD   F4,F4,F0      ;H = H - A(IA)*X(II)
    BGT    lp9           ;loop N-J times
    LDR    R4,adX        ;(X(1))
    ADD    R4,R4,R6,LSL#2;(X(KST))
    LDR    ip,[R4,R5,LSL#2];X(II), II=KST+ID*L
    STR    ip,[R4],R5,LSL#2;X(KST) = X(II)
    FMLS   F0,F4,F5
    STFS   F0,[R4]       ;X(II) = H*PIV
    ADD    R6,R6,#1      ;KST = KST + 1
    SUBS   R1,R1,#1
    BGT    lp8           ;loop L times
    SUB    R0,R0,#4      ;JST = JST - 1
    SUBS   R9,R9,#1      ;J = J - 1
    BGT    lp7           ;loop over J=KR,1,-1
    LDR    R4,com        ;restore pointer to /TLSDIM/
    MUL    ip,R7,R8
    LDR    R5,adB        ;(B(1))
    ADD    R5,R5,ip,LSL#2;(B(IST)), IST = N*L+1
    LDR    R6,adAUX      ;(AUX(1))
    LDR    R0,m
    SUB    R0,R0,R7
    STR    R0,mmn        ;M-N
lpa MOV    R0,R5         ;(B(IST))
    ADR    R1,l
    ADR    R2,mmn
    BL     tlsmsq_
    STFS   F0,[R6],#4    ;AUX(J) = TLSMSQ(B(IST),L,M-N)
    ADD    R5,R5,#4      ;IST = IST + 1
    SUBS   R8,R8,#1
    BGT    lpa           ;loop L times
ret LDFE   F7,[sp,#36]   ;restore F7
    LDFE   F6,[sp,#48]   ;restore F6
    LDFE   F5,[sp,#60]   ;restore F5
    LDFE   F4,[sp,#72]   ;restore F4
    LDMDB  fp,{R4-R9,fp,sp,pc}  ;return
;       problem encountered
err MVN    ip,#1000
    STR    ip,ier        ;IER=-1001
    B      ret
com DCD    tlsdim__      ;pointer to COMMON/TLSDIM/
      ^  -52,fp
adA   #    4     ;(A(1))
adB   #    4     ;(B(1))
adAUX #    4     ;(AUX(1))
adPIV #    4     ;(IPIV(1))
      ^    4,fp
adEPS #    4     ;(EPS)
adX   #    4     ;(X(1))
      ^    0,sp
arg5  #    4     ;3 args for TLSTEP
arg6  #    4
arg7  #    4
lv    #    4     ;LV
kpiv  #    4     ;KPIV
beta  #    4     ;BETA
sig   #    4     ;SIG
nmk1  #    4     ;N-K-1
k1    #    4     ;K1
mmk   EQU  beta  ;M-K
mmn   EQU  lv    ;M-N
    END
;
    TTL   TLSC
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
F2  FN     2
F3  FN     3
F4  FN     4
    AREA   tlsdim__,DATA,COMMON
    %      20
    ^    0,R4
m1  #      4       ;#constraints
m   #      4       ;#constraints+equations
n   #      4       ;#variables
l   #      4       ;#solutions
ier #      4       ;#parameters solved
;
    AREA   |C$$code|,CODE,READONLY
    EXPORT tlsc_  ;(A,B,AUX,IPIV,EPS,X) constrained least squares fit
    IMPORT tluk_  ;(A,IASEP,NR,SIG,BETA)
    IMPORT tlstep_;(A,B,IASEP,IBSEP,NR,NC,BETA)
    IMPORT tlsmsq_;(B,L,M)
    IMPORT tlswop_;(A,AD,N,NR)
;
    DCB    "tlsc_",0,0,0,8,0,0,255
tlsc_
    MOV    ip,sp
    STMDB  sp!,{R0-R9,fp,ip,lr,pc}
    SUB    fp,ip,#4
    STFE   F4,[sp,#-12]! ;save F4
    SUB    sp,sp,#32     ;working space
    LDR    ip,adEPS      ;(EPS)
    LDFS   F4,[ip]       ;EPS
    LDR    R4,com        ;set base for COMMON/TLSDIM/
    LDMIA  R4,{R5-R8}    ;M1,M,N,L
    CMP    R7,R6
    CMPLE  R5,R7
    BGT    err           ;skip if N>M or M1>N
    STR    R7,ier        ;IER = N
    MOV    ip,#1
lp1 CMP    ip,R7
    STRLE  ip,[R3],#4    ;IPIV(K) = K
    ADD    ip,ip,#1
    BLT    lp1           ;loop over K=1,N
    BGT    pt3           ;skip if N<1
    MOV    R9,#0         ;initialise K=0,N-1
    MOV    R5,R0         ;IST = (A(1))
lp2 LDMIA  R4,{ip,lr}    ;get M1,M
    SUBS   ip,ip,R9
    SUBLE  ip,lr,R9
    STR    ip,lv         ;LV = M-K or M1-K
    MVFS   F3,#0         ;PIV=0.0 (F3 not used by TLSMSQ)
    SUB    R5,R5,R7,LSL#2;IST = IST - N
    ADD    R6,R9,#1      ;initialise J=K+1,N
lp3 CMP    R9,#0
    LDRNE  lr,m1
    CMPNE  R9,lr
    BNE    TC1
    ADD    R0,R5,R7,LSL#2;(A(IST+N))
    ADR    R1,n          ;(N)
    ADR    R2,lv         ;(LV)
    BL     tlsmsq_       ;PIVT = TLSMSQ(A(IST+N),N,LV)
    LDR    R2,adAUX      ;restore (AUX)
    ADD    ip,R2,R6,LSL#2;(AUX(J+1))
    B      TC2
TC1 LDFS   F0,[R5]       ;A(IST)
    FMLS   F1,F0,F0      ;A(IST)*A(IST)
    ADD    ip,R2,R6,LSL#2;(AUX(J+1))
    LDFS   F0,[ip,#-4]   ;AUX(J)
    SUFS   F0,F0,F1      ;PIVT = AUX(J) - A(IST)*A(IST)
TC2 STFS   F0,[ip,#-4]   ;AUX(J) = PIVT
    FMLS   F1,F4,F0      ;EPS*PIVT
    CMF    F1,F3         ;IF(EPS.PIVT .GT. PIV) THEN
    MVFGTS F3,F0         ;  PIV = PIVT
    STRGT  R6,kpiv       ;  KPIV = J
    ADD    R5,R5,#4      ;IST = IST + 1
    ADD    R6,R6,#1      ;J = J + 1
    CMP    R6,R7
    BLE    lp3           ;loop over J=K+1,N
    ADD    R5,R5,R9,LSL#2;restore IST by adding K
    LDR    ip,kpiv
    SUBS   R3,ip,R9      ;I=KPIV-K
    LDRGT  lr,[R2,R9,LSL#2];AUX(K+1)
    SUBGT  ip,ip,#1
    LDRGT  R1,[R2,ip,LSL#2];AUX(KPIV)
    STRGT  R1,[R2,R9,LSL#2];AUX(K+1) = AUX(KPIV)
    STRGT  lr,[R2,ip,LSL#2];AUX(KPIV) = AUX(K+1)
    MOVGT  R0,R5         ;(A(IST))
    ADDGT  R1,R5,R3,LSL#2
    SUBGT  R1,R1,#4      ;(A(IST+I-1))
    ADRGT  R2,n          ;(N)
    LDRGT  ip,m
    SUBGT  ip,ip,R9      ;M-K
    STRGT  ip,mmk
    ADRGT  R3,mmk        ;(M-K)
    BLGT   tlswop_       ;CALL TLSWOP(A(IST),A(IST+I-1),N,M-K)
    MOV    R0,R5         ;(A(IST))
    ADR    R1,n          ;(N)
    ADR    R2,lv         ;(LV)
    ADR    R3,sig        ;(SIG)
    ADR    ip,beta
    STR    ip,arg5
    BL     tluk_         ;CALL TLUK(A(IST),N,LV,SIG,BETA)
    LDR    ip,lv
    CMP    ip,#0
    BEQ    err
    LDR    R2,adAUX      ;restore (AUX)
    CMP    R7,R8
    ADDGT  ip,R9,R7
    ADDLE  ip,R9,R8      ;K+K1
    LDR    lr,sig
    EOR    lr,lr,#8,4
    STR    lr,[R2,ip,LSL#2];AUX(K+K1+1) = -SIG
    SUB    ip,R7,R9      ;N-K
    SUB    ip,ip,#1
    STR    ip,nmk        ;N-K-1
    ADR    R1,lv
    ADR    R2,nmk
    ADR    R3,beta
    STMIA  sp,{R1-R3}
    MOV    R0,R5         ;(A(IST))
    ADD    R1,R5,#4      ;(A(IST+1))
    ADR    R2,n          ;(N)
    ADR    R3,n          ;(N)
    BL     tlstep_       ;CALL TLSTEP(A(IST),A(IST+1),N,N,LV,N-K-1,BETA)
    LDR    R1,adB        ;restore (B)
    MOV    R0,R5         ;(A(IST))
    MUL    ip,R9,R8      ;K*L
    ADD    R1,R1,ip,LSL#2;(B(K*L+1))
    ADR    R2,n          ;(N)
    ADR    R3,l          ;(L)
    STR    R3,arg6       ;(L)
    BL     tlstep_       ;CALL TLSTEP(A(IST),B(K*L+1),N,L,LV,L,BETA)
    LDR    R3,adPIV      ;restore (IPIV)
    LDR    R2,kpiv       ;KPIV
    SUB    R1,R2,#1      ;KPIV-1
    LDR    ip,[R3,R9,LSL#2]
    STR    ip,[R3,R1,LSL#2];IPIV(KPIV) = IPIV(K+1)
    STR    R2,[R3,R9,LSL#2];IPIV(K+1) = KPIV
    LDMIA  R4,{R2,R6}    ;get M1,M
    CMP    R9,R2
    CMPLT  R2,R6
    BGE    pt2           ;skip if K>=M1 or M1=M
    LDR    R1,adB        ;restore (B)
    LDFS   F3,sig        ;SIG
lp4 SUB    ip,R2,R9      ;I-K
    MUL    ip,R7,ip      ;(I-K)*N
    ADD    R3,R5,ip,LSL#2;(A(ID1)), ID1=IST+(I-K)*N
    LDFS   F2,[R3]       ;A(ID1)
    CMF    F2,#0
    BEQ    pt1
    FDVS   F2,F2,F3
    MNFS   F2,F2         ;H = -A(ID1)/SIG
    STFS   F2,[R3]       ;A(ID1) = H
    MOV    ip,R5         ;ID = IST
    SUB    lr,R7,R9      ;N-K
    SUBS   lr,lr,#1      ;J-count (N-K-1)
lp5 LDFGTS F0,[ip,#4]!   ;ID = ID + 1, A(ID)
    LDFGTS F1,[R3,#4]!   ;ID1 = ID1 + 1, A(ID1)
    FMLGTS F0,F0,F2      ;H*A(ID)
    SUFGTS F0,F1,F0
    STFGTS F0,[R3]       ;A(ID1) = A(ID1) - H*A(ID)
    SUBS   lr,lr,#1      ;J = J - 1
    BGT    lp5           ;loop over J
    MUL    R3,R2,R8      ;I*L
    ADD    R3,R1,R3,LSL#2;IB1 = (B(I*L+1))
    MUL    ip,R9,R8      ;K*L
    ADD    ip,R1,ip,LSL#2;IB  = (B(K*L+1))
    SUBS   lr,R8,#0      ;J-count (L)
lp6 LDFGTS F0,[ip],#4    ;B(IB), IB = IB + 1
    LDFGTS F1,[R3]       ;B(IB1)
    FMLGTS F0,F0,F2      ;H*B(IB)
    SUFGTS F0,F1,F0
    STFGTS F0,[R3],#4    ;B(IB1) = B(IB1) - H*B(IB), IB1 = IB1 + 1
    SUBS   lr,lr,#1      ;J = J - 1
    BGT    lp6           ;loop over J
pt1 ADD    R2,R2,#1      ;I = I + 1
    CMP    R2,R6
    BLT    lp4           ;loop over I=M1,M-1
pt2 LDR    R2,adAUX      ;restore (AUX)
    ADD    R5,R5,R7,LSL#2
    ADD    R5,R5,#4      ;IST = IST + N + 1
    ADD    R9,R9,#1      ;K = K + 1
    CMP    R9,R7
    BLT    lp2           ;loop over K=0,N-1
;       back substitution and back interchange
    CMP    R7,R8
    ADDGT  ip,R7,R7
    ADDLE  ip,R7,R8      ;K1+N
    ADD    R2,R2,ip,LSL#2;(AUX(K1+N+1))
    LDFS   F0,[R2,#-4]!  ;(AUX(K1+N))
    FRDS   F3,F0,#1      ;PIV = 1.0/AUX(K1+N)
    MUL    lr,R7,R8      ;N*L
    LDR    R1,adB
    LDR    R3,adX        ;(X)
    ADD    ip,R1,lr,LSL#2;(B(N*L+1))
    ADD    lr,R3,lr,LSL#2;(X(N*L+1))
    MOV    R6,R8         ;K-count (L)
lp7 LDFS   F1,[ip,#-4]!
    FMLS   F1,F1,F3
    STFS   F1,[lr,#-4]!  ;X(JK) = PIV*B(JK), JK = JK - 1
    SUBS   R6,R6,#1
    BGT    lp7
    SUBS   R9,R7,#1      ;initialise J=N-1,1,-1
    BLE    pt3           ;skip if N<2
    MUL    ip,R7,R7      ;N*N
    LDR    R0,adA        ;(A(1))
    ADD    R0,R0,ip,LSL#2;(A(JST)), JST = N*N+1
    LDR    R6,adPIV      ;(IPIV)
    SUB    R6,R6,#4      ;(IPIV(0))
lp8 SUB    R0,R0,R7,LSL#2
    SUB    R0,R0,#4      ;JST = JST - N - 1
    LDFS   F0,[R2,#-4]!  ;AUX(K1+J)
    STR    R2,[sp]       ;save (AUX(K1+J))
    FRDS   F3,F0,#1      ;PIV = 1.0/AUX(K1+J)
    LDR    R2,[R6,R9,LSL#2];IPIV(J)
    SUB    R2,R2,R9      ;IPIV(J) - J
    MUL    R2,R8,R2      ;ID = (IPIV(J)-J)*L
    SUB    R5,R9,#1
    MUL    R5,R8,R5      ;KST = (J-1)*L
    MOV    ip,R8         ;K-count (L)
lp9 ADD    lr,R1,R5,LSL#2
    LDFS   F0,[lr]       ;H = B(KST)
    LDR    R3,adX        ;(X)
    ADD    R3,R3,R5,LSL#2;(X(II)), II=KST
    MOV    lr,R0         ;(A(MST)), MST=JST
    SUB    R4,R7,R9      ;I count (N-J)
lpa LDFS   F1,[lr],#4    ;A(MST), MST = MST + 1
    ADD    R3,R3,R8,LSL#2;II = II + L
    LDFS   F2,[R3]       ;X(II)
    FMLS   F2,F2,F1
    SUBS   R4,R4,#1
    SUFS   F0,F0,F2      ;H = H - A(I)*X(II)
    BGT    lpa           ;loop over I
    FMLS   F0,F0,F3      ;PIV*H
    LDR    R3,adX        ;restore (X)
    ADD    R3,R3,R5,LSL#2;(X(KST))
    LDR    lr,[R3,R2,LSL#2]
    STR    lr,[R3],R2,LSL#2;X(KST) = X(KST+ID)
    STFS   F0,[R3]       ;X(KST+ID) = PIV*H
    ADD    R5,R5,#1      ;KST = KST + 1
    SUB    ip,ip,#1      ;K = K - 1
    BGT    lp9           ;loop over K
    LDR    R2,[sp]       ;restore (AUX(K1+J))
    SUBS   R9,R9,#1      ;J = J - 1
    BGT    lp8           ;loop over J=N-1,1,-1
;        computation of least squares
    LDR    R4,com        ;restore R4
pt3 MUL    R5,R7,R8      ;IST = N*L
    ADD    R5,R1,R5,LSL#2;(B(IST+1))
    LDR    R6,m
    SUB    R0,R6,R7      ;M-N
    STR    R0,mmn        ;store it
    LDR    R9,adAUX
lpb SUBS   R8,R8,#1
    BLT    ret
    MOV    R0,R5         ;B(IST+1)
    ADR    R1,l          ;(L)
    ADR    R2,mmn        ;(M-N)
    BL     tlsmsq_       ;CALL TLSMSQ(B(IST+1),L,M-N)
    STFS   F0,[R9],#4
    ADD    R5,R5,#4      ;IST = IST + 1
    B      lpb           ;loop L times
ret LDFE   F4,[sp,#32]   ;restore F4
    LDMDB  fp,{R4-R9,fp,sp,pc}  ;return
;       problem encountered
err MVN    ip,#1000
    STR    ip,ier        ;IER=-1001
    B      ret
com DCD    tlsdim__      ;pointer to COMMON/TLSDIM/
      ^  -52,fp
adA   #    4     ;(A(1))
adB   #    4     ;(B(1))
adAUX #    4     ;(AUX(1))
adPIV #    4     ;(IPIV(1))
      ^    4,fp
adEPS #    4     ;(EPS)
adX   #    4     ;(X(1))
      ^    0,sp
arg5  #    4     ;3 args for TLSTEP
arg6  #    4
arg7  #    4
lv    #    4     ;LV
kpiv  #    4     ;KPIV
beta  #    4     ;BETA
sig   #    4     ;SIG
nmk   #    4     ;N-K
mmk   EQU  beta  ;M-K
mmn   EQU  lv    ;M-N
    END
;
    TTL   TLSMSQ
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R0  RN     0
R1  RN     1
R2  RN     2
F0  FN     0
F1  FN     1
    AREA   |C$$code|,CODE,READONLY
    EXPORT tlsmsq_;(B,L,M) (part of TLS)
    DCB    "tlsmsq_",0,8,0,0,255
tlsmsq_
    MOV    ip,sp
    STMDB  sp!,{R0-R2,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R1,[R1]       ;L
    LDR    R2,[R2]       ;M
    MVFD   F0,#0         ;TLSMSQ = 0.0
lp1 SUBS   R2,R2,#1
    LDFGES F1,[R0]       ;B(IB)
    FMLGES F1,F1,F1
    ADDGE  R0,R0,R1,LSL#2;IB = IB + L
    ADFGED F0,F0,F1      ;TLSMSQ = TLSMSQ + B(IB)*B(IB)
    BGT    lp1
    LDMDB  fp,{fp,sp,pc}  ;return
    END
;
    TTL   TLSTEP
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
F0  FN     0
F1  FN     1
F2  FN     2
F3  FN     3
    AREA   |C$$code|,CODE,READONLY
    EXPORT tlstep_;(A,B,IASEP,IBSEP,NR,NC,BETA) (part of TLS)
    DCB    "tlstep_",0,8,0,0,255
tlstep_
    MOV    ip,sp
    STMDB  sp!,{R0-R6,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDMIB  fp,{R4-R6}    ;(NR),(NC),(BETA)
    LDR    R4,[R4]       ;NR
    LDR    R5,[R5]       ;NC
    CMP    R4,#0
    CMPGT  R5,#0
    LDMLEDB fp,{R4-R6,fp,sp,pc}  ;return if NR or NC not >0
    LDFS   F3,[R6]       ;BETA
    LDR    R2,[R2]       ;IASEP
    LDR    R3,[R3]       ;IBSEP
lp1 MVFD   F2,#0         ;H = 0.0
    MOV    ip,R0         ;JA = 1
    MOV    lr,R1         ;JB = J
    MOV    R6,R4         ;I-count (NR)
lp2 LDFS   F0,[ip]       ;A(JA)
    LDFS   F1,[lr]       ;B(JB)
    ADD    ip,ip,R2,LSL#2;JA = JA + IASEP
    FMLS   F1,F1,F0      ;A(JA)*B(JB)
    ADD    lr,lr,R3,LSL#2;JB = JB + IBSEP
    SUBS   R6,R6,#1      ;I = I - 1
    ADFD   F2,F2,F1      ;H = H + A(JA)*B(JB)
    BGT    lp2           ;loop over I
    MUFD   F2,F2,F3      ;H = H * BETA
    MOV    ip,R0         ;JA = 1
    MOV    lr,R1         ;JB = J
    MOV    R6,R4         ;I-count (NR)
lp3 LDFS   F0,[ip]       ;A(JA)
    LDFS   F1,[lr]       ;B(JB)
    FMLS   F0,F0,F2      ;H*A(JA)
    ADD    ip,ip,R2,LSL#2;JA = JA + IASEP
    SUFS   F1,F1,F0
    SUBS   R6,R6,#1      ;I = I - 1
    STFS   F1,[lr]       ;B(JB) = B(JB) - H*A(JA)
    ADD    lr,lr,R3,LSL#2;JB = JB + IBSEP
    BGT    lp3           ;loop over I
    ADD    R1,R1,#4      ;"J = J + 1"
    SUBS   R5,R5,#1
    BGT    lp1           ;loop NC times
    LDMDB  fp,{R4-R6,fp,sp,pc}  ;return
    END
;
    TTL   TLSWOP
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 tlswop_;(A,AD,N,NR) (part of TLS)
    DCB    "tlswop_",0,8,0,0,255
tlswop_
    MOV    ip,sp
    STMDB  sp!,{R0-R3,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R2,[R2]       ;N
    LDR    R3,[R3]       ;NR
lp1 SUBS   R3,R3,#1
    LDRGE  ip,[R0]
    LDRGE  lr,[R1]
    STRGE  ip,[R1],R2,LSL#2
    STRGE  lr,[R0],R2,LSL#2
    BGT    lp1
    LDMDB fp,{fp,sp,pc}  ;return
    END
;
    TTL   TLUK
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
F0  FN     0
F1  FN     1
    AREA   |C$$code|,CODE,READONLY
    EXPORT tluk_;(A,IASEP,NR,SIG,BETA) (part of TLS)
    DCB    "tluk_",0,0,0,8,0,0,255
tluk_
    MOV    ip,sp
    STMDB  sp!,{R0-R3,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R1,[R1]      ;IASEP
    LDR    R2,[R2]      ;NR
    MOV    ip,#0        ;LL = 0
    SUBS   lr,R2,#1     ;I-count (NR)
    MVFD   F0,#0        ;SIG = 0.0
    BLT    pt1
lp1 LDFS   F1,[R0]      ;A(JA)
    CMF    F1,#0
    FMLNES F1,F1,F1
    SUBNE  ip,R2,lr     ;set LL to last non-zero A(IJ)
    ADFNED F0,F0,F1     ;sum A(JA)**2
    ADD    R0,R0,R1,LSL#2
    SUBS   lr,lr,#1
    BGE    lp1          ;loop over I
pt1 LDMIA  sp,{R0-R2}
    STR    ip,[R2]      ;overwrite NR with LL
    SQTS   F0,F0
    LDFS   F1,[R0]      ;A(1)
    CMF    F1,#0
    MNFLTS F0,F0        ;SIG = SIGN(SQRT(SIG),A(1))
    STFS   F0,[R3]      ;store SIG
    CMP    ip,#0
    LDMEQDB fp,{fp,sp,pc}  ;return if no terms
    ADFS   F1,F0,F1     ;BETA
    STFS   F1,[R0]      ;A(1)=BETA
    FMLS   F1,F1,F0
    RDFS   F1,F1,#1
    LDR    R0,[fp,#4]   ;(BETA)
    STFS   F1,[R0]      ;store BETA
    LDMDB  fp,{fp,sp,pc}  ;return
    END
;
    TTL    TMREAD
R0  RN 0
R1  RN 1
R2  RN 2
R3  RN 3
fp  RN 11
ip  RN 12
sp  RN 13
lr  RN 14
pc  RN 15
OS_ReadLine EQU &0E
OS_WriteN   EQU &46
    AREA   |C$$code|,CODE,READONLY
    EXPORT tmread_;(MAXCH,CHLINE,NCH,ISTAT) read line from stangard input
    DCB    "tmread_",0,8,0,0,255
tmread_
    MOV    ip,sp
    STMDB  sp!,{R0-R3,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R1,[R0]       ;buffer size
    LDR    R0,[sp,#4]    ;buffer pointer
    MOV    R2,#128,2     ;clear C and accept ASCII 32
    MOV    R3,#126       ;to ASCII 126
    SWI    OS_ReadLine
    MOVCS  R0,#-1
    MOVCC  R0,#0
    LDR    R2,[sp,#8]
    LDR    R3,[sp,#12]
    STR    R1,[R2]       ;store NCH
    STR    R0,[R3]       ;store ISTAT
    LDMDB  fp,{fp,sp,pc} 
;
    EXPORT tmpro_;(TEXT) sends prompt to screen
    EXPORT tminit_;does nothing
tmpro_
    SWI    OS_WriteN     ;send TEXT to screen (no CR/LF)
tminit_
    MOV    pc,lr
    END
;
    TTL    TRACE
;                     from utils library
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R6  RN     6
R5  RN     5
R4  RN     4
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
;
    AREA   Utils_,CODE,READONLY
    EXPORT tracep_;(N,NAME,LB,LC) name, (beginning) and (call) of Nth traceback
    DCB    "tracep_",0,8,0,0,255
tracep_
    MOV    ip,sp
    STMDB  sp!,{R4-R6,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R4,[fp,#4]    ;length of NAME
    LDR    R0,[R0]       ;N
    MOV    R5,fp         ;current frame pointer
lp1 LDR    R6,[R5]       ;program counter at entry
    BIC    R6,R6,#255,6  ;clear non-PSR bits
lp2 LDR    ip,[R6,#-4]!
    AND    lr,ip,#255,8
    CMP    lr,#255,8
    BNE    lp2           ;search for introduction
    AND    ip,ip,#&FC
    SUB    R6,R6,ip      ;beginning of introduction
    LDR    ip,[R5,#-4]
    BIC    ip,ip,#255,6  ;clear all but pc
    CMP    ip,#&31,14
    LDRGE  R5,[R5,#-12]  ;next frame pointer
    SUBS   R0,R0,#1
    BLT    pt1           ;found entry
    LDR    ip,[R6]       ;get beginning of name
    LDR    lr,main
    SUBS   lr,lr,ip
    LDRNE  R5,[R5,#-12]  ;next frame pointer
    BNE    lp1
    STR    lr,[R2]       ;flag 'end of trace'
    LDMDB  fp,{R4-R6,fp,sp,pc}  ;return
pt1;    found required entry
    STR    R6,[R2]       ;store location of beginning
    LDR    ip,[R5,#-4]
    SUB    ip,ip,#4
    BIC    ip,ip,#255,6  ;clear all but pc
    STR    ip,[R3]       ;store where called from
lp3 LDRB   lr,[R6],#1
    CMP    lr,#"a"
    SUBGE  lr,lr,#32
    CMP    lr,#0
    CMPNE  lr,#"_"
    STRNEB lr,[R1],#1    ;transfer name
    SUBNES R4,R4,#1
    BNE    lp3
    MOV    lr,#" "
lp4 SUBS   R4,R4,#1
    STRGEB lr,[R1],#1    ;blank fill
    BGT    lp4
    LDMDB  fp,{R4-R6,fp,sp,pc}  ;return
main DCB   "MAIN"
    END
;
    TTL    TRACEQ
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
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 traceq_;(LUN,N) print traceback of depth N
    IMPORT io_start_we
    IMPORT io_end
    IMPORT tracep_
    IMPORT io_do_single
    IMPORT io_do_array
    DCB    "traceq_",0,8,0,0,255
traceq_
    MOV     ip,sp
    STMDB   sp!,{R0-R1,R4-R6,fp,ip,lr,pc}
    SUB     fp,ip,#4
    LDR     R6,[R1]      ;N
    CMP     R6,#0
    LDMLEDB fp,{R4-R6,fp,sp,pc} ;return if N<=0
    LDR     R4,[R0]      ;LUN
    CMP     R4,#0
    MOVLE   R4,#6        ;default stream
    SUB     sp,sp,#24    ;reserve space for I, NAME and addresses
    ADR     R1,format101
    MOV     R0,R4        ;stream #
    BL      io_start_we  ;print initial message
    BL      io_end
    MOV     R5,#1        ;I=1
lp1 STR     R5,[sp]      ;store it
    MOV     R0,sp        ;address of I
    ADD     R1,sp,#4     ;address for NAME
    ADD     R2,sp,#16    ;address for IADR(1)
    ADD     R3,sp,#20    ;address for IADR(2)
    MOV     ip,#12       ;length of NAME
    STR     ip,[sp,#-4]! ;store on stack
    BL      tracep_
    ADD     sp,sp,#4     ;restore stack
    LDR     R0,[sp,#16]  ;IADR(1)
    CMP     R0,#0
    BLE     pt1
    ADR     R1,format102
    MOV     R0,R4
    BL      io_start_we
    ADD     R0,sp,#4
    MOV     R1,#12
    BL      io_do_single ;print NAME
    ADD     R1,sp,#16
    MOV     R2,#4
    MOV     R0,#2
    BL      io_do_array  ;print IADR
    BL      io_end
    ADD     R5,R5,#1
    CMP     R5,R6
    BLE     lp1
pt1 ADR     R1,format103
    MOV     R0,R4
    BL      io_start_we
    BL      io_end
    LDMDB   fp,{R4-R6,fp,sp,pc} 
format101
    DCB     "(/' Routine         at    called from'/)",0,0,0,0
format102
    DCB     "(1X,A12,2Z8)",0,0,0,0
format103
    DCB     "(/' End of trace-back'/)",0,0,0,0
    END
;
    TTL   TRAAT
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
F0  FN     0
F1  FN     1
F2  FN     2
    AREA   |C$$code|,CODE,READONLY
    EXPORT traat_;(A,S,M,N) S(sym M) =  A*A'(MxN)
    DCB    "traat_",0,0,8,0,0,255
traat_
    MOV    ip,sp
    STMDB  sp!,{R0-R6,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R2,[R2]       ;M (dimension of S)
    LDR    R3,[R3]       ;N
    MOV    ip,R0         ;initialise IA
    MOV    R4,R2         ;I count (M)
l10 MOV    lr,R0         ;initialise IAT
    SUB    R5,R2,R4      ;J count (M-I+1)
l20 MVFD   F0,#0         ;SUM = 0.0
    MOV    R6,R3         ;K count (1,N)
l30 LDFS   F1,[ip],#4    ;A(IA), IA = IA + 1
    LDFS   F2,[lr],#4    ;A(IAT), IAT = IAT + 1
    FMLS   F1,F1,F2
    SUBS   R6,R6,#1
    ADFD   F0,F0,F1      ;SUM = SUM + A(IA)*A(IAT)
    BGT    l30           ;loop over K (N times)
    STFS   F0,[R1],#4    ;S(IS) = SUM, IS = IS + 1
    SUBS   R5,R5,#1
    SUBGE  ip,ip,R3,LSL#2;restore IA
    BGE    l20           ;loop over J
    SUBS   R4,R4,#1
    BGT    l10           ;loop over I
    LDMDB  fp,{R4-R6,fp,sp,pc} ;return
    END
;
    TTL   TRAL
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
F1  FN     1
F2  FN     2
    AREA   |C$$code|,CODE,READONLY
    EXPORT tral_;(A,V,B,M,N) B(MxN) = A(MxN)*V(lower tri N)
    DCB    "tral_",0,0,0,8,0,0,255
tral_
    MOV    ip,sp
    STMDB  sp!,{R0-R7,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R3,[R3]       ;M
    LDR    R4,[ip]
    LDR    R4,[R4]       ;N (dimension of V)
l10 MOV    R5,R1         ;INDV
    MOV    R6,#1         ;inititalise J=1,N
l20 MOV    ip,R0         ;initialise IA
    MOV    lr,R5         ;initialise IV
    MVFD   F0,#0         ;SUM = 0.0
    MOV    R7,R6         ;initialise K = J,N
l30 LDFS   F1,[ip],#4    ;A(IA), IA = IA + 1
    LDFS   F2,[lr]       ;V(IV)
    ADD    lr,lr,R7,LSL#2;IV = IV + K
    FMLS   F2,F1,F2
    ADD    R7,R7,#1      ;K = K + 1
    CMP    R7,R4
    ADFD   F0,F0,F2      ;SUM = SUM + A(IA)*V(IV)
    BLE    l30           ;loop over K=J,N
    STFS   F0,[R2],#4    ;B(IB) = SUM, IB = IB + 1
    ADD    R0,R0,#4      ;increment base of IA
    ADD    R6,R6,#1      ;J = J + 1
    ADD    R5,R5,R6,LSL#2;INDV = INDV + J + 1
    CMP    R6,R4
    BLE    l20           ;loop over J=1,N
    SUBS   R3,R3,#1
    BGT    l10           ;loop over M
    LDMDB  fp,{R4-R7,fp,sp,pc} ;return
    END
;
    TTL   TRALT
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
F0  FN     0
F1  FN     1
F2  FN     2
    AREA   |C$$code|,CODE,READONLY
    EXPORT tralt_;(A,V,B,M,N) B(MxN) = A(MxN)*V'(lower tri N)
    DCB    "tralt_",0,0,8,0,0,255
tralt_
    MOV    ip,sp
    STMDB  sp!,{R0-R6,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R3,[R3]       ;M
    LDR    R4,[ip]
    LDR    R4,[R4]       ;N (dimension of V)
    MUL    ip,R4,R3      ;M*N
    ADD    R0,R0,ip,LSL#2;IA1 = ( A(M*N+1) )
    ADD    R2,R2,ip,LSL#2;IB1 = ( B(M*N+1) )
    MLA    R5,R4,R4,R4   ;N*N+N
    ADD    R1,R1,R5,LSL#1;INDV+1 = ( V((N*N+N)/2+1) )
l10 MOV    R5,R4         ;IR count (N)
    MOV    ip,R1         ;IV = INDV
l20 MVFD   F0,#0         ;SUM = 0.0
    MOV    lr,R0         ;initialise IA
    MOV    R6,R5         ;K count (IR)
l30 LDFS   F1,[ip,#-4]!  ;IV = IV - 1, V(IV)
    LDFS   F2,[lr,#-4]!  ;IA = IA - 1, A(IA)
    FMLS   F1,F1,F2
    SUBS   R6,R6,#1
    ADFD   F0,F0,F1      ;SUM = SUM + A(IA)*V(IV)
    BGT    l30           ;loop over K
    STFS   F0,[R2,#-4]!  ;IB = IB - 1, B(IB) = SUM
    SUB    R0,R0,#4      ;IA base = IA base -1
    SUBS   R5,R5,#1
    BGT    l20           ;loop over IR
    SUBS   R3,R3,#1
    BGT    l10           ;loop over IC (M times)
    LDMDB  fp,{R4-R6,fp,sp,pc} ;return
    END
;
    TTL   TRAS
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
F0  FN     0
F1  FN     1
F2  FN     2
    AREA   |C$$code|,CODE,READONLY
    EXPORT tras_;(A,R,C,M,N) C(MxN) =  A(MxN) * R(sym N)
    DCB    "tras_",0,0,0,8,0,0,255
tras_
    MOV    ip,sp
    STMDB  sp!,{R0-R8,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R3,[R3]       ;M
    LDR    R4,[ip]
    LDR    R4,[R4]       ;N (dimension of R)
    MOV    R5,#0         ;initialise I = 0,N-1
l10 ADD    R1,R1,R5,LSL#2;INDR = INDR + I
    MOV    ip,R0         ;initialise IA
    ADD    R6,R2,R5,LSL#2;initialise IC
    MOV    R7,R3         ;J count (M)
l20 MOV    lr,R1         ;IR = INDR
    MVFD   F0,#0         ;SUM = 0.0
    MOV    R8,#0         ;initialise K = 0,N-1
l30 LDFS   F1,[ip],#4    ;A(IA), IA = IA + 1
    LDFS   F2,[lr],#4    ;R(IR), IR = IR + 1
    CMP    R8,R5
    ADDGE  lr,lr,R8,LSL#2;(IR = IR + K)
    FMLS   F1,F1,F2
    ADD    R8,R8,#1      ;K = K + 1
    CMP    R8,R4
    ADFD   F0,F0,F1      ;SUM = SUM + A(IA)*R(IR)
    BLT    l30           ;loop over K = 0, N-1
    STFS   F0,[R6]       ;C(IC) = SUM
    ADD    R6,R6,R4,LSL#2;IC = IC + N
    SUBS   R7,R7,#1
    BGE    l20           ;loop over J
    ADD    R5,R5,#1
    CMP    R5,R4
    BLT    l10           ;loop over I = 0,N-1
    LDMDB  fp,{R4-R8,fp,sp,pc} ;return
    END
;
    TTL   TRASAT
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
F0  FN     0
F1  FN     1
F2  FN     2
    AREA   |C$$code|,CODE,READONLY
    EXPORT trasat_;(A,S,R,M,N) R(sym M) =  A(MxN)* S(sym N) * A'
    DCB    "trasat_",0,8,0,0,255
trasat_
    MOV    ip,sp
    STMDB  sp!,{R0-R8,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R3,[R3]       ;M
    LDR    ip,[ip]
    LDR    R4,[ip]       ;N
    MLA    ip,R3,R3,R3   ;M*M+M
    MOV    R5,#0         ;initialize I = 0,N-1
zer SUBS   ip,ip,#2
    STRGE  R5,[R2,ip,LSL#1];zero R
    BGT    zer
l10 ADD    R1,R1,R5,LSL#2;INDS = INDS + I
    MOV    ip,R0         ;IA
    MOV    R6,R2         ;IR
    MOV    R7,R3         ;J count (M)
l20 MOV    lr,R1         ;IS = INDS
    MVFD   F0,#0         ;SUM = 0.0
    MOV    R8,#0         ;initialise K = 0,N-1
l30 LDFS   F2,[ip],#4    ;A(IA), IA = IA + 1
    LDFS   F1,[lr],#4    ;S(IS), IS = IS + 1
    CMP    R8,R5
    ADDGE  lr,lr,R8,LSL#2;(IS = IS + K)
    FMLS   F1,F1,F2
    ADD    R8,R8,#1      ;K = K + 1
    CMP    R8,R4
    ADFD   F0,F0,F1      ;SUM = SUM + S(IS)*A(IA)
    BLT    l30           ;loop over K=0,N-1
    ADD    lr,R0,R5,LSL#2;IAA = I + 1
    SUB    R8,R3,R7      ;L count (M-J+1)
l40 LDFS   F2,[lr]       ;A(IAA)
    LDFS   F1,[R6]       ;R(IR)
    FMLS   F2,F2,F0      ;SUM*A(IAA)
    ADD    lr,lr,R4,LSL#2;IAA = IAA + N
    ADFS   F1,F1,F2
    SUBS   R8,R8,#1
    STFS   F1,[R6],#4    ;R(IR) = R(IR) + SUM*A(IAA), IR = IR + 1
    BGE    l40           ;loop M-J+1 times
    SUBS   R7,R7,#1
    BGT    l20           ;loop M times
    ADD    R5,R5,#1      ;I = I + 1
    CMP    R5,R4
    BLT    l10           ;loop over I = 0,N-1
    LDMDB  fp,{R4-R8,fp,sp,pc} ;return
    END
;
    TTL   TRATA
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
F1  FN     1
F2  FN     2
    AREA   |C$$code|,CODE,READONLY
    EXPORT trata_;(A,R,M,N) R(sym M) =  A*A'(NxM)
    DCB    "trata_",0,0,8,0,0,255
trata_
    MOV    ip,sp
    STMDB  sp!,{R0-R7,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R2,[R2]       ;M (dimension of S)
    LDR    R3,[R3]       ;N
    MLA    ip,R2,R2,R2   ;M*M+M
    ADD    R1,R1,ip,LSL#1;IR = (M*M+M)/2 +1
    SUB    R4,R2,#1      ;I count (M)
l10 MOV    R5,R4         ;J count (I)
l20 ADD    ip,R0,R4,LSL#2;IA
    ADD    lr,R0,R5,LSL#2;IAT
    MVFD   F0,#0         ;SUM
    MOV    R7,R3         ;K count (N)
l30 LDFS   F1,[ip]       ;A(IA)
    ADD    ip,ip,R2,LSL#2;IA = IA + M
    LDFS   F2,[lr]       ;A(IAT)
    ADD    lr,lr,R2,LSL#2;IAT = IAT + M
    FMLS   F1,F1,F2
    SUBS   R7,R7,#1
    ADFD   F0,F0,F1      ;SUM = SUM + A(IA)*A(IAT)
    BGT    l30           ;loop over K (N times)
    STFS   F0,[R1,#-4]!  ;IR = IR - 1, R(IR) = SUM
    SUBS   R5,R5,#1
    BGE    l20           ;loop over J
    SUBS   R4,R4,#1
    BGE    l10           ;loop over I
    LDMDB  fp,{R4-R7,fp,sp,pc} ;return
    END
;
    TTL   TRATS
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
F0  FN     0
F1  FN     1
F2  FN     2
    AREA   |C$$code|,CODE,READONLY
    EXPORT trats_;(B,R,C,M,N) C(MxN) =  B'(MxN) * R(sym N)
    DCB    "trats_",0,0,8,0,0,255
trats_
    MOV    ip,sp
    STMDB  sp!,{R0-R8,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R3,[R3]       ;M
    LDR    R4,[ip]
    LDR    R4,[R4]       ;N (dimension of R)
    MOV    R5,#0         ;initialise I = 0,N-1
l10 ADD    R1,R1,R5,LSL#2;INDR = INDR + I
    ADD    R6,R2,R5,LSL#2;initialise IC
    MOV    R7,#0         ;initialise J = "1,M"
l20 MOV    lr,R1         ;IR = INDR
    ADD    ip,R0,R7,LSL#2;initialise IB
    MVFD   F0,#0         ;SUM = 0.0
    MOV    R8,#0         ;initialise K = 0,N-1
l30 LDFS   F1,[ip]       ;B(IB)
    LDFS   F2,[lr],#4    ;R(IR), IR = IR + 1
    CMP    R8,R5
    ADDGE  lr,lr,R8,LSL#2;(IR = IR + K)
    FMLS   F1,F1,F2
    ADD    ip,ip,R3,LSL#2;IB = IB + M
    ADD    R8,R8,#1      ;K = K + 1
    CMP    R8,R4
    ADFD   F0,F0,F1      ;SUM = SUM + B(IB)*R(IR)
    BLT    l30           ;loop over K = 0, N-1
    STFS   F0,[R6]       ;C(IC) = SUM
    ADD    R6,R6,R4,LSL#2;IC = IC + N
    ADD    R7,R7,#1      ;J = J + 1
    CMP    R7,R3
    BLT    l20           ;loop over J = 0, M-1
    ADD    R5,R5,#1      ;I = I + 1
    CMP    R5,R4
    BLT    l10           ;loop over I = 0,N-1
    LDMDB  fp,{R4-R8,fp,sp,pc} ;return
    END
;
    TTL   TRATSA
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
F2  FN     2
    AREA   |C$$code|,CODE,READONLY
    EXPORT tratsa_;(B,S,R,M,N) R(sym M) =  B' * S(sym N) * B(NxM)
    DCB    "tratsa_",0,8,0,0,255
tratsa_
    MOV    ip,sp
    STMDB  sp!,{R0-R9,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R3,[R3]       ;M
    LDR    ip,[ip]
    LDR    R4,[ip]       ;N
    MLA    ip,R3,R3,R3   ;M*M+M
    MOV    R5,#0         ;initialize I = 0,N-1
zer SUBS   ip,ip,#2
    STRGE  R5,[R2,ip,LSL#1];zero R
    BGT    zer
    MOV    R9,R0         ;initialise IBB
l10 ADD    R1,R1,R5,LSL#2;INDS = INDS + I
    MOV    R6,R2         ;initialise IR
    MOV    R7,#0         ;initialize J = "1,M"
l20 MOV    ip,R1         ;IS = INDS
    ADD    lr,R0,R7,LSL#2;IB = J
    MVFD   F0,#0         ;SUM = 0.0
    MOV    R8,#0         ;initialize K = 0,N-1
l30 LDFS   F1,[lr]       ;B(IB)
    LDFS   F2,[ip],#4    ;S(IS), IS = IS + 1
    ADD    lr,lr,R3,LSL#2;IB = IB + M
    CMP    R8,R5
    ADDGE  ip,ip,R8,LSL#2;(IS = IS + K)
    FMLS   F1,F1,F2
    ADD    R8,R8,#1      ;K = K + 1
    CMP    R8,R4
    ADFD   F0,F0,F1      ;SUM = SUM + S(IS)*B(IB)
    BLT    l30           ;loop over K=0,N-1
    MOV    lr,R9         ;IB = IBB
    MOV    R8,R7         ;K count (=J)
l40 LDFS   F1,[lr],#4    ;B(IB), IB = IB + 1
    LDFS   F2,[R6]       ;R(IR)
    FMLS   F1,F1,F0
    ADFS   F2,F2,F1
    SUBS   R8,R8,#1
    STFS   F2,[R6],#4    ;R(IR) = R(IR) + SUM*B(IB), IR = IR + 1
    BGE    l40           ;loop J times
    ADD    R7,R7,#1      ;J = J + 1
    CMP    R7,R3
    BLT    l20           ;loop over J = "1,M"
    ADD    R9,R9,R3,LSL#2;IBB = IBB + M
    ADD    R5,R5,#1      ;I = I + 1
    CMP    R5,R4
    BLT    l10           ;loop over I = 0,N-1
    LDMDB  fp,{R4-R9,fp,sp,pc} ;return
    END
;
    TTL   TRCHLU
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
F1  FN     1
F2  FN     2
F3  FN     3
    AREA   |C$$code|,CODE,READONLY
    EXPORT trchlu_;(A,B,N) Choleski decompose A(sym) to B'B(lower tri)
    DCB    "trchlu_",0,8,0,0,255
trchlu_
    MOV    ip,sp
    STMDB  sp!,{R0-R2,R4-R7,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R2,[R2]       ;N
    MOV    R3,#0         ;initialise I=0,N-1
l10 MOV    R4,R0         ;(A(KPIV))
    MOV    R5,R1         ;(B(KPIV))
    LDFS   F0,[R0]       ;R = A(IPIV)
    MOV    R6,R3         ;J = I
l60 MVFD   F1,#0         ;SUM = 0.0
    CMP    R3,#0
    BEQ    l40
    CMF    F0,#0
    BEQ    l42
    MOV    ip,R1         ;ID = IPIV
    MOV    lr,R5         ;KD = KPIV
    MOV    R7,R3         ;K-count = I
l30 LDFS   F2,[ip,#-4]!  ;ID=ID-1, B(ID)
    LDFS   F3,[lr,#-4]!  ;KD=KD-1,B(KD)
    FMLS   F2,F2,F3
    SUBS   R7,R7,#1      ;K=K-1
    ADFD   F1,F1,F2      ;SUM = SUM + B(ID)*B(KD)
    BGT    l30           ;loop I times
l40 LDFS   F2,[R4]
    SUFD   F1,F2,F1      ;SUM = A(KPIV) - SUM
l42 CMP    R3,R6         ;is I < J?
    MUFLTD F1,F1,F0
    SQTGED F1,F1
    CMFGE  F0,#0
    RDFGTD F0,F1,#1      ;IF(R.GT.0) R=1/SQRT(SUM)
    STFS   F1,[R5]       ;store B(KPIV)
    ADD    R6,R6,#1      ;J= J + 1
    ADD    R5,R5,R6,LSL#2;(B(KPIV)) = (B(KPIV)) + J
    ADD    R4,R4,R6,LSL#2;(A(KPIV)) = (A(KPIV)) + J
    CMP    R6,R2
    BLT    l60           ;loop while J < N
    ADD    R3,R3,#1      ;I = I + 1
    ADD    ip,R3,#1      ;I+1
    ADD    R0,R0,ip,LSL#2;(A(IPIV)) = (A(IPIV)) + I + 1
    ADD    R1,R1,ip,LSL#2;(B(IPIV)) = (B(IPIV)) + I + 1
    CMP    R3,R2
    BLT    l10           ;loop while I < N
    LDMDB  fp,{R4-R7,fp,sp,pc} ;return
    END
;
    TTL   TRCHUL
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
F0  FN     0
F1  FN     1
F2  FN     2
F3  FN     3
    AREA   |C$$code|,CODE,READONLY
    EXPORT trchul_;(A,B,N) Choleski decompose A(sym) to BB'(lower tri)
    DCB    "trchul_",0,8,0,0,255
trchul_
    MOV    ip,sp
    STMDB  sp!,{R0-R2,R4-R6,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R2,[R2]       ;N
    MLA    R3,R2,R2,R2   ;N*N+N = 2*KPIV
    ADD    R0,R0,R3,LSL#1;( A(KPIV+1) )
    ADD    R1,R1,R3,LSL#1;( B(KPIV+1) )
    MOV    R3,R2         ;initialise I=N,1,-1
l10 SUB    R4,R1,#4      ;(B(IPIV))
    LDFS   F0,[R0,#-4]   ;R = A(KPIV)
    MOV    R6,R3         ;initialize J=I,1,-1
l20 MVFD   F1,#0         ;SUM = 0
    CMP    R3,R2
    BEQ    l40           ;skip if I=N
    CMF    F0,#0
    BEQ    l42           ;skip if R=0
    MOV    R5,R3         ;NSTEP = I
    MOV    ip,R4         ;ID = IPIV
    SUB    lr,R1,#4      ;KD = KPIV
l30 ADD    ip,ip,R5,LSL#2;ID = ID + NSTEP
    LDFS   F2,[ip]       ;B(ID)
    ADD    lr,lr,R5,LSL#2;KD = KD + NSTEP
    LDFS   F3,[lr]       ;B(KD)
    FMLS   F2,F2,F3
    ADD    R5,R5,#1      ;NSTEP = NSTEP + 1
    CMP    R5,R2
    ADFD   F1,F1,F2      ;SUM = SUM + B(ID)*B(KD)
    BLT    l30           ;loop while NSTEP < N
l40 LDFS   F2,[R0,#-4]   ;A(KPIV)
    SUFS   F1,F2,F1      ;SUM = A(KPIV) - SUM
l42 CMP    R6,R3         ;is J<I?
    FMLLTS F1,F1,F0
    SQTGED F1,F1         ;SQRT(SUM)
    CMFGE  F0,#0
    FRDGTS F0,F1,#1
l60 STFS   F1,[R1,#-4]!  ;store B(KPIV), KPIV+1 = KPIV
    SUB    R0,R0,#4      ;(A(KPIV)) = (A(KPIV)) -1
    SUBS   R6,R6,#1
    BGT    l20           ;loop over J=I,1,-1
    SUBS   R3,R3,#1
    BGT    l10           ;loop while I=N,1,-1
    LDMDB  fp,{R4-R6,fp,sp,pc} ;return
    END
;
    TTL   TRINV
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
F1  FN     1
F2  FN     2
F3  FN     3
    AREA   |C$$code|,CODE,READONLY
    EXPORT trinv_;(T,S,N) invert T(lower tri) to S(lower tri)
    DCB    "trinv_",0,0,8,0,0,255
trinv_
    MOV    ip,sp
    STMDB  sp!,{R0-R2,R4-R7,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R2,[R2]       ;N
    MLA    ip,R2,R2,R2   ;N*N+N = 2*MX
    ADD    R0,R0,ip,LSL#1;(T(IPIV+1))
    ADD    R1,R1,ip,LSL#1;(S(IPIV+1))
    SUB    R4,R1,#4      ;initialise IND1 to MX
    MOV    R3,R2         ;initialise I to N
l10 LDFS   F0,[R0,#-4]   ;T(IPIV)
    CMF    F0,#0
    FRDGTS F0,F0,#1      ;R = 1.0/T(IPIV)
    MVFLED F0,#0         ;or R = 0.0
    STFS   F0,[R1,#-4]   ;S(IPIV) = R
    CMP    R3,R2
    BEQ    l50           ;skip if I=N
    MOV    R5,R2         ;NDSTEP = N
    MOV    R6,R4         ;IND = IND1
l20 MVFD   F1,#0         ;SUM = 0.0
    CMF    F0,#0
    BEQ    l40           ;skip if R=0.0
    SUB    ip,R0,#4      ;LHOR = IPIV
    MOV    lr,R6         ;LVER = IND
    MOV    R7,R3         ;J = I
l30 ADD    ip,ip,R7,LSL#2;LHOR = LHOR + J
    LDFS   F2,[ip]       ;T(LHOR)
    LDFS   F3,[lr,#4]!   ;LVER = LVER + 1: S(LVER)
    ADD    R7,R7,#1      ;J = J + 1
    FMLS   F2,F2,F3
    CMP    R7,R5
    SUFD   F1,F1,F2      ;SUM = SUM - T(LHOR)*S(LVER)
    BLT    l30           ;loop while J < NDSTEP
    FMLS   F1,F1,F0
l40 STFS   F1,[R6]       ;S(IND) = SUM*R
    SUB    R5,R5,#1      ;NDSTEP = NDSTEP - 1
    SUB    R6,R6,R5,LSL#2;IND = IND - NDSTEP (+ 1)
    CMP    R5,R3
    BGT    l20           ;loop while NDSTEP>I
l50 SUB    R4,R4,#4      ;IND1 = IND1 - 1
    SUB    R0,R0,R3,LSL#2;(T(IPIV+1)) = (T(IPIV+1)) - I
    SUB    R1,R1,R3,LSL#2;(S(IPIV+1)) = (S(IPIV+1)) - I
    SUBS   R3,R3,#1
    BGT    l10           ;loop while I > 0
    LDMDB  fp,{R4-R7,fp,sp,pc} ;return
    END
;
    TTL   TRLA
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
F0  FN     0
F1  FN     1
F2  FN     2
    AREA   |C$$code|,CODE,READONLY
    EXPORT trla_;(W,A,B,M,N) B(MxN) = W(lower tri M)*A(MxN)
    DCB    "trla_",0,0,0,8,0,0,255
trla_
    MOV    ip,sp
    STMDB  sp!,{R0-R6,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R3,[R3]       ;M (dimension of W)
    LDR    R4,[ip]
    LDR    R4,[R4]       ;N
    MLA    ip,R3,R3,R3   ;M*M+M
    ADD    R0,R0,ip,LSL#1;(W(IPIV+1)), IPIV=(M*M+M)/2
    MUL    ip,R4,R3      ;M*N
    ADD    R2,R2,ip,LSL#2;IB=(B(N*M+1))
    ADD    R1,R1,ip,LSL#2;IA=(A(N*M+1))
l10 MOV    R5,R4         ;column count (N)
l20 SUB    lr,R1,#4      ;(A(IA)), IA=IB
    MOV    ip,R0         ;IW+1 = IPIV+1
    MVFD   F0,#0         ;SUM = 0.0
    MOV    R6,R3         ;count (= row number)
l30 LDFS   F1,[lr]       ;A(IA)
    LDFS   F2,[ip,#-4]!  ;IW=IW-1, W(IW)
    SUB    lr,lr,R4,LSL#2;IA = IA - N
    FMLS   F1,F1,F2
    SUBS   R6,R6,#1
    ADFD   F0,F0,F1      ;SUM = SUM + A(IA)*W(IW)
    BGT    l30           ;loop over sum
    STFS   F0,[R2,#-4]!  ;IB+1 = IB, B(IB)=SUM
    SUB    R1,R1,#4      ;IA+1 = IA
    SUBS   R5,R5,#1
    BGT    l20           ;loop over columns
    MOV    R0,ip         ;IPIV+1 = IW+1
    SUBS   R3,R3,#1
    BGT    l10           ;loop over rows
    LDMDB  fp,{R4-R6,fp,sp,pc} ;return
    END
;
    TTL   TRLTA
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
F0  FN     0
F1  FN     1
F2  FN     2
    AREA   |C$$code|,CODE,READONLY
    EXPORT trlta_;(W,A,B,M,N) B(MxN) = W'(lower tri M)*A(MxN)
    DCB    "trlta_",0,0,8,0,0,255
trlta_
    MOV    ip,sp
    STMDB  sp!,{R0-R8,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R3,[R3]       ;M (dimension of W)
    LDR    R4,[ip]
    LDR    R4,[R4]       ;N
    MOV    R6,#1         ;initialise IR = 1,M
l10 MOV    R8,R4         ;column count IC
l20 MOV    ip,R0         ;IW = IPIV
    MOV    R7,R6         ;NSTEP = IR
    MOV    lr,R1         ;IA = IAA
    MVFD   F0,#0         ;SUM = 0.0
l30 LDFS   F1,[lr]
    LDFS   F2,[ip]
    ADD    lr,lr,R4,LSL#2;(A(IA)) = (A(IA)) + N
    ADD    ip,ip,R7,LSL#2;(W(IW)) = (W(IW)) + NSTEP
    FMLS   F1,F1,F2
    ADD    R7,R7,#1      ;NSTEP = NSTEP + 1
    CMP    R7,R3
    ADFD   F0,F0,F1      ;SUM = SUM + A(IA)*W(IW)
    BLE    l30           ;loop over NSTEP = IR,M
    STFS   F0,[R2],#4    ;B(IB) = SUM, IB = IB + 1
    ADD    R1,R1,#4      ;IAA = IAA + 1
    SUBS   R8,R8,#1
    BGT    l20           ;loop over columns
    ADD    R6,R6,#1      ;IR = IR + 1
    ADD    R0,R0,R6,LSL#2;IPIV = IPIV + IR + 1
    CMP    R6,R3
    BLE    l10           ;loop through I=1,M
    LDMDB  fp,{R4-R8,fp,sp,pc} ;return
    END
;
    TTL   TRPCK
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 trpck_;(A,S,M) S(sym) = A(full)
    DCB    "trpck_",0,0,8,0,0,255
trpck_
    MOV    ip,sp
    STMDB  sp!,{R0-R2,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R2,[R2]       ;M
    MOV    R3,R2         ;I count (M)
l10 SUB    lr,R2,R3      ;J count (M-I+1)
l20 LDR    ip,[R0],#4    ;A(IA), IA = IA + 1
    STR    ip,[R1],#4    ;->S(IS), IS = IS + 1
    SUBS   lr,lr,#1
    BGE    l20           ;loop over J
    SUBS   R3,R3,#1
    ADD    R0,R0,R3,LSL#2;skip symmetric terms
    BGT    l10           ;loop M times
    LDMDB  fp,{fp,sp,pc} ;return
    END
;
    TTL   TRQSQ
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
F2  FN     2
    AREA   |C$$code|,CODE,READONLY
    EXPORT trqsq_;(Q,T,R,M) R(sym M) =  QTQ (sym M)
    DCB    "trqsq_",0,0,8,0,0,255
trqsq_
    MOV    ip,sp
    STMDB  sp!,{R0-R9,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R3,[R3]       ;M
    MLA    ip,R3,R3,R3   ;M*M+M
    MOV    R5,#0         ;initialize I = 0,M-1
zer SUBS   ip,ip,#2
    STRGE  R5,[R2,ip,LSL#1];zero R
    BGT    zer
    MOV    R9,#0         ;initialise IND
l10 ADD    R9,R9,R5,LSL#2;IND = IND + I
    MOV    R6,R2         ;initialise IR
    MOV    R7,R0         ;initialise INDQ
    MOV    R8,#0         ;initialise J = 0,M-1
l20 ADD    R7,R7,R8,LSL#2;INDQ = INDQ + J
    ADD    ip,R1,R9      ;IT = IND
    MOV    lr,R7         ;IQ = INDQ
    MVFD   F0,#0         ;SUM = 0.0
    MOV    R4,#0         ;initialise K = 0,M-1
l30 LDFS   F1,[ip],#4    ;T(IT), IT = IT + 1
    LDFS   F2,[lr],#4    ;Q(IQ), IQ = IQ + 1
    CMP    R4,R5
    ADDGE  ip,ip,R4,LSL#2;(IT = IT + K)
    CMP    R4,R8
    ADDGE  lr,lr,R4,LSL#2;(IQ = IQ + K)
    FMLS   F1,F1,F2
    ADD    R4,R4,#1      ;K = K + 1
    CMP    R4,R3
    ADFD   F0,F0,F1      ;SUM = SUM + T(IT)*Q(IQ)
    BLT    l30           ;loop over K=0,M-1
    ADD    ip,R0,R9      ;initialise IQ to IND
    MOV    R4,#0         ;initialise L =0,J
l60 LDFS   F1,[ip],#4    ;Q(IQ), IQ = IQ + 1
    CMP    R4,R5
    ADDGE  ip,ip,R4,LSL#2;(IQ = IQ + L)
    LDFS   F2,[R6]       ;R(IR)
    FMLS   F1,F1,F0
    ADD    R4,R4,#1      ;L = L + 1
    ADFS   F2,F2,F1
    CMP    R4,R8
    STFS   F2,[R6],#4    ;R(IR) = R(IR) + Q(IQ)*SUM, IR = IR + 1
    BLE    l60           ;loop over L = 0,J
    ADD    R8,R8,#1      ;J = J + 1
    CMP    R8,R3
    BLT    l20           ;loop over J=0,M-1
    ADD    R5,R5,#1      ;I = I + 1
    CMP    R5,R3
    BLT    l10           ;loop over I=0,M-1
    LDMDB  fp,{R4-R9,fp,sp,pc} ;return
    END
;
    TTL   TRSA
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
F1  FN     1
F2  FN     2
    AREA   |C$$code|,CODE,READONLY
    EXPORT trsa_;(S,A,C,M,N) C(MxN) = S(sym M) * A(MxN)
    DCB    "trsa_",0,0,0,8,0,0,255
trsa_
    MOV    ip,sp
    STMDB  sp!,{R0-R7,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R3,[R3]       ;M (dimension of S)
    LDR    R4,[ip]
    LDR    R4,[R4]       ;N
    MOV    R5,#0         ;initialise I = 0,M-1
l10 MOV    R6,#0         ;initialise J ="1,N"
    ADD    R0,R0,R5,LSL#2;INDS = INDS + I
l20 ADD    ip,R1,R6,LSL#2;initialise IA=J
    MOV    lr,R0         ;IS = INDS
    MOV    R7,#0         ;initialise K = 0,M-1
    MVFD   F0,#0         ;SUM = 0.0
l30 LDFS   F1,[ip]       ;A(IA)
    LDFS   F2,[lr],#4    ;S(IS), IS = IS + 1
    CMP    R7,R5
    ADDGE  lr,lr,R7,LSL#2;(IS = IS + K)
    ADD    ip,ip,R4,LSL#2;IA = IA + N
    FMLS   F1,F1,F2
    ADD    R7,R7,#1      ;K = K + 1
    CMP    R7,R3
    ADFD   F0,F0,F1      ;SUM = SUM + S(IS)*A(IA)
    BLT    l30           ;loop over K=0,M-1
    STFS   F0,[R2],#4    ;C(IC) = SUM, IC = IC + 1
    ADD    R6,R6,#1      ;J = J + 1
    CMP    R6,R4
    BLT    l20           ;loop over J = 0,N-1
    ADD    R5,R5,#1
    CMP    R5,R3
    BLT    l10           ;loop over I=0,M-1
    LDMDB  fp,{R4-R7,fp,sp,pc} ;return
    END
;
    TTL   TRSAT
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
F1  FN     1
F2  FN     2
    AREA   |C$$code|,CODE,READONLY
    EXPORT trsat_;(S,B,C,M,N) C(MxN) =   S(sym M) * B'(MxN)
    DCB    "trsat_",0,0,8,0,0,255
trsat_
    MOV    ip,sp
    STMDB  sp!,{R0-R7,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R3,[R3]       ;M (dimension of S)
    LDR    R4,[ip]
    LDR    R4,[R4]       ;N
    MOV    R5,#0         ;initialise I = 0,M-1
l10 MOV    R6,R4         ;initialise J to N
    ADD    R0,R0,R5,LSL#2;INDS = INDS + I
    MOV    ip,R1         ;IB
l20 MOV    lr,R0         ;IS = INDS
    MOV    R7,#0         ;initialise K = 0,M-1
    MVFD   F0,#0         ;SUM = 0.0
l30 LDFS   F1,[ip],#4    ;B(IB), IB = IB + 1
    LDFS   F2,[lr],#4    ;S(IS), IS = IS + 1
    CMP    R7,R5
    ADDGE  lr,lr,R7,LSL#2;(IS = IS + K)
    FMLS   F1,F1,F2
    ADD    R7,R7,#1      ;K = K + 1
    CMP    R7,R3
    ADFD   F0,F0,F1      ;SUM = SUM + S(IS)*B(IB)
    BLT    l30           ;loop over K=0,M-1
    STFS   F0,[R2],#4    ;C(IC) = SUM, IC = IC + 1
    SUBS   R6,R6,#1      ;J = J - 1
    BGT    l20           ;loop over J=N,1,-1
    ADD    R5,R5,#1      ;I = I + 1
    CMP    R5,R3
    BLT    l10           ;loop over I=0,M-1
    LDMDB  fp,{R4-R7,fp,sp,pc} ;return
    END
;
    TTL   TRSINV
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R0  RN     0
R1  RN     1
R2  RN     2
    AREA   |C$$code|,CODE,READONLY
    EXPORT trsinv_;(S,R,N) inverts S(sym) to R(sym)
    IMPORT trchlu_
    IMPORT trinv_
    IMPORT trsmul_
    DCB    "trsinv_",0,8,0,0,255
trsinv_
    MOV    ip,sp
    STMDB  sp!,{R0-R2,fp,ip,lr,pc}
    SUB    fp,ip,#4
    BL     trchlu_
    LDMIB  sp,{R1,R2}
    MOV    R0,R1
    BL     trinv_
    LDMIB  sp,{R1,R2}
    MOV    R0,R1
    BL     trsmul_
    LDMDB  fp,{fp,sp,pc} ;return
    END
;
    TTL   TRSMLU
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
F0  FN     0
F1  FN     1
F2  FN     2
    AREA   |C$$code|,CODE,READONLY
    EXPORT trsmlu_;(W,R,N) R(sym) = WW'(lower tri)
    DCB    "trsmlu_",0,8,0,0,255
trsmlu_
    MOV    ip,sp
    STMDB  sp!,{R0-R2,R4-R5,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R2,[R2]       ;N
    MLA    R3,R2,R2,R2   ;N*N+N = IND*2
    ADD    R0,R0,R3,LSL#1;(W(IND+1))
    ADD    R1,R1,R3,LSL#1;(R(IND+1))
    MOV    R3,R2         ;I count (N)
l10 SUB    ip,R0,#4      ;(W(LVER)), LVER=IND
    MOV    R4,R3         ;K count (I)
l20 SUB    lr,R0,#4      ;(W(LHOR)), LHOR=IND
    MVFD   F0,#0         ;SUM = 0.0
    MOV    R5,R4         ;L count (K)
l30 LDFS   F1,[ip],#-4   ;W(LVER), LVER=LVER-1
    LDFS   F2,[lr],#-4   ;W(LHOR), LHOR=LHOR-1
    FMLS   F1,F1,F2
    SUBS   R5,R5,#1
    ADFD   F0,F0,F1      ;SUM = SUM + W(LVER)*W(LHOR)
    BGT    l30           ;loop over L
    STFS   F0,[R1,#-4]!  ;(R(IND+1)) = (R(IND)), R(IND) = SUM
    SUB    R0,R0,#4      ;(W(IND+1)) = (W(IND))
    SUBS   R4,R4,#1
    BGT    l20           ;loop over K
    SUBS   R3,R3,#1
    BGT    l10           ;loop over I
    LDMDB  fp,{R4-R5,fp,sp,pc} ;return
    END
;
    TTL   TRSMUL
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
F0  FN     0
F1  FN     1
F2  FN     2
    AREA   |C$$code|,CODE,READONLY
    EXPORT trsmul_;(W,S,N) S(sym) = W'W(lower tri)
    DCB    "trsmul_",0,8,0,0,255
trsmul_
    MOV    ip,sp
    STMDB  sp!,{R0-R2,R4-R6,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R2,[R2]       ;N
    MOV    R3,#1         ;initialise I=1,N
    SUB    R6,R0,#4      ;(W(LPIV)) = (W(0))
l10 MOV    R4,R3         ;J count (I)
    ADD    R6,R6,R3,LSL#2;(W(LPIV)) = (W(LPIV)) + I
l20 MOV    R5,R3         ;initialise K=I,N
    MOV    lr,R0         ;(W(LHOR)), LHOR=IND
    MOV    ip,R6         ;(W(LVER)), LVER=LPIV
    MVFD   F0,#0         ;SUM = 0.0
l30 LDFS   F1,[ip]       ;W(LVER)
    LDFS   F2,[lr]       ;W(LHOR)
    ADD    ip,ip,R5,LSL#2;(W(LVER)) = (W(LVER)) + K
    FMLS   F1,F1,F2
    ADD    lr,lr,R5,LSL#2;(W(LHOR)) = (W(LHOR)) + K
    ADD    R5,R5,#1      ;K = K + 1
    ADFD   F0,F0,F1      ;SUM = SUM + W(LVER)*W(LHOR)
    CMP    R5,R2
    BLE    l30           ;loop over K=I,N
    STFS   F0,[R1],#4    ;S(IND) = SUM, (S(IND)) = (S(IND+1))
    ADD    R0,R0,#4      ;(W(IND)) = (W(IND+1))
    SUBS   R4,R4,#1
    BGT    l20           ;loop over J
    ADD    R3,R3,#1      ;I = I + 1
    CMP    R3,R2
    BLE    l10           ;loop over I=1,N
    LDMDB  fp,{R4-R6,fp,sp,pc} ;return
    END
;
    TTL   TRUPCK
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 trupck_;(S,A,M) A(full) = S(sym)
    DCB    "trupck_",0,8,0,0,255
trupck_
    MOV    ip,sp
    STMDB  sp!,{R0-R2,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R2,[R2]       ;M
    MUL    R3,R2,R2      ;M*M
    ADD    ip,R3,R2      ;M*M+M
    ADD    R0,R0,ip,LSL#1;IS = ( S((M*M+M)/2+1) )
    ADD    R1,R1,R3,LSL#2;IA = ( A(M*M+1) )
    MOV    R3,#1         ;initialise I =1,M
l10 SUB    lr,R2,R3      ;initialise J =M-I,0,-1
l20 LDR    ip,[R0,#-4]!  ;IS = IS - 1, S(IS)
    STR    ip,[R1,#-4]!  ;IA = IA - 1, -> A(IA)
    SUBS   lr,lr,#1
    BGE    l20           ;loop over J
    CMP    R3,R2
    SUBLT  R1,R1,R3,LSL#2;IA = IA - I (except last time)
    ADDLT  R3,R3,#1
    BLT    l10           ;loop over I=1,M
;
    MOV    R0,#1         ;initialise I = 1,M-1
l30 SUBS   R3,R2,R0      ;count of columns (M-I)
    LDMLEDB fp,{fp,sp,pc} ;return
    ADD    R1,R1,R0,LSL#2;IA = IA + I
    SUB    ip,R1,#4      ;IAA = IA
l40 LDR    lr,[ip,R2,LSL#2]!;IAA = IAA + M, A(IAA)
    STR    lr,[R1],#4    ;IA = IA + 1, -> A(IA)
    SUBS   R3,R3,#1
    BGT    l40           ;loop (M-I) times
    ADD    R0,R0,#1      ;I = I + 1
    B      l30           ;loop over I
    END
;
    TTL    UBITS
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R4  RN     4
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT ubits_;(IWORDS,NBITS,IXV,NX) finds set bits in word or array
    DCB    "ubits_",0,0,8,0,0,255
ubits_
    MOV    ip,sp
    STMDB  sp!,{R0-R4,fp,ip,lr,pc}
    SUB    fp,ip,#4
    MOV    ip,#0       ;bit count
wu0 LDR    R1,[R1]     ;NBITS
    ADD    R1,R1,ip    ;correct bit count
    MOV    R4,#0       ;initialise NX
    ADDS   lr,R4,#1    ;initialise I/P word and clear C
wu1 MOVS   lr,lr,RRX
    LDREQ  lr,[R0],#4
    MOVEQS lr,lr,RRX
    ADD    ip,ip,#1    ;count bits
    STRCS  ip,[R2,R4,LSL#2]  ;store if set
    ADDCS  R4,R4,#1    ;count bits set
    CMP    ip,R1       ;check if finished
    BCC    wu1         ;loop over bits
    STR    R4,[R3]     ;store NX
    LDMDB  fp,{R4,fp,sp,pc} ;return
;
    EXPORT bitpos_;(IWORDS,NBITS,IXV,NX) finds set bits in word or array
    DCB    "bitpos_",0,8,0,0,255
bitpos_
    MOV    ip,sp
    STMDB  sp!,{R0-R4,fp,ip,lr,pc}
    SUB    fp,ip,#4
    MOV    ip,#-1      ;bit count
    B      wu0         ;like UBITS except start at 0
    END
;
;          UBLANK see UFILL
;
    TTL    UBLOW
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT ublow_;(VM,V1,NCH) converts 4H array into 1H array
    DCB    "ublow_",0,0,8,0,0,255
ublow_
    MOV    ip,sp
    STMDB  sp!,{R0-R2,fp,ip,lr,pc}
    B      wu1
;
    EXPORT uctoh1_;(VC,V1,NCH) converts string to 1H format
    DCB    "uctoh1_",0,8,0,0,255
uctoh1_
    MOV    ip,sp
    STMDB  sp!,{R0-R2,fp,ip,lr,pc}
wu1 SUB    fp,ip,#4
    LDR    R2,[R2]     ;nch
    LDR    R3,template
wlw SUBS   R2,R2,#1
    LDRGEB ip,[R0],#1  ;get byte of vm
    ORRGE  ip,ip,R3    ;add blanks
    STRGE  ip,[R1],#4  ;store in v1
    BGT    wlw         ;loop
    LDMDB  fp,{fp,sp,pc} ;return
template DCD &20202000
    END
;
    TTL    UBUNCH
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT ubunch_;(V1,VM,NCH) converts 1H array to 4H array
    DCB    "ubunch_",0,8,0,0,255
ubunch_
    MOV    ip,sp
    STMDB  sp!,{R0-R2,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R2,[R2]     ;nch
lh1 SUBS   R2,R2,#1
    LDRGEB R3,[R0],#4  ;get byte from v1
    STRGEB R3,[R1],#1  ;store in vm
    BGT    lh1         ;loop
    MOV    R3,#" "
lh2 TST    R1,#3
    STRNEB R3,[R1],#1  ;pad with blanks
    BNE    lh2
    LDMDB  fp,{fp,sp,pc} ;return
    END
;
    TTL    UCOCOP
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R5  RN     5
R4  RN     4
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT ucocop_;(IN,OUT,N,IW,NIN,NOUT) copies dispersed to compressed vector
    DCB    "ucocop_",0,8,0,0,255
ucocop_
    MOV    ip,sp
    STMDB  sp!,{R0-R5,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R2,[R2]       ;N
    LDR    R3,[R3]       ;IW
    LDMIB  fp,{ip,lr}    ;addresses of NIN,NOUT
    LDR    ip,[ip]       ;NIN
    LDR    lr,[lr]       ;NOUT
    SUB    ip,ip,R3      ;NIN-IW
    SUB    lr,lr,R3      ;NOUT-IW
lc1 MOV    R4,R3         ;count for inner loop
    SUBS   R2,R2,#1
lc2 SUBGES R4,R4,#1
    LDRGE  R5,[R0],#4
    STRGE  R5,[R1],#4
    BGT    lc2           ;move block
    ADDEQ  R0,R0,ip,LSL#2;move to next i/p block
    ADDEQ  R1,R1,lr,LSL#2;move to next o/p block
    BEQ    lc1           ;loop over blocks
    LDMDB  fp,{R4,R5,fp,sp,pc} ;return
    END
;
    TTL    UCOPIV
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT ucopiv_;(A,X,N) invert order of A into X
    DCB    "ucopiv_",0,8,0,0,255
ucopiv_
    MOV    ip,sp
    STMDB  sp!,{R0-R2,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R2,[R2]       ;N
    SUBS   R2,R2,#1      ;N-1
    ADD    R3,R1,R2,LSL#2;end of X
    ADD    R2,R0,R2,LSL#2;end of A
nlp LDRGE  lr,[R0],#4    ;A(1)
    LDRGT  ip,[R2],#-4   ;A(N)
    STRGE  lr,[R3],#-4   ;X(N)=A(1)
    STRGT  ip,[R1],#4    ;X(1)=A(N) etc.
    CMP    R2,R0
    BGE    nlp
    LDMDB  fp,{fp,sp,pc} ;return
    END
;
    TTL    UCOPY
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R9  RN     9
R4  RN     4
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT ucopy_;(IN,OUT,N) OUT() = IN() where vectors do not overlap
    DCB    "ucopy_",0,0,8,0,0,255
ucopy_
    MOV    ip,sp
    STMDB  sp!,{R0-R2,R4-R9,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    ip,[R2]         ;N
lu1 SUBS   ip,ip,#8
    LDMGEIA R0!,{R2-R9}    ;load 8 words
    STMGEIA R1!,{R2-R9}    ;store 8 words
    BGT    lu1             ;loop over blocks of 8 words
    ADDLTS ip,ip,#8
lu2 LDRGT  R2,[R0],#4
    STRGT  R2,[R1],#4      ;move the odd ones
    SUBS   ip,ip,#1
    BGT    lu2             ;loop over odd ones
    LDMDB  fp,{R4-R9,fp,sp,pc} ;return
;
    EXPORT ucopy2_;(IN,OUT,N) OUT() = IN() where vectors may overlap
    DCB    "ucopy2_",0,8,0,0,255
ucopy2_
    MOV    ip,sp
    STMDB  sp!,{R0-R2,R4-R9,fp,ip,lr,pc}
    SUB    fp,ip,#4
    CMP    R0,R1
    LDMEQDB  fp,{R4-R9,fp,sp,pc} ;return
    LDR    ip,[R2]       ;N
    BGT    lu1           ;forward copy if IN higher than OUT
    ADD    R0,R0,ip,LSL#2;end of IN
    ADD    R1,R1,ip,LSL#2;end of OUT
lu3 SUBS   ip,ip,#8
    LDMGEDB R0!,{R2-R9}  ;load 8 words
    STMGEDB R1!,{R2-R9}  ;store 8 words
    BGT    lu3           ;loop over blocks of 8 words
    ADDLTS ip,ip,#8
lu4 LDRGT  R2,[R0,#-4]!
    STRGT  R2,[R1,#-4]!  ;move the odd ones
    SUBS   ip,ip,#1
    BGT    lu4           ;loop over odd ones
    LDMDB  fp,{R4-R9,fp,sp,pc} ;return
    END
;
;          UCOPY2 see UCOPY
;
    TTL    UCOPYN
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT ucopyn_;(IA,IX,N)  IX() = -IA()
    DCB    "ucopyn_",0,8,0,0,255
ucopyn_
    MOV    ip,sp
    STMDB  sp!,{R0-R2,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R2,[R2]       ;N
ulp SUBS   R2,R2,#1
    LDRGE  R3,[R0],#4
    RSBGE  R3,R3,#0
    STRGE  R3,[R1],#4
    BGT    ulp
    LDMDB  fp,{fp,sp,pc} ;return
    END
;
    TTL    UCTOH
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R5  RN     5
R4  RN     4
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT uctoh_;(VC,VJ,NH,NCH) copy string VC to Hollerith(NH) array VJ
    DCB    "uctoh_",0,0,8,0,0,255
uctoh_
    MOV    ip,sp
    STMDB  sp!,{R0-R5,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R2,[R2]    ;NH
    CMP    R2,#4
    MOVGT  R2,#4      ;NH (<=4)
    MOV    R2,R2,LSL#3;#bits / word
    LDR    R3,[R3]    ;NCH
    LDR    R4,blk     ;blank
uc1 MOV    ip,#0      ;count of bits in O/P word
    MOV    R5,R4,LSL R2;blank fill
uc2 SUBS   R3,R3,#1   ;count bytes to store
    LDRGEB lr,[R0],#1 ;get byte from VC
    ORRGE  R5,R5,lr,LSL ip;store byte
    ADDGE  ip,ip,#8   ;# bits stored in O/P word
    CMPGE  R2,ip
    BGT    uc2
    STREQ  R5,[R1],#4 ;store word of VJ
    BEQ    uc1
    CMP    ip,#0
    ORRNE  R5,R5,R4,LSL ip; blank out spare characters
    STRNE  R5,[R1]        ;store runt word
    LDMDB  fp,{R4,R5,fp,sp,pc} ;return
blk DCB    "    "
    END
;
;          UCTOH1 see UBLOW
;
    TTL    UDICOP
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R5  RN     5
R4  RN     4
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT udicop_;(IN,OUT,N,IW,NIN,NOUT) copy compressed to dispersed array
    DCB    "udicop_",0,8,0,0,255
udicop_
    MOV    ip,sp
    STMDB  sp!,{R0-R5,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R2,[R2]       ;N
    LDR    R3,[R3]       ;IW
    LDMIB  fp,{ip,lr}    ;addresses of NIN,NOUT
    LDR    ip,[ip]       ;NIN
    LDR    lr,[lr]       ;NOUT
    MUL    R4,ip,R2      ;# words in 'IN'
    MUL    R5,lr,R2      ;# words in 'OUT'
    ADD    R0,R0,R4,LSL#2;end of 'IN'
    ADD    R1,R1,R5,LSL#2;end of 'OUT'
    SUB    ip,ip,R3      ;NIN-IW
    SUB    lr,lr,R3      ;NOUT-IW
ld1 MOV    R4,R3         ;count of words in block
    SUB    R0,R0,ip,LSL#2;move to next i/p block
    SUB    R1,R1,lr,LSL#2;move to next o/p block
    SUBS   R2,R2,#1
ld2 SUBGES R4,R4,#1
    LDRGE  R5,[R0,#-4]!
    STRGE  R5,[R1,#-4]!
    BGT    ld2           ;move block of words
    BEQ    ld1           ;loop over blocks
    LDMDB  fp,{R4,R5,fp,sp,pc} ;return
    END
;
    TTL    UFILL
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 ufill_ ;(BUF,L1,L2,VAR) BUF(I) = VAR (I=L1,L2)
    DCB    "ufill_",0,0,8,0,0,255
ufill_
    MOV    ip,sp
    STMDB  sp!,{R0-R9,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R3,[R3]    ;VAR
    B      wu2
;
    EXPORT ublank_;(BUF,L1,L2) BUF(I) = 4H     (I=L1,L2)
    DCB    "ublank_",0,8,0,0,255
ublank_
    MOV    ip,sp
    STMDB  sp!,{R0-R9,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R3,blk
    B      wu2
blk DCB   "    "
;
    EXPORT uzero_ ;(BUF,L1,L2) BUF(I) = 0 (I=L1,L2)
    DCB    "uzero_",0,0,8,0,0,255
uzero_
    MOV    ip,sp
    STMDB  sp!,{R0-R9,fp,ip,lr,pc}
    SUB    fp,ip,#4
    MOV    R3,#0
wu2 LDR    R1,[R1]    ;L1
    LDR    R2,[R2]    ;L2
    SUB    R1,R1,#1
    ADD    R0,R0,R1,LSL#2;first address to fill
    SUB    R1,R2,R1   ;number of words to fill
    MOV    R2,R3      ;fill word
    MOV    R4,R2
    MOV    R5,R2
    MOV    R6,R2
    MOV    R7,R2
    MOV    R8,R2
    MOV    R9,R2
wf1 SUBS   R1,R1,#8
    STMGEIA R0!,{R2-R9};store 8 words
    BGT    wf1        ;loop over blocks of 8 words
    ADDLT  R1,R1,#8   ;restore count
wf2 SUBS   R1,R1,#1
    STRGE  R2,[R0],#4 ;store a word
    BGT    wf2        ;loop over single words
    LDMDB  fp,{R4-R9,fp,sp,pc} ;return
    END
;
    TTL    UFLINT
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
F0  FN    0
;
    AREA   |C$$code|,CODE,READONLY
    EXPORT uflint_;(VECT,NW,MODE) assure integer or floating
    DCB    "uflint_",0,8,0,0,255
uflint_
    MOV    ip,sp
    STMDB  sp!,{R0-R2,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R2,[R2]       ;MODE
    LDR    R1,[R1]       ;NW
    ADDS   R3,R1,#0
    RSBLT  R3,R3,#0      ;|NW|
lp1 SUBS   R3,R3,#1      ;count down words
    LDMLTDB fp,{fp,sp,pc} ; return when NW<0
    LDR    ip,[R0],#4    ;get next word from VECT
    MOVS   lr,ip,ASR#23
    MVNMI  lr,lr         ;signed 'exponent'
    TST    R2,#1
    BNE    integer       ;integer required
;         floating required
    TST    lr,#&FF       ;see if there is an exponent
    FLTEQS F0,ip         ;no, then float it
    STFEQS F0,[R0,#-4]   ;and store it back
    B      loop
integer; integer required
    TST    lr,#&FF       ;check if already integer
    MOVNE  lr,ip,LSR#23
    BICNE  lr,lr,#256    ;real exponent
    CMPNE  lr,#158       ;check if too big for integer
    LDFLTS F0,[R0,#-4]
    FIXLTZ ip,F0        ;fix it (rounding towards zero)
    STRLT  ip,[R0,#-4]   ;and store it back
loop;
    CMP    R1,#0
    MOVLT  R2,R2,LSR#1   ;for -ve NW get next bit of MODE
    B      lp1
    END
;
    TTL    UH1TOC
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
    AREA   slate__,COMMON,NOINIT
    %      160
    AREA   |C$$code|,CODE,READONLY
    EXPORT uh1toc_;(V1,VC,NCH) converts NCH 1H characters in V1 to string VC
    DCB    "uh1toc_",0,8,0,0,255
uh1toc_
    MOV    ip,sp
    STMDB  sp!,{R0-R2,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R2,[R2]    ;nch
wc1 SUBS   R2,R2,#1
    LDRGEB R3,[R0],#4
    STRGEB R3,[R1],#1
    BGT    wc1        ;loop over bytes
    LDMDB  fp,{fp,sp,pc} ;return
    END
;
    TTL    uhollr
pc  RN     15
lr  RN     14
sp  RN     13
ip  RN     12
fp  RN     11
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT uhollr_;(IOUT,NC,IHOLL) copy hollerith string to array
    DCB    "uhollr_",0,8,0,0,255
uhollr_
    MOV    ip,sp
    STMDB  sp!,{R0-R2,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R1,[R1]      ;NC
lp1 SUBS   R1,R1,#1
    LDRGEB lr,[R2],#1
    STRGEB lr,[R0],#1
    BGT    lp1
    MOV    lr,#" "
lp2 TST    R0,#3
    STRNEB lr,[R0],#1
    BNE    lp2
    LDMDB  fp,{fp,sp,pc} 
    END
;
    TTL    UHTOC
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT uhtoc_;(VI,I,VC,NCH) converts Hollerith (nI) array VI to string VC
    DCB    "uhtoc_",0,0,8,0,0,255
uhtoc_
    MOV    ip,sp
    STMDB  sp!,{R0-R3,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R1,[R1]     ;I
    LDR    R3,[R3]     ;NCH
    CMP    R1,#4
    MOVGT  R1,#4       ;limit I to 4
    MOV    lr,#0
wlc SUBS   lr,lr,#1    ;count bytes in word
    MOVLE  lr,R1       ;if word finished
    LDRLE  ip,[R0],#4  ;load word from VI
    MOVGT  ip,ip,LSR#8 ;or move to next byte
    SUBS   R3,R3,#1    ;count bytes
    STRGEB ip,[R2],#1  ;store byte in VC
    BGT    wlc         ;loop over bytes
    LDMDB  fp,{fp,sp,pc} ;return
    END
;
    TTL    ULEFT
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R4  RN     4
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
    AREA   slate__,COMMON,NOINIT
    %      160
;
    AREA   |C$$code|,CODE,READONLY
    EXPORT uleft_;(ch,jl,jr) left justifies characters in CH(JL,JR)
    DCB    "uleft_",0,0,8,0,0,255
uleft_
    MOV    ip,sp
    STMDB  sp!,{R0-R2,R4,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R1,[R1]     ;jl
    LDR    R2,[R2]     ;jr
    SUB    R0,R0,#8    ;(ch(-1))
    LDR    R3,blnk
    MOV    lr,R1       ;output pointer
    MOV    ip,R1       ;initialize count
wl1 ADD    R1,R1,#1
    LDR    R4,[R0,R1,LSL#2]
    CMP    R4,R3       ;check for blank
    ADDNE  lr,lr,#1    ;if not, add to output
    CMPNE  R1,lr
    STRNE  R4,[R0,lr,LSL#2]
    STRNE  R3,[R0,R1,LSL#2]
    CMP    R1,R2
    BLE    wl1         ;loop until > jr
    SUB    ip,lr,ip    ;find # output
    LDR    R0,slpt
    STMIA  R0,{ip,lr}  ;store answers
    LDMDB  fp,{R4,fp,sp,pc} ;return
blnk DCB    "    "      ;blank ASCII word
slpt DCD    slate__     ;pointer to COMMON/SLATE/
    END
;
    TTL    UOPT
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R5  RN     5
R4  RN     4
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT uopt_;(IACT,IPOSS,IOPT,N) selects options
    DCB    "uopt_",0,0,0,8,0,0,255
uopt_
    MOV    ip,sp
    STMDB  sp!,{R0-R5,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R3,[R3]     ;n (= length of iposs & iopt)
    MOV    R4,R3
    MOV    R5,#0
wc4 SUBS   R4,R4,#1
    STRGE  R5,[R2,R4,LSL#2] ;clear iopt
    BGT    wc4
    MOV    R5,#1       ;to store in selected iopt
wc5 LDRB   ip,[R0],#1  ;char from iact
    SUB    R4,R3,#1
wc6 LDRB   lr,[R1,R4]  ;char from iposs
    CMP    ip,lr
    STREQ  R5,[R2,R4,LSL#2];char found
    BEQ    wc5         ;go try next iact
    SUBS   R4,R4,#1
    BGE    wc6         ;try next poss
    LDMDB  fp,{R4,R5,fp,sp,pc} ;return
    END
;
    TTL    UOPTC
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R5  RN     5
R4  RN     4
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT uoptc_;(CHACT,CHPOSS,IOPT) selects options
    DCB    "uoptc_",0,0,8,0,0,255
uoptc_
    MOV    ip,sp
    STMDB  sp!,{R0-R5,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    ip,[ip]     ;length of CHPOSS
wc1 LDRB   lr,[R1],#1  ;char from chposs
    SUB    R4,R3,#1    ;pointer in chact
wc2 LDRB   R5,[R0,R4]  ;char from chact
    CMP    R5,lr
    MOVEQ  R4,#-1      ;flag found
    SUBS   R4,R4,#1
    BGE    wc2         ;loop over act
    MVN    R4,R4       ;v1 = 0 if not found, =1 if found
    STR    R4,[R2],#4  ;store
wc3 SUBS   ip,ip,#1
    BGT    wc1         ;loop over chposs/iopt
    LDMDB  fp,{R4,R5,fp,sp,pc} ;return
    END
;
    TTL    UPKBYT
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
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 upkbyt_;(MA,JA,IY,N,MPACK) unpacks N bytes from packed vector MA
    DCB    "upkbyt_",0,8,0,0,255
upkbyt_
    MOV    ip,sp
    STMDB  sp!,{R0-R6,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    ip,[ip]    ;address of MPACK
    LDR    R1,[R1]    ;ja
    SUB    R1,R1,#1   ;ja-1
    LDR    R3,[R3]    ;n
    LDMIA  ip,{R4,R5} ;get nbits,inword
    CMP    R4,#0      ;check for default
    MOVLE  R4,#1      ;default nbits=1
    MOVLE  R5,#32     ;and inword=32
wu1 SUBS   R1,R1,R5
    ADDGE  R0,R0,#4
    BGE    wu1        ;move to first word
    ADD    R1,R1,R5
    MUL    R1,R4,R1   ;pointer to first byte
    LDR    ip,[R0],#4 ;1st input word
    MOV    R6,#-1
    BIC    R6,R6,R6,LSL R4;mask
    MUL    R5,R4,R5   ;# bits to use in o/p word
wu2 AND    lr,R6,ip,LSR R1;mask off byt
    STR    lr,[R2],#4 ;store byt
    ADD    R1,R1,R4
    CMP    R1,R5      ;check if word is finished
    MOVGE  R1,#0      ;initialise for new word
    LDRGE  ip,[R0],#4 ;load i/p word
    SUBS   R3,R3,#1
    BGT    wu2        ;loop over byts
    LDMDB  fp,{R4-R6,fp,sp,pc} ;return
    END
;
    TTL    UPKCH
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   slate__,COMMON,NOINIT
    %      160
    AREA   |C$$code|,CODE,READONLY
    EXPORT upkch_;(char,int,n,ipar) unpacks words from continuous byte string
    DCB    "upkch_",0,0,8,0,0,255
upkch_
    MOV    ip,sp
    STMDB  sp!,{R0-R9,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R2,[R2]      ;n
    LDMIA  R3,{R3-R6}   ;4 words of ipar
    CMP    R5,#0
    MOVEQ  R5,#32       ;set default zone
    CMP    R4,#0
    MOVEQ  R4,R5        ;default nchar
    STR    R4,[sp,#-4]! ;save bytes/zone
    MOV    R9,#-1
    BIC    R9,R9,R9,LSL R3;byt mask
    MOV    R8,#0        ;start bit
    MOV    lr,R3
wu1 SUB    lr,lr,R3;#bits remaining in zone
    CMP    lr,R3        ;check there is space in zone
    SUBGES ip,ip,#1     ;check there are more chars
    SUBLE  R8,R8,lr     ;allow for remaining space in zone
    LDRLE  ip,[sp]      ;remaining chars to store in zone
    SUBLE  lr,R5,R6     ;remaining space in zone
    SUBLES R8,R8,R6     ;skip the ignore space
wu2 LDRLE  R7,[R0],#4   ;read in next packed word
    ADDLES R8,R8,#32    ;reset bit pointer
    BLE    wu2          ;loop if still insufficient space
    SUBS   R8,R8,R3     ;move to next slot
    ANDGE  R4,R9,R7,LSR R8;get byte from this word
    RSBLT  R8,R8,#0
    ANDLT  R4,R9,R7,LSL R8;get partial byte from this word
    RSBLT  R8,R8,#32    ;reset bit pointer
    LDRLT  R7,[R0],#4   ;read in packed word
    ORRLT  R4,R4,R7,LSR R8;insert remaining bits
    STR    R4,[R1],#4   ;store byte
    SUBS   R2,R2,#1
    BGT    wu1          ;loop over characters
    LDR    R1,[sp,#4]   ;restore (CHAR)
    RSB    R1,R1,R0     ;#bytes read
    MOV    R1,R1,LSR#2  ;#words read
    LDR    R0,slpt
    STR    R1,[R0]      ;store in /SLATE/
    LDMDB  fp,{R4-R9,fp,sp,pc} ;return
slpt DCD    slate__      ;pointer to COMMON/SLATE/
    END
;
    TTL    URIGHT
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R4  RN     4
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
    AREA   slate__,COMMON,NOINIT
    %      160
;
    AREA   |C$$code|,CODE,READONLY
    EXPORT uright_;(CH,JL,JR) right justifies string CH(JL,JR)
    DCB    "uright_",0,8,0,0,255
uright_
    MOV    ip,sp
    STMDB  sp!,{R0-R2,R4,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R1,[R1]     ;jl
    LDR    R2,[R2]     ;jr
    LDR    R3,blnk
    MOV    lr,R2       ;output pointer
    MOV    ip,R2       ;initialize count
wa2 SUB    R2,R2,#1
    LDR    R4,[R0,R2,LSL#2]
    CMP    R4,R3       ;check for blank
    SUBNE  lr,lr,#1    ;if not, add to output
    CMPNE  R2,lr
    STRNE  R4,[R0,lr,LSL#2]
    STRNE  R3,[R0,R2,LSL#2]
    CMP    R1,R2
    BLE    wa2         ;loop until < jl
    SUB    ip,ip,lr    ;find # output
    LDR    R0,slpt
    STMIA  R0,{ip,lr}  ;store answers
    LDMDB  fp,{R4,fp,sp,pc} ;return
blnk DCB    "    "      ;blank ASCII word
slpt DCD    slate__     ;pointer to COMMON/SLATE/
    END
;
    TTL    USET
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R6  RN     6
R5  RN     5
R4  RN     4
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
    AREA   slate__,COMMON,NOINIT
    %      160
;
    AREA   |C$$code|,CODE,READONLY
    EXPORT uset_;(INT,CH,JL,JR) writes INT into CH(JL,JR) right justified
    DCB    "uset_",0,0,0,8,0,0,255
uset_
    MOV    ip,sp
    STMDB  sp!,{R0-R6,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R0,[R0]     ;int
    LDR    R2,[R2]     ;jl
    LDR    R3,[R3]     ;jr
    MOV    lr,R3       ;pointer to output word
    LDR    R4,zero     ;"0   "
wu1 MOV    R6,#33      ;divide R0 by 10
    MOV    R5,#0
wu2 CMP    R5,#10
    SUBCS  R5,R5,#10
    ADCS   R0,R0,R0
    ADC    R5,R5,R5
    SUBS   R6,R6,#1
    BGT    wu2         ;loop over bits
    ADD    R5,R4,R5,LSR#1;make to ASCII digit
    CMP    lr,R2       ;check for space
    SUBGE  lr,lr,#1
    STRGE  R5,[R1,lr,LSL#2]  ;store digit
    CMPGT  R0,#0
    BGT    wu1         ;get next digit
    SUB    ip,R3,lr    ;get # digits
    LDR    R0,slpt
    STMIA  R0,{ip,lr}  ;store answers
    LDMDB  fp,{R4-R6,fp,sp,pc} ;return
zero DCB    "0   "
slpt DCD    slate__     ;pointer to COMMON/SLATE/
    END
;
    TTL    USWOP
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
    AREA   |C$$code|,CODE,READONLY
;
    EXPORT uswop_;(A,B,N) swops arrays A and B
    DCB    "uswop_",0,0,8,0,0,255
uswop_
    MOV    ip,sp
    STMDB  sp!,{R0-R2,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R2,[R2]       ;N
slp SUBS   R2,R2,#1
    LDRGE  R3,[R0]
    LDRGE  ip,[R1]
    STRGE  R3,[R1],#4
    STRGE  ip,[R0],#4
    BGT    slp
    LDMDB  fp,{fp,sp,pc} ;return
    END
;
    TTL    UTRANS
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
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   slate__,COMMON,NOINIT
    %      160
    AREA   |C$$code|,CODE,READONLY
    EXPORT utrans_;(VI,VJ,NCH,I,J) converts one format Hollerith array to anothe
    DCB    "utrans_",0,8,0,0,255
utrans_
    MOV    ip,sp
    STMDB  sp!,{R0-R8,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    ip,[ip]     ;address of J
    MOV    R4,#0       ;NI
    MOV    R5,#0       ;NJ
    LDR    R2,[R2]     ;NCH
    LDR    R3,[R3]
    CMP    R3,#4
    MOVGT  R3,#4       ;I (<=4)
    LDR    ip,[ip]
    CMP    ip,#4
    MOVGT  ip,#4       ;J (<=4)
    CMP    R2,#0
    CMPGT  ip,#0
    CMPGT  R3,#0
    BLE    ut4         ;NCH,I,J <=0
    MOV    R8,#" "     ;blank
    MOV    R6,#0       ;bytes left in input word
ut1 MOV    R7,ip       ;bytes left to store
ut2 SUBS   R6,R6,#1
    MOVLE  R6,R3
    LDRLE  lr,[R0],#4  ;get word from VI
    ADDLE  R4,R4,#1    ;count NI
    MOVGT  lr,lr,LSR#8 ;otherwise move to next byte
    STRB   lr,[R1],#1  ;store byte in VJ
    SUBS   R2,R2,#1    ;count bytes to store
    SUBGTS R7,R7,#1    ;decrement count in word
    BGT    ut2
ut3 TST    R1,#3
    STRNEB R8,[R1],#1
    BNE    ut3
    ADD    R5,R5,#1    ;count NJ
    CMP    R2,#0
    BGT    ut1
ut4 LDR    lr,slpt
    STMIA  lr,{R4,R5}  ;store NI,NJ
    LDMDB  fp,{R4-R8,fp,sp,pc} ;return
slpt DCD    slate__
    END
;
;          UZERO see UFILL
;
    TTL    VADD
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
F3  FN     3
F2  FN     2
F1  FN     1
;
    AREA   |C$$code|,CODE,READONLY
    EXPORT vadd_;(A,B,X,N) X() = A() + B()
    DCB    "vadd_",0,0,0,8,0,0,255
vadd_
    MOV    ip,sp
    STMDB  sp!,{R0-R3,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R3,[R3]     ;n
wt1 SUBS   R3,R3,#1
    LDFGES F1,[R0],#4  ;Ai
    LDFGES F2,[R1],#4  ;Bi
    ADFGES F3,F1,F2    ;Xi = Ai+Bi
    STFGES F3,[R2],#4
    BGT    wt1         ;loop over i
    LDMDB  fp,{fp,sp,pc} ;return
    END
;
    TTL    VASUM
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R1  RN     1
R0  RN     0
F1  FN     1
F0  FN     0
;
    AREA   |C$$code|,CODE,READONLY
    EXPORT vasum_;(A,N)  returns sum(|A()|)
    DCB    "vasum_",0,0,8,0,0,255
vasum_
    MOV    ip,sp
    STMDB  sp!,{R0,R1,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R1,[R1]    ;N
    MVFS   F0,#0      ;init sum
ws1 SUBS   R1,R1,#1
    LDFGES F1,[R0],#4 ;Ai
    ABSGES F1,F1      ;|Ai|
    ADFGES F0,F0,F1   ;sum(|Ai|)
    BGT    ws1        ;loop over i
    LDMDB  fp,{fp,sp,pc} ;return
    END
;
    TTL    VBIAS
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R3  RN     3
R2  RN     2
R1  RN     1
F3  FN     3
F2  FN     2
F1  FN     1
R0  RN     0
;
    AREA   |C$$code|,CODE,READONLY
    EXPORT vbias_;(A,ALPHA,X,N) X() = A() + ALPHA
    DCB    "vbias_",0,0,8,0,0,255
vbias_
    MOV    ip,sp
    STMDB  sp!,{R0-R3,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R3,[R3]     ;n
    LDFS   F2,[R1]     ;alpha
wt4 SUBS   R3,R3,#1
    LDFGES F1,[R0],#4  ;Ai
    ADFGES F3,F1,F2    ;Xi = Ai+alpha
    STFGES F3,[R2],#4
    BGT    wt4         ;loop over i
    LDMDB  fp,{fp,sp,pc} ;return
    END
;
;          VBLANK see VFILL
;
    TTL    VCOPYN
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
;
    AREA   |C$$code|,CODE,READONLY
    EXPORT vcopyn_;(A,X,N) X() = -A()
    DCB    "vcopyn_",0,8,0,0,255
vcopyn_
    MOV    ip,sp
    STMDB  sp!,{R0-R2,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R2,[R2]     ;N
slp SUBS   R2,R2,#1
    LDRGE  R3,[R0],#4
    EORGE  R3,R3,#&80000000; change floating sign
    STRGE  R3,[R1],#4
    BGT    slp
    LDMDB  fp,{fp,sp,pc} ;return
    END
;
    TTL    VDIST
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R2  RN     2
R1  RN     1
R0  RN     0
F2  FN     2
F1  FN     1
F0  FN     0
;
    AREA   |C$$code|,CODE,READONLY
    EXPORT vdist_;(A,B,N) returns vector distance A()-B()
    DCB    "vdist_",0,0,8,0,0,255
vdist_
    MOV    ip,sp
    STMDB  sp!,{R0-R2,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R2,[R2]    ;N
    MVFS   F0,#0      ;init sum
wx5 SUBS   R2,R2,#1
    LDFGES F1,[R0],#4 ;A(i)
    LDFGES F2,[R1],#4 ;B(i)
    SUFGEE F1,F1,F2
    MUFGEE F2,F1,F1
    ADFGEE F0,F0,F2   ;sum(Ai-Bi)**2
    BGT    wx5        ;loop over i
    SQTS   F0,F0      ;square root
    LDMDB  fp,{fp,sp,pc} ;return
    END
;
    TTL    VDIST2
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R2  RN     2
R1  RN     1
R0  RN     0
F2  FN     2
F1  FN     1
F0  FN     0
;
    AREA   |C$$code|,CODE,READONLY
    EXPORT vdist2_;(A,B,N) returns ( A() - B() )**2
    DCB    "vdist2_",0,8,0,0,255
vdist2_
    MOV    ip,sp
    STMDB  sp!,{R0-R2,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R2,[R2]    ;N
    MVFE   F0,#0      ;init sum
wx4 SUBS   R2,R2,#1
    LDFGES F1,[R0],#4 ;A(i)
    LDFGES F2,[R1],#4 ;B(i)
    SUFGEE F1,F1,F2
    MUFGEE F2,F1,F1
    ADFGEE F0,F0,F2   ;sum(Ai-Bi)**2
    BGT    wx4
    LDMDB  fp,{fp,sp,pc} ;return
    END
;
    TTL    VDOT
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R2  RN     2
R1  RN     1
R0  RN     0
F2  FN     2
F1  FN     1
F0  FN     0
;
    AREA   |C$$code|,CODE,READONLY
    EXPORT vdot_;(A,B,N) dot product A().B()
    DCB    "vdot_",0,0,0,8,0,0,255
vdot_
    MOV    ip,sp
    STMDB  sp!,{R0-R2,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R2,[R2]    ;N
    MVFE   F0,#0      ;init sum
wx6 SUBS   R2,R2,#1
    LDFGES F1,[R0],#4 ;A(i)
    LDFGES F2,[R1],#4 ;B(i)
    MUFGEE F1,F2,F1
    ADFGEE F0,F0,F1   ;sum(Ai*Bi)
    BGT    wx6
    LDMDB  fp,{fp,sp,pc}  ;return
    END
;
    TTL    VDOTN
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
F5  FN     5
F4  FN     4
F3  FN     3
F2  FN     2
F1  FN     1
F0  FN     0
;
    AREA   |C$$code|,CODE,READONLY
    EXPORT vdotn_;(A,B,N) Cosine of angle between A() and B()
    DCB    "vdotn_",0,0,8,0,0,255
vdotn_
    MOV    ip,sp
    STMDB  sp!,{R0-R2,fp,ip,lr,pc}
    SUB    fp,ip,#4
    STFE   F4,[sp,#-12]!;preserve F4
    STFE   F5,[sp,#-12]!;preserve F5
    LDR    R2,[R2]    ;N
    MVFE   F0,#0      ;init sum a.b
    MVFE   F3,F0      ;init sum a**2
    MVFE   F4,F0      ;init sum b**2
wx7 SUBS   R2,R2,#1
    LDFGES F1,[R0],#4 ;A(i)
    LDFGES F2,[R1],#4 ;B(i)
    MUFGEE F5,F1,F2
    ADFGEE F0,F0,F5   ;sum(A(i)*B(i))
    MUFGEE F5,F1,F1
    ADFGEE F3,F3,F5   ;sum(Ai**2)
    MUFGEE F5,F2,F2
    ADFGEE F4,F4,F5   ;sum(Bi**2)
    BGT    wx7        ;loop over i
    CMF    F0,#0
    MUFNEE F3,F3,F4   ;A**2*B**2
    SQTNEE F2,F3      ;SQRT(A**2*B**2)
    FDVNES F0,F0,F2   ;(A*B)/SQRT(A**2*B**2))
    LDFE   F5,[sp],#12;restore F5
    LDFE   F4,[sp],#12;restore F4
    LDMDB  fp,{fp,sp,pc} ;return
    END
;
    TTL    VDOTN2
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
F5  FN     5
F4  FN     4
F3  FN     3
F2  FN     2
F1  FN     1
F0  FN     0
;
    AREA   |C$$code|,CODE,READONLY
    EXPORT vdotn2_;(A,B,N) ( A().B() )**2 / (A()**2 * B()**2)
    DCB    "vdotn2_",0,8,0,0,255
vdotn2_
    MOV    ip,sp
    STMDB  sp!,{R0-R2,fp,ip,lr,pc}
    SUB    fp,ip,#4
    STFE   F4,[sp,#-12]!;preserve F4
    STFE   F5,[sp,#-12]!;preserve F5
    LDR    R2,[R2]    ;N
    MVFE   F0,#0      ;init sum a.b
    MVFE   F3,F0      ;init sum a**2
    MVFE   F4,F0      ;init sum b**2
wx7 SUBS   R2,R2,#1
    LDFGES F1,[R0],#4 ;A(i)
    LDFGES F2,[R1],#4 ;B(i)
    MUFGEE F5,F1,F2
    ADFGEE F0,F0,F5   ;sum(A(i)*B(i))
    MUFGEE F5,F1,F1
    ADFGEE F3,F3,F5   ;sum(Ai**2)
    MUFGEE F5,F2,F2
    ADFGEE F4,F4,F5   ;sum(Bi**2)
    BGT    wx7        ;loop over i
    CMF    F0,#0
    MUFNEE F0,F0,F0   ;(A*B)**2
    MUFNEE F3,F3,F4   ;A**2*B**2
    FDVNES F0,F0,F3   ;(A*B)**2/(A**2*B**2)
    LDFE   F5,[sp],#12;restore F5
    LDFE   F4,[sp],#12;restore F4
    LDMDB  fp,{fp,sp,pc} ;return
    END
;
    TTL    VERIFY
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R5  RN     5
R4  RN     4
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT verify_;(STR,SET) ==> location (integer!) of first character not in S
    DCB    "verify_",0,8,0,0,255
verify_
    MOV    ip,sp
    STMDB  sp!,{R0-R5,fp,ip,lr,pc}
    SUB    fp,ip,#4
    ADD    R3,R3,R1    ;end of set
    ADD    R4,R2,#1    ;1+ length of str
wv1 MOV    R5,R1       ;start of set
    LDRB   ip,[R0],#1  ;character from str
wv2 LDRB   lr,[R5],#1  ;character from set
    CMP    ip,lr
    CMPNE  R5,R3
    BLT    wv2         ;loop over set
    CMP    ip,lr
    BNE    wv3
    SUBS   R2,R2,#1
    BGT    wv1         ;loop over str
wv3 SUBNE  R0,R4,R2    ;character position in str
    LDMDB  fp,{R4,R5,fp,sp,pc} ;return
    END
;
    TTL    VEXCUM
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R2  RN     2
R1  RN     1
R0  RN     0
F3  FN     3
F2  FN     2
F1  FN     1
F0  FN     0
;
    AREA   |C$$code|,CODE,READONLY
    EXPORT vexcum_;(A,EX,N) finds minimum, maximum and sum of A()
    DCB    "vexcum_",0,8,0,0,255
vexcum_
    MOV    ip,sp
    STMDB  sp!,{R0-R2,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R2,[R2]    ;N
    CMP    R2,#0
    LDMLEDB fp,{fp,sp,pc} ;return if <=0
    LDFS   F1,[R1]    ;init minimum
    LDFS   F2,[R1,#4] ;init maximum
    LDFS   F3,[R1,#8] ;init sum
wx3 LDFS   F0,[R0],#4 ;A(i)
    ADFE   F3,F3,F0   ;sum of A
    CMF    F0,F1
    MVFLTS F1,F0      ;minimum of A
    CMF    F0,F2
    MVFGTS F2,F0
    SUBS   R2,R2,#1
    BGT    wx3
    STFS   F1,[R1]    ;store EX(1)
    STFS   F2,[R1,#4] ;store EX(2)
    STFS   F3,[R1,#8] ;store EX(3)
    LDMDB  fp,{fp,sp,pc} ;return
    END
;
    TTL    VFILL
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 vfill_;(BUF,N,VAR) BUF() = VAR
    DCB    "vfill_",0,0,8,0,0,255
vfill_
    MOV    ip,sp
    STMDB  sp!,{R0-R2,R4-R9,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R2,[R2]    ;var
    B      wz1
;
    EXPORT vblank_;(BUF,N) BUF() = 4H
    DCB    "vblank_",0,8,0,0,255
vblank_
    MOV    ip,sp
    STMDB  sp!,{R0-R1,R4-R9,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R2,blk
    B      wz1
blk DCB   "    "
;
    EXPORT vzero_;(BUF,N) BUF() = 0
    DCB    "vzero_",0,0,8,0,0,255
vzero_
    MOV    ip,sp
    STMDB  sp!,{R0-R1,R4-R9,fp,ip,lr,pc}
    SUB    fp,ip,#4
    MOV    R2,#0
wz1 LDR    R1,[R1]    ;N
    MOV    R3,R2      ;fill 8 registers with number
    MOV    R4,R2
    MOV    R5,R2
    MOV    R6,R2
    MOV    R7,R2
    MOV    R8,R2
    MOV    R9,R2
wz2 SUBS   R1,R1,#8
    STMGEIA R0!,{R2-R9};store 8 words
    BGT    wz2        ;loop over blocks of 8 words
    ADDLT  R1,R1,#8   ;restore count
wz3 SUBS   R1,R1,#1
    STRGE  R2,[R0],#4 ;store a word
    BGT    wz3        ;loop over single words
    LDMDB  fp,{R4-R9,fp,sp,pc} ;return
    END
;
    TTL    VFIX
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
F0  FN     0
;
    AREA   |C$$code|,CODE,READONLY
    EXPORT vfix_;(A,IX,N) IX() = A()
    DCB    "vfix_",0,0,0,8,0,0,255
vfix_
    MOV    ip,sp
    STMDB  sp!,{R0-R2,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R2,[R2]     ;N
wx1 SUBS   R2,R2,#1
    LDFGES F0,[R0],#4  ;A(i)
    FIXGEZ R3,F0      ;fix, rounding towards zero
    STRGE  R3,[R1],#4  ;store in IX(i)
    BGT    wx1
    LDMDB  fp,{fp,sp,pc} ;return
    END
;
    TTL    VFLOAT
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
F0  FN     0
;
    AREA   |C$$code|,CODE,READONLY
    EXPORT vfloat_;(IA,X,N) X() = IA()
    DCB    "vfloat_",0,8,0,0,255
vfloat_
    MOV    ip,sp
    STMDB  sp!,{R0-R2,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R2,[R2]     ;N
wx2 SUBS   R2,R2,#1
    LDRGE  R3,[R0],#4  ;IA(i)
    FLTGES F0,R3       ;float
    STFGES F0,[R1],#4  ;store in X(i)
    BGT    wx2
    LDMDB  fp,{fp,sp,pc} ;return
    END
;
    TTL   VIZPRI
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
R4  RN     4
R5  RN     5
R6  RN     6
R7  RN     7
R8  RN     8
mxtext EQU 9
mxchar EQU 128     ;14*mxtext rounded up to multiple of 4
    AREA   |C$$code|,CODE,READONLY
    EXPORT vizpri_ ;(LUN,TEXT) sends banner text to stream LUN
    IMPORT __rt_stkovf_split_small
    IMPORT io_start_we
    IMPORT io_end
    IMPORT io_do_single
;
    DCB    "vizpri_",0,8,0,0,255
vizpri_
    MOV    ip,sp
    STMDB  sp!,{R0-R2,R4-R8,fp,ip,lr,pc}
    SUB    fp,ip,#4
    CMP    sp,sl
    BLLT   __rt_stkovf_split_small
    SUB    sp,sp,#mxchar+4*mxtext  ;work space
    CMP    R2,#mxchar
    MOVGT  R2,#mxchar
    MOVS   R5,R2
    LDMLEDB fp,{R4-R8,fp,sp,pc} 
    LDR    R4,[R0]      ;LUN
    CMP    R4,#0
    MOVLE  R4,#6        ;set LUN to 6 if was <=0
    SUB    R3,R5,#1
lp1 LDRB   ip,[R1,R3]
    SUBS   ip,ip,#32
    MOVLE  ip,#0
    CMP    ip,#92
    MOVGT  ip,#0
    STR    ip,[sp,R3,LSL#2] ;move translated text to stack
    SUBS   R3,R3,#1
    BGE    lp1
    ADD    R6,sp,R5,LSL#2   ;pointer to 'line' on stack
    MOV    R0,R4
    MOV    R1,#-1
    BL     io_start_we
    BL     io_end           ;write out blank line
    MOV    R7,#0            ;line count
lp2 MOV    R0,R6            ;character bit count
    MOV    R1,#0            ;character count
    MOV    R3,#" "          ;blank
lp3 LDR    ip,[sp,R1,LSL#2] ;'character' index
    ADD    lr,ip,#32        ;character
    CMP    ip,#64+26        ;fix up for lower case
    ADDGT  ip,ip,#32-26
    CMP    ip,#64
    SUBGT  ip,ip,#32
    ADD    ip,ip,ip,LSL#1   ;index*3
    ADR    R2,c20
    ADD    ip,R2,ip,LSL#3   ;c20+index*24 = pointer to character data
    ADD    R2,R7,R7
    BIC    R2,R2,#3         ;word address in data
    LDR    R2,[ip,R2]       ;word
    TST    R7,#1            ;check for odd line
    MOVNE  R2,R2,LSR#16     ;get required bits
    STRB   R3,[R0],#1       ;start with blank
    MOV    ip,#12
lp4 MOVS   R2,R2,LSR#1
    STRCSB lr,[R0],#1       ;store character for 1 bit
    STRCCB R3,[R0],#1       ;store blank for 0 bit
    SUBS   ip,ip,#1
    BGT    lp4
    STRB   R3,[R0],#1       ;end with blank
    ADD    R1,R1,#1
    CMP    R1,R5
    BLT    lp3              ;loop over characters
    SUB    R8,R0,R6         ;# characters in line
    MOV    R0,R4
    ADR    R1,fmt
    BL     io_start_we
    MOV    R0,R6
    MOV    R1,R8
    BL     io_do_single
    BL     io_end           ;write out line
    ADD    R7,R7,#1
    CMP    R7,#12
    BLT    lp2              ;loop over lines
    MOV    R0,R4
    MOV    R1,#-1
    BL     io_start_we
    BL     io_end           ;write out blank line
    LDMDB  fp,{R4-R8,fp,sp,pc} ;return
fmt DCB  "(A)",0
c20 DCD  &00000000,&00000000,&00000000,&00000000,&00000000,&00000000
c21 DCD  &00600060,&00600060,&00600060,&00600060,&00000000,&00600060
c22 DCD  &01980198,&00000198,&00000000,&00000000,&00000000,&00000000
c23 DCD  &01980198,&0FFF0198,&01980FFF,&0FFF0198,&01980FFF,&01980198
c24 DCD  &07FE0060,&00630E67,&03FE0067,&0E6007FC,&0E670C60,&006007FE
c25 DCD  &061C0000,&019C0314,&006000C0,&00180030,&014601CC,&000001C3
c26 DCD  &00FC0078,&00CC00CC,&007800FC,&0DC60CFC,&07030783,&0CFE0FFF
c27 DCD  &00600060,&00000060,&00000000,&00000000,&00000000,&00000000
c28 DCD  &006001C0,&00300030,&00180018,&00180018,&00300030,&01C00060
c29 DCD  &00600038,&00C000C0,&01800180,&01800180,&00C000C0,&00380060
c2A DCD  &06660060,&03FC076E,&0FFF01F8,&01F80FFF,&076E03FC,&00600666
c2B DCD  &00600000,&00600060,&07FE0060,&006007FE,&00600060,&00000060
c2C DCD  &00000000,&00000000,&00000000,&00000000,&00000000,&00300060
c2D DCD  &00000000,&00000000,&07FE0000,&000007FE,&00000000,&00000000
c2E DCD  &00000000,&00000000,&00000000,&00000000,&00000000,&00600060
c2F DCD  &06000000,&01800300,&006000C0,&00180030,&0006000C,&00000003
c30 DCD  &07FE03FC,&0C030C03,&0C030C03,&0C030C03,&0C030C03,&03FC07FE
c31 DCD  &00700060,&00600078,&00600060,&00600060,&00600060,&07FE07FE
c32 DCD  &0FFF07FE,&0C000C03,&06000C00,&00600180,&00060018,&0FFF0FFF
c33 DCD  &0FFF07FE,&0C000C03,&07800C00,&0C000780,&0C030C00,&07FE0FFF
c34 DCD  &01E001C0,&019801B0,&0FFE018C,&01800FFF,&01800180,&01800180
c35 DCD  &0FFF0FFF,&00030003,&01FF0003,&060003FF,&0C000C00,&07FF0FFF
c36 DCD  &0FFF07FE,&00030C03,&07FF0003,&0C030FFF,&0C030C03,&07FE0FFF
c37 DCD  &07FF0FFF,&01800303,&006000C0,&00600060,&00600060,&00600060
c38 DCD  &0FFF07FE,&0C030C03,&03FC0606,&060603FC,&0C030C03,&07FE0FFF
c39 DCD  &0FFF07FE,&0C030C03,&0FFF0C03,&0C000FFF,&0C030C00,&07FE0FFF
c3A DCD  &00000000,&00600000,&00000060,&00600000,&00000060,&00000000
c3B DCD  &00000000,&00000000,&00000000,&00600000,&00600000,&00300060
c3C DCD  &00C00180,&00300060,&000C0018,&0018000C,&00600030,&018000C0
c3D DCD  &00000000,&07FE0000,&000007FE,&07FE0000,&000007FE,&00000000
c3E DCD  &00300018,&00C00060,&03000180,&01800300,&006000C0,&00180030
c3F DCD  &0FFF07FE,&0C000C03,&07E00E00,&006003E0,&00000060,&00600060
c40 DCD  &0FFF07FE,&0CF30C03,&0D9B0DFB,&0DF30D9B,&07030FF3,&003E003F
c41 DCD  &0FFF07FE,&0C030C03,&0FFF0C03,&0C030FFF,&0C030C03,&0C030C03
c42 DCD  &0FFF07FF,&0C030C03,&03FF0603,&060303FF,&0C030C03,&07FF0FFF
c43 DCD  &0FFF07FE,&00030C03,&00030003,&00030003,&0C030003,&07FE0FFF
c44 DCD  &03FF01FF,&0C030603,&0C030C03,&0C030C03,&06030C03,&01FF03FF
c45 DCD  &0FFF0FFF,&00030003,&00FF0003,&000300FF,&00030003,&0FFF0FFF
c46 DCD  &0FFF0FFF,&00030003,&00FF0003,&000300FF,&00030003,&00030003
c47 DCD  &0FFF07FE,&00030C03,&00030003,&0F830F83,&0C030C03,&07FE0FFF
c48 DCD  &0C030C03,&0C030C03,&0FFF0C03,&0C030FFF,&0C030C03,&0C030C03
c49 DCD  &07FE07FE,&00600060,&00600060,&00600060,&00600060,&07FE07FE
c4A DCD  &0FFC0FFC,&00C000C0,&00C000C0,&00C000C0,&00C300C3,&007E00FF
c4B DCD  &06030C03,&01830303,&007F00C3,&00C3007F,&03030183,&0C030603
c4C DCD  &00030003,&00030003,&00030003,&00030003,&00030003,&0FFF0FFF
c4D DCD  &0E070C03,&0D9B0F0F,&0C630CF3,&0C030C03,&0C030C03,&0C030C03
c4E DCD  &0C070C03,&0C1B0C0F,&0C630C33,&0D830CC3,&0E030F03,&08030C03
c4F DCD  &0FFF0FFF,&0C030C03,&0C030C03,&0C030C03,&0C030C03,&0FFF0FFF
c50 DCD  &0FFF07FF,&0C030C03,&0FFF0C03,&000307FF,&00030003,&00030003
c51 DCD  &0FFF07FE,&0C030C03,&0C030C03,&0CC30C03,&0F030D83,&0DFE07FF
c52 DCD  &0FFF07FF,&0C030C03,&0FFF0C03,&00C307FF,&03030183,&0C030603
c53 DCD  &0FFF07FE,&00030C03,&03FE0007,&0E0007FC,&0C030C00,&07FE0FFF
c54 DCD  &0FFF0FFF,&00600060,&00600060,&00600060,&00600060,&00600060
c55 DCD  &0C030C03,&0C030C03,&0C030C03,&0C030C03,&0C030C03,&07FE0FFF
c56 DCD  &0C030C03,&0C030C03,&0C030C03,&06060C03,&0198030C,&006000F0
c57 DCD  &0C030C03,&0C030C03,&0C030C03,&0CF30C63,&0F0F0D9B,&0C030E07
c58 DCD  &0C030C03,&030C0606,&00F00198,&019800F0,&0606030C,&0C030C03
c59 DCD  &0C030C03,&030C0606,&00F00198,&00600060,&00600060,&00600060
c5A DCD  &0FFF0FFF,&03000600,&00C00180,&00300060,&000C0018,&0FFF0FFE
c5B DCD  &000C03FC,&000C000C,&000C000C,&000C000C,&000C000C,&03FC000C
c5C DCD  &00060000,&0018000C,&00600030,&018000C0,&06000300,&00000C00
c5D DCD  &030003FC,&03000300,&03000300,&03000300,&03000300,&03FC0300
c5E DCD  &00F00060,&030C0198,&00000000,&00000000,&00000000,&00000000
c5F DCD  &00000000,&00000000,&00000000,&00000000,&00000000,&0FFF0FFF
c60 DCD  &00600030,&000000C0,&00000000,&00000000,&00000000,&00000000
c7B DCD  &00000000,&00000000,&00000000,&00000000,&00000000,&00000000
c7C DCD  &00600060,&00600060,&00600060,&00600060,&00600060,&00600060
    END
;
    TTL    VLINCO
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
F3  FN     3
F2  FN     2
F1  FN     1
F0  FN     0
;
    AREA   |C$$code|,CODE,READONLY
    EXPORT vlinco_;(A,F1,B,F2,X,N) X() = A()*F1 + B()*F2
    DCB    "vlinco_",0,8,0,0,255
vlinco_
    MOV    ip,sp
    STMDB  sp!,{R0-R3,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDFS   F1,[R1]     ;F1
    LDFS   F2,[R3]     ;F2
    LDR    R1,[ip]     ;address of x
    LDR    R3,[ip,#4]  ;address of n
    LDR    R3,[R3]     ;n
wt6 SUBS   R3,R3,#1
    LDFGES F0,[R0],#4  ;Ai
    FMLGES F0,F0,F1    ;Ai*F1
    LDFGES F3,[R2],#4  ;Bi
    FMLGES F3,F3,F2    ;Bi*F2
    ADFGES F0,F0,F3
    STFGES F0,[R1],#4  ;Xi = Ai*f1 +Bi*f2
    BGT    wt6         ;loop over i
    LDMDB  fp,{fp,sp,pc} ;return
    END
;
    TTL    VMATL
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
F2  FN     2
F1  FN     1
F0  FN     0
;
    AREA   |C$$code|,CODE,READONLY
    EXPORT vmatl_;(G,C,X,N,M) X(j)=C(i)*G(i,j) i=1,M  j=1,N
    DCB    "vmatl_",0,0,8,0,0,255
vmatl_
    MOV    ip,sp
    STMDB  sp!,{R0-R3,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    ip,[ip]     ;(M)
    LDR    R3,[R3]     ;N
    LDR    lr,[ip]     ;M
wm3 SUBS   R3,R3,#1
    LDMLTDB fp,{fp,sp,pc} ;return after n loops
    MOV    ip,lr       ;M (count of i)
    MVFE   F0,#0       ;init accumulator
wm4 SUBS   ip,ip,#1
    LDFGES F1,[R0],#4  ;G(i,j)
    LDFGES F2,[R1],#4  ;C(i)
    MUFGEE F1,F2,F1    ;G(i,j) * C(i)
    ADFGEE F0,F0,F1    ;sum
    BGT    wm4         ;loop over i
    STFS   F0,[R2],#4  ;X(j) = sum
    SUB    R1,R1,lr,LSL#2;restore (C(1))
    B      wm3         ;loop over j
    END
;
    TTL    VMATR
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R7  RN     7
R6  RN     6
R5  RN     5
R4  RN     4
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
F3  FN     3
F2  FN     2
F1  FN     1
F0  FN     0
;
    AREA   |C$$code|,CODE,READONLY
    EXPORT vmatr_;(A,G,V,N,M) V(j)=G(j,i)*A(i), i=1,N  j=1,M
    DCB    "vmatr_",0,0,8,0,0,255
vmatr_
    MOV    ip,sp
    STMDB  sp!,{R0-R7,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    ip,[ip]     ;(M)
    LDR    R4,[ip]     ;M
    MOVS   R7,R4       ;j-count
    LDR    R3,[R3]     ;N
wm1 SUBS   R7,R7,#1    ;count j
    LDMLTDB fp,{R4-R7,fp,sp,pc} ;return when j-count <0
    MOV    R5,R1       ;(G(j,1))
    MOV    R6,R0       ;(A(1))
    MVFE   F0,#0       ;accumulator
    MOV    ip,R3       ;i-count
wm2 SUBS   ip,ip,#1
    LDFGES F1,[R5]     ;G(j,i)
    LDFGES F2,[R6],#4  ;A(i)
    MUFGEE F3,F1,F2
    ADFGEE F0,F0,F3    ;sum A(i)*G(j,i)
    ADDGE  R5,R5,R4,LSL#2;(G(j,i+1))
    BGT    wm2         ;loop over i
    STFS   F0,[R2],#4  ;store V(j)
    ADD    R1,R1,#4    ;(G(j+1,1))
    B      wm1         ;loop over j
    END
;
;          VMAX see VMINMAX
;          VMAXA see VMINMAX
;          VMIN see VMINMAX
;          VMINA see VMINMAX
;
    TTL    VMINMAX
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R7  RN     7
R6  RN     6
R5  RN     5
R4  RN     4
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
F0  FN     0
;
    AREA   |C$$code|,CODE,READONLY
    EXPORT lvsmi_ ;(A,N,INC) index of minimum of A(I), I=1,N*INC,INC
    DCB    "lvsmi_",0,0,8,0,0,255
lvsmi_
    MOV    ip,sp
    STMDB  sp!,{R0-R2,R4-R7,fp,ip,lr,pc}
    SUB    fp,ip,#4
    MOV    R3,#0       ;use signed values
    LDR    R2,[R2]     ;inc
    B      mv2
;
    EXPORT lvmin_ ;(A,N) index of minimum of A()
    EXPORT vmin_  ;(A,N) minimum of A()
    DCB    "lvmin_",0,0,8,0,0,255
lvmin_
vmin_
    MOV    ip,sp
    STMDB  sp!,{R0,R1,R4-R7,fp,ip,lr,pc}
    SUB    fp,ip,#4
    MOV    R3,#0       ;use signed values
    B      mv1
;
    EXPORT lvmina_;(A,N) index of minimum of |A()|
    EXPORT vmina_ ;(A,N) minimum of |A()|
    DCB    "lvmina_",0,8,0,0,255
lvmina_
vmina_
    MOV    ip,sp
    STMDB  sp!,{R0,R1,R4-R7,fp,ip,lr,pc}
    SUB    fp,ip,#4
    MOV    R3,#&80000000;use |values|
mv1 MOV    R2,#1       ;inc
mv2 MVN    ip,#0       ;find minimum
    B      vm3
;
    EXPORT lvsmx_ ;(A,N,INC) index of maximum of A(I), I=1,N*INC,INC
    DCB    "lvsmx_",0,0,8,0,0,255
lvsmx_
    MOV    ip,sp
    STMDB  sp!,{R0-R2,R4-R7,fp,ip,lr,pc}
    SUB    fp,ip,#4
    MOV    R3,#0       ;use signed values
    LDR    R2,[R2]
    B      vm2
;
    EXPORT lvmax_ ;(A,N) index of maximum of A()
    EXPORT vmax_  ;(A,N) maximum of A()
    DCB    "lvmax_",0,0,8,0,0,255
lvmax_
vmax_
    MOV    ip,sp
    STMDB  sp!,{R0,R1,R4-R7,fp,ip,lr,pc}
    SUB    fp,ip,#4
    MOV    R3,#0       ;use signed values
    B      vm1
;
    EXPORT lvmaxa_;(A,N) index of maximum of |A()|
    EXPORT vmaxa_ ;(A,N) maximum of |A()|
    DCB    "lvmaxa_",0,8,0,0,255
lvmaxa_
vmaxa_
    MOV    ip,sp
    STMDB  sp!,{R0,R1,R4-R7,fp,ip,lr,pc}
    SUB    fp,ip,#4
    MOV    R3,#&80000000;use |values|
vm1 MOV    R2,#1       ;inc
vm2 MOV    ip,#0       ;find maximum
vm3 LDR    R1,[R1]     ;N
    MOV    R4,#&80000000;init max value
    MVN    lr,R4       ;mask
    CMP    R1,#0
    MOVLE  R0,#0
    BLE    wl2
    SUB    R5,R0,R2,LSL#2  ;index
wl1 LDR    R6,[R5,R2,LSL#2]!
    BICS   R6,R6,R3    ;take abs value if required
    EORMI  R6,R6,lr    ;fix up format of negatives
    EOR    R6,R6,ip    ;max or min
    CMP    R6,R4
    MOVGT  R4,R6       ;save max value
    SUBGT  R7,R5,R0    ;save max index
    SUBS   R1,R1,#1
    BGT    wl1         ;loop over values
    EORS   R4,R4,ip    ;restore true value
    EORMI  R4,R4,lr
    MOV    R0,R7,LSR#2 ;calculate fortran index
    ADD    R0,R0,#1
wl2 STR    R4,[sp,#-4]!;transfer floating value to F0
    LDFS   F0,[sp],#4
    LDMDB  fp,{R4-R7,fp,sp,pc} ;return
    END
;
    TTL    VMOD
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R1  RN     1
R0  RN     0
F2  FN     2
F1  FN     1
F0  FN     0
;
    AREA   |C$$code|,CODE,READONLY
    EXPORT vmod_;(A,N) |A()|
    DCB    "vmod_",0,0,0,8,0,0,255
vmod_
    MOV    ip,sp
    STMDB  sp!,{R0,R1,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R1,[R1]    ;N
    MVFS   F0,#0      ;init sum
wx9 SUBS   R1,R1,#1
    LDFGES F1,[R0],#4 ;Ai
    FMLGES F2,F1,F1
    ADFGES F0,F0,F2   ;sum(Ai**2)
    BGT    wx9        ;loop over i
    SQTS   F0,F0      ;square root
    LDMDB  fp,{fp,sp,pc} ;return
    END
;
    TTL    VMUL
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
F3  FN     3
F2  FN     2
F1  FN     1
;
    AREA   |C$$code|,CODE,READONLY
    EXPORT vmul_;(A,B,X,N) X() = A()*B()
    DCB    "vmul_",0,0,0,8,0,0,255
vmul_
    MOV    ip,sp
    STMDB  sp!,{R0-R3,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R3,[R3]     ;n
wt3 SUBS   R3,R3,#1
    LDFGES F1,[R0],#4  ;Ai
    LDFGES F2,[R1],#4  ;Bi
    FMLGES F3,F1,F2    ;Xi = Ai*Bi
    STFGES F3,[R2],#4
    BGT    wt3         ;loop over i
    LDMDB  fp,{fp,sp,pc} ;return
    END
;
    TTL    VSCALE
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
F3  FN     3
F2  FN     2
F1  FN     1
;
    AREA   |C$$code|,CODE,READONLY
    EXPORT vscale_;(A,ALPHA,X,N) X() = A()*ALPHA
    DCB    "vscale_",0,8,0,0,255
vscale_
    MOV    ip,sp
    STMDB  sp!,{R0-R3,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R3,[R3]       ;n
    LDFS   F2,[R1]       ;alpha
wt5 SUBS   R3,R3,#1
    LDFGES F1,[R0],#4    ;Ai
    FMLGES F3,F1,F2      ;Xi = Ai*alpha
    STFGES F3,[R2],#4
    BGT    wt5           ;loop over i
    LDMDB  fp,{fp,sp,pc} ;return
    END
;
    TTL    VSUB
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
F3  FN     3
F2  FN     2
F1  FN     1
;
    AREA   |C$$code|,CODE,READONLY
    EXPORT vsub_;(A,B,X,N) X() = A() - B()
    DCB    "vsub_",0,0,0,8,0,0,255
vsub_
    MOV    ip,sp
    STMDB  sp!,{R0-R3,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R3,[R3]     ;n
wt2 SUBS   R3,R3,#1
    LDFGES F1,[R0],#4  ;Ai
    LDFGES F2,[R1],#4  ;Bi
    SUFGES F3,F1,F2    ;Xi = Ai-Bi
    STFGES F3,[R2],#4
    BGT    wt2         ;loop over i
    LDMDB  fp,{fp,sp,pc} ;return
    END
;
    TTL    VSUM
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R1  RN     1
R0  RN     0
F1  FN     1
F0  FN     0
;
    AREA   |C$$code|,CODE,READONLY
    EXPORT vsum_;(A,N) sum A()
    DCB    "vsum_",0,0,0,8,0,0,255
vsum_
    MOV    ip,sp
    STMDB  sp!,{R0-R1,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R1,[R1]    ;N
    MVFE   F0,#0      ;init sum
ws2 SUBS   R1,R1,#1
    LDFGES F1,[R0],#4 ;Ai
    ADFGEE F0,F0,F1   ;sum(Ai)
    BGT    ws2        ;loop over i
    LDMDB  fp,{fp,sp,pc} ;return
    END
;
    TTL    VUNIT
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
F2  FN     2
F1  FN     1
F0  FN     0
;
    AREA   |C$$code|,CODE,READONLY
    EXPORT vunit_;(A,X,N) A() = A()/|A()|
    DCB    "vunit_",0,0,8,0,0,255
vunit_
    MOV    ip,sp
    STMDB  sp!,{R0-R2,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R2,[R2]     ;n
    ADD    R3,R0,R2,LSL#2;(A(n+1))
    MVFS   F0,#0       ;zero acculumator
wt7 CMP    R3,R0
    LDFGTS F1,[R3,#-4]!;Ai
    FMLGTS F2,F1,F1    ;Ai**2
    ADFGTS F0,F0,F2    ;sum(Ai**2)
    BGT    wt7         ;loop over i
    CMF    F0,#0
    LDMEQDB fp,{fp,sp,pc} ;return if null vector
    SQTS   F0,F0
    FRDS   F0,F0,#1    ;1 / |a|
wt8 LDFS   F1,[R0],#4  ;Ai
    FMLS   F2,F1,F0
    STFS   F2,[R1],#4  ;Xi = Ai/|a|
    SUBS   R2,R2,#1
    BGT    wt8         ;loop over i
    LDMDB  fp,{fp,sp,pc} ;return
    END
;
    TTL   vxinvb
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R0  RN     0
R1  RN     1
R2  RN     2
;
    AREA   |C$$code|,CODE,READONLY
    EXPORT vxinvb_;(IW,N) inverts bytes in N words of IW
    EXPORT vxinvc_;(IV,IW,N) inverts bytes in N words of IV into IW
;
    DCB    "vxinvc_",0,8,0,0,255
vxinvc_
    MOV    ip,sp
    STMDB  sp!,{R0-R2,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R2,[R2]       ;N
    B      lp1
;
    DCB    "vxinvb_",0,8,0,0,255
vxinvb_
    MOV    ip,sp
    STMDB  sp!,{R0-R1,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R2,[R1]       ;N
    MOV    R1,R0         ;(result) = (IW)
lp1 SUBS   R2,R2,#1
    LDRGE  ip,[R0],#4
    STRGEB ip,[R1,#3]
    MOVGE  ip,ip,LSR#8
    STRGEB ip,[R1,#2]
    MOVGE  ip,ip,LSR#8
    STRGEB ip,[R1,#1]
    MOVGE  ip,ip,LSR#8
    STRGEB ip,[R1],#4
    BGT    lp1
    LDMDB  fp,{fp,sp,pc} ;return
    END
;
;          VXINVC see VXINVB
;          VZERO  see VFILL
;
    TTL    wheneq
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R4  RN     4
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT wheneq_;(NW,IA,INC,IT,INDX,NF) finds pointers to IA(I)=IT
    DCB    "wheneq_",0,8,0,0,255
wheneq_
    MOV    ip,sp
    STMDB  sp!,{R0-R4,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R0,[R0]     ;NW
    LDR    R2,[R2]     ;INC
    LDR    R3,[R3]     ;IT
    LDR    R4,[fp,#4]  ;(INDX)
    MOV    ip,#1       ;initialise pointer (J)
lp1 SUBS   R0,R0,#1
    LDRCS  lr,[R1],R2,LSL#2;A(J)
    TEQCS  lr,R3
    STREQ  ip,[R4],#4  ;store INDX(NF) = J
    ADDCS  ip,ip,R2    ;J = J + INC
    BCS    lp1
    LDMIB  fp,{R0,R1}  ;(INDX),(NF)
    SUB    R4,R4,R0
    MOV    R4,R4,LSR#2
    STR    R4,[R1]     ;store NF
    LDMDB  fp,{R4,fp,sp,pc} 
    END
;
    TTL    whenfge
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R5  RN     5
R4  RN     4
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT whenfge_;(NW,A,INC,T,INDX,NF) finds pointers to  A(I)>=T
    DCB    "whenfge_",0,0,0,0,12,0,0,255
whenfge_
    MOV    ip,sp
    STMDB  sp!,{R0-R5,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R0,[R0]     ;NW
    LDR    R2,[R2]     ;INC
    LDR    R3,[R3]     ;T
    MOV    lr,R3,ASR#31
    EOR    R3,R3,lr,LSR#1;correct for negative
    LDR    R4,[fp,#4]  ;(INDX)
    MOV    R5,#1       ;initialise pointer (J)
lp1 SUBS   R0,R0,#1
    BLT    pt1
    LDR    ip,[R1],R2,LSL#2;A(J)
    MOV    lr,ip,ASR#31
    EOR    ip,ip,lr,LSR#1;correct for negative
    CMP    ip,R3       ;compare with T
    STRGE  R5,[R4],#4  ;store INDX(NF) = J
    ADD    R5,R5,R2    ;J = J + INC
    B      lp1
pt1 LDMIB  fp,{R0,R1}  ;(INDX),(NF)
    SUB    R4,R4,R0
    MOV    R4,R4,LSR#2 ;NF
    STR    R4,[R1]     ;store NF
    LDMDB  fp,{R4,R5,fp,sp,pc} 
    END
;
    TTL    whenfgt
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R5  RN     5
R4  RN     4
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT whenfgt_;(NW,A,INC,T,INDX,NF) finds pointers to  A(I)>T
    DCB    "whenfgt_",0,0,0,0,12,0,0,255
whenfgt_
    MOV    ip,sp
    STMDB  sp!,{R0-R5,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R0,[R0]     ;NW
    LDR    R2,[R2]     ;INC
    LDR    R3,[R3]     ;T
    MOV    lr,R3,ASR#31
    EOR    R3,R3,lr,LSR#1;correct for negative
    LDR    R4,[fp,#4]  ;(INDX)
    MOV    R5,#1       ;initialise pointer (J)
lp1 SUBS   R0,R0,#1
    BLT    pt1
    LDR    ip,[R1],R2,LSL#2;A(J)
    MOV    lr,ip,ASR#31
    EOR    ip,ip,lr,LSR#1;correct for negative
    CMP    ip,R3       ;compare with T
    STRGT  R5,[R4],#4  ;store INDX(NF) = J
    ADD    R5,R5,R2    ;J = J + INC
    B      lp1
pt1 LDMIB  fp,{R0,R1}  ;(INDX),(NF)
    SUB    R4,R4,R0
    MOV    R4,R4,LSR#2 ;NF
    STR    R4,[R1]     ;store NF
    LDMDB  fp,{R4,R5,fp,sp,pc} 
    END
;
    TTL    whenfle
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R5  RN     5
R4  RN     4
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT whenfle_;(NW,A,INC,T,INDX,NF) finds pointers to  A(I)<=T
    DCB    "whenfle_",0,0,0,0,12,0,0,255
whenfle_
    MOV    ip,sp
    STMDB  sp!,{R0-R5,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R0,[R0]     ;NW
    LDR    R2,[R2]     ;INC
    LDR    R3,[R3]     ;T
    MOV    lr,R3,ASR#31
    EOR    R3,R3,lr,LSR#1;correct for negative
    LDR    R4,[fp,#4]  ;(INDX)
    MOV    R5,#1       ;initialise pointer (J)
lp1 SUBS   R0,R0,#1
    BLT    pt1
    LDR    ip,[R1],R2,LSL#2;A(J)
    MOV    lr,ip,ASR#31
    EOR    ip,ip,lr,LSR#1;correct for negative
    CMP    ip,R3       ;compare with T
    STRLE  R5,[R4],#4  ;store INDX(NF) = J
    ADD    R5,R5,R2    ;J = J + INC
    B      lp1
pt1 LDMIB  fp,{R0,R1}  ;(INDX),(NF)
    SUB    R4,R4,R0
    MOV    R4,R4,LSR#2 ;NF
    STR    R4,[R1]     ;store NF
    LDMDB  fp,{R4,R5,fp,sp,pc} 
    END
;
    TTL    whenflt
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R5  RN     5
R4  RN     4
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT whenflt_;(NW,A,INC,T,INDX,NF) finds pointers to  A(I)<T
    DCB    "whenflt_",0,0,0,0,12,0,0,255
whenflt_
    MOV    ip,sp
    STMDB  sp!,{R0-R5,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R0,[R0]     ;NW
    LDR    R2,[R2]     ;INC
    LDR    R3,[R3]     ;T
    MOV    lr,R3,ASR#31
    EOR    R3,R3,lr,LSR#1;correct for negative
    LDR    R4,[fp,#4]  ;(INDX)
    MOV    R5,#1       ;initialise pointer (J)
lp1 SUBS   R0,R0,#1
    BLT    pt1
    LDR    ip,[R1],R2,LSL#2;A(J)
    MOV    lr,ip,ASR#31
    EOR    ip,ip,lr,LSR#1;correct for negative
    CMP    ip,R3       ;compare with T
    STRLT  R5,[R4],#4  ;store INDX(NF) = J
    ADD    R5,R5,R2    ;J = J + INC
    B      lp1
pt1 LDMIB  fp,{R0,R1}  ;(INDX),(NF)
    SUB    R4,R4,R0
    MOV    R4,R4,LSR#2 ;NF
    STR    R4,[R1]     ;store NF
    LDMDB  fp,{R4,R5,fp,sp,pc} 
    END
;
    TTL    whenige
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R4  RN     4
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT whenige_;(NW,IA,INC,IT,INDX,NF) finds pointers to  IA(I)>=IT
    DCB    "whenige_",0,0,0,0,12,0,0,255
whenige_
    MOV    ip,sp
    STMDB  sp!,{R0-R4,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R0,[R0]     ;NW
    LDR    R2,[R2]     ;INC
    LDR    R3,[R3]     ;IT
    LDR    R4,[fp,#4]  ;(INDX)
    MOV    ip,#1       ;initialise pointer (J)
lp1 SUBS   R0,R0,#1
    BLT    pt1
    LDR    lr,[R1],R2,LSL#2;IA(J)
    CMP    lr,R3       ;compare with IT
    STRGE  ip,[R4],#4  ;store INDX(NF) = J
    ADD    ip,ip,R2    ;J = J + INC
    B      lp1
pt1 LDMIB  fp,{R0,R1}  ;(INDX),(NF)
    SUB    R4,R4,R0
    MOV    R4,R4,LSR#2
    STR    R4,[R1]     ;store NF
    LDMDB  fp,{R4,fp,sp,pc} 
    END
;
    TTL    whenigt
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R4  RN     4
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT whenigt_;(NW,IA,INC,IT,INDX,NF) finds pointers to  IA(I)>IT
    DCB    "whenigt_",0,0,0,0,12,0,0,255
whenigt_
    MOV    ip,sp
    STMDB  sp!,{R0-R4,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R0,[R0]     ;NW
    LDR    R2,[R2]     ;INC
    LDR    R3,[R3]     ;IT
    LDR    R4,[fp,#4]  ;(INDX)
    MOV    ip,#1       ;initialise pointer (J)
lp1 SUBS   R0,R0,#1
    BLT    pt1
    LDR    lr,[R1],R2,LSL#2;IA(J)
    CMP    lr,R3       ;compare with IT
    STRGT  ip,[R4],#4  ;store INDX(NF) = J
    ADD    ip,ip,R2    ;J = J + INC
    B      lp1
pt1 LDMIB  fp,{R0,R1}  ;(INDX),(NF)
    SUB    R4,R4,R0
    MOV    R4,R4,LSR#2
    STR    R4,[R1]     ;store NF
    LDMDB  fp,{R4,fp,sp,pc} 
    END
;
    TTL    whenile
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R4  RN     4
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT whenile_;(NW,IA,INC,IT,INDX,NF) finds pointers to  IA(I)<=IT
    DCB    "whenile_",0,0,0,0,12,0,0,255
whenile_
    MOV    ip,sp
    STMDB  sp!,{R0-R4,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R0,[R0]     ;NW
    LDR    R2,[R2]     ;INC
    LDR    R3,[R3]     ;IT
    LDR    R4,[fp,#4]  ;(INDX)
    MOV    ip,#1       ;initialise pointer (J)
lp1 SUBS   R0,R0,#1
    BLT    pt1
    LDR    lr,[R1],R2,LSL#2;IA(J)
    CMP    lr,R3       ;compare with IT
    STRLE  ip,[R4],#4  ;store INDX(NF) = J
    ADD    ip,ip,R2    ;J = J + INC
    B      lp1
pt1 LDMIB  fp,{R0,R1}  ;(INDX),(NF)
    SUB    R4,R4,R0
    MOV    R4,R4,LSR#2
    STR    R4,[R1]     ;store NF
    LDMDB  fp,{R4,fp,sp,pc} 
    END
;
    TTL    whenilt
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R4  RN     4
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT whenilt_;(NW,IA,INC,IT,INDX,NF) finds pointers to  IA(I)<IT
    DCB    "whenilt_",0,0,0,0,12,0,0,255
whenilt_
    MOV    ip,sp
    STMDB  sp!,{R0-R4,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R0,[R0]     ;NW
    LDR    R2,[R2]     ;INC
    LDR    R3,[R3]     ;IT
    LDR    R4,[fp,#4]  ;(INDX)
    MOV    ip,#1       ;initialise pointer (J)
lp1 SUBS   R0,R0,#1
    BLT    pt1
    LDR    lr,[R1],R2,LSL#2;IA(J)
    CMP    lr,R3       ;compare with IT
    STRLT  ip,[R4],#4  ;store INDX(NF) = J
    ADD    ip,ip,R2    ;J = J + INC
    B      lp1
pt1 LDMIB  fp,{R0,R1}  ;(INDX),(NF)
    SUB    R4,R4,R0
    MOV    R4,R4,LSR#2
    STR    R4,[R1]     ;store NF
    LDMDB  fp,{R4,fp,sp,pc} 
    END
;
    TTL    whenne
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R4  RN     4
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT whenne_;(NW,A,INC,IT,INDX,NF) finds pointers to IA(I)<>IT
    DCB    "whenne_",0,8,0,0,255
whenne_
    MOV    ip,sp
    STMDB  sp!,{R0-R4,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R0,[R0]     ;NW
    LDR    R2,[R2]     ;INC
    LDR    R3,[R3]     ;IT
    LDR    R4,[fp,#4]  ;(INDX)
    MOV    ip,#1       ;initialise pointer (J)
lp1 SUBS   R0,R0,#1
    BLT    pt1
    LDR    lr,[R1],R2,LSL#2;IA(J)
    CMP    lr,R3       ;compare with IT
    STRNE  ip,[R4],#4  ;store INDX(NF) = J
    ADD    ip,ip,R2    ;J = J + INC
    B      lp1
pt1 LDMIB  fp,{R0,R1}  ;(INDX),(NF)
    SUB    R4,R4,R0
    MOV    R4,R4,LSR#2
    STR    R4,[R1]     ;store NF
    LDMDB  fp,{R4,fp,sp,pc} 
    END
;
    TTL    WORD
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
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 subword_;(STR,IW,NW) ==> words IW to IW+NW-1 from STR
    EXPORT word_;(STR,IW) ==> word IW from STR
    IMPORT M433_sep
    DCB    "word_",0,0,0,8,0,0,255
word_
    MOV    ip,sp
    STMDB  sp!,{R0-R6,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R5,[fp,#4]  ;LEN(STR)
    MOV    R4,#1       ;NW = 1
    B      wss
;
    DCB    "subword_",0,0,0,0,12,0,0,255
subword_
    MOV    ip,sp
    STMDB  sp!,{R0-R6,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDMIB  fp,{R4,R5} ;(NW), LEN(STR)
    LDR    R4,[R4]    ;NW
wss LDR    R3,[R3]    ;IW
    CMP    R3,#0
    CMPGT  R4,#0
    BLE    ws3        ;no words to copy, so just blank fill
    LDR    ip,sep
    LDRB   R6,[ip]    ;get separator
;        find word IW
    MOV    ip,#1      ;initialise previous character to 'sep'
ws1 SUBS   R5,R5,#1
    BLT    ws3        ;word not found
    LDRB   lr,[R2],#1
    CMP    lr,R6
    MOVEQ  ip,#1      ;flag this byte as 'sep'
    CMPNE  ip,#0
    BEQ    ws1        ;loop until non-'sep' and previous was 'sep'
    MOV    ip,#0      ;set flag to non-'sep'
    SUBS   R3,R3,#1   ;count down words
    BGT    ws1        ;go look for next word
;        now copy NW words
ws2 STRB   lr,[R0],#1  ;copy to answer
    SUBS   R1,R1,#1
    LDMLEDB fp,{R4-R6,fp,sp,pc} ;return if full
    SUBS   R5,R5,#1
    BLT    ws3        ;word not found
    LDRB   lr,[R2],#1
    CMP    lr,R6      ;check if 'sep'
    MOVNE  ip,#0      ;flag for this is non-'sep'
    BNE    ws2        ;loop over ordinary data
    CMP    ip,#1      ;check if last was 'sep'
    MOV    ip,#1      ;flag for this is 'sep'
    BEQ    ws2        ;loop over contiguous 'sep's
    SUBS   R4,R4,#1   ;count down words
    BGT    ws2        ;go look for next word
;        blank fill
ws3 MOV    lr,#" "
ws4 STRB   lr,[R0],#1
    SUBS   R1,R1,#1
    BGT    ws4
    LDMDB  fp,{R4-R6,fp,sp,pc} ;return
sep DCD    M433_sep
    END
;
    TTL    WORDS
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
    AREA   |C$$code|,CODE,READONLY
    EXPORT words_;(STR) ==> # words in STR
    IMPORT M433_sep
    DCB    "words_",0,0,8,0,0,255
words_
    MOV    ip,sp
    STMDB  sp!,{R0-R1,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDR    R2,sep
    LDRB   R2,[R2]     ;separator
    MOV    R3,#0       ;word count
    MOV    ip,#1       ;set flag for previous character ='sep'
ww1 LDRB   lr,[R0],#1
    CMP    lr,R2
    MOVEQ  ip,#1       ;set flag for 'sep'
    CMPNE  ip,#0
    ADDNE  R3,R3,#1    ;count beginnings of words
    MOVNE  ip,#0       ;flag that word has started
    SUBS   R1,R1,#1
    BGT    ww1
    MOV    R0,R3
    LDMDB  fp,{fp,sp,pc} ;return
sep DCD    M433_sep
    END
;
    TTL    WORDSEP
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
R3  RN     3
R2  RN     2
R1  RN     1
R0  RN     0
    AREA   M433_DATA,DATA
    EXPORT M433_sep
M433_sep
    DCB    " ",0,0,0   ;separator is initially blank
;
    AREA   |C$$code|,CODE,READONLY
    EXPORT wordsep_;(SEP) set SEParator
    DCB    "wordsep_",0,0,0,0,12,0,0,255
wordsep_
    MOV    ip,sp
    STMDB  sp!,{R0,fp,ip,lr,pc}
    SUB    fp,ip,#4
    LDRB   R0,[R0]
    LDR    R1,sep
    STRB   R0,[R1]
    LDMDB  fp,{fp,sp,pc} ;return
sep DCD    M433_sep
    END
;
    TTL   WPLNML
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
F0  FN     0
F1  FN     1
F2  FN     2
F3  FN     3
F4  FN     4
F5  FN     5
F6  FN     6
R0  RN     0
R1  RN     1
R2  RN     2
R3  RN     3
    AREA   |C$$code|,CODE,READONLY
    EXPORT wplnml_ ;(Z,N,C,MODE) make polynomial sum
;
    DCB    "wplnml_",0,8,0,0,255
wplnml_
    MOV    ip,sp
    STMDB  sp!,{R0-R3,fp,ip,lr,pc}
    SUB    fp,ip,#4
    STFE   F4,[sp,#-12]!
    STFE   F5,[sp,#-12]!
    STFE   F6,[sp,#-12]!
    LDFD   F2,[R1]       ;X
    LDFD   F3,[R1,#8]    ;Y
    LDR    R2,[R2]       ;N
    LDR    R1,[fp,#4]    ;(mode)
    LDR    R1,[R1]       ;mode
    CMP    R1,#0
    MOVLT  R1,#16        ;step size
    MOVGE  R1,#-16
    ADDGE  R3,R3,R2,LSL#4;pointer to relevant end of array (0 or N)
    MVFE   F0,#0         ;real accumulator
    MVFE   F1,#0         ;imag accumulator
wlp MUFE   F4,F0,F2      ;multiply sum by Z
    MUFE   F5,F1,F3
    MUFE   F6,F0,F3
    SUFE   F0,F4,F5
    MUFE   F5,F1,F2
    LDFD   F4,[R3]       ;get coefficient
    ADFE   F1,F5,F6
    LDFD   F5,[R3,#8]
    ADD    R3,R3,R1
    SUBS   R2,R2,#1
    ADFE   F0,F0,F4      ;add coefficient
    ADFE   F1,F1,F5      ;add coefficient
    BGE    wlp           ;loop N+1 times
    STFD   F0,[R0]       ;store result
    STFD   F1,[R0,#8]
    LDFE   F6,[sp],#12
    LDFE   F5,[sp],#12
    LDFE   F4,[sp],#12
    LDMDB  fp,{fp,sp,pc} ;return
    END
;
    TTL    XINOUT
pc  RN    15
lr  RN    14
sp  RN    13
ip  RN    12
fp  RN    11
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 xinb_;(LUN,XV,NX) reads binary of variable length
    EXPORT xoutb_;(LUN,XV,NX) writes binary of variable length
    EXPORT xinbf_;(LUN,XV,NX) reads binary of fixed length
    EXPORT xoutbf_;(LUN,XV,NX) writes binary of fixed length
    EXPORT xinbs_;(LUN,XAV,NA,XV,NX) reads binary in split mode
    EXPORT xoutbs_;(LUN,XAV,NA,XV,NX) writes binary in split mode
    IMPORT io_start_we
    IMPORT io_start_re
    IMPORT io_end
    IMPORT io_do_single
    IMPORT io_do_array
;
    DCB    "xoutbf_",0,8,0,0,255
xoutbf_
    MOVS    ip,sp
    STMDB   sp!,{R0-R2,R4-R7,fp,ip,lr,pc}
    MOV     R7,#1             ;(write)
    B       pt1
;
    DCB    "xinbf_",0,0,8,0,0,255
xinbf_
    MOV     ip,sp
    STMDB   sp!,{R0-R2,R4-R7,fp,ip,lr,pc}
    MOV     R7,#0             ;(read)
pt1 SUB     fp,ip,#4
    LDMIB   sp,{R5,R6}        ;(XV),(NX)
    LDR     R0,[R0]
    ORR     R0,R0,#3,2        ;UNIT,ERR=,END=
    MOV     R1,#0             ;unformatted
    CMP     R7,#0
    BLEQ    io_start_re
    CMP     R7,#0
    BLNE    io_start_we
pt2 LDR     R0,[R6]           ;NX
pt3 ADDS    R4,R0,#0
    MOVLE   R4,#1             ;if no words, flag output with 1
    MOVGT   R2,#4
    MOVGT   R1,R5             ;(XV)
    BLGT    io_do_array
    BL      io_end
    CMP     R0,#0
    MOVLT   R4,#0             ;E-O-F
    RSBGT   R4,R0,#0          ;error
    STR     R4,[R6]           ;store NX
    LDMDB   fp,{R4-R7,fp,sp,pc} 
;
    DCB    "xinb_",0,0,0,8,0,0,255
xinb_
    MOV     ip,sp
    STMDB   sp!,{R0-R2,R4-R7,fp,ip,lr,pc}
    LDMIB   sp,{R5,R6}        ;(XV),(NX)
    MOVS    R7,#0
    B       pt4
;
    DCB    "xinbs_",0,0,8,0,0,255
xinbs_
    MOV     ip,sp
    STMDB   sp!,{R0-R7,fp,ip,lr,pc}
    LDMIB   sp,{R3-R5}        ;(XAV),(NA),(XV)
    LDR     R6,[ip]           ;(NX)
    MOV     R7,#1
pt4 SUB     fp,ip,#4
    SUB     sp,sp,#4          ;space for NR
    LDR     R0,[R0]
    ORR     R0,R0,#3,2        ;UNIT,ERR=,END=
    MOV     R1,#0             ;unformatted
    BL      io_start_re
    MOV     R0,sp
    MOV     R1,#4
    BL      io_do_single      ;read NR
    CMP     R7,#0
    LDRNE   R0,[R4]           ;NA (xinbs only)
    LDRNE   R1,[fp,#-36]      ;(XAV)
    MOVNE   R2,#4
    BLNE    io_do_array       ;read XAV(1 to NA) (xinbs only)
    LDR     R0,[sp],#4        ;NR
    LDR     R2,ptr            ;address of COMMON/SLATE/
    LDR     R4,[R6]           ;NX
    STR     R0,[R2]           ;store NR in /SLATE/
    CMP     R0,R4
    MOVGT   R0,R4
    B       pt3
;
ptr DCD     slate__
;
    DCB    "xoutb_",0,0,8,0,0,255
xoutb_
    MOV     ip,sp
    STMDB   sp!,{R0-R2,R4-R7,fp,ip,lr,pc}
    LDMIB   sp,{R5,R6}        ;(XV),(NX)
    MOV     R7,#0
    B       pt5
;
    DCB    "xoutbs_",0,8,0,0,255
xoutbs_
    MOV     ip,sp
    STMDB   sp!,{R0-R7,fp,ip,lr,pc}
    LDMIB   sp,{R3-R5}        ;(XAV),(NA),(XV)
    LDR     R6,[ip]           ;(NX)
    MOV     R7,#1
pt5 SUB     fp,ip,#4
    LDR     R0,[R0]
    ORR     R0,R0,#3,2        ;UNIT,ERR=,END=
    MOV     R1,#0             ;unformatted
    BL      io_start_we
    MOV     R0,R6             ;(NX)
    MOV     R1,#4
    BL      io_do_single      ;write NX
    CMP     R7,#0
    LDRNE   R0,[R4]           ;NA (xoutbs only)
    LDRNE   R1,[fp,#-36]      ;(XAV)
    MOVNE   R2,#4
    BLNE    io_do_array       ;write XAV(1 to NA) (xoutbs only)
    B       pt2
;
    AREA    slate__,COMMON,NOINIT
    %       160
    END
