$! CDROM_VMS_UTILITY_PROGRAMS.COM: Create, compile & link CDDIR, CDTYPE, CDCOPY
$! Assumes CDROMLIB.OLB has been previously created with
$! CDROM_UTILITY_SUBROUTINES.COM. RMX 05feb89
$!
$WRITE SYS$OUTPUT "Create the CDDIR.FOR file"
$CREATE CDDIR.FOR
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_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*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 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*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
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
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
ext_len = lenosp(extent)
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-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)
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
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, 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, 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
$EOD
$WRITE SYS$OUTPUT "Create the CDTYPE.FOR file"
$CREATE CDTYPE.FOR
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 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*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].
C_DESC The program requests the user to enter the name of a file. The
C compact disk is then searched for the specified file and if the
C file is found it is listed to the terminal or output file. The
C program assumes that each line is terminated by a <CR>.
C_KEYS CDROM
C_HIST 15Apr87, DMcMacken, ISD, U.S.G.S., Flagstaff, Original Version
C __Jan89, DMcMacken, modifications for ISO format ! RMX
C 13Jan89, RMehlman UCLA/IGPP, VMS (non-TAE) version ! RMX
C Interactive Fortran input replaces TAE. ! RMX
C Program now loops on FROM parameter. ! RMX
C_END
C*******************************************************************************
c
c local variables
c
character*50 file_nam !user supplied name of file
integer*4 chan !channel number from CDOPEN
integer*4 sblk !starting block of file (CDOPEN)
integer*4 fsize !file size (bytes) (CDOPEN)
integer*4 nblks !number of blocks in file
integer*4 log_blk !logical block to read
integer*4 blk_len !length of block top read
byte ibuf(2560) !input buffer
byte lbuf(80) !line buffer for output
integer*4 ndx !do loop index
integer*4 nbytes !byte counter
INTEGER*4 ITERM/5/ !INTERACTIVE INPUT UNIT ! RMX
integer*4 iso/6/ !sys$out logical unit
integer*4 ipr !list output logical unit
character*50 out_lst !output list file
integer*4 out_len !length of list file specification
integer*4 ierr !error return value (CDOPEN, CDREAD,
c CDCLOSE)
c
c
c initialize TAE call and obtain the file specification
c
CTAE call xzinit (block, xprdim, iso, xabort, istat)
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) ! RMX
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) then
IF (OUT_LST.EQ.' ') THEN ! RMX
ipr = 6
else
ipr = 1
open (unit=ipr, file=out_lst, status='new',
1 carriagecontrol='list')
endif
10 continue ! RMX
write (ITERM, 8000) ! RMX
8000 format (/'$Enter name of file to open or EOF to exit: ') ! RMX
read (ITERM, 9000, end=1000) file_nam ! RMX
9000 format (a)
call cdopen (file_nam, chan, sblk, fsize, ierr)
c write (iso, 8001) file_nam, chan, sblk, fsize
c8001 format (/' file = ', a/' chan = ', i5/' sblk = ', i10/
c 1 ' fsize = ', i10)
write (iso, 8001) file_nam
8001 format (/' file = ', a//)
if (ierr .ge. 0) then
c write (iso, 8002)
c8002 format (/'$Enter number of blocks to read: ')
c read (5, 9001, end=1000) nblks
c9001 format (i5)
c if (nblks .gt. (fsize+511)/512) then
nblks = (fsize+511)/512
c write (iso, 8003) nblks
c8003 format (' *** requested number of blocks exceeds ',
c 1 'file length, ', i5, ' blocks used.')
c endif
c
blk_len = 5
jpntr = 0
do log_blk = 1, nblks, 5
if (log_blk+4 .gt. nblks)
1 blk_len = nblks - log_blk + 1
call cdread (chan, sblk, log_blk, blk_len, ibuf, ierr)
c nbytes = 512 * blk_len
if (fsize .gt. 2560) then
nbytes = 2560
fsize = fsize - 2560
else
nbytes = fsize
endif
ipntr = 1
do while (ipntr .le. nbytes)
if (ibuf(ipntr) .eq. 13) then
if (ipr .eq. 6) then
write (ipr, 8004)
1 (lbuf(ndx), ndx=1, jpntr)
8004 format (x, 80a1)
else
write (ipr, 8006)
1 (lbuf(ndx), ndx=1, jpntr)
8006 format (80a1)
endif
ipntr = ipntr + 2
jpntr = 0
else
jpntr = jpntr + 1
if (jpntr .le. 80)
1 lbuf(jpntr) = ibuf(ipntr)
ipntr = ipntr + 1
endif
enddo
enddo
else
write (iso, 8005) file_nam
8005 format (/' %CDTYPE-F-FNF, could not find file ', a)
endif
GO TO 10 ! GO BACK FOR ANOTHER REQUEST ! RMX
c
1000 continue
call cdclose (chan, ierr)
c
call exit
end
$EOD
$WRITE SYS$OUTPUT "Create the CDCOPY.FOR file"
$CREATE CDCOPY.FOR
PROGRAM CDCOPY
C_TITLE CDCOPY Copy CDROM file to magnetic disk (VMS non-TAE version)
C_USER CHARACTER*64 FROM ! Specification of file on CDROM
C CHARACTER*64 TO ! Specification for output disk file (default:
C current directory, same filename as input)
C INTEGER*4 IQ ! Over-ride record length (bytes) for files
C with bad attribute records (e.g. IDI disks)
C_DESCR Copy CDROM file to disk preserving logical format, according to
C the CDROM attribute record of the file. Fixed-length-record files
C supported. Variable-length-record files not yet implemented.
C Stream (text) files are copied to files of variable length records
C with 'LIST' carriage control. (Program CDTYPE can do this too.)
C Program uses 1/4 MB of internal buffer space, which can be reduced.
C
C User over-ride of record format and length provided due to attribute
C block errors on both ISO and High Sierra versions of the IDI disk.
C_FILES CDROM files and directories written according to either the 1988
C ISO or older High Sierra formats.
C References:
C VOLINFO.TXT in [DOCUMENT] directory of each CDROM of series
C "Voyager 2 Images of Uranus"
C ISO 9660 (Information processing -- Volume and file structure of
C CD-ROM for information interchange), first edition, 1988-04-15
C (High Sierra ref?)
C
C Output disk files are written as VMS files with record type FIXED or
C VARIABLE as appropriate. STREAM records are converted to VARIABLE ones.
C_CALLS CDOPEN, CDATT, CDREAD, CDCLOSE, B2B (USGS/Flagstaff CDROM rtnes)
C WTSREC (included below)
C_LIMS Maximum attribute record size is 2048 bytes.
C Variable-length-record files not yet supported.
C_KEYS CDROM, DISK, FILE_I/O, VMS
C_HIST 14aug87 R. Mehlman, UCLA/IGPP (RMX) ORIGINAL VMS (non-TAE) VERSION
C 02sep87 RMX Stream (text) file conversion to EDT-type file added
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 transfer
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.
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_END
CHARACTER*64 FLSPEC,FLOUT ! FROM and TO parameters
BYTE IATTR(2048) ! CDROM attribute record
BYTE IBUF(512,512),KBUF(262144) ! 1/4 MB buffer
EQUIVALENCE (IBUF,KBUF)
C IFMT,IRATT,IREC are ISO variables, JFMT,JRATT,JREC are High Sierra
C LFMT,LRATT,LREC are working variables
BYTE IFMT,IRATT,JFMT,JRATT,LFMT,LRATT ! record format, display attr.
INTEGER*2 IREC,JREC ! VAX-format record-lengths
INTEGER*4 LREC,LREC4
EQUIVALENCE (IFMT,IATTR(79)),(IRATT,IATTR(80)),(IREC,IATTR(81))
EQUIVALENCE (JFMT,IATTR(75)),(JRATT,IATTR(76)),(JREC,IATTR(77))
DATA IIN,IOUT,IDISK,LBLK,NBBUF
1 / 5, 6, 1, 512, 512/
C
C Request input file spec
10 WRITE (IOUT,910)
910 FORMAT (' Enter CDROM filespec, or EOF to quit')
READ (IIN,911,END=80) FLSPEC
911 FORMAT (A)
C Open CDROM file
CALL CDOPEN(FLSPEC,ICHAN,ISBLK,ISIZE,IERR)
IF (IERR.NE.0) STOP ! CDOPEN writes own error msgs
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 10
C Read attribute record, determine standard (High Sierra or ISO)
15 CALL CDATT(ICHAN,IATTR,NLEN,IDSTAND,IERR)
IF (IERR.NE.0) THEN ! If error, CDATT writes msg
IDSTAND=1 ! No attr rec - assume High Sierra
JFMT=0 ! Trigger user request for rec length
ENDIF
IF (IDSTAND.EQ.1) THEN ! High Sierra standard
LFMT=JFMT
LRATT=JRATT
LREC=JREC
ELSE IF (IDSTAND.EQ.2) THEN ! ISO standard
LFMT=IFMT
LRATT=IRATT
LREC=IREC
ENDIF
NRECS=0
IF (LFMT.GT.0) NRECS=(FLOAT(LBLK)/FLOAT(LREC))*FLOAT(NBLKS)+.5
WRITE (IOUT,915) LFMT,LRATT,LREC,NLEN,IDSTAND,NRECS
915 FORMAT (' REC FMT',I3,' REC ATTR',I3,' REC LEN',I6,
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',
1 ' supported by CDCOPY')
GO TO 10
ENDIF
C Check for over-ride (due to IDI disk errors)
IF (LFMT.EQ.0) WRITE (IOUT,9152)
9152 FORMAT ('0File appears to be in stream format.')
IF (LFMT.EQ.1) WRITE (IOUT,9153) LREC
9153 FORMAT ('0File appears to be in fixed-length-record format'/
1 ' with record length',I6,'.')
IF (LFMT.EQ.0.OR.LFMT.EQ.1) WRITE (IOUT,916)
916 FORMAT (' If this is correct, enter zero. If incorrect, enter'/
1 ' correct record length, or -1 to force stream format,'/
2 ' or ctrl-Z to quit.')
161 READ (IIN,9161,ERR=161,END=80) IQ
9161 FORMAT (I7)
IF (IQ.NE.0) THEN
IF (IQ.GT.0) THEN
LFMT=1
LREC=IQ
NRECS=(FLOAT(LBLK)/FLOAT(LREC))*FLOAT(NBLKS)+.5
ENDIF
IF (IQ.EQ.-1) LFMT=0
ENDIF
LREC4=(LREC+3)/4
C Generate output filespec
C WRITE (IOUT,917)
C917 FORMAT (' Enter output disk filespec, or EOF to quit')
C READ (IIN,911,END=10) FLOUT
IBRACK=INDEX(FLSPEC,']')
ICOLON=INDEX(FLSPEC,':')
IF (IBRACK+ICOLON.EQ.0)THEN
FLOUT=FLSPEC
ELSE
FLOUT=FLSPEC(MAX0(IBRACK,ICOLON)+1:)
ENDIF
C Open disk file (or quit, if variable-length-record file)
IF (LFMT.EQ.1) THEN ! Fixed-length records
OPEN (IDISK,FILE=FLOUT,STATUS='NEW',RECL=LREC4,
1 FORM='UNFORMATTED',RECORDTYPE='FIXED',INITIALSIZE=NBLKS)
C ELSE IF (LFMT.EQ.2) THEN ! Variable-length recs
C OPEN (IDISK,FILE=FLOUT,STATUS='NEW',RECL=LREC4,
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=1
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)
IF (IERR.NE.0) STOP ! If error, CDREAD writes msg
KTOP=KSTART+NVBLKS*LBLK-1
IF (LFMT.EQ.1) THEN
C Fixed-length-record file: Write as many whole disk records as are in buffer
K1=1
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) KREC
935 FORMAT (' Disk write error in record',I7)
STOP
ENDIF
IF (KREC.GE.NRECS) GO TO 50
K1=K1+LREC
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=1
36 K=K1
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 37
38 WRITE (IDISK,938) (KBUF(I),I=K1,K) ! found it, copy line
938 FORMAT (132A1)
K1=K+2 ! skip <CR> & <LF>
GO TO 36 ! go get next
ENDIF
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 20
C Close CDROM file and disk file
50 CALL CDCLOSE(ICHAN,IERR) ! if error, CDCLOSE writes msg
CLOSE (IDISK)
IF (IERR.EQ.0) GO TO 10
C Termination
80 STOP
END
C
C_TITLE: WTSREC: Write VAX-record to file open for sequential access
C
C_ARGS: IFU I [I] Fortran logical unit of open file
C IBUF (*) BYTE [I] Buffer for record to be written (any spec ok)
C LREC I [I] Record length
C IR I [O] Return code (0 = ok, >0 = VAX/VMS error code)
C
C_KEYS: FILE_I/O, SYSTEM, VMS
C
C_DESCR: Write single VAX record in order to avoid implicit DO loop
C generated by Fortran I/O in calling routine
C
C_FILES: Any with fixed length records open for unformatted sequential access
C
C_HIST: 14aug87 RMX ORIGINAL VERSION
C
C_END:
C
SUBROUTINE WTSREC(IFU,IBUF,LREC,IR)
BYTE IBUF(LREC)
C
WRITE (IFU,IOSTAT=IR) IBUF
RETURN
END
$EOD
$WRITE SYS$OUTPUT "Compile the CDDIR program"
$FOR CDDIR
$WRITE SYS$OUTPUT "Link the CDDIR program"
$LINK CDDIR,CDROMLIB/LIB
$WRITE SYS$OUTPUT "Compile the CDTYPE program"
$FOR CDTYPE
$WRITE SYS$OUTPUT "Link the CDTYPE program"
$LINK CDTYPE,CDROMLIB/LIB
$WRITE SYS$OUTPUT "Compile the CDCOPY program"
$FOR CDCOPY
$WRITE SYS$OUTPUT "Link the CDCOPY program"
$LINK CDCOPY,CDROMLIB/LIB
$EXIT