module dc_trace

    use dc_types, only: token
    implicit none
    private

    logical, save:: lfirst = .true.
    integer, save, public:: dbg = -1
    integer, save:: level = 0
    integer, parameter:: trace_stack_size = 128
    character(token), save:: table(trace_stack_size)

    public:: beginsub, endsub, debug, setdebug, message, dbg_scratch
    public:: sublevel

contains

    integer function sublevel() result(result)
        result = level
    end function

    subroutine dbg_scratch(on)
        logical, intent(in):: on
        integer, save:: saved_dbg = -1
        logical:: x, p
        character(80):: line
        integer:: ios
    continue
        if (on) then
            if (dbg < 0) return
            saved_dbg = dbg
            dbg = 98
            do
                inquire(unit=dbg, exist=x, opened=p)
                if (x .and. .not. p) then
                    open(unit=dbg, status='SCRATCH')
                    return
                endif
                dbg = dbg - 1
                if (dbg < 0) exit
            enddo
            dbg = saved_dbg
            saved_dbg = -1
        else
            if (saved_dbg < 0) return
            rewind(dbg, err=100)
            do
                read(dbg, '(A)', iostat=ios) line
                if (ios /= 0) exit
                write(saved_dbg, '(A)', iostat=ios) trim(line)
                if (ios /= 0) exit
            enddo
            100 continue
            close(dbg, iostat=ios)
            dbg = saved_dbg
            saved_dbg = -1
        endif
    end subroutine

    subroutine setdebug(debug)
        integer, intent(in), optional:: debug
        integer:: ios
        if (present(debug)) then
            dbg = debug
            write(dbg, "('#setdebug: dbg =', i4)", iostat=ios) dbg
            if (ios == 0) return
        else
            dbg = 0
            write(dbg, "('#setdebug: dbg = 0')", iostat=ios)
            if (ios == 0) return
            dbg = 6
            write(dbg, "('#setdebug: dbg = 6')", iostat=ios)
            if (ios == 0) return
        endif
        dbg = -1
    end subroutine

    logical function debug() result(result)
        result = dbg >= 0
    end function

    subroutine initialize
        table(:) = ' '
        lfirst = .false.
    end subroutine

    subroutine beginsub(name, fmt, i, r, d, L, s, n, c1, c2, c3)
        use dc_types, only: string
        use dcstring_base, only: vstring
        use dc_string, only: cprintf
        character(*), intent(in):: name
        character(*), intent(in), optional:: fmt
        integer, intent(in), optional:: i(:), n(:)
        real, intent(in), optional:: r(:)
        double precision, intent(in), optional:: d(:)
        logical, intent(in), optional:: L(:)
        type(vstring), intent(in), optional:: s(:)
        character(*), intent(in), optional:: c1, c2, c3
        character(string):: cbuf
    continue
        if (lfirst) call initialize
        if (debug()) then
            if (present(fmt)) then
                cbuf = cprintf(fmt, i, r, d, L, s, n, c1, c2, c3)
                write(dbg, "('#', A, 'call ', A, ' ', A)") &
                    & repeat(' ', level), trim(name), trim(cbuf)
            else
                write(dbg, "('#', A, 'call ',A)") &
                    & repeat(' ', level), trim(name)
            endif
        endif
        ! call errtra ! --- for Fujitsu debug
        if (level > size(table)) return
        level = level + 1
        table(level) = name
    end subroutine

    subroutine message(fmt, i, r, d, L, s, n, c1, c2, c3)
        use dc_types, only: string
        use dcstring_base, only: vstring
        use dc_string, only: cprintf
        character(*), intent(in):: fmt
        integer, intent(in), optional:: i(:), n(:)
        real, intent(in), optional:: r(:)
        double precision, intent(in), optional:: d(:)
        logical, intent(in), optional:: L(:)
        type(vstring), intent(in), optional:: s(:)
        character(*), intent(in), optional:: c1, c2, c3
        character(string):: cbuf
    continue
        if (.not. debug()) return
        cbuf = cprintf(fmt, i, r, d, L, s, n, c1, c2, c3)
        write(dbg, "('#', A, A)") repeat(' ', level), trim(cbuf)
    end subroutine

    subroutine endsub(name, fmt, i, r, d, L, s, n, c1, c2, c3)
        use dc_types, only: string
        use dcstring_base, only: vstring
        use dc_string, only: cprintf
        character(*), intent(in):: name
        character(*), intent(in), optional:: fmt
        integer, intent(in), optional:: i(:), n(:)
        real, intent(in), optional:: r(:)
        double precision, intent(in), optional:: d(:)
        logical, intent(in), optional:: L(:)
        type(vstring), intent(in), optional:: s(:)
        character(*), intent(in), optional:: c1, c2, c3
        character(string):: cbuf
    continue
        if (lfirst) call initialize
        if (debug()) then
            if (present(fmt)) then
                cbuf = cprintf(fmt, i, r, d, L, s, n, c1, c2, c3)
                write(dbg, "('#', A, 'end ', A, ' ', A)") &
                    & repeat(' ', level), trim(name), trim(cbuf)
            else
                write(dbg, "('#', A, 'end ', A)") &
                    & repeat(' ', level), trim(name)
            endif
        endif
        ! call errtra ! --- for Fujitsu debug
        if (level <= 0) then
            write(*, "('#Warning endsub[',A,'] without beginsub')") trim(name)
        else if (name /= table(level)) then
            write(*, "('#Warning endsub[',A,'] but tos[',A,']')") &
                & trim(name), trim(table(level))
        else
            level = level - 1
        endif
    end subroutine

end module
