!
!  FITS I/O for photometry calibration
!
!  Copyright © 2014-2022 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 sfits

  use titsio
  use iso_fortran_env

  implicit none

  integer, parameter, private :: dbl = selected_real_kind(15)
  real(dbl), parameter, private :: rad = 57.295779513082322865_dbl

  type qFITS
     character(len=FLEN_FILENAME) :: filename
     real, dimension(:,:), allocatable :: frame
     integer :: naxis, nrows
     integer, dimension(2) :: naxes
     real(dbl), dimension(:),allocatable :: ra,dec,cts,dcts,sky,dsky,&
          ph,dph,phsky,dphsky,mag,dmag
     real(dbl) :: exptime,coo_err,aper,area,scale,rsky,rskyerr,skymag,&
          radf90, airmass, jd, hjd, longitude, latitude
     real(dbl), dimension(2) :: annuls
     character(len=FLEN_VALUE) :: filter, phtype
     logical :: geodefined = .false.
     logical :: status
  end type qFITS

  private :: readfits, qfits_init, qfits_deallocate, qfits_setph

contains



  subroutine writecal(filenames,outputs,keys,advanced,phsystable, &
    filters,catid,photsys,area,init_area,saper,tra,ctph,dctph,quantities,phres)

    use phsysfits
    use oakleaf
    use jamming
    use calibre
    use fotran
    use mfits
    use colorex

    real, parameter :: pi = 3.14159

    character(len=*), dimension(:), intent(in) :: filenames,outputs,keys, &
         quantities, filters
    character(len=*), intent(in) :: photsys, catid, phsystable
    real(dbl), dimension(:,:), intent(in) :: tra
    real(dbl), dimension(:), intent(in) :: ctph,dctph
    type(photores), dimension(:), intent(in), optional :: phres
    real(dbl), intent(in) :: area
    integer, intent(in) :: saper
    logical, intent(in) :: init_area, advanced

    real(dbl), parameter :: nullval = 0
    integer, parameter :: dim2 = 2
    integer, dimension(:), allocatable :: ndat
    integer, dimension(:,:), allocatable :: idx,pairs
    type(qFITS), dimension(:), allocatable :: fitses
    type(type_phsys) :: phsyscal
    real(dbl), dimension(:), allocatable :: atol
    real(dbl), dimension(:,:), allocatable :: ras,decs,ct,dct,sky,dsky,ph,dph, &
         phsky,dphsky,mag,dmag,phr,dphr
    real, dimension(:,:,:), allocatable :: cube,tcube
    real(dbl), dimension(size(ctph)) :: xctph,sqarcsec,airmass,aring,nsky
    real(dbl), dimension(1,size(ctph)) :: skymag,dskymag,skyrate,dskyrate
    integer, allocatable, dimension(:) :: order
    integer :: i,j,k,n,status,nrows_max, width, height, nq, ncat, nfiles, nrows, npht
    real(dbl) :: rsky,rskyerr,k0,r,lref

    nfiles = size(filenames)
    nq = size(quantities)
    npht = size(tra,1)

    status = 0
    allocate(fitses(nfiles))

    ! init photometry parameters
    call phselect(phsystable,photsys,phsyscal)
    call phsyspairs(phsyscal,filters,pairs)
    call file_order(filenames,keys,phsyscal%filter,order)

    nrows_max = 0
    ! read frames
    do n = 1, nfiles
       call qfits_init(fitses(n))
       call readfits(filenames(order(n)),keys,saper,fitses(n),status)
       if( status /= 0 ) stop 'FITS read failed.'
       if( fitses(n)%nrows > nrows_max ) nrows_max = fitses(n)%nrows
       if( init_area ) fitses(n)%area = area
       airmass(n) = fitses(n)%airmass
    end do

    ! convert frames from counts to photons
    if( nfiles == 1 ) then
       fitses(1)%frame = real(ctph(1)*fitses(1)%frame)
    else
       ! uncorrect handling for multiple frames with small mutual offsets !
       ! this code supposes all the fames with no mutual offset and the same dimensions
       width = fitses(1)%naxes(1)
       height = fitses(1)%naxes(2)
       allocate(cube(width,height,nfiles),tcube(width,height,nfiles))
       do n = 1,nfiles
          cube(:,:,n) = fitses(n)%frame
       end do

       do i = 1,width
          do j = 1,height
             !             call tra_frame(tra,pairs,ctph,cube(i,j,:),tcube(i,j,:))
             forall(n=1:npht)
                tcube(i,j,n) = real(ctph(n)*cube(i,j,n)*tra(n,n))
             end forall
          end do
       end do

       do n = 1,nfiles
          fitses(n)%frame = tcube(:,:,n)
       end do

       deallocate(cube,tcube)
    end if


    ! match both frames to be able to determine of colour indexes
    if( nfiles > 1 ) then

       allocate(ras(nrows_max,nfiles),decs(nrows_max,nfiles),atol(nfiles), &
            ndat(nfiles),idx(nrows_max,nfiles))
       idx = 0
       ras = 0
       decs = 0
       do n = 1,nfiles
          nrows = fitses(n)%nrows
          ndat(n) = nrows
          ras(1:nrows,n) = fitses(n)%ra
          decs(1:nrows,n) = fitses(n)%dec
       end do

       atol = 5.0*fitses%coo_err

       call jamframes(atol, ndat, ras, decs, idx)

       deallocate(ras,decs,atol,ndat)

    else ! nfiles == 1
       allocate(idx(nrows_max,nfiles))
       forall(i=1:size(idx,1))
          idx(i,1) = i
       end forall
    end if

    ncat = 0
    do i = 1,size(idx,1)
       if( all(idx(i,:) > 0) ) ncat = ncat + 1
    end do

    allocate(ct(ncat,nfiles),dct(ncat,nfiles),sky(ncat,nfiles), &
         dsky(ncat,nfiles),ras(ncat,nfiles),decs(ncat,nfiles))


    ncat = 0
    do i = 1,size(idx,1)
       if( all(idx(i,:) > 0) )then
          ncat = ncat  + 1
          do j = 1,nfiles
             k = idx(i,j)
             ras(ncat,j) = fitses(j)%ra(k)
             decs(ncat,j) = fitses(j)%dec(k)
             ct(ncat,j) = fitses(j)%cts(k)
             dct(ncat,j) = fitses(j)%dcts(k)
             sky(ncat,j) = fitses(j)%sky(k)
             dsky(ncat,j) = fitses(j)%dsky(k)
          end do
       end if
    end do
    deallocate(idx)

    do n = 1,nfiles
       deallocate(fitses(n)%ra,fitses(n)%dec)
       allocate(fitses(n)%ra(ncat),fitses(n)%dec(ncat))
       fitses(n)%ra = ras(:,n)
       fitses(n)%dec= decs(:,n)
    end do
    deallocate(ras,decs)


    allocate(ph(ncat,nfiles),dph(ncat,nfiles),phsky(ncat,nfiles), &
         dphsky(ncat,nfiles))
    ph = -1
    dph = -1
    phsky = -1
    dphsky = -1

    do n = 1,size(fitses)
       xctph(n) = fitses(n)%area * fitses(n)%exptime
       !xctph(n) = 1
       sqarcsec(n) = (3600 * fitses(n)%scale)**2
       ! unused:
       aring(n) = pi*(fitses(n)%annuls(2)**2 - fitses(n)%annuls(1)**2) /  &
            fitses(n)%scale**2
       nsky(n) = pi*fitses(n)%aper**2/fitses(n)%scale**2
    end do

!    write(*,*) aring
!    write(*,*) nsky

    allocate(mag(ncat,nfiles),dmag(ncat,nfiles),phr(ncat,nfiles), &
         dphr(ncat,nfiles))

    if( nfiles > 1 ) then
       ! estimate effective extinction
       call scaterr(phsyscal%lam_eff,ctph,airmass,k0,r,lref)
    else
       r = -1
    end if

    do i = 1,ncat
       if( nfiles == 1 )then
!          write(*,*) sqrt(ctph(1)),sqarcsec(1), dsky(i,1)
          where( sky(i,:) > 0 .and. dsky(i,:) > 0 )
             phsky(i,:) = ctph(1) * sky(i,:) !* sqarcsec(1)
             dphsky(i,:) = phsky(i,:) * (dsky(i,:)/sky(i,:))
!             dphsky(i,:) = sqrt(ctph(1)) * dsky(i,:) !* sqarcsec(1)
          elsewhere
             phsky(i,:) = -1
             dphsky(i,:) = -1
          end where

          where( ct(i,:) > 0 .and. dct(i,:) > 0 )
             ph(i,:) = ctph(1)*ct(i,:)
             dph(i,:) = sqrt(ctph(1)) * dct(i,:)  ! pure Poisson
             dph(i,:) = sqrt(ctph(1)**2*dct(i,:)**2 + ct(i,:)**2*dctph(1)**2)

             ! "gain" update
!             dph(i,:) = dph(i,:) / sqrt(ctph(1))

!             dph(i,:) = sqrt(dct(i,:)**2 + ct(i,:)**2*dctph(1)**2 + ctph(1)**2*dph(i,:)**2)


             ! Errors are estimated under Poisson statistics
             ! assumption, it can be underestimated for faint stars.

             ! fully optimal estimate: independent scaling Po and N parts
!             dph(i,:) = max(dct(i,:)**2 - ct(i,:),0.0)
!             dph(i,:) = sqrt(ph(i,:) + dph(i,:)*ctph(1)**2)


!             dph(i,:) = sqrt(ct(i,:)**2 * dctph(1)**2 + &
!                  ctph(1)**2 * dct(i,:)**2)
!             dph(i,:) = ph(i,:)*(dct(i,:)/ct(i,:))
             !dph(i,:) = sqrt(ph(i,:) + dphsky(i,:)**2*nsky(1)**2 + &
             !     dphsky(i,:)**2*pi*nsky(1)**2)
          elsewhere
             ph(i,:) = -1
             dph(i,:) = -1
          end where

!          write(*,*) sqrt(abs(ph(i,:))),sqrt(dphsky(i,:)**2*nsky(1)**2), &
          !               sqrt(dphsky(i,:)**2*pi*nsky(1)**2)
       else
          ct(i,:) = ctph * ct(i,:) / xctph
          dct(i,:) = ctph * dct(i,:) / xctph !! needs correction !!!
          sky(i,:) = ctph * sky(i,:) / xctph
          dsky(i,:) = ctph * dsky(i,:) / xctph
          call fotra(tra,pairs,ct(i,:),dct(i,:),phr(i,:),dphr(i,:))
          call fotra(tra,pairs,sky(i,:),dsky(i,:),phsky(i,:),dphsky(i,:))
          call correx(phsyscal%lam_eff,phsyscal%lam_fwhm/2,airmass,k0,r,lref,phr(i,:))
          where( phr(i,:) > 0 )
             ph(i,:) = phr(i,:) * xctph
             dph(i,:) = dphr(i,:) * xctph !! correct !!!
          elsewhere
             ph(i,:) = - 1
             dph(i,:) = -1
          end where
          where( phsky(i,:) > 0 )
             phsky(i,:) = phsky(i,:) * xctph
             dphsky(i,:) = dphsky(i,:) * xctph !! correct needs!!!
          elsewhere
             phsky(i,:) = -1
             dphsky(i,:) = -1
          end where
       end if

    end do
!    write(*,*) ct(4,1),ph(4,1)


!    write(*,*) ctph,dctph
!    write(*,*) ct
!    write(*,*) dct
!    write(*,*) ph
!    write(*,*) dph


    do i = 1, nfiles
       call rmean(phsky(:,i),rsky,rskyerr)
       skyrate(1,i) = (rsky / xctph(i)) / sqarcsec(i)
       dskyrate(1,i)= (rskyerr / (xctph(i)) / sqarcsec(i))
!       write(*,*) rsky,skyrate(1,i),xctph(i),sqarcsec(i)
    end do

    if( nfiles == 1 ) then
       call phsysphmag1(phsyscal,filters(1),ph(:,1)/xctph(1), &
            dph(:,1)/xctph(1),mag(:,1),dmag(:,1))
!            dph(:,1)/sqrt(xctph(1)),mag(:,1),dmag(:,1))
       call phsysphmag1(phsyscal,filters(1),skyrate(1,:),dskyrate(1,:), &
            skymag(1,:),dskymag(1,:))
!       write(*,*) trim(filenames(1)),xctph(1),ph(4,1),mag(4,1)
    else
       call phsysphmag(phsyscal,filters,pairs,phr,dphr,mag,dmag)
       call phsysphmag(phsyscal,filters,pairs,skyrate,dskyrate,skymag,dskymag)
    end if

!    write(*,*) xctph
!    write(*,*) mag
!    write(*,*) dmag

    do n = 1,size(fitses)
       call qfits_setph(fitses(n),ph(:,n),dph(:,n),phsky(:,n),dphsky(:,n))

       fitses(n)%mag = mag(:,n)
       fitses(n)%dmag = dmag(:,n)
       fitses(n)%rsky = skyrate(1,n)
       fitses(n)%rskyerr = dskyrate(1,n)
       fitses(n)%skymag = skymag(1,n)

    end do

    do n = 1,size(fitses)
       i = order(n)
       if( present(phres) ) then
          call savefits(filenames(i),outputs(i),fitses(n),advanced, &
               photsys,phsyscal,area,init_area,catid,quantities, &
               ctph(n),dctph(n),status,k0,r,lref,phres(n))
       else
          call savefits(filenames(i),outputs(i),fitses(n),advanced, &
               photsys,phsyscal,area,init_area,catid,quantities, &
               ctph(n),dctph(n),status,k0,r,lref)
       end if
       call qfits_deallocate(fitses(n))
    end do

    call deallocate_phsyscal(phsyscal)
    deallocate(ct,dct,sky,dsky,ph,dph,mag,dmag,phr,dphr, &
         phsky,dphsky,pairs,order)

  end subroutine writecal

  subroutine readfits(filename,keys,saper,fits,status)

    ! this is candidate for merge with the analogical subroutine in mfits.f95

    use astrotrafo
    use astrosphere
    use trajd
    use phio

    character(len=*), intent(in) :: filename
    character(len=*), dimension(:), intent(in) :: keys
    integer, intent(in) :: saper
    type(qFITS), intent(in out) :: fits
    integer, intent(in out) :: status

    real, parameter :: nullval = -huge(1.0)
    real(REAL64), parameter :: dullval = -huge(real(0.0,REAL64))
    integer, parameter :: group = 1, extver = 0
    integer :: frow
    real(dbl), dimension(:), allocatable :: xcen, ycen
    type(AstroTrafoProj) :: tastr
    logical :: anyf
    character(len=FLEN_CARD) :: key, dateobs
    integer :: w,h,i,l,ccol,dcol,xcol,ycol,scol,ecol,nrows,maper, naper, srows
    real(dbl) :: ls, jd0
    real :: hwhm, aper
    logical :: have_grow
    type(fitsfiles) :: fitsfile

    fits%filename = filename

    call fits_open_image(fitsfile,filename,FITS_READONLY,status)
    if( status /= 0 ) then
       write(error_unit,*) &
            'Error: failed to read an image in the file `',trim(filename),"'."
       return
    end if

    call fits_get_img_size(fitsfile,2,fits%naxes,status)
    if( status /= 0 ) goto 666

    ! WCS
    call wcsget(fitsfile,tastr,status)
    if( status == FITS_KEYWORD_NOT_FOUND ) then
       write(error_unit,*) 'Error: Astrometry keywords not found in header.'
       goto 666
    end if
    fits%scale = tastr%scale

    ! Citizen date
    call fits_get_dateobs(fitsfile,(/keys(3),keys(8)/),dateobs,status)
    if( status == 0 ) then
       fits%jd = fits_jd(dateobs,status)

       block
         real(REAL64), parameter :: one = real(1.0,REAL64)
         integer :: year, month, day, hour, minute
         real(dbl) :: second
         call fits_str2date(dateobs,year,month,day,hour,minute,second,status)

         ! Julian date of 1. january
         jd0 = datjd(real(year,REAL64),one,one)

       end block

    else
       write(error_unit,*) "Warning: Failed to get date or time."
       fits%jd = 0
       jd0 = 0
       status = 0
    end if

    call fits_read_key(fitsfile,keys(1),fits%exptime,status)
    if( status == FITS_KEYWORD_NOT_FOUND ) then
       write(error_unit,*) "Warning: Exposure time identified by FITS keyword `", &
            trim(keys(1)),"' not found (default to 1 sec)."
       fits%exptime = 1
       status = 0
    end if

    call fits_read_key(fitsfile,keys(2),fits%area,status)
    if( status == FITS_KEYWORD_NOT_FOUND ) then
!       write(error_unit,*) "Warning: Area identified by FITS keyword `",trim(keys(2)), &
!            "' not found (default to 1 [m2])."
       fits%area = 1
       status = 0
    end if

!    call ftgkyd(25,keys(3),fits%airmass,buf,status)
!    if( status == KEYWORD_NOT_FOUND ) then
!       fits%airmass = 1
!       status = 0
!    end if

    call fits_read_key(fitsfile,keys(5),fits%filter,status)
    if( status == FITS_KEYWORD_NOT_FOUND ) then
       write(error_unit,*) "Warning: Filter identified by FITS keyword `",trim(keys(5)), &
            "' not found (default to empty `')."
       fits%filter = ''
       status = 0
    end if

    call fits_read_key(fitsfile,keys(6),fits%longitude,status)
    call fits_read_key(fitsfile,keys(7),fits%latitude,status)
    fits%geodefined = status == 0
    if( status == FITS_KEYWORD_NOT_FOUND ) then
       write(error_unit,*) &
            "Warning: Geographical longitude or latitude identified by FITS keywords `",&
            trim(keys(6)),"',`",trim(keys(7)),"' not found. Airmass is undefined."
       status = 0
    end if

    ! Julian date at midpoint of exposure
    fits%jd = fits%jd + fits%exptime / 2.0_dbl / 86400.0_dbl

    ! Heliocentric JD
    ls = longsun(fits%jd - jd0)
    fits%hjd = fits%jd + helcor(tastr%acen,tastr%dcen,ls)

    ! airmass at the time
    if( fits%geodefined ) &
         fits%airmass = xairmass(fits%jd,fits%longitude,fits%latitude, &
         tastr%acen,tastr%dcen)

    ! frame
    w = fits%naxes(1)
    h = fits%naxes(2)
    allocate(fits%frame(w,h))
    call fits_read_image(fitsfile,group,nullval,fits%frame,anyf,status)

    ! move to aperture photometry extension
    call fits_movnam_hdu(fitsfile,FITS_BINARY_TBL,APEREXTNAME,0,status)
    if( status == FITS_BAD_HDU_NUM ) then
       write(error_unit,*) &
            "Failed to find an aperture photometry extension in ",trim(filename)
       goto 666
    end if

    ! sky annulus
    do i = 1, 2
       call fits_make_keyn(FITS_KEY_ANNULUS,i,key,status)
       call fits_read_key(fitsfile,key,fits%annuls(i),status)
    end do
    fits%annuls = fits%annuls * tastr%scale

    ! aperture
    if( saper == 0 ) then
       call fits_read_key(fitsfile,FITS_KEY_HWHM,hwhm,status)
       call fits_read_key(fitsfile,FITS_KEY_NAPER,naper,status)
       do i = 1, naper
          call fits_make_keyn(FITS_KEY_APER,i,key,status)
          call fits_read_key(fitsfile,key,aper,status)
          if( aper > 2*hwhm ) then
             maper = i
             exit
          end if
       end do
    else
       maper = saper
    end if
    call fits_make_keyn(FITS_KEY_APER,maper,key,status)
    call fits_read_key(fitsfile,key,fits%aper,status)
    fits%aper = fits%aper * tastr%scale

    ! move to growth-curve photometry extension
    call fits_movnam_hdu(fitsfile,FITS_BINARY_TBL,GROWEXTNAME,0,status)
    have_grow = .not. (status == FITS_BAD_HDU_NUM)
    if( status == FITS_BAD_HDU_NUM ) then
       ! no problem, we're continuing with aperture extension
       status = 0
    end if

    if( .not. have_grow .or. saper > 0 ) then
       call fits_movnam_hdu(fitsfile,FITS_BINARY_TBL,APEREXTNAME,0,status)
       write(key,'(a,i0)') FITS_COL_APCOUNT,maper
       call fits_get_colnum(fitsfile,.true.,key,ccol,status)
       write(key,'(a,i0)') FITS_COL_APCOUNTERR,maper
       call fits_get_colnum(fitsfile,.true.,key,dcol,status)
       fits%radf90 = -1
       fits%phtype = 'APHOT'
    else
       call fits_read_key(fitsfile,FITS_KEY_RF90,fits%radf90,status)
       fits%radf90 = fits%scale * fits%radf90
       fits%aper = -1
       call fits_get_colnum(fitsfile,.true.,FITS_COL_GCOUNT,ccol,status)
       call fits_get_colnum(fitsfile,.true.,FITS_COL_GCOUNTERR,dcol,status)
       fits%phtype = 'GPHOT'
    end if

    call fits_get_colnum(fitsfile,.true.,FITS_COL_X,xcol,status)
    call fits_get_colnum(fitsfile,.true.,FITS_COL_Y,ycol,status)
    call fits_get_colnum(fitsfile,.true.,FITS_COL_SKY,scol,status)
    call fits_get_colnum(fitsfile,.true.,FITS_COL_SKYERR,ecol,status)
    if( status /= 0 ) goto 666

    call fits_get_num_rows(fitsfile,nrows,status)
    allocate(xcen(nrows),ycen(nrows))
    allocate(fits%sky(nrows),fits%dsky(nrows), &
         fits%cts(nrows),fits%dcts(nrows))

    call fits_get_rowsize(fitsfile,srows,status)
    do i = 1, nrows, srows
       frow = i
       l = min(i+srows,nrows)

       call fits_read_col(fitsfile,xcol,frow,dullval,xcen(i:l),anyf,status)
       call fits_read_col(fitsfile,ycol,frow,dullval,ycen(i:l),anyf,status)
       call fits_read_col(fitsfile,scol,frow,dullval,fits%sky(i:l),anyf,status)
       call fits_read_col(fitsfile,ecol,frow,dullval,fits%dsky(i:l),anyf,status)
       call fits_read_col(fitsfile,ccol,frow,dullval,fits%cts(i:l),anyf,status)
       call fits_read_col(fitsfile,dcol,frow,dullval,fits%dcts(i:l),anyf,status)
       if( status /= 0 ) goto 666
    end do

    call fits_close_file(fitsfile,status)

    !  coordinates conversions
    allocate(fits%ra(nrows),fits%dec(nrows))
    call invtrafo(tastr,xcen,ycen,fits%ra,fits%dec)

    fits%nrows = nrows
    fits%coo_err = tastr%err

    deallocate(xcen,ycen)
    return

666 continue

    call fits_close_file(fitsfile,status)
    call fits_report_error(error_unit,status)

  end subroutine readfits


  subroutine savefits(filename,output,fits,advanced,photsys,phsyscal,&
       area,init_area,catid, qlabels,ctph, dctph, status, k0, r, lref, phres)

    use phsysfits
    use photoconv
    use calibre

    character(len=*), intent(in) :: filename,output,photsys,catid
    character(len=*), dimension(:), intent(in) :: qlabels
    type(qFITS), intent(in) :: fits
    type(type_phsys), intent(in) :: phsyscal
    real(dbl), intent(in) :: area, ctph, dctph, k0, r, lref
    logical, intent(in) :: init_area, advanced
    type(photores), intent(in), optional :: phres
    integer, intent(in out) :: status

    integer, parameter :: group = 1, extver = 0
    character(len=*), parameter :: bunit = units(3)
    character(len=FLEN_VALUE), dimension(:), allocatable :: ttype, tform,tunit
    character(len=FLEN_CARD), dimension(2) :: com
    real(dbl), dimension(:,:), allocatable :: q,dq
    character(len=FLEN_CARD) :: key, buf
    real(dbl) :: photflam,photzpt,photplam,photbw
    integer :: n, m, i, l, width, height, hdutype, nq, nrows, ncols, chdu, nhdu, &
         srows, frow
    type(fitsfiles) :: fitsfile, fitscal

    width = fits%naxes(1)
    height = fits%naxes(2)
    nq = size(qlabels)

    call fits_open_image(fitsfile,filename,FITS_READONLY,status)
    if( status /= 0 ) then
       write(error_unit,*) &
            'Error: failed to read an image in the file `',trim(filename),"'."
       return
    end if

    call fits_create_scratch(fitscal,status)
    call fits_copy_header(fitsfile,fitscal,status)
    call fits_update_key(fitscal,'BITPIX',-32,'',status)
    !call fits_delete_key(fitscal,'BSCALE,status)
    !call fits_delete_key(fitscal,'BZERO,status)

    if( status /= 0 ) goto 666

    call fits_get_hdu_num(fitsfile,chdu)

    call fits_update_key(fitscal,FITS_KEY_PHOTSYS,photsys,'photometry filter system',status)
    call fits_update_key(fitscal,FITS_KEY_BUNIT,bunit,'Physical units of array values',status)

    if( init_area ) then
       call fits_update_key(fitscal,FITS_KEY_AREA,area,-5, &
            '[m2] Area of input aperture',status)
    end if

    if( photsys /= '' ) then
       ! compatibility with HST calibration
       call phstkeys(phsyscal,fits%filter,photflam,photzpt,photplam,photbw)

       call fits_update_key(fitscal,FITS_KEY_PHOTFLAM,photflam,5, &
            '[erg/s/cm2/A] flux for 1 photon/s/cm2',status)
       call fits_update_key(fitscal,FITS_KEY_PHOTZPT,photzpt,-6, &
            'mag zero-point for fluxes in [erg/s/cm2/A]',status)
       call fits_update_key(fitscal,FITS_KEY_PHOTPLAM,photplam,-6, &
            '[A] effective wavelength',status)
       call fits_update_key(fitscal,FITS_KEY_PHOTBW,photbw,-6,'[A] passband FWHM',status)
    end if

    call fits_write_image(fitscal,group,fits%frame,status)
    if( status == FITS_NUMERICAL_OVERFLOW ) then
       call fits_report_error(error_unit,status)
       status = 0
    end if

    if( advanced ) then
       ! copy all others extensions
       call fits_get_num_hdus(fitsfile,nhdu,status)
       do n = 1,nhdu
          if( n /= chdu ) then
             call fits_movabs_hdu(fitsfile,n,hdutype,status)
             call fits_copy_hdu(fitsfile,fitscal,0,status)
             if( status /= 0 ) goto 666
          end if
       end do
    end if
    call fits_close_file(fitsfile,status)
    call fits_report_error(error_unit,status)

    ! prepare HDU with photometry
    ncols = 6 + 2*nq
    allocate(ttype(ncols),tform(ncols),tunit(ncols))

    tform = '1D'
    tunit(1:2) = 'deg'
    tunit(3:) = bunit

    ttype(1:6) = [ character(len=FLEN_VALUE) :: FITS_COL_RA, FITS_COL_DEC, &
         FITS_COL_SKY, FITS_COL_SKYERR, FITS_COL_PHOTON, FITS_COL_PHOTONERR ]

    do n = 1, nq
       i = 2*n + 5
       ttype(i) = qlabels(n)
       ttype(i+1) = trim(qlabels(n))//'ERR'
       call quantity(qlabels(n),tunit(i))
       tunit(i+1) = tunit(i)
    end do

    call fits_insert_btbl(fitscal,ncols,ttype,tform,tunit,PHOTOEXTNAME,status)
    call fits_update_key(fitscal,FITS_KEY_JD,fits%jd,-18, &
         'Julian date at midpoint of exposure',status)
    call fits_update_key(fitscal,FITS_KEY_HJD,fits%hjd,-12,'Heliocentric JD',status)

    if( fits%geodefined ) then
       call fits_update_key(fitscal,FITS_KEY_AIRMASS,fits%airmass,-5,&
            'The airmass of centre at JD',status)
    else
       call fits_update_key(fitscal,FITS_KEY_AIRMASS,fits%airmass,-1,&
            'Consider the airmass as UNDEFINED',status)
    end if
    call fits_update_key(fitscal,FITS_KEY_PHOTOTYP,fits%phtype,'photometry method',status)
    call fits_update_key(fitscal,FITS_KEY_CTPH,ctph,13,'counts per photons, calibration',status)
    call fits_update_key(fitscal,FITS_KEY_CTPHERR,dctph,1,'std. error of CTPH ',status)

    if( fits%aper > 0 ) &
         call fits_update_key(fitscal,FITS_KEY_APER,fits%aper,3, &
         '[deg] calibration aperture radius',status)
    if( fits%radf90 > 0 ) &
         call fits_update_key(fitscal,FITS_KEY_RF90,fits%radf90,3, &
         '[deg] radius contains 90% of flux',status)

    com(1) = '[deg] inner sky annulus radius'
    com(2) = '[deg] outer sky annulus radius'
    do i = 1, 2
       call fits_make_keyn(FITS_KEY_ANNULUS,i,key,status)
       call fits_update_key(fitscal,key,fits%annuls(i),3,com(i),status)
    end do
    call fits_update_key(fitscal,FITS_KEY_PHOTSYS,photsys,'photometry filter system',status)
    call fits_update_key(fitscal,FITS_KEY_FILTER,fits%filter,'filter in the system',status)
    if( status /= 0 ) goto 666

    if( r > 1 ) then
       call fits_write_comment(fitscal,'Extinction model k = k0*(lam/lref)**-r with parameters:',status)
       call fits_write_key(fitscal,FITS_KEY_EXTINK0,k0,-3,'mean extinction k0',status)
       call fits_write_key(fitscal,FITS_KEY_EXTINR,r,-3,'extinction power r',status)
       call fits_write_key(fitscal,FITS_KEY_EXTINREF,lref,-3,'[m] extinction reference wavelenght lref',status)
    end if

    call fits_update_key(fitscal,FITS_KEY_SKYMAG,fits%skymag,-5, &
         '[mag/arcsec2] the averadge sky in magnitudes',status)
    call fits_update_key(fitscal,FITS_KEY_SKYMEAN,fits%rsky,-5, &
         '[ph/s/m2/arcsec2] averadge sky of star anullii',status)
    call fits_update_key(fitscal,FITS_KEY_SKYSTD,fits%rskyerr,-2, &
         '[ph/s/m2/arcsec2] statistical error of the mean sky',status)

    call fits_update_key(fitscal,FITS_KEY_CREATOR,FITS_VALUE_CREATOR,FITS_COM_CREATOR,status)
    if( status /= 0 ) goto 666

    call fits_write_comment(fitscal,BEGIN_PHOTOCAL,status)

    if( catid /= '' ) then
       call fits_write_comment(fitscal,"Reference photometric sequence: "//trim(catid),status)
    end if
    write(buf,'(a,g0.5,a,es8.1)') "Counts per photons = ",ctph," +- ",dctph
    call fits_write_comment(fitscal,buf,status)

    if( present(phres) ) then

       write(buf,'(a,i0)') "Objects used = ",phres%ndat
       call fits_write_comment(fitscal,buf,status)
       call fits_write_comment(fitscal,'   Catalogue RA,DEC [deg]    Photons/s/m2    Counts/s/m2       rel.dev.',status)
       do i = 1, phres%ndat
          write(buf,'(2f13.8,2en15.3,f14.4)') &
               phres%ra(i),phres%dec(i),phres%pht(i),phres%cts(i),phres%res(i)
          call fits_write_comment(fitscal,buf,status)
       end do
    end if

    call fits_write_comment(fitscal,MUNIPACK_VERSION,status)
    call fits_write_comment(fitscal,'Description: http://munipack.physics.muni.cz/dataform_photometry.html',status)
    call fits_write_comment(fitscal,END_PHOTOCAL,status)

    nrows = size(fits%ra)

    allocate(q(nrows,nq),dq(nrows,nq))
    do n = 1, nq
       call phsysconv(qlabels(n),fits%filter,phsyscal,fits%area,fits%exptime,&
            1.0_dbl,fits%ph,fits%dph,q(:,n),dq(:,n))
    end do

    call fits_get_rowsize(fitscal,srows,status)
    do i = 1, nrows, srows
       frow = i
       l = min(i+srows,nrows)
       call fits_write_col(fitscal,1,frow,fits%ra(i:l),status)
       call fits_write_col(fitscal,2,frow,fits%dec(i:l),status)
       call fits_write_col(fitscal,3,frow,fits%phsky(i:l),status)
       call fits_write_col(fitscal,4,frow,fits%dphsky(i:l),status)
       call fits_write_col(fitscal,5,frow,fits%ph(i:l),status)
       call fits_write_col(fitscal,6,frow,fits%dph(i:l),status)
       do n = 1,nq
          m = 2*n + 5
          call fits_write_col(fitscal,m,frow,q(i:l,n),status)
          call fits_write_col(fitscal,m+1,frow,dq(i:l,n),status)
       end do
    end do

    deallocate(ttype,tform,tunit,q,dq)

    ! add residuals to a next extension
    if( advanced .and. present(phres) ) then

       ncols = 5
       allocate(ttype(ncols),tform(ncols),tunit(ncols))

       tform = '1D'
       tunit(1:2) = 'deg'
       tunit(3:) = ''

       ttype(1:5) = [ character(len=FLEN_VALUE) :: FITS_COL_RA, FITS_COL_DEC, &
            FITS_COL_PHOTON, FITS_COL_COUNT, 'RESIDUALS' ]

       call fits_insert_btbl(fitscal,0,ttype,tform,tunit,EXT_PHRES,status)
       call fits_update_key(fitscal,FITS_KEY_CTPH,ctph,13,'counts per photons, calibration',status)
       call fits_update_key(fitscal,FITS_KEY_CTPHERR,dctph,1,'std. error of CTPH ',status)

       call fits_write_comment(fitscal,'This table contains relative residuals of photometry',status)
       call fits_write_comment(fitscal,'calibration in '//trim(PHOTOEXTNAME)//' extension.',status)
       write(buf,'(a,g0.5,a,es8.1)') "Counts per photons = ",ctph," +- ",dctph
       call fits_write_comment(fitscal,buf,status)

       call fits_get_rowsize(fitscal,srows,status)
       do i = 1, nrows, srows
          frow = i
          l = min(i+srows,nrows)

          call fits_write_col(fitscal,1,frow,phres%ra(i:l),status)
          call fits_write_col(fitscal,2,frow,phres%dec(i:l),status)
          call fits_write_col(fitscal,3,frow,phres%pht(i:l),status)
          call fits_write_col(fitscal,4,frow,phres%cts(i:l),status)
          call fits_write_col(fitscal,5,frow,phres%res(i:l),status)
       end do

       deallocate(ttype,tform,tunit)

    end if

    if( status == 0 ) then
       if( fits_file_exist(output) ) call fits_file_delete(output)
       call fits_file_duplicate(fitscal,output,status)
    end if

666 continue

    call fits_delete_file(fitscal,status)
    call fits_report_error(error_unit,status)

  end subroutine savefits


  subroutine tra_frame(tra,pairs,ctph,xcts,xpht)

    use fotran

    integer, dimension(:,:), intent(in) :: pairs
    real(dbl), dimension(:,:), intent(in) :: tra
    real(dbl), dimension(:), intent(in) :: ctph
    real, dimension(:), intent(in) :: xcts
    real, dimension(:), intent(out) :: xpht

    real(dbl), dimension(:), allocatable :: cts,dcts,pht,dpht
    integer :: n

    n = size(xcts)
    allocate(cts(n),dcts(n),pht(n),dpht(n))
    cts = xcts * ctph
    dcts = 0
    dpht = 0
    call fotra(tra,pairs,cts,dcts,pht,dpht)
    xpht = real(pht)
    deallocate(cts,dcts,pht,dpht)

  end subroutine tra_frame


  subroutine qfits_init(fits)

    type(qFITS), intent(out) :: fits
    fits%status = .false.
    fits%filename = ''
    fits%nrows = 0
    fits%naxis = 0
    fits%naxes = 0
    fits%aper = -1
    fits%area = 1
    fits%exptime = 1
    fits%coo_err = -1
    fits%scale = 0
    fits%annuls = 0
    fits%filter = ''
    fits%rsky = 0
    fits%rskyerr = 0
    fits%skymag = 99.999
    fits%radf90 = -1
    fits%airmass = 1
    fits%jd = 0.0
    fits%latitude = 0.0
    fits%longitude = 0.0

  end subroutine qfits_init

  subroutine qfits_deallocate(fits)

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

    if( allocated(fits%frame) ) deallocate(fits%frame)
    if( allocated(fits%ra) ) deallocate(fits%ra)
    if( allocated(fits%dec) ) deallocate(fits%dec)
    if( allocated(fits%cts) ) deallocate(fits%cts)
    if( allocated(fits%dcts) ) deallocate(fits%dcts)
    if( allocated(fits%sky) ) deallocate(fits%sky)
    if( allocated(fits%dsky) ) deallocate(fits%dsky)
    if( allocated(fits%ph) ) deallocate(fits%ph)
    if( allocated(fits%dph) ) deallocate(fits%dph)
    if( allocated(fits%phsky) ) deallocate(fits%phsky)
    if( allocated(fits%dphsky) ) deallocate(fits%dphsky)

    if( allocated(fits%dmag) ) deallocate(fits%dmag)
    if( allocated(fits%mag) ) deallocate(fits%mag)

  end subroutine qfits_deallocate

  subroutine qfits_setph(fits,ph,dph,phsky,dphsky)

    type(qFITS), intent(in out) :: fits
    real(dbl), dimension(:), intent(in) :: ph,dph,phsky,dphsky
    integer :: ncat

    ncat = size(ph)
    allocate(fits%ph(ncat),fits%dph(ncat),fits%phsky(ncat),fits%dphsky(ncat))
    allocate(fits%mag(ncat),fits%dmag(ncat))
    fits%ph = ph
    fits%dph = dph
    fits%phsky = phsky
    fits%dphsky = dphsky

  end subroutine qfits_setph

end module sfits
