! (Copyright IRAM, the GILDAS team)
!
! Author: Stephane Guilloteau, Laboratoire d'Astrophysique de Bordeaux
!   June 2015
!
! Task to "refine" the imaging process.
!   The zeroth order in imaging is to compute a single gridding
! and beam for all channels, at the center frequency: this is
! the standard way of making imaging. Strictly speaking, it produces
! an angular scale inversely proportional to frequency.
!   The infinite order is to compute one beam per channel, but it
! is a costly process.
!
!   This task is here for the first order correction, of the angular
! scale varying with frequency, just making a linear interpolation
! between images computed with two different gridding because of
! the angular scale.
!   This task interpolates
! the dirty images for each channel based on dirty images computed
! for 2 different angular scales (corresponding to the frequencies
! of the 2 extreme channels).
!
program map_refine
  use gkernel_interfaces
  use gildas_def
  !
  character(len=filename_length) :: namea, nameb, nameo
  character(len=12) :: ctype
  logical :: error
  !
  call gildas_open
  call gildas_char('FILE_A$',namea)
  call gildas_char('FILE_B$',nameb)
  call gildas_char('OUTPUT$',nameo)
  call gildas_char('TYPE$',ctype)
  call gildas_close
  !
  call sic_lower (ctype)
  if (ctype(1:1).ne.'.') ctype = '.'//ctype
  call sub_map_refine(namea,nameb,nameo,ctype,error)
  if (error) call sysexi(fatale)
  !
contains
!<FF>
subroutine sub_map_refine(namea,nameb,nameo,ctype,error)
  use gkernel_interfaces
  use gbl_message
  use image_def
  !
  character(len=*), intent(in) :: namea    ! First file name
  character(len=*), intent(in) :: nameb    ! Second file name
  character(len=*), intent(in) :: nameo    ! Output file name
  character(len=*), intent(in) :: ctype    ! Type of file name
  logical, intent(out) :: error
  !
  character(len=*), parameter :: rname='MAP_REFINE'
  !
  type(gildas) :: ha,hb,hout
  real, allocatable :: da(:,:,:)
  real, allocatable :: db(:,:,:)
  real, allocatable :: dout(:,:,:)
  !
  integer :: nx,ny,nv,nb,sblock,space_gildas,first,last
  integer :: iblock,iv,kv,ier
  real :: ra,rb
  real(8) :: fa,fb
  logical :: equal
  character(len=64) :: chain
  !
  call gildas_null (ha)
  call gildas_null (hb)
  call gildas_null (hout)
  !
  ! Read Headers
  call sic_parse_file(namea,' ',ctype,ha%file)
  call gdf_read_header (ha,error)
  if (error) return
  if (ctype.ne.'.beam') then
    if (ha%gil%dim(3).le.2) then
      call gag_message(seve%e,rname, &
        & 'no refinement needed for less than 3 channels')
      error = .true.
      return
    endif
  endif
  !
  call sic_parse_file(nameb,' ',ctype,hb%file)
  call gdf_read_header (hb,error)
  if (error) return
  !
  ! Compare shapes and axes (TBD)
  call gdf_compare_shape(ha,hb,equal)
  if (.not.equal) then
    call gag_message(seve%e,rname,'Images do not match')
    error = .true.
    return
  endif
  !
  ! Create output image
  nx = ha%gil%dim(1)
  ny = ha%gil%dim(2)
  if (ctype.eq.'.lmv') then
    nv = ha%gil%dim(3)
    nb = nv
  else if (ctype.eq.'.beam') then
    fa = (1-ha%gil%ref(3))*ha%gil%inc(3)+ha%gil%val(3)
    fb = (1-hb%gil%ref(3))*hb%gil%inc(3)+hb%gil%val(3)
    nv = nint (abs(fa-fb)/abs(hb%gil%inc(3)))+1
    nb = 1
    write (chain,'(a,i0,a)') 'Beam differ by ',nv,'channels'
    call gag_message(seve%i,rname,chain)
  else
    call gag_message(seve%e,rname,'Invalid image type '//ctype)
    error = .true.
    return
  endif
  !
  call gdf_copy_header(ha,hout,error)
  hout%gil%dim(3) = nv
  call sic_parse_file(nameo,' ',ctype,hout%file)
  call gdf_create_image(hout,error)
  if (error) return
  !
  ! Work by blocks
  space_gildas = 128
  ier = sic_getlog('SPACE_GILDAS',space_gildas)            ! Mega Bytes
  ! Number of channels per block
  sblock = max(int(256.0*space_gildas*1024.0)/(nx*ny),1)
  nb = min(sblock,nb)
  allocate(da(nx,ny,nb),db(nx,ny,nb),dout(nx,ny,sblock), &
      & stat=ier)
  if (ier.ne.0) then
    call gag_message(seve%e,rname,'Memory allocation error')
    error = .true.
    return
  endif
  !
  ! Read beams only once
  if (ctype.eq.'.beam') then
    call gdf_read_data(ha,da,error)
    if (error) return
    call gdf_read_data(hb,db,error)
    if (error) return
  endif
  !
  ! Loop on blocks for images
  first = 0
  do iblock = 1, nv, sblock
    last = min(first+sblock,nv)
    first = first+1
    !
    if (ctype.eq.'.lmv') then
      ha%blc(3) = first
      ha%trc(3) = last
      hb%blc(3) = first
      hb%trc(3) = last
      !
      call gdf_read_data(ha,da,error)
      if (error) return
      call gdf_read_data(hb,db,error)
      if (error) return
      !
      kv = 0
      do iv = first, last
        ra = real(nv-iv)/real(nv-1)
        rb = real(iv-1)/real(nv-1)
        !
        kv = kv+1
        dout(:,:,kv) = ra*da(:,:,kv) + rb*db(:,:,kv)
      enddo
    else
      kv = 0
      do iv = first, last
        ra = real(nv-iv)/real(nv-1)
        rb = real(iv-1)/real(nv-1)
        !
        kv = kv+1
        dout(:,:,kv) = ra*da(:,:,1) + rb*db(:,:,1)
      enddo
    endif
    !
    hout%blc(3) = first
    hout%trc(3) = last
    call gdf_write_data(hout,dout,error)
  enddo
  !
  call gdf_close_image(ha,error)
  call gdf_close_image(hb,error)
  call gdf_close_image(hout,error)
  !
end subroutine sub_map_refine
!
end program map_refine

