*-----------------------------------------------------------------------
* raw.f - read and write raw audio files
* by Andy Allinger, 2016-2021, released to the public domain
*
*    Permission  to  use, copy, modify, and distribute this software and
*    its documentation  for  any  purpose  and  without  fee  is  hereby
*    granted,  without any conditions or restrictions.  This software is
*    provided "as is" without express or implied warranty.
*-----------------------------------------------------------------------

*-----------------------------------------------------------------------
* rmono - read audio in mono, 16 bit signed integer, little-endian
*
*___Name___Type_______________In/Out____Description_____________________
*   IFIL   Character*(*)      In        Name of input file
*   S(L)   Double Precision   Out       Buffer of samples
*   L      Integer            In        Length of S
*   IERR   Integer            Out       Error code
*-----------------------------------------------------------------------
      SUBROUTINE RMONO (IFIL, S, L, IERR)
       IMPLICIT NONE
       INTEGER L, IERR
       DOUBLE PRECISION S(L)
       CHARACTER*(*) IFIL

*         Local variables
       INTEGER*1 B
       INTEGER*2 SAMPL
       INTEGER I, J,           ! count bytes, samples
     $         IOU,            ! i/o unit
     $         POS             ! offset in bytes

       LOGICAL FEXIST

*-----------------------------------------------------------------------
* Open input file
*-----------------------------------------------------------------------
       INQUIRE (FILE=IFIL, EXIST=FEXIST, IOSTAT=IERR)
       IF (IERR .NE. 0) RETURN
       IF (.NOT. FEXIST) THEN
         PRINT *, 'file not found: ', IFIL
         IERR = -1
         RETURN
       END IF

       IOU = 1
       OPEN (UNIT=IOU, FILE=IFIL, STATUS='OLD', ACCESS='DIRECT',
     $  RECL=1, FORM='UNFORMATTED', IOSTAT=IERR)
       IF (IERR .NE. 0) RETURN

*   Read in samples, 16 bit signed integer, little-endian, 1 channel
       SAMPL = 0
       POS = 0
       B = 0
       DO J = 1, L            ! for each time
         DO I = 0, 1, +1        ! less-significant, more signficant byte
           POS = POS + 1
           READ (UNIT=IOU, REC=POS, IOSTAT=IERR) B
           IF (IERR .NE. 0) THEN
             PRINT *, 'trouble reading byte ', POS, ' of ', IFIL
             RETURN
           END IF
           CALL B2GET (B, SAMPL, I)  ! copy bits
         END DO  ! loop on bytes
         S(J) = REAL(SAMPL) / 32768.
       END DO  ! loop on samples

*         Done with input file
       CLOSE (UNIT=IOU, IOSTAT=IERR)
       IF (IERR .NE. 0) PRINT *, 'trouble closing file: ', IFIL
       RETURN
      END  ! of rmono


*-----------------------------------------------------------------------
* wmono - write a raw audio file, 16 bit integer, mono
*
*___Name___Type_______________In/Out____Description_____________________
*   OFIL   Character*(*)      In        Name of output file
*   S(L)   Double Precision   In        Buffer of samples
*   L      Integer            In        Length of S
*   IERR   Integer            Out       Error code
*-----------------------------------------------------------------------
      SUBROUTINE WMONO (OFIL, S, L, IERR)
       IMPLICIT NONE
       INTEGER L, IERR
       DOUBLE PRECISION S(L)
       CHARACTER*(*) OFIL

*         Local variables
       INTEGER*1 B
       INTEGER*2 SAMPL
       INTEGER I, J,           ! count bytes, samples
     $         IOU,            ! i/o unit
     $         POS             ! offset in bytes

       LOGICAL FEXIST

*-----------------------------------------------------------------------
* Open output file
*-----------------------------------------------------------------------
       INQUIRE (FILE=OFIL, EXIST=FEXIST, IOSTAT=IERR)
       IF (IERR .NE. 0) RETURN
       IF (FEXIST) THEN
         PRINT *, 'file exists: ', OFIL
         IERR = 1
         RETURN
       END IF

       IOU = 1
       OPEN (UNIT=IOU, FILE=OFIL, STATUS='NEW', ACCESS='DIRECT',
     $  RECL=1, FORM='UNFORMATTED', IOSTAT=IERR)
       IF (IERR .NE. 0) RETURN

*-----------------------------------------------------------------------
*   Write out samples, 16 bit signed integer, little-endian
*-----------------------------------------------------------------------
       B = 0
       POS = 0
       DO J = 1, L            ! for each time
         SAMPL = MIN(MAX(-32768, NINT(S(J) * 32768.D0)), +32767)
         DO I = 0, 1, +1      ! less-significant, more-significant byte
           POS = POS + 1
           CALL B2PUT (B, SAMPL, I)
           WRITE (UNIT=IOU, REC=POS, IOSTAT=IERR) B
           IF (IERR .NE. 0) THEN
             PRINT *, 'trouble writing byte ', POS, ' of ', OFIL
             RETURN
           END IF
         END DO  ! loop on bytes
       END DO  ! loop on samples

       CLOSE (UNIT=IOU, IOSTAT=IERR)
       IF (IERR .NE. 0) PRINT *, 'trouble closing file: ', OFIL
       RETURN
      END  ! of wmono


*-----------------------------------------------------------------------
* Copy 8 bits from an INTEGER*1 into an INTEGER*2
*-----------------------------------------------------------------------
      SUBROUTINE B2GET (B, S, POS)
       IMPLICIT NONE
       INTEGER*1 B
       INTEGER*2 S
       INTEGER POS

       INTEGER I, P8

       P8 = 8 * POS
       DO I = 0, 7
         IF (BTEST(B, I)) THEN
           S = IBSET(S, I + P8)
         ELSE
           S = IBCLR(S, I + P8)
         END IF
       END DO

       RETURN
      END  ! of b2get


*-----------------------------------------------------------------------
* Copy 8 bits from an INTEGER*2 into an INTEGER*1
*-----------------------------------------------------------------------
      SUBROUTINE B2PUT (B, S, POS)
       IMPLICIT NONE
       INTEGER*1 B
       INTEGER*2 S
       INTEGER POS

       INTEGER I, P8

       P8 = 8 * POS
       DO I = 0, 7
         IF (BTEST(S, I + P8)) THEN
           B = IBSET(B, I)
         ELSE
           B = IBCLR(B, I)
         END IF
       END DO

       RETURN
      END  ! of b2put