module cubeio_chan
  use cubetools_parameters
  use cubetools_header_types
  use cubetools_setup_types
  use cubeio_messaging
  use cubeio_cube_define
  use cubeio_cube

  type cube_chan_t
    integer(kind=pixe_k) :: nx = 0                         ! Number of X pixels
    integer(kind=pixe_k) :: ny = 0                         ! Number of Y pixels
    integer(kind=4)      :: allocated = code_pointer_null  !
    logical              :: iscplx = .false.               ! R*4 or C*4?
    real(kind=sign_k),    pointer :: r4(:,:) => null()     ! [nx,ny]
    complex(kind=sign_k), pointer :: c4(:,:) => null()     ! [nx,ny]
  end type cube_chan_t

  private
  public :: cube_chan_t
  public :: cubeio_get_chan,cubeio_put_chan,cubeio_free_chan
  public :: cubeio_chan_number

contains

  subroutine cubeio_reallocate_chan(cubset,chan,iscplx,nx,ny,error)
    use gkernel_interfaces
    !-------------------------------------------------------------------
    ! (Re)allocate a cube_chan_t
    ! Do nothing when the array sizes do not need to change
    !-------------------------------------------------------------------
    type(cube_setup_t),   intent(in)    :: cubset
    type(cube_chan_t),    intent(inout) :: chan
    logical,              intent(in)    :: iscplx
    integer(kind=pixe_k), intent(in)    :: nx
    integer(kind=pixe_k), intent(in)    :: ny
    logical,              intent(inout) :: error
    ! Local
    character(len=*), parameter :: rname='REALLOCATE>CUBE>CHAN'
    integer(kind=4) :: ier
    !
    call cubeio_message(ioseve%trace,rname,'Welcome')
    !
    ! Sanity checks
    if (nx.le.0) then
      call cubeio_message(seve%e,rname,'Number of X pixels is null or negative')
      error = .true.
    endif
    if (ny.le.0) then
      call cubeio_message(seve%e,rname,'Number of Y pixels is null or negative')
      error = .true.
    endif
    if (error)  return
    !
    ! Allocation or reallocation?
    if (chan%allocated.eq.code_pointer_allocated) then
      ! Reallocation?
      if ((chan%iscplx.eqv.iscplx) .and. chan%nx.eq.nx .and. chan%ny.eq.ny) then
        ! Same type and same size => Nothing to be done!
        call cubeio_message(ioseve%alloc,rname,'Channel array already allocated with correct size')
        goto 100
      else  ! Different type or different size => reallocation
        call cubeio_message(ioseve%alloc,rname,'Reallocating channel array')
        call cubeio_free_chan(chan,error)
        if (error)  return
      endif
    else
      ! Allocation
      call cubeio_message(ioseve%alloc,rname,'Creating channel array')
    endif
    !
    ! Reallocate memory of the right size
    if (iscplx) then
      allocate(chan%c4(nx,ny),stat=ier)
    else
      allocate(chan%r4(nx,ny),stat=ier)
    endif
    if (failed_allocate(rname,'Channel array',ier,error)) return
    !
  100 continue
    ! Operation success
    chan%nx = nx
    chan%ny = ny
    chan%iscplx = iscplx
    chan%allocated = code_pointer_allocated
    !
  end subroutine cubeio_reallocate_chan

  subroutine cubeio_free_chan(chan,error)
    !---------------------------------------------------------------------
    ! Free a 'cube_chan_t' instance
    !---------------------------------------------------------------------
    type(cube_chan_t), intent(inout) :: chan   !
    logical,           intent(inout) :: error  !
    !
    if (chan%allocated.eq.code_pointer_allocated) then
      if (chan%iscplx) then
        deallocate(chan%c4)
      else
        deallocate(chan%r4)
      endif
    endif
    !
    chan%nx = 0
    chan%ny = 0
    chan%allocated = code_pointer_null
    chan%iscplx = .false.
    chan%c4 => null()
    chan%r4 => null()
    !
  end subroutine cubeio_free_chan

  subroutine cubeio_get_chan(cubset,cubdef,head,cub,ichan,chan,error)
    !---------------------------------------------------------------------
    ! Get all data (Nx x Ny) for the desired channel
    !---------------------------------------------------------------------
    type(cube_setup_t),   intent(in)    :: cubset
    type(cube_define_t),  intent(in)    :: cubdef
    type(cube_header_t),  intent(in)    :: head
    type(cubeio_cube_t),  intent(inout) :: cub
    integer(kind=chan_k), intent(in)    :: ichan
    type(cube_chan_t),    intent(inout) :: chan
    logical,              intent(inout) :: error
    ! Local
    character(len=*), parameter :: rname='GET>CHAN'
    character(len=message_length) :: mess
    integer(kind=chan_k) :: doichan
    !
    if (.not.cub%ready()) then
      call cubeio_message(seve%e,rname,'Internal error: cube data is not ready')
      error = .true.
      return
    endif
    doichan = cubeio_chan_number(cub,ichan)
    if (doichan.le.0 .or. doichan.gt.cub%desc%nc) then
      write(mess,'(2(A,I0))')  'Channel number ',doichan,' out of range 1 - ',cub%desc%nc
      call cubeio_message(seve%e,rname,mess)
      error = .true.
      return
    endif
    !
    select case (cub%desc%buffered)
    case (code_buffer_memory)
      call cubeio_get_chan_from_memory(cubset,cub,doichan,chan,error)
    case (code_buffer_disk)
      call cubeio_get_chan_from_block(cubset,head,cub,doichan,chan,error)
    case default
      call cubeio_message(seve%e,rname,'Unexpected cube buffering')
      error = .true.
    end select
    if (error)  return
  end subroutine cubeio_get_chan

  subroutine cubeio_get_chan_from_memory(cubset,cub,ichan,chan,error)
    !---------------------------------------------------------------------
    ! Get all data (Nx x Ny) for the desired channel, in the context of
    ! memory mode. In return, the 'chan' points to the cube data buffer.
    ! --
    ! Do not call directly, use cubeio_get_chan instead.
    !---------------------------------------------------------------------
    type(cube_setup_t),          intent(in)    :: cubset
    type(cubeio_cube_t), target, intent(in)    :: cub
    integer(kind=chan_k),        intent(in)    :: ichan
    type(cube_chan_t),           intent(inout) :: chan
    logical,                     intent(inout) :: error
    ! Local
    character(len=*), parameter :: rname='GET>CHAN'
    !
    select case (cub%desc%order)
    case (code_cube_imaset)
      ! Data is simply associated to LMV buffer
      ! ZZZ deallocate if needed before associating!
      chan%nx = cub%memo%nx
      chan%ny = cub%memo%ny
      if (cub%memo%iscplx) then
        chan%c4 => cub%memo%c4(:,:,ichan)
      else
        chan%r4 => cub%memo%r4(:,:,ichan)
      endif
      chan%iscplx = cub%memo%iscplx
      chan%allocated = code_pointer_associated
    case (code_cube_speset)
      ! Data is copied/duplicated from VLM buffer
      call cubeio_reallocate_chan(cubset,chan,cub%memo%iscplx,cub%memo%nx,cub%memo%ny,error)
      if (error)  return
      ! Non-contiguous (unefficient) copy
      if (cub%memo%iscplx) then
        chan%c4(:,:) = cub%memo%c4(ichan,:,:)
      else
        chan%r4(:,:) = cub%memo%r4(ichan,:,:)
      endif
    case default
      call cubeio_message(seve%e,rname,'No data available')
      error = .true.
      return
    end select
  end subroutine cubeio_get_chan_from_memory

  subroutine cubeio_get_chan_from_block(cubset,head,cub,ichan,chan,error)
    !---------------------------------------------------------------------
    ! Get all data (Nx x Ny) for the desired channel, in the context of
    ! disk mode. In return, the 'chan' points to a memory buffer that is
    ! intended to disappear as others channels are accessed => no warranty
    ! the pointer remains valid after another call.
    ! --
    ! Do not call directly, use cubeio_get_chan instead.
    !---------------------------------------------------------------------
    type(cube_setup_t),          intent(in)    :: cubset
    type(cube_header_t),         intent(in)    :: head
    type(cubeio_cube_t), target, intent(inout) :: cub
    integer(kind=chan_k),        intent(in)    :: ichan
    type(cube_chan_t),           intent(inout) :: chan
    logical,                     intent(inout) :: error
    ! Local
    character(len=*), parameter :: rname='GET>CHAN'
    integer(kind=chan_k) :: bchan
    !
    if (cub%desc%order.ne.code_cube_imaset) then
      call cubeio_message(seve%e,rname,'Reading a channel from disk in a VLM file is prohibitive')
      call cubeio_message(seve%e,rname,'Transpose VLM file to LMV file and then READ it')
      error = .true.
      return
    endif
    !
    call cubeio_check_input_chan_block(cubset,head,cub,ichan,ichan,error)
    if (error)  return
    !
    ! Point channel data from correct position in chan%block
    bchan = ichan-cub%file%block%first+1  ! Position in chan%block
    ! ZZZ deallocate if needed before associating!
    chan%nx = cub%desc%nx
    chan%ny = cub%desc%ny
    if (cub%file%block%iscplx) then
      chan%c4 => cub%file%block%c4(:,:,bchan)
    else
      chan%r4 => cub%file%block%r4(:,:,bchan)
    endif
    chan%iscplx = cub%file%block%iscplx
    chan%allocated = code_pointer_associated
    !
  end subroutine cubeio_get_chan_from_block
  !
  subroutine cubeio_put_chan(cubset,cubdef,head,cub,ichan,chan,error)
    use gkernel_interfaces
    use cubetools_header_types
    !-------------------------------------------------------------------
    ! Put all data (Nx x Ny) for the desired channel
    ! (This is symetric to cubeio_get_chan)
    !-------------------------------------------------------------------
    type(cube_setup_t),   intent(in)    :: cubset
    type(cube_define_t),  intent(in)    :: cubdef
    type(cube_header_t),  intent(in)    :: head
    type(cubeio_cube_t),  intent(inout) :: cub
    integer(kind=chan_k), intent(in)    :: ichan
    type(cube_chan_t),    intent(in)    :: chan
    logical,              intent(inout) :: error
    ! Local
    character(len=*), parameter :: rname='PUT>CHAN'
    character(len=message_length) :: mess
    !
    if (.not.cub%ready()) then
      call cubeio_message(seve%e,rname,'Internal error: cube data is not ready')
      error = .true.
      return
    endif
    if (ichan.le.0 .or. ichan.gt.cub%desc%nc) then
      write(mess,'(A,I0,A,I0,A)')  &
        'Channel number out of range (',ichan,'/',cub%desc%nc,')'
      call cubeio_message(seve%e,rname,mess)
      error = .true.
    endif
    if (chan%nx.ne.cub%desc%nx .or. chan%ny.ne.cub%desc%ny) then
      write(mess,'(5(A,I0))')  'Nx or Ny mismatch: attempt to put ',chan%nx,'x',  &
      chan%ny,' pixels while output cube has ',cub%desc%nx,'x',cub%desc%ny,' pixels'
      call cubeio_message(seve%e,rname,mess)
      error = .true.
    endif
    if (chan%iscplx.neqv.cub%desc%iscplx) then
      call cubeio_message(seve%e,rname,'Channel and output cube type mismatch (R*4/C*4)')
      error = .true.
    endif
    if (error)  return
    !
    select case (cub%desc%buffered)
    case (code_buffer_memory)
      call cubeio_put_chan_to_data(cubset,cub,ichan,chan,error)
    case (code_buffer_disk)
      call cubeio_put_chan_to_block(cubset,head,cub,ichan,chan,error)
    case default
      call cubeio_message(seve%e,rname,'Unexpected cube data buffering')
      error = .true.
    end select
    if (error)  return
  end subroutine cubeio_put_chan
  !
  subroutine cubeio_put_chan_to_data(cubset,cub,ichan,chan,error)
    !-------------------------------------------------------------------
    ! Write a single channel to the cubeio_memory_t, in the context of
    ! memory mode.
    ! ---
    ! Do not call directly, use cubeio_put_chan instead.
    !-------------------------------------------------------------------
    type(cube_setup_t),   intent(in)    :: cubset
    type(cubeio_cube_t),  intent(inout) :: cub
    integer(kind=chan_k), intent(in)    :: ichan
    type(cube_chan_t),    intent(in)    :: chan
    logical,              intent(inout) :: error
    ! Local
    character(len=*), parameter :: rname='PUT>CHAN'
    !
    select case (cub%desc%order)
    case (code_cube_imaset)
      if (cub%memo%iscplx) then
        cub%memo%c4(:,:,ichan) = chan%c4(:,:)
      else
        cub%memo%r4(:,:,ichan) = chan%r4(:,:)
      endif
    case (code_cube_speset)
      ! Non-contiguous (unefficient) copies
      if (cub%memo%iscplx) then
        cub%memo%c4(ichan,:,:) = chan%c4(:,:)
      else
        cub%memo%r4(ichan,:,:) = chan%r4(:,:)
      endif
    case default
      call cubeio_message(seve%e,rname,'No data available')
      error = .true.
      return
    end select
    !
  end subroutine cubeio_put_chan_to_data
  !
  subroutine cubeio_put_chan_to_block(cubset,head,cub,ichan,chan,error)
    !-------------------------------------------------------------------
    ! Write a single channel to the cubeio_block_t, in the context of
    ! disk mode.
    ! ---
    ! Do not call directly, use cubeio_put_chan instead.
    !-------------------------------------------------------------------
    type(cube_setup_t),   intent(in)    :: cubset
    type(cube_header_t),  intent(in)    :: head
    type(cubeio_cube_t),  intent(inout) :: cub
    integer(kind=chan_k), intent(in)    :: ichan
    type(cube_chan_t),    intent(in)    :: chan
    logical,              intent(inout) :: error
    ! Local
    character(len=*), parameter :: rname='PUT>CHAN'
    integer(kind=chan_k) :: bchan
    integer(kind=size_length) :: ndata
    !
    if (cub%desc%order.ne.code_cube_imaset) then
      call cubeio_message(seve%e,rname,'Writing a channel to disk in a VLM file is impossible')
      error = .true.
      return
    endif
    if (cub%file%block%iscplx.neqv.chan%iscplx) then
      call cubeio_message(seve%e,rname,'Channel and output cube mismatch type (R*4/C*4)')
      error = .true.
      return
    endif
    !
    call cubeio_check_output_chan_block(cubset,head,cub,ichan,ichan,error)
    if (error)  return
    !
    ! Buffer might already be in memory but read-only: switch to read-write
    cub%file%block%readwrite = .true.
    !
    ! Write DATA to cub%file%block buffer
    bchan = ichan-cub%file%block%first+1  ! Position in cub%file%block
    ndata = cub%desc%nx*cub%desc%ny
    if (cub%file%block%iscplx) then
      call c4toc4_sl(chan%c4,cub%file%block%c4(1,1,bchan),ndata)
    else
      call r4tor4_sl(chan%r4,cub%file%block%r4(1,1,bchan),ndata)
    endif
    !
  end subroutine cubeio_put_chan_to_block
  !
  function cubeio_chan_number(cub,ichan)
    !-------------------------------------------------------------------
    ! Convert a channel number from a 'user' (external programmer)
    ! request to the proper value internal value.
    ! As of today, the following behaviour is implemented:
    !  1) if the 'cube' has only 1 entry, requesting any positive
    !     entry value results in returning the unique entry. This
    !     is a way to vectorize at no cost the entry dimension.
    ! This only makes sense when reading entries (no sense writing
    ! different entries to the same one).
    !-------------------------------------------------------------------
    integer(kind=chan_k) :: cubeio_chan_number  ! Function value on return
    type(cubeio_cube_t),  intent(in) :: cub
    integer(kind=chan_k), intent(in) :: ichan
    !
    if (ichan.le.0) then  ! Invalid
      cubeio_chan_number = ichan
    elseif (cub%desc%nc.eq.1) then
      cubeio_chan_number = 1
    else
      cubeio_chan_number = ichan
    endif
  end function cubeio_chan_number
  !
end module cubeio_chan
