!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
module cubetopology_sperange_set_types
  use cubetools_parameters
  use cubetools_structure
  use cubetools_unit_arg
  use cubetools_axis_types
  use cubetopology_messaging
  use cubetopology_sperange_types
  !
  public :: sperange_set_comm_t,sperange_set_user_t,sperange_set_prog_t
  private
  !
  type sperange_set_comm_t
     type(option_t),   pointer :: key
     type(unit_arg_t), pointer :: unit
   contains
     procedure :: register => cubetopology_sperange_set_comm_register
     procedure :: parse    => cubetopology_sperange_set_comm_parse
  end type sperange_set_comm_t
  !
  type sperange_set_user_t
     logical,               public           :: present = .false.
     integer(kind=wind_k),  private          :: n = 0                         ! Size
     type(sperange_user_t), private, pointer :: val(:) => null()              ! Address
     integer(kind=code_k),  private          :: pointeris = code_pointer_null ! Null, allocated, or associated?
   contains
     procedure, private :: reallocate => cubetopology_sperange_set_user_reallocate
     procedure, private :: free       => cubetopology_sperange_set_user_free
     procedure, public  :: toprog     => cubetopology_sperange_set_user_toprog
     procedure, public  :: list       => cubetopology_sperange_set_user_list
     final :: cubetopology_sperange_set_user_final
  end type sperange_set_user_t
  !
  type sperange_set_prog_t
     integer(kind=wind_k),  public           :: n = 0                         ! Size
     type(sperange_prog_t), private, pointer :: val(:) => null()              ! Address
     integer(kind=code_k),  private          :: pointeris = code_pointer_null ! Null, allocated, or associated?
   contains
     procedure, private :: reallocate => cubetopology_sperange_set_prog_reallocate
     procedure, private :: free       => cubetopology_sperange_set_prog_free
     procedure, public  :: list       => cubetopology_sperange_set_prog_list
     procedure, public  :: get_into   => cubetopology_sperange_set_prog_get_into
     final :: cubetopology_sperange_set_prog_final
  end type sperange_set_prog_t
  !
contains
  !
  subroutine cubetopology_sperange_set_comm_register(comm,name,abstract,error)
    use cubetools_unit
    !----------------------------------------------------------------------
    ! Register a /NAME key for a set of spectral ranges. The abstract is
    ! customizable by the caller.
    !----------------------------------------------------------------------
    class(sperange_set_comm_t), intent(out)   :: comm
    character(len=*),           intent(in)    :: name
    character(len=*),           intent(in)    :: abstract
    logical,                    intent(inout) :: error
    !
    type(unit_arg_t) :: unitarg
    type(standard_arg_t) :: stdarg
    character(len=*), parameter :: rname='SPERANGE>SET>COMM>REGISTER'
    !
    call cubetopology_message(toposeve%trace,rname,'Welcome')
    !
    call cubetools_register_option(&
         name,'l1 h1 [... [ln hn]] [unit]',&
         abstract,&
         'Enable to define one or more spectral ranges',&
         comm%key,error)
    if (error) return
    call stdarg%register(&
         'l1', &
         'Low edge of first range',&
         strg_id,&
         code_arg_mandatory,&
         error)
    if (error) return
    call stdarg%register(&
         'h1', &
         'High edge of first range',&
         strg_id,&
         code_arg_mandatory,&
         error)
    if (error) return
    call stdarg%register(&
         'ln', &
         'Low edge of n-th range',&
         strg_id,&
         code_arg_unlimited,&
         error)
    if (error) return
    call stdarg%register(&
         'hn', &
         'High edge of n-th range',&
         strg_id,&
         code_arg_unlimited,&
         error)
    if (error) return
    call unitarg%register(&
         'unit',&
         'Range unit',&
         strg_id,&
         code_arg_optional,&
         code_unit_velo,&
         comm%unit,&
         error)
    if (error) return
  end subroutine cubetopology_sperange_set_comm_register
  !
  subroutine cubetopology_sperange_set_comm_parse(comm,line,user,error)
    use cubetools_structure
    !----------------------------------------------------------------------
    ! 
    !----------------------------------------------------------------------
    class(sperange_set_comm_t), intent(in)    :: comm
    character(len=*),           intent(in)    :: line
    type(sperange_set_user_t),  intent(inout) :: user
    logical,                    intent(inout) :: error
    !
    integer(kind=argu_k) :: narg
    integer(kind=wind_k) :: ir,jr,nr
    character(len=unit_l) :: userunit
    character(len=*), parameter :: rname='SPERANGE>SET>COMM>PARSE'
    !
    call cubetopology_message(toposeve%trace,rname,'Welcome')
    !
    call comm%key%present(line,user%present,error)
    if (error) return
    if (user%present) then
       ! Compute number of ranges
       narg = comm%key%getnarg()
       nr = narg/2
       ! Unit when present
       if (modulo(narg,2).eq.1) then
          ! Odd number of arguments => Last argument must be a unit
          call cubetools_getarg(line,comm%key,narg,userunit,mandatory,error)
          if (error) return
       endif
       ! Ranges
       call user%reallocate(nr,error)
       if (error) return
       jr = 0 ! argument counter
       do ir=1,nr
          user%val(ir)%do = user%present
          user%val(ir)%unit = userunit
          call get_next_arg(user%val(ir)%val(1))
          if (error) return
          call get_next_arg(user%val(ir)%val(2))
          if (error) return
       enddo ! ir
    endif
    !
  contains
    !
    subroutine get_next_arg(value)
      ! Use this one as a C macro
      character(len=*), intent(inout) :: value
      !
      jr = jr+1
      call cubetools_getarg(line,comm%key,jr,value,mandatory,error)
    end subroutine get_next_arg
  end subroutine cubetopology_sperange_set_comm_parse
  !
  !------------------------------------------------------------------------
  !
  subroutine cubetopology_sperange_set_user_reallocate(array,n,error)
    use gkernel_interfaces
    !----------------------------------------------------------------------
    !
    !----------------------------------------------------------------------
    class(sperange_set_user_t), intent(inout) :: array
    integer(kind=wind_k),       intent(in)    :: n
    logical,                    intent(inout) :: error
    !
    logical :: alloc
    integer(kind=4) :: ier
    character(len=mess_l) :: mess
    character(len=*), parameter :: rname='SPERANGE>SET>USER>REALLOCATE'
    !
    call cubetopology_message(toposeve%trace,rname,'Welcome')
    !
    ! Sanity check
    if (n.le.0) then
       call cubetopology_message(seve%e,rname,'Negative or zero number of ranges')
       error = .true.
      return
    endif
    !
    if (array%pointeris.eq.code_pointer_allocated) then
       ! The request is to get an allocated pointer
       if (array%n.eq.n) then
          write(mess,'(a,i0)') &
               'sperange_set_user pointer already allocated at the right size: ',n
          call cubetopology_message(toposeve%alloc,rname,mess)
          alloc = .false.
       else
          write(mess,'(a)') &
               'sperange_set_user pointer already allocated but with a different size => Freeing it first'
          call cubetopology_message(toposeve%alloc,rname,mess)
          call cubetopology_sperange_set_user_free(array)
          alloc = .true.
       endif
    else
       ! array%val is either null or associated => need to allocate it anyway
       alloc = .true.
    endif
    if (alloc) then
       allocate(array%val(n),stat=ier)
       if (failed_allocate(rname,'sperange_set_user pointer',ier,error)) return
    endif
    ! Allocation success => array%pointeris may be updated
    array%n = n
    array%pointeris = code_pointer_allocated
  end subroutine cubetopology_sperange_set_user_reallocate
  !
  subroutine cubetopology_sperange_set_user_free(array)
    !----------------------------------------------------------------------
    !
    !----------------------------------------------------------------------
    class(sperange_set_user_t), intent(inout) :: array
    !
    character(len=*), parameter :: rname='ARRAY>LONG>1D>FREE'
    !
    call cubetopology_message(toposeve%trace,rname,'Welcome')
    !
    if (array%pointeris.eq.code_pointer_allocated) then
       if (associated(array%val)) deallocate(array%val)
    else
       array%val => null()
    endif
    array%n = 0
    array%pointeris = code_pointer_null
  end subroutine cubetopology_sperange_set_user_free
  !
  subroutine cubetopology_sperange_set_user_final(array)
    !----------------------------------------------------------------------
    !
    !----------------------------------------------------------------------
    type(sperange_set_user_t), intent(inout) :: array
    !
    call cubetopology_sperange_set_user_free(array)
  end subroutine cubetopology_sperange_set_user_final
  !
  subroutine cubetopology_sperange_set_user_toprog(user,cube,prog,error)
    use cube_types
    !----------------------------------------------------------------------
    !
    !----------------------------------------------------------------------
    class(sperange_set_user_t), intent(in)    :: user
    type(cube_t),               intent(in)    :: cube
    type(sperange_set_prog_t),  intent(inout) :: prog
    logical,                    intent(inout) :: error
    !
    integer(kind=wind_k) :: ir
    character(len=*), parameter :: rname='SPERANGE>SET>USER>TOPROG'
    !
    call cubetopology_message(toposeve%trace,rname,'Welcome')
    !
    call prog%reallocate(user%n,error)
    if (error) return
    do ir=1,user%n
       call user%val(ir)%toprog(cube,code_sperange_truncated,prog%val(ir),error)
       if (error) return
    enddo ! ir
  end subroutine cubetopology_sperange_set_user_toprog
  !
  subroutine cubetopology_sperange_set_user_list(user,error)
    !----------------------------------------------------------------------
    !
    !----------------------------------------------------------------------
    class(sperange_set_user_t), intent(in)    :: user 
    logical,                    intent(inout) :: error
    !
    integer(kind=wind_k) :: ir
    character(len=*), parameter :: rname='SPERANGE>SET>USER>LIST'
    !
    call cubetopology_message(toposeve%trace,rname,'Welcome')
    !
    do ir=1,user%n
       call user%val(ir)%list(error)
       if (error) return
    enddo ! ir
  end subroutine cubetopology_sperange_set_user_list
  !
  !------------------------------------------------------------------------
  !
  subroutine cubetopology_sperange_set_prog_reallocate(array,n,error)
    use gkernel_interfaces
    !----------------------------------------------------------------------
    !
    !----------------------------------------------------------------------
    class(sperange_set_prog_t), intent(inout) :: array
    integer(kind=wind_k),       intent(in)    :: n
    logical,                    intent(inout) :: error
    !
    logical :: alloc
    integer(kind=4) :: ier
    character(len=mess_l) :: mess
    character(len=*), parameter :: rname='SPERANGE>SET>PROG>REALLOCATE'
    !
    call cubetopology_message(toposeve%trace,rname,'Welcome')
    !
    ! Sanity check
    if (n.le.0) then
       call cubetopology_message(seve%e,rname,'Negative or zero number of ranges')
       error = .true.
      return
    endif
    !
    if (array%pointeris.eq.code_pointer_allocated) then
       ! The request is to get an allocated pointer
       if (array%n.eq.n) then
          write(mess,'(a,i0)') &
               'sperange_set_prog pointer already allocated at the right size: ',n
          call cubetopology_message(toposeve%alloc,rname,mess)
          alloc = .false.
       else
          write(mess,'(a)') &
               'sperange_set_prog pointer already allocated but with a different size => Freeing it first'
          call cubetopology_message(toposeve%alloc,rname,mess)
          call cubetopology_sperange_set_prog_free(array)
          alloc = .true.
       endif
    else
       ! array%val is either null or associated => need to allocate it anyway
       alloc = .true.
    endif
    if (alloc) then
       allocate(array%val(n),stat=ier)
       if (failed_allocate(rname,'sperange_set_prog pointer',ier,error)) return
    endif
    ! Allocation success => array%pointeris may be updated
    array%n = n
    array%pointeris = code_pointer_allocated
  end subroutine cubetopology_sperange_set_prog_reallocate
  !
  subroutine cubetopology_sperange_set_prog_free(array)
    !----------------------------------------------------------------------
    !
    !----------------------------------------------------------------------
    class(sperange_set_prog_t), intent(inout) :: array
    !
    character(len=*), parameter :: rname='ARRAY>LONG>1D>FREE'
    !
    call cubetopology_message(toposeve%trace,rname,'Welcome')
    !
    if (array%pointeris.eq.code_pointer_allocated) then
       if (associated(array%val)) deallocate(array%val)
    else
       array%val => null()
    endif
    array%n = 0
    array%pointeris = code_pointer_null
  end subroutine cubetopology_sperange_set_prog_free
  !
  subroutine cubetopology_sperange_set_prog_final(array)
    !----------------------------------------------------------------------
    !
    !----------------------------------------------------------------------
    type(sperange_set_prog_t), intent(inout) :: array
    !
    call cubetopology_sperange_set_prog_free(array)
  end subroutine cubetopology_sperange_set_prog_final
  !
  subroutine cubetopology_sperange_set_prog_list(prog,key,error)
    use cubetools_format
    !----------------------------------------------------------------------
    !
    !----------------------------------------------------------------------
    class(sperange_set_prog_t), intent(in)    :: prog
    character(len=*),           intent(in)    :: key
    logical,                    intent(inout) :: error
    !
    character(len=mess_l) :: mess
    integer(kind=wind_k) :: ir
    character(len=*), parameter :: rname='SPERANGE>SET>PROG>LIST'
    !
    call cubetopology_message(toposeve%trace,rname,'Welcome')
    !
    call cubetopology_message(seve%r,rname,'')
    mess = cubetools_format_stdkey_boldval(key,'Global Window',40)
    call cubetopology_message(seve%r,rname,mess)
    do ir=1,prog%n
       call prog%val(ir)%list(error)
       if (error) return
    enddo ! ir
  end subroutine cubetopology_sperange_set_prog_list
  !
  subroutine cubetopology_sperange_set_prog_get_into(prog,ir,range,error)
    !----------------------------------------------------------------------
    !
    !----------------------------------------------------------------------
    class(sperange_set_prog_t), intent(in)    :: prog
    integer(kind=wind_k),       intent(in)    :: ir
    type(sperange_prog_t),      intent(inout) :: range
    logical,                    intent(inout) :: error
    !
    character(len=*), parameter :: rname='SPERANGE>SET>PROG>GET>INTO'
    !
    call cubetopology_message(toposeve%trace,rname,'Welcome')
    !
    if ((1.le.ir).and.(ir.le.prog%n)) then
       range = prog%val(ir)
    else
       call cubetopology_message(toposeve%trace,rname,'Trying to get a range outside the available rangeset list')
       error = .true.
       return
    endif
  end subroutine cubetopology_sperange_set_prog_get_into
end module cubetopology_sperange_set_types
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
