!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
module cubeadm_cubeprod_types
  !---------------------------------------------------------------------
  ! Support module for description of cubes as a product created by a
  ! command.
  !---------------------------------------------------------------------
  use cubetools_primitive_prod
  use cubetools_structure
  use cubedag_flag
  use cubeadm_messaging
  !
  public :: cubeadm_cubeprod_ptr
  public :: cube_prod_t
  private
  !
  integer(kind=4), parameter :: flag_k = 4
  integer(kind=4), parameter :: cube_k = 4
  !
  type, extends(primitive_prod_t) :: cube_prod_t
     integer(kind=code_k) :: access = code_unk
     integer(kind=code_k) :: flagmode = code_unk
     integer(kind=flag_k) :: nflag = -1
     type(flag_t), allocatable :: flag(:)
   contains
     procedure :: register       => cubeadm_cubeprod_register
     procedure :: print_abstract => cubeadm_cubeprod_abstract
  end type cube_prod_t
  !
contains
  !
  function cubeadm_cubeprod_ptr(tot,error)
    use cubetools_list
    !-------------------------------------------------------------------
    ! Check if the input class is of type(cube_prod_t), and return
    ! a pointer to it if relevant.
    !-------------------------------------------------------------------
    type(cube_prod_t), pointer :: cubeadm_cubeprod_ptr  ! Function value on return
    class(tools_object_t), pointer       :: tot
    logical,               intent(inout) :: error
    !
    character(len=*), parameter :: rname='CUBEPROD>PTR'
    !
    select type(tot)
    type is (cube_prod_t)
      cubeadm_cubeprod_ptr => tot
    class default
      cubeadm_cubeprod_ptr => null()
      call cubeadm_message(seve%e,rname,'Internal error: object is not a cube_prod_t type')
      error = .true.
      return
    end select
  end function cubeadm_cubeprod_ptr
  !
  !---------------------------------------------------------------------
  !
  subroutine cubeadm_cubeprod_allocate_and_init(nflag,prod,error)
    use gkernel_interfaces
    use cubedag_parameters
    !-------------------------------------------------------------------
    !
    !-------------------------------------------------------------------
    integer(kind=flag_k), intent(in)    :: nflag
    type(cube_prod_t),    intent(inout) :: prod
    logical,              intent(inout) :: error
    !
    integer(kind=4) :: ier
    character(len=*), parameter :: rname='CUBEPROD>ALLOCATE'
    !
    call cubeadm_message(admseve%trace,rname,'Welcome')
    !
    if (allocated(prod%flag)) then
       call cubeadm_message(admseve%alloc,rname,'Flag array already allocated deallocating')
       deallocate(prod%flag)
    endif
    !
    allocate(prod%flag(nflag),stat=ier)
    if (failed_allocate(rname,'flag array',ier,error)) return
    prod%nflag = nflag
    !
    prod%flag(:) = flag_unknown
  end subroutine cubeadm_cubeprod_allocate_and_init
  !
  subroutine cubeadm_cubeprod_put(flags,prod,error,access,flagmode)
    !-------------------------------------------------------------------
    !
    !-------------------------------------------------------------------
    type(flag_t),         intent(in)           :: flags(:)
    type(cube_prod_t),    intent(inout)        :: prod
    logical,              intent(inout)        :: error
    integer(kind=code_k), intent(in), optional :: access    ! Custom access
    integer(kind=code_k), intent(in), optional :: flagmode  ! Custom flags
    !
    integer(kind=flag_k) :: nflag
    character(len=*), parameter :: rname='CUBEPROD>PUT'
    !
    call cubeadm_message(admseve%trace,rname,'Welcome')
    !
    nflag = size(flags)
    call cubeadm_cubeprod_allocate_and_init(nflag,prod,error)
    if (error) return
    prod%flag(:) = flags(:)
    !
    if (present(access))    prod%access   = access
    if (present(flagmode))  prod%flagmode = flagmode
  end subroutine cubeadm_cubeprod_put
  !
  !---------------------------------------------------------------------
  !
  subroutine cubeadm_cubeprod_register(template,name,abstract,help,  &
    flags,pcube,error,access,flagmode)
    !-------------------------------------------------------------------
    !
    !-------------------------------------------------------------------
    class(cube_prod_t),   intent(in)           :: template  ! Template
    character(len=*),     intent(in)           :: name
    character(len=*),     intent(in)           :: abstract
    character(len=*),     intent(in)           :: help
    type(flag_t),         intent(in)           :: flags(:)
    type(cube_prod_t),    pointer              :: pcube     ! Pointer to registered cube product
    logical,              intent(inout)        :: error
    integer(kind=code_k), intent(in), optional :: access    ! Custom access
    integer(kind=code_k), intent(in), optional :: flagmode  ! Custom flags
    !
    class(primitive_prod_t), pointer :: actualprod
    character(len=*), parameter :: rname='CUBEPROD>REGISTER'
    !
    call cubeadm_message(admseve%trace,rname,'Welcome')
    !
    ! Register the primitive parts, and get pointer to the actual object
    ! saved in the parsing structure
    call cubetools_register_primitive_prod(template,name,abstract,help,actualprod,error)
    if (error) return
    !
    ! Register the extended parts
    select type (actualprod)
    type is (cube_prod_t)
      pcube => actualprod
      call cubeadm_cubeprod_put(flags,pcube,error,access,flagmode)
      if (error) return
    class default
      call cubeadm_message(seve%e,rname,'Internal error: product has wrong type')
      error = .true.
      return
    end select
  end subroutine cubeadm_cubeprod_register
  !
  subroutine cubeadm_cubeprod_abstract(prod,iprod,error)
    use gkernel_interfaces
    use cubetools_format
    use cubetools_help
    use cubetools_messaging
    use cubetools_string
    !-------------------------------------------------------------------
    !
    !-------------------------------------------------------------------
    class(cube_prod_t),   intent(in)    :: prod
    integer(kind=prod_k), intent(in)    :: iprod
    logical,              intent(inout) :: error
    !
    character(len=mess_l) :: status,mess,flags
    character(len=*), parameter :: rname='CUBEPROD>ABSTRACT'
    !
    call cubeadm_message(admseve%trace,rname,'Welcome')
    !
    if ((iprod.lt.1).or.(9.lt.iprod)) then
       ! ZZZ does this make sense for cube products?
       call cubeadm_message(seve%e,rname,'Product number out of authorized range: [1-9]')
       error = .true.
       return
    endif
    !
    call cubedag_flaglist_tostr(prod%flag,prod%nflag,strflag=flags,error=error)
    if (error) return
    if (prod%flagmode.ne.code_unk) then
      if (prod%flagmode.ne.keep_none) then
        flags = strg_star//','//flags
      endif
    endif
    if (prod%access.eq.code_unk) then
      status = 'sameset'
    else
      status = access_status(prod%access)
    endif
    !
    write(mess,'(a1,i1,1x,3a,1x,a)')  &
      '#',iprod,'(',trim(status),')',trim(flags)
    mess = '  '//cubetools_format_stdkey_boldval(mess,prod%abstract,help_width())
    call cubetools_message(toolseve%help,rname,mess)
  end subroutine cubeadm_cubeprod_abstract
  !
end module cubeadm_cubeprod_types
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
