$! 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, ']'/ 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 . 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 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 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 & 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