!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
module cubeedit_getheader_tool
  use cubetools_parameters
  use cubelist_types
  use cubetools_structure
  use cubetools_keywordlist_types
  use cubetuple_format_class
  use cubeedit_messaging
  use cubetools_userspace
  use cubetools_uservar
  use cubetools_userstruct
  !
  public :: getheader_comm_t,getheader_user_t,getheader_prog_t
  private
  !
  character(len=*), parameter :: axes(7) = &
       ['VELOCITY  ','FREQUENCY ','REDSHIFT  ','WAVELENGTH','IMAGEFREQ ','L         ','M         ']
  !
  integer(kind=code_k), parameter :: inoaction      = 0
  integer(kind=code_k), parameter :: iaxis          = inoaction+1
  !
  integer(kind=code_k), parameter :: ishape         = iaxis+1
  integer(kind=code_k), parameter :: iunit          = ishape+1
  integer(kind=code_k), parameter :: iextrema       = iunit+1
  integer(kind=code_k), parameter :: inoise         = iextrema+1
  !
  integer(kind=code_k), parameter :: ispatialframe  = inoise+1
  integer(kind=code_k), parameter :: isource        = ispatialframe+1
  integer(kind=code_k), parameter :: iptype         = isource+1
  integer(kind=code_k), parameter :: ipcenter       = iptype+1
  integer(kind=code_k), parameter :: ipangle        = ipcenter+1
  integer(kind=code_k), parameter :: ibeam          = ipangle+1
  !
  integer(kind=code_k), parameter :: ispectralframe = ibeam+1
  integer(kind=code_k), parameter :: ivelocity      = ispectralframe+1
  integer(kind=code_k), parameter :: iredshift      = ivelocity+1
  integer(kind=code_k), parameter :: iline          = iredshift+1
  integer(kind=code_k), parameter :: ifrequency     = iline+1
  integer(kind=code_k), parameter :: iwavelength    = ifrequency+1
  !
  integer(kind=code_k), parameter :: iobservatory   = iwavelength+1
  !
  integer(kind=code_k), parameter :: iid            = iobservatory+1
  integer(kind=code_k), parameter :: ituple         = iid+1
  integer(kind=code_k), parameter :: iparents       = ituple+1
  integer(kind=code_k), parameter :: ichildren      = iparents+1
  integer(kind=code_k), parameter :: itwins         = ichildren+1
  !
  integer(kind=code_k), parameter :: naction        = itwins
  !
  character(len=*), parameter :: options(naction) = [&
       'AXIS         ','SHAPE        ','UNIT         ','EXTREMA      ','NOISE        ',&
       'SPATIALFRAME ','SOURCE       ','PTYPE        ','PCENTER      ','PANGLE       ',&
       'BEAM         ','SPECTRALFRAME','VELOCITY     ','REDSHIFT     ','LINE         ',&
       'FREQUENCY    ','WAVELENGTH   ','OBSERVATORY  ','ID           ','TUPLE        ',&
       'PARENTS      ','CHILDREN     ','TWINS        ']
  character(len=*), parameter :: names(naction) = [&
       'Axis          ','Shape         ','Unit          ','Extrema       ','Noise         ',&
       'Spatial frame ','Source        ','Proj. Type    ','Proj. Center  ','Proj. Angle   ',&
       'Beam          ','Spectral frame','Velocity      ','Redshift      ','Line          ',&
       'Frequency     ','Wavelength    ','Observatory   ','Id            ','Tuple         ',&
       'Parents       ','Children      ','Twins         ']
  !
  type action_comm_t
     type(option_t), pointer :: p
  end type action_comm_t
  !
  type :: getheader_comm_t
     type(option_t),            pointer :: getheader
     type(action_comm_t)                :: actions(naction)
     type(keywordlist_comm_t),  pointer :: axtype
     type(keywordlist_comm_t),  pointer :: coortype
     type(userspace_opt_t),     pointer :: into
   contains
     procedure :: register => cubeedit_getheader_comm_register
     procedure :: parse    => cubeedit_getheader_comm_parse
  end type getheader_comm_t
  !
  type getheader_user_t
     type(userspace_user_t), pointer :: userspace
     character(len=argu_l)           :: axtype    ! Axis name
     character(len=argu_l)           :: coortype  ! Coordinate type
     character(len=argu_l)           :: axunit    ! Axis unit
     integer(kind=4)                 :: nact      ! Number of actions chosen by user
     logical                         :: which(naction) = .false.
     logical                         :: present = .false.
   contains
     procedure, public :: toprog => cubeedit_getheader_user_toprog
  end type getheader_user_t
  !
  type getheader_prog_t
     class(format_t),    pointer     :: cube
     class(userspace_t), allocatable :: userspace
     character(len=unit_l)           :: unit     ! axis  unit
     character(len=12)               :: axtype   ! Resolved axis name
     logical                         :: absolute ! Coordinate is absolute?
     logical                         :: issub    ! Load information on substructure
     logical                         :: which(naction) = .false.
     logical                         :: doget = .false.
   contains
     procedure :: get  => cubeedit_getheader_prog_act_get
     procedure :: list => cubeedit_getheader_prog_act_list
  end type getheader_prog_t
  !
  type, extends(userspace_t) :: getheader_buffer_t
     character(len=32) :: type
     integer(kind=4)   :: id
  end type getheader_buffer_t
  type(list_t) :: bookkeeping ! List of getheader_buffer_t
  !
contains
  !
  subroutine cubeedit_getheader_comm_register(comm,topstruct,into,error)
    !-------------------------------------------------------------------
    ! Register EDIT\HEADER and GO\LOAD header related options
    !-------------------------------------------------------------------
    class(getheader_comm_t), intent(out)   :: comm
    character(len=*),        intent(in)    :: topstruct
    type(userspace_opt_t),   target        :: into
    logical,                 intent(inout) :: error
    !
    type(standard_arg_t) :: stdarg
    type(keywordlist_comm_t) :: keyarg
    integer(kind=4) :: iwhich
    character(len=*), parameter :: coortype(2)  = ['RELATIVE','ABSOLUTE']
    character(len=*), parameter :: rname='GETHEADER>COMM>REGISTER'
    !
    call cubeedit_message(edseve%trace,rname,'Welcome')
    !
    call cubetools_register_option(&
         'AXIS','axtype relative|absolute [unit]',&
         'Define axis to be fetched from the cube',&
         strg_emp,&
         comm%actions(iaxis)%p,error)
    if (error) return
    call keyarg%register(&
         'axtype',&
         'Axis type',&
         strg_emp,&
         code_arg_mandatory,&
         axes,&
         flexible,&
         comm%axtype,&
         error)
    if (error) return
    call keyarg%register(&
         'coortype',&
         'Coordinate type, relative or absolute',&
         strg_emp,&
         code_arg_mandatory,&
         coortype,&
         .not.flexible,&
         comm%coortype,&
         error)
    if (error) return
    call stdarg%register(&
         'unit',&
         'Unit for axis',&
         'available units vary with axis type',&
         code_arg_optional,&
         error)
    if (error) return
    !
    do iwhich=ishape,naction
       call cubetools_register_option(&
            options(iwhich),'',&
            'Fetch '//trim(names(iwhich))//' of a cube into a variable',&
            'The default variable name of the /INTO key will be '//trim(topstruct)//'%'//options(iwhich),&
            comm%actions(iwhich)%p,&
            error)
       if (error) return
    enddo
    !
    comm%into => into
  end subroutine cubeedit_getheader_comm_register
  !
  subroutine cubeedit_getheader_comm_parse(comm,line,userspace,user,error)
    !-------------------------------------------------------------------
    ! Parse for the getheader keys, and return flag indicating if
    ! something relevant here is to be done
    !-------------------------------------------------------------------
    class(getheader_comm_t), intent(in)    :: comm
    character(len=*),        intent(in)    :: line
    type(userspace_user_t),  target        :: userspace
    type(getheader_user_t),  intent(out)   :: user
    logical,                 intent(inout) :: error
    !
    integer(kind=4) :: iwhich
    character(len=*), parameter :: rname='GETHEADER>COMM>PARSE'
    !
    call cubeedit_message(edseve%trace,rname,'Welcome')
    !
    call cubetools_userspace_array_update(bookkeeping,error)
    if (error) return
    !
    call cubeedit_getheader_comm_parse_axis(comm,line,user,error)
    if (error) return
    !
    do iwhich=ishape,naction
       call comm%actions(iwhich)%p%present(line,user%which(iwhich),error)
       if (error) return
    enddo
    !
    user%nact = count(user%which)
    user%present = (user%nact.gt.0)
    user%userspace => userspace
  end subroutine cubeedit_getheader_comm_parse
  !
  subroutine cubeedit_getheader_comm_parse_axis(comm,line,user,error)
    !-------------------------------------------------------------------
    ! 
    !-------------------------------------------------------------------
    class(getheader_comm_t), intent(in)    :: comm
    character(len=*),        intent(in)    :: line
    type(getheader_user_t),  intent(inout) :: user
    logical,                 intent(inout) :: error
    !
    character(len=*), parameter :: rname='GETHEADER>COMM>PARSE>AXIS'
    !
    call cubeedit_message(edseve%trace,rname,'Welcome')
    !
    call comm%actions(iaxis)%p%present(line,user%which(iaxis),error)
    if (error) return
    user%axunit = strg_equal
    if (user%which(iaxis)) then
       call cubetools_getarg(line,comm%actions(iaxis)%p,1,user%axtype,mandatory,error)
       if (error) return
       call cubetools_getarg(line,comm%actions(iaxis)%p,2,user%coortype,mandatory,error)
       if (error) return
       call cubetools_getarg(line,comm%actions(iaxis)%p,3,user%axunit,.not.mandatory,error)
       if (error) return
    endif
  end subroutine cubeedit_getheader_comm_parse_axis
  !
!!$  subroutine cubeedit_getheader_comm_main(comm,user,error)
!!$    !----------------------------------------------------------------------
!!$    !
!!$    !----------------------------------------------------------------------
!!$    class(getheader_comm_t), intent(in)    :: comm
!!$    type(getheader_user_t),  intent(inout) :: user
!!$    logical,                 intent(inout) :: error
!!$    !
!!$    type(image2image_prog_t) :: prog
!!$    character(len=*), parameter :: rname='GETHEADER>COMM>MAIN'
!!$    !
!!$    call cubeedit_message(templateseve%trace,rname,'Welcome')
!!$    !
!!$    call user%toprog(comm,prog,error)
!!$    if (error) return
!!$    call prog%header(comm,error)
!!$    if (error) return
!!$    call cubeadm_timing_prepro2process()
!!$    call prog%data(error)
!!$    if (error) return
!!$    call cubeadm_timing_process2postpro()
!!$  end subroutine cubeedit_getheader_comm_main
  !
  !----------------------------------------------------------------------
  !
  subroutine cubeedit_getheader_user_toprog(user,comm,defname,dodata,prog,error)
    use gkernel_interfaces, only: failed_allocate
    !-------------------------------------------------------------------
    ! 
    !-------------------------------------------------------------------
    class(getheader_user_t), intent(in)    :: user
    type(getheader_comm_t),  intent(in)    :: comm
    character(len=*),        intent(in)    :: defname
    logical,                 intent(in)    :: dodata
    type(getheader_prog_t),  intent(inout) :: prog
    logical,                 intent(inout) :: error
    !
    integer(kind=4) :: ikey,ier
    character(len=10) :: coortype
    logical, parameter :: local=.false., overwrite = .true. 
    type(userstruct_t), pointer :: userstruct
    character(len=*), parameter :: rname='GETHEADER>USER>TOPROG'
    !
    call cubeedit_message(edseve%trace,rname,'Welcome')
    !
    prog%doget = user%present
    !
    if (dodata) then ! If also doing data, always a member of a parent structure
       allocate(userstruct_t::prog%userspace,stat=ier)
       if (failed_allocate(rname,'userspace',ier,error)) return
       prog%issub = .true. 
    else
       if (user%nact.gt.1) then ! More than one option, main structure obligatory
          allocate(userstruct_t::prog%userspace,stat=ier)
          if (failed_allocate(rname,'userspace',ier,error)) return
          prog%issub = .true. ! Data will be split on substructures
       else ! Only one option, structure or variable depending on the case
          if (user%userspace%do) then ! User has specified a name for userspace
             prog%issub = .false. ! Data will be loaded on a single level structure
             if (user%which(iunit).or.user%which(isource) .or.& ! Single field information with a specific name
                  user%which(iptype).or.user%which(iline) .or.& ! SIC object is a variable
                  user%which(ispectralframe)) then
                allocate(uservar_t::prog%userspace,stat=ier)
                if (failed_allocate(rname,'userspace',ier,error)) return
             else ! More than one field for info, struct obligatory
                allocate(userstruct_t::prog%userspace,stat=ier)
                if (failed_allocate(rname,'userspace',ier,error)) return
             endif
          else ! information loaded as a subfield of parent structure
             prog%issub = .true.
             allocate(userstruct_t::prog%userspace,stat=ier)
             if (failed_allocate(rname,'userspace',ier,error)) return
          endif
       endif
    endif
    !
    if (user%userspace%do) then
       call comm%into%user2prog(user%userspace,prog%userspace,error)
       if (error) return
       if (prog%issub) then
          userstruct => cubetools_userstruct_ptr(prog%userspace,error)
          if (error)  return
          call userstruct%def(error)
          if (error) return
       endif
    else
       userstruct => cubetools_userstruct_ptr(prog%userspace,error)
       if (error)  return
       call userstruct%create(defname,local,overwrite_user,error)
       if (error) return
    endif                      
    !
    prog%which(:) = user%which(:)
    !
    if (prog%which(iaxis)) then
       call cubetools_keywordlist_user2prog(comm%axtype,user%axtype,ikey,prog%axtype,error)
       if (error) return
       if (prog%axtype.eq.strg_unresolved) prog%axtype = user%axtype
       call cubetools_keywordlist_user2prog(comm%coortype,user%coortype,ikey,coortype,error)
       if (error) return
       prog%absolute = coortype.eq.'ABSOLUTE'
       prog%unit = user%axunit
    endif
  end subroutine cubeedit_getheader_user_toprog
  !
  !----------------------------------------------------------------------
  !
  subroutine cubeedit_getheader_prog_act_list(prog,error)
    !-------------------------------------------------------------------
    ! 
    !-------------------------------------------------------------------
    class(getheader_prog_t), intent(in)    :: prog
    logical,                 intent(inout) :: error
    !
    integer(kind=4) :: ibuf
    class(list_object_t), pointer :: buffer
    character(len=mess_l) :: mess
    character(len=*), parameter :: rname='GETHEADER>PROG>ACT>LIST'
    !
    call cubeedit_message(edseve%trace,rname,'Welcome')
    !
    write(mess,'(a,i0)') 'Loaded header buffers: ',bookkeeping%n
    call cubeedit_message(seve%r,rname,mess)
    !
    if (bookkeeping%n.gt.0) then
       write(mess,'(4x,a,4x,a,x,a,18x,a)') '#','Id', 'Type', 'Variable'
       call cubeedit_message(seve%r,rname,mess)
       do ibuf=1,bookkeeping%n
          buffer => bookkeeping%list(ibuf)%p
          select type (buffer)
          type is (getheader_buffer_t)
            write(mess,'(2x,i3,x,i5,x,a20,2x,a)') ibuf,buffer%id,buffer%type,trim(buffer%name)
          class is (userspace_t)
            write(mess,'(2x,i3,x,a5,x,a20,2x,a)') ibuf,'TBD','TBD',trim(buffer%name)
          class default
            write(mess,'(2x,i3,x,a5,x,a20,2x,a)') ibuf,'TBD','TBD','TBD'
          end select
          call cubeedit_message(seve%r,rname,mess)
       enddo
    endif
    call cubeedit_message(seve%r,rname,'')
  end subroutine cubeedit_getheader_prog_act_list
  !
  subroutine cubeedit_getheader_prog_act_get(prog,error)
    !-------------------------------------------------------------------
    ! 
    !-------------------------------------------------------------------
    class(getheader_prog_t), intent(inout) :: prog
    logical,                 intent(inout) :: error
    !
    character(len=*), parameter :: rname='GETHEADER>PROG>ACT>GET'
    !
    call cubeedit_message(edseve%trace,rname,'Welcome')
    !
    if (.not.prog%doget) return
    !
    if (prog%which(iaxis)) then
       call cubeedit_getheader_prog_act_get_axis(prog,error)
       if (error) return
    endif
    if (prog%which(ishape)) then
       call cubeedit_getheader_prog_act_get_shape(prog,error)
       if (error) return
    endif
    if (prog%which(iunit)) then
       call cubeedit_getheader_prog_act_get_unit(prog,error)
       if (error) return  
    endif
    if (prog%which(iextrema)) then
       call cubeedit_getheader_prog_act_get_extrema(prog,error)
       if (error) return
    endif
    if (prog%which(inoise)) then
       call cubeedit_getheader_prog_act_get_noise(prog,error)
       if (error) return
    endif
    if (prog%which(ispatialframe)) then
       call cubeedit_getheader_prog_act_get_spatialframe(prog,error)
       if (error) return
    endif
    if (prog%which(isource)) then
       call cubeedit_getheader_prog_act_get_source(prog,error)
       if (error) return
    endif
    if (prog%which(iptype)) then
       call cubeedit_getheader_prog_act_get_ptype(prog,error)
       if (error) return
    endif
    if (prog%which(ipcenter)) then
       call cubeedit_getheader_prog_act_get_pcenter(prog,error)
       if (error) return
    endif
    if (prog%which(ipangle)) then
       call cubeedit_getheader_prog_act_get_pangle(prog,error)
       if (error) return
    endif
    if (prog%which(ibeam)) then
       call cubeedit_getheader_prog_act_get_beam(prog,error)
       if (error) return
    endif
    if (prog%which(ispectralframe)) then
       call cubeedit_getheader_prog_act_get_spectralframe(prog,error)
       if (error) return
    endif
    if (prog%which(ivelocity)) then
       call cubeedit_getheader_prog_act_get_velocity(prog,error)
       if (error) return
    endif
    if (prog%which(iredshift)) then
       call cubeedit_getheader_prog_act_get_redshift(prog,error)
       if (error) return
    endif
    if (prog%which(iline)) then
       call cubeedit_getheader_prog_act_get_line(prog,error)
       if (error) return
    endif
    if (prog%which(ifrequency)) then
       call cubeedit_getheader_prog_act_get_frequency(prog,error)
       if (error) return
    endif
    if (prog%which(iwavelength)) then
       call cubeedit_getheader_prog_act_get_wavelength(prog,error)
       if (error) return
    endif
    if (prog%which(iobservatory)) then
       call cubeedit_getheader_prog_act_get_observatory(prog,error)
       if (error) return
    endif
    if (prog%which(iid)) then
       call cubeedit_getheader_prog_act_get_id(prog,error)
       if (error) return
    endif
    if (prog%which(ituple)) then
       call cubeedit_getheader_prog_act_get_tuple(prog,error)
       if (error) return
    endif
    if (prog%which(iparents)) then
       call cubeedit_getheader_prog_act_get_parents(prog,error)
       if (error) return
    endif
    if (prog%which(ichildren)) then
       call cubeedit_getheader_prog_act_get_children(prog,error)
       if (error) return
    endif
    if (prog%which(itwins)) then
       call cubeedit_getheader_prog_act_get_twins(prog,error)
       if (error) return
    endif
  end subroutine cubeedit_getheader_prog_act_get
  !
  subroutine cubeedit_getheader_prog_act_get_axis(prog,error)
    use gkernel_interfaces, only: failed_allocate
    ! use cubetools_spapro_types
    ! use gkernel_types, except_this=>axis_t
    use cubetools_disambiguate
    use cubetools_unit
    use cubetools_axis_types
    !-------------------------------------------------------------------
    ! 
    !-------------------------------------------------------------------
    type(getheader_prog_t), intent(inout) :: prog
    logical,                intent(inout) :: error
    !
    type(userstruct_t) ::substruct
    logical      :: isspat, laxis
    integer(kind=4) :: naxis,jaxis,ier
    type(axis_t) :: axis
    type(unit_user_t) :: axunit
    type(userstruct_t), pointer :: userstruct
    ! type(projection_t) :: proj
    ! real(kind=coor_k), allocatable :: xin(:),xou(:),yin(:),you(:)
    character(len=unit_l), allocatable :: axnames(:)
    character(len=unit_l) :: axname
    character(len=*), parameter :: rname='GETHEADER>PROG>ACT>GET>AXIS'
    !
    call cubeedit_message(edseve%trace,rname,'Welcome')
    !
    select case(prog%axtype)
    case('VELOCITY')
       call cubetools_axis_copy(prog%cube%head%spe%v,axis,error)
       if (error) return
       isspat = .false.
    case('FREQUENCY')
       call cubetools_axis_copy(prog%cube%head%spe%f,axis,error)
       if (error) return
       isspat = .false.
    case('REDSHIFT')
       call cubetools_axis_copy(prog%cube%head%spe%z,axis,error)
       if (error) return
       isspat = .false.
    case('WAVELENGTH')
       call cubetools_axis_copy(prog%cube%head%spe%l,axis,error)
       if (error) return
       isspat = .false.
    case('IMAGEFREQ')
       call cubetools_axis_copy(prog%cube%head%spe%i,axis,error)
       if (error) return
       isspat = .false.
    case('L')
       call cubetools_axis_copy(prog%cube%head%spa%l,axis,error)
       if (error) return
       isspat = .true.
       laxis  = .true.
    case('M')
       call cubetools_axis_copy(prog%cube%head%spa%m,axis,error)
       if (error) return
       isspat = .true.
       laxis =  .false.
    case default ! Search in axset
       naxis = prog%cube%head%set%n
       allocate(axnames(naxis),stat=ier)
       if (failed_allocate(rname,'axnames',ier,error)) return
       do jaxis=1,naxis
          axnames(jaxis) = prog%cube%head%set%axis(jaxis)%name
       enddo ! iaxis
       call cubetools_disambiguate_flexible(prog%axtype,axnames,jaxis,axname,error)
       if (error) return
       if (axname.eq.strg_unresolved) then
          call cubeedit_message(seve%e,rname,'Axis '//trim(prog%axtype)//' not found in cube')
          error = .true.
          return
       else
          call cubetools_axis_copy(prog%cube%head%set%axis(jaxis),axis,error)
          if (error) return
          isspat = .false.
       endif
    end select
    !
    if (isspat) then
       if (prog%absolute) then
          call cubeedit_message(seve%e,rname,'Not yet implemented')
          error = .true.
          return
          ! Complicated
          ! call axunit%get(prog%unit,code_unit_pang,error)
          ! if (error) return
          ! call transformation_magic
          !    call prog%cube%head%spa%pro%gwcs(proj,error)
          !    if (error) return
          !    allocate(xin(axis%n),xou(axis%n),yin(axis%n),you(axis%n),stat=ier)
          !    if (failed_allocate(rname,'work arrays',ier,error)) return
          !    if (laxis) then
          !       xin(:) = axis%coord(:)
          !       yin(:) = 0d0
          !    else
          !       xin(:) = 0d0
          !       yin(:) = axis%coord(:)
          !    endif
          !    call rel_to_abs_1dn4(proj,xin,yin,xou,you,int(axis%n,4))
          !    if (laxis) then
          !       axis%coord(:) = xou(:)
          !    else
          !       axis%coord(:) = you(:)
          !    endif
          !    axis%coord(:) = axis%coord(:)*axunit%user_per_prog
          !    axis%val = L0*axunit%user_per_prog ! L0 or M0
          !    axis%inc = NaN
          !    axis%regulier = .false.
       else
          call axunit%get_from_name_for_code(prog%unit,axis%kind,error)
          if (error) return
          axis%coord(:) = (axis%coord(:)-axis%val)*axunit%user_per_prog
          axis%val = axis%val*axunit%user_per_prog
          axis%inc = axis%inc*axunit%user_per_prog
          axis%unit = axunit%name
       endif
    else
       call axunit%get_from_name_for_code(prog%unit,axis%kind,error)
       if (error) return
       if (prog%absolute) then
          axis%coord(:) = axis%coord(:)*axunit%user_per_prog
       else
          axis%coord(:) = (axis%coord(:)-axis%val)*axunit%user_per_prog
       endif
       axis%val  = axis%val*axunit%user_per_prog
       axis%inc  = axis%inc*axunit%user_per_prog
       axis%unit = axunit%name
    endif
    !
    userstruct => cubetools_userstruct_ptr(prog%userspace,error)
    if (error)  return
    if (prog%issub) then
       call userstruct%def_substruct(trim(prog%axtype)//'_'//options(iaxis),substruct,error)
       if (error) return
       call cubetools_axis_axis2userstruct(axis,substruct,error)
       if (error) return
       call cubeedit_getheader_newbuffer(prog%cube%node%id,trim(prog%axtype)//' axis',substruct,error)
       if (error) return
    else
       call cubetools_axis_axis2userstruct(axis,userstruct,error)
       if (error) return
       call cubeedit_getheader_newbuffer(prog%cube%node%id,trim(prog%axtype)//' axis',prog%userspace,error)
       if (error) return
    endif
  end subroutine cubeedit_getheader_prog_act_get_axis
  !
  subroutine cubeedit_getheader_prog_act_get_shape(prog,error)
    use cubetools_shape_types
    use cubetools_header_methods
    !-------------------------------------------------------------------
    ! 
    !-------------------------------------------------------------------
    type(getheader_prog_t), intent(inout) :: prog
    logical,                intent(inout) :: error
    !
    type(shape_t) :: n
    type(userstruct_t) ::substruct
    type(userstruct_t), pointer :: userstruct
    character(len=*), parameter :: rname='GETHEADER>PROG>ACT>GET>SHAPE'
    !
    call cubeedit_message(edseve%trace,rname,'Welcome')
    !
    call cubetools_header_get_array_shape(prog%cube%head,n,error)
    if (error) return
    userstruct => cubetools_userstruct_ptr(prog%userspace,error)
    if (error)  return
    if (prog%issub) then
       call userstruct%def_substruct(options(ishape),substruct,error)
       if (error) return
       call cubetools_shape_shape2userstruct(n,substruct,error)
       if (error) return
       call cubeedit_getheader_newbuffer(prog%cube%node%id,options(ishape),substruct,error)
       if (error) return
    else
       call cubetools_shape_shape2userstruct(n,userstruct,error)
       if (error) return
       call cubeedit_getheader_newbuffer(prog%cube%node%id,options(ishape),prog%userspace,error)
       if (error) return
    endif
  end subroutine cubeedit_getheader_prog_act_get_shape
  !
  subroutine cubeedit_getheader_prog_act_get_extrema(prog,error)
    use cubetools_header_array_types
    !-------------------------------------------------------------------
    ! 
    !-------------------------------------------------------------------
    type(getheader_prog_t), intent(inout) :: prog
    logical,                intent(inout) :: error
    !
    type(userstruct_t) ::substruct
    type(userstruct_t), pointer :: userstruct
    character(len=*), parameter :: rname='GETHEADER>PROG>ACT>GET>EXTREMA'
    !
    call cubeedit_message(edseve%trace,rname,'Welcome')
    !
    userstruct => cubetools_userstruct_ptr(prog%userspace,error)
    if (error)  return
    if (prog%issub) then
       call userstruct%def_substruct(options(iextrema),substruct,error)
       if (error) return
       call cubetools_array_extrema2userstruct(prog%cube%head%arr,substruct,error)
       if (error) return
       call cubeedit_getheader_newbuffer(prog%cube%node%id,options(iextrema),substruct,error)
       if (error) return
    else
       call cubetools_array_extrema2userstruct(prog%cube%head%arr,userstruct,error)
       if (error) return
       call cubeedit_getheader_newbuffer(prog%cube%node%id,options(iextrema),prog%userspace,error)
       if (error) return
    endif
  end subroutine cubeedit_getheader_prog_act_get_extrema
  !
  subroutine cubeedit_getheader_prog_act_get_unit(prog,error)
    use cubetools_header_array_types
    !-------------------------------------------------------------------
    ! 
    !-------------------------------------------------------------------
    type(getheader_prog_t), intent(inout) :: prog
    logical,                intent(inout) :: error
    !
    type(uservar_t) :: membervar
    type(userstruct_t), pointer :: userstruct
    type(uservar_t), pointer :: uservar
    character(len=*), parameter :: rname='GETHEADER>PROG>ACT>GET>UNIT'
    !
    call cubeedit_message(edseve%trace,rname,'Welcome')
    !
    if (prog%issub) then
       userstruct => cubetools_userstruct_ptr(prog%userspace,error)
       if (error)  return
       call userstruct%create_member(options(iunit),membervar,error)
       if (error) return
       call cubetools_array_unit2uservar(prog%cube%head%arr,membervar,error)
       if (error) return
       call cubeedit_getheader_newbuffer(prog%cube%node%id,options(iunit),membervar,error)
       if (error) return
    else
       uservar => cubetools_uservar_ptr(prog%userspace,error)
       if (error)  return
       call cubetools_array_unit2uservar(prog%cube%head%arr,uservar,error)
       if (error) return
       call cubeedit_getheader_newbuffer(prog%cube%node%id,options(iunit),prog%userspace,error)
       if (error) return
    endif
  end subroutine cubeedit_getheader_prog_act_get_unit
  !
  subroutine cubeedit_getheader_prog_act_get_noise(prog,error)
    use cubetools_noise_types
    !-------------------------------------------------------------------
    !
    !-------------------------------------------------------------------
    type(getheader_prog_t), intent(inout) :: prog
    logical,                intent(inout) :: error
    !
    type(userstruct_t) :: substruct
    type(userstruct_t), pointer :: userstruct
    character(len=*), parameter :: rname='GETHEADER>PROG>ACT>GET>NOISE'
    !
    call cubeedit_message(edseve%trace,rname,'Welcome')
    !
    userstruct => cubetools_userstruct_ptr(prog%userspace,error)
    if (error)  return
    if (prog%issub) then
       call userstruct%def_substruct(options(inoise),substruct,error)
       if (error) return
       call cubetools_array_noise2userstruct(prog%cube%head%arr%noi,substruct,error)
       if (error) return
       call cubeedit_getheader_newbuffer(prog%cube%node%id,options(inoise),substruct,error)
       if (error) return
    else
       call cubetools_array_noise2userstruct(prog%cube%head%arr%noi,userstruct,error)
       if (error) return
       call cubeedit_getheader_newbuffer(prog%cube%node%id,options(inoise),prog%userspace,error)
       if (error) return
    endif
  end subroutine cubeedit_getheader_prog_act_get_noise
  !
  subroutine cubeedit_getheader_prog_act_get_spatialframe(prog,error)
    use cubetools_spafra_types
    !-------------------------------------------------------------------
    ! 
    !-------------------------------------------------------------------
    type(getheader_prog_t), intent(inout) :: prog
    logical,                intent(inout) :: error
    !
    type(userstruct_t) :: substruct
    type(userstruct_t), pointer :: userstruct
    character(len=*), parameter :: rname='GETHEADER>PROG>ACT>GET>SPATIAL'
    !
    call cubeedit_message(edseve%trace,rname,'Welcome')
    !
    userstruct => cubetools_userstruct_ptr(prog%userspace,error)
    if (error)  return
    if (prog%issub) then
       call userstruct%def_substruct(options(ispatialframe),substruct,error)
       if (error) return
       call cubetoools_spafra_spafra2userstruct(prog%cube%head%spa%fra,substruct,error)
       if (error) return
       call cubeedit_getheader_newbuffer(prog%cube%node%id,options(ispatialframe),substruct,error)
       if (error) return
    else
       call cubetoools_spafra_spafra2userstruct(prog%cube%head%spa%fra,userstruct,error)
       if (error) return
       call cubeedit_getheader_newbuffer(prog%cube%node%id,options(ispatialframe),prog%userspace,error)
       if (error) return
    endif
  end subroutine cubeedit_getheader_prog_act_get_spatialframe
  !
  subroutine cubeedit_getheader_prog_act_get_source(prog,error)
    use cubetools_spatial_types
    !-------------------------------------------------------------------
    ! 
    !-------------------------------------------------------------------
    type(getheader_prog_t), intent(inout) :: prog
    logical,                intent(inout) :: error
    !
    type(uservar_t) :: membervar
    type(userstruct_t), pointer :: userstruct
    type(uservar_t), pointer :: uservar
    character(len=*), parameter :: rname='GETHEADER>PROG>ACT>GET>SOURCE'
    !
    call cubeedit_message(edseve%trace,rname,'Welcome')
    !
    if (prog%issub) then
       userstruct => cubetools_userstruct_ptr(prog%userspace,error)
       if (error)  return
       call userstruct%create_member(options(isource),membervar,error)
       if (error) return
       call cubetools_spatial_source2uservar(prog%cube%head%spa,membervar,error)
       if (error) return
       call cubeedit_getheader_newbuffer(prog%cube%node%id,options(isource),membervar,error)
       if (error) return
    else
       uservar => cubetools_uservar_ptr(prog%userspace,error)
       if (error)  return
       call cubetools_spatial_source2uservar(prog%cube%head%spa,uservar,error)
       if (error) return
       call cubeedit_getheader_newbuffer(prog%cube%node%id,options(isource),prog%userspace,error)
       if (error) return
    endif
  end subroutine cubeedit_getheader_prog_act_get_source
  !
  subroutine cubeedit_getheader_prog_act_get_ptype(prog,error)
    use cubetools_spapro_types
    !-------------------------------------------------------------------
    ! 
    !-------------------------------------------------------------------
    type(getheader_prog_t), intent(inout) :: prog
    logical,                intent(inout) :: error
    !
    type(uservar_t) :: membervar
    type(userstruct_t), pointer :: userstruct
    type(uservar_t), pointer :: uservar
    character(len=*), parameter :: rname='GETHEADER>PROG>ACT>GET>PTYPE'
    !
    call cubeedit_message(edseve%trace,rname,'Welcome')
    !
    if (prog%issub) then
       userstruct => cubetools_userstruct_ptr(prog%userspace,error)
       if (error)  return
       call userstruct%create_member(options(iptype),membervar,error)
       if (error) return
       call cubetools_spapro_type2uservar(prog%cube%head%spa%pro,membervar,error)
       if (error) return
       call cubeedit_getheader_newbuffer(prog%cube%node%id,options(iptype),membervar,error)
       if (error) return
    else
       uservar => cubetools_uservar_ptr(prog%userspace,error)
       if (error)  return
       call cubetools_spapro_type2uservar(prog%cube%head%spa%pro,uservar,error)
       if (error) return
       call cubeedit_getheader_newbuffer(prog%cube%node%id,options(iptype),prog%userspace,error)
       if (error) return
    endif
  end subroutine cubeedit_getheader_prog_act_get_ptype
  !
  subroutine cubeedit_getheader_prog_act_get_pcenter(prog,error)
    use cubetools_spapro_types
    !-------------------------------------------------------------------
    ! 
    !-------------------------------------------------------------------
    type(getheader_prog_t), intent(inout) :: prog
    logical,                intent(inout) :: error
    !
    type(userstruct_t) ::substruct
    type(userstruct_t), pointer :: userstruct
    character(len=*), parameter :: rname='GETHEADER>PROG>ACT>GET>PCENTER'
    !
    call cubeedit_message(edseve%trace,rname,'Welcome')
    !
    userstruct => cubetools_userstruct_ptr(prog%userspace,error)
    if (error)  return
    if (prog%issub) then
       call userstruct%def_substruct(options(ipcenter),substruct,error)
       if (error) return
       call cubetools_spapro_center2userstruct(prog%cube%head%spa%fra,prog%cube%head%spa%pro,&
         substruct,error)
       if (error) return
       call cubeedit_getheader_newbuffer(prog%cube%node%id,options(ipcenter),substruct,error)
       if (error) return
    else
       call cubetools_spapro_center2userstruct(prog%cube%head%spa%fra,prog%cube%head%spa%pro,&
            userstruct,error)
       if (error) return
       call cubeedit_getheader_newbuffer(prog%cube%node%id,options(ipcenter),prog%userspace,error)
       if (error) return
    endif
  end subroutine cubeedit_getheader_prog_act_get_pcenter
  !
  subroutine cubeedit_getheader_prog_act_get_pangle(prog,error)
    use cubetools_spapro_types
    !-------------------------------------------------------------------
    ! 
    !-------------------------------------------------------------------
    type(getheader_prog_t), intent(inout) :: prog
    logical,                intent(inout) :: error
    !
    type(userstruct_t) ::substruct
    type(userstruct_t), pointer :: userstruct
    character(len=*), parameter :: rname='GETHEADER>PROG>ACT>GET>PANGLE'
    !
    call cubeedit_message(edseve%trace,rname,'Welcome')
    !
    userstruct => cubetools_userstruct_ptr(prog%userspace,error)
    if (error)  return
    if (prog%issub) then
       call userstruct%def_substruct(options(ipangle),substruct,error)
       if (error) return
       call cubetools_spapro_angle2userstruct(prog%cube%head%spa%pro,substruct,error)
       if (error) return
       call cubeedit_getheader_newbuffer(prog%cube%node%id,options(ipangle),substruct,error)
       if (error) return
    else
       call cubetools_spapro_angle2userstruct(prog%cube%head%spa%pro,userstruct,error)
       if (error) return
       call cubeedit_getheader_newbuffer(prog%cube%node%id,options(ipangle),prog%userspace,error)
       if (error) return
    endif
  end subroutine cubeedit_getheader_prog_act_get_pangle
  !
  subroutine cubeedit_getheader_prog_act_get_beam(prog,error)
    use cubetools_beam_types
    use cubetools_header_methods
    !-------------------------------------------------------------------
    ! 
    !-------------------------------------------------------------------
    type(getheader_prog_t), intent(inout) :: prog
    logical,                intent(inout) :: error
    !
    type(userstruct_t) ::substruct
    type(userstruct_t), pointer :: userstruct
    type(beam_t) :: beam
    character(len=*), parameter :: rname='GETHEADER>PROG>ACT>GET>BEAM'
    !
    call cubeedit_message(edseve%trace,rname,'Welcome')
    !
    call cubetools_header_get_spabeam(prog%cube%head,beam,error)
    if (error) return
    userstruct => cubetools_userstruct_ptr(prog%userspace,error)
    if (error)  return
    if (prog%issub) then
       call userstruct%def_substruct(options(ibeam),substruct,error)
       if (error) return
       call cubetools_beam_beam2userstruct(beam,substruct,error)
       if (error) return
       call cubeedit_getheader_newbuffer(prog%cube%node%id,options(ibeam),substruct,error)
       if (error) return
    else
       call cubetools_beam_beam2userstruct(beam,userstruct,error)
       if (error) return
       call cubeedit_getheader_newbuffer(prog%cube%node%id,options(ibeam),prog%userspace,error)
       if (error) return
    endif
  end subroutine cubeedit_getheader_prog_act_get_beam
  !
  subroutine cubeedit_getheader_prog_act_get_spectralframe(prog,error)
    !-------------------------------------------------------------------
    ! 
    !-------------------------------------------------------------------
    type(getheader_prog_t), intent(inout) :: prog
    logical,                intent(inout) :: error
    !
    type(uservar_t) :: membervar
    type(userstruct_t), pointer :: userstruct
    type(uservar_t), pointer :: uservar
    character(len=*), parameter :: rname='GETHEADER>PROG>ACT>GET>SPECTRALFRAME'
    !
    call cubeedit_message(edseve%trace,rname,'Welcome')
    !
    if (prog%issub) then
       userstruct => cubetools_userstruct_ptr(prog%userspace,error)
       if (error)  return
       call userstruct%create_member(options(ispectralframe),membervar,error)
       if (error) return
       call prog%cube%head%spe%load_frame_into(membervar,error)
       if (error) return
       call cubeedit_getheader_newbuffer(prog%cube%node%id,options(ispectralframe),membervar,error)
       if (error) return
    else
       uservar => cubetools_uservar_ptr(prog%userspace,error)
       if (error)  return
       call prog%cube%head%spe%load_frame_into(uservar,error)
       if (error) return
       call cubeedit_getheader_newbuffer(prog%cube%node%id,options(ispectralframe),prog%userspace,error)
       if (error) return
    endif
  end subroutine cubeedit_getheader_prog_act_get_spectralframe
  !
  subroutine cubeedit_getheader_prog_act_get_velocity(prog,error)
    !-------------------------------------------------------------------
    ! 
    !-------------------------------------------------------------------
    type(getheader_prog_t), intent(inout) :: prog
    logical,                intent(inout) :: error
    !
    type(userstruct_t) :: substruct
    type(userstruct_t), pointer :: userstruct
    character(len=*), parameter :: rname='GETHEADER>PROG>ACT>GET>VELOCITY'
    !
    call cubeedit_message(edseve%trace,rname,'Welcome')
    !
    userstruct => cubetools_userstruct_ptr(prog%userspace,error)
    if (error)  return
    if (prog%issub) then
       call userstruct%def_substruct(options(ivelocity),substruct,error)
       if (error) return
       call prog%cube%head%spe%load_velocity_into(substruct,error)
       if (error) return
       call cubeedit_getheader_newbuffer(prog%cube%node%id,options(ivelocity),substruct,error)
       if (error) return
    else
       call prog%cube%head%spe%load_velocity_into(userstruct,error)
       if (error) return
       call cubeedit_getheader_newbuffer(prog%cube%node%id,options(ivelocity),prog%userspace,error)
       if (error) return
    endif
  end subroutine cubeedit_getheader_prog_act_get_velocity
  !
  subroutine cubeedit_getheader_prog_act_get_redshift(prog,error)
    !-------------------------------------------------------------------
    ! 
    !-------------------------------------------------------------------
    type(getheader_prog_t), intent(inout) :: prog
    logical,                intent(inout) :: error
    !
    type(userstruct_t) :: substruct
    type(userstruct_t), pointer :: userstruct
    character(len=*), parameter :: rname='GETHEADER>PROG>ACT>GET>REDSHIFT'
    !
    call cubeedit_message(edseve%trace,rname,'Welcome')
    !
    userstruct => cubetools_userstruct_ptr(prog%userspace,error)
    if (error)  return
    if (prog%issub) then
       call userstruct%def_substruct(options(iredshift),substruct,error)
       if (error) return
       call prog%cube%head%spe%load_redshift_into(substruct,error)
       if (error) return
       call cubeedit_getheader_newbuffer(prog%cube%node%id,options(iredshift),substruct,error)
       if (error) return
    else
       call prog%cube%head%spe%load_redshift_into(userstruct,error)
       if (error) return
       call cubeedit_getheader_newbuffer(prog%cube%node%id,options(iredshift),prog%userspace,error)
       if (error) return
    endif
  end subroutine cubeedit_getheader_prog_act_get_redshift
  !
  subroutine cubeedit_getheader_prog_act_get_line(prog,error)
    !-------------------------------------------------------------------
    ! 
    !-------------------------------------------------------------------
    type(getheader_prog_t), intent(inout) :: prog
    logical,                intent(inout) :: error
    !
    type(uservar_t) :: membervar
    type(userstruct_t), pointer :: userstruct
    type(uservar_t), pointer :: uservar
    character(len=*), parameter :: rname='GETHEADER>PROG>ACT>GET>LINE'
    !
    call cubeedit_message(edseve%trace,rname,'Welcome')
    !
    if (prog%issub) then
       userstruct => cubetools_userstruct_ptr(prog%userspace,error)
       if (error)  return
       call userstruct%create_member(options(iline),membervar,error)
       if (error) return
       call prog%cube%head%spe%load_line_into(membervar,error)
       if (error) return
       call cubeedit_getheader_newbuffer(prog%cube%node%id,options(iline),membervar,error)
       if (error) return
    else
       uservar => cubetools_uservar_ptr(prog%userspace,error)
       if (error)  return
       call prog%cube%head%spe%load_line_into(uservar,error)
       if (error) return
       call cubeedit_getheader_newbuffer(prog%cube%node%id,options(iline),prog%userspace,error)
       if (error) return
    endif
  end subroutine cubeedit_getheader_prog_act_get_line
  !
  subroutine cubeedit_getheader_prog_act_get_frequency(prog,error)
    !-------------------------------------------------------------------
    ! 
    !-------------------------------------------------------------------
    type(getheader_prog_t), intent(inout) :: prog
    logical,                intent(inout) :: error
    !
    type(userstruct_t) :: substruct
    type(userstruct_t), pointer :: userstruct
    character(len=*), parameter :: rname='GETHEADER>PROG>ACT>GET>FREQUENCY'
    !
    call cubeedit_message(edseve%trace,rname,'Welcome')
    !
    userstruct => cubetools_userstruct_ptr(prog%userspace,error)
    if (error)  return
    if (prog%issub) then
       call userstruct%def_substruct(options(ifrequency),substruct,error)
       if (error) return
       call prog%cube%head%spe%load_frequency_into(substruct,error)
       if (error) return
       call cubeedit_getheader_newbuffer(prog%cube%node%id,options(ifrequency),substruct,error)
       if (error) return
    else
       call prog%cube%head%spe%load_frequency_into(userstruct,error)
       if (error) return
       call cubeedit_getheader_newbuffer(prog%cube%node%id,options(ifrequency),prog%userspace,error)
       if (error) return
    endif
  end subroutine cubeedit_getheader_prog_act_get_frequency
  !
  subroutine cubeedit_getheader_prog_act_get_wavelength(prog,error)
    !-------------------------------------------------------------------
    ! 
    !-------------------------------------------------------------------
    type(getheader_prog_t), intent(inout) :: prog
    logical,                intent(inout) :: error
    !
    type(userstruct_t) :: substruct
    type(userstruct_t), pointer :: userstruct
    character(len=*), parameter :: rname='GETHEADER>PROG>ACT>GET>WAVELENGTH'
    !
    call cubeedit_message(edseve%trace,rname,'Welcome')
    !
    userstruct => cubetools_userstruct_ptr(prog%userspace,error)
    if (error)  return
    if (prog%issub) then
       call userstruct%def_substruct(options(iwavelength),substruct,error)
       if (error) return
       call prog%cube%head%spe%load_wavelength_into(substruct,error)
       if (error) return
       call cubeedit_getheader_newbuffer(prog%cube%node%id,options(iwavelength),substruct,error)
       if (error) return
    else
       call prog%cube%head%spe%load_wavelength_into(userstruct,error)
       if (error) return
       call cubeedit_getheader_newbuffer(prog%cube%node%id,options(iwavelength),prog%userspace,error)
       if (error) return
    endif
  end subroutine cubeedit_getheader_prog_act_get_wavelength
  !
  subroutine cubeedit_getheader_prog_act_get_observatory(prog,error)
    use cubetools_observatory_types
    !-------------------------------------------------------------------
    ! 
    !-------------------------------------------------------------------
    type(getheader_prog_t), intent(inout) :: prog
    logical,                intent(inout) :: error
    !
    type(userstruct_t) :: substruct
    type(userstruct_t), pointer :: userstruct
    character(len=*), parameter :: rname='GETHEADER>PROG>ACT>GET>OBSERVATORY'
    !
    call cubeedit_message(edseve%trace,rname,'Welcome')
    !
    userstruct => cubetools_userstruct_ptr(prog%userspace,error)
    if (error)  return
    if (prog%issub) then
       call userstruct%def_substruct(options(iobservatory),substruct,error)
       if (error) return
       call cubetools_observatory_obs2userstruct(prog%cube%head%obs,substruct,error)
       if (error) return
       call cubeedit_getheader_newbuffer(prog%cube%node%id,options(iobservatory),substruct,error)
       if (error) return
    else
       call cubetools_observatory_obs2userstruct(prog%cube%head%obs,userstruct,error)
       if (error) return
       call cubeedit_getheader_newbuffer(prog%cube%node%id,options(iobservatory),prog%userspace,error)
       if (error) return
    endif
  end subroutine cubeedit_getheader_prog_act_get_observatory
  !
  !------------------------------------------------------------------------
  !
  subroutine cubeedit_getheader_prog_act_get_id(prog,error)
    !-------------------------------------------------------------------
    !
    !-------------------------------------------------------------------
    type(getheader_prog_t), intent(inout) :: prog
    logical,                intent(inout) :: error
    !
    type(userstruct_t) :: substruct
    type(userstruct_t), pointer :: userstruct
    character(len=*), parameter :: rname='GETHEADER>PROG>ACT>GET>ID'
    !
    call cubeedit_message(edseve%trace,rname,'Welcome')
    !
    if (prog%issub) then
       userstruct => cubetools_userstruct_ptr(prog%userspace,error)
       if (error)  return
       call userstruct%def_substruct(options(iid),substruct,error)
       if (error) return
       call id_to_struct(prog%cube,substruct,error)
       if (error) return
       call cubeedit_getheader_newbuffer(prog%cube%node%id,options(iid),substruct,error)
       if (error) return
    else
       call id_to_struct(prog%cube,prog%userspace,error)
       if (error) return
       call cubeedit_getheader_newbuffer(prog%cube%node%id,options(iid),prog%userspace,error)
       if (error) return
    endif
  contains
    subroutine id_to_struct(cube,userspace,error)
!      use gkernel_interfaces
      use cubetools_flag_types
      !----------------------------------------------------------------------
      !
      !----------------------------------------------------------------------
      class(format_t),    intent(in)    :: cube
      class(userspace_t), intent(inout) :: userspace
      logical,            intent(inout) :: error
      !
      integer(kind=4) :: nc
      character(len=dag_flagl), allocatable :: flags(:)
      character(len=argu_l) :: concatenated
      type(userstruct_t), pointer :: struct
      character(len=*), parameter :: rname='GETHEADER>ID>TOSTRUCT'
      !
      call cubeedit_message(edseve%trace,rname,'Welcome')
      !
      struct => cubetools_userstruct_ptr(userspace,error)
      if (error)  return
      call struct%def(error)
      if (error) return
      !
      call struct%set_member('id',cube%node%id,error)
      if (error) return
      call struct%set_member('family',cube%node%family,error)
      if (error) return
      call struct%set_member('nflag',cube%node%flag%n,error)
      if (error) return
      !
      call cube%node%flag%export(flags,error)
      if (error)  return
      call struct%set_member('flags',flags,error)
      if (error) return
      !
      call cube%node%flag%repr(strflag=concatenated,lstrflag=nc,error=error)
      if (error)  return
      if (concatenated(nc-1:nc).eq.'..') then
        call cubeedit_message(seve%w,rname,&
          trim(struct%name)//'%FLAGSTRING variable truncated')
      endif
      call struct%set_member('flagstring',concatenated,error)
      if (error) return
    end subroutine id_to_struct
  end subroutine cubeedit_getheader_prog_act_get_id
  !
  subroutine cubeedit_getheader_prog_act_get_tuple(prog,error)
    !-------------------------------------------------------------------
    !
    !-------------------------------------------------------------------
    type(getheader_prog_t), intent(inout) :: prog
    logical,                intent(inout) :: error
    !
    type(userstruct_t) :: substruct
    type(userstruct_t), pointer :: userstruct
    character(len=*), parameter :: rname='GETHEADER>PROG>ACT>GET>TUPLE'
    !
    call cubeedit_message(edseve%trace,rname,'Welcome')
    !
    if (prog%issub) then
       userstruct => cubetools_userstruct_ptr(prog%userspace,error)
       if (error)  return
       call userstruct%def_substruct(options(ituple),substruct,error)
       if (error) return
       call prog%cube%node%tuple%to_struct(substruct,error)
       if (error) return
       call cubeedit_getheader_newbuffer(prog%cube%node%id,options(ituple),substruct,error)
       if (error) return
    else
       call prog%cube%node%tuple%to_struct(prog%userspace,error)
       if (error) return
       call cubeedit_getheader_newbuffer(prog%cube%node%id,options(ituple),prog%userspace,error)
       if (error) return
    endif
  end subroutine cubeedit_getheader_prog_act_get_tuple
  !
  subroutine cubeedit_getheader_prog_act_get_parents(prog,error)
    !-------------------------------------------------------------------
    !
    !-------------------------------------------------------------------
    type(getheader_prog_t), intent(inout) :: prog
    logical,                intent(inout) :: error
    !
    call cubeedit_getheader_prog_act_get_links(prog,options(iparents),&
      prog%cube%node%links%parents,error)
    if (error)  return
  end subroutine cubeedit_getheader_prog_act_get_parents
  !
  subroutine cubeedit_getheader_prog_act_get_children(prog,error)
    !-------------------------------------------------------------------
    !
    !-------------------------------------------------------------------
    type(getheader_prog_t), intent(inout) :: prog
    logical,                intent(inout) :: error
    !
    call cubeedit_getheader_prog_act_get_links(prog,options(ichildren),&
      prog%cube%node%links%children,error)
    if (error)  return
  end subroutine cubeedit_getheader_prog_act_get_children
  !
  subroutine cubeedit_getheader_prog_act_get_twins(prog,error)
    !-------------------------------------------------------------------
    !
    !-------------------------------------------------------------------
    type(getheader_prog_t), intent(inout) :: prog
    logical,                intent(inout) :: error
    !
    call cubeedit_getheader_prog_act_get_links(prog,options(itwins),&
      prog%cube%node%links%twins,error)
    if (error)  return
  end subroutine cubeedit_getheader_prog_act_get_twins
  !
  subroutine cubeedit_getheader_prog_act_get_links(prog,optname,link,error)
    use cubedag_link_type
    !-------------------------------------------------------------------
    ! Generic for
    !   cubeedit_getheader_prog_act_get_parents
    !   cubeedit_getheader_prog_act_get_children
    !   cubeedit_getheader_prog_act_get_twins
    !-------------------------------------------------------------------
    type(getheader_prog_t), intent(inout) :: prog
    character(len=*),       intent(in)    :: optname
    type(cubedag_link_t),   intent(in)    :: link
    logical,                intent(inout) :: error
    !
    type(userstruct_t) :: substruct
    type(userstruct_t), pointer :: userstruct
    character(len=*), parameter :: rname='GETHEADER>PROG>ACT>GET>LINKS'
    !
    call cubeedit_message(edseve%trace,rname,'Welcome')
    !
    if (prog%issub) then
       userstruct => cubetools_userstruct_ptr(prog%userspace,error)
       if (error)  return
       call userstruct%def_substruct(optname,substruct,error)
       if (error) return
       call link_to_struct(link,substruct,error)
       if (error) return
       call cubeedit_getheader_newbuffer(prog%cube%node%id,optname,substruct,error)
       if (error) return
    else
       call link_to_struct(link,prog%userspace,error)
       if (error) return
       call cubeedit_getheader_newbuffer(prog%cube%node%id,optname,prog%userspace,error)
       if (error) return
    endif
  end subroutine cubeedit_getheader_prog_act_get_links
  !
  subroutine link_to_struct(link,userspace,error)
    use gkernel_interfaces, only: failed_allocate
    use cubedag_parameters
    use cubedag_link_type
    use cubedag_node_class
    !----------------------------------------------------------------------
    !
    !----------------------------------------------------------------------
    type(cubedag_link_t), intent(in)    :: link
    class(userspace_t),   intent(inout) :: userspace
    logical,              intent(inout) :: error
    !
    type(userstruct_t), pointer :: struct
    character(len=128), allocatable :: cubeids(:)
    integer(kind=iden_l), allocatable :: ids(:)
    integer(kind=4) :: ier,ilink
    class(cubedag_node_object_t), pointer :: this
    character(len=*), parameter :: rname='GETHEADER>ID>TOSTRUCT'
    !
    call cubeedit_message(edseve%trace,rname,'Welcome')
    !
    struct => cubetools_userstruct_ptr(userspace,error)
    if (error)  return
    call struct%def(error)
    if (error) return
    !
    call struct%set_member('n',link%n,error)
    if (error) return
    !
    if (link%n.le.0)  return
    !
    allocate(cubeids(link%n),ids(link%n),stat=ier)
    if (failed_allocate(rname,'cubeids',ier,error)) return
    do ilink=1,link%n
      this => cubedag_node_ptr(link%list(ilink)%p,error)
      if (error)  return
      ids(ilink) = this%node%id
      cubeids(ilink) = this%node%cubeid(error)
      if (error)  return
    enddo
    call struct%set_member('id',ids,error)
    if (error) return
    call struct%set_member('cubeid',cubeids,error)
    if (error) return
  end subroutine link_to_struct
  !
  !----------------------------------------------------------------------
  !
  subroutine cubeedit_getheader_newbuffer(id,type,space,error)
    !------------------------------------------------------------------------
    ! Reallocates buffers for bookeeping
    !------------------------------------------------------------------------
    integer(kind=4),    intent(in)    :: id
    character(len=*),   intent(in)    :: type
    class(userspace_t), intent(in)    :: space
    logical,            intent(inout) :: error
    !
    type(getheader_buffer_t), pointer :: buffer
    type(getheader_buffer_t) :: template
    class(list_object_t), pointer :: lot
    character(len=*), parameter :: rname='GETHEADER>NEWBUFFER'
    !
    call cubeedit_message(edseve%trace,rname,'welcome')
    !
    ! First remove any conflicting buffer. NB: SIC variables have
    ! already been removed-and-replaced, we just have to remove
    ! the buffers associated to the removed SIC variable.
    call cubetools_userspace_array_remove(bookkeeping,space,error)
    if (error) return
    !
    ! Insert new buffer associated to new SIC variable
    call bookkeeping%allocate(template,lot,error)
    if (error)  return
    ! Save in list
    buffer => getheader_buffer_ptr(lot,error)
    if (error)  return
    buffer%userspace_t = space
    buffer%type        = type
    buffer%id          = id
  end subroutine cubeedit_getheader_newbuffer
  !
  function getheader_buffer_ptr(buffer,error)
    !-------------------------------------------------------------------
    ! Check if the input class is of type(getheader_buffer_t), and
    ! return a pointer to it if yes.
    !-------------------------------------------------------------------
    type(getheader_buffer_t), pointer :: getheader_buffer_ptr  ! Function value on return
    class(list_object_t),     pointer       :: buffer
    logical,                  intent(inout) :: error
    !
    character(len=*), parameter :: rname='GETHEADER>BUFFER>PTR'
    !
    select type(buffer)
    type is (getheader_buffer_t)
      getheader_buffer_ptr => buffer
    class default
      getheader_buffer_ptr => null()
      call cubeedit_message(seve%e,rname,&
        'Internal error: object is not a getheader_buffer_t type')
      error = .true.
      return
    end select
  end function getheader_buffer_ptr
end module cubeedit_getheader_tool
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
