
! Copyright (C) 2002 - Observatoire de Paris/Meudon
!                      Universite Paris 7
!                      CNRS (France)
!                      Contact : Jacques.Lebourlot@obspm.fr
!
! This program is free software; you can redistribute it and/or
! modify it under the terms of the GNU General Public License version 2
! as published by the Free Software Foundation.
!
! This program is distributed in the hope that it will be useful,
! but WITHOUT ANY WARRANTY; without even the implied warranty of
! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
! GNU General Public License for more details.
!
! You should have received a copy of the GNU General Public License
! along with this program; if not, write to the Free Software
! Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.

! JLB - 23 May 2008
! Last modif. 2011-03-25 by Julien Montillaud

MODULE PREP_SPHERE

  USE PXDR_CONSTANTES

  PRIVATE

  ! Variables defining the sphere geometry
  REAL (KIND=dp)    :: r_sph, r_max
  REAL (KIND=dp)    :: x_imp, r_imp
  INTEGER           :: i_sph, i_imp
  INTEGER           :: F_FULL_DET
  ! rx is used to compute the distance along the ray.
  !  WARNING: that distance is rx(i_imp) - rx(i)
  !  However, we avoid substracting twice the constant for computing ds
  REAL (KIND=dp), ALLOCATABLE, DIMENSION (:) :: rx

  PUBLIC :: SPHERE

CONTAINS

!%%%%%%%%%%%%%%%%
SUBROUTINE SPHERE
!%%%%%%%%%%%%%%%%

   USE PXDR_FLAGS
   USE PXDR_CONSTANTES
   USE PXDR_CHEM_DATA
   USE PXDR_PROFIL
   USE PXDR_AUXILIAR
   USE PREP_VAR
   USE PREP_EXCIT
   USE PREP_EMISSI

   IMPLICIT NONE

   CHARACTER (LEN=lenSpeci) :: yspec

   INTEGER           :: i, j, k, jj
   INTEGER           :: ind_sp, inqn
   INTEGER           :: ii2, ii3, ii4, ii5

   ! Single ray variables
   REAL (KIND=dp)    :: cd_sph

   ! Full cloud variables
   INTEGER, PARAMETER                           :: npcol = 250
   INTEGER                                      :: ny
   REAL (KIND=dp), ALLOCATABLE, DIMENSION (:,:) :: ysphr
   CHARACTER (LEN=12), DIMENSION (npcol)        :: sph_head

   ! Emission line variables
   INTEGER                                      :: ii
   INTEGER                                      :: iupl, jlol
   CHARACTER (LEN=17)                           :: tampon
   REAL (KIND=dp)                               :: emisl, Int_m, rad_t

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

   PRINT *, " "
   PRINT *, "  Pseudo-Spherical cloud Module"
   r_max = d_cm(npo/2)
   PRINT *, "  Initial cloud size up to center is:"
   WRITE (6,'(1p,"  R_max =",e10.2," cm (=",e10.2," pc)")') &
         r_max, r_max / pccm

   DO
      PRINT *, "  Enter sphere radius (as a fraction of R_max)"
      READ *, r_sph
      IF (r_sph < 0.0_dp) THEN
         PRINT *, "  Radius should be between larger than 0 "
      ELSE
         IF (irec == 1) THEN
            WRITE (8,*) r_sph
         ENDIF
         WRITE (6, '(1p,"  R_sph =",e10.2," (=",e10.2," pc)")') r_sph, r_sph * r_max / pccm
         r_sph = r_sph * r_max
         EXIT
      ENDIF
   ENDDO

   IF (r_sph<r_max) THEN
      ! Search indices
      DO i = 0, npo/2
         IF (d_cm(i) >= r_sph) THEN
            i_sph = i
            EXIT
         ENDIF
      ENDDO
      r_sph = d_cm(i_sph)
      PRINT *, "  Center of sphere at index:", i_sph
      PRINT *, "  Radius corrected to:", r_sph / pccm, " pc"
   ELSE
      i_sph = npo/2
   ENDIF

   PRINT *, "  Do you want a single radius or the whole cloud?"
   PRINT *, "     1: single radius"
   PRINT *, "     2: whole cloud"
   READ *, ii5
   IF (irec == 1) THEN
      WRITE (8,*) ii5
   ENDIF

  IF (ii5 == 1) THEN
      DO
         IF (r_sph < r_max) THEN
            PRINT *, "  Enter impact parameter (0: grazing, to 1: thru center)"
         ELSE
            PRINT *, "  Enter impact parameter (0: grazing surface, to 1: max depth)"
         ENDIF
         READ *, x_imp
         IF (x_imp < 0.0_dp .OR. x_imp > 1.0) THEN
            PRINT *, "  Impact parameter should be between 0 and 1"
         ELSE
            IF (irec == 1) THEN
               WRITE (8,*) x_imp
            ENDIF
            r_imp = x_imp * MIN(r_sph,r_max)
            EXIT
         ENDIF
      ENDDO

      ! Search indices
      DO i = 0, npo/2
         IF (d_cm(i) >= r_imp) THEN
            i_imp = i
            EXIT
         ENDIF
      ENDDO
      r_imp = d_cm(i_imp)
      x_imp = r_imp / r_sph
      PRINT *, "  Maximum depth at index:", i_imp
      WRITE (6, '(1p,"  X_imp =",e10.2," (",e10.2," pc)")') x_imp, r_imp / pccm
      ALLOCATE (rx(0:i_imp))
      DO i = 0, i_imp
         rx(i) = SQRT((2.0_dp*r_sph - (r_imp + d_cm(i))) * (r_imp - d_cm(i)))
      ENDDO

      PRINT *, " "
      PRINT *, "  Compute column densities"
      DO
         PRINT *, '   Which column density? (end: -1)'
         READ (*,'(a8)') yspec
         IF (irec == 1) THEN
            WRITE (8,'(a8)') yspec
         ENDIF

         IF (yspec == '-1') THEN
            EXIT
         ENDIF

         ii2 = 0
         DO jj = 1, n_var
            IF (speci(jj) == yspec) THEN
               ii2 = jj
               EXIT
            ENDIF
         ENDDO

         IF (ii2 == 0) THEN
            PRINT *, "  WARNING:", yspec, " is not in species list"
            CYCLE
         ELSE
            PRINT *, "  Computing CD of:", yspec, ", ii2 =", ii2
         ENDIF

         cd_sph = 0.0_dp
         DO i = 0, i_imp-1
            cd_sph = cd_sph + (abnua(ii2,i) + abnua(ii2,i+1)) * (rx(i) - rx(i+1))
         ENDDO
         WRITE (6, '(1p,"  CD of ",a8,": ",e10.2," cm-2")') yspec, cd_sph

         IF (in_sp(ii2) /= 0) THEN
            ind_sp = in_sp(ii2)
            PRINT *, " Relative populations? (1: yes, 0: no)"
            READ  *,ii4
            IF (irec == 1) THEN
               WRITE (8,*) ii4
            ENDIF

            IF (ii4 == 1) THEN
               jj = spec_lin(ind_sp)%nlv
               PRINT *, "  Num:    ", (spec_lin(ind_sp)%qnam(k), k=1,spec_lin(ind_sp)%nqn)
               DO i = 1, 1+jj/10
                  DO j = 1+10*(i-1), MIN(jj,10*i)
                     WRITE (6,'(2x,i3," :")',ADVANCE="NO") j
                     inqn = 0
                     DO k = 1, spec_lin(ind_sp)%nqn
                        inqn = inqn + 1
                        WRITE (6,"(2x,a3)",ADVANCE="NO") spec_lin(ind_sp)%quant(j,inqn)
                     ENDDO
                     WRITE (6,*)
                  ENDDO
                  PRINT *, "  More? (yes: -1)"
                  READ *, j
                  IF (irec == 1) THEN
                     WRITE (8,*) j
                  ENDIF
                  IF (j /= -1) EXIT
               ENDDO
               ii3 = 999
               DO WHILE (ii3 /= 0)
                  PRINT *
                  PRINT *, '    level number (end: 0)'
                  READ *, ii3
                  IF (ii3 > spec_lin(ind_sp)%use) THEN
                     ii3 = 0
                  ENDIF
                  IF (irec == 1) THEN
                     WRITE (8,*) ii3
                  ENDIF
                  IF (ii3 /=  0) THEN
                     cd_sph = 0.0_dp
                     DO i = 0, i_imp-1
                        cd_sph = cd_sph + (rx(i) - rx(i+1)) &
                               * (abnua(ii2,i) * spec_lin(ind_sp)%xre(ii3,i) &
                               + abnua(ii2,i+1) * spec_lin(ind_sp)%xre(ii3,i+1))
                     ENDDO
                     WRITE (6, '(1p,"  CD of ",a8,", level: ",i5,": ",e10.2," cm-2")') yspec, ii3, cd_sph
                  ENDIF
               ENDDO
            ENDIF
         ENDIF

         ! It is easier to have a second block for line intensities (with same IF)
         IF (in_sp(ii2) /= 0) THEN
            ind_sp = in_sp(ii2)
            PRINT *, " Integrated line intensities? (1: yes, 0: no)"
            READ  *,ii4
            IF (irec == 1) THEN
               WRITE (8,*) ii4
            ENDIF
            F_FULL_DET = 1

            IF (ii4 == 1) THEN
               fichier = TRIM(out_dir)//TRIM(modele)//'_'//TRIM(yspec)//'_lin.sph'
               OPEN (35, FILE=fichier, STATUS="unknown")
               ii = 999
               PRINT *, ' Emission lines of: ', yspec
               CALL VIEW_LINES(spec_lin(ind_sp), irec)
               DO WHILE (ii /= 0)
                  PRINT *, 'Transition?  (0: end)'
                  READ *, ii
                  IF (ii > spec_lin(ind_sp)%ntr) THEN
                     ii = 0
                  ENDIF
                  IF (irec == 1) THEN
                     WRITE (8,*) ii
                  ENDIF

                  IF (ii /= 0) THEN
                     iupl = spec_lin(ind_sp)%iup(ii)
                     jlol = spec_lin(ind_sp)%jlo(ii)
                     tampon = 'Emis.'//TRIM(spec_lin(ind_sp)%nam)//'.'
                     tampon = TRIM(ADJUSTL(tampon))//TRIM(ADJUSTL(ii2c(iupl)))//'->'//TRIM(ADJUSTL(ii2c(jlol)))
                     CALL LDVSph(spec_lin(ind_sp), ii, tampon, emisl)
                  ENDIF

               ENDDO
               CLOSE (35)
            ENDIF
         ENDIF
      ENDDO
      DEALLOCATE (rx)

  ELSE IF (ii5 == 2) THEN

      PRINT *, " "
      PRINT *, "  Compute column densities"
      DO
         PRINT *, '   Which column density? (end: -1)'
         READ (*,'(a8)') yspec
         IF (irec == 1) THEN
            WRITE (8,'(a8)') yspec
         ENDIF

         IF (yspec == '-1') THEN
            EXIT
         ENDIF

         ii2 = 0
         DO jj = 1, n_var
            IF (speci(jj) == yspec) THEN
               ii2 = jj
               EXIT
            ENDIF
         ENDDO

         IF (ii2 == 0) THEN
            PRINT *, "  WARNING:", yspec, " is not in species list"
            CYCLE
         ELSE
            PRINT *, "  Computing CD of:", yspec, ", ii2 =", ii2
         ENDIF

         ALLOCATE (ysphr(0:i_sph,npcol))
         ysphr(:,:) = 0.0_dp
         fichier = TRIM(out_dir)//TRIM(modele)//'_'//TRIM(yspec)//'.sph'
         OPEN (53, FILE=fichier, STATUS="unknown")
         WRITE (53,'("# Radius:",1p,e12.3,", Nb Pts:",i5)') r_sph, i_sph

         ysphr(:,1) = d_cm(0:i_sph)
         sph_head(1) = "Dist_cm"

         ny = 2
         sph_head(2) = "CD."//TRIM(yspec)
         DO i_imp = 1, i_sph
            r_imp = d_cm(i_imp)
            cd_sph = 0.0_dp
            ALLOCATE (rx(0:i_imp))
            DO i = 0, i_imp
               rx(i) = SQRT((2.0_dp*r_sph - (r_imp + d_cm(i))) * (r_imp - d_cm(i)))
            ENDDO
            DO i = 0, i_imp-1
               cd_sph = cd_sph + (abnua(ii2,i) + abnua(ii2,i+1)) * (rx(i) - rx(i+1))
            ENDDO
            ysphr(i_imp,ny) = cd_sph
            DEALLOCATE (rx)
         ENDDO

         IF (in_sp(ii2) /= 0) THEN
            ind_sp = in_sp(ii2)
            PRINT *, " Relative populations? (1: yes, 0: no)"
            READ  *,ii4
            IF (irec == 1) THEN
               WRITE (8,*) ii4
            ENDIF

            IF (ii4 == 1) THEN
               jj = spec_lin(ind_sp)%nlv
               PRINT *, "  Num:    ", (spec_lin(ind_sp)%qnam(k), k=1,spec_lin(ind_sp)%nqn)
               DO i = 1, 1+jj/10
                  DO j = 1+10*(i-1), MIN(jj,10*i)
                     WRITE (6,'(2x,i3," :")',ADVANCE="NO") j
                     inqn = 0
                     DO k = 1, spec_lin(ind_sp)%nqn
                        inqn = inqn + 1
                        WRITE (6,"(2x,a3)",ADVANCE="NO") spec_lin(ind_sp)%quant(j,inqn)
                     ENDDO
                     WRITE (6,*)
                  ENDDO
                  PRINT *, "  More? (yes: -1)"
                  READ *, j
                  IF (irec == 1) THEN
                     WRITE (8,*) j
                  ENDIF
                  IF (j /= -1) EXIT
               ENDDO
               ii3 = 999
               DO WHILE (ii3 /= 0)
                  PRINT *
                  PRINT *, '    level number (end: 0)'
                  READ *, ii3
                  IF (ii3 > spec_lin(ind_sp)%use) THEN
                     ii3 = 0
                  ENDIF
                  IF (irec == 1) THEN
                     WRITE (8,*) ii3
                  ENDIF
                  IF (ii3 /=  0) THEN
                     ny = ny + 1
                     sph_head(ny) = "Lev."//TRIM(ADJUSTL(ii2c(ii3)))
                     IF (ny > npcol) THEN
                        PRINT *, "  Maximum number of column exceeded!"
                        PRINT *, ny, " > ", npcol
                        PRINT *, "  Please change npcol in PXDR_SPHERE and recompile"
                        STOP
                     ENDIF
                     DO i_imp = 1, i_sph
                        r_imp = d_cm(i_imp)
                        ALLOCATE (rx(0:i_imp))
                        DO i = 0, i_imp
                           rx(i) = SQRT((2.0_dp*r_sph - (r_imp + d_cm(i))) * (r_imp - d_cm(i)))
                        ENDDO
                        cd_sph = 0.0_dp
                        DO i = 0, i_imp-1
                           cd_sph = cd_sph + (rx(i) - rx(i+1)) &
                                  * (abnua(ii2,i) * spec_lin(ind_sp)%xre(ii3,i) &
                                  + abnua(ii2,i+1) * spec_lin(ind_sp)%xre(ii3,i+1))
                        ENDDO
                        ysphr(i_imp,ny) = cd_sph
                        DEALLOCATE (rx)
                     ENDDO
                  ENDIF
               ENDDO
            ENDIF
         ENDIF

         ! Line intensities
         IF (in_sp(ii2) /= 0) THEN
            ind_sp = in_sp(ii2)
            PRINT *, " Integrated line intensities? (1: yes, 0: no)"
            READ  *,ii4
            IF (irec == 1) THEN
               WRITE (8,*) ii4
            ENDIF

            IF (ii4 == 1) THEN
               PRINT *, ' Emission lines of: ', yspec
               CALL VIEW_LINES(spec_lin(ind_sp), irec)
               F_FULL_DET = 0
               ii = 999
               fichier = TRIM(out_dir)//TRIM(modele)//'_'//TRIM(yspec)//'_int.sph'
               OPEN (45, FILE=fichier, STATUS="unknown")
               WRITE (45,'(250a12)') (sph_head(j), j = 1, ny)
               DO WHILE (ii /= 0)
                  PRINT *, 'Transition?  (0: end)'
                  READ *, ii
                  IF (ii > spec_lin(ind_sp)%ntr) THEN
                     ii = 0
                  ENDIF
                  IF (irec == 1) THEN
                     WRITE (8,*) ii
                  ENDIF

                  IF (ii /= 0) THEN
                     ny = ny + 1
                     IF (ny > npcol) THEN
                        PRINT *, "  Maximum number of column exceeded!"
                        PRINT *, ny, " > ", npcol
                        PRINT *, "  Please change npcol in PXDR_SPHERE and recompile"
                        STOP
                     ENDIF
                     iupl = spec_lin(ind_sp)%iup(ii)
                     jlol = spec_lin(ind_sp)%jlo(ii)
                     sph_head(ny) = "Lin."//TRIM(ADJUSTL(ii2c(iupl)))//'->'//TRIM(ADJUSTL(ii2c(jlol)))
                     tampon = 'Emis.'//TRIM(spec_lin(ind_sp)%nam)//'.'
                     tampon = TRIM(ADJUSTL(tampon))//TRIM(ADJUSTL(ii2c(iupl)))//'->'//TRIM(ADJUSTL(ii2c(jlol)))

                     DO i_imp = 1, i_sph
                        r_imp = d_cm(i_imp)
                        ALLOCATE (rx(0:i_imp))
                        DO i = 0, i_imp
                           rx(i) = SQRT((2.0_dp*r_sph - (r_imp + d_cm(i))) * (r_imp - d_cm(i)))
                        ENDDO
                        cd_sph = 0.0_dp
                        CALL LDVSph(spec_lin(ind_sp), ii, tampon, emisl)
                        ysphr(i_imp,ny) = emisl
                        DEALLOCATE (rx)
                     ENDDO
                     ! JLB - 29 Nov 2011 - Integrate over radius
                     Int_m = 0.0_dp
                     rad_t = ysphr(i_sph,1)
                     DO i_imp = 1, i_sph
                        Int_m = Int_m + 0.5_dp * (ysphr(i_imp,ny) * (rad_t - ysphr(i_imp,1)) &
                              + ysphr(i_imp-1,ny) * (rad_t - ysphr(i_imp-1,1))) &
                              * (ysphr(i_imp,1) - ysphr(i_imp-1,1))
                     ENDDO
                     Int_m = 2.0_dp * Int_m / ysphr(i_sph,1)**2
                     WRITE (45,*) sph_head(ny), Int_m
                  ENDIF
               ENDDO
               CLOSE (45)
            ENDIF
         ENDIF

         WRITE (53,'(250a12)') (sph_head(j), j = 1, ny)
         DO i_imp = 0, i_sph
            WRITE (53,'(1p,250e17.8E3)') (ysphr(i_imp,j), j = 1, ny)
         ENDDO

         DEALLOCATE (ysphr)
         CLOSE (53)

      ENDDO
  ELSE
     PRINT *, "  Wrong value:", ii5
     RETURN
  ENDIF

END SUBROUTINE SPHERE

SUBROUTINE LDVSph (spelin, itr, tampon, emisl)

  USE PXDR_FLAGS
  USE PXDR_CONSTANTES
  USE PXDR_PROFIL
  USE PXDR_STR_DATA
  USE PXDR_RF_TOOLS
  USE PREP_VAR

  IMPLICIT NONE

  TYPE(SPECTRA), INTENT (IN)                    :: spelin         !  Line data
  INTEGER, INTENT (IN)                          :: itr            !  Transition index
  CHARACTER (LEN=17), INTENT (IN)               :: tampon         !  Line identity
  REAL (KIND=dp), INTENT (OUT)                  :: emisl          !  Total line emissivity (L alone)

  REAL (KIND=dp), DIMENSION (:), ALLOCATABLE    :: dtau_L          !  Integrand of line optical depth
  REAL (KIND=dp), DIMENSION (:), ALLOCATABLE    :: dtau_D          !  Integrand of dust optical depth
  REAL (KIND=dp), DIMENSION (:), ALLOCATABLE    :: tau_L           !  Line optical depth
  REAL (KIND=dp), DIMENSION (:), ALLOCATABLE    :: tau_D           !  Dust optical depth
  REAL (KIND=dp), DIMENSION (:), ALLOCATABLE    :: tau_T           !  Total optical depth (running variable)
  REAL (KIND=dp), DIMENSION (:), ALLOCATABLE    :: tau_nu          !  Total optical depth at line center

  REAL (KIND=dp)                                 :: nuij           !  Line frequency (s-1)
  REAL (KIND=dp)                                 :: eij            !  E_ij = (c**2 / 2h nu**3) * D_ij
  REAL (KIND=dp)                                 :: dij            !  D_ij = (h nu / 4 pi) g_i A_ij
  INTEGER                                        :: ju, jl

  INTEGER                                        :: jpm = 100      !  Number of points in line profile
  REAL (KIND=dp), ALLOCATABLE, DIMENSION(:)      :: spec_BG        ! Background contribution to spectra
  REAL (KIND=dp), ALLOCATABLE, DIMENSION(:)      :: dspec_D        ! Integrand of dust contribution to spectra
  REAL (KIND=dp), ALLOCATABLE, DIMENSION(:)      :: dspec_L        ! Integrand of line contribution to spectra
  REAL (KIND=dp), ALLOCATABLE, DIMENSION(:)      :: spec_D         ! Dust contribution to spectra
  REAL (KIND=dp), ALLOCATABLE, DIMENSION(:)      :: spec_L         ! Line contribution to spectra
  REAL (KIND=dp), ALLOCATABLE, DIMENSION(:)      :: spec_DT        ! Dust contribution to spectra
  REAL (KIND=dp), ALLOCATABLE, DIMENSION(:)      :: spec_LT        ! Line contribution to spectra
  REAL (KIND=dp), ALLOCATABLE, DIMENSION(:)      :: spec_T         ! Total spectra
  REAL (KIND=dp), ALLOCATABLE, DIMENSION(:)      :: ibg            ! Cosmic background
  REAL (KIND=dp)                                 :: emist          !  Total line emissivity (L + D)
  REAL (KIND=dp)                                 :: emisa          !  Total line emissivity (Apparent)

  INTEGER                                        :: i, j, j_wl
  REAL (KIND=dp)                                 :: nu, dnu, ddnu, yy
  REAL (KIND=dp)                                 :: fac_exp

  ! All expressions here are from the document "Line_Formation_dV0.pdf", version Octobre 2010

  ! Find index of wavelength in grid
  DO j = 1, nwlg
     IF (rf_wl%Val(j) == spelin%lac(itr) *1.0e8_dp) THEN
        j_wl = j
        EXIT
     ENDIF
  ENDDO

  nuij = clum/spelin%lac(itr)
  dnu = MINVAL(spelin%dnu(itr,:)) / 20.0_dp
  ju = spelin%iup(itr)
  jl = spelin%jlo(itr)
  dij = (xhp * nuij / (4.0_dp * xpi)) * spelin%gst(ju) * spelin%aij(itr)
  eij = spelin%lac(itr)**2 * spelin%aij(itr) * spelin%gst(ju) / (8.0_dp*xpi)

  IF (.NOT. ALLOCATED(dtau_L)) THEN
     ALLOCATE (dtau_L(0:npo))
     ALLOCATE (dtau_D(0:npo))
     ALLOCATE (tau_L(0:npo))
     ALLOCATE (tau_D(0:npo))
     ALLOCATE (tau_T(0:npo))
     ALLOCATE (dspec_D(0:npo))
     ALLOCATE (dspec_L(0:npo))
     ALLOCATE (spec_D(0:npo))
     ALLOCATE (spec_L(0:npo))
  ENDIF
  IF (.NOT. ALLOCATED(spec_T)) THEN
     ALLOCATE (spec_BG(-jpm:jpm))
     ALLOCATE (spec_T(-jpm:jpm))
     ALLOCATE (spec_LT(-jpm:jpm))
     ALLOCATE (spec_DT(-jpm:jpm))
     ALLOCATE (ibg(-jpm:jpm))
     ALLOCATE (tau_nu(-jpm:jpm))
  ENDIF
  dtau_L  = 0.0_dp
  dtau_D  = 0.0_dp
  tau_L   = 0.0_dp
  tau_D   = 0.0_dp
  tau_T   = 0.0_dp
  dspec_D = 0.0_dp
  dspec_L = 0.0_dp
  spec_D  = 0.0_dp
  spec_L  = 0.0_dp
  spec_BG = 0.0_dp
  spec_T  = 0.0_dp
  spec_LT = 0.0_dp
  spec_DT = 0.0_dp
  ibg     = 0.0_dp
  tau_nu  = 0.0_dp

  ! Compute optical depth
  ! Integration is done from the emerging position backward to the entrance point, so
  ! the quantity computed is tau_T(t) - tau_T(r_max)

  ! Dust optical depth (independant of profile):
  dtau_D = (du_prop%abso(j_wl) + du_prop%scat(j_wl)) * densh(0:npo)
  tau_D(0) = 0.0_dp
  DO i = 1, i_imp
     tau_D(i) = tau_D(i-1) + (dtau_D(i) + dtau_D(i-1)) * (rx(i-1) - rx(i)) * 0.5_dp
  ENDDO
  DO i = i_imp+1, 2*i_imp
     tau_D(i) = tau_D(i-1) + (dtau_D(2*i_imp-i) + dtau_D(2*i_imp-i+1)) * (rx(2*i_imp-i) - rx(2*i_imp-i+1)) * 0.5_dp
  ENDDO

  ! Scan line profile
  DO j = -jpm, jpm
     ddnu = j * dnu
     nu = nuij + ddnu
     yy = ddnu / nuij

     ! Background
     fac_exp = xhp*nu/(xk*tcmb)
     IF (fac_exp > LOG(HUGE(1.0_dp))*0.9_dp) THEN
        ibg(j) = 0.0_dp
     ELSE
        ibg(j) = 2.0_dp * xhp * nu**3 / (clum*clum)
        ibg(j) = ibg(j) / (EXP(xhp*nu/(xk*tcmb)) - 1.0_dp)
     ENDIF

     ! Line optical depth
     dtau_L = (clum * eij / (SQRT(xpi) * nuij)) * spelin%abu &
            * (spelin%xre(jl,:) / spelin%gst(jl) - spelin%xre(ju,:) / spelin%gst(ju)) &
            * EXP(-(yy*clum/spelin%vel)**2) / spelin%vel
     tau_L(0) = 0.0_dp
     DO i = 1, i_imp
        tau_L(i) = tau_L(i-1) + (dtau_L(i) + dtau_L(i-1)) * (rx(i-1) - rx(i)) * 0.5_dp
     ENDDO
     DO i = i_imp+1, 2*i_imp
        tau_L(i) = tau_L(i-1) + (dtau_L(2*i_imp-i) + dtau_L(2*i_imp-i+1)) * (rx(2*i_imp-i) - rx(2*i_imp-i+1)) * 0.5_dp
     ENDDO
!    DO i = 0, i_imp
!       print *, i, rx(0)-rx(i), dtau_D(i), tau_D(i), dtau_L(i), tau_L(i)
!    ENDDO
!    DO i = i_imp+1, 2*i_imp
!       print *, i, rx(0)+rx(2*i_imp-i), dtau_D(i), tau_D(i), dtau_L(i), tau_L(i)
!    ENDDO
!    stop

     ! Total optical depth
     tau_T = tau_L + tau_D
     tau_nu(j) = tau_T(2*i_imp)

     ! Background contribution
     spec_BG(j) = ibg(j) * EXP(-tau_nu(j))

     ! Dust contribution :
     DO i = 1, i_imp
        dspec_D(i) = (1.0e8_dp * spelin%lac(itr)**2 / clum) * du_prop%emis(j_wl,i) * densh(i) * EXP(-tau_T(2*i_imp-i))
     ENDDO
     DO i = i_imp+1, 2*i_imp
        dspec_D(i) = (1.0e8_dp * spelin%lac(itr)**2 / clum) &
                   * du_prop%emis(j_wl,2*i_imp-i) * densh(2*i_imp-i) * EXP(-tau_T(2*i_imp-i))
     ENDDO
     spec_D(2*i_imp) = 0.0_dp
     DO i = 2*i_imp-1, i_imp, -1
        spec_D(i) = spec_D(i+1) + (dspec_D(i) + dspec_D(i+1)) * (rx(2*i_imp-i-1) - rx(2*i_imp-i)) * 0.5_dp
     ENDDO
     DO i = i_imp-1, 0, -1
        spec_D(i) = spec_D(i+1) + (dspec_D(i) + dspec_D(i+1)) * (rx(i) - rx(i+1)) * 0.5_dp
     ENDDO

     ! Line contribution
     DO i = 1, i_imp
        dspec_L(i) = (clum * dij / (SQRT(xpi) * nuij)) * (spelin%abu(i) * spelin%xre(ju,i) / spelin%gst(ju)) &
                * EXP(-(yy*clum/spelin%vel(i))**2) * EXP(-tau_T(2*i_imp-i)) / spelin%vel(i)
     ENDDO
     DO i = i_imp+1, 2*i_imp
        dspec_L(i) = (clum * dij / (SQRT(xpi) * nuij)) * (spelin%abu(2*i_imp-i) * spelin%xre(ju,2*i_imp-i) / spelin%gst(ju)) &
                * EXP(-(yy*clum/spelin%vel(2*i_imp-i))**2) * EXP(-tau_T(2*i_imp-i)) / spelin%vel(2*i_imp-i)
     ENDDO
     spec_L(2*i_imp) = 0.0_dp
     DO i = 2*i_imp-1, i_imp, -1
        spec_L(i) = spec_L(i+1) + (dspec_L(i) + dspec_L(i+1)) * (rx(2*i_imp-i-1) - rx(2*i_imp-i)) * 0.5_dp
     ENDDO
     DO i = i_imp-1, 0, -1
        spec_L(i) = spec_L(i+1) + (dspec_L(i) + dspec_L(i+1)) * (rx(i) - rx(i+1)) * 0.5_dp
     ENDDO

     spec_LT(j) = spec_L(0)
     spec_DT(j) = spec_D(0)
     spec_T(j) = spec_BG(j) + spec_DT(j) + spec_LT(j)
  ENDDO

  ! Supress background
  spec_T = spec_T - ibg

  ! Output
  emist = 0.0_dp
  emisl = 0.0_dp
  emisa = 0.0_dp
  DO j = -jpm, jpm
     emist = emist + spec_T(j)
     emisl = emisl + spec_LT(j)
     emisa = emisa + (spec_T(j) - spec_DT(jpm))
  ENDDO
  emist = emist * dnu
  emisl = emisl * dnu
  emisa = emisa * dnu

  IF (F_FULL_DET == 1) THEN
     PRINT *, tampon, emist, emisl, emisa, " erg cm-2 s-1 str-1"
     WRITE (35, '(/,"# ",a17," nu:",f11.2," GHz, lamda:",f11.4," micron ")') &
            tampon, 1.0e-9_dp*nuij, 1.0e4_dp*spelin%lac(itr)
     WRITE (35, '("#  I.T:",1pe12.5,", I.L:", e12.5,", I.ap:",e12.5," erg cm-2 s-1 str-1 ")') &
            emist, emisl, emisa
     WRITE (35, '("#  Int. Obs:",1pe12.5," K km s-1 ")') 0.5e-5_dp * emisl * spelin%lac(itr)**3 / xk
     WRITE (35, '("# D.nu/nu   Tau_nu  Spec.T    Spec.BG    spec.DT    spec.LT    ibg")')
     DO j = -jpm, jpm
        ddnu = j * dnu
        yy = ddnu / nuij
        WRITE (35, "(1p,20e15.6E3)") yy, tau_nu(j), spec_T(j), spec_BG(j), spec_DT(j), spec_LT(j), ibg(j)
     ENDDO
  ENDIF

  DEALLOCATE (dtau_L, dtau_D)
  DEALLOCATE (tau_L, tau_D, tau_T, tau_nu)
  DEALLOCATE (dspec_D, dspec_L)
  DEALLOCATE (spec_BG, spec_D, spec_L)
  DEALLOCATE (spec_DT, spec_LT, spec_T)
  DEALLOCATE (ibg)

END SUBROUTINE LDVSph

END MODULE PREP_SPHERE

