module n3io
  use n3blkio, only: FILES
  implicit none

  private
  logical, save:: lfirst = .true.


  ! Block length is specified by user at FOPEN() time and retained
  ! throughout to FCLOSE().  This is used as the preferred record length,
  ! although different record length may be used to handle the end of file.

  type blkofs
    ! block number, 1-starting (same as REC= specifier)
    integer:: blk
    ! offset in block, 0-starting (to make computations simpler)
    integer:: ofs
  end type

  type ioinfo
    integer:: blk_words
    type(blkofs):: cur, eof, cached
    logical:: hot
    integer:: fd
    integer(4), pointer:: buf(:)
  end type

  type(ioinfo), target:: info(FILES)

  integer, parameter:: default_blkwords = 256 * 1024

  public:: fopen, fread, fwrite, fgetpos, fclose

contains

  ! private
  subroutine init
    integer:: i
    if (.not. lfirst) return
    lfirst = .false.
    do, i = 1, FILES
      info(i)%blk_words = 0
      info(i)%cur = blkofs(0, 0)
      info(i)%eof = blkofs(0, 0)
      info(i)%cached = blkofs(0, 0)
      info(i)%hot = .false.
      nullify(info(i)%buf)
    enddo
  end subroutine

  ! private
  subroutine set_buffer(unit, iostat)
    use n3error, only: EALLOC
    integer, intent(in):: unit
    integer, intent(out):: iostat
    if (associated(info(unit)%buf)) return
    allocate(info(unit)%buf(info(unit)%blk_words), stat=iostat)
    if (iostat /= 0) then
      iostat = EALLOC
    endif
  end subroutine

  ! private
  subroutine free_buffer(unit, iostat)
    use n3error, only: EDEALLOC
    integer, intent(in):: unit
    integer, intent(out):: iostat
    if (.not. associated(info(unit)%buf)) return
    deallocate(info(unit)%buf, stat=iostat)
    if (iostat /= 0) then
      iostat = EDEALLOC
    endif
  end subroutine

  !private
  subroutine writeblock(unit, i, buf, iostat)
    use n3error, only: EWRITE
    use n3blkio, only: blkio_write
    integer, intent(in):: unit, i, buf(*)
    integer, intent(out):: iostat
    ! DON'T BUFFER BECAUSE IT HAS LITTLE MEANING WHEN WHOLE BLOCK IS WRITTEN
    call blkio_write(handle=unit, blk=i+1, buf=buf, iostat=iostat)
  end subroutine

  !private
  subroutine readblock(unit, i, buf, iostat)
    use n3error, only: EREAD
    use n3blkio, only: blkio_read
    integer, intent(in):: unit, i
    integer, intent(out):: buf(*)
    integer, intent(out):: iostat
    call blkio_read(handle=unit, blk=i+1, buf=buf, iostat=iostat)
  end subroutine

  !private
  subroutine flushblock(unit, iostat)
    integer, intent(in):: unit
    integer, intent(out):: iostat
    if (info(unit)%hot) then
      call writeblock(unit, info(unit)%cached%blk, info(unit)%buf, iostat)
      info(unit)%hot = .false.
    else
      iostat = 0
    endif
  end subroutine

  !private
  subroutine fetchblock(unit, i, iostat)
    integer, intent(in):: unit, i
    integer, intent(out):: iostat
    call set_buffer(unit, iostat)
    if (iostat /= 0) return
    if (info(unit)%cur%blk == i) return
    call flushblock(unit, iostat)
    if (iostat /= 0) return
    call readblock(unit, i, info(unit)%buf, iostat)
  end subroutine

  !private
  subroutine writeblock_part(unit, i, ofs, nwords, buf, iostat)
    integer, intent(in):: unit, i, ofs, nwords, buf(*)
    integer, intent(out):: iostat
    call set_buffer(unit, iostat)
    if (iostat /= 0) return
    call flushblock(unit, iostat)
    if (iostat /= 0) return
    info(unit)%buf(1+ofs:1+ofs+nwords) = buf(1:nwords)
    if (iostat /= 0) return
  end subroutine

  !private
  subroutine readblock_part(unit, i, ofs, nwords, buf, iostat)
    integer, intent(in):: unit, i, ofs, nwords
    integer, intent(out):: buf(*)
    integer, intent(out):: iostat
    call fetchblock(unit, i, iostat)
    if (iostat /= 0) return
    buf(1:nwords) = info(unit)%buf(1+ofs:1+ofs+nwords)
  end subroutine

  ! private
  subroutine fopen_modeparse(mode, flags)
    use n3blkio, only: O_RDONLY, O_WRONLY, O_CREAT, O_EXCL, O_TRUNC
    character(*), intent(in):: mode
    integer, intent(out):: flags
    integer:: i
    call init
    flags = 0
    do, i = 1, len(mode)
      select case (mode(i:i))
        case('r', 'R')
          flags = ior(flags, O_RDONLY)
        case('w', 'W', '+')
          flags = iand(flags, not(O_RDONLY))
          flags = ior(flags, O_CREAT)
        case('o', 'O')
          flags = iand(flags, not(O_CREAT))
        case('c', 'C')
          flags = ior(flags, O_CREAT)
        case('x', 'X')
          flags = ior(flags, O_EXCL)
        case('t', 'T', '>')
          flags = ior(flags, O_TRUNC)
      end select
    enddo
  end subroutine

  !public
  subroutine fopen(file, mode, blkwords, unit)
    use n3blkio, only: blkio_open
    ! file name
    character(*), intent(in):: file
    character(*), intent(in):: mode
    ! block length (suggested record length) in words
    integer, intent(in):: blkwords
    integer, intent(out):: unit
    integer:: flags, i_blkwords, iostat
    call init
    call fopen_modeparse(mode, flags)
    if (blkwords == 0) then
      i_blkwords = 10240
    else
      i_blkwords = blkwords
    endif
    call blkio_open(file=file, flags=flags, blkl=i_blkwords, &
    & handle=unit)
    if (unit <= 0) then
      return
    endif
    info(unit)%blk_words = i_blkwords
  end subroutine

  !public
  subroutine fclose(unit, iostat)
    use n3blkio, only: blkio_close
    integer, intent(in):: unit
    integer, intent(out):: iostat
    call init
    call blkio_close(unit, iostat)
    if (iostat /= 0) return
    call free_buffer(unit, iostat)
  end subroutine

  !public
  subroutine fgetpos(unit, pos)
    use n3long, only: long, long_by_muladd, assignment(=)
    integer, intent(in):: unit
    type(long), intent(out):: pos
    call init
    if (unit < 1 .or. unit > FILES) then
      pos = 0
      return
    endif
    call long_by_muladd(pos, &
    & info(unit)%blk_words, info(unit)%cur%blk, info(unit)%cur%ofs)
  end subroutine

  !private
  subroutine blkofs_add_int(cur, nwords, blkl, fin)
    type(blkofs), intent(in):: cur
    integer, intent(in):: nwords, blkl
    type(blkofs), intent(out):: fin
    fin%blk = cur%blk + nwords / blkl
    fin%ofs = cur%ofs + mod(nwords, blkl)
    if (fin%ofs >= blkl) then
      fin%blk = fin%blk + 1
      fin%ofs = mod(fin%ofs, blkl)
    endif
  end subroutine

  !public
  subroutine fread(unit, nwords, buf, iostat)
    integer, intent(in):: unit, nwords
    integer, intent(out):: buf(*), iostat
    type(blkofs):: cur, fin
    integer:: blkl, base, j1, j2, j
    call init
    cur = info(unit)%cur
    blkl = info(unit)%blk_words
    call blkofs_add_int(cur, nwords - 1, blkl, fin)
    if (cur%blk == fin%blk .and. &
      & (cur%ofs > 0 .or. fin%ofs < (blkl - 1))) then
      call readblock_part(unit, cur%blk, 0, nwords, buf, iostat)
      if (iostat /= 0) return
      return
    endif
    if (cur%ofs > 0) then
      call readblock_part(unit, cur%blk, &
      & cur%ofs, blkl-cur%ofs, buf(1+cur%ofs:blkl), iostat)
      if (iostat /= 0) return
      j1 = cur%blk + 1
    else
      j1 = cur%blk
    endif
    if (fin%ofs < (blkl - 1)) then
      base = (fin%blk - cur%blk) * blkl - cur%ofs + 1
      call readblock_part(unit, fin%blk, &
      & 0, 1 + fin%ofs, buf(base:base+fin%ofs), iostat)
      if (iostat /= 0) return
      j2 = fin%blk - 1
    else
      j2 = fin%blk
    endif
    do, j = j1, j2
      base = (fin%blk - cur%blk) * blkl - cur%ofs
      call readblock(unit, fin%blk, info(unit)%buf(base+1:base+blkl), iostat)
      if (iostat /= 0) return
    enddo
  end subroutine

  !public
  subroutine fwrite(unit, nwords, buf, iostat)
    integer, intent(in):: unit, nwords, buf(*)
    integer, intent(out):: iostat
    type(blkofs):: cur, fin
    integer:: blkl, base, j1, j2, j
    call init
    cur = info(unit)%cur
    blkl = info(unit)%blk_words
    call blkofs_add_int(cur, nwords - 1, blkl, fin)
    if (cur%blk == fin%blk .and. &
      & (cur%ofs > 0 .or. fin%ofs < (blkl - 1))) then
      call writeblock_part(unit, cur%blk, 0, nwords, buf, iostat)
      if (iostat /= 0) return
      return
    endif
    if (cur%ofs > 0) then
      call writeblock_part(unit, cur%blk, &
      & cur%ofs, blkl-cur%ofs, buf(1+cur%ofs:blkl), iostat)
      if (iostat /= 0) return
      j1 = cur%blk + 1
    else
      j1 = cur%blk
    endif
    if (fin%ofs < (blkl - 1)) then
      base = (fin%blk - cur%blk) * blkl - cur%ofs + 1
      call writeblock_part(unit, fin%blk, &
      & 0, 1 + fin%ofs, buf(base:base+fin%ofs), iostat)
      if (iostat /= 0) return
      j2 = fin%blk - 1
    else
      j2 = fin%blk
    endif
    do, j = j1, j2
      base = (fin%blk - cur%blk) * blkl - cur%ofs
      call writeblock(unit, j, buf(base+1:base+blkl), iostat)
      if (iostat /= 0) return
    enddo
  end subroutine

end module