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

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

  private
  public :: cubeio_pixblock_t
  public :: cubeio_get_pixblock,cubeio_put_pixblock,cubeio_free_pixblock

contains

  subroutine cubeio_reallocate_pixblock(pixblock,iscplx,nc,np,error)
    use gkernel_interfaces
    !-------------------------------------------------------------------
    ! (Re)allocate a cubeio_pixblock_t
    ! Do nothing when the array sizes do not need to change
    !-------------------------------------------------------------------
    type(cubeio_pixblock_t), intent(inout) :: pixblock
    logical,                 intent(in)    :: iscplx
    integer(kind=chan_k),    intent(in)    :: nc
    integer(kind=pixe_k),    intent(in)    :: np
    logical,                 intent(inout) :: error
    ! Local
    character(len=*), parameter :: rname='REALLOCATE>CUBE>PIXBLOCK'
    integer(kind=4) :: ier
    integer(kind=pixe_k) :: mp
    !
    call cubeio_message(ioseve%trace,rname,'Welcome')
    !
    ! Sanity checks
    if (nc.le.0) then
      call cubeio_message(seve%e,rname,'Number of channels is null or negative')
      error = .true.
    endif
    if (np.le.0) then
      call cubeio_message(seve%e,rname,'Number of pixels is null or negative')
      error = .true.
    endif
    if (error)  return
    !
    ! Allocation or reallocation?
    if (pixblock%allocated.eq.code_pointer_allocated) then
      ! Reallocation?
      if (pixblock%iscplx) then
        mp = ubound(pixblock%c4,2)
      else
        mp = ubound(pixblock%r4,2)
      endif
      if ((pixblock%iscplx.eqv.iscplx) .and.  &
           pixblock%nc.eq.nc           .and.  &
           mp.ge.np) then
        ! Same type and same size (at least on 2nd dim) => Nothing to be done!
        call cubeio_message(ioseve%alloc,rname,'Pixel block already allocated with correct size')
        goto 100
      else  ! Different type or different size => reallocation
        call cubeio_message(ioseve%alloc,rname,'Reallocating pixel array')
        call cubeio_free_pixblock(pixblock,error)
        if (error)  return
      endif
    else
      ! Allocation
      call cubeio_message(ioseve%alloc,rname,'Creating pixel array')
    endif
    !
    ! Reallocate memory of the right size
    if (iscplx) then
      allocate(pixblock%c4(nc,np),stat=ier)
    else
      allocate(pixblock%r4(nc,np),stat=ier)
    endif
    if (failed_allocate(rname,'Pixel array',ier,error)) return
    !
  100 continue
    ! Operation success
    pixblock%nc = nc
    pixblock%np = np
    pixblock%iscplx = iscplx
    pixblock%allocated = code_pointer_allocated
    !
  end subroutine cubeio_reallocate_pixblock

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

  subroutine cubeio_get_pixblock(cubset,cubdef,head,cub,fpix,lpix,pixblock,error)
    !---------------------------------------------------------------------
    ! Get all data (Nc) for the desired pixel
    !---------------------------------------------------------------------
    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=pixe_k),    intent(in)    :: fpix,lpix
    type(cubeio_pixblock_t), intent(inout) :: pixblock
    logical,                 intent(inout) :: error
    ! Local
    character(len=*), parameter :: rname='GET>PIXBLOCK'
    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 (fpix.le.0 .or. lpix.gt.cub%desc%nx*cub%desc%ny) then
      write(mess,'(2(A,I0))')  'Pixel range out of range 1 - ',cub%desc%nx*cub%desc%ny
      call cubeio_message(seve%e,rname,mess)
      error = .true.
      return
    endif
    !
    select case (cub%desc%buffered)
    case (code_buffer_memory)
      call cubeio_get_pixblock_from_memory(cubset,cub,fpix,lpix,pixblock,error)
    case (code_buffer_disk)
      call cubeio_get_pixblock_from_block(cubset,head,cub,fpix,lpix,pixblock,error)
    case default
      call cubeio_message(seve%e,rname,'Unexpected cube buffering')
      error = .true.
    end select
    if (error)  return
    !
  end subroutine cubeio_get_pixblock

  subroutine cubeio_get_pixblock_from_memory(cubset,cub,fpix,lpix,pixblock,error)
    !---------------------------------------------------------------------
    ! Get all data (Nc) for the desired pixel, in the context of memory
    ! mode. In return, the 'pixblock' points to the cube data buffer.
    ! --
    ! Do not call directly, use cubeio_get_pixblock instead.
    !---------------------------------------------------------------------
    type(cube_setup_t),          intent(in)    :: cubset
    type(cubeio_cube_t), target, intent(in)    :: cub
    integer(kind=pixe_k),        intent(in)    :: fpix
    integer(kind=pixe_k),        intent(in)    :: lpix
    type(cubeio_pixblock_t),     intent(inout) :: pixblock
    logical,                     intent(inout) :: error
    ! Local
    character(len=*), parameter :: rname='GET>PIXBLOCK'
    integer(kind=pixe_k) :: np,ipix,opix
    real(kind=sign_k), pointer :: allr4(:,:)
    complex(kind=sign_k), pointer :: allc4(:,:)
    !
    np = lpix-fpix+1
    !
    select case (cub%desc%order)
    case (code_cube_speset)
      ! Data is simply associated to VLM buffer
      ! ZZZ deallocate if needed before associating!
      pixblock%nc = cub%memo%nc
      pixblock%np = np
      if (cub%memo%iscplx) then
        allc4(1:cub%memo%nc,1:cub%memo%nx*cub%memo%ny) => cub%memo%c4
        pixblock%c4 => allc4(:,fpix:lpix)
      else
        allr4(1:cub%memo%nc,1:cub%memo%nx*cub%memo%ny) => cub%memo%r4
        pixblock%r4 => allr4(:,fpix:lpix)
      endif
      pixblock%iscplx = cub%memo%iscplx
      pixblock%allocated = code_pointer_associated
    case (code_cube_imaset)
      ! Data is copied/duplicated from LMV buffer
      call cubeio_reallocate_pixblock(pixblock,cub%memo%iscplx,  &
        cub%memo%nc,np,error)
      if (error)  return
      ! Non-contiguous (unefficient) copy
      if (cub%memo%iscplx) then
        allc4(1:cub%memo%nx*cub%memo%ny,1:cub%memo%nc) => cub%memo%c4
        do ipix=fpix,lpix
          opix = ipix-fpix+1
          pixblock%c4(:,opix) = allc4(ipix,:)
        enddo
      else
        allr4(1:cub%memo%nx*cub%memo%ny,1:cub%memo%nc) => cub%memo%r4
        do ipix=fpix,lpix
          opix = ipix-fpix+1
          pixblock%r4(:,opix) = allr4(ipix,:)
        enddo
      endif
    case default
      call cubeio_message(seve%e,rname,'No data available')
      error = .true.
      return
    end select
  end subroutine cubeio_get_pixblock_from_memory

  subroutine cubeio_get_pixblock_from_block(cubset,head,cub,fpix,lpix,pixblock,error)
    !---------------------------------------------------------------------
    ! Get all data (Nc) for the desired range of pixels, in the context of
    ! disk mode. In return, the 'pixblock' points to a memory buffer that
    ! is intended to disappear as others pixels are accessed => no warranty
    ! the pointer remains valid after another call.
    ! --
    ! Do not call directly, use cubeio_get_pixblock 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=pixe_k),        intent(in)    :: fpix
    integer(kind=pixe_k),        intent(in)    :: lpix
    type(cubeio_pixblock_t),     intent(inout) :: pixblock
    logical,                     intent(inout) :: error
    ! Local
    character(len=*), parameter :: rname='GET>PIXBLOCK'
    integer(kind=pixe_k) :: np,fypix,lypix,bfpix,blpix
    real(kind=sign_k), pointer :: allr4(:,:)
    complex(kind=sign_k), pointer :: allc4(:,:)
    !
    np = lpix-fpix+1
    !
    select case (cub%desc%order)
    case (code_cube_speset,code_cube_imaset)
      fypix = (fpix-1)/cub%desc%nx+1
      lypix = (lpix-1)/cub%desc%nx+1
      ! In case of LMV data, this call will collect the data by traversing
      ! the whole file. Unefficient, but useful for transposition.
      call cubeio_check_input_pix_block(cubset,head,cub,fypix,lypix,error)
      if (error)  return
      !
      ! Point pixel data from correct position in pixblock%block
      bfpix = fpix - cub%desc%nx*(cub%file%block%first-1)  ! Position in pixblock%block
      blpix = lpix - cub%desc%nx*(cub%file%block%first-1)  ! Position in pixblock%block
      ! ZZZ deallocate if needed before associating!
      pixblock%nc = cub%desc%nc
      pixblock%np = np
      if (cub%file%block%iscplx) then
        allc4(1:cub%file%block%dim1,1:cub%file%block%dim2*cub%file%block%dim3) => cub%file%block%c4
        pixblock%c4 => allc4(:,bfpix:blpix)
      else
        allr4(1:cub%file%block%dim1,1:cub%file%block%dim2*cub%file%block%dim3) => cub%file%block%r4
        pixblock%r4 => allr4(:,bfpix:blpix)
      endif
      pixblock%iscplx = cub%file%block%iscplx
      pixblock%allocated = code_pointer_associated
      !
    case default
      call cubeio_message(seve%e,rname,'No data available')
      error = .true.
      return
    end select
    !
  end subroutine cubeio_get_pixblock_from_block
  !
  subroutine cubeio_put_pixblock(cubset,cubdef,head,cub,fpix,lpix,pixblock,error)
    use gkernel_interfaces
    use cubetools_header_types
    !-------------------------------------------------------------------
    ! Put all data (Nc) for the desired pixel
    ! (This is symetric to cubeio_get_pix)
    !-------------------------------------------------------------------
    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=pixe_k),    intent(in)    :: fpix
    integer(kind=pixe_k),    intent(in)    :: lpix
    type(cubeio_pixblock_t), intent(in)    :: pixblock
    logical,                 intent(inout) :: error
    ! Local
    character(len=*), parameter :: rname='PUT>PIXBLOCK'
    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 (fpix.le.0 .or. lpix.gt.cub%desc%nx*cub%desc%ny) then
      write(mess,'(A,I0)')  'Pixel range out of range 1 - ',cub%desc%nx*cub%desc%ny
      call cubeio_message(seve%e,rname,mess)
      error = .true.
    endif
    if (pixblock%nc.ne.cub%desc%nc) then
      write(mess,'(3(A,I0))')  'Number of channels mismatch: attempt to put ',  &
        pixblock%nc,' channels while output cube has ',cub%desc%nc,' channels'
      call cubeio_message(seve%e,rname,mess)
      error = .true.
    endif
    if (pixblock%iscplx.neqv.cub%desc%iscplx) then
      call cubeio_message(seve%e,rname,'Pixel 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_pixblock_to_data(cubset,cub,fpix,lpix,pixblock,error)
    case (code_buffer_disk)
      call cubeio_put_pixblock_to_block(cubset,head,cub,fpix,lpix,pixblock,error)
    case default
      call cubeio_message(seve%e,rname,'Unexpected cube data buffering')
      error = .true.
      return
    end select
    !
  end subroutine cubeio_put_pixblock
  !
  subroutine cubeio_put_pixblock_to_data(cubset,cub,fpix,lpix,pixblock,error)
    !-------------------------------------------------------------------
    ! Write a single channel to the cubeio_memory_t, in the context of
    ! memory mode.
    ! ---
    ! Do not call directly, use cubeio_put_pixblock instead.
    !-------------------------------------------------------------------
    type(cube_setup_t),          intent(in)    :: cubset
    type(cubeio_cube_t), target, intent(inout) :: cub
    integer(kind=pixe_k),        intent(in)    :: fpix
    integer(kind=pixe_k),        intent(in)    :: lpix
    type(cubeio_pixblock_t),     intent(in)    :: pixblock
    logical,                     intent(inout) :: error
    ! Local
    character(len=*), parameter :: rname='PUT>PIXBLOCK'
    integer(kind=pixe_k) :: np,ipix,opix
    real(kind=sign_k), pointer :: allr4(:,:)
    complex(kind=sign_k), pointer :: allc4(:,:)
    !
    np = lpix-fpix+1
    !
    select case (cub%desc%order)
    case (code_cube_speset)
      if (cub%memo%iscplx) then
        allc4(1:cub%memo%nc,1:cub%memo%nx*cub%memo%ny) => cub%memo%c4
        allc4(:,fpix:lpix) = pixblock%c4(:,1:np)
      else
        allr4(1:cub%memo%nc,1:cub%memo%nx*cub%memo%ny) => cub%memo%r4
        allr4(:,fpix:lpix) = pixblock%r4(:,1:np)
      endif
    case (code_cube_imaset)
      ! Non-contiguous (unefficient) copies
      if (cub%memo%iscplx) then
        allc4(1:cub%memo%nx*cub%memo%ny,1:cub%memo%nc) => cub%memo%c4
        do opix=fpix,lpix
          ipix = opix-fpix+1
          allc4(opix,:) = pixblock%c4(:,ipix)
        enddo
      else
        allr4(1:cub%memo%nx*cub%memo%ny,1:cub%memo%nc) => cub%memo%r4
        do opix=fpix,lpix
          ipix = opix-fpix+1
          allr4(opix,:) = pixblock%r4(:,ipix)
        enddo
      endif
    case default
      call cubeio_message(seve%e,rname,'No data available')
      error = .true.
      return
    end select
    !
  end subroutine cubeio_put_pixblock_to_data
  !
  subroutine cubeio_put_pixblock_to_block(cubset,head,cub,fpix,lpix,pixblock,error)
    !-------------------------------------------------------------------
    ! Write a single channel to the cubeio_block_t, in the context of
    ! disk mode.
    ! ---
    ! Do not call directly, use cubeio_put_pixblock 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=pixe_k),        intent(in)    :: fpix
    integer(kind=pixe_k),        intent(in)    :: lpix
    type(cubeio_pixblock_t),     intent(in)    :: pixblock
    logical,                     intent(inout) :: error
    ! Local
    character(len=*), parameter :: rname='PUT>PIXBLOCK'
    integer(kind=pixe_k) :: np,fypix,lypix,bfpix,blpix
    integer(kind=size_length) :: ndata
    real(kind=sign_k), pointer :: allr4(:,:)
    complex(kind=sign_k), pointer :: allc4(:,:)
    !
    if (cub%desc%order.ne.code_cube_speset) then
      call cubeio_message(seve%e,rname,'Writing a pixel to disk in a LMV file is impossible')
      error = .true.
      return
    endif
    if (cub%file%block%iscplx.neqv.pixblock%iscplx) then
      call cubeio_message(seve%e,rname,'Pixel and output cube mismatch type (R*4/C*4)')
      error = .true.
      return
    endif
    !
    fypix = (fpix-1)/cub%desc%nx+1
    lypix = (lpix-1)/cub%desc%nx+1
    call cubeio_check_output_pix_block(cubset,head,cub,fypix,lypix,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
    bfpix = fpix - cub%desc%nx*(cub%file%block%first-1)  ! Position in pixblock%block
    blpix = lpix - cub%desc%nx*(cub%file%block%first-1)  ! Position in pixblock%block
    np = lpix-fpix+1
    ndata = cub%desc%nc*np
    if (cub%file%block%iscplx) then
      allc4(1:cub%file%block%dim1,1:cub%file%block%dim2*cub%file%block%dim3) => cub%file%block%c4
      call c4toc4_sl(pixblock%c4,allc4(1,bfpix),ndata)
    else
      allr4(1:cub%file%block%dim1,1:cub%file%block%dim2*cub%file%block%dim3) => cub%file%block%r4
      call r4tor4_sl(pixblock%r4,allr4(1,bfpix),ndata)
    endif
    !
  end subroutine cubeio_put_pixblock_to_block

end module cubeio_pixblock
