
! Copyright (C) 2002 - Observatoire de Paris/Meudon
!                      Universite Paris 7
!                      CNRS (France)
!                      Contact : Jacques.Lebourlot@obspm.fr
!
! This program is free software; you can redistribute it and/or
! modify it under the terms of the GNU General Public License version 2
! as published by the Free Software Foundation.
!
! This program is distributed in the hope that it will be useful,
! but WITHOUT ANY WARRANTY; without even the implied warranty of
! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
! GNU General Public License for more details.
!
! You should have received a copy of the GNU General Public License
! along with this program; if not, write to the Free Software
! Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.

! JLB - 22 May 2008

MODULE PXDR_FGK_TR

  USE PXDR_CONSTANTES

  PRIVATE

  PUBLIC :: FGKTR2, FGKDAT

CONTAINS

!%%%%%%%%%%%%%%%%%%%%%%%
SUBROUTINE FGKTR2 (iopt)
!%%%%%%%%%%%%%%%%%%%%%%%
! Interpolates the dust temperature, min, moy, and max charges, photoelectric emission and
! heating rates for the current position in the cloud ... it may be better to do this in a
! different function since it has nothing to do with the FGK approximation.
!
! Computes line absorption using FGK (Federman, Glassgold, & Kwan 1979) approximation
! Interpolates the radiation from both sides for the current position. The radiation field
! is defined in PXDR_RF_INIT.f90 and the transfer is solved in PXDR_TRANSFER.f90

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

   IMPLICIT NONE

   INTEGER, INTENT (IN)                       :: iopt

   REAL (KIND=dp), DIMENSION (nlevh2)         :: cdh2f
   REAL (KIND=dp), DIMENSION (nlevhd)         :: cdhdf
   REAL (KIND=dp), DIMENSION (nlevh2)         :: cdh2r
   REAL (KIND=dp), DIMENSION (nlevhd)         :: cdhdr
   REAL (KIND=dp), DIMENSION(:), ALLOCATABLE  :: cdc0f
   REAL (KIND=dp), DIMENSION(:), ALLOCATABLE  :: cdc1f
   REAL (KIND=dp), DIMENSION(:), ALLOCATABLE  :: cdc2f
   REAL (KIND=dp), DIMENSION(:), ALLOCATABLE  :: cdc3f
   REAL (KIND=dp), DIMENSION(:), ALLOCATABLE  :: cdc0r
   REAL (KIND=dp), DIMENSION(:), ALLOCATABLE  :: cdc1r
   REAL (KIND=dp), DIMENSION(:), ALLOCATABLE  :: cdc2r
   REAL (KIND=dp), DIMENSION(:), ALLOCATABLE  :: cdc3r
   REAL (KIND=dp), DIMENSION (0:noptm)        :: cdtau

   REAL (KIND=dp)                             :: ress
   REAL (KIND=dp)                             :: ajrf
   REAL (KIND=dp)                             :: vt2

   REAL (KIND=dp), DIMENSION(0:nwlg)          :: intJ1, intJ2
   TYPE (RF_TYPE)                             :: rf_tmp

   REAL (KIND=dp)                             :: ff1 = 3.02_dp
   REAL (KIND=dp)                             :: ff2 = 1.0e3_dp
   REAL (KIND=dp)                             :: ff3 = 6.4e-2_dp
   INTEGER                                    :: i, j, k, iwlg, mm, lev
   INTEGER                                    :: njl, nvl, krai, njj
   INTEGER                                    :: jwl
   REAL (KIND=dp)                             :: cdinf, aux1, aux2
   REAL (KIND=dp)                             :: bdop, ct1, rapwl
   REAL (KIND=dp)                             :: xlam0, gama, betas, betas0
   REAL (KIND=dp)                             :: r, t1, opt0, taudf, u1f
   REAL (KIND=dp)                             :: taudfr, u1fr, ajrfr
   REAL (KIND=dp), DIMENSION (:), ALLOCATABLE :: fgkrf                 ! Line absorption (direct)
   REAL (KIND=dp), DIMENSION (:), ALLOCATABLE :: fgkrfr                ! Line absorption (reverse)

   REAL (KIND=dp)                             :: lgrtau                ! logarithmic interpolation

   IF (i_co /= 0) THEN
      ALLOCATE (cdc0f(spec_lin(in_sp(i_co))%use))
      ALLOCATE (cdc0r(spec_lin(in_sp(i_co))%use))
   ENDIF
   IF (j_c13o /= 0) THEN
      ALLOCATE (cdc1f(spec_lin(in_sp(j_c13o))%use))
      ALLOCATE (cdc1r(spec_lin(in_sp(j_c13o))%use))
   ENDIF
   IF (j_co18 /= 0) THEN
      ALLOCATE (cdc2f(spec_lin(in_sp(j_co18))%use))
      ALLOCATE (cdc2r(spec_lin(in_sp(j_co18))%use))
   ENDIF
   IF (j_c13o18 /= 0) THEN
      ALLOCATE (cdc3f(spec_lin(in_sp(j_c13o18))%use))
      ALLOCATE (cdc3r(spec_lin(in_sp(j_c13o18))%use))
   ENDIF

   ! ------------------------------------------------------------------------------------
   ! 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)
   IF ( (icd_o == 0) .OR. (icd_o == npo) ) THEN
      lgrtau = 0
   ELSE
      lgrtau = LOG( tau(iopt) / tau_o(icd_o) ) / LOG( tau_o(icd_o+1) / tau_o(icd_o) )
   ENDIF

   ! ------------------------------------------------------------------------------------
   ! Interpolate the dust temperature on the new grid of optical depth
   ! ------------------------------------------------------------------------------------
   DO mm = 1, npg
         IF ( (icd_o == 0) .OR. (icd_o == npo) ) THEN
            tdust(mm,iopt) = tdust_o(mm,icd_o)
         ELSE IF ( (tdust_o(mm,icd_o) < istiny) .OR. (tdust_o(mm,icd_o+1) < istiny) ) THEN
            ! ---------------------------------------------------------------------------
            ! linear interpolation
            ! ---------------------------------------------------------------------------
            tdust(mm,iopt) = tdust_o(mm,icd_o) + raptau * (tdust_o(mm,icd_o+1) - tdust_o(mm,icd_o))
         ELSE
            ! ---------------------------------------------------------------------------
            ! logarithmic interpolation
            ! ---------------------------------------------------------------------------
            tdust(mm,iopt) = LOG( tdust_o(mm,icd_o) ) + lgrtau * LOG( tdust_o(mm,icd_o+1) / tdust_o(mm,icd_o) )
            tdust(mm,iopt) = EXP( tdust(mm,iopt) )
         ENDIF
   ENDDO

   ! ------------------------------------------------------------------------------------
   ! Radiation field attenuation between the edge of the cloud and the present position
   ! See Flannery, Roberge, Rybicki, Ap J, 236, 598 (1980)
   ! ------------------------------------------------------------------------------------
   vt2 = vturb * vturb
   intJ1 = 0.0_dp
   intJ2 = 0.0_dp
   DO iwlg = 0, nwlg
      IF ( (icd_o == 0).OR.(icd_o == npo) ) THEN
         intJ1(iwlg)    = intJm(icd_o,iwlg)
         intJ2(iwlg)    = intJp(icd_o,iwlg)
         rf_u%Val(iwlg) = intJmp(icd_o,iwlg) * J_to_u
      ELSE
         ! ------------------------------------------------------------------------------
         ! Select linear or logarithmic interpolation depending on the values
         ! ------------------------------------------------------------------------------
         IF ( (intJm(icd_o,iwlg) < istiny).OR.(intJm(icd_o+1,iwlg) < istiny) ) THEN
            intJ1(iwlg)    = INTERPCD(raptau, intJm(0:npo,iwlg), icd_o, npo)
         ELSE
            intJ1(iwlg)    = INTERPLCD(lgrtau, intJm(0:npo,iwlg),  icd_o, npo)
         ENDIF
         IF ( (intJp(icd_o,iwlg) < istiny).OR.(intJp(icd_o+1,iwlg) < istiny) ) THEN
            intJ2(iwlg)    = INTERPCD(raptau, intJp(0:npo,iwlg), icd_o, npo)
         ELSE
            intJ2(iwlg)    = INTERPLCD(lgrtau, intJp(0:npo,iwlg),  icd_o, npo)
         ENDIF
         IF ( (intJmp(icd_o,iwlg) < istiny).OR.(intJmp(icd_o+1,iwlg) < istiny) ) THEN
            rf_u%Val(iwlg) = INTERPCD(raptau, intJmp(0:npo,iwlg), icd_o, npo) * J_to_u
         ELSE
            rf_u%Val(iwlg) = INTERPLCD(lgrtau, intJmp(0:npo,iwlg), icd_o, npo) * J_to_u
         ENDIF
      ENDIF
   ENDDO

   CALL RF_CREATE(rf_tmp, rf_wl%lower, rf_wl%upper)
   rf_tmp%Ord = rf_u%Ord
   DO mm = 1, npg
      rf_tmp%Val = rf_u%Val
      CALL SECT_PRI(sigabs(mm), rf_tmp, wl_pointer, si_, nwlg)
      si_QU(mm,:) = si_
      rf_tmp%Val = rf_tmp%Val * rf_wl%Val
      CALL SECT_PRI(sigabs(mm), rf_tmp, wl_pointer, si_, nwlg)
      si_QUl(mm,:) = si_
      rf_tmp%Val = rf_tmp%Val * rf_wl%Val
      CALL SECT_PRI(sigabs(mm), rf_tmp, wl_pointer, si_, nwlg)
      si_QUl2(mm,:) = si_
   ENDDO
   CALL RF_FREE (rf_tmp)

   ! ************************************************************************************
   !               ct1= pi e^2/mc = 2.654057e-2_dp
   !                  =(section d absorption totale integree sur les frequences)
   !                    en cm^2
   !               vturb donne en cm s-1
   !               bdop:  DIMENSION vitesse cm s-1 a
   ! ************************************************************************************

   ! ------------------------------------------------------------------------------------
   ! CDUNIT Gas to dust ratio : NH = CDUNIT * E(B-V)
   ! RRR Extinction to color index ratio : Av = RRR * E(B-V)
   ! ------------------------------------------------------------------------------------
   ct1 = xpi * xqe2 / xme / clum

   ! ------------------------------------------------------------------------------------
   ! Computes Doppler width weighted H2 column density for each level
   ! If "one side", THEN the true optical depth towards "dark" side is high
   ! ------------------------------------------------------------------------------------
   IF (isoneside == 0) THEN
      cdinf = 1.0_dp
   ELSE
      cdinf = 10.0_dp
   ENDIF

   ! ------------------------------------------------------------------------------------
   ! Ratio of turbulent Doppler width to total Doppler width
   ! This ratio does not depend on the line because lambda disapears
   ! ------------------------------------------------------------------------------------
   DO lev = 1, l0h2
      cdtau(0:npo) = cdth2(lev,0:npo)
      ress = INTERPCD(raptau, cdtau(0:npo), icd_o, npo)
      cdh2f(lev) = ress
      cdh2r(lev) = MAX(0.0_dp,cdinf * cdtau(npo) - ress)
   ENDDO

   ! ------------------------------------------------------------------------------------
   ! Computes Doppler width weighted HD column density for each level
   ! ------------------------------------------------------------------------------------
   IF (i_hd /= 0) THEN
      DO lev = 1, l0hd
         cdtau(0:npo) = cdthd(lev,0:npo)
         ress = INTERPCD(raptau, cdtau(0:npo), icd_o, npo)
         cdhdf(lev) = ress
         cdhdr(lev) = MAX(0.0_dp,cdinf * cdtau(npo) - ress)
      ENDDO
   ENDIF

   ! ------------------------------------------------------------------------------------
   ! Computes Doppler width weighted CO column density for each level
   ! ------------------------------------------------------------------------------------
   IF (i_co /= 0) THEN
      DO j = 1, spec_lin(in_sp(i_co))%use
         cdtau(0:npo) = cdtco(j,:)
         ress = INTERPCD(raptau, cdtau, icd_o, npo)
         cdc0f(j) = ress
         cdc0r(j) = MAX(0.0_dp,cdinf * cdtau(npo) - ress)
      ENDDO
   ENDIF

   ! ------------------------------------------------------------------------------------
   ! Computes Doppler width weighted 13CO column density for each level
   ! ------------------------------------------------------------------------------------
   IF (i_c13 /= 0) THEN
      DO j = 1, spec_lin(in_sp(j_c13o))%use
         cdtau(0:npo) = cdtc13o(j,:)
         ress = INTERPCD(raptau, cdtau, icd_o, npo)
         cdc1f(j) = ress
         cdc1r(j) = MAX(0.0_dp,cdinf * cdtau(npo) - ress)
      ENDDO
   ENDIF

   ! ------------------------------------------------------------------------------------
   ! Computes Doppler width weighted C18O column density for each level
   ! ------------------------------------------------------------------------------------
   IF (i_o18 /= 0) THEN
      DO j = 1, spec_lin(in_sp(j_co18))%use
         cdtau(0:npo) = cdtco18(j,:)
         ress = INTERPCD(raptau, cdtau, icd_o, npo)
         cdc2f(j) = ress
         cdc2r(j) = MAX(0.0_dp,cdinf * cdtau(npo) - ress)
      ENDDO
   ENDIF

   ! ------------------------------------------------------------------------------------
   ! Computes Doppler width weighted 13C18O column density for each level
   ! ------------------------------------------------------------------------------------
   IF (i_c13o18 /= 0) THEN
      DO j = 1, spec_lin(in_sp(j_c13o18))%use
         cdtau(0:npo) = cdtc13o18(j,:)
         ress = INTERPCD(raptau, cdtau, icd_o, npo)
         cdc3f(j) = ress
         cdc3r(j) = MAX(0.0_dp,cdinf * cdtau(npo) - ress)
      ENDDO
   ENDIF

   IF (.NOT. ALLOCATED(fgkrf)) THEN
     ALLOCATE (fgkrf(mfgk), fgkrfr(mfgk))
   ENDIF

   fgkrf = 1.0_dp
   fgkrfr = 1.0_dp

!  Reminder:
! irah2b : Line PARAMETERs (INTEGER values - Lyman)
! irah2c : Line PARAMETERs (INTEGER values - Werner)
!          1: v lower level
!          2: J lower level
!          3: v upper level
!          4: Delta J (J_up = J_low + Delta J)
!          5: used in full transfer? (0: no, 1: yes)
!          6: lower limit of line in WL grid
!          7: upper limit of line in WL grid
!          8: index of line in WL grid
! prah2b : Line PARAMETERs (REAL values - Lyman)
! prah2c : Line PARAMETERs (REAL values - Werner)
!          1: oscilator strength
!          2: wave length (Angstrom)
!          3: inverse life time (s-1)
!          4: Upper level dissociation probability
!          5: WL min in line profile
!          6: WL max in line profile

   ! Computes H2 line profiles
   bdop = 1.0e8_dp * SQRT(vt2 + deksamu * tgaz(iopt) / spec_lin(in_sp(i_h2))%mom)

   DO i = 1, nrh2bt
      njl = irah2b(i,2)
      nvl = irah2b(i,1)
      lev = lev_h2(nvl,njl)
      xlam0 = prah2b(i,2)
      gama = prah2b(i,3) / (4.0_dp * xpi)
      betas = bdop / xlam0

      betas0 = 1.0e8_dp * vturb / xlam0
      r     = gama / (sqpi * betas)
      t1    = ff1 * (ff2 * r) ** (-ff3)
      opt0  = ct1 * prah2b(i,1) / (sqpi * betas0)
      taudf = opt0 * cdh2f(lev)
      u1f   = SQRT(taudf * r) / t1
      ajrf  = (r / t1) / SQRT(u1f * u1f + xpi / 4.0_dp)
      taudfr = opt0 * cdh2r(lev)
      u1fr   = SQRT(taudfr * r) / t1
      ajrfr  = (r / t1) / SQRT(u1fr * u1fr + xpi / 4.0_dp)

      fgkrf(i) = MIN(AJDF(taudf) + ajrf, 1.0_dp)
      fgkrfr(i) = MIN(AJDF(taudfr) + ajrfr, 1.0_dp)
   ENDDO
   krai = nrh2bt

   DO i = 1, nrh2ct
      njl = irah2c(i,2)
      nvl = irah2c(i,1)
      lev = lev_h2(nvl,njl)
      xlam0 = prah2c(i,2)
      gama = prah2c(i,3) / (4.0_dp * xpi)
      betas = bdop / xlam0

      betas0 = 1.0e8_dp * vturb / xlam0
      r     = gama / (sqpi * betas)
      t1    = ff1 * (ff2 * r) ** (-ff3)
      opt0  = ct1 * prah2c(i,1) / (sqpi * betas0)
      taudf = opt0 * cdh2f(lev)
      u1f   = SQRT(taudf * r) / t1
      ajrf  = (r / t1) / SQRT(u1f * u1f + xpi / 4.0_dp)
      taudfr = opt0 * cdh2r(lev)
      u1fr   = SQRT(taudfr * r) / t1
      ajrfr  = (r / t1) / SQRT(u1fr * u1fr + xpi / 4.0_dp)

      fgkrf(krai+i) = MIN(AJDF(taudf) + ajrf, 1.0_dp)
      fgkrfr(krai+i) = MIN(AJDF(taudfr) + ajrfr, 1.0_dp)
   ENDDO
   krai = krai + nrh2ct

   ! Computes HD line profiles
   IF (i_hd /= 0) THEN

      bdop = 1.0e8_dp * SQRT(vt2 + deksamu * tgaz(iopt) / spec_lin(in_sp(i_hd))%mom)

      DO i = 1, nrhdbt
         njl = irahdb(i,2)
         nvl = irahdb(i,1)
         lev = lev_hd(nvl,njl)
         xlam0 = prahdb(i,2)
         gama = prahdb(i,3) / (4.0_dp * xpi)
         betas = bdop / xlam0
         betas0 = 1.0e8_dp * vturb / xlam0
         r     = gama / (sqpi * betas)
         t1    = ff1 * (ff2 * r) ** (-ff3)
         opt0  = ct1 * prahdb(i,1) / (sqpi * betas0)
         taudf = opt0 * cdhdf(lev)
         u1f   = SQRT(taudf * r) / t1
         ajrf  = (r / t1) / SQRT(u1f * u1f + xpi / 4.0_dp)
         taudfr = opt0 * cdhdr(lev)
         u1fr   = SQRT(taudfr * r) / t1
         ajrfr  = (r / t1) / SQRT(u1fr * u1fr + xpi / 4.0_dp)

         fgkrf(krai+i) = MIN(AJDF(taudf) + ajrf, 1.0_dp)
         fgkrfr(krai+i) = MIN(AJDF(taudfr) + ajrfr, 1.0_dp)
      ENDDO
      krai = krai + nrhdbt

      DO i = 1, nrhdct
         njl = irahdc(i,2)
         nvl = irahdc(i,1)
         lev = lev_hd(nvl,njl)
         xlam0 = prahdc(i,2)
         gama = prahdc(i,3) / (4.0_dp * xpi)
         betas = bdop / xlam0
         betas0 = 1.0e8_dp * vturb / xlam0
         r     = gama / (sqpi * betas)
         t1    = ff1 * (ff2 * r) ** (-ff3)
         opt0  = ct1 * prahdc(i,1) / (sqpi * betas0)
         taudf = opt0 * cdhdf(lev)
         u1f   = SQRT(taudf * r) / t1
         ajrf  = (r / t1) / SQRT(u1f * u1f + xpi / 4.0_dp)
         taudfr = opt0 * cdhdr(lev)
         u1fr   = SQRT(taudfr * r) / t1
         ajrfr  = (r / t1) / SQRT(u1fr * u1fr + xpi / 4.0_dp)

         fgkrf(krai+i) = MIN(AJDF(taudf) + ajrf, 1.0_dp)
         fgkrfr(krai+i) = MIN(AJDF(taudfr) + ajrfr, 1.0_dp)
      ENDDO
      krai = krai + nrhdct
   ENDIF

   ! Computes CO line profiles
   IF (i_co /= 0) THEN
      bdop  = 1.0e8_dp * SQRT(vt2 + deksamu * tgaz(iopt) / spec_lin(in_sp(i_co))%mom)

      DO i = 1, nrco
         njl   = iraco(i,1)
         nvl   = 0
         lev = lev_co(nvl,njl)
         IF (lev > spec_lin(in_sp(i_co))%use) CYCLE
         xlam0 = praco(i,2)
         gama  = praco(i,3) / (4.0_dp * xpi)
         betas = bdop / xlam0
         betas0 = 1.0e8_dp * vturb / xlam0
         r     = gama / (sqpi * betas)
         t1    = ff1 * (ff2*r) ** (-ff3)
         opt0  = ct1 * praco(i,1) / (sqpi * betas0)
         taudf = opt0 * cdc0f(lev)
         u1f   = SQRT(taudf * r) / t1
         ajrf  = (r / t1) / SQRT(u1f * u1f + xpi / 4.0_dp)
         taudfr = opt0 * cdc0r(lev)
         u1fr   = SQRT(taudfr * r) / t1
         ajrfr  = (r / t1) / SQRT(u1fr * u1fr + xpi / 4.0_dp)

         fgkrf(krai+i) = MIN(AJDF(taudf) + ajrf, 1.0_dp)
         fgkrfr(krai+i) = MIN(AJDF(taudfr) + ajrfr, 1.0_dp)
      ENDDO
      krai = krai + nrco
   ENDIF

   ! Computes 13CO line profiles
   IF (i_c13o /= 0) THEN
      bdop = 1.0e8_dp * SQRT(vt2 + deksamu * tgaz(iopt) / spec_lin(in_sp(j_c13o))%mom)

      DO i = 1, nrc13o
         njj   = irac13o(i,1) + 1
         IF (njj > spec_lin(in_sp(j_c13o))%use) CYCLE
         xlam0  = prac13o(i,2)
         gama   = prac13o(i,3) / (4.0_dp * xpi)
         betas  = bdop / xlam0
         betas0 = 1.0e8_dp * vturb / xlam0
         r      = gama / (sqpi*betas)
         t1     = ff1 * (ff2*r) ** (-ff3)
         opt0   = ct1 * prac13o(i,1) / (sqpi * betas0)
         taudf  = opt0 * cdc1f(njj)
         u1f    = SQRT(taudf * r) / t1
         ajrf   = (r / t1) / SQRT(u1f * u1f + xpi / 4.0_dp)
         taudfr = opt0 * cdc1r(njj)
         u1fr   = SQRT(taudfr * r) / t1
         ajrfr  = (r / t1) / SQRT(u1fr * u1fr + xpi / 4.0_dp)

         fgkrf(krai+i) = MIN(AJDF(taudf) + ajrf, 1.0_dp)
         fgkrfr(krai+i) = MIN(AJDF(taudfr) + ajrfr, 1.0_dp)
      ENDDO
      krai = krai + nrc13o
   ENDIF

   ! Computes C18O line profiles
   IF (i_co18 /= 0) THEN
      bdop = 1.0e8_dp * SQRT(vt2 + deksamu * tgaz(iopt) / spec_lin(in_sp(j_co18))%mom)

      DO i = 1, nrco18
         njj   = iraco18(i,1) + 1
         IF (njj > spec_lin(in_sp(j_co18))%use) CYCLE
         xlam0  = praco18(i,2)
         gama   = praco18(i,3) / (4.0_dp * xpi)
         betas  = bdop / xlam0
         betas0 = 1.0e8_dp * vturb / xlam0
         r      = gama / (sqpi*betas)
         t1     = ff1 * (ff2*r) ** (-ff3)
         opt0   = ct1 * praco18(i,1) / (sqpi * betas0)
         taudf  = opt0 * cdc2f(njj)
         u1f    = SQRT(taudf * r) / t1
         ajrf   = (r / t1) / SQRT(u1f * u1f + xpi / 4.0_dp)
         taudfr = opt0 * cdc2r(njj)
         u1fr   = SQRT(taudfr * r) / t1
         ajrfr  = (r / t1) / SQRT(u1fr * u1fr + xpi / 4.0_dp)

         fgkrf(krai+i) = MIN(AJDF(taudf) + ajrf, 1.0_dp)
         fgkrfr(krai+i) = MIN(AJDF(taudfr) + ajrfr, 1.0_dp)
      ENDDO
      krai = krai + nrco18
   ENDIF

   ! Computes 13C18O line profiles
   IF (i_c13o18 /= 0) THEN
      bdop = 1.0e8_dp * SQRT(vt2 + deksamu * tgaz(iopt) / spec_lin(in_sp(j_c13o18))%mom)

      DO i = 1, nrc13o18
         njj   = irac13o18(i) + 1
         IF (njj > spec_lin(in_sp(j_c13o18))%use) CYCLE
         xlam0  = prac13o18(i,2)
         gama   = prac13o18(i,3) / (4.0_dp * xpi)
         betas  = bdop / xlam0
         betas0 = 1.0e8_dp * vturb / xlam0
         r      = gama / (sqpi*betas)
         t1     = ff1 * (ff2*r) ** (-ff3)
         opt0   = ct1 * prac13o18(i,1) / (sqpi * betas0)
         taudf  = opt0 * cdc3f(njj)
         u1f    = SQRT(taudf * r) / t1
         ajrf   = (r / t1) / SQRT(u1f * u1f + xpi / 4.0_dp)
         taudfr = opt0 * cdc3r(njj)
         u1fr   = SQRT(taudfr * r) / t1
         ajrfr  = (r / t1) / SQRT(u1fr * u1fr + xpi / 4.0_dp)

         fgkrf(krai+i) = MIN(AJDF(taudf) + ajrf, 1.0_dp)
         fgkrfr(krai+i) = MIN(AJDF(taudfr) + ajrfr, 1.0_dp)
      ENDDO
   ENDIF

   ! Computes radiation field in slab
   DO k = 1, nrh2bt
         xlam0 = prah2b(k,2)
!        CALL RF_LOCATE(rf_wl, xlam0, jwl)
         jwl = irah2b(k,8)
         rapwl = (xlam0 - rf_wl%Val(jwl)) / (rf_wl%Val(jwl+1) - rf_wl%Val(jwl))
         aux1 = intJ1(jwl) + (intJ1(jwl+1) - intJ1(jwl)) * rapwl
         aux2 = intJ2(jwl) + (intJ2(jwl+1) - intJ2(jwl)) * rapwl
         fgkgrd(k) = aux1 * fgkrf(k) + aux2 * fgkrfr(k)
         fgkgrd(k) = fgkgrd(k) * J_to_u
   ENDDO
   krai = nrh2bt

   DO k = 1, nrh2ct
         xlam0 = prah2c(k,2)
!        CALL RF_LOCATE(rf_wl, xlam0, jwl)
         jwl = irah2c(k,8)
         rapwl = (xlam0 - rf_wl%Val(jwl)) / (rf_wl%Val(jwl+1) - rf_wl%Val(jwl))
         aux1 = intJ1(jwl) + (intJ1(jwl+1) - intJ1(jwl)) * rapwl
         aux2 = intJ2(jwl) + (intJ2(jwl+1) - intJ2(jwl)) * rapwl
         fgkgrd(krai+k) = aux1 * fgkrf(krai+k) + aux2 * fgkrfr(krai+k)
         fgkgrd(krai+k) = fgkgrd(krai+k) * J_to_u
   ENDDO
   krai = krai + nrh2ct

   IF (i_hd /= 0) THEN
      DO k = 1, nrhdbt
            xlam0 = prahdb(k,2)
            CALL RF_LOCATE(rf_wl, xlam0, jwl)
            rapwl = (xlam0 - rf_wl%Val(jwl)) / (rf_wl%Val(jwl+1) - rf_wl%Val(jwl))
            aux1 = intJ1(jwl) + (intJ1(jwl+1) - intJ1(jwl)) * rapwl
            aux2 = intJ2(jwl) + (intJ2(jwl+1) - intJ2(jwl)) * rapwl
            fgkgrd(krai+k) = aux1 * fgkrf(krai+k) + aux2 * fgkrfr(krai+k)
            fgkgrd(krai+k) = fgkgrd(krai+k) * J_to_u
      ENDDO
      krai = krai + nrhdbt

      DO k = 1, nrhdct
            xlam0 = prahdc(k,2)
            CALL RF_LOCATE(rf_wl, xlam0, jwl)
            rapwl = (xlam0 - rf_wl%Val(jwl)) / (rf_wl%Val(jwl+1) - rf_wl%Val(jwl))
            aux1 = intJ1(jwl) + (intJ1(jwl+1) - intJ1(jwl)) * rapwl
            aux2 = intJ2(jwl) + (intJ2(jwl+1) - intJ2(jwl)) * rapwl
            fgkgrd(krai+k) = aux1 * fgkrf(krai+k) + aux2 * fgkrfr(krai+k)
            fgkgrd(krai+k) = fgkgrd(krai+k) * J_to_u
      ENDDO
      krai = krai + nrhdct
   ENDIF

   IF (i_co /= 0) THEN
      DO k = 1, nrco
            xlam0 = praco(k,2)
            CALL RF_LOCATE(rf_wl, xlam0, jwl)
            rapwl = (xlam0 - rf_wl%Val(jwl)) / (rf_wl%Val(jwl+1) - rf_wl%Val(jwl))
            aux1 = intJ1(jwl) + (intJ1(jwl+1) - intJ1(jwl)) * rapwl
            aux2 = intJ2(jwl) + (intJ2(jwl+1) - intJ2(jwl)) * rapwl
            fgkgrd(krai+k) = aux1 * fgkrf(krai+k) + aux2 * fgkrfr(krai+k)
            fgkgrd(krai+k) = fgkgrd(krai+k) * J_to_u
      ENDDO
      krai = krai + nrco
   ENDIF

   IF (i_c13o /= 0) THEN
      DO k = 1, nrc13o
            xlam0 = prac13o(k,2)
            CALL RF_LOCATE(rf_wl, xlam0, jwl)
            rapwl = (xlam0 - rf_wl%Val(jwl)) / (rf_wl%Val(jwl+1) - rf_wl%Val(jwl))
            aux1 = intJ1(jwl) + (intJ1(jwl+1) - intJ1(jwl)) * rapwl
            aux2 = intJ2(jwl) + (intJ2(jwl+1) - intJ2(jwl)) * rapwl
            fgkgrd(krai+k) = aux1 * fgkrf(krai+k) + aux2 * fgkrfr(krai+k)
            fgkgrd(krai+k) = fgkgrd(krai+k) * J_to_u
      ENDDO
      krai = krai + nrc13o
   ENDIF

   IF (i_co18 /= 0) THEN
      DO k = 1, nrco18
            xlam0 = praco18(k,2)
            CALL RF_LOCATE(rf_wl, xlam0, jwl)
            rapwl = (xlam0 - rf_wl%Val(jwl)) / (rf_wl%Val(jwl+1) - rf_wl%Val(jwl))
            aux1 = intJ1(jwl) + (intJ1(jwl+1) - intJ1(jwl)) * rapwl
            aux2 = intJ2(jwl) + (intJ2(jwl+1) - intJ2(jwl)) * rapwl
            fgkgrd(krai+k) = aux1 * fgkrf(krai+k) + aux2 * fgkrfr(krai+k)
            fgkgrd(krai+k) = fgkgrd(krai+k) * J_to_u
      ENDDO
      krai = krai + nrco18
   ENDIF

   IF (i_c13o18 /= 0) THEN
      DO k = 1, nrc13o18
         xlam0 = prac13o18(k,2)
         CALL RF_LOCATE(rf_wl, xlam0, jwl)
         rapwl = (xlam0 - rf_wl%Val(jwl)) / (rf_wl%Val(jwl+1) - rf_wl%Val(jwl))
         aux1 = intJ1(jwl) + (intJ1(jwl+1) - intJ1(jwl)) * rapwl
         aux2 = intJ2(jwl) + (intJ2(jwl+1) - intJ2(jwl)) * rapwl
         fgkgrd(krai+k) = aux1 * fgkrf(krai+k) + aux2 * fgkrfr(krai+k)
         fgkgrd(krai+k) = fgkgrd(krai+k) * J_to_u
      ENDDO
   ENDIF

   IF (i_co /= 0) THEN
      DEALLOCATE (cdc0f)
      DEALLOCATE (cdc0r)
   ENDIF
   IF (j_c13o /= 0) THEN
      DEALLOCATE (cdc1f)
      DEALLOCATE (cdc1r)
   ENDIF
   IF (j_co18 /= 0) THEN
      DEALLOCATE (cdc2f)
      DEALLOCATE (cdc2r)
   ENDIF
   IF (j_c13o18 /= 0) THEN
      DEALLOCATE (cdc3f)
      DEALLOCATE (cdc3r)
   ENDIF

END SUBROUTINE FGKTR2

!%%%%%%%%%%%%%%%%%%%%%%%
SUBROUTINE FGKDAT (iopt)
!%%%%%%%%%%%%%%%%%%%%%%%
!  Prepares data for H2, HD and CO detailed balance
!  Computes H2, HD and CO photodissociation rates
!  Computes C and S ionisation rates

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

   IMPLICIT NONE

   INTEGER, INTENT (IN)                      :: iopt

   TYPE (RF_TYPE)                            :: rf_tmp, rf_tmp1

   REAL (KIND=dp)                            :: coefb, vt2
   INTEGER                                   :: k, ik, krai, levl
   INTEGER                                   :: nvl, njl, lev, kdeph
   INTEGER                                   :: nvu, nju, ndj, i1, i2
   INTEGER                                   :: ivu, iju, nj2
   REAL (KIND=dp)                            :: dumh2, dumhd, dumy
   REAL (KIND=dp)                            :: dumco
   REAL (KIND=dp)                            :: bdop, xlam0, chrai
   REAL (KIND=dp)                            :: probdi, beinst, absorb
   REAL (KIND=dp)                            :: disici

   SAVE

   ! Numerical coeficient : pi e**2 / (me * h * c**2) * 1.0e-16 (for Angstrom)
   coefb = 1.0e-16_dp * xpi * xqe2 / (xme * xhp * clum*clum)
   vt2 = vturb * vturb

   ! ------------------------------------------------------------------------------------
   ! Compute energy density from Lyman cut-off up to Habing cut-off (2400 Angstrom)
   ! JLB - 7 I 2013: full energy density is not used. Using Habing cut-off gives G0
   ! ------------------------------------------------------------------------------------
   CALL RF_CREATE(rf_tmp, 1, 2)
   CALL RF_LOCATE(rf_wl, wl_lym, i2)
   rf_tmp%Val(1) = 1.0_dp
   rf_tmp%Ord(1) = rf_wl%Ord(i2)
   CALL RF_LOCATE(rf_wl, wl_hab, i2)
   rf_tmp%Val(2) = 1.0_dp
   rf_tmp%Ord(2) = rf_wl%Ord(i2)
   int_rad(iopt) = SECT_INT(rf_tmp, rf_u, wl_pointer, wl_hab)
   CALL RF_FREE (rf_tmp)

   ! ------------------------------------------------------------------------------------
   ! Compute photon flux (used in chemistry)
   ! 5 VIII 09 - Photon flux is used only for desorption from grains.
   !           - Threshold set at 2000 A rather arbitrarily (JLB)
   ! ------------------------------------------------------------------------------------
   CALL RF_LOCATE(rf_wl, wl_lym, i1)
   CALL RF_LOCATE(rf_wl, 2000.0_dp, i2)
   CALL RF_CREATE(rf_tmp1, rf_wl%lower, rf_wl%upper)
   rf_tmp1%Val(rf_wl%lower:i1)   = 0.0_dp
   rf_tmp1%Val(i1:i2)            = rf_u%Val(i1:i2) * rf_wl%Val(i1:i2)
   rf_tmp1%Val(i2+1:rf_wl%upper) = 0.0_dp
   fluph(iopt) = RF_INTEGRATION (rf_wl,rf_tmp1) * 1.0e-8_dp / xhp
   CALL RF_FREE (rf_tmp1)

   ! ------------------------------------------------------------------------------------
   ! calcul du taux de photoionisation de toutes les especes
   ! a partir des sections de photodestruction contenues dans
   ! les fichiers data/section/*.dat : Mars 2006
   ! ------------------------------------------------------------------------------------
   CALL RF_CREATE (rf_tmp1, 0, nwlg)
   rf_tmp1%Val = rf_wl%Val * rf_u%Val
   DO k = 1, nphot_i - i_mandat
      pdiesp(k,iopt) = SECT_INT (phdest(k)%rf_esp, rf_tmp1, wl_pointer, phdest(k)%wl_cut_u_esp) &
                     / (1.0e8_dp * xhp)
   ENDDO
   CALL RF_FREE(rf_tmp1)

   ! ------------------------------------------------------------------------------------
   ! End modif - 14 Jan au 12 Fev 2002
   ! Radiative pumping
   !    H2
   ! ------------------------------------------------------------------------------------
   evrdbc(1:l0h2,1:l0h2) = 0.0_dp
   IF (i_hd /= 0) THEN
      evrdhd(1:l0hd,1:l0hd) = 0.0_dp
   ENDIF

   IF (i_co /= 0) THEN
      eqrco = 0.0_dp
   ENDIF
   IF (i_c13o /= 0) THEN
      eqrc13o = 0.0_dp
   ENDIF
   IF (i_co18 /= 0) THEN
      eqrco18 = 0.0_dp
   ENDIF
   IF (i_c13o18 /= 0) THEN
      eqrc13o18 = 0.0_dp
   ENDIF

   dumh2 = 0.0_dp
   dumhd = 0.0_dp
   dumy = 0.0_dp
   pdh2vJ(:,iopt) = 0.0_dp

   ! ------------------------------------------------------------------------------------
   !  H2 dissociation probability
   ! ------------------------------------------------------------------------------------
   bdop = 1.0e8_dp * SQRT(vt2 + deksamu * tgaz(iopt) / spec_lin(in_sp(i_h2))%mom)

   DO ik = 1, nrh2bt
      nvl = irah2b(ik,1)
      njl = irah2b(ik,2)
      lev = lev_h2(nvl,njl)
      xlam0 = prah2b(ik,2)
      chrai = fgkgrd(ik)

      nvu = irah2b(ik,3)
      ndj = irah2b(ik,4)
      nju = njl + ndj

      probdi = prah2b(ik,4)
      beinst = coefb * prah2b(ik,1) * (xlam0**3)
      absorb = beinst * chrai
      disici = absorb * probdi
      dumh2 = dumh2 + disici * xreh2(lev,iopt)     ! Total dissociation probability [s-1] at iopt
      pdh2vJ(lev,iopt) = pdh2vJ(lev,iopt) + disici ! Dissociation probability from level lev [s-1]

      ! calcul explicite des populations de la bande B
      IF ((nvu <= nvbc) .AND. (nju <= njbc)) THEN
         h2bnua(nvu,nju,iopt) = h2bnua(nvu,nju,iopt) + absorb * xreh2(lev,iopt)
      ENDIF

      ! Radiative equilibrium matrix
      ! 5 IX 08 - JLB - Suppress dissociation from equilibrium matrix (now taken care of in chemistry)
      evrdbc(lev,lev) = evrdbc(lev,lev) + absorb * (1.0_dp - probdi)

      IF (MOD(njl,2) == 0) THEN
         evrdbc(levpc,lev) = evrdbc(levpc,lev) - absorb * (1.0_dp - probdi) * bhmbx(levpc,nju,nvu)
      ELSE
         evrdbc(levic,lev) = evrdbc(levic,lev) - absorb * (1.0_dp - probdi) * bhmbx(levic,nju,nvu)
      ENDIF
   ENDDO

   ! End of upper levels population computation
   DO ivu = 0, nvbc
      DO iju = 0, njbc
         h2bnua(ivu,iju,iopt) = h2bnua(ivu,iju,iopt) / tmunh2bc(1,ivu,iju)
      ENDDO
   ENDDO
   krai = nrh2bt

   DO ik = 1, nrh2ct
      nvl = irah2c(ik,1)
      njl = irah2c(ik,2)
      lev = lev_h2(nvl,njl)
      xlam0 = prah2c(ik,2)
      chrai = fgkgrd(krai+ik)

      nvu = irah2c(ik,3)
      ndj = irah2c(ik,4)
      nju = njl + ndj

      probdi = prah2c(ik,4)
      beinst = coefb * prah2c(ik,1) * (xlam0**3)
      absorb = beinst * chrai
      disici = absorb * probdi
      dumh2 = dumh2 + disici * xreh2(lev,iopt)     ! Total dissociation probability [s-1] at iopt
      pdh2vJ(lev,iopt) = pdh2vJ(lev,iopt) + disici ! Dissociation probability from level lev [s-1]

      ! calcul explicite des populations de la bande C
      IF ((nvu <= nvbc) .AND. (nju <= njbc)) THEN
         h2cnua(nvu,nju,iopt) = h2cnua(nvu,nju,iopt) + absorb * xreh2(lev,iopt)
      ENDIF

      ! Construction de la matrice d'equilibre radiatif
      evrdbc(lev,lev) = evrdbc(lev,lev) + absorb * (1.0_dp - probdi)

      IF (MOD(njl,2) == 0) THEN
         evrdbc(levpc,lev) = evrdbc(levpc,lev) - absorb * (1.0_dp - probdi) * bhmcx(levpc,nju,nvu)
      ELSE
         evrdbc(levic,lev) = evrdbc(levic,lev) - absorb * (1.0_dp - probdi) * bhmcx(levic,nju,nvu)
      ENDIF
   ENDDO

   ! Fin du calcul des populations des niveaux hauts
   DO ivu = 0, nvbc
      DO iju = 0, njbc
         IF (tmunh2bc(2,ivu,iju) > 1.0e-30_dp) THEN
            h2cnua(ivu,iju,iopt) = h2cnua(ivu,iju,iopt) / tmunh2bc(2,ivu,iju)
         ELSE
            h2cnua(ivu,iju,iopt) = -1.0_dp
         ENDIF
      ENDDO
   ENDDO
   kdeph = kdeph0
   pdiesp(kdeph,iopt) = dumh2
   krai = krai + nrh2ct

   ! ------------------------------------------------------------------------------------
   ! HD dissociation probability
   ! ------------------------------------------------------------------------------------
   IF (i_hd /= 0) THEN
      DO ik = 1, nrhdbt
         nvl = irahdb(ik,1)
         njl = irahdb(ik,2)
         lev = lev_hd(nvl,njl)
         xlam0 = prahdb(ik,2)
         chrai = fgkgrd(krai+ik)

         nvu = irahdb(ik,3)
         ndj = irahdb(ik,4)
         nju = njl + ndj

         probdi = prahdb(ik,4)
         beinst = coefb * prahdb(ik,1) * (xlam0**3)
         absorb = beinst * chrai
         disici = absorb * probdi
         dumhd = dumhd + disici * xrehd(lev,iopt)

         evrdhd(lev,lev) = evrdhd(lev,lev) + absorb

         DO levl = 1, l0hd
            nj2 = njl_hd(levl)
            dumy = absorb * (1.0_dp - probdi) * bhdbx(nvu,nju,levl)
            evrdhd(levl,lev) = evrdhd(levl,lev) - dumy
         ENDDO
      ENDDO
      krai = krai + nrhdbt

      DO ik = 1, nrhdct
         nvl = irahdc(ik,1)
         njl = irahdc(ik,2)
         lev = lev_hd(nvl,njl)
         xlam0 = prahdc(ik,2)
         chrai = fgkgrd(krai+ik)

         nvu = irahdc(ik,3)
         ndj = irahdc(ik,4)
         nju = njl + ndj

         probdi = prahdc(ik,4)
         beinst = coefb * prahdc(ik,1) * (xlam0**3)
         absorb = beinst * chrai
         disici = absorb * probdi
         dumhd = dumhd + disici * xrehd(lev,iopt)

         evrdhd(lev,lev) = evrdhd(lev,lev) + absorb

         DO levl = 1, l0hd
            nj2 = njl_hd(levl)
            IF (ndj == 0) THEN
               dumy = absorb * (1.0_dp - probdi) * bhdcmx(nvu,nju,levl)
               evrdhd(levl,lev) = evrdhd(levl,lev) - dumy
            ELSE
               dumy = absorb * (1.0_dp - probdi) * bhdcpx(nvu,nju,levl)
               evrdhd(levl,lev) = evrdhd(levl,lev) - dumy
            ENDIF
         ENDDO
      ENDDO
      kdeph = kdeph + 1
      pdiesp(kdeph,iopt) = dumhd
      krai = krai + nrhdct
   ENDIF

   ! ------------------------------------------------------------------------------------
   ! CO dissociation probability
   ! ------------------------------------------------------------------------------------
   !  coeff num: coefb = (pi*e**2)/(m*h*c**2)=1.336d14
   !     * 1.0e-16_dp (pour tenir compte des longueurs d onde en a).
   IF (i_co /= 0) THEN
      dumco = 0.0_dp
      bdop  = 1.0e8_dp * SQRT(vt2 + deksamu * tgaz(iopt) / spec_lin(in_sp(i_co))%mom)
      DO ik = 1, nrco
         njl = iraco(ik,1)
         nvl = 0
         lev = lev_co(nvl,njl)
         IF (lev > spec_lin(in_sp(i_co))%use) CYCLE
         probdi = praco(ik,4)
         xlam0 = praco(ik,2)
         beinst = coefb * praco(ik,1) * (xlam0**3)
         chrai = fgkgrd(krai+ik)
         absorb = beinst * chrai
         dumco = dumco + absorb * probdi * xreco(lev,iopt)
         eqrco(lev) = eqrco(lev) + absorb * probdi
      ENDDO
      kdeph = kdeph + 1
      pdiesp(kdeph,iopt) = dumco
      krai = krai + nrco
   ENDIF

   ! ------------------------------------------------------------------------------------
   ! 13CO dissociation probability
   ! ------------------------------------------------------------------------------------
   IF (i_c13o /= 0) THEN
      dumco = 0.0_dp
      DO ik = 1, nrc13o
         njl = irac13o(ik,1)
         IF ((njl+1) > spec_lin(in_sp(j_c13o))%use) CYCLE
         probdi = prac13o(ik,4)
         xlam0 = prac13o(ik,2)
         beinst = coefb * prac13o(ik,1) * (xlam0**3)
         chrai = fgkgrd(krai+ik)
         absorb = beinst * chrai
         dumco = dumco + absorb * probdi * xrec13o(njl+1,iopt)
         eqrc13o(njl+1) = eqrc13o(njl+1) + absorb * probdi
      ENDDO
      kdeph = kdeph + 1
      pdiesp(kdeph,iopt) = dumco
      krai = krai + nrc13o
   ENDIF

   ! -------------------------------------------------------------------------------------
   ! C18O dissociation probability
   ! -------------------------------------------------------------------------------------
   IF (i_co18 /= 0) THEN
      dumco = 0.0_dp
      DO ik = 1, nrco18
         njl = iraco18(ik,1)
         IF ((njl+1) > spec_lin(in_sp(j_co18))%use) CYCLE
         probdi = praco18(ik,4)
         xlam0 = praco18(ik,2)
         beinst = coefb * praco18(ik,1) * (xlam0**3)
         chrai = fgkgrd(krai+ik)
         absorb = beinst * chrai
         dumco = dumco + absorb * probdi * xreco18(njl+1,iopt)
         eqrco18(njl+1) = eqrco18(njl+1) + absorb * probdi
      ENDDO
      kdeph = kdeph + 1
      pdiesp(kdeph,iopt) = dumco
      krai = krai + nrco18
   ENDIF

   ! ------------------------------------------------------------------------------------
   ! 13C18O dissociation probability
   ! ------------------------------------------------------------------------------------
   IF (i_c13o18 /= 0) THEN
      dumco = 0.0_dp
      DO ik = 1, nrc13o18
         njl = irac13o18(ik)
         IF ((njl+1) > spec_lin(in_sp(j_c13o18))%use) CYCLE
         probdi = prac13o18(ik,4)
         xlam0 = prac13o18(ik,2)
         beinst = coefb * prac13o18(ik,1) * (xlam0**3)
         chrai = fgkgrd(krai+ik)
         absorb = beinst * chrai
         dumco = dumco + absorb * probdi * xrec13o18(njl+1,iopt)
         eqrc13o18(njl+1) = eqrc13o18(njl+1) + absorb * probdi
      ENDDO
      kdeph = kdeph + 1
      pdiesp(kdeph,iopt) = dumco
   ENDIF

END SUBROUTINE FGKDAT

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
REAL (KIND=dp) FUNCTION INTERPCD(rapp, cd_o, i, npo)
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!  Interpolation FUNCTION, used to find the column density between
!  the current point and the center of the cloud

   USE PXDR_FLAGS
   USE PXDR_CONSTANTES

   IMPLICIT NONE

   INTEGER,                           INTENT (IN) :: i, npo
   REAL (KIND=dp),                    INTENT (IN) :: rapp
   REAL (KIND=dp), DIMENSION (0:npo), INTENT (IN) :: cd_o
   REAL (KIND=dp)                                 :: cd_c

   cd_c = cd_o(i) + (cd_o(i+1) - cd_o(i)) * rapp
   INTERPCD = cd_c

END FUNCTION INTERPCD

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
REAL (KIND=dp) FUNCTION INTERPLCD(rapp, cd_o, i, npo)
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!  Same function as the INTERPCD except that it is done in a logarithmic scale

   USE PXDR_FLAGS
   USE PXDR_CONSTANTES

   IMPLICIT NONE

   INTEGER,                           INTENT (IN) :: i, npo
   REAL (KIND=dp),                    INTENT (IN) :: rapp
   REAL (KIND=dp), DIMENSION (0:npo), INTENT (IN) :: cd_o
   REAL (KIND=dp)                                 :: cd_c

   cd_c = LOG( cd_o(i) ) + rapp * LOG( cd_o(i+1) / cd_o(i) )
   INTERPLCD = EXP( cd_c )

END FUNCTION INTERPLCD

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
REAL (KIND=dp) FUNCTION AJDF(taudf)
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

   USE PXDR_FLAGS
   USE PXDR_CONSTANTES
   REAL (KIND=dp), INTENT (IN) ::  taudf

   IF (taudf < 2.0_dp) THEN
      AJDF = EXP(-2.0_dp * taudf / 3.0_dp)
   ELSE IF (taudf < 10.0_dp) THEN
      AJDF = 0.638_dp * taudf**(-1.25_dp)
   ELSE IF (taudf < 1.0d2) THEN
      AJDF = 0.505_dp * taudf**(-1.15_dp)
   ELSE
      AJDF = 0.344_dp * taudf**(-1.0667_dp)
   ENDIF

END FUNCTION AJDF

END MODULE PXDR_FGK_TR
