	program fragment
c
	parameter fragment_version = '(FRAGMENT v1.0 13-Sep-1985)'
c
	parameter io_unit = 10
c
	external FRAG_DEVNOTREC
c
	include '($DVIDEF)/NOLIST'
	include '($DCDEF)/NOLIST'
	include '($CLIDEF)/LIST'
c
	integer*4 sys$getdvi
	integer*4 cli$get_value
	integer*4 cli$present
c
	integer*2 item_w(92)
	integer*4 item_l(46), avail_blocks, device_class
c
	equivalence (item_w, item_l)
c
	character*23 report_date
	character*32 device
	character*64 output_file
c
	integer*4 device_length, output_length
	integer*4 cluster, max_blocks, max_frag
c
	character*64 device_name
	character*12 volnam
c
	integer*4 device_errors,device_name_lth,maxblock,maxfiles,vprot
	integer*4 mountcnt,ownuic,refcnt,serialnum,transcnt,volnam_lth
c
	logical report_available, report_used
c
	data report_available	/.false./
	data report_used	/.false./
c
	icode = sys$asctim ( , report_date, , )
	icode = cli$get_value ('device_name', device, device_length)
	icode = cli$get_value ('output', output_file, output_length)
	icode = cli$present ('available')
	if (icode) report_available = .true.
	icode = cli$present ('used')
	if (icode) report_used = .true.
c
	item_w(1) = 4
	item_w(2) = dvi$_freeblocks
	item_l(2) = %loc(avail_blocks)
	item_l(3) = 0
c
	item_w(7) = 4
	item_w(8) = dvi$_devclass
	item_l(5) = %loc(device_class)
	item_l(6) = 0
c
	item_w(13)= 4
	item_w(14)= dvi$_errcnt
	item_l(8) = %loc(device_errors)
	item_l(9) = 0
c
	item_w(19)= 64
	item_w(20)= dvi$_alldevnam
	item_l(11)= %loc(device_name)
	item_l(12)= %loc(device_name_lth)
c
	item_w(25)= 4
	item_w(26)= dvi$_maxblock
	item_l(14)= %loc(maxblock)
	item_l(15)= 0
c
	item_w(31)= 4
	item_w(32)= dvi$_maxfiles
	item_l(17)= %loc(maxfiles)
	item_l(18)= 0
c
	item_w(37)= 4
	item_w(38)= dvi$_mountcnt
	item_l(20)= %loc(mountcnt)
	item_l(21)= 0
c
	item_w(43)= 4
	item_w(44)= dvi$_ownuic
	item_l(23)= %loc(ownuic)
	item_l(24)= 0
c
	item_w(49)= 4
	item_w(50)= dvi$_refcnt
	item_l(26)= %loc(refcnt)
	item_l(27)= 0
c
	item_w(55)= 4
	item_w(56)= dvi$_serialnum
	item_l(29)= %loc(serialnum)
	item_l(30)= 0
c
	item_w(61)= 4
	item_w(62)= dvi$_transcnt
	item_l(32)= %loc(transcnt)
	item_l(33)= 0
c
	item_w(67)= 12
	item_w(68)= dvi$_volnam
	item_l(35)= %loc(volnam)
	item_l(36)= %loc(volnam_lth)
c
	item_w(73)= 4
	item_w(74)= dvi$_vprot
	item_l(38)= %loc(vprot)
	item_l(39)= 0
c
	item_w(79)= 4
	item_w(80)= dvi$_cluster
	item_l(41)= %loc(cluster)
	item_l(42)= 0
c
	item_w(85)= 4
	item_w(86)= dvi$_maxblock
	item_l(44)= %loc(max_blocks)
	item_l(45)= 0
c
	item_l(46)= 0
c
	icode = sys$getdvi( , , device(:device_length), item_w, , , , )
	if ((icode) .and. (device_class .eq. DC$_DISK)) then
	  open (unit=io_unit,
     *		file=output_file(:output_length), 
     *		access='sequential',
     *		carriagecontrol='list',
     *		type='new')
	  write (io_unit, 100) fragment_version, report_date(:17)
	  write (io_unit, 110) 'Volume: "', volnam(:volnam_lth), '" on device: ',
     *		device_name(:device_name_lth),
     *		'Device Errors', device_errors,
     *		'Max. Files', maxfiles,
     *		'Max. Blocks ', max_blocks,
     *		'Cluster Size ', cluster,
     *		'Refcnt', refcnt
	  max_frag = (avail_blocks / max (1, cluster))
	  if (report_available) call avail_report (io_unit,
     *						device_name,
     *						device_name_lth,
     *						max_frag,
     *						cluster)
	  if (report_used) call used_report (io_unit)
	  close (unit=io_unit)
	else
	  call lib$signal(FRAG_DEVNOTREC, %val(1), device(:device_length))
	endif
100	format (a, ' - Volume Fragmentation Report - ', a, /)
110	format (
     *		t6, a, a12, a, a, //,
     *		t6, a, t25, i9, /,
     *		t6, a, t25, i9, /,
     *		t6, a, t25, i9, /,
     *		t6, a, t25, i9, /,
     *		t6, a, t25, i9)
	end
	integer function slot (value, slot_bounds, bound_count)
	integer slot_bounds (*), value, bound_count
	slot = -1
	do i = 1, bound_count
	  if ((value .gt. slot_bounds(i)) .and.
     *	      (value .le. slot_bounds(i+1))) slot = i
	enddo
	return
	end
	subroutine avail_report (io_unit,
     *				device_name,
     *				device_name_lth,
     *				max_frag,
     *				cluster)
c
	character*(*) device_name
	integer*4 slot
	integer*4 get_free_blocks
c
	integer*4 device_name_lth
	integer*4 io_unit, max_frag, cluster, total_frag
	integer*4 slot_bounds (19), slot_num, usage (-1:19)
	real*4 percent_frag
	data slot_bounds /    0,      3,      6,     10,      25,     50,
     *	                    100,    200,    300,    500,    1000,   5000, 
     *	                  10000,  25000,  50000, 100000,  250000, 500000,
     *	                9999999/
c
	slot_num = 0
	do i = -1, 18
	  usage (i) = 0
	enddo
	call open_bitmap (device_name(:device_name_lth), ierror)
	if (ierror) then
c
	  total_frag = -1
	  do while (slot_num .ne. -1)
	    slot_num = slot(get_free_blocks(), slot_bounds, 18)
	    total_frag = total_frag + 1
	    usage (slot_num) = usage (slot_num) + 1
	  enddo
	  percent_frag = (float (total_frag - 1) / float (max_frag)) * 100.00
	  write (io_unit, 100)
	  do i = 1, 18
	    write (io_unit, 110) slot_bounds(i) + 1, slot_bounds(i+1), usage(i)
	  enddo
	  write (io_unit, 120) total_frag, max_frag, percent_frag
	else
	  call lib$signal(%val(ierror))
	endif
	return
100	format (//, 5x, 'Fragmentation Report for AVAILABLE disk space:', //
     *		t6, 'Fragment Sizes:', /)
110	format (t6, I8, ' to ', I8, ' : ', I8)
120	format (t29, '--------', /, t6, 'Available Fragments',
     *		t29, i8, ' Out of: ', i8, ' (', f7.3, '% Fragmented)')
	end
	subroutine used_report (io_unit)
	external FRAG_NOSUPPORT
	call lib$signal(FRAG_NOSUPPORT)
	end
