module READCB_m

! Read column binary "deck" from Brian Knittel.

! Each "card" is in a 160-byte record.  Each column is stored in two
! bytes, with rows 12-5 in the high-order byte, and rows 6-9 in the
! high-order four bits of the low-order byte.

  implicit NONE
  private

  public :: OPENCB, READCB, READRAW, CLOSECB

  integer, save :: FilePos = 0, SeqNo = 0
  logical, public :: Dump = .false.  ! Dump each record as read.
  logical, public :: Quiet = .false. ! Don't check or report Column Binary stuff

contains

  subroutine OPENCB ( FILE, UNIT, IOSTAT, REC1 )

  ! Open FILE for direct access using 160-byte records.  Attach it to
  ! UNIT.  Set FilePos = 0.  The status from the OPEN is returned in
  ! IOSTAT

    character(len=*), intent(in) :: FILE
    integer, intent(in) :: UNIT
    integer, intent(out), optional :: IOSTAT
    integer, intent(in), optional :: REC1 ! Start here, default 1

    character(len=160) :: BUF ! only to get the length for the OPEN statement
    integer :: IOLENGTH
    integer :: MyCol, MyRec

    filePos = 0
    seqNo = 0

    if ( present(rec1) ) filePos = rec1 - 1
    inquire ( iolength=iolength ) buf
    if ( present(iostat) ) then
      open ( unit, file=file, access='direct', recl=iolength, status='old', &
        & form='unformatted', iostat=iostat )
    else
      open ( unit, file=file, access='direct', recl=iolength, status='old', &
        & form='unformatted' )
    end if

  end subroutine OPENCB

  subroutine READRAW ( UNIT, REC, COLS, IOSTAT )

  ! Read 160-byte record REC from UNIT.  Store it in COLS with bits 11-0 in
  ! each word being rows 12, 11, 0 ... 9, respectively/

    integer, intent(in) :: UNIT
    integer, intent(in) :: REC
    integer, intent(out) :: COLS(80)
    integer, intent(out), optional :: IOSTAT ! Status from the READ statement.

    character(len=160) :: BUF
    integer :: I

    if ( present(iostat) ) then
      read ( unit, rec=rec, iostat=iostat ) buf
      if ( iostat /= 0 ) return
    else 
      read ( unit, rec=rec ) buf ! Let the system crash it if error
    end if

    do i = 2, 160, 2
      ! Little Endian
      cols(i/2) = ishft(256 * ichar(buf(i:i)) + ichar(buf(i-1:i-1)),-4)
    end do

  end subroutine READRAW

  subroutine READCB ( UNIT, BUF, IOSTAT )

  ! Read a 160-byte record from UNIT.  Break the two-byte column data into
  ! two 6-bit quantities, for rows 12-3 and rows 4-9, respectively, and
  ! put each column into an element of BUF, with rows 12-9 in bits 12-9,
  ! respectively.

    integer, intent(in) :: UNIT
    character(len=156), intent(out) :: BUF
    integer, intent(out), optional :: IOSTAT ! Status from the READ statement.
      ! Since EOF and EOR can't occur for direct-access unformatted reads,
      ! negative values have the following meanings:
      !  -1  Not column binary
      !  -2  Checksum doesn't check
      !  -3  Out of sequence

    integer :: CBMASK
    data CBMASK / O'3000' / ! Column binary if rows 11-0 set
    integer :: CKMASK
    data CKMASK / O'0400' / ! Checksum if row 1 set
    integer :: CKSUM        ! to accumulate checksum
    integer :: COLS(80)     ! Columns, i.e. two bytes from the buffer as read.
                            ! Rows 12-9 in bits 12-0.
    integer :: I            ! Loop index and substring index
    character(len=160) :: MyBuf
    integer :: T            ! Test for sequence number

1   format ( a, :, i0, :, a, :, i0, :, a, :, i0 )

    filePos = filePos + 1
    if ( present(iostat) ) then
      read ( unit, rec=filePos, iostat=iostat ) myBuf
      if ( iostat /= 0 ) return
    else 
      read ( unit, rec=filePos ) myBuf ! Let the system crash it if error
    end if

    do i = 2, 160, 2
      ! Little Endian
      cols(i/2) = ishft(256 * ichar(myBuf(i:i)) + ichar(myBuf(i-1:i-1)),-4)
    end do

    if ( dump ) print '(16o5.4)', cols

    if ( .not. quiet ) then

      ! Check whether column binary
      if ( iand(cols(1),cbmask) /= cbmask ) then
        print 1, 'Record ', filePos, ' is not column binary'
        call setstat ( iostat, -1 )
      end if

      ! Check for checksum
      if ( iand(cols(1),ckmask) == ckmask ) then
        cksum = cols(2)
        do i = 3, 80
          cksum = ieor(cksum, cols(i))
        end do
        if ( cksum /= 0 ) then
          print 1, 'Record ', filePos, ' checksum does not check'
          call setstat ( iostat, -2 )
        end if
      end if

      ! Check sequence number
      t = iand(cols(1),255)
      seqno = mod(seqno+1,256)
      if ( t /= seqno ) then
        print 1, 'Record ', filePos, ' out of sequence.  Expected ', seqno, &
          & ', got ', t
        seqno = t
        call setstat ( iostat, -3 )
      end if

    end if ! .not. quiet

    ! Convert COLS to BUF
    do i = 3, 80
      buf(2*i-5:2*i-5) = char(ishft(cols(i),-6)) ! Rows 12-3
      buf(2*i-4:2*i-4) = char(iand(cols(i),63))  ! Rows 4-9
    end do

  contains
    subroutine SetStat ( IOSTAT, SET )
      integer, intent(out), optional :: IOSTAT
      integer, intent(in) :: SET
      print '(16o5.4)', cols
      if ( .not. present(iostat) ) stop
      iostat = set
    end subroutine SetStat
  end subroutine READCB

  subroutine CLOSECB ( UNIT, IOSTAT )

  ! Close the file indicated by UNIT.  Set FilePos = 0.  Return the status
  ! in IOSTAT if present.

    integer, intent(in) :: UNIT
    integer, intent(out), optional :: IOSTAT

    if ( present(iostat) ) then
      close ( unit, iostat=iostat )
    else
      close ( unit )
    end if

    filePos = 0

  end subroutine CLOSECB

end module READCB_m
