C**********************************************************************
C**********************************************************************
C** 
C**  File: readbin.for
C**
C**  Description: Routines for reading binary files.
C**
C**  Date: 8th January 2004
C**
C**********************************************************************
C**
C** Copyright (c) 2004 Scott A. Belmonte
C** All rights reserved.
C**
C** Redistribution and use in source and binary forms, with or without 
C** modification, are permitted provided that the following conditions
C** are met:
C**
C** Redistributions of source code must retain the above copyright
C** notice, this list of conditions and the following disclaimer.
C**
C** Redistributions in binary form must reproduce the above copyright
C** notice, this list of conditions and the following disclaimer in
C** the documentation and/or other materials provided with the
C** distribution.
C**
C** Neither the name of the copyright holder nor the names of any
C** contributors may be used to endorse or promote products derived
C** from this software without specific prior written permission.
C**
C** THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND
C** CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,
C** INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
C** MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
C** DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS
C** BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
C** EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
C** TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
C** DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON
C** ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR
C** TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF
C** THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
C** SUCH DAMAGE.
C**
C**********************************************************************
C**********************************************************************
C
C
C**********************************************************************
C     Routine: OPEN_BIN_FILE
C
C     Description:
C        Opens a binary file whose name is stored in NAME.
C
C        NB. Uses a fixed unit number. This means only one file
C        can be open at a time. CLOSE_BIN_FILE must be called
C        before OPEN_BIN_FILE can be called again.
C
C
C        Returns: 0 file successfully opened, 
C                 1 error opening file
C**********************************************************************
      INTEGER FUNCTION OPEN_BIN_FILE(NAME)
      IMPLICIT NONE
      INCLUDE 'readbin.inc'
C
C     Parameters
C
      CHARACTER*(*) NAME        ! File name
C
C     Functions
C
      LOGICAL BIGEND_CPU
C
C     Variables
C
      LOGICAL   OPEN            ! .TRUE. if a file is already open
C
C     Initialise the LAST_REC common. 0 means that BUFFER contains
C     no valid record.
C
      LAST_REC = 0
C
C     Check that a file isn't currently open. These routines
C     can only work with one file at a time.
C
      INQUIRE(UNIT=UNT, OPENED=OPEN)
      IF (OPEN) THEN
         WRITE(*,*) '** OPEN_BIN_FILE error: File already opened.'
         WRITE(*,*) '** Only one file can be opened at a time.'
         GOTO 901
      ENDIF
C
C     Open file
C
      OPEN(UNIT=UNT, FILE=NAME, STATUS='OLD', FORM='UNFORMATTED',
     $     ACCESS='DIRECT', RECL=REC_SIZE, ERR=901)
      REWIND(UNIT=UNT)
C
      OPEN_BIN_FILE = 0
      RETURN
C
C     Error traps
C
 901  OPEN_BIN_FILE = 1        ! Error opening file
      RETURN
      END
C
C
C**********************************************************************
C     Routine: CLOSE_BIN_FILE
C
C     Description:
C        Closes the binary file.
C**********************************************************************
      SUBROUTINE CLOSE_BIN_FILE()
      IMPLICIT NONE
      INCLUDE 'readbin.inc'
C
      CLOSE(UNIT=UNT)
      END
C
C
C**********************************************************************
C     Routine: READ_BIN_FILE
C
C     Description:
C        Reads bytes START_BYTE to END_BYTE, inclusive, from a binary
C        file into the array DATA.
C        NB. START_BYTE and END_BYTE are zero offset.
C     
C        Returns 0 if successful, 1 otherwise
C**********************************************************************
      INTEGER FUNCTION READ_BIN_FILE(DATA, START_BYTE, END_BYTE)
      IMPLICIT NONE
      INCLUDE 'readbin.inc'
C
C     Parameters
C     
      BYTE    DATA(*)           ! The array to read the bytes into
      INTEGER START_BYTE        ! The byte to start reading from
      INTEGER END_BYTE          ! The byte to finish reading at.
C
C     Functions
C
      INTEGER READ_BIN_RECORD
C
C     Variables
C          
      INTEGER START_REC         ! Start record
      INTEGER END_REC           ! End record
      INTEGER TOTAL_BYTES       ! The total number of bytes to read
      INTEGER NEXT_BYTE         ! The next byte to write into DATA
      INTEGER CUR_REC           ! Current record being read
      INTEGER SKIP_BYTES        ! Num bytes to skip in first record
      INTEGER NUM_BYTES         ! Num bytes to read from first record
      INTEGER STATUS            ! Status of the read
      INTEGER I                 ! Loop counter
C     
C     Check for errors in the parameters START_BYTE and END_BYTE.
C     
      IF ((START_BYTE .GT. END_BYTE) .OR. (START_BYTE .LT. 0)) THEN
         WRITE(*,*) '** READ_BIN_FILE Error: Bad START_BYTE or
     $        END_BYTE'
         WRITE(*,*) '** START = ', START_BYTE, ', END = ', END_BYTE
         GOTO 911
      ENDIF
C     
C     Calculate the first and last records that have to be read, and
C     the total number of bytes that have to be read.
C     
      START_REC   = 1 + START_BYTE/REC_SIZE
      END_REC     = 1 + END_BYTE/REC_SIZE
      TOTAL_BYTES = END_BYTE - START_BYTE + 1
C     
      NEXT_BYTE = 1
      CUR_REC   = START_REC
C     
C     Read the first record (unless it already is in BUFFER).  
C     
      STATUS = 0
      IF(CUR_REC .NE. LAST_REC) THEN
         READ(UNIT=UNT, REC=CUR_REC, IOSTAT=STATUS) BUFFER
      ENDIF
C     
C     Copy the required bytes from BUFFER to DATA.
C     
      SKIP_BYTES = START_BYTE - (START_REC - 1)*REC_SIZE
      NUM_BYTES  = MIN(REC_SIZE - SKIP_BYTES, TOTAL_BYTES)
      DO I = 1, NUM_BYTES
         DATA(I) = BUFFER(I + SKIP_BYTES)
      ENDDO
      NEXT_BYTE = NEXT_BYTE + NUM_BYTES
      IF(STATUS .NE. 0) GOTO 911
C     
C     Read anymore whole records directly into DATA.
C     
      DO CUR_REC = START_REC + 1, END_REC - 1
         STATUS = READ_BIN_RECORD(DATA(NEXT_BYTE), CUR_REC)
         IF(STATUS .NE. 0) GOTO 911
         NEXT_BYTE = NEXT_BYTE + REC_SIZE
      ENDDO
C     
C     If needed, read the last record into BUFFER, then transfer to DATA.
C     
      CUR_REC = END_REC
      IF (CUR_REC .NE. START_REC) THEN
         READ(UNIT=UNT, REC=CUR_REC, IOSTAT=STATUS) BUFFER
         DO I = NEXT_BYTE, TOTAL_BYTES
            DATA(I) = BUFFER(I - NEXT_BYTE + 1)
         ENDDO
      ENDIF
C     
C     Store the number of the record that BUFFER contains, then return.
C     
      LAST_REC = CUR_REC
      READ_BIN_FILE = 0
      RETURN
C     
C     Error occured. Set LAST_REC = 0 so we don't reuse BUFFER contents.
C
C     Ignore errors that occur when reading END_REC since this
C     might be the last record in the file and may cause an error
C     because it is less than REC_SIZE in size.
C     
 911  IF (CUR_REC .EQ. END_REC) THEN
         LAST_REC = CUR_REC
         READ_BIN_FILE = 0
      ELSE
         LAST_REC = 0
         READ_BIN_FILE = 1
      ENDIF
      RETURN
C     
      END
C
C
C
C**********************************************************************
C     Routine: READ_BIN_RECORD
C
C     Description:
C        Reads the record RECORD for the open file on unit UNT into
C        ARRAY.
C     
C        Returns 0 if successful, 1 otherwise
C**********************************************************************
      INTEGER FUNCTION READ_BIN_RECORD(ARRAY, RECORD)
      IMPLICIT NONE
      INCLUDE 'readbin.inc'
C
C     Parameters
C
      BYTE    ARRAY(REC_SIZE)
      INTEGER RECORD
C
C     Variables
C
      INTEGER STATUS
C
      READ(UNIT=UNT, REC=RECORD, IOSTAT=STATUS) ARRAY
      READ_BIN_RECORD = STATUS
      RETURN
      END
C
C
C**********************************************************************
C     Routine: READ_BIN_SHORT
C
C     Description:
C        Converts the 2 bytes in RAW to INTEGER swapping
C        the bytes if necessary.
C**********************************************************************
      INTEGER FUNCTION READ_BIN_SHORT(RAW)
      IMPLICIT NONE
      INCLUDE 'readbin.inc'
C
C     Parameters
C     
      BYTE         RAW(2)
C
C     Variables
C
      BYTE         B(2)
      INTEGER*2    I2
      EQUIVALENCE (B, I2)
C
      IF (SWAP) THEN
         B(1) = RAW(2)
         B(2) = RAW(1)
      ELSE
         B(1) = RAW(1)
         B(2) = RAW(2)
      ENDIF
C
      READ_BIN_SHORT = I2
      RETURN
      END
C
C
C
C**********************************************************************
C     Routine: READ_BIN_LONG
C
C     Description:
C        Converts the 4 bytes in RAW to INTEGER swapping
C        the bytes if necessary.
C**********************************************************************
      INTEGER FUNCTION READ_BIN_LONG(RAW)
      IMPLICIT NONE
      INCLUDE 'readbin.inc'
C
C     Parameters
C     
      BYTE         RAW(4)
C
C     Variables
C          
      BYTE         B(4)
      INTEGER*4    I4
      EQUIVALENCE (B, I4)
C
      IF (SWAP) THEN
         B(1) = RAW(4)
         B(2) = RAW(3)
         B(3) = RAW(2)
         B(4) = RAW(1)
      ELSE
         B(1) = RAW(1)
         B(2) = RAW(2)
         B(3) = RAW(3)
         B(4) = RAW(4)
      ENDIF
C
      READ_BIN_LONG = I4
      RETURN
      END
C
C
C**********************************************************************
C     Routine: BIGEND_CPU
C
C     Description:
C        Returns .TRUE. if the machine is big endian
C**********************************************************************
      LOGICAL FUNCTION BIGEND_CPU()
      IMPLICIT NONE
C
C     Variables
C          
      BYTE         B(2)
      INTEGER*2    I2
      EQUIVALENCE (B, I2)
C
      I2 = 1
      BIGEND_CPU = (B(1) .NE. 1)
      RETURN
      END
C