HPHP48-P,*0TASSEMBLE
=xPI		EQU #1AABD
=x+		EQU #1AB67
=x*		EQU #1ADEE
=x/		EQU #1AF05
=xSQRT		EQU #1B374
=xSIN		EQU #1B4AC

=ELEMENTTYPE	EQU #0358F
='EvalNoCK:	EQU #18F6A
=putop:		EQU #5E51C
=onlyputopCHS	EQU #5CD2A

=%%PI		EQU #2A458
=%%1		EQU #2A4E0
=%%2		EQU #2A4FA
=%%3		EQU #2A514
=%%4		EQU #2A52E
=%%5		EQU #2A548

=POP2%SPLTAC	EQU #29FF8
=NoXcpEND%	EQU #2AEDB
=SQRF		EQU #2BA0F
=PUTAB1		EQU #2C066
=GPPushR0Lp	EQU #307D2
=aATTNFLG	EQU #4226C

RPL
xROMID 904
xTITLE QFRAC v0.0'Fin
xCONFIG CfgMe

LABEL CfgMe
:: 904 TOSRRP ;

*********************************
ASSEMBLE
	CON(1)	8
RPL
xNAME QFI
::
 CK1&Dispatch
 ONE	Qfi
 FIVE
 ::
  RESOROMP xQFI
  ZEROZERO 4ROLLSWAP
  BEGIN
    NEXTCOMPOB
  WHILE
  ::
   5PICK EvalNoCK 5UNROLL
   ROT#1+UNROT
  ;
  REPEAT
  DROPSWAPDROP {}N
 ;
;
*********************************
ASSEMBLE
	CON(1)	8
RPL
xNAME PSLQ
::
 CK1&Dispatch
 FOUR
 ::
  DUP ELEMENTTYPE
  TYPEREAL #= NcaseTYPEERR
  DUP DIMLIMITS
  INNERCOMP #1= NcaseTYPEERR
  ONE #> NcaseTYPEERR
  PSLQ
  DUPTYPEREAL? ?SEMI
  MAT>%
 ;
;
*********************************
NULLNAME Qfi
::
  %0=case ONE{}N
  DUP %>%%
  NULL{}
  {{ X XX LS }}

* A*X^2+B*X+C=0

  ::
    XX DUP %%* XX %%1 THREE
    >ARRY PSLQ
    DUPTYPEREAL? caseDROP
    NORM % 1E6 %< NOTcaseDROP
    VEC>STK ( a b c )
    DUP%0= IT UNROT
    ROT %0=case
    ::
      DROP %CHS SWAP >RAT
      LS SWAP >TCOMP LS!
    ;
    UNROT		( a b c )
    %4 %* 3PICK %*
    OVERDUP %* SWAP %-	( a b d )
    ROT %2 %*		( b d 2a )
    OVER %SQRT		( b d 2a sqrt )
    DUP 5PICK %-
    3PICK %/ X %- %ABS	( b d 2a sqrt df+ )
    SWAP 5PICK %+ %CHS
    3PICK %/ X %- %ABS	( b d 2a df+ df- )
    %<			( b d 2a flag+ )
    ROT ROOT		( b 2a flag+ n r )
    5ROLL %CHS
    5PICK >RAT		( 2a flag+ n r '-b/2a' )
    ROT
    4ROLL ?SKIP %CHS
    4ROLL >RAT		( r '-b/2a' 's*n/2a' )
    ROT ' xSQRT TWO SYMBN
    'EvalNoCK: x*
    'EvalNoCK: x+
    LS SWAP >TCOMP LS!     
  ;

  ATTN? case :: LS ABND ;

*         A*PI+B
* X = SIN(------)
*           C

  ::
    XX %%ABS %%1 %%< NOT?SEMI
    XX %%ASINRAD %%PI %%1 THREE
    >ARRY PSLQ
    DUPTYPEREAL? caseDROP
    NORM % 1E6 %< NOTcaseDROP
    VEC>STK		( a b c )
    UNROTOVER %CHS >RAT
    SYMBOL xPI ;
    'EvalNoCK: x*
    UNROT %CHS >RAT
    'EvalNoCK: x+
    syminner putop: xSIN SYMBN
    LS SWAP >TCOMP LS!
  ;

  ATTN? case :: LS ABND ;

* X^2 = A+B*SQRT(2)+C*SQRT(3)+D*SQRT(5)

  ::
    %%1 %%2 %%SQRT %%3 %%SQRT %%5 %%SQRT
    XX DUP %%* FIVE
    >ARRY PSLQ
    DUPTYPEREAL? caseDROP
    NORM % 1E6 %< NOTcaseDROP
    VEC>STK %CHS	( a b c d e )
    5ROLL OVER >RAT
    5ROLL 3PICK >RAT
    SYMBOL %2 xSQRT ;
    'EvalNoCK: x* 'EvalNoCK: x+
    4ROLL 3PICK >RAT
    SYMBOL %3 xSQRT ;
    'EvalNoCK: x* 'EvalNoCK: x+
    UNROT >RAT
    SYMBOL %5 xSQRT ;
    'EvalNoCK: x* 'EvalNoCK: x+
    syminner putop: xSQRT
    X %0< IT onlyputopCHS
    SYMBN
    LS SWAP >TCOMP LS!
  ;

  ATTN? case :: LS ABND ;

*   A*PI^2+B*PI+C*SQRT(PI)+D
* X=------------------------
*             E

  ::
    %%PI DUP %%* %%PI DUP %%SQRT
    %%1 XX FIVE
    >ARRY PSLQ
    DUPTYPEREAL? caseDROP
    NORM % 1E6 %< NOTcaseDROP
    VEC>STK %CHS	( 2 1 .5 0 d )
    5ROLL OVER >RAT
    SYMBOL xPI %2 x^ ;
    'EvalNoCK: x*
    5ROLL 3PICK >RAT
    SYMBOL xPI ;
    'EvalNoCK: x* 'EvalNoCK: x+
    4ROLL 3PICK >RAT
    SYMBOL xPI xSQRT ;
    'EvalNoCK: x* 'EvalNoCK: x+
    UNROT >RAT
    'EvalNoCK: x+
    LS SWAP >TCOMP LS!
  ;

* ATTN? case :: LS ABND ;

  LS ABND
;
*********************************
NULLNAME PSLQ
::
  DUPTYPELIST? IT LIST>VEC
  DUP ELEMENTTYPE TYPEREAL
  #=ITE M>%% TOTEMPOB
  DUP DIMLIMITS CARCOMP
  DUPDUP TWO{}N %0 MAKEARRY PTR 35D71
  M>%% DUP TOTEMPOB
  3PICK DUP#1- TWO{}N %%0 MAKEARRY
  5PICK TOTEMPOB
  DUP TOTEMPOB
  6ROLL

* 6 5 4 3 2 1
* x A B H s y n

  CODE
My	EQU 1	n*1
Ms	EQU 2	n*1
MH	EQU 3	n*(n-1)
MB	EQU 4	n*n
MA	EQU 5	n*n
Mx	EQU 6	n*1

	ABASE	#100
N	ALLOC	5
I	ALLOC	5
J	ALLOC	5
K	ALLOC	5
M	ALLOC	5
t1	ALLOC	21
t2	ALLOC	21
t3	ALLOC	21
t4	ALLOC	21

	GOSBVL	=POP#	A[A]=n
	GOSBVL	=SAVPTR
	D0=(5)	(=IRAM@)-4
	C=DAT0	A
	D0=C
	D0=(4)	N
	DAT0=A	A

******* Initializations *********

* For k=1 to n
*   s.k=Sqrt(Sum(j=k,n,x.j^2))
* Next

	D0=(2)	K
	A=0	A
	A=A+1	A
	DAT0=A	A
--	A=0	W	s=0
	R0=A
	R1=A	
	D0=(2)	K
	A=DAT0	A
	D0=(2)	J
	DAT0=A	A
-	D0=(2)	J
	C=DAT0	A
	P=	Mx
	GOSUB	GETEL
	GOSUB	sqf
	GOSUB	addr
	SETHEX
	A=DAT0	A
	A=A+1	A
	DAT0=A	A
	D0=(2)	N
	C=DAT0	A
	?A<=C	A
	GOYES	-
	GOSUB	rcab0
	GOSUB	sqrt
	GOSUB	stab0
	D0=(2)	K
	C=DAT0	A
	P=	Ms
	GOSUB	STOEL
	SETHEX
	D0=(2)	K
	A=DAT0	A
	A=A+1	A
	DAT0=A	A
	D0=(2)	N
	C=DAT0	A
	?A<=C	A
	GOYES	--

* For k=1 to n
*   y.k=x.k/s.1
*   s.k=s.k/s.1
* Next

	D0=(2)	K
	C=0	A
	C=C+1	A
	DAT0=C	A
	P=	Ms
	GOSUB	GETEL
	GOSUB	stab2
--	D0=(2)	K
	C=DAT0	A	K
	P=	My
	GOSUB	GETEL
	GOSUB	rccd2
	GOSUB	divf
	D1=D1-	21
	GOSUB	putab1
	C=DAT0	A	K
	P=	Ms
	GOSUB	GETEL
	GOSUB	rccd2
	GOSUB	divf
	D1=D1-	21
	GOSUB	putab1
	SETHEX
	A=DAT0	A
	A=A+1	A
	DAT0=A	A
	D0=(2)	N
	C=DAT0	A
	?A<=C	A
	GOYES	--	

*********** Compute H ***********

* For i=1 to n
*   For j=i+1 to n-1
*     H.ij=0
*   Next
*   If i<=n-1
*     H.ii=s.i+1/s.i
*   For j=1 to i-1
*     H.ij=-y.i*y*j/(s.j*s.j+1)
*   Next
* Next

	D0=(2)	I
	A=0	A
	A=A+1	A
	DAT0=A	A
--	D0=(2)	I
	A=DAT0	A
	D0=(2)	J
	DAT0=A	A
* Test first to exclude corner!
	A=0	W
	R0=A	W
	R1=A	W
	SETHEX
-	D0=(2)	J
	C=DAT0	A
	C=C+1	A
	DAT0=C	A
	D0=(2)	N
	A=DAT0	A
	?C>=A	A	Allow n-1
	GOYES	+
	D0=(2)	I
	A=DAT0	A
	P=	MH
	GOSUB	STOEL
	GOTO	-

+	D0=(2)	N
	A=DAT0	A
	D0=(2)	I
	C=DAT0	A
	?C>=A	A
	GOYES	+
	P=	Ms
	GOSUB	GETEL	s.i
	GOSUB	getcd1	s.i+1
	GOSBVL	=XYEX
	GOSUB	divf
	GOSUB	stab0
*	D0=(2)	I
	A=DAT0	A
	C=A	A
	P=	MH
	GOSUB	STOEL
+	SETHEX
	D0=(2)	I
	A=DAT0	A
	A=A-1	A
	?A=0	A
	GOYES	+
	D0=(2)	J
	A=0	A
	A=A+1	A
	DAT0=A	A
-	D0=(2)	J
	C=DAT0	A
	P=	Ms
	GOSUB	GETEL
	GOSUB	getcd1
	GOSUB	multf
	GOSUB	stab2
	C=DAT0	A
	P=	My
	GOSUB	GETEL
	GOSUB	stab0
	D0=(2)	I
	C=DAT0	A
	P=	My
	GOSUB	GETEL
	GOSUB	rccd0
	GOSUB	multf
	A=-A-1	S
	GOSUB	rccd2
	GOSUB	divf
	GOSUB	stab0
*	D0=(2)	I
	A=DAT0	A
	D0=(2)	J
	C=DAT0	A
	P=	MH
	GOSUB	STOEL
	SETHEX
	A=DAT0	A
	A=A+1	A
	DAT0=A	A
	D0=(2)	I
	C=DAT0	A
	?A<C	A
	GOYES	-
+
*	D0=(2)	I
	C=DAT0	A
	C=C+1	A
	DAT0=C	A	
	D0=(2)	N
	A=DAT0	A
	?C>A	A
	GOYES	+
	GOTO	--
+

*********** Reduct H ***********

* For i=2 to n
*   For j=i-1 to 1 step -1
*     Reduct
*   Next
* Next
	D0=(2)	I
	C=0	A
	C=C+1	A
	C=C+1	A
	DAT0=C	A
reduct1	D0=(2)	I
	A=DAT0	A
	A=A-1	A
	D0=(2)	J
	DAT0=A	A
reduct2	GOSUB	Reduct
	D0=(2)	J
	A=DAT0	A
	A=A-1	A
	DAT0=A	A
	?A#0	A
	GOYES	reduct2
	D0=(2)	I
	A=DAT0	A
	A=A+1	A
	DAT0=A	A
	D0=(2)	N
	C=DAT0	A
	?A<=C	A
	GOYES	reduct1	

************* MAIN **************

* Select m such that
*	Gamma^i*Abs(H.ii)
* is maximal when i=m

MAIN	D0=(2)	M
	A=0	W
	DAT0=A	A	M=0
	R0=A	W
	R1=A	W	MAX=0
	D0=(2)	I
	A=A+1	A
	DAT0=A	A	I=1
	GOSUB	Gamma
	GOSUB	stcd2	COEF=Gamma
-	D0=(2)	I
	A=DAT0	A
	C=A	A
	P=	MH
	GOSUB	GETEL	H.ii
	A=0	S
	GOSUB	rccd2
	GOSUB	multf	COEF*H.ii
	GOSUB	rccd0	MAX
	GOSUB	tst>
	GONC	+
	GOSUB	stab0
*	D0=(2)	I
	A=DAT0	A
	D0=(2)	M
	DAT0=A	A
+	GOSUB	Gamma
	GOSUB	rcab2
	GOSUB	multf
	GOSUB	stab2
	SETHEX
	D0=(2)	I
	A=DAT0	A
	A=A+1	A
	DAT0=A	A
	D0=(2)	N
	C=DAT0	A
	?A<C	A	n(n-1)
	GOYES	-	

* Exchange entries m and m+1 of y
* corresponding rows of A and H
* corresponding columns of B

	D0=(2)	M
	A=DAT0	A	M
	C=A	A
	C=C+1	A	M+1
	P=	My
	GOSUB	COLSWAP
	A=DAT0	A	M
	C=A	A
	C=C+1	A	M+1
	P=	MA
	GOSUB	ROWSWAP
	A=DAT0	A	M
	C=A	A
	C=C+1	A	M+1
	P=	MH
	GOSUB	ROWSWAP
	D0=(2)	M
	A=DAT0	A	M
	C=A	A
	C=C+1	A	M+1
	P=	MB
	GOSUB	COLSWAP

* If m<=n-2 then update H
*   t0=sqrt(H[m,m]^2+H[m,m+1]^2)
*   t1=H[m,m]/t0
*   t2=H[m,m+1]/t0
*   For i=m to n
*     t3=H[i,m]
*     t4=H[i,m+1]
*     H[i,m]=t1*t2+t2*t4
*     H[i,m+1]=-t2*t3+t1*t4
*   Next

	SETHEX
	D0=(2)	M
	A=DAT0	A
	D0=(2)	N
	C=DAT0	A
	C=C-1	A
	?A<C	A
	GOYES	+
	GOTO	BREDUCT
+	C=A	A
	P=	MH
	GOSUB	GETEL	H[m,m]
	GOSUB	stab0
	GOSUB	sqf
	GOSUB	stab2
	GOSUB	getab1	H[m,m+1]
	GOSUB	sqf
	GOSUB	rccd2
	GOSUB	addf
	GOSUB	sqrt
	GOSUB	stab2	t0

	GOSUB	rcab0
	GOSUB	rccd2
	GOSUB	divf
	D0=(2)	t1
	GOSUB	putab0	t1

	D1=D1-	21
	GOSUB	getab1	H[m,m+1]
	GOSUB	rccd2
	GOSUB	divf
	D0=(2)	t2
	GOSUB	putab0	t2

	D0=(2)	M
	A=DAT0	A
	D0=(2)	I
	DAT0=A	A
--	D0=(2)	I
	A=DAT0	A
	D0=(2)	M
	C=DAT0	A
	P=	MH
	GOSUB	GETEL	H[i,m]
	D0=(2)	t3
	GOSUB	putab0
	GOSUB	getab1	H[i,m+1]
	D0=(2)	t4
	GOSUB	putab0
	D0=(2)	t1
	GOSUB	getab0
	D0=(2)	t3
	GOSUB	getcd0
	GOSUB	multf
	GOSUB	stab0	t1*t3
	D0=(2)	t2
	GOSUB	getab0
	D0=(2)	t4
	GOSUB	getcd0
	GOSUB	multf	t2*t4
	GOSUB	rccd0
	GOSUB	addf	t1*t3+t2*t4
	GOSUB	stab0
	D0=(2)	I
	A=DAT0	A
	D0=(2)	M
	C=DAT0	A
	P=	MH
	GOSUB	STOEL
	D0=(2)	t2
	GOSUB	getab0
*	D0=(2)	t3
	GOSUB	getcd0
	GOSUB	multf	t2*t3
	GOSUB	stab0
*	D0=(2)	t4
	GOSUB	getcd0
	D0=(2)	t1
	GOSUB	getab0
	GOSUB	multf	t1*t4
	GOSUB	rccd0
	GOSUB	subf	t1*t4-t2*t3
	GOSUB	putab1
	SETHEX
	D0=(2)	I
	A=DAT0	A
	A=A+1	A
	DAT0=A	A
	D0=(2)	N
	C=DAT0	A
	?A>C	A
	GOYES	+
	GOTO	--
+

* Perform block reduction on H,
* simultaneously updating y,A,B

BREDUCT

* For i=m+1 to n
*   For j=min(i-1,m+1) to 1 step -1
*     Reduct
*   Next
* Next

	SETHEX
	D0=(2)	M
	A=DAT0	A
	A=A+1	A
	D0=(2)	I
	DAT0=A	A
REDUCT1	SETHEX
	D0=(2)	I
	A=DAT0	A
	A=A-1	A	i-1
	D0=(2)	M
	C=DAT0	A
	C=C+1	A	m+1
	?A<=C	A
	GOYES	+
	A=C	A	min
+	D0=(2)	J
	DAT0=A	A
REDUCT2	GOSUB	Reduct
	SETHEX
	D0=(2)	J
	A=DAT0	A
	A=A-1	A
	DAT0=A	A
	?A#0	A
	GOYES	REDUCT2
	D0=(2)	I
	A=DAT0	A
	A=A+1	A
	DAT0=A	A
	D0=(2)	N
	C=DAT0	A
	?A<=C	A
	GOYES	REDUCT1

* Norm bound:
* Compute M=1/max.j(abs(H.j))
* where H.j denotes the j-th row
* of H. Then there can exist no
* relation vector whose Euclidean
* norm is less than M.

*	No need for M?

* Termination test:
* If the largest entry of A
* exceeds the level of numeric
* precision used, then precision
* is exhausted. If the smallest
* entry of the y vector is less
* than the detection threshold,
* a relation has been detected
* and is given in the
* corresponding column of B.

* Own note:
*	Exhaust A and take
*	last column of B	

	GOSUB	TESTA
	GOC	DONE
	D1=(5)	=aATTNFLG
	A=DAT1	A
	D1=A
	A=DAT1	A
	?A#0	A
	GOYES	FAIL
	GOTO	MAIN
FAIL	GOVLNG	=GPPushFLoop
*********************************

* Copy last column of B to s

DONE	D0=(2)	N
	A=DAT0	A
	R4=A		N
-	R3=A		y
	C=R4	A
	P=	MB
	GOSUB	GETEL
	GOSUB	stab0
	C=R3	A
	P=	Ms
	GOSUB	STOEL
	A=R3	A
	A=A-1	A
	?A#0	A
	GOYES	-	

	GOVLNG	=GPPushTLoop

*********************************
TESTA	P=	MA
	GOSUB	STACKP
	D1=C
	D1=D1+	5
	A=DAT1	A
	A=A+C	A
	B=A	A
	D1=D1+	25
-	A=DAT1	A
	SETDEC
	A=A+A	A
	SETHEX
	GOC	+
	A=DAT1	A
	LC(5)	#00010	1E10
	?A>C	A
	RTNYES
+	D1=D1+	21
	AD1EX
	D1=A
	?A<B	A
	GOYES	-
	RTNCC

*********************************
putab0	GOVLNG	=PUTAB0
getab0	GOVLNG	=GETAB0
getcd0	GOVLNG	=GETCD0
getcd1	GOVLNG	=GETCD1
addr	SETDEC
	GOSUB	rccd0
	GOSUB	addf
stab0	GOVLNG	=STAB0
stab2	GOVLNG	=STAB2
stcd2	GOVLNG	=STCD2
rcab0	GOVLNG	=RCAB0
rcab2	GOVLNG	=RCAB2
rccd0	GOVLNG	=RCCD0
rccd2	GOVLNG	=RCCD2
sqrt	SETDEC
	GOVLNG	=SQRF
sqf	SETDEC
	C=B	W
	D=C	W
	C=A	W
multf	SETDEC
	GOVLNG	=MULTF
divf	SETDEC
	GOVLNG	=DIVF
subf	SETDEC
	C=-C-1	S
addf	SETDEC
	CD0EX
	RSTK=C
	CD0EX
	GOSBVL	=ADDF
	C=RSTK
	D0=C
	RTN
tst>	SETDEC
	P=	4
	GOVLNG	=TST15
nint	SETDEC
	ST=0	1
	ST=1	2
	C=0	A
	C=C+1	A
	HS=0	3
	GOSBVL	=CCSB1
	GOVLNG	=RNDC[B]
*********************************
* SQRT(4/3)=1.15470053837924
*********************************
Gamma	P=	0
	LC(N)	16
	NIBHEX	4297383500745110
	D=C	W
	C=0	W
	RTN
*********************************
* In:	P	stack pos
*	A[A]	I
*	C[A]	J
*	R0:R1	M[J] / M[I,J]
* Out:
* Alt:	A[W] B[W] C[A] D1 P
*********************************
STOEL	GOSUB	ELPOS
	GOSBVL	=RCAB0
putab1	GOVLNG	=PUTAB1
*********************************
* In:	P	stack pos
*	A[A]	I
*	C[A]	J
* Out:	A:B	M[J] / M[I,J]
* Alt:	A[W] B[W] C[A] D1 P
*********************************
GETEL	GOSUB	ELPOS
getab1	GOVLNG	=GETAB1
*********************************
* In:	P	stack pos
*	A[A]	I
*	C[A]	J
* Out:	D1	->M[J] / ->M[I,J]
*	A[A]	X
*	C[A]	Y (1 if 1DIM)
* Alt:	A[A] B[A] C[A] D1 P
*********************************
ELPOS	B=C	A
	GOSUB	STACKP
	D1=C
	D1=D1+	15
	C=DAT1	A	dims
	D1=D1+	10
	C=C-1	A
	C=C-1	A
	GONC	+
	D1=D1-	10
	C=DAT1	A	Y=1
	D1=D1+	5
	A=DAT1	A	X
	D1=D1+	5
	GONC	elposn
+	C=DAT1	A
	A=A-1	A
-	SB=0
	ASRB.F	A
	?SB=0
	GOYES	+
	B=B+C	A
+	C=C+C	A
	?A#0	A
	GOYES	-
	A=DAT1	A	X
	D1=D1-	5
	C=DAT1	A	Y
	D1=D1+	10
elposn	B=B-1	A
	CD1EX
	C=C+B	A
	B=B+B	A
	B=B+B	A
	C=C+B	A
	B=B+B	A
	B=B+B	A
	C=C+B	A
	CD1EX
	RTN

STACKP	SETHEX
	GOSBVL	=D1=DSKTOP
	C+P+1
	C+P+1
	C+P+1
	C+P+1
	C+P+1
	P=	0
	D1=C
	D1=D1-	10
	C=DAT1	A	->M
	RTN
*********************************
ROWSWAP	C=P	15
	R0=C	A	Y2
	C=0	A
	C=C+1	A
	GOSUB	ELPOS	->M[Y1,1]
	CD1EX
	CR0EX
	A=C	A
	C=0	A
	C=C+1	A
	P=C	15
	GOSUB	ELPOS	->M[Y2,1]
	C=A	A
	D=C	A	X
	B=0	A
	GOTO	SWAPELS
*********************************
COLSWAP	C=P	15
	R0=C	W	X2
	C=A	A
	A=0	A
	A=A+1	A
	GOSUB	ELPOS	->M[1,X1]
	CD1EX
	CR0EX
	A=0	A
	A=A+1	A
	P=C	15
	GOSUB	ELPOS	->M[1,X2]
	A=A-1	A	X-1
	B=A	A
	A=A+A	A
	A=A+A	A
	B=B+A	A	5(X-1)
	A=A+A	A
	A=A+A	A
	B=B+A	A	21(X-1)
	D=C	A	Y
SWAPELS	AD0EX
	AR0EX
	D0=A
-	A=DAT0	W
	C=DAT1	W
	DAT0=C	W
	DAT1=A	W
	D0=D0+	16
	D1=D1+	16
	A=DAT0	A
	C=DAT1	A
	DAT0=C	A
	DAT1=A	A
	D0=D0+	5
	D1=D1+	5
	AD0EX
	A=A+B	A
	AD1EX
	A=A+B	A
	AD0EX
	D=D-1	A
	?D#0	A
	GOYES	-
	A=R0	A
	D0=A
	RTN
*********************************
*	Reduction step
*********************************

*     t=nint(H.ij/H.jj)
*     y.j=y.j+t*y.i
*     For k=1 to j
*       H.ik=H.ik-t*H.jk
*     Next
*     For k=1 to n
*       A.ik=A.ik=t*A.jk
*       B.kj=B.kj+t*B.ki
*     Next

Reduct	D0=(2)	J
	A=DAT0	A
	C=A	A
	P=	MH
	GOSUB	GETEL
	GOSUB	stab0
	C=DAT0	A
	D0=(2)	I
	A=DAT0	A
	P=	MH
	GOSUB	GETEL
	GOSUB	rccd0
	GOSUB	divf
	GOSUB	nint
	GOSUB	stab2	R2:R3=t

	D0=(2)	I
	C=DAT0	A
	P=	My
	GOSUB	GETEL
	GOSUB	rccd2
	GOSUB	multf
	GOSUB	stab0
	D0=(2)	J
	C=DAT0	A
	P=	My
	GOSUB	GETEL
	GOSUB	rccd0
	GOSUB	addf
	D1=D1-	21
	GOSUB	putab1	

	D0=(2)	K
	A=0	A
	A=A+1	A
	DAT0=A	A
-	D0=(2)	J
	A=DAT0	A
	D0=(2)	K
	C=DAT0	A
	P=	MH
	GOSUB	GETEL
	GOSUB	rccd2
	GOSUB	multf
	GOSUB	stab0
*	D0=(2)	K
	C=DAT0	A
	D0=(2)	I
	A=DAT0	A
	P=	MH
	GOSUB	GETEL
	GOSUB	rccd0
	GOSUB	subf	
	D1=D1-	21
	GOSUB	putab1
	SETHEX
	D0=(2)	K
	A=DAT0	A
	A=A+1	A
	DAT0=A	A
	D0=(2)	J
	C=DAT0	A
	?A<=C	A
	GOYES	-
	
	D0=(2)	K
	A=0	A
	A=A+1	A
	DAT0=A	A
-	D0=(2)	J
	A=DAT0	A
	D0=(2)	K
	C=DAT0	A
	P=	MA
	GOSUB	GETEL
	GOSUB	rccd2
	GOSUB	multf
	GOSUB	stab0
*	D0=(2)	K
	C=DAT0	A
	D0=(2)	I
	A=DAT0	A
	P=	MA
	GOSUB	GETEL
	GOSUB	rccd0
	GOSUB	subf
	D1=D1-	21
	GOSUB	putab1
*	D0=(2)	I
	C=DAT0	A
	D0=(2)	K
	A=DAT0	A
	P=	MB
	GOSUB	GETEL
	GOSUB	rccd2
	GOSUB	multf
	GOSUB	stab0
*	D0=(2)	K
	A=DAT0	A
	D0=(2)	J
	C=DAT0	A
	P=	MB
	GOSUB	GETEL
	GOSUB	rccd0
	GOSUB	addf
	D1=D1-	21
	GOSUB	putab1
	SETHEX
	D0=(2)	K
	A=DAT0	A
	A=A+1	A
	DAT0=A	A
	D0=(2)	N
	C=DAT0	A
	?A>C	A
	RTNYES
	GOTO	-
  ENDCODE
  NOTcase :: 6DROP %0 ;
  DROP 5UNROLL 4DROP
;
*********************************
NULLNAME LIST>VEC
::
 INNERCOMP ONE{}N >ARRY
;
*********************************
NULLNAME VEC>STK
::
  DUP ARSIZE #1+_ONE_DO
    INDEX@ OVER GETATELN DROP
    DUPTYPEREAL? ?SKIP %%>%
    SWAP
  LOOP
  DROP
;
*********************************
NULLNAME >ARRY
::
  DUPTYPEBINT? ITE
    :: ONE{}N DUP CARCOMP ;
    :: DUPINCOMP #1=?SKIP #*OVF ;
  3PICK TYPEREAL? ITE %0 %%0
  ROTSWAP MAKEARRY
  CODE
	A=DAT1	A
	D1=D1+	5
	D=D+1	A
	R0=A
	GOSBVL	=POP#
	R4=A
	GOSBVL	=SAVPTR
	A=R0
	D0=A
	GOSBVL	=SKIPOB
--	A=R4	A
	A=A-1	A
	R4=A	A
	GOC	++
	AD0EX
	R1=A	A
	GOSBVL	=GETPTR
	GOSBVL	=PopASavptr
	D1=A
	A=R1	A
	D0=A
	A=DAT1	A
	D1=D1+	5
	LC(5)	=DOREAL
	?A#C	A
	GOYES	+
	A=DAT1	W
	D0=D0-	16
	DAT0=A	W
	GONC	--
+	C=DAT1	A
	D1=D1+	5
	A=DAT1	W
	D0=D0-	16
	DAT0=A	W
	D0=D0-	5
	DAT0=C	A
	GONC	--
++	GOVLNG	=GPPushR0Lp
  ENDCODE
;
*********************************
NULLNAME M>%%
::
  DUP DIMLIMITS %%0 MAKEARRY
  CODE
	GOSBVL	=PopASavptr
	C=DAT1	A
	DAT1=A	A
	D0=C
	D1=A
	D0=D0+	15
	D1=D1+	5
	C=DAT1	A
	C=C+A	A
	D=C	A
	D1=D1+	10
	A=DAT0	A	dims
	A=A+1	A
	C=A	A
	C=C+C	A
	C=C+C	A
	A=A+C	A	5*dims+5
	CD0EX
	C=C+A	A
	CD1EX
	C=C+A	A
-	D0=C
	A=DAT1	W
	D1=D1+	16
	GOSBVL	=SPLITA
	SETHEX
	GOSBVL	=PUTAB0
	CD0EX
	?C<D	A
	GOYES	-
	GOVLNG	=GETPTRLOOP
  ENDCODE
;
*********************************
NULLNAME MAT>%
::
  DUP ARSIZE #1+_ONE_DO
    INDEX@ OVER GETATELN DROP
    %%>% SWAP
  LOOP
  DIMLIMITS >ARRY
;
*********************************
NULLNAME >RAT
::
  OVER %0= caseDROP
  2DUP
  CODE
	GOSBVL	=POP2%SPLTAC
	A=0	S
	ST=0	10
	?C=0	S
	GOYES	+
	ST=1	10
+	C=0	S
	GOSBVL	=STCD2
-	GOSBVL	=RCCD2
	GOSBVL	=aMODF
	GOSBVL	=EXAB2
	?B#0	W
	GOYES	-
	GOSBVL	=RCAB2
	?ST=0	10
	GOYES	+
	A=-A-1	S
+	GOVLNG	=NoXcpEND%
  ENDCODE
  ROTOVER %/ UNROT %/
  %1=case DROP
  ' x/ THREE
  4PICK %0< NOTcase SYMBN
  4ROLL %ABS 4UNROLL
  onlyputopCHS SYMBN
;
*********************************
NULLNAME ROOT
::
  %1=case DUP
  DUP % 1048575 %>
  case :: %1 SWAP ;
  COERCE
  CODE
	GOSBVL	=POP#
	R1=A
	GOSBVL	=SAVPTR
	C=0	A
	C=C+1	A
	R0=C
	LC(1)	4
	R2=C
	C=C+1	A
	R3=C	A
--	A=R1
	C=R2
	GOSBVL	=IntDiv
	?C=0	A
	GOYES	sqrdone
	?A=0	A
	GOYES	+
	A=R2	A
	C=R3	A
	A=A+C	A
	R2=A	A
	C=C+1	A
	C=C+1	A
	R3=C	A
	GONC	--
+	R1=C
	A=R0
	C=R3
	CSRB.F	A
	GOSBVL	=MUL#
	A=B	A
	R0=A
	GOTO	--
sqrdone	GOVLNG	=Push2#Loop
  ENDCODE
  UNCOERCE2
;
*********************************
NULLNAME NORM
::
  %0 OVER ARSIZE #1+_ONE_DO
    INDEX@ 3PICK GETATELN DROP
    DUPTYPEREAL? ?SKIP %%>%
    DUP %* %+
  LOOP
  %SQRT
;
*********************************