!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
module cubemain_compress
  use cubetools_parameters
  use cube_types
  use cubetools_structure
  use cubeadm_cubeid_types
  use cubeadm_cubeprod_types
  use cubetopology_cuberegion_types
  use cubemain_messaging
  !
  public :: compress
  private
  !
  type :: compress_comm_t
     type(option_t), pointer :: comm
     type(option_t), pointer :: spatial
     type(option_t), pointer :: spectral
     type(cuberegion_comm_t) :: region
     type(cubeid_arg_t), pointer :: incube
     type(cube_prod_t),  pointer :: oucube
   contains
     procedure, public  :: register => cubemain_compress_comm_register
     procedure, private :: parse    => cubemain_compress_comm_parse
     procedure, private :: main     => cubemain_compress_comm_main
  end type compress_comm_t
  type(compress_comm_t) :: compress
  !
  type compress_user_t
     type(cubeid_user_t)     :: cubeids
     logical                 :: dospatial
     character(len=24)       :: lmfactor
     logical                 :: dospectral
     character(len=24)       :: cfactor
     type(cuberegion_user_t) :: region
   contains
     procedure, private :: toprog => cubemain_compress_user_toprog
  end type compress_user_t
  !
  type compress_prog_t
     type(cuberegion_prog_t) :: region
     type(cube_t), pointer   :: incube
     integer(kind=indx_k)    :: lmfactor,cfactor
     integer(kind=indx_k)    :: factor1,factor2,factor3
     type(cube_t), pointer   :: oucube
   contains
     procedure, private :: header => cubemain_compress_prog_header
     procedure, private :: data   => cubemain_compress_prog_data
     procedure, private :: loop   => cubemain_compress_prog_loop
     procedure, private :: act    => cubemain_compress_prog_act
  end type compress_prog_t
  !
contains
  !
  subroutine cubemain_compress_command(line,error)
    !----------------------------------------------------------------------
    !
    !----------------------------------------------------------------------
    character(len=*), intent(in)    :: line
    logical,          intent(inout) :: error
    !
    type(compress_user_t) :: user
    character(len=*), parameter :: rname='COMPRESS>COMMAND'
    !
    call cubemain_message(mainseve%trace,rname,'Welcome')
    !
    call compress%parse(line,user,error)
    if (error) return
    call compress%main(user,error)
    if (error) continue
  end subroutine cubemain_compress_command
  !
  !----------------------------------------------------------------------
  !
  subroutine cubemain_compress_comm_register(comm,error)
    use cubedag_allflags
    !----------------------------------------------------------------------
    !
    !----------------------------------------------------------------------
    class(compress_comm_t), intent(inout) :: comm
    logical,                intent(inout) :: error
    !
    type(cubeid_arg_t) :: incube
    type(standard_arg_t) :: stdarg
    type(cube_prod_t) :: oucube
    character(len=*), parameter :: comm_abstract='Compress an image or cube by a factor 2 in spatial directions'
    character(len=*), parameter :: rname='COMPRESS>COMM>REGISTER'
    !
    call cubemain_message(mainseve%trace,rname,'Welcome')
    !
    ! Syntax
    call cubetools_register_command(&
         'COMPRESS','[cubeid]',&
         comm_abstract,&
         strg_id,&
         cubemain_compress_command,&
         comm%comm,&
         error)
    if (error) return
    call incube%register(&
         'INPUT',&
         'Signal cube',&
         strg_id,&
         code_arg_optional,&
         [flag_any],&
         code_read,&
         code_access_subset,&
         comm%incube,&
         error)
    if (error) return
    !
    call cubetools_register_option(&
         'SPATIAL','N',&
         'Customize the compression factor along spatial axes',&
         strg_id,&
         comm%spatial,error)
    if (error) return
    call stdarg%register(&
         'N',&
         'Compression factor',&
         'Default is 2.',&
         code_arg_optional,&
         error)
    if (error) return
    !
    call cubetools_register_option(&
         'SPECTRAL','N',&
         'Customize the compression factor along spectral axis',&
         strg_id,&
         comm%spectral,error)
    if (error) return
    call stdarg%register(&
         'N',&
         'Compression factor',&
         'Default is 1 (no compression).',&
         code_arg_optional,&
         error)
    if (error) return
    !
    call comm%region%register(error)
    if (error) return
    !
    ! Products
    call oucube%register(&
         'COMPRESSED',&
         'Output cube',&
         strg_id,&
         [flag_compress],&
         comm%oucube,&
         error,&
         flagmode=keep_prod)
    if (error)  return
  end subroutine cubemain_compress_comm_register
  !
  subroutine cubemain_compress_comm_parse(comm,line,user,error)
    !----------------------------------------------------------------------
    ! COMPRESS [CubeId]
    !   /FACTOR [N]
    !   /SPECTRAL [N]
    !   /RANGE /CENTER /SIZE
    !----------------------------------------------------------------------
    class(compress_comm_t), intent(in)    :: comm
    character(len=*),       intent(in)    :: line
    type(compress_user_t),  intent(out)   :: user
    logical,                intent(inout) :: error
    !
    character(len=*), parameter :: rname='COMPRESS>COMM>PARSE'
    !
    call cubemain_message(mainseve%trace,rname,'Welcome')
    !
    call cubeadm_cubeid_parse(line,comm%comm,user%cubeids,error)
    if (error) return
    !
    call comm%spatial%present(line,user%dospatial,error)
    if (error) return
    if (user%dospatial) then
       call cubetools_getarg(line,comm%spatial,1,user%lmfactor,mandatory,error)
       if (error) return
    else
       user%lmfactor = strg_star
    endif
    !
    call comm%spectral%present(line,user%dospectral,error)
    if (error) return
    if (user%dospectral) then
       call cubetools_getarg(line,comm%spectral,1,user%cfactor,mandatory,error)
       if (error) return
    else
       user%cfactor = strg_star
    endif
    !
    call comm%region%parse(line,user%region,error)
    if (error) return
  end subroutine cubemain_compress_comm_parse
  !
  subroutine cubemain_compress_comm_main(comm,user,error)
    use cubeadm_timing
    !----------------------------------------------------------------------
    !
    !----------------------------------------------------------------------
    class(compress_comm_t), intent(in)    :: comm
    type(compress_user_t),  intent(inout) :: user
    logical,                   intent(inout) :: error
    !
    type(compress_prog_t) :: prog
    character(len=*), parameter :: rname='COMPRESS>MAIN'
    !
    call cubemain_message(mainseve%trace,rname,'Welcome')
    !
    call user%toprog(comm,prog,error)
    if (error) return
    call prog%header(comm,error)
    if (error) return
    call cubeadm_timing_prepro2process()
    call prog%data(error)
    if (error) return
    call cubeadm_timing_process2postpro()
  end subroutine cubemain_compress_comm_main
  !
  !----------------------------------------------------------------------
  !
  subroutine cubemain_compress_user_toprog(user,comm,prog,error)
    use cubetools_unit
    use cubetools_user2prog
    use cubeadm_get
    !----------------------------------------------------------------------
    !
    !----------------------------------------------------------------------
    class(compress_user_t), intent(in)    :: user
    type(compress_comm_t),  intent(in)    :: comm
    type(compress_prog_t),  intent(out)   :: prog
    logical,                   intent(inout) :: error
    !
    integer(kind=indx_k), parameter :: lmdefault=2
    integer(kind=indx_k), parameter :: cdefault=1
    character(len=*), parameter :: rname='COMPRESS>USER>TOPROG'
    !
    call cubemain_message(mainseve%trace,rname,'Welcome')
    !
    call cubeadm_get_header(comm%incube,user%cubeids,prog%incube,error)
    if (error) return
    !
    call cubetools_user2prog_resolve_star(user%lmfactor,lmdefault,prog%lmfactor,error)
    if (error) return
    !
    call cubetools_user2prog_resolve_star(user%cfactor,cdefault,prog%cfactor,error)
    if (error) return
    !
    select case (prog%incube%order())  ! Cube native order
    case (code_cube_imaset)
      prog%factor1 = prog%lmfactor
      prog%factor2 = prog%lmfactor
      prog%factor3 = prog%cfactor
    case (code_cube_speset)
      prog%factor1 = prog%cfactor
      prog%factor2 = prog%lmfactor
      prog%factor3 = prog%lmfactor
    case default
      call cubemain_message(seve%e,rname,'Unexpected cube order')
      error = .true.
      return
    end select
    !
    call user%region%toprog(prog%incube,prog%region,error)
    if (error) return
    ! User feedback about the interpretation of his command line
    ! call prog%region%list(error)
    ! if (error) return
  end subroutine cubemain_compress_user_toprog
  !
  !----------------------------------------------------------------------
  !
  subroutine cubemain_compress_prog_header(prog,comm,error)
    use cubetools_axis_types
    use cubetools_header_methods
    use cubeadm_clone
    !----------------------------------------------------------------------
    !
    !----------------------------------------------------------------------
    class(compress_prog_t), intent(inout) :: prog
    type(compress_comm_t),  intent(in)    :: comm
    logical,                intent(inout) :: error
    !
    type(axis_t) :: axis
    character(len=*), parameter :: rname='COMPRESS>PROG>HEADER'
    !
    call cubemain_message(mainseve%trace,rname,'Welcome')
    !
    call cubeadm_clone_header_with_region(comm%oucube,  &
      prog%incube,prog%region,prog%oucube,error)
    if (error) return
    !
    ! Then compress the relevant axes
    call cubetools_header_get_axis_head_l(prog%oucube%head,axis,error)
    if (error) return
    call cubemain_compress_axis(axis,prog%lmfactor,error)
    if (error) return
    call cubetools_header_update_axset_l(axis,prog%oucube%head,error)
    if (error) return
    !
    call cubetools_header_get_axis_head_m(prog%oucube%head,axis,error)
    if (error) return
    call cubemain_compress_axis(axis,prog%lmfactor,error)
    if (error) return
    call cubetools_header_update_axset_m(axis,prog%oucube%head,error)
    if (error) return
    !
    call cubetools_header_get_axis_head_c(prog%oucube%head,axis,error)
    if (error) return
    call cubemain_compress_axis(axis,prog%cfactor,error)
    if (error) return
    call cubetools_header_update_axset_c(axis,prog%oucube%head,error)
    if (error) return
  end subroutine cubemain_compress_prog_header
  !
  subroutine cubemain_compress_axis(axis,factor,error)
    use cubetools_axis_types
    !-------------------------------------------------------------------
    !
    !-------------------------------------------------------------------
    type(axis_t),         intent(inout)  :: axis
    integer(kind=indx_k), intent(in)     :: factor
    logical,              intent(inout)  :: error
    !
    integer(kind=4), parameter :: limit=1
    character(len=*), parameter :: rname='COMPRESS>AXIS'
    !
    axis%n = (axis%n-1)/factor+1   ! Take care of non-integer division
    if (axis%n.lt.limit) then
      call cubemain_message(seve%e,rname,  &
        'Output cube would have less than 1 pixel along '//axis%name)
      error = .true.
      return
    endif
    axis%ref = 0.5d0 - (0.5d0-axis%ref)/factor
   !axis%val = unchanged
    axis%inc = factor * axis%inc
  end subroutine cubemain_compress_axis
  !
  subroutine cubemain_compress_prog_data(prog,error)
    use cubeadm_opened
    !----------------------------------------------------------------------
    !
    !----------------------------------------------------------------------
    class(compress_prog_t), intent(inout) :: prog
    logical,                intent(inout) :: error
    !
    type(cubeadm_iterator_t) :: iter
    character(len=*), parameter :: rname='COMPRESS>PROG>DATA'
    !
    call cubemain_message(mainseve%trace,rname,'Welcome')
    !
    call cubeadm_datainit_all(iter,prog%region,error)
    if (error) return
    !$OMP PARALLEL DEFAULT(none) SHARED(prog,error) FIRSTPRIVATE(iter)
    !$OMP SINGLE
    do while (cubeadm_dataiterate_all(iter,error))
       if (error) exit
       !$OMP TASK SHARED(prog,error) FIRSTPRIVATE(iter)
       if (.not.error) &
         call prog%loop(iter,error)
       !$OMP END TASK
    enddo
    !$OMP END SINGLE
    !$OMP END PARALLEL
  end subroutine cubemain_compress_prog_data
  !
  subroutine cubemain_compress_prog_loop(prog,iter,error)
    use cubeadm_taskloop
    !----------------------------------------------------------------------
    !
    !----------------------------------------------------------------------
    class(compress_prog_t),    intent(inout) :: prog
    type(cubeadm_iterator_t),  intent(inout) :: iter
    logical,                   intent(inout) :: error
    !
    character(len=*), parameter :: rname='COMPRESS>PROG>LOOP'
    !
    do while (iter%iterate_entry(error))
      call prog%act(iter,error)
      if (error) return
    enddo ! ie
  end subroutine cubemain_compress_prog_loop
  !
  subroutine cubemain_compress_prog_act(prog,itertask,error)
    use cubetools_real_2d_types
    use cubetools_real_3d_types
    use cubeadm_subcube_types
    use cubeadm_taskloop
    !----------------------------------------------------------------------
    !
    !----------------------------------------------------------------------
    class(compress_prog_t),   intent(in)    :: prog
    type(cubeadm_iterator_t), intent(in)    :: itertask
    logical,                  intent(inout) :: error
    !
    type(subcube_t) :: insub,ousub
    type(real_3d_t) :: insubsub
    type(real_2d_t) :: ouima
    integer(kind=indx_k) :: o3,first,last
    character(len=mess_l) :: mess
    character(len=*), parameter :: rname='COMPRESS>PROG>ACT'
    !
    ! Subcubes are initialized here as their size (3rd dim) may change from
    ! from one task to another.
    call insub%associate('insub',prog%incube,itertask,error)
    if (error) return
    call insub%get(error)
    if (error) return
    !
    call ousub%allocate('ousub',prog%oucube,itertask,error)
    if (error) return
    !
    ! Sanity check: check that the iterator and insub%get have done things
    ! as expected.
    ! 1) insub must provide a multiple of factor3 dimension in any
    ! case (it is the responsibility of the iterator to respect this).
    ! The last subcube might overlap beyond the right cube boundary: this
    ! is treated after (insub%nvalid3)
    if (mod(insub%nz,prog%factor3).ne.0) then
      write(mess,'(2(a,i0))')  &
        'Internal error: subcube 3rd dimension is size ',insub%nz,  &
        ' while expected a multiple of ',prog%factor3
      call cubemain_message(seve%e,rname,mess)
      error = .true.
      return
    endif
    ! 2) insub must not overlap the left boundary of the cube. This should
    ! not happen regarding the way we define in this command the output 3rd
    ! axis from the input 3rd axis (left boundaries are aligned)
    if (insub%v3shift.ne.0) then
      write(mess,'(a,i0,a)')  &
        'Internal error: subcube overlaps left cube boundary (v3shift=',  &
        insub%v3shift,')'
      call cubemain_message(seve%e,rname,mess)
      error = .true.
      return
    endif
    !
    call insubsub%prepare_association('insubsub',insub%nx,insub%ny,prog%factor3,error)
    if (error) return
    call ouima%prepare_association('ouima',ousub%nx,ousub%ny,error)
    if (error)  return
    ouima%pointeris = code_pointer_associated
    !
    do o3=1,ousub%nz                              ! For each output plane:
      first = (o3-1)*prog%factor3+1               ! - first plane processed in insub
      last  = min(o3*prog%factor3,insub%nvalid3)  ! - last plane processed in insub
      insubsub%val => insub%val(:,:,first:last)
      insubsub%nz  = last-first+1
      ouima%val    => ousub%val(:,:,o3)
      call cubemain_compress_prog_image(prog,insubsub,ouima,error)
      if (error)  return
    enddo
    !
    call ousub%put(error)
    if (error)  return
  end subroutine cubemain_compress_prog_act

  subroutine cubemain_compress_prog_image(prog,insub,ouima,error)
    use cubetools_real_2d_types
    use cubetools_real_3d_types
    !-------------------------------------------------------------------
    ! Compute one output image from the input subcube.
    ! Note that this engine is generic for any data order (LMV/VLM)
    ! while the suffixes x/y/z might be misleading.
    !-------------------------------------------------------------------
    type(compress_prog_t), intent(in)    :: prog
    type(real_3d_t),       intent(inout) :: insub
    type(real_2d_t),       intent(inout) :: ouima
    logical,               intent(inout) :: error
    !
    integer(kind=pixe_k) :: i1,i2,i3
    integer(kind=indx_k) :: o1,o2
    integer(kind=indx_k) :: l1,l2,l3
    integer(kind=indx_k) :: n1,n2
    integer(kind=data_k) :: w
    real(kind=8) :: s
    !
    n1 = prog%factor1
    n2 = prog%factor2
    !
    l1 = insub%nx/n1  ! Integer division (as opposed to ouima%nx value)
    l2 = insub%ny/n2
    l3 = insub%nz
    !
    ! Main loop for "full" pixels. For efficiency purpose, do not
    ! compute the non-integer boundary pixels, if any. This avoids "if"
    ! tests or min(n*o1,inima%nx) for ALL pixels while we know these
    ! apply only on boundary and this command is meant to be executed
    ! on huge images.
    w = n1*n2*l3  ! Always in this loop
    do o2=1,l2
      do o1=1,l1
        s = 0.d0
       !w = 0
        do i3=1,l3  ! Non-contiguous read of input subcube (this is
                    ! inherent to the problem)
          ! Do not call compute_pixel also for efficiency, loop is
          ! simpler anyway.
          do i2=n2*o2-n2+1,n2*o2
            do i1=n1*o1-n1+1,n1*o1
              s = s + insub%val(i1,i2,i3)
             !w = w+1
            enddo  ! i1
          enddo  ! i2
          ouima%val(o1,o2) = s/w
        enddo ! i3
      enddo ! o1
    enddo ! o2
    !
    ! Last column with upper i1 truncated to NX
    if (l1.lt.ouima%nx) then
      o1 = ouima%nx
      do o2=1,l2
        ouima%val(o1,o2) = compute_pixel(o1,o2,insub%nx,n2*o2)
      enddo
    endif
    !
    ! Last row with upper i2 truncated to NY
    if (l2.lt.ouima%ny) then
      o2 = ouima%ny
      do o1=1,l1
        ouima%val(o1,o2) = compute_pixel(o1,o2,n1*o1,insub%ny)
      enddo
    endif
    !
    ! Last pixel with upper i1 and i2 truncated to NX and NY
    if (l1.lt.ouima%nx .and. l2.lt.ouima%ny) then
      o1 = ouima%nx
      o2 = ouima%ny
      ouima%val(o1,o2) = compute_pixel(o1,o2,insub%nx,insub%ny)
    endif
    !
  contains
    !
    function compute_pixel(o1,o2,mx,my)
      real(kind=4) :: compute_pixel
      integer(kind=pixe_k), intent(in) :: o1,o2
      integer(kind=pixe_k), intent(in) :: mx,my
      s = 0.d0
      w = 0
      do i3=1,l3
        do i2=n2*o2-n2+1,my
          do i1=n1*o1-n1+1,mx
            w = w+1
            s = s + insub%val(i1,i2,i3)
          enddo  ! i1
        enddo  ! i2
      enddo
      compute_pixel = s/w
    end function compute_pixel
  end subroutine cubemain_compress_prog_image
end module cubemain_compress
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
