C**********************************************************************
C**********************************************************************
C** 
C**  File: writebin.for
C**
C**  Description: Routines for writing binary files.
C**
C**  Date: 17th July 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     Routine: WRITE_BIN_FILE
C
C     Description:
C        Writes NUMBYTES bytes from BUFFER to a binary file called
C        NAME. Returns non-zero if the write fails.
C
C**********************************************************************
      INTEGER FUNCTION WRITE_BIN_FILE(NAME, BUFFER, NUMBYTES)
      IMPLICIT NONE
C
C     Parameters
C
      CHARACTER*(*) NAME        ! File name
      INTEGER       NUMBYTES    ! Number of bytes in buffer
      BYTE          BUFFER(NUMBYTES)   ! The data to write
C
C
      OPEN(UNIT=11, FILE=NAME, STATUS='UNKNOWN', FORM='UNFORMATTED',
     $     ACCESS='DIRECT', RECL=NUMBYTES, ERR=901)
C
      WRITE(UNIT=11, REC=1, ERR=902) BUFFER
      CLOSE(UNIT=11)
      WRITE_BIN_FILE = 0
      RETURN
C
C     Error trap
C
 901  WRITE(*,*) '** Error opening file for output: ', NAME
      WRITE_BIN_FILE = 1
      RETURN
 902  WRITE(*,*) '** Error while writing file: ', NAME
      WRITE_BIN_FILE = 2
      RETURN
      END
C
C
C
C**********************************************************************
C     Routine: WRITE_BIN_UINT16
C
C     Description:
C        Writes an unsigned 16-bit integer to BUFFER. The bytes
C        will be swapped if SWAP is true. The function returns
C        the number of bytes written to BUFFER.
C        
C**********************************************************************
      INTEGER FUNCTION WRITE_BIN_UINT16(BUFFER, DATA, SWAP)
      IMPLICIT NONE
C
C     Parameters
C
      BYTE      BUFFER(2)
      INTEGER   DATA
      LOGICAL   SWAP
C
C     Variables
C
      BYTE         TMPBUF(2)
      INTEGER*2    I2
      EQUIVALENCE (TMPBUF, I2)
C
      IF (DATA .LT. 0) THEN
         I2 = 0
      ELSE IF (DATA .GT. 65535) THEN
         I2 = 65535
      ELSE
         I2 = DATA
      ENDIF
C
      IF (SWAP) THEN
         BUFFER(1) = TMPBUF(2)
         BUFFER(2) = TMPBUF(1)
      ELSE
         BUFFER(1) = TMPBUF(1)
         BUFFER(2) = TMPBUF(2)
      ENDIF
C
      WRITE_BIN_UINT16 = 2
      RETURN
      END
C
C
C
C**********************************************************************
C     Routine: WRITE_BIN_INT16
C
C     Description:
C        Writes a signed 16-bit integer to BUFFER. The bytes
C        will be swapped if SWAP is true. The function returns
C        the number of bytes written to BUFFER.
C        
C**********************************************************************
      INTEGER FUNCTION WRITE_BIN_INT16(BUFFER, DATA, SWAP)
      IMPLICIT NONE
C
C     Parameters
C
      BYTE      BUFFER(2)
      INTEGER   DATA
      LOGICAL   SWAP
C
C     Variables
C
      BYTE         TMPBUF(2)
      INTEGER*2    I2
      EQUIVALENCE (TMPBUF, I2)
C
      IF (DATA .LT. -32768) THEN
         I2 = -32768
      ELSE IF (DATA .GT. 32767) THEN
         I2 = 32767
      ELSE
         I2 = DATA
      ENDIF
C
      IF (SWAP) THEN
         BUFFER(1) = TMPBUF(2)
         BUFFER(2) = TMPBUF(1)
      ELSE
         BUFFER(1) = TMPBUF(1)
         BUFFER(2) = TMPBUF(2)
      ENDIF
C
      WRITE_BIN_INT16 = 2
      RETURN
      END
C
C
C
C**********************************************************************
C     Routine: WRITE_BIN_UINT32
C
C     Description:
C        Writes an unsigned 32-bit integer to BUFFER. The bytes
C        will be swapped if SWAP is true. The function returns
C        the number of bytes written to BUFFER.
C        
C**********************************************************************
      INTEGER FUNCTION WRITE_BIN_UINT32(BUFFER, DATA, SWAP)
      IMPLICIT NONE
C
C     Parameters
C
      BYTE      BUFFER(4)
      INTEGER   DATA
      LOGICAL   SWAP
C
C     Variables
C
      BYTE         TMPBUF(4)
      INTEGER*4    I4
      EQUIVALENCE (TMPBUF, I4)
C
      IF (DATA .LT. 0) THEN
         I4 = 0
      ELSE
         I4 = DATA
      ENDIF
C
      IF (SWAP) THEN
         BUFFER(1) = TMPBUF(4)
         BUFFER(2) = TMPBUF(3)
         BUFFER(3) = TMPBUF(2)
         BUFFER(4) = TMPBUF(1)
      ELSE
         BUFFER(1) = TMPBUF(1)
         BUFFER(2) = TMPBUF(2)
         BUFFER(3) = TMPBUF(3)
         BUFFER(4) = TMPBUF(4)
      ENDIF
C
      WRITE_BIN_UINT32 = 4
      RETURN
      END
C
C
C
C**********************************************************************
C     Routine: WRITE_BIN_INT32
C
C     Description:
C        Writes an signed 32-bit integer to BUFFER. The bytes
C        will be swapped if SWAP is true. The function returns
C        the number of bytes written to BUFFER.
C        
C**********************************************************************
      INTEGER FUNCTION WRITE_BIN_INT32(BUFFER, DATA, SWAP)
      IMPLICIT NONE
C
C     Parameters
C
      BYTE      BUFFER(4)
      INTEGER   DATA
      LOGICAL   SWAP
C
C     Variables
C
      BYTE         TMPBUF(4)
      INTEGER*4    I4
      EQUIVALENCE (TMPBUF, I4)
C
      I4 = DATA
C
      IF (SWAP) THEN
         BUFFER(1) = TMPBUF(4)
         BUFFER(2) = TMPBUF(3)
         BUFFER(3) = TMPBUF(2)
         BUFFER(4) = TMPBUF(1)
      ELSE
         BUFFER(1) = TMPBUF(1)
         BUFFER(2) = TMPBUF(2)
         BUFFER(3) = TMPBUF(3)
         BUFFER(4) = TMPBUF(4)
      ENDIF
C
      WRITE_BIN_INT32 = 4
      RETURN
      END
C
C
C
C**********************************************************************
C     Routine: WRITE_BIN_REAL
C
C     Description:
C        Writes a 32-bit real to BUFFER. The bytes will be swapped
C        if SWAP is true. The function returns the number of bytes
C        written to BUFFER.
C        
C**********************************************************************
      INTEGER FUNCTION WRITE_BIN_REAL(BUFFER, DATA, SWAP)
      IMPLICIT NONE
C
C     Parameters
C
      BYTE    BUFFER(4)
      REAL    DATA
      LOGICAL SWAP
C
C     Variables
C
      BYTE         TMPBUF(4)
      REAL         R4
      EQUIVALENCE (TMPBUF, R4)
C
      R4 = DATA
C
      IF (SWAP) THEN
         BUFFER(1) = TMPBUF(4)
         BUFFER(2) = TMPBUF(3)
         BUFFER(3) = TMPBUF(2)
         BUFFER(4) = TMPBUF(1)
      ELSE
         BUFFER(1) = TMPBUF(1)
         BUFFER(2) = TMPBUF(2)
         BUFFER(3) = TMPBUF(3)
         BUFFER(4) = TMPBUF(4)
      ENDIF
C
      WRITE_BIN_REAL = 4
      RETURN
      END
C
C
C
C**********************************************************************
C     Routine: WRITE_BIN_STRING
C
C     Description:
C        Writes the string in DATA to BUFFER
C        
C**********************************************************************
      INTEGER FUNCTION WRITE_BIN_STRING(BUFFER, DATA)
      IMPLICIT NONE
C
C     Parameters
C
      CHARACTER*(*) DATA
      BYTE          BUFFER(*)
C
C     Variables
C
      INTEGER I
C
      DO I = 1, LEN(DATA)
          BUFFER(I) = ICHAR(DATA(I:I))
      ENDDO
      WRITE_BIN_STRING = I - 1
      RETURN
      END
C