!
!  munilist
!
!  Copyright © 2012-7 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 mtable


  implicit none

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

contains

  subroutine table(filename,extname,fitskeys,headkeys,coonames,colnames,verbose,&
       cootype, &
       fitsval,headval,photsys,filter,year,month,day,hour,min,sec,airmass,exptime, &
       tproj,coo,data,status)

    use fitsio
    use astrotrafo
    use phio
    use iso_fortran_env

    logical, intent(in) :: verbose
    character(len=*), intent(in) :: filename, extname, cootype
    character(len=*), intent(out) :: filter, photsys
    character(len=*), dimension(:), intent(in) :: fitskeys, headkeys, coonames,colnames
    character(len=*), dimension(:), intent(inout) :: fitsval,headval
    real(dbl), intent(out) :: year,month,day,hour,min,sec,airmass,exptime
    real(dbl), dimension(:,:), allocatable, intent(out) :: coo,data
    type(AstroTrafoProj),intent(out) :: tproj
    integer, intent(out) :: status

    integer, parameter :: DIM = 2
    integer, dimension(DIM) :: naxes
    real(dbl), dimension(:), allocatable :: tmp
    integer :: naxis,pcount,gcount,bitpix,nrows,colnum,frow,felem, &
         ndata,i,y1,m1,d1,h1,min1,ctaper,ncols
    logical :: simple,extend,anyf
    real(dbl) :: nullval
    character(len=80) :: line, buf,colname,card, key

    line = ''; buf = ''; colname = ''; card = ''; key = ''

    frow = 1
    felem = 1
    nullval = 0.0_dbl
    ctaper = 0

    ! input FITS file
    status = 0
    call ftdopn(20,filename,0,status)

    call ftghpr(20,DIM,simple,bitpix,naxis,naxes,pcount,gcount,extend,status)
    if( status /= 0 ) then
       if( verbose ) write(error_unit,*) "Failed to open: ",trim(filename)
       goto 666
    endif

    ! read date and time
    call datetime(20,fitskeys(1:2),y1,m1,d1,h1,min1,sec,status)
    if( status == 0 ) then
       year = y1; month = m1; day = d1; hour = h1; min = min1
    else
!      if( verbose ) write(error_unit,*) "Warning: Failed to get date or time."
       goto 666
    end if

    ! read date, time, exposure, filter
    call ftgkyd(20,fitskeys(3),exptime,buf,status)
    if( status == KEYWORD_NOT_FOUND ) then
       exptime = 1.0
!       if( verbose ) write(*,*) 'Exposure time not found. Assumed =0.'
       status = 0
    endif

    ! read date, time, exposure, filter
    call ftgkys(20,fitskeys(4),filter,buf,status)
    if( status == KEYWORD_NOT_FOUND ) then
       filter = ''
!       if( verbose )  write(*,*) 'Filter not found.'
       status = 0
    endif

    call ftgkys(20,fitskeys(15),photsys,buf,status)
    if( status == KEYWORD_NOT_FOUND ) then
       photsys = ''
       status = 0
    endif

    ! required header quantities
    do i = 1, size(fitskeys)

       call ftgkys(20,fitskeys(i),line,buf,status)
       if( status == 0 ) then
          fitsval(i) = line
       else
          fitsval(i) = ''
          status = 0
       end if
    end do

    do i = 1, size(headkeys)

       call ftgkys(20,headkeys(i),line,buf,status)
       if( status == 0 ) then
          headval(i) = line
       else
          headval(i) = ''
          status = 0
       end if

    end do

    if( cootype == 'DEG' ) then
       call wcsget(20,tproj,status)
    else if( cootype == 'RECT' ) then
       tproj%type = ''
    end if

    ! select data extension
    call ftmnhd(20,BINARY_TBL,extname,0,status)
    if( status == BAD_HDU_NUM ) then
       if( verbose ) write(error_unit,*)  &
            "Failed to find a photometry extension: ",trim(filename)
       goto 666
    end if

    call ftgkyd(20,'AIRMASS',airmass,buf,status)

    ! possible keys in table HDU
    do i = 1, size(headkeys)

       call ftgkys(20,headkeys(i),line,buf,status)
       if( status == 0 ) then
          headval(i) = line
       else
          status = 0
       end if

    end do

    call ftgnrw(20,nrows,status)
    if( status /= 0 ) goto 666

    ! table
    ncols = size(coonames)
    allocate(coo(nrows,ncols))
    allocate(tmp(nrows))

    do i = 1, ncols
       call ftgcno(20,.true.,coonames(i),colnum,status)
       call ftgcvd(20,colnum,frow,felem,nrows,nullval,tmp,anyf,status)
       coo(:,i) = tmp
    end do

    ndata = size(colnames)
    allocate(data(nrows,ndata))
    do i = 1, ndata
       call ftgcno(20,.true.,colnames(i),colnum,status)
       call ftgcvd(20,colnum,frow,felem,nrows,nullval,tmp,anyf,status)
       if( status == 0 ) data(:,i) = tmp
    end do
    deallocate(tmp)

666 continue

    call ftclos(20,status)
    call ftrprt('STDERR',status)

  end subroutine table

end module mtable
