module n3fmt
  implicit none

  character(1), parameter:: digit(0:15) = &
  & (/'0', '1', '2', '3', '4', '5', '6', '7', '8', '9', &
  'A', 'B', 'C', 'D', 'E', 'F'/)

  interface hex
    module procedure i4_hex
  end interface

contains

  character(8) function i4_hex(i) result(result)
    integer(4), intent(in):: i
    integer:: j, k
    do, j = 1, 8
      k = ibits(i, 32 - j * 4, 4)
      result(j:j) = digit(k)
    enddo
  end function

  subroutine hexdigit2val(c, result)
    character, intent(in):: c
    integer, intent(out):: result
    select case(c)
    case('0'); result = 0; case('1'); result = 1
    case('2'); result = 2; case('3'); result = 3
    case('4'); result = 4; case('5'); result = 5
    case('6'); result = 6; case('7'); result = 7
    case('8'); result = 8; case('9'); result = 9
    case('A', 'a'); result = 10; case('B', 'b'); result = 11
    case('C', 'c'); result = 12; case('D', 'd'); result = 13
    case('E', 'e'); result = 14; case('F', 'f'); result = 15
    case default
      result = -1
    end select
  end subroutine

  subroutine dfmt_hex(buf, x, stat)
    character(*), intent(in):: buf
    integer, intent(out):: x, stat
    integer:: digit
    logical:: init
    x = 0
    stat = 0
    init = .true.
    do
      stat = stat + 1
      if (stat > len(buf)) exit
      if (init) then
        select case(buf(stat:stat))
        case('0':'9', 'A':'F', 'a':'f')
          init = .false.
        case(' ')
          cycle
        case default
          exit
        end select
      endif
      call hexdigit2val(buf(stat:stat), digit)
      if (digit == -1) exit
      x = ior(ishft(x, 4), digit)
    enddo
  end subroutine

  subroutine dfmt_decimal(buf, x, stat)
    character(*), intent(in):: buf
    integer, intent(out):: x, stat
    integer:: mode, c, sgn
    x = 0
    mode = 0
    sgn = 1
    stat = 0
    do
      stat = stat + 1
      if (stat > len(buf)) exit
      c = ichar(buf(stat:stat))
      if (mode == 0 .or. mode == ichar(' ')) then
        if (c == ichar('-')) then
          mode = ichar('-')
          sgn = -1
        else if (c >= ichar('0') .and. c <= ichar('9')) then
          mode = ichar('0')
          x = sgn * (c - ichar('0'))
        else if (c == ichar(' ') .or. c == ichar('+')) then
          mode = c
        else if (c == 8) then
          mode = ichar(' ')
        else
          exit
        endif
      else if (mode == ichar('-') .or. mode == ichar('+')) then
        if (c >= ichar('0') .and. c <= ichar('9')) then
          mode = ichar('0')
          x = sgn * (c - ichar('0'))
        else
          exit
        endif
      else if (mode == ichar('0')) then
        if (c >= ichar('0') .and. c <= ichar('9')) then
          x = x * 10 + sgn * (c - ichar('0'))
        else
          exit
        endif
      else
        exit
      endif
    enddo
  end subroutine

  subroutine fmt_hexa(x, buf)
    integer, intent(in):: x
    character(*), intent(out):: buf
    integer:: i, j
    j = x
    do, i = len(buf), 1, -1
      buf(i:i) = digit(ibits(j, 0, 4))
      j = ishft(j, -4)
    enddo
    if (j /= 0) then
      buf = repeat('*', len(buf))
    endif
  end subroutine

  subroutine fmt_decimal(x, buf)
    integer, intent(in):: x
    character(*), intent(out):: buf
    integer:: i, j, left
    logical:: negative
    j = x
    negative = (j < 0)
    if (negative) then
      j = -j
      left = 2
    else
      left = 1
    endif
    do, i = len(buf), left, -1
      buf(i:i) = digit(modulo(j, 10))
      j = j / 10
    enddo
    if (j /= 0) then
      buf = repeat('*', len(buf))
      return
    endif
    if (negative) buf(1:1) = '-'
  end subroutine

end module