#
#
#
#    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
#
#
#
#      *******************************************************
#      *                                                     *
#      *      THIS SOFTWARE WAS DEVELOPED WITH SUPPORT       *
#      *      FROM THE NATIONAL INSTITUTES OF HEALTH:        *
#      *         NIH CA06927                                 *
#      *         NIH CA22780                                 *
#      *                                                     *
#      *      DIRECT INQUIRIES TO:                           *
#      *            COMPUTER CENTER                          *
#      *            THE INSTITUTE FOR CANCER RESEARCH        *
#      *            7701 BURHOLME AVENUE                     *
#      *            PHILADELPHIA, PENNSYLVANIA   19111       *
#      *                                                     *
#      *      NO WARRANTY OR REPRESENTATION, EXPRESS OR      *
#      *      IMPLIED, IS MADE WITH RESPECT TO THE           *
#      *      CORRECTNESS, COMPLETENESS, OR USEFULNESS       *
#      *      OF THIS SOFTWARE, NOR THAT USE OF THIS         *
#      *      SOFTWARE MIGHT NOT INFRINGE PRIVATELY          *
#      *      OWNED RIGHTS.                                  *
#      *                                                     *
#      *      NO LIABILITY IS ASSUMED WITH RESPECT TO        *
#      *      THE USE OF, OR FOR DAMAGES RESULTING FROM      *
#      *      THE USE OF THIS SOFTWARE                       *
#      *                                                     *
#      *******************************************************
#      *                                                     *
#      *      THIS SOFTWARE WAS DESIGNED FOR USE ON A        *
#      *      PDP-11/70 OPERATING UNDER IAS V3.0 USING       *
#      *      THE FORTRAN-IV PLUS COMPILER.                  *
#      *                                                     *
#      *******************************************************
#
_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