!-----------------------------------------------------------------------
! Support file to decode a list of number from the following format
!    (chain =) n1 n2 n3 to n4 n5 n6 n7 to n8 by n9
! The list will include
!    n1,n2, n3,n3+1,...,n4, n5, n6,n6+n9,n6+2*n9,...,n8
! There are 3 flavors of the subroutine:
!  - sic_parse_listi4, which returns a list of integer*4
!  - sic_parse_listi8, which returns a list of integer*8
!  - sic_parse_listr8, which returns a list of real*8
! Two have slightly diverged, it would be nice to merge them again.
!-----------------------------------------------------------------------
subroutine sic_parse_listi4(rname,chain,l4,mlist,error)
  use gbl_message
  use sic_dependencies_interfaces
  use sic_interfaces, except_this=>sic_parse_listi4
  use sic_types
  !----------------------------------------------------------------------
  ! @ public
  !  Decode a list as integer*4 values
  !----------------------------------------------------------------------
  character(len=*),   intent(in)    :: rname  ! Procedure name
  character(len=*),   intent(in)    :: chain  ! Input line to be decoded
  type(sic_listi4_t), intent(inout) :: l4     ! The lists
  integer(kind=4),    intent(in)    :: mlist  ! Maximum number of lists
  logical,            intent(inout) :: error  ! Logical error flag
  ! Local
  type(sic_listi8_t) :: l8
  !
  call sic_parse_listi8(rname,chain,l8,mlist,error)
  if (error .or. l8%nlist.eq.0)  return
  !
  call sic_allocate_listi4(l4,mlist,error)
  if (error)  return
  !
  ! Copy 'l8' into 'l4'
  l4%nlist = l8%nlist
  call i8toi4_fini(l8%i1,l4%i1,l4%nlist,error)
  if (error)  return
  call i8toi4_fini(l8%i2,l4%i2,l4%nlist,error)
  if (error)  return
  call i8toi4_fini(l8%i3,l4%i3,l4%nlist,error)
  if (error)  return
  !
end subroutine sic_parse_listi4
!
subroutine sic_parse_listi8(rname,chain,l,mlist,error)
  use gbl_message
  use sic_dependencies_interfaces
  use sic_interfaces, except_this=>sic_parse_listi8
  use sic_types
  !----------------------------------------------------------------------
  ! @ public
  !  Decode a list as integer*8 values
  !----------------------------------------------------------------------
  character(len=*),   intent(in)    :: rname  ! Procedure name
  character(len=*),   intent(in)    :: chain  ! Input line to be decoded
  type(sic_listi8_t), intent(inout) :: l      ! The lists
  integer(kind=4),    intent(in)    :: mlist  ! Maximum number of lists
  logical,            intent(inout) :: error  ! Logical error flag
  ! Local
  character(len=20) :: par
  integer(kind=4) :: j,long, next, lpar
  integer(kind=8) :: i8
  character(len=message_length) :: mess
  !
  call sic_allocate_listi8(l,mlist,error)
  if (error)  return
  !
  j=0
  l%nlist=0
  long=lenc(chain)
  if (long.eq.0) then
     goto 30
  else
     next=1
     call sic_next(chain,par,lpar,next)
     goto 20
  endif
  !
  ! Is the decoding finished ?
10 continue
  if (next.gt.long) goto 30
  call sic_next(chain(next:),par,lpar,next)
  !
  ! Increment the loop counter and decode the next loop parameters
20 continue
  j=j+1
  if (j.gt.l%mlist) then
     write(mess,'(A,I0,A)')  'Too many loops (max ',l%mlist,' allowed)'
     call sic_message(seve%e,rname,mess)
     l%nlist = l%mlist
     error = .true.
     return
  endif
  !
  ! First parameter
  call sic_math_long(par,lpar,i8,error)
  if (error) goto 100
  l%i1(j) = i8
  l%i2(j) = l%i1(j)
  l%i3(j) = 1_8
  !
  ! Is there a second parameter
  if (next.gt.long) goto 10
  call sic_next(chain(next:),par,lpar,next)
  call sic_upper(par(1:lpar))
  !
  ! If so, what is its numerical value
  if (par(1:lpar).eq.'TO') then
     if (next.gt.long) goto 110
     call sic_next(chain(next:),par,lpar,next)
     call sic_math_long(par,lpar,i8,error)
     if (error) goto 100
     l%i2(j) = i8
     !
     ! Value of increment (default=1)
     if (next.gt.long) goto 10
     call sic_next(chain(next:),par,lpar,next)
     call sic_upper(par(1:lpar))
     if (par(1:lpar).eq.'BY') then
        if (next.gt.long) goto 110
        call sic_next(chain(next:),par,lpar,next)
        call sic_math_long(par,lpar,i8,error)
        if (error) goto 100
        l%i3(j) = i8
        goto 10
     endif
  endif
  goto 20
  !
  ! End of processing
30 continue
  l%nlist=j
  if (l%nlist.eq.0) then
     call sic_message(seve%e,rname,'Empty list')
     error=.true.
  else
     !
     ! Are the loops meaningfull ?
     do j=1,l%nlist
        if (l%i3(j).eq.0_8 .or. (l%i2(j)-l%i1(j))*l%i3(j).lt.0_8) then
           call sic_message(seve%e,rname,'Invalid list :')
           write (6,103) l%i1(j),l%i2(j),l%i3(j)
           error=.true.
           return
        endif
     enddo
  endif
  return
  !
100 continue
  call sic_message(seve%e,rname,'Syntax error in list :')
  write (6,102) chain(1:min(next,long))
  error = .true.
  return
  !
110 continue
  call sic_message(seve%e,rname,'Incomplete list :')
  write (6,104) chain(1:min(next,long))
  error = .true.
  return
  !
102 format(t12,a,'...')
103 format(t10,i6,' TO ',i6,' BY ',i6)
104 format(t10,a,' !!')
end subroutine sic_parse_listi8
!
subroutine sic_parse_listr8(rname,chain,l,mlist,error)
  use gbl_message
  use sic_dependencies_interfaces
  use sic_interfaces, except_this=>sic_parse_listr8
  use sic_types
  !----------------------------------------------------------------------
  ! @ public
  !  Decode a list as real*8 values
  !----------------------------------------------------------------------
  character(len=*),   intent(in)    :: rname  ! Procedure name
  character(len=*),   intent(in)    :: chain  ! Input line to be decoded
  type(sic_listr8_t), intent(inout) :: l      ! The lists
  integer(kind=4),    intent(in)    :: mlist  ! Maximum number of lists
  logical,            intent(inout) :: error  ! Logical error flag
  ! Local
  integer(kind=4) :: j,long,next,lpar,length
  real(kind=8) :: dble
  character(len=132) :: par,argum
  character(len=message_length) :: mess
  logical :: readnext
  !
  call sic_allocate_listr8(l,mlist,error)
  if (error)  return
  !
  j = 0
  l%nlist = 0
  long = len_trim(chain)
  next = 1
  readnext = .true.
  !
  do
    if (readnext) then
       if (next.gt.long)  exit  ! while loop
       call sic_next(chain(next:),par,lpar,next)
    endif
    !
    ! Increment the loop counter and decode the next loop parameters
    j=j+1
    if (j.gt.l%mlist)  goto 105
    !
    ! First parameter
    call sic_shape(argum,par,1,lpar,length,error)
    par = argum
    lpar = length
    call sic_math_dble(par,lpar,dble,error)
    if (error) goto 100
    !
    l%r1(j) = dble
    l%r2(j) = l%r1(j)
    l%r3(j) = 0.d0  ! Make Zero the default...
    !
    ! Is there a second parameter?
    if (next.gt.long)  exit  ! while loop
    call sic_next(chain(next:),par,lpar,next)
    readnext = .false.
    !
    ! If so, what is its numerical value
    call sic_upper(par)
    if (par(1:lpar).ne.'TO')  cycle
    !
    ! 'TO' was found, expect the upper limit
    if (next.gt.long) goto 110
    call sic_next(chain(next:),par,lpar,next)
    call sic_shape(argum,par,1,lpar,length,error)
    par = argum
    lpar = length
    call sic_math_dble(par,lpar,dble,error)
    if (error) goto 100
    l%r2(j) = dble
    !
    ! Value of increment
    if (next.gt.long)  exit  ! while loop
    call sic_next(chain(next:),par,lpar,next)
    !
    call sic_upper(par)
    if (par(1:lpar).ne.'BY')  cycle
    !
    ! 'BY' was found, expect the increment
    if (next.gt.long) goto 110
    call sic_next (chain(next:),par,lpar,next)
    call sic_shape(argum,par,1,lpar,length,error)
    par = argum
    lpar = length
    call sic_math_dble(par,lpar,dble,error)
    if (error) goto 100
    if (dble.eq.0.d0) then
      call sic_message(seve%e,rname,'Invalid loop :')
      write(mess,103) l%r1(j),l%r2(j),dble
      call sic_message(seve%e,rname,mess)
      error=.true.
      return
    endif
    l%r3(j) = dble
    readnext = .true.
    !
  end do
  !
  ! End of processing
  l%nlist = j
  if (l%nlist.eq.0) then
    call sic_message(seve%e,rname,'Empty list')
    error=.true.
    return
  endif
  !
  ! Are the loops meaningfull ?
  do j=1,l%nlist
    if (l%r3(j).eq.0.0d0) then
      ! It has not been specified by user:
      ! set if to something meaningful if l%r2(J) = l%r1(J)
      if (l%r2(j).eq.l%r1(j)) then
        l%r3(j) = max(1.0d0,abs(l%r1(j)))  ! set it to 1 by default...
        cycle  ! No need to check precision
      elseif (l%r2(j).gt.l%r1(j)) then
        l%r3(j) = 1.0d0
      else  ! l%r2 < l%r1
        ! Loop is meaningless, leave to zero (do not execute)
        cycle  ! No more check
      endif
    endif
    !
    if (l%r1(j)+l%r3(j).eq.l%r1(j) .or. l%r2(j)+l%r3(j).eq.l%r2(j)) then
      ! Avoid infinite loops
      call sic_message(seve%e,rname,  &
        'Invalid loop (increment lower than precision):')
      write(mess,103) l%r1(j),l%r2(j),l%r3(j)
      call sic_message(seve%e,rname,mess)
      error=.true.
      return
      !
    elseif ((l%r2(j)-l%r1(j))*l%r3(j).lt.0.d0) then
      ! Increment has wrong sign for given range
      l%r3(j) = 0.0d0            ! Do not execute loop
    endif
  enddo
  !
  return
  !
100 call sic_message(seve%e,rname,'Syntax error in list :')
  write(mess,102) chain(1:min(next,long))
  call sic_message(seve%e,rname,mess)
  error = .true.
  return
  !
105 write(mess,'(A,I0,A)')  'Too many loops (max ',l%mlist,' allowed)'
  call sic_message(seve%e,rname,mess)
  l%nlist = l%mlist
  error = .true.
  return
  !
110 call sic_message(seve%e,rname,'Incomplete list :')
  write(mess,104) chain(1:min(next,long))
  call sic_message(seve%e,rname,mess)
  error = .true.
  return
  !
102 format(a,'...')
103 format(1pg13.6,' TO',1pg13.6,' BY',1pg13.6)
104 format(a,' !!')
end subroutine sic_parse_listr8
!
subroutine sic_build_listr4(levels,nlev,mlev,chain,rname,error)
  use gbl_message
  use sic_interfaces, except_this=>sic_build_listr4
  use sic_types
  !---------------------------------------------------------------------
  ! @ public
  !  Decode a list of numbers in the following format
  !    (CHAIN =) n1 n2 n3 TO n4 n5 n6 n7 TO n8 BY n9
  !  The list will contain
  !    n1,n2, n3,n3+1,...,n4, n5, n6,n6+n9,n6+2*n9,...,n7
  !---------------------------------------------------------------------
  integer(kind=4),  intent(in)    :: mlev          ! Size of levels array
  real(kind=4),     intent(out)   :: levels(mlev)  ! Array to receive the list of values
  integer(kind=4),  intent(out)   :: nlev          ! Number of values
  character(len=*), intent(in)    :: chain         ! Input line to be decoded
  character(len=*), intent(in)    :: rname         ! Procedure name
  logical,          intent(inout) :: error         ! Logical error flag
  ! Local
  integer(kind=4), parameter :: mlist=40
  type(sic_listr8_t) :: l
  real(kind=8) :: rr
  integer(kind=4) :: i
  character(len=message_length) :: mess
  !
  nlev = 0  ! In case of error
  !
  call sic_parse_listr8(rname,chain,l,mlist,error)
  if (error) return
  !
  do i=1,l%nlist
    if (l%r3(i).eq.0d0)  cycle  ! Means do not execute loop
    !
    rr = l%r1(i)
    if (l%r3(i).gt.0d0) then
      do while (rr.le.l%r2(i))
        nlev=nlev+1
        levels(nlev)=rr
        if (nlev.ge.mlev) goto 10
        rr = rr+l%r3(i)
      enddo
    else
      do while (rr.ge.l%r2(i))
        nlev=nlev+1
        levels(nlev)=rr
        if (nlev.ge.mlev) goto 10
        rr = rr+l%r3(i)
      enddo
    endif
    !
  enddo
  return
  !
10 continue
  write(mess,'(A,I0,A)')  'List too long, truncated to ',nlev,' values'
  call sic_message(seve%w,rname,mess)
end subroutine sic_build_listr4
!
subroutine sic_build_listi4 (level,nlev,mlev,chain,rname,error)
  use gbl_message
  use sic_interfaces, except_this=>sic_build_listi4
  use sic_types
  !---------------------------------------------------------------------
  ! @ public
  !  Decode a list of numbers in the following format
  !    (CHAIN =) n1 n2 n3 TO n4 n5 n6 n7 TO n8 BY n9
  !  The list will contain
  !    n1,n2, n3,n3+1,...,n4, n5, n6,n6+n9,n6+2*n9,...,n7
  !---------------------------------------------------------------------
  integer(kind=4),  intent(in)    :: mlev         ! Size of LEVEL array
  integer(kind=4),  intent(out)   :: level(mlev)  ! Array to receive the list of values
  integer(kind=4),  intent(out)   :: nlev         ! Number of values
  character(len=*), intent(in)    :: chain        ! String to be decoded
  character(len=*), intent(in)    :: rname        ! Header of message
  logical,          intent(inout) :: error        ! Logical error flag
  ! Local
  integer(kind=4), parameter :: mlist=15
  type(sic_listi4_t) :: l
  integer(kind=4) :: i,rr
  character(len=message_length) :: mess
  !
  nlev = 0  ! In case of error
  !
  call sic_parse_listi4(rname,chain,l,mlist,error)
  if (error) return
  !
  do i=1,l%nlist
    if (l%i3(i).eq.0)  cycle  ! Means do not execute loop
    !
    do rr=l%i1(i),l%i2(i),l%i3(i)
      nlev = nlev+1
      level(nlev) = rr
      if (nlev.ge.mlev) goto 10
    enddo
    !
  enddo
  return
  !
10 continue
  write(mess,'(A,I0,A)')  'List too long, truncated to ',nlev,' values'
  call sic_message(seve%w,rname,mess)
end subroutine sic_build_listi4
!
subroutine list2(l,k,r,error)
  use gbl_message
  use sic_interfaces, except_this=>list2
  use sic_types
  !---------------------------------------------------------------------
  ! @ private
  !  Execute a set of loops defined by sic_parse_listr8
  !       R               Current value
  !       K               Current loop number
  !---------------------------------------------------------------------
  type(sic_listr8_t), intent(in)    :: l      !
  integer(kind=4),    intent(inout) :: k      !
  real(kind=8),       intent(inout) :: r      !
  logical,            intent(out)   :: error  !
  ! Local
  integer(kind=4) :: i
  character(len=message_length) :: mess
  !
  error = .false.
  if (k.lt.0 .or. k.gt.l%nlist) then
    write(mess,'(A,I3,I3)') 'Internal logic error',k,l%nlist
    call sic_message(seve%e,'LIST2',mess)
    error = .true.
    return
  endif
  if (k.ne.0) then
    r = r + l%r3(k)
    if (l%r3(k).gt.0.d0) then
      if (r.le.(l%r2(k)+1.d-8*l%r3(k))) return
    else
      if (r.ge.(l%r2(k)+1.d-8*l%r3(k))) return
    endif
  endif
  do i=k+1,l%nlist
    if (l%r3(i).ne.0.d0) then
      k = i
      r = l%r1(k)
      return
    endif
  enddo
  error = .true.
  k = 0
end subroutine list2
!
subroutine sic_allocate_listi4(l,mlist,error)
  use gbl_message
  use sic_dependencies_interfaces
  use sic_interfaces, except_this=>sic_allocate_listi4
  use sic_types
  !---------------------------------------------------------------------
  ! @ public
  !  Allocate the input sic_list type.
  ! No deallocation subroutine, Fortran ensure that allocatable arrays
  ! are implicitly deallocated before destruction.
  !---------------------------------------------------------------------
  type(sic_listi4_t), intent(inout) :: l      !
  integer(kind=4),    intent(in)    :: mlist  ! Maximum number of lists
  logical,            intent(inout) :: error  ! Logical error flag
  ! Local
  character(len=*), parameter :: rname='ALLOCATE'
  integer(kind=4) :: ier
  !
  if (mlist.le.0) then
    call sic_message(seve%e,rname,'Requested empty listi4 array')
    error = .true.
    return
  endif
  !
  if (allocated(l%i1)) then
    if (size(l%i1).eq.mlist)  return
    deallocate(l%i1,l%i2,l%i3)
  endif
  !
  allocate(l%i1(mlist),l%i2(mlist),l%i3(mlist),stat=ier)
  if (failed_allocate(rname,'list i1/i2/i3',ier,error))  return
  l%mlist = mlist
  l%nlist = 0
  !
end subroutine sic_allocate_listi4
!
subroutine sic_allocate_listi8(l,mlist,error)
  use gbl_message
  use sic_dependencies_interfaces
  use sic_interfaces, except_this=>sic_allocate_listi8
  use sic_types
  !---------------------------------------------------------------------
  ! @ public
  !  Allocate the input sic_list type.
  ! No deallocation subroutine, Fortran ensure that allocatable arrays
  ! are implicitly deallocated before destruction.
  !---------------------------------------------------------------------
  type(sic_listi8_t), intent(inout) :: l      !
  integer(kind=4),    intent(in)    :: mlist  ! Maximum number of lists
  logical,            intent(inout) :: error  ! Logical error flag
  ! Local
  character(len=*), parameter :: rname='ALLOCATE'
  integer(kind=4) :: ier
  !
  if (mlist.le.0) then
    call sic_message(seve%e,rname,'Requested empty listi8 array')
    error = .true.
    return
  endif
  !
  if (allocated(l%i1)) then
    if (size(l%i1).eq.mlist)  return
    deallocate(l%i1,l%i2,l%i3)
  endif
  !
  allocate(l%i1(mlist),l%i2(mlist),l%i3(mlist),stat=ier)
  if (failed_allocate(rname,'list i1/i2/i3',ier,error))  return
  l%mlist = mlist
  l%nlist = 0
  !
end subroutine sic_allocate_listi8
!
subroutine sic_allocate_listr8(l,mlist,error)
  use gbl_message
  use sic_dependencies_interfaces
  use sic_interfaces, except_this=>sic_allocate_listr8
  use sic_types
  !---------------------------------------------------------------------
  ! @ public
  !  Allocate the input sic_list type.
  ! No deallocation subroutine, Fortran ensure that allocatable arrays
  ! are implicitly deallocated before destruction.
  !---------------------------------------------------------------------
  type(sic_listr8_t), intent(inout) :: l      !
  integer(kind=4),    intent(in)    :: mlist  ! Maximum number of lists
  logical,            intent(inout) :: error  ! Logical error flag
  ! Local
  character(len=*), parameter :: rname='ALLOCATE'
  integer(kind=4) :: ier
  !
  if (mlist.le.0) then
    call sic_message(seve%e,rname,'Requested empty listr8 array')
    error = .true.
    return
  endif
  !
  if (allocated(l%r1)) then
    if (size(l%r1).eq.mlist)  return
    deallocate(l%r1,l%r2,l%r3)
  endif
  !
  allocate(l%r1(mlist),l%r2(mlist),l%r3(mlist),stat=ier)
  if (failed_allocate(rname,'list r1/r2/r3',ier,error))  return
  l%mlist = mlist
  l%nlist = 0
  !
end subroutine sic_allocate_listr8
