!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
module cubedag_list
  use phys_const
  use gkernel_interfaces
  use classic_api
  use toc_types
  use cubedag_parameters
  use cubedag_dag
  use cubedag_find
  use cubedag_messaging
  use cubedag_tuple
  use cubedag_type
  use cubedag_types
  use cubedag_index

  integer(kind=4), parameter :: opttoc=1
  integer(kind=4), parameter :: optpage=2
  integer(kind=4), parameter :: optcolumn=3
  integer(kind=4), parameter :: optfile=4
  integer(kind=4), parameter :: optvar=5

  integer(kind=4), parameter :: ncolumns=41
  character(len=*), parameter :: columns(ncolumns) = (/  &
    'ENTRY      ','IDENTIFIER ','PARENTS    ','CHILDREN   ','TWINS      ',  &
    'UNIT       ','SOURCE     ','PROJTYPE   ','L0         ','M0         ',  &
    'PROJANGLE  ','SPALINC    ','SPAMINC    ','LINE       ','SPEFREQVAL ',  &
    'SPEFREQINC ','SPEVELOVAL ','BMAJOR     ','BMINOR     ','BPA        ',  &
    'OBSERVATORY','LOCATION   ','ACCESS     ','ORIGIN     ','FAMILY     ',  &
    'FLAG       ','TYPE       ','VARIABLE   ','SEPARATOR  ','HISTORY    ',  &
    'MEMSIZE    ','DISKSIZE   ','DATASIZE   ',                              &
    ! Shorcuts for group of columns
    'DEFAULT    ','BEAM       ','PROJECTION ','GRAPH      ','SPECTRAL   ',  &
    'SPATIAL    ','TUPLE      ','SIZE       '/)
  integer(kind=4) :: col_width(ncolumns)
  character(len=6) :: col_hformat(ncolumns)  ! Header format
  character(len=6) :: col_vformat(ncolumns)  ! Value format
  !
  integer(kind=code_k), parameter :: col_none        = 0  ! Nullifier
  integer(kind=code_k), parameter :: col_entry       = 1
  integer(kind=code_k), parameter :: col_id          = 2
  integer(kind=code_k), parameter :: col_parents     = 3
  integer(kind=code_k), parameter :: col_children    = 4
  integer(kind=code_k), parameter :: col_twins       = 5
  integer(kind=code_k), parameter :: col_unit        = 6
  integer(kind=code_k), parameter :: col_source      = 7
  integer(kind=code_k), parameter :: col_ptype       = 8
  integer(kind=code_k), parameter :: col_l0          = 9
  integer(kind=code_k), parameter :: col_m0          = 10
  integer(kind=code_k), parameter :: col_pang        = 11
  integer(kind=code_k), parameter :: col_lres        = 12
  integer(kind=code_k), parameter :: col_mres        = 13
  integer(kind=code_k), parameter :: col_line        = 14
  integer(kind=code_k), parameter :: col_restf       = 15
  integer(kind=code_k), parameter :: col_fres        = 16
  integer(kind=code_k), parameter :: col_vsys        = 17
  integer(kind=code_k), parameter :: col_rmaj        = 18
  integer(kind=code_k), parameter :: col_rmin        = 19
  integer(kind=code_k), parameter :: col_rang        = 20
  integer(kind=code_k), parameter :: col_observatory = 21
  integer(kind=code_k), parameter :: col_location    = 22
  integer(kind=code_k), parameter :: col_access      = 23
  integer(kind=code_k), parameter :: col_origin      = 24
  integer(kind=code_k), parameter :: col_family      = 25
  integer(kind=code_k), parameter :: col_flag        = 26
  integer(kind=code_k), parameter :: col_type        = 27
  integer(kind=code_k), parameter :: col_sicvar      = 28
  integer(kind=code_k), parameter :: col_separ       = 29
  integer(kind=code_k), parameter :: col_history     = 30
  integer(kind=code_k), parameter :: col_memsize     = 31
  integer(kind=code_k), parameter :: col_disksize    = 32
  integer(kind=code_k), parameter :: col_datasize    = 33
  ! Aliases
  integer(kind=code_k), parameter :: col_default     = 34
  integer(kind=code_k), parameter :: col_beam        = 35
  integer(kind=code_k), parameter :: col_proj        = 36
  integer(kind=code_k), parameter :: col_graph       = 37
  integer(kind=code_k), parameter :: col_spec        = 38
  integer(kind=code_k), parameter :: col_spat        = 39
  integer(kind=code_k), parameter :: col_tuple       = 40
  integer(kind=code_k), parameter :: col_size        = 41
  !
  ! Aliases translation
  integer(kind=code_k), parameter :: col_default_list(7) =  &
    [col_id,col_type,col_family,col_observatory,col_source,col_line,col_flag]
  integer(kind=code_k), parameter :: col_beam_list(3) = &
    [col_rmaj,col_rmin,col_rang]
  integer(kind=code_k), parameter :: col_proj_list(4) = &
    [col_ptype,col_l0,col_m0,col_pang]
  integer(kind=code_k), parameter :: col_graph_list(4) = &
    [col_family,col_parents,col_children,col_twins]
  integer(kind=code_k), parameter :: col_spec_list(4) = &
    [col_line,col_restf,col_fres,col_vsys]
  integer(kind=code_k), parameter :: col_spat_list(5) = &
    [col_source,col_l0,col_m0,col_lres,col_mres]
  integer(kind=code_k), parameter :: col_tuple_list(2) = &
    [col_access,col_location]
  integer(kind=code_k), parameter :: col_size_list(3) = &
    [col_datasize,col_memsize,col_disksize]
  !
  ! Support for /TOC option
  ! Keywords (order matters, see subroutine cubedag_toc_init):
  character(len=*), parameter :: cubedag_list_toc_keys(6) = (/  &
    'SOURCE', 'LINE  ', 'OBSERV', 'ORIGIN', 'FAMILY', 'FLAG  ' /)
  ! CUBE index types, i.e. for fields which needs special decoding (e.g.
  ! gag_date: we won't display the I*4 value, but its translation as a string)
  integer(kind=4), parameter :: cubedag_ptype_null=0
  integer(kind=4), parameter :: cubedag_ptype_origin=1
  type(toc_t), target :: mtoc
  integer(kind=code_k),  target, allocatable :: toc_origin(:)
  character(len=base_l), target, allocatable :: toc_family(:)
  character(len=sour_l), target, allocatable :: toc_source(:)
  character(len=line_l), target, allocatable :: toc_line(:)
  character(len=flag_l), target, allocatable :: toc_flag(:)
  character(len=12),     target, allocatable :: toc_obs(:)
  !
  public :: cubedag_list_command,cubedag_list_optx,cubedag_list_link
  public :: cubedag_list_user_t, columns
  public :: cubedag_list_columns_parse,cubedag_list_columns_set
  public :: cubedag_list_link_widths,cubedag_list_one_custom
  public :: cubedag_list_toc_keys
  private
  !
  type cubedag_list_user_t
     type(cubedag_find_t)  :: find
     character(len=argu_l) :: ucols(20)
     character(len=argu_l) :: tocvar
     character(len=file_l) :: file
     integer(kind=code_k)  :: index
     integer(kind=4)       :: ncol
     logical               :: dofile
     logical               :: dovar
     logical               :: dopage
     logical               :: dotoc
     integer(kind=4)       :: iopttoc
     character(len=:), pointer :: line  ! Sic can not work with a copy, but with the original chain only
  end type cubedag_list_user_t
  !
contains
  !
  subroutine cubedag_list_command(user,error)
    !---------------------------------------------------------------------
    ! Execution routine for command LIST
    !---------------------------------------------------------------------
    type(cubedag_list_user_t), intent(inout) :: user
    logical,                   intent(inout) :: error
    ! Local
    character(len=*), parameter :: rname='LIST'
    character(len=7) :: optname
    integer(kind=4) :: ier,olun
    type(cubedag_optimize_t) :: optx
    integer(kind=4) :: ukeys(20),custom(20)  ! Up to 20 custom columns
    character(len=filename_length) :: file
    !
    select case (user%index)
    case (code_index_dag)
      optname = 'DAG'
      call cubedag_find_ix2optx(user%find,optx,error)
      if (error)  return
    case (code_index_current)
      optname = 'Current'
      call cubedag_find_cx2optx(user%find,optx,error)
      if (error)  return
    case default
      call cubedag_message(seve%e,rname,'Default index is not supported')
      error = .true.
      return
    end select
    !
    ! Output to STDOUT or file?
    if (user%dofile) then  ! /FILE
      ier = sic_getlun(olun)
      if (ier.ne.1) then
        call cubedag_message(seve%e,rname,'No logical unit left')
        error = .true.
        return
      endif
      ier = sic_open(olun,user%file,'NEW',.false.)
      if (ier.ne.0) then
        call cubedag_message(seve%e,rname,'Cannot open file '//file)
        error = .true.
        call sic_frelun(olun)
        return
      endif
    else
      olun = stdout
    endif
    !
    if (user%dotoc) then  ! /TOC
      call cubedag_list_toc_comm(optx,user,olun,error)
      if (error)  goto 10
    else
      call cubedag_list_columns_parse(user%ncol,user%ucols,ukeys,error)
      if (error)  goto 10
      call cubedag_list_columns_set(ukeys,custom,error)
      if (error)  goto 10
      call cubedag_list_optx_widths(optx,custom,error)
      if (error)  goto 10
      call cubedag_list_do(optx,optname,custom,olun,user%dopage,error)
      if (error)  goto 10
    endif
    !
  10 continue
    if (olun.ne.stdout) then
      ier = sic_close(olun)
      call sic_frelun(olun)
    endif
  end subroutine cubedag_list_command
  !
  subroutine cubedag_list_optx(optx,optname,error)
    type(cubedag_optimize_t), intent(in)    :: optx
    character(len=*),         intent(in)    :: optname
    logical,                  intent(inout) :: error
    ! Local
    integer(kind=4) :: custom(20)
    !
    call cubedag_list_columns_set([col_default],custom,error)
    if (error)  return
    call cubedag_list_optx_widths(optx,custom,error)
    if (error)  return
    call cubedag_list_do(optx,optname,custom,stdout,.false.,error)
    if (error)  return
  end subroutine cubedag_list_optx
  !
  subroutine cubedag_list_columns_parse(ncol,ucols,ukeys,error)
    use cubetools_disambiguate
    !---------------------------------------------------------------------
    ! Support routine for command:
    !   MLIST /COLUMNS Key1 ... KeyN
    ! Get the custom list of columns (user identifiers)
    !---------------------------------------------------------------------
    integer(kind=4),      intent(in)    :: ncol
    character(len=*),     intent(in)    :: ucols(:)
    integer(kind=code_k), intent(out)   :: ukeys(:)  ! User keys
    logical,              intent(inout) :: error     !
    ! Local
    character(len=*), parameter :: rname='LIST'
    integer(kind=4) :: iarg
    character(len=12) :: key
    !
    ukeys(:) = col_none
    do iarg=1,ncol
      call cubetools_disambiguate_strict(ucols(iarg),columns,ukeys(iarg),key,error)
      if (error)  return
    enddo
  end subroutine cubedag_list_columns_parse
  !
  subroutine cubedag_list_columns_set(ukeys,ckeys,error)
    !---------------------------------------------------------------------
    ! Support routine for command:
    !   MLIST /COLUMNS Key1 ... KeyN
    ! Translate the list of user keys to column keys.
    !---------------------------------------------------------------------
    integer(kind=4), intent(in)    :: ukeys(:)  !
    integer(kind=4), intent(out)   :: ckeys(:)  !
    logical,         intent(inout) :: error     !
    ! Local
    character(len=*), parameter :: rname='LIST'
    integer(kind=4) :: ikey,iout,nnew
    integer(kind=4) :: new(10)
    !
    ckeys(:) = col_none
    !
    iout=0
    do ikey=1,size(ukeys)
      if (ukeys(ikey).eq.col_none)  exit
      ! Cases are for grouped columns, case default add a single column
      select case (ukeys(ikey))
      case(col_default)
        nnew = size(col_default_list)
        new(1:nnew) = col_default_list(:)
      case(col_beam)
        nnew = size(col_beam_list)
        new(1:nnew) = col_beam_list(:)
      case(col_proj)
        nnew = size(col_proj_list)
        new(1:nnew) = col_proj_list(:)
      case (col_graph)
        nnew = size(col_graph_list)
        new(1:nnew) = col_graph_list(:)
      case (col_spec)
        nnew = size(col_spec_list)
        new(1:nnew) = col_spec_list(:)
      case (col_spat)
        nnew = size(col_spat_list)
        new(1:nnew) = col_spat_list(:)
      case (col_tuple)
        nnew = size(col_tuple_list)
        new(1:nnew) = col_tuple_list(:)
      case (col_size)
        nnew = size(col_size_list)
        new(1:nnew) = col_size_list(:)
      case default
        nnew = 1
        new(1) = ukeys(ikey)
      end select
      !
      if (iout+nnew.gt.size(ckeys)) then
        call cubedag_message(seve%w,rname,'/COLUMNS list too long, truncated')
        return
      endif
      ckeys(iout+1:iout+nnew) = new(1:nnew)
      iout = iout+nnew
    enddo
  end subroutine cubedag_list_columns_set
  !
  subroutine cubedag_list_optx_widths(optx,custom,error)
    use cubedag_node
    !-------------------------------------------------------------------
    ! Compute the best width for columns supporting adaptative width,
    ! based on the index to be listed.
    ! This version with cubedag_optimize_t as argument
    !-------------------------------------------------------------------
    type(cubedag_optimize_t), intent(in)    :: optx       !
    integer(kind=4),          intent(in)    :: custom(:)  ! Columns to be listed
    logical,                  intent(inout) :: error      !
    ! Local
    integer(kind=entr_k) :: ient,maxid
    integer(kind=4) :: maxlfamily,maxlobs,maxlsour,maxlline,maxlflag,lflag
    character(len=24) :: str24  ! Max column length for these is 24
    class(cubedag_node_object_t), pointer :: obj
    !
    maxid = 0
    maxlfamily = 1
    maxlobs = 1
    maxlsour = 1
    maxlline = 1
    maxlflag = 1
    !
    do ient=1,optx%next-1
      obj => optx%object(ient)%p
      if (obj%node%type.eq.code_type_node)  cycle
      ! Identifier
      maxid = max(maxid,obj%node%id)
      ! Family name length
      maxlfamily = max(maxlfamily,len_trim(obj%node%family))
      ! Observatory name length
      call obj%node%head%obs%tostr(str24,error)
      if (error)  return
      maxlobs = max(maxlobs,len_trim(str24))
      ! Source name length
      maxlsour = max(maxlsour,len_trim(obj%node%head%spatial_source))
      ! Line name length
      maxlline = max(maxlline,len_trim(obj%node%head%spectral_line))
      ! Flag name length
      call cubedag_flag_tostr(obj%node,lstrflag=lflag,error=error)
      if (error)  return
      maxlflag = max(maxlflag,lflag)
    enddo
    !
    col_width(col_id) = max(2,floor(log10(real(maxid,kind=8)))+1)
    write(col_hformat(col_id),'(A,I0,A)')  '(A',col_width(col_id),')'  ! Right-justified
    write(col_vformat(col_id),'(A,I0,A)')  '(I',col_width(col_id),')'
    !
    col_width(col_family) = maxlfamily
    col_hformat(col_family) = '(A)'
    write(col_vformat(col_family),'(A,I0,A)')  '(A',col_width(col_family),')'
    !
    col_width(col_observatory) = maxlobs
    col_hformat(col_observatory) = '(A)'
    write(col_vformat(col_observatory),'(A,I0,A)')  '(A',col_width(col_observatory),')'
    !
    col_width(col_source) = maxlsour
    col_hformat(col_source) = '(A)'
    write(col_vformat(col_source),'(A,I0,A)')  '(A',col_width(col_source),')'
    !
    col_width(col_line) = maxlline
    col_hformat(col_line) = '(A)'
    write(col_vformat(col_line),'(A,I0,A)')  '(A',col_width(col_line),')'
    !
    col_width(col_flag) = maxlflag
    col_hformat(col_flag) = '(A)'
    write(col_vformat(col_flag),'(A,I0,A)')  '(A',col_width(col_flag),')'
  end subroutine cubedag_list_optx_widths
  !
  subroutine cubedag_list_link_widths(link,custom,error)
    use cubedag_index
    !-------------------------------------------------------------------
    ! Compute the best width for columns supporting adaptative width,
    ! based on the link_t to be listed.
    ! This version with cubedag_link_t as argument
    !-------------------------------------------------------------------
    type(cubedag_link_t), intent(in)    :: link       !
    integer(kind=4),      intent(in)    :: custom(:)  ! Columns to be listed
    logical,              intent(inout) :: error      !
    ! Local
    type(cubedag_optimize_t) :: myoptx
    integer(kind=entr_k) :: ient
    !
    ! For simplicity, convert the cubedag_link_t into a cubedag_optimize_t
    call cubedag_index_reallocate(myoptx,link%n,.false.,error)
    if (error)  return
    do ient=1,link%n
      myoptx%object(ient)%p => link%list(ient)%p
      myoptx%topomarker(ient) = 0
    enddo
    myoptx%next = link%n+1
    !
    call cubedag_list_optx_widths(myoptx,custom,error)
    if (error)  return
  end subroutine cubedag_list_link_widths
  !
  subroutine cubedag_list_do(optx,name,custom,olun,page,error)
    use cubedag_node
    !---------------------------------------------------------------------
    !
    !---------------------------------------------------------------------
    type(cubedag_optimize_t), intent(in)    :: optx       !
    character(len=*),         intent(in)    :: name       !
    integer(kind=4),          intent(in)    :: custom(:)  ! Columns to be listed
    integer(kind=4),          intent(in)    :: olun       ! Output logical unit
    logical,                  intent(in)    :: page       ! Page or Scroll mode?
    logical,                  intent(inout) :: error      !
    ! Local
    character(len=*), parameter :: rname='LIST'
    integer(kind=entr_k) :: ient
    integer(kind=4) :: tt_lines,iline
    character(len=message_length) :: mess
    class(cubedag_node_object_t), pointer :: obj
    !
    if (optx%next.le.1) then
      call cubedag_message(seve%w,rname,'No entry in '//trim(name)//' index')
      return
    endif
    if (custom(1).eq.col_none) then
      call cubedag_message(seve%e,rname,'Internal error: list of colums is empty')
      error = .true.
      return
    endif
    !
    tt_lines = sic_ttynlin()-1
    iline = 0
    !
    ! Print header
    call cubedag_list_one_custom_header(custom,mess,error)
    if (error)  return
    call cubedag_list_one_print(mess,olun,iline)
    !
    do ient=1,optx%next-1
      !
      obj => optx%object(ient)%p
      !
      ! Do not list pure-node object, which are irrelevant (no data provided)
      if (obj%node%type.eq.code_type_node)  cycle
      !
      if (olun.eq.stdout .and. page) then
        if (mod(iline,tt_lines).eq.0) then
          if (hlp_more().ne.0)  return
          ! Repeat header
          call cubedag_list_one_custom_header(custom,mess,error)
          if (error)  return
          call cubedag_list_one_print(mess,olun,iline)
        endif
      endif
      !
      call cubedag_list_node(obj,custom,olun,iline,error)
      if (error)  return
      !
    enddo
    !
    if (iline.gt.tt_lines .and. .not.page) then
      ! Long list in non-page mode: repeat header at last line
      call cubedag_list_one_custom_header(custom,mess,error)
      if (error)  return
      call cubedag_list_one_print(mess,olun,iline)
    endif
  end subroutine cubedag_list_do
  !
  subroutine cubedag_list_link(link,doheader,ucols,error)
    !-------------------------------------------------------------------
    ! List objects from a cubedag_link_t
    !-------------------------------------------------------------------
    type(cubedag_link_t), intent(in)    :: link
    logical,              intent(in)    :: doheader
    character(len=*),     intent(in)    :: ucols(:)
    logical,              intent(inout) :: error
    ! Local
    integer(kind=entr_k) :: iobj
    integer(kind=code_k) :: ukeys(20)
    integer(kind=4) :: iline,custom(20)
    character(len=mess_l) :: mess
    !
    call cubedag_list_columns_parse(size(ucols),ucols,ukeys,error)
    if (error)  return
    call cubedag_list_columns_set(ukeys,custom,error)
    if (error)  return
    call cubedag_list_link_widths(link,custom,error)
    if (error)  return
    !
    iline = 0
    !
    if (doheader) then  ! Print header
      call cubedag_list_one_custom_header(custom,mess,error)
      if (error)  return
      call cubedag_list_one_print(mess,stdout,iline)
    endif
    !
    do iobj=1,link%n
      call cubedag_list_node(link%list(iobj)%p,custom,stdout,iline,error)
      if (error)  return
    enddo
  end subroutine cubedag_list_link
  !
  function cubedag_list_shows_tuple(custom)
    !-------------------------------------------------------------------
    ! Return .true. if one of the tuple-related columns is to be shown
    !-------------------------------------------------------------------
    logical :: cubedag_list_shows_tuple
    integer(kind=4), intent(in) :: custom(:)
    !
    cubedag_list_shows_tuple = any(custom.eq.col_location) .or.  &
                               any(custom.eq.col_access)   .or.  &
                               any(custom.eq.col_disksize)
  end function cubedag_list_shows_tuple
  !
  subroutine cubedag_list_node(obj,custom,olun,iline,error)
    !-------------------------------------------------------------------
    ! List one node with custom columns
    !-------------------------------------------------------------------
    class(cubedag_node_object_t), intent(in)    :: obj        !
    integer(kind=4),              intent(in)    :: custom(:)  ! Columns to be listed
    integer(kind=4),              intent(in)    :: olun       !
    integer(kind=4),              intent(inout) :: iline      ! Current line number
    logical,                      intent(inout) :: error      !
    ! Local
    integer(kind=4), parameter :: naccesses=6
    integer(kind=code_k), parameter :: accesses(naccesses) =  &
      (/ code_cube_imaset,code_cube_speset,code_cube_unkset,  &
         code_cube_imaset,code_cube_speset,code_cube_unkset /)
    integer(kind=code_k), parameter :: locations(naccesses) =  &
      (/ code_buffer_disk,  code_buffer_disk,  code_buffer_disk, &
         code_buffer_memory,code_buffer_memory,code_buffer_memory /)
    logical :: first
    character(len=message_length) :: mess
    integer(kind=4) :: icube
    !
    first = .true.
    if (cubedag_list_shows_tuple(custom)) then
      do icube=1,naccesses  ! Loop over the possible cubes in tuple
        if (obj%node%tuple%hascube(accesses(icube),locations(icube))) then
          call cubedag_list_one_custom(obj,custom,first,accesses(icube),locations(icube),mess,error)
          if (error)  return
          call cubedag_list_one_print(mess,olun,iline)
          if (first)  first = .false.
        endif
      enddo
    endif
    !
    if (first) then
      ! This can happen if:
      ! 1) no tuple-related column is to be shown
      ! 2) not a single cube was available. Might happen in case of error...
      call cubedag_list_one_custom(obj,custom,first,code_null,code_null,mess,error)
      if (error)  return
      call cubedag_list_one_print(mess,olun,iline)
    endif
  end subroutine cubedag_list_node
  !
  subroutine cubedag_list_one_custom(obj,custom,all,access,location,mess,error)
    class(cubedag_node_object_t), intent(in)    :: obj
    integer(kind=4),              intent(in)    :: custom(:)  !
    logical,                      intent(in)    :: all        !
    integer(kind=code_k),         intent(in)    :: access     !
    integer(kind=code_k),         intent(in)    :: location   !
    character(len=*),             intent(out)   :: mess       !
    logical,                      intent(inout) :: error      !
    !
    if (all) then
      call cubedag_list_one_custom_all(obj,custom,access,location,mess,error)
      if (error)  return
    else
      call cubedag_list_one_custom_tuple(obj,custom,access,location,mess,error)
      if (error)  return
    endif
  end subroutine cubedag_list_one_custom
  !
  subroutine cubedag_list_one_custom_header(custom,mess,error)
    integer(kind=4),  intent(in)    :: custom(:)  !
    character(len=*), intent(out)   :: mess       !
    logical,          intent(inout) :: error      !
    ! Local
    integer(kind=4) :: icol,nc
    !
    mess = ''
    nc = 0
    do icol=1,size(custom)
      select case (custom(icol))
      case (col_entry)
        write(mess(nc+1:),'(A5)')   'Entry'
        nc = nc+6
      case (col_id)
        write(mess(nc+1:),col_hformat(col_id))   'Id'  ! Right-justified
        nc = nc+col_width(col_id)+1
      case (col_parents)
        write(mess(nc+1:),'(A20)')  'Parents             '
        nc = nc+21
      case (col_children)
        write(mess(nc+1:),'(A20)')  'Children            '
        nc = nc+21
      case (col_twins)
        write(mess(nc+1:),'(A20)')  'Twins               '
        nc = nc+21
      case (col_unit)
        write(mess(nc+1:),'(A12)')  'Unit        '
        nc = nc+13
      case (col_source)
        mess(nc+1:nc+col_width(col_source)) = 'Source'
        nc = nc+col_width(col_source)+1
      case (col_ptype)
        write(mess(nc+1:),'(A13)')  'ProjType     '
        nc = nc+14
      case (col_l0)
        write(mess(nc+1:),'(A11)')  'L0         '
        nc = nc+12
      case (col_m0)
        write(mess(nc+1:),'(A11)')  'M0         '
        nc = nc+12
      case (col_pang)
        write(mess(nc+1:),'(A5)')  'ProjA'
        nc = nc+6
      case (col_lres)
        write(mess(nc+1:),'(A7)')  'SpaLInc'
        nc = nc+8
      case (col_mres)
        write(mess(nc+1:),'(A7)')  'SpaMInc'
        nc = nc+8
      case (col_line)
        mess(nc+1:nc+col_width(col_line)) = 'Line'
        nc = nc+col_width(col_line)+1
      case (col_restf)
        write(mess(nc+1:),'(A10)')  'SpeFreqVal'
        nc = nc+11
      case (col_fres)
        write(mess(nc+1:),'(A7)')  'FreqInc'
        nc = nc+8
      case (col_vsys)
        write(mess(nc+1:),'(A6)')  'VeloVa'
        nc = nc+7
      case (col_rmaj)
        write(mess(nc+1:),'(A6)')  'BeaMaj'
        nc = nc+7
      case (col_rmin)
        write(mess(nc+1:),'(A6)')  'BeaMin'
        nc = nc+7
      case (col_rang)
        write(mess(nc+1:),'(A5)')  'BeaPA'
        nc = nc+6
      case (col_observatory)
        mess(nc+1:nc+col_width(col_observatory)) = 'Observatory'
        nc = nc+col_width(col_observatory)+1
      case (col_location)
        write(mess(nc+1:),'(A30)')  'Location                      '
        nc = nc+31
      case (col_access)
        write(mess(nc+1:),'(A14)')  'Access        '
        nc = nc+15
      case (col_origin)
        write(mess(nc+1:),'(A8)')  'Origin  '
        nc = nc+9
      case (col_family)
        mess(nc+1:nc+col_width(col_family)) = 'Family'
        nc = nc+col_width(col_family)+1
      case (col_flag)
        mess(nc+1:nc+col_width(col_flag)) = 'Flag'
        nc = nc+col_width(col_flag)+1
      case (col_type)
        write(mess(nc+1:),'(A2)')  'Ty'
        nc = nc+3
      case (col_memsize)
        write(mess(nc+1:),'(A8)')  'MemSize '
        nc = nc+9
      case (col_disksize)
        write(mess(nc+1:),'(A8)')  'DiskSize'
        nc = nc+9
      case (col_datasize)
        write(mess(nc+1:),'(A8)')  'DataSize'
        nc = nc+9
      case (col_sicvar)
        write(mess(nc+1:),'(A24)')  'Variable                '
        nc = nc+25
      case (col_separ)
        write(mess(nc+1:),'(A1)')  '|'
        nc = nc+2
      case (col_history)
        write(mess(nc+1:),'(A16)')  'History         '
        nc = nc+17
      case (col_none)
        exit
      case default
        write(mess(nc+1:),'(A3)')   '???'
        nc = nc+4
      end select
    enddo
  end subroutine cubedag_list_one_custom_header
  !
  subroutine cubedag_list_one_custom_all(obj,custom,access,location,mess,error)
    use cubetools_format
    use cubedag_history
    class(cubedag_node_object_t), intent(in)    :: obj
    integer(kind=4),              intent(in)    :: custom(:)
    integer(kind=code_k),         intent(in)    :: access
    integer(kind=code_k),         intent(in)    :: location
    character(len=*),             intent(out)   :: mess
    logical,                      intent(inout) :: error
    ! Local
    integer(kind=4) :: icol,nc
    !
    mess = ''
    nc = 0
    !
    do icol=1,size(custom)
      select case (custom(icol))
      case (col_entry)
        write(mess(nc+1:),'(I5)')   obj%node%ient
        nc = nc+6
      case (col_id)
        if (obj%node%id.lt.0) then  ! Null id
          mess(nc+1:nc+col_width(col_id)) = '--------------------'
        else
          write(mess(nc+1:),col_vformat(col_id))   obj%node%id
        endif
        nc = nc+col_width(col_id)+1
      case (col_parents)
        call obj%node%parents%repr('p=',mess(nc+1:nc+20))
        nc = nc+21
      case (col_children)
        call obj%node%children%repr('c=',mess(nc+1:nc+20))
        nc = nc+21
      case (col_twins)
        call obj%node%twins%repr('t=',mess(nc+1:nc+20))
        nc = nc+21
      case (col_unit)
        write(mess(nc+1:),'(A12)')  obj%node%head%array_unit
        nc = nc+13
      case (col_source)
        write(mess(nc+1:),col_vformat(col_source))  obj%node%head%spatial_source
        nc = nc+col_width(col_source)+1
      case (col_ptype)
        write(mess(nc+1:),'(A13)')  projnam(obj%node%head%spatial_projection_code)
        nc = nc+14
      case (col_l0)
        call sexag(mess(nc+1:nc+12),obj%node%head%spatial_projection_l0,24)
        mess(nc+12:nc+12) = ''
        nc = nc+12
      case (col_m0)
        call sexag(mess(nc+1:nc+12),obj%node%head%spatial_projection_m0,360)
        mess(nc+12:nc+12) = ''
        nc = nc+12
      case (col_pang)
        write(mess(nc+1:),'(F5.1)')  obj%node%head%spatial_projection_pa*deg_per_rad
        nc = nc+6
      case (col_lres)
        write(mess(nc+1:),'(F7.2)')  obj%node%head%axset_convert  &
          (code_inc,obj%node%head%axset_ix)*sec_per_rad
        nc = nc+8
      case (col_mres)
        write(mess(nc+1:),'(F7.2)')  obj%node%head%axset_convert  &
          (code_inc,obj%node%head%axset_iy)*sec_per_rad
        nc = nc+8
      case (col_line)
        write(mess(nc+1:),col_vformat(col_line))  obj%node%head%spectral_line
        nc = nc+col_width(col_line)+1
      case (col_restf)
        write(mess(nc+1:),'(F10.3)')  obj%node%head%spectral_signal_value
        nc = nc+11
      case (col_fres)
        write(mess(nc+1:),'(F7.3)')  obj%node%head%spectral_increment_value
        nc = nc+8
      case (col_vsys)
        write(mess(nc+1:),'(F6.2)')  obj%node%head%spectral_systemic_value
        nc = nc+7
      case (col_rmaj)
        write(mess(nc+1:),'(F6.2)')  obj%node%head%spatial_beam_major*sec_per_rad
        nc = nc+7
      case (col_rmin)
        write(mess(nc+1:),'(F6.2)')  obj%node%head%spatial_beam_minor*sec_per_rad
        nc = nc+7
      case (col_rang)
        write(mess(nc+1:),'(F5.1)')  obj%node%head%spatial_beam_pa*deg_per_rad
        nc = nc+6
      case (col_observatory)
        call obj%node%head%obs%tostr(mess(nc+1:nc+col_width(col_observatory)),error)
        nc = nc+col_width(col_observatory)+1
      case (col_location)
        call obj%node%tuple%location(access,location,mess(nc+1:nc+30),error)
        if (error)  return
        nc = nc+31
      case (col_access)
        call cubedag_list_access(access,mess(nc+1:nc+14),error)
        nc = nc+15
      case (col_origin)
        call cubedag_list_origin(obj%node%origin,mess(nc+1:nc+8),error)
        nc = nc+9
      case (col_family)
        write(mess(nc+1:),col_vformat(col_family))  obj%node%family
        nc = nc+col_width(col_family)+1
      case (col_flag)
        call cubedag_flag_tostr(obj%node,strflag=mess(nc+1:nc+col_width(col_flag)),error=error)
        nc = nc+col_width(col_flag)+1
      case (col_type)
        mess(nc+1:nc+2) = obj%ltype()
        nc = nc+3
      case (col_memsize)
        mess(nc+1:nc+8) = cubetools_format_memsize(obj%memsize())
        nc = nc+9
      case (col_disksize)
        mess(nc+1:nc+8) = cubetools_format_memsize(obj%node%tuple%disksize(access,location))
        nc = nc+9
      case (col_datasize)
        mess(nc+1:nc+8) = cubetools_format_memsize(obj%datasize())
        nc = nc+9
      case (col_sicvar)
        call cubedag_sicvar_tostr(obj%node%nsicvar,obj%node%sicvar,mess(nc+1:nc+24),error)
        nc = nc+25
      case (col_separ)
        write(mess(nc+1:),'(A1)')  '|'
        nc = nc+2
      case (col_history)
        call cubedag_history_tostr(obj%node%history,mess(nc+1:nc+16),error)
        nc = nc+17
      case (col_none)
        exit
      case default
        write(mess(nc+1:),'(A3)')   '???'
        nc = nc+4
      end select
    enddo
  end subroutine cubedag_list_one_custom_all
  !
  subroutine cubedag_list_one_custom_tuple(obj,custom,access,location,mess,error)
    use cubetools_format
    !-------------------------------------------------------------------
    ! Print only tuple-related columns. Others are replaced by blanks
    !-------------------------------------------------------------------
    class(cubedag_node_object_t), intent(in)    :: obj
    integer(kind=4),              intent(in)    :: custom(:)
    integer(kind=code_k),         intent(in)    :: access
    integer(kind=code_k),         intent(in)    :: location
    character(len=*),             intent(out)   :: mess
    logical,                      intent(inout) :: error
    ! Local
    integer(kind=4) :: icol,nc
    !
    mess = ''
    nc = 0
    !
    do icol=1,size(custom)
      select case (custom(icol))
      case (col_entry)
        nc = nc+6
      case (col_id)
        nc = nc+col_width(col_id)+1
      case (col_parents)
        nc = nc+21
      case (col_children)
        nc = nc+21
      case (col_twins)
        nc = nc+21
      case (col_unit)
        nc = nc+13
      case (col_source)
        nc = nc+col_width(col_source)+1
      case (col_ptype)
        nc = nc+14
      case (col_l0)
        nc = nc+12
      case (col_m0)
        nc = nc+12
      case (col_pang)
        nc = nc+6
      case (col_lres)
        nc = nc+8
      case (col_mres)
        nc = nc+8
      case (col_line)
        nc = nc+col_width(col_line)+1
      case (col_restf)
        nc = nc+11
      case (col_fres)
        nc = nc+8
      case (col_vsys)
        nc = nc+7
      case (col_rmaj)
        nc = nc+7
      case (col_rmin)
        nc = nc+7
      case (col_rang)
        nc = nc+6
      case (col_observatory)
        nc = nc+col_width(col_observatory)+1
      case (col_location)
        call obj%node%tuple%location(access,location,mess(nc+1:nc+30),error)
        if (error)  return
        nc = nc+31
      case (col_access)
        call cubedag_list_access(access,mess(nc+1:nc+14),error)
        nc = nc+15
      case (col_origin)
        nc = nc+9
      case (col_family)
        nc = nc+col_width(col_family)+1
      case (col_flag)
        nc = nc+col_width(col_flag)+1
      case (col_type)
        nc = nc+3
      case (col_memsize,col_datasize)
        nc = nc+9
      case (col_disksize)
        mess(nc+1:nc+8) = cubetools_format_memsize(obj%node%tuple%disksize(access,location))
        nc = nc+9
      case (col_sicvar)
        nc = nc+25
      case (col_separ)
        write(mess(nc+1:),'(A1)')  '|'
        nc = nc+2
      case (col_history)
        nc = nc+17
      case (col_none)
        exit
      case default
        write(mess(nc+1:),'(A3)')   '???'
        nc = nc+4
      end select
    enddo
  end subroutine cubedag_list_one_custom_tuple
  !
  subroutine cubedag_list_access(access,straccess,error)
    !-------------------------------------------------------------------
    ! Return the list of available access modes
    !-------------------------------------------------------------------
    integer(kind=code_k), intent(in)    :: access
    character(len=*),     intent(out)   :: straccess
    logical,              intent(inout) :: error
    !
    select case (access)
    case (code_cube_speset)
      straccess = 'spectrum'
    case (code_cube_imaset)
      straccess = 'image'
    case (code_cube_unkset)
      straccess = 'unknown'
    case default
      straccess = '???'  ! Should not happen
    end select
  end subroutine cubedag_list_access
  !
  subroutine cubedag_list_origin(origin,strorigin,error)
    !-------------------------------------------------------------------
    ! Return the list of available access modes
    !-------------------------------------------------------------------
    integer(kind=code_k), intent(in)    :: origin
    character(len=*),     intent(out)   :: strorigin
    logical,              intent(inout) :: error
    !
    select case (origin)
    case (1:dag_norigins)
      strorigin = dag_origin_names(origin)
    case default
      strorigin = '???'
    end select
  end subroutine cubedag_list_origin
  !
  subroutine cubedag_list_one_print(message,olun,iline)
    !---------------------------------------------------------------------
    !  Send the message to the given Logical Unit. Quite generic, could
    ! be used in other contexts.
    !---------------------------------------------------------------------
    character(len=*), intent(in)    :: message
    integer(kind=4),  intent(in)    :: olun
    integer(kind=4),  intent(inout) :: iline  ! Current line number
    ! Local
    character(len=*), parameter :: rname='LIST'
    !
    iline = iline+1
    if (olun.eq.stdout) then
      call cubedag_message(seve%r,rname,message)
    else
      write(olun,'(A)') trim(message)
    endif
  end subroutine cubedag_list_one_print
  !
  !=======================================================================
  !
  subroutine cubedag_list_toc_comm(optx,user,olun,error)
    !---------------------------------------------------------------------
    ! Support routine for command
    !   LIST [IN|CURRENT] /TOC [Key1] ... [KeyN]  [/VARIABLE VarName]
    ! Main entry point
    !---------------------------------------------------------------------
    type(cubedag_optimize_t),  intent(in)    :: optx   !
    type(cubedag_list_user_t), intent(in)    :: user   ! User input
    integer(kind=4),           intent(in)    :: olun   !
    logical,                   intent(inout) :: error  ! Logical error flag
    ! Local
    character(len=16) :: toc_args(13)  ! Arbitrary number of args accepted in option /TOC
    !
    call cubedag_toc_init(mtoc,error)
    if (error)  return
    !
    ! Default (unchanged if no arguments)
    toc_args(:) = ' '
    toc_args(1) = 'OBSERV'
    toc_args(2) = 'SOURCE'
    toc_args(3) = 'LINE'
    call toc_getkeys(user%line,user%iopttoc,mtoc,toc_args,error)
    if (error)  return
    !
    call cubedag_list_toc(optx,toc_args,user%tocvar,olun,error)
    if (error)  return
  end subroutine cubedag_list_toc_comm
  !
  subroutine cubedag_toc_init(toc,error)
    !---------------------------------------------------------------------
    ! Support routine for command LIST /TOC
    ! Initialization routine
    !---------------------------------------------------------------------
    type(toc_t), intent(inout) :: toc    !
    logical,     intent(inout) :: error  !
    ! Local
    character(len=*), parameter :: rname='TOC>INIT'
    integer(kind=4) :: ier
    !
    if (toc%initialized)  return
    !
    toc%nkey = 6
    allocate(toc%keys(toc%nkey),stat=ier)
    if (failed_allocate(rname,'keys array',ier,error)) return
    !
    toc%keys(1)%keyword       = cubedag_list_toc_keys(1)
    toc%keys(1)%sic_var_name  = 'sour'
    toc%keys(1)%human_name    = 'SOURCE'
    toc%keys(1)%message       = 'Number of sources......'
    toc%keys(1)%ftype         = toc_ftype_c12_1d
    toc%keys(1)%ptype         = cubedag_ptype_null
    !
    toc%keys(2)%keyword       = cubedag_list_toc_keys(2)
    toc%keys(2)%sic_var_name  = 'line'
    toc%keys(2)%human_name    = 'LINE'
    toc%keys(2)%message       = 'Number of lines........'
    toc%keys(2)%ftype         = toc_ftype_c12_1d
    toc%keys(2)%ptype         = cubedag_ptype_null
    !
    toc%keys(3)%keyword       = cubedag_list_toc_keys(3)
    toc%keys(3)%sic_var_name  = 'obs'
    toc%keys(3)%human_name    = 'OBSERVATORY'
    toc%keys(3)%message       = 'Number of observatories'
    toc%keys(3)%ftype         = toc_ftype_c12_1d
    toc%keys(3)%ptype         = cubedag_ptype_null
    !
    toc%keys(4)%keyword       = cubedag_list_toc_keys(4)
    toc%keys(4)%sic_var_name  = 'origin'
    toc%keys(4)%human_name    = 'ORIGIN'
    toc%keys(4)%message       = 'Number of origins......'
    toc%keys(4)%ftype         = toc_ftype_i4_1d
    toc%keys(4)%ptype         = cubedag_ptype_origin
    !
    toc%keys(5)%keyword       = cubedag_list_toc_keys(5)
    toc%keys(5)%sic_var_name  = 'family'
    toc%keys(5)%human_name    = 'FAMILY'
    toc%keys(5)%message       = 'Number of families.....'
    toc%keys(5)%ftype         = toc_ftype_c128_1d
    toc%keys(5)%ptype         = cubedag_ptype_null
    !
    toc%keys(6)%keyword       = cubedag_list_toc_keys(6)
    toc%keys(6)%sic_var_name  = 'flag'
    toc%keys(6)%human_name    = 'FLAG'
    toc%keys(6)%message       = 'Number of flags........'
    toc%keys(6)%ftype         = toc_ftype_c128_1d
    toc%keys(6)%ptype         = cubedag_ptype_null
    !
    call toc_init_pointers(toc,error)
    if (error)  return
    !
    toc%initialized = .true.
  end subroutine cubedag_toc_init
  !
  subroutine cubedag_toc_clean(error)
    !---------------------------------------------------------------------
    ! Support routine for command MLIST /TOC
    ! Clean the global variable holding the TOC
    !---------------------------------------------------------------------
    logical, intent(inout) :: error  !
    !
    call toc_clean(mtoc,error)
    ! if (error)  continue
  end subroutine cubedag_toc_clean
  !
  subroutine cubedag_list_toc(optx,keywords,tocname,olun,error)
    !---------------------------------------------------------------------
    ! Support routine for command
    !   LIST /TOC
    ! Processing routine
    !---------------------------------------------------------------------
    type(cubedag_optimize_t), intent(in)    :: optx         ! The optx whose TOC is desired
    character(len=*),         intent(in)    :: keywords(:)  !
    character(len=*),         intent(in)    :: tocname      ! Structure name
    integer(kind=4),          intent(in)    :: olun         !
    logical,                  intent(inout) :: error        ! Logical error flag
    ! Local
    character(len=*), parameter :: rname='LIST>TOC'
    !
    call cubedag_toc_datasetup(mtoc,optx,error)
    if (error)  return
    !
    call toc_main(rname,mtoc,optx%next-1,keywords,tocname,olun,cubedag_toc_format,error)
    if (error)  return
    !
    call cubedag_toc_datafree(error)
    if (error)  return
  end subroutine cubedag_list_toc
  !
  subroutine cubedag_toc_datasetup(toc,idx,error)
    use toc_types
    use cubedag_types
    !---------------------------------------------------------------------
    ! support routine for command
    !   LIST /TOC
    ! Associate the TOC data pointers to the index whose TOC is desired
    !---------------------------------------------------------------------
    type(toc_t),              intent(inout)      :: toc
    type(cubedag_optimize_t), intent(in), target :: idx  ! The idx whose TOC is desired
    logical,                  intent(inout)      :: error
    ! Local
    character(len=*), parameter :: rname='TOC>DATASETUP'
    integer(kind=4) :: ier
    integer(kind=entr_k) :: ient
    class(cubedag_node_object_t), pointer :: obj
    !
    ! Local copy because these elements are not contiguous in memory
    allocate(toc_origin(idx%next-1),stat=ier)
    if (failed_allocate(rname,'toc_origin',ier,error)) return
    allocate(toc_family(idx%next-1),stat=ier)
    if (failed_allocate(rname,'toc_family',ier,error)) return
    allocate(toc_source(idx%next-1),stat=ier)
    if (failed_allocate(rname,'toc_source',ier,error)) return
    allocate(toc_line(idx%next-1),stat=ier)
    if (failed_allocate(rname,'toc_line',ier,error)) return
    allocate(toc_flag(idx%next-1),stat=ier)
    if (failed_allocate(rname,'toc_flag',ier,error)) return
    allocate(toc_obs(idx%next-1),stat=ier)
    if (failed_allocate(rname,'toc_obs',ier,error)) return
    do ient=1,idx%next-1
      obj => idx%object(ient)%p
      toc_origin(ient) = obj%node%origin
      toc_family(ient) = obj%node%family
      toc_source(ient) = obj%node%head%spatial_source
      toc_line(ient)   = obj%node%head%spectral_line
      call cubedag_flag_tostr(obj%node,strflag=toc_flag(ient),error=error)
      if (error)  return
      if (obj%node%head%obs%ntel.ge.1) then
        toc_obs(ient)  = obj%node%head%obs%tel(1)%name ! ZZZ Only one...
      else
        toc_obs(ient)  = strg_unk
      endif
    enddo
    !
    toc%keys(1)%ptr%c12%data1  => toc_source
    toc%keys(2)%ptr%c12%data1  => toc_line
    toc%keys(3)%ptr%c12%data1  => toc_obs
    toc%keys(4)%ptr%i4%data1   => toc_origin
    toc%keys(5)%ptr%c128%data1 => toc_family
    toc%keys(6)%ptr%c128%data1 => toc_flag
  end subroutine cubedag_toc_datasetup
  !
  subroutine cubedag_toc_datafree(error)
    !---------------------------------------------------------------------
    ! Support routine for command MLIST /TOC
    ! Clean the global variable holding the TOC
    !---------------------------------------------------------------------
    logical, intent(inout) :: error  !
    !
    if (allocated(toc_origin))  deallocate(toc_origin)
    if (allocated(toc_family))  deallocate(toc_family)
    if (allocated(toc_source))  deallocate(toc_source)
    if (allocated(toc_line))    deallocate(toc_line)
    if (allocated(toc_flag))    deallocate(toc_flag)
    if (allocated(toc_obs))     deallocate(toc_obs)
  end subroutine cubedag_toc_datafree
  !
  subroutine cubedag_toc_format(key,ival,output)
    !---------------------------------------------------------------------
    ! support routine for command
    !   LIST /TOC
    ! Custom display routine (because there are custom types)
    !---------------------------------------------------------------------
    type(toc_descriptor_t), intent(in)  :: key     !
    integer(kind=entr_k),   intent(in)  :: ival    !
    character(len=*),       intent(out) :: output  !
    !
    select case(key%ftype)
    case(toc_ftype_c12_1d) ! string*12
      output = key%ptr%c12%data1(ival)
    case(toc_ftype_c128_1d) ! string*128
      output = key%ptr%c128%data1(ival)
    case(toc_ftype_i4_1d)  ! integer*4
      if (key%ptype.eq.cubedag_ptype_origin) then
        output = dag_origin_names(key%ptr%i4%data1(ival))
      else
        write(output,'(i12)') key%ptr%i4%data1(ival)
      endif
    case default
      output = '???'
    end select
  end subroutine cubedag_toc_format
end module cubedag_list
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
