module cubefitsio_image_write
  use cfitsio_api
  use cubetools_checksum
  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,dochecksum,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(in)    :: dochecksum
    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,dochecksum,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

#if defined(CFITSIO420)
  subroutine cubefitsio_image_datawrite(hfits,data,iblc,itrc,error)
    use iso_c_binding, only: c_loc
    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), target,       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,ier
    integer(kind=8) :: nbytes
    character(len=6) :: laxisname
    character(len=80) :: comment
    character(len=mess_l) :: mess
    integer(kind=size_length) :: fpixel,nelements
    integer(kind=index_length) :: blc(maxdim),trc(maxdim)
    !
    call cubefitsio_image_dataoffset(hfits,iblc,itrc,blc,trc,  &
                                     fpixel,nelements,error)
    if (error)  return
    !
    ! Sanity check
    if (size(data,kind=size_length).lt.nelements) then
      ! Note that it is OK to receive a buffer which is too large. It is
      ! the responsibility of the caller to know that not all the buffer
      ! is written (thanks to blc/trc). This is the case in particular when
      ! reading by blocks: the last block is not shrinked before writing.
      write(mess,'(2(a,i0))')  'Internal error: trying to write ',nelements,  &
        ' values in a buffer of size ',size(data,kind=size_length)
      call cubefitsio_message(seve%e,rname,mess)
      error = .true.
      return
    endif
    !
    call cubefitsio_message(fitsioseve%others,rname,'Writing data with CFITSIO')
    group = 1
    status = 0
    call ftpprell(hfits%unit,group,fpixel,nelements,data,status)
    if (cubefitsio_error(rname,status,error))  return
    !
    if (hfits%checksum) then
      if (fpixel.eq.1) then
        ! Start or restart writing from the beginning (this can happen
        ! because we usually write a fake 1st image when creating the
        ! header).
        ier = cubetools_sha1sum_init()
        if (ier.ne.0) then
          error = .true.
          return
        endif
      endif
      nbytes = nelements*4
      ier = cubetools_sha1sum_update(c_loc(data),nbytes)
      if (ier.ne.0) then
        call cubefitsio_message(seve%e,rname,'Could not checksum data')
        error = .true.
        return
      endif
    endif
    !
    ! 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.trc(idime)) then
        laxisval = trc(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
#else /* CFITSIO420 */
  subroutine cubefitsio_image_datawrite(hfits,data,iblc,itrc,error)
    use iso_c_binding, only: c_loc
    use gkernel_interfaces
    use cubetools_parameters
    use cubefitsio_image_utils
    !-------------------------------------------------------------------
    ! OBSOLESCENT IMPLEMENTATION WITH INCORRECT USE OF BINTABLE API TO
    ! WRITE LARGE (>2GB) IMAGE HDUS.
    !-------------------------------------------------------------------
    type(fitsio_header_t),      intent(in)    :: hfits
    real(kind=4), target,       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
    integer(kind=8) :: nbytes
    character(len=6) :: laxisname
    character(len=80) :: comment
    integer(kind=size_length) :: nelements
    integer(kind=4) :: ier,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
    !
    if (hfits%checksum) then
      if (all(fpixels(1:naxis).eq.1)) then
        ! Start or restart writing from the beginning (this can happen
        ! because we usually write a fake 1st image when creating the
        ! header).
        ier = cubetools_sha1sum_init()
        if (ier.ne.0) then
          error = .true.
          return
        endif
      endif
      nbytes = nelements*4
      ier = cubetools_sha1sum_update(c_loc(data),nbytes)
      if (ier.ne.0) then
        call cubefitsio_message(seve%e,rname,'Could not checksum data')
        error = .true.
        return
      endif
    endif
    !
    ! 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
#endif /* CFITSIO420 */
end module cubefitsio_image_write
