
! Copyright (C) 2002 - Observatoire de Paris/Meudon
!                      Universite Paris 7
!                      CNRS (France)
!                      Contact : Jacques.Lebourlot@obspm.fr
!
! This program is free software; you can redistribute it and/or
! modify it under the terms of the GNU General Public License version 2
! as published by the Free Software Foundation.
!
! This program 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 this program; if not, write to the Free Software
! Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.

! JLB - 23 May 2008

MODULE PXDR_DUSTEM

  PRIVATE

  PUBLIC :: DUST_PROPERTIES

CONTAINS

! This routine initialise "du_prop" with dust properties (absorption, scatering, emission,
!      albedo and anisotropy g factor) for each wavelength and each position in the cloud.
! Two different inputs are available:
!      * Fitzpatrick and Massa fits to extinction curves in the UV
!      * Draine's data for graphite and silicates

!%%%%%%%%%%%%%%%%%%%%%%%%%
SUBROUTINE DUST_PROPERTIES
!%%%%%%%%%%%%%%%%%%%%%%%%%

   USE PXDR_FLAGS
   USE PXDR_CONSTANTES
   USE PXDR_PROFIL
   USE PXDR_AUXILIAR
   USE PXDR_STR_DATA
   USE PXDR_RF_TOOLS
   USE PXDR_DRAINE_DUST

   IMPLICIT NONE

   INTEGER                        :: iopt, mm                  ! Index for position and grain size
   INTEGER                        :: ilocb, ilocv              ! Index for wavelengths
   INTEGER                        :: icutL                     ! Index for Lyman wavelengths
   INTEGER                        :: i, ii, j, k               ! Loop index
   REAL (KIND=dp)                 :: wlth                      ! A wavelength
   INTEGER                        :: il1                       ! Index for interpolation
   REAL (KIND=dp)                 :: fact                      ! Interpolation ratio
   REAL (KIND=dp)                 :: Dr_int1, Dr_int2, Dr_int3 ! Auxiliaries for mean over grain size
   REAL (KIND=dp)                 :: absor, scater             ! Partial summation variables
   REAL (KIND=dp)                 :: emi, le_g                 ! Partial summation variables
   REAL (KIND=dp)                 :: du_FM, du_dr              ! Auxiliaries for reconstruction of size dependent FM coefficients
   REAL (KIND=dp)                 :: B_ext, V_ext              ! Extinction at B and V bands
   REAL (KIND=dp)                 :: cd_eff                    ! Effective CD_unit
   TYPE (DU_DIST)                 :: du_Fitzpa                 ! F&M's    coefficients copied in du_prop if F_DUST_P = 0
   TYPE (DU_DIST)                 :: du_Draine                 ! Draine's coefficients copied in du_prop if F_DUST_P = 2

   REAL (KIND=dp), DIMENSION(:,:),   ALLOCATABLE :: Raposs     ! Absorption rate per unit energy of photons
                                                               ! with E > Edposs (divided by pi*a^2)
   REAL (KIND=dp), DIMENSION(:,:),   ALLOCATABLE :: Eddist     ! Dust energy distribution function
   REAL (KIND=dp), DIMENSION(:,:),   ALLOCATABLE :: Indist     ! Integral of energy/temperature distributions
                                                               ! (must be smaller than 1)
   REAL (KIND=dp), DIMENSION(:,:),   ALLOCATABLE :: tdemi      ! Dust temperature of the cold grains
                                                               ! (used for emissivity only)
   REAL (KIND=dp), DIMENSION(:,:),   ALLOCATABLE :: ldemi      ! Wavelength corresponding to the internal energy
                                                               ! of grains of temperature tdemi.
   REAL (KIND=dp), DIMENSION(:,:),   ALLOCATABLE :: Edcut      ! Cut-off of the dust high energy distribution
   INTEGER,        DIMENSION(:,:),   ALLOCATABLE :: Idcut      ! Index of the Edcut cut-off
   REAL (KIND=dp), DIMENSION(:,:),   ALLOCATABLE :: Pabstot    ! Total power absorbed by grains (divided by pi*a^2)
   REAL (KIND=dp), DIMENSION(:,:),   ALLOCATABLE :: Pemtail    ! Total power emitted by the dust high energy tail
                                                               ! (divided by pi*a^2)
   REAL (KIND=dp), DIMENSION(:,:),   ALLOCATABLE :: Pemitot    ! Total power emitted by grains (divided by pi*a^2)
   REAL (KIND=dp), DIMENSION(:),     ALLOCATABLE :: dumy_dist  ! dumy for computation of dust high energy tail emission
   REAL (KIND=dp), DIMENSION(:,:),   ALLOCATABLE :: dumy_iemi  ! dumy for computation of dust high energy tail emission
   REAL (KIND=dp), DIMENSION(:),     ALLOCATABLE :: ttail      ! average temperature of the dust high energy tail
   LOGICAL,        DIMENSION(:),     ALLOCATABLE :: istail     ! boolean: do we include the high energy tail or not in
                                                               ! the computation of dust emissivities and temperatures ?
   TYPE (RF_TYPE)                                :: rf_tmp
   TYPE (RF_TYPE)                                :: eff_tmp
   REAL (KIND=dp)                                :: dum, dum1, dum2
   REAL (KIND=dp), DIMENSION(:),     ALLOCATABLE :: ddum2
   REAL (KIND=dp)                                :: xiig
   REAL (KIND=dp)                                :: sum_t
   REAL (KIND=dp)                                :: ccff
   INTEGER                                       :: jwlgr

   REAL (KIND=dp)                                :: time1
   REAL (KIND=dp)                                :: time2

   ccff = 1.0_dp/(8.0_dp*xpi*xhp*clum*clum)

   !======================================================================================
   ! 0 - ALLOCATE ALL TABLES FOR THE COMPUTATION OF DUST EMISSIVITIES AND TEMPERATURES
   !======================================================================================
   PRINT *, " Deallocate du_prop"
   IF (ALLOCATED (du_prop%abso)) THEN
      DEALLOCATE (du_prop%abso)
      DEALLOCATE (du_prop%scat)
      DEALLOCATE (du_prop%emis)
      DEALLOCATE (du_prop%gcos)
      DEALLOCATE (du_prop%albe)
   ENDIF
   ALLOCATE (du_prop%abso(0:nwlg))
   ALLOCATE (du_prop%scat(0:nwlg))
   ALLOCATE (du_prop%emis(0:nwlg,0:npo))
   ALLOCATE (du_prop%gcos(0:nwlg))
   ALLOCATE (du_prop%albe(0:nwlg))
   PRINT *, " Deallocate tdust_o"
   IF (ALLOCATED (tdust_o)) DEALLOCATE (tdust_o)
   ALLOCATE (tdust_o(1:npg,0:npo))
   ALLOCATE (Raposs(1:npg,nTd))
   ALLOCATE (Eddist(1:npg,nTd))
   ALLOCATE (Indist(1:npg,0:npo))
   ALLOCATE (tdemi(1:npg,0:npo))
   ALLOCATE (ldemi(1:npg,0:npo))
   ALLOCATE (Edcut(1:npg,0:npo))
   ALLOCATE (Idcut(1:npg,0:npo))
   ALLOCATE (Pabstot(1:npg,0:npo))
   ALLOCATE (Pemtail(1:npg,0:npo))
   ALLOCATE (Pemitot(1:npg,0:npo))
   ALLOCATE (dumy_dist(nTd*npg))
   ALLOCATE (dumy_iemi(nTd,jwlmin_gr:jwlmax_gr+1))
   ALLOCATE (ttail(1:npg))
   ALLOCATE (istail(1:npg))
   Raposs(:,:)        = 0.0_dp
   Eddist(:,:)        = 0.0_dp
   Indist(:,:)        = 0.0_dp
   tdemi(1:npg,0:npo) = tdust(1:npg,0:npo)
   ldemi(:,:)         = 0.0_dp
   Pemtail(:,:)       = 0.0_dp
   Pemitot(:,:)       = 0.0_dp
   dumy_dist(:)       = 0.0_dp
   dumy_iemi(:,:)     = 0.0_dp
   istail(:)          = .true.
   CALL CPU_TIME(time1)
   ! ------------------------------------------------------------------------------------

   ! Absorption, scatering and emission coefficient do not include the factor n_H (densh(iopt))
   ! Do no forget to scale when using.

   !======================================================================================
   ! 1 - COMPUTE COEFFICIENTS FROM DRAINE'S DATAFILE REGARDLESS OF F_DUST_P
   !======================================================================================
   ! In PDR_light Qabs does not depend on position
   ALLOCATE (du_Draine%abso(0:nwlg))
   ALLOCATE (du_Draine%scat(0:nwlg))
   ALLOCATE (du_Draine%emis(0:nwlg,0:npo))
   ALLOCATE (du_Draine%gcos(0:nwlg))
   ALLOCATE (du_Draine%albe(0:nwlg))
      DO j = 0, nwlg
         wlth = rf_wl%Val(j)
         ! -------------------------------------------------------------------------------
         ! compute the closest position in Draine's wavelength grid
         ! -------------------------------------------------------------------------------
         DO i = jwlmin_gr, jwlmax_gr+1
            IF (wavgrd(i) > wlth) THEN
               il1 = i-1
               EXIT
            ENDIF
         ENDDO
         IF (wavgrd(jwlmax_gr) < wlth) THEN
            il1 = jwlmax_gr
         ENDIF
         ! -------------------------------------------------------------------------------
         ! absor, scater, le_g = absorption, scattering, & anisotropy summed over size
         ! ** power laws extrapolations at small and large wavelengths except for le_g
         ! ** linear interpolation otherwise
         ! -------------------------------------------------------------------------------
         emi    = 0.0_dp
         absor  = 0.0_dp
         scater = 0.0_dp
         le_g   = 0.0_dp
         IF ( (il1 == 0) .OR. (il1 == jwlmax_gr) ) THEN
            fact = (LOG(wlth) - LOG(wavgrd(il1))) / (LOG(wavgrd(il1+1)) - LOG(wavgrd(il1)))
            DO mm = 1, npg
               Dr_int1 = LOG(Qabs_Dr(il1,mm)) + (LOG(Qabs_Dr(il1+1,mm)) - LOG(Qabs_Dr(il1,mm))) * fact
               absor   = absor + wwmg(mm) * EXP(Dr_int1) * xpi * adust(mm)**2
               Dr_int2 = LOG(Qsca_Dr(il1,mm)) + (LOG(Qsca_Dr(il1+1,mm)) - LOG(Qsca_Dr(il1,mm))) * fact
               scater  = scater + wwmg(mm) * EXP(Dr_int2) * xpi * adust(mm)**2
               Dr_int3 = g_Dr(il1,mm) + (g_Dr(il1+1,mm) - g_Dr(il1,mm)) &
                       * (wlth - wavgrd(il1)) / (wavgrd(il1+1) - wavgrd(il1))
               le_g    = le_g + wwmg(mm) * Dr_int3 * EXP(Dr_int2) * xpi * adust(mm)**2
            ENDDO
         ELSE
            fact = (wlth - wavgrd(il1)) / (wavgrd(il1+1) - wavgrd(il1))
            DO mm = 1, npg
               Dr_int1 = Qabs_Dr(il1,mm) + (Qabs_Dr(il1+1,mm) - Qabs_Dr(il1,mm)) * fact
               absor   = absor + wwmg(mm) * Dr_int1 * xpi * adust(mm)**2
               Dr_int2 = Qsca_Dr(il1,mm) + (Qsca_Dr(il1+1,mm) - Qsca_Dr(il1,mm)) * fact
               scater  = scater + wwmg(mm) * Dr_int2 * xpi * adust(mm)**2
               Dr_int3 = g_Dr(il1,mm) + (g_Dr(il1+1,mm) - g_Dr(il1,mm)) * fact
               le_g    = le_g + wwmg(mm) * Dr_int3 * Dr_int2 * xpi * adust(mm)**2
            ENDDO
         ENDIF
         le_g   = le_g / scater
         du_Draine%abso(j) = absor
         du_Draine%scat(j) = scater
         du_Draine%albe(j) = scater / (absor + scater)
         du_Draine%gcos(j) = le_g
      ENDDO
   ! -------------------------------------------------------------------------------------
   ! set the du_prop table and deallocate du_Draine to save memory
   ! -------------------------------------------------------------------------------------
   du_prop = du_Draine
   DEALLOCATE (du_Draine%abso)
   DEALLOCATE (du_Draine%scat)
   DEALLOCATE (du_Draine%emis)
   DEALLOCATE (du_Draine%gcos)
   DEALLOCATE (du_Draine%albe)
   CALL CPU_TIME(time2)
   WRITE(*,'(A10,ES10.3,A1)') 'step   1 : ', time2 - time1, 's'
   time1 = time2
   ! -------------------------------------------------------------------------------------

   !======================================================================================
   ! 2 - COMPUTE COEFFICIENTS FROM INPUT DATA FILE AND FITZPATRICK AND MASSA FIT IF NEEDED
   !======================================================================================
   IF (F_DUST_P == 0) THEN
      ALLOCATE (du_Fitzpa%abso(0:nwlg))
      ALLOCATE (du_Fitzpa%scat(0:nwlg))
      ALLOCATE (du_Fitzpa%emis(0:nwlg,0:npo))
      ALLOCATE (du_Fitzpa%gcos(0:nwlg))
      ALLOCATE (du_Fitzpa%albe(0:nwlg))
         ! -------------------------------------------------------------------------------
         ! 1 - Replace constant g by the coefficient from Draine
         ! 2 - Initialise albedo with the albedo of Draine
         ! 3 - Recovering abs, scat, and emi from the F&M extinction curve
         !     note that this curve does not applies below 911 Å - BG 04/2013
         !     -> Replace abso and scater by those from Draine
         !     -> Check the junction at 911 Å and deduce a law to apply below.
         !     -> First try: simple shift of Draine's data for absorption and
         !                   scattering to match Fitzpatrick's at 911 Å
         !     -> Second (default): apply a function that match Fitzpatrick's at 911 Å and
         !                          exponentially tend towards Draine's at low wavelength
         ! -------------------------------------------------------------------------------
         du_Fitzpa%gcos(:) = du_prop%gcos(:)
         du_Fitzpa%albe(:) = du_prop%albe(:)
         CALL RF_LOCATE (rf_wl, wl_lym,  icutL)
         du_Fitzpa%abso(icutL:) = (1.0_dp - du_Fitzpa%albe(icutL:)) * rf_extpou%Val(icutL:) / coef2
         du_Fitzpa%scat(icutL:) = du_Fitzpa%albe(icutL:) * rf_extpou%Val(icutL:) / coef2
         ! ----------------------------------------------------------------------------------
         ! Reconstruction of grain-size dependent Fitzpatrick and Massa coefficients.
         ! Depending on if the user wants Qabs and Qsca re-scaled
         ! - for each size, Qabs and Qsca are copied from Draine's data and scaled by the ratio Fitzpatrick/Draine
         ! - for each size, we use directly Qabs and Qsca from Draine's data
         ! ----------------------------------------------------------------------------------
         IF (F_QABS_SCALED == 1) THEN
            DO j = jwlmin_gr, jwlmax_gr+1
               CALL RF_LOCATE (rf_wl, wavgrd(j), i)
               IF(rf_wl%val(i) >= wlthm) THEN
                  fact  = (LOG(wavgrd(j)) - LOG(rf_wl%val(i-1))) / (LOG(rf_wl%val(i)) - LOG(rf_wl%val(i-1)))
                  du_fm = LOG(du_Fitzpa%abso(i-1)) + (LOG(du_Fitzpa%abso(i)) - LOG(du_Fitzpa%abso(i-1))) * fact
                  du_dr = LOG(du_prop%abso(i-1)) + (LOG(du_prop%abso(i)) - LOG(du_prop%abso(i-1))) * fact
                  Qabs_FM(j,1:npg) = Qabs_Dr(j,1:npg) * EXP(du_fm)/EXP(du_dr)
                  du_fm = LOG(du_Fitzpa%scat(i-1)) + (LOG(du_Fitzpa%scat(i)) - LOG(du_Fitzpa%scat(i-1))) * fact
                  du_dr = LOG(du_prop%scat(i-1)) + (LOG(du_prop%scat(i)) - LOG(du_prop%scat(i-1))) * fact
                  Qsca_FM(j,1:npg) = Qsca_Dr(j,1:npg) * EXP(du_fm)/EXP(du_dr)
               ELSE IF(rf_wl%val(i) < wavgrd(j)) THEN
                  fact  = (LOG(wavgrd(j)) - LOG(rf_wl%val(i))) / (LOG(rf_wl%val(i+1)) - LOG(rf_wl%val(i)))
                  du_fm = LOG(du_Fitzpa%abso(i)) + (LOG(du_Fitzpa%abso(i+1)) - LOG(du_Fitzpa%abso(i))) * fact
                  du_dr = LOG(du_prop%abso(i)) + (LOG(du_prop%abso(i+1)) - LOG(du_prop%abso(i))) * fact
                  Qabs_FM(j,1:npg) = Qabs_Dr(j,1:npg) * EXP(du_fm)/EXP(du_dr)
                  du_fm = LOG(du_Fitzpa%scat(i)) + (LOG(du_Fitzpa%scat(i+1)) - LOG(du_Fitzpa%scat(i))) * fact
                  du_dr = LOG(du_prop%scat(i)) + (LOG(du_prop%scat(i+1)) - LOG(du_prop%scat(i))) * fact
                  Qsca_FM(j,1:npg) = Qsca_Dr(j,1:npg) * EXP(du_fm)/EXP(du_dr)
               ELSE
                  Qabs_FM(j,1:npg) = Qabs_Dr(j,1:npg) * du_Fitzpa%abso(i) / du_prop%abso(i)
                  Qsca_FM(j,1:npg) = Qsca_Dr(j,1:npg) * du_Fitzpa%scat(i) / du_prop%scat(i)
               ENDIF
            ENDDO
         ELSE
            Qabs_FM(jwlmin_gr:jwlmax_gr+1,1:npg) = Qabs_Dr(jwlmin_gr:jwlmax_gr+1,1:npg)
            Qsca_FM(jwlmin_gr:jwlmax_gr+1,1:npg) = Qsca_Dr(jwlmin_gr:jwlmax_gr+1,1:npg)
         ENDIF

      ! ----------------------------------------------------------------------------------
      ! set the du_prop table and deallocate du_Fitzpa to save memory
      ! ----------------------------------------------------------------------------------
      du_prop = du_Fitzpa
      DEALLOCATE (du_Fitzpa%abso)
      DEALLOCATE (du_Fitzpa%scat)
      DEALLOCATE (du_Fitzpa%emis)
      DEALLOCATE (du_Fitzpa%gcos)
      DEALLOCATE (du_Fitzpa%albe)
   ENDIF
   CALL CPU_TIME(time2)
   WRITE(*,'(A10,ES10.3,A1)') 'step   2 : ', time2 - time1, 's'
   time1 = time2
   ! -------------------------------------------------------------------------------------

   !======================================================================================
   ! 4 - SELECT WHICH DATA ARE USED IN THE CODE AND INITIALIZE THE SIGABS TABLE
   !======================================================================================
   IF (F_DUST_P == 0) THEN
      DO i = jwlmin_gr, jwlmax_gr+1
         DO mm = 1, npg
            sigabs(mm)%Val(i-jwlmin_gr+1) = Qabs_FM(i,mm) * xpi * adust(mm)*adust(mm) / x_nc(mm)
            Q_abs = Qabs_FM
         ENDDO
      ENDDO
   ELSE IF(F_DUST_P == 2) THEN
      DO i = jwlmin_gr, jwlmax_gr+1
         DO mm = 1, npg
            sigabs(mm)%Val(i-jwlmin_gr+1) = Qabs_Dr(i,mm) * xpi * adust(mm)*adust(mm) / x_nc(mm)
            Q_abs = Qabs_Dr
         ENDDO
      ENDDO
   ENDIF
   CALL CPU_TIME(time2)
   WRITE(*,'(A10,ES10.3,A1)') 'step   4 : ', time2 - time1, 's'
   time1 = time2
   ! -------------------------------------------------------------------------------------

   !======================================================================================
   ! 5 - COMPUTE THE DUST PHOTON ABSORPTION RATE, ABSORBED POWER, AND EMITTED POWER
   !     CAREFUL WITH THE ENERGY CUT-OFF OF ALL THESE QUANTITIES
   !======================================================================================
   ! -------------------------------------------------------------------------------------
   ! Possible emitted power : integrate Qabs over Planck functions at several fixed
   !                          temperatures from ldposs(mm,i) to wlthm
   ! -------------------------------------------------------------------------------------
   DO i = 1, nTd
      DO mm = 1, npg
         Peposs(mm,i) = SECT_INTB (sigabs(mm), rf_Plint(i), wl_pointer, ldposs(mm,i), rf_wl%Val(nwlg)) &
                      * x_nc(mm) / (xpi * adust(mm)*adust(mm)) * 4 * xpi
      ENDDO
   ENDDO
   ! -------------------------------------------------------------------------------------
   ! a) Possible absorption rate for populating the dust high energy tail
   !    Computed from wlth0 up to ldposs(mm,1:nTd)
   ! b) Total power absorbed by dust
   !    Computed over the entire wavelength domain
   ! -------------------------------------------------------------------------------------
   IF( ALLOCATED (J_du_pro) ) THEN
      CALL RF_CREATE(rf_tmp, rf_wl%lower, rf_wl%upper)
      CALL RF_CREATE(eff_tmp, 1,jwlmax_gr-jwlmin_gr+2)
      rf_tmp%Ord = rf_u%Ord
      DO iopt = 0, npo
         rf_u%Val(0:nwlg) = J_du_pro(iopt,0:nwlg) * J_to_u
         rf_tmp%Val = rf_u%Val / ( xhp * clum ) * (rf_wl%Val*1.0e-8_dp)
         DO mm = 1, npg
            eff_tmp%Ord = sigabs(mm)%Ord
            DO i = 1, jwlmax_gr-jwlmin_gr+2
               eff_tmp%Val(i) = sigabs(mm)%Val(i) * (1.0_dp - eff_phel(mm,iopt)%Val(i))
            ENDDO
            Pabstot(mm,iopt) = SECT_INT(eff_tmp, rf_u, wl_pointer, rf_wl%Val(nwlg))
            Pabstot(mm,iopt) = Pabstot(mm,iopt) * clum * x_nc(mm) / (xpi * adust(mm)*adust(mm))
         ENDDO
      ENDDO
      CALL RF_FREE(rf_tmp)
      CALL RF_FREE(eff_tmp)
   ELSE
      Pabstot(:,:)  = 0.0_dp
   ENDIF
   CALL CPU_TIME(time2)
   WRITE(*,'(A10,ES10.3,A1)') 'step   5 : ', time2 - time1, 's'
   time1 = time2
   ! -------------------------------------------------------------------------------------

   !======================================================================================
   ! 6 - COMPUTE THE ENERGY AND TEMPERATURE DISTRIBUTION FUNCTIONS OF THE DUST HIGH ENERGY
   !     TAIL (EMERIC'S PRESCRIPTION, SEE DOCUMENT DUST_TEMP_APPROX.PDF)
   !======================================================================================
   ! -------------------------------------------------------------------------------------
   ! Define dumy tables to reduce the computational time
   ! -------------------------------------------------------------------------------------
   DO j = jwlmin_gr, jwlmax_gr+1
      CALL RF_LOCATE(rf_wl, wavgrd(j), jwlgr)
      DO i = 1, nTd
         dumy_iemi(i,j) = rf_Plint(i)%Val(jwlgr)
      ENDDO
   ENDDO
   DO iopt = 0, npo
      ! ----------------------------------------------------------------------------------
      ! Compute the dust photon absorption rate
      ! ----------------------------------------------------------------------------------
      CALL RF_CREATE(rf_tmp, rf_wl%lower, rf_wl%upper)
      CALL RF_CREATE(eff_tmp, 1,jwlmax_gr-jwlmin_gr+2)
      IF( ALLOCATED (J_du_pro) ) THEN
         rf_u%Val(0:nwlg) = J_du_pro(iopt,0:nwlg) * J_to_u
         rf_tmp%Val = rf_u%Val / ( xhp * clum ) * (rf_wl%Val*1.0e-8_dp)
         DO mm = 1, npg
            eff_tmp%Ord = sigabs(mm)%Ord
            DO i = 1, jwlmax_gr-jwlmin_gr+2
               eff_tmp%Val(i) = sigabs(mm)%Val(i)      * (1.0_dp - eff_phel(mm,iopt)%Val(i))
            ENDDO
            CALL INCREMENTAL_INTEG (eff_tmp, rf_tmp, wl_pointer, Raposs(mm,1:nTd), ldposs(mm,1:nTd), nTd)
            Raposs(mm,:) = Raposs(mm,:) * clum * x_nc(mm) / (xpi * adust(mm)*adust(mm))
         ENDDO
      ELSE
         Raposs(:,:) = 0.0_dp
      ENDIF
      CALL RF_FREE(rf_tmp)
      CALL RF_FREE(eff_tmp)
      ! ----------------------------------------------------------------------------------
      ! Energy distribution function (Eq. 13 of document dust_temp_approx.pdf by EB)
      ! ----------------------------------------------------------------------------------
      DO mm = 1, npg
         DO i = nTd, 1, -1
            IF(Peposs(mm,i) /= 0.0_dp) THEN
               Eddist(mm,i) = Raposs(mm,i) / Peposs(mm,i)
            ELSE
               Eddist(mm,i) = 0.0_dp
            ENDIF
         ENDDO
      ENDDO
      ! ----------------------------------------------------------------------------------
      ! Compute the energy below which the approximation is not valid (Eqs. 16 & 17)
      ! ----------------------------------------------------------------------------------
      DO mm = 1, npg
         Edcut(mm,iopt) = Edposs(mm,1)
         dum = 0.0_dp
         DO i = nTd, 2, -1
            dum = dum + ( Eddist(mm,i) + Eddist(mm,i-1) ) &
                      * ( Edposs(mm,i) - Edposs(mm,i-1) ) / 2.0_dp
            IF(dum >= 1.0_dp) THEN
               Edcut(mm,iopt) = Edposs(mm,i)
               EXIT
            ENDIF
         ENDDO
         ! The following limit is empirical - needs to be tested
         Edcut(mm,iopt) = 3.0_dp * Edcut(mm,iopt)
      ENDDO
      ! ----------------------------------------------------------------------------------
      ! Find the index associated to this validity limit
      ! ----------------------------------------------------------------------------------
      DO mm = 1, npg
         Idcut(mm,iopt) = 1
         DO i = nTd, 1, -1
            IF( Edposs(mm,i) < Edcut(mm,iopt) ) THEN
               Eddist(mm,1:i) = 0.0_dp
               Idcut(mm,iopt) = i
               EXIT
            ENDIF
         ENDDO
      ENDDO
      ! ----------------------------------------------------------------------------------
      ! Integral of the high temperature distribution function - cannot be larger than 1
      ! ----------------------------------------------------------------------------------
      Indist(:,iopt) = 0.0_dp
      DO i = nTd, 2, -1
         DO mm = 1, npg
            dum  = (Edposs(mm,i)-Edposs(mm,i-1)) / 2.0_dp
            Indist(mm,iopt) = Indist(mm,iopt) + (Eddist(mm,i)+Eddist(mm,i-1)) * dum
         ENDDO
      ENDDO
      DO mm = 1, npg
         IF (Indist(mm,iopt) > 1.0_dp) THEN
            WRITE(*,'(A,ES10.3)') 'Indist = ', Indist(mm,iopt)
            WRITE(*,'(A)') 'problem: the proba of dust high energy distribution is > 1  '
            WRITE(*,'(A)') '         there is an inconsistency in the computation of the'
            WRITE(*,'(A)') '         energy limit of the dust high energy tail'
            STOP
         ENDIF
      ENDDO

      !===================================================================================
      ! 7 - COMPUTE DUST TEMPERATURES AND EMISSIVITIES
      !===================================================================================
      ! ----------------------------------------------------------------------------------
      ! Define dumy tables to reduce the computational time
      ! ----------------------------------------------------------------------------------
      DO mm = 1, npg
         DO i = 1, nTd
            k = nTd*(mm-1) + i
            dumy_dist(k) = Eddist(mm,i)
         ENDDO
      ENDDO
      ! ----------------------------------------------------------------------------------
      ! Compute the power emitted by the dust high energy tail (Eq. 20)
      ! ----------------------------------------------------------------------------------
      Q_emi(:,:)      = 0.0_dp
      Pemtail(:,iopt) = 0.0_dp
      DO mm = 1, npg
         IF (Idcut(mm,iopt)+1 > nTd) CYCLE
         DO j = jwlmin_gr, jwlmax_gr+1
            CALL RF_LOCATE(rf_wl, wavgrd(j), jwlgr)
            ! -----------------------------------------------------
            ! define an intermediate variable instead of repeatedly
            ! calling a 2D table diminish the computational time
            ! -----------------------------------------------------
            sum_t = 0.0_dp
            ! -----------------------------------------------------
            ! Compute the first point of the trapezoidal integral
            ! over the dust high energy tail distribution
            ! ---------------------------------------------------
            ! JLB - 3 X 2014 - Accelerate code
            k = nTd*(mm-1) + Idcut(mm,iopt)
            IF( wavgrd(j) > ldposs(mm,Idcut(mm,iopt)) ) THEN
               dum1 = (Edposs(mm,Idcut(mm,iopt)+1)-Edposs(mm,Idcut(mm,iopt))) / 2.0_dp
               dum2 = dumy_dist(k) * dumy_iemi(Idcut(mm,iopt),j)
               sum_t = sum_t + dum1 * dum2
            ENDIF
            ! -----------------------------------------------------
            ! Compute the middle points of the trapezoidal integral
            ! over the dust high energy tail distribution
            ! -----------------------------------------------------
            DO i = Idcut(mm,iopt)+1, nTd-1
               IF( wavgrd(j) > ldposs(mm,i) ) THEN
                  ii = i
                  EXIT
               ENDIF
            ENDDO
            ALLOCATE (ddum2(ii:nTd-1))
            DO i = ii, nTd-1
               k = nTd*(mm-1) + i
               ddum2(i) = dumy_dist(k) * dumy_iemi(i,j)
            ENDDO

            DO i = ii, nTd-1
               sum_t = sum_t + D_Edposs(i,mm) * ddum2(i)
            ENDDO
            DEALLOCATE (ddum2)
            ! ---------------------------------------------------
            ! Compute the last point of the trapezoidal integral
            ! over the dust high energy tail distribution
            ! ---------------------------------------------------
            k = nTd*(mm-1) + nTd
            IF( wavgrd(j) > ldposs(mm,nTd) ) THEN
               dum1 = (Edposs(mm,nTd)-Edposs(mm,nTd-1)) / 2.0_dp
               dum2 = dumy_dist(k) * dumy_iemi(nTd,j)
               sum_t = sum_t + dum1 * dum2
            ENDIF
            Q_emi(j,mm) = Q_abs(j,mm) * sum_t
         ENDDO
         ! ------------------------------------------------------
         ! Integration of the dust high energy tail
         ! ------------------------------------------------------
         ! For precision, perform a Simpson integration - In fact
         ! it has no impact -> we could keep a trapezoidal method
         ! ------------------------------------------------------
         Pemtail(mm,iopt) = Pemtail(mm,iopt) &
                          + (Q_emi(jwlmin_gr,mm) + Q_emi(jwlmin_gr+1,mm)) &
                          * (wavgrd(jwlmin_gr+1) - wavgrd(jwlmin_gr)) &
                          / 2.0_dp * 4.0_dp * xpi / 2.0_dp
         DO j = jwlmin_gr+1, jwlmax_gr
            dum  = (wavgrd(j+1) - wavgrd(j-1)) ! x2 - x0
            dum1 = (wavgrd(j)   - wavgrd(j-1)) ! x1 - x0
            dum2 = (wavgrd(j+1) - wavgrd(j)  ) ! x2 - x1
            Dr_int1 = dum * (2.0_dp*dum1-dum2) / (6.0_dp*dum1) * Q_emi(j-1,mm)
            Dr_int2 = dum**3.0_dp / (6.0_dp*dum1*dum2) * Q_emi(j,mm)
            Dr_int3 = dum * (2.0_dp*dum2-dum1) / (6.0_dp*dum2) * Q_emi(j+1,mm)
            Pemtail(mm,iopt) = Pemtail(mm,iopt) + (Dr_int1 + Dr_int2 + Dr_int3) &
                             * 4.0_dp * xpi / 2.0_dp
         ENDDO
         Pemtail(mm,iopt) = Pemtail(mm,iopt) &
                          + (Q_emi(jwlmax_gr,mm) + Q_emi(jwlmax_gr+1,mm)) &
                          * (wavgrd(jwlmax_gr+1) - wavgrd(jwlmax_gr-1)) &
                          / 2.0_dp * 4.0_dp * xpi / 2.0_dp
      ENDDO
      ! ----------------------------------------------------------------------------------
      ! Test if the power emitted by the tail is larger than the total dust absorption
      ! stop the code if the tail emits 101% of the total energy absorbed by dust
      ! ----------------------------------------------------------------------------------
      DO mm = 1, npg
         dum = Pabstot(mm,iopt) - Pemtail(mm,iopt)
         IF (Pabstot(mm,iopt) == 0.0_dp) CYCLE
         IF( (dum < 0.0_dp).AND.(ABS(dum/Pabstot(mm,iopt)) > 0.01_dp) ) THEN
            WRITE(*,'(A)') 'Bad conservation of radiative power due to the'
            WRITE(*,'(A)') 'dust high energy tail ... see PXDR_DUSTEM.f90 '
            !WRITE(*,*) tau(iopt), mm, adust(mm), Pabstot(mm,iopt), Pemtail(mm,iopt)
            STOP
         ENDIF
      ENDDO

      ! ----------------------------------------------------------------------------------
      ! Compute the mean temperature of the dust high energy tail - Simpson integration
      ! ----------------------------------------------------------------------------------
      DO mm = 1, npg
         ttail(mm) = 0.0_dp
         IF (Idcut(mm,iopt)+1 > nTd) CYCLE
         dum1 = (Edposs(mm,Idcut(mm,iopt)+1)-Edposs(mm,Idcut(mm,iopt))) / 2.0_dp
         dum2 = Eddist(mm,Idcut(mm,iopt)) * Tdposs(Idcut(mm,iopt))
         ttail(mm) = ttail(mm) + dum1 * dum2
         DO i = Idcut(mm,iopt)+1, nTd-1
!           dum1 = (Edposs(mm,i+1)-Edposs(mm,i-1)) / 2.0_dp
            dum1 = D_Edposs(i,mm)
            dum2 = Eddist(mm,i) * Tdposs(i)
            ttail(mm) = ttail(mm) + dum1 * dum2
         ENDDO
         dum1 = (Edposs(mm,nTd)-Edposs(mm,nTd-1)) / 2.0_dp
         dum2 = Eddist(mm,nTd) * Tdposs(nTd)
         ttail(mm) = ttail(mm) + dum1 * dum2
      ENDDO
      ! ----------------------------------------------------------------------------------
      ! Compute dust temp : a) temperature of cold grains to conserve the radiative energy
      !                     b) dust temperature (used for chemistry) as an integral of the
      !                        temperatures computed over the warm and cold distributions
      ! ----------------------------------------------------------------------------------
      DO mm = 1, npg
         IF( Pabstot(mm,iopt) == 0.0_dp ) CYCLE
         ! -------------------------------------------------------------------------------
         ! Tdemi = dust equilibrium temperature
         !   - first computed  with the high energy tail removed from the absorbed power
         !     *** p = ( 1.0_dp - Indist(mm,iopt) ) is the probability of the grain of
         !         being in the cold domain (Eq. 22 of dust_temp_approx.pdf by EB)
         !   - tdust = average computed over time spent in warm / cold distributions
         !   - if tdemi > tdust, we entirely disregard the high energy tail in the
         !     calculations of both the dust temperatures and the dust emissivities
         ! -------------------------------------------------------------------------------
         xiig  = ( Pabstot(mm,iopt) - Pemtail(mm,iopt) ) / ( 1.0_dp - Indist(mm,iopt) )
         CALL DUST_TEMP_COLD(mm, xiig, tdemi(mm,iopt), ldemi(mm,iopt))
         tdust_o(mm,iopt) = tdemi(mm,iopt) * ( 1.0_dp - Indist(mm,iopt) ) + ttail(mm)
         IF ( tdemi(mm,iopt) < tdust_o(mm,iopt) ) THEN
            tdust_o(mm,iopt) = tdemi(mm,iopt) * ( 1.0_dp - Indist(mm,iopt) ) + ttail(mm)
            istail(mm) = .true.
         ELSE
            xiig = Pabstot(mm,iopt)
            CALL DUST_TEMP_COLD(mm, xiig, tdemi(mm,iopt), ldemi(mm,iopt))
            tdust_o(mm,iopt) = tdemi(mm,iopt)
            istail(mm) = .false.
         ENDIF
      ENDDO

      ! ----------------------------------------------------------------------------------
      ! Add the contribution of cold grains to Q_emi and compute the total emitted power
      ! ----------------------------------------------------------------------------------
      DO mm = 1, npg
         IF( istail(mm) ) THEN
            DO j = jwlmin_gr, jwlmax_gr+1
               IF( wavgrd(j) > ldemi(mm,iopt) ) THEN
                  Q_emi(j,mm) = Q_emi(j,mm) + (1.0_dp - Indist(mm,iopt)) &
                              * Q_abs(j,mm) * BBL (wavgrd(j), tdemi(mm,iopt))
               ENDIF
            ENDDO
         ELSE
            Q_emi(:,mm) = 0.0_dp
            DO j = jwlmin_gr, jwlmax_gr+1
               IF( wavgrd(j) > ldemi(mm,iopt) ) THEN
                  Q_emi(j,mm) = Q_abs(j,mm) * BBL (wavgrd(j), tdemi(mm,iopt))
               ENDIF
            ENDDO
         ENDIF
         ! ------------------------------------------------------
         ! For precision, perform a Simpson integration - In fact
         ! it has no impact -> we could keep a trapezoidal method
         ! ------------------------------------------------------
         Pemitot(mm,iopt) = Pemitot(mm,iopt) &
                          + (Q_emi(jwlmin_gr,mm) + Q_emi(jwlmin_gr+1,mm)) &
                          * (wavgrd(jwlmin_gr+1) - wavgrd(jwlmin_gr)) &
                          / 2.0_dp * 4.0_dp * xpi / 2.0_dp
         DO j = jwlmin_gr+1, jwlmax_gr
            dum  = (wavgrd(j+1) - wavgrd(j-1)) ! x2 - x0
            dum1 = (wavgrd(j)   - wavgrd(j-1)) ! x1 - x0
            dum2 = (wavgrd(j+1) - wavgrd(j)  ) ! x2 - x1
            Dr_int1 = dum * (2.0_dp*dum1-dum2) / (6.0_dp*dum1) * Q_emi(j-1,mm)
            Dr_int2 = dum**3.0_dp / (6.0_dp*dum1*dum2) * Q_emi(j,mm)
            Dr_int3 = dum * (2.0_dp*dum2-dum1) / (6.0_dp*dum2) * Q_emi(j+1,mm)
            Pemitot(mm,iopt) = Pemitot(mm,iopt) + (Dr_int1 + Dr_int2 + Dr_int3) &
                             * 4.0_dp * xpi / 2.0_dp
         ENDDO
         Pemitot(mm,iopt) = Pemitot(mm,iopt) &
                          + (Q_emi(jwlmax_gr,mm) + Q_emi(jwlmax_gr+1,mm)) &
                          * (wavgrd(jwlmax_gr+1) - wavgrd(jwlmax_gr-1)) &
                          / 2.0_dp * 4.0_dp * xpi / 2.0_dp
      ENDDO
      ! ----------------------------------------------------------------------------------
      ! Test if the local conservation of radiative energy. We accept an error on
      ! of 3%, which is about the photoelectric heating efficiency of big grains
      ! ----------------------------------------------------------------------------------
      DO mm = 1, npg
         dum = Pabstot(mm,iopt) - Pemitot(mm,iopt)
         IF (Pabstot(mm,iopt) == 0.0_dp) CYCLE
         IF( (ABS(dum/Pabstot(mm,iopt)) > 0.03_dp) ) THEN
            WRITE(*,'(A)') 'Bad conservation of radiative power (> 3 %) when adding'
            WRITE(*,'(A)') 'contributions of warm and cold grains -> see PXDR_DUSTEM.f90'
            WRITE(*,'(6(A8,ES10.3,A3))') "Av    = ", tau(iopt-1)*tautav,        " ; ", &
                                         "rdust = ", adust(mm),                 " ; ", &
                                         "P_abs = ", Pabstot(mm,iopt),          " ; ", &
                                         "P_emi = ", Pemitot(mm,iopt),          " ; ", &
                                         "1-E/A = ", ABS(dum/Pabstot(mm,iopt)), " ; ", &
                                         "Temp  = ", tdemi(mm,iopt),            " ; "
         ENDIF
      ENDDO
      ! ----------------------------------------------------------------------------------
      ! CHECK THE SIZE-DEPENDENT EMISSIVITY COEFFICIENTS
      ! ----------------------------------------------------------------------------------
      ! The emissivity coefficients (Qabs*BBL) of the cold grain + the high energy tail
      ! are written in the file ../out/modele/check_emi_coef.res for all size of grains
      ! and all wavelengths for iopt = 0 - Only for debug purposes (BG 11/2013)
      ! ----------------------------------------------------------------------------------
      !IF (iopt == 0) THEN
      !   fichier = TRIM(out_dir)//'check_emi_coef.res'
      !   OPEN(iwrtmp,file=TRIM(fichier),status='unknown')
      !   DO mm = 1, npg
      !      WRITE(iwrtmp,'(A1,ES10.3)') '#',adust(mm)
      !      WRITE(iwrtmp,'(A27)') '#w(angstr) Q_abs      Q_emi'
      !      DO j=jwlmin_gr, jwlmax_gr+1
      !         WRITE(iwrtmp,'(3(ES10.3,1X))') wavgrd(j), Q_abs(j,mm), Q_emi(j,mm)
      !      ENDDO
      !      WRITE(iwrtmp,*)
      !      WRITE(iwrtmp,*)
      !   ENDDO
      !   CLOSE(iwrtmp)
      !ENDIF
      ! ----------------------------------------------------------------------------------

      ! ----------------------------------------------------------------------------------
      ! Compute the dust emissivities (summed over the size) over the entire rf_wl grid
      ! ----------------------------------------------------------------------------------
      DO j = 0, nwlg
         wlth = rf_wl%Val(j)
         !DICHOTOMIE
         DO i = jwlmin_gr, jwlmax_gr+1
            IF (wavgrd(i) > wlth) THEN
               il1 = i-1
               EXIT
            ENDIF
         ENDDO
         IF (wavgrd(jwlmax_gr) < wlth) THEN
            il1 = jwlmax_gr
         ENDIF
         emi    = 0.0_dp
         IF(il1 == jwlmax_gr) THEN
            fact = (LOG(wlth) - LOG(wavgrd(il1))) / (LOG(wavgrd(il1+1)) - LOG(wavgrd(il1)))
            DO mm = 1, npg
               Dr_int1 = LOG(Q_emi(il1,mm)) + (LOG(Q_emi(il1+1,mm)) - LOG(Q_emi(il1,mm))) * fact
               emi     = emi + wwmg(mm) * xpi * adust(mm)**2 * EXP(Dr_int1)
            ENDDO
         ELSE
            fact = (wlth - wavgrd(il1)) / (wavgrd(il1+1) - wavgrd(il1))
            DO mm = 1, npg
               Dr_int1 = Q_emi(il1,mm) + (Q_emi(il1+1,mm) - Q_emi(il1,mm)) * fact
               emi     = emi + wwmg(mm) * xpi * adust(mm)**2 * Dr_int1
            ENDDO
         ENDIF
         ! -------------------------------------------------------------------------------
         ! copy the emissivity coefficient in the du_prop table except if dustem is used
         ! -------------------------------------------------------------------------------
         du_prop%emis(j,iopt) = emi ! dust emissivity per proton
      ENDDO
   ENDDO
   CALL CPU_TIME(time2)
   WRITE(*,'(A10,ES10.3,A1)') 'step 6-7 : ', time2 - time1, 's'
   time1 = time2
   ! -------------------------------------------------------------------------------------

   !======================================================================================
   ! 9 - DEBUG, WRITE ALL THE DUST COEFFICIENTS IN THE check_du_pro.dat FILE
   !======================================================================================
   !fichier = TRIM(out_dir)//'check_du_pro.dat'
   !OPEN (iwrtmp, file=TRIM(fichier), STATUS="unknown")
   !k = 0
   !DO iopt = 0, npo
   !   IF( iopt == 0 ) CYCLE
   !   dum = tau(1)*10.0_dp**(LOG10(tau(npo)/tau(1))/10.0_dp*DBLE(k))
   !   IF( (iopt == 1).OR.(tau(iopt) > dum) ) THEN
   !      WRITE (iwrtmp,'(A8,I2)') '#index: ', k
   !      DO j = 0, nwlg
   !         WRITE (iwrtmp,'(1p,7e16.7E3)') tau(iopt-1)*tautav, rf_wl%Val(j) &
   !             , du_prop%abso(j), du_prop%scat(j), du_prop%emis(j,iopt-1) &
   !             , du_prop%albe(j), du_prop%gcos(j)
   !      ENDDO
   !      WRITE (iwrtmp,*)
   !      WRITE (iwrtmp,*)
   !      k = k+1
   !   ENDIF
   !ENDDO
   !CLOSE (iwrtmp)
   !CALL CPU_TIME(time2)
   !WRITE(*,'(A10,ES10.3,A1)') 'step   9 : ', time2 - time1, 's'
   !time1 = time2
   ! -------------------------------------------------------------------------------------

   !======================================================================================
   ! 10 - WRITE THE ENERGY CONSERVATION DATA AND DUST TEMPERATURE IN check_dust_conser.res
   !======================================================================================
   !fichier = TRIM(out_dir)//'check_dust_conser.res'
   !OPEN (iwrtmp, file=TRIM(fichier), STATUS="unknown")
   !DO mm = 1, npg
   !   WRITE(iwrtmp,'(5(A9,4X))',ADVANCE='no') &
   !   &'#Tau     ', 'Pabstot  ', 'Pemitot  ', 'tdust    ', 'tdemi    '
   !ENDDO
   !WRITE(iwrtmp,*)
   !WRITE(iwrtmp,'(A1,12X)', ADVANCE='no') '#'
   !DO mm = 1, npg
   !   WRITE(iwrtmp,'(ES10.3,3X,52X)', ADVANCE='no') adust(mm)
   !ENDDO
   !WRITE(iwrtmp,*)
   !DO iopt = 0, npo
   !   DO mm = 1, npg
   !      WRITE(iwrtmp,'(5(ES10.3,3X))', ADVANCE='no') tau(iopt)*tautav, &
   !      & Pabstot(mm,iopt), Pemitot(mm,iopt), tdust_o(mm,iopt), tdemi(mm,iopt)
   !   ENDDO
   !   WRITE(iwrtmp,*)
   !ENDDO
   !CLOSE (iwrtmp)
   !CALL CPU_TIME(time2)
   !WRITE(*,'(A10,ES10.3,A1)') 'step  10 : ', time2 - time1, 's'
   !time1 = time2
   ! -------------------------------------------------------------------------------------

   !======================================================================================
   ! 13 - WRITE INFORMATION ON DUST COEF AND CDUNIT ON SCREEN - ERROR MESSAGES IF NEEDED
   !======================================================================================
   CALL RF_LOCATE (rf_wl, B_band_wl, ilocb)
   CALL RF_LOCATE (rf_wl, V_band_wl, ilocv)
   B_ext = du_prop%abso(ilocb) + du_prop%scat(ilocb)
   V_ext = du_prop%abso(ilocv) + du_prop%scat(ilocv)
   cd_eff  = 1.0_dp / (tautav &
           * (( du_prop%abso(ilocb)+du_prop%scat(ilocb)) &
           - (du_prop%abso(ilocv)+du_prop%scat(ilocv))))
   WRITE(*,*)
   IF (B_ext /= V_ext) THEN
      WRITE(*,'(A,ES12.4)') "     R_V from input file:", rrv
      WRITE(*,'(A,ES12.4)') "   Effective R_V at edge:", V_ext / (B_ext - V_ext)
   ELSE
      WRITE(*,'(A)')        "         R_V not defined:"
      WRITE(*,'(A,ES12.4)') "           B_ext = V_ext:", B_ext
   ENDIF
   WRITE(*,'(A,ES12.4)') "  cdunit from input file:", cdunit
   IF (F_DUST_P == 0) THEN
      WRITE(*,'(A,ES12.4)') "      cdunit from Fitzpa:", cd_eff
   ELSE IF (F_DUST_P == 2) THEN
      WRITE(*,'(A,ES12.4)') "      cdunit from Draine:", cd_eff
   ENDIF
   WRITE(*,'(A, ES12.4)') "                   coef2:", coef2
   WRITE(*,'(A, ES12.4)') "                 1/(k+s):", 1.0 / V_ext
   WRITE(*,'(A,2ES12.4)') "        Qabs(B), Qsca(B):", du_prop%abso(ilocb), du_prop%scat(ilocb)
   WRITE(*,'(A,2ES12.4)') "        Qabs(V), Qsca(V):", du_prop%abso(ilocv), du_prop%scat(ilocv)
   ! -------------------------------------------------------------------------------------
   ! check the consistency of input file
   ! -------------------------------------------------------------------------------------
   IF (ABS(cdunit - cd_eff)/cdunit > 1.0e-3_dp) THEN
      PRINT *, " "
      PRINT *, " WARNING !"
      PRINT *, " Inconsistency in input file:"
      PRINT *, "     input r_min and r_max =", rgrmin, rgrmax
      PRINT *, "                     rhogr =", rhogr
      PRINT *, "             input g_ratio =", g_ratio
      PRINT *, "              input cdunit =", cdunit
      PRINT *, "          effective cdunit =", cd_eff
      PRINT *, "           computed rgazgr =", rgazgr
      PRINT *, "             computed xngr =", xngr
      PRINT *, "           computed agrnrm =", agrnrm
      PRINT *, "            computed coef2 =", coef2
      PRINT *, " Adjust cdunit, rgrmax or g_ratio to consistent values"
      STOP
   ENDIF
   ! -------------------------------------------------------------------------------------

   ! -------------------------------------------------------------------------------------
   ! Deallocate all tables related to the computation of dust emissivities and temperature
   ! -------------------------------------------------------------------------------------
   DEALLOCATE (Raposs)
   DEALLOCATE (Eddist)
   DEALLOCATE (Indist)
   DEALLOCATE (tdemi)
   DEALLOCATE (ldemi)
   DEALLOCATE (Edcut)
   DEALLOCATE (Idcut)
   DEALLOCATE (Pabstot)
   DEALLOCATE (Pemtail)
   DEALLOCATE (Pemitot)
   DEALLOCATE (dumy_dist)
   DEALLOCATE (dumy_iemi)
   DEALLOCATE (ttail)
   DEALLOCATE (istail)

END SUBROUTINE DUST_PROPERTIES

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
SUBROUTINE DUST_TEMP_COLD ( mm, power_abs, tdust_equ, ldust_equ)
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
! ----------------------------------------------------------------------------------------
! This routine compute the temperature of a grain (labelled by "mm") so that the
! corresponding black body emit a given input radiative power : "power_abs"
! Compute dust temp : a) temperature of cold grains to conserve the radiative energy
!                     b) dust temperature (used for chemistry) as an integral of the
!                        temperatures computed over the warm and cold distributions
! ----------------------------------------------------------------------------------------
   USE PXDR_FLAGS
   USE PXDR_CONSTANTES
   USE PXDR_PROFIL
   USE PXDR_AUXILIAR
   USE PXDR_STR_DATA
   USE PXDR_RF_TOOLS
   USE PXDR_DRAINE_DUST

   IMPLICIT NONE

   INTEGER,  INTENT(in)  :: mm
   REAL(dp), INTENT(in)  :: power_abs
   REAL(dp), INTENT(out) :: tdust_equ
   REAL(dp), INTENT(out) :: ldust_equ
   INTEGER               :: imins, iplus
   REAL (KIND=dp)        :: Tdplus     ! dichotomy : upper temperature
   REAL (KIND=dp)        :: Tdmins     ! dichotomy : lower temperature
   REAL (KIND=dp)        :: ldplus     ! wavelength associated to Tdplus
   REAL (KIND=dp)        :: ldmins     ! wavelength associated to Tdmins
   REAL (KIND=dp)        :: Prplus     ! power associated to Tdplus
   REAL (KIND=dp)        :: Prmins     ! power associated to Tdmins
   REAL (KIND=dp)        :: Tdraff     ! Refinement grid of temperature
   REAL (KIND=dp)        :: Edraff     ! Energy grid corresponding to Tdraff
   REAL (KIND=dp)        :: ldraff     ! Wavelength grid corresponding to Edraff
   REAL (KIND=dp)        :: Peraff     ! Emitted power of photons with E < Edraff (refinement grid)
   REAL (KIND=dp)        :: Edmins     ! Auxiliary for refining the the equilibrium temperature
   REAL (KIND=dp)        :: Chmins     ! Auxiliary for refining the the equilibrium temperature
   REAL (KIND=dp)        :: Cheat      ! Auxiliary for refining the the equilibrium temperature
   REAL (KIND=dp)        :: dum        ! Auxiliary variable
   INTEGER               :: i, k       ! dummy indices
   TYPE (RF_TYPE)        :: rf_tmp

   ! -------------------------------------------------------------------------------------
   ! grid method to converge towards the value of Td closest to energy conservation
   ! -------------------------------------------------------------------------------------
   imins = 1
   iplus = nTd
   IF ( ((Peposs(mm,imins)-power_abs)*(Peposs(mm,iplus)-power_abs)) > 0.0_dp ) THEN
      IF( (Peposs(mm,imins)-power_abs) > 0.0_dp) THEN
         iplus = 2
      ELSE
         WRITE(*,'(A,F7.1)') 'problem: dust temperature larger than ', tdmax
         STOP
      ENDIF
   ENDIF
   DO WHILE((iplus-imins) /= 1)
      i = (iplus + imins)/2
      IF( (Peposs(mm,i)-power_abs) <= 0.0_dp ) THEN
         imins = i
      ELSE
         iplus = i
      ENDIF
   ENDDO
   IF ( ((Peposs(mm,imins)-power_abs)*(Peposs(mm,iplus)-power_abs) > 0.0_dp).AND.(imins/=1) ) THEN
      WRITE(*,'(A,F5.1)') 'problem: encircling dust temperature has failed'
      WRITE(*,*) imins,iplus
      STOP
   ENDIF
   ! -------------------------------------------------------------------------------------
   ! If the power to emit is negative set the temperature to an arbitrary minimal value
   ! -------------------------------------------------------------------------------------
   IF( power_abs < 0.0_dp ) THEN
      Tdmins = 1.0e-1_dp
      Tdplus = 1.0e-1_dp
      ldmins = rf_wl%Val(nwlg)
      ldplus = rf_wl%Val(nwlg)
      Prmins = power_abs
      Prplus = power_abs * 2.0_dp
   ! -------------------------------------------------------------------------------------
   ! To improve the conservation of radiative energy with no increase of the computational
   ! time, the previous best interval is iteratively and logarithmically divided in nraff
   ! temperature intervalls where the corresponding emitted power are estimated
   ! -------------------------------------------------------------------------------------
   ELSE
      IF ( (Peposs(mm,imins)-power_abs)*(Peposs(mm,iplus)-power_abs) > 0.0_dp ) THEN
         Tdmins = 0.0_dp
         Tdplus = Tdposs(imins)
         ldmins = rf_wl%Val(nwlg)
         ldplus = ldposs(mm,imins)
         Prmins = 0.0_dp
         Prplus = Peposs(mm,imins)
         Edmins = 0.0_dp
         Chmins = 0.0_dp
      ELSE
         Tdmins = Tdposs(imins)
         Tdplus = Tdposs(iplus)
         ldmins = ldposs(mm,imins)
         ldplus = ldposs(mm,iplus)
         Prmins = Peposs(mm,imins)
         Prplus = Peposs(mm,iplus)
         Edmins = Edposs(mm,imins)
         Chmins = Cheat_Dr(imins,mm)
      ENDIF
      dum = Tdmins
      CALL RF_CREATE(rf_tmp, rf_wl%lower, rf_wl%upper)
      rf_tmp%Ord = rf_wl%Ord
      DO i = 1, nraff
         Tdraff = EXP( (LOG(Tdplus)+LOG(Tdmins))/2.0_dp )
         Cheat  = LOG(Cheat_Dr(imins,mm)) &
                + ( LOG(Cheat_Dr(iplus,mm)/Cheat_Dr(iplus,mm)) ) &
                * LOG(Tdraff/Tdposs(imins)) / LOG(Tdposs(iplus)/Tdposs(imins))
         Edraff = Edmins + (Chmins + EXP(Cheat)) * (Tdraff - dum)/ 2.0_dp
         ldraff = xhp * clum / Edraff * 1.e8_dp
         DO k = 0, nwlg
            rf_tmp%Val(k) = BBL (rf_wl%Val(k), Tdraff)
         ENDDO
         Peraff = SECT_INTB (sigabs(mm), rf_tmp, wl_pointer, ldraff, rf_wl%Val(nwlg)) &
                * x_nc(mm) / (xpi * adust(mm)*adust(mm)) * 4 * xpi
         IF( (Peraff-power_abs) <= 0.0_dp ) THEN
            Tdmins = Tdraff
            ldmins = ldraff
            Prmins = Peraff
         ELSE
            Tdplus = Tdraff
            ldplus = ldraff
            Prplus = Peraff
         ENDIF
      ENDDO
      CALL RF_FREE(rf_tmp)
   ENDIF
   ! -------------------------------------------------------------------------------------
   ! Emission temperature = interpolation between lower and upper values
   ! -------------------------------------------------------------------------------------
   tdust_equ = Tdmins + ( Tdplus - Tdmins ) * (power_abs - Prmins) / (Prplus-Prmins)
   ldust_equ = ldmins + ( ldplus - ldmins ) * (power_abs - Prmins) / (Prplus-Prmins)
END SUBROUTINE DUST_TEMP_COLD

END MODULE PXDR_DUSTEM
