module cubeio_subcube
  !---------------------------------------------------------------------
  ! Support module for a contiguous block of 2D planes
  !---------------------------------------------------------------------
  use cubetools_parameters
  use cubetools_setup_types
  use cubedag_node_type
  use cubeio_messaging
  use cubeio_cube_define
  use cubeio_cube
  use cubeio_flush
  use cubeio_read
  use cubeio_write

  type cubeio_subcube_t
    integer(kind=data_k), public  :: f3 = 0  ! Index of first plane in the corresponding full cube
    integer(kind=data_k), public  :: n1 = 0                         ! Size of 1st dimension
    integer(kind=data_k), public  :: n2 = 0                         ! Size of 2nd dimension
    integer(kind=data_k), public  :: n3 = 0                         ! (Useful) size of 3rd dimension
    integer(kind=code_k), public  :: allocated = code_pointer_null  !
    logical,              public  :: iscplx = .false.               ! R*4 or C*4?
    real(kind=sign_k),    public, pointer :: r4(:,:,:) => null()    ! [n1,n2,m3]
    complex(kind=sign_k), public, pointer :: c4(:,:,:) => null()    ! [n1,n2,m3]
  contains
    procedure, public :: get  => cubeio_get_subcube
    procedure, public :: put  => cubeio_put_subcube
    procedure, public :: free => cubeio_free_subcube
  end type cubeio_subcube_t

  private
  public :: cubeio_subcube_t
  public :: cubeio_iterate_subcube

contains

  subroutine cubeio_reallocate_subcube(subcube,iscplx,n1,n2,n3,error)
    use gkernel_interfaces
    !-------------------------------------------------------------------
    ! (Re)allocate a cubeio_subcube_t
    ! Do nothing when the array sizes do not need to change
    !-------------------------------------------------------------------
    type(cubeio_subcube_t), intent(inout) :: subcube
    logical,                intent(in)    :: iscplx
    integer(kind=data_k),   intent(in)    :: n1
    integer(kind=data_k),   intent(in)    :: n2
    integer(kind=data_k),   intent(in)    :: n3  ! Minimum desired (can be different from size of allocation)
    logical,                intent(inout) :: error
    ! Local
    character(len=*), parameter :: rname='REALLOCATE>SUBCUBE'
    integer(kind=4) :: ier
    integer(kind=data_k) :: m3
    !
    call cubeio_message(ioseve%trace,rname,'Welcome')
    !
    ! Sanity checks
    if (n1.le.0) then
      call cubeio_message(seve%e,rname,'Size of 1st dimension is null or negative')
      error = .true.
    endif
    if (n2.le.0) then
      call cubeio_message(seve%e,rname,'Size of 2nd dimension is null or negative')
      error = .true.
    endif
    if (n3.le.0) then
      call cubeio_message(seve%e,rname,'Size of 3rd dimension is null or negative')
      error = .true.
    endif
    if (error)  return
    !
    ! Allocation or reallocation?
    if (subcube%allocated.eq.code_pointer_allocated) then
      ! Reallocation?
      if (subcube%iscplx) then
        m3 = ubound(subcube%c4,3)
      else
        m3 = ubound(subcube%r4,3)
      endif
      if ((subcube%iscplx.eqv.iscplx) .and.  &
           subcube%n1.eq.n1           .and.  &
           subcube%n2.eq.n2           .and.  &
           m3.ge.n3) then
        ! Same type and same size (at least on 3rd dim) => Nothing to be done!
        call cubeio_message(ioseve%alloc,rname,'Subcube already allocated with correct size')
        goto 100
      else  ! Different type or different size => reallocation
        call cubeio_message(ioseve%alloc,rname,'Reallocating subcube')
        call cubeio_free_subcube(subcube,error)
        if (error)  return
      endif
    else
      ! Allocation
      call cubeio_message(ioseve%alloc,rname,'Creating subcube')
    endif
    !
    ! Reallocate memory of the right size
    if (iscplx) then
      allocate(subcube%c4(n1,n2,n3),stat=ier)
    else
      allocate(subcube%r4(n1,n2,n3),stat=ier)
    endif
    if (failed_allocate(rname,'Subcube',ier,error)) return
    !
  100 continue
    ! Operation success
    subcube%n1 = n1
    subcube%n2 = n2
    subcube%n3 = n3
    subcube%iscplx = iscplx
    subcube%allocated = code_pointer_allocated
    !
  end subroutine cubeio_reallocate_subcube

  subroutine cubeio_free_subcube(subcube,error)
    !---------------------------------------------------------------------
    ! Free a 'cubeio_subcube_t' instance
    !---------------------------------------------------------------------
    class(cubeio_subcube_t), intent(inout) :: subcube
    logical,                 intent(inout) :: error
    !
    if (subcube%allocated.eq.code_pointer_allocated) then
      if (subcube%iscplx) then
        deallocate(subcube%c4)
      else
        deallocate(subcube%r4)
      endif
    endif
    !
    subcube%f3 = 0
    subcube%n1 = 0
    subcube%n2 = 0
    subcube%n3 = 0
    subcube%allocated = code_pointer_null
    subcube%iscplx = .false.
    subcube%c4 => null()
    subcube%r4 => null()
  end subroutine cubeio_free_subcube

  subroutine cubeio_get_subcube(subcube,cubset,cubdef,dno,cub,f3,l3,order,error)
    use cubetools_access_types
    !---------------------------------------------------------------------
    ! Get all data (N1 x N2) for the desired range on 3rd dimension
    ! ---
    ! Usually called for a subcube in native order, if the requested order
    ! is different, implicit transposition will occur.
    !---------------------------------------------------------------------
    class(cubeio_subcube_t),      intent(inout) :: subcube
    type(cube_setup_t),           intent(in)    :: cubset
    type(cube_define_t),          intent(in)    :: cubdef
    class(cubedag_node_object_t), intent(inout) :: dno
    type(cubeio_cube_t),          intent(inout) :: cub
    integer(kind=data_k),         intent(in)    :: f3
    integer(kind=data_k),         intent(in)    :: l3
    integer(kind=code_k),         intent(in)    :: order   ! Desired order
    logical,                      intent(inout) :: error
    ! Local
    character(len=*), parameter :: rname='GET>SUBCUBE'
    integer(kind=data_k) :: n3
    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
    select case (order)
    case (code_cube_imaset)
      n3 = cub%desc%nc
    case (code_cube_speset)
      n3 = cub%desc%ny
    case default
      write(mess,'(A,I0)')  'Unexpected subcube order: ',order
      call cubeio_message(seve%e,rname,mess)
      error = .true.
      return
    end select
    if (f3.le.0 .or. l3.gt.n3) then
      write(mess,'(3(A,I0),2A)')  'Subcube range ',f3,'-',l3,  &
        ' out of input cube range 1-',n3,' for order ',cubetools_ordername(order)
      call cubeio_message(seve%e,rname,mess)
      error = .true.
      return
    endif
    !
    subcube%f3 = f3  ! Bookkeeping at which position it was gotten
    select case (cub%desc%buffered)
    case (code_buffer_memory)
      call cubeio_get_subcube_from_memory(cubset,cub,f3,l3,order,subcube,error)
    case (code_buffer_disk)
      call cubeio_get_subcube_from_block(cubset,dno,cub,f3,l3,order,subcube,error)
    case default
      call cubeio_message(seve%e,rname,'Unexpected cube buffering')
      error = .true.
    end select
    if (error)  return
  end subroutine cubeio_get_subcube

  subroutine cubeio_get_subcube_from_memory(cubset,cub,f3,l3,order,subcube,error)
    !---------------------------------------------------------------------
    ! Get all data (N1 x N2) for the desired range, in the context of
    ! memory mode. In return, the 'subcube' points to the cube data buffer.
    ! --
    ! Do not call directly, use cubeio_get_subcube instead.
    !---------------------------------------------------------------------
    type(cube_setup_t),          intent(in)    :: cubset
    type(cubeio_cube_t), target, intent(in)    :: cub
    integer(kind=data_k),        intent(in)    :: f3
    integer(kind=data_k),        intent(in)    :: l3
    integer(kind=code_k),        intent(in)    :: order   ! Desired order
    type(cubeio_subcube_t),      intent(inout) :: subcube
    logical,                     intent(inout) :: error
    ! Local
    character(len=*), parameter :: rname='GET>SUBCUBE>FROM>MEMORY'
    integer(kind=data_k) :: n3,ic,oc,iy,oy
    !
    n3 = l3-f3+1
    !
    if (order.eq.cub%desc%order) then  ! Native order
      ! Data is simply associated to memory buffer
      ! ZZZ deallocate if needed before associating!
      subcube%n1 = cub%desc%n1
      subcube%n2 = cub%desc%n2
      subcube%n3 = n3
      if (cub%memo%iscplx) then
        subcube%c4 => cub%memo%c4(:,:,f3:l3)
      else
        subcube%r4 => cub%memo%r4(:,:,f3:l3)
      endif
      subcube%iscplx = cub%memo%iscplx
      subcube%allocated = code_pointer_associated
      !
    elseif (order.eq.code_cube_speset .and.  &
            cub%desc%order.eq.code_cube_imaset) then
      ! Subcube is VLM, cube is LMV: transposition needed
      call cubeio_reallocate_subcube(subcube,cub%memo%iscplx,cub%desc%nc,cub%desc%nx,n3,error)
      if (error)  return
      if (cub%memo%iscplx) then
        do iy=f3,l3
          oy = iy-f3+1
          do ic=1,cub%desc%nc
            subcube%c4(ic,:,oy) = cub%memo%c4(:,iy,ic)
          enddo
        enddo
      else
        do iy=f3,l3
          oy = iy-f3+1
          do ic=1,cub%desc%nc
            subcube%r4(ic,:,oy) = cub%memo%r4(:,iy,ic)
          enddo
        enddo
      endif
      !
    elseif (order.eq.code_cube_imaset .and.  &
            cub%desc%order.eq.code_cube_speset) then
      ! Subcube is LMV, cube is VLM: transposition needed
      call cubeio_reallocate_subcube(subcube,cub%memo%iscplx,cub%desc%nx,cub%desc%ny,n3,error)
      if (error)  return
      if (cub%memo%iscplx) then
        do ic=f3,l3
          oc = ic-f3+1
          do iy=1,cub%desc%ny
            subcube%c4(:,iy,oc) = cub%memo%c4(ic,:,iy)
          enddo
        enddo
      else
        do ic=f3,l3
          oc = ic-f3+1
          do iy=1,cub%desc%ny
            subcube%r4(:,iy,oc) = cub%memo%r4(ic,:,iy)
          enddo
        enddo
      endif
      !
    else
      call cubeio_message(seve%e,rname,  &
        'No data available or transposition not implemented')
      error = .true.
      return
    endif
  end subroutine cubeio_get_subcube_from_memory

  subroutine cubeio_get_subcube_from_block(cubset,dno,cub,f3,l3,order,subcube,error)
    !---------------------------------------------------------------------
    ! Get all data (N1 x N2) for the desired range, in the context of
    ! disk mode. In return, the 'subcube' points to a memory buffer that is
    ! intended to disappear as others planes are accessed => no warranty
    ! the pointer remains valid after another call.
    ! --
    ! Do not call directly, use cubeio_get_subcube instead.
    !---------------------------------------------------------------------
    type(cube_setup_t),           intent(in)    :: cubset
    class(cubedag_node_object_t), intent(inout) :: dno
    type(cubeio_cube_t), target,  intent(inout) :: cub
    integer(kind=data_k),         intent(in)    :: f3
    integer(kind=data_k),         intent(in)    :: l3
    integer(kind=code_k),         intent(in)    :: order   ! Desired order
    type(cubeio_subcube_t),       intent(inout) :: subcube
    logical,                      intent(inout) :: error
    ! Local
    character(len=*), parameter :: rname='GET>SUBCUBE>FROM>BLOCK'
    integer(kind=data_k) :: n3,bf3,bl3
    !
    n3 = l3-f3+1
    !
    if (order.eq.cub%desc%order) then
      ! Native order
      call cubeio_check_input_any_block(cubset,dno,cub,f3,l3,error)
      if (error)  return
    elseif (order.eq.code_cube_speset .and.  &
            cub%desc%order.eq.code_cube_imaset) then
      ! Subcube is VLM, cube is LMV: transposition needed. This is done
      ! when reading the block.
      call cubeio_check_input_pix_block(cubset,dno,cub,f3,l3,error)
      if (error)  return
    elseif (order.eq.code_cube_imaset .and.  &
            cub%desc%order.eq.code_cube_speset) then
      ! Subcube is LMV, cube is VLM: transposition needed. This is done
      ! when reading the block.
      call cubeio_check_input_chan_block(cubset,dno,cub,f3,l3,error)
      if (error)  return
    else
      call cubeio_message(seve%e,rname,  &
        'No data available or transposition not implemented')
      error = .true.
      return
    endif
    !
    ! Now the subcube is simply associated to the file block
    bf3 = f3-cub%file%block%first+1  ! First position in cub%file%block
    bl3 = l3-cub%file%block%first+1  ! Last position in cub%file%block
    ! ZZZ deallocate if needed before associating!
    subcube%n1 = cub%file%block%dim1
    subcube%n2 = cub%file%block%dim2
    subcube%n3 = n3
    if (cub%file%block%iscplx) then
      subcube%c4 => cub%file%block%c4(:,:,bf3:bl3)
    else
      subcube%r4 => cub%file%block%r4(:,:,bf3:bl3)
    endif
    subcube%iscplx = cub%file%block%iscplx
    subcube%allocated = code_pointer_associated
  end subroutine cubeio_get_subcube_from_block
  !
  subroutine cubeio_put_subcube(subcube,cubset,cubdef,dno,cub,f3,l3,error)
    use gkernel_interfaces
    !-------------------------------------------------------------------
    ! Put all data (N1 x N2) for the desired channel range
    ! (This is symetric to cubeio_get_subcube)
    ! ---
    ! Subcube data is always put in native order
    !-------------------------------------------------------------------
    class(cubeio_subcube_t),      intent(inout) :: subcube
    type(cube_setup_t),           intent(in)    :: cubset
    type(cube_define_t),          intent(in)    :: cubdef
    class(cubedag_node_object_t), intent(inout) :: dno
    type(cubeio_cube_t),          intent(inout) :: cub
    integer(kind=data_k),         intent(in)    :: f3
    integer(kind=data_k),         intent(in)    :: l3
    logical,                      intent(inout) :: error
    ! Local
    character(len=*), parameter :: rname='PUT>SUBCUBE'
    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 (f3.le.0 .or. l3.gt.cub%desc%n3) then
      write(mess,'(3(A,I0))')  'Subcube range ',f3,'-',l3,  &
        ' out of output cube range 1-',cub%desc%n3
      call cubeio_message(seve%e,rname,mess)
      error = .true.
    endif
    if (subcube%n1.ne.cub%desc%n1 .or. subcube%n2.ne.cub%desc%n2) then
      write(mess,'(5(A,I0))')  'N1 or N2 mismatch: attempt to put ',  &
        subcube%n1,'x',subcube%n2,' sized plane(s) while output cube has ',  &
        cub%desc%n1,'x',cub%desc%n2,' planes'
      call cubeio_message(seve%e,rname,mess)
      error = .true.
    endif
    if (subcube%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
    !
    subcube%f3 = f3  ! Bookkeeping at which position it was put
    select case (cub%desc%buffered)
    case (code_buffer_memory)
      call cubeio_put_subcube_to_data(cubset,cub,f3,l3,subcube,error)
    case (code_buffer_disk)
      call cubeio_put_subcube_to_block(cubset,dno,cub,f3,l3,subcube,error)
    case default
      call cubeio_message(seve%e,rname,'Unexpected cube data buffering')
      error = .true.
    end select
    if (error)  return
  end subroutine cubeio_put_subcube
  !
  subroutine cubeio_put_subcube_to_data(cubset,cub,f3,l3,subcube,error)
    !-------------------------------------------------------------------
    ! Write a data range to the cubeio_memory_t, in the context of
    ! memory mode.
    ! ---
    ! Do not call directly, use cubeio_put_subcube instead.
    !-------------------------------------------------------------------
    type(cube_setup_t),     intent(in)    :: cubset
    type(cubeio_cube_t),    intent(inout) :: cub
    integer(kind=data_k),   intent(in)    :: f3
    integer(kind=data_k),   intent(in)    :: l3
    type(cubeio_subcube_t), intent(in)    :: subcube
    logical,                intent(inout) :: error
    ! Local
    character(len=*), parameter :: rname='PUT>SUBCUBE'
    integer(kind=data_k) :: n3,i3,o3
    !
    n3 = l3-f3+1
    !
    select case (cub%desc%order)
    case (code_cube_imaset,code_cube_speset)
      if (cub%memo%iscplx) then
        do o3=f3,l3
          i3 = o3-f3+1
          cub%memo%c4(:,:,o3) = subcube%c4(:,:,i3)
        enddo
      else
        do o3=f3,l3
          i3 = o3-f3+1
          cub%memo%r4(:,:,o3) = subcube%r4(:,:,i3)
        enddo
      endif
    case default
      call cubeio_message(seve%e,rname,'No data available')
      error = .true.
      return
    end select
    !
  end subroutine cubeio_put_subcube_to_data
  !
  subroutine cubeio_put_subcube_to_block(cubset,dno,cub,f3,l3,subcube,error)
    !-------------------------------------------------------------------
    ! Write a data range to the cubeio_block_t, in the context of
    ! disk mode.
    ! ---
    ! Do not call directly, use cubeio_put_subcube instead.
    !-------------------------------------------------------------------
    type(cube_setup_t),           intent(in)    :: cubset
    class(cubedag_node_object_t), intent(inout) :: dno
    type(cubeio_cube_t),          intent(inout) :: cub
    integer(kind=data_k),         intent(in)    :: f3
    integer(kind=data_k),         intent(in)    :: l3
    type(cubeio_subcube_t),       intent(in)    :: subcube
    logical,                      intent(inout) :: error
    ! Local
    character(len=*), parameter :: rname='PUT>SUBCUBE'
    integer(kind=data_k) :: n3,bf3,bl3
    integer(kind=size_length) :: ndata
    !
    if (cub%file%block%iscplx.neqv.subcube%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_any_block(cubset,dno,cub,f3,l3,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
    n3 = l3-f3+1
    bf3 = f3-cub%file%block%first+1  ! First position in cub%file%block
    bl3 = l3-cub%file%block%first+1  ! Last position in cub%file%block
    ndata = cub%desc%n1*cub%desc%n2*n3
    if (cub%file%block%iscplx) then
      call c4toc4_sl(subcube%c4,cub%file%block%c4(1,1,bf3),ndata)
    else
      call r4tor4_sl(subcube%r4,cub%file%block%r4(1,1,bf3),ndata)
    endif
    !
  end subroutine cubeio_put_subcube_to_block
  !
  subroutine cubeio_iterate_subcube(cubset,cubdef,dno,cub,first,last,error)
    !---------------------------------------------------------------------
    ! Prepare buffers for working (at least) on the requested range.
    ! To be used when iterating the cube in native order. Otherwise use
    ! cubeio_iterate_pix or cubeio_iterate_chan.
    ! ZZZ All the 3 iteration procedures should be merged if the 3
    ! associated types are merged.
    !---------------------------------------------------------------------
    type(cube_setup_t),           intent(in)    :: cubset
    type(cube_define_t),          intent(in)    :: cubdef
    class(cubedag_node_object_t), intent(inout) :: dno
    type(cubeio_cube_t),          intent(inout) :: cub
    integer(kind=data_k),         intent(in)    :: first
    integer(kind=data_k),         intent(in)    :: last
    logical,                      intent(inout) :: error
    ! Local
    character(len=*), parameter :: rname='ITERATE>SUBCUBE'
    !
    select case (cub%desc%action)
    case (code_read_head)
      call cubeio_message(seve%e,rname,'Access to data not allowed for action read-header')
      error = .true.
    case (code_read,code_update)
      call cubeio_iterate_read_subcube(cubset,cubdef,dno,cub,first,last,error)
    case (code_write)
      call cubeio_iterate_write_subcube(cubset,cubdef,dno,cub,first,last,error)
    case default
      call cubeio_message(seve%e,rname,'Unexpected action mode')
      error = .true.
    end select
  end subroutine cubeio_iterate_subcube

  subroutine cubeio_iterate_read_subcube(cubset,cubdef,dno,icub,first,last,error)
    !---------------------------------------------------------------------
    ! Pre-load all or part of the data from disk in a buffer which
    ! provides (at least) the requested range.
    !---------------------------------------------------------------------
    type(cube_setup_t),           intent(in)    :: cubset
    type(cube_define_t),          intent(in)    :: cubdef
    class(cubedag_node_object_t), intent(inout) :: dno
    type(cubeio_cube_t),          intent(inout) :: icub
    integer(kind=data_k),         intent(in)    :: first
    integer(kind=data_k),         intent(in)    :: last
    logical,                      intent(inout) :: error
    ! Local
    character(len=*), parameter :: rname='ITERATE>READ>SUBCUBE'
    !
    ! On first iteration, read or prepare the cube data (does nothing on
    ! subsequent iterations):
    call cubeio_read_cube_data(cubset,cubdef,icub,error)
    if (error)  return
    !
    ! Work to be done on next iterations
    select case (icub%desc%buffered)
    case (code_buffer_none)
      return
    case (code_buffer_memory)
      return
    case (code_buffer_disk)
      ! Ensure the proper buffer is available in memory
      call cubeio_check_input_any_block(cubset,dno,icub,first,last,error)
      if (error)  return
    case default
      call cubeio_message(seve%e,rname,'Unexpected buffering kind')
      error = .true.
      return
    end select
  end subroutine cubeio_iterate_read_subcube

  subroutine cubeio_iterate_write_subcube(cubset,cubdef,dno,ocub,first,last,error)
    !---------------------------------------------------------------------
    ! Prepare a buffer covering all or part of the data, providing
    ! (at least) the requested range.
    !---------------------------------------------------------------------
    type(cube_setup_t),           intent(in)    :: cubset
    type(cube_define_t),          intent(in)    :: cubdef
    class(cubedag_node_object_t), intent(inout) :: dno
    type(cubeio_cube_t),          intent(inout) :: ocub
    integer(kind=data_k),         intent(in)    :: first
    integer(kind=data_k),         intent(in)    :: last
    logical,                      intent(inout) :: error
    ! Local
    character(len=*), parameter :: rname='ITERATE>WRITE>SUBCUBE'
    !
    ! On first iteration, prepare the cube data (does nothing on
    ! subsequent iterations):
    call cubeio_create_cube_data(cubset,cubdef,dno,ocub,error)
    if (error)  return
    !
    ! Work to be done on next iterations
    select case (ocub%desc%buffered)
    case (code_buffer_none)
      return
    case (code_buffer_memory)
      return
    case (code_buffer_disk)
      ! Ensure the proper buffer is available in memory
      call cubeio_check_output_any_block(cubset,dno,ocub,first,last,error)
      if (error)  return
    case default
      call cubeio_message(seve%e,rname,'Unexpected buffering kind')
      error = .true.
      return
    end select
  end subroutine cubeio_iterate_write_subcube

end module cubeio_subcube
