module n3blkio
  implicit none
  private

  type blkio_info
    integer:: unit
    ! actual record length in Fortran-processor dependent units.
    integer:: recl
    ! desired record length in words.
    integer:: reclw
    ! desired record length in words. Initially 0. If this field is zero,
    ! the entry of info table is considered to be unused.
    integer:: blkl
    integer:: flags
  end type

  type(blkio_info), parameter:: BLKIO_INI = blkio_info(-1, 0, 0, 0, 0)

  integer, public, parameter:: FILES = 20
  integer, public, parameter:: FNAM_MAXLEN = 1024
  type(blkio_info), private, save:: info(FILES)
  logical, private, save:: lfirst = .true.

  integer, private, save:: iol_per_word = 0

  public:: blkio_open, blkio_close
  public:: blkio_read, blkio_write

  integer, public, parameter:: O_RDWR = 0
  integer, public, parameter:: O_RDONLY = 1
  integer, public, parameter:: O_WRONLY = 2
  integer, public, parameter:: O_CREAT = 4
  integer, public, parameter:: O_EXCL = 8
  integer, public, parameter:: O_TRUNC = 16

contains

  subroutine init
    integer, parameter:: IOLTESTER = 240
    integer:: i, dummy(IOLTESTER), iol
    if (.not. lfirst) return
    inquire(iolength=iol) dummy
    if (iol >= IOLTESTER) then
      iol_per_word = iol / IOLTESTER
    else
      iol_per_word = -IOLTESTER / iol
    endif
    do, i = 1, FILES
      info(i) = BLKIO_INI
    enddo
    lfirst = .false.
  end subroutine

  ! error: negative handle
  subroutine open_find_slot(handle)
    integer, intent(out):: handle
    do, handle = 1, FILES
      if (info(handle)%recl == 0) return
    enddo
    handle = -1
  end subroutine

  ! error: negative unit
  subroutine open_find_unit(unit)
    integer, intent(out):: unit
    logical:: op, ex
    do, unit = 99, 1, -1
      inquire(unit=unit, opened=op, exist=ex)
      if (ex .and. .not. op) return
    enddo
    unit = -1
  end subroutine

  subroutine flag2open(flags, action, status)
    integer, intent(in):: flags
    character(*), intent(out):: action, status
    if (bit_test(flags, O_RDONLY)) then
      action = "READ"
    else if (bit_test(flags, O_WRONLY)) then
      action = "WRITE"
    else
      action = "READWRITE"
    endif
    if (.not. bit_test(flags, O_CREAT)) then
      status = "OLD"
    else if (bit_test(flags, O_EXCL)) then
      status = "NEW"
    else if (bit_test(flags, O_TRUNC)) then
      status = "REPLACE"
    else
      status = "UNKNOWN"
    endif
  contains
    logical function bit_test(i, j)
      integer, intent(in):: i, j
      bit_test = (iand(i, j) /= 0)
    end function
  end subroutine

  ! error: negative handle
  subroutine blkio_open(file, flags, blkl, handle)
    use n3error, only: error_set, EBLANKNAME, EINVAL, ETABFUL, &
      & ENOCLOSEDUNIT, ELONGNAME, EOPEN, error_add, ETHROUGH
    character(*), intent(in):: file
    integer, intent(in):: flags
    integer, intent(in):: blkl
    integer, intent(out):: handle
    character(9):: action, status
    integer:: recl, ios
  continue
    if (blkl <= 0) then
      call error_set(930030010, EINVAL)
      handle = -1
      return
    else if (file == '') then
      call error_set(930030020, EBLANKNAME)
      handle = -1
      return
    else if (len_trim(file) > FNAM_MAXLEN) then
      call error_set(930030030, ELONGNAME)
      handle = -1
      return
    endif
    call init
    call open_find_slot(handle)
    if (handle == -1) then
      call error_set(930030040, ETABFUL)
      return
    endif
    call open_find_unit(info(handle)%unit)
    if (info(handle)%unit == -1) then
      call error_set(930030050, ENOCLOSEDUNIT)
      handle = -1
      return
    endif
    recl = blkl * iol_per_word
    call flag2open(flags, action, status)
    open(unit=info(handle)%unit, file=file, access='DIRECT', &
      & form='UNFORMATTED', action=action, recl=recl, iostat=ios)
    if (ios /= 0) then
      call error_set(930030070, EOPEN)
      handle = -1
      return
    endif
    info(handle)%blkl = blkl
    info(handle)%reclw = blkl
    info(handle)%recl = recl
    info(handle)%flags = flags
  end subroutine

  ! error: nonzero iostat
  subroutine blkio_close(handle, iostat)
    use n3error, only: error_set, ECLOSE, EBADID, ECLOSED
    integer, intent(in):: handle
    integer, intent(out):: iostat
    if (handle < 1 .or. handle > FILES) then
      iostat = -1
      call error_set(930030110, EBADID)
      return
    endif
    if (info(handle)%recl == 0) then
      iostat = -1
      call error_set(930030110, ECLOSED)
      return
    endif
    close(unit=info(handle)%unit, iostat=iostat)
    if (iostat /= 0) then
      call error_set(930030100, ECLOSE)
    endif
    info(handle) = BLKIO_INI
  end subroutine

  ! error: nonzero iostat
  subroutine set_recl(h, reclw, iostat)
    use n3error, only: error_set, EIOLEN, EBADID, EINQNAME, ECLOSE, EOPEN
    integer, intent(in):: h, reclw
    integer, intent(out):: iostat
    character(FNAM_MAXLEN):: fnam
    integer:: recl
    if (iol_per_word <= 0) then
      call error_set(930030210, EIOLEN)
      iostat = -1
      return
    endif
    if (reclw == info(h)%reclw) then
      iostat = 0
      return
    endif
    inquire(unit=info(h)%unit, name=fnam, iostat=iostat)
    if (iostat /= 0) then
      call error_set(930030220, EINQNAME)
      return
    endif
    close(unit=info(h)%unit, iostat=iostat)
    if (iostat /= 0) then
      call error_set(930030230, ECLOSE)
      return
    endif
    recl = reclw * iol_per_word
    open(unit=info(h)%unit, file=fnam, access='DIRECT', &
      & form='UNFORMATTED', recl=recl, iostat=iostat)
    if (iostat /= 0) then
      call error_set(930030240, EOPEN)
      return
    endif
    info(h)%reclw = reclw
    info(h)%recl = recl
    iostat = 0
  end subroutine

  ! error: nonzero iostat
  subroutine fallback(h, factor, iostat)
    integer,  intent(in):: h
    integer, intent(out):: factor, iostat
    do, factor = 2, info(h)%reclw
      if (mod(info(h)%reclw, factor) == 0) then
        call set_recl(h, info(h)%reclw / factor, iostat)
        return
      endif
    enddo
    iostat = -1
  end subroutine

  ! iostat = 0: no error, full block read
  ! iostat > 0: eof reached, number of unread words
  ! iostat < 0: other error
  subroutine blkio_read(handle, blk, buf, iostat)
    use n3error, only: error_set, EBADID, ETHROUGH, EREAD, error_add, EWRONLY
    integer, intent(in):: handle
    integer, intent(in):: blk
    integer, intent(out):: buf(*)
    integer, intent(out):: iostat
    integer:: factor, ofs, i, iblk, reclw
    if (handle < 1 .or. handle > FILES) then
      iostat = -1
      call error_set(930030400, EBADID)
      return
    endif
    if (btest(info(handle)%flags, O_WRONLY)) then
      iostat = -1
      call error_set(930030410, EWRONLY)
      return
    endif
    call set_recl(handle, info(handle)%blkl, iostat)
    if (iostat /= 0) then
      iostat = -1
      call error_add(930030420, ETHROUGH)
    endif
    ! try to read whole
    iblk = blk
    ofs = 0
    reclw = info(handle)%reclw
    read(unit=info(handle)%unit, rec=iblk, iostat=iostat) buf(1:reclw)
    if (iostat == 0) then
      return
    endif
    ! try to read partially
    SHRINK: do
      if (info(handle)%reclw == 1) exit SHRINK
      call fallback(handle, factor, iostat)
      if (iostat /= 0) then
        call error_add(930030430, ETHROUGH)
        iostat = -1
        return
      endif
      iblk = (iblk - 1) * factor + 1
      do, i = 1, factor - 1
        reclw = info(handle)%reclw
        read(unit=info(handle)%unit, rec=iblk, iostat=iostat) &
        & buf(1+ofs:reclw+ofs)
        if (iostat /= 0) cycle SHRINK
        iblk = iblk + 1
        ofs = ofs + info(handle)%reclw
      enddo
    enddo SHRINK
    iostat = abs(info(handle)%blkl - ofs)
    return
  end subroutine

  ! iostat = 0: no error, full block read
  ! iostat > 0: eof reached, number of unwritten words
  ! iostat < 0: other error
  subroutine blkio_write(handle, blk, buf, iostat)
    use n3error, only: error_set, EBADID, ETHROUGH, EREAD, error_add, &
      & ERDONLY, EBLKNO
    integer, intent(in):: handle
    integer, intent(in):: blk
    integer, intent(in):: buf(*)
    integer, intent(out):: iostat
    integer:: factor, ofs, i, iblk, reclw
    if (handle < 1 .or. handle > FILES) then
      iostat = -1
      call error_set(930030500, EBADID)
      return
    endif
    if (blk <= 0) then
      iostat = -1
      call error_set(930030505, EBLKNO)
      return
    endif
    if (btest(info(handle)%flags, O_RDONLY)) then
      iostat = -1
      call error_set(930030510, ERDONLY)
      return
    endif
    call set_recl(handle, info(handle)%blkl, iostat)
    if (iostat /= 0) then
      iostat = -1
      call error_add(930030520, ETHROUGH)
    endif
    ! try to read whole
    iblk = blk
    ofs = 0
    reclw = info(handle)%reclw
    write(unit=info(handle)%unit, rec=iblk, iostat=iostat) buf(1:reclw)
    if (iostat == 0) then
      return
    endif
    ! try to read partially
    SHRINK: do
      if (info(handle)%reclw == 1) exit SHRINK
      call fallback(handle, factor, iostat)
      if (iostat /= 0) then
        call error_add(930030530, ETHROUGH)
        iostat = -1
        return
      endif
      iblk = (iblk - 1) * factor + 1
      do, i = 1, factor - 1
        reclw = info(handle)%reclw
        write(unit=info(handle)%unit, rec=iblk, iostat=iostat) &
        & buf(1+ofs:reclw+ofs)
        if (iostat /= 0) cycle SHRINK
        iblk = iblk + 1
        ofs = ofs + info(handle)%reclw
      enddo
    enddo SHRINK
    iostat = abs(info(handle)%blkl - ofs)
    return
  end subroutine

end