C	PROGRAM PTILE.FT
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	APRIL 5, 1978
C
C	INTRODUCTION
C	------------
C	PTILE.FT IS A CHAINED PROGRAM USED WITH BMON2
C	IT RECEIVES ITS ARGUMENTS FROM THE CD AREA AND THE IBM1,IHGH1
C	IBM2,IHGH2, JBM, JHGH  VARIABLES IN COMMON. COMMON IS RESTORED
C	FIRST BEFORE THE FUNCTION (TO BE INSERTED INTO THE BODY) IS
C	EVALUATED. AFTER THE FUNCTION IS PERFORMED, COMMON
C	IS SAVED AND BMON2 IS CHAINED BACK TO.
C	ANY COMPUTATIONS ARE DONE, THE ARGUMENTS ARE THEN CHECKED
C
C	PTILE, t - Compute the t'th percentile of the last histogram
C	computed. That is t% of the values are below the selected
C	gray value of the histogram. The gray value is printed
C	and stored in QRP.
C	OPDEFS
C	------
S	OPDEF	TADI	1400
S	OPDEF	DCAI	3400
C
S	OPDEF	MQA	7501
S	OPDEF	MQL	7421
S	OPDEF   KRS	6034
S	OPDEF	BSW	7002
C
C
S	OPDEF	SWAB	7431
S	OPDEF	SWBA	7447
S	OPDEF	SHL	7413
S	OPDEF	ASR	7415
S	OPDEF	DCM	7575
S	OPDEF	DAD	7443
S	OPDEF	DST	7445
S	OPDEF	DPIC	7573
S	OPDEF	CLAMQ	7621
S	OPDEF	MUY	7405
S	OPDEF	DVI	7407
C	[1] INITIALIZATION
	WRITE(1,995)
995	FORMAT('PTILE 4/5/78 - 4:01PM')
C
	ET=TIMER(0)
C
C
C	[1.1] GET THE PERCENTILE,
C	NOTE: FORCE ICNUM TO BE BETWEEN 0 AND 100.
S	TAD \ICNUM
S	SPA
S	CLA /0 IF < 0
S	TAD (-D101
S	SMA 
S	CLA IAC /FORCE IT TO 100
S	TAD (D101 /ADD IT BACK OR SET TO 100
S	DCA \ICNUM
	PERCENT=FLOAT(ICNUM)/100.0
C
C
C	[2] FIND THE SUM OF THE HISTOGRAM
	IC=0
S	DCA \IC#
C
	DO 200 I=1,512,2
	IA=IH(I)
	IAH=IH(I+1)
S	TAD \IAH
S	CPAGE 12
S	DCA \IA#
S	SWAB
S	DAD
S	\IA
S	DAD
S	\IC
S	DST
S	\IC
S	CLAMQ
200	CONTINUE
C
C
C	[2.1] FIND T% OF IC[1:2]
	CALL DPCVRT(IC,FC,-1)
	FB=FC*PERCENT
	CALL DPCVRT(IB,FB,+1)
C
C
C	[3] SEARCH THE HISTOGRAM FROM 0 TO 255 UNTIL THE PARTIAL
C	SUM GEQ t% OF TOTAL SUM. THEN PRINT THE GRAY VALUE AND
C	SAVE IT IN QRP.
	IC=0
S	DCA \IC#
C
	DO 300 I=1,512,2
	IA=IH(I)
	IAH=IH(I+1)
S	TAD \IAH
S	CPAGE 15
S	DCA \IA#
S	SWAB
S	DAD
S	\IA
S	DAD
S	\IC
S	DST
S	\IC
C
S	DCM
S	DAD
S	\IB
S	SPA CLA
S	JMP \400 /FOUND IT
C	IF IC[1:2] > IB[1:2]
C		THEN DONE
S	CLAMQ
300	CONTINUE
	I=511
C
C
C	[4] SET PTILE
400	IPTILE=I/2
	ITMPSTK(16)=IPTILE
C
	DO 401 INDEX=1,3,2
401	WRITE(INDEX,402)ICNUM(1),IPTILE
402	FORMAT(' THE ',I3,'%TILE = ',I5)
C
C
C	[999] RETURN
C	SAVE COMMON
999	ET=TIMER(1)
C
C	SAVE COMMON SINCE UPDATED QRP
	CALL BSCOMMON(1)
S	SWBA
	CALL CHAIN('BMON2')
C
C
	END
  