
! 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 - 24 May 2008

MODULE CHEM_ANALYS

  PRIVATE

  PUBLIC :: ANALYS

CONTAINS

!%%%%%%%%%%%%%%%%
SUBROUTINE ANALYS
!%%%%%%%%%%%%%%%%

   USE PXDR_CONSTANTES
   USE PXDR_CHEM_DATA
   USE PXDR_PROFIL
   USE PXDR_STR_DATA
   USE PREP_VAR
   USE PREP_AUTRE

   IMPLICIT NONE

   REAL (KIND=dp), DIMENSION(nqm) :: ab1, ab2, ab3
   REAL (KIND=dp), DIMENSION(nqm) :: fabric, destru

   CHARACTER (LEN=lenSpeci) :: yspec
   REAL (KIND=dp)           :: dmax, fmax
   REAL (KIND=dp)           :: dpc, fpc, toto, dtot, ftot, eq_rel
   REAL (KIND=dp)           :: seuil, answ
   INTEGER                  :: ii, jj, jmax
   INTEGER                  :: j1, j2, j3
   INTEGER                  :: iff, id, k
   INTEGER                  :: nrxi, isp, lev
   INTEGER                  :: ii0, iopt
   INTEGER                  :: skip_h2p

   abnua(n_var+1,0:npo) = 1.0_dp
   abnua(n_var+2,0:npo) = 1.0_dp
   abnua(n_var+3,0:npo) = 1.0_dp
   abnua(n_var+4,0:npo) = 1.0_dp
   abnua(n_var+5,0:npo) = 1.0_dp
   abnua(n_var+6,0:npo) = 1.0_dp
   abnua(n_var+7,0:npo) = 1.0_dp

   PRINT *, '*****************************************'
   PRINT *, '           Chemistry Analysis            '
   PRINT *, '*****************************************'
   PRINT *, ''
   PRINT *,'Do you want reaction rates profiles as a function of Av?'
   PRINT *,'[1] - yes, [0] - no (recommended choice)'
   READ *,ii0
   IF (ii0 == 1) THEN
      CALL EVOLREACT
   ENDIF

   PRINT *,'Do you want chemistry heating rates by reactions ? '
   PRINT *,'[1] - yes, [0] - no (recommended choice)'
   READ *,ii0
   IF (ii0 == 1) THEN
      CALL HEATCOOLCHEM
   ENDIF

   PRINT *, ''
   PRINT *, '-----------------------------------------'
   PRINT *, '  Start chemistry analysis at a fixed Av '
   PRINT *, '-----------------------------------------'

   answ = 0
   DO WHILE (answ /= 1)
      PRINT *, 'Select the position in the cloud (position index)'
      PRINT *, '- Maximum value is: ', npo
      PRINT *, '- To end analysis enter: -1'
      READ *, iopt

      IF (iopt == -1) THEN
         RETURN
      ENDIF

      PRINT *
      av = tau(iopt) * tautav
      PRINT *, 'Point ', iopt, ', Av =', av, ", T = ", tgaz(iopt),&
              "  nH = ", densh(iopt)
      PRINT *, 'Keep that position ?'
      PRINT *, '[1] - yes,  [0] - no'
      READ  *, answ
   ENDDO

   PRINT *, 'Select threshold'
   PRINT *, '- High value => more reactions'
   PRINT *, '- All reactions:  0'
   PRINT *, '- Typical value: 10 to 100'
   READ *, seuil

   temp = tgaz(iopt)

   h2para = 0.0_dp
   h2orth = 0.0_dp
   DO lev = 1, l0h2
      jj = njl_h2(lev)
      IF (MOD(jj,2) == 0) THEN
         h2para = h2para + spec_lin(in_sp(i_h2))%xre(lev,iopt)
      ELSE
         h2orth = h2orth + spec_lin(in_sp(i_h2))%xre(lev,iopt)
      ENDIF
   ENDDO
   !PRINT *, " H2 para:", h2para, " H2 ortho:", h2orth

   CALL XKFILL (iopt)

   DO
      PRINT *
      PRINT *, 'Select species? (End: -1)'
      READ (*,'(a8)') yspec
      IF (yspec == '-1') THEN
         EXIT
      ENDIF

      DO jj = 1, n_var
         IF (speci(jj) == yspec) THEN
            isp = jj
            EXIT
         ENDIF
      ENDDO
      IF (jj > nsp_n1 .AND. jj <= nsp_n1+nsp_g1) THEN
         PRINT *, yspec, " is not computed directly"
         PRINT *, "      Use and check the corresponding moment equations."
         CYCLE
      ELSE IF (jj > n_var) THEN
         PRINT *, yspec, " is not in chemistry"
         CYCLE
      ELSE
         nrxi = xmatk(isp)%nbt
         PRINT *, "  Number of reactions: ", nrxi
      ENDIF

      IF (yspec == "h2") THEN
         PRINT *, ' Do you want to skip adsorbed H2? (yes:1, no: 0)'
         READ *, skip_h2p
      ENDIF

      fabric(1:neqt) = 0.0_dp
      destru(1:neqt) = 0.0_dp

      DO k = 1, nrxi
         j1 = xmatk(isp)%fdt(k)%r1
         j2 = xmatk(isp)%fdt(k)%r2
         j3 = xmatk(isp)%fdt(k)%r3
         ab1(k) = abnua(j1,iopt)
         ab2(k) = abnua(j2,iopt)
         ab3(k) = abnua(j3,iopt)
      ENDDO

!    Formation and destruction

      iff = 0
      id = 0
      ftot = 0.0_dp
      dtot = 0.0_dp
      DO k = 1, nrxi
         IF (yspec == "h2" .AND. skip_h2p == 1 .AND. &
             (xmatk(isp)%fdt(k)%it == 113 .OR. xmatk(isp)%fdt(k)%it == 118)) THEN
            CYCLE
         ENDIF
         toto = xmatk(isp)%fdt(k)%k
         IF (toto > 0.0_dp) THEN
            iff = iff + 1
            fabric(k) = toto * ab1(k) * ab2(k) * ab3(k)
            ftot = ftot + fabric(k)
         ELSE IF (toto < 0.0_dp) THEN
            id = id + 1
            destru(k) = -toto * ab1(k) * ab2(k) * ab3(k)
            dtot = dtot + destru(k)
         ENDIF
      ENDDO

      PRINT *
      PRINT *, '-----------------------------------------------'
      PRINT *, '        Chemistry of:  ', yspec
      PRINT *, '-----------------------------------------------'
      PRINT *
      PRINT *, 'Point ', iopt, ', Av =', av, ", T = ", tgaz(iopt),&
              "  nH = ", densh(iopt)
      IF (isp == nspec) THEN
         WRITE (6,'(" Photo-ejection of electrons by grains:",1p,E18.6," (cm-3 s-1)")') relgr(1,iopt)
         WRITE (6,'(" Recombination of electrons on grains: ",1p,E18.6," (cm-3 s-1)")') relgr(2,iopt)*abnua(isp,iopt)
      ENDIF
      IF (isp <= nspec) THEN
         WRITE (6,1003) ftot, dtot, abnua(isp,iopt)
      ELSE
         WRITE (6,1004) ftot, dtot, abnua(isp,iopt)
      ENDIF
      eq_rel = ABS(ftot - dtot) / (ftot + dtot)
      IF (eq_rel > 1.0e-2_dp) THEN
         WRITE (6,'("  WARNING: poor chemical balance:",1P,E15.6," %")') 100.0_dp * ABS(ftot - dtot) / (ftot + dtot)
      ENDIF
      PRINT *
      fpc = ftot
      dpc = dtot
      IF (seuil /= 0.0_dp) THEN
         ftot = ftot / seuil
         dtot = dtot / seuil
      ELSE
         ftot = 0.0_dp
         dtot = 0.0_dp
      ENDIF

      PRINT *, '-- Formation of ', yspec,':'
      WRITE (*,1005)
      DO ii = 1, nrxi
         fmax = 0.0_dp
         DO jj = 1, nrxi
            IF (fabric(jj) > fmax) THEN
               fmax = fabric(jj)
               jmax = jj
            ENDIF
         ENDDO

         IF (fmax < ftot .OR. fmax == 0.0_dp) EXIT

         WRITE (6,1002) xmatk(isp)%fdt(jmax)%it &
                   , speci(xmatk(isp)%fdt(jmax)%r1), speci(xmatk(isp)%fdt(jmax)%r2) &
                   , speci(xmatk(isp)%fdt(jmax)%p1), speci(xmatk(isp)%fdt(jmax)%p2) &
                   , speci(xmatk(isp)%fdt(jmax)%p3), speci(xmatk(isp)%fdt(jmax)%p4) &
                   , fmax, fmax / abnua(isp,iopt),   xmatk(isp)%fdt(jmax)%k         &
                   , 100.0_dp*fmax/fpc
         fabric(jmax) = 0.0_dp
      ENDDO

      PRINT *, ' '
      PRINT *, '-- Destruction of ', yspec,':'
      WRITE (*,1005)
      DO ii = 1, nrxi
         dmax = 0.0_dp
         DO jj = 1, nrxi
           IF (destru(jj) > dmax) THEN
             dmax = destru(jj)
             jmax = jj
           ENDIF
         ENDDO

         IF (dmax < dtot .OR. dmax == 0.0_dp) EXIT

         WRITE (6,1002) xmatk(isp)%fdt(jmax)%it &
                    , speci(xmatk(isp)%fdt(jmax)%r1), speci(xmatk(isp)%fdt(jmax)%r2) &
                    , speci(xmatk(isp)%fdt(jmax)%p1), speci(xmatk(isp)%fdt(jmax)%p2) &
                    , speci(xmatk(isp)%fdt(jmax)%p3), speci(xmatk(isp)%fdt(jmax)%p4) &
                    , dmax, dmax / abnua(isp,iopt) ,  xmatk(isp)%fdt(jmax)%k         &
                    , 100.0_dp*dmax/dpc
         destru(jmax) = 0.0_dp
      ENDDO

      PRINT *, '-----------------------------------------------'

   ENDDO

 1002 format (1x,i4,1x,a8,' + ',a8,' = ',4a8,5x,1pe12.4,'  cm-3 s-1',e12.4,' s-1' &
             ,1pe12.4,' cm3 s-1 or s-1',0pf8.2,' %',i4)
 1003 format (1x,'fabric:',1pe15.6,' (cm-3 s-1), destru:',e15.6,' (cm-3 s-1), abond:',e15.6,' (cm-3)')
 1004 format (1x,'fabric:',1pe15.6,' (cm-3 s-1), destru:',e15.6,' (cm-3 s-1), abond:',e15.6,' (part / grain)')
 1005 format (67x,'Reaction rate (R)     R/n(X)          k                           %' )

END SUBROUTINE ANALYS

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
SUBROUTINE HEATCOOLCHEM
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

   USE PXDR_CONSTANTES
   USE PXDR_CHEM_DATA
   USE PXDR_PROFIL
   USE PREP_VAR
   USE PREP_AUTRE

   IMPLICIT NONE

   CHARACTER(len=lenfilename) :: file_HeatCoolChem
   CHARACTER(len=lenSpeci)    :: speci1, speci2, speci3
   CHARACTER(len=lenSpeci)    :: speci4, speci5, speci6, speci7
   INTEGER                    :: answ
   INTEGER                    :: iopt
   INTEGER                    :: ideb, ifin
   INTEGER                    :: ir1, ir2, ir3
   INTEGER                    :: ip1, ip2
   INTEGER                    :: i
   INTEGER                    :: ind_sp, iv1, lev

   REAL(KIND=dp)              :: ab1, ab2, ab3
   REAL(KIND=dp)              :: expon
   REAL(KIND=dp)              :: rate, rate_h, rate_l
   REAL(KIND=dp)              :: dde
   REAL(KIND=dp)              :: endo_rxn, rat_l, scale_rot, scale_vib
   REAL(KIND=dp)              :: xkchim, thresh
   REAL(KIND=dp)              :: xkchim_tot
   REAL (KIND=dp), DIMENSION (0:14) :: xh2v
   REAL (KIND=dp), DIMENSION (0:14) :: kvh2

   !----------------------------------------------------------------------------
   ! SELECT AN AV
   !----------------------------------------------------------------------------
   PRINT *, '-----------------------------------------'
   PRINT *, '             Select and AV               '
   PRINT *, '-----------------------------------------'

   answ = 0
   DO WHILE (answ /= 1)
      PRINT *, 'Give Av position index'
      PRINT *, 'max value: (iopt):', npo
      PRINT *, 'End analysis: -1'
      READ *, iopt

      IF (iopt == -1) THEN
         RETURN
      ENDIF

      PRINT *
      av = tau(iopt) * tautav
      PRINT *, 'Point ', iopt, ', Av =', av, ", T = ", tgaz(iopt), "  nH = ", densh(iopt)
      PRINT *, 'Keep that point?'
      PRINT *, '1- yes   0- no'
      READ  *, answ
   ENDDO

   PRINT *, "Give a threshold"
   READ *, thresh

   !----------------------------------------------------------------------------
   ! SELECT AN OUTPUT FILE
   !----------------------------------------------------------------------------
   PRINT *,""
   PRINT *,"Enter output file name"
   READ  *, file_HeatCoolChem
   OPEN(70, file=file_HeatCoolChem, status="UNKNOWN", action="WRITE")
   WRITE(70, 1072)
   WRITE(70, 1073) fichier
   WRITE(70, 1074) iopt, av, tgaz(iopt), densh(iopt)
   WRITE(70, 1075) ! separator
   WRITE(70, 1076) ! columns titles
   WRITE(70, 1077) ! columns units

   xkchim_tot = 0.0_dp

   !----------------------------------------------------------------------------
   ! Compute heating / cooling rate for each reaction [erg cm-3 s-1]
   !----------------------------------------------------------------------------
   ideb = nh2for + ncrion + npsion + nasrad + 1
   ifin = nh2for + ncrion + npsion + nasrad + nrest

   DO i = ideb, ifin

      !--- Get abundances of reactants -----------------------------------------
      ir1 = react(i,1)
      ir2 = react(i,2)
      ir3 = react(i,3)

      ab1 = abnua(ir1,iopt)
      ab2 = abnua(ir2,iopt)
      ab3 = abnua(ir3,iopt)

      !--- Compute heating / cooling rates as in the PDR code ------------------
      IF (de(i) > 1.0e3_dp) THEN
         dde = 0.0_dp
         PRINT *, i, ir1, ir2, de(i)
      ELSE IF (ir2 == nspec) THEN
         dde = de(i) - e_int_co          ! For dissociative recombination e_int_co goes in internal energy
      ELSE IF (     (ir1 == i_h2p .AND. ir2 == i_h2 ) &
              .OR.  (ir1 == i_h2  .AND. ir2 == i_h2p) &
!              .AND. (F_H3p_CH_PUM == 1)               &
              ) THEN
         dde = MAX(de(i) - e_int_h3p, 0.0_dp)
      ELSE
         dde = de(i)
      ENDIF

      IF (bet(i) < 0.0_dp) THEN
         expon = EXP(-bet(i)/MAX(tgaz(iopt),200.0_dp))
      ELSE
         expon = EXP(-bet(i)/tgaz(iopt))
      ENDIF

      !--- Reaction rate
      rate   = gamm(i) * expon * (tgaz(iopt)/300.0_dp)**alpha(i)
      !--- Heating / Cooling rates
      xkchim = ab1 * ab2 * ab3 * rate * dde * everg

      speci1 = speci(react(i,1))
      speci2 = speci(react(i,2))
      speci3 = speci(react(i,3))
      speci4 = speci(react(i,4))
      speci5 = speci(react(i,5))
      speci6 = speci(react(i,6))
      speci7 = speci(react(i,7))

      IF (thresh < ABS(xkchim)) THEN
         WRITE(70,1070) speci1, speci2, speci3, speci4, speci5, speci6, speci7, &
                        rate, xkchim, dde, itype(i)
      ENDIF
      xkchim_tot = xkchim_tot + xkchim
   ENDDO

   !----------------------------------------------------------------------------
   ! Add here endothermical reactions with H2 (wrong above)
   !----------------------------------------------------------------------------
   ideb = nh2for + ncrion + npsion + nasrad + nrest + 1
   ifin = nh2for + ncrion + npsion + nasrad + nrest + nh2endo

   DO i = ideb, ifin

      !--- Get abundances of reactants -----------------------------------------
      ir1 = react(i,1)
      ir2 = react(i,2)
      ir3 = react(i,3)
      ip1 = react(i,4)
      ip2 = react(i,5)

      ab1 = abnua(ir1,iopt)
      ab2 = abnua(ir2,iopt)
      ab3 = abnua(ir3,iopt)

      !--- Compute heating / cooling rates as in the PDR code ------------------
      IF (de(i) > 1.0e3_dp) THEN
         dde = 0.0_dp
         PRINT *, i, ir1, ir2, de(i)
      ELSE IF (ir2 == nspec) THEN
         dde = de(i) - e_int_co          ! For dissociative recombination e_int_co goes in internal energy
      ELSE IF (     (ir1 == i_h2p .AND. ir2 == i_h2 ) &
              .OR.  (ir1 == i_h2  .AND. ir2 == i_h2p) &
!              .AND. (F_H3p_CH_PUM == 1)               &
              ) THEN
         dde = MAX(de(i) - e_int_h3p, 0.0_dp)
      ELSE
         dde = de(i)
      ENDIF

      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) * (tgaz(iopt)/300.0_dp)**alpha(i) * EXP(-endo_rxn/tgaz(iopt))
            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

         scale_rot = 2.4_dp * (tgaz(iopt) / 1000.0_dp)**(-0.5_dp)
         scale_vib = 1.4_dp * (tgaz(iopt) / 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 * tgaz(iopt)**(-0.94_dp) + 9.83_dp)) &
              * scale_rot * xreh2(1,iopt) ! v=0, J=0
         rate = rate + 10.0_dp**(-(1682.81_dp * tgaz(iopt)**(-0.95_dp) + 9.87_dp)) &
              * scale_rot * xreh2(2,iopt) ! v=0, J=1
         rate = rate + 10.0_dp**(-(1400.00_dp * tgaz(iopt)**(-0.94_dp) + 9.80_dp)) &
              * scale_rot * xreh2(3,iopt) ! v=0, J=2 - Interpolation
         rate = rate + 10.0_dp**(-(1219.00_dp * tgaz(iopt)**(-0.93_dp) + 9.74_dp)) &
              * scale_rot * xreh2(4,iopt) ! v=0, J=3
         rate = rate + 10.0_dp**(-(1000.00_dp * tgaz(iopt)**(-0.92_dp) + 9.74_dp)) &
              * scale_rot * xreh2(5,iopt) ! v=0, J=4 - Interpolation
         rate = rate + 10.0_dp**(-(740.30_dp  * tgaz(iopt)**(-0.92_dp) + 9.74_dp)) &
              * scale_rot * xreh2(6,iopt) ! v=0, J=5
         rate = rate + 10.0_dp**(-(322.27_dp  * tgaz(iopt)**(-0.86_dp) + 9.72_dp)) &
              * scale_rot * xreh2(7,iopt) ! v=0, J=6 - Interpolation
         rate = rate + 10.0_dp**(-(21.41_dp   * tgaz(iopt)**(-0.52_dp) + 9.58_dp)) &
              * scale_rot * xreh2(8,iopt) ! v=0, J=7
         rate = rate + (4.66E-10_dp * tgaz(iopt)**(-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 * tgaz(iopt)**(-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 * tgaz(iopt)**(-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/tgaz(iopt))
            rate  = rate + rat_l * xreh2(lev,iopt)
         ENDDO
         DO lev = 19, l0h2
            rate = rate + 1.6e-9_dp * xreh2(lev,iopt)
         ENDDO

      ENDIF

      !--- Heating / Cooling rates
      xkchim = ab1 * ab2 * ab3 * rate * dde * everg

      speci1 = speci(react(i,1))
      speci2 = speci(react(i,2))
      speci3 = speci(react(i,3))
      speci4 = speci(react(i,4))
      speci5 = speci(react(i,5))
      speci6 = speci(react(i,6))
      speci7 = speci(react(i,7))

      IF (thresh < ABS(xkchim)) THEN
         WRITE(70,1070) speci1, speci2, speci3, speci4, speci5, speci6, speci7, &
                        rate, xkchim, dde, itype(i)
      ENDIF
      xkchim_tot = xkchim_tot + xkchim
   ENDDO

   !----------------------------------------------------------------------------
   ! Add special reactions (type 101 to 110)
   !----------------------------------------------------------------------------
   ideb = nh2for + ncrion + npsion + nasrad + nrest + nh2endo + nphot_f + nphot_i + n3body
   ifin = ideb + ncpart

   !-----------------------------------------------------------------------------
   ! H2 abundance in vibrational levels
   !-----------------------------------------------------------------------------
   ind_sp = in_sp(i_h2)
   xh2v = 0.0_dp
   DO lev = 1, l0h2
      iv1 = nvl_h2(lev)
      xh2v(iv1) = xh2v(iv1) + spec_lin(ind_sp)%xre(lev,iopt)
   ENDDO

   DO i = ideb, ifin

      !--- Get abundances of reactants -----------------------------------------
      ir1 = react(i,1)
      ir2 = react(i,2)
      ir3 = react(i,3)
      ip1 = react(i,4)
      ip2 = react(i,5)

      ab1 = abnua(ir1,iopt)
      ab2 = abnua(ir2,iopt)
      ab3 = abnua(ir3,iopt)

      !--- Compute heating / cooling rates as in the PDR code ------------------
      IF (de(i) > 1.0e3_dp) THEN
         dde = 0.0_dp
         PRINT *, i, ir1, ir2, de(i)
      ELSE IF (ir2 == nspec) THEN
         dde = de(i) - e_int_co          ! For dissociative recombination e_int_co goes in internal energy
      ELSE IF (     (ir1 == i_h2p .AND. ir2 == i_h2 ) &
              .OR.  (ir1 == i_h2  .AND. ir2 == i_h2p) &
!              .AND. (F_H3p_CH_PUM == 1)               &
              ) THEN
         dde = MAX(de(i) - e_int_h3p, 0.0_dp)
      ELSE
         dde = de(i)
      ENDIF

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

      !--------------------------------------------------------------------------
      ! (102) H2 + H2D+ -> H3+ + HD
      !--------------------------------------------------------------------------
      !--- Expression with para and ortho H2
      ELSE IF (ir1 == i_h2 .AND. ir2 == i_h2dp)  THEN
         rate = gamm(i) * (h2para * EXP(-bet(i) / tgaz(iopt))                  &
                        + h2orth * EXP(-61.5_dp / tgaz(iopt)) * ((tgaz(iopt) / 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) * (tgaz(iopt)/300.0_dp)**alpha(i) * EXP(-6.5_dp/tgaz(iopt))  &
                        * (1.0_dp / (1.0_dp + EXP(-bet(i)/tgaz(iopt))))

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

      !--------------------------------------------------------------------------
      ! (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) * (tgaz(iopt)/300.0_dp)**alpha(i)   &
                        * (1.0_dp / (1.0_dp + EXP(-bet(i)/tgaz(iopt))))
      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) * (tgaz(iopt)/300.0_dp)**alpha(i)   &
                        * EXP(-bet(i)/tgaz(iopt)) * (1.0_dp / (1.0_dp + EXP(-bet(i)/tgaz(iopt))))

      !--------------------------------------------------------------------------
      ! (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) * alpha(i) * (0.62_dp + (0.4767_dp * bet(i) / sqrt(tgaz(iopt)/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(tgaz(iopt)/300.0_dp) &
                                             + (bet(i)**2 / 10.526_dp * 300.0_dp/tgaz(iopt))))

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

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

      !--------------------------------------------------------------------------
      ! (108) F + H2 -> HF + H
      !--------------------------------------------------------------------------
      ELSE IF (itype(i) == 108) THEN
        !--- Expression updated by Tizniti et al. 2014
        rate = 4.71e-13_dp * (EXP(-0.364_dp/tgaz(iopt)) + 3.38_dp * EXP(-38.9_dp/tgaz(iopt)) &
             + 212.0_dp * EXP(-881.0_dp/tgaz(iopt)) + 124.0_dp * EXP(-414.0_dp/tgaz(iopt)))

      !--------------------------------------------------------------------------
      ! (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) * (tgaz(iopt)/300.0_dp)**alpha(i) &
                        * (2.0_dp / (2.0_dp + EXP(-bet(i)/tgaz(iopt))))
      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) * (tgaz(iopt)/300.0_dp)**alpha(i) &
                        * EXP(-bet(i)/tgaz(iopt)) * (1.0_dp / (2.0_dp + EXP(-bet(i)/tgaz(iopt))))

      !--------------------------------------------------------------------------
      ! (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) / (tgaz(iopt)**a3h2v(iv1) * (1.0_dp + a4h2v(iv1) * tgaz(iopt)**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(tgaz(iopt)) * EXP(-(1.0_dp + 63590.0_dp / tgaz(iopt)))
        !!rate = rate_l
        !rate_h = 3.52e-9_dp * EXP(-43900.0_dp / tgaz(iopt))
        !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 / tgaz(iopt)) * 1.0e-10_dp
        ENDDO
        rate = SUM(kvh2(:)*xh2v(:))

        ! Glover et Mac Low, low and high density
        !rate_l = 5.996e-30_dp * tgaz(iopt)**4.1881_dp * EXP(-54657.4_dp/tgaz(iopt)) / (1.0_dp + 6.761e-6_dp * tgaz(iopt))**5.6881_dp
        !!rate = rate_l
        !rate_h = 1.3e-9_dp * EXP(-53300.0_dp / tgaz(iopt))
        !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

      !--- Heating / Cooling rates
      xkchim = ab1 * ab2 * ab3 * rate * dde * everg

      speci1 = speci(react(i,1))
      speci2 = speci(react(i,2))
      speci3 = speci(react(i,3))
      speci4 = speci(react(i,4))
      speci5 = speci(react(i,5))
      speci6 = speci(react(i,6))
      speci7 = speci(react(i,7))

      IF (thresh < ABS(xkchim)) THEN
         WRITE(70,1070) speci1, speci2, speci3, speci4, speci5, speci6, speci7, &
                        rate, xkchim, dde, itype(i)
      ENDIF
      xkchim_tot = xkchim_tot + xkchim
   ENDDO

   WRITE(70,1071) xkchim_tot

   PRINT *,"Data stored in output file"
   PRINT *,"Continue with chemistry analyzis"
   PRINT *,""

   CLOSE(70)

!1070 FORMAT(3(A8," , "),"-> , ",4(A8," , "),1pE12.4E3," , ",1pE12.4E3," , ",1pE12.4E3,i8)
1070 FORMAT(3(A8,"   "),"->   ",4(A8,"   "),1pE12.4E3,"   ",1pE12.4E3,"   ",1pE12.4E3,i8)
1071 FORMAT("#Total heating rate by chemistry = ",1pE12.4E3,"  [erg cm-3 s-1]")
1072 FORMAT("#--- Heating rates by chemical reactions ----")
1073 FORMAT("#- Model: ",A255)
1074 FORMAT("#- Position:",I4," , AV= ",1pE16.8E3,", T= ",1pE12.4,", nH= ",1pE12.4)
1075 FORMAT("#--------------------------------------------")
1076 FORMAT("#React1  , React2   , React3   , -> , Prod1    ,  Prod2   ,&
            & Prod3    , Prod4    ,  Rate        ,  Heating rate,     Enthalpy,    Type")
1077 FORMAT("#        ,          ,          ,    ,          ,          ,&
            &          ,          ,  [cm-3 s-1]  ,  [erg cm-3 s-1],       [eV]")

END SUBROUTINE HEATCOOLCHEM

!%%%%%%%%%%%%%%%%%%%
SUBROUTINE EVOLREACT
!%%%%%%%%%%%%%%%%%%%

   USE PXDR_CONSTANTES
   USE PXDR_CHEM_DATA
   USE PXDR_PROFIL
   USE PREP_VAR
   USE PREP_AUTRE

   IMPLICIT NONE

!-------------------------------------------------------------
! DECLARATIONS
!-------------------------------------------------------------

   REAL (KIND=dp)             :: seuil, toto
   INTEGER                    :: numdest, numfabr
   INTEGER                    :: numdest2, numfabr2
   INTEGER                    :: j1, j2, j3
   INTEGER                    :: lev, iopt, k, isp
   INTEGER                    :: jj, nrxi
   INTEGER, DIMENSION(1:neqt) :: flagreact

   CHARACTER (LEN=75)         :: fichier1, fichier2, fichier3
   CHARACTER (LEN=lenSpeci)   :: yspec

   REAL (KIND=dp), DIMENSION(1:neqt,0:npo) :: fabri, destr
   REAL (KIND=dp), DIMENSION(0:npo)        :: fabtot, destot
   REAL (KIND=dp)                          :: taudest, taufabr
   REAL (KIND=dp), DIMENSION(0:npo,1:neqt) :: pourfabr
   REAL (KIND=dp), DIMENSION(0:npo,1:neqt) :: pourdest
   REAL (KIND=dp), DIMENSION(0:npo,1:neqt) :: pourfabr2
   REAL (KIND=dp), DIMENSION(0:npo,1:neqt) :: pourdest2
   REAL (KIND=dp), DIMENSION(nqm)          :: ab1, ab2, ab3

!------------------------------------------------------------
! xmatk(isp)%fdt(k)%k : cste de vitesse de form (si >0), de dest (si <0)
! de l'espece isp dans la k ieme reaction ou elle intervient.

!------------------------------------------------------------
! ESPECE
!------------------------------------------------------------
   PRINT *,'Which species do you want?'
   READ (*,'(a8)') yspec
   DO jj = 1, nspec
      IF (speci(jj) == yspec) THEN
         isp = jj               !num de l'esp choisie
      ENDIF
   ENDDO

   PRINT *,'Enter a threshold (%)'
   READ(*,*) seuil

!------------------------------------------------------------
! INITIALISATION
!------------------------------------------------------------
   nrxi = xmatk(isp)%nbt      ! nbre de reaction concernant isp
   DO k = 1, nrxi
      flagreact(k) = 0        ! on met un flag a zero a toutes ces reaction
   ENDDO                      ! qd flag vaut 1, on garde la reaction

   numfabr = 0                ! nbre de reactions de fabr qu'il faudra sortir
   numdest = 0                ! idem pour destruction

!----------------------------------------------------------
! CALCUL DES TAUX DE FABRICATION ET DE DESTRUCTION TOTAL.
!----------------------------------------------------------
   DO iopt = 0, npo
      temp = tgaz(iopt)
      av = tau(iopt) * tautav

      h2para = 0.0_dp
      h2orth = 0.0_dp
      DO lev = 1, spec_lin(in_sp(i_h2))%use
         jj = njl_h2(lev)
         IF (MOD(jj,2) == 0) THEN
            h2para = h2para + spec_lin(in_sp(i_h2))%xre(lev,iopt)
         ELSE
            h2orth = h2orth + spec_lin(in_sp(i_h2))%xre(lev,iopt)
         ENDIF
      ENDDO

      CALL XKFILL (iopt)

      fabri(1:neqt,iopt) = 0.0_dp
      destr(1:neqt,iopt) = 0.0_dp

      DO k = 1, nrxi
         j1 = xmatk(isp)%fdt(k)%r1
         j2 = xmatk(isp)%fdt(k)%r2
         j3 = xmatk(isp)%fdt(k)%r3
         ab1(k) = abnua(j1,iopt)              ! abond du premier reactif
         ab2(k) = abnua(j2,iopt)              ! abond du second reactif
         ab3(k) = abnua(j3,iopt)              ! abond du troisieme reactif
      ENDDO

! Calcul du taux de fabrication total et du tau de destruction total
! au point iopt.

      fabtot(iopt) = 0.0_dp
      destot(iopt) = 0.0_dp

      DO k = 1, nrxi
         toto = xmatk(isp)%fdt(k)%k       !taux de la kieme reaction
         IF (toto > 0.0_dp) THEN
            fabri(k,iopt) = toto * ab1(k) * ab2(k) * ab3(k)
            fabtot(iopt) = fabtot(iopt) + fabri(k,iopt)
         ELSE IF (toto < 0.0_dp) THEN
            destr(k,iopt) = -toto * ab1(k) * ab2(k) * ab3(k)
            destot(iopt) = destot(iopt) + destr(k,iopt)
         ENDIF
      ENDDO

   ENDDO

!--------------------------------------------------------------------
! RECHERCHE DES REACTIONS A CONSERVER
!--------------------------------------------------------------------
! En chaque point iopt, on calcul le pourcentage que represente chaque
! reaction et si ce pourcentage est superieur au seuil on la garde.
! Les reaction qu'on garde sont associees a un indice different de 0
! dans le tableau flagreact. Si cet indice vaut 1, c'est une reaction
! de formation, s'il vaut -1, de destruction.
! Que la reaction soit conservee ou non, les pourcentages sont conserves
! dans deux tableaux: pourdest et pourfabr.

   DO iopt = 0, npo
      DO k = 1, nrxi
         toto = xmatk(isp)%fdt(k)%k
         IF (toto < 0.0_dp) THEN
            taudest = destr(k, iopt)
            pourdest(iopt,k) = 100.0_dp * taudest / destot(iopt)
            IF (pourdest(iopt,k) > seuil) THEN
               IF (flagreact(k) == 0) THEN
                  flagreact(k)=-1
                  numdest = numdest+1
               ENDIF
            ENDIF
         ELSE IF (toto > 0.0_dp) THEN
            taufabr = fabri(k, iopt)
            pourfabr(iopt,k) = 100.0_dp * taufabr / fabtot(iopt)
            IF (pourfabr(iopt,k) > seuil) THEN
               IF (flagreact(k) == 0) THEN
                  flagreact(k)=1
                  numfabr = numfabr +1
               ENDIF
            ENDIF
         ENDIF
      ENDDO
   ENDDO


! Pour les sorties, il ne faut garder dans deux tableaux que les pourcentages
! des reactions conservees. On stocke ces pourcentages dans deux nouveaux
! tableaux pourdest2 et pourfabr2.
! On releve egalement a cette occasion les nombre de reaction de formation
! et le nombre de reaction de destruction.

   DO iopt = 0, npo
      numfabr2 = 0
      numdest2 = 0
      DO k = 1, nrxi
         IF (flagreact(k) == 1) THEN
            numfabr2 = numfabr2 +1
            pourfabr2(iopt,numfabr2)  = pourfabr(iopt,k)
         ENDIF
         IF (flagreact(k) == -1) THEN
            numdest2 = numdest2 +1
            pourdest2(iopt,numdest2) = pourdest(iopt,k)
         ENDIF
      ENDDO
   ENDDO

!---------------------------------------------------------------------
! SORTIE DES RESULTATS
!---------------------------------------------------------------------
   fichier1 = 'chimevold'
   fichier2 = 'chimevolf'
   fichier3 = 'chimevolr'

   OPEN(10,file=fichier1,status='unknown')
   OPEN(20,file=fichier2,status='unknown')
   OPEN(30,file=fichier3,status='unknown')

   WRITE(30,*) 'Reactions de fabrication'
   DO k = 1, nrxi
      IF (flagreact(k) == 1) THEN
         WRITE(30,*) speci(xmatk(isp)%fdt(k)%r1), speci(xmatk(isp)%fdt(k)%r2) &
                   , speci(xmatk(isp)%fdt(k)%r3), speci(xmatk(isp)%fdt(k)%p1) &
                   , speci(xmatk(isp)%fdt(k)%p2), speci(xmatk(isp)%fdt(k)%p3) &
                   , speci(xmatk(isp)%fdt(k)%p4)
      ENDIF
   ENDDO
   WRITE(30,*)
   WRITE(30,*) 'Reactions de destruction'
   DO k = 1, nrxi
      IF (flagreact(k) == -1) THEN
         WRITE(30,*) speci(xmatk(isp)%fdt(k)%r1), speci(xmatk(isp)%fdt(k)%r2) &
                   , speci(xmatk(isp)%fdt(k)%r3), speci(xmatk(isp)%fdt(k)%p1) &
                   , speci(xmatk(isp)%fdt(k)%p2), speci(xmatk(isp)%fdt(k)%p3) &
                   , speci(xmatk(isp)%fdt(k)%p4)
      ENDIF
   ENDDO

   PRINT *,'Nbre of formation reaction kept:',numfabr
   PRINT *,'Nbre of destruction reaction kept:',numdest
   PRINT *,'Results are in files:'
   PRINT *,' - chimevolr:    list of reactions'
   PRINT *,' - chimevolf:    formation rates'
   PRINT *,' - chimevold:    destructionrates '
   PRINT *,'Rem: Columns order are the same in all files'
   PRINT *

   DO iopt = 0, npo
      av = tau(iopt) * 1.085736
      WRITE(10,'(1p,100e12.5)') av, (pourdest2(iopt,k), k=1,numdest)
      WRITE(20,'(1p,100e12.5)') av, (pourfabr2(iopt,k), k=1,numfabr)
   ENDDO

   CLOSE(10)
   CLOSE(20)
   CLOSE(30)

!-------------------------------------------------------------------
! FIN
!-------------------------------------------------------------------

END SUBROUTINE EVOLREACT

END MODULE CHEM_ANALYS
