#
#
#
#    BURSTF Fortran program unit burster
#    ===================================
#
#
#         Author:  William Wood
#                  Computer Center
#                  Institute For Cancer Research
#                  7701 Burholme Ave.
#                  Philadelphia, Pa. 19111
#                  (215) 728 2760
#
#         Version: 2.0
#
#         Date:   December 18, 1981
#
#
_ifdef(VAX)
define(FORT_EXT,'.FOR')
_elsedef
define(FORT_EXT,'.FTN')
_enddef
define(MAXCOLUMN,72)

character file(FILENAMESIZE), buf(MAXLINE), white(3), temp(MAXLINE),
     filout(MAXLINE), digscn(13), endnam(4), temp2(MAXLINE)
character cupper
integer nc, source, n, f, ftmp, i, j, nfile, nfileb, ncomnt, fout
integer search, garg, scan, length, openc, getlin, bkscan
data white /' ', TAB, EOS/
data digscn /' ', TAB, '1', '2', '3', '4', '5', '6', '7', '8', '9', '0', EOS/
data endnam /' ', '(', TAB, EOS/
 
call initr4
ftmp = openc('BURSTF.TMP', READWRITE)
if (ftmp == ERR)
  call endr4
nfile = 1
nfileb = 1
repeat {
  n = 0
  if (garg('BURSTF> ', n, file, MAXLINE) == EOF)
    break
  call defnam(file, EOS, EOS, EOS, EOS, FORT_EXT, .false.)
  f = openc(file, READ)
  if (f == ERR)
    next
  repeat {
    for (ncomnt = 0; getlin(buf, f) != EOF; ncomnt = ncomnt + 1)
      if (cupper(buf(1)) == 'C')
        call putlin(buf, ftmp)
      else if (buf(scan(buf, white, 1)) == NEWLINE)
        call putlin(buf, ftmp)
      else
        break
    if (buf(1) != EOF) {
      i = 0
      call scopy(buf, 1, temp2, 1)
      buf(min(MAXCOLUMN+1, length(buf))) = EOS	# delete NEWLINE, ignore
      						# stuff past MAXCOLUMN for now
      call upper(buf)
      if (search(buf, 'FUNCTION') != 0)
        i = scan(buf, white, search(buf, 'FUNCTION') + length('FUNCTION'))
      else if (search(buf, 'SUBROUTINE') != 0)
        i = scan(buf, white, search(buf, 'SUBROUTINE') + length('SUBROUTINE'))
      else if (search(buf, 'PROGRAM') != 0)
        i = scan(buf, white, search(buf, 'PROGRAM') + length('PROGRAM'))
      else if (search(buf, 'BLOCK DATA') != 0)
        i = scan(buf, white, search(buf, 'BLOCK DATA') + length('BLOCK DATA'))
      if (i == 0) {
        call scopy('MAIN', 1, filout, 1)
        call itoc(nfile, temp, MAXLINE)
        nfile = nfile + 1
        call concat(filout, temp, FILENAMESIZE)
        }
      else {
        call scopy(buf, i, filout, 1)
        filout(bkscan(filout, endnam, 1)) = EOS
        if (length(filout) == 0) {
          call scopy('BLOCK', 1, filout, 1)
          call itoc(nfileb, temp, MAXLINE)
          nfileb = nfileb + 1
          call concat(filout, temp, FILENAMESIZE)
          }
        }
      }
    else if (ncomnt > 0) {
      call scopy('MAIN', 1, filout, 1)
      call itoc(nfile, temp, MAXLINE)
      nfile = nfile + 1
      call concat(filout, temp, FILENAMESIZE)
      }
    else
      break
    call concat(filout, FORT_EXT, FILENAMESIZE)
    fout = openc(filout, WRITE)
    if (fout == ERR)
      break 2
    call outlin(filout, STDOUT)
    if (ncomnt > 0) {
      rewind ftmp
      while (getlin(temp, ftmp) != EOF)
        call putlin(temp, fout)
      rewind ftmp
      }
    if (buf(1) != EOF) {
      call putlin(temp2, fout)
      repeat {
        if (getlin(buf, f) == EOF)
          break
        call putlin(buf, fout)
        i = scan(buf, digscn, 1)
        if (cupper(buf(i)) == 'E'  &  cupper(buf(i+1)) == 'N'  &
            cupper(buf(i+2)) == 'D') {
	  j = scan(buf, white, i+3)
	  if (j > MAXCOLUMN | buf(j) == NEWLINE)
	    break
	  }
	}
      }
    call closel(fout, SAVEF)
    }
  call closel(f, SAVEF)
  }
call closel(ftmp, DELETEF)
call endr4
end