program classic_demo_write
  use classic_api
  implicit none
  !---------------------------------------------------------------------
  !  Demonstration program which writes a Classic file version 2, with
  ! a few entries, and 1 Entry Index, 1 section, and 1 data array per
  ! entry. The output file 'foo.bin' can be read again by the reading
  ! demonstration program.
  !
  !  * Entry Index:
  !     - Entry starting record  (I*8)
  !     - Entry starting word    (I*4)
  !     - Dummy 'foo' value      (I*4)
  !  * Section:
  !     - One R*4 value
  !     - One R*8 value
  !     - One I*4 value
  !     - One I*8 value
  !     - One C*8 value
  !  * Data:
  !     - Array of 10 R*4 values
  !---------------------------------------------------------------------
  type(classic_recordbuf_t) :: rbufind,rbufobs
  integer(kind=4) :: i
  integer(kind=entry_length) :: ientry
  logical :: error,full
  ! File
  type(classic_file_t) :: file
  integer(kind=4), parameter :: file_lun=50  ! Arbitrary value
  character(len=*), parameter :: file_name='foo.bin'
  integer(kind=4), parameter :: file_version=2
  integer(kind=4), parameter :: file_reclen=64  ! Arbitrary value
  ! File Descriptor
  integer(kind=4), parameter :: fdesc_kind=classic_kind_demo
  logical, parameter :: fdesc_single=.true.
  real(kind=4), parameter :: fdesc_expo=2.0
  integer(kind=entry_length), parameter :: fdesc_size=1  ! Not relevant for exponential growth
  ! Entry Index
  integer(kind=4), parameter :: ind_version=123  ! Index version (arbitrary value)
  integer(kind=4), parameter :: ind_length=4  ! 1 I*8, 2 I*4
  integer(kind=8) :: ind_rstart
  integer(kind=4) :: ind_wstart
  integer(kind=4) :: ind_foo
  integer(kind=4) :: bufind(ind_length)  ! Buffer for byte-swapping one index
  ! Entry Descriptor
  type(classic_entrydesc_t) :: edesc
  integer(kind=4), parameter :: edesc_maxsec=1     ! Maximum number of section per entry
  integer(kind=4), parameter :: edesc_version=456  ! Observation version (arbitrary value)
  ! Section
  integer(kind=4), parameter :: sec_id=789  ! Identifier (arbitrary value)
  integer(kind=data_length), parameter :: sec_length=8  ! 1 R*4, 1 R*8, 1 I*4, 1 I*8, 1 C*8
  real(kind=4) :: sec_r4
  real(kind=8) :: sec_r8
  integer(kind=4) :: sec_i4
  integer(kind=8) :: sec_i8
  character(len=8) :: sec_c8
  integer(kind=4) :: bufsec(sec_length)  ! Buffer for byte-swapping one section
  ! Data
  integer(kind=data_length), parameter :: dat_length=10
  real(kind=4) :: data(dat_length)
  real(kind=4) :: bufdat(dat_length)  ! Buffer for byte-swapping one data block
  !
  write(*,'(A)')  '--- Welcome to the Classic demonstration writing program ---'
  !
  error = .false.
  !
  ! Initialize the Classic library
  call classic_init(error)
  if (error)  stop
  !
  file%lun = file_lun
  file%spec = file_name
  file%nspec = len_trim(file%spec)
  file%update = .false.
  call classic_file_init(file,file_version,file_reclen,error)
  if (error)  stop
  !
  call classic_filedesc_init(file,fdesc_kind,fdesc_single,fdesc_size,  &
    ind_version,ind_length,fdesc_expo,error)
  if (error)  stop
  !
  call reallocate_recordbuf(rbufind,file%desc%reclen,error)
  if (error)  stop
  call reallocate_recordbuf(rbufobs,file%desc%reclen,error)
  if (error)  stop
  !
  do ientry=1,5  ! Write 5 entries
    write(*,*) ''
    write(*,'(A,I0)') 'Writing entry #',ientry
    call classic_entry_init(file,ientry,edesc_maxsec,edesc_version,full,  &
      edesc,error)
    if (full)  write(*,*) 'Error: file is full'
    if (error)  stop
    !
    ! Set the working buffer
    call classic_recordbuf_open(file,file%desc%nextrec,file%desc%nextword,  &
      rbufobs,error)
    if (error)  stop
    !
    ! Add the Entry Index
    ind_rstart = rbufobs%rstart
    ind_wstart = rbufobs%wstart
    ind_foo = 900+ientry  ! Some dummy value to be stored in the Index
    write(*,'(A,I0,1X,I0,1X,I0)')  &
      '  INDEX: ',ind_rstart,ind_wstart,ind_foo
    ! Entry Index can be anything => byte swapping is application specific.
    call classic_demo_ind2buf(ind_rstart,ind_wstart,ind_foo,bufind,  &
      file%conv)
    if (error)  stop
    call classic_entryindex_write(file,ientry,bufind,rbufind,error)
    if (error)  stop
    !
    ! Add 1 section: 1 R*4, 1 R*8, 1 I*4, 1 I*8, 1 C*8
    sec_r4 = real(ientry,kind=4)
    sec_r8 = real(ientry,kind=8)
    sec_i4 = int(ientry,kind=4)
    sec_i8 = int(ientry,kind=8)
    write(sec_c8,'(I8)')  ientry
    write(*,'(A,F0.2,1X,F0.4,1X,I0,1X,I0,1X,A)')   &
      '  SECTION: ',sec_r4,sec_r8,sec_i4,sec_i8,sec_c8
    ! Section can be anything => byte swapping is application specific.
    call classic_demo_sec2buf(sec_r4,sec_r8,sec_i4,sec_i8,sec_c8,bufsec,  &
      file%conv)
    call classic_entry_section_add(sec_id,sec_length,bufsec,edesc,rbufobs,  &
      error)
    if (error)  stop
    !
    ! Add data
    ! Data can be anything => byte swapping is application specific.
    data(:) = (/ (ientry+i, i=1,dat_length) /)
    write(*,'(A,I0,A,10(1X,F0.2))')  &
      '  DATA (',dat_length,' values): ',data(1:dat_length)
    call classic_demo_dat2buf(int(dat_length,kind=4),data,bufdat,file%conv)
    call classic_entry_data_add(bufdat,dat_length,edesc,rbufobs,error)
    if (error)  stop
    !
    ! Write the Entry Descriptor
    write(*,'(A,I0,1X,I0,1X,I0,1X,I0)')  &
      '  DESCRIPTOR: ',edesc%nsec,edesc%nword,edesc%adata,edesc%ldata
    call classic_entrydesc_write(file,rbufobs,edesc,error)
    if (error)  stop
    !
    call classic_entry_close(file,rbufobs,error)
    if (error)  stop
    !
    ! Once the Entry and Entry Descriptor are written, update the File
    ! Descriptor on disk (in particular xnext)
    file%desc%xnext = ientry+1
    call classic_filedesc_write(file,error)
    if (error)  stop
  enddo
  !
  ! Debugging printout
  write(*,*) ''
  write(*,'(A)')  'File Descriptor:'
  call classic_filedesc_dump(file%desc,'w')
  !
  call classic_file_close(file,error)
  if (error)  stop
  !
  call deallocate_recordbuf(rbufobs,error)
  if (error)  stop
  call deallocate_recordbuf(rbufind,error)
  if (error)  stop
  !
  write(*,*) ''
  write(*,'(A,A,A)') 'File ',trim(file%spec),' successfully written'
  !
contains
  !
  subroutine classic_demo_ind2buf(rec,word,foo,buf,conv)
    use gildas_def
    use gkernel_interfaces
    use classic_api
    !---------------------------------------------------------------------
    ! Copy the Entry Index into the given buffer, swap bytes if needed
    !---------------------------------------------------------------------
    integer(kind=8),          intent(in)  :: rec
    integer(kind=4),          intent(in)  :: word
    integer(kind=4),          intent(in)  :: foo
    integer(kind=4),          intent(out) :: buf(*)
    type(classic_fileconv_t), intent(in)  :: conv
    !
#if defined(FORTRAN2003_PP) /* Fortran 2003 Pointer Procedures */
    call conv%writ%i8(rec, buf(1),1)  ! 1-2: record
    call conv%writ%i4(word,buf(3),1)  !   3: word
    call conv%writ%i4(foo, buf(4),1)  !   4: foo
#else  /* not FORTRAN2003_PP */
    integer(kind=address_length) :: adi4,adi8
    integer(kind=1) :: membyt(8)
    !
    adi4 = bytpnt(file%conv%writ%i4,membyt)
    adi8 = bytpnt(file%conv%writ%i8,membyt)
    call convert_buf(membyt(adi8),rec, buf(1),1)
    call convert_buf(membyt(adi4),word,buf(3),1)
    call convert_buf(membyt(adi4),foo, buf(4),1)
#endif
    !
  end subroutine classic_demo_ind2buf
  !
  subroutine classic_demo_sec2buf(r4,r8,i4,i8,c8,buf,conv)
    use gildas_def
    use gkernel_interfaces
    use classic_api
    !---------------------------------------------------------------------
    ! Copy the section values into the given buffer, swap bytes if needed
    !---------------------------------------------------------------------
    real(kind=4),             intent(in)  :: r4
    real(kind=8),             intent(in)  :: r8
    integer(kind=4),          intent(in)  :: i4
    integer(kind=8),          intent(in)  :: i8
    character(len=*),         intent(in)  :: c8
    integer(kind=4),          intent(out) :: buf(*)
    type(classic_fileconv_t), intent(in)  :: conv
    !
#if defined(FORTRAN2003_PP) /* Fortran 2003 Pointer Procedures */
    call conv%writ%r4(r4,buf(1),1)  !   1: R*4
    call conv%writ%r8(r8,buf(2),1)  ! 2-3: R*8
    call conv%writ%i4(i4,buf(4),1)  !   4: I*4
    call conv%writ%i8(i8,buf(5),1)  ! 5-6: I*8
    call conv%writ%cc(c8,buf(7),2)  ! 7-8: C*8
#else  /* not FORTRAN2003_PP */
    integer(kind=address_length) :: adr4,adr8,adi4,adi8,adcc
    integer(kind=1) :: membyt(8)
    !
    adr4 = bytpnt(file%conv%writ%r4,membyt)
    adr8 = bytpnt(file%conv%writ%r8,membyt)
    adi4 = bytpnt(file%conv%writ%i4,membyt)
    adi8 = bytpnt(file%conv%writ%i8,membyt)
    adcc = bytpnt(file%conv%writ%cc,membyt)
    call convert_buf(membyt(adr4),r4,buf(1),1)
    call convert_buf(membyt(adr8),r8,buf(2),1)
    call convert_buf(membyt(adi4),i4,buf(4),1)
    call convert_buf(membyt(adi8),i8,buf(5),1)
    call convert_chtow4(membyt(adcc),c8,buf(7),2)
#endif
    !
  end subroutine classic_demo_sec2buf
  !
  subroutine classic_demo_dat2buf(ldata,data,buf,conv)
    use gildas_def
    use gkernel_interfaces
    use classic_api
    !---------------------------------------------------------------------
    ! Copy the Data array into the given buffer, swap bytes if needed
    !---------------------------------------------------------------------
    integer(kind=4),          intent(in)  :: ldata
    real(kind=4),             intent(in)  :: data(ldata)
    real(kind=4),             intent(out) :: buf(ldata)
    type(classic_fileconv_t), intent(in)  :: conv
    !
#if defined(FORTRAN2003_PP) /* Fortran 2003 Pointer Procedures */
    call conv%writ%r4(data,buf,ldata)
#else  /* not FORTRAN2003_PP */
    integer(kind=address_length) :: adr4
    integer(kind=1) :: membyt(8)
    !
    adr4 = bytpnt(conv%writ%r4,membyt)
    call convert_buf(membyt(adr4),data,buf,ldata)
#endif
    !
  end subroutine classic_demo_dat2buf
  !
end program classic_demo_write
