module cubeadm_opened
  use cubedag_parameters
  use cubedag_flag
  use cubedag_types
  use cubedag_node
  use cubetuple_format
  use cube_types
  use cubeadm_cubeid_types
  use cubeadm_taskloop
  use cubeadm_messaging
  !---------------------------------------------------------------------
  ! Support module for registering and keep track of cubes opened by
  ! current command, up to the moment they are closed with
  ! 'cubeadm_finish_all'
  !---------------------------------------------------------------------
  !
  ! Keep a list of the parents and children currently 'opened'.
  ! At some point they are all 'flushed' in the DAG, with the proper
  ! cross-references.
  type(cubedag_link_t) :: pa  ! Parents list
  type(cubedag_link_t) :: ch  ! Children list
  !
  integer(kind=entr_k), parameter    :: min_alluser_alloc=16
  type(cubeid_arg_list_t)            :: allarg      ! Parents and children argument list
  character(len=argu_l), allocatable :: alluser(:)  ! Parents and children user inputs
  type(cubedag_link_t)               :: all         ! Parents and children cube list
  !
  interface cubeadm_datainit_all
    module procedure cubeadm_datainit_allcubes_full
    module procedure cubeadm_datainit_allcubes_subset
  end interface cubeadm_datainit_all
  !
  public :: cubeadm_parents_add,cubeadm_parents_add_v2,cubeadm_children_add
  public :: cubeadm_datainit_all,cubeadm_dataiterate_all,cubeadm_finish_all
  public :: cubeadm_iterator_t  ! For convenience to users
  public :: cubeadm_parents_children_pop, cubeadm_opened_list_size
  private
  !
contains
  !
  subroutine cubeadm_parents_add(dno,action)
    class(cubedag_node_object_t), pointer    :: dno
    integer(kind=code_k),         intent(in) :: action
    logical :: error
    !
    error = .false.
    !
    ! Argument => unknown with this API
    call allarg%reallocate(allarg%n+1,error)
    if (error)  return
    allarg%n = allarg%n+1
    allarg%arg(allarg%n)%p => null()
    !
    ! User input => unknown with this API
    call alluser_reallocate(allarg%n,error)
    if (error)  return
    alluser(allarg%n) = ' '
    !
    ! Cube (in list of parents)
    call pa%reallocate(pa%n+1,error)
    pa%n = pa%n+1
    pa%list(pa%n)%p => dno
    pa%flag(pa%n) = action
    !
    ! Cube (in list of all cubes)
    call all%reallocate(all%n+1,error)
    all%n = all%n+1
    all%list(all%n)%p => dno
  end subroutine cubeadm_parents_add
  !
  subroutine cubeadm_parents_add_v2(arg,user,dno,action)
    type(cubeid_arg_t), target,   intent(in) :: arg
    type(cubeid_user_cube_t),     intent(in) :: user
    class(cubedag_node_object_t), pointer    :: dno
    integer(kind=code_k),         intent(in) :: action
    logical :: error
    !
    error = .false.
    !
    ! Argument
    call allarg%reallocate(allarg%n+1,error)
    if (error)  return
    allarg%n = allarg%n+1
    allarg%arg(allarg%n)%p => arg
    !
    ! User input
    call alluser_reallocate(allarg%n,error)
    if (error)  return
    alluser(allarg%n) = user%id  ! Keep only the non-parsed string
    !
    ! Cube (in list of parents)
    call pa%reallocate(pa%n+1,error)
    pa%n = pa%n+1
    pa%list(pa%n)%p => dno
    pa%flag(pa%n) = action
    !
    ! Cube (in list of all cubes)
    call all%reallocate(all%n+1,error)
    all%n = all%n+1
    all%list(all%n)%p => dno
  end subroutine cubeadm_parents_add_v2
  !
  subroutine cubeadm_children_add(dno,action)
    class(cubedag_node_object_t), pointer    :: dno
    integer(kind=code_k),         intent(in) :: action
    logical :: error
    !
    error = .false.
    !
    ! Argument => irrelevant
    call allarg%reallocate(allarg%n+1,error)
    if (error)  return
    allarg%n = allarg%n+1
    allarg%arg(allarg%n)%p => null()
    !
    ! User input => irrelevant
    call alluser_reallocate(allarg%n,error)
    if (error)  return
    alluser(allarg%n) = ' '
    !
    ! Cube (in list of children)
    call ch%reallocate(ch%n+1,error)
    ch%n = ch%n+1
    ch%list(ch%n)%p => dno
    ch%flag(ch%n) = action
    !
    ! Cube (in list of all cubes)
    call all%reallocate(all%n+1,error)
    all%n = all%n+1
    all%list(all%n)%p => dno
  end subroutine cubeadm_children_add
  !
  subroutine cubeadm_parents_children_pop(dno,error)
    !-------------------------------------------------------------------
    ! Pop out the given node from the parents/children lists
    !-------------------------------------------------------------------
    class(cubedag_node_object_t), pointer       :: dno
    logical,                      intent(inout) :: error
    !
    call pa%unlink(dno,error)
    call ch%unlink(dno,error)
    call all%unlink(dno,error)
    ! ZZZ For consistency these ones should be cleaned too (but they are
    ! only needed for feedback): allarg, alluser
  end subroutine cubeadm_parents_children_pop
  !
  subroutine cubeadm_parents_children_reset()
    logical :: error
    error = .false.
    call allarg%final(error)
    call pa%final(error)
    call ch%final(error)
    call all%final(error)
  end subroutine cubeadm_parents_children_reset

  subroutine cubeadm_list_opened(error)
    use cubedag_list
    logical, intent(inout) :: error
    ! Local
    character(len=*), parameter :: rname='LIST>OPENED'
    !
    call cubeadm_message(seve%r,rname,'Input cubes are:')
    if (pa%n.le.0) then
      call cubeadm_message(seve%r,rname,'<none>')
    else
      call cubedag_list_link(pa,error)
      if (error)  return
    endif
    !
    call cubeadm_message(seve%r,rname,'Output cubes are:')
    if (ch%n.le.0) then
      call cubeadm_message(seve%r,rname,'<none>')
    else
      call cubedag_list_link(ch,error)
      if (error)  return
    endif
    !
  end subroutine cubeadm_list_opened
  !
  subroutine cubeadm_list_opened_v2(error)
    use cubedag_list
    logical, intent(inout) :: error
    ! Local
    integer(kind=4) :: custom(20),larg,lflag,luser,nc
    character(len=mess_l) :: mess
    integer(kind=entr_k) :: icub
     character(len=*), parameter :: cols(8) = &
         ['IDENTIFIER ','TYPE       ','FAMILY     ','FLAG       ',&
          'OBSERVATORY','SOURCE     ','LINE       ','DATASIZE   ']
    character(len=*), parameter :: rname='LIST>OPENED'
    !
    ! Set up trailing columns
    call cubeadm_opened_list_size(cols,custom,error)
    if (error) return
    !
    ! Automatic widths for leading columns
    larg = 1   ! Argument name width
    lflag = 1  ! Flag list width
    luser = 1  ! User input width
    do icub=1,all%n
      if (associated(allarg%arg(icub)%p)) then
        larg = max(larg,len_trim(allarg%arg(icub)%p%name))
        call cubedag_flaglist_tostr(allarg%arg(icub)%p%flag,allarg%arg(icub)%p%nflag,lstrflag=nc,error=error)
        if (error)  return
        lflag = max(lflag,nc)
        luser = max(1,len_trim(alluser(icub)))
      else
        call cubedag_flag_tostr(all%list(icub)%p%node,lstrflag=nc,error=error)
        if (error)  return
        lflag = max(lflag,nc)
      endif
    enddo
    !
    ! Actual print
    do icub=1,all%n
      nc = 1
      if (associated(allarg%arg(icub)%p)) then
        mess(nc:) = 'I'
        nc = nc+2
        mess(nc:) = allarg%arg(icub)%p%name
        nc = nc+larg+1
        call cubedag_flaglist_tostr(allarg%arg(icub)%p%flag,allarg%arg(icub)%p%nflag,strflag=mess(nc:),error=error)
        if (error)  return
        nc = nc+lflag+1
        mess(nc:) = alluser(icub)
        nc = nc+luser
      else
        mess(nc:) = 'O'
        nc = nc+2
        mess(nc:) = ' '  ! No argument name
        nc = nc+larg+1
        call cubedag_flag_tostr(all%list(icub)%p%node,strflag=mess(nc:),error=error)
        if (error)  return
        nc = nc+lflag+1
        mess(nc:) = alluser(icub)
        nc = nc+luser
      endif
      mess(nc:) = ' => '
      nc = nc+4
      call cubedag_list_one_custom(all%list(icub)%p,custom,.true.,code_null,code_null,mess(nc:),error)
      if (error)  return
      call cubeadm_message(seve%r,rname,mess)
    enddo
    !
  end subroutine cubeadm_list_opened_v2
  !
  subroutine cubeadm_datainit_allcubes_full(iter,error)
    use cubeadm_entryloop
    !-------------------------------------------------------------------
    ! Prepare the data IO for all the registered cubes
    !-------------------------------------------------------------------
    type(cubeadm_iterator_t), intent(out)   :: iter
    logical,                  intent(inout) :: error
    ! Local
    character(len=*), parameter :: rname='DATAINIT>ALLCUBES>FULLSET'
    integer(kind=data_k) :: startplane,stopplane
    !
    startplane = nullplane  ! Will be resolved later
    stopplane = nullplane  ! Will be resolved later
    call cubeadm_datainit_allcubes_subset(iter,startplane,stopplane,error)
    if (error)  return
    !
  end subroutine cubeadm_datainit_allcubes_full
  !
  subroutine cubeadm_datainit_allcubes_subset(iter,startplane,stopplane,error)
    use cubetools_access
    use cubeadm_entryloop
    !-------------------------------------------------------------------
    ! Prepare the data IO for all the registered cubes
    !-------------------------------------------------------------------
    type(cubeadm_iterator_t), intent(out)   :: iter
    integer(kind=data_k),     intent(in)    :: startplane,stopplane
    logical,                  intent(inout) :: error
    ! Local
    character(len=*), parameter :: rname='DATAINIT>ALLCUBES'
    type(cube_t), pointer :: incube,oucube
    integer(kind=entr_k) :: icube
    integer(kind=code_k) ::refaccess,reforder
    character(len=mess_l) :: mess
    !
    ! Loop on all the input cubes to check their consistency
    do icube=1,pa%n
      incube => cubetuple_cube_ptr(pa%list(icube)%p,error)
      if (error)  return
      if (icube.eq.1) then
        refaccess = incube%access()
        reforder = incube%order()
      else
        if (incube%order().ne.reforder .or. &
            incube%access().ne.refaccess) then
          call cubeadm_message(seve%e,rname,'Inconsistent cube accesses or orders:')
          write(mess,'(A,I0,4A)')  '  Cube #',1,  &
                                   ': access ',trim(cubetools_accessname(refaccess)),  &
                                   ', order ',cubetools_ordername(reforder)
          call cubeadm_message(seve%e,rname,mess)
          write(mess,'(A,I0,4A)')  '  Cube #',icube,  &
                                   ': access ',trim(cubetools_accessname(incube%access())),  &
                                   ', order ',cubetools_ordername(incube%order())
          call cubeadm_message(seve%e,rname,mess)
          error = .true.
          return
        endif
      endif
    enddo
    !
    ! Loop on all the output cubes to prepare them for data access
    do icube=1,ch%n
      oucube => cubetuple_cube_ptr(ch%list(icube)%p,error)
      if (error)  return
      call cubeadm_datainit_one(oucube,error)
      if (error)  return
    enddo
    !
    ! Taskloop iterator is set by taking all the input and output cubes
    ! into account
    call cubeadm_taskloop_init(pa,ch,startplane,stopplane,iter,error)
    if (error) return
    ! Entryloop iterator
    call cubeadm_entryloop_init(iter%ne,error)
    if (error) return
    ! User feedback (after the output cubes have been prepared)
    if (pa%n.gt.0 .and. associated(allarg%arg(1)%p)) then
      ! New feedback
      call cubeadm_list_opened_v2(error)
      if (error)  return
    else
      ! Old feedback
      call cubeadm_list_opened(error)
      if (error)  return
    endif
    !
  end subroutine cubeadm_datainit_allcubes_subset
  !
  subroutine cubeadm_datainit_one(oucube,error)
    use cubetools_header_array_types
    use cubeio_interfaces_public
    use cubeadm_import
    !-------------------------------------------------------------------
    ! Prepare the data IO for one cube
    !-------------------------------------------------------------------
    type(cube_t), intent(inout) :: oucube
    logical,      intent(inout) :: error
    !
    ! Re-initialize the extrema if they are about to be recomputed
    ! in the upcoming processing loop
    if (oucube%user%output%extrema .and. .not.oucube%iscplx()) then
      call cubetools_array_init_extrema(oucube%head%arr,error)
      if (error)  return
    endif
    !
    ! Prepare HGDF and the descriptor (the later is needed between now
    ! and first data access)
    ! ZZZ RENAME THIS SUBROUTINE
    call cubeio_clone_cube_header(oucube%user,oucube%prog,oucube%head,oucube%tuple%current,error)
    if (error)  return
    !
    call cubeadm_head_to_node(oucube%head,oucube,error)
    if (error)  return
    !
  end subroutine cubeadm_datainit_one
  !
  function cubeadm_dataiterate_all(iter,error)
    !-------------------------------------------------------------------
    ! Iterate the iterator until all data is processed, and ensure all
    ! the registered cubes are ready to access their first to last
    ! entries.
    !-------------------------------------------------------------------
    logical :: cubeadm_dataiterate_all
    type(cubeadm_iterator_t), intent(inout) :: iter
    logical,                  intent(inout) :: error
    ! Local
    integer(kind=entr_k) :: icube
    integer(kind=data_k) :: firstplane,lastplane
    !
    ! Iteration
    cubeadm_dataiterate_all = cubeadm_taskloop_iterate(iter,error)
    if (error)  return
    if (.not.cubeadm_dataiterate_all)   return  ! All done
    !
    ! Parents
    do icube=1,pa%n
      if (pa%flag(icube).eq.code_read .or.  &
          pa%flag(icube).eq.code_update) then  ! Skip parent which is code_read_head
        firstplane = iter%firstplane
        lastplane  = iter%lastplane
        call cubeadm_dataiterate_one(firstplane,lastplane,pa%list(icube)%p,error)
        if (error)  return
      endif
    enddo
    !
    ! Children
    do icube=1,ch%n
      firstplane = iter%firstplane-iter%offsetplane
      lastplane  = iter%lastplane-iter%offsetplane
      call cubeadm_dataiterate_one(firstplane,lastplane,ch%list(icube)%p,error)
      if (error)  return
    enddo
    !
  end function cubeadm_dataiterate_all
  !
  subroutine cubeadm_dataiterate_one(firstplane,lastplane,dno,error)
    use cubeadm_ioloop
    !-------------------------------------------------------------------
    ! Ensure the identified cube is ready to access its iter%first to
    ! iter%last entries.
    !-------------------------------------------------------------------
    integer(kind=data_k),         intent(in)    :: firstplane
    integer(kind=data_k),         intent(in)    :: lastplane
    class(cubedag_node_object_t), pointer       :: dno
    logical,                      intent(inout) :: error
    ! Local
    type(cube_t), pointer :: cube
    character(len=*), parameter :: rname='DATAITERATE>ONE'
    !
    cube => cubetuple_cube_ptr(dno,error)
    if (error)  return
    call cubeadm_io_iterate_planes(firstplane,lastplane,cube,error)
    if (error)  return
  end subroutine cubeadm_dataiterate_one
  !
  subroutine cubeadm_finish_all(comm,line,error)
    use cubedag_dag
    use cubedag_history
    use cubeadm_import
    !---------------------------------------------------------------------
    ! Finish all cubes currently opened in index.
    ! ---
    ! Beware this subroutine can be called in an error recovery context,
    ! i.e. with error = .true. on input
    !---------------------------------------------------------------------
    character(len=*), intent(in)    :: comm
    character(len=*), intent(in)    :: line
    logical,          intent(inout) :: error
    ! Local
    character(len=*), parameter :: rname='FINISH>ALL'
    integer(kind=entr_k) :: ient,hid
    logical :: lerror
    !
    lerror = .false.  ! Local error
    !
    ! Insert in history
    if (.not.error) then
      ! If you plan to put failed commands in the HISTORY list,
      ! you can not reference output cubes ('ch' list) which are
      ! not inserted in DAG but destroyed instead.
      call cubedag_history_add(comm,line,pa,ch,hid,lerror)
      if (lerror)  continue
    endif
    !
    if (.not.error) then
      ! Update the links between parents and children, according to their read/write
      ! status. This is to be done before the cubes are freed (finalized)
      call cubedag_node_links(pa,ch,hid,lerror)
      if (lerror)  continue
    endif
    !
    ! Deal with the input cubes (including cubes opened in UPDATE mode, needing
    ! to be written on disk).
    do ient=1,pa%n
      call cubeadm_finish_one(pa%list(ient)%p,lerror)
      if (lerror)  exit
    enddo
    !
    ! Deal with the output cubes
    do ient=1,ch%n
      call cubeadm_finish_one(ch%list(ient)%p,lerror)
      if (lerror)  exit
      if (error)  then
        call cubedag_node_destroy(ch%list(ient)%p,lerror)
        if (lerror)  exit
      else
        call cubedag_dag_attach(ch%list(ient)%p,lerror)
        if (lerror)  exit
      endif
    enddo
    !
    ! Reset parents and children list
    call cubeadm_parents_children_reset()
    !
    ! Ensure the ID counter is up-to-date (in particular if an error
    ! occured, i.e. the output cubes were discarded)
    call cubedag_dag_updatecounter(lerror)
    if (lerror)  continue
    !
    if (lerror)  error = .true.
    !
  end subroutine cubeadm_finish_all
  !
  subroutine cubeadm_finish_one(format,error)
    use cubeadm_timing
    !-------------------------------------------------------------------
    ! Finish one cube given its id
    ! ---
    ! Beware this subroutine can be called in an error recovery context
    !-------------------------------------------------------------------
    class(cubedag_node_object_t), intent(inout) :: format
    logical,                      intent(inout) :: error
    ! Local
    character(len=*), parameter :: rname='FINISH>ONE'
    !
    if (error)  return  ! Error recovery: we should probably do some cleaning below!
    !
    select type (format)
    class is (format_t)
      call format%finish(error)
      if (error) continue
      call format%dag_upsert(error)
      if (error) continue
      call cubeadm_timing_collect_io(format)
      ! Always free the GIO slot, which is a limited ressource. The other
      ! ressources are handled by the GC
      call format%close(error)
      if (error)  return
    type is (cubedag_node_object_t)
      ! For the root object which is sometimes the parent node
      continue
    class default
      call cubeadm_message(seve%e,rname,'Object has wrong type')
      error = .true.
      return
    end select
  end subroutine cubeadm_finish_one
  !
  subroutine alluser_reallocate(nuser,error)
    use gkernel_interfaces
    !-------------------------------------------------------------------
    !-------------------------------------------------------------------
    integer(kind=4), intent(in)    :: nuser
    logical,         intent(inout) :: error
    ! Local
    character(len=*), parameter :: rname='ALLUSER>REALLOCATE'
    character(len=argu_l), allocatable :: tmp(:)
    integer(kind=entr_k) :: oldsize,newsize
    integer(kind=4) :: ier
    !
    if (allocated(alluser)) then
      oldsize = size(alluser)
      if (oldsize.ge.nuser)  return
      allocate(tmp(oldsize),stat=ier)
      if (failed_allocate(rname,'tmp',ier,error)) return
      tmp(:) = alluser(:)
      deallocate(alluser)
      newsize = max(min_alluser_alloc,2*oldsize)
    else
      newsize = min_alluser_alloc
    endif
    !
    allocate(alluser(newsize),stat=ier)
    if (failed_allocate(rname,'alluser',ier,error)) return
    if (allocated(tmp)) then
      alluser(1:oldsize) = tmp(:)
      deallocate(tmp)
    endif
  end subroutine alluser_reallocate
  !
  subroutine cubeadm_opened_list_size(ucols,custom,error)
    use cubedag_list
    !----------------------------------------------------------------------
    ! Defines de size and columns of a list from a list of columns
    ! based on the currently opened cubes
    !----------------------------------------------------------------------
    character(len=*), intent(in)    :: ucols(:)
    integer(kind=4),  intent(out)   :: custom(20)
    logical,          intent(inout) :: error
    !
    type(cubedag_list_user_t) :: user
    integer(kind=4) :: ukeys(20),icol
    character(len=*), parameter :: rname='OPENED>LIST>SIZE'
    !
    call cubeadm_message(admseve%trace,rname,'Welcome')
    !
    user%ncol = size(ucols)
    do icol=1,user%ncol
       user%ucols(icol) = ucols(icol)
    enddo
    call cubedag_list_columns_parse(user,ukeys,error)
    if (error)  return
    call cubedag_list_columns_set(ukeys,custom,error)
    if (error)  return
    call cubedag_list_link_widths(all,custom,error)
    if (error)  return
  end subroutine cubeadm_opened_list_size
end module cubeadm_opened
