subroutine greg_write(line,error)
  use gbl_format
  use gbl_message
  use greg_dependencies_interfaces
  use greg_interfaces, except_this=>greg_write
  use greg_kernel
  use greg_poly
  use greg_rg
  use greg_xyz
  !---------------------------------------------------------------------
  ! @ private
  ! GREG	Support routine for command
  !
  !   WRITE
  !     COLUMN Filename [NEW [Format]] /TABLE X Nx Y Ny z Nz
  !     IMAGE
  !     RGDATA Filename "Comment X" "Comment Y"
  !     POLYGON
  !---------------------------------------------------------------------
  character(len=*), intent(in)    :: line   ! Command line
  logical,          intent(inout) :: error  ! Error flag
  ! Local
  character(len=*), parameter :: rname='WRITE'
  integer(kind=4) :: nkey,nc
  character(len=filename_length) :: fname,ffile
  character(len=12) :: argum,keywor
  integer(kind=4), parameter :: mvoc=4
  character(len=7), parameter :: vocab(mvoc)=(/'COLUMN ','RGDATA ','POLYGON','IMAGE  '/)
  !
  ! Argument
  call sic_ke(line,0,1,argum,nc,.true.,error)
  if (error) return
  call sic_ambigs(rname,argum,keywor,nkey,vocab,mvoc,error)
  if (error) return
  !
  ! File name
  call sic_ch (line,0,2,fname,nc,.true.,error)
  if (error) return
  !
  ! Option /TABLE
  if (nkey.ne.1 .and. sic_present(1,0)) then
    call greg_message(seve%e,rname,'Option /TABLE valid only with COLUMN argument')
    error = .true.
    return
  endif
  !
  select case (keywor)
  case ('COLUMN')
    if (nxy.le.0) then
      call greg_message(seve%e,rname,'No column loaded')
      error = .true.
      return
    endif
    if (sic_present(1,0)) then ! WRITE COLUMN /TABLE (binary table)
      call greg_write_column(line,fname,error)
      if (error)  return
    else                       ! WRITE COLUMN (formatted table)
      call sic_parsef(fname,ffile,' ','.dat')
      open(unit=jtmp,file=ffile,status='NEW',err=98)
      call greg_message(seve%i,rname,'Creating '//ffile)
      if (.not.associated(column_z)) then
        call wrcol2(jtmp,nxy,column_x,column_y)
      else
        call wrcol3(jtmp,nxy,column_x,column_y,column_z)
      endif
      close(unit=jtmp)
    endif
    !
  case ('RGDATA')
    if (rg%status.eq.code_pointer_null) then
      call greg_message(seve%e,rname,'No map loaded')
      error=.true.
      return
    endif
    call sic_parsef(fname,ffile,' ','.dat')
    open(unit=jtmp,file=ffile,status='NEW',err=98)
    call greg_message(seve%i,rname,'Creating '//ffile)
    call greg_write_rgdata(line,jtmp,rg%data,rg%nx*rg%ny,error)
    close(unit=jtmp)
    !
  case ('POLYGON')
    call greg_poly_write(rname,gpoly,fname,error)
    if (error) return
    !
  case ('IMAGE')
    if (rg%status.eq.code_pointer_null) then
      call greg_message(seve%e,rname,'No map loaded')
      error=.true.
      return
    endif
    call sic_parsef(fname,ffile,' ','.gdf')
    call greg_message(seve%i,rname,'Creating '//ffile)
    call greg_write_image(ffile,rg%data,error)
    !
  end select
  return
  !
  ! Error opening file
98 continue
  call greg_message(seve%e,rname,'Cannot open file '//ffile)
  error = .true.
end subroutine greg_write
!
subroutine greg_write_column(line,fname,error)
  use image_def
  use gbl_message
  use greg_dependencies_interfaces
  use greg_interfaces, except_this=>greg_write_column
  use greg_xyz
  !---------------------------------------------------------------------
  ! @ private
  ! Support routine for command
  !   WRITE COLUMN Filename [NEW [Format]] /TABLE X Nx Y Ny z Nz
  !---------------------------------------------------------------------
  character(len=*), intent(in)    :: line
  character(len=*), intent(in)    :: fname
  logical,          intent(inout) :: error
  ! Local
  character(len=*), parameter :: rname='WRITE>COLUMN'
  integer(kind=4) :: ncx,ncy,ncz,iarg,nc
  integer(kind=index_length) :: ncn,odim2
  character(len=2) :: code  ! len=2 so that we trap syntax error with 2 letters
  type(gildas) :: t
  character(len=16) :: argum,keywor
  integer(kind=4), parameter :: matype=2  ! Access type
  character(len=3), parameter :: atype(matype) = (/'OLD','NEW'/)
  integer(kind=4), parameter :: mforms=3  ! Formats
  character(len=7), parameter :: forms(mforms) = (/'REAL   ','DOUBLE ','INTEGER'/)
  !
  ncx = 0
  ncy = 0
  ncz = 0
  !
  do iarg=1,max(1,sic_narg(1)),2  ! At least 1 argument is needed!
    ! X, Y, or Z
    call sic_ke(line,1,iarg,code,nc,.true.,error)
    if (error) return
    if (code.eq.'X') then
      call sic_i4(line,1,iarg+1,ncx,.true.,error)
    elseif (code.eq.'Y') then
      call sic_i4(line,1,iarg+1,ncy,.true.,error)
    elseif (code.eq.'Z') then
      call sic_i4(line,1,iarg+1,ncz,.true.,error)
    else
      call greg_message(seve%e,rname,'Unknown column code '//code)
      error = .true.
    endif
    if (error) return
  enddo
  !
  ! New or old table?
  argum = 'OLD'
  call sic_ke(line,0,3,argum,nc,.false.,error)
  if (error) return
  call sic_ambigs(rname,argum,keywor,nc,atype,matype,error)
  if (error) return
  !
  call gildas_null(t, type='TABLE')
  if (keywor.eq.'NEW') then
    ! Create new file
    call sic_parse_file(fname,' ','.gdf',t%file)
    call greg_message(seve%i,rname,'Creating '//t%file)
    !
    ! Table format?
    argum = 'REAL'
    call sic_ke (line,0,4,argum,nc,.false.,error)
    if (error) return
    call sic_ambigs(rname,argum,keywor,nc,forms,mforms,error)
    if (error) return
    !
    t%gil%dim(1) = nxy
    t%gil%dim(2)  = max(ncx,ncy,ncz)
    if (keywor.eq.forms(1)) t%gil%form=fmt_r4
    if (keywor.eq.forms(2)) t%gil%form=fmt_r8
    if (keywor.eq.forms(3)) t%gil%form=fmt_i4
    call gdf_create_image (t, error)
    call gdf_allocate (t, error)
    !
  else
    ! Fill an existing file
    t%gil%form = 0  ! i.e. accept any format
    call gdf_read_gildas(t,fname,'.gdf',error,data=.false.)
    if (error) then
      call greg_message(seve%e,rname,'Error reading table')
      error = .true.
      return
    endif
    if (t%gil%dim(1).ne.nxy) then
      call greg_message(seve%e,rname,  &
        'Output table has incompatible number of lines')
      call gdf_close_image(t,error)
      error = .true.
      return
    endif
    if (t%gil%dim(2).lt.max(ncx,ncy,ncz)) then
      odim2 = t%gil%dim(2)
      call gdf_close_image (t, error)
      call greg_message(seve%w,rname,'Extending number of columns')
      ncn = max(ncx,ncy,ncz)
      call gdf_extend_image(t,ncn,error)
      if (error) return
    endif
    call gdf_allocate(t,error)  ! Allocate to new dimensions
    if (error) return
    ! Read only the old dimensions from disk
    t%blc(:) = 0
    t%blc(2) = 1
    t%trc(:) = 0
    t%trc(2) = odim2
    ! Damn why do I have to say where I want to read the data!?
    if (t%gil%form.eq.fmt_r4) then
      call gdf_read_data(t,t%r2d,error)
    elseif (t%gil%form.eq.fmt_r8) then
      call gdf_read_data(t,t%d2d,error)
    elseif (t%gil%form.eq.fmt_i4) then
      call gdf_read_data(t,t%i2d,error)
    endif
    t%blc(:) = 0
    t%trc(:) = 0
    if (error) then
      call my_close_image(t,error)
      return
    endif
  endif
  !
  ! OK now fill the requested columns
  if (t%gil%form.eq.fmt_r4) then
    !!Print *,'Real*4 ',t%gil%form,ncx,ncy,ncz
    if (ncx.ne.0)                             call r8tor4(column_x,t%r2d(1,ncx),nxy)
    if (ncy.ne.0)                             call r8tor4(column_y,t%r2d(1,ncy),nxy)
    if (ncz.ne.0 .and. associated(column_z))  call r8tor4(column_z,t%r2d(1,ncz),nxy)
    call gdf_write_data(t,t%r2d,error)
    !
  elseif (t%gil%form.eq.fmt_r8) then
    if (ncx.ne.0)                             call r8tor8(column_x,t%d2d(1,ncx),nxy)
    if (ncy.ne.0)                             call r8tor8(column_y,t%d2d(1,ncy),nxy)
    if (ncz.ne.0 .and. associated(column_z))  call r8tor8(column_z,t%d2d(1,ncz),nxy)
    call gdf_write_data(t,t%d2d,error)
    !
  elseif (t%gil%form.eq.fmt_i4) then
    if (ncx.ne.0)                             call r8toi4_fini(column_x,t%i2d(1,ncx),nxy,error)
    if (ncy.ne.0)                             call r8toi4_fini(column_y,t%i2d(1,ncy),nxy,error)
    if (ncz.ne.0 .and. associated(column_z))  call r8toi4_fini(column_z,t%i2d(1,ncz),nxy,error)
    if (.not.error)  &
      call gdf_write_data(t,t%i2d,error)
  else
    call greg_message(seve%e,rname,'Table format not supported')
    error = .true.
  endif
  call my_close_image(t,error)
  !
contains
  subroutine my_close_image(t,error)
    use image_def
    !-------------------------------------------------------------------
    ! Close the image and deallocate the data buffer. This subroutine
    ! is because we do not want to loose the error in case of error 
    ! recovery (status is reset by gdf_close_image...)
    !-------------------------------------------------------------------
    type(gildas), intent(inout) :: t
    logical,      intent(inout) :: error
    ! 
    logical :: err
    !
    err = .false.
    call gdf_close_image(t,err)
    if (associated(t%r2d)) deallocate(t%r2d)
    if (associated(t%d2d)) deallocate(t%d2d)
    if (associated(t%i2d)) deallocate(t%i2d)
    error = error.or.err  ! Propagate previous error
  end subroutine my_close_image
  !
end subroutine greg_write_column
!
subroutine greg_write_rgdata(line,jtmp,regmap,mreg,error)
  use greg_dependencies_interfaces
  use greg_interfaces, except_this=>greg_write_rgdata
  use greg_rg
  !---------------------------------------------------------------------
  ! @ private
  !  Writes a RGDATA like file from the Regular_Grid array
  !---------------------------------------------------------------------
  character(len=*), intent(in)    :: line          ! Input command line
  integer(kind=4),  intent(in)    :: jtmp          ! Logical unit number
  integer(kind=4),  intent(in)    :: mreg          ! Size of array
  real(kind=4),     intent(in)    :: regmap(mreg)  ! Array to write
  logical,          intent(inout) :: error         ! Logical error flag
  ! Local
  character(len=80) :: fname
  integer(kind=4) :: nc
  !
  write (jtmp,*) rg%nx,rg%xref,rg%xval,rg%xinc
  if (sic_present(0,3)) then
    call sic_ch (line,0,3,fname,nc,.false.,error)
    write (jtmp,'(A)') fname
  else
    write (jtmp,'(A)') ' '
  endif
  write (jtmp,*) rg%ny,rg%yref,rg%yval,rg%yinc
  if (sic_present(0,4)) then
    call sic_ch (line,0,4,fname,nc,.false.,error)
    write (jtmp,'(A)') fname
  else
    write (jtmp,'(A)') ' '
  endif
  !
  ! Write the map
  write (jtmp,'(10Z8.8)') regmap
end subroutine greg_write_rgdata
!
subroutine greg_poly_write(rname,poly,fname,error)
  use gildas_def
  use gbl_message
  use greg_dependencies_interfaces
  use greg_interfaces, except_this=>greg_poly_write
  use greg_kernel  ! For jtmp
  use greg_types
  !---------------------------------------------------------------------
  ! @ public
  !  Write the given polygon into the output file
  !---------------------------------------------------------------------
  character(len=*), intent(in)    :: rname
  type(polygon_t),  intent(in)    :: poly
  character(len=*), intent(in)    :: fname
  logical,          intent(inout) :: error
  ! Local
  character(len=filename_length) :: ffile
  integer(kind=4) :: ier
  !
  if (poly%ngon.le.2) then
    call greg_message(seve%e,rname,'No polygon defined')
    error = .true.
    return
  endif
  !
  call sic_parse_file(fname,' ','.pol',ffile)
  ier = sic_open(jtmp,ffile,'NEW',.false.)
  if (ier.ne.0) then
    call putios('E-'//trim(rname)//',  ',ier)
    error = .true.
    return
  endif
  call greg_message(seve%i,rname,'Creating '//ffile)
  call wrcol2(jtmp,poly%ngon,poly%xgon,poly%ygon)
  ier = sic_close(jtmp)
  !
end subroutine greg_poly_write
!
subroutine wrcol2(jun,n,x,y)
  !---------------------------------------------------------------------
  ! @ private
  !---------------------------------------------------------------------
  integer(kind=4), intent(in) :: jun   !
  integer(kind=4), intent(in) :: n     !
  real(kind=8),    intent(in) :: x(*)  !
  real(kind=8),    intent(in) :: y(*)  !
  ! Local
  integer(kind=4) :: i
  do i=1,n
    write(jun,*) x(i),y(i)
  enddo
end subroutine wrcol2
!
subroutine wrcol3(jun,n,x,y,z)
  !---------------------------------------------------------------------
  ! @ private
  !---------------------------------------------------------------------
  integer(kind=4), intent(in) :: jun   !
  integer(kind=4), intent(in) :: n     !
  real(kind=8),    intent(in) :: x(*)  !
  real(kind=8),    intent(in) :: y(*)  !
  real(kind=8),    intent(in) :: z(*)  !
  ! Local
  integer(kind=4) :: i
  do i=1,n
    write(jun,*) x(i),y(i),z(i)
  enddo
end subroutine wrcol3
!
subroutine greg_write_image(name,array,error)
  use gildas_def
  use gbl_message
  use gbl_format
  use phys_const
  use greg_dependencies_interfaces
  use greg_interfaces, except_this=>greg_write_image
  use greg_wcs
  use greg_kernel
  use greg_rg
  !---------------------------------------------------------------------
  ! @ private
  !---------------------------------------------------------------------
  character(len=*), intent(in)    :: name      ! File name
  real(kind=4),     intent(in)    :: array(*)  ! Data array
  logical,          intent(inout) :: error     ! Error flag
  !
  call gildas_null(rg%imag)
  !
  ! Same assumption as BOX: X is 1 and Y is 2
  rg%imag%gil%ndim = 2
  rg%imag%gil%dim(1) = rg%nx
  rg%imag%gil%dim(2) = rg%ny
  rg%imag%gil%dim(3) = 1
  rg%imag%gil%dim(4) = 1
  rg%imag%gil%convert(:,1) = (/rg%xref,rg%xval,rg%xinc/)
  rg%imag%gil%convert(:,2) = (/rg%yref,rg%yval,rg%yinc/)
  !
  ! Blanking
  rg%imag%gil%blan_words = 2
  rg%imag%gil%bval = cblank
  rg%imag%gil%eval = eblank
  !
  ! Extrema
  if (rg%minmax) then
    rg%imag%gil%rmin = rg%zmin
    rg%imag%gil%rmax = rg%zmax
    rg%imag%gil%minloc(:) = 0
    rg%imag%gil%minloc(1) = nint((rg%zxmin-rg%xval)/rg%xinc+rg%xref)
    rg%imag%gil%minloc(2) = nint((rg%zymin-rg%yval)/rg%yinc+rg%yref)
    rg%imag%gil%maxloc(:) = 0
    rg%imag%gil%maxloc(1) = nint((rg%zxmax-rg%xval)/rg%xinc+rg%xref)
    rg%imag%gil%maxloc(2) = nint((rg%zymax-rg%yval)/rg%yinc+rg%yref)
    rg%imag%gil%extr_words = 6
  else
    rg%imag%gil%extr_words = 0
  endif
  !
  ! Section 4 DESCRIPTION
  rg%imag%char%unit = 'UNKNOWN'
  rg%imag%gil%posi_words = 12
  if (i_system.eq.type_ic) then
    call greg_message(seve%w,'WRITE',  &
      'Computing galactic coordinates of source from ICRS coordinates is not implemented')
    rg%imag%gil%lii = 0.d0
    rg%imag%gil%bii = 0.d0
    rg%imag%gil%ra = gproj%a0
    rg%imag%gil%dec = gproj%d0
    rg%imag%char%syst = 'ICRS'
    rg%imag%gil%epoc = equinox_null
    rg%imag%char%code(1) = 'RA'   ! Same assumption as BOX /ABS: X is RA
    rg%imag%char%code(2) = 'DEC'  ! Same assumption as BOX /ABS: Y is DEC
  elseif (i_system.eq.type_eq) then
    ! Compute alternate coordinates in galactic system
    if (i_equinox.eq.equinox_null) then
      call greg_message(seve%w,'WRITE',  &
        'Unknown equinox, could not compute galactic coordinates of source')
      rg%imag%gil%lii = 0.
      rg%imag%gil%bii = 0.
    else
      call equ_gal(gproj%a0,gproj%d0,i_equinox,rg%imag%gil%lii,rg%imag%gil%bii,error)
      if (error)  return
    endif
    rg%imag%gil%ra = gproj%a0
    rg%imag%gil%dec = gproj%d0
    rg%imag%char%syst = 'EQUATORIAL'
    rg%imag%gil%epoc = i_equinox
    rg%imag%char%code(1) = 'RA'   ! Same assumption as BOX /ABS: X is RA
    rg%imag%char%code(2) = 'DEC'  ! Same assumption as BOX /ABS: Y is DEC
  elseif (i_system.eq.type_ga) then
    ! Compute alternate coordinates in equatorial system, use an arbitrary
    ! equinox
    call gal_equ(gproj%a0,gproj%d0,rg%imag%gil%ra,rg%imag%gil%dec,i_equinox_def,error)
    if (error)  return
    rg%imag%gil%lii = gproj%a0
    rg%imag%gil%bii = gproj%d0
    rg%imag%char%syst = 'GALACTIC'
    rg%imag%gil%epoc = i_equinox_def
    rg%imag%char%code(1) = 'LII'  ! Same assumption as BOX /ABS: X is LII
    rg%imag%char%code(2) = 'BII'  ! Same assumption as BOX /ABS: Y is BII
  else
    rg%imag%gil%posi_words = 0
    rg%imag%char%syst = 'UNKNOWN'
  endif
  rg%imag%gil%desc_words = 18
  !
  ! Section 5 POSITION
  !
  ! Section 6 PROJECTION
  if (gproj%type.ne.p_none) then
    rg%imag%gil%ptyp = gproj%type
    rg%imag%gil%a0 = gproj%a0
    rg%imag%gil%d0 = gproj%d0
    rg%imag%gil%xaxi = 1
    rg%imag%gil%yaxi = 2
    rg%imag%gil%pang = gproj%angle
    rg%imag%gil%proj_words = 9
    if (u_angle.eq.u_second) then
      rg%imag%gil%convert(2:3,1:2)  = pi/3600d0/180d0 * rg%imag%gil%convert(2:3,1:2)
    elseif (u_angle.eq.u_minute) then
      rg%imag%gil%convert(2:3,1:2)  = pi/60d0/180d0 * rg%imag%gil%convert(2:3,1:2)
    elseif (u_angle.eq.u_degree) then
      rg%imag%gil%convert(2:3,1:2)  = pi/180d0 * rg%imag%gil%convert(2:3,1:2)
    endif
  endif
  !
  ! Now write the image, using the new interface
  rg%imag%file = name
  call gdf_write_image(rg%imag,array,error)
  !
end subroutine greg_write_image
