!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
module cubetools_userspace
  use gkernel_interfaces
  use gkernel_types
  use cubetools_messaging
  use cubetools_parameters
  use cubetools_structure
  use cubetools_keyword_arg
  use cubetools_list
  !
  public :: userspace_opt_t,userspace_user_t,userspace_t
  public :: cubetools_userspace_array_remove,cubetools_userspace_array_update
  public :: cubetools_userspace_get,cubetools_userspace_query
  private
  !
  integer(kind=4), parameter  :: nforbid = 2
  character(len=*), parameter :: forbidden(2) = [strg_star,strg_equal]
  !
  type userspace_opt_t
     type(option_t),      pointer :: opt
     type(keyword_arg_t), pointer :: scope
     type(keyword_arg_t), pointer :: overwrite
   contains
     procedure :: register  => cubetools_userspace_register
     procedure :: parse     => cubetools_userspace_parse
     procedure :: user2prog => cubetools_userspace_user2prog
  end type userspace_opt_t
  !
  type userspace_user_t
     logical               :: do        = .false.
     character(len=varn_l) :: name      = strg_unk
     character(len=argu_l) :: scope     = strg_unk
     character(len=argu_l) :: overwrite = strg_unk
  end type userspace_user_t
  !
  type, extends(tools_object_t) :: userspace_t
     character(len=varn_l)  :: name
     logical                :: scope
     logical                :: overwrite
     type(sic_descriptor_t) :: desc ! sic descriptor
   contains
     procedure, private :: copy => cubetools_userspace_copy
     generic, public    :: assignment(=) => copy
     procedure :: exists      => cubetools_sicdef_exists
     procedure :: fetch_desc  => cubetools_sicdef_fetch_descriptor
     procedure :: has_changed => cubetools_sicdef_desc_changed
  end type userspace_t
  !
contains
  !
  subroutine cubetools_userspace_register(opt,error)
    !------------------------------------------------------------------------
    !
    !------------------------------------------------------------------------
    class(userspace_opt_t), intent(out)   :: opt
    logical,                intent(inout) :: error
    !
    type(standard_arg_t) :: stdarg
    type(keyword_arg_t)  :: keyarg
    character(len=*), parameter :: scope(2) = ['GLOBAL','LOCAL ']
    character(len=*), parameter :: yesno(2) = ['YES','NO ']
    character(len=*), parameter :: rname='USERSPACE>REGISTER'
    !
    call cubetools_message(toolseve%trace,rname,'Welcome')
    !
    call cubetools_register_option(&
         'INTO','varname [scope [overwrite]]',&
         'Define the SIC variable name and its status',&
         strg_id,&
         opt%opt,error)
    if (error) return
    call stdarg%register( &
         'varname',  &
         'Variable name', &
         strg_id,&
         code_arg_mandatory, &
         error)
    if (error) return
    call keyarg%register( &
         'scope',  &
         'Variable is global or local', &
         'Default is global',&
         code_arg_optional, &
         scope, &
         .not.flexible, &
         opt%scope, &
         error)
    if (error) return
    call keyarg%register( &
         'overwrite',  &
         'Overwrite previous variable of same name', &
         'Default is yes',&
         code_arg_optional, &
         yesno, &
         .not.flexible, &
         opt%overwrite, &
         error)
    if (error) return
  end subroutine cubetools_userspace_register
  !
  subroutine cubetools_userspace_parse(opt,line,user,error)
    !----------------------------------------------------------------------
    !
    !----------------------------------------------------------------------
    class(userspace_opt_t), intent(in)    :: opt
    character(len=*),       intent(in)    :: line
    type(userspace_user_t), intent(out)   :: user
    logical,                intent(inout) :: error
    !
    character(len=*), parameter :: rname='USERSPACE>PARSE'
    !
    call cubetools_message(toolseve%trace,rname,'Welcome')
    !
    call opt%opt%present(line,user%do,error)
    if (error) return
    if (user%do) then
       call cubetools_getarg(line,opt%opt,1,user%name,mandatory,error)
       if (error) return
       user%scope = 'LOCAL'
       call cubetools_getarg(line,opt%opt,2,user%scope,.not.mandatory,error)
       if (error) return
       user%overwrite = 'YES'
       call cubetools_getarg(line,opt%opt,3,user%overwrite,.not.mandatory,error)
       if (error) return
    endif
  end subroutine cubetools_userspace_parse
  !
  subroutine cubetools_userspace_user2prog(opt,user,prog,error)
    use cubetools_disambiguate
    !----------------------------------------------------------------------
    !
    !----------------------------------------------------------------------
    class(userspace_opt_t), intent(in)    :: opt
    type(userspace_user_t), intent(in)    :: user
    class(userspace_t),     intent(inout) :: prog
    logical,                intent(inout) :: error
    !
    character(len=argu_l) :: scope,overwrite
    integer(kind=4) :: ikey,iforbid
    character(len=*), parameter :: rname='USERSPACE>USER2PROG'
    !
    call cubetools_message(toolseve%trace,rname,'Welcome')
    !
    do iforbid=1,nforbid
       if (user%name.eq.forbidden(iforbid)) then
          call cubetools_message(seve%e,rname,'The name '//trim(user%name)//&
               ' is protected and cannot be used')
          error = .true.
          return
       endif
    enddo
    call cubetools_disambiguate_toupper(user%name,prog%name,error)
    if (error) return
    call cubetools_keyword_user2prog(opt%scope,user%scope,ikey,scope,error)
    if (error)  return
    prog%scope = scope.eq.'GLOBAL'
    call cubetools_keyword_user2prog(opt%overwrite,user%overwrite,ikey,overwrite,error)
    if (error)  return
    prog%overwrite = overwrite.eq.'YES'
  end subroutine cubetools_userspace_user2prog
  !
  !----------------------------------------------------------------------
  !
  subroutine cubetools_userspace_get(type,name,userspace,error)
    use cubetools_disambiguate
    !----------------------------------------------------------------------
    ! Get a userspace element from a name and a type
    !----------------------------------------------------------------------
    character(len=*),   intent(in)    :: type
    character(len=*),   intent(in)    :: name
    class(userspace_t), intent(out)   :: userspace
    logical,            intent(inout) :: error
    !
    integer(kind=4) :: ikey
    character(len=16) :: key
    logical :: wrongtype
    character(len=*), parameter :: types(8) = &
         ['REAL   ','DOUBLE ','COMPLEX','INTEGER','LONG   ','LOGICAL','STRING ','STRUCT ']
    character(len=*), parameter :: rname='USERSPACE>GET'
    !
    call cubetools_message(toolseve%trace,rname,'Welcome')
    !
    if (sic_varexist(name)) then ! Cool variable exists
       userspace%name = name 
       call userspace%fetch_desc(error)
       if (error) return
       userspace%overwrite = .not. userspace%desc%readonly
       userspace%scope = sic_level(name).eq.0
       !
       call cubetools_disambiguate_strict(type,types,ikey,key,error)
       if (error) return
       wrongtype = .false.
       select case(key)
       case('REAL')
          wrongtype = userspace%desc%type.ne.fmt_r4
       case('DOUBLE')
          wrongtype = userspace%desc%type.ne.fmt_r8
       case('COMPLEX')
          wrongtype = userspace%desc%type.ne.fmt_c4          
       case('INTEGER')
          wrongtype = userspace%desc%type.ne.fmt_i4
       case('LONG')
          wrongtype = userspace%desc%type.ne.fmt_i8
       case('LOGICAL')
          wrongtype = userspace%desc%type.ne.fmt_l
       case('STRING')
          wrongtype = userspace%desc%type.lt.1
       case('STRUCT')
          wrongtype = userspace%desc%type.ne.0
       end select
       !
       if (wrongtype) then
          call cubetools_message(seve%e,rname,trim(name)//' exists but it is not of type '//trim(key))
          error = .true.
          return
       endif
    else
       call cubetools_message(seve%e,rname,'Variable '//trim(name)//' Does not exist')
       error = .true.
       return
    endif
  end subroutine cubetools_userspace_get
  !
  subroutine cubetools_userspace_query(name,found,error)
    !----------------------------------------------------------------------
    ! Tests if a variable with name exists in userspace
    !----------------------------------------------------------------------
    character(len=*), intent(in)    :: name
    logical,          intent(out)   :: found
    logical,          intent(inout) :: error
    !
    found = sic_varexist(name)
  end subroutine cubetools_userspace_query
  !
  !------------------------------------------------------------------------
  !
  subroutine cubetools_sicdef_exists(userspace,error)
    !------------------------------------------------------------------------
    ! Tests if a sic object with that name exists, if it does raises an
    ! error if overwrite is not true
    !------------------------------------------------------------------------
    class(userspace_t), intent(in)    :: userspace
    logical,            intent(inout) :: error
    !
    character(len=*), parameter :: rname='SICDEF>EXISTS'
    !
    call cubetools_message(toolseve%trace,rname,'Welcome')
    !
    if (sic_varexist(trim(userspace%name))) then
       if (userspace%overwrite) then
          call cubetools_message(toolseve%others,rname,trim(userspace%name)//' exists, overwriting it')
          call sic_delvariable(trim(userspace%name),.true.,error)
          if (error) return
       else
          call cubetools_message(seve%e,rname,'Variable '//trim(userspace%name)//' already exists')
          error = .true.
          return
       endif
    endif
  end subroutine cubetools_sicdef_exists
  !
  subroutine cubetools_sicdef_fetch_descriptor(userspace,error)
    !------------------------------------------------------------------------
    ! Fetch sic descriptor for the userspace item
    !------------------------------------------------------------------------
    class(userspace_t), intent(inout) :: userspace
    logical,            intent(inout) :: error
    !
    logical :: found
    character(len=*), parameter :: rname='SICDEF>FETCH>DESCRIPTOR'
    !
    call cubetools_message(toolseve%trace,rname,'Welcome')
    !
    found = .false.
    call sic_descriptor(userspace%name,userspace%desc,found)
    if (.not.found) then
       call cubetools_message(seve%e,rname,'User space item does not exist')
       error = .true.
       return
    endif
  end subroutine cubetools_sicdef_fetch_descriptor
  !
  function cubetools_sicdef_desc_changed(userspace) result(changed)
    !------------------------------------------------------------------------
    ! Checks if descriptor for a userspace object exists, and if it
    ! has changed since created
    !------------------------------------------------------------------------
    class(userspace_t), intent(in) :: userspace
    logical                        :: changed   
    !
    logical :: found
    type(sic_descriptor_t) :: mydesc
    character(len=*), parameter :: rname='SICDEF>DESCRIPTOR>CHANGED'
    !
    call cubetools_message(toolseve%trace,rname,'Welcome')
    !
    call sic_descriptor(userspace%name,mydesc,found)
    if (.not.found) then
       changed = .true.
       return
    else
       changed = sic_notsamedesc(userspace%desc,mydesc)
    endif
  end function cubetools_sicdef_desc_changed
  !
  !---------------------------------------------------------------------
  !
  subroutine cubetools_userspace_array_remove(arr,uspace,error)
    !-------------------------------------------------------------------
    ! Clean out from the list elements which are "identical" to the
    ! given userspace. This is intended to be used before inserting such
    ! a userspace, i.e. to avoid conflicts.
    !-------------------------------------------------------------------
    type(tools_list_t), intent(inout) :: arr
    class(userspace_t), intent(in)    :: uspace
    logical,            intent(inout) :: error
    ! Local
    integer(kind=list_k) :: obuf
    class(userspace_t), pointer :: lspace
    !
    obuf = 1
    do while (obuf.le.arr%n)  ! NB: arr%n is expected to change during loop execution
      lspace => cubetools_userspace_ptr(arr%list(obuf)%p,error)
      if (error)  return
      if (lspace%name.eq.uspace%name .and.  &
          (lspace%scope.eqv.uspace%scope)) then
        call cubetools_list_pop(arr,obuf,error)
        if (error)  return
      else
        obuf = obuf+1
      endif
    enddo
  end subroutine cubetools_userspace_array_remove
  !
  subroutine cubetools_userspace_array_update(arr,error)
    !------------------------------------------------------------------------
    ! Update the array list, i.e. check for buffers removed by some
    ! external mean (e.g. user DELETE /VAR) and compress the list
    ! accordingly
    !------------------------------------------------------------------------
    type(tools_list_t), intent(inout) :: arr
    logical,            intent(inout) :: error
    !
    class(userspace_t), pointer :: uspace
    integer(kind=4) :: oldn,newn,obuf
    character(len=*), parameter :: rname='USERSPACE>ARRAY>UPDATE'
    !
    call cubetools_message(toolseve%trace,rname,'welcome')
    !
    if (arr%n.le.0)  return
    !
    oldn = arr%n
    newn = 0
    do obuf=1,oldn
      uspace => cubetools_userspace_ptr(arr%list(obuf)%p,error)
      if (error)  return
      if (uspace%has_changed()) then
        ! Ideally we should use cubetools_list_pop, but I would like
        ! to avoid compressing the list several times, as several
        ! buffers migth be removed here
        if (arr%list(obuf)%code_pointer.eq.code_pointer_allocated)  &
          deallocate(uspace)
      else
        newn = newn+1
        arr%list(newn)%p => uspace
        arr%list(newn)%code_pointer = arr%list(obuf)%code_pointer
      endif
    enddo
    !
    ! There might be unused elements at the end of the list
    do obuf=newn+1,oldn
      arr%list(obuf)%p => null()
      arr%list(obuf)%code_pointer = code_pointer_null
    enddo
    !
    ! Update array size
    arr%n = newn
    !
    if (newn.eq.0) then
      call cubetools_list_final(arr,error)
      if (error)  return
    endif
  end subroutine cubetools_userspace_array_update
  !
  function cubetools_userspace_ptr(tot,error)
    !-------------------------------------------------------------------
    ! Check if the input class is of class(userspace_t), and return a
    ! pointer to it if relevant.
    !-------------------------------------------------------------------
    class(userspace_t), pointer :: cubetools_userspace_ptr  ! Function value on return
    class(tools_object_t), pointer       :: tot
    logical,               intent(inout) :: error
    !
    character(len=*), parameter :: rname='USERSPACE>PTR'
    !
    select type(tot)
    class is (userspace_t)
      cubetools_userspace_ptr => tot
    class default
      cubetools_userspace_ptr => null()
      call cubetools_message(seve%e,rname,  &
        'Internal error: object is not a userspace_t class')
      error = .true.
      return
    end select
  end function cubetools_userspace_ptr
  !
  subroutine cubetools_userspace_copy(o,i)
    !-------------------------------------------------------------------
    ! Copy one userspace_t CLASS to another CLASS
    !-------------------------------------------------------------------
    class(userspace_t), intent(inout) :: o
    class(userspace_t), intent(in)    :: i
    !
    o%tools_object_t = i%tools_object_t
    o%name           = i%name
    o%scope          = i%scope
    o%overwrite      = i%overwrite
    o%desc           = i%desc
  end subroutine cubetools_userspace_copy
  !
end module cubetools_userspace
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
