subroutine evaluate_tree(operand,tree,last_node,max_level,min_level,result,  &
  type,err)
  use gildas_def
  use sic_dependencies_interfaces
  use sic_interfaces, except_this=>evaluate_tree
  use sic_dictionaries
  use sic_expressions
  use sic_interactions
  use sic_types
  use gbl_message
  !---------------------------------------------------------------------
  ! @ private
  ! SIC   Internal routine
  !       Transforms tree into result. Each node of the tree
  !       contains:
  !       - level of the node
  !       - code of operator
  !       - pointer to previous node
  !       - pointer to next node
  !       - number of associated operands
  !       - for each operand a pointer to operand descriptor
  !
  ! Arguments:
  !       TREE            I       Tree structure                  Input
  !       LAST_NODE       I       Pointer to last node in tree    Input
  !       MAX_LEVEL       I       Maximum parenthesis level       Input
  !       RESULT          I       Descriptor of Result            Input
  !       TYPE            I       Type of RESULT                  Output
  !       ERR             L       Logical error flag              Output
  ! Written       11-Feb-1987     T.Forveille
  !---------------------------------------------------------------------
  type(sic_descriptor_t) :: operand(0:maxoper)  ! List of operands (input)
  integer :: tree(formula_length*2)             !
  integer :: last_node                      !
  integer :: max_level                      !
  integer :: min_level                      !
  type(sic_descriptor_t) :: result          !
  integer :: type                           !
  logical :: err                            !
  ! Local
  character(len=*), parameter :: rname='MTH'
  integer :: i
  character(len=message_length) :: mess
  !
  ! Setup output descriptor
  ! The COMPLETE output descriptor must be set from 1 to 9 (STATUS)
  operand(0) = result
  call do_tree(operand,tree,last_node,max_level,min_level,type,err)
  !
  ! Free everything (in principle, no scratch status remains,
  ! except for NOP operations
  do i=1,maxoper
    if (operand(i)%status.eq.free_operand) then
      call free_vm (operand(i)%size,operand(i)%addr)
      !
    elseif (operand(i)%status.eq.scratch_operand) then
      if (.not.err) then
        write(mess,101) 'Scratch operand remaining ',i
        call sic_message(seve%w,rname,mess)
      endif
      call free_vm (operand(i)%size,operand(i)%addr)
      !
    elseif (operand(i)%status.eq.interm_operand) then
      if (operand(i)%addr.ne.operand(0)%addr) then
        if (.not.err) then
          write(mess,101) 'Lost intermediate result ',i
          call sic_message(seve%e,rname,mess)
          call sic_message(seve%e,rname,'Please submit an SPR')
        endif
        call free_vm (operand(i)%size,operand(i)%addr)
      endif
    endif
    operand(i)%status = empty_operand
  enddo
  result%type = operand(0)%type
  result%readonly = operand(0)%readonly
  !
101 format(a,i2,a)
end subroutine evaluate_tree
!
subroutine do_tree(operand,tree,last_node,max_level,min_level,type,err)
  use sic_dependencies_interfaces
  use gildas_def
  use sic_dictionaries
  use sic_expressions
  use sic_types
  use sic_interfaces, except_this=>do_tree, &
                      no_interface1=>sic_descriptor_fill_r41d, &
                      no_interface2=>sic_descriptor_fill_r81d, &
                      no_interface3=>sic_descriptor_fill_i41d, &
                      no_interface4=>sic_descriptor_fill_i81d, &
                      no_interface5=>sic_descriptor_fill_c41d, &
                      no_interface6=>sic_descriptor_fill_l1d
  use gbl_message
  use gbl_format
  !---------------------------------------------------------------------
  ! @ private
  ! SIC   Internal routine
  !       Transforms tree into result. Each node of the tree
  !       contains:
  !       - level of the node
  !       - code of operator
  !       - pointer to previous node
  !       - pointer to next node
  !       - number of associated operands
  !       - for each operand, a pointer to operand descriptor
  !
  ! Arguments:
  !       TREE            I       Tree structure                  Input
  !       LAST_NODE       I       Pointer to last node in tree    Input
  !       MAX_LEVEL       I       Maximum parenthesis level       Input
  !       TYPE            I       Type of RESULT                  Output
  !       ERR             L       Logical error flag              Output
  ! Written       11-Feb-1987     T.Forveille
  !---------------------------------------------------------------------
  type(sic_descriptor_t) :: operand(0:maxoper)  ! List of operands (input)
  integer :: tree(formula_length*2)             !
  integer :: last_node                      !
  integer :: max_level                      !
  integer :: min_level                      !
  integer :: type                           !
  logical :: err                            !
  ! Global
  include 'gbl_memory.inc'
  ! Local
  character(len=*), parameter :: rname='MTH'
  logical :: error,unknown
  integer :: level,first_node,l
  integer(kind=size_length) :: neleml,nelem0
  integer(kind=address_length) :: ipntl,ipnt0
  character(len=message_length) :: mess
  !
  ! This flag is set to .TRUE. by default, and cleared if no error occured. If
  ! an error occurs, the routine returns via the handler,
  ! and flag is not cleared.
  if (operand(0)%type.eq.fmt_un) then
    unknown = .true.
    operand(0)%type = fmt_r8
  else
    unknown = .false.
  endif
  err = .true.
  error = .false.
  first_node = 1
  level = max_level
  do while (level.gt.0)
    call execute(operand,tree,first_node,last_node,level,min_level,error)
    if (error) return
  enddo
  !
  ! A few checks on the internal logic (can be removed after extensive testing)
  if (last_node.ne.first_node) then
    call sic_message(seve%e,rname,'First node is not equal to last node')
    error = .true.
  elseif (tree(last_node+2).ne.0 .or. tree(last_node+3).ne.0) then
    error = .true.
  endif
  if (error) then
    call sic_message(seve%e,rname,'Internal logic error in EVALUATE_TREE')
    return
  endif
  l = tree(last_node+5)
  !
  ! To be checked for stupid cases :
  !       A = +1.0        A = +B
  !       A[] = 1         A[] = B[]
  !
  ipntl = gag_pointer(operand(l)%addr,memory)
  ipnt0 = gag_pointer(operand(0)%addr,memory)
  if (operand(l)%type.eq.fmt_r8 .or.  &
      operand(l)%type.eq.fmt_i8 .or.  &
      operand(l)%type.eq.fmt_c4) then
    neleml = operand(l)%size/2
  else
    neleml = operand(l)%size
  endif
  if (operand(0)%type.eq.fmt_r8 .or.  &
      operand(0)%type.eq.fmt_i8 .or.  &
      operand(0)%type.eq.fmt_c4) then
    nelem0 = operand(0)%size/2
  else
    nelem0 = operand(0)%size
  endif
  !
  if (unknown) operand(0)%type = fmt_un
  !
  if (operand(l)%addr.eq.operand(0)%addr) then
    ! Result was assigned
    !
    ! Automatic data type assignment. Note that RESULT can always accomodate
    ! a long-word (Real*8).
    if (operand(0)%type.eq.fmt_un) then
      if (operand(l)%type.eq.fmt_r4 .or. &
          operand(l)%type.eq.fmt_r8 .or. &
          operand(l)%type.eq.fmt_i4 .or.  &
          operand(l)%type.eq.fmt_l) then
        if (neleml.ne.nelem0) then
          write (mess,102) nelem0,neleml
          call sic_message(seve%e,rname,mess)
          return
        endif
      elseif (operand(l)%type.eq.fmt_i8) then
        call sic_message(seve%e,rname,'Long integers not supported (1)')
        return
      elseif (operand(l)%type.eq.fmt_c4) then
        call sic_message(seve%e,rname,'Complex not supported (1)')
        return
      else
        call sic_message(seve%e,rname,'Data type not supported (1)')
        return
      endif
      operand(0)%type = operand(l)%type
      operand(0)%readonly = operand(l)%readonly
    endif
    !
  else
    ! Result was not assigned
    if (operand(0)%type.eq.fmt_un) then
      ! Automatic data type assignment (see SIC_MATH_AUTO). Note that RESULT
      ! can always accomodate a long-word (2 4-bytes words have been
      ! reserved)
      if (operand(l)%type.eq.fmt_r4 .or.  &
          operand(l)%type.eq.fmt_r8 .or.  &
          operand(l)%type.eq.fmt_i4 .or.  &
          operand(l)%type.eq.fmt_i8 .or.  &
          operand(l)%type.eq.fmt_l) then
        if (neleml.ne.nelem0) then
          write (mess,102) nelem0,neleml
          call sic_message(seve%e,rname,mess)
          return
        endif
      elseif (operand(l)%type.eq.fmt_c4) then
        call sic_message(seve%e,rname,'Complex not supported (2)')
        return
      else
        call sic_message(seve%e,rname,'Data type not supported (2)')
        return
      endif
      operand(0)%type = operand(l)%type
      operand(0)%readonly = operand(l)%readonly
      call w4tow4_sl(memory(ipntl),memory(ipnt0),operand(l)%size)
      !
    ! Genuine non-assignment
    elseif (operand(l)%type.eq.fmt_r4) then
      call sic_descriptor_fill_r41d(operand(0),memory(ipntl),neleml,error)
      if (error)  return
      !
    elseif (operand(l)%type.eq.fmt_r8) then
      call sic_descriptor_fill_r81d(operand(0),memory(ipntl),neleml,error)
      if (error)  return
      !
    elseif (operand(l)%type.eq.fmt_i4) then
      call sic_descriptor_fill_i41d(operand(0),memory(ipntl),neleml,error)
      if (error)  return
      !
    elseif (operand(l)%type.eq.fmt_i8) then
      call sic_descriptor_fill_i81d(operand(0),memory(ipntl),neleml,error)
      if (error)  return
      !
    elseif (operand(l)%type.eq.fmt_c4) then
      call sic_descriptor_fill_c41d(operand(0),memory(ipntl),neleml,error)
      if (error)  return
      !
    elseif (operand(l)%type.eq.fmt_l) then
      call sic_descriptor_fill_l1d(operand(0),memory(ipntl),neleml,error)
      if (error)  return
      !
    else
      call sic_message(seve%e,rname,'Data type not supported (3)')
      return
    endif
    !
    if (operand(l)%status.eq.scratch_operand) operand(l)%status = free_operand
  endif
  type = tree(last_node+5)
  err  = .false.
  !
102 format('Mathematics on arrays of inconsistent dimensions ',i12,i12)
end subroutine do_tree
!
subroutine execute(operand,tree,first_node,last_node,level,min_level,error)
  use sic_interfaces, except_this=>execute
  use gildas_def
  use sic_expressions
  use sic_dictionaries
  use sic_types
  use gbl_message
  !---------------------------------------------------------------------
  ! @ private
  ! SIC   Internal routine
  !       Executes all operations at level LEVEL
  !
  ! Arguments:
  !       TREE            I       Tree structure                  Input-Output
  !       FIRST_NODE      I       Pointer to first node in tree   Input-Output
  !       LAST_NODE       I       Pointer to last node in tree    Input-Output
  !       LEVEL           I       Parenthesis level               Input-Output
  !---------------------------------------------------------------------
  type(sic_descriptor_t) :: operand(0:maxoper)  ! List of operands (input-output)
  integer                           :: tree(formula_length*2)  !
  integer                           :: first_node      !
  integer                           :: last_node       !
  integer                           :: level           !
  integer                           :: min_level       !
  logical,            intent(inout) :: error           ! Logical error flag
  ! Local
  character(len=*), parameter :: rname='MTH'
  integer :: itree,i,j,next,next_lev
  character(len=message_length) :: mess
  !
  ! Exponentiation is evaluated from right to left, while all other operations are
  ! evaluated from left to right.
  if (mod(level,10).eq.6) then
    itree = last_node
    next  = 2
  else
    itree = first_node
    next  = 3
  endif
  next_lev = 0
  !
  do while (itree.ne.0)
    !
    ! Defer evaluation for lower levels, but keep track of next level
    if (tree(itree).lt.level) then
      next_lev = max(next_lev,tree(itree))
      itree = tree(itree+next)
      ! Higher levels should already have been evaluated. This test can be removed
      ! once the program is reliable.
    elseif (tree(itree).gt.level) then
      write(mess,101) 'Level ',tree(itree),' should already have been evaluated'
      call sic_message(seve%e,rname,mess)
      goto 99
      ! This the right level
    else
      if (tree(itree+4).gt.maxoper) then
        call sic_message(seve%e,rname,'Too many operands in function call')
        goto 99
      endif
      !
      ! Optimize storage
      if (level.eq.min_level) then
        if (tree(itree+next).eq.0) then
          operand(0)%status = free_operand
        endif
      endif
      ! Actual computations
      ! print *, 'Calling DO_CALL'
      call do_call(tree(itree+1),tree(itree+4),tree(itree+5),operand,error)
      ! print *, 'Called DO_CALL'
      if (error) return
      ! Suppress node from chained list:
      ! Clears operator field as a safety (useless, but...).
      !               TREE(ITREE+1) = 0
      !               TREE(ITREE) = 0
      ! - For previous node, new next node is next node of
      !   current node.
      if (itree.ne.first_node) then
        tree(tree(itree+2)+3) = tree(itree+3)
        ! This was the first node: no previous node to update, but FIRST_NODE  changes.
      else
        if ( tree(itree+3).ne.0) then
          first_node = tree(itree+3)
        endif
      endif
      ! - For next node, new previous node is previous node of current node.
      ! This was the last node: no next node to update, but LAST_NODE changes.
      if (itree.eq.last_node) then
        ! This was not also the first one
        if ( tree(itree+2).ne.0) then
          last_node = tree(itree+2)
        endif
        ! This was not the last node. Update next one
      else
        tree(tree(itree+3)+2) = tree(itree+2)
        ! If node had two or more operators and next node had one of its operands (the
        ! first one in practice) equal to second operand of current node, replace it
        ! with first one. To be checked...
        do i=2, tree(itree+4)
          do j=1, tree(tree(itree+3)+4)
            if (tree(itree+4+i) .eq. tree(tree(itree+3)+4+j)) then
              tree(tree(itree+3)+4+j) = tree(itree+5)
            endif
          enddo
        enddo
      endif
      itree = tree(itree+next)
    endif
  enddo
  level = next_lev
  return
  !
99 call sic_message(seve%e,rname,'Internal logic error in EXECUTE')
  error = .true.
  return
  !
101 format(a,i6,a)
end subroutine execute
!
subroutine do_call(code,noper,ioper,operand,error)
  use gildas_def
  use sic_expressions
  use sic_dictionaries
  use sic_interactions
  use sic_interfaces, except_this=>do_call
  use sic_types
  use gbl_message
  use gbl_format
  !---------------------------------------------------------------------
  ! @ private
  ! SIC   Internal routine
  !       Evaluate one elementary numerical operation
  !
  ! Arguments:
  !       CODE            I       Code for operation              Input
  !       NOPER           I       Number of operands              Input
  !       IOPER           I       Pointers to operands            Input
  !       ERROR           L       Logical error flag              Output
  ! Written       11-Oct-1987     S.Guilloteau, T.Forveille
  !---------------------------------------------------------------------
  integer :: code                           !
  integer :: noper                          !
  integer :: ioper(noper)                   !
  type(sic_descriptor_t) :: operand(0:maxoper)  ! List of operands (input-output)
  logical :: error                          !
  ! Local
  character(len=*), parameter :: rname='MTH'
  integer :: kind(maxoper),i,j,precis
  type(sic_descriptor_t) :: desc
  character(len=message_length) :: mess
  !
  !!Print *,'DO_CALL ',code,noper,(operand(ioper(i))%type,i=1,noper)
  !
  ! Handle dummy nodes
  if (code.eq.code_nop) then
    do i=1,noper
      if (operand(ioper(i))%status.eq.scratch_operand)  &
        operand(ioper(i))%status = free_operand
    enddo
    return
  endif
  !
  ! Handle (some) function nodes
  if (code.eq.code_size) then
    call size_call(noper,ioper,operand,error)
    return
  else if (code.eq.code_index) then
    call index_call(noper,ioper,operand,error) !SG
    return  ! Always    SG
  endif
  !
  ! Check everything is consistent
  do i = 1,noper
    kind(i) = operand(ioper(i))%type
    if ( ((kind(1).gt.0)    .neqv.(kind(i).gt.0)) .or.  &
         ((kind(1).eq.fmt_l).neqv.(kind(i).eq.fmt_l)) ) then
      call sic_message(seve%e,rname,'Inconsistent mixture of Arithmetic, '//  &
      'Logic and Character expressions')
      write(mess,101) (kind(j),j=1,i)
      call sic_message(seve%e,rname,mess)
      error = .true.
      return
    endif
  enddo
  !
  if (kind(1).gt.0) then
    call char_call(code,noper,ioper,operand,error)
  elseif (kind(1).eq.fmt_l) then
    call logic_call(code,noper,ioper,operand,error)
  else                         ! Operation with numerical inputs
    if (code.le.code_not) then
      call sic_message(seve%e,rname,'Logical operator with numerical arguments')
      error = .true.
      return
    endif
    ! Determine precision used for intermediate result
    if (sicprecis.ne.0) then
      precis = sicprecis
    else
      call get_precis(kind,noper,precis,error)
      if (error) return
    endif
    ! Get an "incarnation" of each operand with the requested precision
    do i=1,noper
      call sic_incarnate(precis,operand(ioper(i)),desc,error)
      if (error) return        ! Not clean...
      ! Free scratch operands if they have been incarnated
      if (desc%addr.ne.operand(ioper(i))%addr) then
        call sic_volatile(operand(ioper(i)))
        operand(ioper(i)) = desc
      endif
    enddo
    call numeric_call(code,noper,ioper,operand,error)
  endif
101 format (15(i4))
end subroutine do_call
!
subroutine numeric_call(code,noper,ioper,operand,error)
  use sic_dependencies_interfaces
  use sic_interfaces, except_this=>numeric_call
  use gildas_def
  use sic_expressions
  use sic_dictionaries
  use sic_types
  use gbl_message
  use gbl_format
  !---------------------------------------------------------------------
  ! @ private
  ! SIC   Internal routine
  !       Evaluate one elementary numerical operation
  !
  ! Arguments:
  !       CODE            I       Code for operation    Input
  !       NOPER           I       Number of operands    Input
  !       IOPER           I       Pointers to operands  Input
  !       ERROR           L       Logical error flag    Output
  ! Written       11-Feb-1987     T.Forveille
  !---------------------------------------------------------------------
  integer :: code                           !
  integer :: noper                          !
  integer :: ioper(noper)                   !
  type(sic_descriptor_t) :: operand(0:maxoper)  ! List of operands (input-output)
  logical :: error                          !
  ! Global
  integer :: lsic_d_eq,lsic_s_eq,lsic_i_eq
  include 'gbl_memory.inc'
  ! Local
  character(len=*), parameter :: rname='MTH'
  integer :: i,iresul,form,rform,fcode,size
  integer(kind=size_length) :: k,dim1,dil
  integer :: isgood
  logical :: lop
  integer(kind=address_length) :: ipnt1,ipnt2,ipntr,ipntf
  character(len=message_length) :: mess
  !
  ! Static storage ?
  save ipnt1,ipnt2,ipntr,ipntf
  !
  ! Get the format of operations (FORM)
  if (operand(ioper(1))%type.eq.fmt_r4) then
    fcode = 0
    form = fmt_r4
    size = 1
  elseif (operand(ioper(1))%type.eq.fmt_r8) then
    fcode = 1
    form = fmt_r8
    size = 2
  elseif (operand(ioper(1))%type.eq.fmt_i8) then
    fcode = 2
    form = fmt_i8
    size = 2
  else
    call sic_message(seve%e,rname,'Internal error: unsupported precision')
    error = .true.
    return
  endif
  !
  ! Get the format of result (RFORM)
  dil = 0
  rform = form
  if (code.ge.code_ne .and. code.le.code_gt) then
    rform = fmt_l
    if (code.eq.code_ne .or. code.eq.code_eq)  dil = operand(0)%size
  endif
  !
  if (dil.eq.1) then
    !
    ! Check identity of two arrays
    dim1 = operand(ioper(1))%size
    if ( dim1.ne.operand(ioper(2))%size ) then
      call sic_message(seve%e,rname,'Comparing arrays of inconsistent '//  &
      'dimensions')
      error = .true.
      return
    endif
    !
    ! Allocate, compute and assign result
    call get_resu (rform,dil,noper,ioper,operand,iresul,error)
    if (error) return
    ipnt1 = gag_pointer(operand(ioper(1))%addr,memory)
    ipnt2 = gag_pointer(operand(ioper(2))%addr,memory)
    if (form.eq.fmt_r8) then
      dim1 = dim1/2
      isgood = lsic_d_eq (dil,lop,dim1,memory(ipnt1),dim1,memory(ipnt2))
    elseif (form.eq.fmt_r4) then
      isgood = lsic_s_eq (dil,lop,dim1,memory(ipnt1),dim1,memory(ipnt2))
    elseif (form.eq.fmt_i8) then
      dim1 = dim1/2
      isgood = lsic_i_eq (dil,lop,dim1,memory(ipnt1),dim1,memory(ipnt2))
    endif
    if (code.eq.code_ne) lop = .not.lop
    ipntr = gag_pointer(operand(iresul)%addr,memory)
    call l4tol4_sl(lop,memory(ipntr),dil)
    !
  else
    !
    ! True arithmetic or element by element logic
    !
    ! Check size
    dim1 = 1
    do i=1,noper
      k = operand(ioper(i))%size/size
      if (k.ne.dim1) then
        if (k.ne.1 .and. dim1.ne.1) then
          write(mess,*) 'Mathematics on arrays of inconsistent dimensions ',  &
          k,dim1
          call sic_message(seve%e,rname,mess)
          error = .true.
          return
        elseif (k.ne.1) then
          dim1 = k
        endif
      endif
    enddo
    !
    ! Allocate the result (with RFORM format)
    call get_resu (rform,dim1,noper,ioper,operand,iresul,error)
    if (error) return
    !
    ! Compute the result (with FORM arithmetic)
    ! Could use the HPUX/CONVEX code for all cases
    ipntf = bytpnt(addr_function(100*fcode+code),membyt)
    if (code.le.code_scalar) then
      call do_vector (membyt(ipntf),form,dim1,iresul,noper,ioper,operand,  &
      code,error)
    else
      call do_scalar (membyt(ipntf),form,dim1,iresul,noper,ioper,operand,error)
    endif
  endif
  ! print *,'Format ',RFORM,operand(iresul)%type,IRESUL
  !
  ! Free scratch operands & move result to next node (note use
  ! of RFORM, the Result format...)
  call free_oper (rform,dim1,noper,ioper,operand,iresul,error)
end subroutine numeric_call
!
subroutine logic_call(code,noper,ioper,operand,error)
  use sic_dependencies_interfaces
  use sic_interfaces, except_this=>logic_call
  use gildas_def
  use sic_expressions
  use sic_dictionaries
  use sic_types
  use gbl_message
  use gbl_format
  !---------------------------------------------------------------------
  ! @ private
  ! SIC   Internal routine
  !       Evaluate one elementary logical operation
  !
  ! Arguments:
  !       CODE            I       Code for operation              Input
  !       NOPER           I       Number of operands              Input
  !       IOPER           I       Pointers to operands            Input
  !       ERROR           L       Logical error flag              Output
  ! Written       11-Feb-1987     T.Forveille
  !---------------------------------------------------------------------
  integer :: code                           !
  integer :: noper                          !
  integer :: ioper(noper)                   !
  type(sic_descriptor_t) :: operand(0:maxoper)  ! List of operands (input-output)
  logical :: error                          !
  ! Global
  integer :: lsic_l_not,lsic_l_or,lsic_l_and,lsic_l_eq,lsic_l_ne,lsic_l_exist
  include 'gbl_memory.inc'
  ! Local
  character(len=*), parameter :: rname='MTH'
  integer(kind=address_length) :: ipnt1,ipnt2,ipntr
  integer :: iresul,form,isgood,i
  integer(kind=size_length) :: dimr,dim1,k
  character(len=message_length) :: mess
  !
  ! Check for arithmetic operators
  if ( (code.gt.code_eq.or.code.lt.code_nop) .and.  &
       (code.ne.code_exist)                  .and.  &
       (code.ne.code_file)                   .and.  &
       (code.ne.code_function)               .and.  &
       (code.ne.code_all)                    .and.  &
       (code.ne.code_any)                    .and.  &
       (code.ne.code_isnan)                  .and.  &
       (code.ne.code_isnum)                  .and.  &
       (code.ne.code_symbol)  )   then
    write(mess,'(A,I6)') 'Attempted operation is not allowed on logical '//  &
    'operands for operator ',code
    call sic_message(seve%e,rname,mess)
    error = .true.
    return
  endif
  !
  ! Check size
  dimr = 1
  do i=1,noper
    k = operand(ioper(i))%size
    if (k.ne.dimr) then
      if (k.ne.1 .and. dimr.ne.1) then
        write (mess,'(A,I3,I3)') 'Mathematics on arrays of inconsistent '//  &
        'dimensions ',k,dimr
        call sic_message(seve%e,rname,mess)
        error = .true.
        return
      elseif (k.ne.1) then
        dimr = k
      endif
    endif
  enddo
  !
  ! Allocate result
  form = fmt_l
  call get_resu (form,dimr,noper,ioper,operand,iresul,error)
  if (error) return
  ipnt1 = gag_pointer(operand(ioper(1))%addr,memory)
  ipntr = gag_pointer(operand(iresul)%addr,memory)
  !
  ! Now compute
  if (code.eq.code_not) then
    if (noper.ne.1) goto 99
    isgood = lsic_l_not (dimr,memory(ipntr),operand(ioper(1))%size,memory(ipnt1))
  elseif (code.eq.code_exist .or.  &
          code.eq.code_file  .or.  &
          code.eq.code_function  .or.  &
          code.eq.code_all   .or.  &
          code.eq.code_any   .or.  &
          code.eq.code_isnum .or.  &
          code.eq.code_isnan .or.  &
          code.eq.code_symbol) then
    ! Just copy the result of the Logical test operation (YES or NO)
    ! to destination...
    dim1 = 1
    isgood = lsic_l_exist (dimr,memory(ipntr),dim1,memory(ipnt1) )
  elseif (code.ge.code_or) then
    !!print *, 'Calling COMPARE operation'
    !!print *,'Operands ',operand(ioper(1))%type,operand(ioper(2))%type,fmt_l
    if (noper.ne.2) goto 99
    ipnt2 = gag_pointer(operand(ioper(2))%addr,memory)
    if (code.eq.code_or) then
      isgood = lsic_l_or (dimr,memory(ipntr),  &
          operand(ioper(1))%size,memory(ipnt1),  &
          operand(ioper(2))%size,memory(ipnt2))
    elseif (code.eq.code_and) then
      isgood = lsic_l_and (dimr,memory(ipntr),  &
          operand(ioper(1))%size,memory(ipnt1),  &
          operand(ioper(2))%size,memory(ipnt2))
    elseif (code.eq.code_ne) then
      isgood = lsic_l_ne (dimr,memory(ipntr),  &
          operand(ioper(1))%size,memory(ipnt1),  &
          operand(ioper(2))%size,memory(ipnt2))
    elseif (code.eq.code_eq) then
      isgood = lsic_l_eq (dimr,memory(ipntr),  &
          operand(ioper(1))%size,memory(ipnt1),  &
          operand(ioper(2))%size,memory(ipnt2))
    else
      goto 99
    endif
    ! print *, 'Done COMPARE operation '
  endif
  !
  ! Free scratch operands
  ! print *, 'Freeing operand'
  call free_oper(form,dimr,noper,ioper,operand,iresul,error)
  ! print *, 'Done Freeing operand'
  return
  !
99 call sic_message(seve%e,rname,'Internal logic error in LOGIC_CALL')
  error = .true.
end subroutine logic_call
!
subroutine char_call(code,noper,ioper,operand,error)
  use sic_dependencies_interfaces
  use sic_interfaces, except_this=>char_call
  use gildas_def
  use sic_expressions
  use sic_dictionaries
  use sic_types
  use gbl_message
  use gbl_format
  !---------------------------------------------------------------------
  ! @ private
  ! SIC   Internal routine
  !       Evaluate one elementary character operation
  !
  ! Arguments:
  !       CODE            I       Code for operation              Input
  !       NOPER           I       Number of operands              Input
  !       IOPER           I       Pointers to operands            Input
  !       ERROR           L       Logical error flag              Output
  ! Written       11-Feb-1987     T.Forveille
  !---------------------------------------------------------------------
  integer :: code                           !
  integer :: noper                          !
  integer :: ioper(noper)                   !
  type(sic_descriptor_t) :: operand(0:maxoper)  ! List of operands (input-output)
  logical :: error                          !
  ! Global
  include 'gbl_memory.inc'
  ! Local
  character(len=*), parameter :: rname='MTH'
  integer :: iresul,form,i,len1,len2
  integer(kind=size_length) :: dimo(2),dimr,k
  integer(kind=address_length) :: addr1,addr2,ipntr
  logical :: lop
  character(len=message_length) :: mess
  character(len=1024) :: local_line1,local_line2
  !
  ! Check for forbidden operators. Function LEN could be added one day.
  if (code.ne.code_eq .and. code.ne.code_ne) then
    write(mess,'(A,I6)') 'Attempted operation is not allowed on character '//  &
    'operands for operator ',code
    call sic_message(seve%e,rname,mess)
    error = .true.
    return
  endif
  if (noper.ne.2) goto 99
  !
  ! Check size
  dimr = 1  ! Dimension of result
  do i=1,noper
    ! Compute dimension of operands and thus of result. Can not use %size
    ! for the number of elements in array. Recompute them...
    dimo(i) = desc_nelem(operand(ioper(i)))
    if (dimo(i).ne.dimr) then
      if (dimo(i).ne.1 .and. dimr.ne.1) then
        write (mess,'(A,I3,I3)') 'Mathematics on arrays of inconsistent '//  &
        'dimensions ',dimo(i),dimr
        call sic_message(seve%e,rname,mess)
        error = .true.
        return
      elseif (dimo(i).ne.1) then
        dimr = dimo(i)
      endif
    endif
  enddo
  !
  ! Get work space for result
  form = fmt_l
  call get_resu (form,dimr,noper,ioper,operand,iresul,error)
  if (error) return
  !
  len1 = operand(ioper(1))%type
  addr1 = operand(ioper(1))%addr
  len2 = operand(ioper(2))%type
  addr2 = operand(ioper(2))%addr
  ipntr = gag_pointer(operand(iresul)%addr,memory)
  !
  do k=1,dimr
    ! Compute result. Using destoc is probably a huge waste of time
    call destoc(len1,addr1,local_line1)
    call destoc(len2,addr2,local_line2)
    lop = local_line1.eq.local_line2
    if (code.eq.code_ne) lop = .not.lop
    !
    ! Assign to result
    call l4tol4(lop,memory(ipntr),1)
    !
    ! Next element
    if (dimo(1).ne.1) addr1 = addr1+len1
    if (dimo(2).ne.1) addr2 = addr2+len2
    ipntr = ipntr+1  ! Next element in output logical array
  enddo
  !
  ! Free scratch operands
  call free_oper (form,dimr,noper,ioper,operand,iresul,error)
  return
  !
99 call sic_message(seve%e,rname,'Internal logic error in CHAR_CALL')
  error = .true.
end subroutine char_call
!
subroutine size_call(noper,ioper,operand,error)
  use gbl_format
  use gbl_message
  use sic_dependencies_interfaces
  use sic_interfaces, except_this=>size_call
  use sic_expressions
  use sic_types
  !---------------------------------------------------------------------
  ! @ private
  !  Support routine for function SIZE(Var,Dim)
  !---------------------------------------------------------------------
  integer(kind=4),        intent(in)    :: noper               ! Number of operators involved
  integer(kind=4),        intent(in)    :: ioper(noper)        ! Pointers to operands
  type(sic_descriptor_t), intent(inout) :: operand(0:maxoper)  !
  logical,                intent(inout) :: error               ! Logical error flag
  ! Global
  include 'gbl_memory.inc'
  ! Local
  integer(kind=4) :: idime,iresul
  integer(kind=size_length), parameter :: one=1
  integer(kind=8) :: value
  integer(kind=address_length) :: ipntr
  !
  ! Foreword: result should be actually integer(kind=size_length) or
  ! integer(kind=index_length), but using integer(kind=8) simplifies
  ! the code.
  !
  ! --- Compute result BEFORE dealing with operands ---
  !
  if (noper.eq.1) then  ! SIZE(VAR)
    ! Return the total number of elements
    value = desc_nelem(operand(ioper(1)))
  else                  ! SIZE(VAR,IDIM)
    ! Get dimension number. Check this operand is scalar!
    if (desc_nelem(operand(ioper(2))).gt.1) then
      call sic_message(seve%e,'SIZE','Dimension operand must be scalar')
      error = .true.
      return
    endif
    call sic_descriptor_getval(operand(ioper(2)),one,idime,error)
    if (error)  return
    ! Number of elements along this dimension
    if (idime.ge.1 .and. idime.le.operand(ioper(1))%ndim) then
      value = operand(ioper(1))%dims(idime)
    else
      value = 0
    endif
  endif
  ! NB: other number of operators already checked and rejected
  !
  ! --- Now save the result ---
  !
  ! Find a place to save the result
  call get_resu(fmt_i8,one,noper,ioper,operand,iresul,error)
  if (error)  return
  !
  ! Copy at correct memory location
  ipntr = gag_pointer(operand(iresul)%addr,memory)
  call i8toi8(value,memory(ipntr),1)
  !
  ! Free scratch operands & move result to next node (note use
  ! of RFORM, the Result format...)
  call free_oper(fmt_i8,one,noper,ioper,operand,iresul,error)
  !
end subroutine size_call
!
subroutine index_call(noper,ioper,operand,error)
  use gbl_format
  use gbl_message
  use sic_dependencies_interfaces
  use sic_interfaces, except_this=>index_call
  use sic_expressions
  use sic_types
  !---------------------------------------------------------------------
  ! @ private
  !  Support routine for function INDEX(String,SubStr)
  !---------------------------------------------------------------------
  integer(kind=4),        intent(in)    :: noper               ! Number of operators involved
  integer(kind=4),        intent(in)    :: ioper(noper)        ! Pointers to operands
  type(sic_descriptor_t), intent(inout) :: operand(0:maxoper)  !
  logical,                intent(inout) :: error               ! Logical error flag
  ! Global
  include 'gbl_memory.inc' 
  ! Local
  integer(kind=4) :: iresul
  integer(kind=size_length), parameter :: one=1
  integer(kind=8) :: value
  integer(kind=address_length) :: ipntr, addr1, addr2
  integer :: len1, len2
  character(len=1024) :: local_line1
  character(len=128) :: local_line2
  !
  ! Foreword: result should be actually integer(kind=size_length) or
  ! integer(kind=index_length), but using integer(kind=8) simplifies
  ! the code.
  !
  ! --- Compute result BEFORE dealing with operands ---
  !
  len1 = operand(ioper(1))%type
  addr1 = operand(ioper(1))%addr
  len2 = operand(ioper(2))%type
  addr2 = operand(ioper(2))%addr
  !
  ! Compute result. Using destoc is probably a huge waste of time
  call destoc(len1,addr1,local_line1)
  call destoc(len2,addr2,local_line2)
  value = index(local_line1(1:len1),local_line2(1:len2))
  ! NB: other number of operators already checked and rejected
  !
  ! --- Now save the result ---
  !
  ! Find a place to save the result
  call get_resu(fmt_i8,one,noper,ioper,operand,iresul,error)
  if (error)  return
  !
  ! Copy at correct memory location
  ipntr = gag_pointer(operand(iresul)%addr,memory)
  call i8toi8(value,memory(ipntr),1)
  !
  ! Free scratch operands & move result to next node (note use
  ! of RFORM, the Result format...)
  call free_oper(fmt_i8,one,noper,ioper,operand,iresul,error)
  !
end subroutine index_call
!
subroutine get_precis(kind,noper,precis,error)
  use sic_interfaces, except_this=>get_precis
  use sic_expressions
  use gbl_format
  !---------------------------------------------------------------------
  ! @ private
  !  Determine automatically the precision (format) of elementary
  ! operation result from format of input operands.
  !
  !  fmt_i8 NOT returned in automatic precision (on purpose) because
  ! of the roundings it provides (not suited for scientific
  ! computations)
  !---------------------------------------------------------------------
  integer(kind=4), intent(in)    :: noper        ! Number of operands
  integer(kind=4), intent(in)    :: kind(noper)  ! Format of input operands
  integer(kind=4), intent(out)   :: precis       ! Format of operation results
  logical,         intent(inout) :: error        ! Logical error flag
  ! Local
  integer :: i,dokind
  logical :: dodouble
  !
  ! I*4 < I*8
  !  /\    /\
  ! R*4 < R*8
  !  /\    /\
  ! C*4 < C*8
  !
  dokind = 1  ! 1=inte, 2=float, 3=complex
  dodouble = .false.
  !
  do i=1,noper
    !
    ! Single or double , short or long?
    if (kind(i).eq.fmt_r8 .or.  &
        kind(i).eq.fmt_i8 .or.  &
        kind(i).eq.fmt_c8)      &
      dodouble = .true.
    !
    if (dokind.eq.3)  cycle
    !
    ! Go to floating point computations?
    if (kind(i).eq.fmt_r4.or.kind(i).eq.fmt_r8)  dokind = 2
    if (kind(i).eq.fmt_c4.or.kind(i).eq.fmt_c8)  dokind = 3
    !
  enddo
  !
  if (dokind.eq.1) then  ! Integers
    ! Always use R*8 precision. There is enough precision for I*4 computations,
    ! but not for (large) I*8. Let us live with this for now.
    ! Note that we can not go to I*8 computations as the Sic functions are
    ! not expected to return a float when an integer is given as input (think
    ! about sqrt(2) and look at lsic_i_sqrt where all input and output operands
    ! are integers). This would require refurbishing the whole code...
    precis = fmt_r8
    !
  elseif (dokind.eq.2) then  ! Floats
    if (dodouble) then
      precis = fmt_r8
    else
      precis = fmt_r4
    endif
    !
  elseif (dokind.eq.3) then  ! Complex
    if (dodouble) then
      precis = fmt_c8
    else
      precis = fmt_c4
    endif
  endif
  !
end subroutine get_precis
