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

! +new formulation for the non-embedded case
!  but incuding R' effects   (spring 2005) jlb
! +theory & code revision (june-july 2005) jrg
! +embedded sources preliminary coding (oct 2005) jlb+jrg

   USE PXDR_FLAGS
   USE PXDR_CONSTANTES

   IMPLICIT NONE

   REAL (KIND=dp), PUBLIC                            :: flu_rad0
   REAL (KIND=dp), PUBLIC                            :: flu_rad1
   REAL (KIND=dp), PUBLIC                            :: flu_rad2
   REAL (KIND=dp), PUBLIC                            :: int_rad0
   REAL (KIND=dp), PUBLIC                            :: int_rad1
   REAL (KIND=dp), PUBLIC                            :: int_rad2
   REAL (KIND=dp), PUBLIC                            :: alpha_m
   REAL (KIND=dp), PUBLIC                            :: alpha_p

   REAL (KIND=dp), PUBLIC                             :: G0m
   REAL (KIND=dp), PUBLIC                             :: G0p

   PRIVATE

   PUBLIC :: ETIN90, CO_UV_EXC

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

CONTAINS

SUBROUTINE ETIN90 (nwlu)

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

! Radiative transfer computation. See file transfer_S.pdf for definitions
! and comments. Index conventions:
!       l goes from 0 to lleg (first Legendre Pol. index)
!       m goes from +/- 1 to +/- mleg (second Legendre Pol. index)
!       i goes from +/- 1 to +/- nmui (discrete angles for boundary conditions)
!       n goes from 0 to npo (optical depth grid)
! 2 sides version: tmax finite and radiation are impiging from mu_i > 0 and mu_i < 0

 IMPLICIT NONE

 INTEGER, INTENT (IN)                          :: nwlu     ! Number of wavelength computed

 INTEGER                                       :: l, m, n

 ! Radiative quantities
 INTEGER                                       :: iwlg
 REAL (KIND=dp), DIMENSION(:,:),   ALLOCATABLE :: tl       ! Full optical depth
 REAL (KIND=dp), DIMENSION(:),     ALLOCATABLE :: dtl      ! Full optical depth increment
 REAL (KIND=dp), DIMENSION(:),     ALLOCATABLE :: sigl     ! Phase function

 REAL (KIND=dp), DIMENSION(:),     ALLOCATABLE :: albed    ! Albedo

 REAL (KIND=dp), DIMENSION(:),     ALLOCATABLE :: kap_dus
 REAL (KIND=dp), DIMENSION(:),     ALLOCATABLE :: sca_dus
 REAL (KIND=dp), DIMENSION(:),     ALLOCATABLE :: emm_dus
 REAL (KIND=dp), DIMENSION(:),     ALLOCATABLE :: Camp     ! Legendre amplitudes

 type(rf_type)                                 :: rf_tmp, rf_lamI

 ! Legendre polynomial related variables
 REAL (KIND=dp), DIMENSION(:),     ALLOCATABLE :: xmunl    ! -1 power l  = (-1)**l
 REAL (KIND=dp), DIMENSION(:,:),   ALLOCATABLE :: pli      ! P_l(mu_i)
 REAL (KIND=dp), DIMENSION(:),     ALLOCATABLE :: p_0
 REAL (KIND=dp), DIMENSION(:),     ALLOCATABLE :: q_0

 ! Matrix A coefficients
 REAL (KIND=dp), DIMENSION(:),     ALLOCATABLE :: hl
 REAL (KIND=dp), DIMENSION(:),     ALLOCATABLE :: wr, wi
 REAL (KIND=dp), DIMENSION(:),     ALLOCATABLE :: xkm      ! Legendre absissa
 REAL (KIND=dp), DIMENSION(:,:),   ALLOCATABLE :: Smk_m    ! integrated xkm
 REAL (KIND=dp), DIMENSION(:,:),   ALLOCATABLE :: Smk_p    ! integrated xkm
 ! We split Emk_m in chunks of size "grand" and a remain.
 INTEGER,        DIMENSION(:,:),   ALLOCATABLE :: Emk_m_n  ! INT(Smk_m / grand)
 REAL (KIND=dp), DIMENSION(:,:),   ALLOCATABLE :: Emk_m_v  ! Exp(-(Smk_m - n * grand))
 REAL (KIND=dp), DIMENSION(:,:),   ALLOCATABLE :: Emk_m    ! Exp(-Smk_m) 0 -> t - Total value
 INTEGER,        DIMENSION(:,:),   ALLOCATABLE :: Emk_p_n  ! INT(Smk_p / grand)
 REAL (KIND=dp), DIMENSION(:,:),   ALLOCATABLE :: Emk_p_v  ! EXP(-(Smk_p - n * grand))
 REAL (KIND=dp), DIMENSION(:,:),   ALLOCATABLE :: Emk_p    ! Exp(-Smk_p) t -> 0 - Total value

 REAL (KIND=dp), DIMENSION(:,:),   ALLOCATABLE :: rlm      ! Eigenvectors matrix
 REAL (KIND=dp), DIMENSION(:,:),   ALLOCATABLE :: rlmi     ! inverse of Rlm(t)

 REAL (KIND=dp), DIMENSION(:),     ALLOCATABLE :: Srm

! Source function contributions

 ! Source function expansion coeficients (as function of l and m respectively)
 REAL (KIND=dp), DIMENSION(:,:),   ALLOCATABLE :: sfl, sfm
 REAL (KIND=dp), DIMENSION(:,:),   ALLOCATABLE :: ggm      ! Inhomogeneous contribution (g vector in notes)
 REAL (KIND=dp), DIMENSION(:,:),   ALLOCATABLE :: Git      ! Product R^-1*A^-1*g vector, same DIMENSIONs as Qit

 ! Boundary conditions related variables
 REAL (KIND=dp), DIMENSION(:,:),   ALLOCATABLE :: Tim      ! Auxiliary
 REAL (KIND=dp), DIMENSION(:,:),   ALLOCATABLE :: Bim      ! BC matrix
 REAL (KIND=dp), DIMENSION(:),     ALLOCATABLE :: Iinc     ! Incident radiation field

 ! Iteration related variables
 REAL (KIND=dp), DIMENSION(:,:),   ALLOCATABLE :: Qit
 REAL (KIND=dp), DIMENSION(:,:),   ALLOCATABLE :: Qit_o
 REAL (KIND=dp), DIMENSION(:,:),   ALLOCATABLE :: Dit
 REAL (KIND=dp), DIMENSION(:,:),   ALLOCATABLE :: Yit
 REAL (KIND=dp), DIMENSION(:,:),   ALLOCATABLE :: Yit_o
 REAL (KIND=dp), DIMENSION(:),     ALLOCATABLE :: Hit

! LAPACK related variables

 ! Eigenvalues only
 CHARACTER (LEN=1)                             :: JOBZ  = 'N'
 REAL (KIND=dp), DIMENSION(:),     ALLOCATABLE :: WORK         ! Real work array
 INTEGER,        DIMENSION(:),     ALLOCATABLE :: IWORK        ! Work array
 REAL (KIND=dp), DIMENSION(:,:),   ALLOCATABLE :: aam, bbm
 REAL (KIND=dp), DIMENSION(:,:),   ALLOCATABLE :: aamf, bbmf
 INTEGER                                       :: info
 CHARACTER (LEN=1)                             :: FACT  = 'E'  ! Equilibrate system
 CHARACTER (LEN=1)                             :: TRANS = 'N'  ! Transpose
 INTEGER                                       :: nrhs
 CHARACTER (LEN=1)                             :: EQUED        ! Kind of equilibration
 REAL (KIND=dp), DIMENSION(:), ALLOCATABLE     :: R, C         ! Equilibration factors
 REAL (KIND=dp), DIMENSION(:), ALLOCATABLE     :: FERR, BERR   ! Errors (estimates)
 REAL (KIND=dp)                                :: RCOND        ! Condition number
 INTEGER, DIMENSION(:), ALLOCATABLE            :: indx

 ! Auxiliaries
 INTEGER                                       :: nl
 INTEGER                                       :: i
 INTEGER                                       :: i1, i2
 REAL (KIND=dp)                                :: ht, ymui
 REAL (KIND=dp)                                :: taux1, taux2
 REAL (KIND=dp)                                :: taux3, taux4
 REAL (KIND=dp)                                :: wlth, wlthcm
 REAL (KIND=dp), DIMENSION(:), ALLOCATABLE     :: argu
 INTEGER, DIMENSION(:,:), ALLOCATABLE          :: indmi, indmj

 ! Computation of emerging specific intensities
 REAL (KIND=dp), DIMENSION(:), ALLOCATABLE     :: fl_0, fl_max

 REAL(KIND=dp)                                 :: lambda1, lambda2
!-----------------------------------------------------------------------------

  ! Number of Legendre coefficient (used for loops that run from 1 to lleg+1)
  nl = lleg + 1

  IF (ALLOCATED(intJm)) THEN
     DEALLOCATE (intJm, intJp)
  ENDIF

  IF (ALLOCATED(I_esc_0)) DEALLOCATE(I_esc_0)
  IF (ALLOCATED(I_esc_max)) DEALLOCATE(I_esc_max)
  IF (ALLOCATED(abs_tot)) DEALLOCATE(abs_tot)
  IF (ALLOCATED(intJmp)) DEALLOCATE(intJmp)

  ALLOCATE (xmunl(0:lleg))
  ALLOCATE (pli(0:lleg,-nmui:nmui))
  ALLOCATE (p_0(0:lleg), q_0(0:lleg))
  ALLOCATE (hl(0:lleg))
  ALLOCATE (wr(lleg+1), wi(lleg+1))
  ALLOCATE (xkm(-mleg:mleg))
  ALLOCATE (Smk_m(0:npo,mleg))
  ALLOCATE (Smk_p(0:npo,mleg))
  ALLOCATE (Emk_m_n(0:npo,mleg))
  ALLOCATE (Emk_m_v(0:npo,mleg))
  ALLOCATE (Emk_m(0:npo,mleg))
  ALLOCATE (Emk_p_n(0:npo,mleg))
  ALLOCATE (Emk_p_v(0:npo,mleg))
  ALLOCATE (Emk_p(0:npo,mleg))

  ALLOCATE (rlm(0:lleg,-mleg:mleg))
  ALLOCATE (rlmi(0:lleg,-mleg:mleg))
  ALLOCATE (sfm(-mleg:mleg,0:npo))
  ALLOCATE (sfl(0:lleg,0:npo))
  ALLOCATE (ggm(-mleg:mleg,0:npo))
  ALLOCATE (Srm(mleg))
  ALLOCATE (sigl(0:lleg))
  ALLOCATE (dtl(0:npo))
  ALLOCATE (tl(0:npo,0:nwlu))
  ALLOCATE (albed(0:nwlu))
  ALLOCATE (kap_dus(0:npo))
  ALLOCATE (sca_dus(0:npo))
  ALLOCATE (emm_dus(0:npo))
  ALLOCATE (intJm(0:npo,0:nwlu))
  ALLOCATE (intJp(0:npo,0:nwlu))
  ALLOCATE (intJmp(0:npo,0:nwlu))
  ALLOCATE (R(nl), C(nl))
  ALLOCATE (FERR(1), BERR(1))
  ALLOCATE (WORK(4*nl))
  ALLOCATE (IWORK(nl))
  ALLOCATE (aam(nl,nl), bbm(nl,1))
  ALLOCATE (aamf(nl,nl), bbmf(nl,1))
  ALLOCATE (indx(nl))
  ALLOCATE (Tim(-nmui:nmui,-mleg:mleg))
  ALLOCATE (Bim(-nmui:nmui,-mleg:mleg))
  ALLOCATE (Iinc(-nmui:nmui))
  ALLOCATE (Qit(-mleg:mleg,0:npo))
  ALLOCATE (Qit_o(-mleg:mleg,0:npo))
  ALLOCATE (Git(-mleg:mleg,0:npo))
  ALLOCATE (Dit(-mleg:mleg,0:npo))
  ALLOCATE (Yit(-mleg:mleg,0:npo))
  ALLOCATE (Yit_o(-mleg:mleg,0:npo))
  ALLOCATE (Hit(-nmui:nmui))
  ALLOCATE (Camp(-nmui:nmui))
  ALLOCATE (argu(0:npo))
  ALLOCATE (indmi(mleg,0:npo), indmj(mleg,0:npo))
  ALLOCATE (fl_0(0:lleg))
  ALLOCATE (fl_max(0:lleg))
  ALLOCATE (I_esc_0(0:nwlu,-nmui:nmui))
  ALLOCATE (I_esc_max(0:nwlu,-nmui:nmui))
  ALLOCATE (abs_tot(0:nwlu))

  p_0(:)         = 0.0_dp
  q_0(:)         = 0.0_dp
  sigl(:)        = 0.0_dp
  Tim(:,:)       = 0.0_dp
  Bim(:,:)       = 0.0_dp
  Iinc(:)        = 0.0_dp
  xkm(:)         = 0.0_dp
  Qit(:,:)       = 0.0_dp
  Dit(:,:)       = 0.0_dp
  Qit_o(:,:)     = 0.0_dp
  Yit(0,0:npo)   = 0.0_dp
  Yit_o(0,0:npo) = 0.0_dp
  I_esc_0(:,:)   = 0.0_dp
  I_esc_max(:,:) = 0.0_dp

  ! This is just (-1)**l
  xmunl(0) = 1.0_dp
  DO l = 1, lleg
     xmunl(l) = - xmunl(l-1)
  ENDDO

! STEP 0 - Initialise radiative quantities
!  (boundary conditions and optical depth grid)

  !--- PREPARE SOME FILES TO STORE QUANTITIES RELATIVE TO RADIATION FIELD ---

  ! uvspec.out is the total absorption through the cloud. multiply by
  !            incident radition field to compute spectrum.

  !--- Emission spectra (specific intensity) at Legendre decomposition angles
  fichier = TRIM(out_dir)//TRIM(modele)//'.Iesc'
  PRINT *, " Escaping intensities in:", TRIM(fichier)
  OPEN (36, file=fichier, status="unknown")
  ! Write comment lines of .Iesc file
  ! --------------------------------------------------------------------------------------
  ! The angles written correspond to "theta" in the document transfer_v6.pdf put in
  ! increasing order from 6.7 to 173.3 degrees (limits of the Legende decomposition
  !  0 < theta <  90 correspond to intensity radiated toward decreasing tau (increasing s)
  ! 90 < theta < 180 correspond to intensity radiated toward increasing tau (decreasing s)
  ! The resulting intensities are computed at the end of the function. BG 09/2013
  ! --------------------------------------------------------------------------------------
  WRITE (36,'("# Emission spectra (specific intensity in erg cm-2 s-1 sr-1 Ang-1)")')
  WRITE (36,'("# provided on observer and back side of the cloud")')
  WRITE (36,'("# at each angle theta = acos(mu) of the Legendre decomposition in degrees (see transfer_v6.pdf)")')
  WRITE (36,'("# On comment line below, ob means observer side")')
  WRITE (36,'("#                        ba means back side")') 
  WRITE (36,'("#                        numeric values are angles in degrees")')
  WRITE (36,'("# Lambda[A]       ")',ADVANCE="NO")
  DO i = 1, nmui
     WRITE (36,'("I_ob:",F7.3,3x)',ADVANCE="NO") AngleLeg_deg(i)
  ENDDO
  DO i = nmui, 1, -1
     WRITE (36,'("I_ob:",F7.3,3x)',ADVANCE="NO") 180.0_dp - AngleLeg_deg(i)
  ENDDO
  DO i = 1, nmui
     WRITE (36,'("I_ba:",F7.3,3x)',ADVANCE="NO") AngleLeg_deg(i)
  ENDDO
  DO i = nmui, 1, -1
     WRITE (36,'("I_ba:",F7.3,3x)',ADVANCE="NO") 180.0_dp - AngleLeg_deg(i)
  ENDDO
  WRITE (36,*)

  !--- Extinction ------------------------------------
  fichier = TRIM(out_dir)//TRIM(modele)//'.uv'
  PRINT *, " Absorption in:", TRIM(fichier)
  OPEN (37, file=fichier, status="unknown")
  WRITE (37,'("#  W-L   EXP(-tau)  tau")')

  !--- Incident radiation field ----------------------
  fichier = TRIM(out_dir)//TRIM(modele)//'.flin'
  PRINT *, " External field:", TRIM(fichier)
  OPEN (60, file=fichier, status="unknown")
  WRITE(60,*) "9      # Number of columns"

! STEP 1 - Compute P_l(mu_i) - see recurence in Num Rec
  WRITE(iscrn,'("       Point             Angstroms       erg cm-2 s-1 A-1 sr-1")')
  ! Example on screen : iwlg =   100 wlth =        925.259  intJmp: edge =   4.5370E-08 middle =  9.0686E-26

  pli(0,:) = 1.0_dp
  DO i = 1, nmui
     ymui = xmui_M(i)
     pli(1,-i) = -ymui
     pli(1,i) = ymui
     DO l = 1, lleg-1
        pli(l+1,-i) = (-ymui*(2.0_dp*l+1.0_dp) * pli(l,-i) - l * pli(l-1,-i)) / (l+1.0_dp)
        pli(l+1,i) = xmunl(l+1) * pli(l+1,-i)
     ENDDO
  ENDDO

  p_0(0) = 1.0_dp
  q_0(1) = p_0(0) / 2.0_dp
  DO l = 1, lleg/2
     p_0(2*l) = - (2.0_dp*l-1) * p_0(2*l-2) / (2.0_dp*l)
     q_0(2*l+1) = p_0(2*l) / (2.0_dp*l+2.0_dp)
  ENDDO

  DO iwlg = 0, nwlu
     ! sigl = gg**l (Formule 48, Henyey-Greenstein phase function)
     sigl(0) = 1.0_dp
     DO l = 1, lleg
        sigl(l) = sigl(l-1) * du_prop%gcos(iwlg)
     ENDDO

     ! a - Reset to 0 most variables
     hl = 0.0_dp
     wr = 0.0_dp
     wi = 0.0_dp
     tl(:,iwlg) = 0.0_dp
     dtl = 0.0_dp

     wlth = rf_wl%Val(iwlg)
     wlthcm = wlth * 1.0e-8_dp

     ! Compute local values of absorption coef for dust and gas and dust scatering coef
     DO n = 0, npo
        kap_dus(n) = du_prop%abso(iwlg) * dens_o(n)
        sca_dus(n) = du_prop%scat(iwlg) * dens_o(n)
        emm_dus(n) = du_prop%emis(iwlg,n) * dens_o(n)
     ENDDO
     albed(iwlg) = du_prop%albe(iwlg)

     ! b - Compute optical depth grid
     !     Convert Delta Tau_v (dust at V) to Delta tau_lambda (dust at Lambda)
     !     17 Oct 2011: use dd_cm (ds) for integration
     tl(0,iwlg) = 0.0_dp
     DO n = 0, npo-1
        ht = ((kap_dus(n) + sca_dus(n)) &
           + (kap_dus(n+1) + sca_dus(n+1))) &
           * 0.5_dp * dd_cm(n+1)
        dtl(n) = ht
        tl(n+1,iwlg) = tl(n,iwlg) + ht
     ENDDO
     ! Compute total attenuation by dust + gas through whole cloud
     taux1 = tl(npo,iwlg)
     abs_tot(iwlg) = EXP(-taux1)
     WRITE (37,"(1p,3e17.7E3)") wlth, abs_tot(iwlg), taux1

! STEP 2a - Compute matrix A(tau)

     ! Formulae A2 and A3 of Roberge:
     hl(0) = 1.0_dp - albed(iwlg)
     DO l = 1, lleg
        hl(l) = (2.0_dp*l+1.0_dp) * (1.0_dp - albed(iwlg) * sigl(l))
     ENDDO
     ! Appendix C of Goicoechea & Le bourlot (2007)
     DO l = 1, lleg
        wi(l) = DBLE(l) / SQRT(hl(l-1)*hl(l))
     ENDDO
     wr = 0.0_dp

     ! Compute eigenvalues (tridiagonal symetric matrix) - LAPACK
     CALL DSTEVD(JOBZ, nl, wr, wi, aam, nl, WORK, 4*nl, IWORK, nl, info )

     ! order eigenvalues by decreasing order
     wi = wr
     DO l = 1, nl
        wr(l) = wi(nl+1-l)
     ENDDO

     ! km = 1 / lamda_m in increasing order
     DO m = 1, mleg
        xkm(m) = 1.0_dp / wr(m)
        xkm(-m) = -xkm(m)
     ENDDO

     ! Calcul des Rlm: Formule A9 de Roberge 1983
     ! Eigenvectors computed only from recurrence relations.
     DO m = 1, mleg
        rlm(0,m)  = 1.0_dp
        rlm(0,-m) = 1.0_dp
        rlm(1,m)  = (1.0_dp - albed(iwlg)) / xkm(m)
        rlm(1,-m) = -rlm(1,m)                             !jrg
        DO l = 2, lleg
           rlm(l,m) = (hl(l-1) * rlm(l-1,m) &
                      - (l-1) * xkm(m) * rlm(l-2,m)) / (l*xkm(m))
           rlm(l,-m) = xmunl(l) * rlm(l,m)
        ENDDO
     ENDDO

! STEP 2c - Compute Srm - used for mean intensity

     CALL AUX_Srm(q_0, rlm, Srm)

! STEP 3 - Compute Smk_m = Sum (xkm) (left to right) and Smk_p (right to left)
!        - Simple trapezoidal rule

     Smk_m(0,:) = 0.0_dp
     Smk_p(npo,:) = 0.0_dp
     DO m = 1, mleg
        DO n = 1, npo
           Smk_m(n,m) = Smk_m(n-1,m) + dtl(n-1) * xkm(m)
        ENDDO
        DO n = npo-1, 0, -1
           Smk_p(n,m) = Smk_p(n+1,m) + dtl(n) * xkm(m)
        ENDDO
     ENDDO

     DO m = 1, mleg
        Emk_m_n(:,m) = MIN(mgr,INT(Smk_m(:,m) / grand,ilk))
        Emk_m_v(:,m) = EXP(-(Smk_m(:,m) - Emk_m_n(:,m) * grand))
        Emk_m(:,m) = expgr(Emk_m_n(:,m)) * Emk_m_v(:,m)
        Emk_p_n(:,m) = MIN(mgr,INT(Smk_p(:,m) / grand,ilk))
        Emk_p_v(:,m) = EXP(-(Smk_p(:,m) - Emk_p_n(:,m) * grand))
        Emk_p(:,m) = expgr(Emk_p_n(:,m)) * Emk_p_v(:,m)
     ENDDO
!    DO m = 1, mleg
!       DO n = 0, npo
!          if (abs(Emk_m(n,m) - EXP(-Smk_m(n,m))) > 1.0e-10 * EXP(-Smk_m(n,m))) then
!             print *, "m", iwlg, n, m, EXP(-Smk_m(n,m)), Emk_m(n,m)
!             print *, Smk_m(n,m), Emk_m_n(n,m), Emk_m_v(n,m)
!             stop
!          endif
!          if (abs(Emk_p(n,m) - EXP(-Smk_p(n,m))) > 1.0e-10 * EXP(-Smk_p(n,m))) then
!             print *, "p", iwlg, n, m
!             print *, Emk_p(n,m), EXP(-Smk_p(n,m)), expgr(Emk_p_n(n,m))
!             print *, Smk_p(n,m), Emk_p_n(n,m), Emk_p_v(n,m)
!             stop
!          endif
!       ENDDO
!    ENDDO

! STEP 4 - Compute R**-1    !Loop to all cloud opacity points

     CALL AUX_Rlmi(rlm, hl, rlmi)

! STEP 5 - Compute source function contribution g~ = R^-1*A^-1*g (in notes)
!          JLB : Check Javier correction (not yet done here)

     DO n = 0, npo
        ! METHOD B1: approx. to continuum thermal isotropic emission
        sfl(0,n) = emm_dus(n) / (kap_dus(n) + sca_dus(n))
        sfl(1:lleg,n) = 0.0_dp
     ENDDO

     ! Put them in m,n desired order
     sfm(-mleg:-1,:) = sfl(0:mleg-1,:)
     sfm(1:mleg,:) = sfl(mleg:lleg,:)

! 5b - Compute vector g

     ggm = 0.0_dp
     DO n = 0, npo
        DO m = -mleg, -1
           l = mleg + m
           ggm(m,n) = -sfm(m,n) / ( 1.0_dp - albed(iwlg) * sigl(l) )
        ENDDO
        DO m = 1, mleg
           l = mleg + m - 1
           ggm(m,n) = -sfm(m,n) / ( 1.0_dp - albed(iwlg) * sigl(l) )
        ENDDO
     ENDDO

! 5d - Compute matrix product  R^-1*A^-1*g = Git

     CALL AUX_GIT(rlmi, ggm, xkm, Git)

! STEP 7 - Compute Tim

     DO m = 1, mleg
        DO i = 1, nmui
           taux1 = 0.0_dp
           taux2 = 0.0_dp
           taux3 = 0.0_dp
           taux4 = 0.0_dp
           DO l = 0, lleg
              taux1 = taux1 + (2.0_dp * l + 1.0_dp) * rlm(l,-m) * pli(l,-i)
              taux2 = taux2 + (2.0_dp * l + 1.0_dp) * rlm(l,m) * pli(l,-i)
              taux3 = taux3 + (2.0_dp * l + 1.0_dp) * rlm(l,-m) * pli(l,i)
              taux4 = taux4 + (2.0_dp * l + 1.0_dp) * rlm(l,m) * pli(l,i)
           ENDDO
           Tim(-i,-m) = taux1
           Tim(-i,m)  = taux2
           Tim(i,-m)  = taux3
           Tim(i,m)   = taux4
        ENDDO
     ENDDO

! STEP 8 - Compute Bim (Boundary conditions matrix)

     DO m = 1, mleg
        DO i = 1, nmui
           Bim(-i,-m) = Tim(-i,-m)
           Bim(-i,m) = Tim(-i,m) * Emk_m(npo,m)
           Bim(i,-m) = Tim(i,-m) * Emk_m(npo,m)
           Bim(i,m) = Tim(i,m)
        ENDDO
     ENDDO

! STEP 9 - Set boundary conditions

     ! Add potential // source (star)
     WRITE (60, '(1p,5e15.6E3)') wlth, I_incr_m(iwlg), rf_incIm%Val(iwlg) &
                               , I_incr_p(iwlg), rf_incIp%Val(iwlg)

     ! 19 XII 2005 - Use "REAL" units (specific intensity)
     Iinc(-nmui:-1) = rf_incIm%Val(iwlg)
     Iinc(1:nmui)   = rf_incIp%Val(iwlg)

     ! JLB - 4 IX 08 : Checked after outgoing intensities have been computed
     !                 xmui_M(1) = 0.99... so theta = 0 is on +1 and theta = pi on -1
     Iinc(-1) = rf_incIm%Val(iwlg) + I_incr_m(iwlg)
     Iinc(1)  = rf_incIp%Val(iwlg) + I_incr_p(iwlg)

! STEP 11 - Compute D  - Simple trapezoidal rule

     ! New procedure - simplified and fast
     Dit(-mleg:-1,0) = 0.0_dp
     DO m = -mleg, -1
        DO n = 1, npo
           IF (Emk_m_v(n,-m) == 0.0_dp) EXIT
           IF (Emk_m_n(n,-m) /= Emk_m_n(n-1,-m)) THEN
              taux1 = expgr(1)
           ELSE
              taux1 = 1.0_dp
           ENDIF
!          print *, m, n, Emk_m_v(n,-m), Emk_m_v(n-1,-m)
!          print *, "      ", Dit(m,n-1), Git(m,n-1), Git(m,n)
           Dit(m,n) = taux1 * (Emk_m_v(n,-m) / Emk_m_v(n-1,-m)) * (Dit(m,n-1) - 0.5_dp * Git(m,n-1) * dtl(n-1)) &
                    - 0.5_dp * Git(m,n) * dtl(n-1)
        ENDDO
     ENDDO

     Dit(1:mleg,npo) = 0.0_dp
     DO m = 1, mleg
        DO n = npo-1, 0, -1
           IF (Emk_p_v(n,m) == 0.0_dp) EXIT
           IF (Emk_p_n(n,m) /= Emk_p_n(n+1,m)) THEN
              taux1 = expgr(1)
           ELSE
              taux1 = 1.0_dp
           ENDIF
           Dit(m,n) = taux1 * (Emk_p_v(n,m) / Emk_p_v(n+1,m)) * (Dit(m,n+1) - 0.5_dp * Git(m,n+1) * dtl(n)) &
                    - 0.5_dp * Git(m,n) * dtl(n)
        ENDDO
     ENDDO

! STEP 12 - Compute Hit

     Hit = 0.0_dp
     DO i = 1, nmui
        taux1 = 0.0_dp
        taux2 = 0.0_dp
        DO m = 1, mleg
           taux1 = taux1 + Dit(-m,npo) * Tim(i,-m)
           taux2 = taux2 + Dit(m,0) * Tim(-i,m)
        ENDDO
        Hit(-i) = Iinc(-i) - taux2
        Hit(i) = Iinc(i) + taux1
     ENDDO

! STEP 13 - solve using LAPACK

     aam(1:nmui,1:mleg) = Bim(-nmui:-1,-mleg:-1)
     aam(1:nmui,mleg+1:2*mleg) = Bim(-nmui:-1,1:mleg)
     aam(nmui+1:nl,1:mleg) = Bim(1:nmui,-mleg:-1)
     aam(nmui+1:nl,mleg+1:nl) = Bim(1:nmui,1:mleg)

     bbm(1:nmui,1) = Hit(-nmui:-1)
     bbm(nmui+1:nl,1) = Hit(1:nmui)

     nrhs = 1
     CALL DGESVX (FACT, TRANS, nl, nrhs, aam, nl, aamf, nl, indx, EQUED, &
          R, C, bbm, nl, bbmf, nl, RCOND, FERR, BERR, WORK, IWORK, info)

     Camp(-nmui:-1) = bbmf(1:nmui,1)
     Camp(1:nmui) = bbmf(nmui+1:nl,1)

! STEP 14 - Compute Y

     DO n = 0, npo
        DO m = 1, mleg
           Yit(-m,n) = Camp(-m) * Emk_m(n,m) - Dit(-m,n)
           Yit(m,n)  = Camp(m)  * Emk_p(n,m) + Dit(m,n)
        ENDDO
     ENDDO

! STEP 17 - Compute radiation field - mean intensity
!           intJm is 0.5 SUM(-1->0) of I
!           intJp is 0.5 SUM(0->1) of I
!           intJmp is 0.5 SUM(-1->1) of I
!           Thus intJm + intJp = J in erg cm-2 s-1 A-1 sterad-1
!           one gets u in erg cm-3 A-1 by u = J * 4 pi / c

     DO n = 0, npo
        taux1 = 0.0_dp
        taux2 = 0.0_dp
        taux3 = 0.0_dp
        DO m = 1, mleg
           taux1 = taux1 + Yit(-m,n) * (1.0_dp + Srm(m)) &
                         + Yit(m,n) * (1.0_dp - Srm(m))
           taux2 = taux2 + Yit(-m,n) * (1.0_dp - Srm(m)) &
                         + Yit(m,n) * (1.0_dp + Srm(m))
           taux3 = taux3 + Yit(-m,n) +  Yit(m,n)
        ENDDO

        ! 19 XII 2005 - Change normalisation
        intJm(n,iwlg) = 0.5_dp * taux1
        intJp(n,iwlg) = 0.5_dp * taux2
        intJmp(n,iwlg) = taux3
     ENDDO

     IF (MOD(iwlg,100) == 0) THEN
        WRITE(iscrn,'("iwlg = ",I6," wlth[A] = ",F16.3,"  intJmp: edge = ",1p,E12.4," middle =",1p,E12.4)') &
              iwlg, wlth, intJmp(0,iwlg), intJmp(INT(npo/2),iwlg)
     ENDIF

     ! Compute emerging specific intensities
     DO l = 0, lleg
        fl_0(l) = 0.0_dp
        fl_max(l) = 0.0_dp
        DO m = 1, mleg
           fl_0(l) = fl_0(l) + rlm(l,m) * Yit(m,0) + rlm(l,-m) * Yit(-m,0)
           fl_max(l) = fl_max(l) + rlm(l,m) * Yit(m,npo) + rlm(l,-m) * Yit(-m,npo)
        ENDDO
     ENDDO

     DO i = 1, nmui
        I_esc_0(iwlg,-i) = 0.0_dp
        I_esc_0(iwlg,i)  = 0.0_dp
        I_esc_max(iwlg,-i) = 0.0_dp
        I_esc_max(iwlg,i)  = 0.0_dp
        DO l = 0, lleg
           I_esc_0(iwlg,-i) = I_esc_0(iwlg,-i) + (2.0_dp*l+1.0_dp) * fl_0(l) * pli(l,-i)
           I_esc_0(iwlg,i)  = I_esc_0(iwlg,i)  + (2.0_dp*l+1.0_dp) * fl_0(l) * pli(l,i)
           I_esc_max(iwlg,-i) = I_esc_max(iwlg,-i) + (2.0_dp*l+1.0_dp) * fl_max(l) * pli(l,-i)
           I_esc_max(iwlg,i)  = I_esc_max(iwlg,i)  + (2.0_dp*l+1.0_dp) * fl_max(l) * pli(l,i)
        ENDDO
     ENDDO
     WRITE (36,'(1p,163e15.6)') wlth, (I_esc_0(iwlg,i), i=1,nmui), (I_esc_0(iwlg,i), i=-nmui,-1) &
                              , (I_esc_max(iwlg,i), i=1,nmui), (I_esc_max(iwlg,i), i=-nmui,-1)
  ENDDO    !end wavelenght loop :: 99  !too slow !!

  CLOSE (36)
  CLOSE (37)
  CLOSE (60)

  lambda1 = 3.0e+0_dp
  lambda2 = 1.0e+3_dp
  Icont_3_1000   = INTEG_TAB(I_esc_0(0:nwlu,1),nwlu,lambda1,lambda2)
  lambda1 = 2.5e+1_dp
  lambda2 = 6.0e+1_dp
  Icont_25_60    = INTEG_TAB(I_esc_0(0:nwlu,1),nwlu,lambda1,lambda2)
  lambda1 = 6.0e+1_dp
  lambda2 = 2.0e+2_dp
  Icont_60_200   = INTEG_TAB(I_esc_0(0:nwlu,1),nwlu,lambda1,lambda2)
  lambda1 = 2.0e+2_dp
  lambda2 = 1.0e+3_dp
  Icont_200_1000 = INTEG_TAB(I_esc_0(0:nwlu,1),nwlu,lambda1,lambda2)
  lambda1 = 6.0e+1_dp
  lambda2 = 1.0e+3_dp
  Icont_60_1000  = INTEG_TAB(I_esc_0(0:nwlu,1),nwlu,lambda1,lambda2)

  IF (F_W_RF_ALB == 1) THEN
     ! Write here full radiation field
     fichier = TRIM(out_dir)//TRIM(modele)//'.rf'
     OPEN(60, file=fichier, status="unknown" , form = 'unformatted')
     WRITE (60) rf_wl%upper-rf_wl%lower+1 ! number of pixels in wavelength grid
     WRITE (60) rf_wl%Val                 ! Wavelength grid in Angstroms
     DO n = 0, npo
        WRITE (60) tau_o(n)*tautav, intJmp(n,:) * J_to_u
     ENDDO
     CLOSE (60)
  ENDIF

  ! Free memory
  DEALLOCATE (xmunl)
  DEALLOCATE (pli)
  DEALLOCATE (p_0, q_0)
  DEALLOCATE (hl)
  DEALLOCATE (wr, wi)
  DEALLOCATE (xkm)
  DEALLOCATE (Emk_m_n)
  DEALLOCATE (Emk_m_v)
  DEALLOCATE (Emk_m)
  DEALLOCATE (Emk_p_n)
  DEALLOCATE (Emk_p_v)
  DEALLOCATE (Emk_p)
  DEALLOCATE (Smk_m, Smk_p)
  DEALLOCATE (rlm, rlmi)
  DEALLOCATE (sfl, sfm)
  DEALLOCATE (Srm)
  DEALLOCATE (sigl)
  DEALLOCATE (tl, dtl)
  DEALLOCATE (albed)
  DEALLOCATE (kap_dus, sca_dus, emm_dus)
  DEALLOCATE (aam, bbm)
  DEALLOCATE (aamf, bbmf)
  DEALLOCATE (Tim, Bim)
  DEALLOCATE (Iinc)
  DEALLOCATE (ggm)
  DEALLOCATE (Dit)
  DEALLOCATE (Qit, Qit_o, Git, Yit, Yit_o)
  DEALLOCATE (Hit)
  DEALLOCATE (R, C)
  DEALLOCATE (FERR, BERR)
  DEALLOCATE (WORK, IWORK)
  DEALLOCATE (Camp)
  DEALLOCATE (indx)
  DEALLOCATE (argu)
  DEALLOCATE (indmi, indmj)
  DEALLOCATE (fl_0)
  DEALLOCATE (fl_max)

  !====================================================================================
  ! COMPUTE THE RADIATION FIELD INTENSITY AND ENERGY FROM THE RIGHT AND LEFT SIDE
  ! (USE RF_U AS AUXILIARY VARIABLE HERE)
  ! The goal is to obtain mean_rad(1,2),  int_rad(1,2),  rad(m,p),  and flu_rad(1,2)
  ! The goal is to obtain mean_xray(1,2), int_xray(1,2), xray(m,p), and flu_xray(1,2)
  ! note BG 04/2013: is it important to do right first ?
  !====================================================================================
  CALL RF_CREATE(rf_lamI,0,nwlu)
  CALL RF_CREATE(rf_tmp,1,2)

  !--------------------------------------------------------------------------------
  ! Integration of UV radiation field from Lyman up to Habing limit
  ! (wl_lym = 911 Å ; wl_hab = 2400 Å) - BG 04/2013
  !--------------------------------------------------------------------------------
  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)
  ! -------------------
  rf_u%Val(0:nwlu)    = intJp(npo,0:nwlu)
  mean_rad2           = SECT_INT(rf_tmp, rf_u, wl_pointer, wl_hab)
  rf_u%Val(0:nwlu)    = intJm(0  ,0:nwlu)
  mean_rad1           = SECT_INT(rf_tmp, rf_u, wl_pointer, wl_hab)
  ! -------------------
  rf_u%Val(0:nwlu)    = intJmp(npo,0:nwlu) * J_to_u
  int_rad2            = SECT_INT(rf_tmp, rf_u, wl_pointer, wl_hab)
  radp                = int_rad2 / int_rad0
  rf_u%Val(0:nwlu)    = intJmp(0  ,0:nwlu) * J_to_u
  int_rad1            = SECT_INT(rf_tmp, rf_u, wl_pointer, wl_hab)
  radm                = int_rad1 / int_rad0
  int_rad(0)          = SECT_INT(rf_tmp, rf_u, wl_pointer, wl_hab)
  ! -------------------
  rf_lamI%Val(0:nwlu) = intJmp(npo,0:nwlu) * J_to_u* rf_wl%Val(0:nwlu)
  flu_rad2            = SECT_INT(rf_tmp, rf_lamI, wl_pointer, wl_hab) / (1.0e8_dp * xhp)
  rf_lamI%Val(0:nwlu) = intJmp(0  ,0:nwlu) * J_to_u* rf_wl%Val(0:nwlu)
  flu_rad1            = SECT_INT(rf_tmp, rf_lamI, wl_pointer, wl_hab) / (1.0e8_dp * xhp)

  !--------------------------------------------------------------------------------
  ! Writing the results of these integrations on the screen and in the .def file
  !--------------------------------------------------------------------------------
  PRINT *, " "
  PRINT *, " Scaled field at cloud edge"
  WRITE (iscrn, '("  U2_UV:",1pe12.4," erg cm-3,     ","from",0pf9.2," to",0pf9.2," Angstrom")') int_rad2,  wl_lym,  wl_hab
  WRITE (iscrn, '("  F2_UV:",1pe12.4," phot cm-2 s-1,","from",0pf9.2," to",0pf9.2," Angstrom")') flu_rad2,  wl_lym,  wl_hab
  WRITE (iwrit2,'("  U2_UV:",1pe12.4," erg cm-3,     ","from",0pf9.2," to",0pf9.2," Angstrom")') int_rad2,  wl_lym,  wl_hab
  WRITE (iwrit2,'("  F2_UV:",1pe12.4," phot cm-2 s-1,","from",0pf9.2," to",0pf9.2," Angstrom")') flu_rad2,  wl_lym,  wl_hab
  !--------------------------------------------------------------------------------
  WRITE (iscrn, '("  U1_UV:",1pe12.4," erg cm-3,     ","from",0pf9.2," to",0pf9.2," Angstrom")') int_rad1,  wl_lym,  wl_hab
  WRITE (iscrn, '("  F1_UV:",1pe12.4," phot cm-2 s-1,","from",0pf9.2," to",0pf9.2," Angstrom")') flu_rad1,  wl_lym,  wl_hab
  WRITE (iwrit2,'("  U1_UV:",1pe12.4," erg cm-3,     ","from",0pf9.2," to",0pf9.2," Angstrom")') int_rad1,  wl_lym,  wl_hab
  WRITE (iwrit2,'("  F1_UV:",1pe12.4," phot cm-2 s-1,","from",0pf9.2," to",0pf9.2," Angstrom")') flu_rad1,  wl_lym,  wl_hab

  !---------------------------------------------------------------------
  ! Compute the effective UV scaling factors in units of G0 and FX0/clum
  !---------------------------------------------------------------------
  G0m = int_rad1  / u_habing
  G0p = int_rad2  / u_habing
  WRITE(iwrit2,'(/," U0:",1pe13.4, " erg cm-3")') int_rad0
  PRINT *, " "
  WRITE (iscrn,'("  G_0m :",1pe12.4," (in Habing units)")') G0m
  WRITE (iscrn,'("  G_0p :",1pe12.4," (in Habing units)")') G0p
  WRITE(iwrit2,'(" G_0m =", 1pe12.3, " in Habing units",/)') G0m
  WRITE(iwrit2,'(" G_0p =", 1pe12.3, " in Habing units",/)') G0p
  PRINT *, " "
  PRINT *, " Effective Radiation field strength AT the edge:"
  WRITE (iscrn, '("  left :",1pe12.4," ",a15)') radm,  ISRF_name
  WRITE (iscrn, '(" right :",1pe12.4," ",a15)') radp,  ISRF_name
  WRITE (iwrit2,'("  left :",1pe12.4," ",a15)') radm,  ISRF_name
  WRITE (iwrit2,'(" right :",1pe12.4," ",a15)') radp,  ISRF_name
  PRINT *, " "

  CALL RF_FREE (rf_tmp)
  CALL RF_FREE (rf_lamI)

END SUBROUTINE ETIN90

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

!**************************
SUBROUTINE CO_UV_EXC (iopt)
!**************************

    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

    IMPLICIT NONE

    INTEGER, INTENT (IN) :: iopt

    INTEGER              :: il2, il1
    INTEGER              :: j
    INTEGER              :: ll, levu, lMX
    INTEGER              :: iwlg
    REAL (KIND=dp)       :: coef, beinst, wl
    REAL (KIND=dp)       :: toto
    REAL (KIND=dp)       :: gl, gu
    REAL (KIND=dp)       :: J_rad

    REAL (KIND=dp), ALLOCATABLE, DIMENSION (:,:) :: absorb

    coef = 1.0e-32_dp / (2.0 * xhp * clum**2)

    UV_exc_CO = 0.0_dp
    lMX = spec_lin(in_sp(i_co))%use
    ALLOCATE (absorb(lMX,SIZE(lm_CO_A,2)))

    ! Interpolation location in previous grid
    DO j = 1, npo
       IF (tau(iopt) <= tau_o(j)) THEN
          icd_o = j-1
          EXIT
       ENDIF
    ENDDO

    raptau = (tau(iopt) - tau_o(icd_o)) / dtau_o(icd_o+1)

    DO il2 = 1, lMX
       gl = spec_lin(in_sp(i_co))%gst(il2)
       toto = 0.0_dp
       DO ll = 1, lm_CO_A(il2,0)
          levu = lm_CO_A(il2,ll)
          gu = 2.0_dp * DBLE(J_CO_A(levu)) + 1.0_dp
          wl = lam_CO_A(levu,il2)
          beinst = coef * (gl / gu) * wl**5 * Aij_CO_A(levu,il2)
          CALL RF_LOCATE(rf_wl, wl, iwlg)
          J_rad = intJmp(icd_o,iwlg) + (intJmp(icd_o+1,iwlg) - intJmp(icd_o,iwlg)) * raptau
          absorb(il2,ll) = beinst * J_rad
          toto = toto + absorb(il2,ll)
       ENDDO
       UV_exc_CO(il2,il2) = toto
    ENDDO

    DO il2 = 1, lMX
       DO il1 = 1, lMX
          toto = 0.0_dp
          DO ll = 1, lm_CO_A(il2,0)
             levu = lm_CO_A(il2,ll)
             toto = toto + absorb(il2,ll) * Cij_CO_X(levu,il1)
          ENDDO
          UV_exc_CO(il2,il1) = UV_exc_CO(il2,il1) - toto
       ENDDO
    ENDDO

    DEALLOCATE (absorb)

END SUBROUTINE CO_UV_EXC

END MODULE PXDR_TRANSFER
