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.
c
c     Compile as gfortran -static -o backupex backupex.f

      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     usage message if called with no or an incorrect number of arguments
      if(iargc().ne.2)then
         print10,'Usage: backupex mmddyy_digits digit_limits'
         if(iargc().eq.0)call exit(0)
         call getarg(1,argt(1))
         if(argt(1)(1:8).eq.'--check ')call exit(0)
         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


      function iargc()

c     get number of command line arguments using gfortran

      implicit none

c output

c     number of command line arguments
      integer iargc

c executable

      iargc=command_argument_count()

      return
      end


      subroutine getarg(arg,argt)

c     get a command line argument using gfortran

      implicit none

c input

c     number of argument to get
      integer arg

c output

c     string
      character*(*) argt

c executable

      call get_command_argument(arg,argt)

      return
      end