!
! color transformation
!
!
! Copyright © 2010-3 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 color_transformation

  implicit none

contains

  subroutine ctrafo(fname,cname,backup,cspace,ctable,black,slope)

    use fitsio

    integer, parameter :: naxis = 3
    integer, parameter :: bitpix = -32
    real, parameter :: minvalue = -huge(1.0)

    character(len=*),intent(in) :: fname,cname,backup,ctable,cspace
    real, dimension(:), intent(in) :: black,slope

    integer,dimension(naxis) :: naxes
    real,dimension(:,:,:),allocatable :: cube,xcube
    real, dimension(:,:),allocatable :: cmatrix
    character(len=80),dimension(:),allocatable :: head

    integer :: i,j,n,ndim,mstat, mdim, nbands, ncolors, width, height, &
         nhead, status, bpix, pcount,gcount, keylen
    logical :: simple,extend,anyf
    character(len=80) :: buf,com,ilabel,olabel,icspace,keyname

    nbands = 0
    ncolors = 0
    width = 0
    height = 0
    status = 0

    call ftnopn(25,fname,0,status)
    if( status /= 0 ) goto 666

    call ftghpr(25,naxis,simple,bpix,n,naxes,pcount,gcount,extend,status)
    if( status /= 0 ) goto 666
    if( n /= naxis ) stop 'Only two dimensional color images (NAXIS=3) are supported.'

    width = naxes(1)
    height = naxes(2)
    nbands = naxes(3)

    if( nbands /= size(black) .or. nbands /= size(slope) ) &
         stop 'Color layers count does not corresponds to black,slope switches.'

    call ftghps(25,nhead,n,status)
    allocate(head(nhead),stat=mstat)
    if( mstat /= 0 ) stop 'Not enough memory for your head.'
    do n = 1, nhead
       call ftgrec(25,n,head(n),status)
    enddo

    call ftgkys(25,FITS_KEY_CSPACE,icspace,buf,status)
    if( status /= 0 ) stop 'Colorspace of input not specified.'

    allocate(cube(width,height,nbands),stat=mstat)
    if( mstat /= 0 ) stop 'Not enough memory.'

    call ftg3de(25,1,minvalue,width,height,width,height,nbands,cube,anyf,status)

    if( status /= 0 ) goto 666

    call ftclos(25,status)


    ! grep color transformation table
    open(1,file=ctable,status='old',iostat=status)
    if( status /= 0 ) stop 'A color table file not found.'

    do
       read(1,*,err=99,end=90) ilabel, olabel
       read(1,*,err=99,end=90) ndim, mdim
       allocate(cmatrix(ndim,mdim))
       read(1,*,err=99,end=90) cmatrix

       if( ilabel == icspace .and. cspace == olabel ) goto 90
       deallocate(cmatrix)
    end do

99  stop 'A color table file read error.'
90  continue
    close(1)

    if( .not. allocated(cmatrix) ) stop 'Required colospaces not found in the table.'
    ncolors = ndim


    ! scale data (only for XYZ)
    if( minval(slope) > 0.0 ) then
       forall(i=1:3)
          cube(:,:,i) = (cube(:,:,i) - black(i))*slope(i)
       end forall
    end if

    ! ???
    where( cube < 0.0 )
       cube = 0.0
    end where


    allocate(xcube(width,height,ncolors))

    ! the transformation
    forall(i=1:width,j=1:height)
       xcube(i,j,:) = matmul(cmatrix,cube(i,j,:))
    end forall

    ! cutoff negative values ??
    where( xcube < 0.0 )
       xcube = 0.0
    end where


    ! write out FITS color
    call fitsbackup(cname,backup,status)
    call ftinit(26,cname,1,status)

    call ftiimg(26,bitpix,naxis,naxes,status)
    call ftukys(26,FITS_KEY_CSPACE,cspace,'the color space for the stored data',status)

    call ftpcom(26,'The matrix of color transformation:',status)
    do i = 1,ncolors
       write(buf,*) cmatrix(i,:)
       call ftpcom(26,buf,status)
    end do

    call ftpcom(26,'Original filename: '//trim(fname),status)

    do n = 1, nhead
       call ftgknm(head(n),keyname,keylen,status)
       call ftgkys(26,keyname,buf,com,status)
       if( buf == '' ) then
          call ftprec(26,head(n),status)
       end if
       status = 0
    end do

    call ftukys(26,'CREATOR','Munipack','Created by color transform utility of Munipack',status)

    call ftp3de(26,1,width,height,width,height,nbands,xcube,status)

    if( status == 412 ) status = 0 ! numerical overflow during implicit datatype conversion

    call ftclos(26,status)


666 continue

    if( allocated(cube) ) deallocate(cube)
    if( allocated(xcube) ) deallocate(xcube)

    call ftrprt('STDERR',status)

  end subroutine ctrafo

end module color_transformation
