program mask_3d
  use gkernel_interfaces
  !---------------------------------------------------------------------
  ! Task
  !   Apply a 3-D real mask to an input data cube
  !   Ouput = Input where Mask is non zero
  !
  !   The Mask does not need to share the same sampling as the
  !   data cube.
  !---------------------------------------------------------------------
  character(len=filename_length) :: cmask
  character(len=filename_length) :: cinp
  character(len=filename_length) :: cout 
  logical :: error
  !
  call gildas_open
  call gildas_char('MASK$',cmask)
  call gildas_char('INPUT$',cinp)
  call gildas_char('OUTPUT$',cout)
  call gildas_close
  !
  call sub_mask3d(cmask,cinp,cout,error)
  if (error) call sysexi(fatale)
  call gagout('S-MASK_3D, successful completion')
  contains
!
subroutine sub_mask3d(cmask,cinp,cout,error)
  use image_def
  use gkernel_interfaces
  use gbl_message
  ! @ private
  character(len=*), intent(inout) :: cmask
  character(len=*), intent(inout) :: cinp
  character(len=*), intent(inout) :: cout
  logical, intent(out) :: error
  !
  character(len=*), parameter :: rname = 'MASK_3D'
  ! Local
  type(gildas) :: gmask, ginp, gout
  real, allocatable :: rmask(:,:), data(:,:,:)
  integer :: nblock, iloop, j, ier, iplane, imask
  !
  ! Code
  call gildas_null (ginp) 
  call gdf_read_gildas (ginp, cinp, '.gdf', error, data=.false.)
  !
  ! Make it a 3-D data set even if only one plane
  call gildas_null (gmask) 
  call gdf_read_gildas (gmask, cmask, '.msk', error, rank=3, data=.true.)
  !
  call gildas_null (gout) 
  call gdf_copy_header(ginp,gout,error)
  if (error) return
  !
  if (gmask%gil%dim(3).gt.1) then
    if (ginp%gil%faxi.ne.3 .or. gmask%gil%faxi.ne.3) then
      call gag_message(seve%e,rname,'Mask and Cube must have FREQUENCY / VELOCITY axis as 3rd one')
      error = .true.
      return
    endif
    if (ginp%char%code(3).ne.gmask%char%code(3)) then
      call gag_message(seve%e,rname,'3rd axis must be of same type')
      error = .true.
      return
    endif
  endif
  !
  call sic_parsef(cout,gout%file,' ','.gdf')
  call gdf_create_image(gout,error)
  if (error) return
  !
  call gdf_nitems('SPACE_GILDAS',nblock,ginp%gil%dim(1)*ginp%gil%dim(2)) 
  nblock = min(nblock,ginp%gil%dim(3))
  allocate(rmask(ginp%gil%dim(1),ginp%gil%dim(2)), &
    & data(ginp%gil%dim(1),ginp%gil%dim(2),nblock),stat=ier)
  if (ier.ne.0) then
    call gag_message(seve%e,rname,'Memory allocation error')
    error = .true.
    return
  endif
  !
  ! Initialize
  imask = 0
  ! Loop over blocks
  do iloop = 1,ginp%gil%dim(3),nblock
    ginp%blc(3) = iloop
    ginp%trc(3) = min(iloop+nblock-1,ginp%gil%dim(3))
    gout%blc(3) = iloop
    gout%trc(3) = ginp%trc(3)
    call gdf_read_data (ginp,data,error)
    if (error) return
    !
    ! Mask it
    do j=1,ginp%trc(3)-ginp%blc(3)+1
      iplane = j+ginp%blc(3)-1
      call get_realmask(imask,iplane,gmask,ginp,rmask)
      data(:,:,j) = rmask*data(:,:,j)
    enddo
    call gdf_write_data (gout, data, error)
    if (error) return
  enddo
  call gdf_close_image(gout,error)
  call gdf_close_image(ginp,error)
  call gdf_close_image(gmask,error)
end subroutine sub_mask3d
!
subroutine get_realmask(imask,iplane,hmask,hmap,rmask)
  use image_def
  !----------------------------------------------------------------
  ! @ private
  !
  ! MAPPING
  !   Define beam plane and check if fit is required
  !----------------------------------------------------------------
  integer, intent(inout) :: imask
  integer, intent(inout) :: iplane
  type (gildas), intent(in) :: hmask
  type (gildas), intent(in) :: hmap   ! Used to figure out which plane
  real, intent(inout) :: rmask(:,:)
  !
  integer :: i, j, nx, ny, ier
  real(8) :: i_freq, r
  integer, allocatable :: im(:), jm(:)
  !
  if (hmask%gil%dim(3).le.1) then
    iplane = 1
 else
    i_freq = (iplane-hmap%gil%ref(3))*hmap%gil%inc(3) + hmap%gil%val(3)
    iplane = nint((i_freq-hmask%gil%val(3))/hmask%gil%inc(3) + hmask%gil%ref(3))
    iplane = min(max(1,iplane),hmask%gil%dim(3)) ! Just  in case
  endif
  !
  if (imask.ne.iplane) then
    !
    ! Should also work in OMP mode...
    nx = hmap%gil%dim(1)
    ny = hmap%gil%dim(2)
    !
    allocate(im(nx),jm(ny),stat=ier)
    !
    do i=1,nx
      r = (i-hmap%gil%ref(1))*hmap%gil%inc(1) + hmap%gil%val(1)
      im(i) = (r-hmask%gil%val(1))/hmask%gil%inc(1) + hmask%gil%ref(1)
      im(i) = max(1,im(i))
      im(i) = min(hmask%gil%dim(1),im(i))
    enddo
    !
    do i=1,ny
      r = (i-hmap%gil%ref(2))*hmap%gil%inc(2) + hmap%gil%val(2)
      jm(i) = (r-hmask%gil%val(2))/hmask%gil%inc(2) + hmask%gil%ref(2)
      jm(i) = max(1,jm(i))
      jm(i) = min(hmask%gil%dim(2),jm(i))
    enddo
    !
    do j=1,ny
      do i=1,nx
        if (hmask%r3d(im(i),jm(j),iplane).ne.0) then
          rmask(i,j) = 1.0
        else
          rmask(i,j) = 0.0
        endif
      enddo
    enddo
    deallocate(im,jm)
    imask = iplane
  endif
end subroutine get_realmask
!
end program
