!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
module cubemain_extract
  use cubetools_structure
  use cube_types
  use cubeadm_cubeid_types
  use cubeadm_cubeprod_types
  use cubemain_messaging
  use cubemain_windowing
  use cubetopology_speline_types
  use cubetopology_sperange_types
  use cubetopology_sparange_types
  use cubetopology_spapos_types
  use cubetopology_spasize_types
  use cubetopology_cuberegion_types
  !
  public :: extract
  private
  !
  type :: extract_comm_t
     type(option_t),     pointer :: comm
     type(cubeid_arg_t), pointer :: cube
     type(sperange_opt_t)        :: range
     type(speline_opt_t)         :: freq
     type(spapos_comm_t)         :: center
     type(spasize_opt_t)         :: size
     type(cube_prod_t),  pointer :: extracted
   contains
     procedure, public  :: register => cubemain_extract_register
     procedure, private :: parse    => cubemain_extract_parse
     procedure, private :: main     => cubemain_extract_main
  end type extract_comm_t
  type(extract_comm_t) :: extract
  !
  type extract_user_t
     type(cubeid_user_t)  :: cubeids
     type(speline_user_t) :: line    ! Optional new line name and freq
     type(sperange_user_t):: range   ! Spectral range to be extracted
     type(spapos_user_t)  :: center  ! [absolute|relative] Center of the region to be extracted
     type(spasize_user_t) :: size    ! Size of the region to be extracted
   contains
     procedure, private :: toprog => cubemain_extract_user_toprog
  end type extract_user_t
  !
  type extract_prog_t
     type(cube_t), pointer   :: cube       ! Input cube
     type(cube_t), pointer   :: extracted  ! Extracted cube
     logical                 :: doline
     type(speline_prog_t)    :: line
     type(sperange_user_t)   :: sperange
     integer(kind=ndim_k)    :: ix,iy,ic
     integer(kind=data_k)    :: range(3,2) ! Extracted ranges
     type(cuberegion_prog_t) :: region     !
   contains
     procedure, private :: header          => cubemain_extract_prog_header
     procedure, private :: header_spectral => cubemain_extract_prog_header_spectral
     procedure, private :: header_spatial  => cubemain_extract_prog_header_spatial
     procedure, private :: create_region   => cubemain_extract_create_region
     procedure, private :: data            => cubemain_extract_prog_data     
     procedure, private :: loop            => cubemain_extract_prog_loop
     procedure, private :: act             => cubemain_extract_prog_act
  end type extract_prog_t
  !
contains
  !
  subroutine cubemain_extract_command(line,error)
    !----------------------------------------------------------------------
    !
    !----------------------------------------------------------------------
    character(len=*), intent(in)    :: line
    logical,          intent(inout) :: error
    !
    type(extract_user_t) :: user
    character(len=*), parameter :: rname='EXTRACT>COMMAND'
    !
    call cubemain_message(mainseve%trace,rname,'Welcome')
    call extract%parse(line,user,error)
    if (error) return
    call extract%main(user,error)
    if (error) return
  end subroutine cubemain_extract_command
  !
  !----------------------------------------------------------------------
  !
  subroutine cubemain_extract_register(extract,error)
    use cubedag_allflags
    !----------------------------------------------------------------------
    !
    !----------------------------------------------------------------------
    class(extract_comm_t), intent(inout) :: extract
    logical,               intent(inout) :: error
    !
    type(cubeid_arg_t) :: cubearg
    type(cube_prod_t) :: oucube
    !
    character(len=*), parameter :: comm_abstract = &
         'Extract a subcube'
    character(len=*), parameter :: comm_help = &
         'The velocity range may be around the current reference&
         & frequency for the cube, or it can be around a new&
         & reference frequency (/FREQUENCY).'
    character(len=*), parameter :: rname='EXTRACT>REGISTER'
    !
    call cubemain_message(mainseve%trace,rname,'Welcome')
    !
    call cubetools_register_command(&
         'EXTRACT','[cube]',&
         comm_abstract,&
         comm_help,&
         cubemain_extract_command,&
         extract%comm,error)
    if (error) return
    call cubearg%register( &
         'CUBE', &
         'Signal cube',  &
         strg_id,&
         code_arg_optional,  &
         [flag_cube], &
         code_read, &
         code_access_subset, &
         extract%cube, &
         error)
    if (error) return
    !
    call extract%range%register('RANGE',&
         'Spectral range of the extracted region',&
         error)
    if (error) return
    !
    call extract%freq%register(&
         'Line name & rest frequency of the extracted region',&
         error)
    if (error) return
    !
    call extract%center%register('CENTER',&
         'Spatial center of the extracted region',&
         error)
    if (error) return
    !
    call extract%size%register(&
         'Spatial size of the extracted region',&
         error)
    if (error) return
    !
    ! Product
    call oucube%register(&
         'EXTRACTED',&
         'Extracted cube',&
         strg_id,&
         [flag_extract,flag_cube],&
         extract%extracted,&
         error)
    if (error) return
  end subroutine cubemain_extract_register
  !
  subroutine cubemain_extract_parse(extract,line,user,error)
    !----------------------------------------------------------------------
    ! EXTRACT cubname
    ! /RANGE vfirst vlast
    ! /FREQUENCY newname newrestfreq [unit]
    ! /CENTER xcen ycen ! can be relative[arcsec] or absolute[RA,DEC or LII,BII]
    ! /SIZE sx [sy]
    !----------------------------------------------------------------------
    class(extract_comm_t), intent(in)    :: extract
    character(len=*),      intent(in)    :: line
    type(extract_user_t),  intent(out)   :: user
    logical,               intent(inout) :: error
    !
    character(len=*), parameter :: rname='EXTRACT>PARSE'
    !
    call cubemain_message(mainseve%trace,rname,'Welcome')
    !
    call cubeadm_cubeid_parse(line,extract%comm,user%cubeids,error)
    if (error) return
    call extract%range%parse(line,user%range,error)
    if (error) return
    call extract%freq%parse(line,user%line,error)
    if (error) return
    call extract%center%parse(line,user%center,error)
    if (error) return
    call extract%size%parse(line,user%size,error)
    if (error) return
    if (user%center%present.and..not.user%size%do) then
       call cubemain_message(seve%e,rname,'A size must be specified when giving a new center')
       error = .true.
       return
    endif
    !
    if (cubetools_nopt().eq.0) then
       call cubemain_message(seve%e,rname,'No options given, nothing to do')
       error = .true.
       return
    endif
  end subroutine cubemain_extract_parse
  !
  subroutine cubemain_extract_main(extract,user,error)
    use cubeadm_timing
    use cubeadm_get
    !----------------------------------------------------------------------
    !
    !----------------------------------------------------------------------
    class(extract_comm_t), intent(in)    :: extract
    type(extract_user_t),  intent(in)    :: user
    logical,               intent(inout) :: error
    !
    type(extract_prog_t) :: prog
    character(len=*), parameter :: rname='EXTRACT>MAIN'
    !
    call cubemain_message(mainseve%trace,rname,'Welcome')
    !
    call user%toprog(prog,error)
    if (error) return
    call prog%header(extract,error)
    if (error) return
    call cubeadm_timing_prepro2process()
    call prog%data(error)
    if (error) return
    call cubeadm_timing_process2postpro()
  end subroutine cubemain_extract_main
  !
  !----------------------------------------------------------------------
  !
  subroutine cubemain_extract_user_toprog(user,prog,error)
    use cubeadm_get
    !----------------------------------------------------------------------
    !
    !----------------------------------------------------------------------
    class(extract_user_t), intent(in)    :: user
    type(extract_prog_t),  intent(out)   :: prog
    logical,               intent(inout) :: error
    !
    integer(kind=chan_k) :: stride
    type(sparange_prog_t) :: lrange,mrange
    type(spapos_prog_t) :: center
    integer(kind=ndim_k), parameter :: ix=1,iy=2
    character(len=*), parameter :: rname='EXTRACT>USER>TOPROG'
    !
    call cubemain_message(mainseve%trace,rname,'Welcome')
    !
    call cubeadm_get_header(extract%cube,user%cubeids,prog%cube,error)
    if (error) return
    !
    select case (prog%cube%order())
    case (code_cube_imaset)
       prog%ix = 1
       prog%iy = 2
       prog%ic = 3
    case (code_cube_speset)
       prog%ix = 2
       prog%iy = 3
       prog%ic = 1
    case default
       call cubemain_message(seve%e,rname,'Order not supported')
       error = .true.
       return
    end select
    !
    prog%doline = user%line%do
    if (prog%doline) then
       call user%line%toprog(prog%cube,prog%line,error)
       if (error) return
    endif
    ! User range is copied because range resolution has to be done
    ! after frequency modification
    prog%sperange = user%range
    !
    call user%center%toprog(prog%cube,center,error)
    if (error) return
    call lrange%fromuser(code_sparange_truncated,prog%cube%head%set%il,prog%cube,center%rela(ix),&
         user%size%x,user%size%unit,prog%cube%head%spa%l%inc,&
         prog%cube%head%spa%l%kind,error)
    if (error) return
    call lrange%to_pixe_k(prog%range(prog%ix,1),prog%range(prog%ix,2),stride,error)
    if (error) return
    call mrange%fromuser(code_sparange_truncated,prog%cube%head%set%im,prog%cube,center%rela(iy),&
         user%size%y,user%size%unit,prog%cube%head%spa%m%inc,&
         prog%cube%head%spa%m%kind,error)
    if (error) return
    call mrange%to_pixe_k(prog%range(prog%iy,1),prog%range(prog%iy,2),stride,error)
    if (error) return
  end subroutine cubemain_extract_user_toprog
  !
  !----------------------------------------------------------------------
  !
  subroutine cubemain_extract_prog_header(prog,comm,error)
    use cubeadm_clone
    !----------------------------------------------------------------------
    !
    !----------------------------------------------------------------------
    class(extract_prog_t), intent(inout) :: prog
    type(extract_comm_t),  intent(in)    :: comm
    logical,               intent(inout) :: error
    !
    character(len=*), parameter :: rname='EXTRACT>PROG>HEADER'
    !
    call cubemain_message(mainseve%trace,rname,'Welcome')
    !
    call cubeadm_clone_header(comm%extracted,prog%cube,prog%extracted,error)
    if (error) return
    call prog%header_spectral(error)
    if (error) return
    call prog%header_spatial(error)
    if (error) return
    call prog%create_region(error)
    if (error) return
  end subroutine cubemain_extract_prog_header
  !
  subroutine cubemain_extract_create_region(prog,error)
    !-----------------------------------------------------------------
    ! Ad-hoc subroutine which converts the 3 ranges to a region type,
    ! for later use by cubeadm_datainit_all.
    !
    ! We allow here the 3rd range to overlap the cube boundaries (no
    ! truncation) because the iterator knows how to deal with this
    ! case.
    !
    ! On the other hand, the 2 first dimensions are kept full (no
    ! subset, no surset), because the subcube%get() API is not able
    ! to get a subcube overlapping the boundaries. This is treated
    ! locally with special care in cubemain_extract_prog_act.
    !-----------------------------------------------------------------
    class(extract_prog_t), intent(inout) :: prog
    logical,               intent(inout) :: error
    !
    ! Default full dimensions:
    ! - 'code_indx_auto' stand for the dimensions of the cube associated
    !   cube to the entry. Remember that in the current command,
    !   dimensions of the input and output cubes might differ in all
    !   directions.
    ! - explicit values would be used explicitly. This is not what we
    !   want as our input subcubes and output subcubes might differ
    !   in size.
    prog%region%ix%first = code_indx_auto
    prog%region%ix%last = code_indx_auto
    prog%region%iy%first = code_indx_auto
    prog%region%iy%last = code_indx_auto
    prog%region%iz%first = code_indx_auto
    prog%region%iz%last = code_indx_auto
    !
    ! Then subset/surset for the last dimension
    if (prog%ix.eq.3) then
      prog%region%ix%first = prog%range(3,1)
      prog%region%ix%last  = prog%range(3,2)
    elseif (prog%iy.eq.3) then
      prog%region%iy%first = prog%range(3,1)
      prog%region%iy%last  = prog%range(3,2)
    elseif (prog%ic.eq.3) then
      prog%region%iz%first = prog%range(3,1)
      prog%region%iz%last  = prog%range(3,2)
    endif
  end subroutine cubemain_extract_create_region
  !
  subroutine cubemain_extract_prog_header_spectral(prog,error)
    use cubetools_unit
    use cubetools_axis_types
    use cubetools_header_methods
    !----------------------------------------------------------------------
    ! *** JP *** Think twice before modifying this one!
    !----------------------------------------------------------------------
    class(extract_prog_t), intent(inout) :: prog
    logical,               intent(inout) :: error
    !
    type(axis_t) :: axis
    integer(kind=chan_k) :: stride
    type(sperange_prog_t) :: sperange
    character(len=*), parameter :: rname='EXTRACT>PROG>HEADER>SPECTRAL'
    !
    call cubemain_message(mainseve%trace,rname,'Welcome')
    !
    ! Everything below is needed!
    if (prog%doline) then
       call cubetools_header_modify_rest_frequency(prog%line%freq,prog%extracted%head,error)
       if (error) return
       call cubetools_header_put_line(prog%line%name,prog%extracted%head,error)
       if (error) return
       call cubetools_header_get_axis_head_f(prog%extracted%head,axis,error)
       if (error) return
       call cubetools_header_update_frequency_from_axis(axis,prog%extracted%head,error)
       if (error) return
    endif
    !
    ! This part of the code has to be executed after the frequency
    ! modification otherwise the range of velocities is wrong!
    call prog%sperange%toprog(prog%extracted,code_sperange_truncated,sperange,error)
    if (error) return
    call sperange%to_chan_k(prog%range(prog%ic,1),prog%range(prog%ic,2),stride,error)
    if (error) return
    !
    call cubetools_header_get_axis_head_c(prog%extracted%head,axis,error)
    if (error) return
    axis%n = prog%range(prog%ic,2)-prog%range(prog%ic,1)+1
    axis%ref = axis%ref-prog%range(prog%ic,1)+1
    !
    ! This snippet of code was copied from: lib/edit/type-cube-buffer.f90:cubeedit_cube_buffer_resize
    ! This points to the necessity of factorizing this piece of code in lib/tools/header-methods.f90x
    if (axis%kind.eq.code_unit_freq) then
       call cubetools_header_update_frequency_from_axis(axis,prog%extracted%head,error)
       if (error) return
    else if (axis%kind.eq.code_unit_velo) then
       call cubetools_header_update_velocity_from_axis(axis,prog%extracted%head,error)
       if (error) return
    else
       call cubetools_header_update_axset_c(axis,prog%extracted%head,error)
       if (error) return
       call cubemain_message(seve%w,rname,'Unknown kind of Spectral axis')
    endif
  end subroutine cubemain_extract_prog_header_spectral
  !
  subroutine cubemain_extract_prog_header_spatial(prog,error)
    use cubetools_axis_types
    use cubetools_header_methods
    !----------------------------------------------------------------------
    !
    !----------------------------------------------------------------------
    class(extract_prog_t), intent(inout) :: prog
    logical,               intent(inout) :: error
    !
    type(axis_t) :: laxis, maxis
    character(len=*), parameter :: rname='EXTRACT>PROG>HEADER>SPATIAL'
    !
    call cubemain_message(mainseve%trace,rname,'Welcome')
    !
    call cubetools_header_get_axis_head_l(prog%extracted%head,laxis,error)
    if (error) return
    laxis%n = prog%range(prog%ix,2)-prog%range(prog%ix,1)+1
    laxis%ref = laxis%ref-1d0*prog%range(prog%ix,1)+1d0
    call cubetools_header_update_axset_l(laxis,prog%extracted%head,error)
    if (error) return
    !
    call cubetools_header_get_axis_head_m(prog%extracted%head,maxis,error)
    if (error) return
    maxis%n = prog%range(prog%iy,2)-prog%range(prog%iy,1)+1
    maxis%ref = maxis%ref-1d0*prog%range(prog%iy,1)+1d0
    call cubetools_header_update_axset_m(maxis,prog%extracted%head,error)
    if (error) return
  end subroutine cubemain_extract_prog_header_spatial
  !
  subroutine cubemain_extract_prog_data(prog,error)
    use cubeadm_opened
    use cubetools_header_types
    !----------------------------------------------------------------------
    !
    !----------------------------------------------------------------------
    class(extract_prog_t), intent(inout) :: prog
    logical,               intent(inout) :: error
    !
    type(cubeadm_iterator_t) :: itertask
    character(len=*), parameter :: rname='EXTRACT>PROG>DATA'
    !
    call cubemain_message(mainseve%trace,rname,'Welcome')
    !
    call cubeadm_datainit_all(itertask,prog%region,error)
    if (error) return
    !
    !$OMP PARALLEL DEFAULT(none) SHARED(prog,error) FIRSTPRIVATE(itertask)
    !$OMP SINGLE
    do while (cubeadm_dataiterate_all(itertask,error))
       if (error) exit
       !$OMP TASK SHARED(prog,error) FIRSTPRIVATE(itertask)
       if (.not.error) then
          call prog%loop(itertask,error)
       endif
       !$OMP END TASK
    enddo ! itertask
    !$OMP END SINGLE
    !$OMP END PARALLEL
  end subroutine cubemain_extract_prog_data
  !
  subroutine cubemain_extract_prog_loop(prog,itertask,error)
    use cubeadm_taskloop
    !-------------------------------------------------------------------
    !
    !-------------------------------------------------------------------
    class(extract_prog_t),    intent(inout) :: prog
    type(cubeadm_iterator_t), intent(inout) :: itertask
    logical,                  intent(inout) :: error
    !
    character(len=*), parameter :: rname='EXTRACT>PROG>LOOP'
    !
    call cubemain_message(mainseve%trace,rname,'Welcome')
    !
    do while (itertask%iterate_entry(error))
      call prog%act(itertask,error)
      if (error) return
    enddo  ! ientry
  end subroutine cubemain_extract_prog_loop
  !
  subroutine cubemain_extract_prog_act(prog,itertask,error)
    use cubetools_nan
    use cubeadm_taskloop
    use cubeadm_subcube_types
    !-------------------------------------------------------------------
    ! Extract from 1 subcube
    !-------------------------------------------------------------------
    class(extract_prog_t),    intent(inout) :: prog
    type(cubeadm_iterator_t), intent(in)    :: itertask
    logical,                  intent(inout) :: error
    !
    type(subcube_t) :: insub,ousub
    integer(kind=indx_k) :: ix,jx,ixmin,ixmax,ixoff
    integer(kind=indx_k) :: iy,jy,iymin,iymax,iyoff
    integer(kind=indx_k) :: iz,jz,izmin,izmax,izoff
    logical :: overlap
    character(len=*), parameter :: rname='EXTRACT>PROG>ACT'
    !
    call cubemain_message(mainseve%trace,rname,'Welcome')
    !
    ! Subcubes are initialized here as their size (3rd dim) may change from
    ! from one subcube to another.
    call insub%associate('insub',prog%cube,itertask,error)
    if (error) return
    call ousub%allocate('ousub',prog%extracted,itertask,error)
    if (error) return
    !
    call insub%get(error)
    if (error) return
    !
    overlap = .false.
    !
    ! 1st dimension
    ixoff = prog%range(1,1)-1
    ixmin = prog%range(1,1)
    if (ixmin.lt.1) then
      overlap = .true.
      ixmin = 1
    endif
    ixmax = prog%range(1,2)
    if (ixmax.gt.insub%nx) then
      overlap = .true.
      ixmax = insub%nx
    endif
    !
    ! 2nd dimension
    iyoff = prog%range(2,1)-1
    iymin = prog%range(2,1)
    if (iymin.lt.1) then
      overlap = .true.
      iymin = 1
    endif
    iymax = prog%range(2,2)
    if (iymax.gt.insub%ny) then
      overlap = .true.
      iymax = insub%ny
    endif
    !
    ! 3rd dimension: subcubes
    izoff = insub%v3shift
    izmin = 1
    izmax = insub%nz
    if (izmax.gt.insub%nvalid3) then
      overlap = .true.
      izmax = insub%nvalid3
    endif
    !
    ! In case of surset extraction, initialize the new bits to NaN.
    ! For simplicity, initialize everything. NaN will be overwritten by
    ! valid values afterwards.
    if (overlap) then
      call ousub%set(gr4nan,error)
      if (error) return
    else
       continue ! No overlap cube boundaries, no init
    endif
    !
    do iz=izmin,izmax
      jz = iz-izoff
      do iy=iymin,iymax
        jy = iy-iyoff
        do ix=ixmin,ixmax
          jx = ix-ixoff
          ousub%val(jx,jy,jz) = insub%val(ix,iy,iz)
        enddo ! ix
      enddo ! iy
    enddo ! iz
    !
    call ousub%put(error)
    if (error) return
  end subroutine cubemain_extract_prog_act
end module cubemain_extract
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
