C	PROGRAM FRETST.FT
C	------------------
C
C
C
C	P. LEMKIN
C	NIH
C	BETHESDA, MD
C
C
C	JUNE 10, 1977
C
C
C	PURPOSE
C	-------
C	TEST THE LIST FREEING COMMAND FIRST IN FREESTORE.FT
C	AND THEN LATER IN BNODE.
C
C	FBW4 SWITCHES
C	--------------
C	0	PRINT NLIST,NPASSES, IACTIVE
C	1	PRINT ON LPT AS WELL AS TTY:
C	2	PRINT THE RANDOM VARIABLE
C	3	PRINT MAKE LIST
C	4	PRINT DELETE LIST
C
C
C	.COMPILE FRETST.FT
C
C	.R LOADER
C	*FREESTORE
C	*BNODE
C	*DPCVRT
C	*IBCD
C	*FRETST$
C	.SAVE SYS FRETST
C
S	OPDEF	FBW4 6344
S	OPDEF	DISP2	6436
S	OPDEF	DISP1	6435
C
	DIMENSION IACTIVE(2,10),LIST(2),IDATA(2),IAVAIL(2)
C
C	[0] INITIALIZATION
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
C	[1] ZERO ALL OF THE LISTS
	NLISTS=0
C	 FOR I_ 1 STEP 1 UNTIL 10
C			 DO IACTIVE[I]_-1;
	DO 100 K=1,10
	IACTIVE(1,K)=-1
100	IACTIVE(2,K)=-1
C
C	SETUP THE FREESTORE
	CALL BNODE(IX,IY,IAVAIL,KINITAVAIL)
C
C
C	[2] CONSTRUCT LIST
200	PASS=PASS+1.0
C
C	IF FBW4[1]=1 THEN ALSO PRINT ON LPT ELSE JUST TTY:
S	FBW4
S	AND (2000
S	SZA CLA
S	TAD (2 /LPT
S	IAC
S	DCA \IDEV
C
C
C
C	COUNT UP PASSES THROUGH THE ALGORITHM
	IPASS=IPASS
S	ISZ \IPASS
S	JMP \204
	WRITE(IDEV,205)
205	FORMAT(' COMPLETED 4K PASSES.')
S\204,	TAD \IPASS
S	DISP1
C
C
C	I_IRANDOM(I)
	I=IRAND(I)
C	IF IACTIVE[I]=-1
	IF(IACTIVE(2,I)+1)300,201,300
C		THEN
C		BEGIN "MAKE LIST"
C	J_IRANDOM(J);
201	J=IRANDOM(J)
C
C	IF FBW4[3]=1 THEN PRINT MAKE LIST
S	FBW4
S	AND (400
S	SNA CLA
S	JMP \298 /NO
C
C
	WRITE(IDEV,299)I,J
299	FORMAT(' MAKE LIST ',I5,' SIZE=',I5)
298	CONTINUE
C		IACTIVE[I]_GETLIST;
	CALL BNODE(IX,IY,IACTIVE(1,I),KGETLIST)
	NLISTS=NLISTS+1
S	TAD \NLISTS
S	DISP2
C
S	JMS PRNLIST
C
C
C		FOR K_2 STEP 1 UNTIL J
C			DO APPENDXY(ACTIVE[I]);
	DO 202 K=2,J
	CALL BNODE(IX,IY,IACTIVE(1,I),KAPPENDXY)
202	CONTINUE
C		END "MAKE LIST";
C
C
C	[3] DELETE LIST
300	CONTINUE
C	I_IRANDOM(I);
	I=IRAND(I)
C
C	IF IACTIVE[I] NEQ -1
	IF(IACTIVE(2,I)+1)301,200,301
C		THEN FREELIST(IACTIVE[I]);
301	CONTINUE
C	IF FBW4[4]=1
C		THEN PRINT DELETE
S	FBW4
S	AND (0200
S	SNA CLA
S	JMP \398 /NO
	WRITE(IDEV,399)I
399	FORMAT(' DELETE LIST ',I5)
398	CONTINUE
C
	CALL BNODE(IX,IY,IACTIVE(1,I),KFREELIST)
	NLISTS=NLISTS-1
S	TAD \NLISTS
S	DISP2
C
S	JMS PRNLIST
C
C	GOTO [2]
	GOTO 200
C
C
C
C
C	******************************************************
C	* SUBROUTINE    I R A N D O M
C	*******************************************************
C	RETURN IRANDOM(I);
C
S	DUMMY IARG
S	CPAGE 2
S IARG,	BLOCK 2
C
S	ENTRY IRAND
S	CPAGE 2
S IRAND,	BLOCK 2
S	INC IRAND#
S	INC IRAND# /SETUP RETURN
C
	JARG=(JARG+1017)*(JARG+2)
S	TAD \JARG
S	RTR
S	AND (17
S	TAD (-6 
S	SPA
S	CLA IAC
S	SNA
S	CLA IAC /MAKE IT 1
S	DCA \IARG
S	FBW4
S	AND (1000
S	SNA CLA
S	JMP \1000
C
	WRITE(IDEV,1001)IARG
1001	FORMAT(' IRAND(.)=',I5)
C
S\1000,	TAD \IARG
S	RETRN IRAND

C	*****************************************************
C	*SUBROUTINE PRNLIST
C	******************************************************
C	IF FBW4[0]=1
C		THEN PRINT NLISTS, IPASS, IACTIVE;
S	CPAGE 3
S RPRNLIST,	JMP I PRNLIST
S PRNLIST,	0
C
S	FBW4
S	AND (4000
S	SNA CLA
S	JMP RPRNLIST
C
	WRITE(IDEV,510)NLISTS,PASSES
510	FORMAT(/,' NLISTS=',I5,' PASSES=',F6.0)
C
	DO 511 L=1,10
	CALL DPCVRT(IACTIVE(1,L),F,-1)
	WRITE(IDEV,512)L,F
512	FORMAT(' LIST[',I2,']=',F9.2)
511	CONTINUE
S	JMP RPRNLIST
	END