c c LIST2FORT.FOR c c Makes a 'LIST' formatted file into a 'FORTRAN' carriagecontrol file c for output to line printer. Can handle wildcard specifications. c c This must be set up as a 'foreign command', for example: c c $ list2fort :== $sys$manager:list2fort c c in your login file will do it. It can then be invoked as: c c LIST2FORT M*.DAT{,...} c or LIST2FORT /CONF [.croak]junk.x%% c or LIST2FORT c c The latter will cause the program to prompt for files. c The /CONF switch requests confirmation on each file renamed. c c 30-Nov-1983 Version 1.0 M.S. Shefler c 14-Feb-1984 Added /CONF switch, multiple files separated by commas c and continuous prompting if command line null. c Version 1.1 M.S.S. c program LISTING implicit integer*4 (a-z) include 'rmsdef.ftn/nolist' character found*80,command_line*255,rec*136,message*80 character default*2,filespec*80 integer*2 msglen logical confirm,prompting c c Get the command line arguments. c confirm = .FALSE. prompting = .FALSE. status = LIB$GET_FOREIGN(command_line) if (.not.status)goto 900 ! some fatal error c c Look for /CONF... switch. Set flag and remove from command line if found. c Note that any part of command line before switch is discarded! c swpos = index(command_line,'/CONF') if (swpos.gt.0) then confirm = .true. swpos = find_sp(command_line,swpos) command_line = command_line(swpos:) endif c c If command line blank, then go into continuous prompting mode. c llen = trulen(command_line) if (llen.le.0) then prompting = .TRUE. write(6,12) read(5,5,end=500)command_line endif call STR$UPCASE(command_line,command_line) c c Loop while command line is not blank. c llen = trulen(command_line) do while (llen.gt.0) c c Set up the wild card loop. Context must be a variable, not a constant, c and is the address of the FAB control block returned by the first call. c If no default is specified, then wildcard specifications such as "M*" c will only search for files with no extension (e.g. M*.;). Only the latest c (highest numbered) version is retrieved; to retrieve all versions, you c could set default = '*.*', I suppose. c context = 0 found = ' ' default = '.*' c c Extract the first file spec from the command line (i.e. up to the c first comma). Replace command line with remainder. c commapos = index(command_line,',') if (commapos.gt.0) then filespec = command_line(:commapos-1) command_line = command_line(commapos+1:) else filespec = command_line command_line = ' ' endif llen = trulen(command_line) ! For beginning of loop test c c Get a file that matches specifications. If /CONF switch set, c then confirm before proceeding. c 100 status = (LIB$FIND_FILE(filespec,found,context,default)) if (.not.status)goto 800 ! file error or no more found if (confirm) then write(6,13)found(:trulen(found)) read(5,5,end=500)answer if (answer.ne.'y'.and.ans.ne.'Y')goto 100 endif c c Open the file for input, then a file of the same name for output. c Since LIB$FIND_FILE returns a fully qualified file name (device+directory+ c name+extension+version), you must strip off the version for the file name c used in the new file (as you are creating a NEW version). c open(unit=1,file=found,status='old',err=700,readonly) tlen = trulen(found) pos = 1 flen = locate(found,pos,';') if (flen.eq.0)flen = tlen ! For some reason, no ';' open(unit=2,file=found(1:flen),status='new',access='sequential', 4 err=600,carriagecontrol='fortran') nfile = nfile + 1 c c Copy the file, assuming max record length of 136 characters. c nrec = 0 nerr = 0 200 read(1,4,iostat=ioerr_no,err=198,end=199)l,rec if(l.gt.0)then write(2,5,err=197,iostat=ioerr_no)rec(1:l) else write(2,7,err=197,iostat=ioerr_no) endif nrec = nrec + 1 goto 200 c c Print message and try for more files. c 199 write(6,6)nrec,found(1:tlen) close(1) close(2) goto 100 c c Read error. Continue if # errors in this file < 10. c 198 nerr = nerr + 1 if (nerr.le.10)then call SYS$GETMSG(%val(ioerr_no),msglen,message,,) write(6,8)'Read',found(1:tlen),nrec,message(1:msglen) goto 200 endif call exit(2) c c Write error. Abort operations on this file. c 197 call SYS$GETMSG(%val(ioerr_no),msglen,message,,) write(6,8),'Write',found(1:tlen),nrec,message(1:msglen) call exit(2) c c Either no more files found, or improper file spec. c 800 if (status.ne.RMS$_NMF)goto 900 ! treat as fatal otherwise write(6,9)nfile enddo 500 call exit c c Command line, file name, or other fatal error. c 900 call SYS$GETMSG(%val(status),msglen,message,,) write(6,10)message(1:msglen) call exit(2) c c Error on file open. c 700 write(6,11)'input' call exit(2) 600 write(6,11)'output' call exit(2) c 1 format(' Enter file to convert:',$) 2 format(a40) 3 format(' Output file name (defaults to input) :',$) 4 format(q,a) 5 format(a) 6 format(' Copied',i6,' records from ',a,'.') 7 format(1x) 8 format(1x,a,' error on file:',a,' record #',i6/1x,a) 9 format(i6,' files processed.') 10 format(' Fatal error: ',a) 11 format(' Can''t open ',a,' file.') 12 format (' File(s) : ',$) 13 format (' OK to copy ',a,' (Y/N) ?',$) end