!MOSAIC> writ beam toto /app
!E-WRITE /APPEND,  BEAM         is not contiguous, starts at 1
!E-WRITE,  failed to complete
!
subroutine write_image (line,error)
  use gkernel_interfaces
  use imager_interfaces, except_this=>write_image
  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
  ! Global
  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'
  ! Local
  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, allowed(2)
  data allowed /'GILDAS','FITS'/
  !
  call sic_ke (line,0,1,argu,larg,.true.,error)
  if (error) return
  if (argu.eq.'?') then
    call sic_ambigs (rname,argu,atype,ntype,vtype,mtype,error)
    return
  elseif (argu.eq.'UV') then
    argu = 'UV_DATA'
  endif
  !
  fits_format = .false. 
  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
      fits_format = .false.
    else if (key(1:nk).eq.allowed(2)(1:nk)) then
      fits_format = .true.
      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
    else
      call map_message(seve%e,rname,'Unknown ouput data format, only FITS and GILDAS allowed')
      error = .true.  
    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
    !
    call sub_append_image(name,ntype,nc,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))
            exit ! Do NOT save UV_DATA in this way...
          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
        call map_message(seve%w,rname,'Attempting to write a SIC image')
        error = .false.
        atype = argu
      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').or.(atype.eq.'MODEL') ) then 
        ! Find the range
        call out_range(rname,crange,drange,nc,huv,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_image
!
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
  !
  ! Local
  character(len=*), parameter :: rname='WRITE'
  type (gildas) :: hin
  logical subset, trim_uv, trim_uvany
  character(len=filename_length) :: file
  integer, parameter :: o_trim=4
  type(sic_descriptor_t) :: desc
  type(c_ptr) :: cptr
  real(4), pointer :: aptr(:)
  integer :: n
  !
  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
  !
  if (ntype.ne.0) then
    call sic_parse_file (name,' ',etype(ntype),file)
  else if (.not.fits_format) then
    call sic_parse_file (name,' ','.gdf',file)
  endif
  if (fits_format) then
    n = len_trim(file)
    if (file(n-4:n).ne.'.fits') file(n+1:) = '.fits'
  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)
      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')
    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_uvdata(file,nc,huvm,duvm,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
!    do while (hbeam%gil%dim(hbeam%gil%ndim).eq.1)
!      hbeam%gil%ndim = hbeam%gil%ndim-1
!      if (hbeam%gil%ndim.eq.0) exit
!    enddo
    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,'CC Table undefined ')
      error = .true.
      return
    endif
    call write_cct(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
  !   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)          ! 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
  !
  type (gildas) :: htcc
  integer :: mclean,i
  logical, parameter :: OLD=.false.
  !
  ! 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,duv,error, mv, ivis)
  use image_def
  use gkernel_interfaces
  use gbl_message
  use imager_interfaces, only : map_message, sub_extract_block
  !---------------------------------------------------------------------
  ! @ private-mandatory
  !
  ! IMAGER
  !   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) :: duv(:,:)          ! Visibilities
  logical, intent(out) :: error         ! Logical error flag
  !
  integer, intent(in), optional :: mv       ! Number of visibilities
  integer, intent(in), optional :: ivis(:)  ! Visibility pointers ?
  !
  type (gildas) :: uvou
  integer :: blc, trc, ib, iv, nblock, ier, i
  integer(kind=index_length) :: nvisi
  logical :: all
  character(len=80) :: mess
  !
  call gildas_null(uvou, type= 'UVT')
  call gdf_copy_header(uvin, uvou, error)
  if (error) return
  call sic_parse_file(file,' ','.uvt',uvou%file)
  !
  ! 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)) then
    !
    call imager_write_data(uvou,duv,error)
  else
    ! Only write a subset, either by trimming or by channels, or both 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) = duv(:,ivis(iv))
          else
            call sub_extract_block(uvou, uvou%r2d(:,iv-blc+1), uvin, &
              &   duv(:,ivis(iv)), nvisi, nc)
          endif
        enddo
      else
        call sub_extract_block(uvou, uvou%r2d, uvin, duv(:,blc:trc), &
          & nvisi, nc)
      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
  !   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
  !
  integer :: iv, icf, icl, jcf, jcl
  !
  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
  ! Local
  character(len=*), parameter :: rname='WRITE /REPLACE'
  character(len=12) atype
  character(len=filename_length) :: file
  !
  if (fits_format) 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
!!    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
  !   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
  logical, intent(inout) :: error         ! Error return flag
  !
  character(len=*), parameter :: rname='WRITE /REPLACE'
  type(gildas) :: hall
  integer :: imin, imax, itmp
  real(8) :: rval, velo
  real(8), parameter :: epsilon=1d-5
  character(len=64) :: chain
  !
  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,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 routine for command
  !   WRITE Type File /APPEND  
  !
  ! 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
  ! Local
  character(len=*), parameter :: rname='WRITE /REPLACE'
  character(len=12) atype
  character(len=filename_length) :: file
  !
  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,error)
      endif
    else
      call map_message(seve%w,rname,'Single beam plane only')
    endif  
  case ('DIRTY')
    call sub_append(atype,file,ddirty,hdirty,error)
  case ('CLEAN')
    call sub_append(atype,file,dclean,hclean,error)
  case ('RESIDUAL')
    call sub_append(atype,file,dresid,hresid,error)
  case ('MASK')
    call sub_append(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 /APPEND')
    error = .true.
    return
!!   call sub_append(atype,file,dcct,hcct,error)
  case ('SKY')
    call sub_append(atype,file,dsky,hsky,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
!
subroutine sub_append(name,file,data,head,error)
  use image_def
  use gkernel_interfaces
  use gbl_message
  use imager_interfaces, only : map_message
  !-------------------------------------------------------
  ! @ 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
  logical, intent(inout) :: error         ! Error return flag
  !
  character(len=*), parameter :: rname='WRITE /APPEND'
  type(gildas) :: hall
  integer :: imin, imax, itmp, faxi
  logical :: err
  real(8) :: rval, velo
  real(8), parameter :: epsilon=1d-5
  character(len=64) :: chain
  integer(kind=index_length) :: newdim  ! New value of last dimension
  !
  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
  faxi = hall%gil%faxi
  if (faxi.ne.head%gil%faxi) then
    call map_message(seve%e,rname,'Data set ordering does not match')
    error = .true.
  endif
  !
  ! 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(faxi)).ne.abs(hall%gil%inc(faxi)) ) then
    call map_message(seve%e,rname,'Frequency resolution do not match')
    error = .true.
  endif
  ! Close this image - Extend works on a new Slot because of size
  err = .false.
  call gdf_close_image(hall,err)
  if (error) return
  !
  ! Check which range in the file is needed - Match the velocities
  velo = (1.d0-head%gil%ref(faxi))*head%gil%inc(faxi) + head%gil%val(faxi)
  rval = (velo-hall%gil%val(faxi))/hall%gil%inc(faxi) + hall%gil%ref(faxi)
  imin = nint(rval)
  !
  if (abs(dble(imin)-rval).gt.epsilon*abs(head%gil%inc(faxi))) then
    call map_message(seve%e,rname,'Frequency axis does not match')
    error = .true.
  endif
  if (error) return
  !
  velo = (head%gil%dim(faxi)-head%gil%ref(faxi))*head%gil%inc(faxi) + head%gil%val(faxi)
  rval = (velo-hall%gil%val(faxi))/hall%gil%inc(faxi) + hall%gil%ref(faxi)
  imax = nint(rval)
  !
  if (imin.gt.imax) then
    itmp = imin
    imin = imax
    imax = itmp
  endif
  !
  ! Tolerate a 1 channel error overlap, but no gap
  if (imin.ne.hall%gil%dim(faxi)+1 .and. imin.ne.hall%gil%dim(faxi)) then
    !!Print *,'Dimensions ',hall%gil%dim(faxi), hall%gil%dim(faxi)+1, imin, imax
    write(chain,'(A,A,I0,A,I0)') name,' is not contiguous, starts at ',imin
    call map_message(seve%e,rname,chain)
    error = .true.
    return
  endif
  !
  ! Extend image - image is left open
  newdim = imax ! in all cases, even for a 1 channel overlap 
  write(chain,'(A,A,I0,A)') name,' extended to ',imax, ' 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 in place (will replace possible overlap here)
  hall%blc(faxi) = imin
  hall%trc(faxi) = imax
  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 
  !-------------------------------------------------------
  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, huv, duv, trim_uv, trim_uvany, error)
  use image_def
  use gbl_message
  use gkernel_interfaces
  use imager_interfaces, only : map_message, sub_write_uvdata
  !---------------------------------------------------------------------
  ! @ private
  !
  ! IMAGER
  !   Write the Selected UV data set
  !---------------------------------------------------------------------
  character(len=*), intent(in) :: file
  integer, intent(in) :: nc(2)
  type(gildas), intent(in) :: huv
  real, intent(in) :: duv(:,:)
  integer, intent(in) :: nfields
  logical, intent(in) :: trim_uv, trim_uvany
  logical, intent(out) :: error
  !
  character(len=*), parameter :: rname='WRITE UV'
  integer(kind=index_length) :: iv,nv,im
  integer, allocatable :: ivis(:)
  integer :: ier, ic, nch, np, mv
  !
  error = .false.
  if (huv%loca%size.eq.0) then
    call map_message(seve%e,rname,'UV data undefined ')
    error = .true.
    return
  endif
  !
  if (nfields.ne.0 .and. huv%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
  !
  ! Trim if needed
  if (trim_uv) then
    np = huv%gil%dim(1)
    nv = huv%gil%nvisi  !! not %dim(2)
    nch = huv%gil%nchan * huv%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 (duv(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 (duv(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
    call sub_write_uvdata(file,nc,huv,duv,error, mv, ivis)
  else
    ! Create output image
    call sub_write_uvdata(file,nc,huv,duv,error)
  endif
end subroutine sub_write_uvset
!
subroutine imager_write_data(head,data,error)
  use image_def
  use gkernel_types
  use gkernel_interfaces
  use clean_types
  ! 
  type(gildas), intent(inout) :: head
  real, intent(in) :: data(*)
  logical, intent(inout) :: error
  !
  logical :: overwrite=.true.
  integer :: nbits=-32
  character(len=4) :: style='  '
  !
  if (fits_format) then
    head%loca%addr = locwrd(data)
    call gildas_to_fits(head,head%file,style,nbits,overwrite,error)
  else
    call gdf_write_image(head,data,error)
  endif
end subroutine imager_write_data
