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


MODULE PXDR_AUXILIAR

  USE PXDR_CONSTANTES

  PRIVATE

  PUBLIC :: LLEV_H2, ii2c, HUMLIK, ORTHOG, GAUCOF, PYTHAG, EXPBOR &
          , MAKE_NAMEMOMENTS, SPEMAJ, STR_INT, INT_STR, LOC_IND, INTERP_BILIN &
          , INTERP_BILIN_GEN, SORT, SIMPINT, TRAPINT, LOCASE, e1xa, LINEARFIT &
          , gammln, ROMBERG, ii3c

  ! Computed in LLEV_H2:
  INTEGER, PUBLIC                                     :: mlph2     ! Nombre de nivaux de H2 pairs effectivement utilises
  INTEGER, PUBLIC                                     :: mlih2     ! Nombre de nivaux de H2 impairs effectivement utilises
  INTEGER, PUBLIC, ALLOCATABLE, DIMENSION(:)          :: levinc    ! Liste (ordonnee) de ces niveaux
  INTEGER, PUBLIC, ALLOCATABLE, DIMENSION(:)          :: levpc     ! Liste (ordonnee) de ces niveaux pairs
  INTEGER, PUBLIC, ALLOCATABLE, DIMENSION(:)          :: levic     ! Liste (ordonnee) de ces niveaux impairs

  REAL (KIND=dp), PUBLIC                              :: wlrwid = 5000.0_dp !  Width (in reduced units) of lines
                                                                            !  included in complete transfer

  ! H2 UV lines
  INTEGER, PUBLIC                                     :: nrh2bt    ! Number of H2 lines - Lyman transitions
  INTEGER, PUBLIC                                     :: nrh2ct    ! Number of H2 lines - Werner transitions
  INTEGER, PUBLIC, DIMENSION(:,:), ALLOCATABLE        :: irah2b    ! Line PARAMETERs (INTEGER values - Lyman)
  INTEGER, PUBLIC, DIMENSION(:,:), ALLOCATABLE        :: irah2c    ! Line PARAMETERs (INTEGER values - Werner)
                                                                   !      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
  REAL (KIND=dp), PUBLIC, DIMENSION(:,:), ALLOCATABLE :: prah2b    ! Line PARAMETERs (REAL values - Lyman)
  REAL (KIND=dp), PUBLIC, DIMENSION(:,:), ALLOCATABLE :: prah2c    ! Line PARAMETERs (REAL values - Werner)
                                                                   !      1: oscilator strength
                                                                   !      2: wave length (Angstrom)
                                                                   !      3: inverse life time (s-1)
                                                                   !      4: Upper level dissociation probability
                                                                   !      5: WL min in line profile
                                                                   !      6: WL max in line profile

  ! HD UV lines
  INTEGER, PUBLIC                                     :: nrhdbt    ! Number of HD lines - Lyman transitions
  INTEGER, PUBLIC                                     :: nrhdct    ! Number of HD lines - Werner transitions
  INTEGER, PUBLIC, DIMENSION(:,:), ALLOCATABLE        :: irahdb    ! Line PARAMETERs (INTEGER values - Lyman)
  INTEGER, PUBLIC, DIMENSION(:,:), ALLOCATABLE        :: irahdc    ! Line PARAMETERs (INTEGER values - Werner)
                                                                   !      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
  REAL (KIND=dp), PUBLIC, DIMENSION(:,:), ALLOCATABLE :: prahdb    ! Line PARAMETERs (REAL values - Lyman)
  REAL (KIND=dp), PUBLIC, DIMENSION(:,:), ALLOCATABLE :: prahdc    ! Line PARAMETERs (REAL values - Werner)
                                                                   !      1: oscilator strength
                                                                   !      2: wave length (Angstrom)
                                                                   !      3: inverse life time (s-1)
                                                                   !      4: Upper level dissociation probability
                                                                   !      5: WL min in line profile
                                                                   !      6: WL max in line profile

  ! CO UV lines
  INTEGER, PUBLIC                                     :: nrco      ! Number of CO lines
  INTEGER, PUBLIC, DIMENSION(:,:), ALLOCATABLE        :: iraco     ! Line PARAMETERs (INTEGER values)
                                                                   !      1: J
                                                                   !      2: unused (yet)
                                                                   !      3: unused (yet)
                                                                   !      4: unused (yet)
                                                                   !      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
  REAL (KIND=dp), PUBLIC, DIMENSION(:,:), ALLOCATABLE :: praco     ! Line PARAMETERs (REAL values)
                                                                   !      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

  INTEGER, PUBLIC                                     :: nrc13o    ! Number of 13CO lines
  INTEGER, PUBLIC, DIMENSION(:,:), ALLOCATABLE        :: irac13o   ! Line PARAMETERs (INTEGER values)
  REAL (KIND=dp), PUBLIC, DIMENSION(:,:), ALLOCATABLE :: prac13o   ! Line PARAMETERs (REAL values)
  INTEGER, PUBLIC                                     :: nrco18    ! Number of C18O lines
  INTEGER, PUBLIC, DIMENSION(:,:), ALLOCATABLE        :: iraco18   ! Line PARAMETERs (INTEGER values)
  REAL (KIND=dp), PUBLIC, DIMENSION(:,:), ALLOCATABLE :: praco18   ! Line PARAMETERs (REAL values)
  INTEGER, PUBLIC                                     :: nrc13o18  ! Number of 13C18O lines
  INTEGER, PUBLIC, DIMENSION(nmrco)                   :: irac13o18 ! Line PARAMETERs (INTEGER values)
  REAL (KIND=dp), PUBLIC, DIMENSION(nmrco,4)          :: prac13o18 ! Line PARAMETERs (REAL values)

CONTAINS

!%%%%%%%%%%%%%%%%%%%%%%%%
SUBROUTINE LLEV_H2 (l0h2)
!%%%%%%%%%%%%%%%%%%%%%%%%

   USE PXDR_FLAGS
   USE PXDR_CONSTANTES

   IMPLICIT NONE

   INTEGER, INTENT (IN)                    :: l0h2
   INTEGER                                 :: i, mlph2, mlih2

   ALLOCATE (levinc(l0h2))
   levinc = (/ (i, i=1,l0h2) /)

   mlph2 = COUNT( MOD(njl_h2(levinc),2) == 0)
   ALLOCATE (levpc(mlph2))
   levpc = PACK( levinc, mask=(MOD(njl_h2(levinc),2) == 0))

   mlih2 = COUNT( MOD(njl_h2(levinc),2) == 1)
   ALLOCATE (levic(mlih2))
   levic = PACK( levinc, mask=(MOD(njl_h2(levinc),2) == 1))

END SUBROUTINE LLEV_H2

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

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
CHARACTER (LEN=4) FUNCTION ii2c(ii)
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

   IMPLICIT NONE
   INTEGER, INTENT (IN) :: ii
   INTEGER              :: icm, icc, icd, icu
   INTEGER              :: jj

   icm = 48 + ii/1000
   IF (icm == 48) THEN
      icm = 32
   ENDIF
   jj  = ii - 1000 * (ii/1000)
   icc = 48 + jj/100
   IF (icm == 32 .AND. icc == 48) THEN
      icc = 32
   ENDIF
   jj  = jj - 100 * (jj/100)
   icd = 48 + jj/10
   jj  = jj - 10 * (jj/10)
   icu = 48 + jj
   ii2c = CHAR(icm)//CHAR(icc)//CHAR(icd)//CHAR(icu)

END FUNCTION ii2c

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
CHARACTER (LEN=4) FUNCTION ii3c(ii)
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

   IMPLICIT NONE
   INTEGER, INTENT (IN) :: ii
   INTEGER              :: icm, icc, icd, icu
   INTEGER              :: jj

   icm = 48 + ii/1000
   IF (icm == 48) THEN
      icm = 32
   ENDIF
   jj  = ii - 1000 * (ii/1000)
   icc = 48 + jj/100
   jj  = jj - 100 * (jj/100)
   icd = 48 + jj/10
   jj  = jj - 10 * (jj/10)
   icu = 48 + jj
   ii3c = CHAR(icm)//CHAR(icc)//CHAR(icd)//CHAR(icu)

END FUNCTION ii3c

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
SUBROUTINE HUMLIK (n1, n2, x, y, k)
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

  USE PXDR_FLAGS
  USE PXDR_CONSTANTES

  INTEGER, INTENT (IN)         :: n1, n2
  REAL (KIND=dp), INTENT (IN)  :: x(n1:n2)
  REAL (KIND=dp), INTENT (IN)  :: y
  REAL (KIND=dp), INTENT (OUT) :: k(n1:n2)

  REAL (KIND=dp) r0, r1
!      PARAMETER (r0 = 146.7, r1 = 14.67)
!  rr must <= 5.0
!      PARAMETER (r0 = 1.51 * EXP(1.144*rr), r1 = 1.60 * EXP(0.554*rr))
  PARAMETER (r0 = 460.4_dp, r1 = 25.5_dp)

  REAL (KIND=dp) rrtpi
  PARAMETER (rrtpi = 0.564189583547756_dp)
  REAL (KIND=dp) y0, y0py0, y0q
  PARAMETER (y0 = 1.5_dp, y0py0 = y0+y0, y0q = y0*y0)
  REAL (KIND=dp) c(0:5), s(0:5), t(0:5)
  save c, s, t
  data c / 1.0117281_dp, -0.75197147_dp, 0.012557727_dp,0.010022008_dp &
         , -0.00024206814_dp,0.00000050084806_dp /
  data s / 1.393237_dp, 0.23115241_dp, -0.15535147_dp, 0.0062183662_dp &
         , 0.000091908299_dp, -0.00000062752596_dp /
  data t / 0.31424038_dp, 0.94778839_dp, 1.5976826_dp, 2.2795071_dp &
         , 3.0206370_dp, 3.8897249_dp /

  INTEGER i, j
  INTEGER rg1, rg2, rg3
  REAL (KIND=dp) abx, xq, yq, yrrtpi
  REAL (KIND=dp) xlim0, xlim1, xlim2, xlim3, xlim4
  REAL (KIND=dp) a0, d0, d2, e0, e2, e4, h0, h2, h4, h6
  REAL (KIND=dp) p0, p2, p4, p6, p8, z0, z2, z4, z6, z8
  REAL (KIND=dp) xp(0:5), xm(0:5), yp(0:5), ym(0:5)
  REAL (KIND=dp) mq(0:5), pq(0:5), mf(0:5), pf(0:5)
  REAL (KIND=dp) d, yf, ypy0, ypy0q

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

  rg1 = 1
  rg2 = 1
  rg3 = 1
  yq = y * y
  yrrtpi = y * rrtpi

  xlim0 = r0 - y
  xlim1 = r1 - y
  xlim3 = 3.097_dp*y - 0.45_dp

!      xlim0 = 15100.0 + y * (40.0 + y * 3.6)
!      xlim1 = 164.0 - y * (4.3 + y * 1.8)
!      xlim3 = 5.76 * yq

  xlim2 = 6.8_dp - y
  xlim4 = 18.1_dp * y + 1.65_dp
  IF (y <= 1.0e-6_dp) THEN
    xlim1 = xlim0
    xlim2 = xlim0
  ENDIF

  DO i = n1, n2
    abx = ABS(x(i))
    xq = abx * abx

    IF (abx > xlim0) THEN
      k(i) = yrrtpi / (xq + yq)

    ELSE IF (abx > xlim1) THEN
      IF (rg1 /= 0) THEN
        rg1 = 0
        a0 = yq + 0.5_dp
        d0 = a0 * a0
        d2 = yq + yq - 1.0_dp
      ENDIF
      d = rrtpi / (d0 + xq * (d2 + xq))
      k(i) = d * y * (a0 + xq)

    ELSE IF (abx > xlim2) THEN
      IF (rg2 /= 0) THEN
        rg2 = 0
        h0 = 0.5625_dp + yq * (4.5_dp + yq * (10.5_dp + yq * (6.0_dp + yq)))
        h2 = -4.5_dp + yq * (9.0_dp + yq * (6.0_dp + yq * 4.0_dp))
        h4 = 10.5_dp - yq * (6.0_dp - yq * 6.0_dp)
        h6 = -6.0_dp + yq * 4.0_dp
        e0 = 1.875_dp + yq * (8.25_dp + yq * (5.5_dp + yq))
        e2 = 5.25_dp + yq * (1.0_dp + yq * 3.0_dp)
        e4 = 0.75_dp * h6
      ENDIF
      d = rrtpi / (h0 + xq * (h2 + xq * (h4 + xq * (h6 + xq))))
      k(i) = d * y * (e0 + xq * (e2 + xq * (e4 + xq)))

    ELSE IF (abx < xlim3) THEN
      IF (rg3 /= 0) THEN
        z0 = 272.1014_dp + y * (1280.829_dp + y * (2802.870_dp + y * (3764.966_dp + y * (3447.629_dp &
                         + y * (2256.981_dp + y * (1074.409_dp + y * (369.1989_dp + y * (88.26741_dp &
                         + y * (13.39880_dp + y)))))))))
        z2 = 211.678_dp  + y * (902.3066_dp + y * (1758.336_dp + y * (2037.310_dp + y * (1549.675_dp &
                         + y * (793.4273_dp + y * (266.2987_dp + y * (53.59518_dp + y * 5.0_dp)))))))
        z4 = 78.86585_dp + y * (308.1852_dp + y * (497.3014_dp + y * (479.2576_dp + y * (269.2916_dp &
                         + y * (80.39278_dp + y * 10.0_dp)))))
        z6 = 22.03523_dp + y * (55.02933_dp + y * (92.75679_dp + y * (53.59518_dp + y * 10.0_dp)))
        z8 = 1.496460_dp + y * (13.39880_dp + y * 5.0_dp)
        p0 = 153.5168_dp + y * (549.3954_dp + y * (919.4955_dp + y * (946.8970_dp + y * (662.8097_dp &
                         + y * (328.2151_dp + y * (115.3772_dp + y * (27.93941_dp + y * (4.264678_dp &
                         + y * 0.3183291_dp))))))))
        p2 = -34.16955_dp + y * (-1.322256_dp + y * (124.5975_dp + y * (189.7730_dp  + y * (139.4665_dp &
                         + y * (56.81652_dp  + y * (12.79458_dp + y * 1.2733163_dp))))))
        p4 = 2.584042_dp + y * (10.46332_dp + y * (24.01655_dp + y * (29.81482_dp + y * (12.79568_dp &
                         + y * 1.9099744_dp))))
        p6 = -0.07272979_dp + y * (0.9377051_dp + y * (4.266322_dp + y * 1.273316_dp))
        p8 = 0.0005480304_dp + y * 0.3183291_dp
      ENDIF
      d = 1.7724538_dp / (z0 + xq * (z2 + xq * (z4 + xq * (z6 + xq * (z8 + xq)))))
      k(i ) = d * (p0 + xq * (p2 + xq * (p4 + xq * (p6 + xq * p8))))

    ELSE
      ypy0 = y + y0
      ypy0q = ypy0 * ypy0
      k(i) = 0.0_dp
      DO j = 0, 5
        d = x(i) - t(j)
        mq(j) = d * d
        mf(j) = 1.0_dp / (mq(j) + ypy0q)
        xm(j) = mf(j) * d
        ym(j) = mf(j) * ypy0
        d = x(i) + t(j)
        pq(j) = d * d
        pf(j) = 1.0_dp / (pq(j) + ypy0q)
        xp(j) = pf(j) * d
        yp(j) = pf(j) * ypy0
      ENDDO

      IF (abx < xlim4) THEN
        DO j = 0, 5
          k(i) = k(i) + c(j) * (ym(j) + yp(j)) - s(j) * (xm(j) - xp(j))
        ENDDO

      ELSE
        yf = y + y0py0
        DO j = 0, 5
          k(i) = k(i) + (c(j) * (mq(j) * mf(j) - y0 * ym(j)) + s(j) * yf * xm(j)) / (mq(j) + y0q) &
                      + (c(j) * (pq(j) * pf(j) - y0 * yp(j)) - s(j) * yf * xp(j)) / (pq(j) + y0q)
        ENDDO
        k(i) = y * k(i) + EXP(-xq)

      ENDIF
    ENDIF
  ENDDO

END SUBROUTINE HUMLIK

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
SUBROUTINE ORTHOG(n,anu,alpha,beta,a,b)
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

   USE PXDR_FLAGS
   USE PXDR_CONSTANTES

   IMPLICIT NONE

   INTEGER, INTENT (IN)                           :: n
   REAL (KIND=dp), INTENT (IN), DIMENSION (2*n)   :: anu
   REAL (KIND=dp), INTENT (IN), DIMENSION (2*n-1) :: alpha, beta
   REAL (KIND=dp), INTENT (OUT), DIMENSION (n)    :: a, b
   INTEGER, PARAMETER                             :: nmax = 64

   INTEGER k, l
   REAL (KIND=dp), DIMENSION (2*nmax+1,2*nmax+1) :: sig

   DO l = 3, 2*n
      sig(1,l) = 0.0_dp
   ENDDO

   DO l = 2, 2*n+1
      sig(2,l) = anu(l-1)
   ENDDO

   a(1) = alpha(1) + anu(2) / anu(1)
   b(1) = 0.0_dp

   DO k = 3, n+1
      DO l = k, 2*n-k+3
         sig(k,l) = sig(k-1,l+1) + (alpha(l-1) - a(k-2)) * sig(k-1,l) - b(k-2) * sig(k-2,l) &
                  + beta(l-1) * sig(k-1,l-1)
      ENDDO
      a(k-1) = alpha(k-1) + sig(k,k+1) / sig(k,k) - sig(k-1,k) / sig(k-1,k-1)
      b(k-1) = sig(k,k) / sig(k-1,k-1)
   ENDDO

END SUBROUTINE ORTHOG

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

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
SUBROUTINE GAUCOF(n,a,b,amu0,x,w)
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

   USE PXDR_FLAGS
   USE PXDR_CONSTANTES

   IMPLICIT NONE

   INTEGER, INTENT (IN)                          :: n
   REAL (KIND=dp), INTENT (IN)                   :: amu0
   REAL (KIND=dp), INTENT (INOUT), DIMENSION (n) :: a
   REAL (KIND=dp), INTENT (INOUT), DIMENSION (n) :: b
   REAL (KIND=dp), INTENT (OUT), DIMENSION (n)   :: w, x
   INTEGER, PARAMETER                            :: nmax = 64

   INTEGER                                       :: i, j
   REAL (KIND=dp), DIMENSION (nmax,nmax)         :: z

   DO i = 1, n
      IF (i /= 1) b(i) = SQRT(b(i))
      DO j = 1, n
         IF (i == j) THEN
            z(i,j) = 1.0_dp
         ELSE
            z(i,j) = 0.0_dp
         ENDIF
      ENDDO
   ENDDO

   CALL TQLI(a,b,n,nmax,z)
   CALL EIGSRT(a,z,n,nmax)

   DO i = 1, n
      x(i) = a(i)
      w(i) = amu0 * z(1,i)**2
   ENDDO

END SUBROUTINE GAUCOF

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

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
REAL (KIND=dp) FUNCTION PYTHAG(a,b)
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

   USE PXDR_FLAGS
   USE PXDR_CONSTANTES

   IMPLICIT NONE

   REAL (KIND=dp), INTENT (IN) :: a, b
   REAL (KIND=dp)              :: absa, absb

   absa = ABS(a)
   absb = ABS(b)

   IF (absa > absb) THEN
      PYTHAG = absa * SQRT(1.0_dp + (absb/absa)**2)
   ELSE
      IF (absb == 0.0_dp) THEN
         PYTHAG = 0.0_dp
      ELSE
         PYTHAG = absb * SQRT(1.0_dp + (absa/absb)**2)
      ENDIF
   ENDIF

END FUNCTION PYTHAG

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

!%%%%%%%%%%%%%%%%%%%%%%%%%%%
SUBROUTINE TQLI(d,e,n,nnp,z)
!%%%%%%%%%%%%%%%%%%%%%%%%%%%

   USE PXDR_FLAGS
   USE PXDR_CONSTANTES

   IMPLICIT NONE

   INTEGER, INTENT (IN)                              :: n, nnp
   REAL (KIND=dp), INTENT (INOUT), DIMENSION (nnp)   :: d
   REAL (KIND=dp), INTENT (INOUT), DIMENSION (nnp)   :: e
   REAL (KIND=dp), INTENT (OUT), DIMENSION (nnp,nnp) :: z

   INTEGER                             :: i, iter, k, l, m
   REAL (KIND=dp)                      :: b, c, dd, f, g, p, r, s

   DO i = 2, n
      e(i-1) = e(i)
   ENDDO
   e(n) = 0.0_dp

   DO l = 1, n
      iter = 0
 1    continue
      DO m = l, n-1
         dd = ABS(d(m)) + ABS(d(m+1))
         IF (ABS(e(m)) + dd == dd) goto 2
      ENDDO

      m = n

 2    IF (m /= l) THEN
!        IF (iter == 30) STOP '  Too many iterations in TQLI'
         iter = iter + 1
         g = (d(l+1) - d(l)) / (2.0_dp * e(l))
         r = PYTHAG(g,1.0_dp)
         g = d(m) - d(l) + e(l) / (g + sign(r,g))
         s = 1.0_dp
         c = 1.0_dp
         p = 0.0_dp

         DO i = m-1, l, -1
            f = s * e(i)
            b = c * e(i)
            r = PYTHAG(f,g)
            e(i+1) = r
            IF (r == 0.0_dp) THEN
               d(i+1) = d(i+1) - p
               e(m) = 0.0_dp
               goto 1
            ENDIF
            s = f / r
            c = g / r
            g = d(i+1) - p
            r = (d(i) - g) * s + 2.0_dp * c * b
            p = s * r
            d(i+1) = g + p
            g = c * r - b

! ...eigenvectors:
            DO k = 1, n
               f = z(k,i+1)
               z(k,i+1) = s * z(k,i) + c * f
               z(k,i) = c * z(k,i) - s * f
            ENDDO
! ...fin eigenvectors

         ENDDO

         d(l) = d(l) - p
         e(l) = g
         e(m) = 0.0_dp
         goto 1
      ENDIF
   ENDDO

END SUBROUTINE TQLI

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

!%%%%%%%%%%%%%%%%%%%%%%%%%%%
SUBROUTINE EIGSRT(d,v,n,nnp)
!%%%%%%%%%%%%%%%%%%%%%%%%%%%

   USE PXDR_FLAGS
   USE PXDR_CONSTANTES

   IMPLICIT NONE

   INTEGER, INTENT (IN)                                :: n, nnp
   REAL (KIND=dp), INTENT (INOUT), DIMENSION (nnp)     :: d
   REAL (KIND=dp), INTENT (INOUT), DIMENSION (nnp,nnp) :: v

   INTEGER                             :: i, j, k
   REAL (KIND=dp)                      :: p

   DO i = 1, n-1
      k = i
      p = d(i)
      DO j = i+1, n
         IF (d(j) >= p) THEN
            k = j
            p = d(j)
         ENDIF
      ENDDO

      IF (k /= i) THEN
         d(k) = d(i)
         d(i) = p
         DO j = 1, n
            p = v(j,i)
            v(j,i) = v(j,k)
            v(j,k) = p
         ENDDO
      ENDIF
   ENDDO

END SUBROUTINE EIGSRT

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

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
REAL (KIND=dp) FUNCTION EXPBOR(x)
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

   USE PXDR_FLAGS
   USE PXDR_CONSTANTES

   IMPLICIT NONE

   REAL (KIND=dp), INTENT (IN) :: x

   IF (x <= l_ty) THEN
      EXPBOR = 0.0_dp
   ELSE IF (x >= l_hu) THEN
      EXPBOR = EXP(l_hu)
   ELSE
      EXPBOR = EXP(x)
   ENDIF

END FUNCTION EXPBOR

!!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!LOGICAL FUNCTION ISNAN(x)
!!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!   USE PXDR_CONSTANTES
!   REAL (KIND=dp), INTENT (IN) :: x
!   REAL (KIND=dp)              :: y
!   y = x
!   ISNAN = .false.
!   RETURN
!END FUNCTION ISNAN

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

!!!=============================================================
!!! SUBROUTINE INT_STR
!!! Transforme un INTEGER en STRING
!!!=============================================================
SUBROUTINE INT_STR(integ, str_int, nb0)

   USE PXDR_FLAGS
   USE PXDR_CONSTANTES

   IMPLICIT NONE

   INTEGER,                  INTENT(IN)  :: integ
   CHARACTER(len=lenstrint), INTENT(OUT) :: str_int
   INTEGER, OPTIONAL, INTENT(IN)         :: nb0

   CHARACTER(len=80) :: formatwrite

   WRITE(formatwrite,'("(i",I2,")")') lenstrint
   WRITE(str_int,formatwrite) integ

   IF (PRESENT(nb0)) THEN
      str_int = ADJUSTL(str_int)
      DO WHILE (LEN_TRIM(str_int) < nb0)
         str_int = "0"//TRIM(str_int)
      ENDDO
   ENDIF

END SUBROUTINE INT_STR

!!!========================================================================
!!! SUBROUTINE STR_INT
!!! Transforme un STRING en INTEGER
!!!========================================================================
SUBROUTINE STR_INT(str, integ)
IMPLICIT NONE

CHARACTER(len=4), INTENT(IN)   :: str
INTEGER,          INTENT(OUT)  :: integ
CHARACTER(len=4)               :: str_tempo
INTEGER                        :: lenstr
INTEGER                        :: istr
INTEGER                        :: k


  str_tempo = TRIM(ADJUSTL(str))

  lenstr = LEN_TRIM(ADJUSTL(str_tempo))
  IF (lenstr > 4) THEN
     PRINT *,"PROBLEM in STR_INT"
     STOP
  ENDIF

  integ = 0
  DO k = lenstr, 1, -1
     istr = IACHAR(str_tempo(k:k)) - 48
     integ  = integ + istr * 10**(lenstr-k)
  ENDDO

END SUBROUTINE STR_INT

!!!========================================================================
!!! SUBROUTINE SPEMAJ
!!! 1) Transforme le nom d'une espece en minuscule en majuscule
!!! 2) Cree un ID sans caractere particulier
!!! Exemple: Recoit: espece="ca+" renvoie: especeHN="Ca+"    especeID="Cap"
!!!          Recoit: espece="co*" renvoie: especeHN="C_18O"  especeID="C_18O"
!!!========================================================================
SUBROUTINE SPEMAJ(espece, especeID, especeHN)

!TODO : ARRANGER DES CAS PARTICULIERS comme :
!       Moments
!       Electrons a renommer eventuellement mais attention aux effets de bords

IMPLICIT NONE
CHARACTER(len=lenSpeci),      INTENT(IN)    :: espece        ! fortran name
CHARACTER(len=lenSpeciHname), INTENT(OUT)   :: especeHN      ! human readable name
CHARACTER(len=lenSpeciID),    INTENT(OUT)   :: especeID      ! ID

CHARACTER(len=lenSpeciHname)                :: espece_sav
INTEGER                                     :: pos_star      ! position of "*" in the string
INTEGER                                     :: pos_m         ! position of "-" in the string. Used for species as a-c3h4
INTEGER                                     :: length_ini    ! Initial length of the string espece
INTEGER                                     :: length        ! Length of the string to transform, <= length_ini
INTEGER                                     :: i             ! Index in the string of espece

!---------------------------------------------------
! Rappel:
! 41  --- A; 90  --- Z; 97  --- a; 122 --- z
! 43 = +, 45 = -, 35 = #, 58 = :
!---------------------------------------------------

   especeHN = TRIM(ADJUSTL(espece))

   !--- Isotopes: Remove * in c* and o* --------------------------------------------------
   ! At this step, we only manage the * symbol. Transformation from lower case
   ! to upper case is done in the general step.
   pos_star   = INDEX(especeHN,"*")
   length_ini = LEN_TRIM(ADJUSTL(especeHN))
   DO WHILE (pos_star .NE. 0)
      IF (pos_star == 2) THEN      ! The first atom is an isotope
         IF (length_ini > 2) THEN  ! Exemple: c*o, o*o, ...
            especeHN(4:) = especeHN(pos_star+1:)
         ENDIF
         IF (especeHN(pos_star-1:pos_star-1) == "c") THEN
            especeHN(1:3)   = "13c"
         ELSE IF (especeHN(pos_star-1:pos_star-1) == "o") THEN
            especeHN(1:3)   = "18o"
         ENDIF
      ELSE ! the isotope is not the first atom of the molecule name
         especeHN(1:pos_star-2)   = especeHN(1:pos_star-2)
         especeHN(pos_star+3:)    = especeHN(pos_star+1:)

         IF (especeHN(pos_star-1:pos_star-1) == "c") THEN
            especeHN(pos_star-1:pos_star+2)   = "_13c"
         ELSE IF (especeHN(pos_star-1:pos_star-1) == "o") THEN
            especeHN(pos_star-1:pos_star+2) = "_18o"
         ENDIF
      ENDIF
      pos_star = INDEX(especeHN,"*") ! search for the next *
   ENDDO

   !--- Special case -----------------------------------------------------------
   IF (espece .EQ. "        ") THEN
      especeID = "nothing"
      RETURN
   ENDIF

   !--- Create HName (upper case) and ID (lower case) --------------------------
   ! At this step, we create the human readable names and le IDs

   !--- Look for "-" character to determine if the specy name has the syntax a-c3h4
   ! If so, we will only write in upper case the end of the string
   length_ini = LEN_TRIM(ADJUSTL(especeHN))    ! Initial length of the string
   pos_m = INDEX(especeHN,"-")                 ! Position of the "-" sign

   IF ((pos_m .NE. 0) .AND. (pos_m < length_ini)) THEN
      ! Species is of type a-c3h4
      espece_sav = especeHN                           ! Save the name of the species
      especeHN   = TRIM(ADJUSTL(especeHN(pos_m+1:)))  ! Get the part to transform
   ENDIF

   length = LEN_TRIM(ADJUSTL(especeHN))               ! New length of the string

   especeID = especeHN
   DO i = 1, length
      IF (     (IACHAR(especeHN(i:i)) .GE. 97)  &
         .AND. (IACHAR(especeHN(i:i)) .LE. 122) &
         .AND. (especeHN(i:i)   .NE. "e")       &
         .AND. (especeHN(i:i)   .NE. "g")       &
         .AND. (especeHN(i:i)   .NE. "r")       &
         .AND. (especeHN(i:i)   .NE. "l")       &
         .AND. (especeHN(i:i)   .NE. "i")       &
         ) THEN
         especeHN(i:i) = ACHAR(IACHAR(especeHN(i:i)) - 32 ) ! Transform to upper case
      ELSE IF (especeHN(i:i) .EQ. "+") THEN
         especeID(i:i) = "p"
      ELSE IF (especeHN(i:i) .EQ. "-") THEN
         especeID(i:i) = "m"
      ELSE IF (especeHN(i:i) .EQ. "#") THEN
         especeID(i:i) = "_"
      ELSE IF (especeHN(i:i) .EQ. ":") THEN
         especeID(i:i) = "a"
      ENDIF
   ENDDO

   ! If required add the prefix (a- for example) to species names
   IF ((pos_m .NE. 0) .AND. (pos_m < length_ini)) THEN
      especeHN = TRIM(ADJUSTL(espece_sav(1:pos_m)))//TRIM(ADJUSTL(especeHN))
      especeID = TRIM(ADJUSTL(espece_sav(1:pos_m-1)))//"_"//TRIM(ADJUSTL(especeID))
   ENDIF

   ! PRINT *,espece,"  ",especeHN,"  ",especeID

END SUBROUTINE SPEMAJ

!!!========================================================================
!!! SUBROUTINE MAKE_NAMEMOMENTS
!!! Transform a fortran name for moments to human name and ID
!!!========================================================================
SUBROUTINE MAKE_NAMEMOMENTS(fortranname, namemom, idmom)
IMPLICIT NONE

CHARACTER(len=lenSpeci),      INTENT(IN)  :: fortranname  ! Fortran name
CHARACTER(len=lenSpeciHname), INTENT(OUT) :: namemom      ! Human readable name
CHARACTER(len=lenSpeciID),    INTENT(OUT) :: idmom        ! ID

INTEGER                         :: iii
INTEGER                         :: length    ! Longeur de la chaine fortran
INTEGER                         :: lengthesp ! Longeur de la chaine definissant l'espece
CHARACTER(len=2)                :: esp       ! Nom de l'espece
CHARACTER(len=2)                :: espmaj    ! Nom de l'espece en majuscule
CHARACTER(len=2)                :: bingr     ! Numero du bin de grains

! Noms fortran : moh:01, moh2:01

   length     = LEN_TRIM(ADJUSTL(fortranname))
   bingr(1:2) = fortranname(length-1:length)
   esp        = TRIM(ADJUSTL(fortranname(3:length-2)))
   lengthesp  = LEN_TRIM(esp)
   DO iii = 1, lengthesp
      IF (     (IACHAR(esp(iii:iii)) .GE. 97)  &
         .AND. (IACHAR(esp(iii:iii)) .LE. 122) &
         .AND. (esp(iii:iii) .NE. "e")         &
         .AND. (esp(iii:iii) .NE. "g")         &
         .AND. (esp(iii:iii) .NE. "a")         &
         .AND. (esp(iii:iii) .NE. "l")         &
         .AND. (esp(iii:iii) .NE. "i")         ) THEN
         espmaj(iii:iii) = ACHAR(IACHAR(esp(iii:iii)) - 32 )
      ELSE
         espmaj(iii:iii) = esp(iii:iii)
      ENDIF
   ENDDO

   namemom    = "&lt;"//TRIM(ADJUSTL(espmaj))//"&gt;_"//bingr(1:2)
!  namemom    =  TRIM(ADJUSTL(espmaj))//"_"//bingr(1:2)
   idmom      = "MOM_"//TRIM(ADJUSTL(espmaj))//"_R"//bingr(1:2)

END SUBROUTINE MAKE_NAMEMOMENTS

!!!========================================================================
!!! SUBROUTINE LOC_IND
!!! Locate index of positions in a vector bracketting a specific value
!!! ii is a first "trial value": x is supposed to be above y(ii)
!!! If x = y(n), then ii = n, so that the interpolation algorithm
!!! must be able to deal with a right boundary too.
!!!========================================================================
SUBROUTINE LOC_IND (ii, i0, n, x, y)

   USE PXDR_FLAGS
   USE PXDR_CONSTANTES

   IMPLICIT NONE

   INTEGER, INTENT (INOUT)                      :: ii
   INTEGER, INTENT (IN)                         :: i0, n
   REAL (KIND=dp), INTENT (IN)                  :: x
   REAL (KIND=dp), DIMENSION(i0:n), INTENT (IN) :: y

   INTEGER                                      :: i

   ! If the trial index is too high, start from scratch
   IF (x < y(ii)) THEN
      ii = i0
   ELSE IF (x > y(n)) THEN
      PRINT *, " Error: x must be smaller than:", n, x, y(n)
      STOP
   ENDIF

   DO i = ii, n
      IF (x < y(i)) THEN
         EXIT
      ENDIF
   ENDDO
   ii = i - 1
   IF (ii == n) THEN
      ii = ii - 1
   ENDIF

END SUBROUTINE LOC_IND

!!!========================================================================
!!! SUBROUTINE INTERP_BILIN
!!! Perform a bilinear interpolation of function f at position (x, y)
!!! x (resp. y) can not be larger than vx(nx) (resp. vy(ny))
!!! Tuned for x: a wavelength (index nx0 to nx)
!!!           y: a optical depth (index ny0 to ny)
!!!========================================================================
SUBROUTINE INTERP_BILIN (x, y, ix, iy, vx, nx0, nx, vy, ny0, ny, f, fe)

   USE PXDR_FLAGS
   USE PXDR_CONSTANTES

   IMPLICIT NONE

   REAL (KIND=dp), INTENT (IN)                    :: x, y
   INTEGER, INTENT (INOUT)                        :: ix, iy
   INTEGER, INTENT (IN)                           :: nx0, ny0
   INTEGER, INTENT (IN)                           :: nx, ny
   REAL (KIND=dp), DIMENSION(nx0:nx), INTENT (IN) :: vx
   REAL (KIND=dp), DIMENSION(ny0:ny), INTENT (IN) :: vy
   TYPE (DU_DIST), INTENT (IN)                    :: f
   REAL (KIND=dp), DIMENSION(5), INTENT (OUT)     :: fe

   REAL (KIND=dp)                                 :: ff1, ff2, ff3, ff4
   REAL (KIND=dp)                                 :: denom

   ! Find position of point (x, y)
   CALL LOC_IND (ix, nx0, nx, x, vx)
   CALL LOC_IND (iy, ny0, ny, y, vy)

   denom = (vx(ix+1) - vx(ix)) * (vy(iy+1) - vy(iy))
   ff1   = (vx(ix+1) - x     ) * (vy(iy+1) - y     ) / denom
   ff2   = (x        - vx(ix)) * (vy(iy+1) - y     ) / denom
   ff3   = (vx(ix+1) - x     ) * (y        - vy(iy)) / denom
   ff4   = (x        - vx(ix)) * (y        - vy(iy)) / denom

   fe(1) = f%abso(ix) * ff1 + f%abso(ix+1) * ff2 + f%abso(ix) * ff3 + f%abso(ix+1) * ff4
   fe(2) = f%scat(ix) * ff1 + f%scat(ix+1) * ff2 + f%scat(ix) * ff3 + f%scat(ix+1) * ff4
   fe(3) = f%emis(ix,iy) * ff1 + f%emis(ix+1,iy) * ff2 + f%emis(ix,iy+1) * ff3 + f%emis(ix+1,iy+1) * ff4
   fe(4) = f%albe(ix) * ff1 + f%albe(ix+1) * ff2 + f%albe(ix) * ff3 + f%albe(ix+1) * ff4
   fe(5) = f%gcos(ix) * ff1 + f%gcos(ix+1) * ff2 + f%gcos(ix) * ff3 + f%gcos(ix+1) * ff4

END SUBROUTINE INTERP_BILIN

!!!========================================================================
!!! SUBROUTINE INTERP_BILIN_GEN
!!! Perform a bilinear interpolation of function f at position (x, y)
!!! x (resp. y) can not be larger than vx(nx) (resp. vy(ny))
!!! Tuned for x: a wavelength (index 0 to nx)
!!!           y: a optical depth (index 1 to ny)
!!! This is a more general function than the previous one
!!!========================================================================
SUBROUTINE INTERP_BILIN_GEN (x, y, ix, iy, vx, nx0, nx, vy, ny0, ny, f, fe)

   IMPLICIT NONE

   REAL (KIND=dp),                           INTENT (IN)    :: x, y
   INTEGER,                                  INTENT (INOUT) :: ix, iy
   INTEGER,                                  INTENT (IN)    :: nx0, ny0
   INTEGER,                                  INTENT (IN)    :: nx, ny
   REAL (KIND=dp), DIMENSION(nx0:nx),        INTENT (IN)    :: vx
   REAL (KIND=dp), DIMENSION(ny0:ny),        INTENT (IN)    :: vy
   REAL (KIND=dp), DIMENSION(nx0:nx,ny0:ny), INTENT (IN)    :: f
   REAL (KIND=dp),                           INTENT (OUT)   :: fe

   REAL (KIND=dp)                                           :: ff1, ff2, ff3, ff4
   REAL (KIND=dp)                                           :: denom

   ! Find position of point (x, y)
   CALL LOC_IND (ix, nx0, nx, x, vx)
   CALL LOC_IND (iy, ny0, ny, y, vy)

   denom = (vx(ix+1) - vx(ix)) * (vy(iy+1) - vy(iy))
   ff1   = (vx(ix+1) - x     ) * (vy(iy+1) - y     ) / denom
   ff2   = (x        - vx(ix)) * (vy(iy+1) - y     ) / denom
   ff3   = (vx(ix+1) - x     ) * (y        - vy(iy)) / denom
   ff4   = (x        - vx(ix)) * (y        - vy(iy)) / denom

   fe = f(ix,iy) * ff1 + f(ix+1,iy) * ff2 + f(ix,iy+1) * ff3 + f(ix+1,iy+1) * ff4
END SUBROUTINE INTERP_BILIN_GEN

!!!=======================================
!!! Sorting routine from Numerical Recipes
!!!=======================================
   SUBROUTINE SORT(arr)

   USE PXDR_FLAGS
   USE PXDR_CONSTANTES
   IMPLICIT NONE

   REAL(KIND=dp), DIMENSION(:), INTENT(INOUT) :: arr
   INTEGER, PARAMETER                         :: NN = 15, NSTACK = 50
   REAL(KIND=dp)                              :: a
   INTEGER                                    :: n, k, i, j, jstack, l, r
   INTEGER, DIMENSION(NSTACK)                 :: istack

   n = SIZE(arr)
   jstack = 0
   l = 1
   r = n
   DO
      IF (r-l < NN) THEN
         DO j = l+1, r
            a = arr(j)
            DO i = j-1, l, -1
               IF (arr(i) <= a) EXIT
               arr(i+1) = arr(i)
            ENDDO
            arr(i+1) = a
         ENDDO
         IF (jstack == 0) RETURN
         r = istack(jstack)
         l = istack(jstack-1)
         jstack = jstack - 2
      ELSE
         k = (l + r) / 2
         CALL SWAP_R(arr(k),arr(l+1))
         CALL M_SWAP_R(arr(l),arr(r),arr(l)>arr(r))
         CALL M_SWAP_R(arr(l+1),arr(r),arr(l+1)>arr(r))
         CALL M_SWAP_R(arr(l),arr(l+1),arr(l)>arr(l+1))
         i = l + 1
         j = r
         a = arr(l+1)
         DO
            DO
               i = i+1
               IF (arr(i) >= a) EXIT
            ENDDO
            DO
               j = j - 1
               IF (arr(j) <= a) EXIT
            ENDDO
            IF (j < i) EXIT
            CALL SWAP_R(arr(i),arr(j))
         ENDDO
         arr(l+1) = arr(j)
         arr(j) = a
         jstack=jstack+2
         IF (jstack > NSTACK) PRINT *, 'SORT: NSTACK too small'
         IF (r-i+1 >= j-l) THEN
            istack(jstack) = r
            istack(jstack-1) = i
            r = j - 1
         ELSE
            istack(jstack) = j - 1
            istack(jstack-1) = l
            l = i
         ENDIF
      ENDIF
   ENDDO
   END SUBROUTINE SORT

!!!=======================================
!!! Sorting routine from Numerical Recipes
!!!=======================================
   SUBROUTINE M_SWAP_R(a,b,mask)

   USE PXDR_FLAGS
   USE PXDR_CONSTANTES

   IMPLICIT NONE

   REAL(KIND=dp), INTENT(INOUT) :: a,b
   LOGICAL, INTENT(IN) :: mask
   REAL(KIND=dp) :: swp
   IF (mask) THEN
      swp = a
      a = b
      b = swp
   ENDIF
   END SUBROUTINE M_SWAP_R

!!!=======================================
!!! Sorting routine from Numerical Recipes
!!!=======================================
   SUBROUTINE SWAP_R(a,b)

   USE PXDR_FLAGS
   USE PXDR_CONSTANTES

   IMPLICIT NONE

   REAL(KIND=dp), INTENT(INOUT) :: a,b
   REAL(KIND=dp) :: dum
   dum = a
   a = b
   b = dum
   END SUBROUTINE SWAP_R

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
SUBROUTINE SIMPINT(x, y, ilmin, ilmax, som)
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

!  Compute the sum of y over x by Simpson rule
!  with uneven spacing of the x's

!  Formula established by Pierre Hily-Blant - 8 Sept 2003

   USE PXDR_FLAGS
   USE PXDR_CONSTANTES
   IMPLICIT NONE

   INTEGER, INTENT (IN)                                :: ilmin, ilmax
   REAL (KIND=dp), INTENT (IN), DIMENSION(ilmin:ilmax) :: x, y
   REAL (KIND=dp), INTENT (OUT)                        :: som
   INTEGER                                             :: i
   REAL (KIND=dp)                                      :: x1, x2, x3, y1, y2, y3
   REAL (KIND=dp)                                      :: aux1
   REAL (KIND=dp)                                      :: t1, t2, t3
   REAL (KIND=dp)                                      :: a31, a12, a23

   som = 0.0_dp
   x3 = x(ilmin)
   y3 = y(ilmin)
   DO i = ilmin+1, ilmax-1, 2
      x1 = x3
      x2 = x(i)
      x3 = x(i+1)
      y1 = y3
      y2 = y(i)
      y3 = y(i+1)

      a12 = x1 - x2
      a23 = x2 - x3
      a31 = x3 - x1

      aux1 = a12*a12 + a23*a23 + x2 * (x2-x1-x3) + x1*x3
      t1 = -y1 * (3.0_dp * a12*a12 - aux1) / (6.0_dp * a12)
      t2 =  y2 * a31*a31*a31 / (6.0_dp * a12 * a23)
      t3 = -y3 * (3.0_dp * a23*a23 - aux1) / (6.0_dp * a23)

      som = som + t1 + t2 + t3
   ENDDO

   ! JLB - 8 II 2012 - Correct a bug for odd value of n
   IF (MOD(ilmax-ilmin,2) == 0) THEN
      som = som + 0.5_dp * (y(ilmax-1) + y(ilmax)) * (x(ilmax) - x(ilmax-1))
   ENDIF

   ! JLB - 8 II 2012: divide by sqrt(pi) outside this routine to get a general purpose one
   ! som = som / SQRT(xpi)

END SUBROUTINE SIMPINT

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
SUBROUTINE TRAPINT(x, y, ilmin, ilmax, som)
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

!  Compute the sum of y over x by Trapezoidal rule
!  with uneven spacing of the x's

   USE PXDR_FLAGS
   USE PXDR_CONSTANTES
   IMPLICIT NONE

   INTEGER, INTENT (IN)                                :: ilmin, ilmax
   REAL (KIND=dp), INTENT (IN), DIMENSION(ilmin:ilmax) :: x, y
   REAL (KIND=dp), INTENT (OUT)                        :: som
   INTEGER                                             :: i

   som = y(ilmin) * (x(ilmin+1) - x(ilmin))
   DO i = ilmin+1, ilmax-1
      som = som + y(i) * (x(i+1) - x(i-1))
   ENDDO
   som = som + y(ilmax) * (x(ilmax) - x(ilmax-1))
   som = 0.5_dp * som

END SUBROUTINE TRAPINT

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

 FUNCTION LOCASE(string) RESULT(lowwer)
  CHARACTER(LEN=*), INTENT(IN) :: string
  CHARACTER(LEN=LEN(string))   :: lowwer
  INTEGER                      :: j

  DO j = 1,LEN(string)
     IF(string(j:j) >= "A" .AND. string(j:j) <= "Z") THEN
        lowwer(j:j) = ACHAR(IACHAR(string(j:j)) + 32)
     ELSE
        lowwer(j:j) = string(j:j)
     ENDIF
  ENDDO
 END FUNCTION LOCASE

subroutine e1xa ( x, e1 )

!*****************************************************************************80
!
!! E1XA computes the exponential integral E1(x).
!
!  Licensing:
!
!    This routine is copyrighted by Shanjie Zhang and Jianming Jin.  However,
!    they give permission to incorporate this routine into a user program
!    provided that the copyright is acknowledged.
!
!  Modified:
!
!    06 July 2012
!
!  Author:
!
!    Shanjie Zhang, Jianming Jin
!
!  Reference:
!
!    Shanjie Zhang, Jianming Jin,
!    Computation of Special Functions,
!    Wiley, 1996,
!    ISBN: 0-471-11963-6,
!    LC: QA351.C45.
!
!  Parameters:
!
!    Input, REAL (KIND=dp) X, the argument.
!
!    Output, REAL (KIND=dp) E1, the function value.
!
  USE PXDR_CONSTANTES

  IMPLICIT NONE

  REAL (KIND=dp), INTENT (IN)  ::  x
  REAL (KIND=dp), INTENT (OUT) :: e1
  REAL (KIND=dp) es1
  REAL (KIND=dp) es2

! Modified with "saturation" by JLB - 29 VIII 2012

  IF (x <= 3.0e-04_dp) THEN

    e1 = 7.5348123959080402_dp

  ELSE IF (x <= 1.0_dp) THEN

    e1 = - LOG(x) + (((( &
        1.07857e-03_dp * x &
      - 9.76004e-03_dp) * x &
      + 5.519968e-02_dp) * x &
      - 0.24991055_dp) * x &
      + 0.99999193_dp) * x &
      - 0.57721566_dp

  ELSE

    es1 = ((( x &
      + 8.5733287401_dp) * x &
      + 18.059016973_dp) * x &
      + 8.6347608925_dp) * x &
      + 0.2677737343_dp

    es2 = ((( x &
      +  9.5733223454_dp) * x &
      + 25.6329561486_dp) * x &
      + 21.0996530827_dp) * x &
      +  3.9584969228_dp

    e1 = EXP(-x) / x * es1 / es2

  ENDIF

END SUBROUTINE e1xa

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
SUBROUTINE LINEARFIT(N, x, y, x0, a, b)
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!  Compute the linear fit of y as function of x
!  over all points x > x0
   IMPLICIT NONE
   INTEGER, INTENT (IN)                     :: N
   REAL(KIND=dp), INTENT (IN), DIMENSION(N) :: x, y
   REAL(KIND=dp), INTENT (IN)               :: x0
   REAL(KIND=dp), INTENT (OUT)              :: a, b
   REAL(KIND=dp)                            :: xm,ym,xym,x2m
   INTEGER                                  :: i, nb
   nb  = 0
   xm  = 0.0_dp
   ym  = 0.0_dp
   xym = 0.0_dp
   x2m = 0.0_dp
   DO i = 1, N
      IF(x(i) < x0) CYCLE
      nb  = nb+1
      xm  = xm  + x(i)
      ym  = ym  + y(i)
      xym = xym + x(i)*y(i)
      x2m = x2m + x(i)*x(i)
   ENDDO
   xm  = xm  / DBLE(nb)
   ym  = ym  / DBLE(nb)
   xym = xym / DBLE(nb)
   x2m = x2m / DBLE(nb)
   b = (xym-xm*ym)/(x2m-xm*xm)
   a = ym - b*xm
END SUBROUTINE LINEARFIT

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
REAL (KIND=dp) FUNCTION gammln(xx)
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
   ! Returns the value ln[Γ(xx)] for xx > 0, where Γ is the Euler Γ function.
   IMPLICIT NONE
   REAL (KIND=dp), INTENT(in)   :: xx
   INTEGER                      :: j
   REAL (KIND=dp)               :: ser,stp,tmp,x,y
   REAL (KIND=dp), DIMENSION(6) :: cof(6)
   cof(1) = 76.1800917294714600e+0_dp
   cof(2) =-86.5053203294167700e+0_dp
   cof(3) = 24.0140982408309100e+0_dp
   cof(4) = -1.2317395724501550e+0_dp
   cof(5) =  0.1208650973866179e-2_dp
   cof(6) = -0.5395239384953000e-5_dp
   stp    =  2.5066282746310005e+0_dp
   x = xx
   y = x
   tmp = x + 5.5e+0_dp
   tmp = (x + 0.5e+0_dp)*log(tmp)-tmp
   ser = 1.000000000190015e+0_dp
   DO j=1,6
      y   = y + 1.e+0_dp
      ser = ser + cof(j) / y
   ENDDO
   gammln = tmp + log(stp * ser / x)
END FUNCTION gammln

! Computes the intergral of an analytical function between a and b
! by Romberg algorithm (fast and accurate)
REAL (KIND=dp) FUNCTION ROMBERG (a, b, eps, fp)

   USE PXDR_CONSTANTES
   IMPLICIT NONE

   REAL (KIND=dp), INTENT (IN)      :: a, b        ! Lower and upper bounds
   REAL (KIND=dp), INTENT (IN)      :: eps         ! Required precision

   REAL (KIND=dp)                   :: iab         ! Result
   REAL (KIND=dp)                   :: o_iab       ! Previous approximation
   REAL (KIND=dp)                   :: h           ! Integration step
   INTEGER                          :: nct         ! Number of iteratin steps
   INTEGER, PARAMETER               :: nmax = 20   ! Max number of iterations
   INTEGER                          :: i, inn
   REAL (KIND=dp)                   :: x
   REAL (KIND=dp)                   :: trp1, trp2
   REAL (KIND=dp)                   :: fact
   REAL (KIND=dp), DIMENSION (nmax) :: rmb1, rmb2
   EXTERNAL                         :: fp          ! Function to integrate
   REAL (KIND=dp)                   :: fp

!  PRINT *, " Entering ROMBERG with", a, b, eps
   nct = 0
   h = b - a
   iab = 0.5_dp * (fp(a) + fp(b)) * h
!  PRINT *, fp(a), fp(b)
   trp1 = iab
   rmb1(1) = trp1
   o_iab = 0.5_dp * iab
   inn = 1
   DO
      IF (ABS((iab-o_iab)/(iab+o_iab)) < eps .OR. (nct > nmax)) EXIT
      nct = nct + 1
      h = 0.5_dp * h
      trp2 = 0.0_dp
      DO i = 1, inn
         x = a + DBLE(2*i-1) * h
         trp2 = trp2 + fp(x)
      ENDDO
      inn = 2 * inn
      trp2 = 0.5_dp * trp1 + h * trp2
      rmb2(1) = trp2

      fact = 1.0
      DO i = 2, nct+1
         fact = fact * 4.0_dp
         rmb2(i) = (fact * rmb2(i-1) - rmb1(i-1)) / (fact - 1.0_dp)
      ENDDO

      o_iab = iab
      iab = rmb2(nct+1)
!     PRINT *, nct, iab, o_iab

      DO i = 1, nct+1
         rmb1(i) = rmb2(i)
      ENDDO
      trp1 = trp2
   ENDDO

!  IF (nct > nmax) THEN
!     PRINT *, " Romberg failed to converge"
!     PRINT *, " o_iab = ", o_iab
!     PRINT *, "   iab = ", iab
!  ELSE
!     PRINT *, " nct = ", nct, " b = ", b, " iab = ", iab
!  ENDIF
   ROMBERG = iab

END FUNCTION ROMBERG

END MODULE PXDR_AUXILIAR

