program prepro
  implicit none
  character(256):: line
  integer:: iostat
  do
    read(*, '(A)', iostat=iostat) line
    if (iostat /= 0) exit
    call dofile(line)
  enddo
contains

  subroutine dofile(fnam)
    use n3regex, only: match
    use n3bits, only: downcase
    character(*), intent(in):: fnam
    character(132):: line
    character(20):: ibuf
    integer:: iostat
    integer:: lineno, start, length, length2, vlineno
    logical:: modulep
    character(66):: locator
    open(unit=10, file=fnam, action='READ', status='OLD', iostat=iostat)
    if (iostat /= 0) then
      write(*, '(A,A,A)') '! ', trim(fnam), ': cannot open'
      return
    endif
    modulep = .false.
    locator = ''
    lineno = 0
    vlineno = 0
    do
      read(10, '(A)', iostat=iostat) line
      if (iostat /= 0) exit
      lineno = lineno + 1
      call downcase(line)
      !
      ! SKIP EMPTY/COMMENT LINE
      !
      call match('^ *$', line, start, length)
      if (length /= -1) cycle
      call match('^ *!', line, start, length)
      if (length /= -1) cycle
      !
      vlineno = vlineno + 1
      !
      ! PICK UP ERROR REFERENCE
      !
      call match('^ *call +error_#w+ *( *#d+', &
      & line, start, length)
      if (length /= -1) then
        call match('^ *call +error_#w+ *( *', &
        & line, start, length2)
        write(ibuf, '(I20.1)') lineno
        write(*, '(A,A,A)') &
        & trim(line(start+length2:start+length-1)) // ': ', &
        & trim(fnam) // ':', trim(adjustl(ibuf)) // ' (' // trim(locator) &
        & // ')'
        cycle
      endif
      !
      ! PICK UP MODULE LINE
      !
      call match('^ *module +#w+', line, start, length)
      if (length /= -1) then
        call match('^ *module +', line, start, length2)
        if (line(start+length2:start+length-1) == "procedure") cycle
        locator = line(start+length2:start+length-1) // '%%'
        modulep = .true.
        cycle
      endif
      !
      ! PICK UP SUBROUTINE LINE
      !
      call match('^ *subroutine +#w+', line, start, length)
      if (length /= -1) then
        call match('^ *subroutine +', line, start, length2)
        call register_proc(locator, modulep, &
        & line(start+length2:start+length-1))
        cycle
      endif
      call match('function +#w+', line, start, length)
      if (length /= -1) then
        call match('function +', line, start, length2)
        call register_proc(locator, modulep, &
        & line(start+length2:start+length-1))
        cycle
      endif
      !
      ! DETECT MAIN PROGRAM
      !
      if (vlineno == 1) then
        locator = "MAIN PROGRAM"
      endif
    enddo
    close(10)
  end subroutine

  subroutine register_proc(locator, modulep, symbol)
    character(*), intent(inout):: locator
    logical, intent(in):: modulep
    character(*), intent(in):: symbol
    integer:: i
    if (modulep) then
      i = index(locator, '%')
      if (i /= 0) then
        locator = locator(1:i+1) // symbol
        return
      endif
    endif
    locator = symbol
  end subroutine

end program