P $! CDROM_VMS_UTILITY_PROGRAMS.COM:  Create, compile & link CDDIR, CDTYPE, CDCOPY8 $! Assumes CDROMLIB.OLB has been previously created with1 $!  CDROM_UTILITY_SUBROUTINES.COM.				RMX 05feb89  $!- $WRITE SYS$OUTPUT "Create the CDDIR.FOR file"  $CREATE CDDIR.FOR H 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 7 	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 H C_DESC	This program lists the directories on a CDROM disk.  It will listC 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 specifyA C	either the device or directory, the program tries to obtain the C 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 theA C	user enters three dots (...) at the end of the directory entry, @ C	the contents of all subdirectories from that point are listed. C G C       The program has the ability to generate a file of complete file D C       names. This option is triggered when the EXTENT input		! RMXB C       parameter is utilized by the user. No header or trailer is> C       provided in the file. This option is especially usefulA 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   6 C     CHARACTER*50 TO	! The optional output file name.7 C			  When a value is entered, the output will be saved : C			  in a new version of the specified file.  If no value8 C			  is given for this parameter the output is directed" C			  to the the user's terminal.   M C     CHARACTER*8 EXTENT !This option triggers CDDIR to create only a file of 9 C			  file names which end with the given extension name. 7 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.  H C     CHARACTER*50 FROM ! Directory spec: ddun:[directory.sub direc...].5 C			  The device and directory defaults are DUB0: and 6 C			  the "ROOT" directory.  Directories are specified7 C			  as main directory (as listed in "ROOT" directory) 8 C			  any subdirectories; e.g. [dir.subd1.subd2].  Using4 C			  '...' causes the current subdirectory and any 7 C			  subdirectories to be listed; e.g. [...] lists all 9 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 D C_HIST	2Apr87, DMcMacken, ISD, U.S.G.S., Flagstaff, Original Version7 C       1Jan89  DMcMacken, ISD, Modify for ISO standard P C       5Jan89  EEliason, Astrogeology, U.S.G.S., Added extent file capabilities@ C	12Jan89 RMehlman (RMX) UCLA/IGPP, VMS (non-TAE) version		! RMX3 C	 	 Interactive Fortran input replaces TAE.		! RMX 1 C	 	 Program now loops on FROM parameter.			! RMX  C  C_END O C******************************************************************************  c  c	local variables  c 0 	character*50	dir_nam		!directory name including! c					device, ddcn:[dir1.dir2...] 0 	character*50	dir_up		!uppercase copy of dir_nam1 	character*100	dir_lst(4096)	!directory list name < 	character*8     extent  	!list files with a given extension0 	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 directory2 	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*4	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 flag4 	logical*2	dir_all		!flag to list all subdirectories1 	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 5 	character*1	file_type	!file type (directory or file) # 	integer*2	file_flg	!file flag byte 0 	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 unit2 	INTEGER*4	ITERM/5/	!INTERACTIVE INPUT UNIT		! RMX/ 	integer*4	nxt_blk		!next logical block to read 8 	integer*4	num_sec		!number logical sectors in directory 	integer*4	i_sec		!sector index # 	character*50	out_lst		!output file 8 	integer*4	out_len		!length of output file specification1 	integer*2	sdx		!standard index - 1 = High Sierra  c							  2 = ISO / c	Offsets into buffers for volume and directory 1 c	parameters.  Correct offsets for High Sierra or 5 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 1 	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 5 	character*9	cdrom_log	!device/directory logical name : 	character*50	default_str	!default device/directory string( 	character*4	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 5 	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-1)  	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 4 CTAE	call xzinit (block, xprdim, ipr, xabort, istat)B CTAE	call xrstr (block, 'FROM', 1, dir_nam, in_len, icount, istat)A CTAE	call xrstr (block, 'TO', 1, out_lst, out_len, icount, istat) B CTAE	call xrstr (block, 'EXTENT',1,extent, ext_len, icount, istat)   C 	VMS parameter input   	WRITE (ITERM, 7000)						! RMX H 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 1 		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 E 7500	FORMAT (/'$Enter extension for file list (default: none)')	! RMX + 	READ (ITERM, 9000, END=10) EXTENT				! RMX   H C***********************************************************************A C If EXTENT is not blank then construct the file extension string H C*********************************************************************** 	if (extent.ne.' ') then  		call str$upcase(extent,extent). 		if (extent(1:1).ne.'.') extent = '.'//extent 		ext_len = lenosp(extent) 	end if    c  C Loop on requests							! RMX   10	CONTINUE							! RMX  C  	write (ITERM, 8000)						! RMX G 8000	format (/'$Enter directory specification, or EOF to exit: ')	! RMX 5        	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-1)  	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 " 	status = sys$assign (dev, chan,,) 	if (.not. status) then  		write (ier, 6001) E 6001	format (/' %CDDIR-F-NOTASG, could not assign channel to device')  		call lib$stop (%val(status)) 	endif c  c	read volume descriptor block c 
 	log_blk = 64  	blk_len = 2048 5 	status = sys$qiow (, %val(chan), %val(io$_readlblk), ! 	1			iosb,,, ibuf, %val(blk_len),  	2			%val(log_blk),,,) c 5 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 3 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 3 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 = 02 			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 = ' '0 				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 4 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, dir_tmp: 8002			format (/' Directory of', x, a, ':[', a<kdir>, ']'/4 	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 3 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 = ' '0 				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_type2 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 0 		if (dir_all) write (ipr, 8005) gtblks, gtfilesC 8005		format (/'0Grand total of', i10, ' blocks in', i5, ' files.')o 		end if 	elseR 		mrk = index (direc, ' ') - 1$ 		write (ier, 6004) dev, direc(:mrk)4 6004	format (/' %CDDIR-F-DNF, directory not found' / 	1	x, a, ':[', a, ']') 	endif ch/ 	GO TO 10			! GO BACK FOR ANOTHER REQUEST	! RMXD c  c	that's all folks cC
 1000	continueS
 	call exit 	end $EOD. $WRITE SYS$OUTPUT "Create the CDTYPE.FOR file" $CREATE CDTYPE.FORD C_TITLE	CDTYPE lists a text from a CD_ROM disk (VMS non-TAE version)   C_VARS   C 	include TAE information( CTAE	INCLUDE 'TAE$INC:PGMINC.FIN/NOLIST' CTAE	COMMON /TAEBLK/ BLOCK CTAE	INTEGER BLOCK(XPRDIM)  % C_USER  Input parameters						! RMX vE  6 C     CHARACTER*50 TO	! The optional output file name.7 C			  When a value is entered, the output will be saveds: C			  in a new version of the specified file.  If no value8 C			  is given for this parameter the output is directed" C			  to the the user's terminal.   H C     CHARACTER*50 FROM ! Directory spec: ddun:[directory.sub direc...].5 C			  The device and directory defaults are DUB0: ands6 C			  the "ROOT" directory.  Directories are specified7 C			  as main directory (as listed in "ROOT" directory) 1 C			  any subdirectories; e.g. [dir.subd1.subd2].a  F C_DESC	The program requests the user to enter the name of a file.  TheA C	compact disk is then searched for the specified file and if the A C	file is found it is listed to the terminal or output file.  The 9 C	program assumes that each line is terminated by a <CR>.s  
 C_KEYS  CDROMu  E C_HIST	15Apr87, DMcMacken, ISD, U.S.G.S., Flagstaff, Original Versions9 C	__Jan89, DMcMacken, modifications for ISO format		! RMX ; C	13Jan89, RMehlman UCLA/IGPP, VMS (non-TAE) version		! RMXn3 C		  Interactive Fortran input replaces TAE.		! RMXe1 C		  Program now loops on FROM parameter.			! RMXp   C_ENDtP C******************************************************************************* cn c	local variablesp cf2 	character*50	file_nam	!user supplied name of file, 	integer*4	chan		!channel number from CDOPEN1 	integer*4	sblk		!starting block of file (CDOPEN)s- 	integer*4	fsize		!file size (bytes) (CDOPEN) + 	integer*4	nblks		!number of blocks in filex* 	integer*4	log_blk		!logical block to read- 	integer*4	blk_len		!length of block top reada 	byte		ibuf(2560)	!input buffers' 	byte		lbuf(80)	!line buffer for outputi 	integer*4	ndx		!do loop index  	integer*4	nbytes		!byte counter2 	INTEGER*4	ITERM/5/	!INTERACTIVE INPUT UNIT		! RMX( 	integer*4	iso/6/		!sys$out logical unit) 	integer*4	ipr		!list output logical unitt( 	character*50	out_lst		!output list file6 	integer*4	out_len		!length of list file specification5 	integer*4	ierr		!error return value (CDOPEN, CDREAD,i c						CDCLOSE)d cu c]7 c	initialize TAE call and obtain the file specification  c 4 CTAE	call xzinit (block, xprdim, iso, xabort, istat)C CTAE	call xrstr (block, 'FROM', 1, file_nam, in_len, icount, istat)	@ CTAE	call xrstr (block, 'TO', 1, out_lst, out_len, icount,istat)   	write (ITERM, 7000)						! RMXpH 7000	format (/'$Enter name of output file (default: terminal): ') 	! RMX, 	read (ITERM, 9000, end=10) OUT_LST				! RMX c   c	open output device if required c. CTAE	if (out_len .eq. 0) theni# 	IF (OUT_LST.EQ.' ') THEN					! RMXG	 		ipr = 6n 	elsee	 		ipr = 1X- 		open (unit=ipr, file=out_lst, status='new',	 	1		carriagecontrol='list')s 	endif   10	continue							! RMX_ 	write (ITERM, 8000)						! RMX*D 8000	format (/'$Enter name of file to open or EOF to exit: ') 	! RMX/ 	read (ITERM, 9000, end=1000) file_nam				! RMXe 9000	format (a)	  0 	call cdopen (file_nam, chan, sblk, fsize, ierr)/ c	write (iso, 8001) file_nam, chan, sblk, fsizet< c8001	format (/' file = ', a/' chan = ', i5/' sblk = ', i10/ c	1	' fsize = ', i10)n 	write (iso, 8001) file_namn 8001	format (/' file = ', a//)   	if (ierr .ge. 0) then c		write (iso, 8002)4 c8002		format (/'$Enter number of blocks to read: ')! c		read (5, 9001, end=1000) nblksr c9001		format (i5)' c		if (nblks .gt. (fsize+511)/512) then  			nblks = (fsize+511)/512 c			write (iso, 8003) nblksg; c8003			format (' *** requested number of blocks exceeds ',0+ c	1			'file length, ', i5, ' blocks used.')i c		endif                 c4
 		blk_len = 5  		jpntr = 00 		do log_blk = 1, nblks, 5 			if (log_blk+4 .gt. nblks) l" 	1			blk_len = nblks - log_blk + 19 			call cdread (chan, sblk, log_blk, blk_len, ibuf, ierr)4 c			nbytes = 512 * blk_len 			if (fsize .gt. 2560) then 				nbytes = 2560r 				fsize = fsize - 2560 			else4 				nbytes = fsize 			endif 			ipntr = 1 			do while (ipntr .le. nbytes)a! 				if (ibuf(ipntr) .eq. 13) thenn 				    if (ipr .eq. 6) then 		 			write (ipr, 8004)4 	1				(lbuf(ndx), ndx=1, jpntr)n 8004					format (x, 80a1)c 				    else 		 			write (ipr, 8006)_ 	1				(lbuf(ndx), ndx=1, jpntr)r 8006					format (80a1)
 				    endifi 					ipntr = ipntr + 2 					jpntr = 0 				else 					jpntr = jpntr + 1 					if (jpntr .le. 80)	  	1					lbuf(jpntr) = ibuf(ipntr) 					ipntr = ipntr + 1	 				endifs 			enddo 		enddod 	elseo 		write (iso, 8005) file_nam9 8005		format (/' %CDTYPE-F-FNF, could not find file ', a)i 	endif  / 	GO TO 10			! GO BACK FOR ANOTHER REQUEST	! RMXr cd
 1000	continue- 	call cdclose (chan, ierr) c 
 	call exit 	end $EOD. $WRITE SYS$OUTPUT "Create the CDCOPY.FOR file" $CREATE CDCOPY.FOR       PROGRAM CDCOPY  F C_TITLE CDCOPY  Copy CDROM file to magnetic disk (VMS non-TAE version)  : C_USER	CHARACTER*64 FROM  ! Specification of file on CDROMC C	CHARACTER*64 TO    ! Specification for output disk file (default: 4 C			      current directory, same filename as input)@ C	INTEGER*4    IQ    ! Over-ride record length (bytes) for files5 C			      with bad attribute records (e.g. IDI disks)M  	G C_DESCR Copy CDROM file to disk preserving logical format, according tooD C	the CDROM attribute record of the file.  Fixed-length-record files? C	supported.  Variable-length-record files not yet implemented. D C	Stream (text) files are copied to files of variable length recordsB C	with 'LIST' carriage control.  (Program CDTYPE can do this too.)E C	Program uses 1/4 MB of internal buffer space, which can be reduced.e CfF C	User over-ride of record format and length provided due to attributeD C	block errors on both ISO and High Sierra versions of the IDI disk.  H C_FILES CDROM files and directories written according to either the 1988# C	ISO or older High Sierra formats.o  
 C	References: > C	 VOLINFO.TXT in [DOCUMENT] directory of each CDROM of series  C	  "Voyager 2 Images of Uranus"C C	 ISO 9660 (Information processing -- Volume and file structure ofoB C	  CD-ROM for information interchange), first edition, 1988-04-15 C	 (High Sierra ref?)d CuF C	Output disk files are written as VMS files with record type FIXED orJ C	VARIABLE as appropriate.  STREAM records are converted to VARIABLE ones.  H C_CALLS CDOPEN, CDATT, CDREAD, CDCLOSE, B2B (USGS/Flagstaff CDROM rtnes) C	WTSREC (included below)	  4 C_LIMS  Maximum attribute record size is 2048 bytes.1 C	Variable-length-record files not yet supported.o  " C_KEYS  CDROM, DISK, FILE_I/O, VMS  .M C_HIST  14aug87  R. Mehlman, UCLA/IGPP (RMX)  ORIGINAL VMS (non-TAE) VERSION  D C	02sep87  RMX  Stream (text) file conversion to EDT-type file addedF C	11dec87  RMX  User over-ride of format & record-length to substitute: C			for incorrectly written attribute records on IDI disk.< C	22mar88  RMX  Fixed bug at label 30 (affected large files)@ C	17jan89  RMX  Revised for ISO format and new USGS I/O routines. C		       B2B replaces MOVE1 for byte transferE C	06feb89  RMX  Revised to use new CDATT routine, and copy files from @ C		       both ISO and High Sierra CDs.  User over-ride expanded: C		       to include both record format and record length.: C	07feb89  RMX  Error msg for var-len-rec files corrected.H C	01mar89  RMX  Really fixes bug at label 30 -- extra recs in long file.? C		      Also,copies even if no ext attr rec - asks for length.    C_ENDe  :       CHARACTER*64 FLSPEC,FLOUT			! FROM and TO parameters2       BYTE IATTR(2048)				! CDROM attribute record6       BYTE IBUF(512,512),KBUF(262144)		! 1/4 MB buffer       EQUIVALENCE (IBUF,KBUF)(E C  IFMT,IRATT,IREC are ISO variables, JFMT,JRATT,JREC are High Sierra ( C  LFMT,LRATT,LREC are working variablesJ       BYTE IFMT,IRATT,JFMT,JRATT,LFMT,LRATT	! record format, display attr.7       INTEGER*2 IREC,JREC			! VAX-format record-lengths*       INTEGER*4 LREC,LREC4E       EQUIVALENCE (IFMT,IATTR(79)),(IRATT,IATTR(80)),(IREC,IATTR(81))rE       EQUIVALENCE (JFMT,IATTR(75)),(JRATT,IATTR(76)),(JREC,IATTR(77))*$       DATA IIN,IOUT,IDISK,LBLK,NBBUF%      1    /  5,   6,    1, 512,  512/( Ce C  Request input file spec  10   WRITE (IOUT,910)6  910  FORMAT (' Enter CDROM filespec, or EOF to quit')"       READ (IIN,911,END=80) FLSPEC  911  FORMAT (A) C  Open CDROM file0       CALL CDOPEN(FLSPEC,ICHAN,ISBLK,ISIZE,IERR)9       IF (IERR.NE.0) STOP		! CDOPEN writes own error msgsT       NBLKS=(ISIZE+LBLK-1)/LBLK .       WRITE (IOUT,912) ICHAN,ISBLK,ISIZE,NBLKS>  912  FORMAT (' CHAN',I7,'  SBLK',I7,'  SIZE',I10,'  BLKS',I7)       IF (ISBLK.GT.0) GO TO 15       WRITE (IOUT,914)  914  FORMAT (' What?')        GO TO 10A C  Read attribute record, determine standard (High Sierra or ISO)h/  15   CALL CDATT(ICHAN,IATTR,NLEN,IDSTAND,IERR)e7       IF (IERR.NE.0) THEN		! If error, CDATT writes msgi/ 	IDSTAND=1			! No attr rec - assume High Sierra 0 	JFMT=0				! Trigger user request for rec length       ENDIFs4       IF (IDSTAND.EQ.1) THEN		! High Sierra standard
 	LFMT=JFMT 	LRATT=JRATT
 	LREC=JREC0       ELSE IF (IDSTAND.EQ.2) THEN	! ISO standard
 	LFMT=IFMT 	LRATT=IRATT
 	LREC=IREC       ENDIF 
       NRECS=0lD       IF (LFMT.GT.0) NRECS=(FLOAT(LBLK)/FLOAT(LREC))*FLOAT(NBLKS)+.59       WRITE (IOUT,915) LFMT,LRATT,LREC,NLEN,IDSTAND,NRECSS;  915  FORMAT (' REC FMT',I3,'  REC ATTR',I3,'  REC LEN',I6,a0      1 '  ATTR BLKS',I3,'  STD ',I1,'  RECS',I6)&       IF (LFMT.EQ.2.OR.LFMT.EQ.3) THEN 	WRITE (IOUT,9151)?  9151	FORMAT (' File is variable-length-record type - not yet',l      1		' supported by CDCOPY') 	 	GO TO 10m       ENDIFa/ C  Check for over-ride (due to IDI disk errors)n&       IF (LFMT.EQ.0) WRITE (IOUT,9152)6  9152 FORMAT ('0File appears to be in stream format.')+       IF (LFMT.EQ.1) WRITE (IOUT,9153) LREC B  9153 FORMAT ('0File appears to be in fixed-length-record format'/%      1 '  with record length',I6,'.')i2       IF (LFMT.EQ.0.OR.LFMT.EQ.1) WRITE (IOUT,916)F  916  FORMAT (' If this is correct, enter zero.  If incorrect, enter'/?      1 ' correct record length, or -1 to force stream format,'/1      2 ' or ctrl-Z to quit.') '  161  READ (IIN,9161,ERR=161,END=80) IQ.  9161 FORMAT (I7)R       IF (IQ.NE.0) THENu 	IF (IQ.GT.0) THEN	 	  LFMT=1 
 	  LREC=IQ2 	  NRECS=(FLOAT(LBLK)/FLOAT(LREC))*FLOAT(NBLKS)+.5 	ENDIF 	IF (IQ.EQ.-1) LFMT=0	       ENDIFe       LREC4=(LREC+3)/4 C  Generate output filespece C     WRITE (IOUT,917)< C917  FORMAT (' Enter output disk filespec, or EOF to quit')! C     READ (IIN,911,END=10) FLOUTd       IBRACK=INDEX(FLSPEC,']')       ICOLON=INDEX(FLSPEC,':')!       IF (IBRACK+ICOLON.EQ.0)THEN 
 	FLOUT=FLSPECf
       ELSE% 	FLOUT=FLSPEC(MAX0(IBRACK,ICOLON)+1:)=       ENDIFf; C  Open disk file (or quit, if variable-length-record file) 3       IF (LFMT.EQ.1) THEN				! Fixed-length recordsh0 	OPEN (IDISK,FILE=FLOUT,STATUS='NEW',RECL=LREC4,A      1   FORM='UNFORMATTED',RECORDTYPE='FIXED',INITIALSIZE=NBLKS)s8 C     ELSE IF (LFMT.EQ.2) THEN				! Variable-length recs1 C	OPEN (IDISK,FILE=FLOUT,STATUS='NEW',RECL=LREC4,,D C    1   FORM='UNFORMATTED',RECORDTYPE='VARIABLE',INITIALSIZE=NBLKS)+       ELSE IF (LFMT.EQ.0.) THEN				! Stream)< 	OPEN (IDISK,FILE=FLOUT,STATUS='NEW',CARRIAGECONTROL='LIST',      1	 INITIALSIZE=NBLKS)       ENDIF(& C  Copy blocks from CDROM to disk file
       IVBLK=1i       NBLEFT=NBLKS       KSTART=1       KREC=0! C   Fill buffer with CDROM blocks	'  20   NBFREE=NBBUF-(KSTART+LBLK-2)/LBLK	        NVBLKS=MIN0(NBFREE,NBLEFT)=       CALL CDREAD(ICHAN,ISBLK,IVBLK,NVBLKS,KBUF(KSTART),IERR) 8       IF (IERR.NE.0) STOP		! If error, CDREAD writes msg       KTOP=KSTART+NVBLKS*LBLK-1i       IF (LFMT.EQ.1) THENfO C   Fixed-length-record file: Write as many whole disk records as are in bufferb 	K1=1dH  30	CALL WTSREC(IDISK,KBUF(K1),LREC,IR)	! rtne to avoid implicit DO loop 	KREC=KREC+1 	IF (IR.NE.0) THEN 	  WRITE (IOUT,935) KREC0  935	  FORMAT (' Disk write error in record',I7) 	  STOPs 	ENDIF 	IF (KREC.GE.NRECS) GO TO 50 	K1=K1+LRECi 	KLEFT=KTOP-K1+1: 	IF (KLEFT.LT.LREC) GO TO 40		! more whole recs in buffer?	 	GO TO 30 @ C  Stream (text) file:  search for <cr>s, write formatted record       ELSE IF (LFMT.EQ.0) THEN 	K1=11  36	K=K13  37	IF (KBUF(K).EQ.13) GO TO 38			! search for <CR>  	K=K+1, 	IF (K.GT.KTOP) GO TO 40				! end of buffer?	 	GO TO 37x>  38	WRITE (IDISK,938) (KBUF(I),I=K1,K) 		! found it, copy line  938	FORMAT (132A1)i 	K1=K+2						! skip <CR> & <LF>i 	GO TO 36					! go get next=       ENDIFlB C   Move unused data to beginning of buffer, prepare for next read&  40   CALL B2B(KBUF(K1),KBUF(1),KLEFT)       KSTART=KLEFT+1       IVBLK=IVBLK+NVBLKS       NBLEFT=NBLEFT-NVBLKS!       IF (IVBLK.LE.NBLKS)GO TO 20i! C  Close CDROM file and disk file >  50   CALL CDCLOSE(ICHAN,IERR)		! if error, CDCLOSE writes msg       CLOSE (IDISK)a       IF (IERR.EQ.0) GO TO 10, C  Termination
  80   STOP	       ENDi C,G C_TITLE:   WTSREC:  Write VAX-record to file open for sequential accessf C @ C_ARGS:    IFU      I     [I]  Fortran logical unit of open fileL C          IBUF (*) BYTE  [I]  Buffer for record to be written (any spec ok)& C	   LREC     I     [I]  Record lengthL C          IR       I     [O]  Return code (0 = ok, >0 = VAX/VMS error code) C   C_KEYS:    FILE_I/O, SYSTEM, VMS C E C_DESCR:   Write single VAX record in order to avoid implicit DO loop 6 C          generated by Fortran I/O in calling routine C O C_FILES:   Any with fixed length records open for unformatted sequential accessl C ) C_HIST:    14aug87  RMX  ORIGINAL VERSION= C' C_END: Cd)       SUBROUTINE WTSREC(IFU,IBUF,LREC,IR)f       BYTE IBUF(LREC)o Ce        WRITE (IFU,IOSTAT=IR) IBUF       RETURN	       END	 $EOD- $WRITE SYS$OUTPUT "Compile the CDDIR program"e
 $FOR CDDIR* $WRITE SYS$OUTPUT "Link the CDDIR program" $LINK CDDIR,CDROMLIB/LIB. $WRITE SYS$OUTPUT "Compile the CDTYPE program" $FOR CDTYPEb+ $WRITE SYS$OUTPUT "Link the CDTYPE program"c $LINK CDTYPE,CDROMLIB/LIBr. $WRITE SYS$OUTPUT "Compile the CDCOPY program" $FOR CDCOPYb+ $WRITE SYS$OUTPUT "Link the CDCOPY program"f $LINK CDCOPY,CDROMLIB/LIB  $EXITl