*******************************************************************************
*
* RENUM 
*
*     A program for renumbering the statements in Fortran programs.
*
* March 1986, John Kodis
*
*******************************************************************************

      program renum

      logical
     &    at end,
     &    eof,
     &    usebuf

      integer
     &    i,
     &    parlvl,
     &    strip,
     &    posc,   posl,
     &    statmc, statml,
     &    wherec, wherel

      integer*4
     &    j,
     &    label,
     &    newlab,
     &    skip

      character
     &    infile*26,
     &    outfil*26,
     &    tmp*149

      include 'rencom'

      logical ! function
     &    blank,
     &    contin,
     &    find,
     &    gotnum,
     &    matchd,
     &    numbr2,
     &    tab

      integer ! function
     &    numsiz

      integer*4 ! function
     &    lookup

      skip = 0

      call get2fn(infile, outfil)

      if (index(infile, '.') .eq. 0)
     &    infile(index(infile, ' '):) = '.FOR'

      if (index(outfil, '.') .eq. 0)
     &    outfil(index(outfil, ' '):) = infile(index(infile, '.'):)

      open(1, file=infile, status='old', err=130,
     &    readonly, shared )

      open(2, file=outfil, status='new', err=140,
     &    carriagecontrol='list' )

*     Build a symbol table of all labels.

   10 laslab = 0

      usebuf = skip .gt. 0
   20 call filbuf(usebuf, atend, eof)
      usebuf = .TRUE.
      if (gotnum(1, 1, 5, label, strip)) then
          laslab = laslab + 1
          if (laslab .le. MAXLAB) then
              labels(laslab) = label
          else
              write(5, '('' **** Error -- too many labels.'')')
              go to 150
          end if
      end if

      if (.not. AtEnd) go to 20

*     Time for pass two.  Rewind the file, skip records up to the
*     start of the next subprogram to be renumbered, and start
*     looking for statement labels to be replaced. 

      rewind(1)

      do 30, j = 1, skip
   30     read(1, '(a)') tmp

      usebuf = .FALSE.
   40 call filbuf(usebuf, atend, eof)
      usebuf = .TRUE.
      skip = skip + laslin

*     To speed up the program, make a quick test for empty lines,
*     blank lines, and comment lines.  If the current statement
*     falls one of these catagories, skip the following tests and
*     just write the statement out as it stands. 

      if ((linlen(1) .eq. 0) .or.
     &    (buf(1) .eq. ' ') .or.
     &    (index('Cc*!', buf(1)(1:1)) .ne. 0) ) go to 110

*     Try to replace the statement label. Set STATMC to the first
*     position after the label, or to 1 if there is no statement
*     label. 

   50 statmc = 1
      statml = 1
      if (gotnum(1, statml, 5, label, strip)) then
          statmc = 7
   60     if (strip.lt.5 .and. buf(1)(strip+1:strip+1).eq.' ') then
              strip = strip + 1
              go to 60
          end if
          newlab = lookup(label)
          write(tmp, '(i5, a)') newlab, buf(1)(strip+1:linlen(1))
          linlen(1) = 5 + linlen(1) - strip
          buf(1) = tmp
      end if

*     Look for an "if" statement.  If found, set STATMC to the
*     first character after the closing parenthisis. 

   70 if (matchd(statmc, statml, 'if(', 3, posc, posl)) then

*         Skip past the expression following the "if".

          parlvl = 1
   80     if (parlvl .gt. 0) then
              if (buf(posl)(posc:posc) .eq. '(' ) parlvl = parlvl + 1
              if (buf(posl)(posc:posc) .eq. ')' ) parlvl = parlvl - 1
              call incr(posc, posl)
              call skipbl(posc, posl)
              go to 80
          end if

          statmc = posc
          statml = posl

*         If this is an arithmatic if statement, try to replace each 
*         of the three required statement labels which follow the "if".

   90     if (gotnum(posc, posl, linlen(posl), label, strip)) then
              newlab = lookup(label)
              write(tmp, '(a, i<numsiz(newlab)>, a)')
     &            buf(posl)( : posc-1),
     &            newlab,
     &            buf(posl)(posc+strip : )
              linlen(posl) = numsiz(newlab) + linlen(posl) - strip
              buf(posl) = tmp
              posc = posc + numsiz(newlab)
              if (matchd(posc, posl, ',', 1, posc, posl)) go to 90
          end if

          go to 70

      end if ! Done processing "if" statements.

*     Try to replace any statement labels in a "do" statement.

      if (matchd(statmc, statml, 'do', 2, wherec, wherel)) then
          call renumb(wherec, wherel)
          go to 110
      end if

*     Try to replace statement labels in "goto 9999" and 
*     "goto (9990,9991,...,9999), exp" type statements.

      if (matchd(statmc, statml, 'goto', 4, wherec, wherel)) then
          call renumb(wherec, wherel)
  100     if (matchd(wherec, wherel, '(', 1, posc, posl)) then
              if (gotnum(posc,posl, linlen(posl), label, strip)) then
                  newlab = lookup(label)
                  write(tmp, '(a, i<numsiz(newlab)>, a)')
     &                buf(posl)(:posc-1), 
     &                newlab, 
     &                buf(posl)(posc+strip:linlen(posl))
                  linlen(posl) = numsiz(newlab) + linlen(posl) - strip
                  buf(posl) = tmp
                  posc = posc + numsiz(newlab)
              end if
              call matchd(posc, posl, ',', 1, posc, posl)
              go to 100
          end if
          go to 110
      end if

*     Try to replace statement labels of format statements, "fmt=" 
*     statements, "err=" statements, and "end=" statements in I/O 
*     and encode/decode statements.

      if (matchd(statmc, statml, 'write(', 6, wherec, wherel)) then

          if (numbr2(wherec, wherel, posc, posl))
     &        call renumb(posc, posl)

          if (find(wherec, wherel, 'fmt=', 4, posc, posl))
     &        call renumb(posc, posl)

          if (find(wherec, wherel, 'err=', 4, posc, posl))
     &        call renumb(posc, posl)

      else if (matchd(statmc,statml, 'rewrite(', 8, wherec,wherel)) then

          if (numbr2(wherec, wherel, posc, posl))
     &        call renumb(posc, posl)

          if (find(wherec, wherel, 'fmt=', 4, posc, posl))
     &        call renumb(posc, posl)

          if (find(wherec, wherel, 'err=', 4, posc, posl))
     &        call renumb(posc, posl)

      else if (matchd(statmc,statml, 'type', 4, wherec,wherel)) then

          call renumb(wherec, wherel)

      else if (matchd(statmc,statml, 'print', 5, wherec,wherel)) then

          call renumb(wherec, wherel)

      else if (matchd(statmc,statml, 'read(', 5, wherec,wherel)) then

          if (numbr2(wherec, wherel, posc, posl))
     &        call renumb(posc, posl)

          if (find(wherec, wherel, 'fmt=', 4, posc, posl))
     &        call renumb(posc, posl)

          if (find(wherec, wherel, 'err=', 4, posc, posl))
     &        call renumb(posc, posl)

          if (find(wherec, wherel, 'end=', 4, posc, posl))
     &        call renumb(posc, posl)

      else if (matchd(statmc,statml, 'accept', 6, wherec,wherel)) then

          call renumb(wherec, wherel)

      else if (matchd(statmc,statml, 'open(', 5, wherec,wherel)) then

          if (find(wherec, wherel, 'err=', 4, posc, posl))
     &        call renumb(posc, posl)

      else if (matchd(statmc,statml, 'close(', 6, wherec,wherel)) then

          if (find(wherec, wherel, 'err=', 4, posc, posl))
     &        call renumb(posc, posl)

      else if (matchd(statmc,statml, 'rewind(', 7, wherec,wherel)) then

          if (find(wherec, wherel, 'err=', 4, posc, posl))
     &        call renumb(posc, posl)

      else if (matchd(statmc,statml,'backspace(',10,wherec,wherel)) then

          if (find(wherec, wherel, 'err=', 4, posc, posl))
     &        call renumb(posc, posl)

      else if (matchd(statmc,statml, 'delete(', 7, wherec,wherel)) then

          if (find(wherec, wherel, 'err=', 4, posc, posl))
     &        call renumb(posc, posl)

      else if (matchd(statmc,statml, 'unlock(', 7, wherec,wherel)) then

          if (find(wherec, wherel, 'err=', 4, posc, posl))
     &        call renumb(posc, posl)

      else if (matchd(statmc,statml, 'endfile(', 8, wherec,wherel)) then

          if (find(wherec, wherel, 'err=', 4, posc, posl))
     &        call renumb(posc, posl)

      else if (matchd(statmc,statml, 'encode(', 7, wherec,wherel)) then

          if (numbr2(wherec, wherel, posc, posl))
     &        call renumb(posc, posl)

          if (find(wherec, wherel, 'err=', 4, posc, posl))
     &        call renumb(posc, posl)

      else if (matchd(statmc,statml, 'decode(', 7, wherec,wherel)) then

          if (numbr2(wherec, wherel, posc, posl))
     &        call renumb(posc, posl)

          if (find(wherec, wherel, 'err=', 4, posc, posl))
     &        call renumb(posc, posl)

      end if

  110 do 120, i = 1, laslin
          write(2, '(a)') buf(i)(1:linlen(i))
  120 continue

      if (linlen(1) .gt. 132) 
     &    write(5, '(a)')
     &        ' **** Warning -- previous line exceeds 132 characters.'

      if (.not. AtEnd) go to 40

      if (.not. eof) go to 10

      go to 150

  130 write(5, '(a, a, a)')
     &    ' **** Error -- can''t open input file "', infile, '".'
      go to 150

  140 write(5, '(a, a, a)')
     &    ' **** Error -- can''t open output file "', outfil, '".'

  150 close(2)
      close(1)

      end

********************************************************************************
*
* FIL BUF
*
*     Used to read one statement (which may be continued on more
*     than one line) into the statement buffer, BUF.  The
*     paramater ENDST indicates whether the current line is an END
*     statement, and the parameter EOF indicates whether the end
*     of the input file has been reached.  Also, EOF implies
*     ENDST.  The parameter USEBUF, when true, indicates that the
*     first line of the statement to be read in is already in BUF 
*     at BUF(LASLIN+1).  When the parameter USEBUF is false the 
*     first line of the statement will be read from the input 
*     file.  This is necessary because the only way to know 
*     whether the last line of a statement has been read in is to 
*     keep reading lines until there are no more continuation 
*     lines.
*
********************************************************************************

      subroutine filbuf(usebuf, endst, eof)

      integer
     &    i,
     &    junk

      logical
     &    endst,
     &    eof,
     &    usebuf

      include 'rencom'

      logical ! functions
     &    atend,
     &    contin


      if (.not. usebuf) then
          read(1, '(q, a)', err=20, end=30) linlen(1), buf(1)
      else
          buf(1) = buf(laslin+1)
          linlen(1) = linlen(laslin+1)
      endif

      laslin = 1

   10 read(1, '(q, a)', err=20, end=30) linlen(laslin+1), buf(laslin+1)
      if (contin(laslin+1, junk)) then
          laslin = laslin + 1
          go to 10
      end if

      eof   = .FALSE.
      endst = atend()

      return

   20 write(5, '('' **** Error -- can''''t read from input file.'')')

   30 eof   = .TRUE.
      endst = .TRUE.

      return
      end

********************************************************************************
*
* GOTNUM
*
*     GOTNUM tests for a statement label starting on line FROML,
*     column FROMC, and continuing for TO characters.  If a label
*     is found in this range of characters, GOTNUM will return the value
*     .TRUE., the numeric value of the label will be returned in
*     LABEL, and STRIP will be set to the number of characters
*     between the first and last digits in the label. Otherwise
*     GOTNUM will return the value .FALSE., and LABEL and STRIP will be
*     undefined. 
*
********************************************************************************

      logical function gotnum(fromc, froml, to, label, strip)

      character
     &    c

      integer
     &    digit,
     &    fromc,
     &    froml,
     &    i,
     &    strip,
     &    to

      integer*4
     &    label

      logical ! function
     &    blank

      include 'rencom'

      label = 0
      i = 0

   10 c = buf(froml)(fromc+i : fromc+i)
      digit = index('0123456789', c)
      if ((digit .ne. 0) .or. blank(c)) then
          if (digit .ne. 0) then
              label = label*10 + digit - 1
              strip = i + 1
          end if
          i = i + 1
          if (fromc+i .le. to) go to 10
      end if

      gotnum = label .gt. 0

      return
      end

********************************************************************************
*
* MATCHD
*
*     If the next KEYLEN non-blank characters from line FROML,
*     column FROMC match the string specified in KEY, then
*     MATCHD will return the value .TRUE., and NEXTL and NEXTC 
*     will be set to the first non-blank character following the 
*     specified key.  Otherwise, MATCHD will be .FALSE., and NEXTL 
*     and NEXTC will be undefined.
*
********************************************************************************

      logical function matchd(fromc, froml, key, keylen, nextc, nextl)

      integer
     &    fromc,
     &    froml,
     &    keychr,
     &    keylen,
     &    nextc,
     &    nextl

      character
     &    key*10

      logical ! function
     &    blank,
     &    chareq

      include 'rencom'

      keychr = 1
      nextc = fromc
      nextl = froml

   10 call skipbl(nextc, nextl)

      if (keychr .gt. keylen) then
          matchd = .TRUE.
      else if (.not. chareq(key(keychr:keychr),
     &                      buf(nextl)(nextc:nextc) )) then
          matchd = .FALSE.
      else
          call incr(nextc, nextl)
          keychr = keychr + 1
          go to 10
      end if

      return
      end

********************************************************************************
*
* FIND
*
*     If the string specified in KEY occurs anywhere in the
*     portion of the current statement which comes after column
*     FROMC on line FROML, then FIND will return the value 
*     .TRUE., and PASTL and PASTC will be set to the first
*     non-blank character following the specified key.  Otherwise,
*     FIND will be .FALSE., and PASTL and PASTC will be
*     undefined. 
*
********************************************************************************

      logical function find(fromc, froml, key, keylen, pastc, pastl)

      integer
     &    fromc,
     &    froml,
     &    keychr,
     &    keylen,
     &    nextc,
     &    nextl,
     &    pastc,
     &    pastl

      character
     &    key*20

      include 'rencom'

      logical ! function
     &    blank,
     &    chareq



      keychr = 1

      nextc = fromc
      nextl = froml

      pastc = nextc
      pastl = nextl

   10 call skipbl(pastc, pastl)

      if (keychr .gt. keylen) then

          find = .TRUE.

      else if (buf(pastl)(pastc:pastc) .eq. ' ') then

              find = .FALSE.

      else if (chareq(key(keychr:keychr), buf(pastl)(pastc:pastc))) then

          call incr(pastc, pastl)
          keychr = keychr + 1
          go to 10

      else

          call incr(nextc, nextl)
          call skipbl(nextc, nextl)
          pastc = nextc
          pastl = nextl
          keychr = 1
          go to 10

      end if

      return
      end

********************************************************************************
*
* NUMBR 2
*
*     Used to test for the occurance of two numbers seperated by a
*     comma beginning at line FROML, column FROMC.  If found, 
*     NUMBR2 will return the value .TRUE., and NEXTL and NEXTC will be 
*     set to the location of the first digit of the second number. 
*     Otherwise, NUMBR2 will be .FALSE., and NEXTL and 
*     NEXTC will be undefined.
*
********************************************************************************

      logical function numbr2(fromc, froml, nextc, nextl)

      integer
     &    fromc,
     &    froml,
     &    nextc,
     &    nextl

      include 'rencom'

      logical ! function
     &    blank


      nextc = fromc
      nextl = froml

   10 call skipbl(nextc, nextl)

      if (index('0123456789', buf(nextl)(nextc:nextc)) .eq. 0) then

          numbr2  = .FALSE.

      else

   20     if (index(' 0123456789', buf(nextl)(nextc:nextc)) .ne. 0) then
              call incr(nextc, nextl)
              go to 20
          end if

          if (buf(nextl)(nextc:nextc) .ne. ',') then

              numbr2  = .FALSE.

          else

              call incr(nextc, nextl)
   30         if (blank(buf(nextl)(nextc:nextc))) then
                  call incr(nextc, nextl)
                  call skipbl(nextc, nextl)
                  go to 30
              end if

              numbr2 = index('0123456789',buf(nextl)(nextc:nextc)).ne.0

          end if

      end if

      return
      end

********************************************************************************
*
* CONTIN
*
*     Used to determine where the statement portion of a line 
*     begins.  POS will be set either to column one, or to the 
*     first column after the continuation character if the line 
*     specified is a continuation line.  GOTCON is set to .TRUE. 
*     if the specified line is a continuation line, and set 
*     .FALSE. otherwise.
*
********************************************************************************

      logical function contin(line, pos)

      integer
     &    line,
     &    pos

      include 'rencom'

      logical ! functions
     &    blank,
     &    tab

      pos = 1
      contin = .FALSE.

      if ((buf(line)(1:5) .eq. ' ') .and.
     &    (buf(line)(6:6) .ne. '0') .and.
     &    (.not. blank(buf(line)(6:6))) ) then

          pos = 7
          contin = .TRUE.

      else

          if ((tab(buf(line)(1:1))) .and.
     &        (index('123456789', buf(line)(2:2)) .ne. 0) ) then

              pos = 3
              contin = .TRUE.

          endif

      end if

      return
      end

********************************************************************************
*
* AT END
*
*     Returns .TRUE. if the current line is an "END" statement.  
*     Returns .FALSE. otherwise.
*
********************************************************************************

      logical function at end

      integer
     &    col,
     &    nextc,
     &    nextl

      logical
     &    match

      include 'rencom'

      logical ! function
     &    blank,
     &    matchd


      col = 1
   10 if ((col .le. 5) .and.
     &    (index(' 0123456789', buf(1)(col:col)) .gt. 0) ) then
          col = col + 1
          go to 10
      end if

      match = matchd(min(col, linlen(1)), 1, 'end', 3, nextc, nextl)

      atend = match .and. blank(buf(nextl)(nextc:nextc))

      return
      end

********************************************************************************
*
* RENUMB
*
*     If a number is at the passed line and column position, it 
*     will be replaced with its new statement number equivalent.  
*     Otherwise, no action is taken.
*
********************************************************************************

      subroutine renumb(fromc, froml)

      integer
     &    fromc,
     &    froml,
     &    strip

      integer*4
     &    label,
     &    newlab

      character
     &    tmp*149

      include 'rencom'

      logical ! function
     &    gotnum

      integer ! functions
     &    numsiz

      integer*4 ! functions
     &    lookup


      if (gotnum(fromc, froml, linlen(froml), label, strip)) then
          newlab = lookup(label)
          write(tmp, '(a, i<numsiz(newlab)>, a)')
     &        buf(froml)(:fromc-1), 
     &        newlab, 
     &        buf(froml)(fromc+strip:linlen(froml))
          linlen(froml) = numsiz(newlab) + linlen(froml) - strip
          buf(froml) = tmp
      end if

      return
      end

********************************************************************************
*
* LOOKUP
*
*     LOOKUP will search through the statement label table for the 
*     label passed to it.  If found, the label's position in the 
*     table will be used to compute a new label value.  Otherwise, 
*     the label value -9999 is returned, and an error message is 
*     written out.
*     
********************************************************************************

      integer*4 function lookup(label)

      integer
     &    i

      integer*4
     &    label

      include 'rencom'

      do 10, i = 1, laslab
          if (label .eq. labels(i)) then
              lookup = i * 10
              return
          end if
   10 continue

      write(5, '(a, i6)')
     &    ' **** Error -- no such label:', label
      lookup = -9999

      return
      end

********************************************************************************
*
* INCR
*
*     Sets line and column variables L and C to the position of 
*     the next character.  If the column position is already at the end 
*     of the line, L and C will be set to the first statement 
*     character in the next line.
*
********************************************************************************

      subroutine incr(c, l)

      integer
     &    c,
     &    l

      include 'rencom'


      if (c .le. linlen(l)) then
          c = c + 1
          if ((c .gt. linlen(l)) .and. (l .lt. laslin)) then
              l = l + 1
              call contin(l, c)
          end if
      end if

      return
      end

********************************************************************************
*
* SKIP BL
*
*     Sets the line and column positions to the first non-blank
*     character at or beyond the current position.  Since text
*     contained in comments and character strings should not be
*     renumbered, aphostrophe-delimited comments and character
*     strings are treated by this routine as if they were
*     sequences of blank space. 
*
********************************************************************************

      subroutine skipbl(col, lin)

      integer
     &    col,
     &    lin

      character
     &    ch

      logical
     &    inchar

      logical ! function
     &    blank

      include 'rencom'


      inchar = .FALSE.

   10 if ((col .le. linlen(lin)) .or. (lin .lt. laslin)) then

          ch = buf(lin)(col:col)

          if (blank(ch)) then
              call incr(col, lin)
              go to 10
          else if (ch .eq. '''') then
              inchar = .not. inchar
              call incr(col, lin)
              go to 10
          else if (inchar) then
              call incr(col, lin)
              go to 10
          else if ((.not. inchar) .and. (ch .eq. '!')) then
              col = linlen(lin)
              call incr(col, lin)
              go to 10
          end if

      end if

      return
      end

********************************************************************************
*
* NUM SIZ
*
*     Returns the number of characters needed to represent a 
*     number in the range of 1 through 99999.  Returns 8 if passed 
*     a value outside of this range.
*
********************************************************************************

      integer function numsiz(n)

      integer n

      if (n .le.    0) then
          numsiz = 8
      else if (n .le.    9) then
          numsiz = 1
      else if (n .le.   99)  then
          numsiz = 2
      else if (n .le.  999) then
          numsiz = 3
      else if (n .le. 9999) then
          numsiz = 4
      else
          numsiz = 5
      end if
 
      return
      end

********************************************************************************
*
* TAB
*
*     Returns .TRUE. if passed an ASCII tab character.  
*     Returns .FALSE. otherwise.
*
********************************************************************************

      logical function tab(char)

      character
     &    char

      tab = ichar(char) .eq. 9

      return
      end

********************************************************************************
*
* BLANK
*
*     Returns .TRUE. if passed a space character or an ASCII tab
*     character.  Returns .FALSE. otherwise. 
*
********************************************************************************

      logical function blank(char)

      character
     &    char

      logical ! function
     &    tab

      blank = ((char .eq. ' ') .or. (tab(char)))

      return
      end

********************************************************************************
*
* CHAR EQ
*
*     Returns .TRUE. if passed two characters which are the same 
*     or which represent the same letter (e.g., chareq('A', 'a') 
*     returns .TRUE.).  Returns .FALSE. otherwise.
*
********************************************************************************

      logical function chareq(char1, char2)

      character
     &    char1,
     &    char2

      integer ! function
     &    ilower

      chareq = ilower(char1) .eq. ilower(char2)

      return
      end

********************************************************************************
*
* ILOWER
*
*     Returns the integer value of the lower case version of the 
*     character which is passed.
*
********************************************************************************

      integer function ilower(c)

      character
     &    c

      if ((ichar(c).lt.ichar('A')) .or. (ichar(c).gt.ichar('Z'))) then
          ilower = ichar(c)
      else
          ilower = ichar(c) - ichar('A') + ichar('a')
      end if

      return
      end

********************************************************************************
*
* GET 2 FN
*
*     Gets one or two filenames.  If a command line is present, 
*     the filenames are read from it.  Otherwise, they are read 
*     from the console.  In either case, if oney one filename is 
*     available, the second filename will be set to be the same as 
*     the first filename.
*
********************************************************************************

      subroutine get2fn(fn1, fn2)

      character
     &    buf*255,
     &    fn1*26,
     &    fn2*26

      integer
     &    i,
     &    linlen,
     &    parm(41),
     &    parms

*     call getmcr(buf, linlen)
      call lib$get_foreign(%descr(buf), , linlen)

      if ((linlen .le. 0) .or. (index(buf(:linlen), ' ') .eq. 0)) then
          write(5, '('' File? '', $)')
          read (5, '(q, a)', end=40) linlen, buf(2:)
          buf(1:1) = ' '
          linlen = linlen + 1
      end if

      i = 1
      parms = 0
   10 if (i .lt. linlen) then
   20     if (i .le. linlen .and. buf(i:i) .ne. ' ') then
              i = i + 1
              go to 20
          end if
   30     if (i .le. linlen .and. buf(i:i) .eq. ' ') then
              i = i + 1
              go to 30
          end if
          if (i .le. linlen) then
              parms = parms + 1
              parm(parms) = i
              parm(parms+1) = linlen + 1
          end if
          go to 10
      end if

      fn1 = buf(parm(1):parm(2)-1)

      if (parms .eq. 1) then
          fn2 = fn1
      else
          fn2 = buf(parm(2):parm(3)-1)
      end if

      return

   40 call exit

      end
