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

  PRIVATE

  PUBLIC :: EQLH2V, COLH2V

CONTAINS

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
SUBROUTINE EQLH2V (ttry, iopt)
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

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

   ! Computes equilibrium matrix of H2 levels and
   ! solves for detailed balace
   IMPLICIT NONE

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

   REAL (KIND=dp), DIMENSION (:,:), ALLOCATABLE :: fr_des
   REAL (KIND=dp), DIMENSION (:), ALLOCATABLE   :: fr_des_m
   INTEGER                                      :: j_sp, nused, nrxi
   INTEGER                                      :: mm, lev, nrendo
   INTEGER                                      :: if_ac, if_110h2
   INTEGER                                      :: k, k1, k2, k3, ii, ij, iv
   INTEGER                                      :: leva, levb, levu, iju, ivu
   REAL (KIND=dp)                               :: toto, fabric, destru, fabric_exo
   REAL (KIND=dp)                               :: rateah2, ratedh2, rateeh2, ratefh2, rateerh2
   REAL (KIND=dp)                               :: endo_rxn, rat_l, taux, dumy
   REAL (KIND=dp), DIMENSION (0:14)             :: kvh2

   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

   j_sp = in_sp(i_h2)
   nused = spec_lin(in_sp(i_h2))%use

   IF ( .NOT. ALLOCATED(fr_des)) THEN
      ALLOCATE (fr_des(1:nused,npbgr))
      ALLOCATE (fr_des_m(1:nused))
   ENDIF
   fr_des   = 0.0_dp
   fr_des_m = 0.0_dp

   !----------------------------------------------------------------------------
   ! H2 desorption from grains
   ! * controls H2 ortho / para conversion on grains
   ! * follows a Boltzman distribution at grains temperatures
   !----------------------------------------------------------------------------
   DO mm = 1, npbgr
      toto = 0.0_dp
      DO lev = 1, nused
         fr_des(lev,mm) = spec_lin(j_sp)%gst(lev) * EXP(-spec_lin(in_sp(i_h2))%elk(lev) / tdust(mm,iopt))
         toto = toto + fr_des(lev,mm)
      ENDDO
      fr_des(:,mm) = fr_des(:,mm) / toto
   ENDDO
   toto = 0.0_dp
   DO lev = 1, nused
      fr_des_m(lev) = SUM(fr_des(lev,1:npbgr) * wwmg(1:npbgr)) / SUM(wwmg(1:npbgr))
      toto = toto + fr_des_m(lev)
   ENDDO
   fr_des_m = fr_des_m / toto

   !TIMH2 useful datas for caracteristic time scales of H2 (in s-1 cm-3)
   !      TIMH2(iopt,1) : FABRIC : H2 formation by gas phase chemistry
   !      TIMH2(iopt,2) : DESTRU : H2 destruction by gas phase chemistry
   !      TIMH2(iopt,3) : RATEGR : H2 formation by Langmuir-Hinshelwood process
   !      TIMH2(iopt,4) : DESPHO : H2 destruction by photons
   !      TIMH2(iopt,5) : RATEER : H2 formation by Eley-Rideal process

   create(1:nused) = 0.0_dp
   remove(1:nused) = 0.0_dp

   ! Pure chemical contributions
   fabric_exo = 0.0_dp
   fabric = 0.0_dp
   destru = 0.0_dp

   nrxi = xmatk(i_h2)%nbt ! number of chemical reactions with H2

   ! New version. JLB 26 II 2008
   nrendo   = nh2for + ncrion + npsion + nasrad + nrest + 1
   rateah2  = 0.0_dp   ! Total accretion on grains
   if_ac    = 0        ! 0 for accretion, 1 for rejection
   if_110h2 = 0        ! 0 for destruction of h2, 1 for collision partner
   ratedh2  = 0.0_dp   ! Total desorption from grains
   rateeh2  = 0.0_dp   ! Total destruction by endothermal reactions
   ratefh2  = 0.0_dp   ! Total H2 formation on grains (physisorption)
   rateerh2 = 0.0_dp   ! Total H2 formation by Eley-Rideal process
   DO k = 1, nrxi
      k1 = xmatk(i_h2)%fdt(k)%r1
      k2 = xmatk(i_h2)%fdt(k)%r2
      k3 = xmatk(i_h2)%fdt(k)%r3

      SELECT CASE (xmatk(i_h2)%fdt(k)%it)
      !.........................................................................
      ! (0) H2 formation on grains - R = 3*10-17 * sqrt(T/100) / Old style
      !.........................................................................
      CASE (0)
         taux = gamm(nh2for) * densh(iopt) * (ttry / bet(nh2for))**alpha(nh2for) &
              * (g_ratio / 0.01_dp) / (istiny + ab(i_h))                     ! cm+3 s-1
         ratefh2 = taux * ab(i_h) * ab(i_h)                                  ! cm-3 s-1

      !.........................................................................
      ! (6) H2 destruction by endothermal reactions
      !.........................................................................
      CASE (6)   ! Energy dependent rxns (endothermal)
         DO ii = 1, nused
            endo_rxn = MAX(bet(nrendo) - spec_lin(in_sp(i_h2))%elk(ii), 0.0_dp)
            rat_l = gamm(nrendo) * (ttry/300.0_dp)**alpha(nrendo) * EXP(-endo_rxn/ttry)
            remove(ii) = remove(ii) + rat_l * ab(k1) * ab(k2)
            rateeh2 = rateeh2 + rat_l * ab(k1) * ab(k2) * xreh2(ii,iopt)
         ENDDO
         nrendo = nrendo + 1

      !.........................................................................
      ! (61) CH+ formation - Destroy H2 in levels
      !.........................................................................
      CASE (61)
         IF (nused <= 8 ) THEN
            WRITE (*,*) ' Error in PXDR_EXCITH2: CH+ formation'
            STOP
         ENDIF

         !--- Rate by Agundez et al. ApJ (2010)
         !DO ii = 1, 8 ! Endothermal reaction with the 8 first levels of H2
         !   endo_rxn = MAX(4827.0_dp - spec_lin(in_sp(i_h2))%elk(ii), 0.0_dp)
         !   rat_l      = 1.58e-10_dp * EXP(-endo_rxn/ttry)
         !   remove(ii) = remove(ii) + rat_l * ab(k1) * ab(k2)
         !   rateeh2    = rateeh2 + rat_l * ab(k1) * ab(k2) * xreh2(ii,iopt)
         !ENDDO
         !DO ii = 9, nused
         !   remove(ii) = remove(ii) + 1.6e-9_dp * ab(k1) * ab(k2)
         !   rateeh2 = rateeh2 + 1.6e-9_dp * ab(k1) * ab(k2) * xreh2(ii,iopt)
         !ENDDO

         !--- Rate by Herraez-Aguilar et al., Phys. Chem. Chem. Phys., 2014
         !rat_l = 10.0**(-(1640.07 * ttry**(-0.94) + 9.83)) ! v=0, J=0
         !remove(1) = remove(1) + rat_l * ab(k1) * ab(k2)
         !rateeh2   = rateeh2   + rat_l * ab(k1) * ab(k2) * xreh2(1,iopt)

         !rat_l = 10.0**(-(1682.81 * ttry**(-0.95) + 9.87)) ! v=0, J=1
         !remove(2) = remove(2) + rat_l * ab(k1) * ab(k2)
         !rateeh2   = rateeh2   + rat_l * ab(k1) * ab(k2) * xreh2(2,iopt)

         !rat_l = 10.0**(-(1400.00 * ttry**(-0.94) + 9.80)) ! v=0, J=2 - Interpolation
         !remove(3) = remove(3) + rat_l * ab(k1) * ab(k2)
         !rateeh2   = rateeh2   + rat_l * ab(k1) * ab(k2) * xreh2(3,iopt)

         !rat_l = 10.0**(-(1219.00 * ttry**(-0.93) + 9.74)) ! v=0, J=3
         !remove(4) = remove(4) + rat_l * ab(k1) * ab(k2)
         !rateeh2   = rateeh2   + rat_l * ab(k1) * ab(k2) * xreh2(4,iopt)

         !rat_l = 10.0**(-(1000.00 * ttry**(-0.92) + 9.74)) ! v=0, J=4 - Interpolation
         !remove(5) = remove(5) + rat_l * ab(k1) * ab(k2)
         !rateeh2   = rateeh2   + rat_l * ab(k1) * ab(k2) * xreh2(5,iopt)

         !rat_l = 10.0**(-(740.30  * ttry**(-0.92) + 9.74)) ! v=0, J=5
         !remove(6) = remove(6) + rat_l * ab(k1) * ab(k2)
         !rateeh2   = rateeh2   + rat_l * ab(k1) * ab(k2) * xreh2(6,iopt)

         !rat_l = 10.0**(-(322.27  * ttry**(-0.86) + 9.72)) ! v=0, J=6 - Interpolation
         !remove(7) = remove(7) + rat_l * ab(k1) * ab(k2)
         !rateeh2   = rateeh2   + rat_l * ab(k1) * ab(k2) * xreh2(7,iopt)

         !rat_l = 10.0**(-(21.41   * ttry**(-0.52) + 9.58)) ! v=0, J=7
         !remove(8) = remove(8) + rat_l * ab(k1) * ab(k2)
         !rateeh2   = rateeh2   + rat_l * ab(k1) * ab(k2) * xreh2(8,iopt)

         !rat_l = (4.66E-10 * ttry**(-0.29) + 1.25E-10)   ! v=0, J=8
         !remove(9) = remove(9) + rat_l * ab(k1) * ab(k2)
         !rateeh2   = rateeh2   + rat_l * ab(k1) * ab(k2) * xreh2(9,iopt)

         !DO lev = 10, l0h2
         !   rat_l = rat_l + 8.0E-10 * ttry**(-0.29) + 1.25E-10   ! other levels
         !   remove(lev) = remove(lev) + rat_l * ab(k1) * ab(k2)
         !   rateeh2     = rateeh2     + rat_l * ab(k1) * ab(k2) * xreh2(lev,iopt)
         !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 on 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)**(-0.5)
        scale_vib = 1.4_dp * (ttry / 1000.0)**(-0.1)
        ! Compute Herraez-Aguilar rates and scale them to get Zanchet et al. values
        rat_l = 10.0**(-(1640.07 * ttry**(-0.94) + 9.83)) * scale_rot ! v=0, J=0
        remove(1) = remove(1) + rat_l * ab(k1) * ab(k2)
        rateeh2   = rateeh2   + rat_l * ab(k1) * ab(k2) * xreh2(1,iopt)

        rat_l = 10.0**(-(1682.81 * ttry**(-0.95) + 9.87)) * scale_rot ! v=0, J=1
        remove(2) = remove(2) + rat_l * ab(k1) * ab(k2)
        rateeh2   = rateeh2   + rat_l * ab(k1) * ab(k2) * xreh2(2,iopt)

        rat_l = 10.0**(-(1400.00 * ttry**(-0.94) + 9.80)) * scale_rot ! v=0, J=2 - Interpolation
        remove(3) = remove(3) + rat_l * ab(k1) * ab(k2)
        rateeh2   = rateeh2   + rat_l * ab(k1) * ab(k2) * xreh2(3,iopt)

        rat_l = 10.0**(-(1219.00 * ttry**(-0.93) + 9.74)) * scale_rot ! v=0, J=3
        remove(4) = remove(4) + rat_l * ab(k1) * ab(k2)
        rateeh2   = rateeh2   + rat_l * ab(k1) * ab(k2) * xreh2(4,iopt)

        rat_l = 10.0**(-(1000.00 * ttry**(-0.92) + 9.74)) * scale_rot ! v=0, J=4 - Interpolation
        remove(5) = remove(5) + rat_l * ab(k1) * ab(k2)
        rateeh2   = rateeh2   + rat_l * ab(k1) * ab(k2) * xreh2(5,iopt)

        rat_l = 10.0**(-(740.30  * ttry**(-0.92) + 9.74)) * scale_rot ! v=0, J=5
        remove(6) = remove(6) + rat_l * ab(k1) * ab(k2)
        rateeh2   = rateeh2   + rat_l * ab(k1) * ab(k2) * xreh2(6,iopt)

        rat_l = 10.0**(-(322.27  * ttry**(-0.86) + 9.72)) * scale_rot ! v=0, J=6 - Interpolation
        remove(7) = remove(7) + rat_l * ab(k1) * ab(k2)
        rateeh2   = rateeh2   + rat_l * ab(k1) * ab(k2) * xreh2(7,iopt)

        rat_l = 10.0**(-(21.41   * ttry**(-0.52) + 9.58)) * scale_rot ! v=0, J=7
        remove(8) = remove(8) + rat_l * ab(k1) * ab(k2)
        rateeh2   = rateeh2   + rat_l * ab(k1) * ab(k2) * xreh2(8,iopt)

        rat_l = (4.66E-10 * ttry**(-0.29) + 1.25E-10) * scale_vib ! v=0, J=8
        remove(9) = remove(9) + rat_l * ab(k1) * ab(k2)
        rateeh2   = rateeh2   + rat_l * ab(k1) * ab(k2) * xreh2(9,iopt)

        ! 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
           rat_l = (8.0E-10 * ttry**(-0.29) + 1.25E-10) * scale_vib
           remove(lev) = remove(lev) + rat_l * ab(k1) * ab(k2)
           rateeh2     = rateeh2     + rat_l * ab(k1) * ab(k2) * xreh2(lev,iopt)
        ENDDO
        ! From v = 2, J=0 (lev = 22) use Zanchet et al. v=2, J=0 rate
        DO lev = min(22,l0h2), l0h2
           rat_l = (2.0E-9 * ttry**(-0.29) + 1.8E-10)
           remove(lev) = remove(lev) + rat_l * ab(k1) * ab(k2)
           rateeh2     = rateeh2     + rat_l * ab(k1) * ab(k2) * xreh2(lev,iopt)
        ENDDO
        nrendo = nrendo + 1

      !.........................................................................
      ! (62) SH+ formation - Destroy H2 in levels
      !.........................................................................
      CASE (62)  ! Formation of SH+ following Agundez et al. ApJ (2010)
         IF (nused <= 18 ) THEN
            WRITE (*,*) ' Error in PXDR_EXCITH2: SH+ formation'
            STOP
         ENDIF
         DO ii = 1, 18 ! Endothermal reaction with the 18 first levels of H2
            endo_rxn = MAX(9860.0_dp - spec_lin(in_sp(i_h2))%elk(ii), 0.0_dp)
            rat_l      = 1.58e-10_dp * EXP(-endo_rxn/ttry)
            remove(ii) = remove(ii) + rat_l * ab(k1) * ab(k2)
            rateeh2    = rateeh2 + rat_l * ab(k1) * ab(k2) * xreh2(ii,iopt)
         ENDDO
         DO ii = 19, nused
            remove(ii) = remove(ii) + 1.6e-9_dp * ab(k1) * ab(k2)
            rateeh2 = rateeh2 + 1.6e-9_dp * ab(k1) * ab(k2) * xreh2(ii,iopt)
         ENDDO
         nrendo = nrendo + 1

      !.........................................................................
      ! (110) Collisional destruction of H2 by H and H2 - rates depend on v
      !.........................................................................
      CASE (110)  ! Collisional destruction of H2
         IF (k1 == i_h .AND. k2 == i_h2) THEN
            DO iv = 0, 14
               kvh2(iv) = -a1h2v(iv) - a2h2v(iv) / (ttry**a3h2v(iv) * (1.0_dp + a4h2v(iv) * ttry**a5h2v(iv)))
            ENDDO
            kvh2 = EXP(kvh2)
            DO lev = 1, l0h2
               iv = nvl_h2(lev)
               remove(lev) = remove(lev) + kvh2(iv) * ab(i_h) * ab(i_h2)
            ENDDO
         ELSE IF (k1 == i_h2 .AND. k2 == i_h2 .AND. if_110h2 == 0) THEN
            DO iv = 0, 14
               kvh2(iv) = 1.30_dp * (1.0_dp + 0.023_dp*iv + 1.93e-5_dp * iv**4.75_dp + 2.85e-24_dp * iv**21.60_dp) &
                         * EXP(-(7.47_dp - 0.322_dp*iv) * 1.0e3 / ttry) * 1.0e-10_dp
            ENDDO
            if_110h2 = 1
            DO lev = 1, l0h2
               iv = nvl_h2(lev)
               remove(lev) = remove(lev) + kvh2(iv) * ab(i_h2) * ab(i_h2)
            ENDDO
         ENDIF

      !.........................................................................
      ! (7) H2 photodissociation
      !.........................................................................
      CASE (7)  ! Photo-dissociation
         ! Matrix evrdbc does not include dissociation any more
         !--- Same destruction rate for all levels
         !destru = destru + xmatk(i_h2)%fdt(k)%k*ab(k1)*ab(k2)*ab(k3)
         !--- or use specific rate per level
         DO ii = 1, nused
            remove(ii) = remove(ii) + pdh2vJ(ii,iopt) * ab(k1)
            rateeh2 = rateeh2 + pdh2vJ(ii,iopt) * ab(k1) * xreh2(ii,iopt)
         ENDDO

      !.........................................................................
      ! (211 / 20) H2 formation on grains
      !.........................................................................
      CASE (211) ! Formation on grains
         ratefh2 = ratefh2 + xmatk(i_h2)%fdt(k)%k * ab(k1) * ab(k2)
      CASE (20) ! Formation on grains by Eley-Rideal process
         rateerh2 = xmatk(i_h2)%fdt(k)%k * ab(k1) * ab(k2)

      !.........................................................................
      ! (113) H2 accretion on grains
      !.........................................................................
      CASE (113)  ! Accretion on grains and direct Eley-Rideal process
         taux = xmatk(i_h2)%fdt(k)%k
         IF (k1 == i_h2) THEN
            IF (if_ac == 0) THEN                      ! accretion
               rateah2 = rateah2 + taux * ab(k1)
               if_ac = 1
            ELSE                                      ! rejection
               rateah2 = rateah2 + taux * ab(k1) * ab(k2)
            ENDIF
         ELSE
            ratefh2 = ratefh2 + taux * ab(k1) * ab(k2)
         ENDIF

      !.........................................................................
      ! (116 / 117) H2 desorption from grains by cosmic rays (116) and photons (117)
      !.........................................................................
      CASE (116, 117)  ! Various desorption processes
         taux = xmatk(i_h2)%fdt(k)%k
         DO lev = 1, nused
            iju = njl_h2(lev)
            ivu = nvl_h2(lev)
            create(lev) = create(lev) + taux * ab(k1) * pophm1(ivu,iju)
         ENDDO
         ratedh2 = ratedh2 + taux * ab(k1)

      !.........................................................................
      ! (118) H2 evaporation from grains
      !.........................................................................
      CASE (118)  ! Various desorption processes
         taux = xmatk(i_h2)%fdt(k)%k
         DO lev = 1, nused
            create(lev) = create(lev) + taux * ab(k1) * fr_des_m(lev)
         ENDDO
         ratedh2 = ratedh2 + taux * ab(k1)

      !.........................................................................
      ! DEFAULT - H2 destruction in gas chemical reactions other than photo-dissociation
      !.........................................................................
      CASE DEFAULT
         taux = xmatk(i_h2)%fdt(k)%k
         IF (taux > 0.0_dp) THEN
            !IF (xmatk(i_h2)%fdt(k)%dt <= 0.0_dp) THEN
               fabric = fabric + taux * ab(k1) * ab(k2) * ab(k3)
            !ELSE
            !   fabric_exo = fabric_exo + taux * ab(k1) * ab(k2) * ab(k3)
            !ENDIF
         ELSE
            destru = destru + taux * ab(k1) * ab(k2) * ab(k3)
         ENDIF
      END SELECT
   ENDDO

   !----------------------------------------------------------------------------
   ! Store some useful data for PREP
   !----------------------------------------------------------------------------
   timh21(iopt) = fabric + fabric_exo
   timh22(iopt) = - destru + rateeh2 - pdiesp(kdeph0,iopt) * ab(i_h2)
   timh23(iopt) = ratefh2
   timh24(iopt) = pdiesp(kdeph0,iopt) * ab(i_h2)
   timh25(iopt) = rateerh2

   !----------------------------------------------------------------------------
   ! Fill H2 create array
   !----------------------------------------------------------------------------

   !--- Formation on grains other than by Eley-Rideal (use pophm1) -------------
   DO lev = 1, nused
      ij = njl_h2(lev)
      iv = nvl_h2(lev)
      dumy = 0.0_dp
      DO levu = nused+1, nlevh2
         iju = njl_h2(levu)
         ivu = nvl_h2(levu)
         dumy = dumy + pophm1(ivu,iju) * cashm(levu,lev)
      ENDDO
      create(lev) = create(lev) + (dumy + pophm1(iv,ij)) * ratefh2
   ENDDO

   !--- Formation by Eley-Rideal (use pophm2) ----------------------------------
   DO lev = 1, nused
      ij = njl_h2(lev)
      iv = nvl_h2(lev)
      dumy = 0.0_dp
      DO levu = nused+1, nlevh2
         iju = njl_h2(levu)
         ivu = nvl_h2(levu)
         dumy = dumy + pophm2(ivu,iju) * cashm(levu,lev)
      ENDDO
      create(lev) = create(lev) + (dumy + pophm2(iv,ij)) * rateerh2
   ENDDO

   !--- Formation by chemical reactions in gas phase ---------------------------
   ! Distribution of H2 formed in the gas phase
   ! This is an ad hoc hypothesys
   !     2/3 on j = 0, 1/3 on j = 1
   !     because rxn h3+ + x -> h2 + xh+ dominates
   leva = lev_h2(0,0)
   levb = lev_h2(0,1)
   create(leva) = create(leva) + 2.0_dp * fabric / 3.0_dp
   create(levb) = create(levb) + fabric / 3.0_dp

   !--- Formation by exothermic reactions --------------------------------------
   ! Not used because fabric_exo = 0.0
   ! Distribution of excited H2 formed by chemistry
   DO lev = 1, nused
      ij = njl_h2(lev)
      iv = nvl_h2(lev)
      dumy = 0.0_dp
      DO levu = nused+1, nlevh2
         iju = njl_h2(levu)
         ivu = nvl_h2(levu)
         dumy = dumy + pophm_ch(ivu,iju) * cashm(levu,lev)
      ENDDO
      create(lev) = create(lev) + (dumy + pophm_ch(iv,ij)) * fabric_exo
   ENDDO

   ! or: all on j = 0
   ! leva = lev_h2(0,0)
   ! create(leva) = create(leva) + fabric

   !----------------------------------------------------------------------------
   ! Fill H2 remove array
   !----------------------------------------------------------------------------

   !--- H2 Destruction assumed to be the same for all levels -------------------
   ! Destruction proportional to population
   ! * destru is negative
   remove(:) = remove(:) - destru - rateah2

END SUBROUTINE EQLH2V

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

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
SUBROUTINE COLH2V (ttry, iopt)
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

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

!---------------------------------------------------------------------
!      xnprot is no. density of protons (cm-3)
!      ttry is temperature of neutral fluid

!      called from sub. EQLH2V
!
!      collision rates for H2 + H come from Martin & Mandy.
!      New fits by Jacques Le Bourlot (july 1996)
!
!          or
!
!      from D. Flower (cf MNRAS)
!
!      Collision rates for H2 + He, H2 + H2o, H2 + H2p
!      come from D. Flower
!
!---------------------------------------------------------------------

   IMPLICIT NONE

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

   REAL (KIND=dp), DIMENSION (30)                   :: gerlic
   INTEGER                                          :: nqc
   REAL (KIND=dp)                                   :: xchh2, fac, ctod
   REAL (KIND=dp)                                   :: decal, tdd, tdd2
   REAL (KIND=dp)                                   :: gmm, ga1, ga2
   REAL (KIND=dp)                                   :: ch2h_nr, ch2h_r, ch2he, ch2h
   REAL (KIND=dp)                                   :: ch2ph2, ch2oh2, cophp, c, d
   INTEGER                                          :: levu, levl, ndej, lev1, lev2
   INTEGER                                          :: ju, jl, ivu, ivl

   ! With David's prescription for O/P balance (3/1)
   ! Data from Gerlich for ortho-para transfer with h+.
   DATA gerlic / 2.024e-10_dp, 9.575e-10_dp, 2.729e-10_dp, 7.910e-10_dp &
         , 2.246e-10_dp, 6.223e-10_dp, 1.828e-10_dp, 4.975e-10_dp, 1.484e-10_dp &
         , 3.000e-10_dp, 1.000e-10_dp, 3.000e-10_dp, 1.000e-10_dp, 3.000e-10_dp &
         , 1.000e-10_dp, 3.000e-10_dp, 1.000e-10_dp, 3.000e-10_dp, 1.000e-10_dp &
         , 3.000e-10_dp, 1.000e-10_dp, 3.000e-10_dp, 1.000e-10_dp, 3.000e-10_dp &
         , 1.000e-10_dp, 3.000e-10_dp, 1.000e-10_dp, 3.000e-10_dp, 1.000e-10_dp &
         , 3.000e-10_dp /

!  Up to now collisions with H2 and He are used only for v = 0
!  Educated guesses may obtain from collisions with H
!  WARNING: c: desexcitation, d: excitation
!            h2h: H2 + H
!            h2h2: H2 + H2
!            h2he: H2 + He
!            ophp: H2 + H+ (ortho - para)

   IF (ichh2 == 0) THEN
      nqc = 4
   ELSE
      nqc = 3
   ENDIF
   IF (ichh2 <= 1) THEN
      xchh2 = 0.0_dp
   ELSE
      xchh2 = 1.0_dp
   ENDIF

   DO levu = 2, l0h2
      ju = njl_h2(levu)
      ivu = nvl_h2(levu)

      DO levl = 1, levu-1
         jl = njl_h2(levl)
         ivl = nvl_h2(levl)

         ! ctod is the Boltzmann factor used to compute
         !    excitation rates from desexcitation rates
         ndej = ABS(ju - jl)
         fac = (spec_lin(in_sp(i_h2))%elk(levu) - spec_lin(in_sp(i_h2))%elk(levl)) / ttry
         ctod = EXP(-fac) * (2.0_dp*ju+1.0_dp) / (2.0_dp*jl+1.0_dp)
         IF (MOD(ju,2) == 1) THEN
            ctod = ctod * 3.0_dp
         ENDIF
         IF (MOD(jl,2) == 1) THEN
            ctod = ctod / 3.0_dp
         ENDIF

         ! Fit of H2 + H rates. The reduced variable tdd is offset by a
         ! different value for reactive (resp. non-reactive) collisions.
         IF (MOD(ndej,2) == 0) THEN
            decal = 1.0_dp
         ELSE
            decal = 0.3_dp
         ENDIF
         tdd = decal + ttry * 1.0e-3_dp
         tdd2 = tdd*tdd

         ! Reactive and non-reactive collisions are mixed in Martin and Mandy
         gmm = q_h2_h_1(levl,levu) + q_h2_h_2(levl,levu) / tdd + q_h2_h_3(levl,levu) / tdd2
         IF (nqc == 4) THEN
            gmm = gmm +  q_h2_h_4(levl,levu) * tdd
         ENDIF

         ch2h_nr = 10.0_dp**gmm
         ch2h_r  = 0.0_dp

         ! Add reactive collisions (David's rule) if ichh2 = 3
         IF (ichh2 == 3 .AND. tau(iopt) <= 1.0_dp) THEN

            IF (MOD(ndej,2) == 0) THEN
               ch2h_r = 10.0_dp**gmm * EXP(-MAX(0.0_dp,(3900.0_dp - spec_lin(in_sp(i_h2))%elk(levu) &
                      + spec_lin(in_sp(i_h2))%elk(levl))/ttry))
            ELSE
               IF (jl > 0) THEN
                  lev1 = lev_h2(ivl,jl-1)
               ELSE
                  lev1 = lev_h2(ivl,jl+1)
               ENDIF
               lev2 = lev_h2(ivl,jl+1)
               IF (lev2 == 0) THEN
                  lev2 = lev_h2(ivl,jl-1)
               ENDIF
               IF (lev2 > l0h2) THEN
                  print *, " +++ Above upper H2 level!"
                  lev2 = levu
               ENDIF
               ga1 = q_h2_h_1(lev1,levu) + q_h2_h_2(lev1,levu) / tdd + q_h2_h_3(lev1,levu) / tdd2
               IF (nqc == 4) THEN
                  ga1 = ga1 + q_h2_h_4(lev1,levu) * tdd
               ENDIF
               ga2 = q_h2_h_1(lev2,levu) + q_h2_h_2(lev2,levu) / tdd + q_h2_h_3(lev2,levu) / tdd2
               IF (nqc == 4) THEN
                  ga2 = ga2 + q_h2_h_4(lev2,levu) * tdd
               ENDIF
               ch2h_r = (10.0_dp**ga1 + 10.0_dp**ga2) * 0.5 * EXP(-MAX(0.0_dp,(3900.0_dp - spec_lin(in_sp(i_h2))%elk(levu) &
                      + spec_lin(in_sp(i_h2))%elk(levl))/ttry))

               IF (MOD(ju,2) == 1) THEN
                  ch2h_r = ch2h_r / 3.0_dp
               ENDIF
            ENDIF
         ENDIF

         ! Ortho/Para transfer with H from Schofield
         ! plus David's rule (for a few delta v = 0)
         IF (ichh2 >= 2 .AND.  ivu == ivl .AND. ndej < 3) THEN
            IF (MOD(ju,2) == 1 .AND. MOD(ndej,2) == 1) THEN
               ch2h_r = 8.0e-11_dp * EXP(-3900.0_dp/ttry) / 3.0_dp
            ELSE
               ch2h_r = 8.0e-11_dp * EXP(-3900.0_dp/ttry)
            ENDIF
         ENDIF

         ch2h = ch2h_nr + xchh2 * ch2h_r

         ! He - H2
         gmm = q_h2_he_1(levl,levu) + q_h2_he_2(levl,levu) / tdd + q_h2_he_3(levl,levu) / tdd2
         ch2he = 10.0_dp**gmm

         ! pH2 - H2
         gmm = q_h2_ph2_1(levl,levu) + q_h2_ph2_2(levl,levu) / tdd + q_h2_ph2_3(levl,levu) / tdd2
         ch2ph2 = 10.0_dp**gmm

         ! oH2 - H2
         gmm = q_h2_oh2_1(levl,levu) + q_h2_oh2_2(levl,levu) / tdd + q_h2_oh2_3(levl,levu) / tdd2
         ch2oh2 = 10.0_dp**gmm

         ! c- Ortho to Para transfer with ions (Gerlich), only for v = 0
         ! IF (ivu == 0 .AND. ndej == 1) THEN
         IF (jl == ju-1) THEN
            cophp = gerlic(ju)
         ELSE
            cophp = 0.0_dp
         ENDIF

         ! Bringing it all back home
         c = ch2ph2 * ab(i_h2) * h2para + ch2oh2 * ab(i_h2) * h2orth &
           + ch2he * ab(i_he) + ch2h * ab(i_h)
         IF (i_hp /= 0) THEN
            c = c + cophp * ab(i_hp)
         ENDIF
         IF (i_h3p /= 0) THEN
            c = c + cophp * ab(i_h3p)
         ENDIF
         d = c * ctod

         eqcol(levl,levu) = eqcol(levl,levu) - c
         eqcol(levu,levu) = eqcol(levu,levu) + c
         eqcol(levu,levl) = eqcol(levu,levl) - d
         eqcol(levl,levl) = eqcol(levl,levl) + d
      ENDDO
   ENDDO

END SUBROUTINE COLH2V

END MODULE PXDR_EXCITH2
