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


MODULE PXDR_RF_INIT

   USE PXDR_FLAGS
   USE PXDR_CONSTANTES
   USE PXDR_TRANSFER

   IMPLICIT NONE

   PRIVATE

   PUBLIC :: RF_INIT

!------------------------------------------------------------------------

CONTAINS

!**********************************************************************************************************
SUBROUTINE RF_INIT
!**********************************************************************************************************
! purpose : Initialise model dependant quantities related to Radiation Field (RF)
!   * Wavelength grid                    : rf_wl (need not have constant step)
!   * Incident ISRF (specific intensity) : rf_incIm and rf_incIp
!   * Dust absorption curve              : rf_extpou (Fitzpatrick fit)

!---------------------------Declaration of PARAMETERs-----------------------------------------------------
    USE PXDR_FLAGS
    USE PXDR_CONSTANTES
    USE PXDR_CHEM_DATA
    USE PXDR_PROFIL
    USE PXDR_AUXILIAR
    USE PXDR_STR_DATA
    USE PXDR_DRAINE_DUST
    USE PXDR_RF_TOOLS
    USE PXDR_TRANSFER
    USE PXDR_READCHIM
    USE PXDR_DUSTEM

    IMPLICIT NONE

    INTEGER                                    :: I_cut_L              !  Index of Lyman limit
    REAL (KIND=dp)                             :: wl_cut_D = 2000.0_dp !  Draine field cutoff wavelength
    REAL (KIND=dp)                             :: wl_cut_F             !  Fitzpatrick cutoff wavelength (Ang)
    INTEGER                                    :: I_cut_F              !  Index of Fitzpatrick cutoff position in grid
    REAL (KIND=dp)                             :: wl_cut_F2            !  WL cutoff below which grains cross section is constant
    INTEGER                                    :: I_cut_F2             !  Index of the wavelength defined above
    REAL (KIND=dp)                             :: wl_cut               !  Dummy WL cutoff
    INTEGER                                    :: I_cut                !  Index of dummy cutoff position in grid

    INTEGER                                    :: mm
    INTEGER                                    :: num                  !  Dummy number
    INTEGER                                    :: ii, i, j, k
    INTEGER                                    :: nb_pt                !  Number of points in a file
    INTEGER                                    :: np_before            !  Number of points before Lyman lim.
    INTEGER                                    :: add_1, iloc, iord    !  Used by RF_EXTAND
    REAL (KIND=dp)                             :: wl, rf
    REAL (KIND=dp)                             :: wl1, wl2, sig1, sig2
    TYPE (RF_TYPE)                             :: rf_tmp
    INTEGER                                    :: nwlg_incr

    ! Auxiliary variables for DUSTEM field

    REAL(KIND=dp)                              :: wlth, fact
    REAL(KIND=dp)                              :: absor, scater, extinct
    REAL(KIND=dp)                              :: Dr_int1, Dr_int2
    INTEGER                                    :: il1

    !==================================================================================
    ! Information written in the .def file
    !==================================================================================
    WRITE(iwrit2, '("  ------------------------------------------------------")')
    WRITE(iwrit2, '("  Statistics of the rf_wl grid (number of points)")')
    nwlg_incr = 0

    !==================================================================================
    ! INITIALIZATION of the radiation field grid
    !==================================================================================
    ! ---------------------------------------
    ! Set initial grid step - BG 04/2013
    ! * 100 points (cf nwlg in PXDR_RF_TOOLS)
    !   from wlth0 to wlthm regardless of the
    !   inclusion of X ray transfer
    ! ---------------------------------------
    wlthm = 2.2e9_dp
    nwlg = 100
    pwlg = EXP(LOG(wlthm / wlth0) / DBLE(nwlg))
    PRINT *, "  wlth0 =", wlth0, " wlthm =", wlthm, " pwlg =", pwlg
    ! ---------------------------------------
    ! Initialisation of wavelengths
    ! * rf_wl%Ord is a permutation of
    !   (rf_wl%lower : rf_wl%upper) giving
    !   the order in which rf_wl%Val have
    !   been entered - see doc RF_Tools (FLP)
    ! ---------------------------------------
    IF (.NOT. ASSOCIATED(rf_wl%Val)) THEN
       CALL RF_CREATE (rf_wl, 0, nwlg)
       rf_wl%Val = wlth0 * ( pwlg**(/ (ii, ii=0,nwlg) /) )
       ! The last wavelength must be equal to wlthm and not an approximation of it
       rf_wl%Val(nwlg) = wlthm
       rf_wl%Ord = (/ (ii, ii=0,nwlg) /)
    ENDIF
    nwlg_incr = nwlg - nwlg_incr
    WRITE(iwrit2, '("     - default initial grid ...................... ",I5)') nwlg_incr
    nwlg_incr = nwlg

    ! Radiation field read in a file
    IF (srcpp(1:2) == 'F_') THEN
       fichier = TRIM(data_dir)//'Astrodata/'//srcpp
       WRITE(iscrn,*) "Opening file : ", TRIM(fichier)
       OPEN(iread2, file = fichier, status = 'old')
       READ (iread2,*) rstar
       READ (iread2,*) teff
       rstar = rstar * rsun
       READ (iread2,*) nb_pt
       READ (iread2,*)
       PRINT *, nb_pt

       ! Warning: for historical reasons data in file are per nanometers
       DO ii = 1, nb_pt
          READ (iread2,*) wl, rf
          wl = wl * 10.0_dp      ! convert to Angstrom
          IF (wl < wlth0) CYCLE
          CALL RF_EXTAND (rf_wl, wl, add_1, iloc, iord)   ! add wl in grid
          nwlg = nwlg + add_1
       ENDDO
       CLOSE (iread2)
    ENDIF
    nwlg_incr = nwlg - nwlg_incr
    WRITE(iwrit2, '("     - input external radiation field ............ ",I5)') nwlg_incr
    nwlg_incr = nwlg

    !================================================================================
    ! Add all "special values"
    !================================================================================

    !---  Habing field limit --------------------------------------------------------
    CALL RF_EXTAND (rf_wl, wl_hab, add_1, iloc, iord)
    nwlg = nwlg + add_1

    !--- 6 eV field limit -----------------------------------------------------------
    CALL RF_EXTAND (rf_wl, wl_6ev, add_1, iloc, iord)
    nwlg = nwlg + add_1

    !--- Draine Field cut-off ------------------------------------------------------
    CALL RF_EXTAND (rf_wl, wl_cut_D, add_1, iloc, iord)
    nwlg = nwlg + add_1

    !--- Fitzpatrick & Massa extinction curve ---------------------------------------
    wl_cut_F = 1.0e4_dp / 5.9_dp
    CALL RF_EXTAND (rf_wl, wl_cut_F, add_1, iloc, iord)
    nwlg = nwlg + add_1

    ! Special : If the name of the line of sight is sig1.9, we force grains cross section
    !           to be 1.9E-21 cm-2 below 1070 Ang (9.346 microm-1) and then use the Galactic curve
    IF (los_ext == 'sig1.9') THEN
       wl_cut_F2 = 1.0e4_dp / 9.346_dp
       CALL RF_EXTAND (rf_wl, wl_cut_F2, add_1, iloc, iord)
       nwlg = nwlg + add_1
    ENDIF

    !--- Upper limit of Fitzpatrick and Massa fit
    CALL RF_EXTAND (rf_wl, FP_up_wl, add_1, iloc, iord)
    nwlg = nwlg + add_1

    !--- B and V Photometric band value
    CALL RF_EXTAND (rf_wl, B_band_wl, add_1, iloc, iord)
    nwlg = nwlg + add_1
    CALL RF_EXTAND (rf_wl, V_band_wl, add_1, iloc, iord)
    nwlg = nwlg + add_1

    nwlg_incr = nwlg - nwlg_incr
    WRITE(iwrit2, '("     - special values (Habing, Draine, ...) ...... ",I5)') nwlg_incr
    nwlg_incr = nwlg

    !--- Wavelength of transitions for detailed balance species
    DO k = 1, nspl
       DO ii = 1, spec_lin(k)%ntr
          wlth = spec_lin(k)%lac(ii) * 1.0e8_dp
          IF (wlth >= wlth0) THEN
             CALL RF_EXTAND (rf_wl, wlth, add_1, iloc, iord)
             nwlg = nwlg + add_1
          ENDIF
       ENDDO
       nwlg_incr = nwlg - nwlg_incr
       WRITE(iwrit2, '("     - detailed balance: ",A8," ................ ",I5)') spec_lin(k)%nam, nwlg_incr
       nwlg_incr = nwlg
    ENDDO

    !================================================================================
    ! Add the photodestruction cross sections (in UV domain) - files in data/section
    !================================================================================
    ! Loop on all photodestruction reactions computed with cross sections
    DO k = 1, nphot_i - i_mandat
       fichier = TRIM(data_dir)//'Sections/'//TRIM(csect_files(k))//".dat"
!      fichier = TRIM(data_dir)//'Sections_Marce/'//TRIM(csect_files(k))//".dat"
!      fichier = TRIM(data_dir)//'Sections_UPD/'//TRIM(csect_files(k))//".dat"
       WRITE(iscrn,*) "Opening file : ",TRIM(fichier)
       OPEN(iread2, file = fichier, status = 'old')

       ! -----------------------------------------------
       ! Count number of point above threshold
       ! -----------------------------------------------
       READ(iread2,"(2/)")
       READ(iread2,*) nb_pt  ! number of points in the file
       READ(iread2,*)

       ! -----------------------------------------------
       ! Remove points below Lyman limit
       ! -----------------------------------------------
       np_before = 0
       DO ii = 1, nb_pt
          READ (iread2,*) num, wl
          IF (wl < wl_lym) THEN
             np_before = np_before + 1
          ENDIF
       ENDDO
       nb_pt = nb_pt - np_before

       ! -----------------------------------------------
       ! Create the table containing the cross sections
       ! -----------------------------------------------
       IF (ASSOCIATED(phdest(k)%rf_esp%Val)) THEN
         CALL RF_FREE(phdest(k)%rf_esp)
       ENDIF
       CALL RF_CREATE (phdest(k)%rf_esp,1,nb_pt+1)

       ! -----------------------------------------------
       ! Jump all the points below wl_lym except for the
       ! last one (is used for interpolation at wl_lym)
       ! -----------------------------------------------
       REWIND(iread2)
       READ(iread2,"(4/)")
       IF (np_before > 1) THEN
          DO ii = 1, np_before-1
             READ(iread2,*)
          ENDDO
       ENDIF

       ! -----------------------------------------------
       ! Set the lower limit for integration
       ! Add the two first points in rf_wl
       !   1-wl_lym -> interpolation of c.s. if possible
       !            -> or c.s. equals the following data
       !   2-first point above wl_lym
       ! Cross section are stored in phdest%rf_esp
       !
       ! note: I really dislike the idea of adding a
       !       point at 912 Å regardless of the first
       !       position of ionization data - BG 04/2013
       !       e.g. : look at CH file to see the problem
       !              of extrapolating from 912 to 1458
       !       It was even worse when the first point
       !       was systematically removed (PDR v1.5.2)
       ! -----------------------------------------------
       phdest(k)%wl_cut_l_esp = wl_lym
       IF (np_before > 0) THEN
          READ (iread2,*) num, wl1, sig1
          READ (iread2,*) num, wl2, sig2
          CALL RF_EXTAND (rf_wl, wl_lym, add_1, iloc, iord)
          nwlg = nwlg + add_1
          phdest(k)%rf_esp%Val(1) = (sig1*(wl2-wl_lym)+sig2*(wl_lym-wl1))/(wl2-wl1)
          phdest(k)%rf_esp%Ord(1) = iord
          CALL RF_EXTAND (rf_wl, wl2, add_1, iloc, iord)
          nwlg = nwlg + add_1
          phdest(k)%rf_esp%Val(2) = sig2
          phdest(k)%rf_esp%Ord(2) = iord
       ELSE
          READ (iread2,*) num, wl2, sig2
          CALL RF_EXTAND (rf_wl, wl_lym, add_1, iloc, iord)
          nwlg = nwlg + add_1
          phdest(k)%rf_esp%Val(1) = sig2
          phdest(k)%rf_esp%Ord(1) = iord
          CALL RF_EXTAND (rf_wl, wl2, add_1, iloc, iord)
          nwlg = nwlg + add_1
          phdest(k)%rf_esp%Val(2) = sig2
          phdest(k)%rf_esp%Ord(2) = iord
       ENDIF

       ! -----------------------------------------------
       ! Read all the following data
       ! Extend rf_wl and store the cross sections
       ! -----------------------------------------------
       IF(nb_pt > 1) THEN
          DO ii = 3, nb_pt+1
             READ (iread2,*) num, wl1, sig1
             CALL RF_EXTAND (rf_wl, wl1, add_1, iloc, iord)
             nwlg = nwlg + add_1
             phdest(k)%rf_esp%Val(ii) = sig1
             phdest(k)%rf_esp%Ord(ii) = iord
          ENDDO
          phdest(k)%wl_cut_u_esp = wl1
       ELSE
          phdest(k)%wl_cut_u_esp = wl2
       ENDIF
       CLOSE(iread2)
       CALL RF_REVERS (wl_pointer)

       nwlg_incr = nwlg - nwlg_incr
       WRITE(iwrit2, '("     - photodestruction: ",A8," ................ ",I5)') phdest(k)%r1, nwlg_incr
       nwlg_incr = nwlg
    ENDDO

    !================================================================================
    ! Add an external radiation field
    !================================================================================
    ! In addition to an isotropic contribution (scales by radm and/or radp)
    ! we add a normal source. Three cases are possible:
    !    1 - srcpp = "F_XXXXX" : Name of a file containing the RF (e.g. Kurucz)
    !    2 - srcpp = "PP"      : Stands for "Plane Parallel" => No isotropic
    !                            contribution, but same energy density at the edge
    !    3 - srcpp = Star type : Analytic Black Body with prescribed spectral type
    !
    ! This normal RF subtends a solid angle such that "geom" = 1 - cos(theta)
    !
    ! Flag "F_Norm_RF" indicates where the radiations comes from:
    !    F_Norm_RF = 1 : from left side (or "m" - minus)
    !    F_Norm_RF = 2 : from right side (or "p" - plus)

    geom = 0.0_dp
    IF (F_Norm_RF /= 0) THEN
       ! Radiation field read in a file
       IF (srcpp(1:2) == 'F_') THEN
          PRINT *, srcpp
          fichier = TRIM(data_dir)//'Astrodata/'//srcpp
          WRITE(iscrn,*) "Opening file : ", TRIM(fichier)
          OPEN(iread2, file = fichier, status = 'old')
          READ (iread2,*) rstar
          READ (iread2,*) teff
          PRINT *, rstar, teff
          rstar = rstar * rsun
          READ (iread2,*) nb_pt
          READ (iread2,*)
          PRINT *, nb_pt

          IF (ALLOCATED(star_rf)) THEN
             DEALLOCATE(star_rf)
          ENDIF
          ALLOCATE (star_rf(nb_pt,2))

          ! Warning: for historical reasons data in file are per nanometers
          DO ii = 1, nb_pt
             READ (iread2,*) wl, rf
             wl = wl * 10.0_dp      ! convert to Angstrom
             rf = rf * 0.1_dp       ! convert to Angstr-1
             star_rf(ii,1) = wl
             star_rf(ii,2) = rf
          ENDDO
          CLOSE (iread2)

       ELSE IF (srcpp(1:2) /= 'PP') THEN

          CALL STAR

       ENDIF

       ! Dilution factor of the star emissivity as seen from the cloud
       ! geom is (1 - cos(theta_0)) so cos(theta_0) is (1.0 - geom)
       ! A second order development is adequate in most cases.
       !
       ! geom = 1 in special case "PP": see analytical derivation in notes
       IF (F_RF_PP == 1) THEN
          geom = 1.0_dp
       ELSE
          geom = 0.5_dp * (rstar/(ABS(d_sour)*pccm))**2
       ENDIF

    ENDIF

    WRITE (iscrn,*) " F_Norm_RF = ", F_Norm_RF, " F_RF_PP = ", F_RF_PP

    !================================================================================
    ! Grains absorption cross sections (interpolated from Draines data for each rad.)
    !================================================================================
    IF (ALLOCATED(sigabs)) THEN
       DO mm = 1, npg
          CALL RF_FREE(sigabs(mm))
       ENDDO
       DEALLOCATE(sigabs)
    ENDIF
    ALLOCATE(sigabs(npg))
    DO mm = 1, npg
       NULLIFY (sigabs(mm)%val,sigabs(mm)%ord)                     !SG
    ENDDO
    DO mm = 1, npg
       IF (ASSOCIATED(sigabs(mm)%Val)) THEN
          CALL RF_FREE(sigabs(mm))
       ENDIF
       CALL RF_CREATE(sigabs(mm),1,jwlmax_gr-jwlmin_gr+2)
    ENDDO

    ! ------------------------------------------------
    ! Modification of jwlmin_gr compared to PDR v1.5.2
    ! See MIXGRSI in PXDR_DRAINE_DUST.f90 - BG 04/2013
    ! ------------------------------------------------
    DO ii = jwlmin_gr, jwlmax_gr+1
       IF (ii == jwlmin_gr) THEN
          wl = wlth0
       ELSE IF (ii == jwlmax_gr+1) THEN
          wl = wlthm
       ELSE
          wl = wavgrd(ii)
       ENDIF
       CALL RF_EXTAND (rf_wl, wl, add_1, iloc, iord)
       nwlg = nwlg + add_1
       DO mm = 1, npg
          sigabs(mm)%Ord(ii-jwlmin_gr+1) = iord
       ENDDO
    ENDDO
    CALL RF_REVERS (wl_pointer)
    nwlg_incr = nwlg - nwlg_incr
    WRITE(iwrit2, '("     - Draine dust coefficients grid ............. ",I5)') nwlg_incr
    nwlg_incr = nwlg

    !================================================================================
    ! Efficiency of the photoelectric effect - fraction of energy that goes in ph-e-
    !================================================================================
    DO mm = 1, npg
       DO i = 0, noptm
          NULLIFY (eff_phel(mm,i)%val,eff_phel(mm,i)%ord)
       ENDDO
    ENDDO
    DO mm = 1, npg
       DO i = 0, noptm
          IF (ASSOCIATED(eff_phel(mm,i)%Val)) THEN
             CALL RF_FREE(eff_phel(mm,i))
          ENDIF
          CALL RF_CREATE(eff_phel(mm,i),1,jwlmax_gr-jwlmin_gr+2)
       ENDDO
    ENDDO
    DO ii = jwlmin_gr, jwlmax_gr+1
       DO mm = 1, npg
          DO i = 0, noptm
             eff_phel(mm,i)%Ord(ii-jwlmin_gr+1) = sigabs(mm)%Ord(ii-jwlmin_gr+1)
             eff_phel(mm,i)%Val(ii-jwlmin_gr+1) = 1.0_dp / xpi * ( xpi / 2.0_dp &
             - ATAN(2.e-2_dp*(rf_wl%Val(wl_pointer(eff_phel(mm,i)%Ord(ii-jwlmin_gr+1))) &
             -5.e2_dp)))
          ENDDO
       ENDDO
    ENDDO

    PRINT *, " 1st pass:  nwlg =", nwlg

    IF (rf_wl%upper /= nwlg) THEN
       PRINT *, "Probleme"
    ENDIF
    CALL RF_REVERS (wl_pointer)

    !================================================================================
    !****From here, the set of wavelength is complete and should not be modified*****
    !================================================================================

    !-------------------------------------------
    ! Initialisation of external radiation Field
    !-------------------------------------------
    IF (ASSOCIATED(rf_incIm%Val)) THEN
       CALL RF_FREE(rf_incIm)
    ENDIF
    CALL RF_CREATE (rf_incIm, 0, nwlg)
    IF (ASSOCIATED(rf_incIp%Val)) THEN
       CALL RF_FREE(rf_incIp)
    ENDIF
    CALL RF_CREATE (rf_incIp, 0, nwlg)

    !-------------------------------------------
    ! Initialisation of internal radiation Field
    !-------------------------------------------
    IF (ASSOCIATED(rf_u%Val)) THEN
       CALL RF_FREE(rf_u)
    ENDIF
    CALL RF_CREATE (rf_u, 0, nwlg)

    !----------------------------------------------------------------------------------
    ! Fitzpatrick and Massa extinction curves
    ! We use the Fitzpatrick and Massa expressions for the grains extinction
    ! Their expression gives E(lambda-V) / E(B-V)
    ! rf_expou%Val = [1 - 1/Rv * E(lambda-V) / E(B-V)]
    !
    ! Modification 24th june 2010
    ! If the name of the line of sight is sig1.9, we use :
    ! - from 912 to 1070 Ang (9.35 mum-1) : sigma_dust = 1.9E-21 (=> E(lambda-V) / E(B-V) = 8.8648)
    ! - above 1070 Ang                    : Galactic extinction curve
    !----------------------------------------------------------------------------------

    IF (ASSOCIATED(rf_extpou%Val)) THEN
       CALL RF_FREE(rf_extpou)
    ENDIF
    CALL RF_CREATE (rf_extpou, 0, nwlg)
    IF (ASSOCIATED(rf_tmp%Val)) THEN
       CALL RF_FREE(rf_tmp)
    ENDIF
    CALL RF_CREATE (rf_tmp, 0, nwlg)
    rf_tmp%Val = 1.0e4_dp / rf_wl%Val

    ! Create extinction curve from analytical fits
    ! 1 - UV slope and 2200 A bump
    !     lowest cut off at the Lyman limit (BG 04/2013)
    CALL RF_LOCATE (rf_wl, wl_lym, I_cut_L)
    wl_cut = FP_up_wl
    CALL RF_LOCATE (rf_wl, wl_cut, I_cut)
    rf_extpou%Val(I_cut_L:I_cut) = cc1 + cc2 * rf_tmp%Val(I_cut_L:I_cut) &
                                 + cc3 * (rf_tmp%Val(I_cut_L:I_cut) * rf_tmp%Val(I_cut_L:I_cut) &
                                 / ((rf_tmp%Val(I_cut_L:I_cut) * rf_tmp%Val(I_cut_L:I_cut) - y0 * y0)**2 &
                                 + xgam * xgam * rf_tmp%Val(I_cut_L:I_cut) * rf_tmp%Val(I_cut_L:I_cut)))

    ! 2 - Far UV rise
    !     lowest cut off at the Lyman limit (BG 04/2013)
    wl_cut_F = 1.0e4_dp / 5.9_dp
    CALL RF_LOCATE (rf_wl, wl_cut_F, I_cut_F)
    rf_extpou%Val(I_cut_L:I_cut_F) = rf_extpou%Val(I_cut_L:I_cut_F) &
                                   + cc4 * (0.5392_dp * (rf_tmp%Val(I_cut_L:I_cut_F)-5.9_dp)**2 &
                                   + 0.0564_dp * (rf_tmp%Val(I_cut_L:I_cut_F)-5.9_dp)**3)

    ! 3 - IR analytical fit (using Galactic values from FP (2009) ApJ 699, 1209)
    !     Equation (5), used with alpha from BD+61 2365
    wl_cut = 1.0e4_dp
    CALL RF_LOCATE (rf_wl, wl_cut, I_cut)
    wl_cut_F = 4.4e4_dp
    CALL RF_LOCATE (rf_wl, wl_cut_F, I_cut_F)
    rf_extpou%Val(I_cut:I_cut_F) = (0.349_dp + 2.087_dp * rrv) / (1.0_dp &
                                 + (1.0_dp / (0.507_dp*rf_tmp%Val(I_cut:I_cut_F))**2.28_dp)) - rrv

    ! 4 - IR rise at 18 microns as obtained with dustem and with Draine's data
    wl_cut = 4.4e4_dp
    CALL RF_LOCATE (rf_wl, wl_cut, I_cut)
    wl_cut_F = 1.82e5_dp
    CALL RF_LOCATE (rf_wl, wl_cut_F, I_cut_F)
    rf_extpou%Val(I_cut:I_cut_F) = rf_extpou%Val(I_cut) + 0.015_dp * ( (1.0_dp / &
                                 & rf_tmp%Val(I_cut:I_cut_F) - wl_cut/1.0e4_dp) / 10.0_dp )**2.0

    ! 5 - IR bump at 10 microns as obtained with dustem and with Draine's data
    wl_cut = 1.0e4_dp
    CALL RF_LOCATE (rf_wl, wl_cut, I_cut)
    rf_extpou%Val(I_cut:) = rf_extpou%Val(I_cut:) + 2.0_dp*rf_tmp%Val(I_cut:) &
                          * DEXP(-((DLOG(1.0_dp/rf_tmp%Val(I_cut:))-2.3_dp)/0.18_dp)**2.0_dp)

    ! 6 - FIR decreasing queue as obtained with dustem and with Draine's data
    wl_cut = 1.82e5_dp
    CALL RF_LOCATE (rf_wl, wl_cut, I_cut)
    rf_extpou%Val(I_cut:) = (rf_extpou%Val(I_cut) + rrv) * (1.0_dp + rf_tmp%Val(I_cut)**(-1.75_dp)) / &
                          & (1.0_dp + rf_tmp%Val(I_cut:)**(-1.75_dp)) - rrv

    ! 7 - Visible: use 3 linear interpolation from 1 micron to V, from V to B and from B to UV cutoff (Ext = 0 at V and 1 at B)
    wl_cut = 1.0e4_dp
    CALL RF_LOCATE (rf_wl, wl_cut, I_cut)
    wl_cut = V_band_wl
    CALL RF_LOCATE (rf_wl, wl_cut, I_cut_F)
    rf_extpou%Val(I_cut_F:I_cut) = rf_extpou%Val(I_cut) - rf_extpou%Val(I_cut) &
                                 * (rf_tmp%Val(I_cut_F:I_cut) - 1.0_dp) &
                                 / ( 1.0e4_dp / V_band_wl -  1.0_dp)

    I_cut = I_cut_F
    wl_cut = B_band_wl
    CALL RF_LOCATE (rf_wl, wl_cut, I_cut_F)
    rf_extpou%Val(I_cut_F:I_cut) = rf_extpou%Val(I_cut) + (1.0_dp - rf_extpou%Val(I_cut)) &
                                 * (rf_tmp%Val(I_cut_F:I_cut) - 1.0e4_dp / V_band_wl) &
                                 / ( 1.0e4_dp / B_band_wl -  1.0e4_dp / V_band_wl)

    I_cut = I_cut_F
    wl_cut = FP_up_wl
    CALL RF_LOCATE (rf_wl, wl_cut, I_cut_F)
    rf_extpou%Val(I_cut_F:I_cut) = rf_extpou%Val(I_cut) + (rf_extpou%Val(I_cut_F) - 1.0_dp) &
                                 * (rf_tmp%Val(I_cut_F:I_cut) - 1.0e4_dp / B_band_wl) &
                                 / ( 1.0e4_dp / FP_up_wl -  1.0e4_dp / B_band_wl)

    IF (los_ext == "sig1.9") THEN
       wl_cut_F2 = 1.0e4_dp / 9.346_dp
       CALL RF_LOCATE (rf_wl, wl_cut_F2, I_cut_F2)
       rf_extpou%Val(I_cut_L:I_cut_F2) = 8.8648_dp ! value to get grain abs. cross section = 1.9E-21 cm2
    ENDIF

    rf_extpou%Val = 1.0_dp + rf_extpou%Val / rrv
    rf_extpou%Ord = (/ (ii, ii=rf_extpou%lower,rf_extpou%upper) /)

    CALL RF_FREE (rf_tmp)

    !--------------------------------------------------------------------------
    ! Compute Planck function over a fixed dust temperature grid
    !--------------------------------------------------------------------------
    DO i = 1, nTd
       IF(ASSOCIATED(rf_Plint(i)%Val)) CALL RF_FREE(rf_Plint(i))
       CALL RF_CREATE (rf_Plint(i), 0, nwlg)
       DO ii = 0, nwlg
          rf_Plint(i)%Val(ii) = BBL (rf_wl%Val(ii), Tdposs(i))
          rf_Plint(i)%Ord(ii) = rf_wl%Ord(ii)
       ENDDO
    ENDDO

    !----------------------------------------------------------------
    ! Set dust properties (absorption, scattering, emission, g factor
    !----------------------------------------------------------------

    IF (ALLOCATED(J_du_pro)) DEALLOCATE(J_du_pro)
    PRINT *, " Enter DUST_PROPERTIES - 1"
    CALL DUST_PROPERTIES

    !--------------------------------------------------------------------------------
    ! A first approximation of distances is needed for the following initialisations
    !--------------------------------------------------------------------------------

    IF (ALLOCATED(d_cm)) THEN
       DEALLOCATE(d_cm)
       DEALLOCATE(dd_cm)
    ENDIF
    ALLOCATE(d_cm(0:npo))
    ALLOCATE(dd_cm(0:npo))
    d_cm(:) = 0.0_dp
    dd_cm(:) = 0.0_dp
    CALL RF_LOCATE (rf_wl, V_band_wl, iloc)
    DO i = 1, npo ! d_cm(0) = 0
       dd_cm(i) = (1.0_dp / ((du_prop%abso(iloc) + du_prop%scat(iloc)) * dens_o(i)) &
                  + 1.0_dp / ((du_prop%abso(iloc) + du_prop%scat(iloc)) * dens_o(i-1))) &
                  * 0.5_dp * dtau_o(i)
       d_cm(i) = d_cm(i-1) + dd_cm(i)
    ENDDO

    !----------------------------------------
    ! Set radiation field boundary conditions
    !----------------------------------------

    IF (ALLOCATED(tmp_wl)) DEALLOCATE(tmp_wl)
    ALLOCATE(tmp_wl(0:nwlg))
    tmp_wl(0:nwlg) = rf_wl%Val(0:nwlg)
    IF (ALLOCATED(intJmp)) DEALLOCATE (intJmp)
    ALLOCATE (intJmp(0:npo,0:nwlg))
    intJmp(0:npo,0:nwlg) = 0.0_dp

    CALL RF_BOUND

    !================================================================================
    ! Create a first very crude approximation to the radiation field
    !================================================================================

    IF (ALLOCATED(intJmp)) THEN
       DEALLOCATE (intJmp)
    ENDIF
    IF (ALLOCATED(intJm)) THEN
       DEALLOCATE (intJm, intJp)
    ENDIF
    ALLOCATE (intJm(0:npo,0:nwlg))
    ALLOCATE (intJp(0:npo,0:nwlg))
    ALLOCATE (intJmp(0:npo,0:nwlg))
    ! -----------------------------------------
    ! This loop takes some code from subroutine
    ! DUST_PROPERTIES to compute a dust extinc-
    ! tion coefficient from Draine's data. It
    ! also takes a code from subroutine ABSGAZ
    ! to compute gas extinction coefficients.
    ! This is used to compute a wavelength
    ! dependant optical depth. BG 04/2013
    ! -----------------------------------------
    DO j = 0, nwlg
       wlth = rf_wl%Val(j)
       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
       ! -----------------------------------------
       ! 1 - absor  = absorption, summed over size
       ! 2 - scater = scattering, summed over size
       !
       ! Extrapolations are required at small and
       ! large wavelengths - BG 04/2013
       ! ** power laws except for le_g
       ! ** linear interpolation otherwise
       ! -----------------------------------------
       absor  = 0.0_dp
       scater = 0.0_dp
       IF (il1 == 0) 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
          ENDDO
       ELSE 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(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
          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
          ENDDO
       ENDIF
       extinct = (absor + scater) * dens_o(0)

       ! --------------------------------------------
       ! Initial approximation of the radiation field
       ! --------------------------------------------
       DO ii = 0, npo
          intJm(ii,j) = (rf_incIm%Val(j) + I_incr_m(j)) * EXP(-extinct*d_cm(ii))
          intJp(ii,j) = (rf_incIp%Val(j) + I_incr_p(j)) * EXP(-extinct*(d_cm(npo) - d_cm(ii)))
          intJmp(ii,j) = (intJm(ii,j) + intJp(ii,j)) * 0.5_dp
       ENDDO
    ENDDO

    !--------------------------------------
    ! Variables used in PDR_DUSTEM - part 2
    !--------------------------------------

    IF (ALLOCATED(J_du_pro)) DEALLOCATE(J_du_pro)
    ALLOCATE (J_du_pro(0:npo,0:nwlg))
    J_du_pro(0:npo,0:nwlg) = intJmp(0:npo,0:nwlg)

    !---------------------------------------------------------------------
    ! Create RF_TYPE objects and tables used in FBTH (stv5c.f)
    !---------------------------------------------------------------------

    IF (ALLOCATED (si_)) THEN
       DEALLOCATE(si_)
    ENDIF
    ALLOCATE (si_(rf_wl%lower:rf_wl%upper))
    IF (ALLOCATED (si_QU)) THEN
       DEALLOCATE(si_QU)
    ENDIF
    ALLOCATE (si_QU(npg,rf_wl%lower:rf_wl%upper))
    IF (ALLOCATED (si_QUl)) THEN
       DEALLOCATE(si_QUl)
    ENDIF
    ALLOCATE (si_QUl(npg,rf_wl%lower:rf_wl%upper))
    IF (ALLOCATED (si_QUl2)) THEN
       DEALLOCATE(si_QUl2)
    ENDIF
    ALLOCATE (si_QUl2(npg,rf_wl%lower:rf_wl%upper))

    PRINT *, "##########   nwlg =", nwlg

END SUBROUTINE RF_INIT

!******************
SUBROUTINE RF_BOUND
!******************

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

    IMPLICIT NONE

    REAL (KIND=dp)                             :: wl_cut_D =1.0e5_dp   ! Draine field cutoff wavelength (extended)
    INTEGER                                    :: I_cut_D              ! Draine field cutoff position in grid
    REAL (KIND=dp)                             :: wl_cut_V = 8000.0_dp ! Visible cutoff wavelength
    INTEGER                                    :: I_cut_V              ! Index in wavelength Grid of visible cutoff
    INTEGER                                    :: I_cut_L              ! Index in wavelength Grid of Lyman cutoff
    INTEGER                                    :: ii
    TYPE (RF_TYPE)                             :: rf_tmp, rf_lamI

    REAL(KIND=dp), DIMENSION (:), ALLOCATABLE  :: perp_RF_m, perp_RF_p
    REAL(KIND=dp)                              :: wlth
    INTEGER                                    :: i1, i2, i_l, iwlg

   TYPE (RF_TYPE)                              :: rf_incI_c1          !  Component 1 of incident radiation field
                                                                      !  (scaled by radm, [resp. radp])
   TYPE (RF_TYPE)                              :: rf_incI_c2          !  Component 2 of incident radiation field(unscaled)
   TYPE (RF_TYPE)                              :: rf_incI_c3          !  Component 3 of incident radiation field (unscaled)
   TYPE (RF_TYPE)                              :: rf_incI_c4          !  Component 4 of incident radiation field (unscaled)

   ! Variables pour ajouter le champs IR cree par DUSTEM.
   REAL (KIND=dp)                              :: a_IR        ! Coefficients to fit the amount of pah
   REAL (KIND=dp)                              :: b_IR        ! Coefficients to fit the amount of vsg
   REAL (KIND=dp)                              :: c_IR        ! Coefficients to fit the amount of bg
   REAL (KIND=dp)                              :: NH_IR       ! Column density to fit the IR data.
   REAL (KIND=dp)                              :: pah_IR      ! 4*pi*I_lambda des PAH (erg s-1 H-1 A-1 sr-1)
   REAL (KIND=dp)                              :: vsg_IR      ! 4*pi*I_lambda des VSG (erg s-1 H-1 A-1 sr-1)
   REAL (KIND=dp)                              :: bg_IR       ! 4*pi*I_lambda des BG  (erg s-1 H-1 A-1 sr-1)
   REAL (KIND=dp), ALLOCATABLE, DIMENSION(:)   :: wl_ir_cpn   ! Longueurs d'onde pour lesquels on a des donnees (A)
   REAL (KIND=dp), ALLOCATABLE, DIMENSION(:)   :: IR_ir_cpn   ! 4*pi*I_lambda totale (erg s-1 H-1 A-1 sr-1)
   INTEGER, PARAMETER                          :: nwlg_ir_cpn = 1500 ! Nombre de points en longueur d'onde
   INTEGER                                     :: j_IR        ! Integer pour faire les boucles.

   ! These constants fit the mean intensity from the outside of the clump
   ! in the case of a perpendicular contribution
   ! Computed with L = 19
   ! Check that it is independant of L (JLB - 25 XII 2013)
   REAL (KIND=dp)                              :: d_pp = 0.0088161_dp
   REAL (KIND=dp)                              :: c_pp = 0.358332_dp
   REAL (KIND=dp)                              :: x_pp = 4.07632_dp
   REAL (KIND=dp)                              :: bet_pp

   INTEGER                                     :: i

    !==================================================================================
    ! Use the correct number of Legendre polynomial roots
    !==================================================================================

    IF (.NOT. ALLOCATED(xmui_M)) THEN
       ALLOCATE (xmui_M(nmui))
       ALLOCATE (AngleLeg_deg(nmui))
    ENDIF
    !xmui_M = xmui32
    !xmui_M = xmui15
    xmui_M = xmui10
    !xmui_M = xmui06

    ! Angle in degrees of Legendre decomposition
    DO i = 1, nmui ! angle
       AngleLeg_deg(i) = ACOS(xmui_M(i)) * 180.0_dp / xpi
    ENDDO

    !===================================================================================
    ! CREATION OF THE INCIDENT RADIATION FIELD
    !===================================================================================
    ! The radiation field from Far-UV to submillimeter is build by 4 components
    ! - component 1 : Far UV
    ! - component 2 : Near UV, Visible, near I.R.
    ! - component 3 : CMB
    ! - component 4 : I.R.
    ! Draine Formula: Specific intensity
    ! Radiation field in erg cm-2 s-1 A-1 sterad-1
    !===================================================================================
    IF (ASSOCIATED(rf_incI_c1%Val)) THEN
       CALL RF_FREE (rf_incI_c1)
    ENDIF
    CALL RF_CREATE (rf_incI_c1, 0, nwlg)
    IF (ASSOCIATED(rf_incI_c2%Val)) THEN
       CALL RF_FREE (rf_incI_c2)
    ENDIF
    CALL RF_CREATE (rf_incI_c2, 0, nwlg)
    IF (ASSOCIATED(rf_incI_c3%Val)) THEN
       CALL RF_FREE (rf_incI_c3)
    ENDIF
    CALL RF_CREATE (rf_incI_c3, 0, nwlg)
    IF (ASSOCIATED(rf_incI_c4%Val)) THEN
       CALL RF_FREE (rf_incI_c4)
    ENDIF
    CALL RF_CREATE (rf_incI_c4, 0, nwlg)

    !--------------------------------------------------------------------------------
    ! Component 1 : Far-UV
    !--------------------------------------------------------------------------------
    CALL RF_LOCATE (rf_wl, wl_lym, I_cut_L)
    IF (F_ISRF == 1) THEN  ! Mathis
       ISRF_name = "MMP83+JB  "
       ! Far UV (fit JLB Jan 2008)
       CALL RF_LOCATE (rf_wl, wl_cut_V, I_cut_V)
       rf_incI_c1%Val(I_cut_L:i_cut_V) = (TANH(4.07e-3_dp*rf_wl%Val(I_cut_L:i_cut_V)-4.5991_dp) + 1.0_dp) &
                                       * 107.192_dp * rf_wl%Val(I_cut_L:i_cut_V)**(-2.89_dp)
       rf_incI_c1%Val(i_cut_V+1:nwlg)  = 2.0_dp * 107.192_dp * rf_wl%Val(i_cut_V+1:nwlg)**(-2.89_dp)
       rf_incI_c1%Ord = (/ (ii, ii=rf_incI_c1%lower,rf_incI_c1%upper) /)

    ELSE IF (F_ISRF == 2) THEN ! Draine

       ISRF_name = "Draine  "
       ! Draine's formula extended to 10000.0 A to give a smooth transition to Visible
       ! 2 Fev 2012 - JLB - Still not enough for Rad = 1.0e5 (required by Leiden Workshop)
       !                    Extend to 1.0e5 A = 10 micron
       CALL RF_LOCATE (rf_wl, wl_cut_D, I_cut_D)
       ! Draine 1978 radiation field
       ! Expression from M. Kopp PhD thesis page 284, from Sternberg and Dalgarno 1985.
       rf_incI_c1%Val(I_cut_L:I_cut_D) = 6.36E7_dp / rf_wl%Val(I_cut_L:I_cut_D)**4 &
                                       - 1.0237E11_dp / rf_wl%Val(I_cut_L:I_cut_D)**5 &
                                       + 4.0812E13_dp / rf_wl%Val(I_cut_L:I_cut_D)**6
       rf_incI_c1%Val = rf_incI_c1%Val / (4.0 * xpi) ! rf_incI is now in erg cm-2 s-1 str-1 A-1
       rf_incI_c1%Ord = (/ (ii, ii=rf_incI_c1%lower,rf_incI_c1%upper) /)
    ENDIF

    !--------------------------------------------------------------------------------
    ! Component 2 : Near-UV, visible, near I.R
    !--------------------------------------------------------------------------------
    ! 3 diluted Black Bodies (from Mathis, Mezger and Panagia 1983, A&A, 128, 212)
    ! Values revised by JLB to take account of far UV.
    !    6 IV 2010
    ! Fit redone by JLB to bring into accordance with DIRBE data provided by Francois Boulanger
    ! Note: still 3 BB component although the first 2 are almost degenerate. Suppress one?
    !--------------------------------------------------------------------------------
    DO ii = 0, nwlg
    !  rf_incI_c2%Val(ii) = 1.05e-14_dp * BBL(rf_wl%Val(ii),7127.0_dp) &
    !                     + 1.28e-13_dp * BBL(rf_wl%Val(ii),4043.0_dp) &
    !                     + 3.30e-13_dp * BBL(rf_wl%Val(ii),2930.0_dp)
       rf_incI_c2%Val(ii) = 2.07e-14_dp * BBL(rf_wl%Val(ii),6184.0_dp) &
                          + 1.09e-14_dp * BBL(rf_wl%Val(ii),6123.0_dp) &
                          + 1.52e-12_dp * BBL(rf_wl%Val(ii),2539.0_dp)
    ENDDO
    rf_incI_c2%Ord = (/ (ii, ii=rf_incI_c1%lower,rf_incI_c1%upper) /)

    !--------------------------------------------------------------------------------
    ! Component 3 : CMB
    !--------------------------------------------------------------------------------
    rf_incI_c3%Ord = (/ (ii, ii=rf_incI_c1%lower,rf_incI_c1%upper) /)
    DO ii = 0, nwlg
       rf_incI_c3%Val(ii) = BBL(rf_wl%Val(ii),tcmb)
    ENDDO

    !--------------------------------------------------------------------------------
    ! Component 4 : Dust contribution to the IR
    !--------------------------------------------------------------------------------
    ! Manuel Gonzalez-Garcia, 20 november 2008
    ! This component has been estimated thanks to the DUSTEM code
    !--------------------------------------------------------------------------------
    ! Coefficients to fit IR Interstellar field from DUSTEM code are:
    a_IR = 52.5593_dp
    b_IR = 75.0854_dp
    c_IR = 16.1213_dp
    NH_IR = 1.0e20_dp
    ! Allocate the variable IR, which will contain data of the IR interstellar field.
    ALLOCATE(IR_ir_cpn(nwlg_ir_cpn))
    ALLOCATE(wl_ir_cpn(nwlg_ir_cpn))
    OPEN(iwrtmp,file='./../data/Astrodata/IR_field_dustem.dat',status='old')
    DO ii = 1, nwlg_ir_cpn
       READ(iwrtmp,*) wl_ir_cpn(ii), pah_IR, vsg_IR, bg_IR
       IR_ir_cpn(ii) = (a_IR*pah_IR + b_IR*vsg_IR + c_IR*bg_IR) * NH_IR
    ENDDO
    CLOSE(iwrtmp)

    rf_incI_c4%Ord = (/ (ii, ii=rf_incI_c1%lower,rf_incI_c1%upper) /)
    DO ii = 0,nwlg
       ! 31 Oct 2011 - Change upper value
       ! IF (rf_wl%Val(ii) < 1.0e4_dp .OR. rf_wl%Val(ii) > 8.0e6_dp ) THEN
       IF (rf_wl%Val(ii) < 1.0e4_dp) THEN
          rf_incI_c4%Val(ii) = 0.0_dp
       ELSE
          DO j_IR = 1, nwlg_ir_cpn-1
             IF (rf_wl%Val(ii) >= wl_ir_cpn(j_IR) .AND. rf_wl%Val(ii) < wl_ir_cpn(j_IR+1)) THEN
                rf_incI_c4%Val(ii) = IR_ir_cpn(j_IR) &
                                   + (IR_ir_cpn(j_IR+1) - IR_ir_cpn(j_IR)) &
                                   * (rf_wl%Val(ii)-wl_ir_cpn(j_IR)) &
                                   / (wl_ir_cpn(j_IR+1)-wl_ir_cpn(j_IR))
             ENDIF
          ENDDO
       ENDIF
    ENDDO

    DEALLOCATE(IR_ir_cpn)
    DEALLOCATE(wl_ir_cpn)

    !===================================================================================
    ! BUILD FULL SPECTRUM (unscaled)
    !===================================================================================
    rf_incIm%Ord = rf_incI_c1%Ord
    rf_incIm%Val = rf_incI_c1%Val + rf_incI_c2%Val + rf_incI_c3%Val + rf_incI_c4%Val

    !===================================================================================
    ! COMPUTE THE RADIATION FIELD INTEGRATED ENERGY IN FREE SPACE (TAKEN FROM STV2Z.F90)
    !===================================================================================

     CALL RF_CREATE(rf_lamI,0,nwlg)
     rf_lamI%Val = rf_wl%Val * rf_incIm%Val

    !--------------------------------------------------------------------------------
    ! Integration of UV radiation field from Lyman up to Habing limit
    ! (wl_lym = 911 Å ; wl_hab = 2400 Å) - BG 04/2013
    !     change to wl_6ev to compute up to 6 eV
    !--------------------------------------------------------------------------------
     CALL RF_CREATE(rf_tmp,1,2)
     CALL RF_LOCATE(rf_wl, wl_lym, i1)
     rf_tmp%Val(1) = 1.0_dp
     rf_tmp%Ord(1) = rf_wl%Ord(i1)
     CALL RF_LOCATE(rf_wl, wl_hab, i2)
     rf_tmp%Val(2) = 1.0_dp
     rf_tmp%Ord(2) = rf_wl%Ord(i2)
     int_rad0 = SECT_INT(rf_tmp, rf_incIm, wl_pointer, wl_hab) * J_to_u
     flu_rad0 = SECT_INT(rf_tmp, rf_lamI,  wl_pointer, wl_hab) * J_to_u / (1.0e8_dp * xhp)
     CALL RF_FREE (rf_lamI)
     CALL RF_FREE (rf_tmp)

     PRINT *, " "
     PRINT *, " Standard field in free space:"
     WRITE (iscrn, '("  U0_UV:",1pe12.4," erg cm-3,     ","from",0pf9.2," to",0pf9.2," Angstrom")') int_rad0,  wl_lym,  wl_hab
     WRITE (iscrn, '("  F0_UV:",1pe12.4," phot cm-2 s-1,","from",0pf9.2," to",0pf9.2," Angstrom")') flu_rad0,  wl_lym,  wl_hab
     WRITE (iwrit2,'("  U0_UV:",1pe12.4," erg cm-3,     ","from",0pf9.2," to",0pf9.2," Angstrom")') int_rad0,  wl_lym,  wl_hab
     WRITE (iwrit2,'("  F0_UV:",1pe12.4," phot cm-2 s-1,","from",0pf9.2," to",0pf9.2," Angstrom")') flu_rad0,  wl_lym,  wl_hab

    ! Now scale left and right side differently:
    rf_incIm%Val = radm_ini * rf_incI_c1%Val + rf_incI_c2%Val + rf_incI_c3%Val + rf_incI_c4%Val
    IF (isoneside == 0) THEN
       rf_incIp%Val = radp_ini * rf_incI_c1%Val + rf_incI_c2%Val + rf_incI_c3%Val + rf_incI_c4%Val
    ELSE
       rf_incIp%Val = radp_ini * (rf_incI_c1%Val + rf_incI_c2%Val + rf_incI_c4%Val) + rf_incI_c3%Val
    ENDIF
    ! 30 oct 2011: try enhancing also the IR field to pump CO
    !rf_incIm%Val = radm_ini * rf_incI_c1%Val + rf_incI_c2%Val + rf_incI_c3%Val + radm_ini * rf_incI_c4%Val
    !rf_incIp%Val = radp_ini * rf_incI_c1%Val + rf_incI_c2%Val + rf_incI_c3%Val + radp_ini * rf_incI_c4%Val

    !===================================================================================
    ! NORMAL - EXTERNAL RADIATION FIELD
    ! An external radiation field, e.g. from a star, is added if d_sour .NE. 0 or srcpp is set to a flag
    ! d_sour > 0 : the star is on the back side of the cloud
    ! d_sour < 0 : the star is on the observer side of the cloud
    !===================================================================================

    ! Everywhere in this block: tag "m" for left side, "p" for right side
    IF (ALLOCATED(I_incr_m)) DEALLOCATE (I_incr_m)
    IF (ALLOCATED(I_incr_p)) DEALLOCATE (I_incr_p)
    ALLOCATE (I_incr_m(0:nwlg))
    ALLOCATE (I_incr_p(0:nwlg))
    I_incr_m = 0.0_dp
    I_incr_p = 0.0_dp
    IF (F_Norm_RF /= 0) THEN

       ALLOCATE (perp_RF_m(0:nwlg))
       ALLOCATE (perp_RF_p(0:nwlg))

       IF (srcpp(1:2) == 'F_') THEN
          i_l = 1
          DO iwlg = 0, nwlg
             wlth = rf_wl%Val(iwlg)
             CALL INTERP_X (wlth, perp_RF_m(iwlg), i_l)
          ENDDO
          perp_RF_p = perp_RF_m
       ELSE IF (F_RF_PP == 1) THEN
          DO iwlg = 0, nwlg
             perp_RF_m(iwlg) = rf_incIm%Val(iwlg)
             perp_RF_p(iwlg) = rf_incIp%Val(iwlg)
          ENDDO
       ELSE
          DO iwlg = 0, nwlg
             perp_RF_m(iwlg) = BBL(rf_wl%Val(iwlg),teff)
          ENDDO
          perp_RF_p = perp_RF_m
       ENDIF

       ! Add here computation of I_incr_m and I_incr_p from note
       !------------------------------------------------------------------------
       ! Perpendicalar RF on the observer side of the cloud (F_Norm_RF == 1)
       !------------------------------------------------------------------------
       IF (F_Norm_RF == 1) THEN
          IF (F_RF_PP == 0) THEN
             DO iwlg = 0, nwlg
                IF (rf_incIm%Val(iwlg) /= 0.0_dp) THEN
                   bet_pp = LOG(0.5_dp * ((1.0_dp - geom) + geom * perp_RF_m(iwlg) / rf_incIm%Val(iwlg)))
                   IF (bet_pp > LOG(0.5_dp)) THEN
                      I_incr_m(iwlg) = rf_incIm%Val(iwlg) &
                                     * EXP(0.5_dp * (x_pp*x_pp + 4.0_dp*c_pp - &
                                       (x_pp - LOG(0.25_dp) + 2.0_dp*bet_pp)**2 ) &
                                     / (LOG(0.25_dp) - 2.0_dp * bet_pp))
                   ENDIF
                ENDIF
             ENDDO
          ELSE IF (F_RF_PP == 1) THEN !--- Case of a beamed ISRF
             DO iwlg = 0, nwlg
                I_incr_m(iwlg) = perp_RF_m(iwlg) * 0.5_dp * geom / d_pp
             ENDDO
          ENDIF
       !------------------------------------------------------------------------
       ! Perpendicalar RF on the back side of the cloud (F_Norm_RF == 2)
       !------------------------------------------------------------------------
       ELSE IF (F_Norm_RF == 2) THEN
          IF (F_RF_PP == 0) THEN !-- Star
             DO iwlg = 0, nwlg
                IF (rf_incIp%Val(iwlg) /= 0.0_dp) THEN
                   bet_pp = LOG(0.5_dp * ((1.0_dp - geom) + geom * perp_RF_p(iwlg) / rf_incIp%Val(iwlg)))
                   IF (bet_pp > LOG(0.5_dp)) THEN
                      I_incr_p(iwlg) = rf_incIp%Val(iwlg) &
                                     * EXP(0.5_dp * (x_pp*x_pp + 4.0_dp*c_pp - &
                                       (x_pp - LOG(0.25_dp) + 2.0_dp*bet_pp)**2 ) &
                                     / (LOG(0.25_dp) - 2.0_dp * bet_pp))
                   ENDIF
                ENDIF
             ENDDO
          ELSE IF (F_RF_PP == 1) THEN !--- Case of a beamed ISRF
             DO iwlg = 0, nwlg
                I_incr_p(iwlg) = perp_RF_p(iwlg) * 0.5_dp * geom / d_pp
             ENDDO
          ENDIF
       ENDIF

       !------------------------------------------------------------------------
       ! Switch off isotropic contribution for beamed ISRF
       !------------------------------------------------------------------------
       IF (F_RF_PP == 1) THEN
          DO iwlg = 0, nwlg
             rf_incIm%Val(iwlg) = 0.0_dp
             rf_incIp%Val(iwlg) = 0.0_dp
          ENDDO
       ENDIF
    ENDIF

!   VERIFICATION DU CHAMP
!     OPEN (iwrtmp,file="toto.dat",status="unknown",action="WRITE")
!     DO ii = 0,nwlg
!        WRITE(iwrtmp,*) rf_wl%Val(ii), rf_incIm%Val(ii)
!     ENDDO
!     CLOSE(iwrtmp)
!     PRINT *,"Fin d'ecriture du champ initial dans toto.dat"
!     STOP

    CALL RF_FREE (rf_incI_c1)
    CALL RF_FREE (rf_incI_c2)
    CALL RF_FREE (rf_incI_c3)
    CALL RF_FREE (rf_incI_c4)
    IF (ALLOCATED(perp_RF_m)) THEN
       DEALLOCATE (perp_RF_m)
       DEALLOCATE (perp_RF_p)
    ENDIF

END SUBROUTINE RF_BOUND

END MODULE PXDR_RF_INIT
