module cubedag_link
  use gkernel_interfaces
  use cubedag_messaging
  use cubedag_parameters
  use cubedag_types

  integer(kind=entr_k), parameter :: cubedag_link_minalloc=10
  character(len=*), parameter :: form_lk='(A,T13,I20,1X,A)'  ! Link_t

  public :: cubedag_link_reallocate,cubedag_link_final
  public :: cubedag_link_copy,cubedag_list_links
  public :: cubedag_write_link,cubedag_read_link
  public :: cubedag_link_unlink
  private

contains

  subroutine cubedag_link_reallocate(link,n,error)
    !-------------------------------------------------------------------
    !-------------------------------------------------------------------
    type(cubedag_link_t), intent(inout) :: link
    integer(kind=entr_k), intent(in)    :: n
    logical,              intent(inout) :: error
    ! Local
    character(len=*), parameter :: rname='LINK>REALLOCATE'
    type(cubedag_link_t) :: tmp
    integer(kind=entr_k) :: osize,nsize,iobj
    integer(kind=4) :: ier
    !
    if (associated(link%list)) then
      osize = size(link%list)
      if (osize.gt.n) then
        ! Nothing to do
        return
      else
        ! Steal allocation from original object
        tmp%n     =  link%n
        tmp%list  => link%list
        tmp%flag  => link%flag
        link%list => null()
        link%flag => null()
      endif
      nsize = max(2*osize,n)
      ! link%n unchanged
    else
      nsize = max(cubedag_link_minalloc,n)
      link%n = 0
    endif
    !
    allocate(link%list(nsize),link%flag(nsize),stat=ier)
    if (failed_allocate(rname,'Link buffers',ier,error)) return
    !
    if (associated(tmp%list)) then
      do iobj=1,link%n
        link%list(iobj)%p => tmp%list(iobj)%p
        link%flag(iobj)   =  tmp%flag(iobj)
      enddo
      call cubedag_link_final(tmp,error)
    endif
  end subroutine cubedag_link_reallocate
  !
  subroutine cubedag_link_final(link,error)
    !-------------------------------------------------------------------
    !-------------------------------------------------------------------
    type(cubedag_link_t), intent(inout) :: link
    logical,              intent(inout) :: error
    !
    if (associated(link%list))  deallocate(link%list,link%flag)
    link%n = 0
  end subroutine cubedag_link_final

  subroutine cubedag_list_links(prefix,link,str)
    character(len=*),     intent(in)    :: prefix
    type(cubedag_link_t), intent(in)    :: link
    character(len=*),     intent(inout) :: str
    ! Local
    integer(kind=entr_k) :: jent
    integer(kind=4) :: nc,mlen
    character(len=10) :: tmp
    !
    str = prefix
    nc = len_trim(prefix)
    mlen= len(str)
    if (link%n.le.0) then
      write(str(nc+1:),'(A6)')  '<none>'
    else
      do jent=1,link%n
        write(tmp,'(I0,A1)')  link%list(jent)%p%node%id,','
        str = str(1:nc)//tmp
        nc = len_trim(str)
        if (nc.eq.mlen) then  ! List too long, string exhausted
          str(nc-1:nc) = '..'
          exit
        elseif (jent.eq.link%n) then  ! Last element, strip off trailing coma
          str(nc:nc) = ' '
        endif
      enddo
    endif
  end subroutine cubedag_list_links

  subroutine cubedag_link_copy(in,out,error)
    type(cubedag_link_t), intent(in)    :: in
    type(cubedag_link_t), intent(inout) :: out
    logical,              intent(inout) :: error
    ! Local
    integer(kind=entr_k) :: iobj
    !
    call cubedag_link_reallocate(out,in%n,error)
    if (error)  return
    !
    do iobj=1,in%n
      out%list(iobj)%p => in%list(iobj)%p
      out%flag(iobj)   =  in%flag(iobj)
    enddo
    out%n = in%n
  end subroutine cubedag_link_copy

  subroutine cubedag_write_link(lun,name,link,error)
    integer(kind=4),      intent(in)    :: lun
    character(len=*),     intent(in)    :: name
    type(cubedag_link_t), intent(inout) :: link
    logical,              intent(inout) :: error
    ! Local
    character(len=*), parameter :: rname='LINK>WRITE'
    integer(kind=entr_k) :: il
    integer(kind=4) :: ic,nc,ier
    character(len=:), allocatable :: buf,tmp
    !
    if (link%n.le.0) then
      write(lun,form_lk) name,link%n
    else
      ic = 0
      allocate(character(100)::buf,stat=ier)
      if (failed_allocate(rname,'char buffer',ier,error)) return
      do il=1,link%n
        if (len(buf).lt.ic+21) then
          tmp = buf(1:ic)  ! Implicit (re)allocation
          deallocate(buf)
          allocate(character(2*ic)::buf,stat=ier)
          if (failed_allocate(rname,'char buffer',ier,error)) return
          buf(1:ic) = tmp
        endif
        write(buf(ic+1:ic+20),'(I0,A1)')  link%list(il)%p%node%id,' '
        nc = len_trim(buf(ic+1:ic+20))+1
        ic = ic+nc
      enddo
      write(lun,form_lk) name,link%n,buf(1:ic)
    endif
    !
  end subroutine cubedag_write_link

  subroutine cubedag_read_link(lun,link,error)
    !-------------------------------------------------------------------
    !-------------------------------------------------------------------
    integer(kind=4),      intent(in)    :: lun
    type(cubedag_link_t), intent(inout) :: link
    logical,              intent(inout) :: error
    ! Local
    character(len=*), parameter :: rname='LINK>READ'
    character(len=12) :: key
    character(len=:), allocatable :: buf
    integer(kind=entr_k) :: nl,il
    integer(kind=4) :: i1,i2,nc,ier
    !
    read(lun,form_lk) key,nl
    if (nl.gt.0) then
      ! Try to read in a long-enough buffer
      nc = 32
      do
        allocate(character(nc)::buf,stat=ier)
        if (failed_allocate(rname,'char buffer',ier,error)) return
        backspace(lun)   ! Backspace in formatted file is not standard!
        read(lun,form_lk) key,nl,buf
        if (buf(nc-1:nc).eq.' ')  then
          ! 2 last chars are blank => ok, no number missed
          exit
        endif
        deallocate(buf)
        nc = 2*nc
      enddo
      call cubedag_link_reallocate(link,nl,error)
      if (error)  return
      il = 0
      i1 = 1
      i2 = 1
      do while (il.lt.nl)
        if (buf(i2+1:i2+1).eq.' ') then
          il = il+1
          read(buf(i1:i2),*)  link%flag(il)
          i1 = i2+2
          i2 = i1
        else
          i2 = i2+1
        endif
      enddo
    endif
    link%n = nl
  end subroutine cubedag_read_link

  subroutine cubedag_link_unlink(link,object,error)
    !-------------------------------------------------------------------
    ! Remove the named 'object' from the link list
    !-------------------------------------------------------------------
    type(cubedag_link_t),         intent(inout) :: link
    class(cubedag_node_object_t), pointer       :: object
    logical,                      intent(inout) :: error
    ! Local
    character(len=*), parameter :: rname='LINK>UNLINK'
    integer(kind=entr_k) :: ient,shift
    logical :: found
    !
    found = .false.
    shift = 0
    do ient=1,link%n
      if (associated(link%list(ient)%p,object)) then
        found = .true.
        shift = shift+1
        cycle
      endif
      if (found) then
        link%list(ient-shift)%p => link%list(ient)%p
        link%flag(ient-shift)   =  link%flag(ient)    ! Probably useless
      endif
    enddo
    link%n = link%n-shift
    !
    ! This is too much verbose, and can happen under legitimate
    ! conditions.
    ! if (.not.found)  &
    !   call cubedag_message(seve%w,rname,'Object not found in list')
    !
  end subroutine cubedag_link_unlink

end module cubedag_link
