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) ! 階層⇔プログラム名
    character(1), parameter :: head    = '#'         ! 行頭文字
    character(2), parameter :: indent  = '| '        ! 字下げ文字
    character(2), parameter :: meshead = '|-'        ! DbgMessage 用行頭文字

    public:: BeginSub, EndSub, Debug, SetDebug, DbgMessage, Dbg_Scratch
    public:: SubLevel, DataDump

    interface DataDump
       module procedure DataD1Dump, DataD2Dump, DataD3Dump
    end interface

contains

    !-------------------------------------------------------
    ! 副プログラムの階層レベルを返す
    !-------------------------------------------------------
    integer function SubLevel() result(result)
        result = level
    end function SubLevel

    !-------------------------------------------------------
    ! デバッグメッセージの抹消
    !-------------------------------------------------------
    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
           ! 有効な 1 〜 99 の装置番号の内の大きめの値を設定 (?)
           dbg = 98
           do
              inquire(unit=dbg, exist=x, opened=p)
              ! 装置番号 dbg が接続可能で、かつ未接続の場合
              if (x .and. .not. p) then
                 ! 装置番号 deg をスクラッチファイルとして開く。
                 !   ※ スクラッチファイルとは、特殊な外部ファイルである。
                 !      これは名前なしの一時ファイルであり、開いている
                 !      間だけ存在する。つまり、プログラムが終了すると
                 !      存在しなくなる。
                 open(unit=dbg, status='SCRATCH')
                 ! 開く事が出来ればそれで終了。
                 return
              endif
              ! 装置番号 dbg が利用不可、または利用済の場合は 0 以下に
              ! なるまで dbg - 1 して繰り返す。
              dbg = dbg - 1
              if (dbg < 0) exit
           enddo
           ! 装置番号 dbg が開けない場合、dbg と saved_dbg を初期化
           dbg = saved_dbg
           saved_dbg = -1
        else
           ! 以前に装置番号 dbg = 98〜0 でスクラッチファイルを開けてい
           ! なければそれで終了
           if (saved_dbg < 0) return
           ! 装置番号 dbg に接続されたスクラッチファイルをその開始位置
           ! に位置付ける。エラーが生じたら「100 continue」へ
           rewind(dbg, err=100)
           do
              ! 装置番号 dbg に接続されたスクラッチファイルの一行を
              ! line へ
              read(dbg, '(A)', iostat=ios) line
              if (ios /= 0) exit
              ! line を装置番号 saved_dbg へ書き出す。
              write(saved_dbg, '(A)', iostat=ios) trim(line)
              if (ios /= 0) exit
           enddo
           100 continue
           close(dbg, iostat=ios)
           ! 最後に dbg と saved_dbg を初期化
           dbg = saved_dbg
           saved_dbg = -1
        endif
    end subroutine Dbg_Scratch

    !-------------------------------------------------------
    ! デバッグモードをオンにするサブルーチン
    !-------------------------------------------------------
    subroutine SetDebug(debug)
        integer, intent(in), optional:: debug
        integer:: ios
        if (present(debug)) then
            ! debug が与えられる時は装置番号として deg を用いる。
            dbg = debug
            write(dbg, "(A, 'SetDebug: dbg =', i4)", iostat=ios) &
                 & trim(head), dbg
            if (ios == 0) return
        else
            ! debug が与えられ無い時は装置番号 0 (標準エラー出力)
            dbg = 0
            write(dbg, "(A, 'SetDebug: dbg = 0')", iostat=ios) trim(head)
            if (ios == 0) return
            ! 装置番号 0 への出力が失敗したら装置番号 6 (標準出力)
            dbg = 6
            write(dbg, "(A, 'SetDebug: dbg = 6')", iostat=ios) trim(head)
            if (ios == 0) return
        endif
        ! 例外処理として dbg の初期化
        dbg = -1
    end subroutine SetDebug

    !-------------------------------------------------------
    ! デバックモードかどうかの診断
    !-------------------------------------------------------
    logical function Debug() result(result)
        result = dbg >= 0
    end function Debug

    !-------------------------------------------------------
    ! 初期化
    !-------------------------------------------------------
    subroutine initialize
        table(:) = ' '
        lfirst = .false.
    end subroutine initialize

    !-------------------------------------------------------
    ! 副プログラム開始のメッセージ出力 (level + 1)
    !-------------------------------------------------------
    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(:)
        real(8),      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, A, 'call ', A, ' : ', A)") trim(head), &
                    & repeat(indent, level), trim(name), trim(cbuf)
            else
                write(dbg, "(A, A, 'call ',A)") trim(head), & 
                    & repeat(indent, level), trim(name)
            endif
        endif
        ! call errtra ! --- for Fujitsu debug
        if (level > size(table)) return
        level = level + 1
        table(level) = name
    end subroutine BeginSub

    !-------------------------------------------------------
    ! 副プログラム終了のメッセージ出力 (level - 1)
    !-------------------------------------------------------
    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(:)
        real(8),      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
        ! call errtra ! --- for Fujitsu debug
        if (level <= 0) then
            write(*, "(A, 'Warning EndSub[',A,'] without BeginSub')") &
                & trim(head), trim(name)
        else if (name /= table(level)) then
            write(*, "(A, 'Warning EndSub[',A,'] but tos[',A,']')") &
                & trim(head), trim(name), trim(table(level))
        else
            level = level - 1
        endif
        if (debug()) then
            if (present(fmt)) then
                cbuf = cprintf(fmt, i, r, d, L, s, n, c1, c2, c3)
                write(dbg, "(A, A, 'end ', A, ' : ', A)") trim(head), &
                    & repeat(indent, level), trim(name), trim(cbuf)
            else
                write(dbg, "(A, A, 'end ', A)") trim(head), &
                    & repeat(indent, level), trim(name)
            endif
        endif
    end subroutine EndSub

    !-------------------------------------------------------
    ! メッセージ出力 (level ± 0)
    !-------------------------------------------------------
    subroutine DbgMessage(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, toChar
        character(*), intent(in)          :: fmt
        integer,      intent(in), optional:: i(:), n(:)
        real,         intent(in), optional:: r(:)
        real(8),      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
        character(string):: meshead_tmp
        integer          :: meshead_len
    continue
        if (.not. debug()) return
        cbuf = cprintf(fmt, i, r, d, L, s, n, c1, c2, c3)
        if (level < 1) then
           meshead_tmp = ''
           meshead_len = 0
        else
           meshead_tmp = meshead
           meshead_len = len(meshead)
        endif
        write(dbg, "(A, A, A, A)") & 
             & trim(head), repeat( indent, max(level-1, 0) ), &
             & meshead_tmp(1:meshead_len), trim(cbuf)
    end subroutine DbgMessage


    !-------------------------------------------------------
    ! 多次元データ出力 (level ± 0)
    !-------------------------------------------------------
    subroutine DataD3Dump(header, d, strlen, multi)
      use dc_types,      only: string
      character(*), intent(in)          :: header  ! データの名称
      real(8),      intent(in)          :: d(:,:,:)! 倍精度実数３次元データ
      integer,      intent(in), optional:: strlen  ! 一行の文字数
      integer,      intent(in), optional:: multi(:)! 上位の次元添字

      integer, allocatable :: total(:)
      integer              :: k

    continue
      if (.not. debug()) return

      if (present(multi)) then
         allocate( total(size(multi)+1) )
         total(2:size(multi)+1) = multi(:)
      else
         allocate( total(1) )
      endif

      do k = 1, size( d(:,:,:), 3 )
         total(1) = k
         call DataDump(header, d(:,:,k), strlen=strlen, multi=total(:))
      enddo

      deallocate( total )

    end subroutine DataD3Dump

    subroutine DataD2Dump(header, d, strlen, multi)
      use dc_types,      only: string
      character(*), intent(in)          :: header  ! データの名称
      real(8),      intent(in)          :: d(:,:)  ! 倍精度実数２次元データ
      integer,      intent(in), optional:: strlen  ! 一行の文字数
      integer,      intent(in), optional:: multi(:)! 上位の次元添字

      integer, allocatable :: total(:)
      integer              :: j

    continue
      if (.not. debug()) return

      if (present(multi)) then
         allocate( total(size(multi)+1) )
         total(2:size(multi)+1) = multi(:)
      else
         allocate( total(1) )
      endif

      do j = 1, size( d(:,:), 2 )
         total(1) = j
         call DataDump(header, d(:,j), strlen=strlen, multi=total(:))
      enddo

      deallocate( total )

    end subroutine DataD2Dump

    subroutine DataD1Dump(header, d, strlen, multi)
      use dc_types,      only: string
      use dc_string,     only: toChar
      character(*), intent(in)          :: header  ! データの名称
      real(8),      intent(in)          :: d(:)    ! 倍精度実数１次元データ
      integer,      intent(in), optional:: strlen  ! 一行の文字数
      integer,      intent(in), optional:: multi(:)! 上位の次元添字

      integer          :: i, j

      character(string):: unit    ! データ文字列
      character(string):: unitbuf ! データ文字列バッファ
      integer          :: ucur    ! unit に書かれた文字数
      character(string):: cbuf    ! read/write 文のバッファ
      integer          :: stat    ! ステータス

      logical  :: first  ! 1つ目のデータかどうか
      integer  :: begini ! 1つ目のデータの添字
      integer  :: endi   ! 最後のデータの添字

      character(string):: cmulti ! 次元添字用文字列
      character(string):: cout   ! 出力する文字列

      character(string):: meshead_tmp
      integer          :: meshead_len
    continue
      if (.not. debug()) return

      ! 初期化
      unit    = ''
      unitbuf = ''
      ucur    = 0
      stat    = 0
      first = .true.

      cmulti = ''

      ! デバッグメッセージヘッダの作成。
      if (level < 1) then
         meshead_tmp = ''
         meshead_len = 0
      else
         meshead_tmp = meshead
         meshead_len = len(meshead)
      endif

      ! 次元添字用文字列を作成
      if (present(multi)) then
         do j = 1, size(multi)
            cmulti = trim(cmulti) // ', ' // trim(  toChar( multi(j) )  )
         enddo
      endif

      i = 1
      Dim_1_Loop : do
         if (first) begini = i
         endi = i
         write(cbuf, "(g40.20)") d(i)
         if (.not. first) cbuf = ', ' // adjustl(cbuf)
         unitbuf = unit
         call append(unit, ucur, trim(adjustl(cbuf)), stat, strlen)

         if ( stat /= 0 .or. i == size( d(:) ) ) then
            ! 一回目は、文字数オーバーでもそのまま出力。
            if (first) then
               cout = header // '(' &
                    &   // trim(toChar(begini)) &
                    &   // trim(cmulti) &
                    &   // ')=' // trim(unit)
            ! 二回目以降は、オーバーしたものは次回へ
            elseif (stat /= 0 .and. begini == endi-1) then
               cout = header // '(' &
                    &   // trim(toChar(begini)) &
                    &   // trim(cmulti) &
                    &   // ')='// trim(unitbuf)
               ! 1つ巻戻す
               i = i - 1
            elseif (stat /= 0 .and. begini /= endi-1) then
               cout = header // '(' &
                    &   // trim(toChar(begini)) // '-' &
                    &   // trim(toChar(endi-1)) &
                    &   // trim(cmulti) &
                    &   // ')=' // trim(unitbuf)
               ! 1つ巻戻す
               i = i - 1
            ! i が size(d) まで到達した場合もそのまま出力。
            elseif ( i == size( d(:) ) ) then
               cout = header // '(' &
                    &   // trim(toChar(begini)) // '-' &
                    &   // trim(toChar(endi))   &
                    &   // trim(cmulti) &
                    &   // ')='// trim(unit)
            endif

            write(dbg, "(A, A, A, A)") & 
                 & trim(head), repeat( indent, max(level-1, 0) ), &
                 & meshead_tmp(1:meshead_len), trim(cout)

            ! unit, unitbuf をクリア
            unit    = ''
            unitbuf = ''
            ucur    = 0
            first = .true.
         else
            first = .false.
         endif
         if (i == size( d(:) ) ) exit Dim_1_Loop
         i = i + 1
      enddo Dim_1_Loop
    end subroutine DataD1Dump


    !
    ! 実質的には DataDump の内部関数。
    ! unit に val を付加。その際、unit がその最大文字列長を越えた場合
    ! には stat = 2 を返す。
    !
    subroutine append(unit, ucur, val, stat, strlen)
      character(*), intent(inout):: unit ! 最終的に返される文字列
      integer,      intent(inout):: ucur ! unit の文字数
      character(*), intent(in)   :: val  ! unit に付加される文字列
      integer,      intent(out)  :: stat ! ステータス
      integer,      intent(in), &
           &        optional     :: strlen ! 文字数の手動指定

      integer                    :: wrsz ! val の文字列
      continue
      ! unit の最大長を越えた場合には stat = 2 を返す。
      if (present(strlen)) then
         if (ucur >= strlen) then
            stat = 2
            return
         endif
      else
         if (ucur >= len(unit)) then
            stat = 2
            return
         endif
      endif
      ! 正常時の処理。
      ! unit の長さを越えた場合も考慮して unit に val を付加する。
      wrsz = min(len(val), len(unit) - ucur)
      unit(1+ucur: wrsz+ucur) = val(1: wrsz)
      ucur = ucur + wrsz
      stat = 0
      if (wrsz < len(val)) stat = 1
    end subroutine append

end module