module cubedag_history_types
  use gkernel_interfaces
  use cubedag_parameters
  use cubedag_messaging
  use cubedag_link_type
  use cubedag_node_type
  !---------------------------------------------------------------------
  ! Support module for the history type
  !---------------------------------------------------------------------

  integer(kind=entr_k), parameter :: history_optimize_minalloc=100
  integer(kind=4), parameter :: command_length=16  ! ZZZ Duplicated from SIC

  type history_optimize_t
    integer(kind=entr_k) :: next=1  ! Number of commands in history index + 1
    integer(kind=iden_l),              allocatable :: id(:)
    character(len=command_length),     allocatable :: command(:)
    character(len=commandline_length), allocatable :: line(:)
    type(cubedag_link_t),              allocatable :: inputs(:)
    type(cubedag_link_t),              allocatable :: outputs(:)
  contains
    procedure, public  :: reallocate => cubedag_history_reallocate_expo
    procedure, public  :: add        => cubedag_history_add_fromargs
    procedure, public  :: list       => cubedag_history_list
    final              :: cubedag_history_final
  end type history_optimize_t

  public :: history_optimize_t
  private

contains

  subroutine cubedag_history_reallocate_expo(optx,mcomms,error)
    !---------------------------------------------------------------------
    !  Reallocate the 'optimize' type arrays. If current allocation is not
    ! enough, double the size of allocation. Since this reallocation
    ! routine is used in a context of adding more and more data, data
    ! is always preserved after reallocation.
    !---------------------------------------------------------------------
    class(history_optimize_t), intent(inout) :: optx    !
    integer(kind=entr_k),      intent(in)    :: mcomms  ! Requested size
    logical,                   intent(inout) :: error   ! Logical error flag
    ! Local
    integer(kind=entr_k) :: ncomms
    !
    if (allocated(optx%command)) then
      ncomms = size(optx%command,kind=8)
      if (ncomms.ge.mcomms)  return           ! Enough size yet
      ncomms = 2_8*ncomms                     ! Request twice more place than before
      if (ncomms.lt.mcomms)  ncomms = mcomms  ! Twice is not enough, use mcomms
    else
      ncomms = max(mcomms,history_optimize_minalloc)  ! No allocation yet, use mcomms
    endif
    !
    call cubedag_history_reallocate(optx,ncomms,.true.,error)
    if (error)  return
  end subroutine cubedag_history_reallocate_expo

  subroutine cubedag_history_reallocate(optx,mcomms,keep,error)
    !---------------------------------------------------------------------
    !  Allocate the 'optimize' type arrays. Enlarge the arrays to the
    ! requested size, if needed. No shrink possible. Keep data if
    ! requested.
    !---------------------------------------------------------------------
    type(history_optimize_t), intent(inout) :: optx    !
    integer(kind=entr_k),     intent(in)    :: mcomms  ! Requested size
    logical,                  intent(in)    :: keep    ! Keep previous data?
    logical,                  intent(inout) :: error   ! Logical error flag
    ! Local
    character(len=*), parameter :: rname='HISTORY>REALLOCATE'
    integer(kind=4) :: ier
    integer(kind=entr_k) :: ncomms,inode
    integer(kind=iden_l), allocatable :: bufid(:)
    character(len=command_length), allocatable :: bufcc(:)
    character(len=commandline_length), allocatable :: bufcl(:)
    type(cubedag_link_t), allocatable :: buflk(:)
    !
    if (allocated(optx%command)) then
      ncomms = size(optx%command,kind=8)  ! Size of allocation
      if (ncomms.ge.mcomms) then
        ! Index is already allocated with a larger size. Keep it like this.
        ! Shouldn't we deallocate huge allocations if user requests a small one?
        return
      endif
    elseif (mcomms.eq.0) then
      ! No problem: can occur when dealing with empty files (e.g. nothing
      ! was written in an output file)
      return
    elseif (mcomms.lt.0) then
      call cubedag_message(seve%e,rname,'Can not allocate empty indexes')
      error = .true.
      return
    endif
    !
    ncomms = min(ncomms,optx%next-1)  ! Used part of the arrays
    if (keep) then
      allocate(bufid(ncomms),stat=ier)
      allocate(bufcc(ncomms),stat=ier)
      allocate(bufcl(ncomms),stat=ier)
      allocate(buflk(ncomms),stat=ier)
      if (failed_allocate(rname,'buf arrays',ier,error)) then
        error = .true.
        return
      endif
    endif
    !
    call reallocate_optimize_id(rname,'id array',     optx%id,     mcomms,keep,bufid,error)
    if (error)  return
    call reallocate_optimize_ch(rname,'command array',optx%command,mcomms,keep,bufcc,error)
    if (error)  return
    call reallocate_optimize_ch(rname,'line array',   optx%line,   mcomms,keep,bufcl,error)
    if (error)  return
    call reallocate_optimize_lk(rname,'inputs array', optx%inputs, mcomms,keep,buflk,error)
    if (error)  return
    call reallocate_optimize_lk(rname,'outputs array',optx%outputs,mcomms,keep,buflk,error)
    if (error)  return
    !
    if (keep) then
      if (allocated(bufid))  deallocate(bufid)
      if (allocated(bufcc))  deallocate(bufcc)
      if (allocated(bufcl))  deallocate(bufcl)
      if (allocated(buflk))  deallocate(buflk)
    endif
    !
    ! Initialize the new components
    do inode=ncomms+1,mcomms
      call history_optimize_init(optx,inode,error)
      if (error)  return
    enddo
  end subroutine cubedag_history_reallocate
  !
  subroutine reallocate_optimize_id(rname,name,val,mcomms,keep,buf,error)
    character(len=*),     intent(in)    :: rname
    character(len=*),     intent(in)    :: name
    integer(kind=iden_l), allocatable   :: val(:)
    integer(kind=entr_k), intent(in)    :: mcomms
    logical,              intent(in)    :: keep
    integer(kind=iden_l), allocatable   :: buf(:)  ! Not allocated if keep is .false.
    logical,              intent(inout) :: error
    ! Local
    integer(kind=4) :: ier
    integer(kind=entr_k) :: ncomms
    !
    if (keep) then
      ncomms = size(buf)
      buf(:) = val(1:ncomms)
    endif
    if (allocated(val)) deallocate(val)
    allocate(val(mcomms),stat=ier)
    if (failed_allocate(rname,name,ier,error))  return
    if (keep) val(1:ncomms) = buf(:)
  end subroutine reallocate_optimize_id
  !
  subroutine reallocate_optimize_ch(rname,name,val,mcomms,keep,buf,error)
    character(len=*),     intent(in)    :: rname
    character(len=*),     intent(in)    :: name
    character(len=*),     allocatable   :: val(:)
    integer(kind=entr_k), intent(in)    :: mcomms
    logical,              intent(in)    :: keep
    character(len=*),     allocatable   :: buf(:)  ! Not allocated if keep is .false.
    logical,              intent(inout) :: error
    ! Local
    integer(kind=4) :: ier
    integer(kind=entr_k) :: ncomms
    !
    if (keep) then
      ncomms = size(buf)
      buf(:) = val(1:ncomms)
    endif
    if (allocated(val)) deallocate(val)
    allocate(val(mcomms),stat=ier)
    if (failed_allocate(rname,name,ier,error))  return
    if (keep) val(1:ncomms) = buf(:)
  end subroutine reallocate_optimize_ch
  !
  subroutine reallocate_optimize_lk(rname,name,val,mcomms,keep,buf,error)
    character(len=*),     intent(in)    :: rname
    character(len=*),     intent(in)    :: name
    type(cubedag_link_t), allocatable   :: val(:)
    integer(kind=entr_k), intent(in)    :: mcomms
    logical,              intent(in)    :: keep
    type(cubedag_link_t), allocatable   :: buf(:)  ! Not allocated if keep is .false.
    logical,              intent(inout) :: error
    ! Local
    integer(kind=4) :: ier
    integer(kind=entr_k) :: icomm,ncomms
    !
    if (keep) then
      ncomms = size(buf)
      do icomm=1,ncomms
        buf(icomm)%n    =  val(icomm)%n
        call move_alloc(from=val(icomm)%list,to=buf(icomm)%list)
        call move_alloc(from=val(icomm)%flag,to=buf(icomm)%flag)
      enddo
    endif
    if (allocated(val)) deallocate(val)
    allocate(val(mcomms),stat=ier)
    if (failed_allocate(rname,name,ier,error))  return
    if (keep) then
      do icomm=1,ncomms
        val(icomm)%n    =  buf(icomm)%n
        call move_alloc(from=buf(icomm)%list,to=val(icomm)%list)
        call move_alloc(from=buf(icomm)%flag,to=val(icomm)%flag)
      enddo
    endif
  end subroutine reallocate_optimize_lk

  subroutine cubedag_history_final(hoptx)
    type(history_optimize_t), intent(inout) :: hoptx
    ! Local
    integer(kind=entr_k) :: ient
    logical :: error
    !
    hoptx%next = 1
    if (allocated(hoptx%id))       deallocate(hoptx%id)
    if (allocated(hoptx%command))  deallocate(hoptx%command)
    if (allocated(hoptx%line))     deallocate(hoptx%line)
    !
    error = .false.
    if (allocated(hoptx%inputs)) then
      do ient=1,size(hoptx%inputs)
        call hoptx%inputs(ient)%final(error)
        if (error)  continue
      enddo
    endif
    if (allocated(hoptx%outputs)) then
      do ient=1,size(hoptx%outputs)
        call hoptx%outputs(ient)%final(error)
        if (error)  continue
      enddo
    endif
  end subroutine cubedag_history_final

  subroutine history_optimize_init(optx,i,error)
    !---------------------------------------------------------------------
    ! Initialize the i-th component in the index
    !---------------------------------------------------------------------
    type(history_optimize_t), intent(inout) :: optx
    integer(kind=entr_k),     intent(in)    :: i
    logical,                  intent(inout) :: error
    !
    optx%id(i)        = 0
    optx%command(i)   = strg_unk
    optx%line(i)      = strg_unk
    optx%inputs(i)%n  = 0
    optx%outputs(i)%n = 0
  end subroutine history_optimize_init

  subroutine cubedag_history_add_fromargs(hoptx,command,line,inputs,outputs,error)
    !-------------------------------------------------------------------
    ! Add a new command in the HISTORY index
    !-------------------------------------------------------------------
    class(history_optimize_t), intent(inout) :: hoptx
    character(len=*),          intent(in)    :: command
    character(len=*),          intent(in)    :: line
    type(cubedag_link_t),      intent(in)    :: inputs
    type(cubedag_link_t),      intent(in)    :: outputs
    logical,                   intent(inout) :: error
    ! Local
    integer(kind=entr_k) :: ient
    !
    ient = hoptx%next
    call hoptx%reallocate(ient,error)
    if (error)  return
    !
    hoptx%id(ient) = ient
    hoptx%command(ient) = command
    hoptx%line(ient) = line
    call inputs%copy(hoptx%inputs(ient),error)
    if (error)  return
    call outputs%copy(hoptx%outputs(ient),error)
    if (error)  return
    !
    hoptx%next = hoptx%next+1
  end subroutine cubedag_history_add_fromargs

  subroutine cubedag_history_list(hoptx,error)
    !-------------------------------------------------------------------
    ! List the history index
    !-------------------------------------------------------------------
    class(history_optimize_t), intent(in)    :: hoptx
    logical,                   intent(inout) :: error
    ! Local
    character(len=*), parameter :: rname='HISTORY>LIST'
    integer(kind=entr_k) :: ient
    character(len=10) :: tmpi,tmpo
    integer(kind=4) :: nd
    character(len=16) :: forma
    !
    if (hoptx%next.le.1) then
      call cubedag_message(seve%w,rname,'History index is empty')
      error = .true.
      return
    endif
    !
    nd = ceiling(log10(real(maxval(hoptx%id(1:hoptx%next-1))+1,kind=8)))
    write(forma,'(A,I0,A)') '(I',nd,',4(2X,A))'
    !
    do ient=1,hoptx%next-1
      call hoptx%inputs(ient)%repr('i=',tmpi)
      call hoptx%outputs(ient)%repr('o=',tmpo)
      write(*,forma)  hoptx%id(ient),hoptx%command(ient),tmpi,tmpo,trim(hoptx%line(ient))
    enddo
  end subroutine cubedag_history_list
  !
end module cubedag_history_types
