program make_mosaic
  use gildas_def
  use gkernel_interfaces
  use gbl_message
  !----------------------------------------------------------------------
  !   Make a mosaic cube from a set of original images.
  !
  ! The original images are assumed to have the same phase tracking center
  ! and hence the same map characterictics (pixel, size, coordinates)
  ! This program compute several images (rather n-D data sets) :
  !
  ! Ouput
  !   NX NY are the image sizes
  !   NC is the number of channels
  !   NF is the number of different frequencies
  !   NP is the number of pointing centers
  !
  ! 'NAME'.LMV  a 3-d cube containing the uniform noise
  !     combined mosaic, i.e. the sum of the product
  !     of the fields by the primary beam. (NX,NY,NC)
  ! 'NAME'.LOBE the primary beams pseudo-cube (NP,NX,NY,NB)
  ! 'NAME'.WEIGHT the sum of the square of the primary beams (NX,NY,NB)
  ! 'NAME'.BEAM a 4-d cube where each cube contains the synthesised
  !     beam for one field (NX,NY,NP,NB)
  !
  ! All images have the same X,Y sizes
  !
  ! It is assumed that the names of the original field images follow
  ! the simple sequence 'NAME'-'I'.LMV
  !----------------------------------------------------------------------
  ! Local
  character(len=*), parameter :: version = 'Version 3.0 23-July-2015'
  character(len=*), parameter :: pname = 'MAKE_MOSAIC'
  integer :: np
  real :: bsize,bmin
  character(len=80) :: generic
  logical :: error
  !
  call gag_message(seve%i,pname,version)
  !
  call gildas_open
  call gildas_inte('FIELDS$',np,1)
  call gildas_char('NAME$',generic)
  call gildas_real('BEAM$',bsize,1)
  call gildas_real('BMIN$',bmin,1)
  call gildas_close
  !
  ! Do all the work in a subroutine...
  call sub_mosaic (trim(generic),np,bsize,bmin,error)
  if (error) call sysexi(fatale)
  call gag_message(seve%i,pname,'Successful completion')
  !
end program make_mosaic
!
subroutine sub_mosaic(generic,np,bsize_rest,bmin,error)
  use gkernel_interfaces
  use image_def
  use gbl_message
  use mapping_primary
  !
  ! Build a Mosaic from an ensemble of NF initial Images
  ! with a name following the convention name-'i' i=1,nf
  !
  character(len=*), intent(in) :: generic  ! Generic name
  integer, intent(in) :: np                ! Number of pointings
  real, intent(in) :: bsize_rest           ! Primary beam size (Radian)
  real, intent(in) :: bmin                 ! Truncation level
  logical, intent(out) :: error
  !
  character(len=*), parameter :: rname = 'MAKE_MOSAIC'
  type(gildas) :: field
  type(gildas) :: beam
  type(gildas) :: lobe
  type(gildas) :: mosaic
  type(gildas) :: tmp
  type(gildas) :: weight
  !
  real, allocatable :: dbeam(:,:,:,:) ! Dirty and Primary beam arrays
  real, allocatable :: dmosaic(:,:,:) ! Mosaic
  real, allocatable :: dprim(:,:)     ! Current primary beam
  real, allocatable :: dtmp(:,:)      ! Temporary work space
  real, allocatable :: dweight(:,:,:) ! Final weight image
  !
  character(len=filename_length) :: name
  integer :: nx,ny,nc,nb,nn,ier
  integer :: ip,ib,ic, fc,lc
  real :: thre, rmin, rmax, bsize
  real(8) :: beam_freq
  integer(kind=size_length) :: nelem, imin, imax
  character(len=64) :: chain
  !
  call gildas_null(field)
  call gildas_null(beam)
  call gildas_null(lobe)
  call gildas_null(mosaic)
  call gildas_null(weight)
  call gildas_null(tmp)
  !
  error = .false.
  nn = len_trim(generic)
  !
  name = generic
  name(nn+1:) = '-1'
  call sic_parsef (name,field%file,' ','.lmv')
  call gdf_read_header(field,error)
  if (error) then
    call gag_message(seve%e,rname,'Cannot open '//trim(field%file))
    return
  endif
  nx = field%gil%dim(1)
  ny = field%gil%dim(2)
  nc = field%gil%dim(3)
  !
  ! Test the dirty beam properties
  name = generic
  name(nn+1:) = '-1'
  call sic_parsef (name,beam%file,' ','.beam')
  call gdf_read_header(beam,error)
  if (error) then
    call gag_message(seve%e,rname,'Cannot open '//trim(beam%file))
    return
  endif
  if (nx.ne.beam%gil%dim(1) .or. ny.ne.beam%gil%dim(2)) then
    write(6,*) 'F-'//rname//',  Beam and Dirty do not match'
    return
  endif
  nb = beam%gil%dim(3)    ! Number of different beams per field
  !
  ! First pass: Produce the .BEAM Dirty Beam 4-D data set
  name = generic
  call sic_parsef (name,beam%file,' ','.beam')
  beam%gil%ndim = 4
  ! Push frequency dimension
  beam%char%code(4) = beam%char%code(3)
  beam%gil%dim(4) = nb
  beam%gil%convert(:,4) = beam%gil%convert(:,3)
  beam%gil%faxi = 4
  !
  ! Fill projection information from fields
  beam%gil%proj_words = def_proj_words
  beam%char%code(1) = 'RA'
  beam%char%code(2) = 'DEC'
  beam%gil%ptyp = field%gil%ptyp
  beam%gil%pang = field%gil%pang ! Defined in table.
  beam%gil%a0 = field%gil%a0
  beam%gil%d0 = field%gil%d0
  !
  ! Fill Field dimension
  beam%char%code(3) = 'FIELD-ID'
  beam%gil%dim(3) = np
  beam%gil%convert(:,3) = 1.d0
  beam%gil%extr_words = 0
  !
  allocate (dbeam(nx,ny,np,nb),dtmp(nx,ny),stat=ier)
  if (ier.ne.0) then
    call gag_message(seve%e,rname,'Memory allocation error DBEAM')
    error = .true.
    return
  endif
  !
  ! Loop over individual synthesized beams
  call gdf_copy_header(field,tmp,error)
  do ip=1,np
    name = generic
    call append_number(name,ip)
    call sic_parsef (name,tmp%file,' ','.beam')
    call gdf_read_header (tmp,error)
    if (error) then
      call gag_message(seve%f,rname,'Cannot open '//trim(tmp%file))
      return
    endif
    if (tmp%gil%dim(1).ne.nx .or. tmp%gil%dim(2).ne.ny) then
      write(chain,'(A,I4,I6,I6)') 'Inconsistent size, field  ',ip,tmp%gil%dim(1:2)
      call gag_message(seve%f,rname,chain)
      error = .true.
      return
    endif
    do ib=1,nb
      tmp%blc(3) = ib
      tmp%trc(3) = ib
      call gdf_read_data(tmp,dtmp,error)
      dbeam(:,:,ip,ib) = dtmp(:,:)
    enddo
    call gdf_close_image(tmp,error) ! Free image after use
  enddo
  call gdf_write_image(beam,dbeam,error)
  deallocate(dbeam,stat=ier) ! Need a different shape later, so just free it
  if (error) then
    call gag_message(seve%f,rname,'Cannot open '//trim(beam%file))
    return
  endif
  !
  ! Create the primary beams  -- This is a transposed cube (NP,NX,NY,NB)
  call gdf_transpose_header(beam,lobe,'3124',error)
  if (error)  return
  name = generic
  call sic_parsef (name,lobe%file,' ','.lobe')
  !
  lobe%gil%inc(1) = bmin                ! Valeur conventionnelle
  lobe%gil%inc(5) = bsize               ! necessaire pour MRC_MOSAIC.
  allocate (dbeam(np,nx,ny,nb),dmosaic(nx,ny,nc),dprim(nx,ny), &
    & dweight(nx,ny,nb),stat=ier)  !
  if (ier.ne.0) then
    call gag_message(seve%e,rname,'Memory allocation error DMOSAIC & DBEAM')
    error = .true.
    return
  endif
  !
  ! Create the .LMV cube
  call gdf_copy_header(field,mosaic,error)
  !
  ! loop over the various fields.
  name = generic(1:nn)
  call sic_parsef (name,mosaic%file,' ','.lmv')
  mosaic%gil%ra = mosaic%gil%a0
  mosaic%gil%dec  = mosaic%gil%d0
  !
  dmosaic = 0
  !
  do ip=1,np
    name = generic
    call append_number(name,ip)
    call sic_parsef (name,field%file,' ','.lmv')
    call gdf_read_header (field,error)
    if (error) then
      call gag_message(seve%f,rname,'Cannot open '//trim(field%file))
      return
    endif
    !
    ! Here, loop over the NB beams at different frequencies
    do ib=1,nb
      !
      ! Figure out the frequency and corresponding Primary Beam size
      beam_freq = (ib-beam%gil%ref(4))*beam%gil%fres + beam%gil%freq
      bsize = bsize_rest * beam%gil%freq / beam_freq
      !
      ! Figure out the first and last channels in the data array
      if (nb.eq.1) then
        fc = 1
        lc = nc
      else if (beam%gil%freq.gt.0) then
        !
        if (field%gil%fres.gt.0) then
          fc = int((beam_freq-beam%gil%fres*0.5d0-field%gil%freq)/field%gil%fres + field%gil%ref(3) + 1d0)
          lc = int((beam_freq+beam%gil%fres*0.5d0-field%gil%freq)/field%gil%fres + field%gil%ref(3) )
          if (ib.eq.1) fc = 1
          if (ib.eq.nb) lc = nc
        else
          fc = int((beam_freq+beam%gil%fres*0.5d0-field%gil%freq)/field%gil%fres + field%gil%ref(3) + 1d0)
          lc = int((beam_freq-beam%gil%fres*0.5d0-field%gil%freq)/field%gil%fres + field%gil%ref(3) )
          if (ib.eq.1) lc = nc
          if (ib.eq.nb) fc = 1
        endif
      else
        !
        if (field%gil%fres.gt.0) then
          fc = int((beam_freq+beam%gil%fres*0.5d0-field%gil%freq)/field%gil%fres + field%gil%ref(3) + 1d0)
          lc = int((beam_freq-beam%gil%fres*0.5d0-field%gil%freq)/field%gil%fres + field%gil%ref(3) )
          if (ib.eq.nb) fc = 1
          if (ib.eq.1) lc = nc
        else
          fc = int((beam_freq-beam%gil%fres*0.5d0-field%gil%freq)/field%gil%fres + field%gil%ref(3) + 1d0)
          lc = int((beam_freq+beam%gil%fres*0.5d0-field%gil%freq)/field%gil%fres + field%gil%ref(3) )
          if (ib.eq.1) fc = 1
          if (ib.eq.nb) lc = nc
        endif
      endif
      !
      ! Compute the non truncated primary beam
      call mos_primary (field,dprim,bsize)
      dbeam(ip,:,:,ib) = dprim  ! Fill the primary beam array
      !
      ! But a truncated primary beam is used
      where (dprim.lt.bmin) dprim = 0
      !
      ! Make it Plane by Plane to save Memory
      ! A more efficient implementation would use a Blocking Factor
      do ic=fc,lc
        field%blc(3) = ic
        field%trc(3) = ic
        call gdf_read_data (field, dtmp, error)
        dmosaic(:,:,ic) = dmosaic(:,:,ic) + dtmp*dprim  ! Apply the primary beam
      enddo
    enddo
    !
    call gdf_close_image (field,error) ! Free field image after use
  enddo
  !
  ! Write the primary beams
  call gdf_write_image (lobe,dbeam,error)
  if (error) then
    call gag_message(seve%f,rname,'Cannot create '//trim(lobe%file))
    return
  endif
  !
  ! Compute the extrema of the Mosaic and write it
  nelem = nx*ny*nc
  call gr4_extrema (nelem,dmosaic,mosaic%gil%bval,mosaic%gil%eval,   &
                    rmin,rmax,imin,imax)
  call t_setextrema(mosaic,rmin,imin,rmax,imax)
  call gdf_write_image(mosaic,dmosaic,error)
  if (error) then
    call gag_message(seve%f,rname,'Cannot open '//trim(mosaic%file))
    return
  endif
  !
  ! Now the .WEIGHT file
  call gdf_copy_header(mosaic,weight,error)
  weight%gil%ndim = 3
  weight%gil%dim(3) = beam%gil%dim(4)
  weight%gil%convert(:,3) = beam%gil%convert(:,4)
  weight%gil%fres = beam%gil%fres
  weight%gil%freq = beam%gil%freq
  !
  name = generic(1:nn)
  call sic_parsef(name,weight%file,' ','.weight')
  !
  ! Use DTMP as temporary space
  thre = bmin**2
  do ib=1,nb
    dtmp = 0.0
    do ip=1,np
      dtmp(:,:) = dtmp + dbeam(ip,:,:,ib)**2
    enddo
    where (dtmp.ge.thre)
      dweight(:,:,ib) = 1.0/dtmp
    else where
      dweight(:,:,ib) = 0.0
    end where
  enddo
  !
  nelem = nx*ny*nb
  call gr4_extrema (nelem,dweight,weight%gil%bval,weight%gil%eval,   &
                    rmin,rmax,imin,imax)
  weight%gil%bval = 0
  weight%gil%eval = 0
  call t_setextrema(weight,rmin,imin,rmax,imax)
  call gdf_write_image(weight,dweight,error)
  !
  if (error) then
    call gag_message(seve%f,rname,'Cannot create '//trim(weight%file))
    return
  endif
end subroutine sub_mosaic

subroutine append_number(name,if)
  character(len=*), intent(inout) :: name
  integer, intent(in) :: if
  !
  character(len=12) :: rchain, lchain
  integer :: nn
  !
  nn = len_trim(name)
  !
  write(rchain,'(I12)') if
  lchain = adjustl(rchain)
  !
  name(nn+1:) = '-'//lchain
end subroutine append_number

