module cubeio_chanblock
  !---------------------------------------------------------------------
  ! Support module for a contiguous block of channels
  !---------------------------------------------------------------------
  use cubetools_parameters
  use cubetools_header_types
  use cubetools_setup_types
  use cubeio_messaging
  use cubeio_cube_define
  use cubeio_cube

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

  private
  public :: cubeio_chanblock_t
  public :: cubeio_get_chanblock,cubeio_put_chanblock,cubeio_free_chanblock

contains

  subroutine cubeio_reallocate_chanblock(chanblock,iscplx,nx,ny,nc,error)
    use gkernel_interfaces
    !-------------------------------------------------------------------
    ! (Re)allocate a cubeio_chanblock_t
    ! Do nothing when the array sizes do not need to change
    !-------------------------------------------------------------------
    type(cubeio_chanblock_t), intent(inout) :: chanblock
    logical,                  intent(in)    :: iscplx
    integer(kind=pixe_k),     intent(in)    :: nx
    integer(kind=pixe_k),     intent(in)    :: ny
    integer(kind=chan_k),     intent(in)    :: nc  ! Minimum desired (can be different from size of allocation)
    logical,                  intent(inout) :: error
    ! Local
    character(len=*), parameter :: rname='REALLOCATE>CUBEIO>CHANBLOCK'
    integer(kind=4) :: ier
    integer(kind=chan_k) :: mc
    !
    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 (nc.le.0) then
      call cubeio_message(seve%e,rname,'Number of channels is null or negative')
      error = .true.
    endif
    if (error)  return
    !
    ! Allocation or reallocation?
    if (chanblock%allocated.eq.code_pointer_allocated) then
      ! Reallocation?
      if (chanblock%iscplx) then
        mc = ubound(chanblock%c4,3)
      else
        mc = ubound(chanblock%r4,3)
      endif
      if ((chanblock%iscplx.eqv.iscplx) .and.  &
           chanblock%nx.eq.nx           .and.  &
           chanblock%ny.eq.ny           .and.  &
           mc.ge.nc) then
        ! Same type and same size (at least on 3rd dim) => Nothing to be done!
        call cubeio_message(ioseve%alloc,rname,'Channel block 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_chanblock(chanblock,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(chanblock%c4(nx,ny,nc),stat=ier)
    else
      allocate(chanblock%r4(nx,ny,nc),stat=ier)
    endif
    if (failed_allocate(rname,'Channel array',ier,error)) return
    !
  100 continue
    ! Operation success
    chanblock%nx = nx
    chanblock%ny = ny
    chanblock%nc = nc
    chanblock%iscplx = iscplx
    chanblock%allocated = code_pointer_allocated
    !
  end subroutine cubeio_reallocate_chanblock

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

  subroutine cubeio_get_chanblock(cubset,cubdef,head,cub,fchan,lchan,chanblock,error)
    !---------------------------------------------------------------------
    ! Get all data (Nx x Ny) for the desired channel range
    !---------------------------------------------------------------------
    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)    :: fchan
    integer(kind=chan_k),     intent(in)    :: lchan
    type(cubeio_chanblock_t), intent(inout) :: chanblock
    logical,                  intent(inout) :: error
    ! Local
    character(len=*), parameter :: rname='GET>CHANBLOCK'
    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 (fchan.le.0 .or. lchan.gt.cub%desc%nc) then
      write(mess,'(A,I0)')  'Channel block range 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_chanblock_from_memory(cubset,cub,fchan,lchan,chanblock,error)
    case (code_buffer_disk)
      call cubeio_get_chanblock_from_block(cubset,head,cub,fchan,lchan,chanblock,error)
    case default
      call cubeio_message(seve%e,rname,'Unexpected cube buffering')
      error = .true.
    end select
    if (error)  return
  end subroutine cubeio_get_chanblock

  subroutine cubeio_get_chanblock_from_memory(cubset,cub,fchan,lchan,chanblock,error)
    !---------------------------------------------------------------------
    ! Get all data (Nx x Ny) for the desired range of channels, in the
    ! context of memory mode. In return, the 'chanblock' points to the
    ! cube data buffer.
    ! --
    ! Do not call directly, use cubeio_get_chanblock instead.
    !---------------------------------------------------------------------
    type(cube_setup_t),          intent(in)    :: cubset
    type(cubeio_cube_t), target, intent(in)    :: cub
    integer(kind=chan_k),        intent(in)    :: fchan
    integer(kind=chan_k),        intent(in)    :: lchan
    type(cubeio_chanblock_t),    intent(inout) :: chanblock
    logical,                     intent(inout) :: error
    ! Local
    character(len=*), parameter :: rname='GET>CHANBLOCK'
    integer(kind=chan_k) :: nc,ichan,ochan
    !
    nc = lchan-fchan+1
    !
    select case (cub%desc%order)
    case (code_cube_imaset)
      ! Data is simply associated to LMV buffer
      ! ZZZ deallocate if needed before associating!
      chanblock%nx = cub%memo%nx
      chanblock%ny = cub%memo%ny
      chanblock%nc = nc
      if (cub%memo%iscplx) then
        chanblock%c4 => cub%memo%c4(:,:,fchan:lchan)
      else
        chanblock%r4 => cub%memo%r4(:,:,fchan:lchan)
      endif
      chanblock%iscplx = cub%memo%iscplx
      chanblock%allocated = code_pointer_associated
    case (code_cube_speset)
      ! Data is transposed (and duplicated) from the available buffer
      call cubeio_reallocate_chanblock(chanblock,cub%memo%iscplx,  &
        cub%memo%nx,cub%memo%ny,nc,error)
      if (error)  return
      ! Non-contiguous (unefficient) copy
      if (cub%memo%iscplx) then
        do ichan=fchan,lchan
          ochan = ichan-fchan+1
          chanblock%c4(:,:,ochan) = cub%memo%c4(ichan,:,:)
        enddo
      else
        do ichan=fchan,lchan
          ochan = ichan-fchan+1
          chanblock%r4(:,:,ochan) = cub%memo%r4(ichan,:,:)
        enddo
      endif
    case default
      call cubeio_message(seve%e,rname,'No data available')
      error = .true.
      return
    end select
  end subroutine cubeio_get_chanblock_from_memory

  subroutine cubeio_get_chanblock_from_block(cubset,head,cub,fchan,lchan,chanblock,error)
    !---------------------------------------------------------------------
    ! Get all data (Nx x Ny) for the desired channel, in the context of
    ! disk mode. In return, the 'chanblock' 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_chanblock 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)    :: fchan
    integer(kind=chan_k),        intent(in)    :: lchan
    type(cubeio_chanblock_t),    intent(inout) :: chanblock
    logical,                     intent(inout) :: error
    ! Local
    character(len=*), parameter :: rname='GET>CHANBLOCK'
    integer(kind=chan_k) :: nc,bfchan,blchan
    !
    nc = lchan-fchan+1
    !
    select case (cub%desc%order)
    case (code_cube_imaset,code_cube_speset)
      ! In case of VLM data, this call will collect the data by traversing
      ! the whole file. Unefficient, but useful for transposition.
      call cubeio_check_input_chan_block(cubset,head,cub,fchan,lchan,error)
      if (error)  return
      !
      ! Point channel data from correct position in cub%file%block
      bfchan = fchan-cub%file%block%first+1  ! First position in cub%file%block
      blchan = lchan-cub%file%block%first+1  ! Last position in cub%file%block
      ! ZZZ deallocate if needed before associating!
      chanblock%nx = cub%desc%nx
      chanblock%ny = cub%desc%ny
      chanblock%nc = nc
      if (cub%file%block%iscplx) then
        chanblock%c4 => cub%file%block%c4(:,:,bfchan:blchan)
      else
        chanblock%r4 => cub%file%block%r4(:,:,bfchan:blchan)
      endif
      chanblock%iscplx = cub%file%block%iscplx
      chanblock%allocated = code_pointer_associated
      !
    case default
      call cubeio_message(seve%e,rname,'No data available')
      error = .true.
      return
    end select
    !
  end subroutine cubeio_get_chanblock_from_block
  !
  subroutine cubeio_put_chanblock(cubset,cubdef,head,cub,fchan,lchan,chanblock,error)
    use gkernel_interfaces
    use cubetools_header_types
    !-------------------------------------------------------------------
    ! Put all data (Nx x Ny) for the desired channel range
    ! (This is symetric to cubeio_get_chanblock)
    !-------------------------------------------------------------------
    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)    :: fchan
    integer(kind=chan_k),     intent(in)    :: lchan
    type(cubeio_chanblock_t), intent(in)    :: chanblock
    logical,                  intent(inout) :: error
    ! Local
    character(len=*), parameter :: rname='PUT>CHANBLOCK'
    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 (fchan.le.0 .or. lchan.gt.cub%desc%nc) then
      write(mess,'(A,I0)')  'Channel block range out of range 1 - ',cub%desc%nc
      call cubeio_message(seve%e,rname,mess)
      error = .true.
    endif
    if (chanblock%nx.ne.cub%desc%nx .or. chanblock%ny.ne.cub%desc%ny) then
      write(mess,'(5(A,I0))')  'Nx or Ny mismatch: attempt to put ',chanblock%nx,'x',  &
        chanblock%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 (chanblock%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_chanblock_to_data(cubset,cub,fchan,lchan,chanblock,error)
    case (code_buffer_disk)
      call cubeio_put_chanblock_to_block(cubset,head,cub,fchan,lchan,chanblock,error)
    case default
      call cubeio_message(seve%e,rname,'Unexpected cube data buffering')
      error = .true.
    end select
    if (error)  return
  end subroutine cubeio_put_chanblock
  !
  subroutine cubeio_put_chanblock_to_data(cubset,cub,fchan,lchan,chanblock,error)
    !-------------------------------------------------------------------
    ! Write a channel block to the cubeio_memory_t, in the context of
    ! memory mode.
    ! ---
    ! Do not call directly, use cubeio_put_chanblock instead.
    !-------------------------------------------------------------------
    type(cube_setup_t),       intent(in)    :: cubset
    type(cubeio_cube_t),      intent(inout) :: cub
    integer(kind=chan_k),     intent(in)    :: fchan
    integer(kind=chan_k),     intent(in)    :: lchan
    type(cubeio_chanblock_t), intent(in)    :: chanblock
    logical,                  intent(inout) :: error
    ! Local
    character(len=*), parameter :: rname='PUT>CHANBLOCK'
    integer(kind=chan_k) :: nc,ichan,ochan
    !
    nc = lchan-fchan+1
    !
    select case (cub%desc%order)
    case (code_cube_imaset)
      if (cub%memo%iscplx) then
        do ochan=fchan,lchan
          ichan = ochan-fchan+1
          cub%memo%c4(:,:,ochan) = chanblock%c4(:,:,ichan)
        enddo
      else
        do ochan=fchan,lchan
          ichan = ochan-fchan+1
          cub%memo%r4(:,:,ochan) = chanblock%r4(:,:,ichan)
        enddo
      endif
    case (code_cube_speset)
      ! Non-contiguous (unefficient) copies
      if (cub%memo%iscplx) then
        do ochan=fchan,lchan
          ichan = ochan-fchan+1
          cub%memo%c4(ochan,:,:) = chanblock%c4(:,:,ichan)
        enddo
      else
        do ochan=fchan,lchan
          ichan = ochan-fchan+1
          cub%memo%r4(ochan,:,:) = chanblock%r4(:,:,ichan)
        enddo
      endif
    case default
      call cubeio_message(seve%e,rname,'No data available')
      error = .true.
      return
    end select
    !
  end subroutine cubeio_put_chanblock_to_data
  !
  subroutine cubeio_put_chanblock_to_block(cubset,head,cub,fchan,lchan,chanblock,error)
    !-------------------------------------------------------------------
    ! Write a single channel to the cubeio_block_t, in the context of
    ! disk mode.
    ! ---
    ! Do not call directly, use cubeio_put_chanblock 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)    :: fchan
    integer(kind=chan_k),     intent(in)    :: lchan
    type(cubeio_chanblock_t), intent(in)    :: chanblock
    logical,                  intent(inout) :: error
    ! Local
    character(len=*), parameter :: rname='PUT>CHANBLOCK'
    integer(kind=chan_k) :: nc,bfchan,blchan
    integer(kind=size_length) :: ndata
    !
    if (cub%desc%order.ne.code_cube_imaset) then
      call cubeio_message(seve%e,rname,'Writing a channel block to disk in a VLM file is impossible')
      error = .true.
      return
    endif
    if (cub%file%block%iscplx.neqv.chanblock%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,fchan,lchan,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
    nc = lchan-fchan+1
    bfchan = fchan-cub%file%block%first+1  ! First position in cub%file%block
    blchan = lchan-cub%file%block%first+1  ! Last position in cub%file%block
    ndata = cub%desc%nx*cub%desc%ny*nc
    if (cub%file%block%iscplx) then
      call c4toc4_sl(chanblock%c4,cub%file%block%c4(1,1,bfchan),ndata)
    else
      call r4tor4_sl(chanblock%r4,cub%file%block%r4(1,1,bfchan),ndata)
    endif
    !
  end subroutine cubeio_put_chanblock_to_block

end module cubeio_chanblock
