C
C-----------------------------------------------------------------------------
C
C Subroutine:	B I T M A P
C
C Purpose:	To get the number of free blocks on assigned disk.
C
C Author:	Han Lasance
C		DEC Software Services
C
C Date:		31-JUL-80
C
C Version:	2.0	25-FEB-86
C
C Language:	FORTRAN-IV+, FORTRAN-77
C
C Input  files:	SY:[0,0]BITMAP.SYS
C
C Output files:	None
C
C LUNs:		Number	I/O	Description
C		LUN	 I	LUN of disk to be checked.
C
C Event flags:	Number	Description
C		   2	RLB QIO's of BITMAP.SYS
C
C Call:		BITMAP	(LUN, DEV, IFREE, ICNTG, IER)
C
C Arguments:	Name	I/O	Type	Description
C		LUN	 I	I*2	LUN      of assigned disk
C		DEV	 I	L*1	Device/unit-no. string
C		IFREE	 O	I*4	No. of free blocks
C		ICNTS	 O	I*4	No. of contiguous blocks
C		IER	 O	I*2	Error/Success status
C					 0	Success
C					-1	Read error
C					-2	Illegal Unit number
C					-3	Open error on BITMAP.SYS
C
C Calls to:	CLOSE,	ERRSET,	GETADR,	OPEN,	QIO,	WAITFR
C
C Building:	No special precautions.
C
C Description:	Every bit in file "BITMAP.SYS" shows, if set, that the
C		corresponding disk-block is free.
C		The first block in the file is for administration.
C
C		This subroutine opens "[0,0]BITMAP.SYS" and simply counts
C		all "1"'s in the file starting with block #2 until an
C		end-of-file is detected (IE.EOF = -10.).
C
C		The reason for using "QIO" is because "BITMAP.SYS" has 
C		recordsize = 0, so normal file access is impossible.
C
C Modified by:	Name			Date		Ident.	Vers.
C		Jan H. Belgraver	25-FEB-86	JB01	V2.0
C		1. For use with any disk, especially our 'new' RP06.
C		Second argument (IUNIT, unit no. of assigned disk) is 
C		replaced with device name string (DEV). 
C				w a r n i n g
C		This module is not compatible any more with previous version.
C
C		2. This documentation header
C-----------------------------------------------------------------------------
C

C
C
	SUBROUTINE	B I T M A P	(LUN, DEV, IFREE, ICNTG, IER)	
C
C
	LOGICAL*1	IOST(4), FNAME(20)
	LOGICAL*1	DEV(1)						

	INTEGER*4	BLOCK, IFREE, FNAM(5), ICNTG, ICNT, ICMAX

	DIMENSION	IBUF(256), IPARM(6), IOSB(2), MASK(16)

	EQUIVALENCE	(IPARM(5), BLOCK),
	1		(IOST(1),  IOSB(1))
	EQUIVALENCE	(FNAME(1), FNAM(1))

	DATA	FNAM	/'DMN:','[0,0',']BIT','MAP.','SYS '/
	DATA	MASK	/    1,      2,      4,
	1		   "10,    "20,    "40,
	2		  "100,   "200,   "400,
	3		 "1000,  "2000,  "4000,
	4		"10000, "20000, "40000, "100000/


	IER	= 0
	IFREE	= 0		! Preset to not free blocks
	ICMAX	= 0		! 
	ICNT	= 0		! 
	ICNTG	= 0		! Preset to no Contiguous blocks
	BLOCK	= 1		! Start at logical block #1
	IPARM(2)= 512		! QIO byte-count, i.e. one disk block
	FNAME(20)= 0

C	Suppress Inconsistent Record Length error messages
	CALL	ERRSET	(37,.TRUE.,.FALSE.,.FALSE.,.FALSE.)


	DO 5	I = 1, 3		
	  FNAME(I)	= DEV(I)	! Replace in default one
5	CONTINUE							
	IF	(DEV(3)	.EQ. ':')	FNAME(3) = '0'

	CALL	GETADR	(IPARM(1), IBUF(1))	! Get buffer address

	OPEN	(UNIT	= LUN,		
	1	 NAME	= FNAME,	! ddn:[0,0]BITMAP.SYS
	2	 TYPE	= 'OLD',
	3	 ACCESS	= 'DIRECT',
	4	 ERR	= 100,
	5	 RECORDSIZE = 1,
	6	 READONLY,
	7	 SHARED)

10	BLOCK	= BLOCK + 1
	CALL	QIO	("10400, LUN,2,, IOSB, IPARM)
	CALL	WAITFR	(2)
	IF	(IOST(1) .LT. 0)	GOTO	50
	DO 20	K = 1, 256
 	  IF	(IBUF(K) .EQ. 0)	GOTO	17
	  DO 20	I = 1, 16
	    IF	(IAND (IBUF(K),MASK(I)) )	15, 17, 15
15	    IFREE	= IFREE + 1
	    ICNT	= ICNT + 1
	    GOTO	20
17	  IF	(ICNT .GT. ICMAX)	ICMAX = ICNT
	  ICNT	= 0
20	CONTINUE
	GOTO	10


50	IF	(IOST(1) .EQ. -10)	GOTO	500
	IER	= -1
	WRITE	(5,60) IOST
60	FORMAT	(/' <BITMAP> * F * -- I/O error on [0,0]BITMAP.SYS -- ',
	1	  ' Status = ', 4O4/)
	GOTO	500

70	IER	= -2
	WRITE	(5,80) IUNIT
80	FORMAT	(/' <BITMAP> * F * -- Illegal unit number: ', I5/)
	GOTO	500

100	IER	= -3
	WRITE	(5,101) FNAME
101	FORMAT	(/' <BITMAP> * F * -- Open error on file ', 20A1/)

500	ICNTG	= ICMAX
	IF	(ICNT .GT. ICMAX) ICNTG = ICNT
	CLOSE	(UNIT	= LUN)

	RETURN
	END