!# 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.
!#====================================================================== 

!# References:
!# DL2001 = Draine & Li (2001), ApJ 551, 807;
!# LD2001 = Li & Draine (2001), ApJ 554, 778.

module mod_dust_emission

  use mod_types
  use mod_read_output_param, only : grain_temp_output, grain_SED_output
  private

  type :: struct_grain
     real(CDR) :: sublim_temp
     integer :: dim_temp
     real(CDR), dimension(:), pointer :: temp => null()
     real(CDR), dimension(:), pointer :: grain_energ0 => null()
     real(CDR), dimension(:,:), pointer :: bol_lum => null()
  end type struct_grain
  
  public :: struct_grain

  integer, public :: unit_grain_temp, unit_grain_SED
  logical, public :: do_output_grain
  public :: temp_grid, compute_grain_bol_lum, compute_grain_energ, compute_dust_emission, read_Debye

contains

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

  subroutine temp_grid(dim_temp, temp, T_min, T_max)

    use mod_types
    use mod_spectra_constants, only : T_min_def, T_max_def

    implicit none
    integer, intent(in) :: dim_temp
    real(CDR), intent(in), optional :: T_min, T_max
    real(CDR), dimension(:), pointer :: temp
!#......................................................................
    real(CDR) :: temp_min, temp_max, alpha
    integer :: i_temp
!#::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::

    if (associated(temp)) deallocate(temp)
    allocate(temp(dim_temp))

    if (present(T_min)) then
       temp_min = T_min
    else
       temp_min = T_min_def
    endif
    if (present(T_max)) then
       temp_max = T_max
    else
       temp_max = T_max_def
    endif

    alpha = (temp_max/temp_min)**(1._CDR/(dim_temp-1))
    
    temp(1) = temp_min
    do i_temp = 2, dim_temp
       temp(i_temp) = temp(i_temp-1)*alpha
    enddo

  end subroutine temp_grid

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

  subroutine temp_grid2(dim_temp2, temp2, &
       T_min, T_max, dim_temp, T_interm, lum_frac)

    use mod_types
    use mod_linked_list
    implicit none
    integer, intent(out) :: dim_temp2
    real(CDR), dimension(:), pointer :: temp2
    real(CDR), intent(in) :: T_min, T_max
    integer, intent(in) :: dim_temp
    real(CDR), dimension(:), intent(in) :: T_interm, lum_frac
!#......................................................................
    integer :: i_sub, i_temp
    real(CDR) :: l10_T_bot, l10_T_top
    real(CDR), parameter :: max_delta_l10_T = 0.05_CDR, &
         max_bin_P = 0.05_CDR, min_delta_l10_T = 0.02_CDR
    type(lk_lst_CDR) :: head_node
    type(lk_lst_CDR), pointer :: current_node => null(), &
         next_node => null()
    integer :: n_sub
!#::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::

!# Subdivide the temperature grid.
    call lk_lst_initialize(head_node)
    dim_temp2 = 0
    do i_temp = 1, dim_temp
       if (T_interm(i_temp+1) < T_min) cycle
       if (T_interm(i_temp) > T_max) exit
       l10_T_bot = log10(max(T_interm(i_temp), T_min))
       l10_T_top = log10(min(T_interm(i_temp+1), T_max))
       n_sub = ceiling( max( &
            (l10_T_top-l10_T_bot)/max_delta_l10_T, &
            lum_frac(i_temp)/max_bin_P) )
       
       dim_temp2 = dim_temp2 + n_sub
       do i_sub = 1, n_sub
          call lk_lst_new_node(head_node, current_node)
          current_node % val = 10**(l10_T_bot + &
               (i_sub-0.5_CDR)/n_sub*(l10_T_top-l10_T_bot))
       enddo
    enddo

!# Merge consecutive temperature nodes if too close.
    current_node => head_node % ptr
    do
       if (associated(current_node)) then
          next_node => current_node % ptr
          if (associated(next_node)) then
             if (log10(next_node % val/current_node % val) &
                  < min_delta_l10_T) then
                current_node % val = &
                     sqrt(current_node % val * next_node % val)
!# Remove next node: {
!# ??? Shouldn't the deleted node be deallocated?
                next_node => next_node % ptr
                deallocate(current_node % ptr)
                current_node % ptr => next_node
!# }
                dim_temp2 = dim_temp2 - 1
             endif
             current_node => next_node
          else
             exit
          endif
       else
          exit
       endif
    enddo

    call lk_lst_to_array(head_node, temp2, dim_temp2)

  end subroutine temp_grid2

!#======================================================================
  
  subroutine compute_dust_emission(carb_abund, sil_abund, &
       dim_cont, lambda_cont, grain_data, M_dust, &
       RF, lum_species, &
       dim_species, species_id, grain_density, grain_mean_atomic_mass, &
       species_weight, grain_abs, stoch_heating, &
       self_abs_power, cont_trans_tot, cont_trans_incl, sublim_lum_species)
  
    use mod_types
    use mod_interp, only : interp_log_log, bracket
    use mod_grain_properties, only : struct_grain_abs
    
    implicit none
    real(CDR), intent(in) :: carb_abund, sil_abund
    integer, intent(in) :: dim_cont, dim_species
    real(CDR), dimension(:), intent(in) :: lambda_cont
    type(struct_grain), dimension(:), intent(in) :: grain_data
    real(CDR), intent(in) :: M_dust
    type(irreg_array_CDR), dimension(:), intent(in) :: RF
    real(CDR), dimension(:,:), intent(out) :: lum_species
    character(len=*), dimension(:), intent(in) :: species_id
    real(CDR), dimension(:), intent(in) :: grain_density, grain_mean_atomic_mass
    type(struct_grain_abs), dimension(:), intent(in) :: grain_abs
    real(CDR), dimension(:), intent(in) :: species_weight
    logical, intent(in) :: stoch_heating
    real(CDR), intent(in), optional :: self_abs_power
    real(CDR), dimension(:), intent(in), optional :: cont_trans_tot, &
         cont_trans_incl
    real(CDR), dimension(:,:), intent(out), optional :: sublim_lum_species
!#......................................................................
    integer :: i_species
    type(irreg_array_CDR), dimension(:), allocatable :: lum_species_orig, &
         sublim_lum_species_orig
    integer :: i_bracket, i_cont
    real(CDR) :: int_num, int_den, ratio
!#::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
    
    if (allocated(lum_species_orig)) then
       do i_species = 1, dim_species
          if (associated(lum_species_orig(i_species) % val)) deallocate(lum_species_orig(i_species) % val)
       enddo
       deallocate(lum_species_orig)
    endif
    allocate(lum_species_orig(dim_species))
    do i_species = 1, dim_species
       allocate(lum_species_orig(i_species) % val(grain_abs(i_species) % dim_lambda))
    enddo

    if (allocated(sublim_lum_species_orig)) then
       do i_species = 1, dim_species
          if (associated(sublim_lum_species_orig(i_species) % val)) deallocate(sublim_lum_species_orig(i_species) % val)
       enddo
       deallocate(sublim_lum_species_orig)
    endif
    allocate(sublim_lum_species_orig(dim_species))
    do i_species = 1, dim_species
       allocate(sublim_lum_species_orig(i_species) % val(grain_abs(i_species) % dim_lambda))
    enddo
    
    if (present(self_abs_power)) then
       if (self_abs_power > 0 .and. .not.(present(cont_trans_tot) .and. &
            present(cont_trans_incl))) then
          write(*, "(a)") "Subroutine `compute_dust_emission`: optional &
               &`cont_trans_tot` and `cont_trans_incl` must be present if &
               &`self_abs_power` is present and > 0. Stopped."
          stop
       endif
    endif

    do i_species = 1, dim_species
       lum_species_orig(i_species) % val = 0
       sublim_lum_species_orig(i_species) % val = 0
    enddo
    lum_species = 0
    if (present(sublim_lum_species)) sublim_lum_species = 0

    if (carb_abund > 0 .or. sil_abund > 0) then
       if (do_output_grain) then
          if (grain_temp_output) write(unit_grain_temp, "(i0)") dim_species
          if (grain_SED_output)  write(unit_grain_SED, "(i0)") dim_species
       endif
       do i_species = 1, dim_species
          if (any(RF(i_species) % val(:) > 0)) then
             call compute_lum_species(grain_abs(i_species) % dim_radius, &
                  grain_abs(i_species) % radius(:), species_id(i_species), grain_density(i_species), &
                  grain_mean_atomic_mass(i_species), &
                  grain_data(i_species) % bol_lum(:,:), grain_abs(i_species) % Q_abs(:,:), &
                  grain_data(i_species) % grain_energ0(:), grain_abs(i_species) % dim_lambda, &
                  grain_abs(i_species) % lambda(:), &
                  grain_abs(i_species) % lambda_interm(:), &
                  RF(i_species) % val(:), grain_data(i_species) % temp, &
                  grain_abs(i_species) % d_S_grain(:), lum_species_orig(i_species) % val(:), &
                  stoch_heating, &
                  grain_data(i_species) % sublim_temp, sublim_lum_species_orig(i_species) % val(:))

          endif
       enddo

       do i_species = 1, dim_species
          lum_species_orig(i_species) % val(:) = M_dust*species_weight(i_species) * &
               lum_species_orig(i_species) % val(:)
          sublim_lum_species_orig(i_species) % val(:) = M_dust*species_weight(i_species) * &
               sublim_lum_species_orig(i_species) % val(:)
       enddo

!# Rebin `lum_species_orig` from `lambda_grains` to `lambda_cont` -> `lum_species`.

       do i_species = 1, dim_species
          i_bracket = 0
          do i_cont = 1, dim_cont
             call bracket(grain_abs(i_species) % dim_lambda, grain_abs(i_species) % lambda(:), &
                  lambda_cont(i_cont), i_bracket)
             lum_species(i_species, i_cont) = interp_log_log(grain_abs(i_species) % lambda(i_bracket), &
                  grain_abs(i_species) % lambda(i_bracket+1), lum_species_orig(i_species) % val(i_bracket), &
                  lum_species_orig(i_species) % val(i_bracket+1), lambda_cont(i_cont))
             if (present(sublim_lum_species)) &
                  sublim_lum_species(i_species, i_cont) = interp_log_log(grain_abs(i_species) % lambda(i_bracket), &
                  grain_abs(i_species) % lambda(i_bracket+1), sublim_lum_species_orig(i_species) % val(i_bracket), &
                  sublim_lum_species_orig(i_species) % val(i_bracket+1), lambda_cont(i_cont))
          enddo
       enddo

!# Self-absorption.

       if (present(self_abs_power)) then
          if (self_abs_power > 0) then
             int_num = 0
             int_den = 0
             do i_cont = 1, dim_cont-1
                int_num = int_num+(lambda_cont(i_cont+1)-lambda_cont(i_cont)) &
                     *sum(lum_species(1:dim_species, i_cont:i_cont+1))/2
                int_den = int_den+(lambda_cont(i_cont+1)-lambda_cont(i_cont)) &
                     *(cont_trans_tot(i_cont)**self_abs_power &
                     *sum(lum_species(1:dim_species, i_cont)) &
                     + cont_trans_tot(i_cont+1)**self_abs_power &
                     *sum(lum_species(1:dim_species, i_cont+1)))/2
             enddo
             
             if (int_num /= 0 .and. int_den /= 0) then
                ratio = int_num/int_den
                do i_cont = 1, dim_cont
                   lum_species(1:dim_species, i_cont) = lum_species(1:dim_species, i_cont) * &
                        cont_trans_incl(i_cont)**self_abs_power * ratio
                   if (present(sublim_lum_species)) &
                        sublim_lum_species(1:dim_species, i_cont) = sublim_lum_species(1:dim_species, i_cont) * &
                        cont_trans_incl(i_cont)**self_abs_power * ratio
                enddo
             endif
          endif
       endif
    else
       if (do_output_grain) then
          if (grain_temp_output) write(unit_grain_temp, "(i0)") 0
          if (grain_SED_output) write(unit_grain_SED, "(i0)") 0
       end if
    endif

  end subroutine compute_dust_emission

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

  subroutine compute_lum_species(dim_radius, radius, species_id, grain_density, &
       grain_mean_atomic_mass, grain_bol_lum, Q_abs, &
       grain_energ0, dim_lambda_grains, lambda_grains, &
       lambda_grains_interm, &
       RF, temp, d_S_grain, &
       lum_species_orig, stoch_heating, sublim_temp, sublim_lum_species_orig)

    use mod_types
    use mod_interp,  only : bracket, interp_log_log
    use mod_loc, only : min_loc, max_loc
    use mod_constants, only : in_um_to_in_cm, pi, H_atom_mass
    use mod_read_output_param, only : grain_output_min_size, grain_output_max_size

    implicit none
    integer, intent(in) :: dim_radius, dim_lambda_grains
    real(CDR), dimension(:), intent(in) :: radius, lambda_grains, &
         RF, temp
    real(DPR), dimension(:), intent(in) :: lambda_grains_interm
    real(CDR), intent(in) :: grain_density, grain_mean_atomic_mass
    character(len=*), intent(in) :: species_id
    real(CDR), dimension(:, :), intent(in) :: grain_bol_lum, Q_abs
    real(CDR), dimension(:), intent(out) :: lum_species_orig
    real(CDR), dimension(:), intent(in) :: grain_energ0, d_S_grain
    logical, intent(in) :: stoch_heating
    real(CDR), intent(in), optional :: sublim_temp
    real(CDR), dimension(:), intent(out), optional :: sublim_lum_species_orig
!#......................................................................
    integer :: dim_temp
    integer :: i_radius
    real(CDR) :: r_cm, area, volume, nb_atoms
    real(CDR), dimension(dim_radius, dim_lambda_grains) :: grain_X_lambda, grain_X_lambda_eq, &
         sublim_grain_X_lambda
    real(CDR) :: temp_eq
    real(CDR), dimension(:), pointer :: T_interm => null(), U_interm => null(), &
         T_interm2 => null(), U_interm2 => null() !# ??? Use rather `nullify` in the executable part, otherwise it is `save`d?
    real(DPR), dimension(:), pointer :: lum_cumul_frac => null()
    real(CDR), dimension(:), pointer :: lum2 => null(), &
         temp2 => null(), &
         lum_frac => null()
    real(CDR), dimension(:), pointer :: prob => null()
    real(CDR), dimension(:), pointer :: grain_energ2 => null()

    integer :: i_radius_min, i_radius_max, dim_temp2
    real(DPR), dimension(dim_lambda_grains+1) :: integral_wqu, h_c_integral_qu
    real(DPR), dimension(dim_lambda_grains) :: q_u_over_2, h_c_q_u
    integer :: i_temp
    real(CDR) :: total_heat_rate
    integer :: i_bracket, dim_temp2_prev
    real(CDR) :: T_min, T_max, temp_eq_prev, T_min_prev, T_max_prev
    real(CDR), parameter :: lum_cumul_frac_min = 1.e-8_DPR, &
         lum_cumul_frac_max = 1-lum_cumul_frac_min
    integer :: dim_output_grain_radius
!#::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
    
    dim_temp = size(temp)

!# No need to initialize `grain_X_lambda` and `grain_X_lambda_eq` because `integrate_over_size`
!# sums them only from `i_radius_min` to `i_radius_max`.
!~    grain_X_lambda(:,:) = 0 
!~    grain_X_lambda_eq(:,:) = 0
    
    i_radius_min = 1
    do
       if (i_radius_min >= dim_radius) exit
       if (d_S_grain(i_radius_min) > 0) exit
       i_radius_min = i_radius_min+1
    enddo
    i_radius_max = dim_radius
    do
       if (i_radius_max <= 1) exit
       if (d_S_grain(i_radius_max) > 0) exit
       i_radius_max = i_radius_max-1
    enddo

    dim_output_grain_radius = &
         count(radius(i_radius_min:i_radius_max) >= grain_output_min_size &
         .and. radius(i_radius_min:i_radius_max) <= grain_output_max_size)
    if (do_output_grain) then
       if (grain_temp_output) then
          write(unit_grain_temp, "(i0)") dim_output_grain_radius
       endif
       if (grain_SED_output) &
            write(unit_grain_SED, "(i0)") dim_output_grain_radius
    end if
    do i_radius = i_radius_min, i_radius_max
       r_cm = radius(i_radius) * in_um_to_in_cm
       area = 4*pi*r_cm**2
       volume = area*r_cm/3
       nb_atoms = grain_density*volume/(grain_mean_atomic_mass*H_atom_mass)

       call compute_integrals_temp_eq(dim_lambda_grains, lambda_grains_interm, &
            Q_abs(i_radius, :), RF, grain_bol_lum(i_radius, :), &
            temp, radius(i_radius), h_c_integral_qu, &
            integral_wqu, h_c_q_u, q_u_over_2, total_heat_rate, temp_eq)

!#//////////////////////////////////////////////////////////////////////
!# Smallest grain for the grain species considered.

       if (i_radius == i_radius_min) then
          if (stoch_heating) then

!# Use first a regular grid of temperatures to compute the approximate probability distribution
!# of temperatures.
             
             call U_grid(species_id, nb_atoms, dim_temp, temp, grain_energ0(:), &
                  T_interm, U_interm)
             
             call GD(dim_lambda_grains, radius(i_radius), grain_bol_lum(i_radius, :), &
                  dim_temp, U_interm, prob, &
                  lambda_grains_interm, integral_wqu, h_c_q_u, q_u_over_2, &
                  h_c_integral_qu, total_heat_rate)

!# Create a refined grid of temperatures to compute the final probability distribution
!# of temperatures, with a higher resolution at most likely temperatures.

             if (associated(lum_cumul_frac)) deallocate(lum_cumul_frac)
             allocate(lum_cumul_frac(dim_temp+1))
             if (associated(lum_frac)) deallocate(lum_frac)
             allocate(lum_frac(dim_temp))

             lum_cumul_frac(1) = 0
             do i_temp = 2, dim_temp+1
                lum_cumul_frac(i_temp) = lum_cumul_frac(i_temp-1) + prob(i_temp-1)*grain_bol_lum(i_radius, i_temp-1)
             enddo
             do i_temp = 1, dim_temp
                lum_frac(i_temp) = prob(i_temp)*grain_bol_lum(i_radius, i_temp)
             enddo
             lum_frac(1:dim_temp) = lum_frac(1:dim_temp)/lum_cumul_frac(dim_temp+1) !# Do not move this line \
!#                                                                                     after next one!
             lum_cumul_frac(1:dim_temp+1) = lum_cumul_frac(1:dim_temp+1)/lum_cumul_frac(dim_temp+1)
             T_min = T_interm(max_loc(lum_cumul_frac(1:dim_temp+1), &
                  mask = lum_cumul_frac(1:dim_temp+1) < lum_cumul_frac_min, &
                  default = 1))
             T_max = T_interm(min_loc(lum_cumul_frac(1:dim_temp+1), &
                  mask = lum_cumul_frac(1:dim_temp+1) > lum_cumul_frac_max, &
                  default = dim_temp+1))

             call temp_grid2(dim_temp2, temp2, &
                  T_min, T_max, dim_temp, T_interm, lum_frac)
             if (associated(lum2)) deallocate(lum2)
             allocate(lum2(dim_temp2))
             if (associated(grain_energ2)) deallocate(grain_energ2)
             allocate(grain_energ2(dim_temp2))

             i_bracket = 0
             do i_temp = 1, dim_temp2
                call bracket(dim_temp, temp, temp2(i_temp), i_bracket)
                lum2(i_temp) = interp_log_log(temp(i_bracket), temp(i_bracket+1), grain_bol_lum(i_radius, i_bracket), &
                     grain_bol_lum(i_radius, i_bracket+1), temp2(i_temp))
                grain_energ2(i_temp) = interp_log_log(temp(i_bracket), temp(i_bracket+1), &
                     grain_energ0(i_bracket), &
                     grain_energ0(i_bracket+1), temp2(i_temp))
             enddo

             call U_grid(species_id, nb_atoms, dim_temp2, temp2, grain_energ2(:), &
                  T_interm2, U_interm2)

             call GD(dim_lambda_grains, radius(i_radius), lum2, dim_temp2, U_interm2, &
                  prob, &
                  lambda_grains_interm, integral_wqu, h_c_q_u, q_u_over_2, &
                  h_c_integral_qu, total_heat_rate)

             temp_eq_prev = temp_eq

             if (present(sublim_temp)) then
                call compute_grain_X_lambda(dim_temp2, temp2, prob, dim_lambda_grains, &
                     lambda_grains, Q_abs(i_radius, :), grain_X_lambda(i_radius, :), &
                     sublim_temp, sublim_grain_X_lambda(i_radius, :))
             else
                call compute_grain_X_lambda(dim_temp2, temp2, prob, dim_lambda_grains, &
                     lambda_grains, Q_abs(i_radius, :), grain_X_lambda(i_radius, :))
                sublim_grain_X_lambda(i_radius, :) = 0
             endif
             if (do_output_grain .and. &
                  radius(i_radius) >= grain_output_min_size .and. &
                  radius(i_radius) <= grain_output_max_size) then
                if (grain_temp_output) &
                     call write_grain_temp(radius(i_radius), temp_eq, dim_temp2, &
                     temp2, T_interm2, prob)
                if (grain_SED_output) then
                   call compute_grain_X_lambda(1, (/temp_eq/), (/1._CDR/), &
                        dim_lambda_grains, lambda_grains, Q_abs(i_radius, :), &
                        grain_X_lambda_eq(i_radius, :))
                   call write_grain_SED(radius(i_radius), &
                        grain_X_lambda(i_radius, :), &
                        grain_X_lambda_eq(i_radius, :))
                end if
             endif
          else  !# No stochastic heating.
             if (present(sublim_temp)) then
                call compute_grain_X_lambda(1, (/temp_eq/), (/1._CDR/), dim_lambda_grains, &
                     lambda_grains, Q_abs(i_radius, :), grain_X_lambda(i_radius, :), &
                     sublim_temp, sublim_grain_X_lambda(i_radius, :))
             else
                call compute_grain_X_lambda(1, (/temp_eq/), (/1._CDR/), &
                     dim_lambda_grains, lambda_grains, Q_abs(i_radius, :), &
                     grain_X_lambda(i_radius, :))
                sublim_grain_X_lambda(i_radius, :) = 0
             endif

             if (do_output_grain .and. &
                  radius(i_radius) >= grain_output_min_size .and. &
                  radius(i_radius) <= grain_output_max_size) then
                if (grain_temp_output) &
                     call write_grain_temp(radius(i_radius), temp_eq)
                if (grain_SED_output) then
                   call write_grain_SED(radius(i_radius), &
                        grain_X_lambda(i_radius, :))
                end if
             end if
          endif

!#//////////////////////////////////////////////////////////////////////
!# Larger grains for the grain species considered.

       else !# i_radius > i_radius_min
          if (stoch_heating) then

             if (associated(lum_cumul_frac)) deallocate(lum_cumul_frac)
             allocate(lum_cumul_frac(dim_temp2+1))
             if (associated(lum_frac)) deallocate(lum_frac)
             allocate(lum_frac(dim_temp2))

             lum_cumul_frac(1) = 0
             do i_temp = 2, dim_temp2+1
                lum_cumul_frac(i_temp) = lum_cumul_frac(i_temp-1) + prob(i_temp-1)*lum2(i_temp-1)
             enddo
             do i_temp = 1, dim_temp2
                lum_frac(i_temp) = prob(i_temp)*lum2(i_temp)
             enddo
             lum_frac(1:dim_temp2) = &
                  lum_frac(1:dim_temp2)/lum_cumul_frac(dim_temp2+1) !# Do not move this line \
!#                                                                     after next one!
             lum_cumul_frac(1:dim_temp2+1) = lum_cumul_frac(1:dim_temp2+1)/lum_cumul_frac(dim_temp2+1)
             T_min_prev = T_interm2(max_loc(lum_cumul_frac(1:dim_temp2+1), &
                  mask = lum_cumul_frac(1:dim_temp2+1) < lum_cumul_frac_min, &
                  default = 1))
             T_max_prev = T_interm2(min_loc(lum_cumul_frac(1:dim_temp2+1), &
                  mask = lum_cumul_frac(1:dim_temp2+1) > lum_cumul_frac_max, &
                  default = dim_temp2+1))

             T_min = max(T_interm(1), min(1._CDR, temp_eq/temp_eq_prev)*T_min_prev)
             T_max = min(T_interm(dim_temp+1), max(1._CDR, temp_eq/temp_eq_prev)*T_max_prev)
             T_interm2(1:dim_temp2+1) = T_interm2(1:dim_temp2+1)*temp_eq/temp_eq_prev

!# Introducing `dim_temp2_prev` is necessary with gfortran because this compiler
!# confuses it in the call to subroutine `temp_grid2` with [the first] 
!# `dim_temp2`, although the latter is `intent(out)` and `dim_temp2[_prev]` is 
!# `intent(in)`.
!# With ifort, `dim_temp2_prev` may be replaced by `dim_temp2` in the call to
!# `temp_grid2`.
             dim_temp2_prev = dim_temp2 
             call temp_grid2(dim_temp2, temp2, &
                  T_min, T_max, dim_temp2_prev, T_interm2, lum_frac)

             if (associated(lum2)) deallocate(lum2)
             allocate(lum2(dim_temp2))
             if (associated(grain_energ2)) deallocate(grain_energ2)
             allocate(grain_energ2(dim_temp2))

             i_bracket = 0
             do i_temp = 1, dim_temp2
                call bracket(dim_temp, temp, temp2(i_temp), i_bracket)
                lum2(i_temp) = interp_log_log(temp(i_bracket), temp(i_bracket+1), grain_bol_lum(i_radius, i_bracket), &
                     grain_bol_lum(i_radius, i_bracket+1), temp2(i_temp))
                grain_energ2(i_temp) = interp_log_log(temp(i_bracket), temp(i_bracket+1), &
                     grain_energ0(i_bracket), &
                     grain_energ0(i_bracket+1), temp2(i_temp))
             enddo

             call U_grid(species_id, nb_atoms, dim_temp2, temp2, grain_energ2(:), &
                  T_interm2, U_interm2)

             call GD(dim_lambda_grains, radius(i_radius), lum2, dim_temp2, U_interm2, prob, &
                  lambda_grains_interm, integral_wqu, h_c_q_u, q_u_over_2, &
                  h_c_integral_qu, total_heat_rate)

             temp_eq_prev = temp_eq

             if (present(sublim_temp)) then
                call compute_grain_X_lambda(dim_temp2, temp2, prob, dim_lambda_grains, &
                     lambda_grains, Q_abs(i_radius, :), grain_X_lambda(i_radius, :), &
                     sublim_temp, sublim_grain_X_lambda(i_radius, :))
             else
                call compute_grain_X_lambda(dim_temp2, temp2, prob, dim_lambda_grains, &
                     lambda_grains, Q_abs(i_radius, :), grain_X_lambda(i_radius, :))
                sublim_grain_X_lambda(i_radius, :) = 0
             endif
             if (do_output_grain .and. &
                  radius(i_radius) >= grain_output_min_size .and. &
                  radius(i_radius) <= grain_output_max_size) then
                if (grain_temp_output) &
                     call write_grain_temp(radius(i_radius), temp_eq, &
                     dim_temp2, temp2, T_interm2, prob)
                if (grain_SED_output) then
                   call compute_grain_X_lambda(1, (/temp_eq/), (/1._CDR/), &
                        dim_lambda_grains, lambda_grains, Q_abs(i_radius, :), &
                        grain_X_lambda_eq(i_radius, :))
                   call write_grain_SED(radius(i_radius), &
                        grain_X_lambda(i_radius, :), &
                        grain_X_lambda_eq(i_radius, :))
                endif
             end if
          else !# No stochastic heating.
             if (present(sublim_temp)) then
                call compute_grain_X_lambda(1, (/temp_eq/), (/1._CDR/), dim_lambda_grains, &
                     lambda_grains, Q_abs(i_radius, :), grain_X_lambda(i_radius, :), &
                     sublim_temp, sublim_grain_X_lambda(i_radius, :))
             else
                call compute_grain_X_lambda(1, (/temp_eq/), (/1._CDR/), &
                     dim_lambda_grains, lambda_grains, Q_abs(i_radius, :), &
                     grain_X_lambda(i_radius, :))
                sublim_grain_X_lambda(i_radius, :) = 0
             endif

             if (do_output_grain .and. &
                  radius(i_radius) >= grain_output_min_size .and. &
                  radius(i_radius) <= grain_output_max_size) then
                if (grain_temp_output) &
                     call write_grain_temp(radius(i_radius), temp_eq)
                if (grain_SED_output) then
                   call write_grain_SED(radius(i_radius), &
                        grain_X_lambda(i_radius, :))
                end if
             endif
          endif
       endif
    end do

    call integrate_over_size(i_radius_min, i_radius_max, dim_lambda_grains, &
         grain_X_lambda, d_S_grain(:), lum_species_orig(:))
    if (present(sublim_temp) .and. present(sublim_lum_species_orig)) &
         call integrate_over_size(i_radius_min, i_radius_max, dim_lambda_grains, &
         sublim_grain_X_lambda, d_S_grain(:), sublim_lum_species_orig(:))
    
  end subroutine compute_lum_species

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

  subroutine compute_integrals_temp_eq(dim_lambda_grains, lambda_grains_interm, &
       Q_abs, RF, grain_bol_lum, &
       temp, radius, h_c_integral_qu, &
       integral_wqu, h_c_q_u, q_u_over_2, total_heat_rate, temp_eq)

    use mod_types
    use mod_constants, only : h_c, pi, um_to_cm, h_Planck
    use mod_interp, only : interp_lin_lin

    implicit none
    integer, intent(in) :: dim_lambda_grains
    real(DPR), dimension(:), intent(in) :: lambda_grains_interm
    real(CDR), dimension(:), intent(in) :: Q_abs, RF, grain_bol_lum, temp
    real(CDR), intent(in) :: radius
    real(DPR), dimension(:), intent(out) :: h_c_integral_qu, integral_wqu, &
         h_c_q_u, q_u_over_2
    real(CDR), intent(out) :: total_heat_rate, temp_eq
!#......................................................................
    integer :: i_temp_eq, dim_temp
    real(DPR) :: lambda_grains_inf, lambda_grains_sup, q_u
    integer :: i_lambda
!#::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::

    dim_temp = size(temp)

    h_c_integral_qu(1) = 0
    integral_wqu(1) = 0
    do i_lambda = 1, dim_lambda_grains-1
       q_u = Q_abs(i_lambda)*RF(i_lambda)
       h_c_q_u(i_lambda) = h_c*q_u
       q_u_over_2(i_lambda) = q_u/2
       lambda_grains_inf = lambda_grains_interm(i_lambda)
       lambda_grains_sup = lambda_grains_interm(i_lambda+1)
       h_c_integral_qu(i_lambda+1) = h_c_integral_qu(i_lambda) + &
            (lambda_grains_sup-lambda_grains_inf)*h_c_q_u(i_lambda)
       integral_wqu(i_lambda+1) = integral_wqu(i_lambda) + &
            (lambda_grains_sup**2-lambda_grains_inf**2)*q_u_over_2(i_lambda)
    enddo
    q_u = Q_abs(dim_lambda_grains)*RF(dim_lambda_grains)
    h_c_q_u(dim_lambda_grains) = h_c*q_u
    q_u_over_2(dim_lambda_grains) = q_u/2
    lambda_grains_inf = lambda_grains_interm(dim_lambda_grains)
    lambda_grains_sup = lambda_grains_interm(dim_lambda_grains+1)
    h_c_integral_qu(dim_lambda_grains+1) = h_c_integral_qu(dim_lambda_grains) &
         +(lambda_grains_sup-lambda_grains_inf)*h_c_q_u(dim_lambda_grains)
    integral_wqu(dim_lambda_grains+1) = integral_wqu(dim_lambda_grains) &
         +(lambda_grains_sup**2-lambda_grains_inf**2) * &
         q_u_over_2(dim_lambda_grains)

    total_heat_rate = um_to_cm**3*pi*radius**2 * &
         h_c_integral_qu(dim_lambda_grains+1)/h_Planck
    i_temp_eq = 1
    do while(grain_bol_lum(i_temp_eq+1)-total_heat_rate < 0 .and. i_temp_eq < dim_temp-2)
       i_temp_eq = i_temp_eq+1
    enddo
    temp_eq = interp_lin_lin(grain_bol_lum(i_temp_eq)-total_heat_rate, grain_bol_lum(i_temp_eq+1) &
         -total_heat_rate, temp(i_temp_eq), temp(i_temp_eq+1), 0._CDR)

  end subroutine compute_integrals_temp_eq

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

  subroutine integrate_over_size(i_radius_min, i_radius_max, dim_lambda_grains, grain_X_lambda, &
       d_S_grain, lum_species_orig)

    use mod_types
    
    implicit none
    integer, intent(in) :: i_radius_min, i_radius_max, dim_lambda_grains
    real(CDR), dimension(:,:), intent(in) :: grain_X_lambda
    real(CDR), dimension(:), intent(in) :: d_S_grain
    real(CDR), dimension(:), intent(out) :: lum_species_orig
!#......................................................................
    integer :: i_lambda
!#::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::

    do i_lambda = 1, dim_lambda_grains
       lum_species_orig(i_lambda) = 4*sum(grain_X_lambda(i_radius_min:i_radius_max, i_lambda) * &
            d_S_grain(i_radius_min:i_radius_max))
    enddo

  end subroutine integrate_over_size

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

  subroutine U_grid(species_id, nb_atoms, dim_temp, temp, grain_energ0, &
       T_interm, U_interm)

    use mod_types
    use mod_strings, only : quote_string
    use mod_constants, only : h_Planck, kB, c_cm
    use mod_interm_grid

    implicit none
    integer, intent(in) :: dim_temp
    character(len=*), intent(in) :: species_id
    real(CDR), intent(in) :: nb_atoms
    real(CDR), dimension(:), intent(in) :: temp
    real(CDR), dimension(:), intent(in) :: grain_energ0
    real(CDR), dimension(:), pointer :: T_interm, U_interm
!#......................................................................
    integer :: i_temp
    real(CDR), dimension(size(temp)) :: grain_energ
    real(CDR) :: nb_H
    real(CDR), parameter :: nu1 = c_cm*886._CDR, nu2 = c_cm*1161._CDR, &
         nu3 = c_cm*3030._CDR
!#::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
    
    do i_temp = 1, dim_temp
       if (species_id == "silicates") then !# Equation (34) of DL2001 = eq. (17) of LD2001.
          grain_energ(i_temp) = (nb_atoms-2) * grain_energ0(i_temp)
       else if (species_id == "graphites") then !# {Equation (33) of DL2001  = eq. (15) \
!#                                                  of LD2001} with nb_H = 0.
          grain_energ(i_temp) = (nb_atoms-2) * grain_energ0(i_temp)
       else if (species_id == "neutral PAHs" .or. species_id == "ionized PAHs") then
!# Equation (8) of DL2001 = eq. (4) of LD2001.
          if (nb_atoms <= 25) then
             nb_H = 0.5_CDR*nb_atoms
          else if (nb_atoms <= 100) then
             nb_H = 2.5_CDR*sqrt(nb_atoms)
          else
             nb_H = 0.25_CDR*nb_atoms
          endif
!# Equation (33) of DL2001 = eq. (15) of LD2001.
          grain_energ(i_temp) = (nb_atoms-2)* grain_energ0(i_temp) &
               + nb_H*(h_Planck*nu1/(exp(h_Planck*nu1/kB/temp(i_temp))-1) &
               + h_Planck*nu2/(exp(h_Planck*nu2/kB/temp(i_temp))-1) &
               + h_Planck*nu3/(exp(h_Planck*nu3/kB/temp(i_temp))-1))
       else
          write(*, "(a)") "Grain species " // quote_string(species_id) // &
               " unknown. Stopped."
          stop
       endif
    end do

!# Create *`_interm` grids.

    call interm_grid(dim_temp, temp, T_interm)
    call interm_grid(dim_temp, grain_energ, U_interm)

  end subroutine U_grid

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

  subroutine GD(dim_lambda_grains, radius, grain_bol_lum, dim_temp, &
       U_interm, prob, lambda_grains_interm, integral_wqu, h_c_q_u, q_u_over_2, &
       h_c_integral_qu, total_heat_rate)

    use mod_types
    use mod_constants, only : h_c, pi, um_to_cm, h_Planck
    use mod_interp, only : bracket, interp_lin_lin
    use mod_interm_grid

    implicit none
    integer, intent(in) :: dim_lambda_grains, dim_temp
    real(CDR), intent(in) :: radius
    real(CDR), dimension(:), intent(in) :: grain_bol_lum, U_interm
    real(DPR), dimension(:), intent(in) :: lambda_grains_interm
    real(DPR), dimension(:), intent(in) :: integral_wqu, &
         h_c_q_u, q_u_over_2, h_c_integral_qu
    real(CDR), intent(in) :: total_heat_rate
    real(CDR), dimension(:), pointer :: prob
!#......................................................................
    integer :: i_temp, f_temp, i_bracket, i_temp0
    real(DPR), parameter :: lambda_c = 1000._DPR !# `lambda_c` in micrometers.
    real(DPR), parameter :: h_c_over_lambda_c = h_c/lambda_c
    real(DPR) :: norm
    real(CDR) :: cont_heat_rate
    real(DPR), dimension(dim_temp, dim_temp) :: A, B
    real(DPR), dimension(dim_temp) :: dU_over_dtime, X
    real(CDR), dimension(:), pointer :: lum_interm => null()
    real(DPR) :: lambda_1, lambda_2, lambda_3, lambda_4, U_f_plus, U_f_minus, &
         U_i_plus, U_i_minus
    real(DPR) :: delta_U, delta_U_max, delta_U_min, h_c_integral_qu_1, &
         h_c_integral_qu_2, h_c_integral_qu_3, h_c_integral_qu_4
    real(DPR) :: integral_wqu_1, integral_wqu_2, integral_wqu_3, integral_wqu_4, &
         A_f_i
    real(DPR) :: fact, h_c_integral_qu_c, integral_wqu_c
    real(DPR) :: delta_U_f, delta_U_i, delta_U_f_plus_i_minus, &
         delta_U_f_minus_i_plus
!#::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::

    if (associated(prob)) deallocate(prob)
    allocate(prob(dim_temp))

    norm = sqrt(huge(1.))
    fact = pi*radius**2*um_to_cm**3/h_Planck

    call interm_grid(dim_temp, grain_bol_lum, lum_interm)

    i_bracket = 0
    call bracket(dim_lambda_grains, lambda_grains_interm, lambda_c, i_bracket)
    h_c_integral_qu_c = integr(lambda_grains_interm, h_c_integral_qu(i_bracket), &
         h_c_q_u(i_bracket), 0, lambda_c, i_bracket)
    integral_wqu_c = integr(lambda_grains_interm, integral_wqu(i_bracket), &
         q_u_over_2(i_bracket), 1, lambda_c, i_bracket)
    cont_heat_rate = total_heat_rate - um_to_cm**3 * pi * radius**2 &
         * h_c_integral_qu_c/h_Planck
    i_temp0 = 1
    do while(lum_interm(i_temp0)-cont_heat_rate < 0 .and. i_temp0 < dim_temp-2)
       i_temp0 = i_temp0+1
    enddo
    dU_over_dtime(:) = cont_heat_rate-lum_interm(:dim_temp)
    dU_over_dtime(i_temp0) = 0

    A(:, :) = 0

!# Computation of A(f, f+1).

    do f_temp = i_temp0, dim_temp-1
       if (U_interm(f_temp+2) /= U_interm(f_temp+1)) then
          A(f_temp, f_temp+1) = -dU_over_dtime(f_temp+1) &
               /(U_interm(f_temp+2)-U_interm(f_temp+1))
       else
          A(f_temp, f_temp+1) = 0
       endif
    enddo

!# Computation of A(f, i) when i < f < dim_temp.

    do f_temp = i_temp0+1, dim_temp-1
       U_f_plus = U_interm(f_temp+1)
       U_f_minus = U_interm(f_temp)
       delta_U_f = U_f_plus-U_f_minus
       do i_temp = i_temp0, f_temp-1
          U_i_plus = U_interm(i_temp+1)
          U_i_minus = U_interm(i_temp)
          i_bracket = 0
          delta_U_f_plus_i_minus = U_f_plus-U_i_minus
          if (h_c_over_lambda_c < delta_U_f_plus_i_minus) then
             lambda_1 = h_c/delta_U_f_plus_i_minus
             call bracket(dim_lambda_grains, lambda_grains_interm, lambda_1, i_bracket)
             h_c_integral_qu_1 = integr(lambda_grains_interm, &
                  h_c_integral_qu(i_bracket), h_c_q_u(i_bracket), 0, lambda_1, i_bracket)
             integral_wqu_1 = integr(lambda_grains_interm, integral_wqu(i_bracket), &
                  q_u_over_2(i_bracket), 1, lambda_1, i_bracket)
             delta_U_i = U_i_plus-U_i_minus
             if (delta_U_f > delta_U_i) then
                delta_U_max = U_f_plus-U_i_plus
                delta_U_min = U_f_minus-U_i_minus
                delta_U = delta_U_i
             else
                delta_U_min = U_f_plus-U_i_plus
                delta_U_max = U_f_minus-U_i_minus
                delta_U = delta_U_f
             endif

             if (h_c_over_lambda_c < delta_U_max) then
                lambda_2 = h_c/delta_U_max
                call bracket(dim_lambda_grains, lambda_grains_interm, lambda_2, i_bracket)
                h_c_integral_qu_2 = integr(lambda_grains_interm, &
                     h_c_integral_qu(i_bracket), h_c_q_u(i_bracket), 0, lambda_2, i_bracket)
                integral_wqu_2 = integr(lambda_grains_interm, &
                     integral_wqu(i_bracket), q_u_over_2(i_bracket), 1, lambda_2, i_bracket)
                A_f_i = delta_U_f_plus_i_minus*(integral_wqu_2 &
                     -integral_wqu_1)-(h_c_integral_qu_2-h_c_integral_qu_1)

                if (h_c_over_lambda_c < delta_U_min) then
                   lambda_3 = h_c/delta_U_min
                   call bracket(dim_lambda_grains, lambda_grains_interm, lambda_3, i_bracket)
                   h_c_integral_qu_3 = integr(lambda_grains_interm, &
                        h_c_integral_qu(i_bracket), h_c_q_u(i_bracket), 0, lambda_3, i_bracket)
                   integral_wqu_3 = integr(lambda_grains_interm, &
                        integral_wqu(i_bracket), q_u_over_2(i_bracket), 1, lambda_3, i_bracket)

                   A_f_i = A_f_i+delta_U*(integral_wqu_3-integral_wqu_2)

                   delta_U_f_minus_i_plus = U_f_minus-U_i_plus
                   if (h_c_over_lambda_c < delta_U_f_minus_i_plus) then
                      lambda_4 = h_c/delta_U_f_minus_i_plus
                      call bracket(dim_lambda_grains, lambda_grains_interm, lambda_4, i_bracket)
                      h_c_integral_qu_4 = integr(lambda_grains_interm, &
                           h_c_integral_qu(i_bracket), h_c_q_u(i_bracket), 0, lambda_4, i_bracket)
                      integral_wqu_4 = integr(lambda_grains_interm, &
                           integral_wqu(i_bracket), q_u_over_2(i_bracket), 1, lambda_4, i_bracket)
                      A_f_i = A_f_i+delta_U_f_minus_i_plus*(integral_wqu_3 &
                           -integral_wqu_4) &
                           +(h_c_integral_qu_4-h_c_integral_qu_3)
                   else
                      A_f_i = A_f_i+delta_U_f_minus_i_plus*(integral_wqu_3 &
                           -integral_wqu_c) &
                           +(h_c_integral_qu_c-h_c_integral_qu_3)
                   endif

                else !# integration from lambda_2 to lambda_c; stop.
                   A_f_i = A_f_i+delta_U*(integral_wqu_c-integral_wqu_2)
                endif

             else !# integration from lambda_1 to lambda_c; stop.
                A_f_i = delta_U_f_plus_i_minus*(integral_wqu_c &
                     -integral_wqu_1)-(h_c_integral_qu_c-h_c_integral_qu_1)

             endif
             if (delta_U_i /= 0) then
                A(f_temp, i_temp) = fact*max(A_f_i, 0._DPR)/delta_U_i
             else
                A(f_temp, i_temp) = 0
             endif
          else
             A(f_temp, i_temp) = 0
          endif
       enddo
    enddo

!# Computation of A(f, i) when i < f = dim_temp.

    U_f_minus = U_interm(dim_temp)
    do i_temp = i_temp0, dim_temp-1
       U_i_plus = U_interm(i_temp+1)
       U_i_minus = U_interm(i_temp)
       delta_U_min = U_f_minus-U_i_minus
       i_bracket = 0
       if (h_c_over_lambda_c < delta_U_min) then
!# Integration from 0 to lambda_3.
          delta_U = U_i_plus-U_i_minus
          lambda_3 = h_c/delta_U_min
          call bracket(dim_lambda_grains, lambda_grains_interm, lambda_3, i_bracket)
          h_c_integral_qu_3 = integr(lambda_grains_interm, &
               h_c_integral_qu(i_bracket), h_c_q_u(i_bracket), 0, lambda_3, i_bracket)
          integral_wqu_3 = integr(lambda_grains_interm, integral_wqu(i_bracket), &
               q_u_over_2(i_bracket), 1, lambda_3, i_bracket)
          A_f_i = delta_U*integral_wqu_3

          delta_U_f_minus_i_plus = U_f_minus-U_i_plus
          if (h_c_over_lambda_c < delta_U_f_minus_i_plus) then
             lambda_4 = h_c/delta_U_f_minus_i_plus
             call bracket(dim_lambda_grains, lambda_grains_interm, lambda_4, i_bracket)
             h_c_integral_qu_4 = integr(lambda_grains_interm, &
                  h_c_integral_qu(i_bracket), h_c_q_u(i_bracket), 0, lambda_4, i_bracket)
             integral_wqu_4 = integr(lambda_grains_interm, integral_wqu(i_bracket), &
                  q_u_over_2(i_bracket), 1, lambda_4, i_bracket)
             A_f_i = A_f_i+delta_U_f_minus_i_plus*(integral_wqu_3 &
                  -integral_wqu_4) &
                  +(h_c_integral_qu_4-h_c_integral_qu_3)
          else
             A_f_i = A_f_i+delta_U_f_minus_i_plus*(integral_wqu_3 &
                  -integral_wqu_c) &
                  +(h_c_integral_qu_c-h_c_integral_qu_3)
          endif
          if (delta_U /= 0) then
             A(dim_temp, i_temp) = fact*max(A_f_i, 0._DPR)/delta_U
          else
             A(dim_temp, i_temp) = 0
          endif
       else !# Integration from 0 to lambda_c; stop.
          A(dim_temp, i_temp) = fact*integral_wqu_c
       endif
    enddo

    B(:, :) = 0
    B(dim_temp, i_temp0:dim_temp-1) = A(dim_temp, i_temp0:dim_temp-1)
    do f_temp = dim_temp-1, i_temp0, -1
       B(f_temp, i_temp0:f_temp-1) = B(f_temp+1, i_temp0:f_temp-1) &
            +A(f_temp, i_temp0:f_temp-1)
    enddo

    X(:) = 0
    X(i_temp0) = 1
    do f_temp = i_temp0+1, dim_temp
       if (A(f_temp-1, f_temp) /= 0) then
          X(f_temp) = sum(B(f_temp, i_temp0:f_temp-1)*X(i_temp0:f_temp-1))/ &
               A(f_temp-1, f_temp)
       else
          X(f_temp) = 0
       endif

       if (X(f_temp) > norm) then !# Renormalization if X is too big.
          X(:) = X(:)/norm
       endif
    enddo

!# `prob(i)`: probability of being between U_i_minus and U_i_plus.
    prob(1:dim_temp) = X(:)/sum(X)

!# Normalization to the luminosity of the grain (necessary if the bins are
!# too wide).
    prob(:) = prob(:)*total_heat_rate/sum(prob(:)*grain_bol_lum(:))

  end subroutine GD

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

  function integr(lambda_grains_interm, f, g, code, lambda, i_bracket)

    use mod_types
    
    implicit none
    integer, intent(in) :: code, i_bracket
    real(DPR), dimension(:), intent(in) :: lambda_grains_interm
    real(DPR), intent(in) :: lambda, f, g
    real(DPR) :: integr
!#::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
    
    if (i_bracket == 1) then
       if (lambda < lambda_grains_interm(1)) then
          integr = 0
       else
          if (code == 0) then
             integr = f+(lambda-lambda_grains_interm(i_bracket))*g
          else if (code == 1) then
             integr = f+(lambda-lambda_grains_interm(i_bracket))* &
                  (lambda+lambda_grains_interm(i_bracket))*g
          else
             write(*, "(a)") "Wrong value of `code` in function `integr` of &
                  &""mod_dust_emission.f90"". Stopped."
             stop
          end if
       endif
    else
       if (code == 0) then
          integr = f+(lambda-lambda_grains_interm(i_bracket))*g
       else if (code == 1) then
          integr = f+(lambda-lambda_grains_interm(i_bracket))* &
               (lambda+lambda_grains_interm(i_bracket))*g
       else
          write(*, "(a)") "Wrong value of `code` in function `integr` of &
               &""mod_dust_emission.f90"". Stopped."
          stop
       end if
    endif

  end function integr

!#======================================================================
!# Compute the spectral exitance of grains (i.e., the flux, per unit surface of a grain
!# and per unit wavelength, summed on all the directions in the half hemisphere above
!# the surface).

  subroutine compute_grain_X_lambda(dim_temp, temp, prob, &
       dim_lambda_grains, lambda_grains, Q_abs, grain_X_lambda, &
       sublim_temp, sublim_grain_X_lambda)

    use mod_types
    use mod_black_body, only : pi_B_lambda

    implicit none
    integer, intent(in) :: dim_lambda_grains, dim_temp
    real(CDR), dimension(:), intent(in) :: prob, Q_abs, temp, lambda_grains
    real(CDR), dimension(:), intent(out) :: grain_X_lambda
    real(CDR), intent(in), optional :: sublim_temp
    real(CDR), dimension(:), intent(out), optional :: sublim_grain_X_lambda
!#......................................................................
    integer :: i_lambda_grains, i_temp
!#::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::

    do i_lambda_grains = 1, dim_lambda_grains
       grain_X_lambda(i_lambda_grains) = 0
       if (present(sublim_temp)) sublim_grain_X_lambda(i_lambda_grains) = 0
       do i_temp = 1, dim_temp
          grain_X_lambda(i_lambda_grains) = grain_X_lambda(i_lambda_grains) + &
               Q_abs(i_lambda_grains) * prob(i_temp) &
               * pi_B_lambda(temp(i_temp), lambda_grains(i_lambda_grains))
          if (present(sublim_temp)) then
             if (temp(i_temp) > sublim_temp) then
                sublim_grain_X_lambda(i_lambda_grains) = &
                     sublim_grain_X_lambda(i_lambda_grains) + &
                     Q_abs(i_lambda_grains) * prob(i_temp) & !# ??? No need to recompute this.
                     * pi_B_lambda(temp(i_temp), lambda_grains(i_lambda_grains))
             endif
          endif
       enddo
    enddo

  end subroutine compute_grain_X_lambda

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

  subroutine compute_grain_bol_lum(dim_radius, radius, dim_lambda_grains, lambda_grains, &
       Q_abs, temp, bol_lum)

    use mod_types
    use mod_constants, only : pi, in_um_to_in_cm
    use mod_black_body, only : pi_B_lambda
    
    implicit none
    integer, intent(in) :: dim_radius, dim_lambda_grains
    real(CDR), dimension(:), intent(in) :: radius
    real(CDR), dimension(:), intent(in) :: lambda_grains
    real(CDR), dimension(:, :), intent(in) :: Q_abs
    real(CDR), dimension(:), intent(in) :: temp
    real(CDR), dimension(:,:), pointer :: bol_lum
!#......................................................................
    integer :: i_lambda, i_radius, i_temp, dim_temp
    real(CDR) :: area
!#::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
    
    dim_temp = size(temp)

    if (associated(bol_lum)) deallocate(bol_lum)
    allocate(bol_lum(dim_radius, dim_temp))

    do i_radius = 1, dim_radius
       area = 4*pi*(radius(i_radius)*in_um_to_in_cm)**2
       do i_temp = 1, dim_temp
          bol_lum(i_radius, i_temp) = 0
          do i_lambda = 1, dim_lambda_grains-1
             bol_lum(i_radius, i_temp) = bol_lum(i_radius, i_temp) + &
                  (pi_B_lambda(temp(i_temp),lambda_grains(i_lambda)) * Q_abs(i_radius, i_lambda) + &
                  pi_B_lambda(temp(i_temp),lambda_grains(i_lambda+1)) * Q_abs(i_radius, i_lambda+1)) &
                  * (lambda_grains(i_lambda+1)-lambda_grains(i_lambda))/2
          enddo
          bol_lum(i_radius, i_temp) = area * bol_lum(i_radius, i_temp)
       end do
    end do

  end subroutine compute_grain_bol_lum

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

  subroutine compute_grain_energ(species_id, temp, grain_energ0, dim_Debye, u_Debye, &
       I2_Debye, I3_Debye)

    use mod_types
    use mod_interp,  only : bracket, interp_log_log
    use mod_constants, only : kB
    use mod_strings, only : quote_string

    implicit none
    character(len=*), intent(in) :: species_id
    real(CDR), dimension(:), intent(in) :: temp
    real(CDR), dimension(:), pointer :: grain_energ0 
    integer, intent(in) :: dim_Debye
    real(CDR), dimension(:), intent(in) :: u_Debye, I2_Debye, I3_Debye
!#......................................................................
    integer :: i_temp, dim_temp
    real(CDR), parameter :: theta2 = 500._CDR, theta3 = 1500._CDR, &
         theta_op = 863._CDR, theta_ip = 2504._CDR
!#::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::

    dim_temp = size(temp)

    if (associated(grain_energ0)) deallocate(grain_energ0)
    allocate(grain_energ0(dim_temp))

    do i_temp = 1, dim_temp
       if (species_id == "silicates") then !# Eqs. (10) and (34) of DL2001 = eqs. (16) \
!#                                            and (17) of LD2001.
          grain_energ0(i_temp) = kB*(2*theta2*f_2_Debye(temp(i_temp)/theta2, dim_Debye, u_Debye, I2_Debye) &
               +theta3*f_3_Debye(temp(i_temp)/theta3, dim_Debye, u_Debye, I3_Debye))
       else if (species_id == "graphites" .or. species_id == "neutral PAHs" .or. &
            species_id == "ionized PAHs") then !# Eqs. (10) and (33) of DL2001 = eqs. (15) \
!#                                                and (16) of LD2001.
          grain_energ0(i_temp) = kB*(theta_op*f_2_Debye(temp(i_temp)/theta_op, dim_Debye, u_Debye, I2_Debye) &
               +2*theta_ip*f_2_Debye(temp(i_temp)/theta_ip, dim_Debye, u_Debye, I2_Debye))
       else
          write(*, "(a)") "Grain species " // quote_string(species_id) // &
               " unknown. Stopped."
          stop
       endif
    end do

  end subroutine compute_grain_energ

!#======================================================================
!# $f_n(x) = n x^{n+1} \int_{t=0}^u t^n dt/(e^t-1)$ (DL2001 give instead
!# "$f_n(x) = (1/n) x^{n+1} \int_{t=0}^u t^n dt/(e^t-1)$", which is wrong;
!# see file "dust_dir/Debye.txt").

  function f_2_Debye(x, dim_Debye, u_Debye, I2_Debye)

    use mod_types
    use mod_interp, only : bracket, interp_log_log

    implicit none
    real(CDR), intent(in) :: x
    integer, intent(in) :: dim_Debye
    real(CDR), dimension(:), intent(in) :: u_Debye, I2_Debye
!#......................................................................
    real(CDR) :: f_2_Debye, inv_x
    integer :: i_bracket
!#::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::

    inv_x = 1/x
    if (inv_x < u_Debye(1)) then
       f_2_Debye = x
    else if (inv_x > u_Debye(dim_Debye)) then
       f_2_Debye = x**3*I2_Debye(dim_Debye)
    else
       i_bracket = 0
       call bracket(dim_Debye, u_Debye, inv_x, i_bracket)
       f_2_Debye = x**3*interp_log_log(u_Debye(i_bracket), u_Debye(i_bracket+1), I2_Debye(i_bracket), I2_Debye(i_bracket+1), inv_x)
    endif

  end function f_2_Debye

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

  function f_3_Debye(x, dim_Debye, u_Debye, I3_Debye)

    use mod_types
    use mod_interp, only : bracket, interp_log_log
    implicit none
    real(CDR), intent(in) :: x
    integer, intent(in) :: dim_Debye
    real(CDR), dimension(:), intent(in) :: u_Debye, I3_Debye
!#......................................................................
    real(CDR) :: f_3_Debye, inv_x
    integer :: i_bracket
!#::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::

    inv_x = 1/x
    if (inv_x < u_Debye(1)) then
       f_3_Debye = x
    else if (inv_x > u_Debye(dim_Debye)) then
       f_3_Debye = x**4*I3_Debye(dim_Debye)
    else
       i_bracket = 0
       call bracket(dim_Debye, u_Debye, inv_x, i_bracket)
       f_3_Debye = x**4*interp_log_log(u_Debye(i_bracket), u_Debye(i_bracket+1), I3_Debye(i_bracket), I3_Debye(i_bracket+1), inv_x)
    endif

  end function f_3_Debye

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

  subroutine read_Debye(dim_Debye, u_Debye, I2_Debye, I3_Debye)

    use mod_directories, only : dust_dir
    use mod_types, only : CDR
    use mod_file_access, only : open_file, close_file, path_file

    implicit none
    integer, intent(out) :: dim_Debye
    real(CDR), dimension(:), pointer :: u_Debye, I2_Debye, I3_Debye
!#......................................................................
    integer :: unit, i_Debye
!#::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::

    call open_file(unit, path_file(dust_dir, "Debye.txt"))
    read(unit,*) dim_Debye
    if (associated(u_Debye)) deallocate(u_Debye)
    allocate(u_Debye(dim_Debye))
    if (associated(I2_Debye)) deallocate(I2_Debye)
    allocate(I2_Debye(dim_Debye))
    if (associated(I3_Debye)) deallocate(I3_Debye)
    allocate(I3_Debye(dim_Debye))
    do i_Debye = 1, dim_Debye
       read(unit,*) u_Debye(i_Debye), I2_Debye(i_Debye), I3_Debye(i_Debye)
    enddo
    call close_file(unit)

  end subroutine read_Debye

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

  subroutine write_grain_temp(radius, temp_eq, dim_temp, temp, &
       T_interm, prob)
    
    use mod_types

    implicit none
    real(CDR), intent(in) :: radius, temp_eq
    integer, intent(in), optional :: dim_temp
    real(CDR), dimension(:), intent(in), optional :: temp, T_interm, prob
!#......................................................................
    integer :: i_temp
!#::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::

    if (present(prob)) then
       write(unit_grain_temp, "(2(es10.4,tr1),i0,a)") radius, temp_eq, dim_temp, &
            " !# `radius`, etc."
       do i_temp = 1, dim_temp
          write(unit_grain_temp, "(2(es10.4,tr1))") temp(i_temp), &
               prob(i_temp)/log10(T_interm(i_temp+1)/T_interm(i_temp))
       enddo
    else
       write(unit_grain_temp, "(2(es10.4,tr1),a)") radius, temp_eq, &
            " !# `radius`, etc."
    end if
    
  end subroutine write_grain_temp

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

  subroutine write_grain_SED(radius, grain_X_lambda, grain_X_lambda_eq)

!# Outputs the monochromatic luminosity of a single grain in erg.s-1.um-1.
!# The exitance `grain_X_lambda` of the grain is in erg.s-1.um-1.cm-2;
!# its radius is in um.

    use mod_types
    use mod_constants, only : pi, in_um_to_in_cm
    use mod_convert_type, only : E_format

    implicit none
    real(CDR), intent(in) :: radius
    real(CDR), dimension(:), intent(in) :: grain_X_lambda
    real(CDR), dimension(:), intent(in), optional :: grain_X_lambda_eq
!#::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
    
    if (present(grain_X_lambda_eq)) then
       write(unit_grain_SED, "(es10.4,a)") radius, " !# `radius`."
       write(unit_grain_SED, "(10(a10,tr1))") &
            E_format(4*pi*(radius*in_um_to_in_cm)**2*grain_X_lambda(:), 10, 4)
       write(unit_grain_SED, "(10(a10,tr1))") &
            E_format(4*pi*(radius*in_um_to_in_cm)**2*grain_X_lambda_eq(:), 10, 4)
    else
       write(unit_grain_SED, "(es10.4,a)") radius, " !# `radius`."
       write(unit_grain_SED, "(10(a10,tr1))") &
            E_format(4*pi*(radius*in_um_to_in_cm)**2*grain_X_lambda(:), 10, 4)
    endif

  end subroutine write_grain_SED

end module mod_dust_emission
