!
!  Tolerant FITSio subroutine
!
!  Copyright © 2012-4,16 F.Hroch (hroch@physics.muni.cz)
!
!  This file is part of Munipack.
!
!  Munipack is free software: you can redistribute it and/or modify
!  it under the terms of the GNU General Public License as published by
!  the Free Software Foundation, either version 3 of the License, or
!  (at your option) any later version.
!
!  Munipack is distributed in the hope that it will be useful,
!  but WITHOUT ANY WARRANTY; without even the implied warranty of
!  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
!  GNU General Public License for more details.
!
!  You should have received a copy of the GNU General Public License
!  along with Munipack.  If not, see <http://www.gnu.org/licenses/>.

module xfitsio

  use fitsio
  use iso_fortran_env

  implicit none

  type xFITS
     character(len=FLEN_FILENAME) :: filename
     real,dimension(:,:),allocatable :: image, stderr
     integer :: naxis, bitpix, nhead, chdu, nhdu
     integer, dimension(2) :: naxes
     character(len=FLEN_CARD), dimension(:), allocatable :: head
     logical :: status
  end type xFITS


contains

  subroutine xfits_init(fits)

    type(xFITS), intent(out) :: fits
    fits%status = .false.
    fits%filename = ''
    fits%naxis = 0
    fits%bitpix = 0
    fits%naxes = 0
    fits%nhead = 0
    fits%nhdu = 0
    fits%chdu = 0

  end subroutine xfits_init

  subroutine xfits_read(file,fits)

    character(len=*), intent(in) :: file
    type(xFITS), intent(out) :: fits

    integer :: istat,n,nh,nhead,extver
    real :: minvalue
    character(len=FLEN_CARD) :: buf
    character(len=FLEN_CARD), dimension(:), allocatable :: head
    logical :: anyf

    minvalue = -huge(minvalue)
    extver = 0

    istat = 0
    call xfits_deallocate(fits)
    call xfits_init(fits)

    fits%filename = file
    call ftdopn(20,file,0,istat)
    call ftgidt(20,fits%bitpix,istat)
    call ftgidm(20,fits%naxis,istat)
    call ftthdu(20,fits%nhdu,istat)
    if( istat /= 0 ) goto 666

    call ftghdn(20,fits%chdu)

    if( fits%naxis /= size(fits%naxes) ) then !stop 'naxis /= 2'
       write(error_unit,*) trim(file),": Assertion failed: naxis /= 2"
       goto 666
    end if

    call ftgisz(20,fits%naxis,fits%naxes,istat)

    if( istat /= 0 ) goto 666

    call ftghps(20,nhead,n,istat)
    if( istat /= 0 ) goto 666
    allocate(head(nhead))
    nh = 0
    do n = 1, nhead
       buf = ''
       call ftgrec(20,n,buf,istat)
       if( istat /= 0 ) goto 666
       if( ftgkcl(buf) > TYP_CMPRS_KEY ) then
          nh = nh + 1
          head(nh) = buf
       end if
    end do
    fits%nhead = nh
    allocate(fits%head(nh))
    fits%head = head(1:nh)
    deallocate(head)

    allocate(fits%image(fits%naxes(1),fits%naxes(2)), &
         fits%stderr(fits%naxes(1),fits%naxes(2)))
    call ftg2de(20,1,minvalue,fits%naxes(1),fits%naxes(1),fits%naxes(2),fits%image,&
         anyf,istat)

    call ftmnhd(20,IMAGE_HDU,EXT_STDERR,extver,istat)
    if( istat == 0 ) then
       call ftg2de(20,1,minvalue,fits%naxes(1),fits%naxes(1),fits%naxes(2),fits%stderr,&
            anyf,istat)
    else
       ! if the information about standard deviation is not available,
       ! we are continuing with epsilons
       fits%stderr = epsilon(fits%stderr)
       istat = 0
    end if

    call ftclos(20,istat)
    if( istat /= 0 ) goto 666

    fits%status = .true.
    return

666 continue

    call xfits_deallocate(fits)
    call ftclos(20,istat)
    call ftrprt('STDERR',istat)
    fits%status = .false.

  end subroutine xfits_read

  subroutine xfits_deallocate(fits)

    type(xFITS), intent(in out) :: fits

    if( allocated(fits%image) ) deallocate(fits%image)
    if( allocated(fits%stderr) ) deallocate(fits%stderr)
    if( allocated(fits%head) ) deallocate(fits%head)

  end subroutine xfits_deallocate

  subroutine xfits_kyd(fits,key,n,status)

    type(xFITS), intent(in) :: fits
    character(len=*), intent(in) :: key
    integer, intent(out) :: n
    integer, intent(in out) :: status
    integer :: i,keylength
    character(len=FLEN_CARD) :: keyname,value,comment

    if( status /= 0 ) return

    do i = 1,size(fits%head)
       keyname = ''
       call ftgknm(fits%head(i),keyname, keylength, status)
       if( status /= 0 ) exit

       if( key == keyname ) then
          value = ''
          comment = ''
          call ftpsvc(fits%head(i),value,comment,status)
          if( status /= 0 ) exit
          read(value,*,iostat=status) n
          return
       end if
    end do
    status = 1

  end subroutine xfits_kyd

  subroutine xfits_kye(fits,key,x,status)

    type(xFITS), intent(in) :: fits
    character(len=*), intent(in) :: key
    real, intent(out) :: x
    integer, intent(in out) :: status
    integer :: i,keylength
    character(len=FLEN_CARD) :: keyname,value,comment

    if( status /= 0 ) return

    do i = 1,size(fits%head)
       keyname = ''
       call ftgknm(fits%head(i),keyname, keylength, status)
       if( status /= 0 ) exit

       if( key == keyname ) then
          value = ''
          comment = ''
          call ftpsvc(fits%head(i),value,comment,status)
          if( status /= 0 ) exit
          read(value,*,iostat=status) x
          return
       end if
    end do
    status = 1

  end subroutine xfits_kye

  subroutine xfits_kys(fits,key,a,status)

    type(xFITS), intent(in) :: fits
    character(len=*), intent(in) :: key
    character(len=*), intent(out) :: a
    integer, intent(in out) :: status
    integer :: i,keylength
    character(len=FLEN_CARD) :: keyname,value,comment

    if( status /= 0 ) return

    do i = 1,size(fits%head)
       keyname = ''
       call ftgknm(fits%head(i),keyname, keylength, status)
       if( status /= 0 ) exit

       if( key == keyname ) then
          value = ''
          comment = ''
          call ftpsvc(fits%head(i),value,comment,status)
          if( status /= 0 ) exit
          read(value,*,iostat=status) a
          return
       end if
    end do
    status = 1

  end subroutine xfits_kys


end module xfitsio
