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

  PRIVATE

  PUBLIC :: CHIMIJ, MNEWT, FBTH1, FBTH2

CONTAINS

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
SUBROUTINE CHIMIJ (ttry, iopt, itn)
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

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

!--------1---------2---------3---------4---------5---------6---------7--
!   Chemical equation source terms computation
!---------------------------------------------------------------------

  IMPLICIT NONE

  REAL (KIND=dp), INTENT (IN)        :: ttry
  INTEGER, INTENT (IN)               :: iopt, itn

  INTEGER, DIMENSION(0:nes)          :: indy
  REAL (KIND=dp), DIMENSION(0:natom) :: ratiab
  REAL (KIND=dp)                     :: ratlim = 1.0_dp
  REAL (KIND=dp)                     :: avr
  REAL (KIND=dp)                     :: rate, rate1, rate2
  REAL (KIND=dp)                     :: sigm, pr, vtherm
  REAL (KIND=dp)                     :: k_Ad, k_i_Ad, k_ij_ER, k_ij_Rej, k_j_ER, k_i_Rej
  REAL (KIND=dp)                     :: nu0, nu0_1, nu0_2, nu0_3
  REAL (KIND=dp)                     :: tgr
  REAL (KIND=dp)                     :: xldb_1, xldb_2, xldb_3
  REAL (KIND=dp)                     :: tm1_1, tm1_2
  REAL (KIND=dp)                     :: react_eff     ! reaction efficiency for 2 species in a site (no unit)
  REAL (KIND=dp)                     :: p_react       ! frequency to try to react (s-1)
  REAL (KIND=dp)                     :: p_diff        ! frequency to try to diffuse (s-1)
  REAL (KIND=dp)                     :: p_desor       ! frequency to try to desorb (s-1)
  REAL (KIND=dp)                     :: tunnel_trans  ! Transmission by tunneling effect through an activation barrier
  REAL (KIND=dp)                     :: redmass       ! Reduced mass of the system
  REAL (KIND=dp)                     :: frach2
  REAL (KIND=dp)                     :: stick_m
  REAL (KIND=dp), ALLOCATABLE, DIMENSION(:) :: stickH
  REAL (KIND=dp)                     :: r_rej
  REAL (KIND=dp)                     :: endo_rxn, rat_l
  REAL (KIND=dp)                     :: Yield_cr
  REAL (KIND=dp)                     :: r_cr          ! radius of the interaction between c.r. and ices
  INTEGER                            :: ir1, ir2, ir3, ip1, ip2, ip3, ip4, iv1, iv2, ivp, iprod
  INTEGER                            :: ideb, ifin
  INTEGER                            :: ik, kkk, lev, lev1, lev2
  REAL (KIND=dp)                     :: E45, zz

  INTEGER                            :: i, j, k2, l, mm
  INTEGER                            :: ici1, ici2, icc
  REAL (KIND=dp)                     :: summ, dum, expon
  REAL (KIND=dp)                     :: top1, top2, attenu
  REAL (KIND=dp)                     :: stick_ER
  REAL (KIND=dp)                     :: ab_ads_tot  ! total number of adsorbed species on grains (in atome or molecule per cm)

  REAL (KIND=dp)                     :: mean_x, mean_y, mean_xy, mean_xx, toto
  INTEGER                            :: nbJ
  REAL (KIND=dp), DIMENSION (9)      :: les_y

  ! ---
  REAL (KIND=dp)                     :: bbadn ! Badnell (2006) coefficients for the
                                              ! radiative recombination atomic ions (dimensionless)

  REAL (KIND=dp)                     :: scale_rot ! Scaling factor applied to Herraez-Aguilar C+ + H2 rates to match Zanchet et al. rates
  REAL (KIND=dp)                     :: scale_vib ! Scaling factor applied to Herraez-Aguilar C+ + H2 rates to match Zanchet et al. rates
  REAL (KIND=dp), DIMENSION (0:14)   :: xh2v
  REAL (KIND=dp), DIMENSION (0:14)   :: kvh2
  REAL (KIND=dp)                     :: rate_l, rate_h ! H2 collisional dissociation rates: low and high density limits.

  INTEGER                            :: i_deb, i_fin

  ! Look for most abundant species
  ! elements conservation is done (for each atom) on the
  ! most abundance species. In case of conflict (e.g. CO)
  ! on the second most abundant

  ! LCON(K2): index of species used for conservation of element K2.
  DO k2 = 1, natom-1
     top1 = 0.0_dp
     top2 = 0.0_dp
     icx(k2,1) = 0
     icx(k2,2) = 0

     DO l = 1, nspec-1
        dum = ael(l,k2)
        IF (dum == 0.0_dp) CYCLE
        IF (lcon(l) == k2) THEN
           lcon(l) = 0
        ENDIF
        IF (ab(l)*dum > top1) THEN
           top2 = top1
           top1 = ab(l) * dum
           icx(k2,2) = icx(k2,1)
           icx(k2,1) = l
        ELSE IF (ab(l)*dum >top2) THEN
           top2 = ab(l) * dum
           icx(k2,2) = l
        ENDIF
     ENDDO
     IF (top1 /= 0.0_dp) THEN
        ratiab(k2) = top2 / top1
     ENDIF
  ENDDO
  if (icx(4,2) == i_h2ogr) then
!    print *, " Reverse to O"
     icx(4,2) = i_o
  endif

  DO k2 = 1, natom-1
     ici1 = icx(k2,1)
     ici2 = icx(k2,2)
     IF (ici1 == 0) CYCLE

     IF (ratiab(k2) > ratlim) THEN
        IF (ael(ici1,natom) == 1 .AND. ael(ici2,natom) == 0) THEN
           j = ici1
           ici1 = ici2
           ici2 = j
        ENDIF
     ENDIF

     icc = 0
     DO i = 1, k2-1
        IF (lcon(ici1) == i) icc = i
     ENDDO

     IF (icc == 0) THEN
        lcon(ici1) = k2
     ELSE
        IF (ratiab(k2) > ratiab(icc)) THEN
           lcon(ici2) = k2
        ELSE
           lcon(ici1) = k2
           lcon(icx(icc,2)) = icc
        ENDIF
     ENDIF
  ENDDO

  indy = 0

  ! Extinction from the "other" side
  avr = Avmax - av

  ! Fraction of H2 (for secondary photons flux)
  frach2 = ab(i_h2) / (ab(i_h) + ab(i_h2))

  !-----------------------------------------------------------------------------
  ! Number of adsorbed species and ice layers on grains
  !-----------------------------------------------------------------------------
  IF (nsp_gm > 0) THEN
     i_deb = nsp_ne + nsp_ip + nsp_im + 1
     i_fin = nsp_ne + nsp_ip + nsp_im + nsp_gm
     ab_ads_tot  = SUM(ab(i_deb:i_fin)) ! Number of mantle species per cm3
     x_lay(iopt) = SUM(ab(i_deb:i_fin)) * dsite*dsite / (s_gr_t_bgr * densh(iopt))
     PRINT *, " Nb. of layers:", x_lay(iopt), " Sur_gr (BG):", s_gr_t_bgr * densh(iopt)
     IF (x_lay(iopt) == 0.0_dp) THEN
        attenu = 1.0_dp
     ELSE
        attenu = 1.0_dp - EXP(-3.0_dp / x_lay(iopt))
     ENDIF
  ELSE
     attenu = 1.0_dp
  ENDIF

  !-----------------------------------------------------------------------------
  ! H2 abundance in vibrational levels
  !-----------------------------------------------------------------------------
  xh2v = 0.0_dp
  DO lev = 1, l0h2
     iv1 = nvl_h2(lev)
     xh2v(iv1) = xh2v(iv1) + xreh2(lev,iopt)
  ENDDO

!-------------------------------------------------------------------------------
! Chemical reaction rates
!-------------------------------------------------------------------------------
! chemical reactions are reordered:
! (0) formation of H2 and HD on grains [Old Style] (nh2for)
! (1) cosmic ray processes (ncrion)
! (2) secondary photon processes (npsion)
! (3) radiative association  (nasrad)
! (4) gas phase reactions (nrest)
! (6) Endothermal reactions with H2 (nh2endo) (NEW!)
! (5) photoreactions avec fit exterieur (nphot_f)
! (7) photoreactions avec integration directe (nphot_i)
! (8) 3 body reactions (n3body)
! (101...) exceptions (ncpart)

! (11) reactions on grain surface (ngsurf)
! (12) photoreactions on grain surface (ngphot)
! (13) adsorption on to grains (ngads)
! (14) neutralization (ngneut)
! (15) explosive desorption from grains (nggdes)
! (16) cosmic ray induced desorption from grains (ncrdes)
! (17) photodesorption from grains (nphdes)
! (18) evaporation from grains (ngevap)
! (19) chemisorption on grains (ngchs)
! (20) Eley-Rideal process (ngelri)
! (40) radiative and dielectronic recombination of atomic ions (nglass)

!-------------------------------------------------------------------------
!  Special cases       : NSPEC + 1 : ELECTRON
!                        NSPEC + 2 : PHOTON
!                        NSPEC + 3 : CRP
!                        NSPEC + 4 : GRAIN
!                        NSPEC + 6 : XRAY
!                        NSPEC + 7 : ELECSEC

!       -------------------
!-- 1 - Gas phase reactions
!       -------------------

!-------------------------------------------------------------------------
! (0) formation of H2 and HD on grains [Old Style] (nh2for)  (cm3 s-1)
!-------------------------------------------------------------------------

  DO i = 1, nh2for
     ir1 = react(i,1)
     ir2 = react(i,2)
     iprod = react(i,4)

     ! H2 formation - OLD STYLE : gamm  = rate in cm+3 s-1 at 100 K for a standard metallicity
     ! Typically, gamm = 3E-17 cm+3 s-1
     ! We scale gamma by SQRT(T) and the metallicity (we use the mass of grains / gas for that)
     ! The scaling (100.0 or 300.0 K) and the exponent (0.0 or 0.5) are set in the chemistry file
     rate = gamm(i) * densh(iopt) * (ttry / bet(i))**alpha(i) &
          * (g_ratio / 0.01_dp) / (istiny + ab(i_h))

     kkk = indy(iprod) + 1
     indy(iprod) = kkk
     xmatk(iprod)%fdt(kkk)%k = rate

     kkk = indy(ir1) + 1
     indy(ir1) = kkk
     xmatk(ir1)%fdt(kkk)%k = - rate

     kkk = indy(ir2) + 1
     indy(ir2) = kkk
     xmatk(ir2)%fdt(kkk)%k = - rate

     all_rate_chem(i,iopt) = rate * ab(ir1) * ab(ir2)
     rate_chem(i) = rate
  ENDDO

!-------------------------------------------------------------------------
! (1) cosmic ray processes (ncrion)   (s-1)
!-------------------------------------------------------------------------
  ideb = nh2for + 1
  ifin = nh2for + ncrion
  DO i = ideb, ifin
     rate = gamm(i) * zeta

     ik = react(i,0)
     DO j = 4, ik+1
        iprod = react(i,j)
        kkk = indy(iprod) + 1
        indy(iprod) = kkk
        xmatk(iprod)%fdt(kkk)%k = rate
     ENDDO

     ir1 = react(i,1)
     kkk = indy(ir1) + 1
     indy(ir1) = kkk
     xmatk(ir1)%fdt(kkk)%k = - rate

     all_rate_chem(i,iopt) = rate * ab(ir1)
     rate_chem(i) = rate
  ENDDO

!-------------------------------------------------------------------------
! (2) secondary photon processes (npsion)   (s-1)
!-------------------------------------------------------------------------

  ideb = ifin + 1
  ifin = ifin + npsion
  DO i = ideb, ifin
     rate = gamm(i) * frach2 * zeta * (ttry/300.0_dp)**alpha(i)

     ik = react(i,0)
     DO j = 4, ik+1
        iprod = react(i,j)
        kkk = indy(iprod) + 1
        indy(iprod) = kkk
        xmatk(iprod)%fdt(kkk)%k = rate
     ENDDO

     ir1 = react(i,1)
     kkk = indy(ir1) + 1
     indy(ir1) = kkk
     xmatk(ir1)%fdt(kkk)%k = - rate

     all_rate_chem(i,iopt) = rate * ab(ir1)
     rate_chem(i) = rate
  ENDDO

!-------------------------------------------------------------------------
! (3) radiative association  (nasrad)   (cm3 s-1)
!-------------------------------------------------------------------------
  ideb = ifin + 1
  ifin = ifin + nasrad
  DO i = ideb, ifin
     rate = gamm(i) * (ttry/300.0_dp)**alpha(i) * EXP(-bet(i)/ttry)

     iprod = react(i,4)
     kkk = indy(iprod) + 1
     indy(iprod) = kkk
     xmatk(iprod)%fdt(kkk)%k = rate

     ir1 = react(i,1)
     kkk = indy(ir1) + 1
     indy(ir1) = kkk
     xmatk(ir1)%fdt(kkk)%k = - rate

     ir2 = react(i,2)
     kkk = indy(ir2) + 1
     indy(ir2) = kkk
     xmatk(ir2)%fdt(kkk)%k = - rate

     all_rate_chem(i,iopt) = rate * ab(ir1) * ab(ir2)
     rate_chem(i) = rate
  ENDDO

!-------------------------------------------------------------------------
! (4) gas phase reactions (nrest)   (cm3 s-1)
!-------------------------------------------------------------------------
  ideb = ifin + 1
  ifin = ifin + nrest
  DO i = ideb, ifin
     IF (bet(i) < 0.0_dp) THEN
        expon = EXP(-bet(i)/MAX(ttry,200.0_dp))
     ELSE
        expon = EXP(-bet(i)/ttry)
     ENDIF
     rate = gamm(i) * (ttry/300.0_dp)**alpha(i) * expon

     ik = react(i,0)
     DO j = 4, ik+1
        iprod = react(i,j)
        kkk = indy(iprod) + 1
        indy(iprod) = kkk
        xmatk(iprod)%fdt(kkk)%k = rate
     ENDDO

     ir1 = react(i,1)
     kkk = indy(ir1) + 1
     indy(ir1) = kkk
     xmatk(ir1)%fdt(kkk)%k = - rate

     ir2 = react(i,2)
     kkk = indy(ir2) + 1
     indy(ir2) = kkk
     xmatk(ir2)%fdt(kkk)%k = - rate

     all_rate_chem(i,iopt) = rate * ab(ir1) * ab(ir2)
     rate_chem(i) = rate
  ENDDO

!-------------------------------------------------------------------------
! (6) Endothermal reactions with H2 (nh2endo)   (cm3 s-1)
!-------------------------------------------------------------------------
  ! Compute effective excitation energy of H2
  ! Least square fit to LOG(x_i/g_i) as a function of E_i
  nbJ = 4
  les_y = 0.0_dp
  les_y(1:nbJ) = LOG(xreh2(1:nbJ,iopt) / spec_lin(in_sp(i_h2))%gst(1:nbJ))
  mean_x       = SUM(spec_lin(in_sp(i_h2))%elk(1:nbJ)) / DBLE(nbJ)
  mean_y       = SUM(les_y(1:nbJ)) / DBLE(nbJ)
  mean_xx      = SUM((spec_lin(in_sp(i_h2))%elk(1:nbJ))**2) / DBLE(nbJ)
  mean_xy      = SUM(spec_lin(in_sp(i_h2))%elk(1:nbJ) * les_y(1:nbJ)) / DBLE(nbJ)
  if (ifaf < 1) then
     T_eff_H2 = ttry
  else
     T_eff_H2 = (mean_x**2 - mean_xx) / (mean_xy - mean_x * mean_y)
  endif
  !print *, "T_eff_H2:", T_eff_H2, "T_gas:", ttry
! toto = 0.0_dp
! do i = 1, 9
!    toto = toto + spec_lin(in_sp(i_h2))%gst(i) * EXP(-spec_lin(in_sp(i_h2))%elk(i)/T_eff_H2)
! enddo
! do i = 1, 9
!    print *, spec_lin(in_sp(i_h2))%elk(i), xreh2(i,iopt) / spec_lin(in_sp(i_h2))%gst(i) &
!           , EXP(-spec_lin(in_sp(i_h2))%elk(i)/T_eff_H2) / toto
! enddo
! stop

  ideb = ifin + 1
  ifin = ifin + nh2endo
  DO i = ideb, ifin
     rate = 0.0_dp
     IF (itype(i) == 6) THEN
        DO lev = 1, l0h2
           endo_rxn = MAX(bet(i) - spec_lin(in_sp(i_h2))%elk(lev), 0.0_dp)
           rat_l = gamm(i) * (ttry/300.0_dp)**alpha(i) * EXP(-endo_rxn/ttry)
           rate = rate + rat_l * xreh2(lev,iopt)
        ENDDO
        ! Try new prescription with H2 effective temperature - JLB 21 I 2016
        !expon = EXP(-bet(i)/T_eff_H2)
        !rate = gamm(i) * (T_eff_H2/300.0_dp)**alpha(i) * expon

     !--- C+ + H2 -> CH+ + H ---------------------------------------------------
     ELSE IF (itype(i) == 61) THEN

        !--- Rate by Agundez et al. ApJ (2010)
        !DO lev = 1, 8
        !   endo_rxn = MAX(4827.0e0_dp-spec_lin(in_sp(i_h2))%elk(lev),0.0e0_dp)
        !   rat_l = 1.58e-10_dp * EXP(-endo_rxn/ttry)
        !   rate  = rate + rat_l * xreh2(lev,iopt)
        !ENDDO
        !DO lev = 9, l0h2
        !   rate = rate + 1.6e-9_dp * xreh2(lev,iopt)
        !ENDDO

        !--- Fit of rates by Herraez-Aguilar et al., Phys. Chem. Chem. Phys., 2014
        !rate = rate + 10.0**(-(1640.07 * ttry**(-0.94) + 9.83)) * xreh2(1,iopt) ! v=0, J=0
        !rate = rate + 10.0**(-(1682.81 * ttry**(-0.95) + 9.87)) * xreh2(2,iopt) ! v=0, J=1
        !rate = rate + 10.0**(-(1400.00 * ttry**(-0.94) + 9.80)) * xreh2(3,iopt) ! v=0, J=2 - Interpolation
        !rate = rate + 10.0**(-(1219.00 * ttry**(-0.93) + 9.74)) * xreh2(4,iopt) ! v=0, J=3
        !rate = rate + 10.0**(-(1000.00 * ttry**(-0.92) + 9.74)) * xreh2(5,iopt) ! v=0, J=4 - Interpolation
        !rate = rate + 10.0**(-(740.30  * ttry**(-0.92) + 9.74)) * xreh2(6,iopt) ! v=0, J=5
        !rate = rate + 10.0**(-(322.27  * ttry**(-0.86) + 9.72)) * xreh2(7,iopt) ! v=0, J=6 - Interpolation
        !rate = rate + 10.0**(-(21.41   * ttry**(-0.52) + 9.58)) * xreh2(8,iopt) ! v=0, J=7
        !rate = rate + (4.66E-10 * ttry**(-0.29) + 1.25E-10)     * xreh2(9,iopt) ! v=0, J=8
        !DO lev = 10, l0h2
        !   rate = rate + (8.0E-10 * ttry**(-0.29) + 1.25E-10)   * xreh2(lev,iopt) ! other levels
        !ENDDO

        !--- Mix Zanchet et al. (ApJ, 2013) and Herraez-Aguilar et al. (PCCP, 2014)
        ! Octavio Roncero suggested to be more confident in the quantum treatment by Zanchet et al.
        ! rather than the semi-classical treatment of Herraez-Aguilar.
        ! Herraez-Aguilar provides rates for H2 in v=0, J=0, 1, 3, 5, 7 + v=1, J=0, 1, 2, 3, 4
        ! Zanchet provides rates for v=0, J=0; v=1, J=0 and J=1; v=2, J=0
        ! Following Octavio Roncero's suggestions, we scale Herraez-Aguilar rates to match Zanchet rates
        ! We find two scaling laws, one for levels <= v=0, J=7 and one for above levels
        ! Note that the rotationnal level v=0, J=8 has the same shape than v=1 levels and so it is scaled by scale_vib.
        scale_rot = 2.4_dp * (ttry / 1000.0_dp)**(-0.5_dp)
        scale_vib = 1.4_dp * (ttry / 1000.0_dp)**(-0.1_dp)
        ! Compute Herraez-Aguilar rates and scale them to get Zanchet et al. values
        rate = rate + 10.0_dp**(-(1640.07_dp * ttry**(-0.94_dp) + 9.83_dp)) &
             * scale_rot * xreh2(1,iopt) ! v=0, J=0
        rate = rate + 10.0_dp**(-(1682.81_dp * ttry**(-0.95_dp) + 9.87_dp)) &
             * scale_rot * xreh2(2,iopt) ! v=0, J=1
        rate = rate + 10.0_dp**(-(1400.00_dp * ttry**(-0.94_dp) + 9.80_dp)) &
             * scale_rot * xreh2(3,iopt) ! v=0, J=2 - Interpolation
        rate = rate + 10.0_dp**(-(1219.00_dp * ttry**(-0.93_dp) + 9.74_dp)) &
             * scale_rot * xreh2(4,iopt) ! v=0, J=3
        rate = rate + 10.0_dp**(-(1000.00_dp * ttry**(-0.92_dp) + 9.74_dp)) &
             * scale_rot * xreh2(5,iopt) ! v=0, J=4 - Interpolation
        rate = rate + 10.0_dp**(-(740.30_dp  * ttry**(-0.92_dp) + 9.74_dp)) &
             * scale_rot * xreh2(6,iopt) ! v=0, J=5
        rate = rate + 10.0_dp**(-(322.27_dp  * ttry**(-0.86_dp) + 9.72_dp)) &
             * scale_rot * xreh2(7,iopt) ! v=0, J=6 - Interpolation
        rate = rate + 10.0_dp**(-(21.41_dp   * ttry**(-0.52_dp) + 9.58_dp)) &
             * scale_rot * xreh2(8,iopt) ! v=0, J=7
        rate = rate + (4.66E-10_dp * ttry**(-0.29_dp) + 1.25E-10_dp)        &
             * scale_vib * xreh2(9,iopt) ! v=0, J=8
        ! From v=1, J=0 (lev=10) and up to v=2, J=0 (lev=22) excluded use scaled Herraez-Aguilar rates
        DO lev = 10, min(l0h2, 21) ! lev = 10 is v=1, J=0 and lev = 22 is v=2, J=0
           rate = rate + (8.0E-10_dp * ttry**(-0.29_dp) + 1.25E-10_dp) &
                * scale_vib *  xreh2(lev,iopt) ! other levels
        ENDDO
        ! From v = 2, J=0 (lev = 22) use Zanchet et al. v=2, J=0 rate
        DO lev = min(22,l0h2), l0h2
           rate = rate + (2.0E-9_dp * ttry**(-0.29_dp) + 1.8E-10_dp) * xreh2(lev,iopt)
        ENDDO

     !--- S+ + H2 -> SH+ + H ---------------------------------------------------
     ELSE IF (itype(i) == 62) THEN ! Test for the formation of SH+ in the same way than CH+
        ! If used in the chemistry, gamm, alp, bet in .chi file are not used.
        DO lev = 1, 18
           endo_rxn = MAX(9860.0e0_dp-spec_lin(in_sp(i_h2))%elk(lev),0.0e0_dp)
           rat_l = 1.58e-10_dp * EXP(-endo_rxn/ttry)
           rate  = rate + rat_l * xreh2(lev,iopt)
        ENDDO
        DO lev = 19, l0h2
           rate = rate + 1.6e-9_dp * xreh2(lev,iopt)
        ENDDO

     ENDIF

     ik = react(i,0)
     DO j = 4, ik+1
        iprod = react(i,j)
        kkk = indy(iprod) + 1
        indy(iprod) = kkk
        xmatk(iprod)%fdt(kkk)%k = rate
     ENDDO

     ir1 = react(i,1)
     kkk = indy(ir1) + 1
     indy(ir1) = kkk
     xmatk(ir1)%fdt(kkk)%k = - rate

     ir2 = react(i,2)
     kkk = indy(ir2) + 1
     indy(ir2) = kkk
     xmatk(ir2)%fdt(kkk)%k = - rate

     all_rate_chem(i,iopt) = rate * ab(ir1) * ab(ir2)
     rate_chem(i) = rate
  ENDDO

!-------------------------------------------------------------------------
! (5) photoreactions (external fit) (nphot_f)    (s-1)
!-------------------------------------------------------------------------
  ideb = ifin + 1
  ifin = ifin + nphot_f
  DO i = ideb, ifin
     ir1 = react(i,1)
     ! The effective radm (or radp) coefficient is computed in PXDR_TRANSFER.f90
     rate1 = gamm(i) * EXP(-bet(i) * av) * radm
     rate2 = gamm(i) * EXP(-bet(i) * avr) * radp
     rate = rate1 + rate2

     ik = react(i,0)
     DO j = 4, ik+1
        iprod = react(i,j)
        kkk = indy(iprod) + 1
        indy(iprod) = kkk
        xmatk(iprod)%fdt(kkk)%k = rate
     ENDDO

     kkk = indy(ir1) + 1
     indy(ir1) = kkk
     xmatk(ir1)%fdt(kkk)%k = - rate

     all_rate_chem(i,iopt) = rate * ab(ir1)
     rate_chem(i) = rate
  ENDDO

!-------------------------------------------------------------------------
! (7) photoreactions with direct integration (nphot_i)    (s-1)
!-------------------------------------------------------------------------
  ideb = ifin + 1
  ifin = ifin + nphot_i
  DO i = ideb, ifin
     rate = pdiesp(i-ideb+1,iopt)

     ik = react(i,0)
     DO j = 4, ik+1
        iprod = react(i,j)
        kkk = indy(iprod) + 1
        indy(iprod) = kkk
        xmatk(iprod)%fdt(kkk)%k = rate
     ENDDO

     ir1 = react(i,1)
     kkk = indy(ir1) + 1
     indy(ir1) = kkk
     xmatk(ir1)%fdt(kkk)%k = - rate

     all_rate_chem(i,iopt) = rate * ab(ir1)
     rate_chem(i) = rate
  ENDDO

!-------------------------------------------------------------------------
! (8) 3 body reactions (n3body)
!-------------------------------------------------------------------------
  ideb = ifin + 1
  ifin = ifin + n3body
  DO i = ideb, ifin
     ir1 = react(i,1)
     ir2 = react(i,2)
     ir3 = react(i,3)
     expon = EXP(-bet(i)/ttry)
     rate = gamm(i) * (ttry/300.0_dp)**alpha(i) * expon

     ik = react(i,0)
     DO j = 4, ik+1
        iprod = react(i,j)
        kkk = indy(iprod) + 1
        indy(iprod) = kkk
        xmatk(iprod)%fdt(kkk)%k = rate
     ENDDO

     kkk = indy(ir1) + 1
     indy(ir1) = kkk
     xmatk(ir1)%fdt(kkk)%k = - rate
     kkk = indy(ir2) + 1
     indy(ir2) = kkk
     xmatk(ir2)%fdt(kkk)%k = - rate
     kkk = indy(ir3) + 1
     indy(ir3) = kkk
     xmatk(ir3)%fdt(kkk)%k = - rate

     all_rate_chem(i,iopt) = rate * ab(ir1) * ab(ir2) * ab(ir3)
     rate_chem(i) = rate
  ENDDO

!-------------------------------------------------------------------------
! (101...) exceptions (ncpart)
!-------------------------------------------------------------------------
  ideb = ifin + 1
  ifin = ifin + ncpart
  DO i = ideb, ifin
     ir1 = react(i,1)
     ir2 = react(i,2)
     ip1 = react(i,4)
     ip2 = react(i,5)

     !--------------------------------------------------------------------------
     ! (101) H2 + N+ -> NH+ + H
     !--------------------------------------------------------------------------
     IF ( (ir1 == i_h2 .AND. ir2 == i_np) .OR. (ir1 == i_np .AND. ir2 == i_h2)) &
        THEN
        !--- Old expression by Jacques
        !rate = gamm(i) * (h2para * EXP(-bet(i) / ttry) + h2orth)
        !               * ((ttry / 300.0_dp)**alpha(i))
        !--- Dislaire 2012 expression
        rate = gamm(i)    * h2para * EXP( -bet(i) / ttry) * (ttry / 300.0_dp)**alpha(i) &
             + 4.2e-10_dp * h2orth * EXP(-44.5_dp / ttry) * (ttry / 300.0_dp)**(-0.17_dp)

     !--------------------------------------------------------------------------
     ! (102) H2 + H2D+ -> H3+ + HD
     !--------------------------------------------------------------------------
     !--- Old expressions
     !ELSE IF (ir1 == i_h2 .AND. ir2 == i_h2dp .AND. ttry>= 20.0_dp)   THEN
     !     rate = gamm(i) / 10**(62.481_dp * ttry**(-0.94871_dp))
     !ELSE IF (ir1 == i_h2 .AND. ir2 == i_h2dp .AND. ttry< 20.0_dp) THEN
     !     rate = gamm(i) / (6.3407e35_dp * ttry**(-25.203_dp))
     !--- Expression with para and ortho H2
     ELSE IF (ir1 == i_h2 .AND. ir2 == i_h2dp)  THEN
        rate = gamm(i) * (h2para * EXP(-bet(i) / ttry)                  &
                       + h2orth * EXP(-61.5_dp / ttry) * ((ttry / 300.0_dp)**alpha(i)))

     !--------------------------------------------------------------------------
     ! (103) 13C+ + CO - Roueff & Loison (2014)
     !--------------------------------------------------------------------------
     ELSE IF (itype(i) == 103 .AND. (ir1 == i_c13p .OR. ir2 == i_c13p ))  THEN
        rate = gamm(i) * (ttry/300.0_dp)**alpha(i) * EXP(-6.5_dp/ttry)  &
                       * (1.0_dp / (1.0_dp + EXP(-bet(i)/ttry)))

     !--------------------------------------------------------------------------
     ! (103) C+ + 13CO - Roueff & Loison (2014)
     !--------------------------------------------------------------------------
     ELSE IF (itype(i) == 103 .AND. (ir1 == i_cp .OR. ir2 == i_cp ))  THEN
        rate = gamm(i) * (ttry/300.0_dp)**alpha(i) * EXP(-6.5_dp/ttry)  &
                       * EXP(-bet(i)/ttry) * (1.0_dp / (1.0_dp + EXP(-bet(i)/ttry)))

     !--------------------------------------------------------------------------
     ! (104) Isotopic exchange class B (Evelyne)
     !       13C+ + XXX ->
     !       13C  + XXX ->
     !--------------------------------------------------------------------------
     ELSE IF (itype(i) == 104 .AND. (ir1 == i_c13p .OR. ir1 == i_c13 &
                              .OR.   ir2 == i_c13p .OR. ir2 == i_c13)) THEN
        rate = gamm(i) * (ttry/300.0_dp)**alpha(i)   &
                       * (1.0_dp / (1.0_dp + EXP(-bet(i)/ttry)))
     ELSE IF (itype(i) == 104 .AND. (ir1 == i_cp .OR. ir1 == i_c &
                              .OR.   ir2 == i_cp .OR. ir2 == i_c)) THEN
        rate = gamm(i) * (ttry/300.0_dp)**alpha(i)   &
                       * EXP(-bet(i)/ttry) * (1.0_dp / (1.0_dp + EXP(-bet(i)/ttry)))

     !--------------------------------------------------------------------------
     ! (105) Reactions avec formule IONPOL1 (voir KIDA)
     ! Example: C+   + NH3
     !          H2+  + CN
     !          NH+  + CN
     !          HCN+ + H2O
     !          H+   + HCN
     !--------------------------------------------------------------------------
     ELSE IF (itype(i) == 105) THEN
        !rate = gamm(i) * (ttry/300.0_dp)**alpha(i) * EXP(-ttry/bet(i)) ! pour EXP()T/DE) ala Black H-
        rate = gamm(i) * alpha(i) * (0.62_dp + (0.4767_dp * bet(i) / sqrt(ttry/300.0_dp)))

     !--------------------------------------------------------------------------
     ! (106) Reactions avec formule IONPOL2
     !--------------------------------------------------------------------------
     ELSE IF (itype(i) == 106) THEN
        rate = gamm(i) * alpha(i) * (1.0_dp + (0.0967_dp * bet(i) / sqrt(ttry/300.0_dp) &
                                            + (bet(i)**2 / 10.526_dp * 300.0_dp/ttry)))

     !--------------------------------------------------------------------------
     ! (107) Cl + H2 -> HCl + H
     !--------------------------------------------------------------------------
     ELSE IF (itype(i) == 107 .AND. ttry< 354.0_dp &
              .AND. (ip1 == i_hcl .OR. ip2 == i_hcl)) THEN
        rate = 2.52e-11_dp * EXP(-2214.0_dp / ttry)
     ELSE IF (itype(i) == 107 .AND. ttry>= 354.0_dp &
              .AND. (ip1 == i_hcl .OR. ip2 == i_hcl)) THEN
        rate = 2.86e-12_dp * (ttry/300.0_dp)**1.72_dp * EXP(-1544.0_dp / ttry)

     !--------------------------------------------------------------------------
     ! (107) HCl + H -> Cl + H2
     !--------------------------------------------------------------------------
     ELSE IF (itype(i) == 107 .AND. ttry< 354.0_dp &
              .AND. (ir1 == i_hcl .OR. ir2 == i_hcl))  THEN
        rate = 1.49e-11_dp * EXP(-1763.0_dp / ttry)
     ELSE IF (itype(i) == 107 .AND. ttry>= 354.0_dp &
              .AND. (ir1 == i_hcl .OR. ir2 == i_hcl))   THEN
        rate = 1.69e-12_dp * (ttry/300.0_dp)**1.72_dp * EXP(-1093.0_dp / ttry)

     !--------------------------------------------------------------------------
     ! (108) F + H2 -> HF + H
     !--------------------------------------------------------------------------
     ELSE IF (itype(i) == 108) THEN
       !--- Old expression from Neufeld 2009
       !rate = 1.0e-10_dp * (EXP(-450.0_dp/ttry) + 0.078_dp * EXP(-80.0_dp/ttry) &
       !     + 0.01555_dp * EXP(-10.0_dp/ttry))
       !--- Expression updated by Tizniti et al. 2014
       rate = 4.71e-13_dp * (EXP(-0.364_dp/ttry) + 3.38_dp * EXP(-38.9_dp/ttry) &
            + 212.0_dp * EXP(-881.0_dp/ttry) + 124.0_dp * EXP(-414.0_dp/ttry))

     !--------------------------------------------------------------------------
     ! (109) Isotopic exchange class B with symmetrical reactions
     !--------------------------------------------------------------------------
     ELSE IF (itype(i) == 109 .AND. (ir1 == i_c13p .OR. ir1 == i_c13 &
                              .OR.   ir2 == i_c13p .OR. ir2 == i_c13)) THEN
        rate = gamm(i) * (ttry/300.0_dp)**alpha(i) &
                       * (2.0_dp / (2.0_dp + EXP(-bet(i)/ttry)))
     ELSE IF (itype(i) == 109 .AND. (ir1 == i_cp .OR. ir1 == i_c &
                              .OR.   ir2 == i_cp .OR. ir2 == i_c)) THEN
        rate = gamm(i) * (ttry/300.0_dp)**alpha(i) &
                       * EXP(-bet(i)/ttry) * (1.0_dp / (2.0_dp + EXP(-bet(i)/ttry)))

     !--------------------------------------------------------------------------
     ! (110) Collisional dissociation of H2
     !--------------------------------------------------------------------------
     ELSE IF (itype(i) == 110 .AND. (ir1 == i_h .AND. ir2 == i_h2)) THEN
        ! Janev et al. (2008)
        DO iv1 = 0, 14
           kvh2(iv1) = -a1h2v(iv1) - a2h2v(iv1) / (ttry**a3h2v(iv1) * (1.0_dp + a4h2v(iv1) * ttry**a5h2v(iv1)))
        ENDDO
        kvh2 = EXP(kvh2)
        rate = SUM(kvh2(:)*xh2v(:))

        ! Glover et Mac Low, low and high density
        !rate_l = 6.67e-12_dp * SQRT(ttry) * EXP(-(1.0_dp + 63590.0_dp / ttry))
        !rate_h = 3.52e-9_dp * EXP(-43900.0_dp / ttry)
        !rate = EXP(((densh(iopt) / 1.3e3_dp) * LOG(rate_h) + LOG(rate_l)) / (1.0_dp + densh(iopt) / 1.3e3_dp))
     ELSE IF (itype(i) == 110 .AND. (ir1 == i_h2 .AND. ir2 == i_h2)) THEN
        ! Janev et al. (2008)
        DO iv1 = 0, 14
           kvh2(iv1) = 1.30_dp * (1.0_dp + 0.023_dp*iv1 + 1.93e-5_dp * iv1**4.75_dp + 2.85e-24_dp * iv1**21.60_dp) &
                     * EXP(-(7.47_dp - 0.322_dp*iv1) * 1.0e3_dp / ttry) * 1.0e-10_dp
        ENDDO
        rate = SUM(kvh2(:)*xh2v(:))

        ! Glover et Mac Low, low density
        !rate_l = 5.996e-30_dp * ttry**4.1881_dp * EXP(-54657.4_dp/ttry) / (1.0_dp + 6.761e-6_dp * ttry)**5.6881_dp
        !rate_h = 1.3e-9_dp * EXP(-53300.0_dp / ttry)
        !rate = EXP(((densh(iopt) / 1.3e3_dp) * LOG(rate_h) + LOG(rate_l)) / (1.0_dp + densh(iopt) / 1.3e3_dp))
     ELSE
        rate = 0.0_dp
     ENDIF

     ik = react(i,0)
     DO j = 4, ik+1
        iprod = react(i,j)
        kkk = indy(iprod) + 1
        indy(iprod) = kkk
        xmatk(iprod)%fdt(kkk)%k = rate
     ENDDO

     kkk = indy(ir1) + 1
     indy(ir1) = kkk
     xmatk(ir1)%fdt(kkk)%k = - rate

     kkk = indy(ir2) + 1
     indy(ir2) = kkk
     xmatk(ir2)%fdt(kkk)%k = - rate

     all_rate_chem(i,iopt) = rate * ab(ir1) * ab(ir2)
     rate_chem(i) = rate
  ENDDO

!       ---------------------
!-- 2 - Reactions with grains
!       ---------------------

!-------------------------------------------------------------------------
! (11) reactions on grain surface (ngsurf)
!-------------------------------------------------------------------------
! 10 Feb 2008 - Those reaction are built for only one product
!               This could be changed later
! 15 Jan 2010 - Upgraded to surface reaction with ice mantle.
!               Heavy species are supposed NOT to exhibit tunelling
!               All terms are written as in the document, without possible simplifications.
! 29 Jan 2010 - Add up to 4 products for Ice mantle species (type 11 only)
!               Note: If H or H2 is produced, it MUST desorb immediatly !!!

  ideb = ifin + 1
  ifin = ifin + ngsurf
  DO i = ideb, ifin

     ir1 = react(i,1)
     ir2 = react(i,2)

     ! vibration frequencies in a site
     nu0_1 = SQRT(2.0_dp*xk*t_evap(ir1)/(xmh*mol(ir1))) / (xpi * dsite)
     nu0_2 = SQRT(2.0_dp*xk*t_evap(ir2)/(xmh*mol(ir2))) / (xpi * dsite)
     ! reaction attempts frequency (Ref: Garrod & Pauly 2011, section 2.2)
     nu0_3 = MAX(nu0_1, nu0_2)
     ! reduced mass of the two reactants
     redmass = xmh * mol(ir1) * mol(ir2) / (mol(ir1) + mol(ir2))

     !-------------------------------------------------------------------
     ! Reaction between 2 mantle species
     !-------------------------------------------------------------------
     IF (itype(i) == 11) THEN

        react_eff = 0.0_dp     ! Efficiency of the reaction (no unit)
        rate      = 0.0_dp     ! Reaction rate

        !-- Probability of reaction
        DO mm = 1, npg
           tgr = tdust(mm,iopt) ! Grain temperature of size mm

           ! Hopping frequencies - diffusion between sites
           tm1_1 = nu0_1 * (EXP(-t_diff(ir1) / tgr)) ! Hopping frequency (s-1)
           tm1_2 = nu0_2 * (EXP(-t_diff(ir2) / tgr)) ! Hopping frequency (s-1)

           ! Tunneling effect transmission through the activation barrier
           ! - Approximation
           ! tunnel_trans = 16.0_dp * (tgr*(bet(i) - tgr)/bet(i)**2) * EXP(-dthres / xhp * xpi * SQRT(2.0_dp * redmass * xk * bet(i)))
           ! - Expression by Evelyne, Atkins or Cohen
           IF (bet(i) > tgr) THEN
              xldb_3 =  2.0_dp * xpi / xhp * SQRT(2.0_dp * redmass * xk * (bet(i) - tgr))
              tunnel_trans =  1.0_dp / (1.0_dp + bet(i)**2 &
                           * (SINH(xldb_3 * dthres))**2 / (4.0_dp * tgr * (bet(i) - tgr)))
              p_react  = gamm(i) * (nu0_3 * EXP(-bet(i)/tgr) + nu0_3 * tunnel_trans)
           ELSE
              p_react  = gamm(i) * nu0_3 * EXP(-bet(i)/tgr)
           ENDIF

           ! Efficiency of reaction between the two species (Chang 2007, Garrod and Pauly 2011)
           p_diff    = tm1_1 + tm1_2
           p_desor   = nu0_1 * EXP(-t_evap(ir1) / tgr) + nu0_2 * EXP(-t_evap(ir2) / tgr)
           react_eff = p_react / (p_react + p_diff + p_desor)

           ! Chemical reaction rates
           rate = rate + react_eff * (tm1_1 + tm1_2) * adust(mm)**2 * wwmg(mm)

        ENDDO
        rate = rate * 2.0_dp*xpi * dsite**2 / (s_gr_t_bgr**2 * densh(iopt))
        rate = rate * attenu**2

        ik = react(i,0)
        DO j = 4, ik+1
           iprod = react(i,j)
           kkk = indy(iprod) + 1
           indy(iprod) = kkk
           xmatk(iprod)%fdt(kkk)%k = rate
        ENDDO

        kkk = indy(ir1) + 1
        indy(ir1) = kkk
        xmatk(ir1)%fdt(kkk)%k = - rate

        kkk = indy(ir2) + 1
        indy(ir2) = kkk
        xmatk(ir2)%fdt(kkk)%k = - rate

        all_rate_chem(i,iopt) = rate * ab(ir1) * ab(ir2)
        rate_chem(i) = rate

     !-------------------------------------------------------------------
     ! Reaction between 1 surface specy and 1 mantle specy
     !-------------------------------------------------------------------
     ELSE IF (itype(i) == 111) THEN

        react_eff = 0.0_dp     ! Efficiency of the reaction (no unit)
        rate      = 0.0_dp     ! Reaction rate

        all_rate_chem(i,iopt) = 0.0_dp
        rate_chem(i) = 0.0_dp

        DO mm = 1, npg
           iv2 = nspec + (ir2 - nsp_n1 - 1) * npg + mm
           tgr = tdust(mm,iopt)

           ! Hopping frequencies - diffusion between sites
           xldb_2 =  2.0_dp * xpi * SQRT(2.0_dp * xmh * mol(ir2) * xk * (t_diff(ir2) - tgr)) / xhp
           tm1_1 = nu0_1 * (EXP(-t_diff(ir1) / tgr))
           tm1_2 = nu0_2 * (EXP(-t_diff(ir2) / tgr) + 1.0_dp / (1.0_dp + t_diff(ir2)**2 &
                 * SINH(xldb_2 * dsite)**2 / (4.0_dp * tgr * (t_diff(ir2) - tgr))))

           ! Tunneling effect transmission through the activation barrier
           ! - Approximation
           ! tunnel_trans = 16.0_dp * (tgr*(bet(i) - tgr)/bet(i)**2) * EXP(-dthres / xhp * xpi * SQRT(2.0_dp * redmass * xk * bet(i)))
           ! - Expression by Evelyne, Atkins or Cohen
           IF (bet(i) > tgr) THEN
              xldb_3 =  2.0_dp * xpi / xhp * SQRT(2.0_dp * redmass * xk * (bet(i) - tgr))
              tunnel_trans =  1.0_dp / (1.0_dp + bet(i)**2 &
                           * (SINH(xldb_3 * dthres))**2 / (4.0_dp * tgr * (bet(i) - tgr)))
              p_react  = gamm(i) * (nu0_3 * EXP(-bet(i)/tgr) + nu0_3 * tunnel_trans)
           ELSE
              p_react  = gamm(i) * nu0_3 * EXP(-bet(i)/tgr)
           ENDIF

           ! Efficiency of reaction between the two species (Chang 2007, Garrod and Pauly 2011)
           p_diff    = tm1_1 + tm1_2
           p_desor   = nu0_1 * EXP(-t_evap(ir1) / tgr) + nu0_2 * EXP(-t_evap(ir2) / tgr)
           react_eff = p_react / (p_react + p_diff + p_desor)

           rate = react_eff * (tm1_1 + tm1_2) * dsite**2 / (2.0_dp * s_gr_t_bgr * densh(iopt))
           rate = rate * attenu

           ik = react(i,0)
           DO j = 4, ik+1
              iprod = react(i,j)
              kkk = indy(iprod) + 1
              indy(iprod) = kkk
              xmatk(iprod)%fdt(kkk)%k = rate * wwmg(mm) * densh(iopt)
           ENDDO

           kkk = indy(ir1) + 1
           indy(ir1) = kkk
           xmatk(ir1)%fdt(kkk)%k = - rate * wwmg(mm) * densh(iopt)

           kkk = indy(iv2) + 1
           indy(iv2) = kkk
           xmatk(iv2)%fdt(kkk)%k = - rate

           all_rate_chem(i,iopt) = all_rate_chem(i,iopt) + rate * wwmg(mm) * densh(iopt) * ab(ir1) * ab(iv2)
           rate_chem(i) = rate_chem(i) + rate * wwmg(mm) * densh(iopt)
        ENDDO

     !-------------------------------------------------------------------
     ! Reaction between 2 surface species
     !-------------------------------------------------------------------
     ELSE IF (itype(i) == 211) THEN

        react_eff = 0.0_dp     ! Efficiency of the reaction (no unit)
        rate      = 0.0_dp     ! Reaction rate

        all_rate_chem(i,iopt) = 0.0_dp
        rate_chem(i) = 0.0_dp
        iprod = react(i,4)
        DO mm = 1, npg
           iv1 = nspec + (ir1 - nsp_n1 - 1) * npg + mm
           iv2 = nspec + (ir2 - nsp_n1 - 1) * npg + mm
           tgr = tdust(mm,iopt)

           ! Hopping frequencies - diffusion between sites
           xldb_1 =  2.0_dp * xpi * SQRT(2.0_dp * xmh * mol(ir1) * xk * (t_diff(ir1) - tgr)) / xhp
           xldb_2 =  2.0_dp * xpi * SQRT(2.0_dp * xmh * mol(ir2) * xk * (t_diff(ir2) - tgr)) / xhp
           tm1_1 = nu0_1 * (EXP(-t_diff(ir1) / tgr) + 1.0_dp / (1.0_dp + t_diff(ir1)**2 &
                 * SINH(xldb_1 * dsite)**2 / (4.0_dp * tgr * (t_diff(ir1) - tgr))))
           tm1_2 = nu0_2 * (EXP(-t_diff(ir2) / tgr) + 1.0_dp / (1.0_dp + t_diff(ir2)**2 &
                 * SINH(xldb_2 * dsite)**2 / (4.0_dp * tgr * (t_diff(ir2) - tgr))))

           ! Tunneling effect transmission through the activation barrier
           ! - Approximation
           ! tunnel_trans = 16.0_dp * (tgr*(bet(i) - tgr)/bet(i)**2) * EXP(-dthres / xhp * xpi * SQRT(2.0_dp * redmass * xk * bet(i)))
           ! - Expression by Evelyne, Atkins or Cohen
           IF (bet(i) > tgr) THEN
              xldb_3 =  2.0_dp * xpi / xhp * SQRT(2.0_dp * redmass * xk * (bet(i) - tgr))
              tunnel_trans =  1.0_dp / (1.0_dp + bet(i)**2 &
                           * (SINH(xldb_3 * dthres))**2 / (4.0_dp * tgr * (bet(i) - tgr)))
              p_react  = gamm(i) * (nu0_3 * EXP(-bet(i)/tgr) + nu0_3 * tunnel_trans)
           ELSE
              p_react  = gamm(i) * nu0_3 * EXP(-bet(i)/tgr)
           ENDIF

           ! Efficiency of reaction between the two species (Chang 2007, Garrod and Pauly 2011)
           p_diff    = tm1_1 + tm1_2
           p_desor   = nu0_1 * EXP(-t_evap(ir1) / tgr) + nu0_2 * EXP(-t_evap(ir2) / tgr)
           react_eff = p_react / (p_react + p_diff + p_desor)

           ! This should be 1 / (8 * pi) (see notes)
           rate = react_eff * (tm1_1 + tm1_2) * dsite**2 / (8.0_dp * xpi * adust(mm)**2)

           kkk = indy(iprod) + 1
           indy(iprod) = kkk
           xmatk(iprod)%fdt(kkk)%k = rate * wwmg(mm) * densh(iopt)

           kkk = indy(iv1) + 1
           indy(iv1) = kkk
           xmatk(iv1)%fdt(kkk)%k = - rate

           kkk = indy(iv2) + 1
           indy(iv2) = kkk
           xmatk(iv2)%fdt(kkk)%k = - rate

           all_rate_chem(i,iopt) = all_rate_chem(i,iopt) + rate * wwmg(mm) * densh(iopt) * ab(iv1) * ab(iv2)
           rate_chem(i) = rate_chem(i) + rate * wwmg(mm) * densh(iopt)
        ENDDO
     ENDIF
  ENDDO

!-------------------------------------------------------------------------
! (12) photoreactions on grain surface (ngphot)
!-------------------------------------------------------------------------
!  11 Feb 2008: not revised yet. Do not use
  ideb = ifin + 1
  ifin = ifin + ngphot
  DO i = ideb, ifin
     rate1 = gamm(i) * EXP(-bet(i)*av) * radm
     rate2 = gamm(i) * EXP(-bet(i)*avr) * radp
     rate = rate1 + rate2

     ik = react(i,0)
     DO j = 4, ik+1
        iprod = react(i,j)
        kkk = indy(iprod) + 1
        indy(iprod) = kkk
        xmatk(iprod)%fdt(kkk)%k = rate
     ENDDO

     ir1 = react(i,1)
     kkk = indy(ir1) + 1
     indy(ir1) = kkk
     xmatk(ir1)%fdt(kkk)%k = - rate

     all_rate_chem(i,iopt) = rate * ab(ir1)
     rate_chem(i) = rate
  ENDDO

!-------------------------------------------------------------------------
! (13) adsorption on to grains (ngads)
!-------------------------------------------------------------------------
  IF (.NOT. ALLOCATED(stickH)) THEN
     ALLOCATE (stickH(npg))
  ENDIF

  ideb = ifin + 1
  ifin = ifin + ngads
  DO i = ideb, ifin
     ir1 = react(i,1)
     iprod = react(i,4)

     vtherm = vmaxw * SQRT(ttry / mol(ir1))

     ! Same sticking probability for all species (not only for H and D)
     CALL STICKING(iopt, i, ir1, stickH)
     stick_m = SUM(wwmg(:) * adust(:)**2 * stickH(:))

     !-------------------------------------------------------------------
     ! Adsorption of mantle species
     !-------------------------------------------------------------------
     IF (itype(i) == 13) THEN

        rate = vtherm * xpi * densh(iopt) * stick_m

        kkk = indy(iprod) + 1
        indy(iprod) = kkk
        xmatk(iprod)%fdt(kkk)%k = rate

        kkk = indy(ir1) + 1
        indy(ir1) = kkk
        xmatk(ir1)%fdt(kkk)%k = - rate

        all_rate_chem(i,iopt) = rate * ab(ir1)
        rate_chem(i) = rate

     !-------------------------------------------------------------------
     ! Adsorption of light species (rejection, reaction and adsorption)
     !-------------------------------------------------------------------
     ELSE IF (itype(i) == 113) THEN

        sigm   = vtherm * dsite*dsite / 4.0_dp
        k_Ad   = vtherm * xpi * densh(iopt) * stick_m

        kkk = indy(ir1) + 1
        indy(ir1) = kkk
        xmatk(ir1)%fdt(kkk)%k = - k_Ad           ! 1 destruction reaction for ir1 (-k_{Ad})

        all_rate_chem(i,iopt) = k_Ad * ab(ir1)
        rate_chem(i) = k_Ad

        DO mm = 1, npg
           ivp = nspec + (iprod - nsp_n1 - 1) * npg + mm

           k_i_Ad  = stickH(mm) * vtherm * xpi * adust(mm)**2
           k_i_Rej = stickH(mm) * sigm

           kkk = indy(ivp) + 1
           indy(ivp) = kkk
           xmatk(ivp)%fdt(kkk)%k = k_i_Ad        ! 1 formation of N_j(a_i) (+k^i_{Ad})

           DO j = nsp_n1+1, nsp_n1+nsp_g1
              pr = pr_rej(iprod-nsp_n1,j-nsp_n1)
              k_ij_Rej = sigm * (stickH(mm) - 1.0_dp + pr) * densh(iopt) * wwmg(mm)
              k_j_ER   = sigm * (1.0_dp - pr)
              k_ij_ER  = k_j_ER * densh(iopt) * wwmg(mm)

              kkk = indy(ir1) + 1
              indy(ir1) = kkk
              xmatk(ir1)%fdt(kkk)%k = k_ij_Rej   ! 1 rejection for ir1 (+k^{ij}_{Rej})

              IF (iprod == i_hgr) THEN
                 IF (j == i_hgr) THEN
                    kkk = indy(ivp) + 1
                    indy(ivp) = kkk
                    xmatk(ivp)%fdt(kkk)%k = -k_i_Rej        ! 1 rejection of N_j(a_i) (-k^i_{Rej})
                    kkk = indy(ivp) + 1
                    indy(ivp) = kkk
                    xmatk(ivp)%fdt(kkk)%k = -k_j_ER      ! 1 destruction of N_j(a_i) (-k^j_{ER})
                    kkk = indy(i_h2) + 1
                    indy(i_h2) = kkk
                    xmatk(i_h2)%fdt(kkk)%k = k_ij_ER      ! 1 formation of H2 (+k^{ij}_ER)
                 ELSE IF (j == i_dgr) THEN
                    kkk = indy(ivp) + 1
                    indy(ivp) = kkk
                    xmatk(ivp)%fdt(kkk)%k = -k_i_Rej        ! 1 rejection of N_j(a_i) (-k^i_{Rej})
                    kkk = indy(ivp) + 1
                    indy(ivp) = kkk
                    xmatk(ivp)%fdt(kkk)%k = -k_j_ER      ! 1 destruction of N_j(a_i) (-k^j_{ER})
                    kkk = indy(i_hd) + 1
                    indy(i_hd) = kkk
                    xmatk(i_hd)%fdt(kkk)%k = k_ij_ER      ! 1 formation of HD (+k^{ij}_ER)
                 ELSE
                    kkk = indy(ivp) + 1
                    indy(ivp) = kkk
                    xmatk(ivp)%fdt(kkk)%k = -k_i_Rej        ! 1 rejection of N_j(a_i) (-k^i_{Rej})
                 ENDIF
              ELSE IF (iprod == i_dgr) THEN
                 IF (j == i_hgr) THEN
                    kkk = indy(ivp) + 1
                    indy(ivp) = kkk
                    xmatk(ivp)%fdt(kkk)%k = -k_i_Rej        ! 1 rejection of N_j(a_i) (-k^i_{Rej})
                    kkk = indy(ivp) + 1
                    indy(ivp) = kkk
                    xmatk(ivp)%fdt(kkk)%k = -k_j_ER      ! 1 destruction of N_j(a_i) (-k^j_{ER})
                    kkk = indy(i_hd) + 1
                    indy(i_hd) = kkk
                    xmatk(i_hd)%fdt(kkk)%k = k_ij_ER      ! 1 formation of HD (+k^{ij}_ER)
                 ELSE
                    kkk = indy(ivp) + 1
                    indy(ivp) = kkk
                    xmatk(ivp)%fdt(kkk)%k = -k_i_Rej        ! 1 rejection of N_j(a_i) (-k^i_{Rej})
                 ENDIF
              ELSE
                 kkk = indy(ivp) + 1
                 indy(ivp) = kkk
                 xmatk(ivp)%fdt(kkk)%k = -k_i_Rej           ! 1 rejection of N_j(a_i) (-k^i_{Rej})
              ENDIF
           ENDDO
        ENDDO
     ENDIF
  ENDDO

  DEALLOCATE (stickH)

!-------------------------------------------------------------------------
! (14) neutralization (ngneut)
!-------------------------------------------------------------------------
  ideb = ifin + 1
  ifin = ifin + ngneut

  IF (from_CT /= 1) THEN
     CALL FBTH1 (ttry, iopt, itn, ab)
  ENDIF

  DO i = ideb, ifin
     ir1   = react(i,1)
     iprod = react(i,4)
     IF ( (ir1 > nsp_ne) .AND. (ir1 <= nsp_ne+nsp_ip+nsp_im) ) THEN
        rate = rxigr(ir1,iopt)
     ELSE IF ( ir1 == nspec ) THEN
        rate = relgr(2,iopt)
     ELSE IF ( iprod == nspec ) THEN
        rate = relgr(1,iopt)
     ENDIF

     IF ( iprod <= n_var ) THEN
        kkk = indy(iprod) + 1
        indy(iprod) = kkk
        xmatk(iprod)%fdt(kkk)%k = rate
     ENDIF

     IF ( ir1 <= n_var ) THEN
        kkk = indy(ir1) + 1
        indy(ir1) = kkk
        xmatk(ir1)%fdt(kkk)%k = - rate
     ENDIF

     all_rate_chem(i,iopt) = rate * ab(ir1)
     rate_chem(i) = rate
  ENDDO

!-------------------------------------------------------------------------
! (15) explosive desorption from grains (nggdes)
!    ref: Shalabiea & Greenberg 1994
!-------------------------------------------------------------------------
!  11 Feb 2008: not revised yet. Do not use
  ideb = ifin + 1
  ifin = ifin + nggdes
  DO i = ideb, ifin
     ir1 = react(i,1)
     rate1 = gamm(i) * rdeso * densh(iopt)
     rate2 = gamm(i) * 3.0d4 * zeta * (signgr / 7.0e-21_dp)
     rate = rate1 + rate2

     IF (itype(i) == 15) THEN
        iprod = react(i,4)
        kkk = indy(iprod) + 1
        indy(iprod) = kkk
        xmatk(iprod)%fdt(kkk)%k = rate

        kkk = indy(ir1) + 1
        indy(ir1) = kkk
        xmatk(ir1)%fdt(kkk)%k = - rate

        all_rate_chem(i,iopt) = rate * ab(ir1)
        rate_chem(i) = rate
     ENDIF
  ENDDO

!-------------------------------------------------------------------------
! (16) cosmic ray induced desorption from grains (ncrdes)
!      (sans les photons secondaires)
!-------------------------------------------------------------------------
  ideb = ifin + 1
  ifin = ifin + ncrdes
  DO i = ideb, ifin

     ! OLD - Rate used in first versions of surface chemistry
     ! rate = gamm(i) * zeta * dsite**2 / 4.0_dp
     ! NEW - New rate following a simple implementation of Emmanuel Dartois
     Yield_cr = 4.0_dp * zeta / 1E-16

     ir1 = react(i,1)

     !--- Mantle species ------------------------------------------------
     IF (itype(i) == 16) THEN

        rate = Yield_cr / 4.0_dp / ab_ads_tot * (s_gr_t_bgr*densh(iopt))

        ik = react(i,0)
        DO j = 4, ik+1
           iprod = react(i,j)
           kkk = indy(iprod) + 1
           indy(iprod) = kkk
           xmatk(iprod)%fdt(kkk)%k = rate
        ENDDO

        kkk = indy(ir1) + 1
        indy(ir1) = kkk
        xmatk(ir1)%fdt(kkk)%k = - rate

     !--- Surface species ------------------------------------------------
     ELSE IF (itype(i) == 116) THEN

        DO mm = 1, npg
           ivp = nspec + (ir1 - nsp_n1 - 1) * npg + mm
           kkk = indy(ivp) + 1
           indy(ivp) = kkk

           ! Compute NEW rate
           rate = 0.0_dp ! ATTENTION pour l'intant pas de desorption de H: par CRP
           !rate = Yield_cr * xpi * adust(mm)**2.0_dp / ab_ads_tot
           xmatk(ivp)%fdt(kkk)%k = - rate

           iprod = react(i,4)
           kkk = indy(iprod) + 1
           indy(iprod) = kkk
           xmatk(iprod)%fdt(kkk)%k = rate * densh(iopt) * wwmg(mm)
        ENDDO
     ENDIF

     all_rate_chem(i,iopt) = rate * ab(ir1)
     rate_chem(i) = rate
  ENDDO

!-------------------------------------------------------------------------
! (17) photodesorption from grains (nphdes)
!-------------------------------------------------------------------------
!  flux de photons secondaires due aux rayons cosmiques:
!     1E3 cm-2 s-1 (Roberge, in Dalgarno's book)
!     fphsec = 1.0e3_dp * (zeta / 1.0e-17_dp) = 1.0e3_dp * fmrc

!  flux de Mathis et al de 911 a 2400 A (avec F(l) = 5e-17 erg cm-3 A-1)
!  flupho = 1e8 photon cm-2 s-1      (Tielens & Hagen, 1982, A&A 114, 245)
!     flupho = 1.0d8
!     flupho = flupho * RAD * EXP(-2.0_dp * AV)
  ideb = ifin + 1
  ifin = ifin + nphdes
  DO i = ideb, ifin
     rate = gamm(i) * (4.0_dp * fphsec * frach2 + fluph(iopt)) * dsite**2 / 4.0_dp
     ir1 = react(i,1)

     !--- Mantle ----------------------------------------------
     IF (itype(i) == 17) THEN

        rate = rate / MAX(1.0_dp, x_lay(iopt))

        kkk = indy(ir1) + 1
        indy(ir1) = kkk
        xmatk(ir1)%fdt(kkk)%k = - rate

        ik = react(i,0)
        DO j = 4, ik+1
           iprod = react(i,j)
           kkk = indy(iprod) + 1
           indy(iprod) = kkk
           xmatk(iprod)%fdt(kkk)%k = rate
        ENDDO

     !--- Surface species --------------------------------------
     ELSE IF (itype(i) == 117) THEN

        DO mm = 1, npg
           ivp = nspec + (ir1 - nsp_n1 - 1) * npg + mm
           kkk = indy(ivp) + 1
           indy(ivp) = kkk
           xmatk(ivp)%fdt(kkk)%k = - rate

           ik = react(i,0)
           DO j = 4, ik+1
              iprod = react(i,j)
              kkk = indy(iprod) + 1
              indy(iprod) = kkk
              xmatk(iprod)%fdt(kkk)%k = rate * densh(iopt) * wwmg(mm)
           ENDDO
        ENDDO
     ENDIF

     all_rate_chem(i,iopt) = rate * ab(ir1)
     rate_chem(i) = rate
  ENDDO

!-------------------------------------------------------------------------
! (18) evaporation from grains (ngevap)
!-------------------------------------------------------------------------
  ideb = ifin + 1
  ifin = ifin + ngevap
  DO i = ideb, ifin
     ir1 = react(i,1)
     iprod = react(i,4)
!    nu0 = SQRT(2.0_dp*xk*t_evap(ir1)/(xmh*mol(ir1))) / (xpi * dsite)
     nu0 = SQRT(2.0_dp*xk*t_evap(ir1)/(xmh*mol(ir1))) / (xpi * dwell)

     IF (itype(i) == 18) THEN

        summ = 0.0_dp
        DO mm = 1, npg
!          tgr = MIN(tdust(mm,iopt), 25.0_dp)
           tgr = tdust(mm,iopt)
           summ = summ + wwmg(mm) * adust(mm)**2 * EXP(-t_evap(ir1) / tgr)
        ENDDO
!       Alternative expression (Evelyne) => no divide by zero for rmin = rmax
        rate = nu0 * summ * 4.0_dp * xpi * attenu / s_gr_t_bgr

        kkk = indy(iprod) + 1
        indy(iprod) = kkk
        xmatk(iprod)%fdt(kkk)%k = rate

        kkk = indy(ir1) + 1
        indy(ir1) = kkk
        xmatk(ir1)%fdt(kkk)%k = - rate

     ELSE IF (itype(i) == 118) THEN

        DO mm = 1, npg
           tgr = tdust(mm,iopt)
           rate = nu0 * EXP(-t_evap(ir1) / tgr)
           ivp = nspec + (ir1 - nsp_n1 - 1) * npg + mm
           kkk = indy(ivp) + 1
           indy(ivp) = kkk
           xmatk(ivp)%fdt(kkk)%k = - rate

           kkk = indy(iprod) + 1
           indy(iprod) = kkk
           xmatk(iprod)%fdt(kkk)%k = rate * densh(iopt) * wwmg(mm)
        ENDDO
     ENDIF

     all_rate_chem(i,iopt) = rate * ab(ir1)
     rate_chem(i) = rate
  ENDDO

!-------------------------------------------------------------------------
! (19) Chemisorption on grains (ngchs)
!-------------------------------------------------------------------------
  ideb = ifin + 1
  ifin = ifin + ngchs

  DO i = ideb, ifin
     ! stick_ER = MIN(1.0_dp, SQRT(300.0_dp/ttry))
     ! stick_ER = 1.0_dp / (1.0_dp + 1.0e-4_dp * ttry**1.5_dp)
     stick_ER = 1.0_dp / (1.0_dp + (ttry/T2_stick_ER)**ex_stick_ER)
     ir1 = react(i,1)

     expon = EXP(-bet(i)/ttry)
     rate  = stick_ER * gamm(i) * vmaxw * SQRT(ttry / mol(ir1)) * s_gr_t * densh(iopt) * expon / 4.0_dp
     r_rej = stick_ER * gamm(i) * vmaxw * SQRT(ttry / mol(ir1)) * dsite**2 *expon / 4.0_dp

     iprod = react(i,4)
     kkk = indy(iprod) + 1
     indy(iprod) = kkk
     xmatk(iprod)%fdt(kkk)%k = rate

     kkk = indy(ir1) + 1
     indy(ir1) = kkk
     xmatk(ir1)%fdt(kkk)%k = - rate

     ! Rejection
     kkk = indy(iprod) + 1
     indy(iprod) = kkk
     xmatk(iprod)%fdt(kkk)%k = - r_rej
     kkk = indy(ir1) + 1
     indy(ir1) = kkk
     xmatk(ir1)%fdt(kkk)%k = r_rej

     ! That value is known analytically if there are only 2 reactions
     ab(i_hgrc) =  (stick_ER * expon / (1.0_dp + stick_ER * expon)) * s_gr_t * densh(iopt) / dsite**2

     all_rate_chem(i,iopt) = rate * ab(ir1)
     rate_chem(i) = rate
  ENDDO

!-------------------------------------------------------------------------
! (20) Eley-Rideal process (ngelri)   (cm3 s-1)
!-------------------------------------------------------------------------
! Note : the total number of sites is: s_gr_t * densh(iopt) / dsite**2
  ideb = ifin + 1
  ifin = ifin + ngelri
  DO i = ideb, ifin

     rate = gamm(i) * vmaxw * SQRT(ttry / mol(ir1)) * dsite**2 / 4.0_dp

     ik = react(i,0)
     DO j = 4, ik+1
        iprod = react(i,j)
        kkk = indy(iprod) + 1
        indy(iprod) = kkk
        xmatk(iprod)%fdt(kkk)%k = rate
     ENDDO

     ir1 = react(i,1)
     kkk = indy(ir1) + 1
     indy(ir1) = kkk
     xmatk(ir1)%fdt(kkk)%k = - rate

     ir2 = react(i,2)
     kkk = indy(ir2) + 1
     indy(ir2) = kkk
     xmatk(ir2)%fdt(kkk)%k = - rate

     all_rate_chem(i,iopt) = rate * ab(ir1) * ab(ir2)
     rate_chem(i) = rate
  ENDDO

!-------------------------------------------------------------------------
! (40) radiative and dielec. recomb. of atomic ions (nglass)   (cm3 s-1)
!-------------------------------------------------------------------------
  ideb = ifin + 1
  ifin = ifin + nglass
  DO i = ideb, ifin
     ir1 = react(i,1)
     ir2 = react(i,2)

     l     = i-ideb+1
     bbadn = rdrec(l)%r_B + rdrec(l)%r_C * EXP(-rdrec(l)%r_T(2)/ttry)
     ! -------------------------------------------
     ! radiative recomb rates from Badnell (2006)
     ! -------------------------------------------
     IF( (rdrec(l)%r_T(0) /= 0.0_dp) .AND. (rdrec(l)%r_T(1) /= 0.0_dp) ) THEN
        rate = rdrec(l)%r_A * ( SQRT(ttry/rdrec(l)%r_T(0)) &
             * (1.0_dp + SQRT(ttry/rdrec(l)%r_T(0)))**(1.0_dp-bbadn) &
             * (1.0_dp + SQRT(ttry/rdrec(l)%r_T(1)))**(1.0_dp+bbadn) )**(-1.0_dp)
     ELSE
        rate = 0.0_dp
     ENDIF
     ! -------------------------------------------
     ! dissociative recomb rates from
     ! http://amdpp.phys.strath.ac.uk/tamoc/DR/
     ! -------------------------------------------
     rate = rate + ttry**(-1.5_dp) * SUM( rdrec(l)%d_C(1:9) * EXP(-rdrec(l)%d_E(1:9)/ttry) )
     ! -------------------------------------------
     ! Since Badnell's data are incomplete, the
     ! recombination of s+, s++, fe+, and fe++ are
     ! taken from Landini & Monsignori Fossi (1990)
     ! DR -> included in dielectro_recomb.dat
     ! RR -> expression A*(T/300)**B
     ! -------------------------------------------
     IF     ( ( (speci(ir1) == 's+      ' ).AND.(speci(ir2)=='electr  ') ).OR.&
              ( (speci(ir1) == 'electr  ' ).AND.(speci(ir2)=='s+      ') ) ) THEN
        rate = rate + 3.734e-12_dp*(ttry/300.0_dp)**(-6.300e-1_dp)
     ELSE IF( ( (speci(ir1) == 's++     ' ).AND.(speci(ir2)=='electr  ') ).OR.&
              ( (speci(ir1) == 'electr  ' ).AND.(speci(ir2)=='s++     ') ) ) THEN
        rate = rate + 1.995e-11_dp*(ttry/300.0_dp)**(-6.860e-1_dp)
     ELSE IF( ( (speci(ir1) == 'fe+     ' ).AND.(speci(ir2)=='electr  ') ).OR.&
              ( (speci(ir1) == 'electr  ' ).AND.(speci(ir2)=='fe+     ') ) ) THEN
        rate = rate + 3.230e-12_dp*(ttry/300.0_dp)**(-8.910e-1_dp)
     ELSE IF( ( (speci(ir1) == 'fe++    ' ).AND.(speci(ir2)=='electr  ') ).OR.&
              ( (speci(ir1) == 'electr  ' ).AND.(speci(ir2)=='fe++    ') ) ) THEN
        rate = rate + 1.961e-11_dp*(ttry/300.0_dp)**(-8.430e-1_dp)
     ENDIF
     ! -------------------------------------------
     ! Since Badnell's data are incomplete, the
     ! recombination of ar+ and ar++ are taken
     ! from Shull & Van Steenberg (1982) for both
     ! the radiative and dielectronic processes.
     ! -------------------------------------------
     IF     ( ( (speci(ir1) == 'Ar+     ' ).AND.(speci(ir2)=='electr  ') ).OR.&
              ( (speci(ir1) == 'electr  ' ).AND.(speci(ir2)=='Ar+     ') ) ) THEN
        rate = rate + 3.70e-12_dp*(ttry/300.0_dp)**(-6.51e-1_dp)
        rate = rate + ttry**(-1.5_dp) * 1.0e-3_dp * EXP(-3.2e+5_dp/ttry) &
             * (1.0_dp + 5.0e-3_dp * EXP(-3.1e+5/ttry))
     ELSE IF( ( (speci(ir1) == 'Ar++    ' ).AND.(speci(ir2)=='electr  ') ).OR.&
              ( (speci(ir1) == 'electr  ' ).AND.(speci(ir2)=='Ar++    ') ) ) THEN
        rate = rate + 2.72e-11_dp*(ttry/300.0_dp)**(-7.52e-1_dp)
        rate = rate + ttry**(-1.5_dp) * 1.1e-2_dp * EXP(-2.9e+5_dp/ttry) &
             * (1.0_dp + 4.5e-2_dp * EXP(-5.5e+5/ttry))
     ENDIF

     iprod = react(i,4)
     kkk = indy(iprod) + 1
     indy(iprod) = kkk
     xmatk(iprod)%fdt(kkk)%k = rate

     kkk = indy(ir1) + 1
     indy(ir1) = kkk
     xmatk(ir1)%fdt(kkk)%k = - rate

     kkk = indy(ir2) + 1
     indy(ir2) = kkk
     xmatk(ir2)%fdt(kkk)%k = - rate

     all_rate_chem(i,iopt) = rate * ab(ir1) * ab(ir2)
     rate_chem(i) = rate
  ENDDO

END SUBROUTINE CHIMIJ

!===============================================================================
SUBROUTINE MNEWT (ttry, iopt, itn)
!===============================================================================

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

!  See numerical recipe p 272.

   IMPLICIT NONE

   REAL (KIND=dp), INTENT (IN)                  :: ttry
   INTEGER, INTENT (IN)                         :: iopt, itn

!  Numerical PARAMETERs (unused outside MNEWT, used to be defined as PARAMETER)

   INTEGER         :: ntr1 = 10         ! Max number of global iteration in N-R algorithm
                                        !     1 global iter = change conservation equation
   INTEGER         :: ntr2 = 3          ! Max number of iteration with the same
                                        !     conservation equation
   REAL (KIND=dp)  :: tolx = 1.0e-6_dp  ! Total relative error for chemistry

   REAL (KIND=dp), ALLOCATABLE, DIMENSION (:,:) :: am, bbmn, bbmx
   REAL (KIND=dp), DIMENSION (nes)              :: abold, abt
   REAL (KIND=dp), DIMENSION(0:natom)           :: ratiab
   REAL (KIND=dp)                               :: ratlim = 1.0_dp
   INTEGER, DIMENSION (nes)                     :: indx
   REAL (KIND=dp), DIMENSION (nqm)              :: ab1, ab2, ab3
   INTEGER, DIMENSION (nqm)                     :: j1, j2, j3
   INTEGER                                      :: i, ii, j, k, l, k1, k2
   INTEGER                                      :: kspec, nrxi
   REAL (KIND=dp)                               :: damp, duma
   REAL (KIND=dp)                               :: bad, dum, tt1, top1, top2, ddumm
   REAL (KIND=dp)                               :: fabric, destru, des_f, toto
   INTEGER                                      :: nrhs = 1
   INTEGER                                      :: INFO, ici1, ici2, jjj, icc

   CHARACTER (LEN=1)                            :: TRANS = 'N'
   CHARACTER (LEN=1)                            :: FACT  = 'E'
   CHARACTER (LEN=1)                            :: EQUED
   REAL (KIND=dp), DIMENSION(:,:), ALLOCATABLE  :: AF
   REAL (KIND=dp), DIMENSION(:),   ALLOCATABLE  :: R, C
   REAL (KIND=dp), DIMENSION(:),   ALLOCATABLE  :: FERR, BERR
   REAL (KIND=dp)                               :: RCOND
   REAL (KIND=dp), DIMENSION(:),   ALLOCATABLE  :: WORK
   INTEGER,        DIMENSION(:),   ALLOCATABLE  :: IWORK

   ALLOCATE (am(n_var,n_var), bbmn(n_var,1))
   ALLOCATE (bbmx(n_var,1))

   ALLOCATE (AF(n_var,n_var))
   ALLOCATE (R(n_var), C(n_var))
   ALLOCATE (FERR(1), BERR(1))
   ALLOCATE (WORK(4*n_var))
   ALLOCATE (IWORK(n_var))

   abold(1:n_var) = ab(1:n_var)

   abt(:) = 0.0_dp
   DO i = 1, n_var
      duma = densh(iopt)
      DO j = 1, natom-1
         kspec = ael(i,j)
         IF (kspec == 0) THEN
            CYCLE
         ELSE
            duma = MIN(duma,densh(iopt)*abtot(j)/kspec)
         ENDIF
      ENDDO
      abt(i) = duma
   ENDDO

   DO k1 = 1, ntr1

   damp = 0.7_dp

   DO k2 = 1, ntr2

      ! usrfun computes the Jacobian and the function to nullify
      CALL USRFUN (iopt, am, bbmn)

      abold(1:n_var) = ab(1:n_var)

      ! Switch to LAPACK
      ! JLB - 3 II 2014 - Try using a faster routine
      IF (itn < 6 .AND. F_STABLE == 0) THEN
         CALL DGETRF (n_var, n_var, am, n_var, indx, INFO)
         CALL DGETRS (TRANS, n_var, nrhs, am, n_var, indx, bbmn, n_var, INFO)
      ELSE IF (F_STABLE == 2) THEN
         ! Use a robust (and time consuming) version of DGESV
         CALL DGESVX (FACT, TRANS, n_var, nrhs, am, n_var, AF, n_var, indx, EQUED, R, &
                      C, bbmn, n_var, bbmx, n_var, RCOND, FERR, BERR, WORK, IWORK, INFO)
!        print *, " DGESVX:", RCOND, FERR(1), BERR(1), WORK(1), INFO
         bbmn = bbmx
      ELSE
         ! Use a light version for the following iterations
         CALL DGESV (n_var, nrhs, am, n_var, indx, bbmn, n_var, INFO)
      ENDIF

      ! We limit variation to gas density, but ALL variables must be rescaled.
      dum = SUM(ABS(bbmn(1:nspec,1)))
      IF (dum > densh(iopt)) THEN
         bbmn(1:n_var,1) = bbmn(1:n_var,1) * densh(iopt) / dum
      ENDIF

      errx = 0.0_dp

      bad = 0.0_dp
      mauvai = 0
      DO i = 1, nspec
         IF (ab(i) > MAX(istiny,-bbmn(i,1)) .OR. bbmn(i,1) > 0.0_dp) THEN
            IF (ab(i) > 1.0e45_dp*istiny) THEN
               tt1 = ABS(bbmn(i,1)) / (abold(i) + istiny)
               errx = errx + tt1
               IF (bad < tt1) THEN
                  bad = tt1
                  mauvai = i
               ENDIF
            ENDIF
            IF (lcon(i) == 0) THEN
               ab(i) = ab(i) + bbmn(i,1) * damp
            ELSE
               ab(i) = ab(i) + bbmn(i,1)
            ENDIF
            IF (ab(i) > abt(i)) THEN
               ab(i) = (abt(i) + abold(i)) * 0.5_dp
            ELSE IF (ab(i) < 0.0_dp) THEN
               ab(i) = abold(i) / 10.0_dp
            ENDIF
         ELSE
            ab(i) = istiny
         ENDIF
         ab(i) = MAX(ab(i),istiny)
      ENDDO
      DO i = nspec+1, n_var
         tt1 = ABS(bbmn(i,1)) / (abold(i) + istiny)
         errx = errx + tt1
         ab(i) = ab(i) + bbmn(i,1)
         IF (ab(i) < 0.0_dp) THEN
            ab(i) = abold(i) / 10.0_dp
         ENDIF
      ENDDO

      IF (MOD(k2,2) == 1) THEN
         DO i = 1, n_var
            ab(i) = (ab(i) + abold(i)) * 0.5_dp
         ENDDO
      ENDIF
      ! *** end patch ***

      ! JLB - 15 X 2010 : add grain charge to electronic balance
      errx = errx / damp
      errc = 0.0_dp
      DO i = 1, n_var
         IF ((i > nsp_n1 .AND. i < nspec) .OR. ab(i) == 0.0_dp) THEN
            CYCLE
         ENDIF
         fabric = 0.0_dp
         destru = 0.0_dp
         des_f = 0.0_dp
         nrxi = xmatk(i)%nbt
         DO k = 1, nrxi
            j1(k) = xmatk(i)%fdt(k)%r1
            j2(k) = xmatk(i)%fdt(k)%r2
            j3(k) = xmatk(i)%fdt(k)%r3
            IF (j1(k) > n_var) THEN
               ab1(k) = 1.0_dp
            ELSE
               ab1(k) = ab(j1(k))
            ENDIF
            IF (j2(k) > n_var) THEN
               ab2(k) = 1.0_dp
            ELSE
               ab2(k) = ab(j2(k))
            ENDIF
            IF (j3(k) > n_var) THEN
               ab3(k) = 1.0_dp
            ELSE
               ab3(k) = ab(j3(k))
            ENDIF
            IF (xmatk(i)%fdt(k)%k > 0.0_dp) THEN
               fabric = fabric + xmatk(i)%fdt(k)%k * ab1(k) * ab2(k) * ab3(k)
            ELSE
               toto = xmatk(i)%fdt(k)%k * ab1(k) * ab2(k) * ab3(k)
               destru = destru + toto
               des_f = des_f + toto / ab(i)
            ENDIF
         ENDDO
         IF (ab(i) > 1.0e-20_dp) THEN
            errc = errc + ABS(fabric+destru)/ABS(fabric-destru)
         ELSE
            ab(i) = - fabric / des_f
            IF (ab(i) > abt(i)) THEN
               ab(i) = (abt(i) + abold(i)) * 0.5_dp
            ENDIF
         ENDIF
      ENDDO

      IF (errx <= tolx .AND. MOD(k2,2) == 0 .AND.  errc < 1.0e-3_dp) THEN
         CALL VERUSF (iopt, bbmn)
         DEALLOCATE (am, bbmn)
         RETURN
      ENDIF
   ENDDO

   ! Modify conservation equation in case of bad convergence
   DO i = 1, natom-1
      top1 = 0.0_dp
      top2 = 0.0_dp
      icx(i,1) = 0
      icx(i,2) = 0

      DO l = 1, nspec-1
         dum = ael(l,i)
         IF (dum == 0.0_dp) CYCLE
         IF (lcon(l) == i) THEN
            lcon(l) = 0
         ENDIF
         ddumm = ab(l) * dum
         IF (ddumm > top1) THEN
            top2 = top1
            top1 = ddumm
            icx(i,2) = icx(i,1)
            icx(i,1) = l
         ELSE IF (ddumm > top2) THEN
            top2 = ddumm
            icx(i,2) = l
         ENDIF
      ENDDO
      IF (top1 /= 0.0_dp) THEN
         ratiab(i) = top2 / top1
      ENDIF
   ENDDO
   if (icx(4,2) == i_h2ogr) then
!     print *, " Reverse to O"
      icx(4,2) = i_o
   endif

   DO i = 1, natom-1
      ici1 = icx(i,1)
      ici2 = icx(i,2)
      IF (ici1 == 0) CYCLE

      ! Patch recombination
      IF (ratiab(i) > ratlim) THEN
         IF (ael(ici1,natom) == 1 .AND. ael(ici2,natom) == 0) THEN
            jjj = ici1
            ici1 = ici2
            ici2 = jjj
         ENDIF
      ENDIF

      icc = 0
      DO ii = 1, i-1
         IF (lcon(ici1) == ii) icc = ii
      ENDDO

      ! Careful ! icx(icc,2) may have been used before to conserve another element
      IF (icc == 0) THEN
         lcon(ici1) = i
      ELSE
         IF (ratiab(i) > ratiab(icc)) THEN
            lcon(ici2) = i
         ELSE
            lcon(ici1) = i
            lcon(icx(icc,2)) = icc
         ENDIF
      ENDIF
   ENDDO

   ENDDO
   CALL VERUSF (iopt, bbmn)

   k2 = k2 - 1
!  ratlim = 0.35_dp
   ratlim = 0.20_dp

   DEALLOCATE (am, bbmn)
   DEALLOCATE (bbmx)

   DEALLOCATE (AF)
   DEALLOCATE (R, C)
   DEALLOCATE (FERR, BERR)
   DEALLOCATE (WORK)
   DEALLOCATE (IWORK)

END SUBROUTINE MNEWT

!===============================================================================
SUBROUTINE USRFUN (iopt, am, bbmn)
!===============================================================================

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

!  Computes the FUNCTION (-beta) to nullify and its derivatives
!  (alpha) at point ab, using conservation equations

   IMPLICIT NONE

   INTEGER, INTENT (IN)                          :: iopt

   REAL (KIND=dp), INTENT (OUT), DIMENSION (:,:) :: am
   REAL (KIND=dp), INTENT (OUT), DIMENSION (:,:) :: bbmn

   REAL (KIND=dp), DIMENSION (nqm)               :: ab1, ab2, ab3
   INTEGER, DIMENSION (nqm)                      :: j1, j2, j3
   REAL (KIND=dp), DIMENSION (0:nes)             :: dumb

   INTEGER                                       :: i, j, k, nrxi, kspec
   INTEGER                                       :: jatom, mm, ivp
   REAL (KIND=dp)                                :: duma

   ! Chemical equations include only polynomials in the abundances
   ! If lcon(i) = 0 : this is an ordinary equation
   !              d[Xi] / dt = 0
   ! If lcon(i) = j /= 0 : this is a conservation equation of atom j
   ! Monolayer on grain species and electrons are done separately
   am = 0.0_dp
   bbmn = 0.0_dp

   ! -------------------------------------------------------------------------------------
   ! Equations for the standard species, which include neutral, cations, anions, and
   ! chemisorbed species ... all up to nsp_n1. Estimate if it is a conservation equation
   ! -------------------------------------------------------------------------------------
   DO i = 1, nsp_n1
      nrxi = xmatk(i)%nbt
      jatom = lcon(i)

      IF (jatom == 0) THEN

         DO k = 1, nrxi
            j1(k) = xmatk(i)%fdt(k)%r1
            j2(k) = xmatk(i)%fdt(k)%r2
            j3(k) = xmatk(i)%fdt(k)%r3
            IF (j1(k) > n_var) THEN
               ab1(k) = 1.0_dp
            ELSE
               ab1(k) = ab(j1(k))
            ENDIF
            IF (j2(k) > n_var) THEN
               ab2(k) = 1.0_dp
            ELSE
               ab2(k) = ab(j2(k))
            ENDIF
            IF (j3(k) > n_var) THEN
               ab3(k) = 1.0_dp
            ELSE
               ab3(k) = ab(j3(k))
            ENDIF
         ENDDO

         ! -------------------------------------
         ! Computes residuals
         ! -------------------------------------
         duma = SUM(xmatk(i)%fdt(1:nrxi)%k * ab1(1:nrxi) * ab2(1:nrxi) * ab3(1:nrxi))
         bbmn(i,1) = - duma

         ! -------------------------------------
         ! Computes partial derivatives
         ! -------------------------------------
         dumb(1:n_var) = 0.0_dp

         DO k = 1, nrxi
            dumb(j1(k)) = dumb(j1(k)) + xmatk(i)%fdt(k)%k * ab2(k) * ab3(k)
            dumb(j2(k)) = dumb(j2(k)) + xmatk(i)%fdt(k)%k * ab1(k) * ab3(k)
            dumb(j3(k)) = dumb(j3(k)) + xmatk(i)%fdt(k)%k * ab1(k) * ab2(k)
         ENDDO

         am(i,1:n_var) = dumb(1:n_var)

      ELSE

         duma = abtot(jatom) * densh(iopt)
         DO j = 1, nspec-1
            kspec = ael(j,jatom)
            duma = duma - kspec * ab(j)
            am(i,j) = kspec
         ENDDO

         bbmn(i,1) = duma
         am(i,nspec) = 0.0_dp
      ENDIF
   ENDDO

   ! -------------------------------------------------------------------------------------
   ! Equations for the species on grains that require detailed size by size evaluation
   ! These equations are necessary conservation equations
   ! -------------------------------------------------------------------------------------
   DO i = nsp_n1+1, nsp_n1+nsp_g1
      duma = ab(i)
      DO mm = 1, npg
         ivp = nspec + (i - nsp_n1 - 1) * npg + mm
         duma = duma - densh(iopt) * wwmg(mm) * ab(ivp)
         am(i,ivp) = densh(iopt) * wwmg(mm)
      ENDDO
      am(i,i) = - 1.0_dp
      bbmn(i,1) = duma
   ENDDO

   ! -------------------------------------------------------------------------------------
   ! Equation for the electrons.
   ! -------------------------------------------------------------------------------------
   duma = ab(nspec)
   DO j = 1, nspec-1
      kspec = ael(j,natom)
      duma = duma - kspec * ab(j)
      am(nspec,j) = kspec
   ENDDO
   duma = duma - grcharge(iopt)
   bbmn(nspec,1) = duma
   am(nspec,nspec) = - 1.0_dp

   ! -------------------------------------------------------------------------------------
   ! Equations for the variables on grains
   ! -------------------------------------------------------------------------------------
   DO i = nspec+1, n_var
      nrxi = xmatk(i)%nbt

      DO k = 1, nrxi
         j1(k) = xmatk(i)%fdt(k)%r1
         j2(k) = xmatk(i)%fdt(k)%r2
         j3(k) = xmatk(i)%fdt(k)%r3
         IF (j1(k) > n_var) THEN
            ab1(k) = 1.0_dp
         ELSE
            ab1(k) = ab(j1(k))
         ENDIF
         IF (j2(k) > n_var) THEN
            ab2(k) = 1.0_dp
         ELSE
            ab2(k) = ab(j2(k))
         ENDIF
         IF (j3(k) > n_var) THEN
            ab3(k) = 1.0_dp
         ELSE
            ab3(k) = ab(j3(k))
         ENDIF
      ENDDO

      duma = SUM(xmatk(i)%fdt(1:nrxi)%k * ab1(1:nrxi) * ab2(1:nrxi) * ab3(1:nrxi))
      bbmn(i,1) = - duma

      dumb(1:n_var) = 0.0_dp
      DO k = 1, nrxi
         dumb(j1(k)) = dumb(j1(k)) + xmatk(i)%fdt(k)%k * ab2(k) * ab3(k)
         dumb(j2(k)) = dumb(j2(k)) + xmatk(i)%fdt(k)%k * ab1(k) * ab3(k)
         dumb(j3(k)) = dumb(j3(k)) + xmatk(i)%fdt(k)%k * ab1(k) * ab2(k)
      ENDDO

      am(i,1:n_var) = dumb(1:n_var)
   ENDDO

END SUBROUTINE USRFUN

!===============================================================================
SUBROUTINE VERUSF (iopt, bbmn)
!===============================================================================

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

!  Verify chemical balance, using result of MNEWT
!  WITHOUT using conservation equations

   IMPLICIT NONE

   INTEGER, INTENT (IN)                             :: iopt
   REAL (KIND=dp), INTENT (OUT), DIMENSION(:,:)     :: bbmn

   REAL (KIND=dp), DIMENSION (nqm)                  :: ab1, ab2, ab3
   INTEGER, DIMENSION (nqm)                         :: j1, j2, j3
   INTEGER                                          :: i, j, k, mm
   INTEGER                                          :: ivp, nrxi
   INTEGER                                          :: kspec
   REAL (KIND=dp)                                   :: duma

   bbmn = 0.0_dp

   ! -------------------------------------------------------------------------------------
   ! Standard species
   ! -------------------------------------------------------------------------------------
   DO i = 1, nsp_n1
      nrxi = xmatk(i)%nbt
      DO k = 1, nrxi
         j1(k) = xmatk(i)%fdt(k)%r1
         j2(k) = xmatk(i)%fdt(k)%r2
         j3(k) = xmatk(i)%fdt(k)%r3
         IF (j1(k) > n_var) THEN
            ab1(k) = 1.0_dp
         ELSE
            ab1(k) = ab(j1(k))
         ENDIF
         IF (j2(k) > n_var) THEN
            ab2(k) = 1.0_dp
         ELSE
            ab2(k) = ab(j2(k))
         ENDIF
         IF (j3(k) > n_var) THEN
            ab3(k) = 1.0_dp
         ELSE
            ab3(k) = ab(j3(k))
         ENDIF
      ENDDO

      ! -------------------------------------
      ! Computes residuals
      ! -------------------------------------
      duma = SUM(xmatk(i)%fdt(1:nrxi)%k * ab1(1:nrxi) * ab2(1:nrxi) * ab3(1:nrxi))

      bbmn(i,1) = duma
      IF (ABS(duma) > 1.0e-5_dp) THEN
         PRINT *, " ++ bad:", i, speci(i), duma
      ENDIF
   ENDDO

   ! -------------------------------------------------------------------------------------
   ! Species on grains that require detailed size by size evaluation
   ! -------------------------------------------------------------------------------------
   DO i = nsp_n1+1, nspec-1
      duma = ab(i)
      DO mm = 1, npg
         ivp = nspec + (i - nsp_n1 - 1) * npg + mm
         duma = duma - densh(iopt) * ab(ivp) * wwmg(mm)
      ENDDO
      bbmn(i,1) = duma
      IF (ABS(duma) > 1.0e-5_dp) THEN
         PRINT *, " ++ bad:", i, speci(i), duma
      ENDIF
   ENDDO

   ! -------------------------------------------------------------------------------------
   ! Equations for the electrons
   ! -------------------------------------------------------------------------------------
   ! Note: this is just a conservation equation. Not a formation/destruction balance
   duma = ab(nspec)
   DO j = 1, nspec-1
      kspec = ael(j,natom)
      duma = duma - kspec * ab(j)
   ENDDO
   duma = duma - grcharge(iopt)
   IF (ABS(duma) > 1.0e-5_dp) THEN
      PRINT *, " ++ bad:", nspec, speci(nspec), duma
   ENDIF
   bbmn(nspec,1) = duma

   ! -------------------------------------------------------------------------------------
   ! Equations for the variables on grains
   ! -------------------------------------------------------------------------------------
   DO i = nspec+1, n_var
      nrxi = xmatk(i)%nbt

      DO k = 1, nrxi
         j1(k) = xmatk(i)%fdt(k)%r1
         j2(k) = xmatk(i)%fdt(k)%r2
         j3(k) = xmatk(i)%fdt(k)%r3
         IF (j1(k) > n_var) THEN
            ab1(k) = 1.0_dp
         ELSE
            ab1(k) = ab(j1(k))
         ENDIF
         IF (j2(k) > n_var) THEN
            ab2(k) = 1.0_dp
         ELSE
            ab2(k) = ab(j2(k))
         ENDIF
         IF (j3(k) > n_var) THEN
            ab3(k) = 1.0_dp
         ELSE
            ab3(k) = ab(j3(k))
         ENDIF
      ENDDO

      ! -------------------------------------
      ! Computes residuals
      ! -------------------------------------
      duma = SUM(xmatk(i)%fdt(1:nrxi)%k * ab1(1:nrxi) * ab2(1:nrxi) * ab3(1:nrxi))

      bbmn(i,1) = - duma
      IF (ABS(duma) > 1.0e-5_dp) THEN
         PRINT *, " ++ bad:", i, speci(i), duma
      ENDIF
   ENDDO

END SUBROUTINE VERUSF

!===============================================================================
SUBROUTINE FBTH1(temper, iopt, itn, abb)
!===============================================================================

   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

!  Grain charge balance as a function of size
!  Modified from Bakes & Tielens, Ap J 427, 822 (1994)

  REAL (KIND=dp), INTENT (IN)                         :: temper
  INTEGER, INTENT (IN)                                :: iopt, itn
  REAL (KIND=dp), DIMENSION(0:nes+npart), INTENT (IN) :: abb

  INTEGER                                             :: mm
  INTEGER                                             :: izmin, izmax
  INTEGER                                             :: kzmin, kzmax
  REAL (KIND=dp)                                      :: zmax
  REAL (KIND=dp)                                      :: zzmoy

  ! Integrals of Q * U * (1 or l or l2)  over lambda
  REAL (KIND=dp)                              :: s_QU, s_QUl, s_QUl2

!  Gas grain interactions are:
!     xjpe : photoemission rate
!     xje  : electrons accretion rate
!     xji  : individual ions accretion rate
!     xjit : total ions accretion rate
!--------------------------------------------------------

  REAL (KIND=dp), DIMENSION (-izm0:izp0)      :: xjpe
  REAL (KIND=dp), DIMENSION (-izm0:izp0)      :: xje
  REAL (KIND=dp), DIMENSION (-izm0:izp0)      :: xjit
  REAL (KIND=dp)                              :: nrj_bal

  ! ionisation fraction
! REAL (KIND=dp), DIMENSION (-izm0:izp0)      :: frac

  ! Ionization potential
  REAL (KIND=dp), DIMENSION (-izm0:izp0)      :: wl_IP ! (in A)
  REAL (KIND=dp)                              :: dum

  ! stic : electrons sticking coefficient
  REAL (KIND=dp)                              :: stic = 1.0_dp

  ! x_nc : Number of carbon atoms in the grain
  ! Dummy variables
  REAL (KIND=dp)                              :: tauph, cte, x_nc_t
  REAL (KIND=dp)                              :: x_ip, thet, xjtm, xjtp, xjt0
  REAL (KIND=dp)                              :: xltm, xltp, xlt0, ziz
  REAL (KIND=dp)                              :: sup, titi, toto, xsum, tier, tempo
  REAL (KIND=dp)                              :: cte_J, cte_IP, cte_E
  REAL (KIND=dp)                              :: xkneut

  REAL (KIND=dp)                              :: wl_cut_IP, IP_min
  INTEGER                                     :: I_cut_IP
  INTEGER                                     :: I_cut_L

  ! Dummy Indices
  INTEGER                                     :: i, j, iz, ndeb, nfin, ir1, iprod, izf, izd

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

  rxigr(:,iopt)  = 0.0_dp
  relgr(:,iopt)  = 0.0_dp
  grcharge(iopt) = 0.0_dp

  tier = 1.0_dp / 3.0_dp
  IP_min = xhp * clum * 1.0e8_dp / (rf_wl%Val(nwlg) * everg)

  ! For neutralisation reactions
  ndeb = nh2for + ncrion + npsion + nasrad + nrest + nh2endo + nphot_f &
       + nphot_i + n3body + ncpart + ngsurf + ngphot + ngads + 1
  nfin = ndeb + ngneut - 1

  DO mm = 1, npg

     ! Reduced PARAMETER (from Eq 9). With qi = +/- 1
     tauph = adust(mm) * xk * temper / xqe2

     ! Eq 9 (first part)
     cte = SQRT(8.0_dp * xk * temper * xpi) * adust(mm)**2
     x_nc_t = x_nc(mm)**tier

     ! Maximum Charges (Eq 26 et 27):
     IF (iopt == 0 .AND. itn == 1) THEN
        ! Charges can not be very negative at the edge...
        !      zmin = 0.4_dp * x_nc_t - 0.5_dp
        !      zmin =  MAX(-zmin,-90.0_dp*tauph)
        !      izmin = zmin
        izmin = -5

        zmax = (hiop/everg - 4.4_dp) * x_nc_t / 11.1_dp - 0.5_dp
        izmax = FLOOR(zmax)

        ! We limit the maximum possible extension
        izmin = MAX(izmin,-izm0)
        izmax = MIN(izmax,izp0)

        IF (izmin >= izmax) THEN
           izmin = izmin - 2
           izmax = izmax + 2
        ENDIF

     ELSE

        izmin = jzmin(mm) - 2
        izmax = jzmax(mm) + 2

     ENDIF

     ! Loop over grain charge:
     ! Three parts: negatives, neutrals, positives
     cte_J = x_nc(mm) * 0.14_dp * bt_fy(mm) * 1.0e-8_dp / xhp
     cte_E = 0.14_dp * bt_fy(mm) * 0.5_dp

     izf = MIN(izmax,-1)

     DO iz = izmin, izf
        ! Ionisation potentiel (en eV) (Eq 25)
        ! 9 III 2012 - JLB - Change IP threshold of negative ions to 0.6 eV
        ! -----------------------------------------------------------------------------------
        ! Change the formalism to define wl_cut_IP in order to find the exact limits wl_lym
        ! and wlthm when needed - BG 04/2013
        ! First try - no extension of photoelectric heating below 911 Å - correction of the
        ! integrals s_QU, s_QUl, s_QUl2 - see notes BG 04/2013 for explanations
        ! If extension of photoelectric heating to small wavelength, replace wl_lym by wlth0
        ! and remove the corrections of s_QU, s_QUl, s_QUl2.
        ! -----------------------------------------------------------------------------------
        x_ip      = 0.6_dp + (iz + 0.5_dp) * 11.1_dp / x_nc_t
        if (x_ip > 0.0_dp) then
           wl_cut_IP = MIN(rf_wl%Val(nwlg),MAX(1.0e8_dp*xhp*clum/(everg*x_ip),wl_lym))
        else
           wl_cut_IP = rf_wl%Val(nwlg)
        endif
        !wl_cut_IP = MIN(rf_wl%Val(nwlg),MAX(1.0e8_dp*xhp*clum/(everg*x_ip),wlth0 ))
        cte_IP    = 1.0_dp / wl_cut_IP
        CALL RF_LOCATE (rf_wl, wl_cut_IP, I_cut_IP)
        CALL RF_LOCATE (rf_wl, wl_lym, I_cut_L)
        s_QU   = si_QU  (mm,I_cut_IP) - si_QU  (mm,I_cut_L)
        s_QUl  = si_QUl (mm,I_cut_IP) - si_QUl (mm,I_cut_L)
        s_QUl2 = si_QUl2(mm,I_cut_IP) - si_QUl2(mm,I_cut_L)
        ! -----------------------------------------------------------------------------------

        ! Ionization potential (in A)
        wl_IP(iz) = 1.0_dp / cte_IP

        ! Ejection of one photo-electron (Eq 20):
        xjpe(iz) = cte_J * (s_QUl - cte_IP * s_QUl2)

        ! Collisions with gas phase particules. Eq 13:
        ziz = -iz
        thet = ziz / (1.0_dp + 1.0_dp/SQRT(ziz))

        ! Eq 11:
        xjtm = (1.0_dp - iz / tauph) * (1.0_dp + SQRT(2.0_dp/(tauph - 2.0_dp * iz)))

        ! Eq 12:
        xjtp = EXP(-thet / tauph) * (1.0_dp + 1.0_dp / SQRT(4.0_dp * tauph - 3.0_dp * iz))**2

        ! Eq 33:
        xltm = (2.0_dp - iz / tauph) * (1.0_dp + SQRT(1.0_dp/(tauph - iz)))

        ! Eq 34:
        xltp = EXP(-thet / tauph) * (2.0_dp - iz / tauph) &
             * (1.0_dp + 1.0_dp / SQRT(3.0_dp /(2.0_dp*tauph) - 3.0_dp * iz))

        ! Eq 9 (continued) et 31:
        xje(iz) = cte * stic * xjtp / SQRT(xme)
        titi = 0.0_dp

        DO i = ndeb, nfin
           ir1 = react(i,1)
           iprod = react(i,4)
           IF ( ir1 <= nsp_ne+nsp_ip+nsp_im ) THEN
              xji(ir1,iz) = cte * gamm(i) * xjtm / SQRT(xmh*mol(ir1))
              nrj_bal = (enth(ir1)*calev - enth(iprod)*calev - x_ip) * everg / xk
              IF (nrj_bal < 0.0_dp ) THEN
                 xji(ir1,iz) = xji(ir1,iz) * EXP (nrj_bal / temper)
              ENDIF
              titi = titi + xji(ir1,iz) * abb(ir1)
           ENDIF
        ENDDO
        xjit(iz) = titi
     ENDDO

     IF (izmin <= 0 .AND. izmax >= 0) THEN

        iz = 0

        ! -----------------------------------------------------------------------------------
        ! Change the formalism to define wl_cut_IP in order to find the exact limits wl_lym
        ! and wlthm when needed - BG 04/2013
        ! First try - no extension of photoelectric heating below 911 Å - correction of the
        ! integrals s_QU, s_QUl, s_QUl2 - see notes BG 04/2013 for explanations
        ! If extension of photoelectric heating to small wavelength, replace wl_lym by wlth0
        ! and remove the corrections of s_QU, s_QUl, s_QUl2.
        ! -----------------------------------------------------------------------------------
        x_ip      = 4.4_dp + (iz + 0.5_dp) * 11.1_dp / x_nc_t
        wl_cut_IP = MIN(rf_wl%Val(nwlg),MAX(1.0e8_dp*xhp*clum/(everg*x_ip),wl_lym))
        !wl_cut_IP = MIN(rf_wl%Val(nwlg),MAX(1.0e8_dp*xhp*clum/(everg*x_ip),wlth0 ))
        cte_IP    = 1.0_dp / wl_cut_IP
        CALL RF_LOCATE (rf_wl, wl_cut_IP, I_cut_IP)
        CALL RF_LOCATE (rf_wl, wl_lym, I_cut_L)
        s_QU   = si_QU  (mm,I_cut_IP) - si_QU  (mm,I_cut_L)
        s_QUl  = si_QUl (mm,I_cut_IP) - si_QUl (mm,I_cut_L)
        s_QUl2 = si_QUl2(mm,I_cut_IP) - si_QUl2(mm,I_cut_L)
        ! -----------------------------------------------------------------------------------

        wl_IP(0) = 1.0_dp / cte_IP
        xjpe(0) = cte_J * (s_QUl - cte_IP * s_QUl2)

        xjt0 = 1.0_dp + SQRT(xpi / (2.0_dp * tauph))

        xlt0 = 2.0_dp + 3.0_dp * SQRT(xpi/(2.0_dp*tauph)) /2.0_dp

        xje(0) = cte * xjt0 / SQRT(xme)
        titi = 0.0_dp

        DO i = ndeb, nfin
           ir1 = react(i,1)
           iprod = react(i,4)
           IF ( ir1 <= nsp_ne+nsp_ip+nsp_im ) THEN
              xji(ir1,0) = cte * gamm(i) * xjt0 / SQRT(xmh*mol(ir1))
              nrj_bal = (enth(ir1)*calev - enth(iprod)*calev - x_ip) * everg / xk
              IF (nrj_bal < 0.0_dp ) THEN
                 xji(ir1,iz) = xji(ir1,iz) * EXP (nrj_bal / temper)
              ENDIF
              titi = titi + xji(ir1,0) * abb(ir1)
           ENDIF
        ENDDO
        xjit(0) = titi
     ENDIF

     izd = MAX (izmin,1)

     DO iz = izd, izmax
        ! Ionisation potentiel (in eV) (Eq 25)
        ! -----------------------------------------------------------------------------------
        ! Change the formalism to define wl_cut_IP in order to find the exact limits wl_lym
        ! and wlthm when needed - BG 04/2013
        ! First try - no extension of photoelectric heating below 911 Å - correction of the
        ! integrals s_QU, s_QUl, s_QUl2 - see notes BG 04/2013 for explanations
        ! If extension of photoelectric heating to small wavelength, replace wl_lym by wlth0
        ! and remove the corrections of s_QU, s_QUl, s_QUl2.
        ! -----------------------------------------------------------------------------------
        x_ip      = 4.4_dp + (iz + 0.5_dp) * 11.1_dp / x_nc_t
        wl_cut_IP = MIN(rf_wl%Val(nwlg),MAX(1.0e8_dp*xhp*clum/(everg*x_ip),wl_lym))
        !wl_cut_IP = MIN(rf_wl%Val(nwlg),MAX(1.0e8_dp*xhp*clum/(everg*x_ip),wlth0 ))
        cte_IP    = 1.0_dp / wl_cut_IP
        CALL RF_LOCATE (rf_wl, wl_cut_IP, I_cut_IP)
        CALL RF_LOCATE (rf_wl, wl_lym, I_cut_L)
        s_QU   = si_QU  (mm,I_cut_IP) - si_QU  (mm,I_cut_L)
        s_QUl  = si_QUl (mm,I_cut_IP) - si_QUl (mm,I_cut_L)
        s_QUl2 = si_QUl2(mm,I_cut_IP) - si_QUl2(mm,I_cut_L)
        ! -----------------------------------------------------------------------------------

        wl_IP(iz) = 1.0_dp / cte_IP
        xjpe(iz) = cte_J * (s_QUl - cte_IP * s_QUl2)

        ! Eq 13:
        ziz = iz
        thet = ziz / (1.0_dp + 1.0_dp/SQRT(ziz))

        ! Eq 11:
        xjtm = (1.0_dp + iz / tauph) * (1.0_dp + SQRT(2.0_dp/(tauph + 2.0_dp * iz)))

        ! Eq 12:
        xjtp = EXP(-thet / tauph) * (1.0_dp + 1.0_dp / SQRT(4.0_dp * tauph + 3.0_dp * iz))**2

        ! Eq 33:
        xltm = (2.0_dp + iz / tauph) * (1.0_dp + SQRT(1.0_dp/(tauph + iz)))

        ! Eq 34:
        xltp = EXP(-thet / tauph) * (2.0_dp + iz / tauph) &
             * (1.0_dp + 1.0_dp / SQRT(3.0_dp /(2.0_dp*tauph) + 3.0_dp * iz))

        ! Eq 9 (continued) et 31:
        xje(iz) = cte * xjtm / SQRT(xme)
        titi = 0.0_dp

        DO i = ndeb, nfin
           ir1 = react(i,1)
           iprod = react(i,4)
           IF ( ir1 <= nsp_ne+nsp_ip+nsp_im ) THEN
              xji(ir1,iz) = cte * gamm(i) * xjtp / SQRT(xmh*mol(ir1))
              nrj_bal = (enth(ir1)*calev - enth(iprod)*calev - x_ip) * everg / xk
              IF (nrj_bal < 0.0_dp ) THEN
                 xji(ir1,iz) = xji(ir1,iz) * EXP (nrj_bal / temper)
              ENDIF
              titi = titi + xji(ir1,iz) * abb(ir1)
           ENDIF
        ENDDO
        xjit(iz) = titi
     ENDDO

      ! -------------------------------------------------------------------------------------
      ! debug - write the different rates in an external file for charges z=+/-2 and the
      ! largest size of dust particles. File opened and close in PXDR.f90
      ! -------------------------------------------------------------------------------------
      !IF (mm == 9) THEN
      !   WRITE(57,  '(ES9.2,2X)', ADVANCE='no') tau(iopt) * tautav
      !   IF ((izmin <= 1).AND.(izmax >= 2)) THEN
      !      WRITE(57,'(3(ES9.2,2X))',ADVANCE='no') xjpe(1), xjit(1), xje(2)
      !      DO i = ndeb, nfin
      !         ir1 = react(i,1)
      !         iprod = react(i,4)
      !         IF ( (ir1 > nsp_ne) .AND. (ir1 <= nsp_ne+nsp_ip+nsp_im) ) THEN
      !            WRITE(57,'(2(ES9.2,2X))',ADVANCE='no') xji(ir1,1),ab(ir1)
      !         ENDIF
      !      ENDDO
      !   ELSE
      !      WRITE(57,'(3(ES9.2,2X))',ADVANCE='no') 0.0_dp, 0.0_dp, 0.0_dp
      !      DO i = ndeb, nfin
      !         ir1 = react(i,1)
      !         iprod = react(i,4)
      !         IF ( (ir1 > nsp_ne) .AND. (ir1 <= nsp_ne+nsp_ip+nsp_im) ) THEN
      !            WRITE(57,'(ES9.2,2X)',ADVANCE='no') 0.0_dp
      !         ENDIF
      !      ENDDO
      !   ENDIF
      !   !IF ((izmin <=-3).AND.(izmax >=-2)) THEN
      !   !   WRITE(57,'(3(ES9.2,2X))',ADVANCE='no') xjpe(-3), xjit(-3), xje(-2)
      !   !ELSE
      !   !   WRITE(57,'(3(ES9.2,2X))',ADVANCE='no') 0.0_dp, 0.0_dp, 0.0_dp
      !   !ENDIF
      !   WRITE(57,*)
      !ENDIF

     ! Ionisation fraction :
     sup = 0.0_dp

     IF (izmin >= 0) THEN
        frac(izmin,mm) = 0.0_dp

        toto = 0.0_dp
        DO iz = izmin+1, izmax
           tempo = (xjpe(iz-1) + xjit(iz-1)) / (xje(iz) * abb(nspec))
           IF (tempo > 1.0e-40_dp) THEN
              toto = toto + LOG(tempo)
           ELSE
              toto = toto - 92.1_dp
           ENDIF
           frac(iz,mm) = toto
           sup = MAX(sup,toto)
        ENDDO

     ELSE IF (izmax <= 0) THEN
        frac(izmax,mm) = 0.0_dp

        toto = 0.0_dp
        DO iz = izf, izmin, -1
           tempo = xje(iz+1) * abb(nspec) / (xjpe(iz) + xjit(iz))
           IF (tempo > 1.0e-40_dp) THEN
              toto = toto + LOG(tempo)
           ELSE
              toto = toto - 92.1_dp
           ENDIF
           frac(iz,mm) = toto
           sup = MAX(sup,toto)
        ENDDO

     ELSE
        frac(0,mm) = 0.0_dp

        ! Eq 6:
        toto = 0.0_dp
        DO iz = izd, izmax
           tempo = (xjpe(iz-1) + xjit(iz-1)) / (xje(iz) * abb(nspec))
           IF (tempo > 1.0e-40_dp) THEN
              toto = toto + LOG(tempo)
           ELSE
              toto = toto - 92.1_dp
           ENDIF
           frac(iz,mm) = toto
           sup = MAX(sup,toto)
        ENDDO

        ! Eq 7:
        toto = 0.0_dp
        DO iz = izf, izmin, -1
           tempo = xje(iz+1) * abb(nspec) / (xjpe(iz) + xjit(iz))
           IF (tempo > 1.0e-40_dp) THEN
              toto = toto + LOG(tempo)
           ELSE
              toto = toto - 92.1_dp
           ENDIF
           frac(iz,mm) = toto
           sup = MAX(sup,toto)
        ENDDO
     ENDIF

     ! Eq 8 et 3 (part of it):
     xsum = 0.0_dp
     DO iz = izmin, izmax
        frac(iz,mm) = EXP(frac(iz,mm) - sup)
        xsum = xsum + frac(iz,mm)
     ENDDO

     IF (xsum == 0.0_dp) THEN
        PRINT *, ' Pb dans FBTH1, xsum = 0.0'
     ENDIF

     kzmin = izmax
     kzmax = izmin
     zzmoy = 0
     eff_phel(mm,iopt)%Val(:) = 0.0_dp
     DO iz = izmin, izmax
        frac(iz,mm) = frac(iz,mm) / xsum
        IF (frac(iz,mm) > 1.0e-5_dp) THEN
           kzmin = MIN(kzmin,iz)
           kzmax = MAX(kzmax,iz)
        ENDIF
        zzmoy = zzmoy + iz * frac(iz,mm)
        ! -------------------------------------------------------------
        ! Compute the efficiency of the photoelectric effect
        !    1 - PAHs  -> we suppose an efficiency of 1 in the X-ray
        !                 domain (all photons ionize or break the PAH
        !                 as they do with the molecules)
        !    2 - Other -> Eqs. 15 & 29 of Bakes & Tielens (1994)
        ! Note : it would be better to rewrite the entire routine using
        !        the more recent paper of Weingartner & Draine (2001)
        ! -------------------------------------------------------------
        IF(adust(mm) < rgrmin) THEN
           DO i = eff_phel(mm,iopt)%lower, eff_phel(mm,iopt)%upper
              IF ( rf_wl%Val(wl_pointer(eff_phel(mm,i)%Ord(i))) > wl_IP(iz) ) EXIT
!             IF ( rf_wl%Val(wl_pointer(eff_phel(mm,i)%Ord(i))) < l_xray ) THEN
!                eff_phel(mm,iopt)%Val(i) = eff_phel(mm,iopt)%Val(i) + frac(iz,mm)
!             ELSE
                 dum = frac(iz,mm) *  cte_E * ( 1.0_dp - 2.0_dp &
                     * rf_wl%Val(wl_pointer(eff_phel(mm,i)%Ord(i))) / wl_IP(iz) &
                     + rf_wl%Val(wl_pointer(eff_phel(mm,i)%Ord(i))) &
                     * rf_wl%Val(wl_pointer(eff_phel(mm,i)%Ord(i))) &
                     / ( wl_IP(iz) * wl_IP(iz) ) )
                 eff_phel(mm,iopt)%Val(i) = eff_phel(mm,iopt)%Val(i) + dum
!             ENDIF
           ENDDO
        ELSE
           DO i = eff_phel(mm,iopt)%lower, eff_phel(mm,iopt)%upper
              IF ( rf_wl%Val(wl_pointer(eff_phel(mm,i)%Ord(i))) > wl_IP(iz) ) EXIT
              dum = frac(iz,mm) *  cte_E * ( 1.0_dp - 2.0_dp &
                  * rf_wl%Val(wl_pointer(eff_phel(mm,i)%Ord(i))) / wl_IP(iz) &
                  + rf_wl%Val(wl_pointer(eff_phel(mm,i)%Ord(i))) &
                  * rf_wl%Val(wl_pointer(eff_phel(mm,i)%Ord(i))) &
                  / ( wl_IP(iz) * wl_IP(iz) ) )
              eff_phel(mm,iopt)%Val(i) = eff_phel(mm,iopt)%Val(i) + dum
           ENDDO
        ENDIF
     ENDDO
     jzmin(mm) = kzmin
     jzmax(mm) = kzmax
     zmoy(mm,iopt) = zzmoy
     grcharge(iopt) = grcharge(iopt) + zmoy(mm,iopt) * wwmg(mm) * densh(iopt)

     j = 0
     DO i = ndeb, nfin
        ir1   = react(i,1)
        iprod = react(i,4)
        j = j + 1
        !  ---------------------------------------------------------------------------------
        ! recombination of ions on grains
        !  ---------------------------------------------------------------------------------
        IF ( ir1 <= nsp_ne+nsp_ip+nsp_im ) THEN
           xkneut = 0.0_dp
           DO iz = izmin, izmax
              xkneut = xkneut + xji(ir1,iz) * frac(iz,mm)
           ENDDO
           rxigr(ir1,iopt) = rxigr(ir1,iopt) + xkneut * wwmg(mm) * densh(iopt)
        !  ---------------------------------------------------------------------------------
        ! attachement of electrons on grains
        !  ---------------------------------------------------------------------------------
        ELSE IF ( ir1 == nspec ) THEN
           xkneut = 0.0_dp
           DO iz = izmin, izmax
              xkneut = xkneut + xje(iz) * frac(iz,mm)
           ENDDO
           relgr(2,iopt) = relgr(2,iopt) + xkneut * wwmg(mm) * densh(iopt)
        !  ---------------------------------------------------------------------------------
        ! photo-electric emission rate
        !  ---------------------------------------------------------------------------------
        ELSE IF ( iprod == nspec ) THEN
           xkneut = 0.0_dp
           DO iz = izmin, izmax
              xkneut = xkneut + xjpe(iz) * frac(iz,mm)
           ENDDO
           relgr(1,iopt) = relgr(1,iopt) + xkneut * wwmg(mm) * densh(iopt)
        ENDIF
     ENDDO

  ENDDO

END SUBROUTINE FBTH1

!===============================================================================
SUBROUTINE FBTH2(temper, iopt, abb)
!===============================================================================

   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

!  Photoelectric heating and grain charge balance as a function of size
!  Modified from Bakes & Tielens, Ap J 427, 822 (1994)

  REAL (KIND=dp), INTENT (IN)                         :: temper
  INTEGER, INTENT (IN)                                :: iopt
  REAL (KIND=dp), DIMENSION(0:nes+npart), INTENT (IN) :: abb

  INTEGER                                             :: mm
  REAL (KIND=dp)                                      :: bilth
  INTEGER                                             :: izmin, izmax

  ! Integrals of Q * U * (1 or l or l2)  over lambda
  REAL (KIND=dp)                                      :: s_QU, s_QUl, s_QUl2

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

  ! Heating and Cooling
  REAL (KIND=dp), DIMENSION (-izm0:izp0)      :: heat
  REAL (KIND=dp), DIMENSION (-izm0:izp0)      :: cool
  REAL (KIND=dp)                              :: cool_FBTH, heat_FBTH

  ! Ionization potential
  REAL (KIND=dp), DIMENSION (-izm0:izp0)      :: wl_IP ! (in A)
  REAL (KIND=dp)                              :: dum

  ! x_nc : Number of carbon atoms in the grain
  ! Dummy variables
  REAL (KIND=dp)                              :: tauph, cte, x_nc_t
  REAL (KIND=dp)                              :: x_ip, thet
  REAL (KIND=dp)                              :: xltm, xltp, xlt0, ziz
  REAL (KIND=dp)                              :: toto, tier
  REAL (KIND=dp)                              :: cte_H, cte_IP, cte_E

  REAL (KIND=dp)                              :: wl_cut_IP, IP_min
  INTEGER                                     :: I_cut_IP
  INTEGER                                     :: I_cut_L

  ! Dummy Indices
  INTEGER                                     :: i, iz, izf, izd

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

  chophg(iopt)   = 0.0_dp
  chophg_c(iopt) = 0.0_dp
  chophg_h(iopt) = 0.0_dp

  tier = 1.0_dp / 3.0_dp
  IP_min = xhp * clum * 1.0e8_dp / (rf_wl%Val(nwlg) * everg)

  DO mm = 1, npg

     ! Reduced PARAMETER (from Eq 9). With qi = +/- 1
     tauph = adust(mm) * xk * temper / xqe2

     ! Eq 9 (first part)
     cte = SQRT(8.0_dp * xk * temper * xpi) * adust(mm)**2
     x_nc_t = x_nc(mm)**tier

     izmin = jzmin(mm) - 2
     izmax = jzmax(mm) + 2

     ! Loop over grain charge:
     ! Three parts: negatives, neutrals, positives
     cte_H = x_nc(mm) * 0.14_dp * bt_fy(mm) * 0.5_dp * clum
     cte_E = 0.14_dp * bt_fy(mm) * 0.5_dp

     izf = MIN(izmax,-1)

     DO iz = izmin, izf
        ! Ionisation potentiel (en eV) (Eq 25)
        ! 9 III 2012 - JLB - Change IP threshold of negative ions to 0.6 eV
        ! -----------------------------------------------------------------------------------
        ! Change the formalism to define wl_cut_IP in order to find the exact limits wl_lym
        ! and wlthm when needed - BG 04/2013
        ! First try - no extension of photoelectric heating below 911 Å - correction of the
        ! integrals s_QU, s_QUl, s_QUl2 - see notes BG 04/2013 for explanations
        ! If extension of photoelectric heating to small wavelength, replace wl_lym by wlth0
        ! and remove the corrections of s_QU, s_QUl, s_QUl2.
        ! -----------------------------------------------------------------------------------
        x_ip      = 0.6_dp + (iz + 0.5_dp) * 11.1_dp / x_nc_t
        if (x_ip > 0.0_dp) then
           wl_cut_IP = MIN(rf_wl%Val(nwlg),MAX(1.0e8_dp*xhp*clum/(everg*x_ip),wl_lym))
        else
           wl_cut_IP = rf_wl%Val(nwlg)
        endif
        !wl_cut_IP = MIN(rf_wl%Val(nwlg),MAX(1.0e8_dp*xhp*clum/(everg*x_ip),wlth0 ))
        cte_IP    = 1.0_dp / wl_cut_IP
        CALL RF_LOCATE (rf_wl, wl_cut_IP, I_cut_IP)
        CALL RF_LOCATE (rf_wl, wl_lym, I_cut_L)
        s_QU   = si_QU  (mm,I_cut_IP) - si_QU  (mm,I_cut_L)
        s_QUl  = si_QUl (mm,I_cut_IP) - si_QUl (mm,I_cut_L)
        s_QUl2 = si_QUl2(mm,I_cut_IP) - si_QUl2(mm,I_cut_L)
        ! -----------------------------------------------------------------------------------

        ! Ionization potential (in A)
        wl_IP(iz) = 1.0_dp / cte_IP

        ! photo-electric heating ( Eq 30):
        heat(iz) = cte_H * (s_QU - 2.0_dp * cte_IP * s_QUl + cte_IP*cte_IP * s_QUl2)

        ! Collisions with gas phase particules. Eq 13:
        ziz = -iz
        thet = ziz / (1.0_dp + 1.0_dp/SQRT(ziz))

        ! Eq 33:
        xltm = (2.0_dp - iz / tauph) * (1.0_dp + SQRT(1.0_dp/(tauph - iz)))

        ! Eq 34:
        xltp = EXP(-thet / tauph) * (2.0_dp - iz / tauph) &
             * (1.0_dp + 1.0_dp / SQRT(3.0_dp /(2.0_dp*tauph) - 3.0_dp * iz))

        toto = cte * xk * temper * abb(nspec) * xltp / SQRT(xme)

        ! If positive ions do not stick on grains, they do not contribute to cooling
        ! Include only electrons contribution
        cool(iz) = toto
     ENDDO

     IF (izmin <= 0 .AND. izmax >= 0) THEN

        iz = 0

        ! -----------------------------------------------------------------------------------
        ! Change the formalism to define wl_cut_IP in order to find the exact limits wl_lym
        ! and wlthm when needed - BG 04/2013
        ! First try - no extension of photoelectric heating below 911 Å - correction of the
        ! integrals s_QU, s_QUl, s_QUl2 - see notes BG 04/2013 for explanations
        ! If extension of photoelectric heating to small wavelength, replace wl_lym by wlth0
        ! and remove the corrections of s_QU, s_QUl, s_QUl2.
        ! -----------------------------------------------------------------------------------
        x_ip      = 4.4_dp + (iz + 0.5_dp) * 11.1_dp / x_nc_t
        wl_cut_IP = MIN(rf_wl%Val(nwlg),MAX(1.0e8_dp*xhp*clum/(everg*x_ip),wl_lym))
        !wl_cut_IP = MIN(rf_wl%Val(nwlg),MAX(1.0e8_dp*xhp*clum/(everg*x_ip),wlth0 ))
        cte_IP    = 1.0_dp / wl_cut_IP
        CALL RF_LOCATE (rf_wl, wl_cut_IP, I_cut_IP)
        CALL RF_LOCATE (rf_wl, wl_lym, I_cut_L)
        s_QU   = si_QU  (mm,I_cut_IP) - si_QU  (mm,I_cut_L)
        s_QUl  = si_QUl (mm,I_cut_IP) - si_QUl (mm,I_cut_L)
        s_QUl2 = si_QUl2(mm,I_cut_IP) - si_QUl2(mm,I_cut_L)
        ! -----------------------------------------------------------------------------------

        wl_IP(0) = 1.0_dp / cte_IP
        heat(0) = cte_H * (s_QU - 2.0_dp * cte_IP * s_QUl + cte_IP*cte_IP * s_QUl2)

        xlt0 = 2.0_dp + 3.0_dp * SQRT(xpi/(2.0_dp*tauph)) /2.0_dp

        toto = cte * xk * temper * abb(nspec) * xlt0 / SQRT(xme)

        ! If positive ions do not stick on grains, they do not contribute to cooling
        cool(0) = toto

     ENDIF

     izd = MAX (izmin,1)

     DO iz = izd, izmax
        ! Ionisation potentiel (in eV) (Eq 25)
        ! -----------------------------------------------------------------------------------
        ! Change the formalism to define wl_cut_IP in order to find the exact limits wl_lym
        ! and wlthm when needed - BG 04/2013
        ! First try - no extension of photoelectric heating below 911 Å - correction of the
        ! integrals s_QU, s_QUl, s_QUl2 - see notes BG 04/2013 for explanations
        ! If extension of photoelectric heating to small wavelength, replace wl_lym by wlth0
        ! and remove the corrections of s_QU, s_QUl, s_QUl2.
        ! -----------------------------------------------------------------------------------
        x_ip      = 4.4_dp + (iz + 0.5_dp) * 11.1_dp / x_nc_t
        wl_cut_IP = MIN(rf_wl%Val(nwlg),MAX(1.0e8_dp*xhp*clum/(everg*x_ip),wl_lym))
        !wl_cut_IP = MIN(rf_wl%Val(nwlg),MAX(1.0e8_dp*xhp*clum/(everg*x_ip),wlth0 ))
        cte_IP    = 1.0_dp / wl_cut_IP
        CALL RF_LOCATE (rf_wl, wl_cut_IP, I_cut_IP)
        CALL RF_LOCATE (rf_wl, wl_lym, I_cut_L)
        s_QU   = si_QU  (mm,I_cut_IP) - si_QU  (mm,I_cut_L)
        s_QUl  = si_QUl (mm,I_cut_IP) - si_QUl (mm,I_cut_L)
        s_QUl2 = si_QUl2(mm,I_cut_IP) - si_QUl2(mm,I_cut_L)
        ! -----------------------------------------------------------------------------------

        wl_IP(iz) = 1.0_dp / cte_IP
        heat(iz) = cte_H * (s_QU - 2.0_dp * cte_IP * s_QUl + cte_IP*cte_IP * s_QUl2)

        ! Eq 13:
        ziz = iz
        thet = ziz / (1.0_dp + 1.0_dp/SQRT(ziz))

        ! Eq 33:
        xltm = (2.0_dp + iz / tauph) * (1.0_dp + SQRT(1.0_dp/(tauph + iz)))

        ! Eq 34:
        xltp = EXP(-thet / tauph) * (2.0_dp + iz / tauph) &
             * (1.0_dp + 1.0_dp / SQRT(3.0_dp /(2.0_dp*tauph) + 3.0_dp * iz))

        toto = cte * xk * temper * abb(nspec) * xltm / SQRT(xme)

        ! If positive ions do not stick on grains, they do not contribute to cooling
        cool(iz) = toto
     ENDDO

     ! Eq 8 et 3 (part of it):
     bilth     = 0.0_dp
     cool_FBTH = 0.0_dp
     heat_FBTH = 0.0_dp

     eff_phel(mm,iopt)%Val(:) = 0.0_dp
     DO iz = izmin, izmax
        bilth = bilth + (heat(iz) - cool(iz)) * frac(iz,mm)
        cool_FBTH = cool_FBTH + cool(iz) * frac(iz,mm)
        heat_FBTH = heat_FBTH + heat(iz) * frac(iz,mm)
        ! -------------------------------------------------------------
        ! Compute the efficiency of the photoelectric effect
        !    1 - PAHs  -> we suppose an efficiency of 1 in the X-ray
        !                 domain (all photons ionize or break the PAH
        !                 as they do with the molecules)
        !    2 - Other -> Eqs. 15 & 29 of Bakes & Tielens (1994)
        ! Note : it would be better to rewrite the entire routine using
        !        the more recent paper of Weingartner & Draine (2001)
        ! -------------------------------------------------------------
        IF(adust(mm) < rgrmin) THEN
           DO i = eff_phel(mm,iopt)%lower, eff_phel(mm,iopt)%upper
              IF ( rf_wl%Val(wl_pointer(eff_phel(mm,i)%Ord(i))) > wl_IP(iz) ) EXIT
!             IF ( rf_wl%Val(wl_pointer(eff_phel(mm,i)%Ord(i))) < l_xray ) THEN
!                eff_phel(mm,iopt)%Val(i) = eff_phel(mm,iopt)%Val(i) + frac(iz,mm)
!             ELSE
                 dum = frac(iz,mm) *  cte_E * ( 1.0_dp - 2.0_dp &
                     * rf_wl%Val(wl_pointer(eff_phel(mm,i)%Ord(i))) / wl_IP(iz) &
                     + rf_wl%Val(wl_pointer(eff_phel(mm,i)%Ord(i))) &
                     * rf_wl%Val(wl_pointer(eff_phel(mm,i)%Ord(i))) &
                     / ( wl_IP(iz) * wl_IP(iz) ) )
                 eff_phel(mm,iopt)%Val(i) = eff_phel(mm,iopt)%Val(i) + dum
!             ENDIF
           ENDDO
        ELSE
           DO i = eff_phel(mm,iopt)%lower, eff_phel(mm,iopt)%upper
              IF ( rf_wl%Val(wl_pointer(eff_phel(mm,i)%Ord(i))) > wl_IP(iz) ) EXIT
              dum = frac(iz,mm) *  cte_E * ( 1.0_dp - 2.0_dp &
                  * rf_wl%Val(wl_pointer(eff_phel(mm,i)%Ord(i))) / wl_IP(iz) &
                  + rf_wl%Val(wl_pointer(eff_phel(mm,i)%Ord(i))) &
                  * rf_wl%Val(wl_pointer(eff_phel(mm,i)%Ord(i))) &
                  / ( wl_IP(iz) * wl_IP(iz) ) )
              eff_phel(mm,iopt)%Val(i) = eff_phel(mm,iopt)%Val(i) + dum
           ENDDO
        ENDIF
     ENDDO

     chophg(iopt)   = chophg(iopt)   + bilth * wwmg(mm) * densh(iopt)
     chophg_c(iopt) = chophg_c(iopt) + cool_FBTH * wwmg(mm) * densh(iopt)
     chophg_h(iopt) = chophg_h(iopt) + heat_FBTH * wwmg(mm) * densh(iopt)

  ENDDO

END SUBROUTINE FBTH2

END MODULE PXDR_CHEMISTRY
