subroutine ghisto(line,error)
  use gildas_def
  use gbl_format
  use phys_const
  use gbl_message
  use sic_types
  use greg_dependencies_interfaces
  use greg_interfaces, except_this=>ghisto,  &
                       no_interface1=>gr8_histo,  &
                       no_interface2=>gr8_histo_base,  &
                       no_interface3=>gr8_histo_hatchfill
  use greg_kernel
  use greg_pen
  use greg_types
  use greg_xyz
  !---------------------------------------------------------------------
  ! @ private
  ! Support routine for command
  !   HISTOGRAM [Array_X Array_Y]
  ! 1   [/BLANKING  Bval Eval]
  ! 2   [/FILL [Icolor]]
  ! 3   [/BASE [Ybase]]
  ! 4   [/HATCH [Ipen] [Angle] [Separ] [Phase]]
  !---------------------------------------------------------------------
  character(len=*), intent(in)    :: line   !
  logical,          intent(inout) :: error  !
  ! Global
  include 'gbl_memory.inc'
  ! Local
  character(len=*), parameter :: rname='HISTOGRAM'
  integer(kind=size_length) :: ixy,nbase
  integer(kind=4) :: form,narg,icol_old,ipen_old
  type(sic_descriptor_t) :: xinca,yinca,basedesc
  integer(kind=address_length) :: ipx,ipy
  real(kind=8) :: bval,eval
  type(polygon_drawing_t) :: drawing
  real(kind=8), allocatable :: ybase(:)
  integer(kind=4), parameter :: optblank=1
  integer(kind=4), parameter :: optfill=2
  integer(kind=4), parameter :: optbase=3
  integer(kind=4), parameter :: opthatch=4
  !
  save xinca,yinca
  !
  ! Command line parsing
  narg = sic_narg(0)
  if (narg.ne.0 .and. narg.ne.2)  return
  !
  ! /BLANK options
  bval = cblank
  call sic_r8 (line,optblank,1,bval,.false.,error)
  if (error) return
  eval = eblank
  call sic_r8 (line,optblank,2,eval,.false.,error)
  if (error) return
  !
  ! /FILL and /HATCH options
  if (penupd) call setpen(cpen)
  call inqcol(icol_old)
  call inqpen(ipen_old)
  call parse_polygon_drawing(rname,line,optfill,opthatch,drawing,error)
  if (error)  return
  !
  ! Command arguments (X and Y arrays)
  form = fmt_r8
  call get_incarnation('HISTOGRAM',line,form,ixy,xinca,yinca,error)
  if (error) return
  ipx = gag_pointer(xinca%addr,memory)
  ipy = gag_pointer(yinca%addr,memory)
  !
  ! /BASE option: argument can be scalar or 1D
  if (.not.sic_present(optbase,1)) then
    nbase = 1
    allocate(ybase(nbase))
    ybase(:) = 0.d0
  else
    call sic_de(line,optbase,1,basedesc,.true.,error)
    if (error)  goto 10
    if (desc_nelem(basedesc).eq.1) then
      nbase = 1
      allocate(ybase(nbase))
      call sic_descriptor_getval(basedesc,nbase,ybase(1),error)
      if (error)  goto 10
    elseif (basedesc%ndim.eq.1) then
      nbase = basedesc%dims(1)
      if (nbase.ne.ixy) then
        call greg_message(seve%e,rname,  &
          '/BASE argument must be scalar or same size as X and Y arrays')
        error = .true.
        goto 10
      endif
      allocate(ybase(nbase))
      call sic_descriptor_getval(basedesc,ybase,nbase,error)
      if (error)  goto 10
    else
      call greg_message(seve%e,rname,'/BASE argument must scalar or 1D')
      error = .true.
      goto 10
    endif
  endif
  !
  call gr_segm(rname,error)
  if (error)  goto 10
  !
  if (drawing%hatched) then  ! /HATCH (+ maybe /FILL)
    if (drawing%filled) then
      ! Hatch+Fill = color filled histogram (base assumed)
      drawing%hatched = .false. ! Temporarily disable hatching (segment colour issue)
      call setcol(drawing%fcolor)
      call gr8_histo_hatchfill(ixy,memory(ipx),memory(ipy),nbase,ybase,bval,eval,drawing,error)
      !
      ! New segment (may have different colors)
      call gtsegm_close(error)
      call setcol(icol_old)  ! Reset color *after* closing the segment
      call gr_segm(rname,error)
      drawing%hatched = .true. ! Reenabled
    endif
    !
    drawing%filled = .false. ! Disable filling (segment colour issue)
    call setpen(drawing%hpen)
    call gr8_histo_hatchfill(ixy,memory(ipx),memory(ipy),nbase,ybase,bval,eval,drawing,error)
    if (error)  continue
    !
  elseif (sic_present(optbase,0)) then  ! /BASE
    if (drawing%filled) then  ! /FILL
      ! Base+Fill = color filled histogram
      call setcol(drawing%fcolor)
      call gr8_histo_hatchfill(ixy,memory(ipx),memory(ipy),nbase,ybase,bval,eval,drawing,error)
    else
      call gr8_histo_base(ixy,memory(ipx),memory(ipy),nbase,ybase,bval,eval)
    endif
    !
  else
    ! No Base (maybe fill): top of histogram (maybe colored)
    if (drawing%filled)  call setcol(drawing%fcolor)
    call gr8_histo(ixy,memory(ipx),memory(ipy),bval,eval)
  endif
  !
  call gtsegm_close(error)
  !
10 continue
  ! Reset pen *after* closing the segment
  call setpen(ipen_old)
  call setcol(icol_old)
  !
  call sic_volatile(xinca)
  call sic_volatile(yinca)
  call sic_volatile(basedesc)
end subroutine ghisto
!
subroutine gr4_histo(nxy,x,y,bval,eval)
  use greg_interfaces, except_this=>gr4_histo
  !---------------------------------------------------------------------
  ! @ public
  !  Connect a set of points with blanked values using histogram (top of
  ! histogram is drawn). Support for blank values and NaN.
  !---------------------------------------------------------------------
  integer(kind=4), intent(in) :: nxy     ! Number of points
  real(kind=4),    intent(in) :: x(nxy)  ! Array of X coordinates
  real(kind=4),    intent(in) :: y(nxy)  ! Array of Y coordinates
  real(kind=4),    intent(in) :: bval    ! Blanking value
  real(kind=4),    intent(in) :: eval    ! Tolerance on blanking
  ! Local
  real(kind=8) :: xav,yav
  integer(kind=4) :: j
  logical :: up
  !
  if (nxy.lt.2) return
  !
  xav = x(1) - 0.5*(x(2)-x(1))
  if (y(1).eq.y(1).and.abs(y(1)-bval) .gt. eval) then
    yav = y(1)
    call relocate(xav,yav)
    up = .false.
  else
    up = .true.
  endif
  !
  do j = 2,nxy
    xav = 0.5 * (x(j)+x(j-1))
    if (y(j).eq.y(j).and.abs(y(j)-bval) .gt. eval) then
      if (up) then
        yav = y(j)
        call relocate(xav,yav)
        up = .false.
      else
        yav = y(j-1)
        call draw(xav,yav)
        yav = y(j)
        call draw(xav,yav)
      endif
    elseif (.not.up) then
      yav = y(j-1)
      call draw(xav,yav)
      up = .true.
    endif
  enddo
  if (up) return
  xav = x(nxy) + 0.5*(x(nxy)-x(nxy-1))
  yav = y(nxy)
  call draw(xav,yav)
end subroutine gr4_histo
!
subroutine gr8_histo(nxy,x,y,bval,eval)
  use greg_interfaces, except_this=>gr8_histo
  !---------------------------------------------------------------------
  ! @ public-mandatory
  !  Connect a set of points with blanked values using histogram (top of
  ! histogram is drawn). Support for blank values and NaN.
  !---------------------------------------------------------------------
  integer(kind=4), intent(in) :: nxy     ! Number of points
  real(kind=8),    intent(in) :: x(nxy)  ! Array of X coordinates
  real(kind=8),    intent(in) :: y(nxy)  ! Array of Y coordinates
  real(kind=8),    intent(in) :: bval    ! Blanking value
  real(kind=8),    intent(in) :: eval    ! Tolerance on blanking
  ! Local
  integer(kind=4) :: j
  real(kind=8) :: xav
  logical :: up
  !
  if (nxy.lt.2) return
  xav = x(1) - 0.5d0*(x(2)-x(1))
  if ((y(1).eq.y(1)).and.abs(y(1)-bval).gt.eval) then
    call relocate(xav,y(1))
    up = .false.
  else
    up = .true.
  endif
  !
  do j = 2,nxy
    xav = 0.5d0 * (x(j)+x(j-1))
    if (y(j).eq.y(j).and.abs(y(j)-bval).gt.eval) then
      if (up) then
        call relocate(xav,y(j))
        up = .false.
      else
        call draw(xav,y(j-1))
        call draw(xav,y(j))
      endif
    elseif (.not.up) then
      call draw(xav,y(j-1))
      up = .true.
    endif
  enddo
  xav = x(nxy) + 0.5d0*(x(nxy)-x(nxy-1))
  if (.not.up) call draw(xav,y(nxy))
end subroutine gr8_histo
!
subroutine gr8_histo_base(nxy,x,y,nbase,ybase,bval,eval)
  use gildas_def
  use greg_interfaces, except_this=>gr8_histo_base
  !---------------------------------------------------------------------
  ! @ private-mandatory
  ! Connect a set of points with blanked values using histogram
  !---------------------------------------------------------------------
  integer(kind=size_length), intent(in) :: nxy           ! Number of points
  real(kind=8),              intent(in) :: x(nxy)        ! Array of X coordinates
  real(kind=8),              intent(in) :: y(nxy)        ! Array of Y coordinates
  integer(kind=size_length), intent(in) :: nbase         ! Number base points (1 or Nxy)
  real(kind=8),              intent(in) :: ybase(nbase)  ! Base value(s)
  real(kind=8),              intent(in) :: bval          ! Blanking value
  real(kind=8),              intent(in) :: eval          ! Tolerance on blanking
  ! Local
  real(kind=8) :: xav
  integer(kind=size_length) :: j
  integer(kind=4) :: sbase
  logical :: up
  integer(kind=size_length), parameter :: first=1
  !
  if (nxy.lt.2) return
  !
  xav = x(1) - 0.5d0*(x(2)-x(1))
  if (y(1).eq.y(1) .and. abs(y(1)-bval).gt.eval) then
    call relocate(xav,ybase(ibase(first)))
    call draw(xav,y(1))
    up = .false.
  else
    up = .true.
  endif
  !
  if (nbase.eq.nxy) then
    sbase = 1
  else
    sbase = 0
  endif
  !
  do j = 2,nxy
    xav = 0.5d0 * (x(j)+x(j-1))
    if (y(j).eq.y(j).and.abs(y(j)-bval) .gt. eval) then
      if (up) then
        call relocate(xav,ybase(ibase(j)))
        call draw(xav,y(j))
        up = .false.
      else
        call draw(xav,y(j-1))
        call draw(xav,ybase(ibase(j)))
        call draw(xav,y(j))
      endif
    elseif (.not.up) then
      call draw(xav,y(j-1))
      call draw(xav,ybase(ibase(j)))
      up = .true.
    endif
  enddo
  if (up) return
  xav = x(nxy) + 0.5d0*(x(nxy)-x(nxy-1))
  call draw(xav,y(nxy))
  call draw(xav,ybase(ibase(nxy)))
  !
contains
  function ibase(ival)
    !-------------------------------------------------------------------
    ! Return index in base arrray for ival-th of histogram
    !-------------------------------------------------------------------
    integer(kind=size_length) :: ibase
    integer(kind=size_length), intent(in) :: ival
    if (nbase.eq.nxy) then
      ibase = ival
    else
      ibase = 1
    endif
  end function ibase
end subroutine gr8_histo_base
!
subroutine gr8_histo_hatchfill(nxy,x,y,nbase,ybase,bval,eval,drawing,error)
  use gildas_def
  use greg_interfaces, except_this=>gr8_histo_hatchfill
  use greg_types
  !---------------------------------------------------------------------
  ! @ public-mandatory
  !  Build the histogram from the input X and Y values, and fill it
  ! with hatches and maybe color. Contour is not drawn.
  !---------------------------------------------------------------------
  integer(kind=size_length), intent(in)    :: nxy           ! Number of points
  real(kind=8),              intent(in)    :: x(nxy)        ! Array of X coordinates
  real(kind=8),              intent(in)    :: y(nxy)        ! Array of Y coordinates
  integer(kind=size_length), intent(in)    :: nbase         ! Number base points (1 or Nxy)
  real(kind=8),              intent(in)    :: ybase(nbase)  ! Base of histogram
  real(kind=8),              intent(in)    :: bval          ! Blanking value
  real(kind=8),              intent(in)    :: eval          ! Tolerance on blanking value
  type(polygon_drawing_t),   intent(in)    :: drawing       ! Drawing description
  logical,                   intent(inout) :: error         ! Logical error flag
  ! Local
  real(kind=8) :: x2(3*nxy+3),y2(3*nxy+3)  ! Automatic arrays
  real(kind=8) :: xav
  integer(kind=size_length) :: j,istart,nelem,inext,jbase,npts
  !
  if (nxy.lt.2) return
  !
  inext = 1
  do while (inext.ne.0)
    ! Read data by blocks of valid values (non blanks if eval>=0, and non NaNs)
    call find_blank8(y,bval,eval,nxy,istart,nelem,inext)
    if (nelem.le.0)  cycle
    !
    ! 1) Build the polygon histogram from the valid values
    npts = 0
    if (istart.eq.1) then
      xav = x(1) - 0.5d0*(x(2)-x(1))
    else
      xav = 0.5d0 * (x(istart-1)+x(istart))
    endif
    call new_point(xav,ybase(ibase(istart)))  ! First point
    call new_point(xav,y(istart))
    !
    ! Histogram top (left parts)
    do j=2,nelem
      xav = 0.5d0 * (x(istart+j-2)+x(istart+j-1))
      call new_point(xav,y(istart+j-2))
      call new_point(xav,y(istart+j-1))
    enddo
    ! Histogram top (right part)
    if (istart+nelem-1.eq.nxy) then
      xav = x(nxy) + 0.5d0*(x(nxy)-x(nxy-1))
    else
      xav = 0.5d0 * (x(istart+nelem-1)+x(istart+nelem))
    endif
    call new_point(xav,y(istart+nelem-1))
    !
    ! Base
    call new_point(xav,ybase(ibase(istart+nelem-1)))
    if (nbase.eq.nxy) then
      do jbase=istart+nelem-1,istart,-1
        call new_point(x(jbase),ybase(ibase(jbase)))
      enddo
    endif
    !
    ! Close the polygon
    call last_point()
    !
    ! 2) Drawings
    ! Contour:
    ! call gr8_connect(nxy2,x2,y2,bval,eval)
    !
    if (drawing%filled) then
      ! Fill the region
      call gr8_ufill(npts,x2,y2)
    endif
    !
    if (drawing%hatched) then
      ! Hatch the region
      call gr8_hatch('HISTO',npts,x2,y2,  &
                    drawing%hangle,drawing%hsepar,drawing%hphase,error)
      if (error)  return
    endif
    !
  enddo
  !
contains
  function ibase(ival)
    !-------------------------------------------------------------------
    ! Return index in base arrray for ival-th of histogram
    !-------------------------------------------------------------------
    integer(kind=size_length) :: ibase
    integer(kind=size_length), intent(in) :: ival
    if (nbase.eq.nxy) then
      ibase = ival
    else
      ibase = 1
    endif
  end function ibase
  !
  subroutine new_point(xx,yy)
    real(kind=8), intent(in) :: xx,yy
    npts = npts+1
    x2(npts) = xx
    y2(npts) = yy
  end subroutine new_point
  !
  subroutine last_point()
    npts = npts+1
    x2(npts) = x2(1)
    y2(npts) = y2(1)
  end subroutine last_point
  !
end subroutine gr8_histo_hatchfill
