subroutine gtinit(sx,sy,lunt,lunh,main,greg_user,error)
  use gildas_def
  use gbl_message
  use gtv_dependencies_interfaces
  use gtv_interfaces, except_this=>gtinit
  use gtv_bitmap
  use gtv_buffers
  use gtv_colors
  use gtv_graphic
  use gtv_plot
  use gtv_protocol
  use gtv_segatt
  use gtv_tree
  !---------------------------------------------------------------------
  ! @ public
  ! Initializes the GTVIRT on a blank world space
  !---------------------------------------------------------------------
  real(kind=4),     intent(in)    :: sx     ! World space in X [0...SX]
  real(kind=4),     intent(in)    :: sy     ! World space in Y [0...SY]
  integer(kind=4),  intent(in)    :: lunt   ! Logical unit number for terminal
  integer(kind=4),  intent(in)    :: lunh   ! Logical unit number for hardcopy. Unused.
  character(len=*), intent(in)    :: main   ! Main directory name
  external :: greg_user  ! Address of a routine to get user coordinates transformation
  logical,          intent(inout) :: error  ! Logical error flag
  ! Local
  character(len=*), parameter :: rname='GTINIT'
  integer(kind=bitmap_depth) :: bitmap
  type(greg_values) :: tab_greg
  !
  if (awake) then
    call gtv_message(seve%e,rname,'Programming error: multiple call to the initialization routine')
    error = .true.
    return
  endif
  !
  ! World area
  phys_sizex_def = sx
  phys_sizey_def = sy
  !
  call sic_defstructure('GTV',.true.,error)
  call sic_def_inte('GTV%NIMA',nb_image,0,0,.true.,error)
  !
  ! Awake the library. This is done only once during a process's life.
  call gtnone
  !
  ! Setup some default values. This is needed because some inializations in
  ! this routine rely on the device values (e.g. background color) while we
  ! do not have yet loaded a device!
  cw_output%color = .true.
  cw_output%background = 1  ! White
  !
  ! Default segment attributes at startup
  cattr%dash   = 1                     ! Continuous
  cattr%weight = graisse(1)            !
  cattr%colour = pen_color_foreground  ! Foreground
  cattr%depth  = 1                     ! First level
  !
  ! Load the language
  call load_gtvl
  !
  ! Define some basic variable
  call sic_def_logi('GTV%NOFAIL',nofail,.false.,error)
  call sic_def_logi('GTV%STDOUT',stdout,.false.,error)
  call sic_def_logi('GTV%FITPAGE',fitpage,.false.,error)
  call sic_def_logi('GTV%EXIST',dexist,.false.,error)
  call sic_def_logi('GTV%STRICT2011',strict2011,.false.,error)
  call sic_def_char('GTV%PWD',pwd,.true.,error)
  call sic_def_char('GTV%DEVICE',gtv_device,.true.,error)
  call sic_def_charn('GTV%DEVICES',device_list,1,1+ndevices,.true.,error)
  call sic_def_charn('GTV%COLORS',pen_colors,1,pen_ncolors,.true.,error)
  if (error) then
    call gtv_message(seve%f,rname,'Failed to initialize GTV% variables')
    call sysexi(fatale)
  endif
  !
  awake = .true.
  call gtx_reset
  !
  ! Get IUNIT
  cw_output%tofile = .true.
  cw_output%iunit = lunt
  !
  ! Define main directory name
  top_dir = main
  !
  ! Save GREG_USER routine address
  gt_greg_user => greg_user
  flag_greg = associated(gt_greg_user)  ! Always true...
  cdepth = 0
  vdepth(:) = .false.
  !
  ! Prepare the colormaps and bitmaps related variables
  bitmap = 0  ! Dummy value to avoid compiler warning
  bitmap_dynamic_max = (huge(bitmap)+1)*2
  !
  ! Load the Colormap and Pen luts
  call init_lut(error)
  if (error)  return
  call init_pen(error)
  if (error)  return
  !
  ! Full clear (internal metacode and interactive screen)
  call gtv_destroy_all(error)
  if (error)  return
  !
  ! Initialisation des constantes Greg pour la racine
  if (flag_greg) call get_greg_values(tab_greg)
  call attach_greg_values(root,tab_greg,error)
  if (error)  return
  !
  ! Initialisation des constantes Greg pour le premier repertoire
  call attach_greg_values(root%son_first,tab_greg,error)
  if (error) return
  !
end subroutine gtinit
!
subroutine gt_setphysical(sx,sy,error)
  use gtv_buffers
  use gtv_graphic
  use gtv_interfaces, except_this=>gt_setphysical
  use gtv_protocol
  use gtv_types
  !---------------------------------------------------------------------
  !  @ public
  !  Reset the physical size of the current tree (only): top directory
  ! must be emptied and use the new values before storing anything. Next
  ! top directories will also use these values.
  !  In practice, this is done like this:
  !   1) go to top directory
  !   2) empty top directory
  !   3) set new physical size of top directory in GTV
  !   4) store new physical size of top directory in GREG (callback)
  !---------------------------------------------------------------------
  real(kind=4), intent(in)    :: sx     ! World space in X [0...SX]
  real(kind=4), intent(in)    :: sy     ! World space in X [0...SX]
  logical,      intent(inout) :: error  ! Logical error flag
  ! Local
  logical :: keepall
  type(gt_directory), pointer :: topdir
  !
  ! World area
  phys_sizex_def = sx
  phys_sizey_def = sy
  !
  ! Go to top directory
  topdir => cw_directory%ancestor
  call gtv_open_segments_for_writing_from_main()
  call cd_by_adr(topdir,topdir%x%curwin,error)
  call gtv_close_segments_for_writing_from_main()
  if (error)  return
  !
  ! Clear its content
  keepall = .false.
  call gt_clear_directory(topdir,keepall,error)
  if (error)  return
  call gtview_update(topdir,error)  ! Update the windows which see 'topdir'
  if (error)  return
  !
  call gtv_open_segments_for_writing_from_main()
  !
  ! Reset its physical size
  topdir%phys_size(1) = phys_sizex_def
  topdir%phys_size(2) = phys_sizey_def
  !
  ! Undefined MINMAX information
  topdir%gen%minmax(1) = phys_sizex_def
  topdir%gen%minmax(2) = 0.0
  topdir%gen%minmax(3) = phys_sizey_def
  topdir%gen%minmax(4) = 0.0
  !
  ! Transmit new values to Greg
  if (flag_greg) then
    call attach_greg_values(cw_directory,cw_directory%val_greg,error)  ! Update val_greg
    call send_greg_values(cw_directory%val_greg)
  endif
  !
  call gtv_close_segments_for_writing_from_main()
  !
  ! Reset clipping area
  call sp_gtwindow(cw_output,0.0,phys_sizex_def,0.0,phys_sizey_def)
  !
end subroutine gt_setphysical
!
subroutine gtpolyl(n,vx,vy,error)
  use gtv_interfaces, except_this=>gtpolyl
  use gtv_tree
  use gtv_buffers
  use gtv_graphic
  !---------------------------------------------------------------------
  ! @ private-mandatory (because symbol is used elsewhere)
  !  Connects points (world coordinates).
  !  GTPOLYL has no effect for N less than 1.
  !  GTPOLYL behaves like GTRELOC for N equal to 1.
  !  Much more efficient than calls to GTRELOC and GTDRAW when N is
  ! substancially larger than 2.
  !---------------------------------------------------------------------
  integer, intent(in)    :: n      ! Number of points
  real*4,  intent(in)    :: vx(n)  ! Array of abscissae
  real*4,  intent(in)    :: vy(n)  ! Array of ordinates
  logical, intent(inout) :: error  ! Logical error flag
  !
  if (.not.awake .or. error_condition) return
  !
  ! Flush POLYL%X and POLYL%Y buffers if they are not empty
  call gtx_frxry(error)
  if (error) return
  !
  ! N is less than 2.
  if (n.lt.2) then
    if (n.lt.1) return
    polyl%x(1) = vx(1)
    polyl%y(1) = vy(1)
    return
  endif
  !
  ! Store the new values in POLYL
  polyl%x(1:n) = vx(1:n)
  polyl%y(1:n) = vy(1:n)
  polyl%n = n
  !
  ! Flush the new values into the tree
  call gtx_frxry(error)
  if (error) return
  !
end subroutine gtpolyl
!
subroutine gtx_frxry(error)
  use gtv_interfaces, except_this=>gtx_frxry
  use gtv_tree
  use gtv_buffers
  use gtv_graphic
  use gtv_plot
  use gbl_message
  !---------------------------------------------------------------------
  ! @ private
  ! Flushes POLYL%X and POLYL%Y buffers into internal metacode.
  !
  !  CAUTION !!!
  !   The indirect return happens if the ERROR_CONDITION flag is set.
  ! This flag may have been set previously by another error condition.
  ! Thus the calling program SHOULD be inactive if he is called with
  ! the error_condition flag set.
  ! ---
  !   Threads status: thread safe
  !---------------------------------------------------------------------
  logical, intent(inout) :: error  ! Logical error flag
  ! Local
  character(len=*), parameter :: rname='GTX_FRXRY'
  integer :: ier
  !
  error = .false.
  if (error_condition) then
    error = .true.
    return
  endif
  !
  if (.not.associated(co_segment)) then
    call gtv_message(seve%e,rname,'Programming error: no segment opened')
    error = .true.
    return
  endif
  !
  ! Nothing to do if less than 2 points in the buffer
  if (polyl%n.le.1)  return
  !
  ! Do we need to save the current PENLUT in the metacode before starting
  ! to write the polyline?
  if (lut_static) then
    if (.not.associated(co_segment%head%lut)) then
      ! We have to save to current global PENLUT in the metacode
      call gt_penlut_segdata(error)  ! This sets co_segment%head%lut
      if (error)  return
    endif
  endif
  !
  ! Update MINMAX
  co_segment%head%gen%minmax(1) = min(minval(polyl%x(1:polyl%n)),co_segment%head%gen%minmax(1))
  co_segment%head%gen%minmax(2) = max(maxval(polyl%x(1:polyl%n)),co_segment%head%gen%minmax(2))
  co_segment%head%gen%minmax(3) = min(minval(polyl%y(1:polyl%n)),co_segment%head%gen%minmax(3))
  co_segment%head%gen%minmax(4) = max(maxval(polyl%y(1:polyl%n)),co_segment%head%gen%minmax(4))
  !
  call gtv_open_segments_for_writing_from_main()
  !
  if (.not.associated(co_segment_data)) then
    allocate(co_segment%data,stat=ier)
    if (ier.ne.0) then
      call gtv_message(seve%e,rname,'Internal error: allocation failure (1)')
      error = .true.
      goto 10
    endif
    co_segment_data => co_segment%data
  else
    allocate(co_segment_data%nextdata,stat=ier)
    if (ier.ne.0) then
      call gtv_message(seve%e,rname,'Internal error: allocation failure (2)')
      error = .true.
      goto 10
    endif
    co_segment_data => co_segment_data%nextdata
  endif
  co_segment_data%nextdata => null()
  !
  allocate(co_segment_data%poly%x(polyl%n),co_segment_data%poly%y(polyl%n),stat=ier)
  if (ier.ne.0) then
    call gtv_message(seve%e,rname,'Internal error: allocation failure (3)')
    error = .true.
    goto 10
  endif
  co_segment_data%kind = seg_poly
  co_segment_data%poly%n = polyl%n
  co_segment_data%poly%x = polyl%x(1:polyl%n)
  co_segment_data%poly%y = polyl%y(1:polyl%n)
  co_segment_data%poly%penlut => co_segment%head%lut  ! Which can be null()
  !
  ! Update POLYL%X and POLYL%Y
  polyl%x(1) = polyl%x(polyl%n)
  polyl%y(1) = polyl%y(polyl%n)
  polyl%n = 1
  !
10 continue
  !
  call gtv_close_segments_for_writing_from_main()
  !
end subroutine gtx_frxry
!
subroutine gtreloc(x,y)
  use gtv_interfaces, except_this=>gtreloc
  use gtv_tree
  use gtv_buffers
  use gtv_graphic
  !---------------------------------------------------------------------
  ! @ public-mandatory (because symbol is used elsewhere)
  !
  !	Relocates the virtual pen to (X,Y)
  !	X,Y	World coordinates			Real*4
  !---------------------------------------------------------------------
  real*4 :: x                       !
  real*4 :: y                       !
  ! Local
  logical :: error
  !
  if (.not.awake .or. error_condition) return
  !
  if (x.eq.polyl%x(polyl%n) .and. y.eq.polyl%y(polyl%n)) return  ! Is this useful ?
  !
  error = .false.
  !
  ! Flush POLYL%X and POLYL%Y buffers
  call gtx_frxry(error)
  if (error) return
  !
  ! Relocate
  polyl%x(1) = x
  polyl%y(1) = y
  !
end subroutine gtreloc
!
subroutine gtdraw(x,y)
  use gtv_interfaces, except_this=>gtdraw
  use gtv_tree
  use gtv_buffers
  use gtv_graphic
  !---------------------------------------------------------------------
  ! @ public-mandatory (because symbol is used elsewhere)
  !
  !	Draws to (X,Y)
  !	X,Y	World coordinates			Real*4
  !---------------------------------------------------------------------
  real*4 :: x                       !
  real*4 :: y                       !
  ! Local
  logical :: error
  !
  if (.not.awake .or. error_condition) return
  !
  error = .false.
  !
  ! Test if POLYL%X and POLYL%Y buffers are full
  if (polyl%n.eq.nrdim) then
    call gtx_frxry(error)
    if (error) return
  endif
  !
  ! Append (X,Y) to POLYL%X and POLYL%Y
  polyl%n = polyl%n+1
  polyl%x(polyl%n) = x
  polyl%y(polyl%n) = y
end subroutine gtdraw
!
subroutine dir_extrema(dir,minmax)
  use gtv_tree
  use gtv_buffers
  use gtv_interfaces, except_this=>dir_extrema
  use gtv_types
  !---------------------------------------------------------------------
  ! @ private
  !   Updates the minmax values of the directory given in input (compose
  ! the areas).
  !---------------------------------------------------------------------
  type(gt_directory), intent(inout) :: dir        ! The directory to be updated
  real(kind=4),       intent(in)    :: minmax(4)  ! The new minmax values
  !
  dir%gen%minmax(1) = min(minmax(1),dir%gen%minmax(1))  ! xmin
  dir%gen%minmax(2) = max(minmax(2),dir%gen%minmax(2))  ! xmax
  dir%gen%minmax(3) = min(minmax(3),dir%gen%minmax(3))  ! ymin
  dir%gen%minmax(4) = max(minmax(4),dir%gen%minmax(4))  ! ymax
  !
end subroutine dir_extrema
!
subroutine gtsegm(name,error)
  use gtv_tree
  use gtv_buffers
  use gtv_graphic
  use gtv_interfaces, except_this=>gtsegm
  use gbl_message
  !---------------------------------------------------------------------
  ! @ public
  !   Initialise a new segment with the current line attributes. No
  ! action if the current segment is empty (except making the
  ! Attribute(4) positive, i.e. visible).
  ! ---
  !   Threads status: thread safe
  !---------------------------------------------------------------------
  character(len=*), intent(in)  :: name   ! Name of the new segment
  logical,          intent(out) :: error  ! Logical error flag
  ! Local
  character(len=*), parameter :: rname='GTSEGM'
  integer :: sever
  character(len=message_length) :: mess
  !
  if (.not.awake .or. error_condition) return
  !
  error = .false.  ! Making error 'inout' would require to check all
                   ! calling routines in the outworld.
  !
  if (associated(co_segment)) then
    if (strict2011) then
      sever = seve%e
    else
      sever = seve%w
    endif
    write(mess,'(3A)')  'Attempt to create a new segment "',trim(name),'"'
    call gtv_message(sever,rname,mess)
    write(mess,'(3A)')  'while the previous (',trim(co_segment%head%gen%name),') is not closed'
    call gtv_message(sever,rname,mess)
    call gtv_message(sever,rname,  &
      'Programmer: call ''gr_segm_close(error)'' to close the previous segment')
    if (strict2011) then
      error = .true.
      return
    endif
    ! Close the segment currently opened. Should not be automatic in the
    ! future, i.e. always raise an error.
    call gtsegm_close(error)  ! Write protected
    if (error)  return
  endif
  !
  ! Par convention la racine de l'arbre n'a pas de feuilles. Decision
  ! scandaleuse et arbitraire, prise avec P.Valiron. Or donc, si le
  ! repertoire courant est < ....
  if (associated(cw_directory,root)) then
    call gtv_message(seve%e,rname,'Can not create leaf under root <')
    error = .true.
    return
  endif
  !
  call gtsegm_create(name,cw_directory,error)
  if (error)  return
  !
end subroutine gtsegm
!
subroutine gtsegm_create(name,parent,error)
  use gbl_message
  use gtv_buffers
  use gtv_interfaces, except_this=>gtsegm_create
  use gtv_types
  !---------------------------------------------------------------------
  ! @ private
  !---------------------------------------------------------------------
  character(len=*),   intent(in)    :: name    ! Segment name
  type(gt_directory), pointer       :: parent  ! Parent directory
  logical,            intent(inout) :: error   ! Logical error flag
  ! Local
  character(len=segname_length) :: nom_seg
  integer :: segnum
  character(len=10) :: suffix
  !
  ! Generation d'un nom de segment
  segnum = parent%segn+1
  !
  if (segnum .le. 9) then
    write(suffix,100) segnum
  elseif (segnum .le. 99) then
    write(suffix,101) segnum
  elseif (segnum .le. 999) then
    write(suffix,102) segnum
  elseif (segnum .le. 9999) then
    write(suffix,103) segnum
  elseif (segnum .le. 99999) then
    write(suffix,104) segnum
  elseif (segnum .le. 999999) then
    write(suffix,105) segnum
  endif
  if (len_trim(name)+len_trim(suffix).gt.segname_length) then
    call gtv_message(seve%e,'GTSEGM','Name too long')
    error = .true.
    return
  endif
  nom_seg = trim(name)//suffix
  call sic_upper(nom_seg)
  !
  call gtv_open_segments_for_writing_from_main()
  !
  ! Reset the global pointers
  co_segment => gtv_newsegment(error)
  if (error)  return
  co_segment_data => null()
  co_segment%data => null()
  !
  ! Current line attributes
  co_segment%head%attr = cattr
  vdepth(cattr%depth) = .true.
  ! Old or new, the segment must be viewable:
  co_segment%head%gen%visible = .true.
  !
  ! Undefined MINMAX information. Get paper size from parent
  co_segment%head%gen%minmax(1) = parent%phys_size(1)
  co_segment%head%gen%minmax(2) = 0.0
  co_segment%head%gen%minmax(3) = parent%phys_size(2)
  co_segment%head%gen%minmax(4) = 0.0
  !
  ! Mise a jour des differents pointeurs.
  co_segment%nextseg => null()  ! Pointer on the next leaf
  co_segment%father => parent   ! Pointer on the father
  !
100 format(':',i1)
101 format(':',i2)
102 format(':',i3)
103 format(':',i4)
104 format(':',i5)
105 format(':',i6)
  !
  ! Mise a jour du nom du segment
  co_segment%head%gen%name = nom_seg
  !
  parent%segn = parent%segn+1
  !
  ! Update the last_leaf of the directory and the forward pointing
  if (associated(parent%leaf_last)) then
    ! Parent directory already contains leaves
    parent%leaf_last%nextseg => co_segment
    parent%leaf_last => co_segment
  else
    ! Parent directory had no leaf
    parent%leaf_first => co_segment
    parent%leaf_last => co_segment
  endif
  !
  call gtv_close_segments_for_writing_from_main()
  !
end subroutine gtsegm_create
!
subroutine gtsegm_flush(error)
  use gtv_buffers
  use gtv_interfaces, except_this=>gtsegm_flush
  use gtv_tree
  use gtv_types
  !---------------------------------------------------------------------
  ! @ private
  !  Flush the internal buffers into the currently opened segment, i.e.
  ! make it ready to be drawn.
  !---------------------------------------------------------------------
  logical, intent(inout) :: error  ! Logical error flag
  ! Local
  type(gt_directory), pointer :: father
  !
  if (.not.associated(co_segment))  return
  !
  ! 1) Flush POLYL%X and POLYL%Y buffers if they are not empty
  call gtx_frxry(error)
  if (error)  return
  !
  ! 2) Update the extrema of the parent directory of the segment we are closing
  father => co_segment%father
  call dir_extrema(father,co_segment%head%gen%minmax)
  !
end subroutine gtsegm_flush
!
subroutine gtsegm_close(error)
  use gtv_interfaces, except_this=>gtsegm_close
  use gbl_message
  use gtv_buffers
  use gtv_graphic
  !---------------------------------------------------------------------
  ! @ public?
  !  Close the segment currently opened. It is harmless to close several
  ! time the same segment.
  !---------------------------------------------------------------------
  logical, intent(inout) :: error  ! Logical error flag
  ! Local
  character(len=*), parameter :: rname='GTSEGM_CLOSE'
  integer :: sever
  logical :: lerror
  !
  if (.not.associated(co_segment)) then
    if (strict2011) then
      sever = seve%e
      error = .true.
    else
      sever = seve%w
    endif
    call gtv_message(sever,rname,  &
      'No segment to close here. Duplicate call to ''gr_segm_close''?')
    return
  endif
  !
  ! 1) Prepare the segment to be drawn
  lerror = .false.
  call gtsegm_flush(lerror)
  if (lerror) then
    ! Use a "local" error, since 'gtsegm_close' can be called with
    ! the 'error' flag flag already .true., but we still want to close
    ! the segment (i.e. ignore the input value)
    error = .true.
    return
  endif
  !
  ! 2) Draw it
  call gtview_append(co_segment,lerror)
  if (lerror) then
    error = .true.
    return
  endif
  !
  ! 3) Definitely close it: can not be used anymore
  co_segment => null()
  co_segment_data => null()
  !
end subroutine gtsegm_close
!
subroutine gtedit(dashed,weight,colour,level,visible)
  use gbl_message
  use gtv_buffers
  use gtv_graphic
  use gtv_interfaces, except_this=>gtedit
  use gtv_tree
  use gtv_types
  !---------------------------------------------------------------------
  ! @ public
  !   Edit the current segment with the current line attributes
  ! ---
  !   Threads status: thread safe
  !---------------------------------------------------------------------
  integer(kind=4), intent(in) :: dashed   ! Line Type
  real(kind=4),    intent(in) :: weight   ! [cm] Line width
  integer(kind=4), intent(in) :: colour   ! Colour index
  integer(kind=4), intent(in) :: level    ! Display Depth
  logical,         intent(in) :: visible  ! Visible segment attribute
  ! Local
  character(len=*), parameter :: rname='GTEDIT'
  character(len=message_length) :: mess
  logical :: error
  !
  if (.not.awake .or. error_condition) return
  !
  ! Check ranges
  error = .false.
  if (dashed.lt.min_dash  .or. dashed.gt.max_dash) then
    write(mess,'(A,I0,A,2(1X,I0))')  &
      'Dash argument ',dashed,' out of range',min_dash,max_dash
    call gtv_message(seve%e,rname,mess)
    error = .true.
  endif
! ZZZ
!   if (weight.lt.min_weight  .or. weight.gt.max_weight) then
!     write(mess,'(A,I0,A,2I0)')  &
!       'Weight argument ',weight,' out of range ',min_weight,max_weight
!     call gtv_message(seve%e,rname,mess)
!     error = .true.
!   endif
! ZZZ
!   if (colour.lt.min_colour  .or. colour.gt.max_colour) then
!     write(mess,'(A,I0,A,2I0)')  &
!       'Colour argument ',colour,' out of range ',min_colour,max_colour
!     call gtv_message(seve%e,rname,mess)
!     error = .true.
!   endif
  if (level.lt.0 .or. level.gt.max_depth) then  ! 0 means unchanged
    write(mess,'(A,I0,A,2(1X,I0))')  &
      'Depth argument ',level,' out of range',0,max_depth
    call gtv_message(seve%e,rname,mess)
    error = .true.
  endif
  if (error) then
    call gtx_err
    return
  endif
  !
  ! Define line attributes
  cattr%dash = dashed
  cattr%weight = weight
  cattr%colour = colour
  if (level.ne.0) then
    cattr%depth = level
    if (level.gt.cdepth)  cdepth = level
  endif
  !
  ! Set the attributes of the current segment
  call gtv_open_segments_for_writing_from_main()
  if (associated(co_segment)) then
    co_segment%head%attr = cattr
    vdepth(cattr%depth) = .true.
    co_segment%head%gen%visible = visible
  else
    ! Well, this is embarassing, I do not know what to update...
    cw_directory%gen%visible = visible
  endif
  call gtv_close_segments_for_writing_from_main()
  !
end subroutine gtedit
!
subroutine gtdls
  use gtv_buffers
  use gtv_graphic
  use gtv_interfaces, except_this=>gtdls
  use gtv_segatt
  use gtv_tree
  use gtv_types
  use gbl_message
  !---------------------------------------------------------------------
  ! @ public
  !   Deletes the last segment in the current directory, taking care
  ! of the chain and pointers in the tree.
  !
  ! Does not modify:
  !  - the virtuel pen position,
  !  - the immediate pen position,
  !  - the pen attributes. Those from the previous segment might not be
  !    consistent with the current pen exposed in GreG.
  ! ---
  !   Threads status: thread safe
  !---------------------------------------------------------------------
  ! Local
  character(len=*), parameter :: rname='GTDLS'
  logical :: error
  type(gt_segment), pointer :: segm,previous
  !
  if (.not.awake .or. error_condition) return
  !
  error = .false.
  !
  ! Avant de s'affoler la tete comme des malades, il faudrait voir
  ! si ce pauvre segment auquel on veut faire la peau est un repertoire.
  ! Flinguer un repertoire se fera par une commande speciale.
  if (.not.associated(cw_directory%leaf_last)) then
    call gtv_message(seve%e,rname,'Unable to delete a Directory segment')
    call gtv_message(seve%e,rname,'Use CLEAR DIRECTORY [Name]')
    return
  endif
  !
  ! Segment to destroy
  segm => cw_directory%leaf_last
  if (associated(segm,co_segment)) then
    co_segment => null()
    co_segment_data => null()
  endif
  !
  call gtv_open_segments_for_writing_from_main()
  !
  polyl%x(1) = polyl%x(polyl%n)
  polyl%y(1) = polyl%y(polyl%n)
  polyl%n = 1
  cw_directory%segn = cw_directory%segn - 1
  !
  ! Update the segments chain in the directory
  segm => cw_directory%leaf_first
  previous => null()
  do while (associated(segm%nextseg))
    previous => segm
    segm => previous%nextseg
  enddo
  !
  ! Update the directory pointers
  if (.not.associated(previous)) then
    cw_directory%leaf_first => null()
    cw_directory%leaf_last => null()
  else
    cw_directory%leaf_last => previous
    previous%nextseg => null()
  endif
  !
  ! And finally update the limits
  call gtv_limits(cw_directory,error)
  !
  call gtv_close_segments_for_writing_from_main()
  !
  ! Free the segment: put it in the stack for later deletion. This can
  ! be done out of the threads protection, since nobody new can know
  ! about it now.
  ! segm%nextseg is already null()
  if (associated(segm))  &
    call x_destroy_segment(segm)  ! will call gtv_delsegments(segm)
  !
end subroutine gtdls
!
function gtv_newsegment(error)
  use gtv_types
  use gbl_message
  !---------------------------------------------------------------------
  ! @ private
  !  Allocate a new GTVIRT segment.
  !---------------------------------------------------------------------
  type(gt_segment), pointer :: gtv_newsegment  ! Function value on return
  logical,    intent(inout) :: error           ! Logical error flag
  ! Local
  character(len=*), parameter :: rname='GTV_NEWSEGMENT'
  integer :: ier
  !
  allocate(gtv_newsegment,stat=ier)
  if (ier.ne.0) then
    call gtv_message(seve%e,rname,'Internal error: allocation failure')
    error = .true.
    return
  endif
  !
end function gtv_newsegment
!
subroutine gtv_delsegment_elem(segm)
  use gtv_interfaces, except_this=>gtv_delsegment_elem
  use gtv_buffers
  use gtv_plot
  use gtv_types
  !---------------------------------------------------------------------
  ! @ private
  !   Elemental routine which deallocates the input segment and frees
  ! the data associated. This routine does NOT take care of the pointers
  ! to this segment in the GTV tree: it is up to the calling routine
  ! to remake the chain, if required.
  ! ---
  !   Threads status: NOT thread safe -> calling routine must be thread
  !  safe.
  !---------------------------------------------------------------------
  type(gt_segment), target :: segm  ! Segment to clean
  ! Local
  logical :: error
  type(gt_segment), pointer :: segm_p
  type(gt_segment_data), pointer :: father,son
  !
  if (associated(co_segment,segm)) then
    co_segment => null()
    co_segment_data => null()
  endif
  !
  error = .false.
  father => segm%data
  do while (associated(father))
    ! Data
    if (associated(father%poly%x))  &
      deallocate(father%poly%x,father%poly%y)
    if (allocated(father%lut%r)) then
      call gt_lut_dealloc(father%lut,error)
    endif
    if (associated(father%image)) then
      call gtv_delimage(father%image)
      nullify(father%image)
    endif
    !
    ! Chain
    son => father%nextdata  ! Keep track before destruction
    deallocate(father)
    father => son
  enddo
  !
  segm_p => segm
  deallocate(segm_p)
  !
end subroutine gtv_delsegment_elem
!
subroutine gtv_delsegments(segm)
  use gtv_interfaces, except_this=>gtv_delsegments
  use gtv_types
  !---------------------------------------------------------------------
  ! @ private
  !  Destroy the input linked list of segments, without taking care of
  ! the surrounding elements in the GTV tree.
  !  This subroutine can only be called if:
  ! - all the segments we are about to destroy have been dereferenced
  !   from the GTV tree,
  ! - all the previous events in the stack (which may refer to these
  !   segments) have been processed, i.e. only the stack can call this
  !   subroutine.
  !
  ! BEWARE! As we receive a target, the caller must ensure that a
  !         it never passes a null() pointer to this subroutine!
  !---------------------------------------------------------------------
  type(gt_segment), target :: segm  ! First segment to destroy
  ! Local
  type(gt_segment), pointer :: nextsegm,cursegm
  !
  nextsegm => segm
  do while (associated(nextsegm))
    cursegm => nextsegm
    nextsegm => cursegm%nextseg  ! Keep track *before* deleting 'cursegm'
    !
    ! Free the segment
    call gtv_delsegment_elem(cursegm)
  enddo
  !
end subroutine gtv_delsegments
!
!-----------------------------------------------------------------------
!
function gtv_newdirectory(error)
  use gtv_types
  use gbl_message
  !---------------------------------------------------------------------
  ! @ private
  !  Allocate a new GTVIRT directory.
  !---------------------------------------------------------------------
  type(gt_directory), pointer :: gtv_newdirectory  ! Function value on return
  logical,      intent(inout) :: error             ! Logical error flag
  ! Local
  character(len=*), parameter :: rname='GTV_NEWDIRECTORY'
  integer :: ier
  !
  allocate(gtv_newdirectory,stat=ier)
  if (ier.ne.0) then
    call gtv_message(seve%e,rname,'Internal error: allocation failure')
    error = .true.
    return
  endif
  !
end function gtv_newdirectory
!
subroutine gtv_deldirectory_elem(dir)
  use gtv_buffers
  use gtv_interfaces, except_this=>gtv_deldirectory_elem
  use gtv_types
  !---------------------------------------------------------------------
  ! @ private
  !   Elemental routine which frees the data associated to the input
  ! directory. This routine:
  !  - does NOT take care of the pointers to this directory in the GTV
  !    tree,
  !  - does NOT delete the subdirectories it might contain, if any.
  ! ---
  !   Threads status: NOT thread safe -> calling routine must be thread
  !  safe.
  !---------------------------------------------------------------------
  type(gt_directory), target :: dir  !
  ! Local
  type(gt_directory), pointer :: dir_p
  !
  ! Destroy the list of segments
  if (associated(dir%leaf_first))  &
    call gtv_delsegments(dir%leaf_first)
  !
  ! Pointers. No need...
  ! dir%ancestor => null()
  ! dir%father => null()
  ! dir%brother => null()
  ! dir%son_first => null()
  ! dir%son_last => null()
  ! dir%leaf_first => null()
  ! dir%leaf_last => null()
  !
  dir_p => dir
  deallocate(dir_p)
  !
end subroutine gtv_deldirectory_elem
!
recursive subroutine gtv_deldirectory_recurs(dir)
  use gtv_interfaces, except_this=>gtv_deldirectory_recurs
  use gtv_types
  !---------------------------------------------------------------------
  ! @ private
  ! Destroy the input directory:
  !  - destroy its segments and data
  !  - destroy its subdirectories (by a recursive call to this routine)
  ! This does NOT take care of the pointers and chain to the destroyed
  ! directory.
  !---------------------------------------------------------------------
  type(gt_directory) :: dir  ! Directory to destroy
  ! Local
  type(gt_directory), pointer :: son,nextson
  !
  ! 1) Destroy its subdirectories
  nextson => dir%son_first
  do while (associated(nextson))
    son => nextson
    nextson => son%brother  ! Keep track before deleting 'son'
    call gtv_deldirectory_recurs(son)
  enddo
  !
  ! 2) Destroy all its segments and data
  call gtv_deldirectory_elem(dir)
  !
end subroutine gtv_deldirectory_recurs
!
subroutine gtv_deldirectories(dir)
  use gtv_interfaces, except_this=>gtv_deldirectories
  use gtv_types
  !---------------------------------------------------------------------
  ! @ private
  !  Destroy the input linked list of directories, recursively for each
  ! of them, without taking care of the surrounding elements in the
  ! GTV tree.
  !  This subroutine can only be called if:
  ! - all the elements we are about to destroy have been dereferenced
  !   from the GTV tree,
  ! - all the previous events in the stack (which may refer to these
  !   elements) have been processed, i.e. only the stack can call this
  !   subroutine.
  !
  ! BEWARE! As we receive a target, the caller must ensure that a
  !         it never passes a null() pointer to this subroutine!
  !---------------------------------------------------------------------
  type(gt_directory), target :: dir  ! First directory to destroy
  ! Local
  type(gt_directory), pointer :: curdir,nextdir
  !
  nextdir => dir
  do while (associated(nextdir))
    curdir => nextdir
    nextdir => curdir%brother  ! Keep track before deleting 'curdir'
    !
    call gtv_deldirectory_recurs(curdir)
  enddo
  !
end subroutine gtv_deldirectories
!
recursive subroutine exec_poly_recurs(dir,execop)
  use gtv_buffers
  use gtv_interfaces, except_this=>exec_poly_recurs
  use gtv_types
  !---------------------------------------------------------------------
  ! @ private
  !  Traverse all the leaves of the input directory and recursively in
  ! subdirectories and execute the input routine 'execop' on the GTV
  ! polylines and polygons it finds.
  !---------------------------------------------------------------------
  type(gt_directory) :: dir     ! Starting directory
  external           :: execop  !
  ! Local
  type(gt_segment), pointer :: leaf
  type(gt_directory), pointer :: son
  !
  ! 1) Search for all the leaves
  leaf => dir%leaf_first
  do while (associated(leaf))
    call poly_codeop(leaf,execop)
    leaf => leaf%nextseg
  enddo
  !
  ! 2) Loop on all the subdirectories
  son => dir%son_first
  do while (associated(son))
    call exec_poly_recurs(son,execop)
    son => son%brother
  enddo
  !
end subroutine exec_poly_recurs
!
subroutine poly_codeop(leaf,execop)
  use gtv_interfaces, except_this=>poly_codeop
  use gtv_buffers
  use gtv_plot
  use gtv_tree
  use gtv_types
  !---------------------------------------------------------------------
  ! @ private
  !  Generic entry point which reads the input 'leaf' and execute
  ! the input routine if it finds a the GTV polyline or polygon.
  !  'execop' takes the segment header and the polyline/polygon address
  ! as argument
  !---------------------------------------------------------------------
  type(gt_segment), pointer :: leaf    ! Segment instance
  external                  :: execop  ! Routine to execute on the image
  ! Local
  type(gt_segment_data), pointer :: segdata
  logical :: error
  !
  if (lut_static) then
    ! Save the current global LUT as last data in this segment
    co_segment => leaf
    co_segment_data => null()
    segdata => leaf%data
    do while (associated(segdata))
      co_segment_data => segdata
      segdata => segdata%nextdata
    enddo
    error= .false.
    call gt_penlut_segdata(error)
    co_segment => null()
    co_segment_data => null()
  else
    ! Unset the LUT to be used by the polylines. We should also remove its
    ! data (which is somewhere in the linked list of data)
    leaf%head%lut => null()
  endif
  !
  ! Follow the linked list of data to make all the polylines use the
  ! LUT we just saved
  segdata => leaf%data
  do while (associated(segdata))
    if (segdata%kind.eq.seg_poly   .or.  &
        segdata%kind.eq.seg_hfpoly .or.  &
        segdata%kind.eq.seg_vfpoly)      &
      call execop(leaf%head,segdata%poly)
    !
    segdata => segdata%nextdata
  enddo
  !
end subroutine poly_codeop
