!>
! This file contains all WRITE command related subroutines
!
! MOSAIC> writ beam toto /app
! E-WRITE /APPEND,  BEAM         is not contiguous, starts at 1
! E-WRITE,  failed to complete
!!
subroutine write_comm (line,error)
  use gkernel_interfaces
  use imager_interfaces, except_this=>write_comm
  use clean_def
  use clean_arrays
  use clean_types
  use gbl_format
  use gbl_message
  !----------------------------------------------------------------------
  ! @ private
  !
  ! IMAGER
  !*
  !   Support routine for command
  !
  !   WRITE Type File [/RANGE Start End Kind] [/TRIM]
  !       [/APPEND] [/REPLACE]
  !!
  !----------------------------------------------------------------------
  character(len=*), intent(in) :: line    !! Command line
  logical, intent(out) :: error           !! Error return code
  ! 
  ! Constants
  integer, parameter :: o_append=1
  integer, parameter :: o_range=2
  integer, parameter :: o_replace=3
  integer, parameter :: o_trim=4  
  character(len=*), parameter :: rname='WRITE'
  character(len=12) :: allowed(3)
  data allowed /'GILDAS','FITS','CSV'/
  !
  ! Local ---
  integer :: mgap
  integer ntype, nc(2), mc(2), larg, is, nk
  character(len=varname_length) argu,atype,crange
  character(len=filename_length) :: name
  real(8) :: drange(2)
  logical :: err
  character(len=12) :: key
  !
  ! Code ----
  call sic_ke (line,0,1,argu,larg,.true.,error)
  if (error) return
  if (argu.eq.'?') then
    call sic_ambigs_list(rname,seve%i,'Choices are:',vtype,vwrite)
    return
  elseif (argu.eq.'UV') then
    argu = 'UV_DATA'
  endif
  !
  write_format = write_default
  if (sic_present(0,3)) then
    call sic_ke(line,0,3,key,nk,.true.,error)
    if (error) return
    if (key(1:nk).eq.allowed(1)(1:nk)) then
      write_format = write_gildas
    else if (key(1:nk).eq.allowed(2)(1:nk)) then
      if (sic_present(o_append,0).or.sic_present(o_replace,0) ) then
        call map_message(seve%e,rname,'Option /REPLACE and /APPEND invalid for FITS format')
        error = .true.
      endif
      write_format = write_fits
    else if (key(1:nk).eq.allowed(3)(1:nk)) then
      write_format = write_csv
    else
      call map_message(seve%e,rname,'Unknown ouput data format, only FITS and GILDAS allowed')
      error = .true.
      return  
    endif
  endif
  !  
  call sic_ch (line,0,2,name,larg,.true.,error)
  if (error) return
  drange = 0.0
  crange  = 'NONE'
  nc = 0
  !
  if (sic_present(o_range,0)) then
    call sic_r8 (line,o_range,1,drange(1),.true.,error)
    if (error) return
    call sic_r8 (line,o_range,2,drange(2),.true.,error)
    if (error) return
    call sic_ke (line,o_range,3,crange,larg,.true.,error)
    if (error) return
  endif
  !
  if (sic_present(o_replace,0)) then
    call sic_ambigs (rname,argu,atype,ntype,vtype,mtype,error)
    if (error) return
    !
    if (atype.eq.'UV_DATA') then
      call map_message(seve%e,rname,'Replacing channels in UV data is not allowed')
      error = .true.
      return
    else
      call map_message(seve%e,rname,'Replacing channels in '//atype) 
      call sub_replace_image(name,ntype,nc,error)
    endif
  else if (sic_present(o_append,0)) then
    call sic_ambigs (rname,argu,atype,ntype,vtype,mtype,error)
    if (error) return
    !
    mgap = 1
    call sic_i4(line,o_append,1,mgap,.false.,error)
    if (error) return
    if (mgap.le.0 .or. mgap.gt.1000) then
      call map_message(seve%e,rname,'Maximum gap size out of [0,1000] range')
      error =.true.
      return
    endif
    call sub_append_image(name,ntype,nc,mgap,error)
    return
  else
    !
    if (argu.eq.'*') then
      if (crange.ne.'NONE') then
        call map_message(seve%e,rname, &
          & '/RANGE option not supported for WRITE *')
        error = .true.
        return
      endif
      do ntype=1,mtype
        if (save_data(ntype)) then
          if (vtype(ntype).eq.'UV_DATA') then
            call map_message(seve%w,rname,'Ignoring modified '//vtype(ntype))
          else
            call map_message(seve%i,rname,'saving '//vtype(ntype))
            mc = 0
            call sub_write_image(name,vtype(ntype),ntype,mc,.true.,err)
            error = error.or.err
          endif
        endif
      enddo
    else
      !
      ! Code for exact name matching
      atype = argu
      ntype = 0
      do is=1,mtype
        if (argu.eq.vtype(is)) then
          ntype = is
          atype = vtype(ntype)
          exit
        endif
      enddo
      !! call sic_ambigs (' ',argu,atype,ntype,vtype,mtype,error)
      !! if (error) then
      if (ntype.eq.0) then
        error = .false.
        atype = argu
        call map_message(seve%w,rname,'Attempting to write SIC image '//trim(atype))
      else
        atype = vtype(ntype)
      endif
      !
      if (atype.eq.'MOMENTS') then
        if (crange.ne.'NONE') then
          call map_message(seve%e,rname,'/RANGE option not supported for ' &
              & //' WRITE MOMENTS')
          error = .true.
          return
        endif
        !
        call sub_write_moments(name,error)
        return
      else if (atype.eq.'FLUX') then
        if (crange.ne.'NONE') then
          call map_message(seve%e,rname,'/RANGE option not supported for ' &
              & //' WRITE FLUX')
          error = .true.
          return
        endif
        !
        call sub_write_flux(name,error)
        return
      else if (atype.eq.'UV_DATA') then
        ! Find the range
        call out_range(rname,crange,drange,nc,huv,error)
        if (error) return
      else if (atype.eq.'MODEL_UV') then
        ! Find the range
        call out_range(rname,crange,drange,nc,huvm,error)
        if (error) return
      else if (crange.ne.'NONE') then
       !      if (atype.ne.'CLEAN') then
        call map_message(seve%e,rname,'/RANGE option not supported for ' &
            & //atype)
        error = .true.
        return
      endif
      !  endif
      !
      call sub_write_image(name,atype,ntype,nc,.false.,error)
    endif
  endif
  !
end subroutine write_comm
!
subroutine sub_write_image (name,atype,ntype,nc,quiet,error)
  use gkernel_interfaces, no_interface=>gdf_write_image
  use imager_interfaces, except_this=>sub_write_image
  use clean_def
  use clean_arrays
  use clean_default
  use clean_support
  use clean_types
  use uvfit_data
  use gkernel_types
  use gbl_format
  use gbl_message
  use iso_c_binding
  !----------------------------------------------------------------------
  ! @ private
  !
  ! IMAGER
  !*
  !   Support routine for command
  !
  !   WRITE Type File [/RANGE Start End Kind] [/TRIM]
  !
  ! Dispatch the writing operation to specific subroutines depending
  ! on the Type of data to be written
  !!
  !----------------------------------------------------------------------
  character(len=*), intent(in) :: name    !! File name 
  character(len=*), intent(in) :: atype   !! TYPE of data
  integer, intent(in) :: nc(2)            !! Channel range
  integer, intent(in) :: ntype            !! Type of file
  logical, intent(in) :: quiet            !! Do not return error if set
  logical, intent(out) :: error           !! Error return code
  !
  ! Constants
  character(len=*), parameter :: rname='WRITE'
  integer, parameter :: o_trim=4    ! /TRIM option number
  !
  ! Local ---
  character(len=32) :: dtype
  type (gildas) :: hin
  logical subset, trim_uv, trim_uvany
  character(len=filename_length) :: file
  type(sic_descriptor_t) :: desc
  type(c_ptr) :: cptr
  real(4), pointer :: aptr(:)
  integer :: n
  !
  ! Code ----
  subset = .false.
  !
  ! WRITE SUPPORT or POLYGON
  if (atype.eq.'SUPPORT') then
    call greg_poly_write(rname,supportpol,name,error)
    return
  else if (atype.eq.'POLYGON') then
    call gr_exec('WRITE POLYGON '//trim(name))
    return
  endif
  !
  dtype = etype(ntype)
  if (ntype.ne.0) then
    dtype = etype(ntype)
  else
    dtype = '.gdf'
  endif
  call sic_parse_file (name,' ',dtype,file)
  !
  if (write_format.ge.write_fits) then
    n = len_trim(file)-len_trim(dtype)+1
    if (file(n:).eq.dtype) then
      if (atype.eq.'UV_DATA') then
        file(n:) = '.uvfits'
      else
        file(n:) = '.fits'
      endif
    endif
  endif
  !
  select case(atype)
  case ('UV_DATA')
    !
    trim_uv = sic_present(o_trim,0)
    trim_uvany = sic_present(o_trim,1)
    !
    select case (current_uvdata)
    case('DATA_UV')
      call sub_write_uvset(file, themap%nfields, nc, huv, duv, trim_uv, trim_uvany, error, dchanflag)
      if (error) return
      if (.not.trim_uv) then
        call sub_setmodif(file,optimize(code_save_uv),nc)
      endif
      save_data(code_save_uv) = .false.
    case ('RESIDUAL_UV')
      call sub_write_uvset(file, themap%nfields, nc, huvf, duvf, trim_uv, trim_uvany, error)
    case ('MODEL_UV')
      call sub_write_uvset(file, themap%nfields, nc, huvm, duvm, trim_uv, trim_uvany, error)
    end select
    return ! This is a special case
  case ('MODEL_UV')
    if (huvm%loca%size.eq.0) then
      if (quiet) return
      call map_message(seve%e,rname,'Model UV data undefined ')
      error = .true.
      return
    endif
    call sub_write_uvset(file, themap%nfields, nc, huvm, duvm, trim_uv, trim_uvany, error)
  case ('CGAINS')
    if (hbgain%loca%size.eq.0) then
      if (quiet) return
      call map_message(seve%e,rname,'Baseline Gains CGAINS undefined ')
      error = .true.
      return
    endif
    call sub_write_uvdata(file,nc,hbgain,duvbg,error)
  case ('SELFCAL')
    if (hagain%loca%size.eq.0) then
      if (quiet) return
      call map_message(seve%e,rname,'Antenna Gains AGAINS undefined ')
      error = .true.
      return
    endif
    hagain%file = file
    call imager_write_data(hagain,dagain,error)
  case ('BEAM')
    if (hbeam%loca%size.eq.0) then
      if (quiet) return
      call map_message(seve%e,rname,'BEAM image undefined ')
      error = .true.
      return
    endif
    hbeam%file = file
    call imager_write_data(hbeam,dbeam,error)
  case ('DIRTY')
    if (hdirty%loca%size.eq.0) then
      if (quiet) return
      call map_message(seve%e,rname,'DIRTY image undefined ')
      error = .true.
      return
    endif
    hdirty%file = file
    call imager_write_data(hdirty,ddirty,error)
  case ('CLEAN')
    if (hclean%loca%size.eq.0) then
      if (quiet) return
      call map_message(seve%e,rname,'CLEAN image undefined ')
      error = .true.
      return
    endif
    hclean%file = file
    if (subset) then
      hclean%blc(3) = nc(1)
      hclean%trc(3) = nc(2)
      call gdf_update_image(hclean,dclean(1,1,nc(1)),error)
      hclean%blc(3) = 0
      hclean%trc(3) = 0
    else
      call imager_write_data(hclean,dclean,error)
    endif
  case ('RESIDUAL')
    if (hresid%loca%size.eq.0) then
      if (quiet) return
      call map_message(seve%e,rname,'RESIDUAL image undefined ')
      error = .true.
      return
    endif
    hresid%file = file
    call imager_write_data(hresid,dresid,error)
  case ('MASK')
    if (hmask%loca%size.eq.0) then
      if (quiet) return
      call map_message(seve%e,rname,'MASK image undefined ')
      error = .true.
      return
    endif
    hmask%file = file
    call imager_write_data(hmask,dmask,error)
  case ('CCT')
    if (hcct%loca%size.eq.0) then
      if (quiet) return
      call map_message(seve%e,rname,'Clean Component Table (CCT) undefined ')
      error = .true.
      return
    endif
    call cct_write(file,error)
  case ('PRIMARY')
    if (hprim%loca%size.eq.0) then
      if (quiet) return
      call map_message(seve%e,rname,'Primary BEAM image undefined ')
      error = .true.
      return
    endif
    hprim%file = file
    call imager_write_data(hprim,dprim,error)
  case ('SKY')
    if (hsky%loca%size.eq.0) then
      if (quiet) return
      call map_message(seve%e,rname,'SKY brightness image undefined ')
      error = .true.
      return
    endif
    hsky%file = file
    if (subset) then
      hsky%blc(3) = nc(1)
      hsky%trc(3) = nc(2)
      call gdf_update_image(hsky,dsky(1,1,nc(1)),error)
      hsky%blc(3) = 0
      hsky%trc(3) = 0
    else
      call imager_write_data(hsky,dsky,error)
    endif
  case ('FIELDS')
    call create_fields(error)
    if (hfields%loca%size.eq.0) then
      if (quiet) return
      call map_message(seve%e,rname,'Primary FIELDS image undefined ')
      error = .true.
      return
    endif
    hfields%file = file
    call imager_write_data(hfields,dfields,error)
  case ('UV_FIT') 
    if (huvfit%loca%size.eq.0) then
      if (quiet) return
      call map_message(seve%e,rname,'No UV_FIT table')
      error = .true.
      return
    endif
    huvfit%file = file
    call imager_write_data(huvfit,duvfit,error)
    return 
  case default
    ! Write any SIC Image variable
    call get_gildas(rname,atype,desc,hin,error)
    if (error) return
    !
    if (desc%size.eq.0) then
      call map_message(seve%e,rname,'Variable '//atype//' has no size')
      error = .true.
      return
    endif
    !
    call adtoad(desc%addr,cptr,1)
    call c_f_pointer(cptr,aptr,[desc%size])
    hin%file = file
    call imager_write_data(hin,aptr,error)
  end select
  !
  ! Set the Read/Write optimization and Save status
  call sub_setmodif(file,optimize(ntype),nc)
  save_data(ntype) = .false.
  !
end subroutine sub_write_image
!
subroutine sub_setmodif (file,opti,nc)
  use gkernel_types
  use clean_types
  !---------------------------------------------------------------------
  ! @ private
  !
  ! IMAGER
  !*
  !   Utility routine for READ and WRITE
  !
  !   Update the Read / Write optimization status
  !!
  !---------------------------------------------------------------------
  character(len=*), intent(in) :: file  !
  ! Filename
  type(readop_t), intent(inout) :: opti 
  !! Status of corresponding buffer
  integer, intent(in) :: nc(2)          
  !! Channel Range to be read
  !
  logical :: error
  !
  if (any(nc.ne.0)) then
    !
    ! Subset write: the internal buffer is not the written file
    return
  else
    ! Whole write: the buffer and the written file match exactly
    ! so one can reset the corresponding "optimize" structure
    ! with this new file.  However, this does not guarantee a full
    ! read optimization here, as the input file and output file may
    ! have different names (but be identical).
    !
    call gag_filmodif(file,opti%modif,error)
  endif
end subroutine sub_setmodif
!
subroutine write_cct(file,error)
  use gkernel_interfaces
  use clean_def
  use clean_arrays
  !----------------------------------------------------------------------
  ! @ private
  !
  ! IMAGER
  !*
  !   Support routine for command
  !
  !   WRITE CCT File [/RANGE Start End Kind]
  !!
  !----------------------------------------------------------------------
  character(len=*), intent(in) :: file    !! Input file name
  logical, intent(out) :: error           !! Error return code
  !
  logical, parameter :: OLD=.false. ! Set to .true. to usee older code...
  !
  type (gildas) :: htcc
  integer :: mclean,i
  !
  ! Define the image header
  call gildas_null (htcc, type = 'IMAGE')
  !
  if (OLD) then
    call gdf_copy_header (hdirty,htcc, error)
    htcc%gil%ndim = 3
    htcc%char%unit = 'Jy'
    !
    htcc%gil%dim(1) = 3
    ! Keep the same axis description
    htcc%gil%xaxi = 1
    !
    htcc%gil%convert(:,2) = hdirty%gil%convert(:,3)
    htcc%gil%convert(:,3) = hdirty%gil%convert(:,2)
    htcc%gil%dim(2) = hdirty%gil%dim(3)
    htcc%char%code(2) = hdirty%char%code(3)
    htcc%gil%faxi = 2
    !
    htcc%gil%dim(3) = ubound(dcct,3)
    htcc%char%code(3) = 'COMPONENT'
    htcc%gil%yaxi = 3
    !
  else
    call gdf_copy_header (hcct,htcc, error)
  endif
  htcc%file = file
  mclean = htcc%gil%dim(3)
  do i=1,htcc%gil%dim(3)
    if (all(dcct(:,:,i).eq.0)) then
      mclean = i-1
      exit
    endif
  enddo
  !
  ! Initialize BLCs...
  htcc%blc = 0
  htcc%trc = 0
  htcc%gil%dim(3) = max(mclean,1)  ! At least one (possibly empty) component
  call gdf_write_image(htcc,dcct(:,:,1:mclean),error)
  !
end subroutine write_cct
!
subroutine sub_write_uvdata(file,nc,uvin,visi,error, mv, ivis, cflag)
  use image_def
  use gkernel_interfaces
  use gbl_message
  use imager_interfaces, only : map_message, sub_extract_block
  !---------------------------------------------------------------------
  ! @ private-mandatory
  !
  ! IMAGER
  !*
  !   Utility routine for WRITE command
  !
  !   Write a subset of the loaded UV data
  !!
  !---------------------------------------------------------------------
  character(len=*), intent(in) :: file    !! Input file name
  integer, intent(in) :: nc(2)            !! Channel range
  type(gildas), intent(in) :: uvin        !! UV data header
  real, intent(in) :: visi(:,:)           !! Visibilities
  logical, intent(out) :: error           !! Logical error flag
  integer, intent(in), optional :: mv     !! Number of visibilities
  integer, intent(in), optional :: ivis(:)    !! Visibility pointers 
  integer, intent(in), optional :: cflag(:)   !! Channel flags
  !
  ! Local ---
  type (gildas) :: uvou
  integer :: blc, trc, ib, iv, nblock, ier, i, ic
  integer(kind=index_length) :: nvisi
  logical :: all, do_zero
  character(len=80) :: mess
  !
  ! Code ----
  call gildas_null(uvou, type= 'UVT')
  call gdf_copy_header(uvin, uvou, error)
  if (error) return
  call sic_parse_file(file,' ','.uvt',uvou%file)
  !
  uvou%gil%ntrail = 0
  call gdf_setuv(uvou,error)
  !
  ! Flagged channels
  do_zero = .false.
  if (present(cflag)) then
    if (any(cflag.eq.0)) do_zero = .true.
  endif
  if (do_zero) call map_message(seve%i,'WRITE','Nullifying filtered channels')
  !
  ! Nullify the Blanking
  uvou%gil%blan_words = 0
  !
  uvou%gil%nchan = nc(2)-nc(1)+1
  uvou%gil%ref(1) = uvin%gil%ref(1)-nc(1)+1
  uvou%gil%dim(1) = uvou%gil%nlead + uvou%gil%nstokes*uvou%gil%natom*uvou%gil%nchan + uvou%gil%ntrail
  uvou%gil%lcol = uvou%gil%nlead + uvou%gil%nstokes*uvou%gil%natom*uvou%gil%nchan 
  !
  all = uvou%gil%nchan.eq.uvin%gil%nchan
  if ((all .and. .not.present(mv)).and..not.do_zero) then
    !
    call imager_write_data(uvou,visi,error)
  else
    ! Only write a subset, either by trimming or by channels, or by Zeroing
    ! channels, or any combination at once...
    !
    ! Define blocking factor
    if (present(mv)) then
      uvou%gil%nvisi = mv
      uvou%gil%dim(2) = mv
    endif
    call gdf_nitems('SPACE_GILDAS',nblock,uvou%gil%dim(1)) ! Visibilities at once
    nblock = min(nblock,uvou%gil%dim(2))
    ! Allocate space
    allocate (uvou%r2d(uvou%gil%dim(1),nblock), stat=ier)
    if (ier.ne.0) then
      write(mess,*) 'Memory allocation error ',uvou%gil%dim(1), nblock
      call map_message(seve%e,'WRITE',mess)
      error = .true.
      return
    endif
    !
    ! Shift trailing columns if any
    if (uvou%gil%ntrail.ne.0) then
      do i=1,code_uvt_last
        if (uvou%gil%column_pointer(i).gt.uvou%gil%lcol) then
          uvou%gil%column_pointer(i) = uvou%gil%column_pointer(i)-uvin%gil%lcol+uvou%gil%lcol
        endif
      enddo
    endif    
    !
    call gdf_create_image(uvou,error)
    if (error) then
      deallocate(uvou%r2d,stat=ier)
      call gdf_close_image(uvou,error)
      error = .true.
      return
    endif
    ! Loop over UV table
    uvou%blc = 0
    uvou%trc = 0
    do ib = 1,uvou%gil%dim(2),nblock
      write(mess,*) ib,' to ',ib+nblock-1,' / ',uvou%gil%dim(2)
      call map_message(seve%i,'WRITE',mess)
      blc = ib
      trc = min(uvou%gil%dim(2),ib-1+nblock)
      uvou%blc(2) = blc
      uvou%trc(2) = trc
      nvisi = trc-blc+1
      !
      ! Here do the job
      if (present(mv)) then
        do iv=blc,trc
          if (all) then
            uvou%r2d(:,iv-blc+1) = visi(:,ivis(iv))
          else
            call sub_extract_block(uvou, uvou%r2d(:,iv-blc+1), uvin, &
              &   visi(:,ivis(iv)), nvisi, nc)
          endif
        enddo
      else
        call sub_extract_block(uvou, uvou%r2d, uvin, visi(:,blc:trc), &
          & nvisi, nc)
      endif
      !
      if (do_zero) then
        ! cflag  corresponds to the original Channels
        ! we have a subset shifted by NC(1)
        do iv=1,nvisi
          do ic=1,uvou%gil%nchan
            if (cflag(ic+nc(1)-1).eq.0) uvou%r2d(5+3*ic:7+3*ic,iv) = 0.
          enddo
        enddo
      endif
      !
      ! Write
      call gdf_write_data(uvou, uvou%r2d, error)
    enddo
    call gdf_close_image(uvou,error)
    deallocate(uvou%r2d,stat=ier)
  endif
  !
end subroutine sub_write_uvdata
!
subroutine sub_extract_block(out, dout, in, din, nvisi, nc)
  use image_def
  !---------------------------------------------------------------------
  ! @ private
  !
  !*
  !   IMAGER -- Utility routine for WRITE command
  !   
  !   Extract a subset block of UV data
  !!
  !---------------------------------------------------------------------
  type(gildas), intent(in) :: out                   !! Output UV header
  type(gildas), intent(in) :: in                    !! Input UV header
  integer(kind=index_length) :: nvisi               !! Number of visibilities
  real, intent(in) :: din(in%gil%dim(1),nvisi)      !! Input visibilities
  real, intent(out) :: dout(out%gil%dim(1),nvisi)   !! Output visibilities
  integer, intent(in) :: nc(2)                      !! Channel range
  !
  ! Local ---
  integer :: iv, icf, icl, jcf, jcl
  !
  ! Code ----
  icf = in%gil%nlead+(nc(1)-1)*in%gil%natom+1
  icl = in%gil%nlead+nc(2)*in%gil%natom
  jcf = out%gil%nlead+1
  jcl = out%gil%nlead+out%gil%nchan*out%gil%natom
  !
  do iv=1,nvisi
    dout(1:in%gil%nlead,iv) = din(1:in%gil%nlead,iv)
    dout(jcf:jcl,iv) = din(icf:icl,iv)
    if (out%gil%ntrail.gt.0) then
      dout(out%gil%dim(1)-out%gil%ntrail+1:out%gil%dim(1),iv) =   &
      &     din(in%gil%dim(1)-in%gil%ntrail+1:in%gil%dim(1),iv)
    endif
  enddo
end subroutine sub_extract_block
!
subroutine sub_replace_image (name,ntype,nc,error)
  use gkernel_interfaces
  use imager_interfaces, except_this=>sub_replace_image
  use clean_def
  use clean_arrays
  use clean_support
  use clean_types
  use gbl_format
  use gbl_message
  !----------------------------------------------------------------------
  ! @ private
  !
  !*
  !   IMAGER -- Support routine for command
  ! 
  !   WRITE Type File /REPLACE 
  !
  ! Dispatch the writing operation to specific subroutines depending
  ! on the Type of data to be written
  !!
  !----------------------------------------------------------------------
  character(len=*), intent(in) :: name      !! Short file name
  integer, intent(in) :: nc(2)              !! Channel range
  integer, intent(in) :: ntype              !! Type of data
  logical, intent(out) :: error             !! Error return flag
  !
  character(len=*), parameter :: rname='WRITE /REPLACE'
  !
  ! Local ---
  character(len=12) atype
  character(len=filename_length) :: file
  !
  ! Code ----
  if (write_format.ge.write_fits) then
    call map_message(seve%e,'WRITE','FITS format not yet supported for /REPLACE')
    error = .true.
    return
  endif
  !
  atype = vtype(ntype)
  call sic_parse_file (name,' ',etype(ntype),file)
  !
  select case(atype)
  case ('BEAM')
    if (hbeam%gil%dim(3).ne.1) then
      if (hbeam%gil%dim(4).ne.1) then
        call map_message(seve%e,rname,'Multi-frequency beams not yet supported for mosaics')
        error = .true.
      else
        call sub_replace(atype,file,dbeam(:,:,:,1),hbeam,error)
      endif
    else
      call map_message(seve%w,rname,'Single beam plane only')
    endif  
  case ('DIRTY')
    call sub_replace(atype,file,ddirty,hdirty,error)
  case ('CLEAN')
    call sub_replace(atype,file,dclean,hclean,error)
  case ('RESIDUAL')
    call sub_replace(atype,file,dresid,hresid,error)
  case ('MASK')
    call sub_replace(atype,file,dmask,hmask,error)
  case ('CCT')      !! The structure is quite different here
    call map_message(seve%e,'WRITE','Type '//atype//' not yet supported for /REPLACE')
    error = .true.
    return
    ! to be done !    call sub_replace(atype,file,dcct,hcct,error)
  case ('SKY')
    call sub_replace(atype,file,dsky,hsky,error)
  case default
    call map_message(seve%e,'WRITE','Unsupported type '//atype//' for /REPLACE')
    error = .true.
    return
  end select
  !
  ! Set the Read/Write optimization and Save status
  call sub_setmodif(file,optimize(ntype),nc)
  save_data(ntype) = .false.
  !
end subroutine sub_replace_image
!
subroutine sub_replace(name,file,data,head,error)
  use image_def
  use gkernel_interfaces
  use gbl_message
  use imager_interfaces, only : map_message
  !-------------------------------------------------------
  ! @ private
  !*
  !   IMAGER -- Support routine for WRITE /REPLACE
  !!
  !-------------------------------------------------------
  character(len=*), intent(in) :: name      !! Name of buffer
  character(len=*), intent(in) :: file      !! File name
  type(gildas), intent(inout) :: head       !! Header of buffer
  real(kind=4), intent(in) :: data(:,:,:)   !! Data cube
  logical, intent(inout) :: error           !! Error return flag
  !
  ! Constants
  character(len=*), parameter :: rname='WRITE /REPLACE'
  real(8), parameter :: epsilon=1d-5
  !
  ! Local ---
  type(gildas) :: hall
  integer :: imin, imax, itmp
  real(8) :: rval, velo
  character(len=64) :: chain
  !
  ! Code ----
  if (head%loca%size.eq.0) then
    call map_message(seve%e,rname,name//' image undefined ')
    error = .true.
    return
  endif
  !
  call gildas_null(hall)
  hall%file = file
  call gdf_read_header(hall,error)
  if (error) return
  !
  ! Basic checks of coordinates
  if ( any(head%gil%dim(1:2).ne.hall%gil%dim(1:2)) ) then
    call map_message(seve%e,rname,'Dimensions do not match')
    error = .true.
  endif
  if ( any(head%gil%convert(:,1:2).ne.hall%gil%convert(:,1:2)) ) then
    call map_message(seve%e,rname,'Positions do not match')
    Print *,'Head ',head%gil%convert(:,1:2)
    Print *,'Hout ',hall%gil%convert(:,1:2)
    Print *,'Difference ',head%gil%convert(:,1:2)-hall%gil%convert(:,1:2)
    error = .true.
  endif
  !
  if ( abs(head%gil%inc(3)).ne.abs(hall%gil%inc(3)) ) then
    call map_message(seve%e,rname,'Frequency resolution do not match')
    error = .true.
  endif
  if (error) return
  !
  ! Check which range in the file is needed - Match the velocities
  velo = (1.d0-head%gil%ref(3))*head%gil%inc(3) + head%gil%val(3)
  rval = (velo-hall%gil%val(3))/hall%gil%inc(3) + hall%gil%ref(3)
  imin = nint(rval)
  !
  if (abs(dble(imin)-rval).gt.epsilon*abs(head%gil%inc(3))) then
    call map_message(seve%e,rname,'Frequency axis does not match')
    error = .true.
  endif
  if (error) return
  !
  velo = (head%gil%dim(3)-head%gil%ref(3))*head%gil%inc(3) + head%gil%val(3)
  rval = (velo-hall%gil%val(3))/hall%gil%inc(3) + hall%gil%ref(3)
  imax = nint(rval)
  !
  if (imin.gt.imax) then
    itmp = imin
    imin = imax
    imax = itmp
  endif
  !
  if (imin.lt.1 .or. imax.gt.hall%gil%dim(3)) then
    write(chain,'(A,A,I0,A,I0)') name,' falls in range ',imin,',',imax
    call map_message(seve%e,rname,chain)
    error = .true.
    return
  endif
  !
  hall%blc(3) = imin
  hall%trc(3) = imax
  !
  call gdf_update_image(hall,data,error)
end subroutine sub_replace
!
subroutine sub_append_image (name,ntype,nc,mgap,error)
  use gkernel_interfaces
  use imager_interfaces, except_this=>sub_append_image
  use clean_def
  use clean_arrays
  use clean_support
  use clean_types
  use gbl_format
  use gbl_message
  !----------------------------------------------------------------------
  ! @ private
  !
  !*
  !   IMAGER -- Support outine for command
  !
  !   WRITE Type File /APPEND  [MaxGap]
  !
  ! Dispatch the writing operation to specific subroutines depending
  ! on the Type of data to be written
  !!
  !----------------------------------------------------------------------
  character(len=*), intent(in) :: name      !! Short file name
  integer, intent(in) :: nc(2)              !! Channel range
  integer, intent(in) :: ntype              !! Type of buffer
  logical, intent(out) :: error             !! Error return flag
  integer, intent(in) :: mgap               !! Maximum Gap size 
  !! This is to avoid attempting to stitch together
  !! Cubes with very different 3rd axis, but still allow reasonable
  !! concatenation
  !
  ! Constants
  character(len=*), parameter :: rname='WRITE /REPLACE'
  !
  ! Local ---
  character(len=12) atype
  character(len=filename_length) :: file
  !
  ! Code ----
  atype = vtype(ntype)
  call sic_parse_file (name,' ',etype(ntype),file)
  !
  select case(atype)
  case ('BEAM')
    if (hbeam%gil%dim(3).ne.1) then
      if (hbeam%gil%dim(4).ne.1) then
        call map_message(seve%e,rname,'Multi-frequency beams not yet supported for mosaics')
        error = .true.
      else
        call sub_append(atype,file,dbeam(:,:,:,1),hbeam,mgap,error)
      endif
    else
      call map_message(seve%w,rname,'Single beam plane only')
    endif  
  case ('DIRTY')
    call sub_append(atype,file,ddirty,hdirty,mgap,error)
  case ('CLEAN')
    call sub_append(atype,file,dclean,hclean,mgap,error)
  case ('RESIDUAL')
    call sub_append(atype,file,dresid,hresid,mgap,error)
  case ('MASK')
    call sub_append(atype,file,dmask,hmask,mgap,error)
  case ('CCT')   !! The structure is quite different here
    call map_message(seve%w,'WRITE','Type '//atype//' not yet debugged for /APPEND',1)
    call cct_append(file,dcct,hcct,mgap,error)
    !no longer!    error = .true.
    !no longer!    return
  case ('SKY')
    call sub_append(atype,file,dsky,hsky,mgap,error)
  case default
    call map_message(seve%e,'WRITE','Unsupported type '//atype//' for /APPEND')
    error = .true.
    return
  end select
  !
  ! Set the Read/Write optimization and Save status
  call sub_setmodif(file,optimize(ntype),nc)
  save_data(ntype) = .false.
  !
end subroutine sub_append_image
!<FF>
subroutine sub_append(name,file,data,head,mgap,error)
  use image_def
  use gkernel_interfaces
  use gbl_message
  use imager_interfaces, only : map_message, gdf_match_header
  !-------------------------------------------------------
  ! @ private
  !*
  !   Support routine for WRITE /APPEND
  !!
  !-------------------------------------------------------
  character(len=*), intent(in) :: name      !! Name of buffer
  character(len=*), intent(in) :: file      !! File name
  type(gildas), intent(inout) :: head       !! Header of buffer
  real(kind=4), intent(in) :: data(:,:,:)   !! Data
  integer, intent(in) :: mgap               !! Max Gap size
  logical, intent(inout) :: error           !! Error return flag
  !
  ! Constants
  character(len=*), parameter :: rname='WRITE /APPEND'
  real(8), parameter :: epsilon=1d-5
  !
  ! Local ---
  type(gildas) :: hall
  integer :: imin, imax, igap, faxi
  logical :: err
  character(len=128) :: chain
  integer(kind=index_length) :: newdim  ! New value of last dimension
  integer(kind=index_length) :: olddim  ! New value of last dimension
  real, allocatable :: dnull(:,:,:)
  integer :: ier
  !
  ! Code ----
  if (head%loca%size.eq.0) then
    call map_message(seve%e,rname,name//' image undefined ')
    error = .true.
    return
  endif
  !
  call gildas_null(hall)
  hall%file = file
  call gdf_read_header(hall,error)
  if (error) return
  !
  call gdf_match_header(head,hall,mgap,imin,imax,igap,error)
  ! Close this image - Extend works on a new Slot because of size
  err = .false.
  call gdf_close_image(hall,err)
  if (error) return
  !
  newdim = imax + igap         ! Append channels
  faxi = hall%gil%faxi
  !
  ! Extend image - image is left open
  olddim = hall%gil%dim(faxi)
  write(chain,'(A,A,I0,A)') name,' extended to ',newdim, ' channels' 
  call map_message(seve%i,rname,chain)
  call gdf_extend_image (hall,newdim,error)
  if (error) then
    call map_message(seve%e,rname,'Extension failed')
    return
  endif
  !
  ! Write Gap if needed
  if (igap.gt.0) then
    hall%blc(faxi) = olddim+1
    hall%trc(faxi) = imin+igap
    allocate(dnull(hall%gil%dim(1),hall%gil%dim(2),igap-1),stat=ier)
    dnull = 0.
    call gdf_write_data(hall,dnull,err)
  endif
  !
  ! Write in place (will replace possible overlap here)
  hall%blc(faxi) = newdim-min(head%gil%dim(faxi),newdim-olddim)+1
  hall%trc(faxi) = newdim
  call gdf_write_data(hall,data,error)
  if (error) then
    call map_message(seve%e,rname,'Data writing failed after extension')
  endif
  ! Close image
  err = .false.
  call gdf_close_image (hall,err)
end subroutine sub_append
!
subroutine sub_write_moments(name,error)
  use gkernel_interfaces
  use moment_arrays
  use gbl_message
  use imager_interfaces, only : map_message
  !-------------------------------------------------------
  ! @ private
  !*
  !   IMAGER -- Support routine for WRITE MOMENTS 
  !
  !   4 separate files are written in this case.
  !!
  !-------------------------------------------------------
  character(len=*), intent(in) :: name  !! Short file name
  logical, intent(inout) :: error       !! Error return flag
  !
  character(len=*), parameter :: rname='WRITE MOMENTS'
  !
  error = .false.
  if (hmean%loca%size.eq.0) then
    call map_message(seve%e,rname,'No M_AREA buffer')
    error = .true.
  endif
  if (hpeak%loca%size.eq.0) then
    call map_message(seve%e,rname,'No M_PEAK buffer')
    error = .true.
  endif
  if (hvelo%loca%size.eq.0) then
    call map_message(seve%e,rname,'No M_VELO buffer')
    error = .true.
  endif
  if (hwidth%loca%size.eq.0) then
    call map_message(seve%e,rname,'No M_WIDTH buffer')
    error = .true.
  endif
  if (error) return
  !
  call sic_parse_file (name,' ','.area',hmean%file)
  call imager_write_data(hmean,dmean,error)
  call sic_parse_file (name,' ','.peak',hpeak%file)
  call imager_write_data(hpeak,dpeak,error)
  call sic_parse_file (name,' ','.velo',hvelo%file)
  call imager_write_data(hvelo,dvelo,error)
  call sic_parse_file (name,' ','.width',hwidth%file)
  call imager_write_data(hwidth,dwidth,error)
end subroutine sub_write_moments
! 
!
subroutine sub_write_flux(name,error)
  use gkernel_interfaces
  use moment_arrays
  use gbl_message
  use imager_interfaces, only : map_message
  !-------------------------------------------------------
  ! @ private
  !*
  !   IMAGER -- Support routine for WRITE FLUX  
  !!
  !-------------------------------------------------------
  character(len=*), intent(in) :: name    !! Short file name
  logical, intent(inout) :: error         !! Error return flag
  !
  character(len=*), parameter :: rname='WRITE FLUX'
  !
  type(gildas) :: htab
  integer :: ier
  !
  if (flux_nf.eq.0) then
    call map_message(seve%e,rname,'No FLUX data, use command FLUX to create one')
    error = .true.
    return
  endif
  !
  call gildas_null(htab)
  call sic_parse_file (name,' ','.tab',htab%file)
  htab%gil%ndim = 2
  htab%gil%dim(1) = flux_nc
  htab%gil%dim(2) = flux_nf+2
  allocate (htab%r2d(htab%gil%dim(1),htab%gil%dim(2)),stat=ier)
  if (ier.ne.0) then
    call map_message(seve%e,rname,'Memory allocation error')
    error = .true.
    return
  endif  
  !
  htab%r2d(:,1) = flux_velo
  htab%r2d(:,2) = flux_freq  ! Loss of precision, but tolerable in most cases.
  htab%r2d(:,3:) = flux_values
  !
  call gdf_write_image(htab,htab%r2d,error)
  deallocate(htab%r2d)
end subroutine sub_write_flux
!
subroutine sub_write_uvset(file, nfields, nc, huvl, visi, trim_uv, trim_uvany, error, cflag)
  use image_def
  use gbl_message
  use gkernel_interfaces
  use imager_interfaces, only : map_message, sub_write_uvdata
  !---------------------------------------------------------------------
  ! @ private
  !
  !*
  !   IMAGER -- Support routine for WRITE UV
  !
  !   Write the Currently Selected UV data set
  !!
  !---------------------------------------------------------------------
  character(len=*), intent(in) :: file          !! Output file name
  integer, intent(in) :: nc(2)                  !! Channel range
  type(gildas), intent(in) :: huvl              !! UV data header 
  real, intent(in) :: visi(:,:)                  !! UV data
  integer, intent(in) :: nfields                !! Number of fields
  logical, intent(in) :: trim_uv, trim_uvany    !! trimming options
  logical, intent(out) :: error                 !! Error return
  integer, intent(in), optional :: cflag(:)     !! Per Channel flags
  !
  character(len=*), parameter :: rname='WRITE UV'
  !
  ! Local ---
  integer(kind=index_length) :: iv,nv,im
  integer, allocatable :: ivis(:)
  integer :: ier, ic, nch, np, mv
  logical :: do_zero
  !
  ! Code ----
  error = .false.
  if (huvl%loca%size.eq.0) then
    call map_message(seve%e,rname,'UV data undefined ')
    error = .true.
    return
  endif
  !
  if (nfields.ne.0 .and. huvl%gil%pang.ne.0.0) then
    call map_message(seve%e,rname,'Cannot write rotated Mosaic UV data: no convention defined by IRAM')
    error = .true.
    return    
  endif
  !
  do_zero = .false.
  if (present(cflag)) then
    if (any(cflag.eq.0)) do_zero = .true.
  endif
  !
  ! Trim if needed
  if (trim_uv) then
    np = huvl%gil%dim(1)
    nv = huvl%gil%nvisi  !! not %dim(2)
    nch = huvl%gil%nchan * huvl%gil%nstokes
    allocate(ivis(nv),stat=ier)
    if (ier.ne.0) then
      call map_message(seve%e,rname,'Memory allocation failure')
      error = .true.
      return
    endif
    !
    ! First passs to identify all valid visibilities
    ! Caution: assume default model here.
    ! This is guaranteed inside IMAGER, since we use gdf_read_uvdataset
    mv = 0
    do iv = 1,nv
      if (trim_uvany) then
        ! If a single channel is Bad, flag data
        im = 1
        do ic=1,nch
          if (visi(7+3*ic,iv).le.0) then
            im = 0
            exit
          endif
        enddo
      else
        ! If a single channel is Good, use data
        im = 0
        do ic=1,nch
          if (visi(7+3*ic,iv).gt.0) then
            im = 1
            exit
          endif
        enddo
      endif
      if (im.ne.0) then
        mv = mv+1
        ivis(mv) = iv
      endif
    enddo
    !
    ! Create output image
    if (do_zero) then
      call sub_write_uvdata(file,nc,huvl,visi,error, mv, ivis, cflag)
    else
      call sub_write_uvdata(file,nc,huvl,visi,error, mv, ivis)
    endif
  else
    ! Create output image
    if (do_zero) then
      call sub_write_uvdata(file,nc,huvl,visi,error,cflag=cflag)
    else
      call sub_write_uvdata(file,nc,huvl,visi,error)
    endif
  endif
end subroutine sub_write_uvset
!
subroutine imager_write_data(head,data,error)
  use image_def
  use gkernel_types
  use gkernel_interfaces
  use gbl_message
  use imager_interfaces, only : map_message
  use clean_types
  !*
  !   Utility routine to write a Data Set in various formats.
  ! Supported formats are GILDAS, FITS, and also CSV fro 2-D Tables
  !!
  type(gildas), intent(inout) :: head  !! Data header
  real, intent(in) :: data(*)          !! Data buffer - Contiguous array
  logical, intent(inout) :: error      !! Logical error flag
  !
  ! Local ---
  type(gildas) :: htmp
  logical :: overwrite=.true.
  integer :: nbits=-32
  character(len=4) :: style='  '
  !
  ! Code ----
  if (write_format.eq.write_csv) then
    if (head%gil%ndim.eq.2.and.head%gil%dim(2).lt.128) then
      call table_to_csv(head,data,error)
      return
    else
      call map_message(seve%w,'WRITE','CSV format not suited for this data, using GILDAS format')
    endif
  endif
  !
  if (write_format.ge.write_fits) then
    if ((write_format.eq.write_fits).or.(head%gil%faxi.eq.0)) then
      head%loca%addr = locwrd(data)
      call gildas_to_fits(head,head%file,style,nbits,overwrite,error)
    else
      call gildas_null(htmp)
      call gdf_copy_header(head,htmp,error)
      htmp%loca%addr = locwrd(data)
      if (write_format.eq.write_fits_velo) then
        htmp%gil%convert(2,htmp%gil%faxi) = htmp%gil%voff
        htmp%gil%convert(3,htmp%gil%faxi) = htmp%gil%vres
        htmp%char%code(htmp%gil%faxi) = 'VELOCITY'
      else
        htmp%gil%convert(2,htmp%gil%faxi) = htmp%gil%freq
        htmp%gil%convert(3,htmp%gil%faxi) = htmp%gil%fres
        htmp%char%code(htmp%gil%faxi) = 'FREQUENCY'
      endif
      call gildas_to_fits(htmp,head%file,style,nbits,overwrite,error)
    endif
  else
    call gdf_write_image(head,data,error)
  endif
end subroutine imager_write_data
!
subroutine table_to_csv(head,data,error)
  use image_def
  use gkernel_interfaces, only : locwrd
  use iso_c_binding
  !*
  !   Utility routine
  !
  ! Write GILDAS Table to CSV file. Supports Real(8) and
  ! Real(4) tables.
  !!
  type(gildas), intent(inout) :: head  !! Table Header
  real, intent(in) :: data(*)          !! Data buffer -- contiguous, no type checking
  logical, intent(inout) :: error
  !
  ! Local ---
  integer :: nx, ny
  type(c_ptr) :: cptr
  real(kind=8), pointer :: d2ptr(:,:)
  integer(kind=address_length) :: addr
  !
  ! Code ----
  nx = head%gil%dim(1)
  ny = head%gil%dim(2)
  if (head%gil%form.eq.fmt_r4) then
    call table_to_csv4(nx,ny,head%file,data)
  else if (head%gil%form.eq.fmt_r8) then
    ! This creates a Warning for type mismatch on "data"
    !   call table_to_csv8(nx,ny,head%file,data)
    ! Circumvent the issue with standard Fortran C interface
    !   cptr = c_loc(data)    
    ! Would require "target" status to data, and thus an interface,and thus type checking on data...
    ! Use non-standard alternative
    addr = locwrd(data)
    call adtoad(addr,cptr,1)
    call c_f_pointer(cptr,d2ptr,head%gil%dim(1:2))    
    call table_to_csv8(nx,ny,head%file,d2ptr)
  endif
end subroutine table_to_csv
!
subroutine table_to_csv4(nx,ny,file,data)
  use gkernel_interfaces
  !*
  !   Utility routine
  !
  ! Write Real(4) 2-D array Table to CSV file. 
  !!
  integer, intent(in) :: nx   !! First dimension
  integer, intent(in) :: ny   !! Second dimension
  character(len=*), intent(inout) :: file !! File name
  real, intent(in) :: data(nx,ny)   !! Array
  !
  ! Local ---
  integer :: ier, lun, i,j
  !
  ! Code ----
  lun = 0
  ier = sic_open(lun,file,'NEW',.false.)
  do i=1,nx
    write(lun,*) (data(i,j),j=1,ny)
  enddo
  close(unit=lun)
  call sic_frelun(lun)
end subroutine table_to_csv4
!
subroutine table_to_csv8(nx,ny,file,data)
  use gkernel_interfaces
  !*
  !   Utility routine
  !
  ! Write Real(8) 2-D array Table to CSV file. 
  !!
  integer, intent(in) :: nx   !! First dimension
  integer, intent(in) :: ny   !! Second dimension
  character(len=*), intent(inout) :: file !! File name
  real(kind=8), intent(in) :: data(nx,ny) !! Array
  !
  ! Local ---
  integer :: ier, lun, i,j
  !
  ! Code ----
  lun = 0
  ier = sic_open(lun,file,'NEW',.false.)
  do i=1,nx
    write(lun,*) (data(i,j),j=1,ny)
  enddo
  close(unit=lun)
  call sic_frelun(lun)
end subroutine table_to_csv8
