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

MODULE PXDR_BILTHERM

  USE PXDR_CONSTANTES

  PRIVATE

  PUBLIC :: BILTHM, FROID, CHAUD, CHECK_THBAL

CONTAINS

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%
SUBROUTINE BILTHM (iopt, itn)
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%

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

   IMPLICIT NONE

   INTEGER, INTENT (IN)               :: iopt, itn

   REAL (KIND=dp)                     :: t_lim_do
   REAL (KIND=dp), PARAMETER          :: t_lim_up = 1.0e4_dp
   REAL (KIND=dp)                     :: eps = 0.9_dp
   REAL (KIND=dp)                     :: oldte, ta, tc
   REAL (KIND=dp)                     :: tcp, tap
   REAL (KIND=dp)                     :: btha, bthb, bthc
   REAL (KIND=dp)                     :: energi

   SAVE

   ! Computes new temperature thru thermal balance
   ! First 2 calls are used as initialisation
   ! TB is current "best" estimate of T
   ! TA and TC are lower and upper bounds at this iteration
   !    (ie, with current chemistry)
   ! TAP and TCP is a wider bounding with previous iterations
   ! one has always TA < TB < TC   et TAP < TB < TCP

   from_CT = 0
   t_lim_do = tcmb0

   IF (iopt > 0) THEN
      oldte = tgaz(iopt-1)
   ELSE
      oldte = tg_init
   ENDIF

   IF (itn == 1) THEN

      ta = temp
      tb(0) = temp
      tc = temp

      CALL LADENS(temp, iopt, itn)
      CALL FROID (temp, iopt)
      CALL CHAUD (temp, iopt, itn)
      bthb = chotot(iopt) - reftot(iopt)

      btha = bthb
      bthc = bthb

      tcp = MIN(temp * 1.1_dp, t_lim_up)
      tap = MAX(temp * 0.9_dp, t_lim_do)

      ! do we bound the solution ?
      DO
         IF (bthc > 0.0_dp .AND. tc < t_lim_up) THEN
            ta = tc
            btha = bthc
            tc = MIN(tc * 1.02_dp, t_lim_up)
            CALL LADENS(tc, iopt, itn)
            CALL FROID (tc, iopt)
            CALL CHAUD (tc, iopt, itn)
            bthc = chotot(iopt) - reftot(iopt)
            CYCLE
         ELSE IF (btha < 0.0_dp .AND. ta > t_lim_do) THEN
            tc = ta
            bthc = btha
            ta = MAX(ta * 0.98_dp, t_lim_do)
            CALL LADENS(ta, iopt, itn)
            CALL FROID (ta, iopt)
            CALL CHAUD (ta, iopt, itn)
            btha = chotot(iopt) - reftot(iopt)
            CYCLE
         ELSE
            EXIT
         ENDIF
      ENDDO

      tb(1) = 0.5_dp * (ta + tc)
      temp = tb(1)

      CALL LADENS(temp, iopt, itn)
      CALL FROID (temp, iopt)
      CALL CHAUD (temp, iopt, itn)
      bthb = chotot(iopt) - reftot(iopt)
      energi = chotot(iopt) + reftot(iopt)
      bthrel = bthb/energi

      tap = MIN(tap, ta)
      tap = MAX(tap, t_lim_do)
      tcp = MAX(tcp, tc)
      tcp = MIN(tcp, t_lim_up)

      WRITE (iscrn,*)
      WRITE (iscrn,*) '--------------- thermal balance --------------'
      WRITE (iscrn,"(2x,5f10.2,2x,1p,3e12.3)") &
             tap, ta, tb(itn), tc, tcp, btha, bthrel, bthc

   ELSE IF (itn >= 2 .AND. itn <= 5) THEN

      CALL LADENS(ta, iopt, itn)
      CALL FROID (ta, iopt)
      CALL CHAUD (ta, iopt, itn)
      btha = chotot(iopt) - reftot(iopt)

      CALL LADENS(tc, iopt, itn)
      CALL FROID (tc, iopt)
      CALL CHAUD (tc, iopt, itn)
      bthc = chotot(iopt) - reftot(iopt)

      CALL LADENS(temp, iopt, itn)
      CALL FROID (temp, iopt)
      CALL CHAUD (temp, iopt, itn)
      bthb = chotot(iopt) - reftot(iopt)

      ! update external bounds
      IF (bthb > 0.0_dp) THEN
         tap = MIN(tap, temp)
         tap = MAX(tap, t_lim_do)
      ELSE
         tcp = MAX(tcp, temp)
         tcp = MIN(tcp, t_lim_up)
      ENDIF

      DO
         IF (btha*bthc < 0.0_dp) THEN
            tb(itn) = ta - btha * (tc - ta) / (bthc - btha)
            EXIT
         ELSE IF (btha < 0.0_dp .AND. ta > oldte * 0.7_dp .AND. ta > t_lim_do) THEN
            ta = MAX(ta * 0.98_dp, t_lim_do)
            CALL LADENS(ta, iopt, itn)
            CALL FROID (ta, iopt)
            CALL CHAUD (ta, iopt, itn)
            btha = chotot(iopt) - reftot(iopt)
            CYCLE
         ELSE IF (bthc > 0.0_dp .AND. tc < oldte * 1.3_dp) THEN
            tc = MIN(tc * 1.02_dp, t_lim_up)
            CALL LADENS(tc, iopt, itn)
            CALL FROID (tc, iopt)
            CALL CHAUD (tc, iopt, itn)
            bthc = chotot(iopt) - reftot(iopt)
            CYCLE
         ELSE
            tb(itn) = 0.5_dp * (ta + tc)
            EXIT
         ENDIF
      ENDDO

      IF (tb(itn) <= t_lim_up .AND. tb(itn) >= t_lim_do) THEN
         CONTINUE
      ELSE
         IF (iopt > 0) THEN
            tb(itn) = tgaz(iopt-1)
         ELSE
            tb(itn) = tg_init
         ENDIF
      ENDIF

      temp = tb(itn)

      tap = MIN(tap, ta)
      tap = MAX(tap, t_lim_do)
      tcp = MAX(tcp, tc)
      tcp = MIN(tcp, t_lim_up)

      CALL LADENS(temp, iopt, itn)
      CALL FROID (temp, iopt)
      CALL CHAUD (temp, iopt, itn)
      bthb = chotot(iopt) - reftot(iopt)
      energi = chotot(iopt) + reftot(iopt)
      bthrel = bthb/energi

      WRITE (iscrn,*)
      WRITE (iscrn,*) '--------------- thermal balance --------------'
      WRITE (iscrn,"(2x,5f10.2,2x,1p,3e12.3)") &
             tap, ta, temp, tc, tcp, btha, bthrel, bthc

   ELSE

      IF (itn >= 30 .AND. MOD(itn,5) == 0) THEN
         ta = 0.5_dp * (tap + ta)
         tc = 0.5_dp * (tcp + tc)
      ENDIF

      ! general case
      CALL LADENS(ta, iopt, itn)
      CALL FROID (ta, iopt)
      CALL CHAUD (ta, iopt, itn)
      btha = chotot(iopt) - reftot(iopt)

      CALL LADENS(tc, iopt, itn)
      CALL FROID (tc, iopt)
      CALL CHAUD (tc, iopt, itn)
      bthc = chotot(iopt) - reftot(iopt)

      CALL LADENS(temp, iopt, itn)
      CALL FROID (temp, iopt)
      CALL CHAUD (temp, iopt, itn)
      bthb = chotot(iopt) - reftot(iopt)

      ! Update external bounds
      IF (bthb > 0.0_dp) THEN
         tap = MAX(tap, temp)
         tap = MAX(tap, t_lim_do)
      ELSE
         tcp = MIN(tcp, temp)
         tcp = MIN(tcp, t_lim_up)
      ENDIF

      IF (btha*bthc < 0.0_dp) THEN

         IF (bthb > 0.0_dp) THEN
            ta = temp
            btha = bthb
         ELSE
            tc = temp
            bthc = bthb
         ENDIF

         tb(itn) = ta - btha * (tc - ta) / (bthc - btha)

         ! Various tries to accelerate convergence
         tb(itn) = tb(itn-1) * (1.0_dp - eps) + eps * tb(itn)

         IF (tb(itn) > tb(itn-1)) THEN
            IF ((tb(itn-2) > tb(itn)) .AND. (tb(itn-3) < tb(itn-1))) THEN
               tb(itn) = 0.5_dp * (tb(itn) + tb(itn-1))
            ENDIF
         ELSE
            IF ((tb(itn-2) < tb(itn)) .AND. (tb(itn-3) > tb(itn-1))) THEN
               tb(itn) = 0.5_dp * (tb(itn) + tb(itn-1))
            ENDIF
         ENDIF

         IF ((tb(itn) < tb(itn-1)) .AND. (tb(itn-1) < tb(itn-2)) &
            .AND. (tb(itn-2) < tb(itn-3))) THEN
            tb(itn) = 0.5_dp * (tb(itn) + tap)
         ENDIF

         IF (tb(itn) <= t_lim_up .AND. tb(itn) >= t_lim_do) THEN
            CONTINUE
         ELSE
            IF (iopt /= 0) THEN
               tb(itn) = tgaz(iopt-1)
            ELSE
               PRINT *, " No thermal convergence at iopt = 0"
               WRITE(*,*) "tb = ", tb(itn), "   t_lim_do = ", t_lim_do, "   t_lim_up = ", t_lim_up
               STOP
            ENDIF
         ENDIF

         temp = tb(itn)

         IF (ta > temp) THEN
            ta = temp
         ENDIF
         IF (tc < temp) THEN
            tc = temp
         ENDIF

         CALL LADENS(ta, iopt, itn)
         CALL FROID (ta, iopt)
         CALL CHAUD (ta, iopt, itn)
         btha = chotot(iopt) - reftot(iopt)

         CALL LADENS(tc, iopt, itn)
         CALL FROID (tc, iopt)
         CALL CHAUD (tc, iopt, itn)
         bthc = chotot(iopt) - reftot(iopt)

         CALL LADENS(temp, iopt, itn)
         CALL FROID (temp, iopt)
         CALL CHAUD (temp, iopt, itn)
         bthb = chotot(iopt) - reftot(iopt)
         energi = chotot(iopt) + reftot(iopt)
         bthrel = bthb/energi

      ELSE

         tb(itn) = 0.5_dp * (tap + tcp)

         IF (tb(itn) > tb(itn-1)) THEN
            IF ((tb(itn-2) > tb(itn)) .AND. (tb(itn-3) < tb(itn-1))) THEN
               tb(itn) = 0.5_dp * (tb(itn) + tb(itn-1))
            ENDIF
         ELSE
            IF ((tb(itn-2) < tb(itn)) .AND. (tb(itn-3) > tb(itn-1))) THEN
               tb(itn) = 0.5_dp * (tb(itn) + tb(itn-1))
            ENDIF
         ENDIF

         IF ((tb(itn) < tb(itn-1)) .AND. (tb(itn-1) < tb(itn-2)) .AND. (tb(itn-2) < tb(itn-3))) THEN
            tb(itn) = 0.5_dp * (tb(itn) + tap)
         ENDIF

         IF (tb(itn) <= t_lim_up .AND. tb(itn) >= t_lim_do) THEN
            CONTINUE
         ELSE
            IF (iopt > 0) THEN
               tb(itn) = tgaz(iopt-1)
            ELSE
               tb(itn) = tg_init
            ENDIF
         ENDIF

         temp = tb(itn)

         IF (ta > temp) THEN
            ta = temp
         ENDIF
         IF (tc < temp) THEN
            tc = temp
         ENDIF

         ta = MAX(ta, tap)
         tc = MIN(tc, tcp)

         CALL LADENS(ta, iopt, itn)
         CALL FROID (ta, iopt)
         CALL CHAUD (ta, iopt, itn)
         btha = chotot(iopt) - reftot(iopt)

         CALL LADENS(tc, iopt, itn)
         CALL FROID (tc, iopt)
         CALL CHAUD (tc, iopt, itn)
         bthc = chotot(iopt) - reftot(iopt)

         CALL LADENS(temp, iopt, itn)
         CALL FROID (temp, iopt)
         CALL CHAUD (temp, iopt, itn)
         bthb = chotot(iopt) - reftot(iopt)
         energi = chotot(iopt) + reftot(iopt)
         bthrel = bthb/energi

         IF ((btha*bthc > 0.0_dp) .AND. (ABS(tcp - tap) < 0.01_dp)) THEN
            IF (bthb > 0.0_dp) THEN
               tcp = tcp * 1.1_dp
               tcp = MIN(tcp, t_lim_up)
            ELSE
               tap = tap * 0.9_dp
               tap = MAX(tap, t_lim_do)
            ENDIF
         ENDIF

      ENDIF

      WRITE (iscrn,*)
      WRITE (iscrn,*) '--------------- thermal balance --------------'
      WRITE (iscrn,"(2x,5f10.2,2x,1p,3e12.3)") &
             tap, ta, tb(itn), tc, tcp, btha, bthrel, bthc

   ENDIF

END SUBROUTINE BILTHM

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

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
SUBROUTINE LADENS(tabc, iopt, itn)
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

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

!   *** correction for pressure, 9 Aout 92: and 21 janv 94

   IMPLICIT NONE

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

   REAL (KIND=dp)                     :: hsurh2, divi, xdens
   INTEGER                            :: ii

   SAVE

   IF (ifisob == 2) THEN
      hsurh2 = ab(i_h) / ab(i_h2)
      divi = (1.0_dp + hsurh2) / (2.0_dp + hsurh2)
      xdens = (presse / tabc) / (abtot(5) + divi)

      DO ii = 1, nspec
         ab(ii) = ab(ii) * xdens / densh(iopt)
      ENDDO
      grcharge(iopt) = grcharge(iopt) * xdens / densh(iopt)

      densh(iopt) = xdens
   ENDIF

   ! 19 XI 2011 - JLB - Try computing chemistry with thermal balance
   IF (tabc > 200.0_dp .OR. from_CT == 1) THEN
      CALL CHIMIJ (tabc, iopt, itn)
      CALL MNEWT  (tabc, iopt, itn)
   ENDIF

END SUBROUTINE LADENS

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%
SUBROUTINE FROID (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
   USE PXDR_EXCITH2

   ! Excitation of various species
   ! and cooling induced
   IMPLICIT NONE
   INTEGER, INTENT (IN)                       :: iopt    ! position index in the cloud
   REAL (KIND=dp), INTENT (IN)                :: ttry    ! Temperature for try

   REAL (KIND=dp)                             :: ref, refr

   INTEGER                                    :: i, j, ii
   INTEGER                                    :: nused
   REAL (KIND=dp), DIMENSION(:), ALLOCATABLE  :: xreici

   REAL (KIND=dp)                             :: tempo1, refh2_o, xkrec
   INTEGER                                    :: lev2, lev1
   INTEGER                                    :: ideb, ifin, ir1, ir2

   ! FROID must be called before CHAUD for initialisation
   reftot(iopt) = 0.0_dp
   chotot(iopt) = 0.0_dp

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

   IF (icd_o < npo) THEN
      raptau = (tau(iopt) - tau_o(icd_o)) / dtau_o(icd_o+1)
   ELSE
      raptau = 0.0_dp
   ENDIF

   ! Compute cooling by selected lines
   ALLOCATE (creat(nspl))
   CALL FABDES (iopt)

   DO j = 1, nspl
      nused = spec_lin(j)%use
      ALLOCATE (xreici(nused))
      xreici = 0.0_dp
      CALL PREPAR (iopt, spec_lin(j), xreici, ttry, nused, ref, creat(j))
      CALL X_REL (spec_lin(j)%ind, xreici, nused, iopt)
      DEALLOCATE (xreici)

      IF (spec_lin(j)%ind == i_h2) THEN
         ! Compute H2 cooling from radiative transitions (old way)
         tempo1 = 0.0_dp
         ii = in_sp(i_h2)
         DO i = 1, spec_lin(ii)%ntr
            lev1 = spec_lin(ii)%iup(i)
            IF (lev1 > spec_lin(ii)%use) CYCLE
            lev2 = spec_lin(ii)%jlo(i)
            tempo1 = tempo1 + spec_lin(ii)%wlk(i) * (spec_lin(ii)%aij(i) - evrdbc(lev2,lev1)) &
                   * xreh2(lev1,iopt)
         ENDDO
         refh2_o = tempo1 * ab(i_h2) * xk
!        write (55,'(i5,1p,4e15.6)')  iopt, tau(iopt)*tautav, ttry, ref, refh2_o
! Use this block if you want to use old cooling for H2
! Do not forget to change "choh2g" accordingly ! (JLB - 20 IV 2010)
!!       IF (ifaf < 5) THEN
!           ref = refh2_o
!!       ENDIF

         ! Compute the purely collisional contribution of H2 (i.e., cooling part)
         ! This is for analysis only and may be skipped in standard use.
         ALLOCATE (xreici(nused))
         xreici = 0.0_dp
         ALLOCATE (eqcol(nused,nused))
         eqcol = 0.0_dp
         CALL COLH2V (ttry, iopt)
         CALL DETBAL1 (iopt, spec_lin(j), refr, xreici, nused)
         xreh2c(1:nused,iopt) = xreici(1:nused)
         f_h2hot(iopt) = 0.0_dp
         do i = 1, nused
            if (xreh2c(i,iopt) < xreh2(i,iopt)) then
               f_h2hot(iopt) = f_h2hot(iopt) + (xreh2(i,iopt) - xreh2c(i,iopt))
            endif
         enddo
         ! 5 XI 2016 - JLB
         ! This is probably wrong. We should consider the full collisional contribution - Suppress this line?
         ! refr = refr * (1.0_dp - f_h2hot(iopt))

         DEALLOCATE (eqcol)
         DEALLOCATE (xreici)
!        fichier = "H2_pop_2_"//TRIM(ADJUSTL(ii2c(iopt)))//".dat"
!        open (59, file=fichier,status="unknown")
!        write (59,'("#",1p,6e15.6)') &
!              tau(iopt), ttry, ab(i_h2), f_h2hot(iopt), ref, refr
!        do i = 1, nused
!           write (59,*) i, nvl_h2(i), njl_h2(i), xreh2(i,iopt), xreh2c(i,iopt)
!        enddo
!        close (59)

      ENDIF

      ! Compute OH cooling with "old" expression
!     IF (spec_lin(j)%ind == i_oh) THEN
!        ref = 1.0e-26_dp * ttry * EXP(-120.0_dp / ttry) * ab(i_oh) * (10.0_dp * ab(i_h) &
!            + ab(i_h2) / SQRT(2.0_dp))
!     ENDIF

!     ! JLB - 2 VIII 2014 - skip H3+ in thermal balance
!     IF (spec_lin(j)%ind == i_h3p) THEN
!        refh3p(iopt) = 0.0_dp
!        CYCLE
!     ENDIF
      IF (.NOT. ISNAN(ref) .AND. spec_lin(j)%ind /= i_h2) THEN
         CALL X_REF (spec_lin(j)%ind, ref, iopt)
         IF (ref < 0.0_dp) THEN
            chotot(iopt) = chotot(iopt) - ref
         ELSE
            reftot(iopt) = reftot(iopt) + ref
         ENDIF
      ENDIF
      IF (.NOT. ISNAN(ref) .AND. spec_lin(j)%ind == i_h2) THEN
         CALL X_REF (spec_lin(j)%ind, ref, iopt)
         rfjh2c(iopt) = refr
         ref = ref - refr
         IF (ref < 0.0_dp) THEN
            chotot(iopt) = chotot(iopt) - ref
         ELSE
            reftot(iopt) = reftot(iopt) + ref
         ENDIF
         IF (refr < 0.0_dp) THEN
            chotot(iopt) = chotot(iopt) - refr
         ELSE
            reftot(iopt) = reftot(iopt) + refr
         ENDIF
      ENDIF

   ENDDO
   DEALLOCATE (creat)

   !--------------------------------------------------------------
   ! COOLING : special cases
   !--------------------------------------------------------------

   !--- Cooling by Fe+ -------------------------------------------
   reffep(iopt) = 1.1e-22_dp * (EXP(-554.0_dp/ttry) &
                + 1.4_dp * EXP(-961.0_dp/ttry)) * ab(i_fep) * (ab(i_h) + ab(i_h2))
   ! Add electrons contribution (Dalgarno et Mc Cray)
   reffep(iopt) = reffep(iopt) + 1.1e-18_dp * ab(i_fep) * (EXP(-554._dp/ttry) &
                + 1.3_dp * EXP(-961._dp/ttry)) * ab(nspec) / SQRT(ttry)
   reftot(iopt) = reftot(iopt) + reffep(iopt)

   !--- Free-free cooling - JLB - 16 IV 2016 ---------------------
   ref_ff(iopt) = 1.42e-27_dp * SQRT(ttry) * ab(nspec) * ab(i_hp)
   reftot(iopt) = reftot(iopt) + ref_ff(iopt)

   !--- Cooling by recombination of atomic ions
   ! JLB - 18 IV 2016
   ! Chemistry thermal balance
   ideb = nh2for + ncrion + npsion + nasrad + nrest + nh2endo &
        + nphot_f + nphot_i + n3body + ncpart + ngsurf + ngphot &
        + ngads + ngneut + nggdes + ncrdes + nphdes + ngevap + ngchs + ngelri + 1
   ifin = ideb + nglass - 1
   xkrec = 0.0_dp
   DO i = ideb, ifin
      ir1 = react(i,1)
      ir2 = react(i,2)

      xkrec = xkrec + ab(ir1) * ab(ir2) * rate_chem(i) * (-de(i) * everg + 1.5_dp * ttry * xk)
   ENDDO
   refrec(iopt) = xkrec
   reftot(iopt) = reftot(iopt) + refrec(iopt)

   !--- Cooling by HD --------------------------------------------
   ! We use a simple prescription for cooling by HD only if HD excitation
   ! is not computed. If it is, then HD is treated in the general way
   ! HD cooling = 6E-11 * ab(i_h2) * 1.5E-5 * ab(i_h2) * 128.381 * 1.38E-16 * EXP(- 128.381 / ttry)
   IF (i_hd == 0 .OR. in_sp(i_hd) == 0) THEN
      refhd(iopt) = 1.59E-29 * ab(i_h2) * ab(i_h2) * EXP(- 128.381 / ttry)
      reftot(iopt) = reftot(iopt) + refhd(iopt)
   ENDIF

END SUBROUTINE FROID

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
SUBROUTINE PREPAR(iopt, spelin, xreici, ttry, nused, refr, fabchi)
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

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

   IMPLICIT NONE

   INTEGER, INTENT (IN)                             :: iopt
   TYPE (SPECTRA), INTENT (INOUT)                   :: spelin
   INTEGER, INTENT (IN)                             :: nused
   REAL (KIND=dp), INTENT (INOUT), DIMENSION(nused) :: xreici
   REAL (KIND=dp), INTENT (IN)                      :: ttry
   REAL (KIND=dp), INTENT (OUT)                     :: refr
   REAL (KIND=dp), INTENT (INOUT)                   :: fabchi

   INTEGER                                          :: i_spec
   INTEGER                                          :: k, kdeph
   INTEGER                                          :: nu_co
   INTEGER                                          :: j, ju
   REAL (KIND=dp)                                   :: deschi, rate
   REAL (KIND=dp)                                   :: sumetl
   REAL (KIND=dp), DIMENSION(:), ALLOCATABLE        :: bfact

   ! Total formation and destruction rates computed from MNEWT
   deschi = fabchi

   IF (i_co /= 0) THEN
      IF (in_sp(i_co) /= 0) THEN
         nu_co = spec_lin(in_sp(i_co))%use
      ELSE
         nu_co = 0
      ENDIF
   ENDIF

   ALLOCATE (eqrspe(nused,nused))
   eqrspe = 0.0_dp
   ALLOCATE (eqcol(nused,nused))
   eqcol = 0.0_dp
   ALLOCATE (create(nused))
   create = 0.0_dp
   ALLOCATE (remove(nused))
   remove = 0.0_dp

   ALLOCATE (bfact(nused))
    sumetl = 0.0_dp
    DO ju = 1, nused
       bfact(ju) = spelin%gst(ju) * EXP(-spelin%elk(ju) / ttry)
       sumetl = sumetl + bfact(ju)
    ENDDO
    bfact = bfact / sumetl

    !---------------------------------------------------------------------------
    ! EXCITATION - SPECIAL CASES
    ! Treat here special cases :
    !       1 - remove photodissociation from deschi if needed
    !       2 - radiative cascades (eqrspe)
    !---------------------------------------------------------------------------
    IF (i_hd /= 0) THEN
       kdeph = kdeph0 + 1
    ELSE
       kdeph = kdeph0
    ENDIF
    !...........................................................................
    ! H2 excitation
    !...........................................................................
    IF (spelin%ind == i_h2) THEN
       eqrspe = evrdbc
       CALL EQLH2V(ttry, iopt)
    !...........................................................................
    ! HD excitation
    !...........................................................................
    ELSE IF (spelin%ind == i_hd) THEN
       eqrspe = evrdhd
       CALL EQLHDV(iopt)
    !...........................................................................
    ! CO excitation
    !...........................................................................
    ELSE IF (spelin%ind == i_co) THEN
       kdeph = kdeph + 1
       deschi = deschi - pdiesp(kdeph,iopt) * ab(i_co)
       DO k = 1, nused
          eqrspe(k,k) = eqrco(k)
       ENDDO
       IF (F_CO_UV_pum == 1) THEN
          eqrspe = eqrspe + TRANSPOSE(UV_exc_CO)
       ENDIF
       IF (F_CO_CH_pum == 0) THEN
          create(:) = fabchi * bfact(:)
       ELSE
          ! Use a fraction of C + OH -> CO + H and HCO+ + e- -> CO + H in CO formation excitation.
          create(:) = 0.0_dp
          rate = xmatk(i_co)%fdt(k_fco_c_oh)%k * ab(i_c) * ab(i_oh)
          create(:) = create(:) + rate * bfact_co(:)
          fabchi = fabchi - rate

          ! Use all dissociative recombination reactions, and not only HCO+ + e-
          DO j = 1, xmatk(i_co)%nbt
             IF (xmatk(i_co)%fdt(j)%it /= 4 .OR. xmatk(i_co)%fdt(j)%r2 /= nspec) CYCLE
             rate = xmatk(i_co)%fdt(j)%k * ab(xmatk(i_co)%fdt(j)%r1) * ab(nspec)
             create(:) = create(:) + rate * bfact_co(:)
             fabchi = fabchi - rate
          ENDDO

          create(:) = create(:) + fabchi * bfact(:)
       ENDIF
       remove = deschi
    !...........................................................................
    ! 13CO excitation
    !...........................................................................
    ELSE IF (spelin%ind == j_c13o) THEN
       IF (i_c13o == 0) THEN
          kdeph = kdeph + 1
          deschi = deschi - pdiesp(kdeph,iopt) * ab(i_co) / r_c13
          IF (nused <= nu_co) THEN
             DO k = 1, nused
                eqrspe(k,k) = eqrco(k)
             ENDDO
          ELSE IF (nused > nu_co) THEN
             DO k = 1, nu_co
                eqrspe(k,k) = eqrco(k)
             ENDDO
             DO k = nu_co+1, nused
                eqrspe(k,k) = 0.0_dp
             ENDDO
          ENDIF
       ELSE
          kdeph = kdeph + 2
          deschi = deschi - pdiesp(kdeph,iopt) * ab(i_c13o)
          DO k = 1, nused
             eqrspe(k,k) = eqrc13o(k)
          ENDDO
       ENDIF
       create(:) = fabchi * bfact(:)
       remove = deschi
    !...........................................................................
    ! C18O excitation
    !...........................................................................
    ELSE IF (spelin%ind == j_co18) THEN
       IF (i_co18 == 0) THEN
          kdeph = kdeph + 1
          deschi = deschi - pdiesp(kdeph,iopt) * ab(i_co) / r_o18
          IF (nused <= nu_co) THEN
             DO k = 1, nused
                eqrspe(k,k) = eqrco(k)
             ENDDO
          ELSE IF (nused > nu_co) THEN
             DO k = 1, nu_co
                eqrspe(k,k) = eqrco(k)
             ENDDO
             DO k = nu_co+1, nused
                eqrspe(k,k) = 0.0_dp
             ENDDO
          ENDIF
       ELSE
          kdeph = kdeph + 3
          deschi = deschi - pdiesp(kdeph,iopt) * ab(i_co18)
          DO k = 1, nused
             eqrspe(k,k) = eqrco18(k)
          ENDDO
       ENDIF
       create(:) = fabchi * bfact(:)
       remove = deschi
    !...........................................................................
    ! 13C18O excitation
    !...........................................................................
    ELSE IF (spelin%ind == j_c13o18) THEN
       IF (i_c13o18 == 0) THEN
          kdeph = kdeph + 1
          deschi = deschi - pdiesp(kdeph,iopt) * ab(i_co) / (r_c13 * r_o18)
          IF (nused <= nu_co) THEN
             DO k = 1, nused
                eqrspe(k,k) = eqrco(k)
             ENDDO
          ELSE IF (nused > nu_co) THEN
             DO k = 1, nu_co
                eqrspe(k,k) = eqrco(k)
             ENDDO
             DO k = nu_co+1, nused
                eqrspe(k,k) = 0.0_dp
             ENDDO
          ENDIF
       ELSE
          kdeph = kdeph + 4
          deschi = deschi - pdiesp(kdeph,iopt) * ab(i_c13o18)
          DO k = 1, nused
             eqrspe(k,k) = eqrc13o18(k)
          ENDDO
       ENDIF
       create(:) = fabchi * bfact(:)
       remove = deschi
    !...........................................................................
    ! H3+ excitation
    !...........................................................................
    ELSE IF (spelin%ind == i_h3p .AND. F_H3p_CH_PUM == 1) THEN
       eqrspe(:,:) = 0.0_dp
       create(:)   = 0.0_dp
       ! H2+ + H2 reaction excite H3+ at formation
       rate      = xmatk(i_h3p)%fdt(k_fh3p_h2p_h2)%k * ab(i_h2p) * ab(i_h2)
       create(:) = create(:) + rate * poph3p(:)
       ! Other H3+ reactions :
       fabchi    = fabchi - rate
       create(:) = create(:) + fabchi * bfact(:)

       remove(:) = deschi
    !...........................................................................
    ! O excitation
    !...........................................................................
    ELSE IF (spelin%ind == i_o .AND. F_Oat_CH_PUM == 1) THEN
       eqrspe(:,:) = 0.0_dp
       create(:)   = 0.0_dp
       ! OH + photon excite O in 1D state
       rate      = xmatk(i_o)%fdt(k_foat_oh_phot)%k * ab(i_o)
       create(:) = create(:) + rate * popoat(:)
       ! Other reactions that form O:
       fabchi    = fabchi - rate
       create(:) = create(:) + fabchi * bfact(:)

       remove(:) = deschi

    !...........................................................................
    ! Standard cases
    !...........................................................................
    ELSE
       eqrspe = 0.0_dp
       create(:) = fabchi * bfact(:)
       remove = deschi
    ENDIF

    !---------------------------------------------------------------------------
    ! Fill all matrices to compute excitation
    !---------------------------------------------------------------------------
    i_spec = spelin%ind
    CALL COLSPE (ttry, i_spec, nused, iopt)

    CALL DETBAL (iopt, spelin, refr, xreici, nused)

    DEALLOCATE (eqrspe)
    DEALLOCATE (eqcol)
    DEALLOCATE (create)
    DEALLOCATE (remove)
    DEALLOCATE (bfact)

END SUBROUTINE PREPAR

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
SUBROUTINE DETBAL (iopt, spelin, refr, xreici, nused)
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

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

   IMPLICIT NONE

   INTEGER,        INTENT (IN)                     :: iopt
   TYPE (SPECTRA), INTENT (IN)                     :: spelin
   INTEGER,        INTENT (IN)                     :: nused
   REAL (KIND=dp), INTENT (OUT)                    :: refr
   REAL (KIND=dp), INTENT (OUT), DIMENSION(nused)  :: xreici

   REAL (KIND=dp), DIMENSION(:,:), ALLOCATABLE     :: eqmat
   REAL (KIND=dp), DIMENSION(:,:), ALLOCATABLE     :: eqrad
   REAL (KIND=dp), DIMENSION(:,:), ALLOCATABLE     :: bbab
   INTEGER       , DIMENSION(:),   ALLOCATABLE     :: indx

   REAL (KIND=dp)                                  :: rien

   REAL (KIND=dp)                                  :: on
   REAL (KIND=dp)                                  :: bet_ijl, bet_ijr
   REAL (KIND=dp)                                  :: jintD
   INTEGER                                         :: j_ind
   REAL (KIND=dp)                                  :: abici
   INTEGER                                         :: ju, jl, i
   REAL (KIND=dp)                                  :: gusgl
   REAL (KIND=dp)                                  :: xx_ij
   REAL (KIND=dp)                                  :: yy_ij
   REAL (KIND=dp)                                  :: dumy
   REAL (KIND=dp)                                  :: pir, puv
!  REAL (KIND=dp)                                  :: bb_int        ! Used for comparison with Poelman and Spaans
!  REAL (KIND=dp)                                  :: tauDu
!  REAL (KIND=dp)                                  :: T_0dust

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

   rien  = 1.0e-300_dp

   ! Computes detailed balance
   ALLOCATE (eqmat(nused,nused))
   ALLOCATE (eqrad(nused,nused))
   ALLOCATE (indx(nused))
   ALLOCATE (bbab(nused,1))
   ALLOCATE (bbax(nused,1))

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

   ! T_0dust: Energy (in K) corresponding to 100 micron
   ! T_0dust = hcsurk / (100.0_dp * 1.0e-4_dp)
   eqmat = 0.0_dp
   eqrad = 0.0_dp

   ! Very progressive set up of line opacities
!  IF (ifaf < 3) THEN
!     on = 0.0_dp
!  ELSE IF (ifaf == 3) THEN
!     on = 1.0e-4_dp
!  ELSE IF (ifaf == 4) THEN
!     on = sqrt(10.0_dp) * 1.0e-4_dp
!  ELSE IF (ifaf == 5) THEN
!     on = 1.0e-3_dp
!  ELSE IF (ifaf == 6) THEN
!     on = sqrt(10.0_dp) * 1.0e-3_dp
!  ELSE IF (ifaf == 7) THEN
!     on = 1.0e-2_dp
!  ELSE IF (ifaf == 8) THEN
!     on = sqrt(10.0_dp) * 1.0e-2_dp
!  ELSE IF (ifaf == 9) THEN
!     on = 1.0e-1_dp
!  ELSE IF (ifaf == 10) THEN
!     on = sqrt(10.0_dp) * 1.0e-1_dp
!  ELSE
!     on = 1.0_dp
!  ENDIF

   ! More agressive progression
   IF (ifaf < 3) THEN
      on = 0.0_dp
   ELSE IF (ifaf == 3) THEN
      on = 1.0e-4_dp
   ELSE IF (ifaf == 4) THEN
      on = 1.0e-3_dp
   ELSE IF (ifaf == 5) THEN
      on = 1.0e-2_dp
   ELSE IF (ifaf == 6) THEN
      on = 1.0e-1_dp
   ELSE
      on = 1.0_dp
   ENDIF

   IF (F_LINE_TRSF == 0) THEN
      on = 0.0_dp
   ENDIF

   DO i = 1, spelin%ntr
      j_ind = spelin%ind
      ! WARNING: j_ind is index of species, except for 13CO, C18O and 13C18O
      ! when they are not explicitly included in the chemistry
      IF (j_ind == nspec + 1) THEN
         abici = ab(i_co) / r_c13
      ELSE IF (j_ind == nspec + 2) THEN
         abici = ab(i_co) / r_o18
      ELSE IF (j_ind == nspec + 3) THEN
         abici = ab(i_co) / (r_c13 * r_o18)
      ELSE
         abici = ab(j_ind)
      ENDIF
      ju = spelin%iup(i)
      IF (ju > nused) CYCLE
      jl = spelin%jlo(i)
      gusgl = spelin%gst(ju) / spelin%gst(jl)

      IF (raptau > 0.0_dp) THEN
         bet_ijl = spelin%bel(i,icd_o) + raptau * (spelin%bel(i,icd_o+1) - spelin%bel(i,icd_o))
         bet_ijr = spelin%ber(i,icd_o) + raptau * (spelin%ber(i,icd_o+1) - spelin%ber(i,icd_o))
         jintD   = spelin%jiD(i,icd_o) + raptau * (spelin%jiD(i,icd_o+1) - spelin%jiD(i,icd_o))
      ELSE
         bet_ijl = spelin%bel(i,icd_o) ! escape probability left
         bet_ijr = spelin%ber(i,icd_o) ! escape probability right
         jintD   = spelin%jiD(i,icd_o) ! dust mean intensity without dimensions
      ENDIF

      !---- Sum contributions to the mean intensity and create the radiative matrix
      ! J = J_dust + J_line + J_ext_l + J_ext_r
      ! The various terms have no dimensions (jintD, spelin%exl, spelin%exr)
      ! * dust contribution
      IF (on == 0.0_dp) THEN
         yy_ij = 0.0_dp
      ELSE
         yy_ij = on * jintD
      ENDIF

      ! JLB - 8 VII 2016 - Add CMB contribution, with escape probability
      yy_ij = yy_ij + (bet_ijl + bet_ijr) / (EXPBOR(spelin%wlk(i) / tcmb) - 1.0_dp)

      yy_ij = yy_ij + (bet_ijl * spelin%exl(i) + bet_ijr * spelin%exr(i))
      xx_ij = (bet_ijl + bet_ijr) + yy_ij
      xx_ij = xx_ij * spelin%aij(i)
      yy_ij = yy_ij * spelin%aij(i) * gusgl

      eqrad(ju,ju) = eqrad(ju,ju) + xx_ij
      eqrad(ju,jl) = eqrad(ju,jl) - yy_ij
      eqrad(jl,jl) = eqrad(jl,jl) + yy_ij
      eqrad(jl,ju) = eqrad(jl,ju) - xx_ij
   ENDDO

   ! Used for debug. Do not remove
   !IF (j_ind == i_h2) THEN
   !   eq_spe%qua = eqrad(1:nld,1:nld)
   !   eq_spe%col = eqcol(1:nld,1:nld)
   !   eq_spe%cas = eqrspe(1:nld,1:nld)
   !   eq_spe%des = remove(1:nld)
   !   eq_spe%cre = create(1:nld)
   !   eq_spe%ref = 0.0_dp
   !   eq_spe%pir = 0.0_dp
   !   eq_spe%puv = 0.0_dp
   !ENDIF

   DO jl = 1, nused
      DO ju = 1, nused
         eqmat(ju,jl) = (eqrad(ju,jl) + eqcol(ju,jl) + eqrspe(ju,jl)) * abici
      ENDDO
   ENDDO
   DO ju = 1, nused
      ! Check sign of remove (JLB)
      eqmat(ju,ju) = eqmat(ju,ju) + remove(ju)
      bbab(ju,1) = create(ju)
   ENDDO

   ! USE LAPACK
   ! 3 II 2014 - Try using a faster routine (DGETRS)
   IF (F_STABLE >= 1) THEN
      CALL DGESVX (FACT, TRANS, nused, nrhs, eqmat, nused, AF, nused, &
                  indx, EQUED, R, C, bbab, nused, bbax, nused, RCOND, FERR, BERR, WORK, IWORK, INFO)
   ELSE
      CALL DGETRF (nused, nused, eqmat, nused, indx, INFO)
      CALL DGETRS (TRANS, nused, nrhs, eqmat, nused, indx, bbab, nused, INFO)
      bbax = bbab
   ENDIF

   dumy = 0.0_dp
   DO ju = 1, nused
      IF (bbax(ju,1) <= 0.0_dp) THEN
         bbax(ju,1) = rien
      ENDIF
      dumy = dumy + bbax(ju,1)
   ENDDO

   DO ju = 1, nused
      bbax(ju,1) = bbax(ju,1) / dumy
   ENDDO
   !IF (ABS(dumy-1.0_dp) > 1.0e-2_dp) then
   !   WRITE(iscrn,*) " "
   !   WRITE(iscrn,*) "Bad population conservation for : ", spelin%spHname
   !   WRITE(iscrn,*) "* Sum of normalized populations : ", dumy
   !   WRITE(iscrn,*) "* Difference to 1.0 (Sum - 1.0) : ", dumy - 1.0_dp
   !ENDIF

   dumy = ABS(dumy - 1.0_dp)
   DO ju = 1, nused
      xreici(ju) = bbax(ju,1)
   ENDDO

   !IF (j_ind == i_h2) THEN
   !   eq_spe%pop = xreici(1:nld)
   !   DO ju = 2, nld
   !      refr = 0.0_dp
   !      pir = 0.0_dp
   !      puv = 0.0_dp
   !      DO jl = 1, ju-1
   !         refr = refr + (eqcol(ju,jl) * bbax(jl,1) - eqcol(jl,ju) * bbax(ju,1)) &
   !              * xk * (spelin%elk(ju) - spelin%elk(jl))
   !         pir = pir + bbax(jl,1) * eqrad(ju,jl)
   !         puv = puv + bbax(jl,1) * eqrspe(ju,jl)
   !      ENDDO
   !      eq_spe%ref(ju) = refr
   !      eq_spe%pir(ju) = -pir
   !      eq_spe%puv(ju) = -puv
   !   ENDDO
   !ENDIF

   ! Remember that off-diagonal elements of eqcol are negative!
   refr = 0.0_dp
   DO jl = 1, nused
      DO ju = 1, nused
         refr = refr - eqcol(ju,jl) * bbax(jl,1) * xk * (spelin%elk(ju) - spelin%elk(jl))
      ENDDO
   ENDDO
   refr = refr * abici

   DEALLOCATE (eqmat)
   DEALLOCATE (eqrad)
   DEALLOCATE (indx)
   DEALLOCATE (bbab)
   DEALLOCATE (bbax)

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

END SUBROUTINE DETBAL

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
SUBROUTINE DETBAL1 (iopt, spelin, refr, xreici, nused)
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

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

   IMPLICIT NONE

   INTEGER,        INTENT (IN)                     :: iopt
   TYPE (SPECTRA), INTENT (IN)                     :: spelin
   INTEGER,        INTENT (IN)                     :: nused
   REAL (KIND=dp), INTENT (OUT)                    :: refr
   REAL (KIND=dp), INTENT (OUT), DIMENSION(nused)  :: xreici

   REAL (KIND=dp), DIMENSION(:,:), ALLOCATABLE     :: eqmat
   REAL (KIND=dp), DIMENSION(:,:), ALLOCATABLE     :: eqrad
   REAL (KIND=dp), DIMENSION(:,:), ALLOCATABLE     :: bbab
   INTEGER       , DIMENSION(:),   ALLOCATABLE     :: indx

   REAL (KIND=dp)                                  :: rien

   REAL (KIND=dp)                                  :: on
   REAL (KIND=dp)                                  :: bet_ijl, bet_ijr
   REAL (KIND=dp)                                  :: jintD
   INTEGER                                         :: j_ind
   INTEGER                                         :: ju, jl, i
   REAL (KIND=dp)                                  :: gusgl
   REAL (KIND=dp)                                  :: xx_ij
   REAL (KIND=dp)                                  :: yy_ij
   REAL (KIND=dp)                                  :: dumy

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

   rien  = 1.0e-300_dp

   ! Computes detailed balance
   ALLOCATE (eqmat(nused,nused))
   ALLOCATE (eqrad(nused,nused))
   ALLOCATE (indx(nused))
   ALLOCATE (bbab(nused,1))
   ALLOCATE (bbax(nused,1))

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

   eqmat = 0.0_dp
   eqrad = 0.0_dp

   IF (ifaf < 3) THEN
      on = 0.0_dp
   ELSE IF (ifaf == 3) THEN
      on = 1.0e-4_dp
   ELSE IF (ifaf == 4) THEN
      on = 1.0e-3_dp
   ELSE IF (ifaf == 5) THEN
      on = 1.0e-2_dp
   ELSE IF (ifaf == 6) THEN
      on = 1.0e-1_dp
   ELSE
      on = 1.0_dp
   ENDIF

   DO i = 1, spelin%ntr
      j_ind = spelin%ind
      ju = spelin%iup(i)
      IF (ju > nused) CYCLE
      jl = spelin%jlo(i)
      gusgl = spelin%gst(ju) / spelin%gst(jl)

      IF (raptau > 0.0_dp) THEN
         bet_ijl = spelin%bel(i,icd_o) + raptau * (spelin%bel(i,icd_o+1) - spelin%bel(i,icd_o))
         bet_ijr = spelin%ber(i,icd_o) + raptau * (spelin%ber(i,icd_o+1) - spelin%ber(i,icd_o))
         jintD   = spelin%jiD(i,icd_o) + raptau * (spelin%jiD(i,icd_o+1) - spelin%jiD(i,icd_o))
      ELSE
         bet_ijl = spelin%bel(i,icd_o) ! escape probability left
         bet_ijr = spelin%ber(i,icd_o) ! escape probability right
         jintD   = spelin%jiD(i,icd_o) ! dust mean intensity without dimensions
      ENDIF

      !---- Sum contributions to the mean intensity and create the radiative matrix
      ! J = J_dust + J_line + J_ext_l + J_ext_r
      ! The various terms have no dimensions (jintD, spelin%exl, spelin%exr)
      ! * dust contribution
      IF (on == 0.0_dp) THEN
         yy_ij = 0.0_dp
      ELSE
         yy_ij = on * jintD
      ENDIF
      yy_ij = yy_ij + (bet_ijl * spelin%exl(i) + bet_ijr * spelin%exr(i))
      xx_ij = (bet_ijl + bet_ijr) + yy_ij
      xx_ij = xx_ij * spelin%aij(i)
      yy_ij = yy_ij * spelin%aij(i) * gusgl

      eqrad(ju,ju) = eqrad(ju,ju) + xx_ij
      eqrad(ju,jl) = eqrad(ju,jl) - yy_ij
      eqrad(jl,jl) = eqrad(jl,jl) + yy_ij
      eqrad(jl,ju) = eqrad(jl,ju) - xx_ij
   ENDDO

   DO jl = 1, nused
      DO ju = 1, nused
         eqmat(ju,jl) = (eqrad(ju,jl) + eqcol(ju,jl)) * ab(j_ind)
      ENDDO
   ENDDO
   bbab(:,1) = 0.0_dp
   eqmat(nused,:) = 1.0_dp
   bbab(nused,1) = 1.0_dp

   ! USE LAPACK
   ! 3 II 2014 - Try using a faster routine (DGETRS)
   IF (F_STABLE >= 1) THEN
      CALL DGESVX (FACT, TRANS, nused, nrhs, eqmat, nused, AF, nused, &
                  indx, EQUED, R, C, bbab, nused, bbax, nused, RCOND, FERR, BERR, WORK, IWORK, INFO)
   ELSE
      CALL DGETRF (nused, nused, eqmat, nused, indx, INFO)
      CALL DGETRS (TRANS, nused, nrhs, eqmat, nused, indx, bbab, nused, INFO)
      bbax = bbab
   ENDIF

   dumy = 0.0_dp
   DO ju = 1, nused
      IF (bbax(ju,1) <= 0.0_dp) THEN
         bbax(ju,1) = rien
      ENDIF
      dumy = dumy + bbax(ju,1)
   ENDDO

   DO ju = 1, nused
      bbax(ju,1) = bbax(ju,1) / dumy
   ENDDO

   dumy = ABS(dumy - 1.0_dp)
   DO ju = 1, nused
      xreici(ju) = bbax(ju,1)
   ENDDO

   ! Remember that off-diagonal elements of eqcol are negative!
   refr = 0.0_dp
   DO jl = 1, nused
      DO ju = 1, nused
         refr = refr - eqcol(ju,jl) * bbax(jl,1) * xk * (spelin%elk(ju) - spelin%elk(jl))
      ENDDO
   ENDDO
   refr = refr * ab(j_ind)

   DEALLOCATE (eqmat)
   DEALLOCATE (eqrad)
   DEALLOCATE (indx)
   DEALLOCATE (bbab)
   DEALLOCATE (bbax)

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

END SUBROUTINE DETBAL1

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
SUBROUTINE COLSPE (ttry, i_spec, nused, iopt)
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

   USE PXDR_FLAGS
   USE PXDR_CONSTANTES
   USE PXDR_CHEM_DATA
   USE PXDR_EXCITH2
   USE PXDR_EXCITHD
   USE PXDR_COLSPE

   IMPLICIT NONE

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

   IF (i_spec == i_h) THEN
      CALL COLHAT (ttry, nused)
   ELSE IF (i_spec == i_h2) THEN
      CALL COLH2V (ttry, iopt)
   ELSE IF (i_spec == i_hd) THEN
      CALL COLHD (ttry)
   ELSE IF (i_spec == i_co) THEN
      CALL COLCO0 (ttry, nused)
!     CALL COLCO0N (ttry, nused)
   ELSE IF (i_spec == j_c13o) THEN
      CALL COLCO1 (ttry, nused)
!     CALL COLCO1N (ttry, nused)
   ELSE IF (i_spec == j_co18) THEN
      CALL COLCO2 (ttry, nused)
!     CALL COLCO2N (ttry, nused)
   ELSE IF (i_spec == j_c13o18) THEN
      CALL COLCO3 (ttry, nused)
!     CALL COLCO3N (ttry, nused)
   ELSE IF (i_spec == i_c) THEN
      CALL COLCAT (ttry, nused)
   ELSE IF (i_spec == i_n) THEN
      CALL COLNAT (ttry, nused)
   ELSE IF (i_spec == i_o) THEN
      CALL COLOAT (ttry, nused)
   ELSE IF (i_spec == i_s) THEN
      CALL COLSAT (ttry, nused)
   ELSE IF (i_spec == i_si) THEN
      CALL COLSiAT (ttry, nused)
   ELSE IF (i_spec == i_cp) THEN
      CALL COLCPL (ttry, nused)
   ELSE IF (i_spec == i_cpp) THEN
      CALL COLCPP (ttry, nused)
   ELSE IF (i_spec == i_np) THEN
      CALL COLNPL (ttry, nused)
   ELSE IF (i_spec == i_npp) THEN
      CALL COLNPP (ttry, nused)
   ELSE IF (i_spec == i_op) THEN
      CALL COLOPL (ttry, nused)
   ELSE IF (i_spec == i_opp) THEN
      CALL COLOPP (ttry, nused)
   ELSE IF (i_spec == i_sp) THEN
      CALL COLSPL (ttry, nused)
   ELSE IF (i_spec == i_spp) THEN
      CALL COLSPP (ttry, nused)
   ELSE IF (i_spec == i_sip) THEN
      CALL COLSIP (ttry, nused)
   ELSE IF (i_spec == i_nep) THEN
      CALL COLNEP (ttry, nused)
   ELSE IF (i_spec == i_nepp) THEN
      CALL COLNEPP (ttry, nused)
   ELSE IF (i_spec == i_cs) THEN
      CALL COLCS0 (ttry, nused)
   ELSE IF (i_spec == i_hcop) THEN
      CALL COLHCOP (ttry, nused)
   ELSE IF (i_spec == i_chp) THEN
      CALL COLCHP (ttry, nused)
   ELSE IF (i_spec == i_hcn) THEN
      CALL COLHCN (ttry, nused)
   ELSE IF (i_spec == i_oh) THEN
      CALL COLOH (ttry, nused)
   ELSE IF (i_spec == i_h2o) THEN
      CALL COLH2O (ttry, nused)
   ELSE IF (i_spec == i_h3p) THEN
      CALL COLH3P (ttry, nused, iopt)
   ELSE IF (i_spec == i_o2) THEN
      CALL COLO2 (ttry, nused)
   ELSE IF (i_spec == i_ohp) THEN
      CALL COLOHP (ttry, nused)
   ELSE IF (i_spec == i_shp) THEN
      CALL COLSHP (ttry, nused)
   ELSE IF (i_spec == i_arhp) THEN
      CALL COLARHP (ttry, nused)
   ENDIF

END SUBROUTINE COLSPE

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
SUBROUTINE X_REL (ind, xre, nused, iopt)
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

   USE PXDR_FLAGS
   USE PXDR_CONSTANTES
   USE PXDR_CHEM_DATA
   USE PXDR_PROFIL
   USE PXDR_STR_DATA

   IMPLICIT NONE

   INTEGER, INTENT (IN)                              :: ind
   INTEGER, INTENT (IN)                              :: nused
   INTEGER, INTENT (IN)                              :: iopt
   REAL (KIND=dp), INTENT (INOUT), DIMENSION (nused) :: xre

   INTEGER                                           :: lev, jj

   ! Prevent underflow
   DO jj = 1, nused
      xre(jj) = MAX(xre(jj), 1.0e-60_dp)
   ENDDO

   IF (ind == i_h) THEN
      xrehat(1:nused,iopt) = xre(:)
   ELSE IF (ind == i_h2) THEN
      h2para = 0.0_dp
      h2orth = 0.0_dp
      DO lev = 1, nused
         jj = njl_h2(lev)
         xreh2(lev,iopt) = xre(lev)
         IF (MOD(jj,2) == 0) THEN
            h2para = h2para + xre(lev)
         ELSE
            h2orth = h2orth + xre(lev)
         ENDIF
      ENDDO
   ELSE IF (ind == i_hd) THEN
      xrehd(1:nused,iopt) = xre(:)
   ELSE IF (ind == i_c) THEN
      xrecat(1:nused,iopt) = xre(:)
   ELSE IF (ind == i_n) THEN
      xrenat(1:nused,iopt) = xre(:)
   ELSE IF (ind == i_o) THEN
      xreoat(1:nused,iopt) = xre(:)
   ELSE IF (ind == i_s) THEN
      xresat(1:nused,iopt) = xre(:)
   ELSE IF (ind == i_si) THEN
      xresia(1:nused,iopt) = xre(:)
   ELSE IF (ind == i_cp) THEN
      xrecpl(1:nused,iopt) = xre(:)
   ELSE IF (ind == i_cpp) THEN
      xrecpp(1:nused,iopt) = xre(:)
   ELSE IF (ind == i_np) THEN
      xrenpl(1:nused,iopt) = xre(:)
   ELSE IF (ind == i_npp) THEN
      xrenpp(1:nused,iopt) = xre(:)
   ELSE IF (ind == i_op) THEN
      xreopl(1:nused,iopt) = xre(:)
   ELSE IF (ind == i_opp) THEN
      xreopp(1:nused,iopt) = xre(:)
   ELSE IF (ind == i_sp) THEN
      xrespl(1:nused,iopt) = xre(:)
   ELSE IF (ind == i_spp) THEN
      xrespp(1:nused,iopt) = xre(:)
   ELSE IF (ind == i_sip) THEN
      xresip(1:nused,iopt) = xre(:)
   ELSE IF (ind == i_nep) THEN
      xrenep(1:nused,iopt) = xre(:)
   ELSE IF (ind == i_nepp) THEN
      xrenepp(1:nused,iopt) = xre(:)
   ELSE IF (ind == i_co) THEN
      xreco(1:nused,iopt) = xre(:)
   ELSE IF (ind == j_c13o) THEN
      xrec13o(1:nused,iopt) = xre(:)
   ELSE IF (ind == j_co18) THEN
      xreco18(1:nused,iopt) = xre(:)
   ELSE IF (ind == j_c13o18) THEN
      xrec13o18(1:nused,iopt) = xre(:)
   ELSE IF (ind == i_cs) THEN
      xrecs0(1:nused,iopt) = xre(:)
   ELSE IF (ind == i_hcop) THEN
      xrehcop(1:nused,iopt) = xre(:)
   ELSE IF (ind == i_chp) THEN
      xrechp(1:nused,iopt) = xre(:)
   ELSE IF (ind == i_hcn) THEN
      xrehcn(1:nused,iopt) = xre(:)
   ELSE IF (ind == i_oh) THEN
      xreoh(1:nused,iopt) = xre(:)
   ELSE IF (ind == i_h2o) THEN
      xreh2o(1:nused,iopt) = xre(:)
   ELSE IF (ind == i_h3p) THEN
      xreh3p(1:nused,iopt) = xre(:)
   ELSE IF (ind == i_o2) THEN
      xreo2(1:nused,iopt) = xre(:)
   ELSE IF (ind == i_ohp) THEN
      xreohp(1:nused,iopt) = xre(:)
   ELSE IF (ind == i_shp) THEN
      xreshp(1:nused,iopt) = xre(:)
   ELSE IF (ind == i_arhp) THEN
      xrearhp(1:nused,iopt) = xre(:)
   ENDIF

END SUBROUTINE X_REL

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
SUBROUTINE X_REF (ind, ref, iopt)
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

   USE PXDR_FLAGS
   USE PXDR_CONSTANTES
   USE PXDR_CHEM_DATA
   USE PXDR_PROFIL
   USE PXDR_STR_DATA

   IMPLICIT NONE

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

   IF (ind == i_h) THEN
      refhat(iopt) = ref
   ELSE IF (ind == i_h2) THEN
      rfjh2t(iopt) = ref
   ELSE IF (ind == i_hd) THEN
      rfjhdt(iopt) = ref
   ELSE IF (ind == i_c) THEN
      refcat(iopt) = ref
   ELSE IF (ind == i_n) THEN
      refnat(iopt) = ref
   ELSE IF (ind == i_o) THEN
      refoat(iopt) = ref
   ELSE IF (ind == i_s) THEN
      refsat(iopt) = ref
   ELSE IF (ind == i_si) THEN
      refsia(iopt) = ref
   ELSE IF (ind == i_cp) THEN
      refcpl(iopt) = ref
   ELSE IF (ind == i_cpp) THEN
      refcpp(iopt) = ref
   ELSE IF (ind == i_np) THEN
      refnpl(iopt) = ref
   ELSE IF (ind == i_npp) THEN
      refnpp(iopt) = ref
   ELSE IF (ind == i_op) THEN
      refopl(iopt) = ref
   ELSE IF (ind == i_opp) THEN
      refopp(iopt) = ref
   ELSE IF (ind == i_sp) THEN
      refspl(iopt) = ref
   ELSE IF (ind == i_spp) THEN
      refspp(iopt) = ref
   ELSE IF (ind == i_sip) THEN
      refsip(iopt) = ref
   ELSE IF (ind == i_nep) THEN
      refnep(iopt) = ref
   ELSE IF (ind == i_nepp) THEN
      refnepp(iopt) = ref
   ELSE IF (ind == i_co) THEN
      refco(iopt) = ref
   ELSE IF (ind == j_c13o) THEN
      refc13o(iopt) = ref
   ELSE IF (ind == j_co18) THEN
      refco18(iopt) = ref
   ELSE IF (ind == j_c13o18) THEN
      refc13o18(iopt) = ref
   ELSE IF (ind == i_cs) THEN
      refcs0(iopt) = ref
   ELSE IF (ind == i_hcop) THEN
      refhcop(iopt) = ref
   ELSE IF (ind == i_chp) THEN
      refchp(iopt) = ref
   ELSE IF (ind == i_hcn) THEN
      refhcn(iopt) = ref
   ELSE IF (ind == i_oh) THEN
      refoh(iopt) = ref
   ELSE IF (ind == i_h2o) THEN
      refh2o(iopt) = ref
   ELSE IF (ind == i_h3p) THEN
      refh3p(iopt) = ref
   ELSE IF (ind == i_o2) THEN
      refo2(iopt) = ref
   ELSE IF (ind == i_ohp) THEN
      refohp(iopt) = ref
   ELSE IF (ind == i_shp) THEN
      refshp(iopt) = ref
   ELSE IF (ind == i_arhp) THEN
      refarhp(iopt) = ref
   ENDIF

END SUBROUTINE X_REF

!%%%%%%%%%%%%%%%%%%%%%%%
SUBROUTINE FABDES (iopt)
!%%%%%%%%%%%%%%%%%%%%%%%

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

   IMPLICIT NONE

   INTEGER, INTENT (IN)                             :: iopt
   REAL (KIND=dp), DIMENSION (nqm)                  :: ab1, ab2, ab3
   INTEGER, DIMENSION (nqm)                         :: j1, j2, j3
   INTEGER                                          :: i, j, k
   INTEGER                                          :: nrxi
   REAL (KIND=dp)                                   :: duma

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

   IF (icd_o < npo) THEN
      raptau = (tau(iopt) - tau_o(icd_o)) / dtau_o(icd_o+1)
   ELSE
      raptau = 0.0_dp
   ENDIF

   DO i = 1, nspec-nsp_g1-1
      IF (in_sp(i) == 0) CYCLE

      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 = 0.0_dp
      DO k = 1, nrxi
         IF (xmatk(i)%fdt(k)%k > 0.0_dp) THEN
            duma = duma + xmatk(i)%fdt(k)%k * ab1(k) * ab2(k) * ab3(k)
         ENDIF
      ENDDO
      creat(in_sp(i)) = duma
   ENDDO

   IF (i_c13o == 0 .AND. j_c13o /= 0) THEN
      creat(in_sp(j_c13o)) = creat(in_sp(i_co)) / r_c13
   ENDIF
   IF (i_co18 == 0 .AND. j_co18 /= 0) THEN
      creat(in_sp(j_co18)) = creat(in_sp(i_co)) / r_o18
   ENDIF
   IF (i_c13o18 == 0 .AND. j_c13o18 /= 0) THEN
      creat(in_sp(j_c13o18)) = creat(in_sp(i_co)) / (r_c13 * r_o18)
   ENDIF

END SUBROUTINE FABDES

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
SUBROUTINE CHAUD (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
   USE PXDR_CHEMISTRY

! ref.1 Hollenbach, Takahashi et Tielens (1991) ApJ 377, 192
! ref.2 Verstraete, Leger, d Hendecourt, Dutuit et Defourneau
!     (1990) AA 237, 436
! ref:3 Tielens & Hollenbach(1985) ApJ 291, 722

   IMPLICIT NONE

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

   REAL (KIND=dp)                      :: avr
   REAL (KIND=dp)                      :: frach2
   REAL (KIND=dp)                      :: xmu
   REAL (KIND=dp)                      :: xkphot, xkrc, xkphs, xkchim, toto
   REAL (KIND=dp)                      :: rate1, rate2, rate, dde
   INTEGER                             :: i
   INTEGER                             :: ir1, ir2, ir3, ip1, ip2
   INTEGER                             :: ideb, ifin
   SAVE

   avr  = Avmax - av

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

   ! -------------------------------------------------------------------------------------
   ! Photoelectric heating on grains from Weingartner et al. (2001)
   ! -------------------------------------------------------------------------------------
   ! chophg is computed in FBTH2
   CALL FBTH1 (ttry, iopt, itn, ab)
   CALL FBTH2 (ttry, iopt, ab)

   ! Heating by thermal balance with grains
   !   Tielens & Hollenbach 1985 (ref.3) eq A19 : not used anymore

   ! 15 III 2012 - JLB - Use simpler expression
   ! ! Burke & Hollenbach 1983 Ap J 265, 223 (Eq 9)
   ! See note on Gas_grain_coupling
   xmu = (ab(i_h) + 2.0_dp *  ab(i_h2) + 4.0_dp * ab(i_he)) &
       / (ab(i_h) + ab(i_h2) + ab(i_he))

   choeqg(iopt) = 0.462_dp * SQRT(2.0_dp) * xpi * xk * vmaxw * SQRT(ttry / xmu) &
                * densh(iopt)**2 * SUM(wwmg(:) * adust(:)**2 * (tdust(:,iopt) - ttry))

   xkphot = 0.0_dp
   xkrc = 0.0_dp
   xkphs = 0.0_dp
   xkchim = 0.0_dp

   ! Heating by photoionisation or photodissociation
   ! de(i) is set in POST_LECTUR in module PXDR_READCHIM
   ! 1 eV for H2, HD
   ! with "enthalpy" of 13 eV for the photon for atoms (C et S, ...) and CO, ...
   ! 1/3 of de for others
   ! photons have an "enthalpy" of 13.O eV

   ! Photodestruction
   ideb = nh2for + ncrion + npsion + nasrad + nrest + nh2endo + 1
   ifin = ideb + nphot_f - 1

   DO i = ideb, ifin
      ir1 = react(i,1)
      xkphot = xkphot + ab(ir1) * rate_chem(i) * de(i) / 3.0_dp
   ENDDO

   ! Photodestruction by direct integration
   ideb = ifin + 1
   ifin = ifin + nphot_i

   DO i = ideb, ifin
      ir1 = react(i,1)
      xkphot = xkphot + ab(ir1) * rate_chem(i) * de(i)
   ENDDO

   ! Heating by cosmic rays ionisation
   ideb = nh2for + 1
   ifin = nh2for + ncrion
   DO i = ideb, ifin
      ir1 = react(i,1)
      xkrc = xkrc + ab(ir1) * rate_chem(i)
   ENDDO

   ! Heating by secondary photons ionisation
   ideb = nh2for + ncrion + 1
   ifin = ideb + npsion - 1
   DO i = ideb, ifin
      ir1 = react(i,1)
      xkphs = xkphs + ab(ir1) * rate_chem(i) * de(i)
   ENDDO

   ! Chemistry thermal balance
   ideb = nh2for + ncrion + npsion + nasrad + 1
   ifin = nh2for + ncrion + npsion + nasrad + nrest + nh2endo
   DO i = ideb, ifin
      ir1 = react(i,1)
      ir2 = react(i,2)
      ir3 = react(i,3)
      ip1 = react(i,4)
      ip2 = react(i,5)

      IF (de(i) > 1.0e3_dp) THEN
         dde = 0.0_dp
         PRINT *, i, ir1, ir2, de(i)
      ELSE IF (ir2 == nspec .AND. (ip1 == i_co .OR. ip2 == i_co) .AND. F_CO_CH_pum == 1) 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

      xkchim = xkchim + ab(ir1) * ab(ir2) * ab(ir3) * rate_chem(i) * dde

   ENDDO
   ideb = nh2for + ncrion + npsion + nasrad + nrest + nh2endo &
        + nphot_f + nphot_i + n3body + 1
   ifin = ideb + ncpart - 1
   DO i = ideb, ifin
      ir1 = react(i,1)
      ir2 = react(i,2)
      ir3 = react(i,3)

      xkchim = xkchim + ab(ir1) * ab(ir2) * ab(ir3) * rate_chem(i) * de(i)
   ENDDO

   chochi(iopt) = xkchim * everg              ! Convert to erg

   ! WARNING: cross check photons energy (2 I 06)
   !   photoionisation ou photodissociation: 1 eV pour H2, HD et CO, de(i) pour les autres
   !   avec une energie moyenne de 10 eV pour les photons incidents.
   chopht(iopt) = xkphot * everg

   ! 4 ev per cosmic ray
!  chorc(iopt) = xkrc * everg * 6.0_dp
   chorc(iopt) = xkrc * everg * 4.0_dp

   ! de(i) per secondary photon
   chophs(iopt) = xkphs * everg

   ! Heating by H2 formation on grains
   ! Each formation releases 1/3 of formation enthalpy (if possible)
   ! TO BE REDONE !

   ! WARNING: check "refh2_o" for consistency !
   ! For old cooling (thru radiative transitions)
   ! Include also internal energy since formation followed by
   ! direct cascades are counted as cooling.
   ! First term in "MIN" is the sum of energy not in the grain
   ! (which has to be lower than 4.5 eV)
   ! For new cooling (thru collisions), then
   ! do NOT include it ! (check with refh2_o) (JLB - 20 IV 2010)

   toto = everg * de(ifh2gr)
!  choh2g(iopt) = MIN(emoyh2 * xk  + toto / 3.0_dp, toto)     ! OLD
   choh2g(iopt) = toto / 3.0_dp                               ! NEW

   choh2g(iopt) = choh2g(iopt) * timh23(iopt)

   ! Add Eley-Rideal contribution
   ! OLD:Bachellerie et al. (2009) 11% of available energy goes into translation
   ! Superseded by Sizun et al. (2010)
   choh2g(iopt) = choh2g(iopt) &
                + (everg * ef_er_h2) * timh25(iopt)
!               + (everg * ef_er_h2 + ttry * xk) * timh25(iopt)

   ! Heating by formation of HD on grains
   IF (i_hd /= 0) THEN
      rate = timhd3(iopt)
      toto = everg * de(ifhdgr)
      chohdg(iopt) = MIN(emoyhd * xk  + toto / 3.0_dp, toto)
      chohdg(iopt) = chohdg(iopt) * rate
   ELSE
      chohdg(iopt) = 0.0_dp
   ENDIF

   choxray(iopt) = 0.0_dp
   ! ----------------------------------------------------------------------------------

   ! Heating by dissipation of turbulence
   ! Falgarone et Puget (1985)
   ! Usually switched off

!  fv = 0.03_dp
   ! On limite la taille inferieure d un clump, pour eviter la divergence de chotur
!  size = MAX(taille(iopt), 0.1_dp)
!  chotur(iopt) = 2.0e-29_dp * densh(iopt) * (vturb / 1.0d5)**3 * (fv / 0.03_dp) / size

   ! Other possibility : (Boland & de Jong, 1984)
!  pmu = (ab(i_h) + 2.0_dp * ab(i_h2) + 4.0_dp * ab(i_he)) / (ab(i_h) + ab(i_h2) + ab(i_he))
!  alp = vturb / SQRT(deksamu * ttry / pmu)
!  chotur(iopt) = 2.7e-30_dp * alp**3 * densh(iopt) * ttry**1.5_dp / (1.0_dp + alp*alp)

   ! up to now:
   chotur(iopt) = 0.0_dp

   chotot(iopt) = chotot(iopt) + chophg(iopt) + choh2g(iopt) + chopht(iopt)  &
                + chorc(iopt)  + chophs(iopt) + choxray(iopt) + chotur(iopt)

   IF (chochi(iopt) >= 0.0_dp) THEN
      chotot(iopt) = chotot(iopt) + chochi(iopt)
   ELSE
      reftot(iopt) = reftot(iopt) - chochi(iopt)
   ENDIF

   IF (choeqg(iopt) >= 0.0_dp) THEN
      chotot(iopt) = chotot(iopt) + choeqg(iopt)
   ELSE
      reftot(iopt) = reftot(iopt) - choeqg(iopt)
   ENDIF

END SUBROUTINE CHAUD

!===============================================================================
! SUBROUTINE CHECK_THBAL
!===============================================================================
SUBROUTINE CHECK_THBAL(done_check_thbal, iopt, itenua, ttry)

   USE PXDR_FLAGS
   USE PXDR_CONSTANTES
   USE PXDR_CHEM_DATA
   USE PXDR_PROFIL
   USE PXDR_AUXILIAR
   USE PXDR_STR_DATA
   USE PXDR_RF_TOOLS
   USE PXDR_RF_INIT
   USE PXDR_TRANSFER
   USE PXDR_INITIAL
   USE PXDR_FGK_TR
   USE PXDR_CHEMISTRY
   USE PXDR_DUSTEM

   IMPLICIT NONE

   LOGICAL, INTENT(INOUT)                 :: done_check_thbal
   INTEGER, INTENT(IN)                    :: iopt
   INTEGER, INTENT(IN)                    :: itenua
   REAL (KIND=dp), INTENT(IN)             :: ttry
   CHARACTER (LEN=4), DIMENSION (14)      :: av_ct
   DATA av_ct / "1e-6", "3e-6", "1e-5", "3e-5", "1e-4", "3e-4" &
              , "1e-3", "3e-3", "1e-2", "3e-2", "1e-1", "3e-1", "1e-0", "3e-0" /

   REAL (KIND=dp), PARAMETER              :: tmin_check_thbal  = 1.0e+1_dp
   REAL (KIND=dp), PARAMETER              :: tmax_check_thbal  = 1.0e+4_dp

   REAL (KIND=dp)                         :: temp_inut, dt_inut
   INTEGER,        PARAMETER              :: Ntemp_check_thbal = 120

   INTEGER                                :: answ

   INTEGER                                :: i, j

   from_CT = 1

   fichier = TRIM(out_dir)//'check_therm_bal'//TRIM(ADJUSTL(ii2c(iopt)))//'_'//TRIM(ADJUSTL(ii2c(ifaf)))//'.res'
   OPEN (iwrtmp, file=TRIM(fichier), STATUS="unknown")
   WRITE(iwrtmp,'(A7,1X,ES13.6,A15,1X,ES13.6)') '# Av =', tau(iopt)*tautav, " Temperature =", ttry
   WRITE(iwrtmp,'(A12,1X)',ADVANCE='no') ' temperature'
   WRITE(iwrtmp,'(A12,1X)',ADVANCE='no') ' photon-dust'
   WRITE(iwrtmp,'(A12,1X)',ADVANCE='no') '    phd-cool'
   WRITE(iwrtmp,'(A12,1X)',ADVANCE='no') '    phd-heat'
   WRITE(iwrtmp,'(A12,1X)',ADVANCE='no') '   gr-charge'
   WRITE(iwrtmp,'(A12,1X)',ADVANCE='no') '   H2-UV-tot'
   WRITE(iwrtmp,'(A12,1X)',ADVANCE='no') '   H2-UV-col'
   WRITE(iwrtmp,'(A12,1X)',ADVANCE='no') 'H2-formation'
   WRITE(iwrtmp,'(A12,1X)',ADVANCE='no') 'HD-formation'
   WRITE(iwrtmp,'(A12,1X)',ADVANCE='no') '  photon-gas'
   WRITE(iwrtmp,'(A12,1X)',ADVANCE='no') ' cosmic-rays'
   WRITE(iwrtmp,'(A12,1X)',ADVANCE='no') ' second-phot'
   WRITE(iwrtmp,'(A12,1X)',ADVANCE='no') ' g-g-equilib'
   WRITE(iwrtmp,'(A12,1X)',ADVANCE='no') '   chemistry'
   WRITE(iwrtmp,'(A12,1X)',ADVANCE='no') '  x-ray-phot'
   WRITE(iwrtmp,'(A12,1X)',ADVANCE='no') '  turbulence'
   WRITE(iwrtmp,'(A12,1X)',ADVANCE='no') '  total-heat'

   DO j = 1, nspl
      IF(spec_lin(j)%ind == i_h)      WRITE(iwrtmp,'(A12,1X)',ADVANCE='no') '       ref-H'
      IF(spec_lin(j)%ind == i_h2)     WRITE(iwrtmp,'(A12,1X)',ADVANCE='no') '     ref-H2t'
      IF(spec_lin(j)%ind == i_h2)     WRITE(iwrtmp,'(A12,1X)',ADVANCE='no') '     ref-H2c'
      IF(spec_lin(j)%ind == i_hd)     WRITE(iwrtmp,'(A12,1X)',ADVANCE='no') '      ref-HD'
      IF(spec_lin(j)%ind == i_c)      WRITE(iwrtmp,'(A12,1X)',ADVANCE='no') '       ref-C'
      IF(spec_lin(j)%ind == i_n)      WRITE(iwrtmp,'(A12,1X)',ADVANCE='no') '       ref-N'
      IF(spec_lin(j)%ind == i_o)      WRITE(iwrtmp,'(A12,1X)',ADVANCE='no') '       ref-O'
      IF(spec_lin(j)%ind == i_s)      WRITE(iwrtmp,'(A12,1X)',ADVANCE='no') '       ref-S'
      IF(spec_lin(j)%ind == i_si)     WRITE(iwrtmp,'(A12,1X)',ADVANCE='no') '      ref-Si'
      IF(spec_lin(j)%ind == i_cp)     WRITE(iwrtmp,'(A12,1X)',ADVANCE='no') '      ref-C+'
      IF(spec_lin(j)%ind == i_cpp)    WRITE(iwrtmp,'(A12,1X)',ADVANCE='no') '     ref-C++'
      IF(spec_lin(j)%ind == i_np)     WRITE(iwrtmp,'(A12,1X)',ADVANCE='no') '      ref-N+'
      IF(spec_lin(j)%ind == i_npp)    WRITE(iwrtmp,'(A12,1X)',ADVANCE='no') '     ref-N++'
      IF(spec_lin(j)%ind == i_op)     WRITE(iwrtmp,'(A12,1X)',ADVANCE='no') '      ref-O+'
      IF(spec_lin(j)%ind == i_opp)    WRITE(iwrtmp,'(A12,1X)',ADVANCE='no') '     ref-O++'
      IF(spec_lin(j)%ind == i_sp)     WRITE(iwrtmp,'(A12,1X)',ADVANCE='no') '      ref-S+'
      IF(spec_lin(j)%ind == i_spp)    WRITE(iwrtmp,'(A12,1X)',ADVANCE='no') '     ref-S++'
      IF(spec_lin(j)%ind == i_sip)    WRITE(iwrtmp,'(A12,1X)',ADVANCE='no') '     ref-Si+'
      IF(spec_lin(j)%ind == i_nep)    WRITE(iwrtmp,'(A12,1X)',ADVANCE='no') '     ref-Ne+'
      IF(spec_lin(j)%ind == i_nepp)   WRITE(iwrtmp,'(A12,1X)',ADVANCE='no') '    ref-Ne++'
      IF(spec_lin(j)%ind == i_co)     WRITE(iwrtmp,'(A12,1X)',ADVANCE='no') '      ref-CO'
      IF(spec_lin(j)%ind == j_c13o)   WRITE(iwrtmp,'(A12,1X)',ADVANCE='no') '    ref-13CO'
      IF(spec_lin(j)%ind == j_co18)   WRITE(iwrtmp,'(A12,1X)',ADVANCE='no') '    ref-C18O'
      IF(spec_lin(j)%ind == j_c13o18) WRITE(iwrtmp,'(A12,1X)',ADVANCE='no') '  ref-13C18O'
      IF(spec_lin(j)%ind == i_cs)     WRITE(iwrtmp,'(A12,1X)',ADVANCE='no') '      ref-CS'
      IF(spec_lin(j)%ind == i_hcop)   WRITE(iwrtmp,'(A12,1X)',ADVANCE='no') '    ref-HCO+'
      IF(spec_lin(j)%ind == i_chp)    WRITE(iwrtmp,'(A12,1X)',ADVANCE='no') '     ref-CH+'
      IF(spec_lin(j)%ind == i_hcn)    WRITE(iwrtmp,'(A12,1X)',ADVANCE='no') '     ref-HCN'
      IF(spec_lin(j)%ind == i_oh)     WRITE(iwrtmp,'(A12,1X)',ADVANCE='no') '      ref-OH'
      IF(spec_lin(j)%ind == i_h2o)    WRITE(iwrtmp,'(A12,1X)',ADVANCE='no') '     ref-H2O'
      IF(spec_lin(j)%ind == i_h3p)    WRITE(iwrtmp,'(A12,1X)',ADVANCE='no') '     ref-H3+'
      IF(spec_lin(j)%ind == i_o2)     WRITE(iwrtmp,'(A12,1X)',ADVANCE='no') '      ref-O2'
      IF(spec_lin(j)%ind == i_ohp)    WRITE(iwrtmp,'(A12,1X)',ADVANCE='no') '     ref-OH+'
      IF(spec_lin(j)%ind == i_shp)    WRITE(iwrtmp,'(A12,1X)',ADVANCE='no') '     ref-SH+'
   ENDDO
   WRITE(iwrtmp,'(A12,1X)',ADVANCE='no') ' g-g-equilib'
   WRITE(iwrtmp,'(A12,1X)',ADVANCE='no') ' chemistry'
   WRITE(iwrtmp,'(A12,1X)',ADVANCE='no') '  ref-Fe+'
   WRITE(iwrtmp,'(A12,1X)',ADVANCE='no') '  ref-ff'
   WRITE(iwrtmp,'(A12,1X)',ADVANCE='no') '  refrec'
   IF (i_hd == 0 .OR. in_sp(i_hd) == 0) THEN
      WRITE(iwrtmp,'(A12,1X)',ADVANCE='no') '  ref-HD'
   ENDIF
   WRITE(iwrtmp,'(A12,1X)') '  total-cool'

   fichier = TRIM(out_dir)//'check_tb_ch'//TRIM(ADJUSTL(ii3c(iopt)))//'_'//TRIM(ADJUSTL(ii2c(ifaf)))//'.res'
   OPEN (15, file=TRIM(fichier), STATUS="unknown")
   WRITE(15,'(A7,1X,ES13.6,A15,1X,ES13.6)') '# Av =', tau(iopt)*tautav, " Temperature =", ttry
   WRITE(15,'(A12,1X)',ADVANCE='no') ' temperature'
   DO i = 1, nspec
      WRITE(15,'(A12,1X)',ADVANCE='no') speci(i)
   ENDDO
   WRITE(15,'(A12,1X)') '   gr-charge'

   dt_inut   = EXP( LOG( tmax_check_thbal / tmin_check_thbal ) / DBLE(Ntemp_check_thbal) )
   DO i = 0, Ntemp_check_thbal
      temp_inut = tmin_check_thbal * dt_inut**DBLE(i)
      print *, i, " Temp:", temp_inut

      !--- Optionnal : Run chemistry with the new temperature
      IF (F_CHECK_THBAL < 0) THEN
         CALL CHIMIJ (temp_inut, iopt, itenua)
         CALL MNEWT  (temp_inut, iopt, itenua)
      ENDIF

      CALL LADENS(temp_inut, iopt, itenua)
      CALL FROID (temp_inut, iopt)
      CALL CHAUD (temp_inut, iopt, itenua)

      WRITE(iwrtmp,'(ES13.6,1X)',ADVANCE='no') temp_inut
      WRITE(iwrtmp,'(ES13.6,1X)',ADVANCE='no') chophg(iopt)
      WRITE(iwrtmp,'(ES13.6,1X)',ADVANCE='no') chophg_c(iopt)
      WRITE(iwrtmp,'(ES13.6,1X)',ADVANCE='no') chophg_h(iopt)
      WRITE(iwrtmp,'(ES13.6,1X)',ADVANCE='no') grcharge(iopt)
      WRITE(iwrtmp,'(ES13.6,1X)',ADVANCE='no') MAX(0.0_dp,-(rfjh2t(iopt)-rfjh2c(iopt)))
      WRITE(iwrtmp,'(ES13.6,1X)',ADVANCE='no') MAX(0.0_dp,-rfjh2c(iopt))
      WRITE(iwrtmp,'(ES13.6,1X)',ADVANCE='no') choh2g(iopt)
      WRITE(iwrtmp,'(ES13.6,1X)',ADVANCE='no') chohdg(iopt)
      WRITE(iwrtmp,'(ES13.6,1X)',ADVANCE='no') chopht(iopt)
      WRITE(iwrtmp,'(ES13.6,1X)',ADVANCE='no') chorc(iopt)
      WRITE(iwrtmp,'(ES13.6,1X)',ADVANCE='no') chophs(iopt)
      WRITE(iwrtmp,'(ES13.6,1X)',ADVANCE='no') MAX(0.0_dp,choeqg(iopt))
      WRITE(iwrtmp,'(ES13.6,1X)',ADVANCE='no') MAX(0.0_dp,chochi(iopt))
      WRITE(iwrtmp,'(ES13.6,1X)',ADVANCE='no') choxray(iopt)
      WRITE(iwrtmp,'(ES13.6,1X)',ADVANCE='no') chotur(iopt)
      WRITE(iwrtmp,'(ES13.6,1X)',ADVANCE='no') chotot(iopt)
      DO j = 1, nspl
         IF(spec_lin(j)%ind == i_h)      WRITE(iwrtmp,'(ES13.6,1X)',ADVANCE='no') refhat(iopt)
         IF(spec_lin(j)%ind == i_h2)     WRITE(iwrtmp,'(ES13.6,1X)',ADVANCE='no') MAX(0.0_dp,(rfjh2t(iopt)-rfjh2c(iopt)))
         IF(spec_lin(j)%ind == i_h2)     WRITE(iwrtmp,'(ES13.6,1X)',ADVANCE='no') MAX(0.0_dp,rfjh2c(iopt))
         IF(spec_lin(j)%ind == i_hd)     WRITE(iwrtmp,'(ES13.6,1X)',ADVANCE='no') rfjhdt(iopt)
         IF(spec_lin(j)%ind == i_c)      WRITE(iwrtmp,'(ES13.6,1X)',ADVANCE='no') refcat(iopt)
         IF(spec_lin(j)%ind == i_n)      WRITE(iwrtmp,'(ES13.6,1X)',ADVANCE='no') refnat(iopt)
         IF(spec_lin(j)%ind == i_o)      WRITE(iwrtmp,'(ES13.6,1X)',ADVANCE='no') refoat(iopt)
         IF(spec_lin(j)%ind == i_s)      WRITE(iwrtmp,'(ES13.6,1X)',ADVANCE='no') refsat(iopt)
         IF(spec_lin(j)%ind == i_si)     WRITE(iwrtmp,'(ES13.6,1X)',ADVANCE='no') refsia(iopt)
         IF(spec_lin(j)%ind == i_cp)     WRITE(iwrtmp,'(ES13.6,1X)',ADVANCE='no') refcpl(iopt)
         IF(spec_lin(j)%ind == i_cpp)    WRITE(iwrtmp,'(ES13.6,1X)',ADVANCE='no') refcpp(iopt)
         IF(spec_lin(j)%ind == i_np)     WRITE(iwrtmp,'(ES13.6,1X)',ADVANCE='no') refnpl(iopt)
         IF(spec_lin(j)%ind == i_npp)    WRITE(iwrtmp,'(ES13.6,1X)',ADVANCE='no') refnpp(iopt)
         IF(spec_lin(j)%ind == i_op)     WRITE(iwrtmp,'(ES13.6,1X)',ADVANCE='no') refopl(iopt)
         IF(spec_lin(j)%ind == i_opp)    WRITE(iwrtmp,'(ES13.6,1X)',ADVANCE='no') refopp(iopt)
         IF(spec_lin(j)%ind == i_sp)     WRITE(iwrtmp,'(ES13.6,1X)',ADVANCE='no') refspl(iopt)
         IF(spec_lin(j)%ind == i_spp)    WRITE(iwrtmp,'(ES13.6,1X)',ADVANCE='no') refspp(iopt)
         IF(spec_lin(j)%ind == i_sip)    WRITE(iwrtmp,'(ES13.6,1X)',ADVANCE='no') refsip(iopt)
         IF(spec_lin(j)%ind == i_nep)    WRITE(iwrtmp,'(ES13.6,1X)',ADVANCE='no') refnep(iopt)
         IF(spec_lin(j)%ind == i_nepp)   WRITE(iwrtmp,'(ES13.6,1X)',ADVANCE='no') refnepp(iopt)
         IF(spec_lin(j)%ind == i_co)     WRITE(iwrtmp,'(ES13.6,1X)',ADVANCE='no') refco(iopt)
         IF(spec_lin(j)%ind == j_c13o)   WRITE(iwrtmp,'(ES13.6,1X)',ADVANCE='no') refc13o(iopt)
         IF(spec_lin(j)%ind == j_co18)   WRITE(iwrtmp,'(ES13.6,1X)',ADVANCE='no') refco18(iopt)
         IF(spec_lin(j)%ind == j_c13o18) WRITE(iwrtmp,'(ES13.6,1X)',ADVANCE='no') refc13o18(iopt)
         IF(spec_lin(j)%ind == i_cs)     WRITE(iwrtmp,'(ES13.6,1X)',ADVANCE='no') refcs0(iopt)
         IF(spec_lin(j)%ind == i_hcop)   WRITE(iwrtmp,'(ES13.6,1X)',ADVANCE='no') refhcop(iopt)
         IF(spec_lin(j)%ind == i_chp)    WRITE(iwrtmp,'(ES13.6,1X)',ADVANCE='no') refchp(iopt)
         IF(spec_lin(j)%ind == i_hcn)    WRITE(iwrtmp,'(ES13.6,1X)',ADVANCE='no') refhcn(iopt)
         IF(spec_lin(j)%ind == i_oh)     WRITE(iwrtmp,'(ES13.6,1X)',ADVANCE='no') refoh(iopt)
         IF(spec_lin(j)%ind == i_h2o)    WRITE(iwrtmp,'(ES13.6,1X)',ADVANCE='no') refh2o(iopt)
         IF(spec_lin(j)%ind == i_h3p)    WRITE(iwrtmp,'(ES13.6,1X)',ADVANCE='no') refh3p(iopt)
         IF(spec_lin(j)%ind == i_o2)     WRITE(iwrtmp,'(ES13.6,1X)',ADVANCE='no') refo2(iopt)
         IF(spec_lin(j)%ind == i_ohp)    WRITE(iwrtmp,'(ES13.6,1X)',ADVANCE='no') refohp(iopt)
         IF(spec_lin(j)%ind == i_shp)    WRITE(iwrtmp,'(ES13.6,1X)',ADVANCE='no') refshp(iopt)
      ENDDO
      WRITE(iwrtmp,'(ES13.6,1X)',ADVANCE='no') MAX(0.0_dp,-choeqg(iopt))
      WRITE(iwrtmp,'(ES13.6,1X)',ADVANCE='no') MAX(0.0_dp,-chochi(iopt))
      WRITE(iwrtmp,'(ES13.6,1X)',ADVANCE='no') reffep(iopt)
      WRITE(iwrtmp,'(ES13.6,1X)',ADVANCE='no') ref_ff(iopt)
      WRITE(iwrtmp,'(ES13.6,1X)',ADVANCE='no') refrec(iopt)
      IF (i_hd == 0 .OR. in_sp(i_hd) == 0) THEN
         WRITE(iwrtmp,'(ES13.6,1X)',ADVANCE='no') refhd(iopt)
      ENDIF
      WRITE(iwrtmp,'(ES13.6,1X)') reftot(iopt)

      WRITE(15,'(ES13.6,1X)',ADVANCE='no') temp_inut
      DO j = 1, nspec
         WRITE(15,'(ES13.6,1X)',ADVANCE='no') ab(j)
      ENDDO
      WRITE(15,'(ES13.6,1X)') grcharge(iopt)

      ENDDO
      CLOSE (iwrtmp)
      CLOSE (15)

      IF (ABS(F_CHECK_THBAL) == 2) THEN
         PRINT *,"Check Thermal Balance file written"
         PRINT *,"at AV = ", tau(iopt)*tautav
         PRINT *,"Do you wish to continue to write files (overwritting)"
         PRINT *,"[1] Yes"
         PRINT *,"[0] No"
         READ *, answ
         IF (answ == 1) done_check_thbal = .false.
      ENDIF

      !--- Run chemistry with the true temperature to reset all variables
      CALL CHIMIJ (ttry, iopt, itenua)
      CALL MNEWT  (ttry, iopt, itenua)

   from_CT = 0

END SUBROUTINE CHECK_THBAL

END MODULE PXDR_BILTHERM
