C	PROGRAM SETOPR.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	MAY 12, 1977
C	APRIL 1, 1977
C
C
C
C	INTRODUCTION
C	------------
C	SETOPR.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	<Opt. QRj>_SETOPR (switch), <Opt. QRi1>, <Opt. QRi2>,<Opt. i,j,k>
C	- compute the set operation accoring to the switch table.
C	
C	Switch	function
C	------	--------
C	/U	UNION	QRj_QRi1 Set Union QRi2;
C	/I	INTER	QRj_QRi1 Set Intersection QRi2;
C	/D	DIFF	QRj_QRi1 Set Difference QRi2;
C	/P	PRINT	Print QRi1, numeric modifier i
C			(See BNODE KPRINTLIST for actual bit allocation).
C	/C	COPY SET    QRj_COPY QRi1
C	/Z	NIL	Set the set pointer QRj to nil.
C	/N	NORM	print and return the size of Set QRi1 into
C			 number QRj.
C	/A	ADD	Add node to Set QRj which contains the info 
C			field i data contained in QRi1.
C	/R	REMOVE	Remove node from set QRj such that the node info
C			is in QRi1 and the i'th node field is used.
C	/M	MODIFY	Modify field i of node QRj to contain data QRi1.
C	/L	LOP	QRj_LOP QRi1; (element from front of set);
C	/E	EVAL	QRj_EVAL,QRi1, j'th element of list and
C			i'th field if exists else -1;
C	/F	FOREACH	FOREACH x SUCHTHAT (x IN QRi1) AND
C			(j leq NODE(x) i'th field datum leq k)
C			DO PUT x INTO QRj.
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
	DIMENSION MQRJ(2),NQRJ(1),MQRI1(2),NQRI1(1),MQRI2(2),NQRI2(1)
	EQUIVALENCE (MQRJ(2),NQRJ), (MQRI1(2),NQRI1), (MQRI2(2),NQRI2)
C		MQRJ[1:2] = QRJ SET PTR
C		MQRI1[1:2] = QRI1 SET PTR
C		MQRI2[1:2] = QRI2 SET PTR
C
C
	DIMENSION IDATA(2)
	DIMENSION ISET2(2),ISET3(2)
	DIMENSION NUM(2),ISET(2)
C
C
C	[1] INIT THE TIMER
	ET=TIMER(0)
C
C
C	[2] PRINT NAME OF PROCEDURE
	LSNUM=1+IOUTSPOOL
	LSNEW=1
	DO 990 INDEX=1,LSNUM
	WRITE(LSNEW,995)
995	FORMAT(' SETOPR 5/12/77 - 4:01PM')
990	LSNEW=3
C
C	[2.1] VERIFY QR SPECS
C@S	JMS CKIN
C@@S	JMS CKOUT
C@@S	JMS CKIN2
C
C
C	[3] !!! SETOPR OPERATION !!!
C	DEFINE BSET CALLS
	LMEMBER=1
	LUNION=2
	LDIFF=3
	LINTERSECT=4
	LPUTDATA=5
	LRMVDATA=6
	LPUTXY=7
	LRMVXY=8
	LSIZE=9
C
C	DEFINE DPCVRT CALLS
	LDTOF=-1
	LFTOD=+1
C
C
C	DEFINE BNODE CALLS:
	KAPPENDXY=1
	KDELETEXY=2
	KPRINTLIST=3
	KINITAVAIL=4
	KGETLIST=5
	KFREELIST=6
	KLASTXY=7
	KNEXTXY=8
	KCARXY=9
	KFINDXY=10
	KCOPYLIST=11
	KCONSLIST=12
	KCDRLIST=13
	KSETXY=14
	KCVXYTOI=15
	KCVITOXY=16
	KWRITEINFO=17
	KREADINFO=18
	KSETFREESTORE=19
C
C
C	SEE IF FREESTORE IS ACTIVE
C	IF LSFREESTORE[2]=-1
C		 THEN NO FREESTORE EXISTS
S	TAD \LSFREESTORE#
S	SMA CLA
S	JMP \301 /OK
C	INIT THE FREESTORE AND PUT PTR==>LSFREESTORE[1:2]
	CALL BNODE(0,0,0,KINITAVAIL)
	LSFREESTORE=1
S	DCA \LSFREESTORE#
301	CONTINUE
C
C	[4] PARSE SWITCH LIST AND INTERPRET
	DO 400 I=1,26
	IF(ISW(I))401,402,401
402	CONTINUE
	GOTO 999
C
C
C	DISPATCHER
	GOTO (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19
     ,20,21,22,3,24,25,26),I
C
C
C	[4.1] /A
C	/A	ADD	Add node to Set QRj which contains the info 
C			field i data contained in QRi1.
1	CONTINUE
S	JMS CKIN
S	JMS CKOUT
	IFIELD=ICNUM(3)
	CALL BSET(NUM,IFIELD,ISET,LPUTDATA)
	GOTO 2047
C
C
C	[4.2] /B
2	CONTINUE
C
C
C	[4.3] /C
C	/C	COPY SET    QRj_COPY QRi1
3	CONTINUE
S	JMS CKIN
S	JMS CKOUT
	CALL BNODE(MQRI1,0,MQRJ,KCOPYLIST)
	GOTO 2047
C
C
C	[4.4] /D
C	/D	DIFF QRj_QRi1 Set difference QRi2;
4	CONTINUE
S	JMS CKIN2
S	JMS CKOUT
	CAL BSET(MQRI1,MQRI2,MQRJ,LDIFF)
	GOTO 2047
C
C
C	[4.5] /E
C	/E	EVAL,	QRj_EVAL, QRi1, j'th element of list and
C			i'th field if exists else -1;
5	CONTINUE
S	JMS CKIN
S	JMS CKOUT
	IFIELD=ICNUM(3)
	JSIZE=ICNUM(4)
C	GET JSIZE'TH NODE
	MQRJ=MQRI1
S	TAD \MQRI1#
S	DCA \MQRJ#
C
	IF(JSIZE-1)26,1053,1052
C
C	SEARCH REST OF LIST
1052	DO 1051 I=2,JSIZE
	CALL BNOE(IX,IY,MQRJ,KNEXTXY)
C	IF MQRJ=MQRI1
C		THEN FAIL AT /Z;
S	TAD \MQRJ
S	CIA
S	TAD \MQRI1
S	SZA CLA
S	JMP \1051 /NOT EOL
S	TAD \MQRJ#
S	CIA
S	TAD \MQRI1#
S	SNA CLA
S	JMP \26 /EOL AT /Z
1051	CONTINUE
C
C	GET IFIELD OF NODE
1053	CALL BNODE(IBUF1,0,MQRJ,KREADINFO)
	DO 1054 I=1,2
1054	MQRJ(I)=IBUF1((IFIELD-1)+(IFIELD-1)+I)
	GOTO 2047
C
C
C	[4.6] /F
C	/F	FOREACH	FOREACH x SUCHTHAT (x IN QRi1) AND
C			(j leq NODE(x) i'th field datum leq k)
C			DO PUT x INTO QRj.
6	CONTINUE
S	JMS CKIN
S	JMS CKOUT
	IFIELD=ICNUM(3)
	JSIZE=ICNUM(4)
	KSIZE=ICNUM(5)
C
	MQRJ=-1
S	CLA CMA
S	DCA \MQRJ#
C
C	IF QRI1=NIL
C		THEN FAIL AT /Z;
S	TAD \MQRI1#
S	SPA CLA
S	JMP \26 /FAILED!
C
C	GET 1ST NODE
	IA=MQRI1
S	TAD \MQRI1#
S	DCA \IA#
C
1060	CALL BNODE(IBUF1,0,IA,KREADINFO)
	IB=IBUF1(IFIELD+IFIELD-2+1)
C	IF JSIZE LEQ IB LEQ KSIZE
C		THEN PUT INTO SET
S	TAD \JSIZE
S	CIA
S	TAD \IB
S	SPA CLA
S	JMP \1061 /NO
S	TAD \IB
S	CIA
S	TAD \KSIZE
S	SPA CLA
S	JMP \1062 /YES
C
C	NO, TEST IF IA=QRI1 THEN DONE ELSE GET NEXT NODE
1061	CALL BNODE(IX,IY,IA,KNEXTXY)
C	IF IA=QRI1
S	TAD \IA
S	CIA
S	TAD \MQRI1
S	SZA CLA
S	JMP \1060 /CONTINUE SEARCH
C
S	TAD \IA#
S	CIA
S	TAD \MQRI1#
S	SZA CLA
S	JMP \1060 /CONTINUE SEARCH
C	RETURN
	GOTO 2047
C
C	PUT IA INTO QRJ BY MAKING COPY OF NODE
1062	CALL BNODE(IX,IY,IB,KGETLIST)
	CALL BNODE(IBUF1,0,IA,KREADINFO)
	CALL BNODE(IBUF2,0,IB,KREADINFO)
C	COPY INFO FIELD
	DO 1063 I=5,10
1063	IBUF2(I)=IBUF1(I)
	CALL BNODE(IBUF2,0,IB,KWRITEINFO)
C	PUT IB INTO QRJ
	CALL BSET(MQRJ,IB,MQRJ,LINTERSECT)
	GOTO 1060
C
C
C	[4.7] /G
7	CONTINUE
C
C
C	[4.8] /H
8	CONTINUE
C
C
C	[4.9] /I
C	/I	INTER QRj_QRi1 Set Intersection QRi2;
9	CONTINUE
S	JMS CKIN2
S	JMS CKOUT
	CALL BSET(MQRI1,MQRI2,MQRJ,LINTERSECT)
	GOTO 2047
C
C
C	[4.10] /J
10	CONTINUE
C
C
C	[4.11] /K
11	CONTINUE
C
C
C	[4.12] /L
C	/L	LOP	QRj_LOP QRi1; (element from front of set);
12	CONTINUE
S	JMS CKIN
S	JMS CKOUT
C
C	BACKUP LIST
	CALL BNODE(IX,IY,MQRI1,KNEXTXY)
C	PUT LIST HEAD ON AVAIL LIST
	CALL BNODE(IX,IY,MQRI1,KDELETEXY)
C	GET NODE WITH INFO INTACCT!
C	INTO QRJ!
	CALL BNODE(IX,IY,MQRJ,KGETLIST)
C	UPDATE QRI PTR
	ITMPSTK(I11)=MQRI1
	IQREG(I11)=MQRI1(2)
	GOTO 2047
C
C
C	[4.13] /M
C	/M	MODIFY	Modify field i of node QRj to contain data QRi1.
13	CONTINUE
S	JMS CKIN
S	JMS CKOUT
	IFIELD=ICNUM(3)
C
C	READ INFO 
	IX1=(IFIELD-1)+(IFIELD-1)++1
	IX2=IX1+1
	CALL BNODE(IBUF1,0,MQRJ,KREADINFO)
	IBUF1(IX1)=MQRI1
	IBUF1(IX2)=MQRI1(2)
	CALL BNODE(IBUF1,0,MQRJ,KWRITEINFO)
	GOTO 998
C
C
C	[4.14] /N
C	/N	NORM	print and return the size of QRi1 ==>QRj.
14	CONTINUE
S	JMS CKIN
S	JMS CKOUT
	CALL BSET(MQRI1,0,MQRJ,LSIZE)
	CALL DPCVRT(MQRJ,FA,LDTOF)
	IZ=1+IOUTSPOOL
	IY=1+IZ
	DO 1401 IX=1,IY,IZ
	WRITE(IX,1402)(KINFILE(ICHAN),ICHAN=5,6),FA
1402	FORMAT(' SIZE OF ',A2,A1,'=',F7.0)
1401	CONTINUE
	GOTO 2047
C
C
C	[4.15] /O
15	CONTINUE
C
C
C	[4.16] /P
C	/P	PRINT	Print QRi1, numeric modifier i
C			(See BNODE KPRINTLIST for actual bit allocation).
16	CONTINUE
S	JMS CKIN
	IFIELD=ICNUM(3)
	IDEV=1+IOUTSPOOL+IOUTSPOOL
	CALL BNODE(IDEV,IFIELD,MQRI1,KPRINTLIST)
	GOTO 2047
C
C
C	[4.17] /Q
17	CONTINUE
C
C
C	[4.18] /R
C	/R	REMOVE	Remove node from set QRj such that the node info
C			is in QRi1 and the i'th node field is used.
18	CONTINUE
S	JMS CKIN
S	JMS CKOUT
	IFIELD=ICNUM(3)
	CALL BSET(MQRI1,IFIELD,MQRJ,LRMVDATA)
	GOTO 2047
C
C
C	[4.19] /S
19	CONTINUE
C
C
C	[4.20] /T
20	CONTINUE
C
C
C	[4.21] /U
C	/U	UNION	QRj_QRi1 Set Union QRi2;
21	CONTINUE
S	JMS CKIN2
S	JMS CKOUT
	CALL BSET(MQRI1,MQRI2,MQRJ,LUNION)
	GOTO 2047
C
C
C	[4.22] /V
22	CONTINUE
C
C
C	[4.23] /W
23	CONTINUE
C
C
C	[4.24] /X
24	CONTINUE
C
C
C	[4.25] /Y
25	CONTINUE
C
C
C	[4.26] /Z
C	/Z	NIL	Set the set pointer QRj to nil.
26	CONTINUE
	MQRJ=-1
S	CLA CMA
S	DCA \MQRJ#
	GOTO 2047
C
C
C
C	[5] IF QRJ THEN COPY POINTER INFO BACK TO Q-REG
2047	CONTINUE
C
C
C	[5.1] TEST IF KOUTFILE="QR"
S	TAD \KOUTFILE
S	CIA
S	TAD QRTEXT
S	SZA CLA
S	JMP \998 /FAILED
C
C	[5.2] TEST IF (KOUTFILE(2) LAND '7700)=LETTER
S	TAD \KOUTFILE#
S	BSW
S	AND (0077
S	DCA \IX
S	TAD \IX
S	SNA /IF ZERO THEN FAIL
S	JMP \998
C
S	TAD (-33 /32=Z
S	SMA CLA
S	JMP \998 /FAILED
C
C
C	[5.3] GET SET PTR
	ITMPSTK(IX)=MQRJ
	IQREG(IX)=NQRJ
C
C
	GOTO 998
C	[999] RETURN
	GOTO 998
999	WRITE(1,996)
996	FORMAT('BAD QR SPECIFICATION!')
998	CONTINUE
C
	CALL BSCOMMON(1)
	ET=TIMER(1)
	CALL CHAIN('QRON2')
C***************************************************
C	*PROCEDURE      C K O U T
C******************************************************
C
C
C	CHECK WHETHER THE OUTPUT QR SPEC IS LEGAL ELSE GOTO 999.
S	CPAGE 3
SRCKOUT,	JMP I CKOUT
S CKOUT,	0 /ENTRY
C
C	[1] TEST IF KOUTFILE="QR"
S	TAD \KOUTFILE
S	CIA
S	TAD QRTEXT
S	SZA CLA
S	JMP \999 /FAILED
C
C	[2] TEST IF (KOUTFILE(2) LAND '7700)=LETTER
S	TAD \KOUTFILE#
S	BSW
S	AND (0077
S	DCA \I13
S	TAD \I13
S	SNA /IF ZERO THEN FAIL
S	JMP \999
C
S	TAD (-33 /32=Z
S	SMA CLA
S	JMP \999 /FAILED
C
C
C	[3] GET SET PTR
	MQRJ=ITMPSTK(I13)
	NQRJ=IQREG(I13)
S	JMP RCKOUT /OK.
C
C
C***************************************************
C	*PROCEDURE      C K I N
C******************************************************
C
C
C	CHECK WHETHER THE INPUT QR SPEC IS LEGAL ELSE GOTO 999.
S	CPAGE 3
SRCKIN,	JMP I CKIN
S CKIN,	0 /ENTRY
C
C	[1] TEST IF QRI1="QR"
	JJ=KINFILE(5)
	KK=KINFILE(6)
S	TAD \JJ
S	CIA
S	TAD QRTEXT
S	SZA CLA
S	JMP \999 /FAILED
C
C	[2] TEST IF (QRI1(2) LAND '7700)=LETTER
S	TAD \KK
S	BSW
S	AND (0077
S	DCA \I11
S	TAD \I11
S	SNA /IF 0 THEN FAIL
S	JMP \999
C
S	TAD (-33 /Z=32
S	SMA CLA
S	JMP \999 /FAILED
C
C
C	[3] GET SET PTR
	MQRI1=ITMPSTK(I11)
	NQRI1=IQREG(I11)
S	JMP RCKIN /OK.
C
C
C***************************************************
C	*PROCEDURE      C K I N 2
C******************************************************
C
C
C	CHECK WHETHER THE INPUT QR SPEC IS LEGAL ELSE GOTO 999.
S	CPAGE 3
SRCKIN2,	JMP I CKIN2
S CKIN2,	0 /ENTRY
C
C	[1] CHECK FIRST IQR1 SPEC
S	JMS CKIN
C
C
C	[2] TEST IF QRI2="QR"
	JJ=KINFILE(9)
	KK=KINFILE(10)
S	TAD \JJ
S	CIA
S	TAD QRTEXT
S	SZA CLA
S	JMP \999 /FAILED
C
C	[3] TEST IF (QRI2((6) LAND '7700)=LETTER
S	TAD \KK
S	BSW
S	AND (0077
S	DCA \I12
S	TAD \I12
S	SNA /IF 0 THEN FAIL
S	JMP \999 /FAIL
C
S	TAD (-33 /Z=32
S	SMA CLA
S	JMP \999 /FAILED
C
C
C	[3] GET PTR
	MQRI2=ITMPSTK(I12)
	NQRI2=IQREG(I12)
S	JMP RCKIN2 /OK.
C
C
C************** P A R A M E T E R S *************
S QRTEXT,	TEXT /QR/
	END