module cubelist_variable_types
  use cubetools_parameters
  use cubelist_types
  use cubedag_messaging
  !---------------------------------------------------------------------
  ! Support module for generic user variable creation (in a structure)
  ! based on a list
  ! ---
  ! FixME: this module should go in cubelist (hence the name of this
  ! module), but we have a dependency on the cubetools_user* modules
  ! from the cubesyntax library, which depend themselves on the basic
  ! list_t. Possible solution:
  !  - have the basic list_t in a library
  !  - have the cubetools_user* modules in cubesyntax library (or other)
  !  - have the advandced list_object_advanced_t in another library.
  !---------------------------------------------------------------------
  !
  public :: list_variable_t
  public :: list_variable_list_t
  private
  !
  ! Support for 1 value
  type, abstract, extends(list_object_t) :: list_variable_t
    character(len=varn_l), public :: parent  ! Parent structure name (e.g. 'ID' used in IDX%ID%)
    character(len=varn_l), public :: name    ! Variable name (e.g. 'FAMILY' used in IDX%ID%FAMILY)
    integer(kind=code_k),  public :: kind
    ! Support arrays (only one used per instance)
    integer(kind=4),  public, allocatable :: i4(:)
    integer(kind=8),  public, allocatable :: i8(:)
    real(kind=4),     public, allocatable :: r4(:)
    real(kind=8),     public, allocatable :: r8(:)
    character(len=:), public, allocatable :: cc(:)
  contains
    procedure(variable_init_interface), deferred :: init        ! [private]
    procedure(fill_array_interface),    deferred :: fill_array  ! [private]
  end type list_variable_t
  !
  ! The collection of variables
  type, extends(list_t) :: list_variable_list_t
    ! No more attributes
  contains
    procedure, public :: create => cubelist_variable_create
  end type list_variable_list_t
  !
contains
  !
  function cubelist_variable_ptr(obj,error)
    !-------------------------------------------------------------------
    ! Check if the input class is of class(list_variable_t), and return
    ! a pointer to it if relevant.
    !-------------------------------------------------------------------
    class(list_variable_t), pointer :: cubelist_variable_ptr
    class(list_object_t),  pointer       :: obj
    logical,               intent(inout) :: error
    !
    character(len=*), parameter :: rname='VARIABLE>PTR'
    !
    select type(obj)
    class is (list_variable_t)
      cubelist_variable_ptr => obj
    class default
      cubelist_variable_ptr => null()
      call cubedag_message(seve%e,rname,  &
        'Internal error: object is not a list_variable_t class')
      error = .true.
      return
    end select
  end function cubelist_variable_ptr
  !
  subroutine variable_init_interface(var,error)
    !-------------------------------------------------------------------
    ! Initialize the variable properties
    !-------------------------------------------------------------------
    class(list_variable_t), intent(inout) :: var
    logical,                intent(inout) :: error
  end subroutine variable_init_interface
  !
  subroutine fill_array_interface(var,obj,ient)
    !-------------------------------------------------------------------
    ! Interface for a function returning a I*4 value
    !-------------------------------------------------------------------
    class(list_variable_t),        intent(inout) :: var
    class(list_object_advanced_t), intent(in)    :: obj
    integer(kind=list_k),          intent(in)    :: ient
  end subroutine fill_array_interface
  !
  subroutine cubelist_variable_create(var,list,name,error)
    use gbl_format
    use gkernel_interfaces
    use cubetools_userspace
    use cubetools_userstruct
    !-------------------------------------------------------------------
    ! Create the user variable structure (top structure + substructures
    ! + members) based on the declared list of variables and the list of
    ! objects.
    !-------------------------------------------------------------------
    class(list_variable_list_t), intent(in)    :: var
    class(list_t),               intent(in)    :: list
    character(len=*),            intent(in)    :: name  ! Top structure name
    logical,                     intent(inout) :: error
    !
    integer(kind=list_k) :: ivar,ient
    class(list_variable_t), pointer :: onevar
    integer(kind=4) :: ier
    class(list_object_advanced_t), pointer :: obj
    type(userstruct_t) :: topstruct,substruct
    character(len=*), parameter :: rname='VARIABLE>MAIN'
    !
    do ivar=1,var%n
      onevar => cubelist_variable_ptr(var%list(ivar)%p,error)
      if (error)  return
      ! Initialize the variable properties
      call onevar%init(error)
      if (error)  return
      ! Allocate the temporary array gathering the relevant values
      select case (onevar%kind)
      case (fmt_i4)
        allocate(onevar%i4(list%n),stat=ier)
      case (fmt_i8)
        allocate(onevar%i8(list%n),stat=ier)
      case (fmt_r4)
        allocate(onevar%r4(list%n),stat=ier)
      case (fmt_r8)
        allocate(onevar%r8(list%n),stat=ier)
      case default  ! >0 == string length
        allocate(character(onevar%kind)::onevar%cc(list%n),stat=ier)
      end select
      if (failed_allocate(rname,'IDX '//trim(onevar%name)//' array',ier,error)) return
    enddo
    !
    ! Fill with values
    do ient=1,list%n
      obj => cubelist_object_advanced_ptr(list%list(ient)%p,error)
      if (error)  return
      !
      do ivar=1,var%n
        onevar => cubelist_variable_ptr(var%list(ivar)%p,error)
        if (error)  return
        call onevar%fill_array(obj,ient)
      enddo
    enddo
    !
    ! The user structure is user-defined: no need for a permanent allocation
    ! of the arrays nor topstruct userstruct_t
    topstruct%name      = name
    topstruct%scope     = .true.          ! Global variable
    topstruct%overwrite = overwrite_user  ! Avoid overwriting e.g. PI
    !
    ! Main structure
    call topstruct%def(error)
    if (error)  return
    call topstruct%set_member('n',list%n,error)
    if (error) return
    if (list%n.le.0)  return  ! No zero-sized arrays in SIC: leave
    !
    ! Create all variables in their substructures
    do ivar=1,var%n
      onevar => cubelist_variable_ptr(var%list(ivar)%p,error)
      if (error)  return
      if (.not.topstruct%has_member(onevar%parent)) then
        ! Create only once if not already existing. topstruct%def()
        ! ensures that the top structure was fully reset.
        call topstruct%def_substruct(onevar%parent,substruct,error)
        if (error) return
      endif
      select case (onevar%kind)
      case (fmt_i4)
        call substruct%set_member(onevar%name,onevar%i4,error)
        if (error) return
      case (fmt_i8)
        call substruct%set_member(onevar%name,onevar%i8,error)
        if (error) return
      case (fmt_r4)
        call substruct%set_member(onevar%name,onevar%r4,error)
        if (error) return
      case (fmt_r8)
        call substruct%set_member(onevar%name,onevar%r8,error)
        if (error) return
      case default
        call substruct%set_member(onevar%name,onevar%cc,error)
        if (error) return
      end select
    enddo
    !
  end subroutine cubelist_variable_create
end module cubelist_variable_types
!
module cubedag_variables
  use gbl_format
  use cubetools_parameters
  use cubelist_types
  use cubelist_variable_types
  !---------------------------------------------------------------------
  ! Support module for all the possible user variables created from the
  ! DAG
  !---------------------------------------------------------------------
  !
  public :: var_identifier_t
  public :: var_family_t
  public :: var_cflags_t
  private
  !
  ! ID number
  type, extends(list_variable_t) :: var_identifier_t
  contains
    procedure         :: init       => variable_init_id        ! [private]
    procedure         :: fill_array => variable_fill_array_id  ! [private]
    procedure, public :: final      => variable_final_id
  end type var_identifier_t
  !
  ! Family
  type, extends(list_variable_t) :: var_family_t
  contains
    procedure         :: init       => variable_init_family        ! [private]
    procedure         :: fill_array => variable_fill_array_family  ! [private]
    procedure, public :: final      => variable_final_family
  end type var_family_t
  !
  ! Character-flags
  type, extends(list_variable_t) :: var_cflags_t
  contains
    procedure         :: init       => variable_init_cflags        ! [private]
    procedure         :: fill_array => variable_fill_array_cflags  ! [private]
    procedure, public :: final      => variable_final_cflags
  end type var_cflags_t
  !
contains
  !
  !---------------------------------------------------------------------
  subroutine variable_init_id(var,error)
    class(var_identifier_t), intent(inout) :: var
    logical,                 intent(inout) :: error
    var%parent = 'id'
    var%name   = 'id'
    var%kind   = fmt_i8
  end subroutine variable_init_id
  subroutine variable_fill_array_id(var,obj,ient)
    use cubedag_node_class
    !-------------------------------------------------------------------
    !
    !-------------------------------------------------------------------
    class(var_identifier_t),       intent(inout) :: var
    class(list_object_advanced_t), intent(in)    :: obj
    integer(kind=list_k),          intent(in)    :: ient
    logical :: found,error
    var%i8(ient) = 0_8  ! Should not be necessary
    error = .false.
    call obj%get_value('IDENTIFIER',found,var%i8(ient),error)
  end subroutine variable_fill_array_id
  subroutine variable_final_id(obj,error)
    class(var_identifier_t), intent(inout) :: obj
    logical,                 intent(inout) :: error
    if (allocated(obj%i8))  deallocate(obj%i8)
  end subroutine variable_final_id
  !---------------------------------------------------------------------
  subroutine variable_init_family(var,error)
    class(var_family_t), intent(inout) :: var
    logical,             intent(inout) :: error
    var%parent = 'id'
    var%name   = 'family'
    var%kind   = base_l
  end subroutine variable_init_family
  subroutine variable_fill_array_family(var,obj,ient)
    use cubedag_node_class
    !-------------------------------------------------------------------
    !
    !-------------------------------------------------------------------
    class(var_family_t),           intent(inout) :: var
    class(list_object_advanced_t), intent(in)    :: obj
    integer(kind=list_k),          intent(in)    :: ient
    logical :: found,error
    error = .false.
    var%cc(ient) = strg_unk
    call obj%get_value('FAMILY',found,var%cc(ient),error)
  end subroutine variable_fill_array_family
  subroutine variable_final_family(obj,error)
    class(var_family_t), intent(inout) :: obj
    logical,             intent(inout) :: error
    if (allocated(obj%cc))  deallocate(obj%cc)
  end subroutine variable_final_family
  !---------------------------------------------------------------------
  subroutine variable_init_cflags(var,error)
    class(var_cflags_t), intent(inout) :: var
    logical,             intent(inout) :: error
    var%parent = 'id'
    var%name   = 'flagstring'
    var%kind   = argu_l  ! Same as LOAD /ID => len=argu_l
  end subroutine variable_init_cflags
  subroutine variable_fill_array_cflags(var,obj,ient)
    use cubedag_node_class
    !-------------------------------------------------------------------
    !
    !-------------------------------------------------------------------
    class(var_cflags_t),           intent(inout) :: var
    class(list_object_advanced_t), intent(in)    :: obj
    integer(kind=list_k),          intent(in)    :: ient
    logical :: found,error
    error = .false.
    var%cc(ient) = strg_unk
    call obj%get_value('FLAGS',found,var%cc(ient),error)
  end subroutine variable_fill_array_cflags
  subroutine variable_final_cflags(obj,error)
    class(var_cflags_t), intent(inout) :: obj
    logical,             intent(inout) :: error
    if (allocated(obj%cc))  deallocate(obj%cc)
  end subroutine variable_final_cflags
  !---------------------------------------------------------------------
end module cubedag_variables
!
module cubedag_variable_types
  use cubetools_parameters
  use cubelist_variable_types
  use cubedag_messaging
  use cubedag_node_class
  use cubedag_link_type
  use cubedag_dag_buffer
  use cubedag_variables
  !---------------------------------------------------------------------
  ! Support module which creates user variables based on the DAG without
  ! knowing the node properties
  !---------------------------------------------------------------------
  !
  ! For convenience, re-export all individual variables known by the DAG
  public :: var_identifier_t
  public :: var_family_t
  public :: var_cflags_t
  public :: dag_variable_list_t
  private
  !
  ! The collection of variables
  type, extends(list_variable_list_t) :: dag_variable_list_t
    ! No more attributes
  contains
    procedure, public :: ix => cubedag_variable_ix
    procedure, public :: cx => cubedag_variable_cx
  end type dag_variable_list_t
  !
contains
  !
  subroutine cubedag_variable_ix(var,error)
    use gkernel_interfaces
    !-------------------------------------------------------------------
    ! Define the structure for the DAG index
    ! ZZZ Should be called by cubedag_dag_attach for each new node
    !-------------------------------------------------------------------
    class(dag_variable_list_t), intent(in)    :: var
    logical,                    intent(inout) :: error
    !
    ! call cubedag_variable_act(var,ix,'DAG',error)
    call var%create(ix,'DAG',error)
    if (error)  return
  end subroutine cubedag_variable_ix
  !
  subroutine cubedag_variable_cx(var,error)
    use gkernel_interfaces
    !-------------------------------------------------------------------
    ! Define the structure for the CURRENT index
    !-------------------------------------------------------------------
    class(dag_variable_list_t), intent(in)    :: var
    logical,                    intent(inout) :: error
    !
    ! call cubedag_variable_act(var,cx,'IDX',error)
    call var%create(cx,'IDX',error)
    if (error)  return
  end subroutine cubedag_variable_cx
end module cubedag_variable_types
