C	PROGRAM WINDMP.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	JAN 24, 1978
C	JUNE 11, 1977
C	JAN 6, 1976
C	JAN 4, 1977
C	NOV 18, 1976
C	NOV 12, 1976
C
C
C
C	INTRODUCTION
C	------------
C	WINDMP.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	WINDMP DUMPS A <BMI> WINDOW SPECIFIED BY THE F&S ON THE TTY
C	AND LPT FILE "WINDMP.DA" IF OPENED.
C	OPDEFS
C	------
S	OPDEF	TADI	1400
S	OPDEF	DCAI	3400
C
S	OPDEF	DISP1	6435
S	OPDEF	DISP2	6436
C
C
S	OPDEF	SWAB	7431
S	OPDEF	SWBA	7447
C
S	OPDEF	MQA	7501
S	OPDEF	MQL	7421
S	OPDEF   KRS	6034
S	OPDEF	BSW	7002
C
C
S	OPDEF	HPL	6360
S	OPDEF	HSL	6361
S	OPDEF	VPL	6362
S	OPDEF	VSL	6363
C	[1] INITIALIZATION
	WRITE(1,995)
995	FORMAT('WINDMP 1/24/78 - 4:01PM')
	ET=TIMER(0)
C
C
C
C	[2] VERIFY BM SPECS
S	JMS CKIN
C@@S	JMS CKOUT
C@@S	JMS CKIN2
C
C
C	[3] DEFINE BMOMNI CALLS
	SCALE=FLOAT(INUMERATOR)/FLOAT(IDENOMINATOR)
	MRDLINE=12
C
C	OPEN IF IOUTSPOOL
	IF(IOUTSPOOL)310,310,309
309	CALL OOPEN('LPT','WINDMP')
C
C	GET THE BM NAME
S\310,	TAD (4040 /"  "
S	DCA \J
S	TAD \IHGH1
S	RAR /BIT 11==>LINK
S	CLA
S	TAD (1100 /"H@"
S	SZL /ADD "H" IF HIGH PART
S	DCA \J
S	CLA
C
	LSNEW=1
	LSNUM=1+IOUTSPOOL
	KX2=MIN(KX2,(KX1+18))
	DO 300 INDEX=1,LSNUM
	WRITE(LSNEW,301)IBM1,J,SCALE,KX1-1,KX2-1,KY1-1,KY2-1
301	FORMAT(' BM',I1,A1,' SCALED BY: ',F9.3,
     1' [',I3,':',I3,' , ',I3,':',I3,']')
300	LSNEW=4
C
C
C
C	[4] DUMP IMAGE
	DO 400 IY1=KY1,KY2
	IY=IY1-1
S	TAD \IY
S	DISP2
C
S	CPAGE 3
S	JMS TTYCTL
S	JMP \998 /DONE
C
	CALL BMOMNI(IBM1,IHGH1,0,IY,0,IBUF1,MRDLINE)
C
	DO 410 IX1=KX1,KX2
410	IBUF1(IX1)=FLOAT(IBUF1(IX1))*SCALE
C
C
	LSNEW=1
	LSNUM=1+IOUTSPOOL
	DO 420 INDEX=1,LSNUM
	WRITE(LSNEW,421)IY,(IBUF1(IX1),IX1=KX1,KX2)
421	FORMAT(' ',I3,':',19I4)
420	LSNEW=4
400	CONTINUE
C
C	CLOSE IF IOUTSPOOL
	IF(IOUTSPOOL)998,998,500
500	CALL OCLOSE
C
C
C
C
C	[999] RETURN
	GOTO 998
999	WRITE(1,996)
996	FORMAT('BAD BM SPECIFICATION!')
998	ET=TIMER(1)
	CALL CHAIN('BMON2')
C***************************************************
C	*PROCEDURE      C K O U T
C******************************************************
C
C
C	CHECK WHETHER THE OUTPUT BM SPEC IS LEGAL ELSE GOTO 999.
S	CPAGE 3
SRCKOUT,	JMP I CKOUT
S CKOUT,	0 /ENTRY
C
C	[1] TEST IF KOUTFILE="BM"
S	TAD \KOUTFILE
S	CIA
S	TAD BMTEXT
S	SZA CLA
S	JMP \999 /FAILED
C
C	[2] TEST IF (KOUTFILE(2) LAND '7700)=DIGIT
S	TAD \KOUTFILE#
S	BSW
S	AND (0077
S	TAD (-60 /"0"
S	SPA
S	JMP \999 /NO, FAILED
S	TAD (-D8 /"7" TEST
S	SMA CLA
S	JMP \999 /FAILED
S	JMP RCKOUT /OK.
C
C
C***************************************************
C	*PROCEDURE      C K I N
C******************************************************
C
C
C	CHECK WHETHER THE INPUT BM SPEC IS LEGAL ELSE GOTO 999.
S	CPAGE 3
SRCKIN,	JMP I CKIN
S CKIN,	0 /ENTRY
C
C	[1] TEST IF BMI1="BM"
S	TAD \SFILE
S	CIA
S	TAD BMTEXT
S	SZA CLA
S	JMP \999 /FAILED
C
C	[2] TEST IF (BMI1(2) LAND '7700)=DIGIT
S	TAD \SFILE#
S	BSW
S	AND (0077
S	TAD (-60 /"0"
S	SPA
S	JMP \999 /NO, FAILED
S	TAD (-D8 /"7" TEST
S	SMA CLA
S	JMP \999 /FAILED
S	JMP RCKIN /OK.
C
C
C***************************************************
C	*PROCEDURE      C K I N 2
C******************************************************
C
C
C	CHECK WHETHER THE INPUT BM SPEC IS LEGAL ELSE GOTO 999.
S	CPAGE 3
SRCKIN2,	JMP I CKIN2
S CKIN2,	0 /ENTRY
C
C	[1] CHECK FIRST IBM1 SPEC
S	JMS CKIN
C
C
C	[2] TEST IF BMI2="BM"
S	TAD \SEXT
S	CIA
S	TAD BMTEXT
S	SZA CLA
S	JMP \999 /FAILED
C
C	[3] TEST IF (BMI2((6) LAND '7700)=DIGIT
S	TAD \SEXT#
S	BSW
S	AND (0077
S	TAD (-60 /"0"
S	SPA
S	JMP \999 /NO, FAILED
S	TAD (-D8 /"7" TEST
S	SMA CLA
S	JMP \999 /FAILED
S	JMP RCKIN2 /OK.
C
C
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************** P A R A M E T E R S *************
S BMTEXT,	TEXT /BM/
	END