C	PROGRAM FLKR1.FT
C	----------------
C
C
C	###SUBROUTINE   FLKR1
C
C
C	PETER LEMKIN
C	IMAGE PROCESSING UNIT, DCBD
C	NATIONAL CANCER INSTITUTE
C	NATIONAL INSTITUTES OF HEALTH
C	9000 ROCKVILLE PIKE
C	BETHESDA, MD. 20014
C
C	JUNE 19, 1978
C	JUNE 12, 1978
C	JUNE 7, 1978
C	JUNE 1, 1978
C	MAY 31, 1978
C	MAY 30, 1978
C	MAY 26, 1978
C	MAY 24, 1978
C	MAY 22, 1978
C
C
C
C	INTRODUCTION
C	------------
C	PROVIDE THE GRAPHPEN MONITOR FOR THE FLICKER.FT FUNCTION.
C	THE FBW3[5] KEY TOGGLES THE GRAPHPEN MONITOR ON/OFF.
C
C	THE COMMAND KEYS: FBW2[0:10] PROVIDE THE KEYBOARD FUNCTIONS.
C	NOTE: THAT THEY ARE LITE WHEN THE KEYBOARD IS ACTIVE.
C
C	OPDEFS
C	------
S	OPDEF	POSTA	6520
S	OPDEF	POSTB	6521
C
S	OPDEF	HPR	6320
S	OPDEF	HSR	6321
S	OPDEF	VPR	6322
S	OPDEF	VSR	6323
C
S	OPDEF	HPL	6360
S	OPDEF	VPL	6362
S	OPDEF	HSL	6361
S	OPDEF	VSL	6363
C
S	OPDEF	TADI	1400
S	OPDEF	DCAI	3400
C
C
S	OPDEF	SWAB	7431
S	OPDEF	SWBA	7447
S	OPDEF	DAD	7443
S	OPDEF	DCM	7575
S	OPDEF	DST	7445
S	OPDEF	CLAMQ	7621
S	OPDEF	MUY	7405
S	OPDEF	SHL	7413
S	OPDEF	DVI	7407
S	OPDEF	MQA	7501
S	OPDEF	MQL	7421
S	OPDEF   KRS	6034
S	OPDEF	BSW	7002
C
C
S	OPDEF	LDXP	6443
S	OPDEF	LDYP	6444
C
S	OPDEF	DISP1	6435
S	OPDEF	DISP2	6436
C
C
S	OPDEF	QPROG2	6371
S	OPDEF	QPROG7	6433
S	OPDEF	LFBW2	6437
S	OPDEF	FBW2	6342
S	OPDEF	FBW3	6343
S	OPDEF	FBW4	6344
C
C
S	OPDEF	BMX0	6500
S	OPDEF	BMY0	6504
C
S	OPDEF	GETA	6522
C@S	OPDEF	GETB	6523
S	OPDEF	LQDT1	6375
S	OPDEF	LQDT2	6376
S	OPDEF	LQDT3	6377
S	OPDEF	STQMT	6300
S	SKPDF	QMSKP	6301
C
C
S	OPDEF	READGP	6146
S	SKPDF	GPSKP	6141
S	OPDEF	FBW12	6352
C
C
	DIMENSION MXSTK(512), MYSTK(512)
C	[0] ENTRY
S	ENTRY FLKR1
S	CPAGE 2
S FLKR1,	BLOCK 2
C
C
C	[1] IF (K8BIT NEQ -1) AND (MODEPENACTIVE=1)
C		THEN CONTINUE
C		ELSE CLEAR MASK DISPLAY MODE AND RETURN;
S	TAD \MODEPENACTIVE
S	SNA CLA
S	JMP \99 /NO
C
S	TAD \K8BIT
S	SMA CLA
S	JMP \100 /OK, CONTINUE
C
S\99,	QPROG2 /TURN OFF MASK DISPLAY MODE
S	QPROG7
C	CLEAR SWITCHES
	JUSEPEN=0
	MBDFLAG=0
	MKFLAG=0
	GOTO 2047
C
C
C	[1.1] COMMAND KEYS
C	IF FBW2[0]
C		THEN CLEAR BND & ENABLE BOUNDARY DRAWING MODE
S\100,	FBW2
S	AND (4000
S	SNA CLA
S	JMP \111 /NO
C	YES, CLEAR AND SET FLAGS
C
101	LPTR=0
	MKFLAG=0
	JUSEPEN=1
	MBDFLAG=1
C	ZERO DRAWING BM
	IBYTE= 1-K8BIT
	DO 110 IZ=1,4
	MEM=IZ-1
	CALL BMOMNI(MEM,IBYTE,0,0,0,IH,4)
C	POST/A/M
	CALL BMOMNI(MEM,K8BIT,0,1,0,IH,5)
110	CONTINUE
C	POST /A/M
C	SETUP THE QMT DISPLAY PROGRAM FOR THE TRACE IN BMJ'
S	TAD (0020
S	QPROG2
S	TAD (6000
S	QPROG7 /PUT IN "/B/M" MODE
C	NOTE:  IFILTER IS THE CURRENT VALUE OF QPROG7
C	WAIT 1 SEC
	LSNEW=200
S	JMS WAITWHILE
C
C
C	IF FBW2[1] AND MBDFLAG=1
C		THEN ERASE BND BACKWARDS;
S\111,	FBW2
S	AND (2000
S	SNA CLA
S	JMP \112 /NO
S	TAD \MBDFLAG
S	SNA CLA
S	JMP \112 /NO
C	GET THE POINT TO ERASE
S	TAD \LPTR
S	SNA CLA
S	JMP \113 /NO
S	JMS READXY
C	DISPLAY CURRENT CURSOR
S	TAD \IXPOSITION
S	TAD \IX
S	LDXP
S	TAD \IYPOSITION
S	TAD \IY
S	LDYP
C
C	DECREMENT CURSOR
	LPTR=LPTR-1
	IX1=IX
	IY1=IY
S	JMS CVT512
	IZ=0
	CALL PACK2D
C	WAIT ABOUT 40 MSEC
	LSNEW=8
S	JMS WAITWHILE
	GOTO 2047
C
C
C	IF FBW2[2]
C		THEN **NOP**
S \112,	FBW2
S	AND (1000
S	SNA CLA
S	JMP \113 /NO
C	***NOP***
C
C
C	IF FBW2[3]
C		THEN **NOP**
S\113,	FBW2
S	AND (0400
S	SNA CLA
S	JMP \114 /NO
C	***NOP***
C
C
C	IF FBW2[4]
C		THEN **NOP**
S\114,	FBW2
S	AND (0200
S	SNA CLA
S	JMP \115 /NO
C
C
C	IF FBW2[5] AND MBDFLAG=1 AND (LPTR NEQ 0)
C			THEN CLOSE BOUNDARY AND MEASURE CONVEX HULL FEATURES;
S\115,	FBW2
S	AND (0100
S	SNA CLA
S	JMP \116 /NO
S	TAD \MBDFLAG
S	SNA CLA
S	JMP \116 /NO
S	TAD \LPTR
S	SNA CLA
S	JMP \116 /NO
	MBDFLAG=0
	LASTX=MXSTK
	LASTY=MYSTK
S	JMS READXY
	NEXTX=IX
	NEXTY=IY
S	JMS INTERPOLATE
C
C	PRINT FEATURES
S	JMS FEATURES
C
C	IF MODECAL=-1
C		THEN GO BACK TO DRAW
C		ELSE GO CLEAR BOUNDARY DRAWING MODE
S	TAD \MODECAL
S	SPA CLA
S	JMP \101 /YES, GO DRAW
C	NO, GO CLEAR BD M
	GOTO 99
C
C
C	IF FBW2[6]
C		THEN MARK MODE (CLOSE BOUNDARY DRAWING MODE IF OPEN);
S\116,	FBW2
S	AND (0040
S	SNA CLA
S	JMP \117 /NO
	JUSEPEN=1
	MBDFLAG=0
	MKFLAG=1
C	POST/A
S	QPROG2
S	QPROG7
C
C
C	IF FBW2[7]
C		THEN "START CALIBRATION MODE"
C			MODECAL_-1, INDEX_STARTING SAMPLE#-1;
C			GO OPEN BOUNDARY DRAWING MODE;
S\117,	FBW2
S	AND (0020
S	SNA CLA
S	JMP \200 /NO
C	YES, REINIT
	MODECAL=-1
	INDEX=ICNUM-1
	LSNEW=200
S	JMS WAITWHILE
C	INIT CAL PROCEDURE
	IVAL=1
	CALL FLKR2
C	GO OPEN BOUNDARY DRAWING MODE
	GOTO 101
C
C
C	[2] TEST IF GRAPHPEN MODE
C	IF JUSEPEN=1
C		THEN GET PEN DATA;
200	CONTINUE
S	TAD \JUSEPEN
S	SNA CLA
S	JMP \2047 /NO
C
C
C	[2.1] YES, GET COORDINATES AND POST CURSOR
S	JMS GRFPEN
C
C
C	[2.2] IF PENTIP PRESSED
C	IF FBW12[11]=1
S	FBW12
S	AND (0001
S	SNA CLA
S	JMP \2047 /NO
C
C		THEN PROCESS THE POINT;
C
C
C	[2.3] IF MARK MODE THEN PROCESS;
S	TAD \MKFLAG
S	SNA CLA
S	JMP \240 /NO
C	IF INDEX < 18
C		THEN PUSH (IX,IY,IZ,K8BIT);
S	TAD (-D18
S	TAD \INDEX
S	SMA CLA
S	JMP \2047 /OVF!
	INDEX=INDEX+1
C	ADD OFFSET (IA,IB) = (IF LOW IMAGE THEN (0,0) ELSE (F&S-STD))
	IA=0
	IB=0
S	TAD \K8BIT
S	SNA CLA
S	JMP \815 /LOW
	IA=KX1-KX
	IB=KY1-KY
815	IBUF3(INDEX)=IX+IA
	IBUF4(INDEX)=IY+IB
C
C	SAVE DENSITY AND LOW/HIGH BYTE FLAG (0 OR 1)
	I17=INDEX+20
	IBUF3(I17)=IZ
	IBUF4(I17)=K8BIT
C
C	DRAW WHITE SQUARE AROUND (IX,IY)
	IBYTE=K8BIT
S	JMS SQUARE
C
C	WAIT ABOUT 1 SECOND
	LSNEW=200
S	JMS WAITWHILE
C
	GOTO 2047
C
C
C	[2.4] IF BOUNDARY DRAWING MODE
C		THEN DRAW VECTOR;
S\240,	TAD \MBDFLAG
S	SNA CLA
S	JMP \2047 /NO
	IBYTE=1-K8BIT
C	IF LPTR=0
C		THEN ENTER FIRST POINT ELSE INTERPOLATE DATA
C		UP TO 512 POINTS INTO STACK.
S	TAD \LPTR
S	SZA CLA
S	JMP \241 /NOT ZERO
S	JMS PUSHXY
	GOTO 2047
C
C	NOT FIRST POINT
S\241,	TAD (-D512
S	TAD \LPTR
S	SMA CLA
S	JMP \2047 /OVF!
C
C	INTERPOLATE POINTS
C	DRAW LINE FROM (LASTX,LASTY) : (IX,IY)
	NEWX=IX
	NEWY=IY
C	GET LAST POINT
S	JMS READXY
	LASTX=IX
	LASTY=IY
C
S	JMS INTERPOLATE
	GOTO 2047
C
C
C	[2047] RETURN
S\2047,	RETRN FLKR1
C	*******************************************
C	*SUBROUTINE   W A I T W H I L E
C	*****************************************************
C	WAIT ABOUT 'LSNEW' 5 MSEC
S	CPAGE 3
S RWAITWHILE,	JMP I WAITWHILE
S WAITWHILE,	0
C
	DO 1111 IZ=1,LSNEW
1111	CALL CLOCK
S	JMP RWAITWHILE
C
C	*******************************************
C	*SUBROUTINE   P U S H X Y
C	*****************************************************
C	IF LPTR < 512 AND [(IX,IY) NEQ TOPSTK OR LPTR=0]
C		 THEN PUSH IX,IY ==>MXSTK,MYSTK.
C	ALSO DRAW BLACK IN THE APPROPRIATE BM
S	CPAGE 3
S RPUSHXY,	JMP I PUSHXY
S PUSHXY,	0
S	TAD \LPTR
S	AND (7000
S	SZA CLA
S	JMP RPUSHXY /OVF!
C
C	TAD \LPTR
S	SNA CLA
S	JMP DOPUSH
C
C	SAVE IX,IY
	I17=IX
	I18=IY
C
C	GET TOPSTK
S	JMS READXY
S	TAD \I17
S	CIA
S	TAD \IX
S	SPA
S	CIA
S	MQL
S	TAD \I18
S	CIA
S	TAD \IY
S	SPA
S	CIA
S	MQA
S	MQL
C	RSTORE X,Y
	IX=I17
	IY=I18
S	MQA /TEST IF EQUAL
S	SNA CLA
S	JMP RPUSHXY
C
C	OK, PUSH IT
S DOPUSH,	INC \LPTR
C
C	COMPUTE:	MXSTK(LPTR)=IX
S	TAD \IX
S	DCA 25
S	CLA CMA
S	TAD \LPTR
S	TAD PMXSTK
S	DCA 7
S	TAD 25 /IX
S	DCAI 7
C
C	COMPUTE:	MYSTK(LPTR)=IY
S	TAD \IY
S	DCA 25
S	CLA CMA
S	TAD \LPTR
S	TAD PMYSTK
S	DCA 7
S	TAD 25 /IY
S	DCAI 7
C
C
C	DRAW A BLACK PIXEL
C	SAVE IX1,IY1
	I17=IX1
	I18=IY1
	IX1=IX
	IY1=IY
S	JMS CVT512
	IZ=255
	CALL PACK2D
C	RESTORE VARIABLES
	IX=IX1
	IY=IY1
	IX1=I17
	IY1=I18
S	JMP RPUSHXY
C
C	*******************************************
C	*SUBROUTINE   R E A D X Y
C	*****************************************************
C	READ THE BOUNDARY STACK ENTRY LPTR==> IX,IY
S	CPAGE 3
S RREADXY,	JMP I READXY
S READXY,	0
C	COMPUTE:	IX=MXSTK(LPTR)
S	CLA CMA
S	TAD \LPTR
S	TAD PMXSTK
S	DCA 7
S	TADI 7
S	DCA \IX
C
C	COMPUTE:	IY=MYSTK(LPTR)
S	CLA CMA
S	TAD \LPTR
S	TAD PMYSTK
S	DCA 7
S	TADI 7
S	DCA \IY
C
S	JMP RREADXY
C
C	*******************************************
C	*SUBROUTINE  I N T E R P O L A T E
C	*****************************************************
C	INTERPOLATE FROM (LASTX,LASTY) TO (NEXTX,NEXT)
C	PUSHXY AT EACH POINT UNLESS OVF!
S	CPAGE 3
S RINTERPOLATE,	JMP I INTERPOLATE
S INTERPOLATE,	0
C
C	USE MDRAW TO DRAW RELATIVE TO LASTX/Y!
C
C	DO MMOVE (0,0)
	CALL BMOMNI(0,0,LASTX,LASTY,0,IBUF1,2)
C
C	DO MDRAW FROM NEWX/Y TO 0,0 IN BUFFER IBUF1.
	KWC=-2
	CALL BMOMNI(0,0, NEWX,NEWY,KWC,IBUF1,3)
C
C	PROCESS THE LINE
	DO 1600 IP=1,KWC
	IZ=(IP-1)+(IP-1)+1
C	COMPUTE:	IX=IBUF1(IZ)
S	CLA CMA
S	TAD PBUF1
S	CPAGE 5
S	TAD \IZ
S	DCA 7
S	TADI 7
S	DCA \IX
C
C	COMPUTE:	IY=IBUF1(IZ+1)
S	INC 7
S	CPAGE 4
S	6211
S	TADI 7
S	DCA \IY
C	PUSH (IX,IY)
S	JMS PUSHXY
C
1600	CONTINUE
C
S	JMP RINTERPOLATE
C	*******************************************
C	*SUBROUTINE  F E A T U R E S
C	*****************************************************
C	COMPUTE CONVEX HULL IN IBUF1:4, THEN COMPUTE FEATURES.
S	CPAGE 3
S RFEATURES,	JMP I FEATURES
S FEATURES,	0
C
C	[F.1] COMPUTE CONVEX HULL
C	ZERO CONVEX HULL
	DO 1500 IY1=1,512
C	COMPUTE:	IBUF1(IY1)=513
S	CLA CMA
S	TAD PBUF1
S	CPAGE 7
S	TAD \IY1
S	DCA 7
S	TAD (D513
S	DCAI 7
C
C	COMPUTE: IBUF3(IY1)=-1
S	CLA CMA
S	TAD PBUF3
S	CPAGE 6
S	TAD \IY1
S	DCA 7
S	CLA CMA
S	DCAI 7 / COMPUTE:	IBUF3(IY1)=-1
1500	CONTINUE
C
C
C	[F.2] COMPUTE CONVEX HULL XLEFT IN IBUF1, XRIGHT IN IBUF3.
	KWC=LPTR
C	ZERO PARTIAL PERIMETER SUMS
	IA=0
	IB=0
C
C
C	FIND MIN ENCLOSING RECTANGLE
	KX1=513
	KY1=513
	KX2=-1
	KY2=-1
C
C
C	[F.2.1] PROCESS A BOUNDARY POINT
	DO 1501 IC=1,KWC
C	COMPUTE: TRUE PERIMETER
C	GET POINT-1
	LPTR=IC-1
S	TAD \LPTR
S	SNA
S	TAD \KWC /END OF BND
S	DCA \LPTR
C
C	[F.2.1.1] GET CURRENT POINT
S	JMS READXY
	LASTX=IX
	LASTY=IY
	LPTR=IC
S	JMS READXY
C
C
C	[F.2.1.2] COMPUTE PERIMETER PARTIAL SUMS
C	IF ABS(IY-LASTY)+ABS(IX-LASTX)=2
C		THEN IB=IB+1 ELSE IA=IA+1
S	TAD \IY
S	CIA
S	TAD \LASTY
S	SPA
S	CIA
S	DCA 7
S	TAD \IX
S	CIA
S	TAD \LASTX
S	SPA
S	CIA
S	TAD 7 /ABS(IY-LASTY)
S	DCA 7 /SAVE IT
C
S	TAD (-2
S	TAD 7 /1ST TEST
S	SZA CLA
S	ISZ \IA /4 NGH CONNECTED
S	NOP
C
S	TAD (-2
S	TAD 7 /2ND TEST
S	SNA CLA
S	ISZ \IB /DIAG CONNECTED
S	CLA
C
C
C	[F.2.1.3] LOOKUP XLEFT AND XRIGHT TO SEE IF UPDATE.
	IY1=IY+1
C	COMPUTE: 	IX1=IBUF1(IY1)
S	CLA CMA
S	TAD PBUF1
S	CPAGE 5
S	TAD \IY1
S	DCA 25
S	TADI 25
S	DCA \IX1
C
C	COMPUTE:	IX2=IBUF3(IY1)
S	CLA CMA
S	TAD PBUF3
S	CPAGE 5
S	TAD \IY1
S	DCA 26
S	TADI 26
S	DCA \IX2
C
C	COMPUTE: IBUF3(IY1)=MAX(IY,IBUF3(IY1));
C	IF IX > IX2
C		THEN IBUF3(IY1):=IX2:=IX;
S	TAD \IX
S	CIA
S	TAD \IX2
S	SMA CLA
S	JMP \1502 /NO
	IX2=IX
S	CPAGE 4
S	TAD \IX2
S	DCAI 26 / COMPUTE:	IBUF3(IY1)=IX
C
C	COMPUTE: IBUF1(IY1)=MIN(IX,IBUF1(IY1));
C	IF IX < IX1
C		THEN IBUF1(IY1):=IX1:=IX;
S\1502,	TAD \IX1
S	CIA
S	TAD \IX
S	SMA CLA
S	JMP \1503 /NO
	IX1=IX
C	COMPUTE:	IBUF1(IY1)=IX1
S	CPAGE 4
S	TAD \IX
S	DCAI 25 /WAS SET UP BEFORE
1503	CONTINUE
C
C
C	[F.2.1.4] COMPUTE MIN RECTANGLE
C	COMPUTE:	KX1=MIN(KX1,IX1)
S	CLA CLL
S	TAD \KX1
S	CIA
S	TAD \IX1
S	SMA CLA
S	JMP F214A
	KX1=IX1
C
C	COMPUTE:	KY1=MIN(KY1,IY)
S F214A, TAD \KY1
S	CIA
S	TAD \IY
S	SMA CLA
S	JMP F214B
	KY1=IY
C
C	COMPUTE:	KX2=MAX(KX2,IX2)
S F214B, TAD \IX2
S	CIA
S	TAD \KX2
S	SMA CLA
S	JMP F214C /NO
	KX2=IX2
C
C	COMPUTE:	KY2=MAX(KY2,IY)
S F214C, TAD \IY
S	CIA
S	TAD \KY2
S	SMA CLA
S	JMP \215 /NO
	KY2=IY
C
C
C	[F.2.1.5] ZERO BOUNDARY POINT IN BM IMAGE
215	IX1=IX
	IY1=IY
	IZ=0
S	JMS CVT512
	CALL PACK2D
1501	CONTINUE
C
C
C	[F.3] COMPUTE FEATURES
C	[F.3.1] COMPUTE CORRECTED PERIMETER
	FC=FLOAT(IA)+1.414*FLOAT(IB)
C
C
C	[F.3.2] INIT FOR REST OF FEATURES
	LPTR=KWC
C		AREA ACC.
	FA=0.0
C
C		DENSITY ACC
	IA=0
S	DCA \IA#
C
C		MIN AND MAX DENSITY RANGE
	IDMIN=256
	IDMAX=-1
C
C		1ST MOMENT ACC
	XMOM=0.0
	YMOM=0.0
C
	IBYTE=K8BIT
C
C
C	[F.3.3] COMPUTE AREA, DENSITY, MIN RECTANGLE
	I11=KY1+1
	I12=KY2+1
	DO 1505 IY2=I11,I12
	IY1=IY2-1
C
C	ZERO 1ST MOMENT ACC
C	Xacc
	IB=0
S	DCA \IB#
C
C	Yacc
	IC=0
S	DCA \IC#
C
S	TAD \IY2
S	DISP2
C	COMPUTE: 	IX1=IBUF1(IY2)
S	CLA CMA
S	TAD PBUF1
S	CPAGE 5
S	TAD \IY2
S	DCA 7
S	TADI 7
S	DCA \IX1
C
C	COMPUTE:	IX2=IBUF3(IY2)
S	CLA CMA
S	TAD PBUF3
S	CPAGE 5
S	TAD \IY2
S	DCA 25
S	TADI 25
S	DCA \IX2
C
C
C	[F.3.3.1] IF IX2 < 0
C		THEN IGNORE;
S	TAD \IX2
S	SPA CLA
S	JMP \1505 /IGNORE
C	OK, CONTINUE
C
C
C	[F.3.3.2] DRAW CONVEX HULL
	IBYTE=1-K8BIT
	I15=IX1
	I16=IX2
S	JMS CVT512
	IZ=255
	CALL PACK2D
	IX1=I16
S	JMS CVT512
	CALL PACK2D
	IX1=I15
	IX2=I16
C
C
C	[F.3.3.3] SUM CORDS TO GET AREA
	FA=FA+FLOAT(IX2+1-IX1)
	I13=IX1+1
	I14=IX2+1
	IBYTE=K8BIT
C
	DO 1506 IX2=I13,I14
S	TAD \IX2
S	DISP1
	IX1=IX2-1
	IY1=IY2-1
S	JMS CVT512
	CALL FETCH2D
C
C	COMPUTE DENSITY RANGE
C	IF IDMIN > IZ THEN IDMIN<==IZ;
S	TAD \IZ
S	CIA
S	TAD \IDMIN
S	SPA CLA
S	JMP F333A /NO
	IDMIN=IZ
C
C	IF IDMAX < IZ THEN IDMAX<==IZ;
SF333A,	TAD \IZ
S	CIA
S	TAD \IDMAX
S	SMA CLA
S	JMP F333B /NO
	IDMAX=IZ
C
C	D.P. ADD DENSITY
SF333B,	CLL CLA
S	TAD \IA
S	TAD \IZ
S	DCA \IA
S	SZL
S	ISZ \IA#
S	CLA
C
C	COMPUTE 1ST MOMENT
C	IB[1:2] = SUM Xi*G(Xi,y)
C	IC[1:2] = SUM Yi*G(x,Yi)
S	CPAGE 12
S	TAD \IZ
S	SWAB /ALSO MQL
S	MUY
S	\IX /Xi*IZ
S	DAD
S	\IB /Xm
S	DST
S	\IB /Xm=Xm+Xi*IZ
S	CLAMQ
C
S	CPAGE 12
S	TAD \IZ
S	SWAB /ALSO MQL
S	MUY
S	\IY /IY*IZ
S	DAD
S	\IC /Ym
S	DST
S	\IC /Ym=Ym+Yi*IZ
S	CLAMQ
S	SWBA
1506	CONTINUE
C	UPDATE MOMENT SUMS
	CALL DPCVRT(IB,CURSYM,-1)
	XMOM=XMOM+CURSYM
	CALL DPCVRT(IC,CURSYM,-1)
	YMOM=YMOM+CURSYM
1505	CONTINUE
C
C	CVT D.P DENSITY TO FLOATING POINT
	CALL DPCVRT(IA,DMAX,-1)
C
C	COMPUTE LEAST SQUARE LOOKUP OF COUNTS/MIN CALIBRATION
C	OF DENSITY INTO "DMIN".
	IVAL=4
	CALL FLKR2
C
C	SCALE MOMENTS
	XMOM=XMOM/DMAX
	YMOM=YMOM/DMAX
C
C
C	[F.4] PRINT AREA, DENSITY, DENS/AREA, PERIM, P2A, BND LTH, REL MIN
C	  ENCLOSING RECTANGLE.
C	COMPUTE SIZE:
	IHSIZE=KX2-KX1+1
	IVSIZE=KY2-KY1+1
C
	LPTR=KWC
C
C	INCREMENT FEATURE COUNTER
	LSUCLASS=1+LSUCLASS
C
	DO 1560 LSNEW=1,3,2
	WRITE(LSNEW,1561)LSUCLASS(1),FA,DMAX,(DMAX/FA),FC
     1,(FC*FC/FA),LPTR,DMIN
1561	FORMAT(/,' [',I4,'] A=',F7.0,', D=',F9.0,', D/A=',F5.0,
     1', P=',F5.0,',P2A=',F10.2,',B.LTH=',I4,
     2/,'  COUNTS/MIN=',F11.0)
C
1560	WRITE(LSNEW,1565)KX1,KY1,IHSIZE,IVSIZE,IXPOSITION
     1,IYPOSITION,XMOM,YMOM,IDMIN,IDMAX
1565	FORMAT('  M.R.[',I3,',',I3,':',I4,
     1'X',I4,'],XF=',I5,',YF=',I5,', XM=',F6.1,', YM=',F6.1
     2,/,'  MIN.D=',I4,', MAX.D=',I4)
C
C	IF MODECAL=-1 AND INDEX < 6
C		THEN ENTER CALIBRATION POINT
S	TAD \MODECAL
S	SMA CLA
S	JMP F5 /NO
S	TAD (-D6
S	TAD \INDEX
S	SMA CLA
S	JMP F5 /NO
C	OK, PUSH POINT
	INDEX=INDEX+1
	IVAL=2
	CALL FLKR2
C
C
C	[F.5] IF /A THEN PRINT THE ABSOLUTE STAGE POSITION IN STEPS
S F5,	TAD \ISW
S	SNA CLA
S	JMP RFEATURES
C
C	YES, GET Y
	CALL DPCVRT(MDPDATA(7,5),FA,-1)
C	GET X
	CALL DPCVRT(MDPDATA(7,6),FB,-1)
C
	DO 1652 LSNEW=1,3,2
1652	WRITE(LSNEW,1653)FB,FA
1653	FORMAT('   STAGE X,Y POSITION=[',F7.0,',',F7.0,'] STEPS')
S	JMP RFEATURE
C	**********************************************
C	*SUBROUTINE    S Q U A R E
C	**************************************************
C	DRAW LETTER(INDEX) AND SQUARE OF SIZE 14X14 AT (IX,IY)
S	CPAGE 3
S RSQUARE,	JMP I SQUARE
S SQUARE,	0
C
C	SAVE IX,IY
	IX2=IX
	IY2=IY
C
C	YES, DRAW SQUARE IN K8BIT BMS
	IBYTE=K8BIT
	IZ=255
C
C	SET UP THE RANGE
	LSPALSIZE2=7
C	COMPUTE:  	I11=MAX(1,IX-LSPALSIZE2)
	I11=IX-LSPALSIZE2
S	CLA CMA
S	TAD \I11
S	SPA
S	CLA
S	IAC 
S	DCA \I11
C
C	COMPUTE:	I12=MIN(511,IX+LSPALSIZE2)
	I12=IX+LSPALSIZE2
S	TAD \I12
S	TAD (-D512
S	SMA
S	CLA CMA /-1
S	TAD (D512
S	DCA \I12
C
C	COMPUTE:	I13=MAX(1,IY-LSPALSIZE2)
	I13=IY-LSPALSIZE2
S	CLA CMA
S	TAD \I13
S	SPA
S	CLA
S	IAC 
S	DCA \I13
C
C	COMPUTE:	I14=MIN(511,IY+LSPALSIZE2)
	I14=IY+LSPALSIZE2
S	TAD \I14
S	TAD (-D512
S	SMA
S	CLA CMA /-1
S	TAD (D512
S	DCA \I14
C
C
C
C	[SQ.1] DISPLAY CHARACTER IN INDEX[6:8]
C	AT (IX,IY) AT CURRENT IZ DENSITY AT THE CURRENT IBYTE.
C
C	DEFINE WINDOW
C	DEFINE TOP
	I15=IY-2
C
C	DEFINE BOT
	I16=I15+5
C
C	DEFINE LEFT
	I17=IX-2
C
C	DEFINE RIGHT
	I18=I17+3
C
C
C	[SQ.2] MAP CHARACTER IN INDEX AND POST
S	TAD \INDEX
S	AND (0077
S	CLL RAL /MULTIPLY BY 2
C
C	GO LOOKUP THE CHARACTER
S	TAD (-1 /FOR AUTOINDEX REG
S	TAD PTAB	/GET TABLE POINTER
S	DCA 11	/STUFF INTO AUTO-INDEX REGISTER
C
S	TAD I 11	/GET FIRST HALF OF BIT PATTERN
S	DCA BUFF#	/PUT IT IN HI-ORDER HALF OF WORD
S	TAD I 11	/GET SECOND HALF OF BIT PATTERN
S	DCA BUFF	/PUT IN IN LOW-ORDER HALF
C
C	WRITE A CHARACTER
	DO 424 IX1=I17,I18
	DO 424 IY1=I15,I16
C
S	SWAB	/CHANGE TO MODE B
S	CPAGE 16
S	JMS 45
S	NOP
S	DAD	/GET...
S	BUFF	/DOUBLE PRECISION BIT PATTERN INTO AC-MQ
S	SHL	/SHIFT LEFT..
S	0001	/...ONE PLACE (INTO LINK)
S	DST	/RESTORE...
S	BUFF	/...REMAINDER OF BIT PATTERN
S	CLAMQ	/CLEAN IT OUT
S	SWBA	/RESTORE MODE A
S	SNL	/SKIP ON ZERO LINK
S	JMP \424 /DO NOT WRITE IT OUT
C
C	DISPLAY THE LOC
S	JMS CVT512
	CALL PACK2D
424	CONTINUE
C
C
C	[SQ.3] DRAW THE ENCLOSING SQUARE
	DO 1800 IY1=I13,I14
	IX1=I11
S	JMS CVT512
	CALL PACK2D
	IX1=I12
S	JMS CVT512
	CALL PACK2D
1800	CONTINUE
C
	DO 1801	IX1=I11,I12
	IY1=I13
S	JMS CVT512
	CALL PACK2D
	IY1=I14
S	JMS CVT512
	CALL PACK2D
1801	CONTINUE
S	JMP RSQUARE
C
C
C	******************************************
C	*SUBROUTINE    C V T 5 1 2
C	***********************************************
C	MAP (IX1,IY1) IN [0:511] ==> (MBM,IX,IY)[0:255].
S RCVT512,	JMP I CVT512
S CVT512,	0
C
C	COMPUTE BMi
S	CLA CMA
S	TAD \IX1
S	AND (400
S	SZA CLA
S	IAC /EITHER 0 OR 2
S	DCA \MEM
S	CLA CMA
S	TAD \IY1
S	AND (400
S	SZA CLA
S	TAD (2 /EITHER 2 OR 3
S	TAD \MEM
S	DCA \MEM
C
C	GET LOW ORDER 8-BITS
S	TAD \IX1
S	AND (377
S	DCA \IX
S	TAD \IY1
S	AND (377
S	DCA \IY
C
S	JMP RCVT512
C	************************************************************
C	SUBROUTINE:	T T Y C T L	(INTERNAL)
C	************************************************************
C
S	CPAGE 3
S RTTYC,	JMP I TTYCTL
S TTYCTL,	0000	/ENTRY
C
S	KSF	/ANYTHING TYPED
S	JMP NORMAL	/NO, RETURN NORMALLY
S	KRB	/GET TYPED CHARACTER
S	AND (0177	/TAKE CARE OF PARITY PROBLEMS
S	TAD (-17	/TEST FOR CTRL/O
S	SNA	/SKIP IF NOT CTRL/O
S	JMP RTTYC	/ABORT CALLING ROUTINE (ERROR RETURN)
S	TAD (-4	/TEST FOR CTRL/S [-17-4=-23(OCTAL)]
S	SZA CLA	/SKIP IF CTRL/S
S	JMP NORMAL	/NOT CTRL/O OR CTRL/S SO RETURN NORMALLY
C
S SLEEP,KSF	/WAIT FOR CTRL/Q
S	JMP SLEEP	/KEEP WAITING
S	KRB	/READ CHARACTER
S	AND (0177
S	TAD (-17	/IS IT A CTRL/O?
S	SNA	/SKIP IF NOT
S	JMP RTTYC	/YES, ABORT
S	TAD (-2	/TEST FOR CTRL/Q (-17-2=-21 OCTAL)
S	SZA CLA	/SKIP IF SO
S	JMP SLEEP	/NOPE, KEEP SLEEPING
C
S NORMAL,INC TTYCTL	/INCREMENT RETURN ADDRESS FOR NORMAL RETURN
S	CLA	/SAFETY VALVE
S	JMP RTTYC	/RETURN
C	*****************************************
C	*SUBROUTINE    B C D D E C
C	************************************************
C	CVT AC (DECIMAL) FROM AC (BCD)
S	CPAGE 3
S RBCDDEC,	JMP I BCDDEC
S BCDDEC,	0
S	MQL
S	MQA
S	BSW; RTR
S	AND (0017
S	DCA \I11
S	MQA
S	RTR;RTR
S	AND (0017
S	DCA \I12
S	MQA
S	AND (0017
S	DCA \I13
C	COMPUTE:   I11*100 + I12*10 + I13
S	TAD \I11
S	MQL
S	CPAGE 2
S	MUY
S	144 /D100
S	CLA
S	MQA
S	DCA 7 /(I11*100)
C
S	TAD \I12
S	MQL
S	CPAGE 2
S	MUY
S	12 /D10
S	CLA
S	MQA /(I12*10)
C
S	TAD 7
S	TAD \I13
C
S	JMP RBCDDEC
C	*****************************************
C	*SUBROUTINE    D E C B C D
C	************************************************
C	CVT AC (BCD) FROM AC ( DECIMAL)
S	CPAGE 3
S RDECBCD,	JMP I DECBCD
S DECBCD,	0
S	DCA \I10
C	COMPUTE:	I11=I10/100
S	TAD \I10
S	MQL
S	CPAGE 2
S	DVI
S	144 /D100
S	CLA
S	MQA
S	DCA \I11
C
C	COMPUTE:	I10=I10-(I11*100)
S	CPAGE 2
S	MUY /NOTE: C(MQ)= I11
S	144 /D100
S	CLA
S	MQA /I11*100
S	CIA
S	TAD \I10
S	DCA \I10
C
C	COMPUTE:	I12=I10/10
S	TAD \I10
S	MQL
S	CPAGE 2
S	DVI
S	12 /D10
S	CLA
S	MQA
S	DCA \I12 /(I10/10)
C
C	COMPUTE:	I13=I10-(I12*10)
S	CPAGE 2
S	MUY
S	12 /D10
S	CLA
S	MQA /I12*10
S	CIA
S	TAD \I10
S	DCA \I13
C
S	TAD \I11
S	BSW; RTL
S	AND (7400
S	MQL
S	TAD \I12
S	RTL; RTL
S	AND (0360
S	MQA
S	TAD \I13
C
S	JMP RDECBCD
C	***********************************************
C	*SUBROUTINE    G R F P E N
C	*******************************************************
C	GET THE IX,IY REL COORDINATES 0:511 AND DISPLAY CURSOR
S	CPAGE 3
S RGRFPEN,	JMP I GRFPEN
S GRFPEN,	0 /ENTRY
C
C
S	GPSKP /GRAPH PEN DATA READY?
S	JMP GRFPEN# /NO
C
C	YES, GET PEN DATA
S	READGP /GET X
S	CLL RAR; RTR /DIVIDE BY 8 SO COVER [0:511]
S	AND (777
S	DCA \IX
C
S	READGP /GET Y
S	CIA
S	CLL RAR; RTR /DIVIDE BY 8 SO COVER [0:511]
S	AND (777
S	DCA \IY
S	TAD \IX
C
C
C	LOAD DISP1/2
S	TAD \IX
S	DISP1
S	TAD \IY
S	DISP2
C
C	READ THE DENSITY FROM PROPER BM AND ==>BCD(LQDT1)
	IX1=IX
	IY1=IY
S	JMS CVT512
	CALL FETCH2D
S	TAD \IZ
S	JMS DECBCD
S	LQDT1
C	RESTORE IX,IY
	IX=IX1
	IY=IY1
C
C	DISPLAY CURSOR IN CORRECT BMS
S	TAD \K8BIT
S	SZA CLA
S	JMP HGHCURSOR
C
C	LOW CURSOR
S	TAD \IX
S	TAD \KX
S	LDXP
S	TAD \KY
S	TAD \IY
S	LDYP
S	JMP RGRFPEN
C
C	HIGH CURSOR
S HGHCURSOR,	TAD \KX1
S	TAD \IX
S	LDXP
S	TAD \KY1
S	TAD \IY
S	LDYP
S	JMP RGRFPEN
C
C************** P A R A M E T E R S *************
S PTAB,	TABLE /POINTER
S	CPAGE 2
S PMXSTK,	\MXSTK
S PMYSTK,	\MYSTK
S PBUF1,	\IBUF1
S PBUF3,	\IBUF3
S BUFF,	BLOCK 2
S BMTEXT,	TEXT /BM/
C
C
S	LAP
S	PAGE
S TABLE,
S	0000	/@
S	0000
S	7744	/A
S	4477
S	7751	/B
S	5126
S	3641	/C
S	4122
S	7741	/D
S	4136
S	7745	/E
S	4541
S	7744	/F
S	4440
S	3641	/G
S	4526
S	7710	/H
S	1077
S	4177	/I
S	4100
S	4241	/J
S	7640
S	7710	/K
S	2443
S	7701	/L
S	0103
S	7730	/M
S	3077
S	7730	/N
S	0677
S	3641	/O
S	4136
S	7744	/P
S	4430
S	7642	/Q
S	7603
S	7744	/R
S	4631
S	2151	/S
S	5146
S	4040	/T
S	7740
S	7701	/U
S	0177
S	7601	/V
S	0274
S	7706	/W
S	0177
S	6314	/X
S	1463
S	7007	/Y
S	0770
S	4345	/Z
S	5161
S	7741	/[
S	0000
S	6010	/\
S	0403
S	0000	/]
S	4177
S	0010	/^
S	2010
S	0101	/_
S	0101
S	0000	/SPACE
S	0000
S	0075	/!
S	0000
S	6000	/"
S	0060
S	7227	/#
S	7227
S	0677	/$ 
S	7730
S	6374	/% 
S	2543
S	6625	/& 
S	1067
S	0000	/'
S	6000
S	3641	/(
S	0000
S	0000	/)
S	4136
S	2214	/*
S	1422
S	1034	/+
S	1000
S	0102	/,
S	0000
S	1010	/-
S	1000
S	0303	/.
S	0000
S	0304	//
S	1060
S	7745	/0
S	5177
S	0121	/1
S	7701
S	2345	/2
S	5121
S	2241	/3
S	5126
S	1424	/4
S	7704
S	7251	/5
S	5106
S	0615	/6
S	2542
S	4344	/7
S	5060
S	2651	/8
S	5126
S	2051	/9
S	5136
S	0063	/:
S	6300
S	6162	/;
S	0000
S	1024	/<
S	4200
S	2222	/=
S	2222
S	0042	/>
S	2410
S	5550	/?
S	2000
C
C
C
	END