program bkupex c Returns the next backup base file name in string fnm through c sourcable file fnm.tmp, given the previous backup file name. c Usage: c backupex mmddyy_...ddddddd ...nnnnnnn c where the first argument is the previous backup file name, in c which mmddyy is the date and ...ddddddd are the hexidecimal-style, c upper-case, digits of the file number, with largest possible value c Z (35 decimal). The second argument, ...nnnnnnn, gives the c maximum allowed values of the digits ...ddddddd, supposedly c corresponding to the number of backups at that age-level not to c save to the next level, for every one saved. The number of digits c in the file number is therefor the number of age levels that is c saved. implicit none c declarations c returns command line parameters integer iargc external iargc,getarg c argument index integer arg c arguments character*132 argt(2) integer argtl(2) c digits character*36 digs parameter (digs='0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ') c maximum digit index integer digmx c digit index integer dig c maximum digit value integer dmax c digit value integer d c file name date length integer datelt parameter (datelt=6) c date string from system character*8 dat c whether a file already exists logical exists c generic string character*80 line c index integer i c executable c format 10 format(a) c get number of arguments if(iargc().ne.2)then print10,'Usage: backupex mmddyy_digits digit_limits' call exit(1) endif c read the arguments do 200 arg=1,2 argt(arg)=' ' call getarg(arg,argt(arg)) do 150 i=132,1,-1 argtl(arg)=i if(argt(arg)(i:i).gt.' ')goto 160 150 continue call fatal('argument '//char(arg+48)//' is blank') 160 if(argtl(arg).ge.80) & call fatal('argument '//char(arg+48)//' is too long') if(arg.eq.1)then if(argt(1)(datelt+1:datelt+1).ne.'_') & call badchr('character '//char(datelt+49)// & ' in the file name is not an underscore', & argt(1)(datelt+1:datelt+1)) do 170 i=1,datelt if(argt(1)(i:i).lt.'0' .or. argt(1)(i:i).gt.'9') & call badchr('invalid date digit in the file name', & argt(1)(i:i)) 170 continue endif do 180 dig=(datelt+1)*(2-arg)+1,argtl(arg) if(index(digs,argt(arg)(dig:dig)).le.0)call badchr( & 'invalid digit in argument '//char(arg+48), & argt(arg)(dig:dig)) 180 continue 200 continue digmx=argtl(2) if(argtl(1).ne.digmx+datelt+1)then write(line,210)argtl(1)-datelt-1,argtl(2) 210 format(2i4) call fatal( & 'arguments have different number of digits:'//line(1:8)) endif c increment file number do 300 dig=1,digmx i=digmx+1-dig dmax=index(digs,argt(2)(i:i))-1 i=i+datelt+1 d=index(digs,argt(1)(i:i))-1 d=d+1 if(d.le.dmax)then argt(1)(i:i)=digs(d+1:d+1) goto 310 endif argt(1)(i:i)='0' 300 continue 310 continue c get date and plug in the name call date_and_time(dat) argt(1)(1:4)=dat(5:8) argt(1)(5:6)=dat(3:4) c write the new file name to file fnm.tmp inquire(file='fnm.tmp',exist=exists,err=410) if(exists)then open(2,file='fnm.tmp',status='old',err=410) close(2,status='delete',err=410) endif open(2,file='fnm.tmp',status='new',err=410) write(2,10,err=410)'set fnm='''//argt(1)(1:argtl(1))//'''' close(2,err=410) goto 420 410 call fatal('Unable to write filename in file fnm.tmp') 420 continue c done call exit(0) end subroutine fatal(msg) c Print out an error message and exit with error implicit none c input c error message character*(*) msg c executable c print the message call errmsg(msg) c exit call exit(1) end subroutine badchr(msg,chr) c Print out a bad character error and exit with error implicit none c input c error message character*(*) msg c bad character character*1 chr c executable c print the message call errmsg(msg) c print the bad character if(chr.ge.' ' .and. chr.le.'~')then print10,chr 10 format(' Bad character: "',a1,'"') else print20,ichar(chr) 20 format(' Bad character code:',i4) endif c exit call exit(1) end subroutine errmsg(msg) c Print out an error message implicit none c input c error message character*(*) msg c executable print10,msg 10 format('*** backupex: ',a,'!') return end