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

!*****************************************************************************************
! Radiation Field manipulations tools
!*****************************************************************************************
MODULE PXDR_RF_TOOLS

   USE PXDR_CONSTANTES
   USE PXDR_PROFIL
   USE PXDR_STR_DATA

   IMPLICIT NONE

   ! RF_TYPE is used for all wavelength dependant quantities.
   !         indexes go from lower to upper (the user does have to care if lower = 0 or not)
   !         Values are in member Val. They must be ordered in increasing order of WaveLength
   !         Ord is used to retrieve the Wave Length value from object rf_wl
   !         rf_wl%Ord(i) is the rank at which rf_wl%val(i) has been entered in rf_wl
   !         A specific vector (wl_pointer) is used to retrieve i from a given iord
   !         Thus rf_wl may been unevenly spaced, and values entered in any order

   ! A special set of SUBROUTINEs and FUNCTIONs is provided to manipulate RF_TYPE objects
   !
   !   SUBROUTINE RF_CREATE (rf_xx, ll, uu)
   !              creates object rf_xx, and ALLOCATEs Val and Ord from ll to uu
   !   SUBROUTINE RF_FREE (rf_xx)
   !              DEALLOCATEs rf_xx%Val and rf_xx%Ord
   !   SUBROUTINE RF_EXTAND (rf_xx, x, add_1, iloc, iord)
   !              add values x in rf_xx%Val. Val must be orderered in ascending order
   !              x is inserted at its proper rank and the routine returns its location (iloc)
   !              and its ordering number (iord). Note that iloc may vary as new values are added
   !              but iord never changes.
   !              If x is allready in rf_xx, add_1 returns with value 0. If not, add_1 = 1
   !              RF_EXTAND was created and is currently used only to add new wavelengths in
   !              rf_wl
   !   SUBROUTINE RF_LOCATE (rf_xx, x, j)                : created in MODULE PXDR_STR_DATA
   !              returns index j such that rf_xx%Val(i) <= x < rf_xx%Val(i+1)
   !              IF x is outside rf_xx%Val, returns either lower or upper as appropriate
   !              rf_xx%Val must be ordered in ascending order.
   !   SUBROUTINE SHELL_SORT (rf_xxin, rf_xxout)
   !              Sorts rf_object rf_xxin in ascending order
   !   SUBROUTINE RF_REVERS (rindex)
   !              Builds vector wl_pointer used to retrieve location of a given wavelength
   !              from its ordering number.
   !   REAL(KIND=dp) FUNCTION  RF_INTEGRATION (xx, ffx)
   !              Integrates ffx over xx using a trapezium rule.
   !              xx and ffx are both rf_objects and must have the same size
   !   REAL(KIND=dp) FUNCTION  SECT_INT (sect, rf_fn, rindex, wl_thresh)
   !              Integrates the product sect * rf_fn over wavelength up to wl_thresh.
   !              sect may have fewer points than rf_wl, but all wl must be in rf_wl (usually
   !              added via RF_EXTAND). rf_fn must have the same number of points as rf_wl
   !              (usually, Radiation field intensity if sect is a cross section).
   !              sect is interpolated linearly between two consecutive points, and the
   !              integral between those points is performed by RF_INTEGRATION.

   !===========================================================================================
   ! DECLARATIONS
   !===========================================================================================

   TYPE (PHOTO_ESP), PUBLIC, DIMENSION(:), ALLOCATABLE :: phdest               ! See PXDR_CONSTANTES for PHOTO_ESP TYPE
   ! Wavelength and Radiation field
   TYPE (RF_TYPE), PUBLIC, SAVE                       :: rf_u                  !  Radiation field energy density (erg/cm^3/A)
   TYPE (RF_TYPE), PUBLIC, SAVE                       :: rf_incIm              !  Incident radiation field specific intensity
   TYPE (RF_TYPE), PUBLIC, SAVE                       :: rf_incIp              !  isotropic part, scaled by radm and radp
   INTEGER, DIMENSION (:), POINTER, PUBLIC            :: wl_pointer            !  Reverse ordering of wavelength

   REAL (KIND=dp), PUBLIC                             :: wlth0                 !  Start of Wavelength grid (H ionisation)
   REAL (KIND=dp), PUBLIC                             :: wlthm                 !  End of Wavelength grid
   REAL (KIND=dp), PUBLIC                             :: u_habing = 5.337e-14_dp ! Habing energy density
                                                                               !  (from c U = 1.6e-3 erg cm-2 s-1)
   REAL (KIND=dp), PUBLIC                             :: wl_lym_t              !  Lyman limit for the ionization of atomic H
                                                                               !  (true value)
   REAL (KIND=dp), PUBLIC                             :: wl_lym                !  Lyman limit for the ionization of atomic H
                                                                               !    "effective" value
                                                                               !    used as the upper limit of the UV gap
   REAL (KIND=dp), PUBLIC                             :: wl_hab = 2400.0_dp    !  Limit of Habing Field
   REAL (KIND=dp), PUBLIC                             :: wl_6ev = 2066.37_dp   !  Limit at 6 eV
   REAL (KIND=dp), PUBLIC                             :: pwlg   = 1.10_dp      !  Initial WL step (log scale)
   INTEGER, PUBLIC                                    :: nwlg   = 100          !  Initial number of WL points
   INTEGER, PUBLIC                                    :: mfgk                  !  Number of lines (H2 + CO + ...) in FGK transfer
   REAL (KIND=dp), PUBLIC, DIMENSION (:), ALLOCATABLE :: fgkgrd                !  Line shielded radiation field
   CHARACTER (LEN=15), PUBLIC                         :: ISRF_name             !  Used in outputs

   ! Photo-ionisation and photo-dissociation related quantities
   REAL (KIND=dp), PUBLIC, DIMENSION (nlevh2,0:noptm) :: pdh2vJ                !  H2 Photdissociation rate from level lev(v,J)
   REAL (KIND=dp), PUBLIC, DIMENSION(:,:), ALLOCATABLE:: pdiesp                !  UV photoionisation rate at iopt of species

   REAL (KIND=dp), PUBLIC, DIMENSION(:,:), ALLOCATABLE:: star_rf               !  External radiation field (if any)

   ! Grain photo-electric efficiency and extinction curve
   TYPE(RF_TYPE), PUBLIC, SAVE                        :: rf_extpou             !  Extinction by dust (Fitzpatrick and Massa)

   REAL (KIND=dp), PUBLIC, DIMENSION(:,:), ALLOCATABLE :: si_QU, si_QUl, si_QUl2
   REAL (KIND=dp), PUBLIC, DIMENSION(:), ALLOCATABLE   :: si_
   TYPE(RF_TYPE), PUBLIC, DIMENSION(:), ALLOCATABLE    :: sigabs               !  (cm**2 / atom)
                                                                               !  Grain absorption cross section per carbon atom
                                                                               !  (From Fitzpatrick & Massa, Draine or Dustem
                                                                               !  depending on F_DUST_P)
                                                                               !  Used for grain charge computation
                                                                               !  Used for photoelectric effect
                                                                               !  Used for the computation of dust temperature
                                                                               !  if F_DUST_P /= 1
   TYPE(RF_TYPE), PUBLIC, SAVE                         :: dust_wl

   ! This is used for photo-electric heating (Bakes & Tielens formalism) in stv5c.f)
   TYPE(RF_TYPE), PUBLIC, SAVE                         :: bt_int                ! Integrand (without sigma)

   INTEGER, PUBLIC                                     :: ic, ns

   ! Effective order of Legendre development
   !   Possible values are 11, 15, 19, 29, 63 (change xmui's name accordingly)

!  INTEGER, PUBLIC                   :: lleg  = 63
!  INTEGER, PUBLIC, PARAMETER        :: mleg  = 32   ! mleg = (lleg + 1) / 2
!  INTEGER, PUBLIC                   :: lleg  = 29
!  INTEGER, PUBLIC, PARAMETER        :: mleg  = 15   ! mleg = (lleg + 1) / 2
   INTEGER, PUBLIC                   :: lleg  = 19
   INTEGER, PUBLIC, PARAMETER        :: mleg  = 10   ! mleg = (lleg + 1) / 2
!  INTEGER, PUBLIC                   :: lleg  = 11
!  INTEGER, PUBLIC, PARAMETER        :: mleg  = 06   ! mleg = (lleg + 1) / 2
   INTEGER, PUBLIC, PARAMETER        :: nmui  = mleg ! number of angles considered

   ! Roots of Legendre polynomials
   ! Set in reverse (correct) order : bug found by Javier, 15 II 2007
   ! select the one you need by changing the comment and the name in this file
   ! Do not forget to modify xmui_M below

!  REAL (KIND=dp), PUBLIC, DIMENSION(nmui)             :: xmui32    ! L = 63

!  DATA xmui32 / 0.999305041735772139456905624346_dp, 0.996340116771955279346924500676_dp, &
!                0.991013371476744320739382383443_dp, 0.983336253884625956931299302157_dp, &
!                0.973326827789910963741853507352_dp, 0.961008799652053718918614121897_dp, &
!                0.946411374858402816062481491347_dp, 0.929569172131939575821490154559_dp, &
!                0.910522137078502805756380668008_dp, 0.889315445995114105853404038273_dp, &
!                0.865999398154092819760783385070_dp, 0.840629296252580362751691544696_dp, &
!                0.813265315122797559741923338086_dp, 0.783972358943341407610220525214_dp, &
!                0.752819907260531896611863774886_dp, 0.719881850171610826848940217832_dp, &
!                0.685236313054233242563558371031_dp, 0.648965471254657339857761231993_dp, &
!                0.611155355172393250248852971019_dp, 0.571895646202634034283878116659_dp, &
!                0.531279464019894545658013903544_dp, 0.489403145707052957478526307022_dp, &
!                0.446366017253464087984947714759_dp, 0.402270157963991603695766771260_dp, &
!                0.357220158337668115950442615046_dp, 0.311322871990210956157512698560_dp, &
!                0.264687162208767416373964172510_dp, 0.217423643740007084149648748989_dp, &
!                0.169644420423992818037313629748_dp, 0.121462819296120554470376463492_dp, &
!                0.072993121787799039449542941940_dp, 0.024350292663424432508955842854_dp /

!  REAL (KIND=dp), PUBLIC, DIMENSION(nmui)             :: xmui15  ! L = 29

!  DATA xmui15 / 0.9968934840746495_dp, 0.9836681232797472_dp, 0.9600218649683075_dp, &
!                0.9262000474292743_dp, 0.8825605357920526_dp, 0.8295657623827684_dp, &
!                0.7677774321048262_dp, 0.6978504947933158_dp, 0.6205261829892429_dp, &
!                0.5366241481420199_dp, 0.4470337695380892_dp, 0.3527047255308781_dp, &
!                0.2546369261678899_dp, 0.1538699136085835_dp, 0.0514718425553177_dp /

   REAL (KIND=dp), PUBLIC, DIMENSION(nmui)             :: xmui10  ! L = 19

   DATA xmui10 / 0.993128599185094924786122388471_dp, 0.963971927277913791267666131197_dp, &
                 0.912234428251325905867752441203_dp, 0.839116971822218823394529061702_dp, &
                 0.746331906460150792614305070356_dp, 0.636053680726515025452836696226_dp, &
                 0.510867001950827098004364050955_dp, 0.373706088715419560672548177025_dp, &
                 0.227785851141645078080496195369_dp, 0.0765265211334973337546404093988_dp /

!  REAL (KIND=dp), PUBLIC, DIMENSION(nmui)             :: xmui08  ! L = 15

!  DATA xmui08 / 0.989400934991649932596154173450_dp, 0.944575023073232576077988415535_dp, &
!                0.865631202387831743880467897712_dp, 0.755404408355003033895101194847_dp, &
!                0.617876244402643748446671764049_dp, 0.458016777657227386342419442984_dp, &
!                0.281603550779258913230460501460_dp, 0.095012509837637440185319335425_dp /

!  REAL (KIND=dp), PUBLIC, DIMENSION(nmui)             :: xmui06  ! L = 11

!  DATA xmui06 / 0.981560634246719250690549090149_dp, 0.904117256370474856678465866119_dp, &
!                0.769902674194304687036893833213_dp, 0.587317954286617447296702418941_dp, &
!                0.367831498998180193752691536644_dp, 0.125233408511468915472441369464_dp /

   REAL (KIND=dp), PUBLIC, ALLOCATABLE, DIMENSION(:)   :: xmui_M        ! Legendre indexes
   REAL (KIND=dp), PUBLIC, ALLOCATABLE, DIMENSION(:)   :: AngleLeg_deg  ! Angles corresponding to the Legendre decomposition [deg]

   ! Radiation field associated quantities
   REAL (KIND=dp), PUBLIC, DIMENSION(0:noptm)          :: fluph     ! Flux of photons at tau up to 2000 A
   REAL (KIND=dp), PUBLIC, DIMENSION(0:noptm)          :: int_rad   ! Total radiative energy density in UV (erg cm-3)
   REAL (KIND=dp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: intJm     ! Mean Intensity from "minus" side
   REAL (KIND=dp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: intJp     ! Mean Intensity from "plus" side
   REAL (KIND=dp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: intJmp    ! Total Mean Intensity (intJm + intJp)
   REAL (KIND=dp), PUBLIC, ALLOCATABLE, DIMENSION(:)   :: tmptau    ! Temporary storage for tau
   REAL (KIND=dp), PUBLIC, ALLOCATABLE, DIMENSION(:)   :: tmp_wl    ! Temporary storage for wl
   REAL (KIND=dp), PUBLIC, ALLOCATABLE, DIMENSION(:)   :: I_incr_m  ! Incremental specific intensity of the star (Obs. side)
   REAL (KIND=dp), PUBLIC, ALLOCATABLE, DIMENSION(:)   :: I_incr_p  ! Incremental specific intensity of the star (Back side)
                                                                    ! [erg cm-2 s-1 str-1 A-1]
   REAL (KIND=dp), PUBLIC, ALLOCATABLE, DIMENSION(:)   :: abs_tot   ! Full absorption thru cloud as a function of wavelength
                                                                    ! (used only in output)
   REAL (KIND=dp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: I_esc_0   ! Escaping radiation
   REAL (KIND=dp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: I_esc_max ! Escaping radiation

   REAL (KIND=dp), PUBLIC                              :: Icont_3_1000   ! continuum intensity in the dir. perpendicular to the cloud integrated from 3 to 1000 microns
   REAL (KIND=dp), PUBLIC                              :: Icont_25_60    ! continuum intensity in the dir. perpendicular to the cloud integrated from 25 to 60 microns
   REAL (KIND=dp), PUBLIC                              :: Icont_60_200   ! continuum intensity in the dir. perpendicular to the cloud integrated from 60 to 200 microns
   REAL (KIND=dp), PUBLIC                              :: Icont_200_1000 ! continuum intensity in the dir. perpendicular to the cloud integrated from 200 to 1000 microns
   REAL (KIND=dp), PUBLIC                              :: Icont_60_1000  ! continuum intensity in the dir. perpendicular to the cloud integrated from 60 to 1000 microns

   PRIVATE

   PUBLIC :: INCREMENTAL_INTEG, SECT_PRI, BBL, BBLT, DERBBL, SECT_INTB, SECT_INT, RF_INTEGRATION &
           , INTEG_TAB, RF_CREATE, RF_FREE, RF_REVERS, INTERP_X, STAR, RF_EXTAND &
           , AUX_Srm, AUX_Rlmi, AUX_GIT &
           , AUX_BP, AUX_BM, FEED_LINES

CONTAINS

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
SUBROUTINE INCREMENTAL_INTEG (sect, rf_fn, rindex, sect_p, lsect_p, nsect_p)
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
   ! Integrate the product sect * rf_fn over lambda
   ! and save each partial sum from lamdda lower (of table sect) to lsect_p

   IMPLICIT NONE

   INTEGER, INTENT (IN)                                :: nsect_p
   TYPE(RF_TYPE), INTENT (IN)                          :: sect       ! Section to integrate
   TYPE(RF_TYPE), INTENT (IN)                          :: rf_fn      ! Weight FUNCTION
   INTEGER, POINTER, DIMENSION(:)                      :: rindex     ! Reverse ordering index
   REAL (KIND=dp), INTENT (IN),   DIMENSION(1:nsect_p) :: lsect_p    ! lambda table for partial integration
   REAL (KIND=dp), INTENT (OUT),  DIMENSION(1:nsect_p) :: sect_p     ! partial integrated section

   INTEGER                                             :: i, j
   INTEGER                                             :: ll, uu
   REAL (KIND = dp)                                    :: s1, s2, l1, l2
   REAL (KIND = dp)                                    :: s, l, so, lo
   REAL (KIND = dp)                                    :: integral
   REAL (KIND = dp)                                    :: fo, f1, f
   INTEGER                                             :: is_p

   sect_p   = 0.0_dp
   integral = 0.0_dp
   is_p     = nsect_p
   DO i = sect%lower, sect%upper-1
      ll = rindex(sect%Ord(i))
      l1 = rf_wl%Val(ll)
      s1 = sect%Val(i)

      uu = rindex(sect%Ord(i+1))
      l2 = rf_wl%Val(uu)
      s2 = sect%Val(i+1)

      lo = l1
      so = s1
      DO j = ll, uu-1
         l  = rf_wl%Val(j+1)

210      CONTINUE
         IF( is_p == 0 ) EXIT
         IF (l > lsect_p(is_p) ) THEN
            IF( lo <= lsect_p(is_p) ) THEN
               fo = rf_fn%Val(j)
               f1 = rf_fn%Val(j+1)
               f = fo + (f1 - fo) * (lsect_p(is_p) - lo) / (l  - lo)
               s = s1 + (s2 - s1) * (lsect_p(is_p) - l1) / (l2 - l1)
               sect_p(is_p) = integral + 0.5_dp * (lsect_p(is_p) - lo) * (so * fo + s * f)
               is_p = is_p - 1
               GOTO 210
            ELSE
               DO WHILE ( (is_p > 0) .AND. (lo > lsect_p(is_p)) )
                   sect_p(is_p) = 0.0_dp
                   is_p = is_p - 1
                   IF (is_p == 0) EXIT
               ENDDO
               GOTO 210
            ENDIF
         ENDIF

         s = s1 + (s2 - s1) * (l - l1) / (l2 - l1)

         integral = integral + 0.5_dp * (l - lo) * (so * rf_fn%Val(j) + s * rf_fn%Val(j+1))
         lo = l
         so = s
      ENDDO
   ENDDO

END SUBROUTINE INCREMENTAL_INTEG

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
SUBROUTINE SECT_PRI (sect, rf_fn, rindex, sect_p, nwlg)
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
! Integrate The product sect * rf_fn over lambda
!           and save each partial sum from lamb1 to lamb_i

   IMPLICIT NONE

   INTEGER, INTENT (IN)                             :: nwlg
   TYPE(RF_TYPE), INTENT (IN)                       :: sect       ! Section to integrate
   TYPE(RF_TYPE), INTENT (IN)                       :: rf_fn      ! Weight FUNCTION
   INTEGER, POINTER, DIMENSION(:)                   :: rindex     ! Reverse ordering index
   REAL (KIND=dp), INTENT (OUT),  DIMENSION(0:nwlg) :: sect_p     ! partial integrated section

   INTEGER                                          :: i, j
   INTEGER                                          :: ll, uu
   REAL (KIND = dp)                                 :: s1, s2, l1, l2
   REAL (KIND = dp)                                 :: s, l, so, lo

   sect_p = 0.0_dp
   sect_p(rindex(sect%Ord(sect%lower))) = 1.0e-40_dp

   DO i = sect%lower, sect%upper-1
      ll = rindex(sect%Ord(i))
      l1 = rf_wl%Val(ll)
      s1 = sect%Val(i)

      uu = rindex(sect%Ord(i+1))
      l2 = rf_wl%Val(uu)
      s2 = sect%Val(i+1)

      lo = l1
      so = s1
      DO j = ll, uu-1
         l = rf_wl%Val(j+1)
         s = s1 + (s2 - s1) * (l - l1) / (l2 - l1)
         sect_p(j+1) = sect_p(j) + 0.5_dp * (l - lo) &
                     * (so * rf_fn%Val(j) + s * rf_fn%Val(j+1))
         lo = l
         so = s
      ENDDO
   ENDDO

END SUBROUTINE SECT_PRI

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
REAL(KIND=dp) FUNCTION  BBL(x,T)
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!---------------------------------------------------------------------------------------------
! Black body. x in Angstrom, T in K, BBL in erg cm-2 s-1 Angstrom-1 sr-1
!---------------------------------------------------------------------------------------------

   USE PXDR_AUXILIAR

   IMPLICIT NONE

   REAL (KIND = dp), INTENT (IN)      :: x          ! Wavelength (Angstrom)
   REAL (KIND = dp), INTENT (IN)      :: T          ! Temperature (K)
   REAL (KIND = dp)                   :: aux

   ! BG 04/2013 - to include X ray domain, it is necessary to compute the exponential of
   ! large values otherwise BBL increase as lambda^(-5) * constant as soon as EXP()>3.E108
   ! Is it a problem in the code to have a null value of BBL ?
   !aux = 2.0_dp * xhp * clum**2 * 1.0e32_dp / (x**5 * (EXPBOR(hcsurk*1.0e8_dp / (x*T)) - 1.0_dp))
   IF ((hcsurk*1.0e8_dp / (x*T)) >= l_hu) THEN
      aux = 0.0_dp
   ELSE
      aux = 2.0_dp * xhp * clum**2 * 1.0e32_dp / (x**5 * (EXPBOR(hcsurk*1.0e8_dp / (x*T)) - 1.0_dp))
   ENDIF

   BBL = aux

END FUNCTION BBL

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
REAL(KIND=dp) FUNCTION  BBLT(x)
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!---------------------------------------------------------------------------------------------
! Wrapper to BBL
!---------------------------------------------------------------------------------------------

   USE PXDR_AUXILIAR
   USE PXDR_PROFIL

   IMPLICIT NONE

   REAL (KIND = dp), INTENT (IN) :: x             ! Wavelength (Angstrom)

   BBLT = BBL(x,teff)

END FUNCTION BBLT

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
REAL(KIND=dp) FUNCTION  DERBBL(x,T)
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!---------------------------------------------------------------------------------------------
! Derivative of the Black body (fot Newton-Raphson determination of dust temperatures).
! x in Angstrom, T in K.
!---------------------------------------------------------------------------------------------

   USE PXDR_AUXILIAR

   IMPLICIT NONE

   REAL (KIND = dp), INTENT (IN)      :: x          ! Wavelength (Angstrom)
   REAL (KIND = dp), INTENT (IN)      :: T          ! Temperature (K)
   REAL (KIND = dp)                   :: aux, exp

   ! BG 04/2013 - to include X ray domain, it is necessary to compute the exponential of
   ! large values otherwise BBL increase as lambda^(-5) * constant as soon as EXP()>3.E108
   ! Is it a problem in the code to have a null value of BBL ?

   IF ((hcsurk*1.0e8_dp / (x*T)) >= l_hu) THEN
      aux = 0.0_dp
   ELSE
      exp = EXPBOR(hcsurk*1.0e8_dp / (x*T))
      aux = 2.0_dp * xhp * clum**2 * 1.0e40_dp * hcsurk * exp / (T**2 * x**6 * (exp - 1.0_dp)**2)
   ENDIF

   DERBBL = aux

END FUNCTION DERBBL

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
REAL(KIND=dp) FUNCTION  SECT_INTB (sect, rf_fn, rindex, wl_thresh_1,  wl_thresh_2)
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!---------------------------------------------------------------------------------------------
! Integrate The product sect * rf_fn over lambda
!           From lamb1 to lamb2
! sect is interpolated between two successive points
! rf_fn must be known at every point in lambda
!---------------------------------------------------------------------------------------------

   IMPLICIT NONE

   TYPE(RF_TYPE), INTENT (IN)     :: sect         ! Section to integrate
   TYPE(RF_TYPE), INTENT (IN)     :: rf_fn        ! Weight FUNCTION
   INTEGER, POINTER, DIMENSION(:) :: rindex       ! Reverse ordering index
   REAL (KIND = dp), INTENT (IN)  :: wl_thresh_1  ! min threshold
   REAL (KIND = dp), INTENT (IN)  :: wl_thresh_2  ! max threshold

   INTEGER                        :: i, j
   INTEGER                        :: ll, uu
   INTEGER                        :: I_thresh_1, I_thresh_2
   REAL (KIND = dp)               :: s1, s2, l1, l2
   REAL (KIND = dp)               :: s, l, so, lo
   REAL (KIND = dp)               :: fo, f1, f
   REAL (KIND = dp)               :: sumt

   CALL RF_LOCATE (rf_wl, wl_thresh_1, I_thresh_1)
   CALL RF_LOCATE (rf_wl, wl_thresh_2, I_thresh_2)

   sumt = 0.0_dp
   DO i = sect%lower, sect%upper-1

      ll = rindex(sect%Ord(i))
      l1 = rf_wl%Val(ll)
      s1 = sect%Val(i)

      uu = rindex(sect%Ord(i+1))
      l2 = rf_wl%Val(uu)
      s2 = sect%Val(i+1)

      IF (ll < I_thresh_1) THEN
         ll = I_thresh_1
         s1 = s1 + (s2 - s1) * (rf_wl%Val(ll) - l1) / (l2 - l1)
         l1 = rf_wl%Val(ll)
      ENDIF

      IF (ll >= I_thresh_2) EXIT
      IF (uu > I_thresh_2) THEN
         uu = I_thresh_2
         s2 = s1 + (s2 - s1) * (rf_wl%Val(uu) - l1) / (l2 - l1)
         l2 = rf_wl%Val(uu)
      ENDIF

      IF (l2 > l1) THEN
         lo = l1
         so = s1
         DO j = ll, uu-1
            l  = rf_wl%Val(j+1)
            IF ( lo < wl_thresh_1 ) THEN
               fo = rf_fn%Val(j)
               f1 = rf_fn%Val(j+1)
               f  = fo + (f1 - fo) * (wl_thresh_1 - lo) / (l  - lo)
               s  = s1 + (s2 - s1) * (wl_thresh_1 - l1) / (l2 - l1)
               sumt = sumt + 0.5_dp * (l - wl_thresh_1) * (s * f)
               s  = s1 + (s2 - s1) * (l - l1) / (l2 - l1)
               sumt = sumt + 0.5_dp * (l - wl_thresh_1) * (s * f1)
            ELSE
               s = s1 + (s2 - s1) * (l - l1) / (l2 - l1)
               sumt = sumt + 0.5_dp * (l - lo) * (so * rf_fn%Val(j) + s * rf_fn%Val(j+1))
            ENDIF
            lo = l
            so = s
         ENDDO
      ENDIF
   ENDDO

   SECT_INTB = sumt

END FUNCTION SECT_INTB

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
REAL(KIND=dp) FUNCTION  SECT_INT (sect, rf_fn, rindex, wl_thresh)
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!---------------------------------------------------------------------------------------------
! Integrate The product sect * rf_fn over lambda
!           From lamb1 to lamb2
! sect is interpolated between two successive points
! rf_fn must be known at every point in lambda
!---------------------------------------------------------------------------------------------

   IMPLICIT NONE

   TYPE(RF_TYPE), INTENT (IN)     :: sect       ! Section to integrate
   TYPE(RF_TYPE), INTENT (IN)     :: rf_fn      ! Weight FUNCTION
   INTEGER, POINTER, DIMENSION(:) :: rindex     ! Reverse ordering index
   REAL (KIND = dp), INTENT (IN)  :: wl_thresh  ! Threshold

   INTEGER                        :: i, j, ll, uu
   INTEGER                        :: I_thresh
   REAL (KIND = dp)               :: sumt, sump
   REAL (KIND = dp)               :: s1, s2, l1, l2
   REAL (KIND = dp)               :: i_int, j_int

   CALL RF_LOCATE (rf_wl, wl_thresh, I_thresh)

   sumt = 0.0_dp
   DO i = sect%lower, sect%upper-1

      ll = rindex(sect%Ord(i))
      l1 = rf_wl%Val(ll)
      s1 = sect%Val(i)

      uu = rindex(sect%Ord(i+1))
      l2 = rf_wl%Val(uu)
      s2 = sect%Val(i+1)

      IF (uu > I_thresh) THEN
         uu = I_thresh
         s2 = s1 + (s2 - s1) * (rf_wl%Val(uu) - l1) / (l2 - l1)
         l2 = rf_wl%Val(uu)
      ENDIF

      IF (l2 > l1) THEN
         i_int = 0.5_dp * SUM( (/ ((rf_wl%Val(j+1) - rf_wl%Val(j)) &
               * (rf_fn%Val(j+1) + rf_fn%Val(j)), j= ll, uu-1) /) )
         j_int = 0.5_dp * SUM( (/ ((rf_wl%Val(j+1) - rf_wl%Val(j)) &
               * (rf_wl%Val(j+1)*rf_fn%Val(j+1) &
               +  rf_wl%Val(j)*rf_fn%Val(j)), j= ll, uu-1) /) )
         sump = (j_int * (s1-s2) - i_int * (s1*l2-s2*l1)) / (l1-l2)    ! Analytical integration of sect
         sumt = sumt + sump
      ELSE
         EXIT
      ENDIF
   ENDDO

   SECT_INT = sumt

END FUNCTION SECT_INT

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
REAL(KIND=dp) FUNCTION  RF_INTEGRATION (xx, ffx)
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!---------------------------------------------------------------------------------------------
! Integrate Function using the trapezium rules.
! With uneven step
!---------------------------------------------------------------------------------------------

   IMPLICIT NONE

   TYPE(RF_TYPE), INTENT (IN) :: xx               ! Abscissa
   TYPE(RF_TYPE), INTENT (IN) :: ffx              ! Y-axis
   INTEGER                    :: l, u, i
   l = xx%lower
   u = xx%upper

   RF_INTEGRATION = 0.5_dp * SUM( (/ ((xx%Val(i+1) - xx%Val(i)) &
                  * (ffx%Val(i+1) + ffx%Val(i)), i= l, u-1) /) )

END FUNCTION RF_INTEGRATION

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
REAL(KIND=dp) FUNCTION INTEG_TAB (tab, nw, l1, l2)
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
   ! Integrate the table tab over lambda from l1 to l2
   ! Careful : wavelength in rf_wl and tab must be ordered 
   ! correctly from the lowest to largest value

   IMPLICIT NONE

   INTEGER, INTENT (IN)                        :: nw
   REAL (KIND=dp), DIMENSION(0:nw), INTENT(IN) :: tab ! table to integrate
   REAL (KIND=dp), INTENT(IN)                  :: l1  ! lower limit for integration
   REAL (KIND=dp), INTENT(IN)                  :: l2  ! upper limit for integration
   INTEGER                                     :: i
   INTEGER                                     :: i1
   INTEGER                                     :: i2
   REAL (KIND=dp)                              :: ll1
   REAL (KIND=dp)                              :: ll2

   ! conversion from microns to angstrom
   ll1  = l1 * 1.0e+4_dp
   ll2  = l2 * 1.0e+4_dp

   ! search limit indices
   DO i = 0, nw
      IF (rf_wl%Val(i) .GE. ll1) EXIT
   ENDDO
   i1 = i
   DO i = nw, 0, -1
      IF (rf_wl%Val(i) .LE. ll2) EXIT
   ENDDO
   i2 = i

   ! test if the integration is possible
   IF (i1 >= i2) THEN
      WRITE(*,*) "Wrong utilization of the INTEG_TAB function - see RF_TOOLS"
      STOP
   ENDIF
   DO i = i1, i2 - 1
      IF (rf_wl%Val(i+1) < rf_wl%Val(i)) THEN
         WRITE(*,*) "Wrong utilization of the INTEG_TAB function - see RF_TOOLS"
         STOP
      ENDIF
   ENDDO

   ! integrate function
   INTEG_TAB = 0.0_dp
   INTEG_TAB = INTEG_TAB + tab(i1) * (rf_wl%Val(i1+1) - rf_wl%Val(i1)) / 2.0_dp
   INTEG_TAB = INTEG_TAB + tab(i2) * (rf_wl%Val(i2) - rf_wl%Val(i2-1)) / 2.0_dp
   DO i = i1+1, i2-1
      INTEG_TAB = INTEG_TAB + tab(i) * (rf_wl%Val(i+1) - rf_wl%Val(i-1)) / 2.0_dp
   ENDDO

END FUNCTION INTEG_TAB

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
SUBROUTINE RF_CREATE (rf_xx, ll, uu)
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
! Purpose: initialize upper and lower range of Val and Ord
!          and ALLOCATE the corresponding vector
! Note : Do NOT forget to DEALLOCATE temporary rf_objects !

   USE PXDR_FLAGS
   USE PXDR_CONSTANTES

   IMPLICIT NONE

   TYPE(RF_TYPE), INTENT (INOUT) :: rf_xx
   INTEGER, INTENT (IN)         :: ll, uu

   rf_xx%lower = ll
   rf_xx%upper = uu
   IF ( .NOT. ASSOCIATED(rf_xx%Val)) THEN
      ALLOCATE (rf_xx%Val(ll:uu))
      ALLOCATE (rf_xx%Ord(ll:uu))
   ELSE
   !  PRINT *, "  Warning : Allocation is done by RF_CREATE"
   !  PRINT *, "            Do not forget to DEALLOCATE if called from a loop"
   !  CALL RF_FREE (rf_xx)
      ALLOCATE (rf_xx%Val(ll:uu))
      ALLOCATE (rf_xx%Ord(ll:uu))
   ENDIF

   rf_xx%Val = 0.0_dp
   rf_xx%Ord = 0

END SUBROUTINE RF_CREATE

!%%%%%%%%%%%%%%%%%%%%%%%%%
SUBROUTINE RF_FREE (rf_xx)
!%%%%%%%%%%%%%%%%%%%%%%%%%
! Purpose: DEALLOCATE all ALLOCATABLE bits of rf_xx

   IMPLICIT NONE
   TYPE(RF_TYPE), INTENT (INOUT) :: rf_xx

   DEALLOCATE (rf_xx%Val)
   DEALLOCATE (rf_xx%Ord)
   NULLIFY(rf_xx%Val)
   NULLIFY(rf_xx%Ord)

END SUBROUTINE RF_FREE

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%
SUBROUTINE RF_REVERS (rindex)
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%
! Purpose: Reverse ordering of wavelength

   IMPLICIT NONE
   INTEGER, POINTER, DIMENSION(:) :: rindex
   INTEGER :: i

   NULLIFY (rindex)
   ALLOCATE (rindex(rf_wl%lower:rf_wl%upper))

   DO i = rf_wl%lower, rf_wl%upper
      rindex(rf_wl%Ord(i)) = i
   ENDDO

END SUBROUTINE RF_REVERS

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
SUBROUTINE RF_EXTAND (rf_xx, x, add_1, iloc, iord)
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
! Purpose: Add one value in rf_xx%Val if not already here
!          and update upper and rf_xx%Ord
! On output, iloc is the index of the added value in rf_xx
!            iord is the rank (order) of the added value

   IMPLICIT NONE

   TYPE(RF_TYPE), INTENT (INOUT) :: rf_xx
   REAL (KIND=dp), INTENT (IN)  :: x
   INTEGER, INTENT (OUT)        :: add_1
   INTEGER, INTENT (OUT)        :: iloc
   INTEGER, INTENT (OUT)        :: iord

   TYPE(RF_TYPE)                :: rf_tmp
   INTEGER                      :: ll, uu
   INTEGER                      :: i

   ll = rf_xx%lower
   uu = rf_xx%upper

   CALL RF_LOCATE (rf_xx, x, i)

   ! if x is already in rf_xx%Val, no need to extand
   IF (rf_xx%Val(i) == x) THEN
      add_1 = 0
      iloc = i
      iord = rf_xx%Ord(i)
      RETURN
   ENDIF

   CALL RF_CREATE (rf_tmp, ll, uu)

   rf_tmp%lower = ll
   rf_tmp%upper = uu
   rf_tmp%Val = rf_xx%Val
   rf_tmp%Ord = rf_xx%Ord

   CALL RF_FREE (rf_xx)
   CALL RF_CREATE (rf_xx, ll, uu+1)

   ! 29 IV 2010 - BUG (JLB) The test must be ">=", and not ">" as was.
   IF (i >= ll) THEN
      rf_xx%Val(ll:i) = rf_tmp%Val(ll:i)
      rf_xx%Ord(ll:i) = rf_tmp%Ord(ll:i)

      iloc = i + 1
      iord = uu + 1
      rf_xx%Val(iloc) = x
      rf_xx%Ord(iloc) = iord

      rf_xx%Val(i+2:uu+1) = rf_tmp%Val(i+1:uu)
      rf_xx%Ord(i+2:uu+1) = rf_tmp%Ord(i+1:uu)

      rf_xx%upper = uu + 1
      ! --------------------------------------
      ! Change the largest limit of the
      ! radiation field
      ! JLB - WARNING: This is a general purpose routine
      !       This correction should go outside, in case
      !       rf_xx is NOT rf_wl !
      ! --------------------------------------
      IF (i == uu) THEN
         wlthm = x
      ENDIF
   ELSE
      ! --------------------------------------
      ! Bug correction (B.G.). iloc=ll and not
      ! i. Used in conjonction with the LOCATE
      ! function it allows the inclusion of
      ! wavelength below the 912 A cut off
      ! 08 / 04 / 2013
      ! --------------------------------------
      iloc = ll
      iord = uu + 1
      rf_xx%Val(iloc) = x
      rf_xx%Ord(iloc) = iord

      rf_xx%Val(ll+1:uu+1) = rf_tmp%Val(ll:uu)
      rf_xx%Ord(ll+1:uu+1) = rf_tmp%Ord(ll:uu)

      rf_xx%upper = uu + 1
      ! --------------------------------------
      ! Change the lowest limit of the
      ! radiation field
      ! --------------------------------------
      wlth0 = x
   ENDIF

   add_1 = 1
   CALL RF_FREE (rf_tmp)

END SUBROUTINE RF_EXTAND

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
SUBROUTINE INTERP_X (wlth, bbstar, i_l)
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

   USE PXDR_FLAGS
   USE PXDR_CONSTANTES
   USE PXDR_PROFIL

   IMPLICIT NONE
   REAL (KIND=dp), INTENT (IN)                     :: wlth
   REAL (KIND=dp), INTENT (OUT)                    :: bbstar
   INTEGER, INTENT (INOUT)                         :: i_l

   REAL (KIND=dp)                                  :: wl_deb, wl_fin
   REAL (KIND=dp)                                  :: wl_l, wl_r, wlthcm
   INTEGER                                         :: i_r, i_lm
   REAL (KIND=dp)                                  :: fact

   i_lm = SIZE(star_rf,1)
   wl_deb = star_rf(1,1)
   wl_fin = star_rf(i_lm,1)

   IF (wlth <= wl_deb .OR. wlth >= wl_fin) THEN
      ! use Black body
      wlthcm = wlth * 1.0e-8_dp
      bbstar = 1.0e-8_dp*2.0_dp*xhp*clum*clum / wlthcm**5
      bbstar = bbstar / (EXP(hcsurk/(teff*wlthcm)) - 1.0_dp)
   ELSE
      ! Interpolate
      DO
         IF (wlth > star_rf(i_l+1,1)) THEN
            i_l = i_l + 1
         ELSE
            i_r = i_l + 1
            wl_l = star_rf(i_l,1)
            wl_r = star_rf(i_r,1)
            fact = (wlth - wl_l) / (wl_r - wl_l)
            EXIT
         ENDIF
      ENDDO
      bbstar = star_rf(i_l,2) + (star_rf(i_r,2) - star_rf(i_l,2)) * fact
   ENDIF

END SUBROUTINE INTERP_X

!%%%%%%%%%%%%%%
SUBROUTINE STAR
!%%%%%%%%%%%%%%

!=================================================================================
! - Most data from "Allen's Astrophysical Quantities" 4th ed (A. Cox Ed.)
!   Sect 15.3.1 (p 388).
! - Some additional data from :
!   Effective temperature are from Lang, "Astrophysical Formulae",  p564
! - Some radii from Lang p 546 - Note inconsistencies between quoted temp...
! - Note a better representation (continuous) can be derived from :
!   De Jager & Nieuwenhuijzen, A & A 177, 217 (1987)
!
!  Specific stars are easily added. Has to be done in /data/star.dat
!=================================================================================

    USE PXDR_FLAGS
    USE PXDR_CONSTANTES
    USE PXDR_PROFIL

    IMPLICIT NONE

    INTEGER                         :: i_star
    INTEGER                         :: star_found   ! flag
    CHARACTER(LEN=15)               :: spectype1    ! spectral type in data
    CHARACTER(LEN=15)               :: spectype2    ! other eventual spelling of spectral type

    fichier = TRIM(ADJUSTL(data_dir))//'Astrodata/star.dat'
    PRINT *, " Open star file:", TRIM(fichier)
    OPEN(iwrtmp,file = fichier,status = "old",action="READ")
    READ(iwrtmp,*) ! commentaire
    READ(iwrtmp,*) ! commentaire
    READ(iwrtmp,*) ! commentaire
    star_found = 0
    DO i_star = 1, 100000
       READ(iwrtmp,1010,END=110) spectype1, spectype2, teff, rstar
       spectype1 = TRIM(ADJUSTL(spectype1))
       spectype2 = TRIM(ADJUSTL(spectype2))
       IF ( (spectype1 == TRIM(ADJUSTL(srcpp)) ) .OR.  (spectype2 == TRIM(ADJUSTL(srcpp)) ) ) THEN
          star_found = 1
          rstar = rstar * rsun
          EXIT
       ENDIF
    ENDDO
110 CONTINUE
    CLOSE(iwrtmp)

    IF (star_found /= 1) THEN
       WRITE(ISCRN,*)" ****  Warning ***** "
       WRITE(ISCRN,*)" Spectral type unknown for :"
       WRITE(ISCRN,*) srcpp
       WRITE(ISCRN,*)" *** STOP *** "
       STOP
    ENDIF

    WRITE(ISCRN,*) "Spectral type used : ", TRIM(ADJUSTL(srcpp))
    WRITE(ISCRN,*) "Teff   : ", teff
    WRITE(ISCRN,*) "radius : ", rstar

 1010   format(A15,A15,F13.4,F10.4,A15)

END SUBROUTINE STAR

!-------- Auxiliary SUBROUTINE for ETIN -----------------------------------

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
SUBROUTINE AUX_Srm(q_0, rlm, Srm)
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

   USE PXDR_FLAGS
   USE PXDR_CONSTANTES
   USE PXDR_PROFIL

   IMPLICIT NONE
   REAL (KIND=dp), DIMENSION(0:lleg),                  INTENT (IN)  :: q_0
   REAL (KIND=dp), DIMENSION(0:lleg,-mleg:mleg),       INTENT (IN)  :: rlm
   REAL (KIND=dp), DIMENSION(mleg),                    INTENT (OUT) :: Srm
   INTEGER                                                          :: m, l, ll
   REAL (KIND=dp), DIMENSION(mleg)                                  :: qq
   REAL (KIND=dp), DIMENSION(mleg,mleg)                             :: rr
   REAL (KIND=dp), DIMENSION(:), ALLOCATABLE                        :: ss

   CHARACTER (LEN=1) :: TRANS = 'N'
   REAL (KIND=dp)    :: ALPHA = 1.0_dp
   REAL (KIND=dp)    :: BETA = 0.0_dp
   INTEGER           :: INCX = 1
   INTEGER           :: INCY = 1

   ALLOCATE (ss(mleg))

   DO l = 1, mleg
      ll = 2 * l - 1
      qq(l) = (2*ll+1) * q_0(ll)
   ENDDO

      DO l = 1, mleg
         ll = 2 * l - 1
         DO m = 1, mleg
            rr(m,l) = rlm(ll,m)
         ENDDO
      ENDDO
      CALL DGEMV (TRANS, mleg, mleg, ALPHA, rr, mleg, qq, INCX, BETA, ss, INCY)
      Srm(:) = ss

   DEALLOCATE (ss)

END SUBROUTINE AUX_Srm

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
SUBROUTINE AUX_Rlmi(rlm, hl, rlmi)
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

   USE PXDR_FLAGS
   USE PXDR_CONSTANTES
   USE PXDR_PROFIL

   IMPLICIT NONE
   REAL (KIND=dp), DIMENSION(0:lleg,-mleg:mleg), INTENT (IN)  :: rlm
   REAL (KIND=dp), DIMENSION(0:lleg), INTENT (IN)             :: hl
   REAL (KIND=dp), DIMENSION(0:lleg,-mleg:mleg), INTENT (OUT) :: rlmi

   INTEGER                                                          :: m, l
   INTEGER                                                          :: i, j
   REAL (KIND=dp)                                                   :: taux1
   REAL (KIND=dp), DIMENSION(lleg+1)                                :: eigJ
   REAL (KIND=dp), DIMENSION(lleg+1,lleg+1)                         :: rr_n
   REAL (KIND=dp), DIMENSION(lleg+1,lleg+1)                         :: rr_t

      ! 4a - Compute inverse norm of J
      DO m = 1, mleg
         taux1 = SUM( (/ (rlm(l,m)*rlm(l,m)*hl(l), l=0,lleg) /) )
         eigJ(mleg+m) = 1.0_dp / taux1
         eigJ(mleg-m+1) = 1.0_dp / taux1
      ENDDO

      rr_n(1:lleg+1,1:mleg) = rlm(0:lleg,-mleg:-1)
      rr_n(1:lleg+1,mleg+1:2*mleg) = rlm(0:lleg,1:mleg)

      ! 4c - Transpose and Left multiply by J**-1  ! jrg: rows are multiplied
      DO i = 1, lleg+1
         DO j = 1, lleg+1
            rr_t(i,j) = eigJ(i) * rr_n(j,i)
         ENDDO
      ENDDO

      ! 4d - Right mutiply by D**2  (G**2 in notes jrg)
      DO j = 1, lleg+1
         rr_t(:,j) = rr_t(:,j) * hl(j-1)
      ENDDO

      ! 4e - Compute R**-1
      rlmi(0:lleg,-mleg:-1) = rr_t(1:lleg+1,1:mleg)
      rlmi(0:lleg,1:mleg) = rr_t(1:lleg+1,mleg+1:2*mleg)

END SUBROUTINE AUX_Rlmi

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
SUBROUTINE AUX_GIT(rlmi, ggm, xkm, Git)
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

   USE PXDR_FLAGS
   USE PXDR_CONSTANTES
   USE PXDR_PROFIL

   IMPLICIT NONE
   REAL (KIND=dp), DIMENSION(0:lleg,-mleg:mleg), INTENT (IN)       :: rlmi
   REAL (KIND=dp), DIMENSION(-mleg:mleg,0:npo), INTENT (IN)        :: ggm
   REAL (KIND=dp), DIMENSION(-mleg:mleg), INTENT (IN)              :: xkm
   REAL (KIND=dp), DIMENSION(-mleg:mleg,0:npo), INTENT (OUT)       :: Git

   REAL (KIND=dp), DIMENSION(lleg+1,2*mleg)                        :: R_aux
   REAL (KIND=dp), DIMENSION(2*mleg)                               :: g_aux
   REAL (KIND=dp), DIMENSION(2*mleg)                               :: GG_aux
   INTEGER                                                         :: n

   CHARACTER (LEN=1) :: TRANS = 'N'
   REAL (KIND=dp)    :: ALPHA = 1.0_dp
   REAL (KIND=dp)    :: BETA = 0.0_dp
   INTEGER           :: INCX = 1
   INTEGER           :: INCY = 1

   ! 5d - Compute matrix product  R^-1*A^-1*g = Git
   Git(0,:) = 0.0_dp
   DO n = 0, npo
      R_aux(1:lleg+1,1:mleg) = rlmi(0:lleg,-mleg:-1)
      R_aux(1:lleg+1,mleg+1:2*mleg) = rlmi(0:lleg,1:mleg)
      g_aux(1:mleg) = ggm(-mleg:-1,n)
      g_aux(mleg+1:2*mleg) = ggm(1:mleg,n)

      CALL DGEMV (TRANS, 2*mleg, 2*mleg, ALPHA, R_aux, 2*mleg, g_aux, INCX, BETA, GG_aux, INCY)

      Git(-mleg:-1,n) = GG_aux(1:mleg)
      Git(1:mleg,n) = GG_aux(mleg+1:2*mleg)
      Git(-mleg:mleg,n) = Git(-mleg:mleg,n) * xkm(-mleg:mleg)
   ENDDO


END SUBROUTINE AUX_GIT

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
SUBROUTINE AUX_BP(rlm, pli, aam)
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

   USE PXDR_FLAGS
   USE PXDR_CONSTANTES
   USE PXDR_PROFIL

   IMPLICIT NONE
   REAL (KIND=dp), DIMENSION(0:lleg,-mleg:mleg), INTENT (IN) :: rlm
   REAL (KIND=dp), DIMENSION(0:lleg,-mleg:mleg), INTENT (IN) :: pli
   REAL (KIND=dp), DIMENSION(lleg+1,lleg+1), INTENT (OUT)    :: aam

   REAL (KIND=dp), DIMENSION(mleg,lleg+1)                    :: R_aux
   REAL (KIND=dp), DIMENSION(lleg+1,mleg)                    :: P_aux
   REAL (KIND=dp), DIMENSION(mleg,mleg)                      :: A_aux
   REAL (KIND=dp)                                            :: g_st
   INTEGER                                                   :: l, m, i

   CHARACTER (LEN=1) :: TRANS = 'T'
   REAL (KIND=dp)    :: ALPHA = 1.0_dp
   REAL (KIND=dp)    :: BETA = 0.0_dp

   DO l = 0, lleg
      g_st = (2.0_dp*l+1.0_dp)
      DO m = 1, mleg
         R_aux(mleg+1-m,l+1) = g_st * rlm(l,-m)
      ENDDO
      DO i = 1, mleg
         P_aux(l+1,mleg+1-i) = pli(l,-i)
      ENDDO
   ENDDO

   CALL DGEMM (TRANS, TRANS, mleg, mleg, lleg+1, ALPHA, P_aux, lleg+1, R_aux, mleg, BETA, A_aux, mleg)

   aam(1:mleg,1:mleg) = A_aux

END SUBROUTINE AUX_BP

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
SUBROUTINE AUX_BM(rlm, pli, aam)
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

   USE PXDR_FLAGS
   USE PXDR_CONSTANTES
   USE PXDR_PROFIL

   IMPLICIT NONE
   REAL (KIND=dp), DIMENSION(0:lleg,-mleg:mleg), INTENT (IN) :: rlm
   REAL (KIND=dp), DIMENSION(0:lleg,-mleg:mleg), INTENT (IN) :: pli
   REAL (KIND=dp), DIMENSION(lleg+1,lleg+1), INTENT (OUT)    :: aam

   REAL (KIND=dp), DIMENSION(mleg,lleg+1)                    :: R_aux
   REAL (KIND=dp), DIMENSION(lleg+1,mleg)                    :: P_aux
   REAL (KIND=dp), DIMENSION(mleg,mleg)                      :: A_aux
   REAL (KIND=dp)                                            :: g_st
   INTEGER                                                   :: l, m, i

   CHARACTER (LEN=1) :: TRANS = 'T'
   REAL (KIND=dp)    :: ALPHA = 1.0_dp
   REAL (KIND=dp)    :: BETA = 0.0_dp

   DO l = 0, lleg
      g_st = (2.0_dp*l+1.0_dp)
      DO m = 1, mleg
         R_aux(m,l+1) = g_st * rlm(l,m)
      ENDDO
      DO i = 1, mleg
         P_aux(l+1,i) = pli(l,i)
      ENDDO
   ENDDO

   CALL DGEMM (TRANS, TRANS, mleg, mleg, lleg+1, ALPHA, P_aux, lleg+1, R_aux, mleg, BETA, A_aux, mleg)

   aam(1:mleg,1:mleg) = A_aux

END SUBROUTINE AUX_BM

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
SUBROUTINE FEED_LINES (spelin)
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

  USE PXDR_FLAGS
  USE PXDR_CONSTANTES
  USE PXDR_PROFIL
  USE PXDR_AUXILIAR

  IMPLICIT NONE

  TYPE (SPECTRA), INTENT (INOUT)             :: spelin
  REAL (KIND=dp)                             :: summ
  INTEGER                                    :: nb, i, j, nused
  INTEGER                                    :: jl, ju
  REAL (KIND=dp)                             :: eij, wk, wl
  REAL (KIND=dp)                             :: xx_p, xx_i
  REAL (KIND=dp)                             :: f_emis, gusgl, source
  INTEGER                                    :: i_pop_inv, iloc, ilocv
  REAL (KIND=dp)                             :: em_m
  REAL (KIND=dp)                             :: dedim_sc

  WRITE(iscrn,'(" Solve Radiative Transfer for ",A8)') TRIM(ADJUSTL(spelin%nam))
  nused = spelin%use

  ! Integration par un trapeze
  ! 17 Oct 2011: Change integration variable to ds (dd_cm)
  !              XXl and XXr are given by Eq. dr14-2
  DO i = 1, nused
     spelin%CoD(i,0) = 0.0_dp
     xx_p = spelin%abu(0) * spelin%xre(i,0)
     DO j = 1, npo
        xx_i = spelin%abu(j) * spelin%xre(i,j)
        summ =  0.5_dp * (xx_p + xx_i) * dd_cm(j)
        spelin%CoD(i,j) = spelin%CoD(i,j-1) + summ
        xx_p = xx_i
     ENDDO

     spelin%XXl(i,0) = 0.0_dp
     xx_p = spelin%abu(0) * spelin%xre(i,0) / (spelin%gst(i) * spelin%vel(0))
     DO j = 1, npo
        xx_i = spelin%abu(j) * spelin%xre(i,j) / (spelin%gst(i) * spelin%vel(j))
        summ =  0.5_dp * (xx_p + xx_i) * dd_cm(j)
        spelin%XXl(i,j) = spelin%XXl(i,j-1) + summ
        xx_p = xx_i
     ENDDO

     spelin%XXr(i,npo) = 0.0_dp
     xx_p = spelin%abu(npo) * spelin%xre(i,npo) / (spelin%gst(i) * spelin%vel(npo))
     DO j = npo-1, 0, -1
        xx_i = spelin%abu(j) * spelin%xre(i,j) / (spelin%gst(i) * spelin%vel(j))
        summ =  0.5_dp * (xx_p + xx_i) * dd_cm(j)
        spelin%XXr(i,j) = spelin%XXr(i,j+1) + summ
        xx_p = xx_i
     ENDDO
  ENDDO

  ! 8 II 2012 - JLB - Modify expressions in accordance with dr14
  CALL RF_LOCATE (rf_wl, V_band_wl, ilocv)
  nb = spelin%ntr
  DO i = 1, nb
     ju = spelin%iup(i)
     IF (ju > nused) THEN
        CYCLE
     ENDIF
     jl = spelin%jlo(i)
     wk = spelin%wlk(i)
     wl = spelin%lac(i) * 1.0e8_dp
     eij = spelin%lac(i)**2 * spelin%aij(i) * spelin%gst(ju) / (8.0_dp*xpi)
     spelin%hot(i) = 0

     ! 8 II 2012 - JLB - siD is the dust extinction at lambda scaled by its value at V
     ! This is the quantity called "A_D" in dr14.
     ! Note: should we include scatering or not ?
     ! Member "pum" is the scaled emissivity of dust. Taken directly from dust properties (no need to use various tests).
     CALL RF_LOCATE (rf_wl, wl, iloc)
     spelin%siD(i) = (du_prop%abso(iloc) + du_prop%scat(iloc)) &
                         / (du_prop%abso(ilocv) + du_prop%scat(ilocv))
     ! spelin%pum is in erg cm-3 s-1 Ang-1 sr-1 / cm2
     spelin%pum(0:npo,i) = du_prop%emis(iloc,0:npo) &
                         / (du_prop%abso(ilocv) + du_prop%scat(ilocv))
     IF (MAXVAL(spelin%pum(0:npo,i)) /= 0.0_dp) THEN
        spelin%hot(i) = 1
     ENDIF

     !-- Contribution of the external radiation field --------------------------
     ! intJm and intJp are mean intensities (erg cm-2 Ang-1 s-1 sr-1 with mean value on solid angle)
     ! spelin%exl and spelin%exr have no dimensions
     dedim_sc = 1.0e-32_dp * wl**5 / (2.0_dp * xhp * clum**2)
     spelin%exl(i) = intJm(0,iloc)   * dedim_sc
     spelin%exr(i) = intJp(npo,iloc) * dedim_sc
     IF (F_LINE_TRSF == 0) THEN
        spelin%exl(i) = 0.0_dp
        spelin%exr(i) = 0.0_dp
     ENDIF

     ! 8 II 2012 - JLB -
     ! odl and odr are the optical depth at line center.
     spelin%dnu(i,0:npo) = spelin%vel(0:npo) / spelin%lac(i)
     DO j = 0, npo
        em_m = MIN(spelin%XXl(jl,j), spelin%XXl(ju,j))
        spelin%odl(i,j) = eij * (spelin%XXl(jl,j) - em_m) * spelin%lac(i) / sqpi
        em_m = MIN(spelin%XXr(jl,j), spelin%XXr(ju,j))
        spelin%odr(i,j) = eij * (spelin%XXr(jl,j) - em_m) * spelin%lac(i) / sqpi
     ENDDO

     taulm = MAX(taulm,spelin%odl(i,npo))

     !-- Dust contribution -----------------------------------------------------
     DO j = 0, npo
        xx_p = spelin%odl(i,j)
        IF (isoneside == 0) THEN
           xx_i = spelin%odr(i,j)
        ELSE
           xx_i = 10.0_dp * spelin%odr(i,j)
        ENDIF
        ! 8 II 2012 - JLB - This should be replaced by a full integration.
        spelin%bel(i,j) = ESCAP(xx_p)
        spelin%ber(i,j) = ESCAP(xx_i)
        CALL POMPAGE(spelin, i, j)
        ! spelin%jiD contains the dust mean intensity (erg cm-2 Ang-1 s-1 sr-1 with mean value on solid angle)
     ENDDO
     ! Remove spelin%jiD dimensions to use it in the radiative equilibrium matrix:
     spelin%jiD(i,:) = spelin%jiD(i,:) * dedim_sc

     i_pop_inv = 0
     DO j = 0, npo
        gusgl = spelin%gst(ju) / spelin%gst(jl)
        source = (spelin%xre(jl,j) * gusgl / spelin%xre(ju,j)) - 1.0_dp
        IF (source == 0.0_dp) THEN
           i_pop_inv = 1
           source = 1.0e-10_dp
        ELSE IF (source <= 0.0_dp) THEN
           i_pop_inv = 1
        ENDIF
        f_emis = 1.0_dp + spelin%jiD(i,j) &
               + spelin%bel(i,j) * spelin%exl(i) + spelin%ber(i,j) * spelin%exr(i) &
               + (1.0_dp - spelin%bel(i,j) - spelin%ber(i,j)) / source
        ! Multiplication of line emissivity by escape probabilities
        spelin%emi(i,j) = xk * wk * spelin%abu(j) * spelin%xre(ju,j) &
                        * (spelin%bel(i,j)+spelin%ber(i,j)) * spelin%aij(i) * f_emis
     ENDDO
  ENDDO

END SUBROUTINE FEED_LINES

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
REAL(KIND=dp) FUNCTION L1b(pst, qst)
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

  USE PXDR_FLAGS
  USE PXDR_CONSTANTES
  USE PXDR_AUXILIAR

  IMPLICIT NONE

  REAL (KIND=dp), INTENT (IN) :: pst, qst
  REAL (KIND=dp)              :: suml
  INTEGER                     :: i
  REAL (KIND=dp)              :: toto, tata

  ! Expansion of E1 close to pst:
  REAL (KIND=dp), DIMENSION(ned) :: coef
  REAL (KIND=dp)                 :: e1a, expa, pstm1

  ! Warning: this implementation REQUIRES an odd number of
  ! abscissa for Gauss-Hermite (i.e. including x=0)
  ! The normalisation is such that we compute 0.5 Int( exp(-x**2) * f(x) dx)
  ! The result is divided by sqrt(pi) for L1

  toto = pst+qst
  pstm1 = 1.0_dp / pst

  IF (toto < 3.0e-4_dp) THEN
     tata = 7.5348123959080402_dp
     suml = sum_wgh * tata
     L1b = suml / sqpi

  ELSE IF ((pst < 0.3_dp .AND. qst < 0.9_dp*pst) &
      .OR. (pst > 0.3_dp .AND. pst < 10.0_dp .AND. qst*qst < 0.25_dp*pst) &
      .OR. (pst > 10.0_dp .AND. qst < 1.6_dp)) THEN

     ! Expansion:
     coef(1) = 1.0_dp
     DO i = 2, ned
        coef(i) = inv_factor(i) + rat_im1(i) * coef(i-1) * pstm1
     ENDDO
     CALL e1xa(pst, e1a)
     expa = EXP(-pst) * pstm1

     tata = coef(ned)
     DO i = ned-1, 1, -1
        tata = coef(i) - qst * tata
     ENDDO
     L1b = (e1a - qst * expa * tata) * 0.5_dp
  ELSE
     CALL e1xa(pst+qst, tata)
     suml = 0.5_dp * w_gh(1) * tata
     DO i = 2, ngh
        toto = pst + exp2gh(i) * qst
        CALL e1xa(toto, tata)
        suml = suml + w_gh(i) * tata
     ENDDO
     L1b = suml / sqpi
  ENDIF

END FUNCTION L1b

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
SUBROUTINE POMPAGE(spelin, itr, iop)
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

  ! This routine computes the sum SL1 of dr14
  USE PXDR_FLAGS
  USE PXDR_CONSTANTES
  USE PXDR_PROFIL

  IMPLICIT NONE

  TYPE (SPECTRA), INTENT (INOUT)   :: spelin
  INTEGER, INTENT (IN)             :: itr, iop

  REAL (KIND=dp)                   :: jintDl, jintDr
  INTEGER                          :: j
  REAL (KIND=dp)                   :: opdl, opdr
  REAL (KIND=dp), DIMENSION(0:npo) :: L1ici
  REAL (KIND=dp), DIMENSION(0:npo) :: dtl_D                      ! ABS(tauD(iop) - tauD(j))
  REAL (KIND=dp)                   :: dtl_L                      ! ABS(tauL(iop) - tauL(j))

  L1ici = 0.0_dp
  dtl_D = 0.0_dp

  IF (spelin%hot(itr) == 0) THEN
    spelin%jiD(itr,iop) = 0.0_dp
    RETURN
  ENDIF

  opdl = spelin%odl(itr,iop)
  opdr = spelin%odr(itr,iop)

  dtl_D(iop) = 0.0_dp
  L1ici(iop) = L1b_0
  DO j = iop-1, 0, -1
    dtl_D(j) = dtl_D(j+1) + dtau_o(j+1) * spelin%siD(itr)
    dtl_L = opdl - spelin%odl(itr,j)
    L1ici(j) = L1b(dtl_D(j), dtl_L)
  ENDDO
  DO j = iop+1, npo
    dtl_D(j) = dtl_D(j-1) + dtau_o(j) * spelin%siD(itr)
    dtl_L = opdr - spelin%odr(itr,j)
    L1ici(j) = L1b(dtl_D(j), dtl_L)
  ENDDO

  ! Before intermediate point (sum from 0 to iop)
  jintDl = 0.0_dp
  DO j =  iop-1, 0, -1
     jintDl = jintDl + 0.5_dp * dtau_o(j+1) * (spelin%pum(j,itr) * L1ici(j) + spelin%pum(j+1,itr) * L1ici(j+1))
  ENDDO

  ! After intermediate point (sum from jp to npo)
  jintDr = 0.0_dp
  DO j = iop, npo-1
     jintDr = jintDr + 0.5_dp * dtau_o(j+1) * (spelin%pum(j,itr) * L1ici(j) + spelin%pum(j+1,itr) * L1ici(j+1))
  ENDDO

  spelin%jiD(itr,iop) = MAX(0.0_dp,(jintDl+jintDr))
  ! speling%jiD is the mean intensity for dust in erg cm-2 Ang-1 s-1 sr-1 with mean value on solid angle

END SUBROUTINE POMPAGE

END MODULE PXDR_RF_TOOLS
