!
!  artificial frames
!
!  Copyright © 2016-9 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/>.
!
!
!  * The variable star part, implemented as a class, would by more classy.
!  * Checking proper combination of parameters during computations (to prevent
!    frames below horizon with atmosphere, negative values of radii, etc.)?
!  * Add galaxies (profiles as NFW, Hubble, King, spirals) or globular clusters
!    with Plummer? Fractals for nebulae?
!

program artificial

  use titsio
  use trajd
  use generator
  use lcurves
  use lcio
  use iso_fortran_env

  implicit none

  integer, parameter :: dbl = selected_real_kind(15)
  real(dbl), parameter :: j2000 = 2451544.5_dbl

  character(len=4*FLEN_FILENAME) :: record,key,val,fmt
  character(len=FLEN_FILENAME) :: cat = '', phsystable = '', &
       phsystem = 'Johnson', file = 'artificial.fits', &
       filemask = 'artificial_???.fits'
  logical :: verbose = .false., plog = .false.
  integer, dimension(2) :: naxes = [ 666, 666 ]
  real(dbl), dimension(2) :: crpix = [ 333, 333 ]
  integer :: bitpix = -32
  integer :: nfiles = 0
  integer :: eq,n,i,l1,l2
  real(dbl) :: skymag = 21               ! mag per 1 sq. arcsec
  real(dbl), dimension(2) :: skygrad = [ 0,0 ]  ! mag per 1 sq. arcsec per pix
  integer :: maglim = 13
  real(dbl) :: exptime = 1, area = 1     ! 1 sec per 1 sq.meter, equiv. r=0.56m
  real(dbl) :: hwhm = 1                  ! in pixels
  real(dbl) :: eccentricity = 0          ! 0 (circle) .. 1 (line)
  real(dbl) :: inclination = 0           ! inclination of major semiaxis, degs
  real(dbl) :: airy = 0.1                ! Airy disk radius in pix for r=0.56m
  real(dbl) :: beta = 2                  ! Moffat exponent
  real(dbl) :: scale = 1.0 / 3600.0      ! 1 arcsex = 1 pix
  real(dbl) :: fov = 666. / 3600.0       ! field of view, used for scale setup
  real(dbl) :: angle = 0
  real(dbl) :: qefficiency = 1
  logical   :: noise = .true.            ! data has added noise componets
  real(dbl) :: extink = 0.1              ! extinction coefficient
  real(dbl) :: longitude = 0             ! geographic longitude
  real(dbl) :: latitude = 0              ! geographic latitude
  real(dbl) :: timestep = 60             ! time step in seconds
  real(dbl) :: jd = j2000                ! 2000-01-01T00:00:00
  real(dbl) :: year = 2000, month = 1, day = 1, hour = 0, minute = 0, sec = 0, r, d
  real(dbl), dimension(2) :: crval = 0
  real(dbl) :: lcmag = 15                ! lc magnitude
  real(dbl) :: ccmag = 15                ! current magnitude
  real(dbl) :: lcamp = 1                 ! lc amplitude
  real(dbl) :: lcjd0 = j2000             ! lc reference time
  real(dbl) :: lcper = 1                 ! lc period
  real(dbl), dimension(2) :: lcoo = 0    ! lc coordinates
  character(len=FLEN_VALUE) :: filter = 'V'
  character(len=FLEN_VALUE), dimension(5) :: labels = [ '','','','','' ]
  character(len=FLEN_VALUE) :: profile = 'SEEING'
  character(len=FLEN_VALUE) :: spread = 'AUTO'
  character(len=FLEN_VALUE) :: lcmodel = '', lctable = '', lcfourier = ''
  complex(dbl), dimension(:), allocatable :: fcoeff ! lc Fourier coefficients
  real(dbl), dimension(:), allocatable :: xcoo,ycoo,flux
  ! 'FFT' for FFT convolution, 'RANDOM' for random offset, 'AUTO' for 'RANDOM'
  ! of short exposures and 'TEST' for direct convolution
  type(SplineSerieType) :: lcspline
  logical :: atmosphere = .false.
  logical :: lcmode = .false.
  logical :: datetime_init = .false.
  logical :: lccoo_init = .false.

  do
     read(*,'(a)',end=20) record

     eq = index(record,'=')
     if( eq == 0 ) stop 'Malformed input record.'
     key = record(:eq-1)
     val = record(eq+1:)

     if( key == 'VERBOSE' ) then

        read(val,*) verbose

     else if( key == 'PIPELOG' ) then

        read(val,*) plog

     else if( key == 'PROFILE' ) then

        read(val,*) profile

     else if( key == 'SPREAD' ) then

        read(val,*) spread

     else if( key == 'NAXES' ) then

        read(val,*) naxes

     else if( key == 'BITPIX' ) then

        read(val,*) bitpix

     else if( key == 'SKYMAG' ) then

        read(val,*) skymag

     else if( key == 'SKYGRADX' ) then

        read(val,*) skygrad(1)

     else if( key == 'SKYGRADY' ) then

        read(val,*) skygrad(2)

     else if( key == 'MAGLIM' ) then

        read(val,*) maglim

     else if( key == 'HWHM' ) then

        read(val,*) hwhm

     else if( key == 'ECCENTRICITY' ) then

        read(val,*) eccentricity
        if( .not. abs(eccentricity) < 1 ) stop 'Error: eccentricity >= 1.'

     else if( key == 'INCLINATION' ) then

        read(val,*) inclination

     else if( key == 'AIRY' ) then

        read(val,*) airy

     else if( key == 'BETA' ) then

        read(val,*) beta

     else if( key == 'FILTER' ) then

        read(val,*) filter

     else if( key == 'EXPTIME' ) then

        read(val,*) exptime

     else if( key == 'AREA' ) then

        read(val,*) area

     else if( key == 'QEFF' ) then

        read(val,*) qefficiency

     else if( key == 'EXTINK' ) then

        read(val,*) extink

     else if( key == 'FOV' ) then

        read(val,*) fov
        scale = fov / naxes(2)

     else if( key == 'DIAMETER' ) then

        read(val,*) d
        r = d / 2
        area = 3.14*r**2
        airy = 7e-2/r

     else if( key == 'ANGLE' ) then

        read(val,*) angle

     else if( key == 'SCALE' ) then

        read(val,*) scale

     else if( key == 'CRVAL' ) then

        read(val,*) crval

     else if( key == 'CAT' ) then

        read(val,*) cat

     else if( key == 'COL_RA' ) then

        read(val,*) labels(1)

     else if( key == 'COL_DEC' ) then

        read(val,*) labels(3)

     else if( key == 'COL_PMRA' ) then

        read(val,*) labels(2)

     else if( key == 'COL_PMDEC' ) then

        read(val,*) labels(4)

     else if( key == 'COL_MAG' ) then

        read(val,*) labels(5)

     else if( key == 'PHSYSTABLE' ) then

        read(val,*) phsystable

     else if( key == 'PHOTSYS' ) then

        read(val,*) phsystem

     else if( key == 'GEOGRAPHIC' ) then

        read(val,*) longitude, latitude

     else if( key == 'TIMESTEP' ) then

        read(val,*) timestep

     else if( key == 'DATE' ) then

        read(val,*) year,month,day
        datetime_init = .true.

     else if( key == 'TIME' ) then

        read(val,*) hour,minute,sec
        datetime_init = .true.

     else if( key == 'ATMOSPHERE' ) then

        read(val,*) atmosphere

     else if( key == 'LCMODEL' ) then

        read(val,*) lcmodel

     else if( key == 'LCTABLE' ) then

        read(val,*) lctable

     else if( key == 'LCFOURIER' ) then

        read(val,*) lcfourier

     else if( key == 'LCMAG' ) then

        read(val,*) lcmag

     else if( key == 'LCAMP' ) then

        read(val,*) lcamp

     else if( key == 'LCJD0' ) then

        read(val,*) lcjd0

     else if( key == 'LCPER' ) then

        read(val,*) lcper

     else if( key == 'LCCOO' ) then

        read(val,*) lcoo
        lccoo_init = .true.

     else if( key == 'NOISE' ) then

        read(val,*) noise

     else if( key == 'NFILES' ) then

        read(val,*) nfiles

     else if( key == 'OUTPUT' ) then

        read(val,*) filemask

     end if

  end do

20 continue

  crpix = naxes / 2

  if( spread == 'AUTO' ) then
     if( exptime < 3 ) then
        spread = 'RANDOM'
     else
        spread = 'FFT'
     end if
  end if

  ! whatever LC is generated
  if( lcmodel /= '' .or. lctable /= '' .or. lcfourier /= '' ) lcmode = .true.

  if( lcmode ) then
     if( .not. lccoo_init ) lcoo = crval

     if( lctable /= '' ) then
        call lctable_init(lctable,lcspline)
     end if
     if( lcfourier /= '' ) then
        call lcfourio(lcfourier,fcoeff)
     end if

  end if

  ! stars
  if( cat /= '' ) then
     call catstars(cat,labels,scale,angle,crval,crpix,phsystable,phsystem, &
          filter,xcoo,ycoo,flux)
  else
     call genstars(maglim,naxes,xcoo,ycoo,flux)
  end if

  if( verbose ) then
     write(error_unit,*)
     write(error_unit,*) "LIST OF PARAMETERS"
     write(error_unit,*)
     write(error_unit,*) "Point spread function (PSF): ",trim(profile)
     write(error_unit,*) "Seeing spread method: ",trim(spread)
     write(error_unit,*) "Atmosphere modelling: ",atmosphere
     write(error_unit,'(a,f0.2)') " HWHM = ",hwhm
     write(error_unit,'(a,f0.3)') " Eccentricity = ",eccentricity
     write(error_unit,'(a,f0.1)') " Inclination = ",inclination
     if( profile == 'MOFFAT' ) then
        write(error_unit,'(a,f0.2)') " Moffat exponent (beta) = ",beta
     else if( profile == 'SEEING' ) then
        write(error_unit,'(a,f0.2)') " Airy disk radius (airy) = ",airy
     end if
     write(error_unit,'(a,f0.2)') " Quantum efficiency = ",qefficiency
     if( atmosphere ) then
        write(error_unit,'(a,f0.2)') " Extinction coefficient = ",extink
     end if
     write(error_unit,*) "Photometry system: ",trim(phsystem)
     write(error_unit,*) "Filter: ",trim(filter)
     write(error_unit,'(a,f0.1,a)') " Sky magnitude = ",skymag," mag/arcsec2"
     write(error_unit,'(a,2(g0.2,2x),a)') &
          " Sky gradient = ",skygrad," mag/arcsec2/pix"
     write(error_unit,'(a,f0.2,a)') " Area = ",area," [m2]"
     write(error_unit,'(a,f0.1,a)') " Exposure time = ",exptime," [s]"
     write(error_unit,'(a,f0.1,a)') " Time span = ",timestep," [s]"
     write(error_unit,'(a,i4.4,2("-",i2.2))') " Exposure start date: ", &
          nint(year),nint(month),nint(day)
     write(error_unit,'(a,2(i2.2,":"),f0.3)') " Exposure start time: ", &
          nint(hour),nint(minute),sec
     write(error_unit,'(a,i0," x ",i0)') " Width and height of image(s): ",naxes
     write(error_unit,'(a,2f7.2,a)') " Equatorial coordinates: ",crval," [deg]"
     write(error_unit,'(a,f0.1,a,g0.1,a)') ' Scale: ',1/scale," [pix/deg],  ", &
          scale*3600," [arcsec/pix]"
     write(error_unit,'(a,f0.1,a)') ' Field rotation = ',angle," [deg]"
     write(error_unit,'(a,f0.1,a)') ' Field of view = ',fov," [deg]"
     if( cat == '' ) then
        write(error_unit,*) "Star coordinates and fluxes: random generated"
        write(error_unit,'(a,i0)') " Magnitude limit = ",maglim
     else
        write(error_unit,*) "Star coordinates and fluxes: by `",trim(cat),"'"
     end if
     write(error_unit,'(a,2f7.2,a)') " Observatory coordinates: ", &
          longitude, latitude," [deg]"
     write(error_unit,*) "Light curve modelling: ",lcmode
     if( lcmode ) then
        if( lcmodel /= '' ) then
           write(error_unit,*) "Light curve model: ",trim(lcmodel)
        else if( lctable /= '' ) then
           write(error_unit,*) "Light curve in table: `",trim(lctable),"'"
        else if( lcfourier /= '' ) then
           write(error_unit,*) "Light curve by Fourier coefficients in: `", &
                trim(lcfourier),"':"
           do i = 0,size(fcoeff)-1
              write(error_unit,'(a,i0,a,2(3x,f0.5),a)') "   c(",i,") = ",&
                   fcoeff(i),"i"
           end do
        end if
        write(error_unit,'(a,f0.1)') " Light curve mean magnitude = ",lcmag
        write(error_unit,'(a,f0.1)') " Light curve amplitude = ",lcamp
        write(error_unit,'(a,f0.6)') " Light curve JD0 = ",lcjd0
        write(error_unit,'(a,f0.6,a)') " Light curve period = ",lcper, &
             " [day(s)]"
        write(error_unit,'(a,2f7.2,a)') " Coordinates of the object: ",lcoo, &
             " [deg]"
     end if
     write(error_unit,*)
     write(error_unit,*) "Filename, JD(begin), airmass, seeing radius:"
  end if


  ! determine '?' in filemask
  n = 0
  do i = 1,len(filemask)
     if( filemask(i:i) == '?' ) n = n + 1
  end do
  if( nfiles > 1 .and. n == 0 ) n = int(log10(real(nfiles)) + 1)
  if( nfiles == 0 .and. n == 0 ) file = filemask
  write(fmt,'(a,i0,a)') '(a,i0.',n,',a)'

  if( datetime_init ) &
       jd = datjd(year,month,day + (hour+(minute+sec/60.0_dbl)/60.0_dbl)/24.0_dbl)
  timestep = timestep / 86400.0_dbl


  if( nfiles == 0 ) then

     call artfits(file,jd)

  else

     l1 = index(filemask,'?')

     if( l1 > 0 ) then
        l1 = l1 - 1
        l2 = index(filemask,'?',back=.true.) + 1

        do i = 1,nfiles
           write(file,fmt) filemask(1:l1),i,filemask(l2:len_trim(filemask))
           call artfits(file,jd)
           jd = jd + timestep
        end do
     else
        ! single filename
        call artfits(filemask,jd)
     end if

  end if

  if( allocated(fcoeff) ) deallocate(fcoeff)
  if( allocated(xcoo) ) deallocate(xcoo,ycoo,flux)

  stop 0

contains

  subroutine artfits(filename,jd)

    use generator
    use marker
    use spray
    use astrosphere
    use lcurves

    real(dbl), parameter :: rad = 57.295779513082322865_dbl

    character(len=*), intent(in) :: filename
    real(dbl), intent(in) :: jd

    integer :: status
    character(len=FLEN_COMMENT) :: com
    character(len=FLEN_VALUE) :: datetime
    real(dbl), dimension(:,:), allocatable :: sky
    real(dbl) :: c,s,x,qe,see,extin,hwhms,jd2, ms, lcflux, phi, mag, back
    real(dbl), dimension(2) :: bgrad
    integer :: year, month, day, hour, minute, sec, m
    real(dbl), dimension(:), allocatable :: xstar,ystar,fluxes,xvar, yvar, fvar
    type(SprayType) :: psf
    type(fitsfiles) :: fits

    ! background at zenit
    back = magiconv(phsystable,phsystem,filter,[skymag])
    back = back * exptime * area * qefficiency * (scale*3600)**2
    bgrad = 1.086 * skygrad * back

    if( atmosphere ) then

       ! compute airmass
       x = xairmass(jd,longitude,latitude,crval(1),crval(2))
       if( x < 0 ) then
          call jdatetime(jd,year,month,day,hour,minute,sec,ms)
          write(error_unit,'(a,i4.4,2(a,i2.2),a,2(i2.2,a),i2.2,a,i0.3,a)') &
               "Airmass undefined (below horizon) for date  ", &
               year,"-",month,"-",day,"  and time ",hour,":",minute,":",sec,".", &
               nint(ms)," UT"
          return
       end if

       ! simulate seeing and extinction
       extin = exp(-extink*(x-1))          ! relative extinction against X=1
       qe = extin * qefficiency

       ! http://www.astro.auth.gr/~seeing-gr/seeing_gr_files/theory/node17.html
       ! Fries parameter for spread
       see = x**0.6
       hwhms = hwhm*see

       ! sky increases by airmass
       back  = back * extin
       bgrad = 1.086 * skygrad * back

       if( verbose ) write(error_unit,'(a,f15.5,f8.3,2f6.2)') &
            trim(filename),jd,x,extin,see
    else
       hwhms = hwhm
       qe = qefficiency

       if( verbose ) &
            write(error_unit,'(a,f15.5)') trim(filename),jd
    endif

    if( lcmode ) then
       ! variables

       phi = phase(jd,lcjd0,lcper)

       lcflux = 1

       if( lcmodel == 'WAVE' ) then
          lcflux = wave(phi)
       else if( lcmodel == 'CEPHEID' ) then
          lcflux = delta_cep(phi)
       else if( lcmodel == 'ALGOL' ) then
          lcflux = beta_per(phi)
       else if( lcmodel /= '' ) then
          stop "Unrecognised light curve model. Try `Cepheid', `Algol', `wave'."
       end if

       if( lcfourier /= '' ) then
          lcflux = fourfun(fcoeff,phi)
       end if

       if( lctable /= '' ) then
          lcflux = lcspline%Spline(phi)
       end if

       if( lcflux > 0 ) then
          mag = lcmag - (2.5_dbl*lcamp*log10(lcflux))
       else
          write(error_unit,*) 'Negative flux detected. Assumed near zero.'
          mag = 99.999
       end if

       allocate(xvar(1),yvar(1),fvar(1))
       call rain([lcoo(1)],[lcoo(2)],[mag],scale,angle,crval,crpix, &
            phsystable,phsystem,filter,xvar,yvar,fvar)

       ccmag = magconv(phsystable,phsystem,filter,fvar)
    else
       allocate(xvar(0),yvar(0),fvar(0))
    end if

    ! Frame generator
    allocate(sky(naxes(1),naxes(2)))
    sky = 0

    call background(back,bgrad,noise,sky)

    ! merge both lists: variables and ordinary stars
    m = size(xvar)
    n = m + size(xcoo)
    allocate(xstar(n),ystar(n),fluxes(n))
    xstar(1:m) = xvar;  xstar(m+1:) = xcoo
    ystar(1:m) = yvar;  ystar(m+1:) = ycoo
    fluxes(1:m) = fvar; fluxes(m+1:) = flux

    ! update fluxes
    fluxes = fluxes * exptime * area * qe

    ! simulate profile
    call psf%Init(profile,spread,hwhms,eccentricity,inclination,airy,beta)

    ! create the artificial sky
    call spreadstars(psf,xstar,ystar,fluxes,noise,sky)

    ! watermark
    call watermark(sky,5*sqrt(back))


    ! save the generated artificial sky to FITS file
    status = 0
    if( fits_file_exist(filename) ) call fits_file_delete(filename)
    call fits_create_file(fits,filename,status)
    if( status /= 0 ) then
       write(error_unit,*) "Error: `",trim(filename),"' failed to create."
       goto 666
    end if

    ! convert JD to date
    call jdatetime(jd,year,month,day,hour,minute,sec,ms)
    jd2 = jd + exptime / 2.0_dbl / 86400.0_dbl

    ! the artifical frame
    call fits_insert_img(fits,bitpix,size(naxes),naxes,status)
    write(datetime, &
         "(i4.4,'-',i2.2,'-',i2.2,'T',i2.2,':',i2.2,':',i2.2,'.',i3.3)") &
         year, month, day, hour, minute, sec, nint(ms)
    call fits_write_key(fits,FITS_KEY_DATEOBS,datetime,'date and time in UT',&
         status)
    call fits_write_key(fits,FITS_KEY_FILTER,filter,'filter',status)
    call fits_write_key(fits,FITS_KEY_JD,jd2,-16, &
         '[day] Julian date at half of exposure',status)
    call fits_write_key(fits,FITS_KEY_EXPTIME,exptime,-3,'[s] exposure time', &
         status)
    call fits_write_key(fits,FITS_KEY_AREA,area,-2,'[m2] detection area',status)
    call fits_write_key(fits,FITS_KEY_HWHM,hwhms,-3, &
         '[pix] half with at half maximum',status)
    call fits_write_key(fits,FITS_KEY_ECCENTRICITY,eccentricity,-3, &
         'eccentricity of ellipsis (0=circle)',status)
    call fits_write_key(fits,FITS_KEY_INCLINATION,inclination,-1, &
         '[deg] inclination of major semiaxis',status)
    if( atmosphere ) &
         call fits_write_key(fits,FITS_KEY_AIRMASS,x,-4,'airmass',status)
    call fits_write_key(fits,'PSF',profile,'PSF',status)
    if( profile == 'MOFFAT' ) then
       call fits_write_key(fits,'MOFFATB',beta,-3,'Moffat exponent',status)
    else if ( profile == 'SEEING' ) then
       call fits_write_key(fits,'AIRYDISK',airy,-3,'[pix] Airy disk radius', &
            status)
       call fits_write_key(fits,'SPREAD',spread,'seeing spread method ',status)
    end if
    call fits_write_key(fits,'CTYPE1','RA---TAN', &
         'the coordinate type for the first axis',status)
    call fits_write_key(fits,'CTYPE2','DEC--TAN', &
         'the coordinate type for the second axis',status)
    call fits_write_key(fits,'CRPIX1',real(naxes(1)/2),-6,'[pix]',status)
    call fits_write_key(fits,'CRPIX2',real(naxes(2)/2),-6,'[pix]',status)
    call fits_write_key(fits,'CRVAL1',crval(1),-17,'[deg]',status)
    call fits_write_key(fits,'CRVAL2',crval(2),-17,'[deg]',status)
    s = sin(angle/rad)
    c = cos(angle/rad)
    call fits_write_key(fits,'CD1_1',-c*scale,13,'',status)
    call fits_write_key(fits,'CD1_2',s*scale,13,'',status)
    call fits_write_key(fits,'CD2_1',s*scale,13,'',status)
    call fits_write_key(fits,'CD2_2',c*scale,13,'',status)
    call fits_write_key(fits,FITS_KEY_LONGITUDE,longitude,-5, &
         '[deg] geographic longitude (-east)',status)
    call fits_write_key(fits,FITS_KEY_LATITUDE,latitude,-5, &
         '[deg] geographic latitude (+north)',status)
    call fits_write_comment(fits,'Artificial sky by Munipack.',status)
    call fits_write_comment(fits,'Parameters:',status)
    write(com,'(a,es10.3,1x,2(g0.2,1x))') &
         'Background: level, gradient = ',back,bgrad
    call fits_write_comment(fits,com,status)
    write(com,'(a,l2)') 'Noise: ',noise
    call fits_write_comment(fits,com,status)
    write(com,'(2a)') 'PSF = ',trim(profile)
    call fits_write_comment(fits,com,status)
    write(com,'(2a)') 'Seeing spread method = ',trim(spread)
    call fits_write_comment(fits,com,status)
    write(com,'(a,i0)') 'Magnitude limit  = ',maglim
    call fits_write_comment(fits,com,status)
    write(com,'(a,g0.3)') 'Quantum efficiency  = ', qe
    call fits_write_comment(fits,com,status)
    if( atmosphere ) then
       write(com,'(a,g0.3)') 'Extinction coefficient  = ', extink
       call fits_write_comment(fits,com,status)
       write(com,'(a,g0.3)') 'Seeing factor  = ', see
       call fits_write_comment(fits,com,status)
    end if
    if( lcmode ) then
       write(com,'(2a)') 'Light curve model = ',trim(lcmodel)
       call fits_write_comment(fits,com,status)
       if( lcfourier /= '' ) then
          write(com,'(2a)') 'Fourier coefficients table = ', trim(lcfourier)
          call fits_write_comment(fits,com,status)
       end if
       if( lctable /= '' ) then
          write(com,'(2a)') 'Spline interpolation table = ', trim(lctable)
          call fits_write_comment(fits,com,status)
       end if
       write(com,'(a,f0.3)') "Light curve current magnitude = ",ccmag
       call fits_write_comment(fits,com,status)
       write(com,'(a,2(f0.3,1x))') &
            "Light curve mean magnitude, amplitude = ",lcmag,lcamp
       call fits_write_comment(fits,com,status)
       write(com,'(a,2(f0.6,1x),a)') &
            "Light curve elements (JD0, period) = ",lcjd0,lcper," [day(s)]"
       call fits_write_comment(fits,com,status)
       write(com,'(a,2(f0.5,1x),a)') &
            "Light curve object coordinates = ",lcoo," [deg]"
       call fits_write_comment(fits,com,status)
    end if
    call fits_write_comment(fits,MUNIPACK_VERSION,status)
    call fits_write_image(fits,0,real(sky),status)

    ! PSF extension
    call fits_insert_img(fits,-32,2,[size(psf%psf,1),size(psf%psf,2)],status)
    call fits_update_key(fits,'EXTNAME','PSF','',status)
    call fits_update_key(fits,'ZOOM',psf%zoom,'zoom',status)
    call fits_write_image(fits,0,real(psf%psf),status)

    ! Star table extension
    block
      character(len=FLEN_VALUE), dimension(3) :: ttype, tform, tunit
      integer :: nrows, srows, i, l, frow

      nrows = size(xstar)
      ttype(1) = FITS_COL_X
      ttype(2) = FITS_COL_Y
      ttype(3) = FITS_COL_COUNT
      tform  = '1E'
      tunit = ''
      call fits_insert_btbl(fits,nrows,ttype,tform,tunit,'CATALOGUE',status)

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

         call fits_write_col(fits,1,frow,xstar(i:l),status)
         call fits_write_col(fits,2,frow,ystar(i:l),status)
         call fits_write_col(fits,3,frow,fluxes(i:l),status)
      end do
    end block

666 continue

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

    ! cleanup
    if( allocated(xvar) ) deallocate(xvar,yvar,fvar)
    deallocate(xstar,ystar,fluxes)
    deallocate(sky)

  end subroutine artfits


  subroutine lctable_init(tablename, lcspline)

    use lcio

    character(len=*), intent(in) :: tablename
    class(SplineSerieType), intent(out) :: lcspline

    real(dbl), dimension(:), allocatable :: time, flux, dflux
    real(dbl), parameter :: sopt = -1

    call lcimport(tablename,time,flux,dflux)

    call lcspline%Init(time,flux,dflux,sopt)
    deallocate(time,flux,dflux)

  end subroutine lctable_init

  function magconv(phsystable,phsystem,filter,ph)

    use phsysfits
    use photoconv

    real(dbl) :: magconv
    character(len=*), intent(in) :: filter, phsystable, phsystem
    real(dbl), dimension(:), intent(in) :: ph
    type(type_phsys) :: phsys
    real(dbl), dimension(size(ph)) :: mag,dmag,dph

    call phselect(phsystable,phsystem,phsys)
    dph = -1
    call phsysphmag1(phsys,filter,ph,dph,mag,dmag)
    magconv = mag(1)

  end function magconv

  function magiconv(phsystable,phsystem,filter,mag)

    use phsysfits
    use photoconv

    real(dbl) :: magiconv
    character(len=*), intent(in) :: filter, phsystable, phsystem
    real(dbl), dimension(:), intent(in) :: mag
    type(type_phsys) :: phsys
    real(dbl), dimension(size(mag)) :: ph,dph,dmag

    call phselect(phsystable,phsystem,phsys)
    dmag = 9.999
    call phsysmagph1(phsys,filter,mag,dmag,ph,dph)
    magiconv = ph(1)

  end function magiconv

end program artificial
