!-- thWCmp3.f90
!-- 10 Dec 92, Richard Maine: Version 1.0.  Round time instead of truncate.

module th_write_cmp3

  !-- Module for writing cmp3 format time history files.
  !-- Intended for calling from the th_write module.
  !-- We rely on th_write for much of the call validity testing.
  !-- Possible system-dependencies in the open, read and write statements.
  !-- 10 Dec 92, Richard Maine.

  use precision
  use binary
  use sysdep_io

  implicit none
  private

  !-- Identifying string for format specification.
  character*(*), public, parameter :: cmp3_format_string='cmp3'

  integer, parameter :: block_size=2048, max_index=255

  integer, parameter :: header_block_code = 1, index_block_code = 2, &
       data_block_code=3
  integer, parameter :: block_head_len = 4
  integer, parameter :: eod_flag = 0, full_frame_flag = 1, bit_map_flag = 2, &
       change_list_flag = 3

  type :: block_type
    type(byte_type) :: body(block_size)
  end type

  type, private :: cmp3_type
    integer :: lun
    logical :: flush_on_close
    integer :: data_precision
    real(r_kind) :: base_time, time_scale
    integer :: time_key_offset, full_frame_interval
    integer :: n_blocks
    integer :: n_keys, index_count, index_div
    integer :: index_key(max_index), index_pos(max_index)
    integer :: first_index_block, n_index_blocks, first_data_block
    integer :: n_frames, prev_full_frame
    real(r_kind) :: first_time, last_time
    integer :: header_block_num, index_block_num, data_block_num
    integer :: header_block_len, index_block_len, data_block_len
    type(block_type) :: data_block, header_block
    real(r_kind), pointer :: last_value(:)
  end type

  type, private :: cmp3_ptr_type
    type(cmp3_type), pointer :: cmp3
  end type

  type(cmp3_type), pointer, private :: cmp3  !-- Scratch use only.  Not saved.
  type(cmp3_ptr_type), private :: cmp3_ptr   !-- Scratch use only.  Not saved.

  !-- Public procedures.
  public open_th_write_cmp3, close_th_write_cmp3, write_th_cmp3

  !-- Forward reference for private procedures.
  private put_header, put_frame, put_cmp3, write_block, read_block, add_key

contains

  subroutine open_th_write_cmp3 (gen, file_name, &
       signal_names, eu_names, dt, file_title, format_parameters, error)

    !-- Open a cmp3 file for writing.
    !-- 31 Jul 92, Richard Maine.

    !-------------------- interface.
    integer, pointer  :: gen(:)
         !-- Generic array for format-specific data.  Null on entry.
    character*(*), intent(in) :: file_name
    character*(*), intent(in) :: signal_names(:)
    character*(*), intent(in), optional :: eu_names(:)
    real(r_kind), intent(in), optional :: dt  !-- 0 or omitted means unknown.
    character*(*), intent(in), optional :: file_title  !-- Default is none.
    real(r_kind), intent(in), optional :: format_parameters(:)
         !-- Format-specific parameters.
         !-- For cmp3, first parameter is data precision (3, 4, or 8).
         !-- Zero or omitted data precision defaults to 3.
    logical, intent(out) :: error             !-- Returns true if open fails.

    !-------------------- local.
    integer :: iostat, open_size, rec_len, i, title_len
    integer :: n_signals
    character :: temp_char*16, where*8
    type(block_type), pointer :: index_block
    type(byte_type) :: header_data(80)  !-- Big enough for title.
    type(byte_type) :: names_header(size(signal_names)*16)

    !-------------------- executable code.

    !-- Allocate the gen array and cmp3 record.
    where = 'allocate'
    nullify(cmp3)
    i = size(transfer(cmp3_ptr, gen))
    allocate(gen(i), stat=iostat)
    if (iostat /= 0) goto 8000
    n_signals = size(signal_names)
    allocate(cmp3, stat=iostat)
    if (iostat /= 0) goto 8000
    cmp3_ptr%cmp3 => cmp3
    gen = transfer(cmp3_ptr, gen)
    cmp3%flush_on_close = .false.
    nullify(cmp3%last_value)
    allocate(cmp3%last_value(n_signals), stat=iostat)
    if (iostat /= 0) goto 8000

    !-- Open the file.
    where = 'open'
    call assign_lun(cmp3%lun)
    inquire(iolength=open_size) cmp3%data_block
    open(cmp3%lun, file=file_name, form='unformatted', iostat=iostat, &
         access='direct', recl=open_size, &
         status='replace', action='readwrite')
    if (iostat /= 0) goto 8000

    !-- Initialize various stuff.
    cmp3%base_time = 0.
    cmp3%time_scale = 1._r_kind/4096
    cmp3%time_key_offset = 2**20
    cmp3%full_frame_interval = 200
    cmp3%n_frames = 0
    cmp3%prev_full_frame = -cmp3%full_frame_interval - 1
    cmp3%first_time = 0.
    cmp3%last_time = 0.
    cmp3%last_value = 0.

    !-- Allocate and initialize the first header block.
    cmp3%n_blocks = 1
    cmp3%header_block%body = zero_byte
    cmp3%header_block_len = 0
    call put_i1(cmp3%header_block%body, cmp3%header_block_len, &
         header_block_code)
    cmp3%header_block_num = 1
    cmp3%header_block_len = block_head_len

    !-- Set data precision.
    where = 'precision'
    cmp3%data_precision = 3
    if (present(format_parameters)) then
      if (size(format_parameters)>=1) cmp3%data_precision=format_parameters(1)
    end if
    if (cmp3%data_precision == 0) cmp3%data_precision = 3
    if ( (cmp3%data_precision /= 3) .and. (cmp3%data_precision /= 4) .and. &
         (cmp3%data_precision /= 8)) goto 8000

    !---------- write header records.
    where = 'headers'

    !-- format header.
    rec_len = 0
    temp_char(1:8) = 'cmp 3'
    temp_char(9:16) = '.2'
    call put_char(header_data, rec_len, temp_char)
    call put_header(3, 'format', header_data, rec_len, error)
    if (error) goto 8000

    !-- blocks header.
    !-- Dummy for now.  Will be rewritten on close.
    header_data = zero_byte
    call put_header(0, 'blocks', header_data, 28, error)
    if (error) goto 8000

    !-- nChans header.
    rec_len = 0
    i = n_signals
    if (cmp3%data_precision /= 3) i = i + 65536*cmp3%data_precision
    call put_i4(header_data, rec_len, i)
    call put_header(1, 'nChans', header_data, rec_len, error)
    if (error) goto 8000

    !-- timeKey header.
    rec_len = 0
    call put_r8(header_data, rec_len, cmp3%base_time)
    call put_r8(header_data, rec_len, cmp3%time_scale)
    call put_i4(header_data, rec_len, cmp3%time_key_offset)
    call put_i4(header_data, rec_len, cmp3%full_frame_interval)
    call put_header(0, 'timeKey', header_data, rec_len, error)
    if (error) goto 8000

    !-- names header.
    !-- Note this is the first header without a hard-wired length.
    rec_len = 0
    do i = 1 , n_signals
      temp_char = signal_names(i)
      call put_char(names_header, rec_len, temp_char)
    end do
    call put_header(67, 'names', names_header, rec_len, error)
    if (error) goto 8000

    !-- optional title header.
    if (present(file_title)) then
      title_len = min(80,len_trim(file_title))
      if (title_len > 0) then
        rec_len = 0
        call put_char(header_data, rec_len, file_title(:title_len))
        call put_header(3, 'title', header_data, rec_len, error)
        if (error) goto 8000
      end if
    end if

    !-- optional dt header.
    if (present(dt)) then
      if (dt > 0.) then
        rec_len = 0
        call put_r4(header_data,rec_len,dt)
        call put_header(2, 'dt', header_data, rec_len, error)
        if (error) goto 8000
      end if
    end if

    !-- optional units header.
    if (present(eu_names)) then
      rec_len = 0
      do i = 1 , n_signals
        temp_char = eu_names(i)
        call put_char(names_header, rec_len, temp_char)
      end do
      call put_header(67, 'units', names_header, rec_len, error)
      if (error) goto 8000
    end if

    !-- Flush the last (so far) header block.
    call write_block(cmp3%lun, cmp3%header_block, cmp3%header_block_num, error)
    if (error) goto 8000

    !-- Initialize an empty index.
    cmp3%n_keys = 0
    cmp3%index_count = 0
    cmp3%index_div = 1

    !-- Allocate and write an empty index block.
    !-- Use the data_block array as it's not currently otherwise in use.
    index_block => cmp3%data_block
    cmp3%n_blocks = cmp3%n_blocks + 1
    cmp3%first_index_block = cmp3%n_blocks
    cmp3%n_index_blocks = 1
    index_block%body = zero_byte
    cmp3%index_block_len = 0
    call put_i1(index_block%body, cmp3%index_block_len, index_block_code)
    cmp3%index_block_num = cmp3%n_blocks
    cmp3%index_block_len = block_head_len
    call write_block(cmp3%lun, index_block, cmp3%index_block_num, error)
    if (error) goto 8000

    !-- Allocate and initialize the first data block.
    cmp3%n_blocks = cmp3%n_blocks + 1
    cmp3%first_data_block = cmp3%n_blocks
    cmp3%data_block%body = zero_byte
    cmp3%data_block_len = 0
    call put_i1(cmp3%data_block%body, cmp3%data_block_len, data_block_code)
    cmp3%data_block_num = cmp3%n_blocks
    cmp3%data_block_len = block_head_len

    !---------- Normal exit.
    cmp3%flush_on_close = .true.
    error = .false.
    return

    !---------- Error exit.
    8000 continue
    if (iostat /= 0) call write_sys_error(iostat)
    call write_error_msg('Open_th_write_cmp3 failed at: '//where)
    if (associated(cmp3)) call close_th_write_cmp3(gen, error)
    error = .true.
    return
  end subroutine open_th_write_cmp3

  subroutine close_th_write_cmp3 (gen, error)

    !-- Close an output cmp3 file.
    !-- 15 Jun 90, Richard Maine.

    !-------------------- interface.
    integer, pointer  :: gen(:)  !-- Generic array for format-specific data.
    logical, intent(out) :: error

    !-------------------- local.
    integer, parameter :: eod_key = 2**30
    integer :: rec_flags, rec_len, i
    integer :: end_of_header, end_of_data
    type(block_type), pointer :: index_block
    type(byte_type) :: header_data(32)  !-- Big enough for blocks header.

    !-------------------- executable code.

    cmp3_ptr = transfer(gen, cmp3_ptr)
    cmp3 => cmp3_ptr%cmp3

    error = .false.
    if (.not. cmp3%flush_on_close) goto 8000

    !-- Write an end-of-data frame.
    rec_flags = eod_flag
    call put_frame(eod_key, rec_flags, error=error)
    if (error) goto 8000

    !-- Flush the last data block.
    call write_block(cmp3%lun, cmp3%data_block, cmp3%data_block_num, error)
    if (error) goto 8000
    end_of_data = (cmp3%data_block_num-1)*block_size + cmp3%data_block_len

    !-- Rewrite the index block.
    !-- Use the data_block array as it's not currently otherwise in use.
    index_block => cmp3%data_block
    index_block%body = zero_byte
    cmp3%index_block_len = 0
    call put_i1(index_block%body, cmp3%index_block_len, index_block_code)
    cmp3%index_block_num = cmp3%first_index_block
    cmp3%index_block_len = block_head_len
    call put_i1(index_block%body, cmp3%index_block_len, cmp3%n_keys)
    cmp3%index_block_len = 8
    do i = 1 , cmp3%n_keys
      call put_i4(index_block%body, cmp3%index_block_len, cmp3%index_key(i))
      call put_i4(index_block%body, cmp3%index_block_len, cmp3%index_pos(i))
    end do
    call write_block(cmp3%lun, index_block, cmp3%index_block_num, error)
    if (error) goto 8000

    !---------- Add final headers.
    !-- times header.
    rec_len = 0
    call put_r8(header_data, rec_len, cmp3%first_time)
    call put_r8(header_data, rec_len, cmp3%last_time)
    call put_i4(header_data, rec_len, cmp3%n_frames)
    call put_header(0, 'times', header_data, rec_len, error)
    if (error) goto 8000
    !-- endHead header.
    call put_header(0, 'endHead', error=error)
    if (error) goto 8000

    !-- Flush the last header block.
    call write_block(cmp3%lun, cmp3%header_block, cmp3%header_block_num, error)
    if (error) goto 8000

    !-- Update the blocks header.
    end_of_header = (cmp3%header_block_num-1)*block_size &
         + cmp3%header_block_len
    call read_block(cmp3%lun, 1, cmp3%header_block, error)
    if (error) goto 8000
    rec_len = 0
    call put_i4(header_data, rec_len, block_size)
    call put_i4(header_data, rec_len, cmp3%n_blocks)
    call put_i4(header_data, rec_len, end_of_header)
    call put_i4(header_data, rec_len, cmp3%first_index_block)
    call put_i4(header_data, rec_len, cmp3%n_index_blocks)
    call put_i4(header_data, rec_len, cmp3%first_data_block)
    call put_i4(header_data, rec_len, end_of_data)
    !-- Hard-wired location in first header block.
    !-- 31 = 4(block header) + 11 (format record header)
    !--      + 16 (format record body)
    cmp3%header_block_len = 31
    call put_header(0, 'blocks', header_data, rec_len, error)
    if (error) goto 8000
    call write_block(cmp3%lun, cmp3%header_block, 1, error)
    if (error) goto 8000

    !-- Close the file and release the lun and info area.
    8000 continue
    close(cmp3%lun)
    call release_lun(cmp3%lun)
    if (associated(cmp3%last_value)) deallocate(cmp3%last_value)
    deallocate(cmp3)
    return
  end subroutine close_th_write_cmp3

  subroutine write_th_cmp3 (gen, time, data, error)

    !-- Write a frame to a cmp3 file.
    !-- 10 Dec 92, Richard Maine.

    !-------------------- interface.
    integer, pointer  :: gen(:)  !-- Generic array for format-specific data.
    real(r_kind), intent(in) :: time     !-- Frame time.
    real(r_kind), intent(in) :: data(:)  !-- Frame data.
    logical, intent(out) :: error

    !-------------------- local.
    integer :: time_key, chan, data_len, data_pos
    integer :: n_signals, n_changes, bit_map_len
    type(byte_type) :: packed_data(8*size(data))
    type(byte_type) :: change_list(size(data)+1)
    type(byte_type) :: bit_map((size(data)-1)/8+1)
    real(r4_kind) :: temp_r4
    real(r_kind) :: new_value
    logical :: full_frame

    !-------------------- executable code.

    cmp3_ptr = transfer(gen, cmp3_ptr)
    cmp3 => cmp3_ptr%cmp3

    !-- Scale time.
    time_key = nint((time-cmp3%base_time)/cmp3%time_scale) &
         + cmp3%time_key_offset

    !-- Record frame counts and times.
    if (cmp3%n_frames == 0) cmp3%first_time = time
    cmp3%last_time = time
    cmp3%n_frames = cmp3%n_frames + 1

    n_signals = size(data)
    full_frame = cmp3%n_frames >= cmp3%prev_full_frame+cmp3%full_frame_interval

    !-- Pack data and generate bit map and change list.
    data_len = 0
    n_changes = 0
    bit_map = zero_byte
    bit_map_len = (n_signals-1)/8 + 1
    do chan = 1 , n_signals
      data_pos = data_len
      if (cmp3%data_precision == 3) then
        call put_r3(packed_data, data_len, real(data(chan),kind=r4_kind))
        call get_r3(packed_data, data_pos, temp_r4)
        new_value = real(temp_r4, kind=r_kind)
      else if (cmp3%data_precision == 4) then
        call put_r4(packed_data, data_len, data(chan))
        call get_r4(packed_data, data_pos, new_value)
      else
        call put_r8(packed_data, data_len, data(chan))
        new_value = data(chan)
      end if
      if (full_frame) then
        cmp3%last_value(chan) = new_value
      else if (new_value /= cmp3%last_value(chan)) then
        cmp3%last_value(chan) = new_value
        call put_i1(change_list, n_changes, chan)
        call set_bit(bit_map, chan)
      else
        data_len = data_len - cmp3%data_precision
      end if
    end do

    !---------- Write in appropriate format.
    !-- Full frame.
    if (full_frame) then
      cmp3%prev_full_frame = cmp3%n_frames
      call put_frame(time_key, full_frame_flag, packed_data, data_len, &
           error=error)
    !-- Change list.
    else if (n_signals<255 .and. n_changes<bit_map_len) then
      call put_i1(change_list, n_changes, 0)
      call put_frame(time_key, change_list_flag, packed_data, data_len, &
           change_list, n_changes, error)
    !-- Bit map.
    else
      call put_frame(time_key, bit_map_flag, packed_data, data_len, &
           bit_map, bit_map_len, error)
    end if
    return
  end subroutine write_th_cmp3

  subroutine put_header (data_code, header_name, header_data, data_len, &
       error)

    !-- Add a header record to a cmp3 file.
    !-- Requires that the cmp3 pointer be defined by calling routine.
    !-- 20 Jun 90, Richard Maine.

    !-------------------- interface.
    integer, intent(in) :: data_code
    character*(*), intent(in) :: header_name
    type(byte_type), intent(in), optional :: header_data(*)
         !-- Must be contiguous
    integer, optional, intent(in) :: data_len
         !-- Must be present if feader_data is.
    logical, intent(out) :: error

    !-------------------- local.
    integer :: rec_len, data_len_temp
    integer, parameter :: rec_header_len = 11
    type(byte_type) :: rec_header(rec_header_len)
    character :: padded_header_name*8

    !-------------------- executable code.

    data_len_temp = 0
    if (present(header_data)) data_len_temp = data_len

    !-- Record header.
    rec_len = 0
    call put_i2(rec_header, rec_len, rec_header_len+data_len_temp)
    call put_i1(rec_header, rec_len, data_code)
    padded_header_name = header_name
    call put_char(rec_header, rec_len, padded_header_name)
    call put_cmp3(rec_header, rec_header_len, cmp3%header_block, &
         cmp3%header_block_num, cmp3%header_block_len, error)
    if (error) return

    !-- Record data body.
    if (data_len_temp > 0) call put_cmp3(header_data, data_len_temp, &
         cmp3%header_block, cmp3%header_block_num, cmp3%header_block_len, &
         error)
    return
  end subroutine put_header

  subroutine put_frame (time_key, rec_flags, data_vec, data_vec_len, &
       chan_vec, chan_vec_len, error)

    !-- Add a data frame to a cmp3 file.
    !-- Requires that the cmp3 pointer be defined by calling routine.
    !-- 20 Jun 90, Richard Maine.

    !-------------------- interface.
    integer, intent(in) :: time_key
    integer, intent(in) :: rec_flags
    type(byte_type), optional, intent(in) :: data_vec(*)
         !-- Must be contiguous
    integer, optional, intent(in) :: data_vec_len
         !-- Must be present if data_vec is.
    type(byte_type), optional, intent(in) :: chan_vec(*)
         !-- Must be contiguous
    integer, optional, intent(in) :: chan_vec_len
         !-- Must be present if chan_vec is.
    logical, intent(out) :: error

    !-------------------- local.
    integer :: rec_len, data_pos, tot_len
    integer, parameter :: rec_header_len = 7
    type(byte_type) :: rec_header(rec_header_len)

    !-------------------- executable code.

    !-- Index full frames and end-of-data frame.
    if (rec_flags == full_frame_flag .or. rec_flags == eod_flag) then
      data_pos = (cmp3%data_block_num-1)*block_size + cmp3%data_block_len
      call add_key(time_key, data_pos, rec_flags/=eod_flag)
    end if

    !-- Record header.
    rec_len = 0
    tot_len = rec_header_len
    if (present(data_vec)) tot_len = tot_len + data_vec_len
    if (present(chan_vec)) tot_len = tot_len + chan_vec_len
    call put_i2(rec_header, rec_len, tot_len)
    call put_i4(rec_header, rec_len, time_key)
    call put_i1(rec_header, rec_len, rec_flags)
    call put_cmp3(rec_header, rec_header_len, cmp3%data_block, &
         cmp3%data_block_num, cmp3%data_block_len, error)
    if (error) return

    !-- Channel flags and data.
    if (present(chan_vec)) call put_cmp3(chan_vec, chan_vec_len, &
         cmp3%data_block, cmp3%data_block_num, cmp3%data_block_len, error)
    if (error) return
    if (present(data_vec)) call put_cmp3(data_vec, data_vec_len, &
         cmp3%data_block, cmp3%data_block_num, cmp3%data_block_len, error)
    return
  end subroutine put_frame

  subroutine add_key (time_key, data_pos, may_thin)

    !-- Add an index key to a cmp3 file.
    !-- Requires that the cmp3 pointer be defined by calling routine.
    !-- 20 Jun 90, Richard Maine.

    !-------------------- interface.
    integer, intent(in) :: time_key
    integer, intent(in) :: data_pos
    logical, intent(in) :: may_thin

    !-------------------- executable code.

    !-- Count and thin entries.
    cmp3%index_count = cmp3%index_count + 1
    if (mod(cmp3%index_count-1,cmp3%index_div) /= 0 .and. may_thin) return

    !-- Add this entry.
    cmp3%n_keys = cmp3%n_keys + 1
    cmp3%index_key(cmp3%n_keys) = time_key
    cmp3%index_pos(cmp3%n_keys) = data_pos

    !-- If all entries are used, thin them further.
    if (cmp3%n_keys >= max_index .and. may_thin) then
      cmp3%index_div = 2*cmp3%index_div
      cmp3%n_keys = max_index/2 + 1
      cmp3%index_key(1:cmp3%n_keys) = cmp3%index_key(::2)
      cmp3%index_pos(1:cmp3%n_keys) = cmp3%index_pos(::2)
      cmp3%index_key(cmp3%n_keys+1:) = 0
      cmp3%index_pos(cmp3%n_keys+1:) = 0
    end if
    return
  end subroutine add_key

  subroutine put_cmp3 (data, data_len, block, block_num, block_len, error)

    !-- Put bytes into a cmp3 header block or data block.
    !-- Flush full blocks and start new ones as needed.
    !-- Requires that the cmp3 pointer be defined by calling routine.
    !-- 20 Jun 90, Richard Maine.

    !-------------------- interface.
    type(byte_type), intent(in) :: data(*)  !-- Must be contiguous.
    integer, intent(in) :: data_len
    type(block_type), intent(inout) :: block
    integer, intent(inout) :: block_num
         !-- Current block number.
         !-- Updated on return if a new block is started.
    integer, intent(inout) :: block_len
         !-- Currently used length of the block.
    logical, intent(out) :: error

    !-------------------- local.
    integer :: done_len, part_len

    !-------------------- executable code.

    error = .false.
    done_len = 0

    block_loop: do

      !-- Put as much as fits in current block.
      part_len = min(data_len-done_len,block_size-block_len)
      if (part_len /= 0) call copy_bytes &
           (data, done_len, block%body, block_len, part_len)

      !-- Exit loop if done.
      if (done_len >= data_len) exit block_loop

      !-- Allocate a new block and chain forward to it.
      cmp3%n_blocks = cmp3%n_blocks + 1
      block_len = 1
      call put_i3(block%body, block_len, cmp3%n_blocks)

      !-- Flush the old block.
      call write_block(cmp3%lun, block, block_num, error)
      if (error) return

      !-- Clear the new block.
      block%body(2:) = zero_byte  !-- Don't wipe block code in the first byte.
      block_num = cmp3%n_blocks
      block_len = block_head_len
    end do block_loop
    return
  end subroutine put_cmp3

  subroutine write_block (lun, block, block_num, error)

    !-- Write a block to a cmp3 file.
    !-- 21 Jun 90, Richard Maine.

    !-------------------- interface.
    integer, intent(in) :: lun  !-- Logical unit number
    type(block_type), intent(inout) :: block
    integer, intent(in) :: block_num
    logical, intent(out) :: error

    !-------------------- local.
    integer :: iostat

    !-------------------- executable code.

    !-- Write to the file.
    write(lun, rec=block_num, iostat=iostat) block
    error = iostat /= 0
    if (error) then
      call write_sys_error(iostat)
      call write_error_msg('Error writing cmp3 file.')
    end if
    return
  end subroutine write_block

  subroutine read_block (lun, block_num, block, error)

    !-- Read a block from a cmp3 file.
    !-- This is identical to the one in the th_read_cmp3 module,
    !-- but we want to keep the read and write modules independent.
    !-- 21 Jun 90, Richard Maine.

    !-------------------- interface.
    integer, intent(in) :: lun  !-- Logical unit number
    integer, intent(in) :: block_num
    type(block_type), intent(out) :: block
    logical, intent(out) :: error

    !-------------------- local.
    integer :: iostat

    !-------------------- executable code.

    !-- Read from the file.
    read(lun, rec=block_num, iostat=iostat) block
    error = iostat /= 0
    if (error) then
      call write_sys_error(iostat)
      call write_error_msg('Error rewriting cmp3 file.')
      return
    end if
    return
  end subroutine read_block

end module th_write_cmp3