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

MODULE PXDR_INITIAL

   PRIVATE

   PUBLIC :: READ_METADATA_NBL, READ_METADATA_DAT, INIT1, &
             CACOEF, CACOEFHD, CALC_EXTRA, REALL, REALL1, &
             MAKE_POPHM, MAKE_POPHD, MAKE_POPH3p, COMP_DIST

CONTAINS

!=======================================================================
!== SUBROUTINE READ_METADATA_NBL
!   The goal of this routine is to read the number of metadata written in the files
!   stored in data/TechConfig directory in order to allocate the metatables.!
!=======================================================================
SUBROUTINE READ_METADATA_NBL(filename, nhdf5)

   USE PXDR_CONSTANTES
   IMPLICIT NONE

   CHARACTER(len=lenfilename), INTENT(in)  :: filename  ! directory of the ASCII files
   INTEGER,                    INTENT(out) :: nhdf5     ! dimension of the metatab table
   CHARACTER(LEN=5)                        :: templ

   ! ------------------------------------------------------------------
   ! Open the inpt metadata file and count the number of lines in it
   ! ------------------------------------------------------------------
   OPEN(iwrtmp,file=TRIM(filename),status='old')
   READ(iwrtmp,'(12/)')
   templ = ""
   nhdf5 = 0
   DO WHILE (templ /= '#----' )
      READ(iwrtmp,'(A5)') templ
      nhdf5 = nhdf5 + 1
   ENDDO
   nhdf5 = nhdf5 -1
   CLOSE(iwrtmp)

END SUBROUTINE READ_METADATA_NBL

!=======================================================================
!== SUBROUTINE READ_METADATA_DAT
!   The goal of this routine is to read the list of data to write in the standard hdf5
!   file along with their metadata. All information are stored in "metatab_std"
!=======================================================================
SUBROUTINE READ_METADATA_DAT(filename, metatab, nhdf5)

   USE PXDR_CONSTANTES
   IMPLICIT NONE

   CHARACTER(len=lenfilename),                   INTENT(in)  :: filename  ! directory of the ASCII files
   INTEGER,                                      INTENT(in)  :: nhdf5     ! dimension of the metatab table
   TYPE (METADATA),            DIMENSION(nhdf5), INTENT(out) :: metatab   ! table of metadata
   INTEGER, PARAMETER                                        :: nchar=1000
   CHARACTER(LEN=nchar)                                      :: line_tmp
   INTEGER                                                   :: i, j, k
   INTEGER                                                   :: ki, kf

   ! ------------------------------------------------------------------
   ! Read the inpt metadata file and store information in metatab
   ! ------------------------------------------------------------------
   OPEN(iwrtmp,file=TRIM(filename),status='old')
   READ(iwrtmp,'(12/)')
   DO i = 1, nhdf5
      READ(iwrtmp,'(A1000)') line_tmp
      j  = 1
      ki = 1
      DO k = 1, nchar
         IF( line_tmp(k:k) /= ';' ) CYCLE
         kf = k - 1
         IF(j== 1) metatab(i)%path   = TRIM(ADJUSTL(line_tmp(ki:kf)))
         IF(j== 2) metatab(i)%file   = TRIM(ADJUSTL(line_tmp(ki:kf)))
         IF(j== 3) metatab(i)%datset = TRIM(ADJUSTL(line_tmp(ki:kf)))
         IF(j== 4) metatab(i)%Hname  = TRIM(ADJUSTL(line_tmp(ki:kf)))
         IF(j== 5) metatab(i)%IDname = TRIM(ADJUSTL(line_tmp(ki:kf)))
         IF(j== 6) metatab(i)%dtype  = TRIM(ADJUSTL(line_tmp(ki:kf)))
         IF(j== 7) metatab(i)%unit   = TRIM(ADJUSTL(line_tmp(ki:kf)))
         IF(j== 8) metatab(i)%SKOS   = TRIM(ADJUSTL(line_tmp(ki:kf)))
         IF(j== 9) metatab(i)%ucd    = TRIM(ADJUSTL(line_tmp(ki:kf)))
         IF(j==10) metatab(i)%utype  = TRIM(ADJUSTL(line_tmp(ki:kf)))
         IF(j==11) metatab(i)%group  = TRIM(ADJUSTL(line_tmp(ki:kf)))
         IF(j==12) metatab(i)%parent = TRIM(ADJUSTL(line_tmp(ki:kf)))
         IF(j==12) metatab(i)%descrp = TRIM(ADJUSTL(line_tmp(kf+2:nchar)))
         ki = kf + 2
         j = j + 1
      ENDDO
   ENDDO
   CLOSE(iwrtmp)

END SUBROUTINE READ_METADATA_DAT

!=======================================================================
!== SUBROUTINE INIT1
!=======================================================================
!== READ INPUT FILE : PDR.IN
!== PREPARE GRAINS DISTRIBUTION
!== INITIALIZE CLOUD PROFILE
!==   - ifisob
!==   - calcul des abh2_o, abh_o, etc...
!==   - fait intervenir parfois des rapports ortho / para
!==   - GRAIN EXTINCTION CURVE
!== PREPARE OUTPUT FILES
!== READ CHEMISTRY FILE
!== READ UV DATA for H
!== PREPARE BOUNDS OF THE RADIATION FIELD WAVELENGTH GRID
!== READ GRAINS PROPERTIES
!== INITIALIZATION OF DETAILED BALANCE DATA
!== INITIALIZATION OF ABUNDANCES AND EXCITATION FOR H2, HD and CO ???
!== INITIALIZATION OF COLLISION RATES
!== INITIALIZATION OF H2, B and C states
!== INITIALIZATION OF H2 ELECTRONIC TRANSITIONS DATA
!== INITIALIZATION OF D ELECTRONIC TRANSITIONS DATA
!== INITIALIZATION OF HD ELECTRONIC TRANSITIONS DATA
!== INITIALIZATION OF CO ELECTRONIC TRANSITIONS DATA
!== CALL CALC_EXTRA (pour les distances ?)
!=======================================================================
SUBROUTINE INIT1

   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_TRANSFER
   USE PXDR_READCHIM
   USE PXDR_DRAINE_DUST

   IMPLICIT NONE

   REAL (KIND=dp)     :: coefosc
   INTEGER            :: i, j, ib, ii, iid, m
   INTEGER            :: nrai, nraib, nraic
   INTEGER            :: ira1, nvl, njl, nvu, nju, ndj
   INTEGER            :: lev, nb_pt
   INTEGER            :: jmaxi0
   REAL (KIND=dp)     :: pra1, pra2, pra3, pra4, pra5
   REAL (KIND=dp)     :: xlamax, dumy, eps, int_J_Hab
   REAL (KIND=dp)     :: wl, wl1, wl2, rf, rf1, rf2

   INTEGER            :: xj, xv

     !====================================================================
     ! PREPARE A FEW USEFUL QUANTITIES
     !====================================================================
     tautav = 2.5_dp * LOG10(EXP(1.0_dp))   ! From tau to Av
     J_to_u = 4.0_dp * xpi / clum           ! From J to u (erg cm-2 s-1 A-1 sr-1 to erg cm-3 A-1)
     cs2rate = SQRT(xme * 0.5_dp / (xpi * xk)) * (xhp / xme)**2 * 0.5_dp / xpi

     !tcmb = tcmb0                           ! CMB temperature - modified in INITIAL if redshift is not 0.0
     tcmb = tcmb0 * (1.0_dp + z_dist)

     ! This is used to keep a high precision with large exponentials in the transfer
     DO i = 0, mgr
        expgr(i) = EXP(-grand*DBLE(i))
     ENDDO

     ! Initialisation of exp2gh (for Gauss-Hermite integration in stv5b.f)
     exp2gh = EXP(-x_gh*x_gh)
     sum_wgh = SUM(w_gh(2:ngh)) + 0.5_dp * w_gh(1)

     inv_factor(1) = 1.0_dp
     rat_im1(1) = 1.0_dp
     DO i = 2, ned
        inv_factor(i) = inv_factor(i-1) / DBLE(i)
        rat_im1(i) = DBLE(i-1) / SQRT(DBLE(i*(i+1)))
     ENDDO
     DO i = 1, ned
        inv_factor(i) = inv_factor(i) / SQRT(DBLE(i+1))
     ENDDO

     ! Initialisation of L1b for 0.0 as argument
     L1b_0 =  0.5_dp * w_gh(1) * aa1_L1
     DO i = 2, ngh
        L1b_0 = L1b_0 + w_gh(i) * aa1_L1
     ENDDO
     L1b_0 = L1b_0 / sqpi

     ! Initialization of the abundance array
     abnua(:,:) = 0.0_dp

     !===========================================================================
     !===             READ INPUT DATA FILE (pdr.in)                           ===
     !===========================================================================

     fichier = inpfile
     WRITE(iscrn,*) "--- Read input datafile : ", TRIM(fichier)
     OPEN (iread1, FILE = fichier, STATUS = 'old')

     !--- Read the name of the model ---------------------------------------------
     READ (iread1,*) modele            ! Name of the model
     modele = TRIM(ADJUSTL(modele))

     !---------------------------------------------------------------------------
     !--- Prepare OUTPUT files
     !---------------------------------------------------------------------------
     !-- Define and create the output directory in ../out
     WRITE(iscrn,*)
     WRITE(iscrn,*) "--- Prepare output files"
     ! Create a new directory to store results
     out_dir = TRIM(out_dir)//TRIM(ADJUSTL(modele))//'/'
     sh_cmd = 'sh -c "if [ ! -d '//TRIM(out_dir)//" ]; then mkdir "
     sh_cmd = TRIM(sh_cmd)//" "//TRIM(out_dir)//'; fi "'
     CALL SYSTEM(sh_cmd)

     WRITE(iscrn,*) "    Results will be stored in : ", TRIM(out_dir)

     !--- Define the log file that is named model.def ---------------------------
     file_def = TRIM(out_dir)//TRIM(ADJUSTL(modele))//'.def'
     OPEN (iwrit2, FILE = file_def, STATUS = 'unknown')
     WRITE(iscrn,*) "    * Log file is             : ", TRIM(file_def)

     !--- Define the binary output file .bin ------------------------------------
     file_bin = TRIM(out_dir)//TRIM(ADJUSTL(modele))//'.bin'
     WRITE(iscrn,*) "    * Main result file        : ", TRIM(file_bin)

     !---------------------------------------------------------------------------
     !--- Read the name of the chemistry file
     !---------------------------------------------------------------------------
     READ (iread1,*) chimie         ! name of the chemistry file
     chimie = TRIM(ADJUSTL(chimie))
     WRITE(iscrn,*) "    * Chemistry file          : ", TRIM(ADJUSTL(chimie))

     !---------------------------------------------------------------------------
     !--- Read the other data in the input data file
     !---------------------------------------------------------------------------
     READ (iread1,*) ifafm                ! Number of global iterations

     READ (iread1,*) Avmax                ! Size of the cloud in Av

     READ (iread1,*) nh_init              ! Proton density in cm-3

     !--------------------------------------------------------------------------
     !--- Data controling the incident radiation field
     !--------------------------------------------------------------------------

     !--- Isotropic radiation field : ISRF -------------------------------------
     READ (iread1,*) F_ISRF               ! Flag controling the shape of the
                                          ! incident UV Radiation field
     READ (iread1,*) radm_ini             ! Scaling factor of the rad. field on the observer side
     READ (iread1,*) radp_ini             ! Scaling factor of the rad. field on the back side
     ! radm_ini and radp_ini will be updated later because of backscattering, ...
     ! Their values are stored in radm and radp. These are the 2 variables that will
     ! be modified and that will be actullay used in the code later.
     radm = radm_ini
     radp = radp_ini

     !--- Stellar spectrum ------------------------------------------------------
     READ (iread1,"(a41)") srcpp          ! Name an incident spectrum provided as ASCII text by user
                                          ! ATTENTION: srccp can have spaces in its name
     srcpp = TRIM(ADJUSTL(srcpp))         ! or name of a specific spectral type that will be used
                                          ! to create a black body spectrum
                                          ! See data/Astrodata/star.dat for a list a recognized spectral types
     READ (iread1,*) d_sour               ! Distance of the star to the cloud in pc
                                          ! If == 0 : no star will be added to the ISRF
                                          ! If <  0 : a stellar spectrum is added on the observer side
                                          ! If >  0 : a stellar spectrum is added on the back side

     IF (ABS(d_sour) <= 1.0e-10_dp) THEN
        srcpp = "none.txt" ! No external source
        F_Norm_RF = 0
     ELSE IF (d_sour < -1.0e-10_dp) THEN
        F_Norm_RF = 1
     ELSE IF (d_sour > 1.0e-10_dp) THEN
        F_Norm_RF = 2
     ENDIF
     IF (srcpp == "PP") THEN
        F_RF_PP = 1
     ELSE
        F_RF_PP = 0
     ENDIF

     ! Computes here scaling factors radm and radp for a PP source
     ! Required for some early initializations
     IF (F_Norm_RF /= 0) THEN
        eps = 1.0e-12_dp
        wl_lym = 912.0_dp
        IF (srcpp(1:2) == 'F_') THEN
           fichier = TRIM(data_dir)//'Astrodata/'//srcpp
           OPEN(iread2, file = fichier, status = 'old')
           READ (iread2,*) rstar
           READ (iread2,*) teff
           rstar = rstar * rsun
           READ (iread2,*) nb_pt
           READ (iread2,*)

           IF (ALLOCATED(star_rf)) THEN
              DEALLOCATE(star_rf)
           ENDIF
           ALLOCATE (star_rf(nb_pt,2))

           ! Warning: for historical reasons data in file are per nanometers
           DO ii = 1, nb_pt
              READ (iread2,*) wl, rf
              wl = wl * 10.0_dp      ! convert to Angstrom
              rf = rf * 0.1_dp       ! convert to Angstr-1
              star_rf(ii,1) = wl
              star_rf(ii,2) = rf
           ENDDO
           CLOSE (iread2)

           int_J_Hab = 0.0_dp
           DO ii = 1, nb_pt-1
              IF (star_rf(ii+1,1) < wl_lym) CYCLE
              wl2 = wl_lym
              rf2 = star_rf(ii,2) + (star_rf(ii+1,2) - star_rf(ii,2)) &
                  * (wl2 - star_rf(ii,1)) / (star_rf(ii+1,1) - star_rf(ii,1))
              iid = ii + 1
              EXIT
           ENDDO
           DO ii = iid, nb_pt
              IF (star_rf(ii,1) > wl_hab) EXIT
              wl1 = wl2
              rf1 = rf2
              wl2 = star_rf(ii,1)
              rf2 = star_rf(ii,2)
              int_J_Hab = int_J_Hab + 0.5_dp * (rf1 + rf2) * (wl2 - wl1)
           ENDDO
           wl1 = wl2
           rf1 = rf2
           wl2 = wl_hab
           rf2 = star_rf(ii-1,2) + (star_rf(ii,2) - star_rf(ii-1,2)) &
                * (wl2 - star_rf(ii-1,1)) / (star_rf(ii,1) - star_rf(ii-1,1))
           int_J_Hab = int_J_Hab + 0.5_dp * (rf1 + rf2) * (wl2 - wl1)
        ELSE
           CALL STAR
           int_J_Hab = ROMBERG(wl_lym, wl_hab, eps, BBLT)
        ENDIF

        geom = 0.5_dp * (rstar/(ABS(d_sour)*pccm))**2
        IF (F_Norm_RF == 1) THEN
           radm = 0.5_dp + 0.5_dp * geom * (int_J_Hab / 1.273e-4_dp - 1.0_dp)
        ELSE IF (F_Norm_RF == 2) THEN
           radp = 0.5_dp + 0.5_dp * geom * (int_J_Hab / 1.273e-4_dp - 1.0_dp)
        ENDIF
        print *, teff, wl_lym, wl_hab, int_J_Hab, radm, radp
     ENDIF

     !----------------------------------------------------------------------------
     !--- Flux of cosmic rays
     !----------------------------------------------------------------------------
     READ (iread1,*) fmrc                 ! Flux of cosmic rays will be fmrc * 1E-17 [s-1]
                                          ! TODO : SPECIFY IF IT IS PER H OR PER H2

     !-----------------------------------------------------------------------------
     !--- Data controling the Density / Temperature / Pressure structure of the cloud
     !-----------------------------------------------------------------------------

     READ (iread1,*) ifeqth               ! Flag to control computation of temperature
                                          ! If == 1  : thermal balance is solved
                                          ! If == 0  : isothermal model with T = tg_init or controled
                                          !            by a user defined density - temperature profile
                                          ! If == -1 : switch thermal balance on only after 6 iterations

     READ (iread1,*) tg_init              ! Initial gas temperature in Kelvin

     READ (iread1,*) ifisob_r             ! Flag to control the state equation of the cloud

     READ (iread1,*) fprofil              ! Name of a user defined ASCII file used to control density and
                                          ! temperature at each position

     READ (iread1,*) presse               ! Gas pressure in cm-3 K

     ! Depending on the value of ifisob presse or nh_init are used or re-computed
     SELECT CASE (ABS(ifisob_r))
        CASE (0)
           PRINT *, " ifisob =", ifisob_r, ": isochoric case"
           presse = nh_init * tg_init
        CASE (1)
           PRINT *, " ifisob =", ifisob_r, ": density and temperature profile read from a file"
        CASE (2)
           PRINT *, " ifisob =", ifisob_r, ": isobaric case"
           nh_init = presse / tg_init
        CASE (4)
           PRINT *, " ifisob =", ifisob_r, ": pressure profile read from a file"
        CASE DEFAULT
           PRINT *, " ifisob =", ifisob_r, " is not allowed!"
           STOP
     END SELECT
     IF ((ifisob_r /= 1 .AND. ifisob_r /= -1 .AND. ifisob_r /= 4) .AND. ifeqth /= -1) THEN
        fprofil = "" ! initialisation of the name of the density profile file
     ENDIF

     IF (ifeqth == -1) THEN
        ifisob = 1
     ELSE
        ifisob = ifisob_r
     ENDIF

     !-----------------------------------------------------------------------------
     !--- Data and parameters controling the radiative transfer.
     !-----------------------------------------------------------------------------

     !--- Turbulent velocity ------------------------------------------------------
     READ (iread1,*) vturb                ! Turbulent velocity in km s-1
                                          ! Used only to compute line broadening

     !-----------------------------------------------------------------------------
     !--- H-H2 Collision rates
     !-----------------------------------------------------------------------------
     READ (iread1,*) ichh2                ! TODO: Check routine COLH2V for that parameter

     !------------------------------------------------------------------------------
     !--- Grains properties on the line of sight
     !------------------------------------------------------------------------------
     READ (iread1,"(a41)") los_ext        ! Name of the line of sight : control the Fitzpatrick and Massa
                                          ! extinction curve that will be used
                                          ! ATTENTION: los_ext can have spaces in its name
                                          ! See data/Astrodata/line_of_sight.dat for different possibilities
     los_ext = TRIM(ADJUSTL(los_ext))

     READ (iread1,*) rrv                  ! Rv parameter on the line of sight
     READ (iread1,*) metal                ! Metallicity (abundance of heavy elements and dust relative to input values)
     READ (iread1,*) cdunit_0             ! NH / E(B-V) on the line of sight for a metallicity Z = 1
     READ (iread1,*) g_ratio_0            ! mass of grains / mass of gas for a metallicity Z = 1
     coef2 = tautav * cdunit_0 / rrv      ! coef2 is determined with cdunit for Z = 1. Dust properties will be scaled with Z later

     ! Automatically scale cdunit and g_ratio with metallicity
     cdunit  = cdunit_0  / metal
     g_ratio = g_ratio_0 * metal

     ! Compute mean grain density for Draine's mixture
     rhogr = rhogra * (1.0_dp - amix) + rhosil * amix

     READ (iread1,*) q_pah                ! Mass fraction of PAHs
     READ (iread1,*) alpgr                ! Exponent of the power law for the grain size distribution
     READ (iread1,*) rgrmin               ! Minimum grain radius in cm
     READ (iread1,*) rgrmax               ! Maximum grain radius in cm
     READ (iread1,*) F_DUST_P             ! Flag to control how grains properties and temperature will be computed
                                          ! If == 0 : Simplified method of the PDR code using Fitzpatrick and Massa extinction curve
                                          ! If == 2 : Simplified method of the PDR code using Draine's data on dust properties

     !-----------------------------------------------------------------------------
     !--- H2 formation on grains parameters
     !-----------------------------------------------------------------------------
     READ (iread1,*) iforh2               ! Flag controling how new H2 molecule formed on grains are spread in the
                                          ! various quantum levels of the molecule
     READ (iread1,*) istic                ! Flag to control different prescription for H sticking on grains

     !------------------------------------------------------------------------------
     !--- Read flags affecting the number of output files
     !-----------------------------------------------------------------------------
     READ (iread1,*) F_W_ALL_IFAF          ! Write output files at each ieration (1), or only for the last two (0)

     !------------------------------------------------------------------------------
     !--- Both side irradiation or semi infinite Cloud
     !-----------------------------------------------------------------------------
     ! If radp = 0.0 then we model a semi-infinite cloud
     IF (radp == 0.0_dp) THEN
        isoneside = 1
        radp = 1.0e-10_dp
     ELSE
        isoneside = 0
     ENDIF

     !------------------------------------------------------------------------------
     !--- Close input data file
     !-----------------------------------------------------------------------------
     CLOSE (iread1)

     !---------------------------------------------------------------------------
     !--- Write a summary of input parameters in the log file
     !---------------------------------------------------------------------------
     WRITE (iwrit2,"('========================================================')")
     WRITE (iwrit2,"('===                                                  ===')")
     WRITE (iwrit2,"('===             PDR CODE LOG FILE                    ===')")
     WRITE (iwrit2,"('===                                                  ===')")
     WRITE (iwrit2,"('========================================================')")

     WRITE (iwrit2,*)
     WRITE (iwrit2,"('=== Code Version : ',A)") TRIM(ADJUSTL(version_code))

     ! Commente le temps de voir si ces fonctions sont reconnues avec tous les compilateurs
     !CALL idate(date) ! date(1)=day, (2)=month, (3)=year
     !CALL itime(hour) ! hour(1)=hour, (2)=minute, (3)=second
     !WRITE (iwrit2,*)
     !WRITE (iwrit2,"('Date : ',I2,'/',I2,'/',I4,'  time ',I2,':',I2,':',I2)") date, hour

     WRITE (iwrit2,*)
     WRITE (iwrit2,"('======== Input datafile used for this model : ',A)") TRIM(inpfile)
     WRITE (iwrit2,"(116('-'))")
     WRITE (iwrit2,20001) modele
     WRITE (iwrit2,20002) chimie
     WRITE (iwrit2,20003) ifafm
     WRITE (iwrit2,20004) Avmax
     WRITE (iwrit2,20005) nh_init
     WRITE (iwrit2,20006) F_ISRF
     WRITE (iwrit2,20007) radm_ini
     WRITE (iwrit2,20008) radp_ini
     IF (srcpp == "" .OR. TRIM(ADJUSTL(srcpp)) == "none.txt") THEN
        WRITE (iwrit2,20009) "none.txt                                 "
     ELSE
        WRITE (iwrit2,20009) srcpp
     ENDIF
     WRITE (iwrit2,20010) d_sour
     WRITE (iwrit2,20011) fmrc
     WRITE (iwrit2,20012) ifeqth
     WRITE (iwrit2,20013) tg_init
     WRITE (iwrit2,20014) ifisob_r
     IF (fprofil == "" .OR. fprofil == "none.pfl") THEN
        WRITE (iwrit2,20015) "none.pfl                                 "
     ELSE
        WRITE (iwrit2,20015) fprofil
     ENDIF
     WRITE (iwrit2,20016) presse
     WRITE (iwrit2,20017) vturb
     WRITE (iwrit2,20021) ichh2
     WRITE (iwrit2,20022) los_ext
     WRITE (iwrit2,20023) rrv
     WRITE (iwrit2,20024) metal
     WRITE (iwrit2,20025) cdunit_0
     WRITE (iwrit2,20026) g_ratio_0
     WRITE (iwrit2,20027) q_pah
     WRITE (iwrit2,20028) alpgr
     WRITE (iwrit2,20029) rgrmin
     WRITE (iwrit2,20030) rgrmax
     WRITE (iwrit2,20031) F_DUST_P
     WRITE (iwrit2,20032) iforh2
     WRITE (iwrit2,20033) istic
     WRITE (iwrit2,20045) F_W_ALL_IFAF

     !--------------------------------------------------------------------------
     ! Write FLAGS in the .def file
     !--------------------------------------------------------------------------
     WRITE (iwrit2,*)
     WRITE (iwrit2,"('======== Flags used in the model ==========')")
     WRITE (iwrit2,"('Flag             Default value      Used  ')")
     WRITE (iwrit2,'("F_CO_UV_pum      1                ",i3)') F_CO_UV_pum
     WRITE (iwrit2,'("F_CO_CH_pum      1                ",i3)') F_CO_CH_pum
     WRITE (iwrit2,'("F_H3p_CH_pum     1                ",i3)') F_H3p_CH_pum
     WRITE (iwrit2,'("F_COLL_H3p       0                ",i3)') F_COLL_H3p
     WRITE (iwrit2,'("F_Oat_CH_pum     1                ",i3)') F_Oat_CH_pum
     WRITE (iwrit2,'("F_LINE_TRSF      1                ",i3)') F_LINE_TRSF
     WRITE (iwrit2,'("F_DUST_P         0                ",i3)') F_DUST_P
     WRITE (iwrit2,'("F_QABS_SCALED    0                ",i3)') F_QABS_SCALED
     WRITE (iwrit2,'("F_CHECK_THBAL    0                ",i3)') F_CHECK_THBAL
     WRITE (iwrit2,"('---- Flags related to output files ----')")
     WRITE (iwrit2,'("F_W_BINARY       0                ",i3)') F_W_BINARY
     WRITE (iwrit2,'("F_W_HDF5_STD     1                ",i3)') F_W_HDF5_STD
     WRITE (iwrit2,'("F_W_HDF5_CHE     1                ",i3)') F_W_HDF5_CHE
     WRITE (iwrit2,'("F_W_HDF5_ANA     0                ",i3)') F_W_HDF5_ANA
     WRITE (iwrit2,'("F_W_LINE_MAP     0                ",i3)') F_W_LINE_MAP
     WRITE (iwrit2,'("F_W_RF_ALB       0                ",i3)') F_W_RF_ALB
     WRITE (iwrit2,"('--- Flags controled by pdr.in -------')")
     WRITE (iwrit2,'("F_ISRF           1                ",i3)') F_ISRF
     WRITE (iwrit2,'("F_NORM_RF        0                ",i3)') F_NORM_RF
     WRITE (iwrit2,'("F_RF_PP          0                ",i3)') F_RF_PP
     WRITE (iwrit2,'("F_DUST_P         0                ",i3)') F_DUST_P
     WRITE (iwrit2,'("F_W_ALL_IFAF     0                ",i3)') F_W_ALL_IFAF
     WRITE (iwrit2,"('===========================================')")

     !=====================================================================
     !== PREPARE GRAINS DISTRIBUTION
     !=====================================================================
     WRITE (iscrn,*)
     WRITE (iscrn,*) "--- Prepare grains properties"
     CALL GRPARAM

     !=====================================================================
     !== INITIALIZE CLOUD PROFILE
     !=====================================================================
     WRITE (iscrn,*)
     WRITE (iscrn,*) "--- Initialize density / temperature profile"
     IF (ABS(ifisob) == 1 .OR. ABS(ifisob) == 4) THEN
        CALL INIT_PROFIL_1
     ELSE
        CALL INIT_PROFIL_0
     ENDIF

     !=====================================================================
     !== WRITE some informations in the log files
     !=====================================================================

     WRITE (iwrit2,'(/,"======== Model definition :",/)')

     IF (F_ISRF == 1) THEN
        WRITE (iwrit2,'(5x, "ISRF is from MMP as modified by JLB (F_ISRF =",i2,")")') F_ISRF
        WRITE (iwrit2,'(10x, "(Use F_ISRF = 2 for Draine)")')
     ELSE
        WRITE (iwrit2,'(5x, "ISRF is from Draine (F_ISRF =",i2,")")') F_ISRF
        WRITE (iwrit2,'(10x, "(Use F_ISRF = 1 for MMP+JLB)")')
     ENDIF
     WRITE (iwrit2,'(/,5x,"Left  side radiation field intensity = ",1pe9.2," x ISRF")') radm
     WRITE (iwrit2,'(5x,  "Right side radiation field intensity = ",1pe9.2," x ISRF")') radp
     IF (srcpp == "" .OR. TRIM(ADJUSTL(srcpp)) == "none.txt") THEN
        WRITE (iwrit2,'(5x,"No beamed radiation field perpendiculat to the slab")')
     ELSE IF (srcpp == "PP") THEN
        WRITE (iwrit2,'(5x,"ISRF perpendicular to the cloud (no isotropic)")')
     ELSE IF (srcpp(1:2) == "F_") THEN
        WRITE (iwrit2,'(5x,"Radiation normal to the slab read from: ",a15)') srcpp
        fichier = TRIM(data_dir)//'Astrodata/'//srcpp
        WRITE(iscrn,*) "Opening file : ", TRIM(fichier)
        OPEN(iread2, file = fichier, status = 'old')
        READ (iread2,*) rstar
        READ (iread2,*) teff
        rstar = rstar * rsun
        WRITE (iwrit2,'(5x,"Star distance:             d = ",1pe10.3," pc")') d_sour
        WRITE (iwrit2,'(10x,"(d < 0 : left side, d > 0 : right side)")')
        WRITE (iwrit2,'(5x,"Star radius:          R_star = ",1pe9.2," R_Sun")') rstar / rsun
        WRITE (iwrit2,'(5x,"Effective temperature: T_eff = ",1pe9.2," K")') teff
     ELSE
        WRITE (iwrit2,'(5x,"Radiation normal to the slab is a star of type: ",a15)') srcpp
        WRITE (iwrit2,'(5x,"Star distance:             d = ",1pe10.3," pc")') d_sour
        WRITE (iwrit2,'(10x,"(d < 0 : left side, d > 0 : right side)")')
        WRITE (iwrit2,'(5x,"Star radius:          R_star = ",1pe9.2," R_Sun")') rstar / rsun
        WRITE (iwrit2,'(5x,"Effective temperature: T_eff = ",1pe9.2," K")') teff
     ENDIF
     WRITE (iwrit2,'(/,5x,"Cosmic rays ionisation flux: fmrc = ",f7.2," (* 1e-17 s-1)")') fmrc

     WRITE (iwrit2,'(/,5x,"Radiative transfer approximation:")')
     WRITE (iwrit2,'(10x,"- H Lyman lines use FGK ")')
     WRITE (iwrit2,'(10x,"- All H2 Lyman and Werner lines use FGK")')

     WRITE (iwrit2,2009) ifeqth, ifisob_r, presse
     WRITE (iwrit2,2013) rrv, metal, cdunit_0, cdunit, vturb
     WRITE (iwrit2,2014) g_ratio_0, g_ratio, rhogr, q_pah, alpgr, rgrmin, rgrmax, dsite, s_gr_t
     WRITE (iwrit2,2015) lleg, taumax, Avmax
     WRITE (iwrit2,2018) los_ext, cc1, cc2,cc3, cc4, xgam, y0
     WRITE (iwrit2,2020) tgaz(0), densh(0)

     !=====================================================================
     !== PREPARE BOUNDS OF THE RADIATION FIELD WAVELENGTH GRID
     !== * Compute the Stefan-Boltzmann constant
     !== * Compute H ionisation potential (hiop)
     !== * Compute true H Lyman threshold wl_lym_t
     !== * Set initial value of wl_lym to wl_lym_t (modified below)
     !=====================================================================
     stebol   = 2.0_dp * xpi**5 * xk**4 / (15.0_dp * xhp**3 * clum**2)
     hiop     = 2.0_dp * xpi*xpi * xqe**4 * xme / (xhp*xhp)
     wl_lym_t = 1.0e8_dp*xhp*clum/hiop
     wl_lym   = wl_lym_t
     ! --------------------------------------------
     ! * min wavelength set to ~ 13.6 eV
     ! * max wavelength beyond H longest wavelength
     ! - originally set in RF_INIT
     ! --------------------------------------------
     wlth0 = wl_lym
     wlthm = 2.2e9_dp

     !=====================================================================
     !== READ CHEMISTRY FILE
     !== * list of chemical species to use in the simulation
     !== * initial abundances
     !== * list of chemical reactions
     !=====================================================================
     CALL LECTUR

     !=====================================================================
     !== ALLOCATE THE TABLE CONTAINING THE ABUNDANCES OF THE IONS AND THE
     !== ELECTRONS INVOLVED IN ALL THE RECOMBINATION REACTIONS WITH DUST
     !== ALLOCATE TABLES CONTAINING THE RATES OF THESE REACTIONS.
     !=====================================================================
     ALLOCATE (abions(ngneut))

     !=====================================================================
     !== READ GRAINS PROPERTIES
     !== (required to initialize pumping in INIT_LINES)
     !=====================================================================
     WRITE (iscrn,*)
     WRITE (iscrn,*) "--- Initialize grains physical properties"
     CALL READ_DRAINE_FILES
     CALL MIXGRSI(wlth0, wlthm)
     IF (.NOT. ALLOCATED (xji)) THEN
        ALLOCATE(xji(0:nspec,-izm0:izp0))
        xji = 0.0_dp
        ALLOCATE(frac(-izm0:izp0,npg))
        frac = 0.0_dp
        ALLOCATE (jzmin(npg), jzmax(npg))
        jzmin = 0
        jzmax = 0
     ENDIF

     !=====================================================================
     !== INITIALIZATION OF DETAILED BALANCE DATA
     !=====================================================================
     ! This must be called here to get l0h2
     ! JLB - 6 V 2010 - FEED_LINES has been moved after grain initialisation is complete
     WRITE (iscrn,*)
     WRITE (iscrn,*) "--- Initialize atoms and molecules levels and lines"
     CALL INIT_LINES

     WRITE (iscrn,*) "--- Prepare pumping data for H2 and HD"
     ! set l0h2 and l0hd, number of ro-vibrationnal levels of H2 and HD
     ! used in the model
     l0h2 = spec_lin(in_sp(i_h2))%use
     IF (i_hd /= 0) THEN
        l0hd = spec_lin(in_sp(i_hd))%use
     ENDIF

     ! If l0h2 < 40, it is not possible to have 1/3 of H2 formation
     !    energy in internal energy
     IF (iforh2 == 0 .AND. l0h2 < 40) THEN
        PRINT *, "   WARNING !: iforh2 changed to 1 (not enough internal energy)"
        iforh2 = 1
     ENDIF
     WRITE (iwrit2,2011) l0h2, l0hd, iforh2, istic

     ! Call MAKE_POPHM and MAKE_POPHD once only (l0h2 and l0hd should never change)
     CALL MAKE_POPHM
     IF (i_hd /= 0) THEN
        CALL MAKE_POPHD
     ENDIF

     IF (in_sp(i_h3p) /= 0 .AND. F_H3p_CH_PUM == 1) THEN
        CALL MAKE_POPH3p
     ELSE
        e_int_h3p = 0.0_dp
     ENDIF

     eform_h2 = 0.0_dp
     eform_hd = 0.0_dp

     !--- Oxygen excitation -----------------------------------------------
     CALL MAKE_POPOAT

     !=====================================================================
     !== INITIALIZATION OF ABUNDANCES AND EXCITATION FOR H2, HD and CO
     !== * Level populations
     !== * Collision rates
     !=====================================================================

     temp = tgaz(1)
     DO i = 0, npo
        abnua(1:nspec,i) = abin(1:nspec) * densh(i)
        abnua(nspec+1:n_var,i) = 1.0e-20_dp
     ENDDO

     !- Initialization of H2 levels populations ---------------------------
     IF (i_h2 /= 0) THEN
        h2para = 0.25_dp
        h2orth = 0.75_dp
        xreh2(1,:) = 0.25_dp
        xreh2(2,:) = 0.75_dp
        DO lev = 3, l0h2
           xj = njl_h2(lev)
           xv = nvl_h2(lev)
           xreh2(lev,:) = 10.0_dp**(-(xj+xv))
        ENDDO
     ENDIF

     !- Initialization of HD levels populations ---------------------------
     IF (i_hd /= 0) THEN
        xrehd(1,:) = 0.25_dp
        xrehd(2,:) = 0.75_dp
        DO lev = 3, l0hd
           xj = njl_hd(lev)
           xrehd(lev,:) = 10.0_dp**(-xj)
        ENDDO
     ENDIF

     !- Initialization of CO levels populations ---------------------------
     IF (i_co /= 0) THEN
        xreco(1,:) = 0.2_dp
        xreco(2,:) = 0.4_dp
        xreco(3,:) = 0.3_dp
        xreco(4,:) = 0.1_dp
     ENDIF

     tau(0:npo) = tau_o(0:npo)
     abnua(i_h,0:npo)  = abh_o
     abnua(i_h2,0:npo) = abh2_o
     IF (i_hd /= 0) THEN
        abnua(i_hd,0:npo) = 1.0e-4_dp * abnua(i_h2,0:npo)
     ENDIF

     ! strange initialization ... ask JLB - BG 04/2013
     ! same remark for below and above
     abnua(i_co,0:npo) = 1.0e-4_dp * abnua(i_h2,0:npo)

     IF (i_c13o /= 0) THEN
        abnua(i_c13o,0:npo) = abnua(i_co,0:npo) / r_c13
     ENDIF
     IF (i_co18 /= 0) THEN
        abnua(i_co18,0:npo) = abnua(i_co,0:npo) / r_o18
     ENDIF
     IF (i_c13o18 /= 0) THEN
        abnua(i_c13o18,0:npo) = abnua(i_co,0:npo) / (r_c13 * r_o18)
     ENDIF

     ALLOCATE (abnua_o(0:n_var,0:npo))
     abnua_o = abnua(0:n_var,0:npo)

     !=====================================================================
     !== INITIALIZATION OF COLLISIONAL DATA
     !=====================================================================
     CALL READ_COL

     !=====================================================================
     !== INITIALIZATION OF H2, B and C states
     !=====================================================================
     ! Inverse life times of H2 B and C states
     tmunh2bc = 0.0_dp
     ! Abundances of H2 B and C states
     h2bnua = 0.0_dp
     h2cnua = 0.0_dp

     !=====================================================================
     !== INITIALIZATION OF H2 ELECTRONIC TRANSITIONS DATA
     !=====================================================================
     ! Read H2 radiative transitions files
     !
     !              uvh2b29.dat: Lyman transitions (all v) J <= 29
     !              uvh2c29.dat: Werner transitions (all v) J <= 29
     !
     !              le fichier "uvh2.dat" contient les transitions
     !              radiatives de l hydrogne moleculaire (au 20 juin 88).
     !              complete le 25 sept 90 pour inclure j -> 14.
     !
     !              les fichiers "uvh2b.dat" et "uvh2c.dat" contiennent
     !              les transitions radiatives (lyman et werner)
     !              de l hydrogne moleculaire (au 01 janvier 89).
     !
     !              Completed to J = 29 some times during the 90's...
     !
     !              One transition per line. Relevant data are gathered
     !              into two tables. X is B (Lyman) or C (Werner)
     !              IRAH2X: INTEGER PARAMETERs
     !              PRAH2X: REAL PARAMETERs
     !
     !     IRAxxx:
     !               1: v lower level
     !               2: J lower level
     !               3: v upper level
     !               4: Delta J (J_up = J_low + Delta J)
     !               5: used in full transfer? (0: no, 1: yes)
     !               6: lower limit of line in WL grid
     !               7: upper limit of line in WL grid
     !               8: index of line in WL grid
     !
     !     PRAxxx:
     !               1: oscilator strength
     !               2: wavelength (Angstrom)
     !               3: inverse life time (s-1)
     !               4: Upper level dissociation probability
     !               5: WL min in line profile
     !               6: WL max in line profile

     ALLOCATE (evrdbc(l0h2,l0h2))
     ALLOCATE (evrdhd(l0hd,l0hd))
     ALLOCATE (evcolh(l0h2,l0h2))
     ALLOCATE (evltot(l0h2,l0h2))

     ! Numerical coeficient : 8 pi**2 e**2 / (me * c)   x 1e16 (for Angstrom)
     coefosc = 8.0e16_dp * xpi*xpi * xqe2 / (xme * clum)

     !-------------------------------------------------------------------
     !--- H2 LYMAN TRANSITIONS
     !-------------------------------------------------------------------

     !- 1 - Determine the number of lines to keep -----------------------
     nrh2bt = 0
     fichier = TRIM(data_dir)//'UVdata/uvh2b29.dat'
     WRITE(iscrn,*) "Opening file : ", TRIM(fichier)
     OPEN (iread2, FILE = fichier, STATUS = 'old')
     READ (iread2,"(i8)") nraib

     DO i = 1, nraib
        READ (iread2,*) ii, ira1, nvl, njl, nvu, ndj, pra1, pra2, pra3, pra4
        ! --------------------------------------------------------------------------
        ! two options below. Include the transitions below 912 A or not - BG 04/2013
        ! --------------------------------------------------------------------------
        IF ((lev_h2(nvl,njl) <= l0h2) .AND. (pra2 >= wlth0)) THEN
        !IF ((lev_h2(nvl,njl) <= l0h2) .AND. (pra2 >= wl_lym)) THEN
           nrh2bt = nrh2bt + 1
        ENDIF
     ENDDO
     CLOSE (iread2)
     ALLOCATE (irah2b(nrh2bt,8), prah2b(nrh2bt,6))
     irah2b = 0
     prah2b = 0.0_dp

     !- 2 - Store data --------------------------------------------------
     WRITE(iscrn,*) "Opening file : ", TRIM(fichier)
     OPEN (iread2, FILE = fichier, STATUS = 'old')
     READ (iread2,"(i8)") nraib
     xlamax = 0.0_dp
     j = 0
     aeitb = 0.0_dp
     DO i = 1, nraib
        READ (iread2,*) ii, ira1, nvl, njl, nvu, ndj, pra1, pra2, pra3, pra4
        lev = lev_h2(nvl,njl)
        nju = njl + ndj
        ! --------------------------------------------------------------------------
        ! two options below. Include the transitions below 912 A or not - BG 04/2013
        ! --------------------------------------------------------------------------
        IF ((lev <= l0h2) .AND. (pra2 >= wlth0)) THEN
        !IF ((lev <= l0h2) .AND. (pra2 >= wl_lym)) THEN
           dumy =  coefosc * pra1 / pra2**2 * ((2.0_dp*njl+1.0_dp) / (2.0_dp*nju+1.0_dp))
           aeinb(nvu,nju,lev) = dumy
           aeitb(nvu,nju) = aeitb(nvu,nju) + dumy
           j = j + 1
           irah2b(j,1) = nvl
           irah2b(j,2) = njl
           irah2b(j,3) = nvu
           irah2b(j,4) = ndj
           prah2b(j,1) = pra1
           prah2b(j,2) = pra2
           prah2b(j,3) = pra3
           prah2b(j,4) = pra4
           xlamax = MAX(xlamax,pra2)
           tmunh2bc(ira1,nvu,nju) = pra3 !ira1 precise si Ly ou We
        ENDIF
     ENDDO
     CLOSE (iread2)

     !-------------------------------------------------------------------
     !--- H2 WERNER TRANSITIONS
     !-------------------------------------------------------------------

     !- 1 - Determine the number of lines to keep -----------------------
     nrh2ct = 0
     fichier = TRIM(data_dir)//'UVdata/uvh2c29.dat'
     WRITE(iscrn,*) "Opening file : ", TRIM(fichier)
     OPEN (iread2, FILE = fichier, STATUS = 'old')
     READ (iread2,"(i8)") nraic

     DO i = 1, nraic
        READ (iread2,*) ii, ira1, nvl, njl, nvu, ndj, pra1, pra2, pra3, pra4
        ! --------------------------------------------------------------------------
        ! two options below. Include the transitions below 912 A or not - BG 04/2013
        ! --------------------------------------------------------------------------
        IF ((lev_h2(nvl,njl) <= l0h2) .AND. (pra2 >= wlth0)) THEN
        !IF ((lev_h2(nvl,njl) <= l0h2) .AND. (pra2 >= wl_lym)) THEN
           nrh2ct = nrh2ct + 1
        ENDIF
     ENDDO
     CLOSE (iread2)
     ALLOCATE (irah2c(nrh2ct,8), prah2c(nrh2ct,6))
     irah2c = 0
     prah2c = 0.0_dp

     !- 2 - Store data --------------------------------------------------
     WRITE(iscrn,*) "Opening file : ", TRIM(fichier)
     OPEN (iread2, FILE = fichier, STATUS = 'old')
     READ (iread2,"(i8)") nraic
     j = 0
     aeitc = 0.0_dp
     DO i = 1, nraic
        READ (iread2,*) ii, ira1, nvl, njl, nvu, ndj, pra1, pra2, pra3, pra4
        lev = lev_h2(nvl,njl)
        nju = njl + ndj
        ! --------------------------------------------------------------------------
        ! two options below. Include the transitions below 912 A or not - BG 04/2013
        ! --------------------------------------------------------------------------
        IF ((lev <= l0h2) .AND. (pra2 >= wlth0)) THEN
        !IF ((lev <= l0h2) .AND. (pra2 >= wl_lym)) THEN
           dumy =  coefosc * pra1 / pra2**2 * ((2.0_dp*njl+1.0_dp) / (2.0_dp*nju+1.0_dp))
           aeinc(nvu,nju,lev) = dumy
           IF (ndj == 0) THEN
              aeitc(nvu,nju,2) = aeitc(nvu,nju,2) + dumy
           ELSE
              aeitc(nvu,nju,1) = aeitc(nvu,nju,1) + dumy
           ENDIF
           j = j + 1
           irah2c(j,1) = nvl
           irah2c(j,2) = njl
           irah2c(j,3) = nvu
           irah2c(j,4) = ndj
           prah2c(j,1) = pra1
           prah2c(j,2) = pra2
           prah2c(j,3) = pra3
           prah2c(j,4) = pra4
           xlamax = MAX(xlamax,pra2)
           tmunh2bc(ira1,nvu,nju)=pra3 !ira1 precise si Ly ou We
        ENDIF
     ENDDO
     CLOSE (iread2)

     !-------------------------------------------------------------------
     !--- COMPUTE CASCADE COEFFICIENTS (CASHM, BHMBX, BHMCX)
     !-------------------------------------------------------------------
     CALL CACOEF

     !===================================================================
     !== INITIALIZATION OF HD ELECTRONIC TRANSITIONS DATA
     !===================================================================
     nrhdbt = 0
     nrhdct = 0
     IF (i_hd /= 0) THEN
        ! Read uvhd.dat (same format as H2)
        !
        ! evdihd(levl,levu) : dipole and quadrupole emission probability within X
        ! ahdtq(lev)        : Sum of emission prob from upper level in X over all lower levels
        ! ahdnb(nvu,nju,lev): Emission probabilities B-X from (v,j) to lev
        ! ahdtb(nvu,nju)    : Sum over all lower levels
        ! ahdnc(nvu,nju,lev): idem C-X
        ! ahdtc(nvu,nju,1:2): idem C-X  1: C+
        !                               2: C-

        !- 1 - Determine the number of lines to keep --------------------
        fichier = TRIM(data_dir)//'UVdata/uvhd.dat'
        WRITE(iscrn,*) "Opening file : ", TRIM(fichier)
        OPEN (iread2, FILE = fichier, STATUS = 'old')

        ahdtb = 0.0_dp
        ahdnb = 0.0_dp

        ahdtc = 0.0_dp
        ahdnc = 0.0_dp

        READ (iread2,"(i8)") nrai
        DO ii = 1, nrai
           READ (iread2,*) ira1, nvl, njl, nvu, ndj, pra1, pra2, pra3, pra4, pra5
           lev = lev_hd(nvl,njl)
           ! --------------------------------------------------------------------------
           ! two options below. Include the transitions below 912 A or not - BG 04/2013
           ! --------------------------------------------------------------------------
           IF ((lev <= l0hd) .AND. (pra2 >= wlth0)) THEN
           !IF ((lev <= l0hd) .AND. (pra2 >= wl_lym)) THEN
              IF (ira1 == 1) THEN
                 nrhdbt = nrhdbt + 1
              ELSE
                 nrhdct = nrhdct + 1
              ENDIF
           ENDIF
        ENDDO
        CLOSE (iread2)

        ALLOCATE (irahdb(nrhdbt,7), prahdb(nrhdbt,6))
        ALLOCATE (irahdc(nrhdct,7), prahdc(nrhdct,6))
        irahdb = 0
        irahdc = 0
        prahdb = 0.0_dp
        prahdc = 0.0_dp

        !- 2 - Store data --------------------------------------------------
        ib = 0
        ic = 0
        WRITE(iscrn,*) "Opening file : ", TRIM(fichier)
        OPEN (iread2, FILE = fichier, STATUS = 'old')
        READ (iread2,"(i8)") nrai
        DO ii = 1, nrai
           READ (iread2,*) ira1, nvl, njl, nvu, ndj, pra1, pra2, pra3, pra4, pra5
           lev = lev_hd(nvl,njl)
           ! --------------------------------------------------------------------------
           ! two options below. Include the transitions below 912 A or not - BG 04/2013
           ! --------------------------------------------------------------------------
           IF ((lev <= l0hd) .AND. (pra2 >= wlth0)) THEN
           !IF ((lev <= l0hd) .AND. (pra2 >= wl_lym)) THEN
              IF (ira1 == 1) THEN
                 ib = ib + 1
                 irahdb(ib,1) = nvl
                 irahdb(ib,2) = njl
                 irahdb(ib,3) = nvu
                 irahdb(ib,4) = ndj
                 prahdb(ib,1) = pra1
                 prahdb(ib,2) = pra2
                 prahdb(ib,3) = pra4
                 prahdb(ib,4) = pra5
              ELSE
                 ic = ic + 1
                 irahdc(ic,1) = nvl
                 irahdc(ic,2) = njl
                 irahdc(ic,3) = nvu
                 irahdc(ic,4) = ndj
                 prahdc(ic,1) = pra1
                 prahdc(ic,2) = pra2
                 prahdc(ic,3) = pra4
                 prahdc(ic,4) = pra5
              ENDIF
              xlamax = MAX(xlamax,pra2)
           ENDIF
        ENDDO
        CLOSE (iread2)

        !- Read emission probabilities ----------------------------------

        jmaxi0 = njl_hd(l0hd)
        fichier = TRIM(data_dir)//'UVdata/ahdnb.dat'
        WRITE(iscrn,*) "Opening file : ", TRIM(fichier)
        OPEN(iread2, FILE = fichier, STATUS = 'old')
        READ(iread2,"(//)")
        DO i = 1, 30000
           READ(iread2,4400, END = 310) nvu, nju, nvl, njl, dumy
           IF (nvu > nvbhd .OR. nju > jmaxi0+1 .OR. nvl > nvxhd) CYCLE
           lev = lev_hd(nvl,njl)
           ahdnb(nvu,nju,lev) = dumy
           ahdtb(nvu,nju) = ahdtb(nvu,nju) + dumy
        ENDDO
310     CONTINUE

        fichier = TRIM(data_dir)//'UVdata/ahdnc1.dat'
        WRITE(iscrn,*) "Opening file : ", TRIM(fichier)
        OPEN(iread2, FILE = fichier, STATUS = 'old')
        READ(iread2,"(//)")
        DO i = 1, 30000
           READ(iread2,4400, END = 311) nvu, nju, nvl, njl, dumy
           IF (nvu > nvchd .OR. nju > jmaxi0+1 .OR. nvl > nvxhd) CYCLE
           lev = lev_hd(nvl,njl)
           ahdnc(nvu,nju,lev) = dumy
           ahdtc(nvu,nju,1) = ahdtc(nvu,nju,1) + dumy
        ENDDO
311     CONTINUE

        fichier = TRIM(data_dir)//'UVdata/ahdnc2.dat'
        WRITE(iscrn,*) "Opening file : ", TRIM(fichier)
        OPEN(iread2, FILE = fichier, STATUS = 'old')
        READ(iread2,"(//)")
        DO i = 1, 30000
           READ(iread2,4400, END = 312) nvu, nju, nvl, njl, dumy
           IF (nvu > nvchd .OR. nju > jmaxi0 .OR. nvl > nvxhd) CYCLE
           lev = lev_hd(nvl,njl)
           ahdnc(nvu,nju,lev) = dumy
           ahdtc(nvu,nju,2) = ahdtc(nvu,nju,2) + dumy
        ENDDO
312     CONTINUE

        !----------------------------------------------------------------
        !  HD cascade coefficients CASHD, BHDBX, BHDCX
        !----------------------------------------------------------------
        CALL CACOEFHD

        WRITE(iscrn,*)
        WRITE(iscrn,*) "Maximum wavelength               :", xlamax
        WRITE(iscrn,*) "Nb of Lyman transitions  (nrhdbt):", nrhdbt
        WRITE(iscrn,*) "Nb of Werner transitions (nrhdct):", nrhdct

     ENDIF ! END OF IF ON HD ELECTRONIC DATA

     !===================================================================
     !== INITIALIZATION OF CO ELECTRONIC TRANSITIONS DATA
     !===================================================================
     nrco = 0
     nrc13o = 0
     nrco18 = 0
     nrc13o18 = 0

     ! iraco - 1: lower level J
     !         2: unused
     !         3: unused
     !         4: unused
     !         5: Line considered for full transfer? (0: no, 1: yes)
     !         6: Lower limit of line
     !         7: Upper limit of line
     ! praco - 1: Oscillator strength
     !         2: Wavelength (in Angstrom).
     !         3: Inverse radiative lifetime of upper level (s-1)
     !         4: dissociation probability of upper level
     !         5: lowest WL of line
     !         6: upper WL of line

     !-------------------------------------------------------------------
     !--- CO ELECTRONIC TRANSITIONS DATA
     !-------------------------------------------------------------------
     IF (i_co /= 0) THEN
        fichier = TRIM(data_dir)//'UVdata/UVCO.NW1'
        WRITE(iscrn,*) "Opening file : ", TRIM(fichier)
        OPEN (iread2, FILE = fichier, STATUS = 'old')
        READ (iread2,"(i8)") nrco
        ALLOCATE (iraco(nrco,7), praco(nrco,6))
        iraco = 0
        praco = 0.0_dp
        DO i = 1, nrco
           READ (iread2,*) iraco(i,1), (praco(i,m), m = 1,4)
        ENDDO
        CLOSE (iread2)
     ENDIF

     !-------------------------------------------------------------------
     !--- 13CO ELECTRONIC TRANSITIONS DATA
     !-------------------------------------------------------------------
     IF (i_c13o /= 0) THEN
        fichier = TRIM(data_dir)//'UVdata/UVC13O.NW1'
        WRITE(iscrn,*) "Opening file : ", TRIM(fichier)
        OPEN (iread2, FILE = fichier, STATUS = 'old')
        READ (iread2,"(i8)") nrc13o
        ALLOCATE (irac13o(nrc13o,7), prac13o(nrc13o,6))
        irac13o = 0
        prac13o = 0.0_dp
        DO i = 1, nrc13o
           READ (iread2,*) irac13o(i,1), (prac13o(i,m), m = 1,4)
        ENDDO
        CLOSE (iread2)
     ENDIF

     !-------------------------------------------------------------------
     !--- C18O ELECTRONIC TRANSITIONS DATA
     !-------------------------------------------------------------------
     IF (i_co18 /= 0)  THEN
        fichier = TRIM(data_dir)//'UVdata/UVCO18.NW1'
        WRITE(iscrn,*) "Opening file : ", TRIM(fichier)
        OPEN (iread2, FILE = fichier, STATUS = 'old')
        READ (iread2,"(i8)") nrco18
        ALLOCATE (iraco18(nrco18,7), praco18(nrco18,6))
        iraco18 = 0
        praco18 = 0.0_dp
        DO i = 1, nrco18
           READ (iread2,*) iraco18(i,1), (praco18(i,m), m = 1,4)
        ENDDO
        CLOSE (iread2)
     ENDIF

     !-------------------------------------------------------------------
     !--- 13C18O ELECTRONIC TRANSITIONS DATA
     !-------------------------------------------------------------------
     IF (i_c13o18 /= 0)  THEN
        fichier = TRIM(data_dir)//'UVdata/UVC13O18.NW1'
        WRITE(iscrn,*) "Opening file : ", TRIM(fichier)
        OPEN (iread2, FILE = fichier, STATUS = 'old')
        READ (iread2,"(i8)") nrc13o18
        DO i = 1, nrc13o18
           READ (iread2,*) irac13o18(i), (prac13o18(i,m), m = 1,4)
        ENDDO
        CLOSE (iread2)
     ENDIF

     !===================================================================
     !== ???
     !===================================================================

     ! Compute the total number of UV lines
     !  Note: This is probably too large if full transfer is done for lowest
     !        lying levels of H2. Can we adjust that number easily?

     mfgk = nrh2bt + nrh2ct + nrhdbt + nrhdct + nrco + nrc13o + nrco18 + nrc13o18

     ALLOCATE (fgkgrd(mfgk))

     !==================================
     !== COMPUTE CO CASCADE COEFFICIENTS
     !==================================

     IF (i_co /=0 .AND. F_CO_UV_pum == 1) THEN
        CALL CAS_CO
     ENDIF

!.......................................................................
20001 FORMAT (2x,A41,5x,      "! modele   : Output file basename")
20002 FORMAT (2x,A41,5x,      "! chimie   : Chemistry file name")
20003 FORMAT (1x,I3,44x,      "! ifafm    : Number of global iterations")
20004 FORMAT (1x,1p,e9.2,38x, "! Avmax    : Integration limit (Av)")
20005 FORMAT (1x,1p,e9.2,38x, "! densh    : Initial density (nH = n(H) + 2n(H2) in cm-3)")
20006 FORMAT (2x,I1,45x,      "! F_ISRF   : (ISRF shape) 1 = Mathis, 2 = Draine")
20007 FORMAT (1x,1p,e9.2,38x, "! radm     : Scaling factor to ISRF (Observer side)")
20008 FORMAT (1x,1p,e9.2,38x, "! radp     : Scaling factor to ISRF (Back side)")
20009 FORMAT (2x,A41,5x,      "! srcpp    : Additional plan parallel rad.field (Ex:Star)")
20010 FORMAT (1x,1p,e9.2,38x, "! d_sour   : Star distance (pc) (<0 : Obs. side, >0 Back side)")
20011 FORMAT (1x,1p,e9.2,38x, "! fmrc     : Cosmic rays ionisation rate = 5*10-17 H2 ionization per s")
20012 FORMAT (1x,I2,45x,      "! ifeqth   : thermal Balance (1 : solved, 0 : fixed T)")
20013 FORMAT (1x,1p,e9.2,38x, "! tgaz     : Initial temperature (K)")
20014 FORMAT (2x,I1,45x,      "! ifisob   : State equation (0: nH = cste, 1: user profile, 2: isobaric)")
20015 FORMAT (2x,A41,5x,      "! fprofil  : Temperature-density profile filename")
20016 FORMAT (1x,1p,e9.2,38x, "! presse   : Initial Pressure (cm-3 K, used only in isobaric models)")
20017 FORMAT (1x,1p,e9.2,38x, "! vturb    : turbulent velocity [km s-1] used for Doppler broadening")
20021 FORMAT (2x,I1,45x,      "! ichh2    : H + H2 collision rate model (2 is standard)")
20022 FORMAT (2x,A41,5x,      "! los_ext  : Line of sight extinction curve")
20023 FORMAT (1x,1p,e9.2,38x, "! rrr      : Rv = Av / E(B-V)  (Typical value 3.1)")
20024 FORMAT (1x,1p,e9.2,38x, "! metal    : metallicity (automatically scales cdunit, gratio, & elemental abundances)")
20025 FORMAT (1x,1p,e9.2,38x, "! cdunit   : NH / E(B-V) for Z = 1, in cm-2 (Galaxy: 5.8e21)")
20026 FORMAT (1x,1p,e9.2,38x, "! gratio   : Mass grains / mass gas for Z = 1 (typical : 0.01; Draine2003 : 6.3e-3)")
20027 FORMAT (1x,1p,e9.2,38x, "! q_pah    : Dust mass fraction in PAHs - default 4.6e-02)")
20028 FORMAT (1x,1p,e9.2,38x, "! alpgr    : grains distribution index (MRN dist. : 3.5)")
20029 FORMAT (1x,1p,e9.2,38x, "! rgrmin   : Grains minimum radius (in cm)")
20030 FORMAT (1x,1p,e9.2,38x, "! rgrmax   : Grains maximum radius (in cm)")
20031 FORMAT (2x,I1,45x,      "! F_DUST_P : 0 - Without DUSTEM, F&M coef / 2 - Without DUSTEM, Draine coef")
20032 FORMAT (2x,I1,45x,      "! iforh2   : H2 formation on grains model (0 is standard)")
20033 FORMAT (2x,I1,45x,      "! istic    : H2 sticking on grain model (4 is standard)")
20045 FORMAT (2x,I1,45x,      "! F_W_ALL_IFAF : 1 = Write output file at each iteration, 0 = only for the two last iterations.")

 2009 FORMAT ( &
         5x,'Thermal balance (no: 0, yes: 1)      = ',i5,/, &
         5x,'Equation of state: ifisob            = ',i5,/, &
         12x,'0: Constant density nH',/, &
         12x,'1: nH and T interpolated from a file',/, &
         12x,'2: Isobaric (nH * T = Cte)',/, &
         12x,'3: Analytical temperature profile',/, &
         12x,'5: Fractal density profile (experimental)',/, &
         5x,'external Pressure: (if needed)       = ',1pe10.2, &
            ' K cm-3')
 2011 FORMAT (5x,'H2 levels PARAMETERs:',/, &
              5x,'l0h2 = ',i4,//, &
              5x,'HD levels PARAMETERs:',/, &
              5x,'l0hd = ',i4,//, &
              5x,'H2 formation on grains: iforh2 = ',i4,/, &
              15x,'0: Mean internal energy is 1/3 E(H2 formation)',/, &
              15x,'1: Maxwell distribution at 1/3 E(H2 formation)',/, &
              15x,'2: All on v = 14, J = 0 or 1 (obsolete)',/, &
              15x,'3: Maxwell distrib at 65 K on v = 6 (obsolete)',//, &
              5x,'H sticking on grains:    istic = ',i4,/ &
              15x,'1: Sticking READ in chemistry file',/, &
              15x,'2: Modified from Sternberg & Dalgarno',/, &
              15x,'3: Modified from Andersson & Wannier',/, &
              15x,'4: Modified from Flower & des Forets',/)
 2013 FORMAT (5x,'Extinction and gas to dust PARAMETERs:',/, &
              5x,'      rrv   = ',f10.3,10x,'Av = rrv * E(B-V)',/, &
              5x,'    metal   = ',1pe9.2,/, &
              5x,'   cdunit_0 = ',1pe9.2,10x,'NH = cdunit * E(B-V) for Z = 1',//, &
              5x,'   cdunit   = ',1pe9.2,10x,'NH = cdunit * E(B-V) for Z',//, &
              5x,'turbulent velocity: vturb = ',e10.3,' cm s-1')
 2014  FORMAT (/,&
              5x,'Mass ratio (gas/grains):     g_ratio_0 = ',1pe10.2,' for Z = 1',/, &
              5x,'Mass ratio (gas/grains):     g_ratio   = ',1pe10.2,/, &
              5x,'Grains density :               rhogr   = ',e10.2, &
                 ' g cm-3',/, &
              5x,'Mass fraction in PAHs:        q_pah    = ',e10.2,' cm',/, &
              5x,'Size distribution exponent:    alpgr   = ',0pf6.2,/, &
              5x,'Grains min radius:            rgrmin   = ',1pe10.2, &
                 ' cm',/, &
              5x,'Grains max radius:            rgrmax   = ',e10.2,' cm',/, &
              5x,'Mean dist between adsorption sites     = ',e10.2,' cm',/, &
              5x,'Surface of grain per nucleon  s_gr_t   = ',e10.2,' cm2 / H')
 2015 FORMAT (/, &
              5x,'Order of Legendre expansion:    lleg   = ',i3,//, &
              5x,'Total optical depth:          taumax   = ',e10.2,/, &
              5x,'                         i.e.  Avmax   = ',e10.2)
 2018  FORMAT (/,5x,'Extinction curve :',a10,/, &
                 5x,'Fitzpatrick & Massa coefs:',1x,6f8.3,/)
 2020  FORMAT (5x,'Initial temperature:            ',1pe12.2,' K',/, &
               5x,'Initial density:                ',e12.2,' cm-3')
 4400  FORMAT (i3,5x,i3,5x,i3,5x,i3,5x,d13.6)
!.......................................................................

END SUBROUTINE INIT1

!=========================================================================
! SUBROUTINE CACOEF
! Compute H2 cascade coefficients
! - bhmbx, bhmcx : cascade coefficients for fluorescence Lyman and Werner
! - cashm        : cascade coefficients inside the X state
!
!=========================================================================
SUBROUTINE CACOEF

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

  IMPLICIT NONE

  REAL (KIND=dp), DIMENSION (nlevh2,nlevh2)    :: cscad
  INTEGER                                      :: j
  INTEGER                                      :: num  ! Line number in the datafile (not used)
  INTEGER                                      :: levu ! Index of the upper level
  INTEGER                                      :: levl ! Index of the lower level
  INTEGER                                      :: nj0, nv0, k, ndj0
  INTEGER                                      :: ndj
  INTEGER                                      :: njl, nju, nj, nvu
  REAL (KIND=dp)                               :: total, total1, total2
  REAL (KIND=dp)                               :: dviei, dviei1, dviei2
  REAL (KIND=dp)                               :: as     ! Energy of the transition in K
  REAL (KIND=dp)                               :: aq     ! De-excitation coefficient (Aul) in s-1
  INTEGER                                      :: nrh2q  ! Number of H2 quadrupole lines
  REAL (KIND=dp), ALLOCATABLE, DIMENSION (:,:) :: evlqua ! H2 quadrupole transitions
  REAL (KIND=dp), ALLOCATABLE, DIMENSION (:)   :: aeitq  ! Total quadrupole prob of emission
  CHARACTER(LEN=1)                             :: caract

  ALLOCATE (evlqua(nlevh2,nlevh2))
  ALLOCATE (aeitq(nlevh2))
  evlqua(:,:) = 0.0_dp  ! Initialization to 0 is important. It is used later to get Aij = 0 if i < j
  aeitq(:)    = 0.0_dp  ! Initialization to 0 is important. It is used later to get Aij = 0 if i < j

  !--- Get molecular data for H2 ro-vibrationnal transitions in the ground electronic state
  fichier = TRIM(data_dir)//'Lines/line_h2.dat'
  WRITE(iscrn,*) "Opening file : ", TRIM(fichier)
  OPEN (iwrtmp, FILE = fichier, STATUS = 'old')
  READ (iwrtmp,"(A1)",ADVANCE="NO") caract   ! On second line, first character is a #, we jump it
  READ (iwrtmp,*) nrh2q                      ! Number of ro-vibrationnal transitions in the data file
  READ (iwrtmp,*)
  READ (iwrtmp,*)
  READ (iwrtmp,*)
  DO j = 1, nrh2q                            ! Read data
     READ (iwrtmp,*) num, levu, levl, as, aq ! index of the line (not used), index of upper level, index of lower level
                                             ! energy of the transition in K, Einstein de-excitation coeff.
     evlqua(levl,levu) = - aq                ! We store Einstein coeff from levu to levl
     aeitq(levu) = aeitq(levu) + aq          ! Total de-excitation probability of level "levu"
  ENDDO
  CLOSE (iwrtmp)

  DO levu = 1, nlevh2
     evlqua(levu,levu) = aeitq(levu)     ! Store on the diagonal of the matrix, the inverse lifetimes of the levels.
  ENDDO

  ! evlqua(levl,levu) / aeitq(levl) = p_levu,levl (Eq. 26)
  !                                 = fraction of all dissociations from levu going directly to levl

  ! l0h2 : index of the upper ro-vib level of H2 for which populations will be computed
  nj0 = njl_h2(l0h2)   ! Get the J quantum number of this level
  nv0 = nvl_h2(l0h2)   ! Get the v quantum number of this level.
  WRITE (iscrn,1001)  l0h2, nv0, nj0, spec_lin(in_sp(i_h2))%elk(l0h2)
  WRITE (iwrit2,1001) l0h2, nv0, nj0, spec_lin(in_sp(i_h2))%elk(l0h2)

  WRITE(iscrn,*)
  WRITE(iscrn,*) 'Nb of Lyman transitions (nrh2bt)', nrh2bt
  WRITE(iscrn,*) '      Werner            (nrh2ct)', nrh2ct

  !--- Compute cascade coefficients ---------------------------------------------------------------
  ! Reference : Viala, Roueff & Abgrall (1988), A&A, 190, 215-236
  !
  ! * nlevh2 is the number of ro-vibrationnal levels of H2 in the ground electronic state
  ! * l0h2h2 is the number of ro-vibrationnal levels of H2 for which we compute level populations
  ! To save computing time, l0h2 <= nlevh2.
  ! Populations of levels between l0h2 and nlevh2 are not directly computed. Because these levels
  ! are mainly populated only by fluorescence and chemistry, we can use the cascade formalism to
  ! take into account their contribution to the populations of levels <= l0h2.
  !------------------------------------------------------------------------------------------------

  cscad(:,:) = 0.0_dp   ! Initialization

  !--- Cascade coefficients for levels upper than l0h2 ------------------
  ! Computed by recurence starting from upper levels - Eq. 33
  !
  ! cashm(levu,levl) = probability that level levu de-excite towards levl by any radiative path

  DO levl = nlevh2, l0h2+1, -1
     cscad(levl,levl) = 1.0_dp   ! By definition (Eq. 31)
     DO levu = levl+1, nlevh2
        total = 0.0_dp
        DO k = levl+1, levu
           IF (aeitq(k) == 0.0_dp) CYCLE
           total = total - cscad(levu,k) * evlqua(levl,k) / aeitq(k)
        ENDDO
        cscad(levu,levl) = total
     ENDDO
  ENDDO

  DO levl = 1, l0h2
     DO levu = l0h2+1, nlevh2
        total = 0.0_dp
        DO k = l0h2+1, levu
           IF (aeitq(k) == 0.0_dp) CYCLE
           total = total - cscad(levu,k) * evlqua(levl,k) / aeitq(k)
        ENDDO
        cashm(levu,levl) = total
     ENDDO
  ENDDO

  DEALLOCATE (evlqua)
  DEALLOCATE (aeitq)

  !--- Verification of cashm -------------------------------------------
  ! Sum over lower levels must be 1 (total number of molecules is constant)

  DO levu = l0h2+1, nlevh2
     nvu = nvl_h2(levu)
     nju = njl_h2(levu)
     total = 1.0_dp
     DO levl = 1, l0h2
        total = total - cashm(levu,levl)
     ENDDO
     IF (ABS(total) > 1.0e-8_dp .AND.  total /= 1.0_dp) THEN
        PRINT *, 'pb CASHM!:', nvu, nju, total, levu
     ENDIF
  ENDDO

  !--- Compute de-excitation from excited electronic states ---------------------------------------
  ! * nvbh2 : highest vibrationnal quantum number of B state
  ! * nvch2 : highest vibrationnal quantum number of C state
  ! * njh2  : highest rotationnal quantum number included in data for electronic states
  !
  ! Compute bhmbx(levl, nju, nvu) and bhmcx(levl, nju, nvu)
  ! * bhmbx(levl, nju, nvu) = probability that level vu,Ju of B state de-excite towards levl by any path

  ALLOCATE (bhmbx(l0h2,0:njh2+1,0:nvbh2))
  ALLOCATE (bhmcx(l0h2,0:njh2+1,0:nvch2))

  !--- Lyman transitions - compute bhmbx
  DO nvu = 0, nvbh2                  ! v of the level of the B state
     DO nju = 0, njh2+1              ! J of the level of the B state
        dviei = aeitb(nvu,nju)       ! Inverse lifetime of level nvu, nju of B state (sum of Aij)
        IF (dviei == 0.0_dp) CYCLE
        DO levl = 1, l0h2
           total = 0.0_dp
           DO levu = l0h2+1, nlevh2
              total = total + aeinb(nvu,nju,levu) * cashm(levu,levl)
           ENDDO
           total = total + aeinb(nvu,nju,levl)
           bhmbx(levl,nju,nvu) = total / dviei
        ENDDO
     ENDDO
  ENDDO

  !--- Verification of bhmbx ---------------------------------------
  DO nvu = 0, nvbh2
     DO nju = 0, njh2+1
        dviei = aeitb(nvu,nju)
        IF (dviei == 0.0_dp) CYCLE
        total = 1.0_dp
        DO levl = 1, l0h2
           njl = njl_h2(levl)
           total = total - bhmbx(levl,nju,nvu)
        ENDDO
        IF (ABS(total) > 1.0e-8_dp) THEN
           PRINT *, 'pb BHMBX!:',nvu,nju,total
        ENDIF
     ENDDO
  ENDDO

  !--- Werner transitions - compute bhmcx
  !    Beware of Lambda-doubling!
  !    Each sub-level is identified only using Delta-J parity
  !    This is a bit tricky (and dangerous). Should we be more systematic?

  DO nvu = 0, nvch2
     DO nju = 1, njh2+1
        dviei1 = aeitc(nvu,nju,1)
        dviei2 = aeitc(nvu,nju,2)
        IF (dviei1 == 0.0_dp .AND. dviei2 == 0.0_dp) CYCLE
        DO levl = 1, l0h2
           njl = njl_h2(levl)
           ndj0 = ABS(nju - njl)
           IF (MOD(ndj0,2) == 0 .AND. dviei2 /= 0.0_dp) THEN
              total = 0.0_dp
              DO levu = l0h2+1, nlevh2
                 nj = njl_h2(levu)
                 ndj = ABS(nju - nj)
                 IF (ndj /= 0) CYCLE
                 total = total + aeinc(nvu,nju,levu) * cashm(levu,levl)
              ENDDO
              total = total + aeinc(nvu,nju,levl)
              bhmcx(levl,nju,nvu) = total / dviei2
           ELSE IF (MOD(ndj0,2) == 1 .AND. dviei1 /= 0.0_dp) THEN
              total = 0.0_dp
              DO levu = l0h2+1, nlevh2
                 nj = njl_h2(levu)
                 ndj = ABS(nju - nj)
                 IF (ndj /= 1) CYCLE
                 total = total + aeinc(nvu,nju,levu) * cashm(levu,levl)
              ENDDO
              total = total + aeinc(nvu,nju,levl)
              bhmcx(levl,nju,nvu) = total / dviei1
           ENDIF
        ENDDO
     ENDDO
  ENDDO

  !--- Verification of bhmcx ---------------------------------------
  DO nvu = 0, nvch2
     DO nju = 1, njh2+1
        dviei1 = aeitc(nvu,nju,1)
        dviei2 = aeitc(nvu,nju,2)
        IF (dviei1 == 0.0_dp .AND. dviei2 == 0.0_dp) CYCLE
        total1 = 1.0_dp
        total2 = 1.0_dp
        DO levl = 1, l0h2
           njl = njl_h2(levl)
           ndj = ABS(nju - njl)
           IF (MOD(ndj,2) == 0) THEN
              total2 = total2 - bhmcx(levl,nju,nvu)
           ELSE IF (MOD(ndj,2) == 1) THEN
              total1 = total1 - bhmcx(levl,nju,nvu)
           ENDIF
        ENDDO
        IF ((ABS(total1) > 1.0e-8_dp .OR. ABS(total2) > 1.0e-8_dp) &
                 .AND. nju /= njh2+1) THEN
           PRINT *, 'CX!:',nvu, nju, total1, total2
        ENDIF
     ENDDO
  ENDDO

!--------+---------+---------+---------+---------+---------+---------+-*-------+

 1001  FORMAT(/,1x,'Levels from 1 to ',i4, ' are included',/ &
       ,1x,'Last level is: v:',i4,' J:',i4,/ &
       ,1x,'Last level energy is:',f15.3,' K',/)
!--------+---------+---------+---------+---------+---------+---------+-*-------+

END SUBROUTINE CACOEF

!--- HD cascade coefficients --------------------------------
!      see Astron. Astrophys. 190, 215-236 (1988)

!%%%%%%%%%%%%%%%%%%
SUBROUTINE CACOEFHD
!%%%%%%%%%%%%%%%%%%

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

  IMPLICIT NONE

  REAL (KIND=dp), DIMENSION (nlevhd,nlevhd)    :: cscad
  INTEGER                                      :: nj0, nv0, k, j
  INTEGER                                      :: levl, levu, ndj
  INTEGER                                      :: num, njl, nju, nj, nvu, jmaxi0
  REAL (KIND=dp)                               :: total, total1, total2
  REAL (KIND=dp)                               :: dviei, dviei1, dviei2
  INTEGER                                      :: nrhdq    ! Number of HD dipole and quadrupole lines (
  REAL (KIND=dp), ALLOCATABLE, DIMENSION (:,:) :: evdihd   ! HD dipole and quadrupole transiti
  REAL (KIND=dp), ALLOCATABLE, DIMENSION (:)   :: ahdtq    ! Total quadrupole prob of emission
  REAL (KIND=dp)                               :: as, aq
  CHARACTER(LEN=1)                             :: caract

  nj0 = njl_hd(l0hd)
  nv0 = nvl_hd(l0hd)
  WRITE (iscrn,1001) l0hd, nv0, nj0, spec_lin(in_sp(i_hd))%elk(l0hd)
  WRITE (iwrit2,1001) l0hd, nv0, nj0, spec_lin(in_sp(i_hd))%elk(l0hd)

  ALLOCATE (evdihd(nlevhd,nlevhd))
  ALLOCATE (ahdtq(nlevhd))
  ahdtq = 0.0_dp
  evdihd = 0.0_dp

! Dipole and quadrupole emission probabilities of HD

  fichier = TRIM(data_dir)//'Lines/line_hd.dat'
  WRITE(iscrn,*) "Opening file : ", TRIM(fichier)
  OPEN (iwrtmp, FILE = fichier, STATUS = 'old')
  READ (iwrtmp,"(A1)",ADVANCE="NO") caract
  READ (iwrtmp,*) nrhdq
  READ (iwrtmp,*)
  READ (iwrtmp,*)
  READ (iwrtmp,*)
  DO j = 1, nrhdq
     READ (iwrtmp,*) num, levu, levl, as, aq
     evdihd(levl,levu) = - aq
     ahdtq(levu) = ahdtq(levu) + aq
  ENDDO
  CLOSE (iwrtmp)

  DO levu = 1, nlevhd
     evdihd(levu,levu) = ahdtq(levu)
  ENDDO

!   initialisation

  cscad = 0.0_dp

!  Same logic as for H2

  DO levl = nlevhd, l0hd+1, -1
     njl = njl_hd(levl)
     cscad(levl,levl) = 1.0_dp
     DO levu = levl+1, nlevhd
        nju = njl_hd(levu)
        total = 0.0_dp
        DO k = levl+1, levu
           nj = njl_hd(k)
           IF (ahdtq(k) == 0.0_dp) CYCLE
           total = total - cscad(levu,k) * evdihd(levl,k) / ahdtq(k)
        ENDDO
        cscad(levu,levl) = total
     ENDDO
  ENDDO

!       PRINT *, '    cscad computed'

  DO levl = 1, l0hd
     njl = njl_hd(levl)
     DO levu = l0hd+1, nlevhd
        nju = njl_hd(levu)
        total = 0.0_dp
        DO k = l0hd+1, levu
           nj = njl_hd(k)
           IF (ahdtq(k) == 0.0_dp) CYCLE
           total = total - cscad(levu,k) * evdihd(levl,k) / ahdtq(k)
        ENDDO
        cashd(levu,levl) = total
     ENDDO
  ENDDO

  DEALLOCATE (evdihd)
  DEALLOCATE (ahdtq)

!  Verify CASHD:

  DO levu = l0hd+1, nlevhd
     nvu = nvl_hd(levu)
     nju = njl_hd(levu)
     total = 1.0_dp
     DO levl = 1, l0hd
        njl = njl_hd(levl)
        total = total - cashd(levu,levl)
     ENDDO
     IF (ABS(total) > 1.0e-8_dp .AND. total /= 1.0_dp) THEN
        PRINT *, 'pb CASHD!:',nvu,nju,total,levu
     ENDIF
  ENDDO

!      PRINT *, '    cashd computed'

!  Compute bhdbx

  jmaxi0 = njl_hd(l0hd)
  DO nvu = 0, nvbhd
     DO nju = 0, jmaxi0+1
        dviei = ahdtb(nvu,nju)
        IF (dviei == 0.0_dp) CYCLE
        DO levl = 1, l0hd
           njl = njl_hd(levl)
           total = 0.0_dp
           DO levu = l0hd+1, nlevhd
              nj = njl_hd(levu)
              total = total + ahdnb(nvu,nju,levu) * cashd(levu,levl)
           ENDDO
           total = total + ahdnb(nvu,nju,levl)
           bhdbx(nvu,nju,levl) = total / dviei
        ENDDO
     ENDDO
  ENDDO

  DO nvu = 0, nvbhd
     DO nju = 1, jmaxi0+1
        dviei = ahdtb(nvu,nju)
        IF (dviei == 0.0_dp) CYCLE
        total = 1.0_dp
        DO levl = 1, l0hd
           njl = njl_hd(levl)
           total = total - bhdbx(nvu,nju,levl)
        ENDDO
        IF (ABS(total) > 1.0e-8_dp) THEN
           PRINT *, 'pb BHDBX!:',nvu,nju,total
        ENDIF
     ENDDO
  ENDDO

!      PRINT *, '    bhdbx computed'

!  Compute BHDCX
!    Same tick as H2 for Lamda-doubling

!  From C-

  DO nvu = 0, nvchd
     DO nju = 1, jmaxi0
        dviei2 = ahdtc(nvu,nju,2)
        IF (dviei2 == 0.0_dp) CYCLE
        DO levl = 1, l0hd
           njl = njl_hd(levl)
           IF (dviei2 /= 0.0_dp) THEN
              total = 0.0_dp
              DO levu = l0hd+1, nlevhd
                 nj = njl_hd(levu)
                 ndj = ABS(nju - nj)
                 IF (ndj /= 0) CYCLE
                 total = total + ahdnc(nvu,nju,levu) * cashd(levu,levl)
              ENDDO
              ndj = ABS(nju - njl_hd(levl))
              IF (ndj == 0) total = total + ahdnc(nvu,nju,levl)
              bhdcmx(nvu,nju,levl) = total / dviei2
           ENDIF
        ENDDO
     ENDDO
  ENDDO

!  From C+

  DO nvu = 0, nvchd
     DO nju = 1, jmaxi0+1
        dviei1 = ahdtc(nvu,nju,1)
        IF (dviei1 == 0.0_dp) CYCLE
        DO levl = 1, l0hd
           njl = njl_hd(levl)
           IF (dviei1 /= 0.0_dp) THEN
              total = 0.0_dp
              DO levu = l0hd+1, nlevhd
                 nj = njl_hd(levu)
                 ndj = ABS(nju - nj)
                 IF (ndj /= 1) CYCLE
                 total = total + ahdnc(nvu,nju,levu) * cashd(levu,levl)
              ENDDO
              ndj = ABS(nju - njl_hd(levl))
              IF (ndj == 1)  total = total + ahdnc(nvu,nju,levl)
              bhdcpx(nvu,nju,levl) = total / dviei1
           ENDIF
        ENDDO
     ENDDO
  ENDDO

!  test bhdcx

  DO nvu = 0, nvchd
     DO nju = 1, jmaxi0+1
        dviei1 = ahdtc(nvu,nju,1)
        dviei2 = ahdtc(nvu,nju,2)
        IF (dviei1 == 0.0_dp .AND. dviei2 == 0.0_dp) CYCLE
        total1 = 1.0_dp
        total2 = 1.0_dp
        DO levl = 1, l0hd
           njl = njl_hd(levl)
           ndj = ABS(nju - njl)
           total2 = total2 - bhdcmx(nvu,nju,levl)
           total1 = total1 - bhdcpx(nvu,nju,levl)
        ENDDO
        IF ((ABS(total1) > 1.0e-8_dp .OR. ABS(total2) > 1.0e-8_dp) .AND. nju /= jmaxi0+1) THEN
           PRINT *, 'CX!:',nvu, nju, total1, total2
        ENDIF
     ENDDO
  ENDDO

!--------+---------+---------+---------+---------+---------+---------+-*-------+

 1001  FORMAT(/,1x,'Levels from 1 to ',i4, ' are included',/ &
       ,1x,'Last level is: v:',i4,' J:',i4,/ &
       ,1x,'Last level energy is:',f15.3,' K',/)
!--------+---------+---------+---------+---------+---------+---------+-*-------+

END SUBROUTINE CACOEFHD

!%%%%%%%%%%%%%%%%
SUBROUTINE CAS_CO
!%%%%%%%%%%%%%%%%

   USE PXDR_FLAGS
   USE PXDR_CONSTANTES
   USE PXDR_STR_DATA
   USE PXDR_CHEM_DATA

   IMPLICIT NONE

   ! Number of levels in X
   INTEGER                                        :: nlX
   ! Number of transitions in X and A
   INTEGER                                        :: ntX
   INTEGER                                        :: nt_CO_A

   INTEGER, ALLOCATABLE, DIMENSION (:)            :: vX, JX

   INTEGER                                        :: ii, ll
   INTEGER                                        :: lMX
   REAL (KIND=dp)                                 :: X1, X2
   REAL (KIND=dp), ALLOCATABLE, DIMENSION (:,:)   :: Aij_X
   REAL (KIND=dp), ALLOCATABLE, DIMENSION (:)     :: Ai_X, Ai_A
   REAL (KIND=dp), ALLOCATABLE, DIMENSION (:,:)   :: Pij_X, Pij_A
   REAL (KIND=dp), ALLOCATABLE, DIMENSION (:,:)   :: Cij_A
   INTEGER                                        :: levu, levl
   INTEGER                                        :: i1, i2, i3, i4, i5

   CHARACTER(len=1)                               :: caract

   PRINT *, "# Computing CO cascade coefficients"

   ! Read full CO levels from X
   fichier = TRIM(data_dir)//'Levels/level_co.dat'
   OPEN (iwrtmp, FILE=fichier, STATUS="old")
   READ (iwrtmp,'(/,1x,i5,//////)') nlX
   ALLOCATE (vX(nlX), JX(nlX))

   DO ll = 1, nlX
      READ (iwrtmp,*) ii, X1, X2, vX(ll), JX(ll)
   ENDDO
   CLOSE (iwrtmp)

   ! Find highest J used
   lMX = spec_lin(in_sp(i_co))%use
   J_CO_max = MAXVAL(JX(1:lMX)) + 1

   ! Read full CO levels from A
   fichier = TRIM(data_dir)//'UVdata/level_co_A.dat'
   OPEN (iwrtmp, FILE=fichier, STATUS="old")
   READ (iwrtmp,'(/,1x,i5,///////)') nl_CO_A
   ALLOCATE (v_CO_A(nl_CO_A), J_CO_A(nl_CO_A), p_CO_A(nl_CO_A))

   DO ll = 1, nl_CO_A
      READ (iwrtmp,*) ii, X1, X2, v_CO_A(ll), J_CO_A(ll), p_CO_A(ll)
   ENDDO
   CLOSE (iwrtmp)

   ! Build reverse pointer
   ALLOCATE (lev_CO_A(0:MAXVAL(v_CO_A),0:MAXVAL(J_CO_A),0:1))
   DO ll = 1, nl_CO_A
      lev_CO_A(v_CO_A(ll),J_CO_A(ll),p_CO_A(ll)) = ll
   ENDDO

   ! Read X-X transition probabilities
   ALLOCATE (Aij_X(nlX,nlX))
   Aij_X = 0.0_dp
   fichier = TRIM(data_dir)//'Lines/line_co.dat'
   OPEN (iwrtmp, FILE=fichier, STATUS="old")
   READ (iwrtmp,"(A1)",ADVANCE="NO") caract   ! On second line, first character is a #, we jump it
   READ (iwrtmp,*) ntX                        ! Number of ro-vibrationnal transitions in the data file
   READ (iwrtmp,*)
   READ (iwrtmp,*)
   READ (iwrtmp,*)
   DO ll = 1, ntX
      READ (iwrtmp,*) ii, levu, levl, X1, Aij_X(levu,levl)
   ENDDO
   CLOSE (iwrtmp)

   ! Read A-X transition probabilities
   ALLOCATE (Aij_CO_A(nl_CO_A,nlX))
   ALLOCATE (lam_CO_A(nl_CO_A,nlX))
   Aij_CO_A = 0.0_dp
   lam_CO_A = 0.0_dp
   fichier = TRIM(data_dir)//'UVdata/line_co_A.dat'
   OPEN (iwrtmp, FILE=fichier, STATUS="old")
   READ (iwrtmp,'(/,1x,i5,11/)') nt_CO_A

   DO ll = 1, nt_CO_A
      READ (iwrtmp,*) ii, levu, levl, X1, Aij_CO_A(levu,levl), i1, i2, i3, i4, i5, lam_CO_A(levu,levl)
   ENDDO
   CLOSE (iwrtmp)

   ! Compute inverse radiative life times Ai
   ALLOCATE (Ai_X(nlX))
   Ai_X = 0.0_dp
   DO levu = 2, nlX
      DO levl = 1, levu-1
         Ai_X(levu) = Ai_X(levu) + Aij_X(levu,levl)
      ENDDO
   ENDDO

   ALLOCATE (Ai_A(nlX))
   Ai_A = 0.0_dp
   DO levu = 1, nl_CO_A
      IF (J_CO_A(levu) > J_CO_max) THEN
         CYCLE
      ENDIF
      DO levl = 1, nlX
         Ai_A(levu) = Ai_A(levu) + Aij_CO_A(levu,levl)
      ENDDO
   ENDDO

   ! Compute Pij
   ALLOCATE (Pij_X(nlX,nlX))
   Pij_X = 0.0_dp
   DO levu = 2, nlX
      Pij_X(levu,levu) = 1.0_dp
      IF (Ai_X(levu) /= 0.0_dp) THEN
         DO levl = 1, levu-1
            Pij_X(levu,levl) = Aij_X(levu,levl) / Ai_X(levu)
         ENDDO
      ENDIF
   ENDDO

   ALLOCATE (Pij_A(nl_CO_A,nlX))
   Pij_A = 0.0_dp
   DO levu = 1, nl_CO_A
      IF (J_CO_A(levu) > J_CO_max) THEN
         CYCLE
      ENDIF
      IF (Ai_A(levu) /= 0.0_dp) THEN
         DO levl = 1, nlX
            Pij_A(levu,levl) = Aij_CO_A(levu,levl) / Ai_A(levu)
         ENDDO
      ENDIF
   ENDDO

   ! List A levels connected to each lowest X
   ii = 0
   DO levl = 1, lMX
      ll = 0
      DO levu = 1, nl_CO_A
         IF (Aij_CO_A(levu,levl) /= 0.0_dp) THEN
            ll = ll + 1
         ENDIF
      ENDDO
      ii = MAX (ii,ll)
   ENDDO
   ALLOCATE (lm_CO_A(lMX,0:ii))
   lm_CO_A = 0
   DO levl = 1, lMX
      ll = 0
      DO levu = 1, nl_CO_A
         IF (Aij_CO_A(levu,levl) /= 0.0_dp) THEN
            ll = ll + 1
            lm_CO_A(levl,ll) = levu
         ENDIF
      ENDDO
      lm_CO_A(levl,0) = ll
   ENDDO

!  DO levl = 1, lMX
!     PRINT *, lm_CO_A(levl,:)
!  ENDDO

   ! Compute Cij_A (coef C in text)
   ! Index order for Cij_A reverted to optimize computing time
   ALLOCATE (Cij_A(nlX,nl_CO_A))
   Cij_A = 0.0_dp
   DO levu = 1, nl_CO_A
      IF (J_CO_A(levu) > J_CO_max) THEN
         CYCLE
      ENDIF
      Cij_A(nlX,levu) = Pij_A(levu,nlX)
      DO levl = nlX-1, lMX+1, -1
         X1 = Pij_A(levu,levl)
         DO ll = levl+1, nlX
            X1 = X1 + Cij_A(ll,levu) * Pij_X(ll,levl)
         ENDDO
         Cij_A(levl,levu) = X1
      ENDDO
   ENDDO
   PRINT *, " # Cij_A done"

   ! Compute Cij_CO_X (coef C' in text)
   ALLOCATE (Cij_CO_X(nl_CO_A,lMX))
   Cij_CO_X = 0.0_dp
   DO levu = 1, nl_CO_A
      IF (J_CO_A(levu) > J_CO_max) THEN
         CYCLE
      ENDIF
      DO levl = 1, lMX
         X1 = Pij_A(levu,levl)
         DO ll = lMX+1, nlX
            X1 = X1 + Cij_A(ll,levu) * Pij_X(ll,levl)
         ENDDO
          Cij_CO_X(levu,levl) = X1
      ENDDO
   ENDDO
   PRINT *, " # Cij_CO_X done"

   ! Allocate coupling matrix
   ALLOCATE (UV_exc_CO(lMX,lMX))

   DEALLOCATE (vX, JX)
   DEALLOCATE (Aij_X)
   DEALLOCATE (Ai_X)
   DEALLOCATE (Ai_A)
   DEALLOCATE (Pij_X)
   DEALLOCATE (Pij_A)
   DEALLOCATE (Cij_A)

END SUBROUTINE CAS_CO

!%%%%%%%%%%%%%%%%%%%
SUBROUTINE COMP_DIST
!%%%%%%%%%%%%%%%%%%%

  USE PXDR_FLAGS
  USE PXDR_CONSTANTES
  USE PXDR_PROFIL
  USE PXDR_STR_DATA

  IMPLICIT NONE
  INTEGER                                    :: i
  INTEGER                                    :: iloc

!--------------------------------------------------------------------
! distance (cm)
!--------------------------------------------------------------------

   PRINT *, "Compute distance"
   IF (ALLOCATED(d_cm)) THEN
      DEALLOCATE(d_cm)
      DEALLOCATE(dd_cm)
   ENDIF
   ALLOCATE(d_cm(0:npo))
   ALLOCATE(dd_cm(0:npo))
   d_cm(:) = 0.0_dp
   dd_cm(:) = 0.0_dp
   CALL RF_LOCATE (rf_wl, V_band_wl, iloc)
   DO i = 1, npo ! d_cm(0) = 0
      dd_cm(i) = (1.0_dp / ((du_prop%abso(iloc) + du_prop%scat(iloc)) * dens_o(i)) &
                 + 1.0_dp / ((du_prop%abso(iloc) + du_prop%scat(iloc)) * dens_o(i-1))) &
                 * 0.5_dp * dtau_o(i)
      d_cm(i) = d_cm(i-1) + dd_cm(i)
   ENDDO

END SUBROUTINE COMP_DIST

!=========================================================================
! CALC_EXTRA
! Computes some quantities derived from true variables
! Some of them used to be computed in prep
!=========================================================================

SUBROUTINE CALC_EXTRA

  USE PXDR_FLAGS
  USE PXDR_CONSTANTES
  USE PXDR_CHEM_DATA
  USE PXDR_PROFIL
  USE PXDR_STR_DATA

  IMPLICIT NONE
  INTEGER                                    :: i, j
  INTEGER                                    :: iopt
  REAL(KIND=dp)                              :: cden
  INTEGER                                    :: isp, j_sp
  REAL (KIND=dp), ALLOCATABLE, DIMENSION (:) :: codesp0, codesp1
  INTEGER                                    :: ind_sp        ! index of species in spec_lin
  INTEGER                                    :: lev           ! level index
  INTEGER                                    :: lev_J         ! H2 rotational level
  INTEGER                                    :: lev_v         ! H2 vibrational level
  REAL (KIND=dp)                             :: ortho_h2      ! H2 ortho populations (abundances)
  REAL (KIND=dp)                             :: para_h2       ! H2 para  populations (abundances)
  REAL (KIND=dp)                             :: para_h2_tot   ! H2 para  populations (cd - all levels)
  REAL (KIND=dp)                             :: para_h2_emi   ! H2 para  populations (cd - J>1 levels)
  REAL (KIND=dp)                             :: para_h2_vib   ! H2 para  populations (cd - v>0 levels)
  REAL (KIND=dp)                             :: ortho_h2_tot  ! H2 ortho populations (cd - all levels)
  REAL (KIND=dp)                             :: ortho_h2_emi  ! H2 ortho populations (cd - J>1 levels)
  REAL (KIND=dp)                             :: ortho_h2_vib  ! H2 ortho populations (cd - all levels)

  CALL COMP_DIST

!--------------------------------------------------------------------
! COLUMN DENSITIES
!--------------------------------------------------------------------

   IF (ALLOCATED(codesp)) DEALLOCATE(codesp)
   ALLOCATE(codesp(0:nspec,0:npo))
   !--- Species column densities ------------------------------------
   ! 17 Oct 2011: use dd_cm (ds) to integrate
   codesp(:,:) = 0.0_dp
   DO iopt = 1, npo
      DO isp = 1, nspec
         cden = 0.5_dp * dd_cm(iopt) * (abnua(isp,iopt) + abnua(isp,iopt-1))
         codesp(isp,iopt) = codesp(isp,iopt-1) + cden
      ENDDO
   ENDDO

   !--- Total column density ----------------------------------------
   IF (.NOT. ALLOCATED(totcoldens)) ALLOCATE(totcoldens(1:nspec))
   totcoldens(1:nspec) = codesp(1:nspec,npo)

!--------------------------------------------------------------------
! Proton column density
!--------------------------------------------------------------------

   IF (ALLOCATED(protoncd)) DEALLOCATE(protoncd)
   ALLOCATE(protoncd(0:npo))
   protoncd(:) = 0.0_dp
   DO i = 1, npo
      protoncd(i) = codesp(i_h,i) + 2.0_dp * codesp(i_h2,i)
      IF (i_hp /= 0) THEN
         protoncd(i) = protoncd(i) + codesp(i_hp,i)
      ENDIF
   ENDDO

!--------------------------------------------------------------------
! Molecular fraction computed from abundances
!--------------------------------------------------------------------

   IF (ALLOCATED(molfrac_ab)) DEALLOCATE(molfrac_ab)
   ALLOCATE(molfrac_ab(0:npo))
   molfrac_ab(:) = 0.0_dp
   DO iopt = 0, npo
      IF (i_hp /= 0) THEN
         molfrac_ab(iopt) = 2.0_dp * abnua(i_h2,iopt) &
                          / (abnua(i_hp,iopt) + abnua(i_h,iopt) + 2.0_dp * abnua(i_h2,iopt))
      ELSE
          molfrac_ab(iopt) = 2.0_dp * abnua(i_h2,iopt) &
                          / (abnua(i_h,iopt) + 2.0_dp * abnua(i_h2,iopt))
      ENDIF
   ENDDO

!--------------------------------------------------------------------
! Molecular fraction computed from column density
!--------------------------------------------------------------------

   IF (ALLOCATED(molfrac_cd)) DEALLOCATE(molfrac_cd)
   ALLOCATE(molfrac_cd(0:npo))
   molfrac_cd(:) = 0.0_dp
   DO iopt = 1, npo
      IF (i_hp /= 0) THEN
         molfrac_cd(iopt) = 2.0_dp * codesp(i_h2,iopt) &
                          / (codesp(i_hp,iopt) + codesp(i_h,iopt) + 2.0_dp * codesp(i_h2,iopt))
      ELSE
         molfrac_cd(iopt) = 2.0_dp * codesp(i_h2,iopt) &
                          / (codesp(i_h,iopt) + 2.0_dp * codesp(i_h2,iopt))
      ENDIF
   ENDDO

!--------------------------------------------------------------------
! T01 - H2 Excitation temperature from abundances
!--------------------------------------------------------------------

   j_sp = in_sp(i_h2)

   IF (ALLOCATED(T01_ab)) DEALLOCATE(T01_ab)
   ALLOCATE(T01_ab(0:npo))
   T01_ab(:) = 0.0_dp
   DO iopt = 0, npo
      T01_ab(iopt) = -1.0_dp  * spec_lin(j_sp)%elk(2) &
                   / LOG(spec_lin(j_sp)%xre(2,iopt)/(9.0_dp * spec_lin(j_sp)%xre(1,iopt)))
   ENDDO

!--------------------------------------------------------------------
! T01 - H2 Excitation temperature from column densities
!--------------------------------------------------------------------

   IF (ALLOCATED(T01_cd)) DEALLOCATE(T01_cd)
   IF (ALLOCATED(codesp0)) DEALLOCATE(codesp0)
   IF (ALLOCATED(codesp1)) DEALLOCATE(codesp1)

   ALLOCATE(T01_cd(0:npo), codesp0(0:npo), codesp1(0:npo))
   !--- Species column densities ------------------------------------
   codesp0(:) = 0.0_dp
   codesp1(:) = 0.0_dp
   T01_cd(:)  = 0.0_dp
   ! 17 Oct 2011: integrate over dd_cm (ds)
   DO iopt = 1, npo
      cden = 0.5_dp * dd_cm(iopt) * (spec_lin(j_sp)%xre(1,iopt) + spec_lin(j_sp)%xre(1,iopt-1))
      codesp0(iopt) = codesp0(iopt-1) + cden
      cden = 0.5_dp * dd_cm(iopt) * (spec_lin(j_sp)%xre(2,iopt) + spec_lin(j_sp)%xre(2,iopt-1))
      codesp1(iopt) = codesp1(iopt-1) + cden
      T01_cd(iopt) = -spec_lin(j_sp)%elk(2) / LOG(codesp1(iopt)/(9.0_dp * codesp0(iopt)))
   ENDDO
   DEALLOCATE(codesp0)
   DEALLOCATE(codesp1)

!--------------------------------------------------------------------
! H2 Ortho-Para ratio (H2OPR) computed with abundances
!--------------------------------------------------------------------

   IF (ALLOCATED(h2opr_ab)) DEALLOCATE(h2opr_ab)
   ALLOCATE(h2opr_ab(0:npo))
   ind_sp = in_sp(i_h2)
   DO iopt = 0, npo
      ortho_h2 = 0.0d0
      para_h2  = 0.0d0
      DO lev = 1, l0h2
         lev_J = njl_h2(lev)
         IF (MOD(lev_J,2) == 0) THEN
             para_h2  = para_h2  + spec_lin(ind_sp)%xre(lev,iopt)
          ELSE
             ortho_h2 = ortho_h2 + spec_lin(ind_sp)%xre(lev,iopt)
          ENDIF
      ENDDO
      h2opr_ab(iopt) = ortho_h2/para_h2
   ENDDO

!--------------------------------------------------------------------
! H2 Ortho-Para ratio (H2OPR) computed with column densities
!--------------------------------------------------------------------

   IF (ALLOCATED(h2opr_cd_tot)) DEALLOCATE(h2opr_cd_tot)
   IF (ALLOCATED(h2opr_cd_emi)) DEALLOCATE(h2opr_cd_emi)
   IF (ALLOCATED(h2opr_cd_vib)) DEALLOCATE(h2opr_cd_vib)
   ALLOCATE(h2opr_cd_tot(0:npo))
   ALLOCATE(h2opr_cd_emi(0:npo))
   ALLOCATE(h2opr_cd_vib(0:npo))
   h2opr_cd_tot(0) = 0.0d0
   h2opr_cd_emi(0) = 0.0d0
   h2opr_cd_vib(0) = 0.0d0
   ind_sp = in_sp(i_h2)
   DO iopt = 1, npo
      para_h2_tot  = spec_lin(ind_sp)%CoD(1,iopt)
      para_h2_emi  = 0.0d0
      para_h2_vib  = 0.0d0
      ortho_h2_tot = spec_lin(ind_sp)%CoD(2,iopt)
      ortho_h2_emi = 0.0d0
      ortho_h2_vib = 0.0d0
      DO lev = 3, l0h2
         lev_J = njl_h2(lev)
         IF (lev_J > njh2) CYCLE
         lev_v = nvl_h2(lev)
         IF (MOD(lev_J,2) == 0) THEN
            para_h2_tot = para_h2_tot + spec_lin(ind_sp)%CoD(lev,iopt)
            para_h2_emi = para_h2_emi + spec_lin(ind_sp)%CoD(lev,iopt)
            IF (lev_v >= 1) para_h2_vib = para_h2_vib + spec_lin(ind_sp)%CoD(lev,iopt)
         ELSE
            ortho_h2_tot = ortho_h2_tot + spec_lin(ind_sp)%CoD(lev,iopt)
            ortho_h2_emi = ortho_h2_emi + spec_lin(ind_sp)%CoD(lev,iopt)
            IF (lev_v >= 1) ortho_h2_vib = ortho_h2_vib + spec_lin(ind_sp)%CoD(lev,iopt)
         ENDIF
      ENDDO
      h2opr_cd_tot(iopt) = ortho_h2_tot / para_h2_tot
      h2opr_cd_emi(iopt) = ortho_h2_emi / para_h2_emi
      h2opr_cd_vib(iopt) = ortho_h2_vib / para_h2_vib
   ENDDO

!--------------------------------------------------------------------
! IONIZATION DEGREE
!--------------------------------------------------------------------

!   PRINT *, "Compute ionization degree"
   IF (ALLOCATED(ionidegree)) DEALLOCATE(ionidegree)
   ALLOCATE(ionidegree(0:npo))
   ionidegree(:) = 0.0_dp
   DO iopt = 0, npo
      ionidegree(iopt) = abnua(nspec,iopt) / densh(iopt)
   ENDDO

!--------------------------------------------------------------------
! TOTAL DENSITY
!--------------------------------------------------------------------

   PRINT *, "Compute total density"
   IF (ALLOCATED(totdensity)) DEALLOCATE(totdensity)
   ALLOCATE(totdensity(0:npo))
   totdensity(:) = 0.0_dp
   DO i = 0, npo
      DO j = 1, nspec
         totdensity(i) = totdensity(i) + abnua(j,i)
      ENDDO
   ENDDO

!--------------------------------------------------------------------
! PRESSURE
!--------------------------------------------------------------------

   PRINT *, "Compute gas pressure"
   IF (ALLOCATED(gaspressure)) DEALLOCATE(gaspressure)
   ALLOCATE(gaspressure(0:npo))
   gaspressure(:) = 0.0_dp
   DO i = 0, npo
      gaspressure(i) = totdensity(i) * tgaz(i)
   ENDDO

!--------------------------------------------------------------------
! visual extinction (mag)
!--------------------------------------------------------------------

   PRINT *, "Compute Visual Ext"
   IF (ALLOCATED(visualext)) DEALLOCATE(visualext)
   ALLOCATE(visualext(0:npo))
   visualext(:) = 0.0_dp
   DO i = 0, npo
      visualext(i) = tau(i) * tautav
   ENDDO

!--------------------------------------------------------------------
! Elementary Abundances
!--------------------------------------------------------------------

   !DO i = 1, natom - 1  ! ael(natom) corresponds to charge and not a relative abundance
   !   WRITE(iscrn,'("Elementary abundances of ",a5,": ",1p,e12.4," [relative to H]")') &
   !        l_atom(i)%name, l_atom(i)%abnorm
   !ENDDO

END SUBROUTINE CALC_EXTRA

!%%%%%%%%%%%%%%%%
SUBROUTINE REALL1
!%%%%%%%%%%%%%%%%

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

  IMPLICIT NONE

  INTEGER        :: i, ii

  i = SIZE(tau_o)
  IF (ALLOCATED(tmptau)) DEALLOCATE(tmptau)
  ALLOCATE(tmptau(0:i-1))
  tmptau = tau_o

  ! Interpolate old temperature on new tau grid
  IF (ALLOCATED (tgaz_oo)) DEALLOCATE (tgaz_oo)
  ALLOCATE (tgaz_oo(0:npo+1))
  ii = 0
  DO i = 0, npo
     CALL LOC_IND (ii, 0, SIZE(tmptau)-1, tau(i), tmptau)
     raptau = (tau(i) - tmptau(ii)) / (tmptau(ii+1) - tmptau(ii))
     tgaz_oo(i) = tgaz_o(ii) + (tgaz_o(ii+1) - tgaz_o(ii)) * raptau
  ENDDO
  tgaz_oo(npo+1) = tgaz_oo(npo)

  ! First PROFIL related quantities
  DEALLOCATE (tau_o)
  DEALLOCATE (dtau_o)
  DEALLOCATE (abh_o)
  DEALLOCATE (abh2_o)
  DEALLOCATE (tgaz_o)
  DEALLOCATE (dens_o)
  DEALLOCATE (abnua_o)

  ALLOCATE (tau_o(0:npo))
  ALLOCATE (dtau_o(0:npo))
  ALLOCATE (abh_o(0:npo))
  ALLOCATE (abh2_o(0:npo))
  ALLOCATE (tgaz_o(0:npo+1))
  ALLOCATE (dens_o(0:npo))
  ALLOCATE (abnua_o(0:n_var,0:npo))

  tau_o(0:npo) = tau(0:npo)
  dtau_o(0:npo) = dtau(0:npo)
  dens_o(0:npo) = densh(0:npo)
  abnua_o(0:n_var,0:npo) = abnua(0:n_var,0:npo)
  tgaz_o(0:npo) = tgaz(0:npo)
  tgaz_o(npo+1) = tgaz(npo)
  abh_o(0:npo) = abnua(i_h,0:npo)
  abh2_o(0:npo) = abnua(i_h2,0:npo)

END SUBROUTINE REALL1

!%%%%%%%%%%%%%%%
SUBROUTINE REALL
!%%%%%%%%%%%%%%%

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

  IMPLICIT NONE

  INTEGER                                    :: k, j, ii, i
  INTEGER                                    :: nb, nuse
  REAL (KIND=dp)                             :: xremin, vt2
  REAL (KIND=dp), ALLOCATABLE, DIMENSION (:) :: xre, xre_o
  REAL (KIND=dp), ALLOCATABLE, DIMENSION (:) :: tgaz_lp
  CHARACTER(LEN=128)                         :: fichin
  INTEGER                                    :: nlev_use_old
  REAL (KIND=dp)                             :: lgrtau

  ! Then SPECTRA related quantities
  vt2 = vturb * vturb
  ALLOCATE (xre(0:npo))
  ALLOCATE (xre_o(0:npo))
  ALLOCATE (tgaz_lp(0:npo))
  tgaz_lp(0:npo) = tgaz_o(0:npo)
  CALL LOWPASS1 (npo, tgaz_lp)
  !open (37, file="T_filtr.dat", status="unknown")
  !do i = 0, npo
  !   write (37,*) tau_o(i)*tautav, tgaz_o(i), tgaz_lp(i)
  !enddo
  !close (37)

  DO k = 1, nspl
    ! PRINT *, "Preparation of ",TRIM(spec_lin(k)%nam), " related quantities"
    DEALLOCATE (spec_lin(k)%abu)
    ALLOCATE (spec_lin(k)%abu(0:npo))

    spec_lin(k)%abu = abnua(spec_lin(k)%ind,0:npo)
    IF (spec_lin(k)%ind == j_c13o .AND. i_c13o == 0 .AND. i_co /= 0) THEN
      spec_lin(in_sp(j_c13o))%abu = abnua(i_co,0:npo) / r_c13
    ENDIF
    IF (spec_lin(k)%ind == j_co18 .AND. i_co18 == 0 .AND. i_co /= 0) THEN
      spec_lin(in_sp(j_co18))%abu = abnua(i_co,0:npo) / r_o18
    ENDIF
    IF (spec_lin(k)%ind == j_c13o18 .AND. i_c13o18 == 0 .AND. i_co /= 0) THEN
      spec_lin(in_sp(j_c13o18))%abu = abnua(i_co,0:npo) / (r_c13 * r_o18)
    ENDIF

    DEALLOCATE (spec_lin(k)%vel)
    ALLOCATE (spec_lin(k)%vel(0:npo))

!   spec_lin(k)%vel = SQRT(vt2 + deksamu * tgaz_o(0:npo) / spec_lin(k)%mom)
    spec_lin(k)%vel = SQRT(vt2 + deksamu * tgaz_lp(0:npo) / spec_lin(k)%mom)

    DEALLOCATE (spec_lin(k)%ref)
    ALLOCATE (spec_lin(k)%ref(0:npo))

    ! Interpolate old populations on new tau grid
    nb   = spec_lin(k)%nlv
    nuse = spec_lin(k)%use
    DEALLOCATE (spec_lin(k)%xre_o)
    ALLOCATE (spec_lin(k)%xre_o(nb,0:npo))
    DO j = 1, nuse
       ii = 0
       DO i = 0, npo
          CALL LOC_IND (ii, 0, SIZE(tmptau)-1, tau_o(i), tmptau)
          raptau = (tau_o(i) - tmptau(ii)) / (tmptau(ii+1) - tmptau(ii))
          IF ( (ii == 0) .OR. (ii == npo) ) THEN
             lgrtau = 0
          ELSE
             lgrtau = LOG( tau_o(i) / tmptau(ii) ) / LOG( tmptau(ii+1) / tmptau(ii) )
          ENDIF
          ! linear interpolation
          ! xre_o(i) = spec_lin(k)%xre(j,ii) + (spec_lin(k)%xre(j,ii+1) - spec_lin(k)%xre(j,ii)) * raptau
          ! logarithmic interpolation
          xre_o(i) = LOG( spec_lin(k)%xre(j,ii) ) + lgrtau * LOG( spec_lin(k)%xre(j,ii+1) / spec_lin(k)%xre(j,ii) )
          xre_o(i) = EXP( xre_o(i) )
       ENDDO
       spec_lin(k)%xre_o(j,:) = xre_o(:)
    ENDDO
    ! Renormalize populations
    DO i = 0, npo
       spec_lin(k)%xre_o(1:nuse,i) = spec_lin(k)%xre_o(1:nuse,i) / SUM(spec_lin(k)%xre_o(1:nuse,i))
    ENDDO

    DEALLOCATE (spec_lin(k)%xre)
    DEALLOCATE (spec_lin(k)%XXl)
    DEALLOCATE (spec_lin(k)%XXr)
    DEALLOCATE (spec_lin(k)%CoD)
    ALLOCATE (spec_lin(k)%xre(nb,0:npo))
    ALLOCATE (spec_lin(k)%XXl(nb,0:npo))
    ALLOCATE (spec_lin(k)%XXr(nb,0:npo))
    ALLOCATE (spec_lin(k)%CoD(nb,0:npo))

    nb = spec_lin(k)%ntr
    DEALLOCATE (spec_lin(k)%odl)
    DEALLOCATE (spec_lin(k)%odr)
    DEALLOCATE (spec_lin(k)%dnu)
    DEALLOCATE (spec_lin(k)%emi)
    DEALLOCATE (spec_lin(k)%optdep)
    DEALLOCATE (spec_lin(k)%dint)
    DEALLOCATE (spec_lin(k)%siD)
    DEALLOCATE (spec_lin(k)%pum)
    DEALLOCATE (spec_lin(k)%jiD)
    DEALLOCATE (spec_lin(k)%bel)
    DEALLOCATE (spec_lin(k)%ber)
    ALLOCATE (spec_lin(k)%odl(nb,0:npo))
    ALLOCATE (spec_lin(k)%odr(nb,0:npo))
    ALLOCATE (spec_lin(k)%dnu(nb,0:npo))
    ALLOCATE (spec_lin(k)%emi(nb,0:npo))
    ALLOCATE (spec_lin(k)%optdep(nb,0:npo))
    ALLOCATE (spec_lin(k)%dint(nb,0:npo))
    ALLOCATE (spec_lin(k)%siD(nb))
    ALLOCATE (spec_lin(k)%pum(0:npo,nb))
    ALLOCATE (spec_lin(k)%jiD(nb,0:npo))
    ALLOCATE (spec_lin(k)%bel(nb,0:npo))
    ALLOCATE (spec_lin(k)%ber(nb,0:npo))
    spec_lin(k)%optdep(:,:) = -10000.0_dp
    spec_lin(k)%dint(:,:)   = -10000.0_dp

    CALL REF_RE (spec_lin(k)%ind, xre)
    spec_lin(k)%ref = xre(0:npo)

    nlev_use_old = spec_lin(k)%use
    DO j = spec_lin(k)%use, 1, -1
      CALL AB_REL (spec_lin(k)%ind, xre, j)
      spec_lin(k)%xre(j,:) = xre(0:npo)
      xremin = MAXVAL(xre(0:npo))
      ! Suppress not useful levels from statistical equilibrium
      IF (xremin < 1.0e-50_dp) THEN
        spec_lin(k)%use = MAX(j-1,spec_lin(k)%usemin)
      ENDIF
    ENDDO
    ! If number of levels has been modified, update list of lines
    IF (spec_lin(k)%use .NE. nlev_use_old) THEN
       PRINT *, " Reduce number of levels for ", spec_lin(k)%nam, " from:", nlev_use_old &
              , " to:", spec_lin(k)%use
       fichin = TRIM(data_dir)//"Lines/line_"//TRIM(spec_lin(k)%nam)//".dat"
       CALL READ_DATALINE(fichin, spec_lin(k))
       IF (TRIM(spec_lin(k)%nam) == "h2") THEN
          PRINT *, " WARNING: l0h2 must be updated too!"
          STOP
       ENDIF
       IF (TRIM(spec_lin(k)%nam) == "hd") THEN
          PRINT *, " WARNING: l0hd must be updated too!"
          STOP
       ENDIF
    ENDIF

    spec_lin(k)%XXl = 0.0_dp
    spec_lin(k)%XXr = 0.0_dp
    spec_lin(k)%CoD = 0.0_dp
    spec_lin(k)%odl = 0.0_dp
    spec_lin(k)%odr = 0.0_dp
    spec_lin(k)%dnu = 0.0_dp
    spec_lin(k)%emi = 0.0_dp
    spec_lin(k)%pum = 0.0_dp
    spec_lin(k)%jiD = 0.0_dp
    spec_lin(k)%bel = 0.0_dp
    spec_lin(k)%ber = 0.0_dp
  ENDDO

  CALL CDT_WRAP

  IF (i_co /= 0) THEN
    DEALLOCATE (eqrco)
    ALLOCATE (eqrco(spec_lin(in_sp(i_co))%use))
  ENDIF

  IF (i_co /= 0 .AND. j_c13o /= 0) THEN
    DEALLOCATE (eqrc13o)
    ALLOCATE (eqrc13o(spec_lin(in_sp(j_c13o))%use))
  ENDIF

  IF (i_co /= 0 .AND. j_co18 /= 0) THEN
    DEALLOCATE (eqrco18)
    ALLOCATE (eqrco18(spec_lin(in_sp(j_co18))%use))
  ENDIF

  IF (i_co /= 0 .AND. j_c13o18 /= 0) THEN
    DEALLOCATE (eqrc13o18)
    ALLOCATE (eqrc13o18(spec_lin(in_sp(j_c13o18))%use))
  ENDIF

  DEALLOCATE (xre)
  DEALLOCATE (xre_o)
  DEALLOCATE (tgaz_lp)

END SUBROUTINE REALL

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
SUBROUTINE AB_REL (ind, xre, j)
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

  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)                            :: j
  REAL (KIND=dp), INTENT (OUT), DIMENSION (0:npo) :: xre

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

END SUBROUTINE AB_REL

!%%%%%%%%%%%%%%%%%%%%%%%%%%%
SUBROUTINE REF_RE (ind, xre)
!%%%%%%%%%%%%%%%%%%%%%%%%%%%

  USE PXDR_FLAGS
  USE PXDR_CONSTANTES
  USE PXDR_CHEM_DATA
  USE PXDR_PROFIL
  USE PXDR_STR_DATA

  IMPLICIT NONE

  INTEGER, INTENT (IN)                            :: ind
  REAL (KIND=dp), INTENT (OUT), DIMENSION (0:npo) :: xre

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

END SUBROUTINE REF_RE

!%%%%%%%%%%%%%%%%%%%%
SUBROUTINE MAKE_POPHM
!%%%%%%%%%%%%%%%%%%%%

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

  IMPLICIT NONE

  REAL (KIND=dp) :: ospg, tform, ech
  REAL (KIND=dp) :: tf_min, tf_max, res
  REAL (KIND=dp) :: dumy, ej0
  INTEGER        :: lev, ij, iv, ivf
  INTEGER        :: levu, iju, ivu
  REAL (KIND=dp) :: e_form_ch

!  H2 and HD formation distribution on grains
!  O/P ratio is usually 3/4 ortho et 1/4 para, but can be changed
!  using variable ospg

  ospg = 3.0_dp
! ospg = 1.0_dp

! black & van dishoeck, formation phi = 1
!     apj, 322, 412 (1987), eform_h2 = 12098 cm-1
!     Not used any more.

  pophm1(:,:) = 0.0_dp
  IF (iforh2 == 0) THEN

     ! Excitation temperature is tuned so that the mean formation energy
     ! is exactly 1.49 eV, whatever the number of H2 levels included
     eform_h2 = everg * de(ifh2gr) / (3.0_dp * xk)

     tform = eform_h2
     tf_min = 0.0_dp
     tf_max = 2.0_dp * eform_h2
     res = 1.0_dp

     DO WHILE ((ABS(res) > 1.0e-5_dp) .AND. (ABS(tf_min-tf_max) > 1.0e-5_dp))
        DO lev = 1, nlevh2
           ij = njl_h2(lev)
           iv = nvl_h2(lev)
           IF (MOD(ij,2) == 0) THEN
              pophm1(iv,ij) = (2.0_dp*ij+1.0_dp) * EXP(-spec_lin(in_sp(i_h2))%elk(lev)/tform)
           ELSE
              pophm1(iv,ij) = (2.0_dp*ij+1.0_dp) * ospg * EXP(-spec_lin(in_sp(i_h2))%elk(lev)/tform)
           ENDIF
        ENDDO
        ech = 0.0_dp
        DO lev = 1, nlevh2
           ij = njl_h2(lev)
           iv = nvl_h2(lev)
           ech = ech + pophm1(iv,ij)
        ENDDO
        pophm1 = pophm1 / ech

        res = 0.0_dp
        DO lev = 1, nlevh2
           ij = njl_h2(lev)
           iv = nvl_h2(lev)
           res = res + spec_lin(in_sp(i_h2))%elk(lev) * pophm1(iv,ij)
        ENDDO
        res = eform_h2 - res
        IF (res < 0.0_dp) THEN
           tf_max = tform
           tform = 0.5_dp * (tf_min + tf_max)
        ELSE
           tf_min = tform
           tform = 0.5_dp * (tf_min + tf_max)
        ENDIF
     ENDDO

     eform_h2 = tform

     DO lev = 1, nlevh2
        ij = njl_h2(lev)
        iv = nvl_h2(lev)
        IF (MOD(ij,2) == 0) THEN
           pophm1(iv,ij) = (2.0_dp*ij+1.0_dp) * EXP(-spec_lin(in_sp(i_h2))%elk(lev)/eform_h2)
        ELSE
           pophm1(iv,ij) = (2.0_dp*ij+1.0_dp) * ospg * EXP(-spec_lin(in_sp(i_h2))%elk(lev)/eform_h2)
        ENDIF
     ENDDO

  ELSE IF (iforh2 == 1) THEN

     ! Use a Boltzmann factor of exactly de(ifh2gr)/3
     ! Note that this does NOT lead to a mean energy of de(ifh2gr)/3
     eform_h2 = everg * de(ifh2gr) / (3.0_dp * xk)

     DO lev = 1, l0h2
        ij = njl_h2(lev)
        iv = nvl_h2(lev)
        IF (MOD(ij,2) == 0) THEN
           pophm1(iv,ij) = (2.0_dp*ij+1.0_dp) * EXP(-spec_lin(in_sp(i_h2))%elk(lev)/eform_h2)
        ELSE
           pophm1(iv,ij) = (2.0_dp*ij+1.0_dp) * ospg * EXP(-spec_lin(in_sp(i_h2))%elk(lev)/eform_h2)
        ENDIF
     ENDDO

  ELSE IF (iforh2 == 2) THEN

     ! Only two lowest levels of H2
     pophm1(0,0) = 0.25_dp
     pophm1(0,1) = 0.75_dp

  ELSE IF (iforh2 == 3) THEN

     ! Rotational temperature of 65 K and high vibrational number (6 here)
     !   Inspired by BvD (CLOSE to grain T?)
     pophm1(6,0) = 0.245284557e0_dp
     pophm1(6,1) = 0.749823809e0_dp
     pophm1(6,2) = 0.471552089e-2_dp
     pophm1(6,3) = 0.176384812e-3_dp
     pophm1(6,4) = 0.247192595e-7_dp
     pophm1(6,5) = 0.265905215e-10_dp
     pophm1(6,6) = 0.132664312e-15_dp
     pophm1(6,7) = 0.629879296e-20_dp

  ELSE IF (iforh2 == 4) THEN

     ! Formation on a single vibrational level (ivf)
     ! with prescribed rotational temperature (eform_h2).
     ! or precribed ratio (Christine's request)
     ivf = 0
     eform_h2 = 300.0_dp
     ej0 = spec_lin(in_sp(i_h2))%elk(lev_h2(ivf,0))

     DO lev = 1, l0h2
        ij = njl_h2(lev)
        iv = nvl_h2(lev)
        IF (iv /= ivf) CYCLE
        IF (MOD(ij,2) == 0) THEN
           pophm1(iv,ij) = (2.0_dp*ij+1.0_dp) * EXP(-(spec_lin(in_sp(i_h2))%elk(lev)-ej0)/eform_h2)
        ELSE
           pophm1(iv,ij) = (2.0_dp*ij+1.0_dp) * ospg * EXP(-(spec_lin(in_sp(i_h2))%elk(lev)-ej0)/eform_h2)
        ENDIF
     ENDDO

  ELSE

     WRITE (iscrn,"(/,5x,' Bad value for iforh2')")
     STOP

  ENDIF

  ! Normalisation
  ech = 0.0_dp
  DO lev = 1, nlevh2
     ij = njl_h2(lev)
     iv = nvl_h2(lev)
     ech = ech + pophm1(iv,ij)
  ENDDO
  pophm1 = pophm1 / ech

  emoyh2 = 0.0_dp
  DO lev = 1, l0h2
     ij = njl_h2(lev)
     iv = nvl_h2(lev)
     dumy = 0.0_dp
     DO levu = l0h2+1, nlevh2
        iju = njl_h2(levu)
        ivu = nvl_h2(levu)
        dumy = dumy + pophm1(ivu,iju) * cashm(levu,lev)
     ENDDO
     emoyh2 = emoyh2 + (pophm1(iv,ij) + dumy) * spec_lin(in_sp(i_h2))%elk(lev)
  ENDDO

  IF (nh2for == 0) THEN
     ! Formation of H2 by Eley-Rideal process
     ! OLD: Data from Bachellerie et al., Phys. Chem. Chem. Phys., 2009, 11, 2715
     ! OLD: Use low energie case (60% v = 5, 40% v = 6)
     ! Superseded by Sizun et al., CPL, 498, 32 (2010)
     ! pophm2 gives the distribution of H2 newly formed by the E-R process on its rovibrational levels
     pophm2(:,:) = 0.0_dp

     ! Excitation temperature is tuned so that the mean formation energy
     ! is exactly 2.7 eV, whatever the number of H2 levels included
     ! However, we need at least 120 levels of H2 for that...
     ! The required factor in a Boltzman distribution is computed by a simple dichotomy
     IF (l0h2 > 120) THEN
        eform_h2 = everg * 2.7_dp / xk          ! Target temperature

        tform = eform_h2                        ! First initial guess
        tf_min = 0.0_dp                         ! Lower bracket
        tf_max = 2.0_dp * eform_h2              ! Upper bracket
        res = 1.0_dp                            ! Dummy variable

        DO WHILE ((ABS(res) > 1.0e-5_dp) .AND. (ABS(tf_min-tf_max) > 1.0e-5_dp))
           ! Compute a set of "pophm" at tform
           DO lev = 1, nlevh2
              ij = njl_h2(lev)
              iv = nvl_h2(lev)
              IF (MOD(ij,2) == 0) THEN
                 pophm2(iv,ij) = (2.0_dp*ij+1.0_dp) * EXP(-spec_lin(in_sp(i_h2))%elk(lev)/tform)
              ELSE
                 pophm2(iv,ij) = (2.0_dp*ij+1.0_dp) * ospg * EXP(-spec_lin(in_sp(i_h2))%elk(lev)/tform)
              ENDIF
           ENDDO
           ! Normalize
           ech = 0.0_dp
           DO lev = 1, nlevh2
              ij = njl_h2(lev)
              iv = nvl_h2(lev)
              ech = ech + pophm2(iv,ij)
           ENDDO
           pophm2 = pophm2 / ech

           ! Use it to compute internal energy at formation
           res = 0.0_dp
           DO lev = 1, nlevh2
              ij = njl_h2(lev)
              iv = nvl_h2(lev)
              dumy = 0.0_dp
              res = res + spec_lin(in_sp(i_h2))%elk(lev) * pophm2(iv,ij)
           ENDDO
           ! Update tform by dichotomy
           res = eform_h2 - res
           IF (res < 0.0_dp) THEN
              tf_max = tform
              tform = 0.5_dp * (tf_min + tf_max)
           ELSE
              tf_min = tform
              tform = 0.5_dp * (tf_min + tf_max)
           ENDIF
        ENDDO
        ! This gives a slightly better precision
        eform_h2 = tform
     ELSE
        ! If we do not have enough levels, then use an arbitrary excitation temperature of 31300 K
        eform_h2 = 31300.0_dp
     ENDIF
     PRINT *, " Eform_H2 E-R:", eform_h2

     ! Now compute the real "pophm2" at temperature eform_h2
     DO lev = 1, nlevh2
        ij = njl_h2(lev)
        iv = nvl_h2(lev)
        IF (MOD(ij,2) == 0) THEN
           pophm2(iv,ij) = (2.0_dp*ij+1.0_dp) * EXP(-spec_lin(in_sp(i_h2))%elk(lev)/eform_h2)
        ELSE
           pophm2(iv,ij) = (2.0_dp*ij+1.0_dp) * ospg * EXP(-spec_lin(in_sp(i_h2))%elk(lev)/eform_h2)
        ENDIF
     ENDDO

     ! Normalization
     ech = 0.0_dp
     DO lev = 1, nlevh2
        ij = njl_h2(lev)
        iv = nvl_h2(lev)
        ech = ech + pophm2(iv,ij)
     ENDDO
     pophm2 = pophm2 / ech

     ! Set translation energy available upon Eley-Rideal formation (eV)
     ef_er_h2 = 0.6_dp
  ELSE
    pophm2 = 0.0_dp
    ef_er_h2 = 0.0_dp
  ENDIF

  ! JLB - 25 II 2013 - Experimental
  ! Try forming H2 on excited levels by exothermic chemical reactions
  ! The "formation energy" is arbitrary (test only)
  e_form_ch = 10000.0_dp
  DO lev = 1, nlevh2
     ij = njl_h2(lev)
     iv = nvl_h2(lev)
     IF (MOD(ij,2) == 0) THEN
        pophm_ch(iv,ij) = (2.0_dp*ij+1.0_dp) * EXP(-spec_lin(in_sp(i_h2))%elk(lev)/e_form_ch)
     ELSE
        pophm_ch(iv,ij) = (2.0_dp*ij+1.0_dp) * ospg * EXP(-spec_lin(in_sp(i_h2))%elk(lev)/e_form_ch)
     ENDIF
  ENDDO

  ! Normalization
  ech = 0.0_dp
  DO lev = 1, nlevh2
     ij = njl_h2(lev)
     iv = nvl_h2(lev)
     ech = ech + pophm_ch(iv,ij)
  ENDDO
  pophm_ch = pophm_ch / ech

END SUBROUTINE MAKE_POPHM

!%%%%%%%%%%%%%%%%%%%%
SUBROUTINE MAKE_POPHD
!%%%%%%%%%%%%%%%%%%%%

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

  IMPLICIT NONE

  REAL (KIND=dp) :: tform, ech
  REAL (KIND=dp) :: tf_min, tf_max, res
  REAL (KIND=dp) :: dummy, dumy, ej0
  INTEGER        :: lev, ij, iv, ivf
  INTEGER        :: levu, iju, ivu
  INTEGER        :: jsp_hd

  jsp_hd = in_sp(i_hd)

  ! HD formation distribution on grains
  IF (ifaf == 0) THEN
     PRINT *, '----------- HD formation distribution ------------'
  ENDIF

  IF (iforh2 == 0) THEN

     ! Excitation temperature is tuned so that the mean formation energy
     ! is exactly 1.49 eV, whatever the number of H2 levels included
     eform_hd = everg * de(ifhdgr) / (3.0_dp * xk)
     tform = eform_hd
     tf_min = 0.0_dp
     tf_max = 2.0_dp * eform_hd
     res = 1.0_dp

     DO WHILE ((ABS(res) > 1.0e-5_dp) .AND. (ABS(tf_min-tf_max) > 1.0e-5_dp))
        res = 0.0_dp
        DO lev = 1, l0hd
           ij = njl_hd(lev)
           res = res + (2.0_dp*ij+1.0_dp) * (eform_hd - spec_lin(jsp_hd)%elk(lev)) &
               * EXP(-spec_lin(jsp_hd)%elk(lev)/tform)
        ENDDO
        IF (res < 0.0_dp) THEN
           tf_max = tform
           tform = 0.5_dp * (tf_min + tf_max)
        ELSE
           tf_min = tform
           tform = 0.5_dp * (tf_min + tf_max)
        ENDIF
     ENDDO

     eform_hd = tform

     DO lev = 1, nlevhd
        ij = njl_hd(lev)
        iv = nvl_hd(lev)
        pophd(iv,ij) = (2.0_dp*ij+1.0_dp) * EXP(-spec_lin(jsp_hd)%elk(lev)/eform_hd)
     ENDDO

  ELSE IF (iforh2 == 1) THEN

     ! Use a Boltzmann factor of exactly de(ifh2gr)/3
     ! Note that this does NOT lead to a mean energy of de(ifh2gr)/3
     eform_hd = everg * de(ifhdgr) / (3.0_dp * xk)

     DO lev = 1, nlevhd
        ij = njl_hd(lev)
        iv = nvl_hd(lev)
        pophd(iv,ij) = (2.0_dp*ij+1.0_dp) * EXP(-spec_lin(jsp_hd)%elk(lev)/eform_hd)
     ENDDO

  ELSE IF (iforh2 == 2) THEN

     ! Only lowest levels of HD
     pophd(0,0) = 1.0_dp

  ELSE IF (iforh2 == 3) THEN

     ! Same as H2
     ! Rotational temperature of 65 K and high vibrational number (6 here)
     !  Inspired by BvD (CLOSE to grain T?)
     pophd(6,0) = 0.245284557e+0_dp
     pophd(6,1) = 0.749823809e+0_dp
     pophd(6,2) = 0.471552089e-2_dp
     pophd(6,3) = 0.176384812e-3_dp
     pophd(6,4) = 0.247192595e-7_dp
     pophd(6,5) = 0.265905215e-10_dp
     pophd(6,6) = 0.132664312e-15_dp
     pophd(6,7) = 0.629879296e-20_dp

  ELSE IF (iforh2 == 4) THEN

     ! Same as H2
     ! Formation on a single vibrational level (ivf)
     ! with prescribed rotational temperature (eform_h2).
     ! or precribed ratio (Christine's request)
     ivf = 6
     eform_hd = 400.0_dp
     ej0 = spec_lin(jsp_hd)%elk(lev_hd(ivf,0))

     DO lev = 1, nlevhd
        ij = njl_hd(lev)
        iv = nvl_hd(lev)
        IF (iv /= ivf) CYCLE
        pophd(iv,ij) = spec_lin(jsp_hd)%gst(lev) * EXP(-(spec_lin(jsp_hd)%elk(lev)-ej0)/eform_hd)
     ENDDO
  ENDIF

  ! Normalisation
  ech = 0.0_dp
  DO lev = 1, nlevhd
     ij = njl_hd(lev)
     iv = nvl_hd(lev)
     ech = ech + pophd(iv,ij)
  ENDDO
  pophd = pophd / ech

  emoyhd = 0.0_dp
  dummy = 0.0_dp
  DO lev = 1, l0hd
     ij = njl_hd(lev)
     iv = nvl_hd(lev)
     dumy = 0.0_dp
     DO levu = l0hd+1, nlevhd
        iju = njl_hd(levu)
        ivu = nvl_hd(levu)
        dumy = dumy + pophd(ivu,iju) * cashd(levu,lev)
     ENDDO
     emoyhd = emoyhd + (dumy + pophd(iv,ij)) * spec_lin(jsp_hd)%elk(lev)
     dummy = dummy + pophd(iv,ij)
  ENDDO

  DO lev = l0hd+1, nlevhd
     ij = njl_hd(lev)
     iv = nvl_hd(lev)
     dummy = dummy + pophd(iv,ij)
  ENDDO

END SUBROUTINE MAKE_POPHD

!=========================================================================================
! SUBROUTINE MAKE_POPH3p
!=========================================================================================
SUBROUTINE MAKE_POPH3p
USE PXDR_CONSTANTES
USE PXDR_CHEM_DATA
USE PXDR_STR_DATA

IMPLICIT NONE

REAL(KIND=DP)  :: Eform     ! Energy of the H2+ + H2 reaction going in H3+ internal energy
REAL(KIND=DP)  :: partition ! Partition function
REAL(KIND=DP)  :: En_fund   ! Energy of H3+ fundamental level

INTEGER        :: ih3p      ! Index of H3+ in spec_lin array
INTEGER        :: lev
INTEGER        :: k
INTEGER        :: iforh3p   ! Scenario for the excitation of H3+ at formation

   ! Choose scenario (default : iforh3p = 2)
   iforh3p = 2
   ! Fraction of H2+ + H2 exothermicity used for H3+ excitation
   formh3p = 0.30_dp
   ! WRITE (iwrit2,'("* fraction of H3+ in int. energy :",2x,1pE8.2)') formH3p

   !--- Initialization for the computation of H3+ excitation at formation ----------------
   ih3p = in_sp(i_h3p)                   ! Index of H3+ in spec_lin array
   IF (ALLOCATED(poph3p)) THEN
      DEALLOCATE(poph3p)
   ENDIF
   ALLOCATE(poph3p(spec_lin(ih3p)%use))
   partition = 0.0_dp

   !--- Find enthalpy of H3+ formation and reaction and compute internal energy ----------
   k_fh3p_h2p_h2 = 0
   DO k = 1, xmatk(i_h3p)%nbt
      IF (    (xmatk(i_h3p)%fdt(k)%r1 == i_h2  .AND. xmatk(i_h3p)%fdt(k)%r2 == i_h2p) &
         .OR. (xmatk(i_h3p)%fdt(k)%r1 == i_h2p .AND. xmatk(i_h3p)%fdt(k)%r2 == i_h2 ) &
         ) THEN
         k_fh3p_h2p_h2 = k
         t_fh3p_h2p_h2 = (enth(i_h) + enth(i_h3p) - enth(i_h2p) - enth(i_h2)) &
                       * calev * everg / xk
         !PRINT *, " H2+ + H2 -> H3+ + H", k_fh3p_h2p_h2, t_fh3p_h2p_h2 / everg * xk
         EXIT
      ENDIF
   ENDDO
   Eform     = ABS(t_fh3p_h2p_h2) * formh3p   ! Energy into H3+ levels at formation in Kelvin
   e_int_h3p = Eform * xk / everg             ! Energy into H3+ levels at formation in eV
   !(e_int_h3p is removed of chemical heating in BILTHERM)

   !----------------------------------------------------------------------------
   ! H3+ excitation at formation
   ! (See paper Le Petit et al. 2015 for effects of various scenarii)
   !----------------------------------------------------------------------------

    ! Boltzman distribution at Eform (energy put in H3+ at formation)
    IF (iforh3p == 1) THEN
      En_fund = spec_lin(ih3p)%elk(1)            ! Energy of H3+ fundamental level in Kelvin
        DO lev = 1, spec_lin(ih3p)%use
         poph3p(lev) = spec_lin(ih3p)%gst(lev) * exp(-(spec_lin(ih3p)%elk(lev)-En_fund)/Eform)
         partition   = partition + poph3p(lev)
      ENDDO
      poph3p(:) = poph3p(:) / partition

   ! Excitation at formation proportionnal to statistical weights (DEFAULT)
   ELSE IF (iforh3p == 2) THEN
      DO lev = 1, spec_lin(ih3p)%use
         poph3p(lev) = spec_lin(ih3p)%gst(lev)
         partition   = partition + poph3p(lev)
      ENDDO
      poph3p(:) = poph3p(:) / partition

   ! Equal probability for all levels
   ELSE IF (iforh3p == 3) THEN
      DO lev = 1, spec_lin(ih3p)%use
         poph3p(lev) = 1.0_dp / spec_lin(ih3p)%use
      ENDDO

   ENDIF

END SUBROUTINE MAKE_POPH3p

!===============================================================================
! SUBROUTINE MAKE_POPOAT
!===============================================================================
SUBROUTINE MAKE_POPOAT
USE PXDR_CONSTANTES
USE PXDR_CHEM_DATA
USE PXDR_STR_DATA

IMPLICIT NONE
INTEGER :: k

   !----------------------------------------------------------------------------
   ! Folowing Storzer and Hollenbach (2000), the reaction OH + photon -> O + H
   ! * 55% percent of O in the 1D state
   ! * 05% percent of O in the 1S state
   ! We assume 1P is populated following statistical weights
   !----------------------------------------------------------------------------

   !--- Search  the index of the OH + photon -> O + H reaction
   k_foat_oh_phot = 0
   DO k = 1, xmatk(i_o)%nbt
      IF (   (            xmatk(i_o)%fdt(k)%r1  == i_oh         &
              .AND. speci(xmatk(i_o)%fdt(k)%r2) == "photon  "   &
              .AND.       xmatk(i_o)%fdt(k)%p1  == i_o          &
              .AND.       xmatk(i_o)%fdt(k)%p2  == i_h        ) &
         .OR.(            xmatk(i_o)%fdt(k)%r1  == i_oh         &
              .AND. speci(xmatk(i_o)%fdt(k)%r2) == "photon  "   &
              .AND.       xmatk(i_o)%fdt(k)%p1  == i_h          &
              .AND.       xmatk(i_o)%fdt(k)%p2  == i_o        ) &
         ) THEN
         k_foat_oh_phot = k
      ENDIF
   ENDDO

   !--- Fill the popoat array that contains O repartition in its levels
   IF (ALLOCATED(popoat)) THEN
      DEALLOCATE(popoat)
   ENDIF
   ALLOCATE(popoat(spec_lin(in_sp(i_o))%use))

   IF (spec_lin(in_sp(i_o))%use .NE. 5) THEN
      PRINT *,"--- Pb: O excitation by chemistry "
      PRINT *,"        not enough O levels considered"
      popoat(:) = 1.0_dp / spec_lin(in_sp(i_o))%use
   ELSE
      popoat(1) = 0.40_dp * 5.0_dp / 9.0_dp  ! 3P, J = 2
      popoat(2) = 0.40_dp * 3.0_dp / 9.0_dp  ! 3P, J = 1
      popoat(3) = 0.40_dp * 1.0_dp / 9.0_dp  ! 3P, J = 0
      popoat(4) = 0.55_dp                    ! 1D, J = 2
      popoat(5) = 0.05_dp                    ! 1S, J = 0
   ENDIF


END SUBROUTINE MAKE_POPOAT

! Read collision data
!===============================================================================
SUBROUTINE READ_COL
!===============================================================================

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

  IMPLICIT NONE

  INTEGER                                      :: i, j, k
  INTEGER                                      :: nqc, ntnr
  INTEGER                                      :: levu, levl
  INTEGER                                      :: iju, ivu, ijl, ivl
  INTEGER                                      :: nup, jup, nlow, jlow
  INTEGER                                      :: i_i, J_i, K_i ! Initial level for H3+ collisionnal transition : index, J and K
  INTEGER                                      :: i_f, J_f, K_f ! Final   level for H3+ collisionnal transition : index, J and K
  INTEGER                                      :: nt, ntc, ntnd
  INTEGER                                      :: lev1, lev2
  INTEGER                                      :: ji, jf
  REAL (KIND=dp)                               :: acs1, acs2, acs3, acs4
  REAL (KIND=dp)                               :: eps, q0, q1, q2, q3, q4, q5, q6
  REAL (KIND=dp), ALLOCATABLE, DIMENSION (:)   :: tempo

  INTEGER                                      :: levcolmax_1, levcolmax_2, levcolmax
  INTEGER                                      :: nused
  CHARACTER(LEN=128)                           :: fichin
  INTEGER                                      :: nlevcco, nlevcoh
  INTEGER                                      :: nctr         ! Number of collisionnal transitions in a data file
  INTEGER                                      :: nctr_he      ! Number of collisionnal transitions with He
  INTEGER                                      :: nctr_h2      ! Number of collisionnal transitions with H2
  INTEGER                                      :: nctr_ph2     ! Number of collisionnal transitions with H2 para
  INTEGER                                      :: nctr_oh2     ! Number of collisionnal transitions with H2 ortho
  INTEGER                                      :: nctr_e       ! Number of collisionnal transitions with electrons
  INTEGER                                      :: nlevcchp_he  ! Number of CH+ levels in collision file with He
  INTEGER                                      :: nlevcchp_e   ! Number of CH+ levels in collision file with e
  INTEGER                                      :: nlevcchp     ! Maximum of nlevcchp_he and nlevcchp_e
  INTEGER                                      :: nlevcohp_h2  ! Number of OH+ levels in collision file with H2
  INTEGER                                      :: nlevcohp_e   ! Number of OH+ levels in collision file with e
  INTEGER                                      :: nlevcohp     ! Maximum of nlevcohp_he and nlevcohp_e
  INTEGER                                      :: nlevcshp_h2  ! Number of SH+ levels in collision file with H2
  INTEGER                                      :: nlevcshp_e   ! Number of SH+ levels in collision file with e
  INTEGER                                      :: nlevcshp     ! Maximum of nlevcshp_he and nlevcshp_e
  INTEGER                                      :: nlevcarhp_he ! Number of ArH+ levels in collision file with He
  INTEGER                                      :: nlevcarhp_e  ! Number of ArH+ levels in collision file with e
  INTEGER                                      :: nlevcarhp    ! Maximum of nlevcarhp_he and nlevcarhp_e
  INTEGER                                      :: nlevch3p_ph2 ! Number of H3+ levels in collision rate file with H2 para
  INTEGER                                      :: nlevch3p_oh2 ! Number of H3+ levels in collision rate file with H2 ortho
  INTEGER                                      :: nlevch3p     ! Number of H3+ levels (max of nlevch3p_ph2 and nlevch3p_oh2)
  INTEGER                                      :: nlevcnep_e   ! Number of Ne+ levels in collision file with e
  INTEGER                                      :: nlevcnepp_e  ! Number of Ne++ levels in collision file with e
  INTEGER                                      :: nlevccpp_e   ! Number of C++ levels in collision file with e
  INTEGER                                      :: nlevcnpp_e   ! Number of N++ levels in collision file with e
  INTEGER                                      :: nlevcspp_e   ! Number of S++ levels in collision file with e
  INTEGER                                      :: nlevch_e     ! Number of H levels in collision file with e

  ! Data from Balakrishnan et al. (2002) for CO + H v'=1 -> v"=0
  REAL (KIND=dp)                               :: aa_tv_h = 3.69465_dp
  REAL (KIND=dp)                               :: bb_tv_h = 12.0429_dp
  REAL (KIND=dp)                               :: cc_tv_h = -8.85647_dp
  REAL (KIND=dp)                               :: x0_tv_h = 2.50485_dp

  ! Data from Cecchi-pestellini et al. (2002) for CO + He v'=1 -> v"=0
  REAL (KIND=dp)                               :: aa_tv_he = 2.64489_dp
  REAL (KIND=dp)                               :: bb_tv_he = 1.23589_dp
  REAL (KIND=dp)                               :: cc_tv_he = -11.2837_dp
  REAL (KIND=dp)                               :: x0_tv_he = 3.5931_dp

  ! Data for evaluation of vibrational CO collisions (educated guess)
  REAL (KIND=dp)                               :: alp_co = -0.25_dp
  INTEGER                                      :: lev0
  REAL (KIND=dp)                               :: E0, qq
  REAL (KIND=dp), ALLOCATABLE, DIMENSION (:,:) :: p_co
  REAL (KIND=dp), ALLOCATABLE, DIMENSION (:,:) :: g_co

     !=====================================================================
     !== INITIALIZATION OF COLLISION RATES
     !=====================================================================

     !---------------------------------------------------------------------
     !- H2 Collision rates
     !---------------------------------------------------------------------

     ! ichh2 is a flag to choose a model for H + H2 collision rates
     IF (ichh2 == 0) THEN
        nqc = 4
     ELSE
        nqc = 3
     ENDIF
     ALLOCATE (q_h2_h_1(l0h2,l0h2))
     ALLOCATE (q_h2_h_2(l0h2,l0h2))
     ALLOCATE (q_h2_h_3(l0h2,l0h2))
     ALLOCATE (q_h2_h_4(l0h2,l0h2))
     ALLOCATE (q_h2_he_1(l0h2,l0h2))
     ALLOCATE (q_h2_he_2(l0h2,l0h2))
     ALLOCATE (q_h2_he_3(l0h2,l0h2))
     ALLOCATE (q_h2_ph2_1(l0h2,l0h2))
     ALLOCATE (q_h2_ph2_2(l0h2,l0h2))
     ALLOCATE (q_h2_ph2_3(l0h2,l0h2))
     ALLOCATE (q_h2_oh2_1(l0h2,l0h2))
     ALLOCATE (q_h2_oh2_2(l0h2,l0h2))
     ALLOCATE (q_h2_oh2_3(l0h2,l0h2))
     q_h2_h_1(:,:)   = -50.0_dp
     q_h2_h_2(:,:)   = 0.0_dp
     q_h2_h_3(:,:)   = 0.0_dp
     q_h2_h_4(:,:)   = 0.0_dp
     q_h2_he_1(:,:)  = -50.0_dp
     q_h2_he_2(:,:)  = 0.0_dp
     q_h2_he_3(:,:)  = 0.0_dp
     q_h2_ph2_1(:,:) = -50.0_dp
     q_h2_ph2_2(:,:) = 0.0_dp
     q_h2_ph2_3(:,:) = 0.0_dp
     q_h2_oh2_1(:,:) = -50.0_dp
     q_h2_oh2_2(:,:) = 0.0_dp
     q_h2_oh2_3(:,:) = 0.0_dp

     PRINT *
     PRINT *,'-------------- H2 levels ----------------'
     CALL LLEV_H2 (l0h2)
     PRINT *,'Nb of H2 levels (l0h2):', l0h2

     !- H + H2 collision rates --------------------------------------------
     IF (ichh2 == 0) THEN
        fichier = TRIM(data_dir)//'Collisions/q_h1_h2_MM.dat'
     ELSE
        !fichier = TRIM(data_dir)//'Collisions/q_h1_h2_DRF.dat'
        fichier = TRIM(data_dir)//'Collisions/q_h1_h2_DRFn.dat'
     ENDIF
     WRITE(iscrn,*) "Opening file : ", TRIM(fichier)
     OPEN(iread2, FILE = fichier, STATUS = 'old')
     READ (iread2,*) ntnr

     DO j = 1, ntnr
        READ (iread2,*) levu, levl, q1, q2, q3, q4
        IF ((levu <= l0h2) .AND. (levl <= l0h2)) THEN
           q_h2_h_1(levl,levu) = q1
           q_h2_h_2(levl,levu) = q2
           q_h2_h_3(levl,levu) = q3
           IF (nqc == 4) THEN
              q_h2_h_4(levl,levu) = q4
           ENDIF
        ENDIF
     ENDDO
     CLOSE (iread2)

     ! 5 jan 2000 - Coarse patch for missing transitions
     DO levu = 3, l0h2
        iju = njl_h2(levu)
        ivu = nvl_h2(levu)
        DO levl = 1, levu-1
           ijl = njl_h2(levl)
           IF (MOD(iju-ijl,2) /= 0) CYCLE
           ivl = nvl_h2(levl)

           IF (q_h2_h_1(levl,levu) == -50.0d0) THEN
              IF (ivl == ivu .OR. ivu == 1) THEN
                 IF (ivl >= 4) THEN
                    lev2 = lev_h2(ivu-1,iju)
                    lev1 = lev_h2(ivl-1,ijl)
                 ELSE IF (ijl <= 1) THEN
                    lev2 = lev_h2(ivu,iju-2)
                    lev1 = levl
                 ELSE
                    lev2 = lev_h2(ivu,iju-2)
                    lev1 = lev_h2(ivl,ijl-2)
                 ENDIF
              ELSE IF (ivu > ivl .AND.  (iju /= 0 .OR. ijl /= 0)) THEN
                 lev2 = lev_h2(ivu-1,iju)
                 lev1 = lev_h2(MAX(ivl-1,0),ijl)
              ELSE
                 lev2 = levu
                 lev1 = levl
              ENDIF
              q_h2_h_1(levl,levu) = q_h2_h_1(lev1,lev2)
              q_h2_h_2(levl,levu) = q_h2_h_2(lev1,lev2)
              q_h2_h_3(levl,levu) = q_h2_h_3(lev1,lev2)
              IF (nqc == 4) THEN
                 q_h2_h_4(levl,levu) = q_h2_h_4(lev1,lev2)
              ENDIF
           ENDIF

        ENDDO
     ENDDO

     !- H2 + He collision rates -------------------------------------------

     fichier = TRIM(data_dir)//'Collisions/q_he_h2.dat'
     WRITE(iscrn,*) "Opening file : ", TRIM(fichier)
     OPEN(iread2, FILE = fichier, STATUS = 'old')
     READ (iread2,*) ntnr

     DO j = 1, ntnr
        READ (iread2,*) levu, levl, q1, q2, q3
        IF ((levu <= l0h2) .AND. (levl <= l0h2)) THEN
           q_h2_he_1(levl,levu) = q1
           q_h2_he_2(levl,levu) = q2
           q_h2_he_3(levl,levu) = q3
        ENDIF
     ENDDO
     CLOSE (iread2)

     !- ortho-H2 + H2 collision rates -------------------------------------

     fichier = TRIM(data_dir)//'Collisions/q_oh2_h2.dat'
     WRITE(iscrn,*) "Opening file : ", TRIM(fichier)
     OPEN(iread2, FILE = fichier, STATUS = 'old')
     READ (iread2,*) ntnr

     DO j = 1, ntnr
        READ (iread2,*) levu, levl, q1, q2, q3
        IF ((levu <= l0h2) .AND. (levl <= l0h2)) THEN
           q_h2_oh2_1(levl,levu) = q1
           q_h2_oh2_2(levl,levu) = q2
           q_h2_oh2_3(levl,levu) = q3
        ENDIF
     ENDDO
     CLOSE (iread2)

     !- para-H2 + H2 collision rates --------------------------------------

     fichier = TRIM(data_dir)//'Collisions/q_ph2_h2.dat'
     WRITE(iscrn,*) "Opening file : ", TRIM(fichier)
     OPEN(iread2, FILE = fichier, STATUS = 'old')
     READ (iread2,*) ntnr

     DO j = 1, ntnr
        READ (iread2,*) levu, levl, q1, q2, q3
        IF ((levu <= l0h2) .AND. (levl <= l0h2)) THEN
           q_h2_ph2_1(levl,levu) = q1
           q_h2_ph2_2(levl,levu) = q2
           q_h2_ph2_3(levl,levu) = q3
        ENDIF
     ENDDO
     CLOSE (iread2)

     !---------------------------------------------------------------------
     !- CO COLLISION RATES (and isotopes)
     !  with H2: from Yang et al. 2010, ApJ 718, 1062
     !  with H: from Balakrishna et al. 2002,
     !          as given by BASECOL and corrected and extended by JLB
     !  with He: from Balakrishna et al. 2002,
     !          as given by BASECOL and corrected and extended by JLB
     !  Note: in q_ files, only v = O, J levels are considered, so lev = J+1
     !
     !  For vibrational transitions, as a first approximation, we
     !      consider that they are the same as pure rotational transitions
     !---------------------------------------------------------------------

     IF (i_co /= 0) THEN
        nused = spec_lin(in_sp(i_co))%use
        ! H
        fichier = TRIM(data_dir)//'Collisions/q_h_12c16o.dat'
        WRITE(iscrn,*) "Opening file : ", TRIM(fichier)
        OPEN (iread2, FILE = fichier, STATUS = 'old')
        READ (iread2,'(/,i5)') nlevcco
        PRINT *, " Number of levels: ", nlevcco
        READ (iread2,'(/,i5)') nctr
        PRINT *, " Number of collisional transitions : ", nctr
        READ (iread2,'(/,i5)') nt_co_h
        PRINT *, " Number of temperatures: ", nt_co_h

        ALLOCATE (tc_co_h(nt_co_h+1))
        READ (iread2,*)
        READ (iread2,*) (tc_co_h(k), k = 1, nt_co_h)
        tc_co_h(nt_co_h+1) = tc_co_h(nt_co_h) * 2.0_dp
        tc_co_h = LOG10(tc_co_h)
!       ALLOCATE (q_co_h(nt_co_h+1,nlevcco,nlevcco))
        ALLOCATE (q_co_h(nt_co_h+1,nused,nused))
        q_co_h = 1.0e-50_dp
        READ (iread2,*)
        ALLOCATE (tempo(nt_co_h))
        DO i = 1, nctr
            READ (iread2,*) jup, jlow, (tempo(j), j = 1, nt_co_h)
            levu = lev_co(0,jup-1)
            IF (levu > nused) CYCLE
            levl = lev_co(0,jlow-1)
            q_co_h(1:nt_co_h,levu,levl) = tempo(:)
            levu = lev_co(1,jup-1)
            IF (levu > nused) CYCLE
            levl = lev_co(1,jlow-1)
            q_co_h(1:nt_co_h,levu,levl) = tempo(:)
        ENDDO
        DEALLOCATE (tempo)
        ! For extrapolation beyond last T, we use a constant q
        q_co_h(nt_co_h+1,:,:) = q_co_h(nt_co_h,:,:)
        q_co_h = LOG10(q_co_h)
        CLOSE (iread2)

        ! He
        fichier = TRIM(data_dir)//'Collisions/q_he_12c16o.dat'
        WRITE(iscrn,*) "Opening file : ", TRIM(fichier)
        OPEN (iread2, FILE = fichier, STATUS = 'old')
        READ (iread2,'(/,i5)') nlevcco
        PRINT *, " Number of levels: ", nlevcco
        READ (iread2,'(/,i5)') nctr
        PRINT *, " Number of collisional transitions : ", nctr
        READ (iread2,'(/,i5)') nt_co_he
        PRINT *, " Number of temperatures: ", nt_co_he

        ALLOCATE (tc_co_he(nt_co_he+1))
        READ (iread2,*)
        READ (iread2,*) (tc_co_he(k), k = 1, nt_co_he)
        tc_co_he(nt_co_he+1) = tc_co_he(nt_co_he) * 2.0_dp
        tc_co_he = LOG10(tc_co_he)
!       ALLOCATE (q_co_he(nt_co_he+1,nlevcco,nlevcco))
        ALLOCATE (q_co_he(nt_co_he+1,nused,nused))
        q_co_he = 1.0e-50_dp
        READ (iread2,*)
        ALLOCATE (tempo(nt_co_he))
        DO i = 1, nctr
            READ (iread2,*) jup, jlow, (tempo(j), j = 1, nt_co_he)
            levu = lev_co(0,jup-1)
            IF (levu > nused) CYCLE
            levl = lev_co(0,jlow-1)
            q_co_he(1:nt_co_he,levu,levl) = tempo(:)
            levu = lev_co(1,jup-1)
            IF (levu > nused) CYCLE
            levl = lev_co(1,jlow-1)
            q_co_he(1:nt_co_he,levu,levl) = tempo(:)
        ENDDO
        DEALLOCATE (tempo)
        ! For extrapolation beyond last T, we use a constant q
        q_co_he(nt_co_he+1,:,:) = q_co_he(nt_co_he,:,:)
        q_co_he = LOG10(q_co_he)
        CLOSE (iread2)

        ! para-H2
        fichier = TRIM(data_dir)//'Collisions/q_ph2_12c16o.dat'
        WRITE(iscrn,*) "Opening file : ", TRIM(fichier)
        OPEN (iread2, FILE = fichier, STATUS = 'old')
        READ (iread2,'(/,i5)') nlevcco
        PRINT *, " Number of levels: ", nlevcco
        READ (iread2,'(/,i5)') nctr
        PRINT *, " Number of collisional transitions : ", nctr
        READ (iread2,'(/,i5)') nt_co_h2
        PRINT *, " Number of temperatures: ", nt_co_h2

        ALLOCATE (tc_co_h2(nt_co_h2+1))
        READ (iread2,*)
        READ (iread2,*) (tc_co_h2(k), k = 1, nt_co_h2)
        tc_co_h2(nt_co_h2+1) = tc_co_h2(nt_co_h2) * 2.0_dp
        tc_co_h2 = LOG10(tc_co_h2)
        ALLOCATE (q_co_ph2(nt_co_h2+1,nused,nused))
        q_co_ph2 = 1.0e-50_dp
        READ (iread2,*)
        ALLOCATE (tempo(nt_co_h2))
        DO i = 1, nctr
            READ (iread2,*) k, jup, jlow, (tempo(j), j = 1, nt_co_h2)
            levu = lev_co(0,jup-1)
            IF (levu > nused) CYCLE
            levl = lev_co(0,jlow-1)
            q_co_ph2(1:nt_co_h2,levu,levl) = tempo(:)
            levu = lev_co(1,jup-1)
            IF (levu > nused) CYCLE
            levl = lev_co(1,jlow-1)
            q_co_ph2(1:nt_co_h2,levu,levl) = tempo(:)
        ENDDO
        DEALLOCATE (tempo)
        ! For extrapolation beyond last T, we use a constant q
        q_co_ph2(nt_co_h2+1,:,:) = q_co_ph2(nt_co_h2,:,:)
        q_co_ph2 = LOG10(q_co_ph2)
        CLOSE (iread2)

        ! ortho-H2
        fichier = TRIM(data_dir)//'Collisions/q_oh2_12c16o.dat'
        WRITE(iscrn,*) "Opening file : ", TRIM(fichier)
        OPEN (iread2, FILE = fichier, STATUS = 'old')
        READ (iread2,'(/,i5)') nlevcco
        PRINT *, " Number of levels: ", nlevcco
        READ (iread2,'(/,i5)') nctr
        PRINT *, " Number of collisional transitions : ", nctr
        READ (iread2,'(/,i5)') nt_co_h2
        PRINT *, " Number of temperatures: ", nt_co_h2

        READ (iread2,*)
        READ (iread2,*) (tc_co_h2(k), k = 1, nt_co_h2)
        tc_co_h2(nt_co_h2+1) = tc_co_h2(nt_co_h2) * 2.0_dp
        tc_co_h2 = LOG10(tc_co_h2)
        ALLOCATE (q_co_oh2(nt_co_h2+1,nused,nused))
        q_co_oh2 = 1.0e-50_dp
        READ (iread2,*)
        ALLOCATE (tempo(nt_co_h2))
        DO i = 1, nctr
            READ (iread2,*) k, jup, jlow, (tempo(j), j = 1, nt_co_h2)
            levu = lev_co(0,jup-1)
            IF (levu > nused) CYCLE
            levl = lev_co(0,jlow-1)
            q_co_oh2(1:nt_co_h2,levu,levl) = tempo(:)
            levu = lev_co(1,jup-1)
            IF (levu > nused) CYCLE
            levl = lev_co(1,jlow-1)
            q_co_oh2(1:nt_co_h2,levu,levl) = tempo(:)
        ENDDO
        DEALLOCATE (tempo)
        q_co_oh2(nt_co_h2+1,:,:) = q_co_oh2(nt_co_h2,:,:)
        q_co_oh2 = LOG10(q_co_oh2)
        CLOSE (iread2)

        ! Build here collision rates for v = 1 -> v = 0 de-excitation (JLB 21 Oct 2011)
        IF (nused >= lev_co(1,0)) THEN
           PRINT *, " Build Delta v = 1 collisions"
           lev0 = lev_co(1,0)
           E0 = spec_lin(in_sp(i_co))%elk(lev0)
           ALLOCATE (g_co(nused,nused))
           g_co = 0.0_dp
           DO levu = lev0, nused
              IF (nvl_co(levu) /= 1) CYCLE
              DO levl = 1, levu-1
                 IF (nvl_co(levl) /= 0) CYCLE
                 qq = ABS(njl_co(levl) - njl_co(levu))
                 g_co(levu,levl) = (2.0_dp * njl_co(levl) + 1.0_dp) &
                                 * (1.0_dp + ABS(njl_co(levl) - njl_co(levu)))**alp_co
              ENDDO
              WHERE (g_co(levu,1:levu-1) /= 0.0_dp)
                 g_co(levu,1:levu-1) = LOG10(g_co(levu,1:levu-1) / SUM(g_co(levu,1:levu-1)))
              ENDWHERE
           ENDDO

           ALLOCATE (p_co(nused,nt_co_h))
           p_co = 0.0_dp
           DO k = 1, nt_co_h
              DO levu = lev0, nused
                 IF (nvl_co(levu) /= 1) CYCLE
                 p_co(levu,k) = (2.0_dp * njl_co(levu) + 1.0_dp) &
                             * EXP(-(spec_lin(in_sp(i_co))%elk(levu)-E0)/(xk*tc_co_h(k)))
              ENDDO
              WHERE (p_co(:,k) /= 0.0_dp)
                 p_co(:,k) = LOG10(p_co(:,k) / SUM(p_co(:,k)))
              ENDWHERE
              qq = aa_tv_h * (LOG10(tc_co_h(k))-x0_tv_h) + cc_tv_h &
                 - SQRT(aa_tv_h**2 * (LOG10(tc_co_h(k))-x0_tv_h)**2 + bb_tv_h)
              DO levu = lev0, nused
                 IF (nvl_co(levu) /= 1) CYCLE
                 DO levl = 1, levu-1
                    IF (nvl_co(levl) /= 0) CYCLE
                    q_co_h(k,levu,levl) = qq + p_co(levu,k) + g_co(levu,levl)
                 ENDDO
              ENDDO
           ENDDO
           DEALLOCATE (p_co)
           q_co_h(nt_co_h+1,:,:) = q_co_h(nt_co_h,:,:)

           ALLOCATE (p_co(nused,nt_co_he))
           p_co = 0.0_dp
           DO k = 1, nt_co_he
              DO levu = lev0, nused
                 IF (nvl_co(levu) /= 1) CYCLE
                 p_co(levu,k) = (2.0_dp * njl_co(levu) + 1.0_dp) &
                             * EXP(-(spec_lin(in_sp(i_co))%elk(levu)-E0)/(xk*tc_co_he(k)))
              ENDDO
              WHERE (p_co(:,k) /= 0.0_dp)
                 p_co(:,k) = LOG10(p_co(:,k) / SUM(p_co(:,k)))
              ENDWHERE
              qq = aa_tv_he * (LOG10(tc_co_he(k))-x0_tv_he) + cc_tv_he &
                 - SQRT(aa_tv_he**2 * (LOG10(tc_co_he(k))-x0_tv_he)**2 + bb_tv_he)
              DO levu = lev0, nused
                 IF (nvl_co(levu) /= 1) CYCLE
                 DO levl = 1, levu-1
                    IF (nvl_co(levl) /= 0) CYCLE
                    q_co_he(k,levu,levl) = qq + p_co(levu,k) + g_co(levu,levl)
                 ENDDO
              ENDDO
           ENDDO
           DEALLOCATE (p_co)
           q_co_he(nt_co_he+1,:,:) = q_co_he(nt_co_he,:,:)

           ALLOCATE (p_co(nused,nt_co_h2))
           p_co = 0.0_dp
           DO k = 1, nt_co_h2
              DO levu = lev0, nused
                 IF (nvl_co(levu) /= 1) CYCLE
                 p_co(levu,k) = (2.0_dp * njl_co(levu) + 1.0_dp) &
                             * EXP(-(spec_lin(in_sp(i_co))%elk(levu)-E0)/(xk*tc_co_h2(k)))
              ENDDO
              WHERE (p_co(:,k) /= 0.0_dp)
                 p_co(:,k) = LOG10(p_co(:,k) / SUM(p_co(:,k)))
              ENDWHERE
              ! Use He value scaled by SQRT(2)
              qq = aa_tv_he * (LOG10(tc_co_h2(k))-x0_tv_he) + cc_tv_he &
                 - SQRT(aa_tv_he**2 * (LOG10(tc_co_h2(k))-x0_tv_he)**2 + bb_tv_he) + 0.5_dp * LOG10(2.0_dp)
              DO levu = lev0, nused
                 IF (nvl_co(levu) /= 1) CYCLE
                 DO levl = 1, levu-1
                    IF (nvl_co(levl) /= 0) CYCLE
                    q_co_oh2(k,levu,levl) = qq + p_co(levu,k) + g_co(levu,levl)
                    q_co_ph2(k,levu,levl) = qq + p_co(levu,k) + g_co(levu,levl)
                 ENDDO
              ENDDO
           ENDDO
           DEALLOCATE (p_co)
           q_co_oh2(nt_co_h2+1,:,:) = q_co_oh2(nt_co_h2,:,:)
           q_co_ph2(nt_co_h2+1,:,:) = q_co_ph2(nt_co_h2,:,:)
        ENDIF
     ENDIF

     ! 13CO: data exist with H2, not with H or He
     IF (i_co /= 0) THEN
        fichier = TRIM(data_dir)//'Collisions/q_ph2_13c16o.dat'
        WRITE(iscrn,*) "Opening file : ", TRIM(fichier)
        OPEN (iread2, FILE = fichier, STATUS = 'old')
        READ (iread2,'(/,i5)') nlevcco
        PRINT *, " Number of levels: ", nlevcco
        READ (iread2,'(/,i5)') nctr
        PRINT *, " Number of collisional transitions : ", nctr
        READ (iread2,'(/,i5)') nt_co_h2
        PRINT *, " Number of temperatures: ", nt_co_h2

        IF (.NOT. ALLOCATED (tc_co_h2)) THEN
           ALLOCATE (tc_co_h2(nt_co_h2+1))
        ENDIF
        READ (iread2,*)
        READ (iread2,*) (tc_co_h2(k), k = 1, nt_co_h2)
        tc_co_h2(nt_co_h2+1) = tc_co_h2(nt_co_h2) * 2.0_dp
        tc_co_h2 = LOG10(tc_co_h2)
        ALLOCATE (q_c13o_ph2(nt_co_h2+1,nlevcco,nlevcco))
        q_c13o_ph2 = 1.0e-50_dp
        READ (iread2,*)
        DO i = 1, nctr
            READ (iread2,*) k, jup, jlow, (q_c13o_ph2(j,jup,jlow), j = 1, nt_co_h2)
        ENDDO
        q_c13o_ph2(nt_co_h2+1,:,:) = q_c13o_ph2(nt_co_h2,:,:)
        q_c13o_ph2 = LOG10(q_c13o_ph2)
        CLOSE (iread2)

        fichier = TRIM(data_dir)//'Collisions/q_oh2_13c16o.dat'
        WRITE(iscrn,*) "Opening file : ", TRIM(fichier)
        OPEN (iread2, FILE = fichier, STATUS = 'old')
        READ (iread2,'(/,i5)') nlevcco
        PRINT *, " Number of levels: ", nlevcco
        READ (iread2,'(/,i5)') nctr
        PRINT *, " Number of collisional transitions : ", nctr
        READ (iread2,'(/,i5)') nt_co_h2
        PRINT *, " Number of temperatures: ", nt_co_h2

        READ (iread2,*)
        READ (iread2,*) (tc_co_h2(k), k = 1, nt_co_h2)
        tc_co_h2(nt_co_h2+1) = tc_co_h2(nt_co_h2) * 2.0_dp
        tc_co_h2 = LOG10(tc_co_h2)
        ALLOCATE (q_c13o_oh2(nt_co_h2+1,nlevcco,nlevcco))
        q_c13o_oh2 = 1.0e-50_dp
        READ (iread2,*)
        DO i = 1, nctr
            READ (iread2,*) k, jup, jlow, (q_c13o_oh2(j,jup,jlow), j = 1, nt_co_h2)
        ENDDO
        q_c13o_oh2(nt_co_h2+1,:,:) = q_c13o_oh2(nt_co_h2,:,:)
        q_c13o_oh2 = LOG10(q_c13o_oh2)
        CLOSE (iread2)
     ENDIF

     ! C18O: data exist with H2, not with H or He
     IF (i_co /= 0) THEN
        fichier = TRIM(data_dir)//'Collisions/q_ph2_12c18o.dat'
        WRITE(iscrn,*) "Opening file : ", TRIM(fichier)
        OPEN (iread2, FILE = fichier, STATUS = 'old')
        READ (iread2,'(/,i5)') nlevcco
        PRINT *, " Number of levels: ", nlevcco
        READ (iread2,'(/,i5)') nctr
        PRINT *, " Number of collisional transitions : ", nctr
        READ (iread2,'(/,i5)') nt_co_h2
        PRINT *, " Number of temperatures: ", nt_co_h2

        IF (.NOT. ALLOCATED (tc_co_h2)) THEN
           ALLOCATE (tc_co_h2(nt_co_h2+1))
        ENDIF
        READ (iread2,*)
        READ (iread2,*) (tc_co_h2(k), k = 1, nt_co_h2)
        tc_co_h2(nt_co_h2+1) = tc_co_h2(nt_co_h2) * 2.0_dp
        tc_co_h2 = LOG10(tc_co_h2)
        ALLOCATE (q_co18_ph2(nt_co_h2+1,nlevcco,nlevcco))
        q_co18_ph2 = 1.0e-50_dp
        READ (iread2,*)
        DO i = 1, nctr
            READ (iread2,*) k, jup, jlow, (q_co18_ph2(j,jup,jlow), j = 1, nt_co_h2)
        ENDDO
        q_co18_ph2(nt_co_h2+1,:,:) = q_co18_ph2(nt_co_h2,:,:)
        q_co18_ph2 = LOG10(q_co18_ph2)
        CLOSE (iread2)

        fichier = TRIM(data_dir)//'Collisions/q_oh2_12c18o.dat'
        WRITE(iscrn,*) "Opening file : ", TRIM(fichier)
        OPEN (iread2, FILE = fichier, STATUS = 'old')
        READ (iread2,'(/,i5)') nlevcco
        PRINT *, " Number of levels: ", nlevcco
        READ (iread2,'(/,i5)') nctr
        PRINT *, " Number of collisional transitions : ", nctr
        READ (iread2,'(/,i5)') nt_co_h2
        PRINT *, " Number of temperatures: ", nt_co_h2

        READ (iread2,*)
        READ (iread2,*) (tc_co_h2(k), k = 1, nt_co_h2)
        tc_co_h2(nt_co_h2+1) = tc_co_h2(nt_co_h2) * 2.0_dp
        tc_co_h2 = LOG10(tc_co_h2)
        ALLOCATE (q_co18_oh2(nt_co_h2+1,nlevcco,nlevcco))
        q_co18_oh2 = 1.0e-50_dp
        READ (iread2,*)
        DO i = 1, nctr
            READ (iread2,*) k, jup, jlow, (q_co18_oh2(j,jup,jlow), j = 1, nt_co_h2)
        ENDDO
        q_co18_oh2(nt_co_h2+1,:,:) = q_co18_oh2(nt_co_h2,:,:)
        q_co18_oh2 = LOG10(q_co18_oh2)
        CLOSE (iread2)
     ENDIF

     ! 13C18O: no data with H2, H or He

     !---------------------------------------------------------------------
     !- HD COLLISION RATES
     !---------------------------------------------------------------------
     IF (i_hd /= 0) THEN
        q_hd_h  = 0.0_dp
        q_hd_he  = 0.0_dp
        q_hd_ph2 = 0.0_dp
        q_hd_oh2 = 0.0_dp
        q_hd_h(1,:,:)  = -50.0_dp
        q_hd_he(1,:,:)  = -50.0_dp
        q_hd_ph2(1,:,:) = -50.0_dp
        q_hd_oh2(1,:,:) = -50.0_dp

        !- HD + He collision rates ----------------------------------------
        fichier = TRIM(data_dir)//'Collisions/q_he_hd.dat'
        WRITE(iscrn,*) "Opening file : ", TRIM(fichier)
        OPEN (iread2, FILE = fichier, STATUS = 'old')
        READ(iread2,*) ntnd

        DO ntc = 1, ntnd
           READ(iread2,4001) levu, levl, (q_hd_he(i,levu,levl), i=1,4)
        ENDDO
        CLOSE (iread2)

        !- HD + H collision rates -----------------------------------------
        fichier = TRIM(data_dir)//'Collisions/q_h1_hd.dat'
        WRITE(iscrn,*) "Opening file : ", TRIM(fichier)
        OPEN (iread2, FILE = fichier, STATUS = 'old')
        READ(iread2,*) ntnd

        DO ntc = 1, ntnd
           READ(iread2,4001) levu, levl, (q_hd_h(i,levu,levl), i=1,4)
        ENDDO
        CLOSE (iread2)

        !- HD + ortho-H2 collision rates ----------------------------------
        fichier = TRIM(data_dir)//'Collisions/q_oh2_hd.dat'
        WRITE(iscrn,*) "Opening file : ", TRIM(fichier)
        OPEN (iread2, FILE = fichier, STATUS = 'old')
        READ(iread2,*) ntnd

        DO ntc = 1, ntnd
           READ(iread2,4001) levu, levl, (q_hd_oh2(i,levu,levl), i=1,4)
        ENDDO
        CLOSE (iread2)

        !- HD + para-H2 collision rates -----------------------------------
        fichier = TRIM(data_dir)//'Collisions/q_ph2_hd.dat'
        WRITE(iscrn,*) "Opening file : ", TRIM(fichier)
        OPEN (iread2, FILE = fichier, STATUS = 'old')
        READ(iread2,*) ntnd

        DO ntc = 1, ntnd
           READ(iread2,4001) levu, levl, (q_hd_ph2(i,levu,levl), i=1,4)
        ENDDO
        CLOSE (iread2)

     ENDIF

     !---------------------------------------------------------------------
     !- CS collision rates
     !---------------------------------------------------------------------
     IF (i_cs /= 0 ) THEN
        IF (in_sp(i_cs) /= 0 ) THEN

           !- CS + H2 collision rates -------------------------------------
           fichier = TRIM(data_dir)//'Collisions/q_h2_cs.dat'
           WRITE(iscrn,*) "Opening file : ", TRIM(fichier)
           OPEN (iread2, FILE = fichier, STATUS = 'old')
           READ(iread2,*) ntccs

           DO nt = 1, ntccs
              READ(iread2,*) ji, jf, acs1, acs2, acs3, acs4
              ntc = 1 + jf + ji * (ji-1) / 2
              IF (nt /= ntc) THEN
                 PRINT *, "  Pb coll CS!", nt, ntc
                 STOP
              ENDIF
              cdocs(1,ntc) = acs1
              cdocs(2,ntc) = acs2
              cdocs(3,ntc) = acs3
              cdocs(4,ntc) = acs4
           ENDDO
           CLOSE (iread2)
        ENDIF
     ENDIF

     !---------------------------------------------------------------------
     !- OH COLLISION RATES
     !---------------------------------------------------------------------

     IF (i_oh /= 0) THEN
        fichier = TRIM(data_dir)//'Collisions/q_ph2_oh.dat'
        WRITE(iscrn,*) "Opening file : ", TRIM(fichier)
        OPEN (iread2, FILE = fichier, STATUS = 'old')
        READ (iread2,'(/,i5)') nlevcoh
        PRINT *, " Number of levels: ", nlevcoh
        READ (iread2,'(/,i5)') nctr
        PRINT *, " Number of collisional transitions : ", nctr
        READ (iread2,'(/,i5)') nttoh
        PRINT *, " Number of temperatures: ", nttoh

        ALLOCATE (tempcoh(nttoh+1))
        READ (iread2,*)
        READ (iread2,*) (tempcoh(k), k = 1, nttoh)
        tempcoh(nttoh+1) = tempcoh(nttoh) * 2.0_dp
        tempcoh = LOG10(tempcoh)
        ALLOCATE (q_oh_ph2(nttoh+1,nlevcoh,nlevcoh))
        q_oh_ph2 = 1.0e-50_dp
        READ (iread2,*)
        DO i = 1, nctr
            READ (iread2,*) k, jup, jlow, (q_oh_ph2(j,jup,jlow), j = 1, nttoh)
!           PRINT *, k, jup, jlow, (q_oh_ph2(j,jup,jlow), j = 1, nttoh)
        ENDDO
        ! For extrapolation beyond last T, we use a constant q
        q_oh_ph2(nttoh+1,:,:) = q_oh_ph2(nttoh,:,:)
        q_oh_ph2 = LOG10(q_oh_ph2)
        CLOSE (iread2)

        fichier = TRIM(data_dir)//'Collisions/q_oh2_oh.dat'
        WRITE(iscrn,*) "Opening file : ", TRIM(fichier)
        OPEN (iread2, FILE = fichier, STATUS = 'old')
        READ (iread2,'(/,i5)') nlevcoh
        PRINT *, " Number of levels: ", nlevcoh
        READ (iread2,'(/,i5)') nctr
        PRINT *, " Number of collisional transitions : ", nctr
        READ (iread2,'(/,i5)') nttoh
        PRINT *, " Number of temperatures: ", nttoh

        DEALLOCATE (tempcoh)
        ALLOCATE (tempcoh(nttoh+1))
        READ (iread2,*)
        READ (iread2,*) (tempcoh(k), k = 1, nttoh)
        tempcoh(nttoh+1) = tempcoh(nttoh) * 2.0_dp
        tempcoh = LOG10(tempcoh)
        ALLOCATE (q_oh_oh2(nttoh+1,nlevcoh,nlevcoh))
        q_oh_oh2 = 1.0e-50_dp
        READ (iread2,*)
        DO i = 1, nctr
            READ (iread2,*) k, jup, jlow, (q_oh_oh2(j,jup,jlow), j = 1, nttoh)
!           PRINT *, k, jup, jlow, (q_oh_oh2(j,jup,jlow), j = 1, nttoh)
        ENDDO
        ! For extrapolation beyond last T, we use a constant q
        q_oh_oh2(nttoh+1,:,:) = q_oh_oh2(nttoh,:,:)
        q_oh_oh2 = LOG10(q_oh_oh2)
        CLOSE (iread2)
     ENDIF

     !---------------------------------------------------------------------
     !- H2O COLLISIONS
     !---------------------------------------------------------------------
     IF (i_h2o /= 0) THEN
        IF (in_sp(i_h2o) /= 0) THEN

           ! 1 - Search highest level in collisions rates --------------------

           !- H2O + He collision rates ---------------------------------------
           levcolmax_1 = - 1
           fichier = TRIM(data_dir)//'Collisions/q_he_h2o.dat'
           WRITE(iscrn,*) "Opening file : ", TRIM(fichier)
           OPEN(iread2, FILE = fichier, STATUS = 'old')
           READ(iread2,*) ntnr
           DO j = 1, ntnr
              READ(iread2,*) levu, levl, q1, q2, q3
              IF (levu > levcolmax_1) levcolmax_1 = levu
           ENDDO
           CLOSE(iread2)

           !- H2O + H2 collision rates ---------------------------------------
           levcolmax_2 = -1
           fichier = TRIM(data_dir)//'Collisions/q_h2_h2o.dat'
           WRITE(iscrn,*) "Opening file : ", TRIM(fichier)
           OPEN(iread2, FILE = fichier, STATUS = 'old')
           READ(iread2,*) ntnr
           DO j = 1, ntnr
              READ(iread2,*) levu, levl, q1, q2, q3
              IF (levu > levcolmax_2) levcolmax_2 = levu
           ENDDO
           CLOSE(iread2)
           levcolmax = MIN(levcolmax_1,levcolmax_2)
           ! modify max level of H2O used
           nused = MIN(levcolmax, spec_lin(in_sp(i_h2o))%use)
           ! if modified, update list of transitions
           IF (nused .NE. spec_lin(in_sp(i_h2o))%use) THEN
              spec_lin(in_sp(i_h2o))%use = nused
              PRINT *, "Max level of H2O modified to ", nused
              fichin = TRIM(data_dir)//"Lines/line_"//TRIM(spec_lin(in_sp(i_h2o))%nam)//".dat"
              CALL READ_DATALINE(fichin,spec_lin(in_sp(i_h2o)))
           ENDIF

           ALLOCATE(q_h2o_he_1(nused,nused))
           ALLOCATE(q_h2o_he_2(nused,nused))
           ALLOCATE(q_h2o_he_3(nused,nused))
           ALLOCATE(q_h2o_h2_1(nused,nused))
           ALLOCATE(q_h2o_h2_2(nused,nused))
           ALLOCATE(q_h2o_h2_3(nused,nused))

           ! 2 - Store collision rates data ----------------------------------

           !- H2O + He collision rates ---------------------------------------

           fichier = TRIM(data_dir)//'Collisions/q_he_h2o.dat'
           WRITE(iscrn,*) "Opening file : ", TRIM(fichier)
           OPEN(iread2, FILE = fichier, STATUS = 'old')
           READ (iread2,*) ntnr

           q_h2o_he_1 = -50.0_DP
           q_h2o_he_2 = 0.0_DP
           q_h2o_he_3 = 0.0_DP

           DO j = 1, ntnr
              READ (iread2,*) levu, levl, q1, q2, q3
              IF (levu > nused) CYCLE
              q_h2o_he_1(levu,levl) = q1
              q_h2o_he_2(levu,levl) = q2
              q_h2o_he_3(levu,levl) = q3
           ENDDO
           CLOSE (iread2)

           !- H2O + H2 collision rates ---------------------------------------
           fichier = TRIM(data_dir)//'Collisions/q_h2_h2o.dat'
           WRITE(iscrn,*) "Opening file : ", TRIM(fichier)
           OPEN(iread2, FILE = fichier, STATUS = 'old')
           READ (iread2,*) ntnr

           q_h2o_h2_1  = -50.0_DP
           q_h2o_h2_2  = 0.0_DP
           q_h2o_h2_3  = 0.0_DP

           DO j = 1, ntnr
              READ (iread2,*) levu, levl, q1, q2, q3
              IF (levu > nused) CYCLE
              q_h2o_h2_1(levu,levl) = q1
              q_h2o_h2_2(levu,levl) = q2
              q_h2o_h2_3(levu,levl) = q3
           ENDDO
           CLOSE (iread2)
        ENDIF
     ENDIF

     !---------------------------------------------------------------------
     !- HCO+ COLLISIONS
     !---------------------------------------------------------------------
     IF (i_hcop /= 0) THEN
        IF (in_sp(i_hcop) /= 0) THEN
           nused = spec_lin(in_sp(i_hcop))%use

           !- HCO+ + H2 collision rates --------------------------------------

           ALLOCATE(q_hcop_h2(4,nused,nused))

           q_hcop_h2        = 0.0_dp

           fichier = TRIM(data_dir)//'Collisions/q_h2_hcop.dat'
           WRITE(iscrn,*) "Opening file : ", TRIM(fichier)
           OPEN (iread2, FILE = fichier, STATUS = 'old')
           READ(iread2,*) ntnr

           DO ntc = 1, ntnr
              READ(iread2,*) levu, levl, q1, q2, q3, q4
              IF (levu > nused) CYCLE
              q_hcop_h2(1,levu,levl) = q1
              q_hcop_h2(2,levu,levl) = q2
              q_hcop_h2(3,levu,levl) = q3
              q_hcop_h2(4,levu,levl) = q4
           ENDDO
           CLOSE (iread2)
        ENDIF
     ENDIF

     !---------------------------------------------------------------------
     !- CH+ COLLISION RATES
     !---------------------------------------------------------------------

     IF (i_chp /= 0) THEN
     IF (in_sp(i_chp) /= 0) THEN

        ! For CH+ we have collision rates with He and electrons
        ! Data set for electron is incomplete

        !--- Get some informations on CH+ + He collisions
        fichier = TRIM(data_dir)//'Collisions/q_he_chp.dat'
        WRITE(iscrn,*) "Opening file : ", TRIM(fichier)
        OPEN (iread2, FILE = fichier, STATUS = 'old')
        READ (iread2,'(/,i5)') nlevcchp_he
        PRINT *, "-- Number of levels                  : ", nlevcchp_he
        READ (iread2,'(/,i5)') nctr_he
        PRINT *, "-- Number of collisional transitions : ", nctr_he
        READ (iread2,'(/,i5)') nttchp_he
        PRINT *, "-- Number of temperatures            : ", nttchp_he

        !--- Get some informations in CH+ + electrons collisions
        fichier = TRIM(data_dir)//'Collisions/q_e_chp.dat'
        WRITE(iscrn,*) "Opening file : ", TRIM(fichier)
        OPEN (iread3, FILE = fichier, STATUS = 'old')
        READ (iread3,'(/,i5)') nlevcchp_e
        PRINT *, "-- Number of levels                  : ", nlevcchp_e
        READ (iread3,'(/,i5)') nctr_e
        PRINT *, "-- Number of collisional transitions : ", nctr_e
        READ (iread3,'(/,i5)') nttchp_e
        PRINT *, "-- Number of temperatures            : ", nttchp_e

        !--- Allocations and initializations
        nlevcchp = MAX(nlevcchp_he, nlevcchp_e)
        ALLOCATE (q_chp_he(nttchp_he+1,nlevcchp,nlevcchp))
        ALLOCATE (q_chp_e(nttchp_e+1,nlevcchp,nlevcchp))
        q_chp_he(:,:,:) = 1.0e-50_dp  ! initialization
        q_chp_e(:,:,:)  = 1.0e-50_dp  ! initialization

        ALLOCATE (tempcchp_he(nttchp_he+1))
        ALLOCATE (tempcchp_e(nttchp_e+1))

        !--- Get data for CH+ collisions with He
        READ (iread2,*)
        READ (iread2,*) (tempcchp_he(k), k = 1, nttchp_he)
        tempcchp_he(nttchp_he+1) = tempcchp_he(nttchp_he) * 2.0_dp
        tempcchp_he = LOG10(tempcchp_he)
        READ (iread2,*)
        DO i = 1, nctr_he
           READ (iread2,*) k, jup, jlow, (q_chp_he(j,jup,jlow), j = 1, nttchp_he)
        ENDDO
        ! For extrapolation beyond last T, we use a constant collision rate
        q_chp_he(nttchp_he+1,:,:) = q_chp_he(nttchp_he,:,:)
        q_chp_he = LOG10(q_chp_he)

        !--- Get data for CH+ collisions with electrons
        READ (iread3,*)
        READ (iread3,*) (tempcchp_e(k), k = 1, nttchp_e)
        tempcchp_e(nttchp_e+1) = tempcchp_e(nttchp_e) * 2.0_dp
        tempcchp_e = LOG10(tempcchp_e)
        READ (iread3,*)
        DO i = 1, nctr_e
           READ (iread3,*) k, jup, jlow, (q_chp_e(j,jup,jlow), j = 1, nttchp_e)
        ENDDO
        ! For extrapolation beyond last T, we use a constant collision rate
        q_chp_e(nttchp_e+1,:,:) = q_chp_e(nttchp_e,:,:)
        q_chp_e = LOG10(q_chp_e)

        !--- Close files
        CLOSE (iread2)
        CLOSE (iread3)

     ENDIF
     ENDIF

     !---------------------------------------------------------------------
     !- HCN COLLISIONS
     !---------------------------------------------------------------------
     IF (i_hcn /= 0) THEN
        IF (in_sp(i_hcn) /= 0) THEN
           nused = spec_lin(in_sp(i_hcn))%use

           !- HCN + H2 collision rates ---------------------------------------
           ! 2 VII 08 HCN collision are idexed by J from 0 to 29
           ! They must be spread on F hyper-fine levels afterwards

           ALLOCATE(q_hcn_h2(6,0:29,0:29))

           q_hcn_h2        = 0.0_dp
           q_hcn_h2(1,:,:) = -50.0_dp

           fichier = TRIM(data_dir)//'Collisions/q_h2_hcn.dat'
           WRITE(iscrn,*) "Opening file : ", TRIM(fichier)
           OPEN (iread2, FILE = fichier, STATUS = 'old')
           READ(iread2,*) ntnr

           DO ntc = 1, ntnr
              READ(iread2,*) iju, ijl, q1, q2, q3, q4, q5, q6
              IF (iju > nused) CYCLE
              q_hcn_h2(1,iju,ijl) = q1
              q_hcn_h2(2,iju,ijl) = q2
              q_hcn_h2(3,iju,ijl) = q3
              q_hcn_h2(4,iju,ijl) = q4
              q_hcn_h2(5,iju,ijl) = q5
              q_hcn_h2(6,iju,ijl) = q6
           ENDDO
           CLOSE (iread2)
        ENDIF
     ENDIF

     !---------------------------------------------------------------------
     !- O2 COLLISIONS
     !---------------------------------------------------------------------
     IF (i_o2 /= 0) THEN
        IF (in_sp(i_o2) /= 0) THEN
           nused = spec_lin(in_sp(i_o2))%use

           ALLOCATE(q_o2_he(8,1:36,1:36))
           q_o2_he(:,:,:) = 0.0_dp

           fichier = TRIM(data_dir)//'Collisions/q_he_o2.dat'
           OPEN(iread2, FILE = fichier, STATUS = 'old')
           READ(iread2,*) ! comment line
           READ(iread2,*) ntnr

           DO ntc = 1, ntnr
              READ(iread2,*) levu, levl, nup, jup, nlow, jlow &
                           , eps, q0, q1, q2, q3, q4, q5, q6
              IF (levu > nused) CYCLE
              q_o2_he(1,levu,levl) = eps
              q_o2_he(2,levu,levl) = q0
              q_o2_he(3,levu,levl) = q1
              q_o2_he(4,levu,levl) = q2
              q_o2_he(5,levu,levl) = q3
              q_o2_he(6,levu,levl) = q4
              q_o2_he(7,levu,levl) = q5
              q_o2_he(8,levu,levl) = q6
           ENDDO

           CLOSE (iread2)
        ENDIF
     ENDIF

     !---------------------------------------------------------------------
     !- OH+ COLLISION RATES
     !---------------------------------------------------------------------

     IF (i_ohp /= 0) THEN
     IF (in_sp(i_ohp) /= 0) THEN

        ! For OH+ we have collision rates with H2 and electrons
        ! Data set for electron is uncomplete

        !--- Get some informations on OH+ + H2 collisions
        fichier = TRIM(data_dir)//'Collisions/q_h2_ohp.dat'
        WRITE(iscrn,*) "Opening file : ", TRIM(fichier)
        OPEN (iread2, FILE = fichier, STATUS = 'old')
        READ (iread2,'(/,i5)') nlevcohp_h2
        PRINT *, " Number of levels: ", nlevcohp_h2
        READ (iread2,'(/,i5)') nctr_h2
        PRINT *, " Number of collisional transitions : ", nctr_h2
        READ (iread2,'(/,i5)') nttohp_h2
        PRINT *, " Number of temperatures: ", nttohp_h2

        !--- Get some informations in OH+ + electrons collisions
        fichier = TRIM(data_dir)//'Collisions/q_e_ohp.dat'
        WRITE(iscrn,*) "Opening file : ", TRIM(fichier)
        OPEN (iread3, FILE = fichier, STATUS = 'old')
        READ (iread3,'(/,i5)') nlevcohp_e
        PRINT *, " Number of levels: ", nlevcohp_e
        READ (iread3,'(/,i5)') nctr_e
        PRINT *, " Number of collisional transitions : ", nctr_e
        READ (iread3,'(/,i5)') nttohp_e
        PRINT *, " Number of temperatures: ", nttohp_e

        !--- Allocations and initializations
        nlevcohp = MAX(nlevcohp_h2, nlevcohp_e)
        ALLOCATE (q_ohp_h2(nttohp_h2+1,nlevcohp,nlevcohp))
        ALLOCATE (q_ohp_e(nttohp_e+1,nlevcohp,nlevcohp))
        q_ohp_h2(:,:,:) = 1.0e-50_dp  ! initialization
        q_ohp_e(:,:,:)  = 1.0e-50_dp  ! initialization

        ALLOCATE (tempcohp_h2(nttohp_h2+1))
        ALLOCATE (tempcohp_e(nttohp_e+1))

        !--- Get data for OH+ collisions with H2
        READ (iread2,*)
        READ (iread2,*) (tempcohp_h2(k), k = 1, nttohp_h2)
        tempcohp_h2(nttohp_h2+1) = tempcohp_h2(nttohp_h2) * 2.0_dp
        tempcohp_h2 = LOG10(tempcohp_h2)
        READ (iread2,*)
        DO i = 1, nctr_h2
           READ (iread2,*) k, jup, jlow, (q_ohp_h2(j,jup,jlow), j = 1, nttohp_h2)
!          PRINT *, k, jup, jlow, (q_ohp_h2(j,jup,jlow), j = 1, nttohp_h2)
        ENDDO
        ! For extrapolation beyond last T, we use a constant collision rate
        q_ohp_h2(nttohp_h2+1,:,:) = q_ohp_h2(nttohp_h2,:,:)
        q_ohp_h2 = LOG10(q_ohp_h2)

        !--- Get data for OH+ collisions with electrons
        READ (iread3,*)
        READ (iread3,*) (tempcohp_e(k), k = 1, nttohp_e)
        tempcohp_e(nttohp_e+1) = tempcohp_e(nttohp_e) * 2.0_dp
        tempcohp_e = LOG10(tempcohp_e)
        READ (iread3,*)
        DO i = 1, nctr_e
           READ (iread3,*) k, jup, jlow, (q_ohp_e(j,jup,jlow), j = 1, nttohp_e)
!          PRINT *, k, jup, jlow, (q_ohp_e(j,jup,jlow), j = 1, nttohp_e)
        ENDDO
        ! For extrapolation beyond last T, we use a constant collision rate
        q_ohp_e(nttohp_e+1,:,:) = q_ohp_e(nttohp_e,:,:)
        q_ohp_e = LOG10(q_ohp_e)

        !--- Close files
        CLOSE (iread2)
        CLOSE (iread3)

     ENDIF
     ENDIF

     !---------------------------------------------------------------------
     !- SH+ COLLISION RATES
     !---------------------------------------------------------------------

     IF (i_shp /= 0) THEN
     IF (in_sp(i_shp) /= 0) THEN

        ! For SH+ we have collision rates with H2 and electrons
        ! Data set for electron is uncomplete

        !--- Get some informations on SH+ + H2 collisions
        fichier = TRIM(data_dir)//'Collisions/q_h2_shp.dat'
        WRITE(iscrn,*)
        WRITE(iscrn,*) "Opening file : ", TRIM(fichier)
        OPEN (iread2, FILE = fichier, STATUS = 'old')
        READ (iread2,'(/,i5)') nlevcshp_h2
        PRINT *, "-- Number of levels: ", nlevcshp_h2
        READ (iread2,'(/,i5)') nctr_h2
        PRINT *, "-- Number of collisional transitions : ", nctr_h2
        READ (iread2,'(/,i5)') nttshp_h2
        PRINT *, "-- Number of temperatures: ", nttshp_h2

        !--- Get some informations in SH+ + electrons collisions
        fichier = TRIM(data_dir)//'Collisions/q_e_shp.dat'
        WRITE(iscrn,*) "Opening file : ", TRIM(fichier)
        OPEN (iread3, FILE = fichier, STATUS = 'old')
        READ (iread3,'(/,i5)') nlevcshp_e
        PRINT *, " Number of levels: ", nlevcshp_e
        READ (iread3,'(/,i5)') nctr_e
        PRINT *, " Number of collisional transitions : ", nctr_e
        READ (iread3,'(/,i5)') nttshp_e
        PRINT *, " Number of temperatures: ", nttshp_e

        !--- Allocations and initializations
        nlevcshp = MAX(nlevcshp_h2, nlevcshp_e)
        ALLOCATE (q_shp_h2(nttshp_h2+1,nlevcshp,nlevcshp))
        ALLOCATE (q_shp_e(nttshp_e+1,nlevcshp,nlevcshp))
        q_shp_h2(:,:,:) = 1.0e-50_dp  ! initialization
        q_shp_e(:,:,:)  = 1.0e-50_dp  ! initialization

        ALLOCATE (tempcshp_h2(nttshp_h2+1))
        ALLOCATE (tempcshp_e(nttshp_e+1))

        !--- Get data for SH+ collisions with H2
        READ (iread2,*)
        READ (iread2,*) (tempcshp_h2(k), k = 1, nttshp_h2)
        tempcshp_h2(nttshp_h2+1) = tempcshp_h2(nttshp_h2) * 2.0_dp
        tempcshp_h2 = LOG10(tempcshp_h2)
        READ (iread2,*)
        DO i = 1, nctr_h2
           READ (iread2,*) k, jup, jlow, (q_shp_h2(j,jup,jlow), j = 1, nttshp_h2)
!          PRINT *, k, jup, jlow, (q_shp_h2(j,jup,jlow), j = 1, nttshp_h2)
        ENDDO
        ! For extrapolation beyond last T, we use a constant collision rate
        q_shp_h2(nttshp_h2+1,:,:) = q_shp_h2(nttshp_h2,:,:)
        q_shp_h2 = LOG10(q_shp_h2)

        !--- Get data for CH+ collisions with electrons
        READ (iread3,*)
        READ (iread3,*) (tempcshp_e(k), k = 1, nttshp_e)
        tempcshp_e(nttshp_e+1) = tempcshp_e(nttshp_e) * 2.0_dp
        tempcshp_e = LOG10(tempcshp_e)
        READ (iread3,*)
        DO i = 1, nctr_e
           READ (iread3,*) k, jup, jlow, (q_shp_e(j,jup,jlow), j = 1, nttshp_e)
!          PRINT *, k, jup, jlow, (q_shp_e(j,jup,jlow), j = 1, nttshp_e)
        ENDDO
        ! For extrapolation beyond last T, we use a constant collision rate
        q_shp_e(nttshp_e+1,:,:) = q_shp_e(nttshp_e,:,:)
        q_shp_e = LOG10(q_shp_e)

        !--- Close files
        CLOSE (iread2)
        CLOSE (iread3)

     ENDIF
     ENDIF

     !---------------------------------------------------------------------
     !- ArH+ COLLISION RATES
     !---------------------------------------------------------------------

     IF (i_arhp /= 0) THEN
     IF (in_sp(i_arhp) /= 0) THEN

        ! For ArH+ we have collision rates with electrons (from A. Faure)
        ! For collisions with He, we use the rates of the SiH+ / He system (as done by Barlow 2013)

        !--- Get some informations on ArH+ + He collisions
        fichier = TRIM(data_dir)//'Collisions/q_he_arhp.dat'
        WRITE(iscrn,*) "Opening file : ", TRIM(fichier)
        OPEN (iread2, FILE = fichier, STATUS = 'old')
        READ (iread2,'(/,i5)') nlevcarhp_he
        PRINT *, "-- Number of levels                  : ", nlevcarhp_he
        READ (iread2,'(/,i5)') nctr_he
        PRINT *, "-- Number of collisional transitions : ", nctr_he
        READ (iread2,'(/,i5)') nttarhp_he
        PRINT *, "-- Number of temperatures            : ", nttarhp_he

        !--- Get some informations in ArH+ + electrons collisions
        fichier = TRIM(data_dir)//'Collisions/q_e_arhp.dat'
        WRITE(iscrn,*) "Opening file : ", TRIM(fichier)
        OPEN (iread3, FILE = fichier, STATUS = 'old')
        READ (iread3,'(/,i5)') nlevcarhp_e
        PRINT *, "-- Number of levels                  : ", nlevcarhp_e
        READ (iread3,'(/,i5)') nctr_e
        PRINT *, "-- Number of collisional transitions : ", nctr_e
        READ (iread3,'(/,i5)') nttarhp_e
        PRINT *, "-- Number of temperatures            : ", nttarhp_e

        !--- Allocations and initializations
        nlevcarhp = MAX(nlevcarhp_he, nlevcarhp_e)
        ALLOCATE (q_arhp_he(nttarhp_he+1,nlevcarhp,nlevcarhp))
        ALLOCATE (q_arhp_e(nttarhp_e+1,nlevcarhp,nlevcarhp))
        q_arhp_he(:,:,:) = 1.0e-50_dp  ! initialization
        q_arhp_e(:,:,:)  = 1.0e-50_dp  ! initialization

        ALLOCATE (tempcarhp_he(nttarhp_he+1))
        ALLOCATE (tempcarhp_e(nttarhp_e+1))

        !--- Get data for ArH+ collisions with He
        READ (iread2,*)
        READ (iread2,*) (tempcarhp_he(k), k = 1, nttarhp_he)
        tempcarhp_he(nttarhp_he+1) = tempcarhp_he(nttarhp_he) * 2.0_dp
        tempcarhp_he = LOG10(tempcarhp_he)
        READ (iread2,*)
        DO i = 1, nctr_he
           READ (iread2,*) k, jup, jlow, (q_arhp_he(j,jup,jlow), j = 1, nttarhp_he)
        ENDDO
        ! For extrapolation beyond last T, we use a constant collision rate
        q_arhp_he(nttarhp_he+1,:,:) = q_arhp_he(nttarhp_he,:,:)
        q_arhp_he = LOG10(q_arhp_he)

        !--- Get data for ArH+ collisions with electrons
        READ (iread3,*)
        READ (iread3,*) (tempcarhp_e(k), k = 1, nttarhp_e)
        tempcarhp_e(nttarhp_e+1) = tempcarhp_e(nttarhp_e) * 2.0_dp
        tempcarhp_e = LOG10(tempcarhp_e)
        READ (iread3,*)
        DO i = 1, nctr_e
           READ (iread3,*) k, jup, jlow, (q_arhp_e(j,jup,jlow), j = 1, nttarhp_e)
        ENDDO
        ! For extrapolation beyond last T, we use a constant collision rate
        q_arhp_e(nttarhp_e+1,:,:) = q_arhp_e(nttarhp_e,:,:)
        q_arhp_e = LOG10(q_arhp_e)

        !--- Close files
        CLOSE (iread2)
        CLOSE (iread3)

     ENDIF
     ENDIF

     !---------------------------------------------------------------------
     !- H3+ COLLISION RATES
     !
     !  In COLSPE several prescriptions can be used for H3+ collision rates
     !  with H2
     !
     !  Here we read 2 datafiles containing Roncero collision rates that is
     !  one of the possible prescriptions
     !  These files contain rates for excitation and de-excitation
     !---------------------------------------------------------------------
     IF (i_h3p /= 0 .AND. F_COLL_H3p == 0) THEN
     IF (in_sp(i_h3p) /= 0) THEN

        !--- Collisions H3+ + H2 para (J=0 only)
        fichier = TRIM(data_dir)//'Collisions/q_ph2_h3p.dat'
        WRITE(iscrn,*)
        WRITE(iscrn,*) "Opening file : ", TRIM(fichier)
        OPEN (iread2, FILE = fichier, STATUS = 'old')
        READ (iread2,'(/,i5)') nlevch3p_ph2
        PRINT *, "-- Number of levels: ", nlevch3p_ph2
        READ (iread2,'(/,i5)') nctr_ph2
        PRINT *, "-- Number of collisional transitions : ", nctr_ph2
        READ (iread2,'(/,i5)') ntth3p_ph2
        PRINT *, "-- Number of temperatures: ", ntth3p_ph2

        !--- Collisions H3+ + H2 ortho (J=1 only)
        fichier = TRIM(data_dir)//'Collisions/q_oh2_h3p.dat'
        WRITE(iscrn,*)
        WRITE(iscrn,*) "Opening file : ", TRIM(fichier)
        OPEN (iread3, FILE = fichier, STATUS = 'old')
        READ (iread3,'(/,i5)') nlevch3p_oh2
        PRINT *, "-- Number of levels: ", nlevch3p_oh2
        READ (iread3,'(/,i5)') nctr_oh2
        PRINT *, "-- Number of collisional transitions : ", nctr_oh2
        READ (iread3,'(/,i5)') ntth3p_oh2
        PRINT *, "-- Number of temperatures: ", ntth3p_oh2

        !--- Allocations and initializations
        nlevch3p = MAX(nlevch3p_ph2, nlevch3p_oh2)
        ALLOCATE (q_h3p_ph2(ntth3p_ph2+1, nlevch3p, nlevch3p))
        ALLOCATE (q_h3p_oh2(ntth3p_oh2+1, nlevch3p, nlevch3p))
        q_h3p_ph2(:,:,:) = 1.0e-50_dp  ! initialization
        q_h3p_oh2(:,:,:) = 1.0e-50_dp  ! initialization

        ALLOCATE (tempch3p_ph2(ntth3p_ph2+1))
        ALLOCATE (tempch3p_oh2(ntth3p_oh2+1))

        !--- Get data for H3+ collisions with H2 J=0
        READ (iread2,*)
        READ (iread2,*) (tempch3p_ph2(k), k = 1, ntth3p_ph2)
        tempch3p_ph2(ntth3p_ph2+1) = tempch3p_ph2(ntth3p_ph2) * 2.0_dp
        tempch3p_ph2 = LOG10(tempch3p_ph2)
        READ (iread2,*)
        DO i = 1, nctr_ph2
           READ (iread2,*) i_i, i_f, j_i, j_f, k_i, k_f, (q_h3p_ph2(j,i_i,i_f), j = 1, ntth3p_ph2)
           !PRINT *, k, i_i, i_f, J_i, K_i, J_f, K_f, q_h3p_ph2(1,i_i,i_f)
        ENDDO
        ! For extrapolation beyond last T, we use a constant collision rate
        q_h3p_ph2(ntth3p_ph2+1,:,:) = q_h3p_ph2(ntth3p_ph2,:,:)
        q_h3p_ph2 = LOG10(q_h3p_ph2)

        !--- Get data for H3+ collisions with H2 J=1
        READ (iread3,*)
        READ (iread3,*) (tempch3p_oh2(k), k = 1, ntth3p_oh2)
        tempch3p_oh2(ntth3p_oh2+1) = tempch3p_oh2(ntth3p_oh2) * 2.0_dp
        tempch3p_oh2 = LOG10(tempch3p_oh2)
        READ (iread3,*)
        DO i = 1, nctr_oh2
           READ (iread3,*) i_i, i_f, j_i, j_f, k_i, k_f, (q_h3p_oh2(j,i_i,i_f), j = 1, ntth3p_oh2)
           !PRINT *, k, i_f, i_i, J_i, K_i, J_f, K_f, q_h3p_oh2(1,i_i,i_f)
        ENDDO
        ! For extrapolation beyond last T, we use a constant collision rate
        q_h3p_oh2(ntth3p_oh2+1,:,:) = q_h3p_oh2(ntth3p_oh2,:,:)
        q_h3p_oh2 = LOG10(q_h3p_oh2)

     ENDIF
     ENDIF

     !---------------------------------------------------------------------
     !- NE+ COLLISION RATES
     !---------------------------------------------------------------------

     IF (i_nep /= 0) THEN
     IF (in_sp(i_nep) /= 0) THEN

        ! For Ne+ we only have collision rates with electrons

        !--- Get some informations in Ne+ + electrons collisions
        fichier = TRIM(data_dir)//'Collisions/q_e_nep.dat'
        WRITE(iscrn,*) "Opening file : ", TRIM(fichier)
        OPEN (iread3, FILE = fichier, STATUS = 'old')
        READ (iread3,'(/,i5)') nlevcnep_e
        PRINT *, "-- Number of levels                  : ", nlevcnep_e
        READ (iread3,'(/,i5)') nctr_e
        PRINT *, "-- Number of collisional transitions : ", nctr_e
        READ (iread3,'(/,i5)') nttnep_e
        PRINT *, "-- Number of temperatures            : ", nttnep_e

        !--- Allocations and initializations
        ALLOCATE (q_nep_e(nttnep_e+1,nlevcnep_e,nlevcnep_e))
        ALLOCATE (tempcnep_e(nttnep_e+1))
        q_nep_e(:,:,:)  = 1.0e-50_dp  ! initialization

        !--- Get data for Ne+ collisions with electrons
        READ (iread3,*)
        READ (iread3,*) (tempcnep_e(k), k = 1, nttnep_e)
        READ (iread3,*)
        DO i = 1, nctr_e
           READ (iread3,*) k, jup, jlow, (q_nep_e(j,jup,jlow), j = 1, nttnep_e)
        ENDDO
        ! For extrapolation beyond last T, we use a constant collision rate
        tempcnep_e(nttnep_e+1)  = tempcnep_e(nttnep_e) * 2.0_dp
        q_nep_e(nttnep_e+1,:,:) = q_nep_e(nttnep_e,:,:)
        tempcnep_e = LOG10(tempcnep_e)
        q_nep_e    = LOG10(q_nep_e)

        !--- Close files
        CLOSE (iread2)
        CLOSE (iread3)

     ENDIF
     ENDIF

     !---------------------------------------------------------------------
     !- NE++ COLLISION RATES
     !---------------------------------------------------------------------

     IF (i_nepp /= 0) THEN
     IF (in_sp(i_nepp) /= 0) THEN

        ! For Ne++ we only have collision rates with electrons

        !--- Get some informations in Ne++ + electrons collisions
        fichier = TRIM(data_dir)//'Collisions/q_e_nepp.dat'
        WRITE(iscrn,*) "Opening file : ", TRIM(fichier)
        OPEN (iread3, FILE = fichier, STATUS = 'old')
        READ (iread3,'(/,i5)') nlevcnepp_e
        PRINT *, "-- Number of levels                  : ", nlevcnepp_e
        READ (iread3,'(/,i5)') nctr_e
        PRINT *, "-- Number of collisional transitions : ", nctr_e
        READ (iread3,'(/,i5)') nttnepp_e
        PRINT *, "-- Number of temperatures            : ", nttnepp_e

        !--- Allocations and initializations
        ALLOCATE (q_nepp_e(nttnepp_e+1,nlevcnepp_e,nlevcnepp_e))
        ALLOCATE (tempcnepp_e(nttnepp_e+1))
        q_nepp_e(:,:,:)  = 1.0e-50_dp  ! initialization

        !--- Get data for Ne++ collisions with electrons
        READ (iread3,*)
        READ (iread3,*) (tempcnepp_e(k), k = 1, nttnepp_e)
        READ (iread3,*)
        DO i = 1, nctr_e
           READ (iread3,*) k, jup, jlow, (q_nepp_e(j,jup,jlow), j = 1, nttnepp_e)
        ENDDO
        ! For extrapolation beyond last T, we use a constant collision rate
        tempcnepp_e(nttnepp_e+1)  = tempcnepp_e(nttnepp_e) * 2.0_dp
        q_nepp_e(nttnepp_e+1,:,:) = q_nepp_e(nttnepp_e,:,:)
        tempcnepp_e = LOG10(tempcnepp_e)
        q_nepp_e    = LOG10(q_nepp_e)

        !--- Close files
        CLOSE (iread2)
        CLOSE (iread3)

     ENDIF
     ENDIF

     !---------------------------------------------------------------------
     !- C++ COLLISION RATES
     !---------------------------------------------------------------------

     IF (i_cpp /= 0) THEN
     IF (in_sp(i_cpp) /= 0) THEN

        ! For C++ we only have collision rates with electrons

        !--- Get some informations in C++ + electrons collisions
        fichier = TRIM(data_dir)//'Collisions/q_e_cpp.dat'
        WRITE(iscrn,*) "Opening file : ", TRIM(fichier)
        OPEN (iread3, FILE = fichier, STATUS = 'old')
        READ (iread3,'(/,i5)') nlevccpp_e
        PRINT *, "-- Number of levels                  : ", nlevccpp_e
        READ (iread3,'(/,i5)') nctr_e
        PRINT *, "-- Number of collisional transitions : ", nctr_e
        READ (iread3,'(/,i5)') nttcpp_e
        PRINT *, "-- Number of temperatures            : ", nttcpp_e

        !--- Allocations and initializations
        ALLOCATE (q_cpp_e(nttcpp_e+1,nlevccpp_e,nlevccpp_e))
        ALLOCATE (tempccpp_e(nttcpp_e+1))
        q_cpp_e(:,:,:)  = 1.0e-50_dp  ! initialization

        !--- Get data for C++ collisions with electrons
        READ (iread3,*)
        READ (iread3,*) (tempccpp_e(k), k = 1, nttcpp_e)
        READ (iread3,*)
        DO i = 1, nctr_e
           READ (iread3,*) k, jup, jlow, (q_cpp_e(j,jup,jlow), j = 1, nttcpp_e)
        ENDDO
        ! For extrapolation beyond last T, we use a constant collision rate
        tempccpp_e(nttcpp_e+1)  = tempccpp_e(nttcpp_e) * 2.0_dp
        q_cpp_e(nttcpp_e+1,:,:) = q_cpp_e(nttcpp_e,:,:)
        tempccpp_e = LOG10(tempccpp_e)
        q_cpp_e    = LOG10(q_cpp_e)

        !--- Close files
        CLOSE (iread2)
        CLOSE (iread3)

     ENDIF
     ENDIF

     !---------------------------------------------------------------------
     !- S++ COLLISION RATES
     !---------------------------------------------------------------------

     IF (i_spp /= 0) THEN
     IF (in_sp(i_spp) /= 0) THEN

        ! For S++ we only have collision rates with electrons

        !--- Get some informations in S++ + electrons collisions
        fichier = TRIM(data_dir)//'Collisions/q_e_spp.dat'
        WRITE(iscrn,*) "Opening file : ", TRIM(fichier)
        OPEN (iread3, FILE = fichier, STATUS = 'old')
        READ (iread3,'(/,i5)') nlevcspp_e
        PRINT *, "-- Number of levels                  : ", nlevcspp_e
        READ (iread3,'(/,i5)') nctr_e
        PRINT *, "-- Number of collisional transitions : ", nctr_e
        READ (iread3,'(/,i5)') nttspp_e
        PRINT *, "-- Number of temperatures            : ", nttspp_e

        !--- Allocations and initializations
        ALLOCATE (q_spp_e(nttspp_e+1,nlevcspp_e,nlevcspp_e))
        ALLOCATE (tempcspp_e(nttspp_e+1))
        q_spp_e(:,:,:)  = 1.0e-50_dp  ! initialization

        !--- Get data for S++ collisions with electrons
        READ (iread3,*)
        READ (iread3,*) (tempcspp_e(k), k = 1, nttspp_e)
        READ (iread3,*)
        DO i = 1, nctr_e
           READ (iread3,*) k, jup, jlow, (q_spp_e(j,jup,jlow), j = 1, nttspp_e)
        ENDDO
        ! For extrapolation beyond last T, we use a constant collision rate
        tempcspp_e(nttspp_e+1)  = tempcspp_e(nttspp_e) * 2.0_dp
        q_spp_e(nttspp_e+1,:,:) = q_spp_e(nttspp_e,:,:)
        tempcspp_e = LOG10(tempcspp_e)
        q_spp_e    = LOG10(q_spp_e)

        !--- Close files
        CLOSE (iread2)
        CLOSE (iread3)

     ENDIF
     ENDIF

     !---------------------------------------------------------------------
     !- N++ COLLISION RATES
     !---------------------------------------------------------------------

     IF (i_npp /= 0) THEN
     IF (in_sp(i_npp) /= 0) THEN

        ! For N++ we only have collision rates with electrons

        !--- Get some informations in N++ + electrons collisions
        fichier = TRIM(data_dir)//'Collisions/q_e_npp.dat'
        WRITE(iscrn,*) "Opening file : ", TRIM(fichier)
        OPEN (iread3, FILE = fichier, STATUS = 'old')
        READ (iread3,'(/,i5)') nlevcnpp_e
        PRINT *, "-- Number of levels                  : ", nlevcnpp_e
        READ (iread3,'(/,i5)') nctr_e
        PRINT *, "-- Number of collisional transitions : ", nctr_e
        READ (iread3,'(/,i5)') nttnpp_e
        PRINT *, "-- Number of temperatures            : ", nttnpp_e

        !--- Allocations and initializations
        ALLOCATE (q_npp_e(nttnpp_e+1,nlevcnpp_e,nlevcnpp_e))
        ALLOCATE (tempcnpp_e(nttnpp_e+1))
        q_npp_e(:,:,:)  = 1.0e-50_dp  ! initialization

        !--- Get data for N++ collisions with electrons
        READ (iread3,*)
        READ (iread3,*) (tempcnpp_e(k), k = 1, nttnpp_e)
        READ (iread3,*)
        DO i = 1, nctr_e
           READ (iread3,*) k, jup, jlow, (q_npp_e(j,jup,jlow), j = 1, nttnpp_e)
        ENDDO
        ! For extrapolation beyond last T, we use a constant collision rate
        tempcnpp_e(nttnpp_e+1)  = tempcnpp_e(nttnpp_e) * 2.0_dp
        q_npp_e(nttnpp_e+1,:,:) = q_npp_e(nttnpp_e,:,:)
        tempcnpp_e = LOG10(tempcnpp_e)
        q_npp_e    = LOG10(q_npp_e)

        !--- Close files
        CLOSE (iread2)
        CLOSE (iread3)

     ENDIF
     ENDIF

     !---------------------------------------------------------------------
     !- H COLLISION RATES
     !---------------------------------------------------------------------

     IF (i_h /= 0) THEN
     IF (in_sp(i_h) /= 0) THEN

        ! For H we only have collision rates with electrons

        !--- Get some informations in H + electrons collisions
        fichier = TRIM(data_dir)//'Collisions/q_e_h.dat'
        WRITE(iscrn,*) "Opening file : ", TRIM(fichier)
        OPEN (iread3, FILE = fichier, STATUS = 'old')
        READ (iread3,'(/,i5)') nlevch_e
        PRINT *, "-- Number of levels                  : ", nlevch_e
        READ (iread3,'(/,i5)') nctr_e
        PRINT *, "-- Number of collisional transitions : ", nctr_e
        READ (iread3,'(/,i5)') ntth_e
        PRINT *, "-- Number of temperatures            : ", ntth_e

        !--- Allocations and initializations
        ALLOCATE (q_h_e(ntth_e+1,nlevch_e,nlevch_e))
        ALLOCATE (tempch_e(ntth_e+1))
        q_h_e(:,:,:)  = 1.0e-50_dp  ! initialization

        !--- Get data for H collisions with electrons
        READ (iread3,*)
        READ (iread3,*) (tempch_e(k), k = 1, ntth_e)
        READ (iread3,*)
        DO i = 1, nctr_e
           READ (iread3,*) k, jup, jlow, (q_h_e(j,jup,jlow), j = 1, ntth_e)
        ENDDO
        ! For extrapolation beyond last T, we use a constant collision rate
        tempch_e(ntth_e+1)  = tempch_e(ntth_e) * 2.0_dp
        q_h_e(ntth_e+1,:,:) = q_h_e(ntth_e,:,:)
        tempch_e = LOG10(tempch_e)
        q_h_e    = LOG10(q_h_e)

        !--- Close files
        CLOSE (iread2)
        CLOSE (iread3)

     ENDIF
     ENDIF

 4001  FORMAT(1x,I2,1x,I2,4(1x,E10.3))

END SUBROUTINE READ_COL

END MODULE PXDR_INITIAL

