C_Title	CDDIR obtains directories of CDROM disk -- VMS (non-TAE) version
C
C_VARS
	include '($syssrvnam)'		!FORTRAN system service definitions
	include '($iodef)'		!FORTRAN I/O definitions
	include '($ssdef)'		!FORTRAN system service code defns
C
C 	include TAE information
C
CTAE	INCLUDE 'TAE$INC:PGMINC.FIN/NOLIST'
CTAE	COMMON /TAEBLK/ BLOCK
CTAE	INTEGER BLOCK(XPRDIM)
C
C_DESC	This program lists the directories on a CDROM disk.  It will list
C	file name, extension, version number, file size, date and whether
C	the file is data file or directory file for each file in the
C	user specified directory(ies).  If the user does not specify
C	either the device or directory, the program tries to obtain the
C	appropriate default from the logical name PIC$CDROM if it exists.
C	If not provided by PIC$CDROM, the device defaults to DUB0: and
C	the directory to the highest level (ROOT) directory.  If the
C	user enters three dots (...) at the end of the directory entry,
C	the contents of all subdirectories from that point are listed.
C
C       The program has the ability to generate a file of complete file
C       names. This option is triggered when the EXTENT input		! RMX
C       parameter is utilized by the user. No header or trailer is
C       provided in the file. This option is especially useful
C       when a file of file names needs to be generated for input
C       to a program which is going to processes many images.
C
C_USER  Input parameters						! RMX v

C     CHARACTER*50 TO	! The optional output file name.
C			  When a value is entered, the output will be saved
C			  in a new version of the specified file.  If no value
C			  is given for this parameter the output is directed
C			  to the the user's terminal. 

C     CHARACTER*8 EXTENT !This option triggers CDDIR to create only a file of
C			  file names which end with the given extension name.
C			  For example EXTENT=IMQ will list only those files
C			  which have an extension of IMQ. This option is useful
C			  when creating a file of file names which will act as
C			  input to a program which needs to process many images.

C     CHARACTER*50 FROM ! Directory spec: ddun:[directory.sub direc...].
C			  The device and directory defaults are DUB0: and
C			  the "ROOT" directory.  Directories are specified
C			  as main directory (as listed in "ROOT" directory)
C			  any subdirectories; e.g. [dir.subd1.subd2].  Using
C			  '...' causes the current subdirectory and any 
C			  subdirectories to be listed; e.g. [...] lists all
C			  directories on the disk; while [dir.s1dir...] lists
C			  the dir.s1dir directory and all those below it.!RMX ^

C_KEYS	CDROM								! RMX
C
C_HIST	2Apr87, DMcMacken, ISD, U.S.G.S., Flagstaff, Original Version
C       1Jan89  DMcMacken, ISD, Modify for ISO standard
C       5Jan89  EEliason, Astrogeology, U.S.G.S., Added extent file capabilities
C	12Jan89 RMehlman (RMX) UCLA/IGPP, VMS (non-TAE) version		! RMX
C	 	 Interactive Fortran input replaces TAE.		! RMX
C	 	 Program now loops on FROM parameter.			! RMX
C
C	Feb 91  B.H. TOBY, minor changes for access to non-DUB0 CDROM
C_END
C******************************************************************************
c
c	local variables
c
	character*50	dir_nam		!directory name including
c					device, ddcn:[dir1.dir2...]
	character*50	dir_up		!uppercase copy of dir_nam
	character*100	dir_lst(4096)	!directory list name
	character*8     extent  	!list files with a given extension
	integer*4       ext_len		!extension name length
	character*64    str		!hold a string
        integer*4       str_len

	integer*2	ldir(4096)	!directory name length
	integer*2	ndir		!number of directories
	character*100	dir_tmp		!current directory
	integer*2	kdir		!length of current directory name
	integer*4	blk_adr(4096)	!directory addresses
	integer*4	blk_sz(10000)	!directory sizes
	integer*4	chan		!assigned channel
	byte		ibuf(61440)	!I/O buffer
	byte		dbuf(3000)	!directory buffer
	integer*4	log_blk		!disk logical block
	integer*4	blk_len		!no bytes to read
	integer*2	iosb(4)		!I/O status block
	integer*4	status		!system call return status
	character*20	dev		!device name
	integer*4	mrk		!string pointer
	integer*4	mrk2		!string pointer
	character*31	dir_str1	!subdirectory string 1
	character*31	dir_str2	!subdirectory string 2
	character*50	direc		!directory string
	integer*4	root_blk	!root directory location
	integer*4	dir_blk		!directory location pointer
	integer*4	root_len	!root directory size
	integer*4	dir_len		!directory record length
	integer*4	dir_sz		!directory size
	integer*4	fid_len		!length of file identifier
	logical*2	found		!file found flag
	logical*2	dir_all		!flag to list all subdirectories
	logical*2	dir_end		!end of directory string flag
	integer*4	nblks		!number of blks in file
	integer*2	year		!file date - year
	integer*2	mon		!file date - month
	integer*2	day		!file date - day
	integer*2	hr		!file time - hour
	integer*2	min		!file time - minute
	integer*2	sec		!file time - second
	integer*2	log_blk_sz	!disk logical block size
	integer*2	blk_fac		!disk blocking factor
	character*1	file_type	!file type (directory or file)
	integer*2	file_flg	!file flag byte
	integer*4	nfiles		!number of files in directory
	integer*4	tblks		!total blocks in directory
	integer*4	gtfiles		!grand total files
	integer*4	gtblks		!grand total blocks
	integer*4	ipr/6/		!sys$out unit
	INTEGER*4	ITERM/5/	!INTERACTIVE INPUT UNIT		! RMX
	integer*4	nxt_blk		!next logical block to read
	integer*4	num_sec		!number logical sectors in directory
	integer*4	i_sec		!sector index
	character*50	out_lst		!output file
	integer*4	out_len		!length of output file specification
	integer*2	sdx		!standard index - 1 = High Sierra
c							  2 = ISO
c	Offsets into buffers for volume and directory
c	parameters.  Correct offsets for High Sierra or
c	ISO standards are found using sdx (standard index).
c
	integer*2	rb(2)		!root block pointer offset
	integer*2	rl(2)		!root directory length offset
	integer*2	lbs(2)		!logical block size offset
	integer*2	db(2)		!directory block pointer offset
	integer*2	ds(2)		!directory size offset
	integer*2	ff(2)		!file flags offset
c
c	default device and directory strings
c
	character*9	cdrom_log	!device/directory logical name
	character*50	default_str	!default device/directory string
	character*20	default_dev	!default device
	character*50	default_dir	!default directory
	integer*4	ierr		!error value from subroutine
c
	data	rb /183, 159/
	data	rl /191, 167/
	data	lbs /137, 129/
	data	db /3, 3/
	data	ds /11, 11/
	data	ff /25, 26/
	data	cdrom_log /'PIC$CDROM'/
c
c	determine device and directory defaults
c
C_ICDD:
	type *,'**NOTE** File extension length modified by ICDD - ',
	1 '3 bytes assumed'
C_ICDD:
	status = lib$sys_trnlog (cdrom_log,, default_str,,,)
	if (status .ne. SS$_NORMAL) default_str = ' '
	mrk = index (default_str, ':')
	mrk2 = index (default_str, ']')
	if (mrk .eq. 0) then
		default_dev = 'DUB0:'
	else
		default_dev = default_str(:mrk)
	endif
	if (mrk2 .eq. 0) then
		default_dir = 'ROOT'
	else
		default_dir = default_str(mrk+2:mrk2-1)
	endif
c
c
c	initialize TAE call and obtain the directory specification
c
CTAE	call xzinit (block, xprdim, ipr, xabort, istat)
CTAE	call xrstr (block, 'FROM', 1, dir_nam, in_len, icount, istat)
CTAE	call xrstr (block, 'TO', 1, out_lst, out_len, icount, istat)
CTAE	call xrstr (block, 'EXTENT',1,extent, ext_len, icount, istat)

C 	VMS parameter input

	WRITE (ITERM, 7000)						! RMX
7000	FORMAT (/'$Enter output specification (default: terminal): ')	! RMX
	READ (ITERM, 9000, END=10) OUT_LST				! RMX
c
c	parse output string
c
        ier = 6

C	if (out_len .eq. 0) then
	IF (OUT_LST.EQ.' ') THEN					! RMX
		ipr = 6
		open (unit=ipr, file='sys$output',status='new',
     1		carriagecontrol='list')
	else
		ipr = 1
		open (unit=ipr, file=out_lst, status='new',
     1		carriagecontrol='list')
	endif

	WRITE (ITERM, 7500)						! RMX
7500	FORMAT (/'$Enter extension for file list (default: none)')	! RMX
	READ (ITERM, 9000, END=10) EXTENT				! RMX

C***********************************************************************
C If EXTENT is not blank then construct the file extension string
C***********************************************************************
	if (extent.ne.' ') then
		call str$upcase(extent,extent)
		if (extent(1:1).ne.'.') extent = '.'//extent
C_ICDD_mod: missing LENOSP subroutine.  Assume length of file extension is 3
CCCCCCC		ext_len = lenosp(extent)
	        ext_len = 3
C_ICDD
	end if

c
C Loop on requests							! RMX

10	CONTINUE							! RMX
C
	write (ITERM, 8000)						! RMX
8000	format (/'$Enter directory specification, or EOF to exit: ')	! RMX
       	read (ITERM, 9000, end=1000) dir_nam				! RMX
9000	format (a)							! RMX
c
c	parse directory name string
c
	call str$upcase (dir_up, dir_nam)
	mrk = index (dir_up, ':')
	mrk2 = index (dir_up, ']')
	if (mrk .ne. 0) then
		dev = dir_up(1:mrk)
	else
		dev = default_dev
	endif
	if (mrk2 .ne. 0) then
		direc = dir_up(mrk+2:mrk2-1)
	else
		direc = default_dir
	endif
	kdir = index (direc, '...')
	if (kdir .eq. 0) then
		dir_lst(1) = direc
	else if (kdir .eq. 1) then
		dir_lst(1) = 'ROOT'
	else
		dir_lst(1) = direc(1:kdir-1)
	endif                                        
	ldir(1) = index (dir_lst(1), ' ') - 1
	ndir = 1
c
c	search for directory
c
	chan = 0
	sblk = 0
	fsize = 0
c
c	open channel to device
c
C!	write (*,'(A)') '$Enter a device name: '
C!	read (*,'(A)') dev
C!	write (*,*) 'Opening device = ',dev
	status = sys$assign (dev, chan,,)
	if (.not. status) then
		write (ier, 6001) dev
6001	format(/'%CDDIR-F-NOTASG, could not assign channel to device ',a)
		call lib$stop (%val(status))
	endif
c
c	read volume descriptor block
c
	log_blk = 64
	blk_len = 2048
	status = sys$qiow (, %val(chan), %val(io$_readlblk),
	1			iosb,,, ibuf, %val(blk_len),
	2			%val(log_blk),,,)
c
c	determine the standard under which disk was written
c
	call cdstand (ibuf, sdx, ierr)
	if (ierr .lt. 0) then
		write (ier, 6000)
6000	format (/ ' %CDDIR-F-NOTSTD, ',
	1	'CDROM not written in acceptable standard')
		call exit
	endif
c
c	copy needed parameters into variables from buffer
c
	call b2b (ibuf(rb(sdx)), root_blk, 4)
	call b2b (ibuf(rl(sdx)), root_len, 4)
	call b2b (ibuf(lbs(sdx)), log_blk_sz, 2)
c
c	search directory tree
c	starting at root
c
	blk_fac = log_blk_sz/512
	log_blk = root_blk*blk_fac
	blk_len = root_len
	dir_all = .false.
	if (direc .eq. 'ROOT') then
		found = .true.
		dir_end = .true.
	else
		found = .false.
		dir_end = .false.
		mrk = 1
	endif
	do while (.not. dir_end)
c
c	determine name of directory we want on this level
c
		mrk = index (direc, '.')
		if (mrk .eq. 0) then
			dir_str1 = direc
		else if (mrk .eq. 1) then
			dir_all = .true.
			found = .true.
			dir_end = .true.
		else
			dir_str1 = direc(1:mrk-1)
	 		direc = direc(mrk+1:50)
		endif
		if (.not. dir_end) then
			if (mrk .eq. 0) dir_end = .true.
			found = .false.
			nxt_blk = log_blk
			num_sec = (blk_len + 2047)/2048
			blk_len = 2048
			i_sec = 0
			do while (i_sec .lt. num_sec .and. .not. found)
			   i_sec = i_sec + 1
c
c	read directory block
c
			   status = sys$qiow (, %val(chan),
	1				%val(io$_readlblk), iosb,,, 
	2				ibuf, %val(blk_len),
	3				%val(nxt_blk),,,)
			   if (.not. status) then
				write (ier, 6002)
6002	format (/' %CDDIR-F-REDDIR, error reading directory')
				call lib$stop (%val(status))
			   endif
c
c	scan directory entries on level
c
			   if (i_sec .eq. 1) then
				mrk2 = ibuf(1) + 1
				mrk2 = ibuf(mrk2) + mrk2
			   else
				mrk2 = 1
			   endif
			   dir_str2 = ' '
		   	   do while (mrk2 .lt. blk_len .and.
	1				ibuf(mrk2) .ne. 0 .and.
	2				dir_str1 .ne. dir_str2)
c
c	copy entry to directory buffer
c
				dir_len = ibuf(mrk2)
				call b2b (ibuf(mrk2), dbuf, dir_len)
c
c	copy needed directory parameters from buffer into variables
c
				call b2b (dbuf(db(sdx)), dir_blk, 4)
				call b2b (dbuf(ds(sdx)), dir_sz, 4)
				call b2b (dbuf(ff(sdx)), file_flg, 2)
c
c	construct directory name string from entry
c
				fid_len = dbuf(33)
				dir_str2 = ' '
				call b2b (dbuf(34), %ref(dir_str2), fid_len)
c
c	save pointer in case this is it
c	point to next directory entry
c
				log_blk = dir_blk*blk_fac
				mrk2 = mrk2 + dir_len
			   enddo
c
c	set values depending on whether we found it or not
c
			   if (dir_str1 .eq. dir_str2) then
				blk_len = dir_sz
				found = .true.
			   else
				found = .false.
			   endif
			   nxt_blk = nxt_blk + 4
			enddo
		endif
	enddo
c
c	finished search of directories
c	now list directory (if possible)
c
	if (found) then
		blk_adr(1) = log_blk
		blk_sz(1) = blk_len
		gtfiles = 0
		gtblks = 0
		idir = 1
		do while (idir .le. ndir)
			log_blk = blk_adr(idir)
			blk_len = blk_sz(idir)
c
c	open directory
c
			dir_tmp = dir_lst(idir)
			kdir = ldir(idir)
			idir = idir + 1
                        if (extent.eq.' ') then
 			write (ipr, 8002) dev(:lench(dev)), dir_tmp
8002			format (/' Directory of', x, a, '[', a<kdir>, ']'/
	1		5x, 'file', 29x, 'size', 4x, 'date', 6x, 'time',
	2		3x, 'type'/)
                        end if
c
			nfiles = 0      
			tblks = 0
			num_sec = (blk_len+2047)/2048
			blk_len = 2048
			i_sec = 0
			do while (i_sec .lt. num_sec)
			   i_sec = i_sec + 1
			   status = sys$qiow (, %val(chan), %val(io$_readlblk),
	1				iosb,,, ibuf, %val(blk_len),
	2				%val(log_blk),,,)
			   if (.not. status) then
				write (ier, 6002)
				call lib$stop (%val(status))
			   endif
c
c	list names in directory
c
			   if (i_sec .eq. 1) then
				mrk2 = ibuf(1) + 1
				mrk2 = ibuf(mrk2) + mrk2
			   else
				mrk2 = 1
			   endif
			   dir_str2 = ' '
		   	   do while (mrk2 .lt. blk_len .and.
	1				ibuf(mrk2) .ne. 0)
c
c	copy entry into directory buffer
c
				dir_len = ibuf(mrk2)
				call b2b (ibuf(mrk2), dbuf, dir_len)
c
c	copy needed parameters from buffer into variables
c
				call b2b (dbuf(db(sdx)), dir_blk, 4)
				call b2b (dbuf(ds(sdx)), dir_sz, 4)
				call b2b (dbuf(ff(sdx)), file_flg, 2)
c
c	construct file name string from entry
c
				fid_len = dbuf(33)
				dir_str2 = ' '
				call b2b (dbuf(34), %ref(dir_str2), fid_len)
				if (btest(file_flg, 1)) then
					file_type = 'D'
					if (dir_all) then
						ndir = ndir + 1
						dir_lst(ndir) =
	1					  dir_tmp(1:kdir)//'.'//
	2					  dir_str2(1:fid_len)
						ldir(ndir) = kdir +
	1					  fid_len + 1
						blk_adr(ndir) = dir_blk*blk_fac
						blk_sz(ndir) = dir_sz
					endif
				else
					file_type = 'F'
				endif
c
c	write directory entry
c
				nblks = (dir_sz + 511)/512
				year = dbuf(19) + 1900
				mon = dbuf(20)
				day = dbuf(21)
				hr = dbuf(22)
				min = dbuf(23)
				sec = dbuf(24)
				nfiles = nfiles + 1
				tblks = tblks + nblks
				if (extent.eq.' ') then
				write (ipr, 8001) dir_str2(1:fid_len), 
	1				nblks, mon, day, year, hr, min, 
	2				sec, file_type
8001				format (5x, a, t35, i6, i5, '-', i2, '-', 
	1				i4, i3, ':', i2, ':', i2, 2x, a)
				else
				jdir = index(dir_tmp,'ROOT.') + 1
                                if (jdir.ne.1) jdir = jdir + 4
				str='['//dir_tmp(jdir:kdir)//']'//
	1			dir_str2(1:fid_len)
				str_len = 2 + kdir + fid_len
				if (index(str,extent(1:ext_len))
	1			.ne.0) then
				if (ipr.eq.6) then
				write(ipr,8010) str(1:str_len)
				else
				write(ipr,8011) str(1:str_len)
				end if
 8010				format(1x,a)
 8011				format(a)
				end if

				end if
c
c	point to next directory entry
c
				mrk2 = mrk2 + dir_len
			   enddo
			   log_blk = log_blk + 4
			enddo
			gtfiles = gtfiles + nfiles
			gtblks = gtblks + tblks
			if (extent.eq.' ') then
			write (ipr, 8003) tblks, nfiles
8003			format ('0Total of', i8, ' blocks in', i4, ' files.')
			end if
		enddo
		if (extent.eq.' ') then
		if (dir_all) write (ipr, 8005) gtblks, gtfiles
8005		format (/'0Grand total of', i10, ' blocks in', i5, ' files.')
		end if
	else
		mrk = index (direc, ' ') - 1
		write (ier, 6004) dev(:lench(dev)), direc(:mrk)
6004	format (/' %CDDIR-F-DNF, directory not found' /
	1	x, a, ':[', a, ']')
	endif
c
	GO TO 10			! GO BACK FOR ANOTHER REQUEST	! RMX
c
c	that's all folks
c
1000	continue
	call exit
	end
