16ビット整数のwav fileのデータを、倍精度実数にして吐き出すことを考えます。今はmpeg音声Layer 1を想定して、ファイル先頭の１チャンネルあたり384個のデータを読みこみ書き出します。
■実行結果
■ソース・プログラム
F2003の新機能ASSOCIATEをあまり必然性も無く使ってみたりして。
結果をよく吟味していないので、バグがあるかも。L-Rチャンネルの定義も曖昧まいんちゃん。
MODULE m_wavio IMPLICIT NONE PRIVATE PUBLIC :: t_wavfile TYPE :: t_chunk CHARACTER(4) :: chunkid INTEGER :: chunksize END TYPE t_chunk TYPE, EXTENDS(t_chunk) :: t_fmt INTEGER :: format_id, channels INTEGER :: sampling_rate INTEGER :: bytes_per_sec INTEGER :: block_size, bits_per_sample END TYPE t_fmt TYPE, EXTENDS(t_chunk) :: t_data ! PCM data 16bit L R END TYPE t_data TYPE, EXTENDS(t_chunk) :: t_riffwav CHARACTER(4) :: formattag = 'WAVE' TYPE (t_fmt ) :: fmt TYPE (t_data) :: dat END TYPE t_riffwav TYPE, EXTENDS(t_riffwav) :: t_wavfile INTEGER :: unit = 10 INTEGER :: ipos CHARACTER(:), ALLOCATABLE :: fn CONTAINS PROCEDURE :: openfile PROCEDURE :: closefile PROCEDURE :: chk_riffwav PROCEDURE :: chk_fmt_chunk PROCEDURE :: chk_data_chunk PROCEDURE :: chk_fmt_parameters PROCEDURE :: read_pcm END TYPE t_wavfile CONTAINS LOGICAL FUNCTION openfile(this, fn) CLASS(t_wavfile), INTENT(IN OUT) :: this CHARACTER(*), INTENT(IN) :: fn INTEGER :: io this%fn = fn OPEN(this%unit, FILE = this%fn, ACCESS = 'STREAM', IOSTAT = io, STATUS = 'OLD', FORM = 'UNFORMATTED') IF (io /= 0) THEN openfile = .FALSE. ELSE openfile = .TRUE. END IF RETURN END FUNCTION openfile ! finalization SUBROUTINE closefile(this) CLASS(t_wavfile), INTENT(IN) :: this CLOSE(this%unit) RETURN END SUBROUTINE closefile LOGICAL FUNCTION chk_riffwav(this) CLASS(t_wavfile), INTENT(IN OUT) :: this READ(this%unit) this%t_chunk IF (this%chunkid == 'RIFF') THEN READ(this%unit) this%formattag IF (this%formattag == 'WAVE') THEN chk_riffwav = .TRUE. ELSE chk_riffwav = .FALSE. END IF ELSE chk_riffwav = .FALSE. END IF RETURN END FUNCTION chk_riffwav LOGICAL FUNCTION chk_fmt_chunk(this) CLASS(t_wavfile), INTENT(IN OUT) :: this TYPE :: t_fmt_sequence SEQUENCE CHARACTER(4) :: chunkid INTEGER(4) :: chunksize INTEGER(2) :: format_id, channels INTEGER(4) :: sampling_rate INTEGER(4) :: bytes_per_sec INTEGER(2) :: block_size, bits_per_sample END TYPE t_fmt_sequence TYPE (t_fmt_sequence) :: fmt READ(this%unit) fmt IF (fmt%chunkid == 'fmt ') THEN this%fmt%chunkid = fmt%chunkid this%fmt%chunksize = fmt%chunksize this%fmt%format_id = INT(fmt%format_id , KIND = 4) this%fmt%channels = INT(fmt%channels , KIND = 4) this%fmt%sampling_rate = fmt%sampling_rate this%fmt%bytes_per_sec = fmt%bytes_per_sec this%fmt%block_size = INT(fmt%block_size , KIND = 4) this%fmt%bits_per_sample = INT(fmt%bits_per_sample, KIND = 4) chk_fmt_chunk = .TRUE. ELSE chk_fmt_chunk = .FALSE. END IF RETURN END FUNCTION chk_fmt_chunk LOGICAL FUNCTION chk_fmt_parameters(this) CLASS(t_wavfile), INTENT(IN) :: this ASSOCIATE (fmt => this%fmt) IF ( fmt%format_id /= 1) THEN !linear PCM WRITE(*, *) 'Unknown WAVE format!' chk_fmt_parameters = .FALSE. END IF IF ( fmt%bits_per_sample /= 16) THEN WRITE(*, *) 'Not 16bit data!' chk_fmt_parameters = .FALSE. END IF SELECT CASE ( fmt%channels ) CASE (1) WRITE(*, '(a, i3, a, i6, a)') 'Monoral', fmt%bits_per_sample, 'bit Sampling rate', fmt%sampling_rate, 'Hz ' chk_fmt_parameters = .TRUE. CASE (2) WRITE(*, '(a, i3, a, i6, a)') 'Stereo' , fmt%bits_per_sample, 'bit Sampling rate', fmt%sampling_rate, 'Hz ' chk_fmt_parameters = .TRUE. CASE DEFAULT WRITE(*, '(a, i1)') ' Number of wave channels is ', fmt%channels WRITE(*, *) 'Wave channel must be 1 or 2!' chk_fmt_parameters = .FALSE. END SELECT END ASSOCIATE RETURN END FUNCTION chk_fmt_parameters LOGICAL FUNCTION chk_data_chunk(this) CLASS(t_wavfile), INTENT(IN OUT) :: this TYPE (t_chunk) :: chunk INQUIRE(this%unit, POS = this%ipos) DO READ(this%unit, POS = this%ipos) chunk IF (chunk%chunkid == 'data') THEN chk_data_chunk = .TRUE. EXIT ELSE this%ipos = this%ipos + 8 + chunk%chunksize END IF END DO RETURN END FUNCTION chk_data_chunk LOGICAL FUNCTION read_pcm(this, pcm) CLASS(t_wavfile), INTENT(IN) :: this REAL(8), INTENT(OUT) :: pcm(:, :) REAL(8), PARAMETER :: denom = REAL(2**15, KIND = 8) INTEGER(2) :: buff16(SIZE(pcm, 1) * SIZE(pcm, 2)) INTEGER :: i, nchannels nchannels = SIZE(pcm, 2) READ(this%unit) buff16 SELECT CASE (nchannels) CASE (1) !mono pcm(:, 1) = buff16 / denom ! pcm(:, 2) = 0.0d0 read_pcm = .TRUE. CASE (2) !stereo pcm(:, 1) = buff16(1::2) / denom ! Left channel pcm(:, 2) = buff16(2::2) / denom ! Right channel read_pcm = .TRUE. CASE DEFAULT WRITE(*, *) 'input file should be 1 or 2 channel(s)' read_pcm = .FALSE. END SELECT RETURN END FUNCTION read_pcm END MODULE m_wavio !==================== PROGRAM test USE m_wavio IMPLICIT NONE TYPE (t_wavfile), ALLOCATABLE :: wavfile REAL(8) :: buff(384, 2) INTEGER :: i ALLOCATE( wavfile ) IF ( wavfile%openfile('2000hz.wav') ) THEN PRINT *, wavfile%chk_riffwav() PRINT *, wavfile%chk_fmt_chunk() PRINT *, wavfile%chk_data_chunk() PRINT *, wavfile%chk_fmt_parameters() PRINT *, wavfile%read_pcm(buff) DO i = 1, SIZE(buff, 1) PRINT *, buff(i, :) END DO CALL wavfile%closefile() ELSE STOP 'open error: wav file not found' END IF STOP END PROGRAM test
