module cubefitsio_image_write
  use cfitsio_api
  use cubefitsio_header
  use cubefitsio_messaging
  !---------------------------------------------------------------------
  ! Support module to write FITS 'images' (e.g. 2D images or 3D cubes)
  !---------------------------------------------------------------------

  public :: cubefitsio_image_create,cubefitsio_image_datawrite
  public :: cubefitsio_image_header_update
  private

contains

  subroutine cubefitsio_image_create(hfits,filename,error)
    use gkernel_interfaces
    use cubetools_parameters
    !-------------------------------------------------------------------
    ! Create a new IMAGE-FITS file on disk.
    !-------------------------------------------------------------------
    type(fitsio_header_t), intent(inout) :: hfits
    character(len=*),      intent(in)    :: filename
    logical,               intent(inout) :: error
    ! Local
    character(len=*), parameter :: rname='IMAGE>CREATE'
    integer(kind=4) :: idime,status
    integer(kind=4) :: bitpix,naxis,naxes(maxdim)
    !
    if (gag_inquire(filename,len_trim(filename)).eq.0)  &
      call gag_filrm(filename(1:len_trim(filename)))
    !
    call hfits%init(filename,error)
    if (error)  goto 10
    !
    ! Put the primary header
    status = 0
    bitpix = -32
    naxis = hfits%ndim
    do idime=1,hfits%ndim
      naxes(idime) = hfits%dim(idime)
    enddo
    call ftphps(hfits%unit,bitpix,naxis,naxes,status)
    if (cubefitsio_error(rname,status,error))  goto 10
    !
    ! Flush (is this useless?)
    call ftflus(hfits%unit,status)
    if (cubefitsio_error(rname,status,error))  goto 10
    !
    return
    !
  10 continue
    ! In case of error at init time, the unit is unusable by any
    ! of the CFITSIO entry point => free it.
    call hfits%close(error)
    !
  end subroutine cubefitsio_image_create

  subroutine cubefitsio_image_header_update(hfits,error)
    use cubefitsio_header_write
    !-------------------------------------------------------------------
    ! Update the header in the current FITS file
    !-------------------------------------------------------------------
    type(fitsio_header_t), intent(in)    :: hfits
    logical,               intent(inout) :: error
    ! Local
    character(len=*), parameter :: rname='IMAGE>HEADER>UPDATE'
    integer(kind=4) :: icard
    !
    do icard=1,hfits%dict%ncard
      call cubefitsio_header_write_card(hfits%unit,hfits%dict%card(icard),error)
      if (error)  return
    enddo
    !
  end subroutine cubefitsio_image_header_update

  subroutine cubefitsio_image_datawrite(hfits,data,iblc,itrc,error)
    use gkernel_interfaces
    use cubetools_parameters
    use cubefitsio_image_utils
    !-------------------------------------------------------------------
    ! Write a contiguous piece of data to the output file
    !-------------------------------------------------------------------
    type(fitsio_header_t),      intent(in)    :: hfits
    real(kind=4),               intent(in)    :: data(*)
    integer(kind=index_length), intent(in)    :: iblc(maxdim)
    integer(kind=index_length), intent(in)    :: itrc(maxdim)
    logical,                    intent(inout) :: error
    ! Local
    character(len=*), parameter :: rname='IMAGE>DATAWRITE'
    integer(kind=4) :: status,group,idime,laxisval
    character(len=6) :: laxisname
    character(len=80) :: comment
    integer(kind=size_length) :: nelements
    integer(kind=4) :: naxis,naxes(maxdim),fpixels(maxdim),  &
                       lpixels(maxdim),incs(maxdim)
    !
    call cubefitsio_image_subset(hfits,iblc,itrc,  &
      naxis,naxes,fpixels,lpixels,incs,nelements,error)
    if (error)  return
    !
    status = 0
    group = 1
    !
    ! ---
    ! PROBLEM: FTPPRE needs fpixel and nelements to be be I*4, i.e. limited
    ! to 2**31-1
    ! call ftppre(hfits%unit,group,fpixel,nelements,data,status)
    ! if (cubefitsio_error(rname,status,error))  return
    !
    ! ---
    ! Use FTPSSE which is able to deal with more than 2**31 elements to
    ! read, as long as the individual dimensions are below this limit (i.e. I*4)
    call ftpsse(hfits%unit,group,naxis,naxes,fpixels,lpixels,data,status)
    if (cubefitsio_error(rname,status,error))  return
    !
    ! Update proper NAXIS* accordingly
    do idime=1,hfits%ndim
      write(laxisname,'(A5,I0)')  'NAXIS',idime
      call ftgkyj(hfits%unit,laxisname,laxisval,comment,status)
      if (cubefitsio_error(rname,status,error))  return
      if (laxisval.lt.lpixels(idime)) then
        laxisval = lpixels(idime)
        call ftukyj(hfits%unit,laxisname,laxisval,comment,status)
        if (cubefitsio_error(rname,status,error))  return
      endif
    enddo
    !
    ! Flush
    call ftflus(hfits%unit,status)
    if (cubefitsio_error(rname,status,error))  return
    !
  end subroutine cubefitsio_image_datawrite

end module cubefitsio_image_write
