!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
module cubeadm_clone
  use gkernel_interfaces
  use cubetools_parameters
  use cubedag_flag
  use cubedag_node_type
  use cubeio_interfaces_public
  use cube_types
  use cubeadm_opened
  use cubeadm_messaging
  !
  public :: cubeadm_clone_header,cubeadm_create_header
  private
  !
  interface cubeadm_clone_header
    module procedure cubeadm_clone_header_prod_with_region
    module procedure cubeadm_clone_header_prod
    module procedure cubeadm_clone_header_0d
    module procedure cubeadm_clone_header_1d
  end interface cubeadm_clone_header
  !
  interface cubeadm_create_header
    module procedure cubeadm_create_header_0d
    module procedure cubeadm_create_header_1d
  end interface cubeadm_create_header
  !
contains
  !
  subroutine cubeadm_create_header_0d(newflag,access,ndim,dim,ou,error)
    !----------------------------------------------------------------------
    ! Create a new node object of type 'cube', for future insertion in the
    ! DAG. Plus, create a new header for the output cube.
    ! ---
    ! 0D 'flag' version
    !----------------------------------------------------------------------
    type(flag_t),         intent(in)    :: newflag
    integer(kind=4),      intent(in)    :: access      ! code_cube_*
    integer(kind=ndim_k), intent(in)    :: ndim
    integer(kind=data_k), intent(in)    :: dim(:)
    type(cube_t),         pointer       :: ou
    logical,              intent(inout) :: error
    !
    class(cubedag_node_object_t), pointer :: dno
    !
    call cubeadm_create_header_do([newflag],access,ndim,dim,ou,error)
    if (error) return
    ! Success
    dno => ou
    call cubeadm_children_add(dno,code_write)
  end subroutine cubeadm_create_header_0d
  !
  subroutine cubeadm_create_header_1d(newflags,access,ndim,dim,ou,error)
    !----------------------------------------------------------------------
    ! Create a new node object of type 'cube', for future insertion in the
    ! DAG. Plus, create a new header for the output cube.
    ! ---
    ! 1D 'flag' version
    !----------------------------------------------------------------------
    type(flag_t),         intent(in)    :: newflags(:)
    integer(kind=4),      intent(in)    :: access      ! code_cube_*
    integer(kind=ndim_k), intent(in)    :: ndim
    integer(kind=data_k), intent(in)    :: dim(:)
    type(cube_t),         pointer       :: ou
    logical,              intent(inout) :: error
    !
    class(cubedag_node_object_t), pointer :: dno
    !
    call cubeadm_create_header_do(newflags,access,ndim,dim,ou,error)
    if (error)  return
    ! Success
    dno => ou
    call cubeadm_children_add(dno,code_write)
  end subroutine cubeadm_create_header_1d
  !
  subroutine cubeadm_create_header_do(newflags,access,ndim,dim,ou,error)
    use gbl_format
    use cubetools_access
    use cubetools_header_interface
    use cubetools_header_types
    !----------------------------------------------------------------------
    ! Create a new node object of type 'cube', for future insertion in the
    ! DAG. Plus, create a new header for the output cube.
    ! ---
    ! No insertion in children list
    !----------------------------------------------------------------------
    type(flag_t),         intent(in)    :: newflags(:)
    integer(kind=4),      intent(in)    :: access      ! code_cube_*
    integer(kind=ndim_k), intent(in)    :: ndim
    integer(kind=data_k), intent(in)    :: dim(:)
    type(cube_t),         pointer       :: ou
    logical,              intent(inout) :: error
    ! Local
    type(cube_header_interface_t) :: interf
    integer(kind=code_k) :: order
    character(len=*), parameter :: rname='CREATE>HEADER>DO'
    !
    call cubeadm_message(admseve%trace,rname,'Welcome')
    !
    order = cubetools_access2order(access)
    call cubeadm_create_node(ou,order,access,'UNKNOWN',newflags,error)
    if (error) return
    !
    ! Set initial header
    call interf%create(fmt_r4,access,ndim,dim,error)
    if (error) return
    call cubetools_header_import_and_derive(interf,ou%head,error)
    if (error) return
  end subroutine cubeadm_create_header_do
  !
  !---------------------------------------------------------------------
  !
  subroutine cubeadm_clone_header_prod_with_region(comm,in,region,ou,error)
    use cubetopology_cuberegion_types
    use cubeadm_cubeprod_types
    !----------------------------------------------------------------------
    ! Clone a cube and restrict its region
    ! ***JP: Right now, it is superset of cubeadm_clone_header_prod. Unclear
    ! ***JP: whether these should be merged at some point.
    !----------------------------------------------------------------------
    type(cube_prod_t),       intent(in)    :: comm
    type(cube_t),            intent(in)    :: in
    type(cuberegion_prog_t), intent(inout) :: region ! ***JP: why inout?
    type(cube_t), pointer,   intent(inout) :: ou
    logical,                 intent(inout) :: error
    !
    call cubeadm_clone_header_prod(comm,in,ou,error)
    if (error) return
    call region%header(ou,error)
    if (error) return
  end subroutine cubeadm_clone_header_prod_with_region
  !
  subroutine cubeadm_clone_header_prod(cubeprod,in,ou,error)
    use cubetools_list
    use cubetools_structure
    use cubeadm_cubeprod_types
    !----------------------------------------------------------------------
    ! Create a new node object of type 'cube', for future insertion in the
    ! DAG. Plus, clone the header of the input cube for the output cube.
    ! ---
    ! With a cube product as argument
    !----------------------------------------------------------------------
    type(cube_prod_t), intent(in)    :: cubeprod
    type(cube_t),      intent(in)    :: in
    type(cube_t),      pointer       :: ou
    logical,           intent(inout) :: error
    !
    class(cubedag_node_object_t), pointer :: dno
    !
    call cubeadm_clone_header_do(in,cubeprod%flag,ou,cubeprod%access,  &
      cubeprod%flagmode,error)
    if (error) return
    ! Success
    dno => ou
    call cubeadm_children_add(cubeprod,dno,code_write)
  end subroutine cubeadm_clone_header_prod
  !
  subroutine cubeadm_clone_header_0d(in,newflag,ou,error,access,flagmode)
    !----------------------------------------------------------------------
    ! Create a new node object of type 'cube', for future insertion in the
    ! DAG. Plus, clone the header of the input cube for the output cube.
    ! ---
    ! 0D 'flag' version
    !----------------------------------------------------------------------
    type(cube_t),                   intent(in)    :: in
    type(flag_t),                   intent(in)    :: newflag
    type(cube_t),                   pointer       :: ou
    logical,                        intent(inout) :: error
    integer(kind=4),      optional, intent(in)    :: access      ! code_cube_*
    integer(kind=code_k), optional, intent(in)    :: flagmode
    !
    integer(kind=code_k) :: laccess,lflagmode
    class(cubedag_node_object_t), pointer :: dno
    !
    if (present(access)) then
      laccess = access
    else
      laccess = code_unk
    endif
    if (present(flagmode)) then
      lflagmode = flagmode
    else
      lflagmode = code_unk
    endif
    call cubeadm_clone_header_do(in,[newflag],ou,laccess,lflagmode,error)
    if (error) return
    ! Success
    dno => ou
    call cubeadm_children_add(dno,code_write)
  end subroutine cubeadm_clone_header_0d
  !
  subroutine cubeadm_clone_header_1d(in,newflags,ou,error,access,flagmode)
    !----------------------------------------------------------------------
    ! Create a new node object of type 'cube', for future insertion in the
    ! DAG. Plus, clone the header of the input cube for the output cube.
    ! ---
    ! 1D 'flag' version
    !----------------------------------------------------------------------
    type(cube_t),                   intent(in)    :: in
    type(flag_t),                   intent(in)    :: newflags(:)
    type(cube_t),                   pointer       :: ou
    logical,                        intent(inout) :: error
    integer(kind=4),      optional, intent(in)    :: access
    integer(kind=code_k), optional, intent(in)    :: flagmode
    !
    integer(kind=code_k) :: laccess,lflagmode
    class(cubedag_node_object_t), pointer :: dno
    !
    if (present(access)) then
      laccess = access
    else
      laccess = code_unk
    endif
    if (present(flagmode)) then
      lflagmode = flagmode
    else
      lflagmode = code_unk
    endif
    call cubeadm_clone_header_do(in,newflags,ou,laccess,lflagmode,error)
    if (error) return
    ! Success
    dno => ou
    call cubeadm_children_add(dno,code_write)
  end subroutine cubeadm_clone_header_1d
  !
  subroutine cubeadm_clone_header_do(in,newflags,ou,access,flagmode,error)
    use cubetools_access
    use cubetools_header_types
    use cubedag_node
    !----------------------------------------------------------------------
    ! Create a new node object of type 'cube', for future insertion in the
    ! DAG. Plus, clone the header of the input cube for the output cube.
    ! ---
    ! No insertion in children list
    !----------------------------------------------------------------------
    type(cube_t),         intent(in)    :: in
    type(flag_t),         intent(in)    :: newflags(:)
    type(cube_t),         pointer       :: ou
    integer(kind=4),      intent(in)    :: access
    integer(kind=code_k), intent(in)    :: flagmode
    logical,              intent(inout) :: error
    ! Local
    integer(kind=code_k) :: laccess,lorder,lflagmode
    integer(kind=4) :: osize
    type(flag_t), allocatable :: oflags(:)
    character(len=*), parameter :: rname='CLONE>HEADER'
    !
    call cubeadm_message(admseve%trace,rname,'Welcome')
    !
    ! Set up file order and access mode. Default is same as input cube
    lorder = in%order()
    laccess = in%access()
    if (access.ne.code_unk) then
      laccess = access
      if (laccess.eq.code_access_imaset .or.  &
          laccess.eq.code_access_speset) then
        lorder = cubetools_access2order(laccess)
      else
        ! Other accesses (e.g. subcube) do not change the output cube order
      endif
    endif
    !
    ! Set up flags
    if (flagmode.ne.code_unk) then
      lflagmode = flagmode
    else
      lflagmode = keep_none  ! Default
    endif
    call cubeadm_clone_flags(lflagmode,in%node%flag,newflags,oflags,osize,error)
    if (error)  return
    !
    call cubeadm_create_node(ou,lorder,laccess,in%node%family,oflags(1:osize),error)
    if (error) return
    !
    ! Set header (copy from input one)
    call cubetools_header_copy(in%head,ou%head,error)
    if (error) return
  end subroutine cubeadm_clone_header_do
  !
  subroutine cubeadm_clone_flags(flagmode,oldflags,newflags,outflags,outsize,error)
    !-------------------------------------------------------------------
    ! Set up the list of output flags depending on the flag mode
    !-------------------------------------------------------------------
    integer(kind=code_k), intent(in)    :: flagmode
    type(flag_list_t),    intent(in)    :: oldflags
    type(flag_t),         intent(in)    :: newflags(:)
    type(flag_t),         allocatable   :: outflags(:)
    integer(kind=4),      intent(out)   :: outsize
    logical,              intent(inout) :: error
    !
    type(flag_t), pointer :: flag
    integer(kind=4) :: oldsize,newsize,iflag,ier
    logical :: doacti,doprod,douser
    integer(kind=code_k) :: flagkind
    character(len=*), parameter :: rname='CLONE>FLAGS'
    !
    oldsize = oldflags%n
    newsize = size(newflags)
    !
    allocate(outflags(newsize+oldsize),stat=ier)  ! Maximum size possible
    if (failed_allocate(rname,'outflags',ier,error)) return
    !
    ! New flags always come first
    outsize = newsize
    outflags(1:outsize) = newflags(1:newsize)
    !
    select case (flagmode)
    case (keep_all,keep_acti,keep_prod)
      doacti = flagmode.eq.keep_all .or. flagmode.eq.keep_acti
      doprod = flagmode.eq.keep_all .or. flagmode.eq.keep_prod
      douser = flagmode.eq.keep_all
      do iflag=1,oldsize
        flag => cubedag_flag_ptr(oldflags%list(iflag)%p,error)
        if (error) return
        flagkind = flag%get_kind()
        if ((doacti .and. flagkind.eq.code_kind_action)  .or.  &
            (doprod .and. flagkind.eq.code_kind_product) .or.  &
            (douser .and. flagkind.eq.code_kind_user)) then
          outsize = outsize+1
          outflags(outsize) = flag
        endif
      enddo
      !
    case (keep_none)
      ! Nothing more
      !
    case default
      call cubeadm_message(seve%e,rname,'Internal error: invalid flag mode code')
      error = .true.
      return
    end select
  end subroutine cubeadm_clone_flags
  !
  subroutine cubeadm_create_node(ou,order,access,family,oflags,error)
    use cubetools_dataformat
    use cubedag_parameters
    use cubedag_dag
    use cubedag_node
    use cubeio_cube_define
    use cubeio_file
    use cubeadm_engine_types
    !-------------------------------------------------------------------
    !
    !-------------------------------------------------------------------
    type(cube_t),         pointer       :: ou
    integer(kind=code_k), intent(in)    :: order
    integer(kind=code_k), intent(in)    :: access
    character(len=*),     intent(in)    :: family
    type(flag_t),         intent(in)    :: oflags(:)
    logical,              intent(inout) :: error
    !
    class(cubedag_node_object_t), pointer :: dno
    character(len=*), parameter :: rname='CREATE>NODE'
    !
    call cubeadm_message(admseve%trace,rname,'Welcome')
    !
    ! Insert a new object in the DAG. Dangling, parents will be attached
    ! when object is finalized.
    call cubedag_dag_newnode(dno,code_ftype_cube,error)
    if (error) return
    ou => cubetuple_cube_ptr(dno,error)
    if (error) return
    call cubeio_cube_define_order(ou%prog,order,error)
    if (error) return
    call cubeio_cube_define_access(ou%prog,access,error)
    if (error) return
    if (access.eq.code_access_fullset) then
      call cubeio_cube_define_buffering(ou%prog,code_buffer_memory,error)
      if (error) return
    endif
    !
    ! Set up the buffer kind on disk (used only if relevant)
    ! => default is to work with GDF format (no byte-swapping)
    call cubeio_cube_define_filekind(ou%prog,code_dataformat_gdf,error)
    if (error) return
    ! Set up buffer name on disk (used only if relevant)
    call cubeadm_set_cubename(ou,order,error)
    if (error) return
    ! => Both file kind and name can be overloaded by commands afterwards
    !
    ! Fill the properties in index
    call cubedag_node_set_origin(dno,code_origin_created,error)
    if (error) return
    call cubedag_node_set_family(dno,family,error)
    if (error) return
    call cubedag_node_set_flags(dno,oflags,error)
    if (error) return
  end subroutine cubeadm_create_node
  !
  subroutine cubeadm_set_cubename(cube,order,error)
    use cubetools_parameters
    use cubetools_access
    use cubeio_cube_define
    use cubeadm_directory_type
    !---------------------------------------------------------------------
    ! Set temporary cube file name according to identifier, cube order,
    ! and tmp directory
    !---------------------------------------------------------------------
    type(cube_t),    intent(inout) :: cube
    integer(kind=4), intent(in)    :: order
    logical,         intent(inout) :: error
    ! Local
    character(len=base_l) :: oubase
    character(len=exte_l) :: ouext
    character(len=file_l) :: ouname
    !
    call cubeadm_directory_create(dir%tmp,error)
    if (error) return
    !
    write(oubase,'(I0)')  cube%node%id
    ouext = cubetools_order2ext(order)
    call sic_parse_file(oubase,dir%tmp,ouext,ouname)
    !
    call cubeio_cube_define_filename(cube%prog,ouname,error)
    if (error) return
  end subroutine cubeadm_set_cubename
end module cubeadm_clone
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
