!# This source file is part of code Pégase.3.0.1 (2019-02-21).
!# Copyright: Michel Fioc (Michel.Fioc@iap.fr), Sorbonne université, 
!# Institut d'astrophysique de Paris/CNRS, France.
!# 
!# Pégase.3.0.1 is governed by the CeCILL license under French law and abides 
!# by the rules of distribution of free software. You can use, modify and/or 
!# redistribute this software under the terms of the CeCILL license as circulated 
!# by CEA, CNRS and INRIA at "http://www.cecill.info". The text of this license
!# is also available in French and in English in directory "doc_dir/" of this
!# code.
!# 
!# As a counterpart to the access to the source code and to the rights to copy,
!# modify and redistribute it granted by the license, users are provided only
!# with a limited warranty, and the software's author, the holder of the
!# economic rights, and the successive licensors have only limited
!# liability. 
!# 
!# The fact that you are presently reading this means that you have had
!# knowledge of the CeCILL license and that you accept its terms.
!#====================================================================== 

module mod_filters

  use mod_types

  implicit none
  private

  type :: struct_filter
     character(std_string) :: file, id, trans_type, calib_type
     integer :: power
     real(DPR) :: lambda_nom
     real(DPR) :: ZPO !# zero point offset. !!! Not used currently.
     integer :: dim_lambda
     real(DPR), dimension(:), pointer :: lambda => null(), trans => null()
  end type struct_filter

  public :: struct_filter, read_filters, flux_band

contains

!#======================================================================

  subroutine read_filters(filters_list, dim_filter, filter)

    use mod_linked_list
    use mod_file_access, only : open_file, skip_comment_lines, skip_lines, &
         close_file, path_file
    use mod_directories, only : calib_dir
    use mod_heap_index, only : heap_index
    use mod_filters_constants, only : filter_min_resol
    implicit none
    character(len=*), intent(in) :: filters_list
    integer, intent(out) :: dim_filter
    type(struct_filter), dimension(:), pointer :: filter
!#......................................................................
    integer :: unit_list, unit_filter, i_filter, error, dim_lambda
    character(std_string) :: filter_file
    character(long_string) :: line
    real(DPR) :: lambda, trans
    type(lk_lst_std_string) :: head_node
    type(lk_lst_std_string), pointer :: current_node, next_node
    type(lk_lst_DPR) :: head_node_lambda, head_node_trans
    type(lk_lst_DPR), pointer :: current_node_lambda, current_node_trans
    logical :: exist
    integer :: i_supp, n_supp
    integer :: pos
    real(DPR) :: lambda_prev, trans_prev
    integer, dimension(:), allocatable :: idx
!#::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::

    call open_file(unit_list, filters_list, exist = exist)
    dim_filter = 0
    call lk_lst_initialize(head_node)
    do
       read(unit_list, *, iostat = error) filter_file
       if (error /= 0 .or. filter_file == "") exit
       dim_filter = dim_filter+1
       call lk_lst_new_node(head_node, current_node)
       current_node % val = adjustl(filter_file)
    enddo
    call close_file(unit_list)

    if (associated(filter)) then
       do i_filter = 1, size(filter)
          if (associated(filter(i_filter) % lambda)) deallocate(filter(i_filter) % lambda)
          if (associated(filter(i_filter) % trans)) deallocate(filter(i_filter) % trans)
       enddo
       deallocate(filter)
    endif
    allocate(filter(dim_filter))

    current_node => head_node % ptr
    do i_filter = 1, dim_filter
       next_node => current_node % ptr
       filter_file = current_node % val
       filter(i_filter) % file = filter_file
       deallocate(current_node)
       current_node => next_node
    end do

    allocate(idx(dim_filter))
!# Check that the same file of filter is not more than once in the list of filters.
    call heap_index(filter(:) % file, idx)
    do i_filter = 1, dim_filter-1
       if (filter(idx(i_filter)) % file == filter(idx(i_filter+1)) % file) then
          write(*, "(a)") "The file of filter """ // &
               trim(filter(idx(i_filter)) % file) // &
               """ appears more than once in """ // trim(filters_list) // &
               """. Stopped."
          stop
       endif
    enddo

    do i_filter = 1, dim_filter
       call open_file(unit_filter, path_file(calib_dir, filter(i_filter) % file), &
            exist = exist)
       read(unit_filter, *) filter(i_filter) % id
       read(unit_filter, *) filter(i_filter) % trans_type
       read(unit_filter, "(a)") line
       line = adjustl(line)
       read(line, *) filter(i_filter) % calib_type

       if (line(1:1) == '"') then
          line = line(2:)
          pos = index(line, '"')
       else if (line(1:1) == "'") then
          line = line(2:)
          pos = index(line, "'")
       else !# No quote character.
          pos = index(line, " ")
       endif
       line = adjustl(line(pos+1:))
       if (filter(i_filter) % calib_type == "Vega") then
          if (line == "") then !# `ZPO` is optional.
             filter(i_filter) % ZPO = 0
          else
             read(line, *, iostat=error) filter(i_filter) % ZPO
             if (error /= 0) then
                write(*, "(a)") "Filter """ // trim(filter(i_filter) % id) // &
                     """: `ZPO` cannot be read. Stopped."
                stop
             endif
          endif
       else if (filter(i_filter) % calib_type == "IRAS") then
          read(line, *, iostat=error) filter(i_filter) % lambda_nom
          if (error /= 0) then
             write(*, "(a)") "Filter """ // trim(filter(i_filter) % id) // &
                  """: `lambda_nom` cannot be read. Stopped."
             stop
          endif
       else if (.not.any(filter(i_filter) % calib_type == (/"AB   ", "TG   ", "HST  ", "FOCA ", "D4000"/))) then
          write(*, "(a)") "Filter """ // trim(filter(i_filter) % id) // &
               """: type of calibration """ // &
               trim(filter(i_filter) % calib_type) // """ is not defined. Stopped."
          stop
       endif

       if (filter(i_filter) % trans_type == "energy") then
          filter(i_filter) % power = 0
       else if (filter(i_filter) % trans_type == "nb_phot") then
          filter(i_filter) % power = 1
       else
          write(*, "(a)") "Filter """ // trim(filter(i_filter) % id) // &
               """: type of transmission """ // &
               trim(filter(i_filter) % trans_type) // """ is not defined. Stopped."
          stop
       end if

       dim_lambda = 0
       call lk_lst_initialize(head_node_lambda)
       call lk_lst_initialize(head_node_trans)
       do
          read(unit_filter, *, iostat = error) lambda, trans
          if (error /= 0) exit
          dim_lambda = dim_lambda+1

          if (dim_lambda > 1) then
             n_supp = floor(filter_min_resol*(lambda-lambda_prev)/lambda_prev)
             do i_supp = 1, n_supp
                dim_lambda = dim_lambda+1
                call lk_lst_new_node(head_node_lambda, current_node_lambda)
                call lk_lst_new_node(head_node_trans, current_node_trans)
                current_node_lambda % val = lambda_prev + (lambda-lambda_prev)*i_supp/n_supp
                current_node_trans % val = trans_prev + (trans-trans_prev)*i_supp/n_supp
             enddo
          endif

          call lk_lst_new_node(head_node_lambda, current_node_lambda)
          call lk_lst_new_node(head_node_trans, current_node_trans)
          current_node_lambda % val = lambda
          current_node_trans % val = trans

          lambda_prev = lambda
          trans_prev = trans
       end do
       call close_file(unit_filter)

       filter(i_filter) % dim_lambda = dim_lambda
       call lk_lst_to_array(head_node_lambda, filter(i_filter) % lambda, dim_lambda)
       call lk_lst_to_array(head_node_trans, filter(i_filter) % trans, dim_lambda)
    end do
    call lk_lst_destroy(head_node_lambda)
    call lk_lst_destroy(head_node_trans)

!# Check that the same identifier is not used for two filters or more.
    call heap_index(filter(:) % id, idx)
    do i_filter = 1, dim_filter-1
       if (filter(idx(i_filter)) % id == filter(idx(i_filter+1)) % id) then
          write(*, "(a)") "The files of filter """ // &
               trim(path_file(calib_dir, filter(idx(i_filter)) % file)) // &
               """ and """ // &
               trim(path_file(calib_dir, filter(idx(i_filter+1)) % file)) // &
               """ share the same identifier, """ // &
               trim(filter(idx(i_filter)) % id) // &
               """. Change the identifier in one of these files. Stopped."
          stop
       endif
    enddo
    deallocate(idx)

  end subroutine read_filters

!#======================================================================

  function flux_band(filter, dim_lambda_cont, lambda_cont, lum_cont, &
       dim_line, lambda_line, L_line)

    use mod_types
    use mod_interp, only : interp_lin_lin, interp_log_log

    implicit none
    real(DPR) :: flux_band
    type(struct_filter), intent(in) :: filter
    integer, intent(in) :: dim_lambda_cont
    real(DPR), dimension(:), intent(in) :: lambda_cont, lum_cont
    integer, intent(in), optional :: dim_line
    real(DPR), dimension(:), intent(in), optional :: lambda_line, L_line
!#......................................................................
    integer :: i_lambda, i_cont, i_line
    real(DPR) :: lambda_inf, lambda_sup, trans_line
    real(DPR) :: lum_inf, lum_sup, trans_inf, trans_sup
!#::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::

    flux_band = 0
    if ((lambda_cont(1) <= filter % lambda(1)) .and. &
         (lambda_cont(dim_lambda_cont) >= filter % lambda(filter % dim_lambda))) then
       i_cont = 1
       do while(lambda_cont(i_cont+1) < filter % lambda(1))
          i_cont = i_cont+1
       enddo
       i_lambda = 1
       lambda_inf = filter % lambda(i_lambda)
       trans_inf = 0
       lum_inf = 0
       lambda_sup = lambda_inf
       do while(i_lambda+1 <= filter % dim_lambda .and. i_cont+1 <= dim_lambda_cont)
          if (filter % lambda(i_lambda+1) < lambda_cont(i_cont+1)) then
             lambda_sup = filter % lambda(i_lambda+1)
             lum_sup = interp_log_log(lambda_cont(i_cont), lambda_cont(i_cont+1), &
                  lum_cont(i_cont), lum_cont(i_cont+1), lambda_sup)
             trans_sup = filter % trans(i_lambda+1)*lambda_sup**filter % power
             i_lambda = i_lambda+1
          else
             lambda_sup = lambda_cont(i_cont+1)
             lum_sup = lum_cont(i_cont+1)
             trans_sup = interp_lin_lin(filter % lambda(i_lambda), filter % lambda(i_lambda+1), &
                  filter % trans(i_lambda), filter % trans(i_lambda+1), lambda_sup) &
                  * lambda_sup**filter % power
             i_cont = i_cont+1
          endif

          flux_band = flux_band+(trans_inf*lum_inf+trans_sup*lum_sup) &
               *(lambda_sup - lambda_inf)/2

          lambda_inf = lambda_sup
          lum_inf = lum_sup
          trans_inf = trans_sup
       enddo
    endif

    if (present(dim_line)) then
       do i_line = 1, dim_line
          i_lambda = 1
          if ((lambda_line(i_line) > filter % lambda(1)) .and. &
               (lambda_line(i_line) < filter % lambda(filter % dim_lambda))) then
             do while (.not.((lambda_line(i_line) >= filter % lambda(i_lambda)) .and. &
                  (lambda_line(i_line) < filter % lambda(i_lambda+1))))
                i_lambda = i_lambda+1
             end do

             trans_line = interp_lin_lin(filter % lambda(i_lambda), filter % lambda(i_lambda+1), &
                  filter % trans(i_lambda), filter % trans(i_lambda+1), lambda_line(i_line)) &
                  * lambda_line(i_line)**filter % power

             flux_band = flux_band + trans_line*L_line(i_line)
          end if
       end do
    endif

  end function flux_band

end module mod_filters
