C	PROGRAM BMAX3.FT
C	----------------
C
S	ENTRY BMAX3
S	CPAGE 2
S BMAX3,BLOCK 2
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	MAY 31, 1978
C	MAY 22, 1978 /CHANGE IN LAPLACIAN "/A"
C	MAY 16, 1978 /CHANGE LAPLACIAN BY ADDING 128 BEFORE CLIP
C	NOV 22, 1977
C	NOV 15, 1977
C	NOV 14, 1977
C	NOV 11, 1977
C	NOV 8, 1977
C	MAY 23, 1977
C	MARCH 31, 1977
C	MARCH 6, 1977
C	MARCH 5, 1977
C	FEB 4, 1977
C	NOV 1, 1976
C	OCT 21, 1976
C	OCT 14, 1976
C	OCT 13, 1976
C	OCT 8, 1976
C	OCT 7, 1976
C	OCT 6, 1976
C	OCT 5, 1976
C	SEPT 30, 1976
C	SEPT 28, 1976
C	SEPT 23, 1976
C	SEPT 21, 1976
C	SEPT 19, 1976
C	SEPT 17, 1976
C	SEPT 15, 1976
C	SEPT 14, 1976
C	SEPT 13, 1976
C	SEPT 11, 1976
C	SEPT 10, 1976
C	SEPT 9, 1976
C	SEPT 8, 1976
C	SEPT 7, 1976
C	SEPT 3, 1976
C	SEPT 1, 1976
C	AUG 30, 1976
C	AUG 28, 1976
C	AUG 27, 1976
C	AUG 24, 1976
C
C	PURPOSE
C	-------
C	BMAX3 IS THE PICTURE PROCESSING PACKAGE FOR BMON1
C	IT CONTAINS THE FOLLOWING FUNTIONS:
C	IVAL	FUNCTION
C	----	--------
C	1	(OPT. <BMJ>) _ HISTOGRAM <BMI>
C	2	SETUP COMPUTING WINDOW (KX1,KX2,KY1,KY2)
C	3	<BMJ> _ EDGE, <BMI>, GRAD THR, LAPL THR
C	4	<BMJ> _ AVG8 <BMI>
C	5	<OPT Q-REG>_ EVAL,<ARG1>,<ARG2> (SWITCH)
C	6	<BMJ> _ GRAYBAR
C	7	<BMJ> _ LAPLACE <BMI>
C	8	<BMJ> _ GRAD4 <BMI> (OPT. /C)
C	9	<BMJ> _ SHOWHIST (ALREADY IN IH[1:512])
C	10	<BMJ> _ FILLPINHOLES <BMI>
C	OPDEFS
C	------
S	OPDEF	TADI	1400
S	OPDEF	DCAI	3400
C
S	OPDEF	HPR	6320
S	OPDEF	HSR	6321
S	OPDEF	VPR	6322
S	OPDEF	VSR	6323
C
C
S	OPDEF	DISP1	6435
S	OPDEF	DISP2	6436
C
S	OPDEF	SWAB	7431
S	OPDEF	SWBA	7447
S	OPDEF	DAD	7443
S	OPDEF	DST	7445
S	OPDEF	DPIC	7573
S	OPDEF	DCM	7575
S	OPDEF	CAM	7621
S	OPDEF	MUY	7405
S	OPDEF	DVI	7407
C
S	OPDEF	LSR	7417
S	OPDEF	MQA	7501
S	OPDEF	MQL	7421
S	OPDEF	BSW	7002
C
C
C	[0] DISPATCH
C	FIRST SAVE THE /C SWITCH
C	COMPUTE:	KOMP=ISW(3)
S	TAD (2 /ISW(3)
S	TAD PISW
S	DCA 7
S	CPAGE 4
S	DCA \IZ
S	TADI 7
S	DCA \KOMP
C
C	SAVE /D SWITCH
C	COMPUTE:	IMONR=ISW(4)
S	TAD (3
S	TAD PISW
S	DCA 7
S	CPAGE 4
S	DCA \IMONR
S	TADI 7
S	DCA \IMONR
C
C	SET THE SPOOLER OUTPUT SWITCH FROM /L
C	COMPUTE:	LSNUM=1+ISW(12)
S	TAD (D11 /ISW(12)
S	TAD PISW
S	DCA 7
S	CPAGE 4
S	DCA \LSNUM
S	TADI 7
S	IAC
S	DCA \LSNUM
C
C	DISPATCH
	GOTO( 1, 2, 199, 199, 5, 6, 199, 199, 1, 199),IVAL
C
S \2047,	RETRN BMAX3
C	COMPUTE:C	[1] HISTOGRAM OF BMI INTO BMJ
C
1	CONTINUE
C	GET THE EXTERNALLY SUPPLIED RANGE PARAMETERS
C	COMPUTE: IHPOSITION=MAX(ICNUM(2)+1,1)
S	TAD \ICNUM#
S	IAC
S	DCA \IHPOSITION
C
C	COMPUTE: IHSIZE= IF ICNUM(3)=0 
C			THEN 256 ELSE ICNUM(3)+1
	IHSIZE=ICNUM(3)
S	TAD \IHSIZE
S	SNA
S	TAD (D255
S	IAC
S	DCA \IHSIZE
C
C
C	IF IVAL=9
C		THEN GOTO [1.2];
S	TAD \IVAL
S	TAD (-D9
S	SNA CLA
S	JMP \120 /YES, GOTO [1.2];
C
C
C	IF ICNUM=0 THEN ICNUM=1
S	TAD \ICNUM
S	SNA
S	IAC
S	DCA \ICNUM
C
C
	DO 188 IX=1,512
S	CLA CMA
S	TAD PIH
S	CPAGE 5
S	TAD \IX
S	DCA 20
S	DCAI 20 /ZERO IT
188	CONTINUE
C
C	COPY THE /X, /Y,/R SWITCHES AND THEN COMPUTE THE HISTOGRAM
C	MODE OPERATOR ITTYP.
C	SAVE /R SWITCH
	MODEE=ISW(18)
	IX2=ISW(24)
	IY2=ISW(25)
C
C	LET ITTYP=1 FOR NORMAL HIST, 2 FOR /X, 3 OR 4 FOR /Y
C	AND 5,6,7,8 FOR /R
	ITTYP=(MODEE+MODEE+MODEE+MODEE)+(IY2+IY2) + IX2 + 1
C
C
C	DEFINE THE SAMPLING DISTANCE IY2
C	IF /R THEN IY2=1
C		ELSE IF ICNUM=0
C			 THEN IY2=1
C			 ELSE IY2=ICNUM
S	TAD \MODEE
S	CLL RAR / LINK
S	TAD \ICNUM
S	SZL
S	CLA IAC /1
S	DCA \IY2
C
C
C	[1.1] COMPUTE FREQUENCY TALLY OF GRAY-VALUES IN IBUF1
C	(DOUBLE PRECISION)
C
	IBYTE=IHGH1
	MEM=IBM1
	DO 119 IY1=KY1,KY2,IY2
	IY=IY1-1
S	TAD \IY
S	DISP2	/PUT BMY ADDRESS IN RIGHT LED'S
S	CPAGE 3
S	JMS TTYCTL /LOOK FROR CONTROL CHARS
S	JMP \2047 /EXIT
C
C	SET THE RUN GRAY VALUE
	KODTN=-1
C
C	ZERO THE RUN LENGTH
	KODTM=0
C
C	READ IN LINE IY ==>IBUF1
	CALL T3BUF(IBUF1,2)
C
	DO 119 IX1=KX1,KX2,IY2
	IX=IX1-1
S	TAD \IX
S	DISP1	/PUT BMX ADDRESS IN LEFT LED'S
C
C	IZ<==IBUF1(IX1)
S	TAD PBUF1
S	CPAGE 5
S	TAD \IX
S	DCA 7
S	TADI 7
S	DCA \IZ
C
C	DISPATCH HISTOGRAM COMPUTATION ACCORDING TO ITTYP
	GOTO(170,171,172,172,173,173,173,173),ITTYP
C
C	NORMAL - 1, COMPUTE: IH(IZ)=IH(IZ)+1

S \170,	TAD PONE
S	DCA A1
	GOTO 174
C
C	/X ( - 2) COMPUTE: IH(IX)=IH(IX)+IZ
S \171,	TAD PZ
S	DCA A1
S	TAD \IZ
S	DCA Z
	IZ=IX
	GOTO 174
C
C	/Y ( - 2) COMPUTE: IH(IY)=IH(IY)+IZ
S \172,	TAD PZ
S	DCA A1
S	TAD \IZ
S	DCA Z
	IZ=IY
	GOTO 174
C
C
C	/R (-5:8) COMPUTE RUN LENGTH HIST
173	CONTINUE
S	TAD PONE
S	DCA A1
C	COMPUTE RUN LENTHG AND PUSH IF CHANGE
C	IF KODTN = IZ
C		THEN [ KODTM_KODTM+1; GOTO 119]
C		ELSE [ KODTN_IZ; IZ_KODTM; KODTM_0]
C	FORCE IF IX=KX2
S	TAD \KX2
S	CIA
S	TAD \IX
S	SNA CLA
S	JMP \175 /PUSH  BECAUSE AT EOL
C
C	TEST IF |irz-iz| > icnum
C		THEN ACCEPT
S	TAD \IZ
S	CIA
S	TAD \KODTN
S	SPA
S	CIA /MAKE > 0
C
S	CIA /MAKE < 0
S	TAD \ICNUM
S	SPA CLA
S	JMP \175 /NEQ, GO PUSH RUN
C
C	=, INCR RUN
	KODTM=KODTM+1
	GOTO 119
C
C	NEQ, PUSH RUN
175	KODTN=IZ
	IZ=KODTM
	KODTM=0
S	TAD \IZ /DO NOT PUSH ZERO RUNS
S	SNA CLA
S	JMP \119 /DO NOT PUSH
C
C
C	IF IZ WITHIN SPECIFIED RANGE (DEFAULT 1:256)
C		THEN INCREMENT ELSE IGNORE
C	NOTE RANGE = [IHPOSITION:IHSIZE] IN 1 TO 256
C	IF (IHPOSITION-1) LEQ IZ LEQ (IHSIZE-1)
C		THEN INCREMENT
S \174,	CLA CMA
S	TAD \IHPOSITION
S	CIA
S	TAD \IZ
S	SPA CLA
S	JMP \119 /OUT OF RANGE
C
S	CLA IAC
S	TAD \IZ
S	CIA
S	TAD \IHSIZE
S	SPA CLA
S	JMP \119 /OUT OF RANGE
C
C	INCREMENT!
S	TAD \IZ
S	AND (0377
S	CLL RAL	/MULTIPLY BY 2
S	TAD PIH	/POINTER TO IH
S	DCA GH1
S	TAD GH1
S	DCA GH2
C
S	SWAB	/CHANGE MODES
S	CPAGE 3
S	6211
S	DAD
S GH1,	0000	/HIST[I] (SET ABOVE)
C
C	COMPUTE IH[-]' ACCORDING TO ITTYP ABOVE
S	CPAGE 5
S	JMS 45
S	NOP
S	DAD
S A1,	0 /PTR TO ONE OR Z.
C
S	CPAGE 3
S	6211
S	DST	/STORE
S GH2,	0000	/SET ABOVE
C
S	CAM
S	SWBA	/CHANGE BACK
C
S	CPAGE 3
S	JMS 45
S	NOP
C
119	CONTINUE
C
C
C
C
C	[1.2] COMPUTE SCALE FACTOR:
C	MAXIMUM FREQUENCY: FB AT GRAY VALUE IMAX
C	MINIMUM FREQUENCY(OTHER THAN 0): FC AT IMIN
C	ABSOLUTE GRAY VALUE RANGE: [ILO:IHI].
C
C	FROM [1.2] TO [1.2.1.2] COMPUTE FB, FC IN DP INT
C	FROM [1.2.2] ON FB,FC IS FLOATING PT.
C
C
C	INITIALIZE FREQUENCY VARIABLES AND RANGE.
C	COMPUTE: FB=-1
120	CONTINUE
S	CLA CMA
S	DCA \FB
S	CLA CMA
S	DCA \FB#
C
C	COMPUTE: FC=INF
S	TAD (3777
S	DCA \FC#
S	DCA \IVAL
S	DCA \IVAL#
C
C	INIT THE RANGE AS IMPOSSIBLE RANGE.
S	CLA CMA
S	DCA \IHI
S	CLA CMA
S	DCA \ILO
C
C	ZERO THE TOTAL HISTOGRAM VALUE
S	DCA \IMONW
S	DCA \IMONW#
C
C	COMPUTE IMONW[1:2]= MAX(IH)/4;
	DO 130 IX1=IHPOSITION,IHSIZE
	IX=IX1-1
C
C	COMPUTE: IVAL=IH(2*IX+1)
C	IVAL(2)=IH(2*IX+2)
S	CLA CMA
S	TAD PIH
S	TAD \IX
S	CPAGE 5
S	TAD \IX
S	DCA 11
C
S	TADI 11
S	CPAGE 4
S	DCA \IVAL
S	TADI 11
S	DCA \IVAL#
C
C	COMPUTE IMONW=MAX(IMONW,IVAL) IN D.P.
S	TAD \IVAL#
S	CIA
S	TAD \IMONW#
S	MQL
S	MQA
S	SPA CLA
S	JMP \131 /YES
C
S	MQA
S	SZA CLA
S	JMP \130 /NO
S	TAD \IVAL
S	CIA
S	TAD \IMONW
S	SMA CLA
S	JMP \130 /NO
C
C	SAVE NEW MAX
131	IMONW=IVAL
S	TAD \IVAL#
S	DCA \IMONW#
130	CONTINUE
C
C	SCALE IMONW[1:2] BY 1/4
S	TAD \IMONW
S	MQL
S	TAD \IMONW#
S	CPAGE 2
S	LSR
S	2 /SHIFT 3 BITS
S	DCA \IMONW#
S	MQA
S	DCA \IMONW
C
C
C	[1.2.1] LOOK FOR NONZERO IH(i)=IVAL[1:2] TO TEST FOR MAX AND MIN
	DO 127 IX1=IHPOSITION,IHSIZE
	IX=IX1-1
S	TAD \IX
S	DISP2
C
S	CPAGE 3
S	JMS TTYCTL	/TEST FOR TTY INPUTS
S	JMP \2047	/ERROR RETURN: ABORT
C
C	COMPUTE: IVAL=IH(2*IX+1)
C	IVAL(2)=IH(2*IX+2)
S	CLA CMA
S	TAD PIH
S	TAD \IX
S	CPAGE 5
S	TAD \IX
S	DCA 11
C
S	TADI 11
S	CPAGE 4
S	DCA \IVAL
S	TADI 11
S	DCA \IVAL#
C
C
C	IF IVAL NEQ 0
C		THEN 
C		BEGIN "TEST"
C		IF ILO < 0
C			THEN ILO _ IX1/2
C			ELSE IHI _ IX1/2;
C		END "TEST";
C
S	TAD \IVAL
S	SZA CLA
S	JMP NONZERO
S	TAD \IVAL#
S	SNA CLA
S	JMP \125 /=0, NO DATA (MAY BE MINIMUM FREQUENCY) GOTO [1.2.1.2]
C
C	GET FIRST OCCURANCE OF ILO
S NONZERO,	TAD \ILO
S	SMA CLA
S	JMP \122
	ILO=IX
	GOTO 123
C
C	IF NOT ILO AND NON-ZERO
C		THEN IHI_IX;
122	IHI=IX
C
C
C
C	[1.2.1.1] FIND FB,IMAX
C	IF IVAL > FB
C		 THEN (FB=IVAL, IMAX=IX);
C	FORCE DATA FIELD TO COMMON
S\123,	SWAB
S	CPAGE 10
S	DCA \I10 /FORCE FIELD 1
S	DAD
S	\IVAL
C
S	DCM /2'S COMP
C
S	DAD
S	\FB
C
S	SWBA
C
S	SMA CLA
S	JMP \125 / (IVAL LEQ FB)
C
C	YES, (IVAL > FB),  SET FB=IVAL,
S	TAD \IVAL
S	DCA \FB
S	TAD \IVAL#
S	DCA \FB#
C
	IMAX=IX
C
C
C	[1.2.1.2] FIND FC,IMIN
C	IF (IVAL < FC) AND (ILO > -1)
C		THEN
C		IF EXISTS (INDEX > IX) AND
C			(IH[INDEX]-IVAL > MAX(IH)/4)
C			THEN FC<==IVAL, IMIN=IX;
C	FORCE DATA FIELD TO COMMON
S \125,	TAD \ILO
S	SPA CLA
S	JMP \127 /IGORE INITIAL ZEROS
C
S	SWAB
S	CPAGE 10
S	DCA \I10 /FORCE FIELD 1
S	DAD
S	\FC
C
S	DCM
C
S	DAD
S	\IVAL
C
S	SWBA
C
S	SMA CLA
S	JMP \127 / NO, (IVAL GE FC)
C
C	YES, (IVAL < FC)
C	THEN 
C	IF EXISTS (INDEX > IX) AND (IH[INDEX]-IVAL > MAX(IH)/4)
C
	DO 129 KOMP=IX1,IHSIZE
	INDEX=KOMP-1
C	COMPUTE: IMONR[1:2]=IH[2*INDEX+1:2*INDEX+2]
S	CLA CMA
S	TAD PIH
S	TAD \INDEX
S	CPAGE 5
S	TAD \INDEX
S	DCA 11
S	TADI 11
S	CPAGE 4
S	DCA \IMONR
S	TADI 11
S	DCA \IMONR#
C
S	CPAGE 15
S	DCA \LSNEW /FORCE FIELD 1
S	SWAB
C
S	DAD
S	\IVAL /IH[IX]
C
S	DAD
S	\IMONW /MAX(IH)/4
C
S	DCM
C
S	DAD
S	\IMONR /IH[INDEX]
C
S	DST
S	\IMONR /(IH(XX)-IH(X)-MAX/8
C
S	CAM
C
C@C****DEBUG****
C@S	TAD \IMONR#
C@S	SPA CLA
C@S	JMP \1235 /<0, DON'T PRINT
C@	CALL DPCVRT(IMONR,W,-1)
C@	WRITE(3,1234)IX,INDEX,W
C@1234	FORMAT(' IX=',I5,', INDEX=',I5,', (H(XX)-H(X)-MAX/8)=',F9.0)
C@1235	CONTINUE
C@C******************
S	SWBA
S	TAD \IMONR# /SIGN OF (IH(XX)-IH(X)-MAX/8)
S	SMA CLA
S	JMP \124 /YES, SAVE THE MIN
129	CONTINUE
C	NO MAX EXISTS AFTER THE MIN SO IGNORE IT
	GOTO 127
C
C
C	THEN SET FC=IVAL
S\124,	TAD \IVAL
S	DCA \FC
S	TAD \IVAL#
S	DCA \FC#
C
	IMIN=IX
C
C
127	CONTINUE
C
C
C	[1.2.2] CONVERT FC AND FB FROM D.P TO FLOATING
	TEMP=FC
	CALL DPCVRT(TEMP,FC,-1)
C
	TEMP=FB
	CALL DPCVRT(TEMP,FB,-1)
C
C
C	[1.2.3] LIST HISTOGRAM STATISTICS.
	IY1=ICNUM
	LSNEW=1
	DO 140 INDEX=1,3,2
	WRITE(LSNEW,128)IY1,FC,IMIN,FB,IMAX,ILO,IHI
128	FORMAT(/' SAMP=',I5,/,' MIN=',F7.0,' AT ',I3,/,
     1' MAX=',F7.0,' AT ',I3,/,' RANGE: [',I3,':',I3,']',/)
140	LSNEW=3+IOUTSPOOL
C
C
C	[1.2.4] SAVE QREGA<==ILO, QREGB<==IHI, QREGC<==IMIN, 
C		QREGD<==IMAX IN COMMON
	ITMPSTK=ILO
S	TAD \IHI
S	DCA \ITMPSTK#
	ITMPSTK(3)=IMIN
	ITMPSTK(4)=IMAX
C
C
C	[1.2.5] COMPUTE THE DISPLAY SCALE FACTOR
C	IF /Q THEN SET FB (MAX FREQ)_1000.
	IX=ISW(17)
S	TAD \IX
S	SNA CLA
S	JMP \164
	FB=1000.0
C
C	COMPUTE: SCALE FACTOR FA
164	FA=250.0/FB
	MEM=JBM
	IBYTE=JHGH
C
C
C	[1.2.6] IF /L THEN LIST THE HISTOGRAM.
	IX=ISW(12)
S	TAD \IX
S	SNA CLA
S	JMP \163
C
C	IF IHPOSITION LEQ 0
C		THEN IHPOSITION_1;
S	CLA CMA
S	TAD \IHPOSITION
S	SPA
S	CLA CLL /LEQ 0
S	IAC
S	DCA \IHPOSITION
	DO 160 IX1=IHPOSITION,IHSIZE
	IX=IX1-1
S	CPAGE 3
S	JMS TTYCTL
S	JMP \2047 /EXIT
C	COMPUTE: IVAL[1:2]=IH[2*IX+1)
S	CLA CMA
S	TAD PIH
S	TAD \IX
S	CPAGE 5
S	TAD \IX
S	DCA 11
S	TADI 11
S	CPAGE 4
S	DCA \IVAL
S	TADI 11
S	DCA \IVAL#
C
C	IF IVAL=0
C		 THEN DON'T PRINT
S	TAD \IVAL
S	MQL
S	TAD \IVAL#
S	MQA
S	SNA CLA
S	JMP \160 /DO NOT PRINT
C
C	CVT D.P. TO F.P.
	CALL DPCVRT(IVAL,CURSYM,-1)
C
	LSNEW=1
S	TAD (5240 /"*@"
S	DCA \IZ
C
C	SCALE IT TO A MAXIMUM OF 65 STARS!
	IY=(65.0*CURSYM)/FB
C	COMPUTE: IY=MIN(IY,65)
S	TAD \IY
S	TAD (-D66
S	SMA
S	CLA CMA /==>65
S	TAD (D66
S	DCA \IY
C
	LSNEW=1
	DO 162 INDEX=1,3,2
	WRITE(LSNEW,161)IX,CURSYM,(IZ,IY1=1,IY)
161	FORMAT(' [',I3,']=',F7.0,65A1)
162	LSNEW=3+IOUTSPOOL
160	CONTINUE
C
C
C	[1.3] DISPLAY HISTOGRAM IN BMJ
C	IF KOUTFILE="BM" THEM DISPLAY ELSE RETURN
S \163,	TAD \KOUTFILE
S	TAD (-0215 /"BM"
S	SZA CLA
S	JMP \2047 /NO DISPLAY..
C
C
C	SET THE DISPLAY DENSITIES
C	IF NOT /J
C		THEN (BACKGROUND: IA<==50, LINES: IPTOP<==150)
C		ELSE (BACKGROUND:IA<==0, LINES: IPTOP<==70)
	IA=50
	IPTOP=150
C
	IZ=ISW(10)
S	TAD \IZ
S	SNA CLA
S	JMP \152 /DEFAULT VALUES
C
	IA=0
	IPTOP=70
C
C
C	COLOR AT DENSITY IA BMJ
152	LSFILL=ICNUM
	ICNUM=IA
	IVAL=1
	CALL BMAX1
	ICNUM=LSFILL
C
C	[1.3.1] DRAW FIDUCIAL MARKS OF DENSITY IPTOP ON THE BOTTOM
C	OF THE BM SPACED 10 PIXELS APART OF LENGTH 3 AND 50 PIXELS
C	APART OF LENGTH 6.
	IZ=IPTOP
	DO 150 IX1=1,256,10
	IX=IX1-1
	DO 150 IY=250,252
	CALL PACK2D
150	CONTINUE
C
	DO 151 IX1=1,256,50
	IX=IX1-1
	DO 151 IY=250,255
	CALL PACK2D
151	CONTINUE
C
C
C
C	[1.3.2] DRAW ONLY VALID DATA
	ILO=ILO+1
	IHI=IHI+1
	DO 133 IX1=ILO,IHI
	IX=IX1-1
S	TAD \IX
S	DISP2	/PUT BMX ADDRESS IN LEFT LED'S
C
S	CPAGE 3
S	JMS TTYCTL	/TEST FOR TTY INPUTS
S	JMP \2047	/ERROR RETURN: ABORT
C
C	[1.3.2.1] COMPUTE: VALUE=IH((2*IX+1)
C	VALUE(2)=IH(2*IX+2)
S	CLA CMA
S	TAD PIH
S	TAD \IX
S	CPAGE 7
S	TAD \IX
S	DCA 11
S	TADI 11
S	MQL
S	TADI 11
S	DCA \VALUE#
S	MQA
S	DCA \VALUE
C
C
C	[1.3.2.2] TEST IF IGNORE THIS ENTRY SINCE ZERO
S	TAD \VALUE
S	SZA CLA
S	JMP \141 /NON-ZERO
S	TAD \VALUE#
S	SNA CLA
S	JMP \133 /=0, SO IGNORE
C
C
C
C	COMPUTE THE VERTICAL LINE LENGTH IY2
141	CALL DPCVRT(VALUE,FC,-1)
C
	IY2=(FC*FA)
C	COMPUTE: IY2=MIN(IY2,256)
S	TAD \IY2
S	TAD (-D257
S	SMA
S	CLA CMA /==>256
S	TAD (D257
S	DCA \IY2
C
C
C	[1.3.2.3] DRAW BLACK LINE FROM BOTTOM TO VALUE (IN BMJ)
	IZ=IPTOP
	DO 133 IY1=7,IY2
	IY=256-IY1
S	TAD \IY
S	DISP2	/PUT BMY ADDRESS IN RIGHT LED'S
	CALL PACK2D
133	CONTINUE
C
C
	GOTO 2047
C	[2] SET UP COMPUTING WINDOW TO USE F&S IF /U
C	ELSE 1:256 FOR BOTH X AND Y
2	IF(ISW(21))200,201,200
201	KX1=1
	KY1=1
	KX2=256
	KY2=256
	GOTO 2047
C
C	GET FROM F&S
S\200,	HPR
S	DCA \IXPOSITION
S	VPR
S	DCA \IYPOSITION
S	HSR
S	DCA \IHSIZE
S	VSR
S	DCA \IVSIZE
	DO 204 I=1,4
204	IXPOSITION(I)=IBCD(IXPOSITION(I),1)
C
C	GET BMI1 (XP,YP)
	DO 202 I=1,2
202	IA(I)=LSAVE(I+12,IBM1+1)
S	TAD \IA#
S	DCA \IB /SAVE LSAVE (Y)
C
C	COMPUTE KX1,KY1
	KX1=(IXPOSITION-IA)+1
	KY1=(IYPOSITION-IB)+1
C
C
C	COMPUTE KX2,KY2
	KX2=KX1+IHSIZE-1
	KY2=KY1+IVSIZE-1
C
C	TEST IF F&S OVERLAYS BMI1
	DO 210 I=1,4
	IZ=KX1(I)
C
S	CLA CMA
S	TAD \IZ
S	SPA CLA
S	JMP \201 /NO, KX1(I) < 1
C
	IF(IZ-256)210,210,201
210	CONTINUE
	GOTO 2047
C	[RASTER LOOP FOR 3,4,7,8)]
C
199	DO 198 IY1=KY1,KY2
	IY=IY1-1
S	TAD \IY
S	DISP2	/PUT BMY ADDRESS IN RIGHT LED'S
C
S	CPAGE 3
S	JMS TTYCTL	/TEST FOR TTY INPUT
S	JMP \2047	/ERROR RETURN: ABORT
C
S	JMS GET3LINES
C
C	GET THE OUTPUT BUFFER COPY
	MEM=JBM
	IBYTE=JHGH
	IY=IY1-1
	CALL T3BUF(IBUF4,2)
C
C
	DO 197 IX1=KX1,KX2
	IX=IX1-1
S	TAD \IX
S	DISP1	/PUT BMX ADDRESS IN LEFT LED'S
C
C	GET THE 8-NEIGHBORHOOD FROM IBUF1:3 BUFFER
S	JMS GETNGH
C
C	DISPATCH
	GOTO(2047,2047,7,4,2047,2047,7,8,2047,10),IVAL
C
C
C	[3] EDGE USING THE PREVIOUSLY COMPUTED GRADIENT (LSNUM)
C	AND LAPLACIAN (INDEX)
C
C	IF |grad|>grad threshold and |Laplacian|>Lap. threshold
C		THEN IZ=I18 ELSE IZ=0
3	IZ=0
S	TAD \ICNUM /GRADIENT THRESHOLD
S	CIA
S	TAD \LSNUM
S	SPA CLA
S	JMP \196 /NO, STORE ZERO
C
S	TAD \ICNUM#
S	CIA
S	TAD \INDEX
S	SPA CLA
S	JMP \196 /NO, STORE ZERO
C
C	YES, STORE I18
	IZ=I18
C	GOTO [R.2]
	GOTO 196
C
C	[4] AVERAGE 8 NEIGHBORS, BMI INTO BMJ
4	IZ=(I10+I11+I12+I13+I14+I15+I16+I17+I18)
S	TAD \IZ	/NOW DIVIDE IT BY 9 USING EAE FOR SPEED
S	MQL
S	CPAGE 2
S	DVI
S	11	/9 DIVISOR
S	CLA
S	MQA	/GET THE QUOTIENT
S	DCA \IZ
C	GOTO [R.2]
	GOTO 196
C
C
C	[5] <Q-REG> _ EVAL, <ARG1>, <ARG2>, (SWITCHES)
C
C
C	[5.0.1] INIT
5	IA=ICNUM
S	TAD \ICNUM#
S	DCA \IB
C	COMPUTE: LSNUM=MAX(1,ICNUM(3)
	LSNUM=ICNUM(3)
S	TAD \LSNUM
S	SNA
S	CLA IAC
S	DCA \LSNUM
S	DCA \IA#
S	DCA \IB#
C
C
C	[5.1] TEST AND DISPATCH
C
C
C	[5.1.1] IF /A THEN ADD
S	TAD \ISW
S	SNA CLA
S	JMP \520 /NO
C
	IZ=IA+IB
	GOTO 590
C
C
C	[5.1.2] IF /M THEN MINUS
C	COMPUTE:	IVAL=ISW(13)
S\520,	TAD (D12 /ISW(13)
S	TAD PISW
S	DCA 7
S	CPAGE 4
S	DCA \IVAL
S	TADI 7
S	DCA \IVAL
S	TAD \IVAL
S	SNA CLA
S	JMP \530 /NO
C	YES,
	IZ=IB-IA
	GOTO 590
C
C
C	[5.1.3] IF /P THEN PRODUCT
C	COMPUTE:	IVAL=ISW(16)
S\530,	TAD (D15 /ISW(16)
S	TAD PISW
S	DCA 7
S	CPAGE 4
S	DCA \IVAL
S	TADI 7
S	DCA \IVAL
S	TAD \IVAL
S	SNA CLA
S	JMP \540 /NO
C	YES, ZERO /P SO NO PARAMETERS WHEN GET BACK
C	COMPUTE:	ISW(16)=0
S	TAD (D15 /ISW(16)
S	TAD PISW
S	DCA 7
S	CPAGE 4
S	DCA \IVAL
S	DCAI 7
C
S	TAD \IA
S	DCA MULT
S	TAD \IB
S	MQL
S	CPAGE 2
S	MUY
S MULT,	0
S	CLA
S	MQA
S	DCA \IZ
	GOTO 590
C
C
C	[5.1.4] IF /D THEN DIVIDE
C	COMPUTE:	IVAL=ISW(4)
S\540,	TAD (D3 /ISW(4)
S	TAD PISW
S	DCA 7
S	CPAGE 4
S	DCA \IVAL
S	TADI 7
S	DCA \IVAL
S	TAD \IVAL
S	SNA CLA
S	JMP \550 /NO
S	TAD \IB
S	DCA DIVISOR
S	TAD \IA
S	MQL
S	CPAGE 2
S	DVI
S DIVISOR,	0
S	CLA
S	MQA
S	DCA \IZ
	GOTO 590
C
C
C	[5.1.5] IF /X THEN MAX
C	COMPUTE:	IVAL=ISW(24)
S\550,	TAD (D23 /ISW(24)
S	TAD PISW
S	DCA 7
S	CPAGE 4
S	DCA \IVAL
S	TADI 7
S	DCA \IVAL
S	TAD \IVAL
S	SNA CLA
S	JMP \560 /NO
	IZ=IA
S	TAD \IB
S	CIA
S	TAD \IA
S	SMA CLA
S	JMP \590 /NO
	IZ=IB
	GOTO 590
C
C
C	[5.1.6] IF /N THE MIN
C	COMPUTE:	IVAL=ISW(14)
S\560,	TAD (D13 /ISW(14)
S	TAD PISW
S	DCA 7
S	CPAGE 4
S	DCA \IVAL
S	TADI 7
S	DCA \IVAL
S	TAD \IVAL
S	SNA CLA
S	JMP \570 /NO
	IZ=IB
S	TAD \IB
S	CIA
S	TAD \IA
S	SMA CLA
S	JMP \590
	IZ=IA
	GOTO 590
C
C
C	[5.1.7] TEST IF CONDITIONAL ELSE NOP
570	I15=ISW(5)
	I17=ISW(7)
	I12=ISW(12)
C
C	IF NOT (/E OR /G OR /L) THEN RETURN (GOTO 2047)
S	TAD \I15
S	TAD \I17
S	TAD \I12
S	SNA CLA
S	JMP \2047 /RETURN
C
C
C	[5.1.7.1] IF /E THEN IF (IA NEQ IB) THEN TRASH LSNUM CD CALLS.
S	TAD \I15
S	SNA CLA
S	JMP \572 /NO
	IF(IA-IB)599,2047,599
C
C
C	[5.1.7.2] IF /G THEN IF (IA LEQ IB) THEN TRASH LSNUM CD CALLS
S \572,	TAD \I17
S	SNA CLA
S	JMP \575 /NO
	IF(IA-IB)599,599,2047
C
C
C	[5.1.7.3] IF /L THEN IF (IA GEQ IB) THEN TRASH LSNUM CD CALLS.
S \575,	TAD \I12
S	SNA CLA
S	JMP \2047 /NO
	IF(IA-IB)2047,599,599
C
C
C	[5.1.7.4] TRASH LSNUM CD LINES
S	DUMMY BATCH
S	CPAGE 2
S BATCH,	6201
S	7777
C
599	CONTINUE
C	IF NO BATCH THEN NOP
S	TAD I BATCH
S	AND (2000 /BATCH BIT
S	SNA CLA
S	JMP \2047 /NOP
C
	DO 580 IX=1,LSNUM
	CALL BCDSPEC
580	CONTINUE
	GOTO 2047
C
C
C	[5.1.8] PRINT THE EVAL AND DO LOADQR
590	LSNEW=1
	DO 592 INDEX=1,2
	WRITE(LSNEW,593)IZ
593	FORMAT(' =',I5)
592	LSNEW=3+IOUTSPOOL
C
C	LOADQR IF EXISTS
	ICNUM=IZ
C	ZERO THE HIGH ORDER!
S	DCA \ICNUM#
C
	IVAL=17
	CALL BMAX2
C
	GOTO 2047
C	[6] GRAYBAR
C	RUN THROUGH THE IMAGE 
C	GET THE BAR WIDTH
C	IF ICNUM=0
C		THEN ICNUM=256
S \6,	TAD \ICNUM
S	SNA
S	TAD (D256 /MAKE FULL SIZE
S	DCA \ICNUM
	IX2=256-ICNUM
	CURSYM=1.414214
C	Z=255*SQRT(2)=360.621
	FC=360.621
C
C	COPY /1 SWITCH
	IC=ISW(28)
C
	MEM=JBM
	IBYTE=JHGH
C
	DO 605 IY1=KY1,KY2
	IY=IY1-1
S	TAD \IY
S	DISP2	/PUT BMX ADDRESS IN RIGHT LED'S
C
C	GET LINE IY==>IBUF1
	CALL T3BUF(IBUF1,2)
C
S	CPAGE 3
S	JMS TTYCTL	/TEST FOR TTY INPUT
S	JMP \2047	/ERROR RETURN: ABORT
C
S	TAD \IC
S	SNA CLA
S	JMP \604 /=0
C
C	ASSUME LINEAR GRAY SCALE IF /1
	ICHAN=255-IY
	GOTO 602
C
	IF(IC)602,604,602
C
C
C	COMPUTE: IZ(N+1)=SQRT(2)*IZ(N)
S \604,	TAD \IY
S	AND (17 /CHANGE IT EVERY 16 LINES
S	SZA CLA
S	JMP \602
C
	FC=FC/CURSYM
	ICHAN=FC
C
C
C	TEST IF COMPLEMENT
602	IZ=ICHAN
S	TAD \KOMP
S	SNA CLA
S	JMP \603 /NO
	IZ=255-IZ
C
C
C	WRITE OUT A LINE
603	DO 601 IX1=IX2,256
	IX=IX1-1
S	TAD \IX
S	DISP1	/PUT BMY ADDRESS IN LEFT LED'S
C
C
C	WRITE IT OUT
C	IZ==>IBUF1(IX1)
S	TAD PBUF1
S	TAD \IX
S	DCA 7
S	CPAGE 4
S	TAD \IZ
S	DCAI 7
C
601	CONTINUE
C
C
C	WRITE OUT THE LINE
	CALL T3BUF(IBUF1,3)
605	CONTINUE
C
	GOTO 2047
C	[7] 8 NEIGHBOR LAPLACIAN NEIGHBORS, BMI INTO BMJ
C
S\7,	TAD \I18
S	RAL;RTL /MULT BY 8
S	AND (3770
S	DCA \IA
C
C	COMPUTE: LAPLACIAN
	IB=IA-(I10+I11+I12+I13+I14+I15+I16+I17)
C
C	IF /A
C		THEN IZ=I18-IB
C		ELSE IZ=IB+128;
	IZ=IB+128
S	TAD \ISW /"/A"
S	SNA CLA
S	JMP \701 /NOT "/A"
	IZ=I18-IB
C
S\701,	TAD \IZ
C
S	SPA
S	CIA /TAKE ABS VALUE
S	DCA \IZ
C
C
C	IF IVAL=3
C		THEN SAVE IZ IN INDEX AND GO TAKE GRAD4 FOR "EDGE"
S	TAD \IVAL
S	TAD (-3
S	SZA CLA
S	JMP \196 /NO, GOTO [R.2] AND STORE THE LAPLACIAN
C	[8]  GRAD4 -  4 DIFFERENCE NEIGHBOR GRADIENT NEIGHBORS,
C
C	COMPUTE Dx
8	IA=(I11+(I10+I10)+I17) - (I13+(I14+I14)+I15)
S	TAD \IA
S	SPA
S	CIA
S	DCA \IA
C
C	Compute Dy
	IB=(I13+(I12+I12)+I11) - (I15+(I16+I16)+I17)
S	TAD \IB
S	SPA
S	CIA
S	DCA \IB
C
C	COMPUTE D45 DEGREES
	IC=(I12+(I11+I11)+I10) - (I14+(I15+I15)+I16)
S	TAD \IC
S	SPA 
S	CIA
S	DCA \IC
C
C
C	COMPUTE D-45 DEGREES
	ID=(I10+(I17+I17)+I16) - (I14+(I13+I13)+I12)
S	TAD \ID
S	SPA
S	CIA
S	DCA \ID
C
C
C	FIND THE MAX(IA,IB,IC,ID)
C
	IMAX=1
S	TAD \IA
S	MQL
S	MQA
S	CIA
S	SPA CLA
S	JMP \803
S	TAD \IB
S	MQL
C	SET TO DY
	IMAX=3
C
S \803,	MQA
S	CIA
S	TAD \IC
S	SPA CLA
S	JMP \804
S	TAD \IC
S	MQL
C	SET TO D45
	IMAX=2
C
S \804,	MQA
S	CIA
S	TAD \ID
S	SPA CLA
S	JMP \805
S	TAD \ID
S	MQL
C	SET TO D135
	IMAX=4
C
C	STORE IT IN IZ
S \805,	MQA
S	DCA \IZ
C
C	FIRST TEST IF USE MAGNITUDE OR DIRECTION
S	TAD \IMONR
S	SNA CLA
S	JMP \807 /NO USE |grad|
C	USE DIRECTION
	IZ=IMAX
C
C	ALSO COPY IT INTO LSNUM
807	LSNUM=IZ
C
C	IF IVAL=3
C		THEN GOTO [3]
S	TAD \IVAL
S	TAD (-3
S	SNA CLA
S	JMP \3 /[3] EDGE
C
C
C	[8.1] SCALE IZ BY
C	(IZ*INUMERATOR)/IDENOMINATOR.
S	TAD \INUMERATOR
S	DCA M8	/SET UP THE MULTIPLIER
S	TAD \IDENOMINATOR
S	DCA D8	/SET UP THE DIVISOR
S	SWBA	/MAKE SURE THAT WE ARE IN A MODE
S	TAD \IZ
S	MQL
S	CPAGE 2
S	MUY
S M8,	0	/WILL CONTAIN INUMERATOR
S	CPAGE 2
S	DVI
S D8,	0	/WILL CONTAIN IDENOMINATOR
S	CLA
S	MQA
S	DCA \IZ /QUOTIENT
C
C	CLIP TO 0:255
S	TAD \IZ
S	SMA / IF >2047 THEN CLIP TO 255
S	JMP \810
S	CLA
S	TAD (D255 /CLIP
C
S \810,	TAD (-D255
S	SMA
S	CLA /CLIP TO 255
S	TAD (D255
S	DCA \IZ
C
C
C	GOTO [R.2] AND SAVE RESULT
	GOTO 196
C
C	[10] FILLPINHOLES
10	IA=I10+I11+I12+I13+I14+I15+I16+I17
S	TAD \IA
S	RAR; RTR /DIVIDE BY 8
S	AND (377
S	DCA \IA
C	IF (IB_|IA-I18|) < THRESHOLD
C		 THEN IZ=I18 ELSE IZ=IA
	IB=IA-I18
S	TAD \IB
S	SPA
S	CIA /MAKE >0
S	DCA \IB
C
	IZ=I18
S	TAD \IB
S	CIA
S	TAD \ICNUM
S	SMA CLA
S	SKP
S	JMP \196 /RETURN
C
C	FILL THE PINHOLE
	IZ=IA
	GOTO 196
C
C	[R.2] SAVE IZ==>(JBM,JHGH,IX,IY)
C	FIRST TEST IF COMPLEMENT (/C)
S \196,	TAD \KOMP
S	SNA CLA
S	JMP \195 /DO NOT COMPLEMENT
	IZ=255-IZ
C
C	SAVE PIXEL
C	PACK IZ IN OUTPUT BUFFER IBUF4(1:256)
S\195,	TAD PBUF4
S	TAD \IX
S	DCA 7
S	CPAGE 4
S	TAD \IZ
S	DCAI 7
C
C
C	[R.3] WRITE OUT THE RASTER IN IBUF4[1:256]
197	CONTINUE
	MEM=JBM
	IBYTE=JHGH
	IY=IY1-1
	CALL T3BUF(IBUF4,3)
C
198	CONTINUE
C
	GOTO 2047
C	**************************************************
C	*SUBROUTINE   G E T 3 L I N E S
C	***************************************************
C	READ THREE LINES <BMI1> INTO THE TRIPLE LINE BUFFER
C
S	CPAGE 3
S RGET3LINES,	JMP I GET3LINES
S GET3LINES,	0 /ENTRY
C
C	READ 3 LINES INTO 
C	LINE Y-1: IBUF1
C	LINE Y  : IBUF2
C	LINE Y+1: IBUF3
C
	MEM=IBM1
	IBYTE=IHGH1
C	IF IY1=KY1
C		THEN GET 3 LINES AND RESET BUFFER PTR
C		ELSE INCR BUFF PTR AND GET NEXT LINE;
S	TAD \IY1
S	CIA
S	TAD \KY1
S	SNA CLA
S	JMP \800 /YES, DO TOP LINE
C
C	NO, INCR POINTER THEN JUMP TO CODE TO READ NEXT LINE
	IZ=KPTR3
	KPTR3=KPTR2
	KPTR2=KPTR1
	KPTR1=IZ
	GOTO 801
C
C
C
C	DO TOP LINE
C	RESET BUFFER PTRS
800	KPTR1=0
	KPTR2=256
	KPTR3=512
C	IF IY-1< 0 THEN READ IY==>IBUF1
S	TAD (-2
S	TAD \IY1
S	SPA
S	CLA /READ LINE 0
S	DCA \IY
	MEM=IBM1
	IBYTE=IHGH1
	CALL T3BUF(IBUF1,2)
C
C	READ LINE IY
	IY=IY1-1
	CALL T3BUF(IBUF2,2)
C
C	IF IY+1 > 255
C		THEN READ LINE 255
S\801,	TAD \IY1 /Y+1
S	TAD (-D256
S	SNA
S	CLA CMA /ADD -1
S	TAD (D256 /ADD BACK 256
S	DCA \IY
	CALL T3BUF(IBUF1(KPTR3+1),2)
C
	IY=IY1-1
S	JMP RGET3LINES
C	********************************************************
C	*SUBROUTINE   G E T N G H
C	********************************************************
C	HAVING PREVIOUSLY CALLED GET3LINES, NOW GET THE NEIGHBORHOOD
C	FROM THE TRIPLE LINE BUFFER. NOTE: NEIGHBORHOODS FOR
C	IX,IY = EITHER 0 OR 255 ARE GARBAGE!. YOUR RESPONSIBILITY!
S	CPAGE 3
S RGETNGH,	JMP I GETNGH
S GETNGH,	0 /ENTRY
C
C	[1] IF  OR Y AT BOUNDARY USE GETI1 ELSE GET FROM BUFFER
C	IF (IX=0) OR (IX=255) OR (IY=0) OR (IY=255)
C		THEN GETI1, RETURN
C		ELSE GET FROM BUFFER
C
S	TAD \IX
S	SNA
S	JMP GETTHEN
S	TAD (-D255
S	SNA CLA
S	JMP GETTHEN
C
S	TAD \IY
S	SNA
S	JMP GETTHEN
S	TAD (-D255
S	SZA CLA
S	JMP GETELSE
C
C
C	[1.1] GET I1
S GETTHEN, TAD \IBM1
S	DCA \MEM
	IBYTE=IHGH1
	CALL GETI1
S	JMP RGETNGH /RETURN
C
C
C	[1.2] SETUP THE PTRS
S GETELSE,	TAD (-2 /-1 FOR AUTOINDEX REG, -1 FOR LEFT NEIGH POINT
S	TAD \IX
S	TAD PBUF1 /LINE Y-1
S	MQL
S	MQA
S	TAD \KPTR1
S	DCA 10
C
C	NOTE: LINE Y PTR = LINE Y-1 PTR + 256
S	MQA
S	TAD \KPTR2
S	DCA 11
C
C	NOTE: LINE Y+1 PTR = LINE Y PTR +256.
S	MQA
S	TAD \KPTR3
S	DCA 12 /LINE Y+1
C
C
C	[2] GET NEIGHBORHOODS
C	GET LINE Y-1
S	CPAGE 4
S	DCA \I13 /FORCE COMMON DATA FIELD
S	TADI 10
S	CPAGE 4
S	DCA \I13
S	TADI 10
S	CPAGE 4
S	DCA \I12
S	TADI 10
S	CPAGE 4
S	DCA \I11
C
C	GET LINE Y
S	TADI 11
S	CPAGE 4
S	DCA \I14
S	TADI 11
S	CPAGE 4
S	DCA \I18
S	TADI 11
S	CPAGE 4
S	DCA \I10
C
C	GET LINE Y+1
S	TADI 12
S	CPAGE 4
S	DCA \I15
S	TADI 12
S	CPAGE 4
S	DCA \I16
S	TADI 12
S	DCA \I17
S	JMP RGETNGH /RETURN
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	POINTERS
C	--------
S PIH,	\IH /POINTER
S PBUF1,	\IBUF1
S PBUF4,	\IBUF4
C
S PONE,	ONE
S	CPAGE 2
S ONE,	0001
S	0000
C
S PISW,	\ISW
S PZ,	Z
S	CPAGE 2
S Z,	\IZ
S	0
C
C
C
C
	END