!-----------------------------------------------------------------------
!  Support file for reading the content of a Sic variable into a target
! Fortran variable, with automatic type casting.
!  (For the reverse operation, i.e. writing a Fortran variable into a
! Sic variable, see file fill.f90)
!-----------------------------------------------------------------------
!
! === SCALARS ==========================================================
!
subroutine sic_get_real (var,rel,error)
  use sic_dependencies_interfaces
  use gildas_def
  use sic_interfaces, except_this=>sic_get_real
  use sic_structures
  use sic_dictionaries
  use sic_types
  use gbl_format
  !---------------------------------------------------------------------
  ! @ public
  ! Retrieve a global variable value
  !---------------------------------------------------------------------
  character(len=*) :: var           !
  real*4 :: rel                     !
  logical :: error                  !
  ! Global
  include 'gbl_memory.inc'
  ! Local
  logical :: found
  integer :: type
  type(sic_descriptor_t) :: descr
  integer(kind=address_length) :: ipnt
  !
  error = .true.
  found = .true.
  call sic_descriptor (var,descr,found)    ! Checked, must be scalar
  if (.not.found) return
  type = descr%type
  ipnt = bytpnt(descr%addr,membyt)
  if (type.ge.0) then          ! Character variable (>0) or header str
    error = .true.
  elseif (descr%ndim.ne.0) then  ! Not a scalar variable
    error = .true.
  elseif (type.eq.fmt_r4) then
    call r4tor4(membyt(ipnt),rel,1)
    error = .false.
  elseif (type.eq.fmt_r8) then
    call r8tor4(membyt(ipnt),rel,1)
    error = .false.
  elseif (type.eq.fmt_i4) then
    call i4tor4(membyt(ipnt),rel,1)
    error = .false.
  elseif (type.eq.fmt_i8) then
    call i8tor4(membyt(ipnt),rel,1)
    error = .false.
  else
    error =.true.
  endif
end subroutine sic_get_real
!
subroutine sic_get_dble (var,doble,error)
  use sic_dependencies_interfaces
  use gildas_def
  use sic_interfaces, except_this=>sic_get_dble
  use sic_structures
  use sic_dictionaries
  use sic_types
  use gbl_format
  !---------------------------------------------------------------------
  ! @ public
  ! Retrieve a global variable value
  !---------------------------------------------------------------------
  character(len=*) :: var           !
  real*8 :: doble                   !
  logical :: error                  !
  ! Global
  include 'gbl_memory.inc'
  ! Local
  logical :: found
  integer :: type
  type(sic_descriptor_t) :: descr
  integer(kind=address_length) :: ipnt
  !
  error = .true.
  found = .true.
  call sic_descriptor (var,descr,found)    ! Checked, must be scalar
  if (.not.found) return
  type = descr%type
  ipnt = bytpnt(descr%addr,membyt)
  if (type.ge.0) then
    error = .true.
  elseif (descr%ndim.ne.0) then
    error = .true.
  elseif (type.eq.fmt_r4) then
    call r4tor8(membyt(ipnt),doble,1)
    error = .false.
  elseif (type.eq.fmt_r8) then
    call r8tor8(membyt(ipnt),doble,1)
    error = .false.
  elseif (type.eq.fmt_i4) then
    call i4tor8(membyt(ipnt),doble,1)
    error = .false.
  elseif (type.eq.fmt_i8) then
    call i8tor8(membyt(ipnt),doble,1)
    error = .false.
  else
    error = .true.
  endif
end subroutine sic_get_dble
!
! Integers
subroutine sic_get_inte (var,inte,error)
  use sic_dependencies_interfaces
  use gildas_def
  use sic_interfaces, except_this=>sic_get_inte
  use sic_structures
  use sic_dictionaries
  use sic_types
  use gbl_format
  use gbl_message
  !---------------------------------------------------------------------
  ! @ public
  ! Retrieve a global variable value
  !---------------------------------------------------------------------
  character(len=*) :: var           !
  integer*4 :: inte                 !
  logical :: error                  !
  ! Global
  include 'gbl_memory.inc'
  ! Local
  logical :: found
  integer :: type
  type(sic_descriptor_t) :: descr
  integer(kind=address_length) :: ipnt
  !
  error = .true.
  found = .true.
  call sic_descriptor (var,descr,found)    ! Checked, must be scalar
  if (.not.found) return
  type = descr%type
  ipnt = bytpnt(descr%addr,membyt)
  if (type.ge.0) then
    error = .true.
  elseif (descr%ndim.ne.0) then
    error = .true.
  elseif (type.eq.fmt_r4) then
    error = .false.
    call r4toi4_fini(membyt(ipnt),inte,1,error)
  elseif (type.eq.fmt_r8) then
    error = .false.
    call r8toi4_fini(membyt(ipnt),inte,1,error)
  elseif (type.eq.fmt_i4) then
    error = .false.
    call i4toi4(membyt(ipnt),inte,1)
  elseif (type.eq.fmt_i8) then
    error = .false.
    call i8toi4_fini(membyt(ipnt),inte,1,error)
  else
    error = .true.
  endif
end subroutine sic_get_inte
!
subroutine sic_get_long (var,long,error)
  use sic_dependencies_interfaces
  use gildas_def
  use sic_interfaces, except_this=>sic_get_long
  use sic_structures
  use sic_dictionaries
  use sic_types
  use gbl_format
  !---------------------------------------------------------------------
  ! @ public
  ! Retrieve a global variable value
  !---------------------------------------------------------------------
  character(len=*) :: var           !
  integer*8 :: long                 !
  logical :: error                  !
  ! Global
  include 'gbl_memory.inc'
  ! Local
  logical :: found
  integer :: type
  type(sic_descriptor_t) :: descr
  integer(kind=address_length) :: ipnt
  !
  error = .true.
  found = .true.
  call sic_descriptor (var,descr,found)    ! Checked, must be scalar
  if (.not.found) return
  type = descr%type
  ipnt = bytpnt(descr%addr,membyt)
  if (type.ge.0) then
    error = .true.
  elseif (descr%ndim.ne.0) then
    error = .true.
  elseif (type.eq.fmt_r4) then
    error = .false.
    call r4toi8_fini(membyt(ipnt),long,1,error)
  elseif (type.eq.fmt_r8) then
    error = .false.
    call r8toi8_fini(membyt(ipnt),long,1,error)
  elseif (type.eq.fmt_i4) then
    error = .false.
    call i4toi8(membyt(ipnt),long,1)
  elseif (type.eq.fmt_i8) then
    error = .false.
    call i8toi8(membyt(ipnt),long,1)
  else
    error = .true.
  endif
end subroutine sic_get_long
!
! Logicals
subroutine sic_get_logi (var,logi,error)
  use sic_dependencies_interfaces
  use gildas_def
  use sic_interfaces, except_this=>sic_get_logi
  use sic_structures
  use sic_dictionaries
  use sic_types
  use gbl_format
  !---------------------------------------------------------------------
  ! @ public
  ! Retrieve a global variable value
  !---------------------------------------------------------------------
  character(len=*) :: var           !
  logical :: logi                   !
  logical :: error                  !
  ! Global
  include 'gbl_memory.inc'
  ! Local
  logical :: found
  type(sic_descriptor_t) :: descr
  integer(kind=address_length) :: ipnt
  !
  error = .true.
  found = .true.
  call sic_descriptor (var,descr,found)    ! Checked, must be scalar
  if (.not.found) return
  if (descr%ndim.ne.0) then
    error = .true.
  elseif (descr%type.eq.fmt_i4 .or. descr%type.eq.fmt_l) then
    ipnt = bytpnt(descr%addr,membyt)
    call l4tol4(membyt(ipnt),logi,1)
    error = .false.
  else
    error = .true.
  endif
end subroutine sic_get_logi
!
! Characters
subroutine sic_get_char (var,chain,lc,error)
  use sic_dependencies_interfaces
  use gildas_def
  use sic_interfaces, except_this=>sic_get_char
  use sic_structures
  use sic_dictionaries
  use sic_types
  !---------------------------------------------------------------------
  ! @ public
  ! Retrieve a global variable value
  !---------------------------------------------------------------------
  character(len=*) :: var           !
  character(len=*) :: chain         !
  integer :: lc                     !
  logical :: error                  !
  ! Global
  include 'gbl_memory.inc'
  ! Local
  logical :: found
  type(sic_descriptor_t) :: descr
  !
  error = .true.
  found = .true.
  call sic_descriptor (var,descr,found)    ! Checked, must be scalar
  if (.not.found) return
  !
  if (desc_nelem(descr).ne.1) then
    error = .true.
  elseif (descr%type.gt.0) then
    call destoc(descr%type,descr%addr,chain)
    lc = len_trim(chain)           ! not MIN(TYPE,LEN(CHAIN))
    error = .false.
  else
    error = .true.
  endif
end subroutine sic_get_char
!
subroutine sic_get_auto (var,value,type,error)
  use sic_dependencies_interfaces
  use gildas_def
  use sic_interfaces
  use sic_structures
  use sic_dictionaries
  use sic_types
  use gbl_format
  !---------------------------------------------------------------------
  ! @ no-interface (because of argument type mismatch - on purpose -)
  !  Returns the SIC variable value in the 8-bit untyped variable, plus
  ! its type in another variable. Variables are automatically converted
  ! to types: REAL*8, INTEGER*8 or LOGICAL.
  !---------------------------------------------------------------------
  character(len=*), intent(in)    :: var       !
  integer(kind=1),  intent(out)   :: value(8)  !
  integer(kind=4),  intent(out)   :: type      !
  logical,          intent(inout) :: error     !
  ! Global
  include 'gbl_memory.inc'
  ! Local
  logical :: found
  type(sic_descriptor_t) :: descr
  integer(kind=address_length) :: ipnt
  !
  found = .false.
  call sic_descriptor (var,descr,found)
  if (.not.found) then
    error = .true.
    return
  endif
  !
  ipnt = bytpnt(descr%addr,membyt)
  if (descr%ndim.ne.0) then
    error = .true.
    !
  elseif (descr%type.eq.fmt_r4) then
    type = fmt_r4
    call r4tor4(membyt(ipnt),value,1)
  elseif (descr%type.eq.fmt_r8) then
    type = fmt_r8
    call r8tor8(membyt(ipnt),value,1)
    !
  elseif (descr%type.eq.fmt_i4) then
    type = fmt_i8
    call i4toi8(membyt(ipnt),value,1)
  elseif (descr%type.eq.fmt_i8) then
    type = fmt_i8
    call i8toi8(membyt(ipnt),value,1)
    !
  elseif (descr%type.eq.fmt_l) then
    type = fmt_l
    call l4tol4(membyt(ipnt),value,1)
    !
  else
    error = .true.
  endif
end subroutine sic_get_auto
!
! === ARRAYS ===========================================================
!
subroutine sic_variable_getr4_0d(caller,varname,r4,error)
  use gildas_def
  use sic_interfaces, except_this=>sic_variable_getr4_0d
  !---------------------------------------------------------------------
  ! @ public-generic sic_variable_get
  !  Get a SIC variable into the r4 value
  ! ---
  !  Scalar version
  !---------------------------------------------------------------------
  character(len=*), intent(in)    :: caller   !
  character(len=*), intent(in)    :: varname  !
  real(kind=4),     intent(out)   :: r4       ! Scalar value to be filled
  logical,          intent(inout) :: error    ! Logical error flag
  ! Local
  real(kind=4) :: val(1)
  integer(kind=size_length), parameter :: one=1
  !
  call sic_variable_getr4_1d(caller,varname,val,one,error)
  if (error)  return
  r4 = val(1)
  !
end subroutine sic_variable_getr4_0d
!
subroutine sic_variable_getr4_1d(caller,varname,r4,nelem,error)
  use gbl_message
  use sic_interfaces, except_this=>sic_variable_getr4_1d
  use sic_types
  !---------------------------------------------------------------------
  ! @ public-generic sic_variable_get
  !  Get a SIC variable into the r4 value
  ! ---
  !  Flat array version
  !---------------------------------------------------------------------
  character(len=*),          intent(in)    :: caller   !
  character(len=*),          intent(in)    :: varname  !
  real(kind=4),              intent(out)   :: r4(*)    ! Flat array of values to be filled
  integer(kind=size_length), intent(in)    :: nelem    ! Number of r4 values
  logical,                   intent(inout) :: error    ! Logical error flag
  ! Local
  type(sic_descriptor_t) :: desc
  !
  call sic_variable_getdesc(caller,varname,.false.,desc,error)
  if (error)  return
  !
  call sic_descriptor_getr4(desc,r4,nelem,error)
  if (error)  return
  !
end subroutine sic_variable_getr4_1d
!
subroutine sic_variable_getr8_0d(caller,varname,r8,error)
  use gildas_def
  use sic_interfaces, except_this=>sic_variable_getr8_0d
  !---------------------------------------------------------------------
  ! @ public-generic sic_variable_get
  !  Get a SIC variable into the r8 value
  ! ---
  !  Scalar version
  !---------------------------------------------------------------------
  character(len=*), intent(in)    :: caller   !
  character(len=*), intent(in)    :: varname  !
  real(kind=8),     intent(out)   :: r8       ! Scalar value to be filled
  logical,          intent(inout) :: error    ! Logical error flag
  ! Local
  real(kind=8) :: val(1)
  integer(kind=size_length), parameter :: one=1
  !
  call sic_variable_getr8_1d(caller,varname,val,one,error)
  if (error)  return
  r8 = val(1)
  !
end subroutine sic_variable_getr8_0d
!
subroutine sic_variable_getr8_1d(caller,varname,r8,nelem,error)
  use gbl_message
  use sic_interfaces, except_this=>sic_variable_getr8_1d
  use sic_types
  !---------------------------------------------------------------------
  ! @ public-generic sic_variable_get
  !  Get a SIC variable into the r8 value
  ! ---
  !  Flat array version
  !---------------------------------------------------------------------
  character(len=*),          intent(in)    :: caller   !
  character(len=*),          intent(in)    :: varname  !
  real(kind=8),              intent(out)   :: r8(*)    ! Flat array of values to be filled
  integer(kind=size_length), intent(in)    :: nelem    ! Number of r8 values
  logical,                   intent(inout) :: error    ! Logical error flag
  ! Local
  type(sic_descriptor_t) :: desc
  !
  call sic_variable_getdesc(caller,varname,.false.,desc,error)
  if (error)  return
  !
  call sic_descriptor_getr8(desc,r8,nelem,error)
  if (error)  return
  !
end subroutine sic_variable_getr8_1d
!
!-----------------------------------------------------------------------
!
subroutine sic_descriptor_get_getnelem(desc,neleml,nelem0,ipnt0,error)
  use gildas_def
  use gbl_format
  use gbl_message
  use sic_dependencies_interfaces
  use sic_interfaces, except_this=>sic_descriptor_get_getnelem
  use sic_types
  !---------------------------------------------------------------------
  ! @ private
  !  Compute and return the number of elements and the 'ipnt' of the Sic
  ! variable described by its descriptor, and check if it is consistent
  ! with 'neleml'.
  !  Technical subroutine mostly to be used by the sic_descriptor_get*
  ! subroutines below.
  !---------------------------------------------------------------------
  type(sic_descriptor_t),       intent(in)    :: desc    !
  integer(kind=size_length),    intent(in)    :: neleml  !
  integer(kind=size_length),    intent(out)   :: nelem0  !
  integer(kind=address_length), intent(out)   :: ipnt0   !
  logical,                      intent(inout) :: error   !
  ! Global
  include 'gbl_memory.inc'
  ! Local
  character(len=*), parameter :: rname='MTH'
  character(len=message_length) :: mess
  !
  ! Convert Nwords to Nelem
  select case (desc%type)
  case (fmt_r8,fmt_i8,fmt_c4)
    nelem0 = desc%size/2
  case (fmt_r4,fmt_i4,fmt_l)
    nelem0 = desc%size
  case (fmt_un)
    call sic_message(seve%e,rname,'Data type is unknown (fmt_un)')
    error = .true.
    return
  case default
    call sic_message(seve%e,rname,'Data type not supported (4)')
    error = .true.
    return
  end select
  !
  if (nelem0.ne.neleml .and. nelem0.ne.1) then
    write(mess,'(A,I0,1X,I0)')  &
      'Mathematics on arrays of inconsistent dimensions ',nelem0,neleml
    call sic_message(seve%e,rname,mess)
    error = .true.
    return
  endif
  !
  ipnt0 = gag_pointer(desc%addr,memory)
  !
end subroutine sic_descriptor_get_getnelem
!
subroutine sic_descriptor_getr4(desc,r4,neleml,error)
  use gildas_def
  use gbl_format
  use gbl_message
  use sic_dependencies_interfaces
  use sic_interfaces, except_this=>sic_descriptor_getr4
  use sic_types
  !---------------------------------------------------------------------
  ! @ private
  !  Fill the r4(*) variable with the descriptor target values. A
  ! consistency check of the number of values is performed, and value is
  ! casted if needed to thee SIC variable type if needed.
  !---------------------------------------------------------------------
  type(sic_descriptor_t),    intent(in)    :: desc    ! The variable descriptor
  real(kind=4),              intent(out)   :: r4(*)   ! Flat array to be filled
  integer(kind=size_length), intent(in)    :: neleml  ! Number of r4 values
  logical,                   intent(inout) :: error   ! Logical error flag
  ! Global
  include 'gbl_memory.inc'
  ! Local
  character(len=*), parameter :: rname='MTH'
  integer(kind=size_length) :: nelem0
  integer(kind=address_length) :: ipnt0
  !
  ! Get appropriate and perform consistency check:
  call sic_descriptor_get_getnelem(desc,neleml,nelem0,ipnt0,error)
  if (error)  return
  !
  select case (desc%type)
  case (fmt_r4)
    if (neleml.eq.nelem0) then
      call w4tow4_sl (memory(ipnt0),r4,neleml)
    elseif (nelem0.eq.1) then
      call r4_fill(neleml,r4,memory(ipnt0))
    endif
    !
  case (fmt_r8)
    if (neleml.eq.nelem0) then
      call r8tor4_sl (memory(ipnt0),r4,neleml)
    elseif (nelem0.eq.1) then
      call r8tor4_sl (memory(ipnt0),r4,nelem0)
      call r4_fill(neleml,r4,r4(1))
    endif
    !
  case (fmt_i4)
    if (neleml.eq.nelem0) then
      call i4tor4_sl (memory(ipnt0),r4,neleml)
      if (error)  return
    elseif (nelem0.eq.1) then
      call i4tor4_sl (memory(ipnt0),r4,nelem0)
      if (error)  return
      call r4_fill (neleml,r4,r4(1))
    endif
    !
  case (fmt_i8)
    if (neleml.eq.nelem0) then
      call i8tor4_sl (memory(ipnt0),r4,neleml)
      if (error)  return
    elseif (nelem0.eq.1) then
      call i8tor4_sl (memory(ipnt0),r4,nelem0)
      if (error)  return
      call r4_fill (neleml,r4,r4(1))
    endif
    !
  case default
    call sic_message(seve%e,rname,'Result type mismatch (3)')
    error = .true.
    return
  end select
  !
end subroutine sic_descriptor_getr4
!
subroutine sic_descriptor_getr8(desc,r8,neleml,error)
  use gildas_def
  use gbl_format
  use gbl_message
  use sic_dependencies_interfaces
  use sic_interfaces, except_this=>sic_descriptor_getr8
  use sic_types
  !---------------------------------------------------------------------
  ! @ private
  !  Fill the r8(*) variable with the descriptor target values. A
  ! consistency check of the number of values is performed, and value is
  ! casted if needed to thee SIC variable type if needed.
  !---------------------------------------------------------------------
  type(sic_descriptor_t),    intent(in)    :: desc    ! The variable descriptor
  real(kind=8),              intent(out)   :: r8(*)   ! Flat array to be filled
  integer(kind=size_length), intent(in)    :: neleml  ! Number of r4 values
  logical,                   intent(inout) :: error   ! Logical error flag
  ! Global
  include 'gbl_memory.inc'
  ! Local
  character(len=*), parameter :: rname='MTH'
  integer(kind=size_length) :: nelem0
  integer(kind=address_length) :: ipnt0
  !
  ! Get appropriate and perform consistency check:
  call sic_descriptor_get_getnelem(desc,neleml,nelem0,ipnt0,error)
  if (error)  return
  !
  select case (desc%type)
  case (fmt_r4)
    if (neleml.eq.nelem0) then
      call r4tor8_sl (memory(ipnt0),r8,neleml)
    elseif (nelem0.eq.1) then
      call r4tor8_sl (memory(ipnt0),r8,nelem0)
      call r8_fill(neleml,r8,r8(1))
    endif
    !
  case (fmt_r8)
    if (neleml.eq.nelem0) then
      call w8tow8_sl (memory(ipnt0),r8,neleml)
    elseif (nelem0.eq.1) then
      call r8_fill(neleml,r8,memory(ipnt0))
    endif
    !
  case (fmt_i4)
    if (neleml.eq.nelem0) then
      call i4tor8_sl (memory(ipnt0),r8,neleml)
      if (error)  return
    elseif (nelem0.eq.1) then
      call i4tor8_sl (memory(ipnt0),r8,nelem0)
      if (error)  return
      call r8_fill (neleml,r8,r8(1))
    endif
    !
  case (fmt_i8)
    if (neleml.eq.nelem0) then
      call i8tor8_sl (memory(ipnt0),r8,neleml)
      if (error)  return
    elseif (nelem0.eq.1) then
      call i8tor8_sl (memory(ipnt0),r8,nelem0)
      if (error)  return
      call r8_fill (neleml,r8,r8(1))
    endif
    !
  case default
    call sic_message(seve%e,rname,'Result type mismatch (4)')
    error = .true.
    return
  end select
  !
end subroutine sic_descriptor_getr8
