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

MODULE PREP_EMISSI

  PRIVATE

  PUBLIC :: EMISSI, VIEW_LINES, EMIINT, FSPECTRUM

CONTAINS

!%%%%%%%%%%%%%%%%
SUBROUTINE EMISSI
!%%%%%%%%%%%%%%%%

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

   IMPLICIT NONE

   CHARACTER (LEN=lenSpeci) :: yspec
   INTEGER                  :: ii, ju, jl, jj
   INTEGER                  :: iloc, i, ind_sp

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

   PRINT *, '   Specify which problem:'
   PRINT *, '      0: Local emissivities'
   PRINT *, '      1: Line intensities'
   IF (F_W_HDF5_STD == 1) THEN
      PRINT *, '   3: All lines intensities'
   ENDIF
   PRINT *, '      4: Full spectrum in a range'
   READ *, iloc
   IF (irec == 1) THEN
      WRITE (8,*) iloc
   ENDIF

   IF (iloc == 1) THEN
      PRINT *, ' Compute integrated emissivities'
      CALL EMIINT
   ELSE IF (F_W_HDF5_STD == 1 .AND. iloc ==3) THEN
      CALL PRINT_INTENSITIES
   ELSE IF (iloc == 4) THEN
      PRINT *, ' Compute full spectrum in a range'
      CALL FSPECTRUM
   ELSE IF (iloc == 0) THEN
      PRINT *, ' Compute local emissivities'
      PRINT *, " "
      PRINT *, " Possible species:"
      i = 1
      DO WHILE (i <= nspl)
         IF (MOD(i,3) /= 0) THEN
            WRITE (*,'(a10)',ADVANCE="NO") spec_lin(i)%nam
         ELSE
            WRITE (*,'(a10)') spec_lin(i)%nam
         ENDIF
         i = i + 1
      ENDDO
      WRITE (*,*)

      DO
         PRINT *
         PRINT *, ' Which species?  (end: -1)'
         READ (*,'(a8)') yspec
         yspec = TRIM(ADJUSTL(yspec))
         IF (irec == 1) THEN
            WRITE (8,'(a8)') yspec
         ENDIF
         IF (yspec == "-1") THEN
            PRINT *, "  End lines"
            EXIT
         ENDIF
         DO i = 1, nspec
            IF (yspec /= TRIM(ADJUSTL(speci(i)))) THEN
               CYCLE
            ELSE
               EXIT
            ENDIF
         ENDDO
         IF (i > nspec) THEN
            SELECT CASE (yspec)
            CASE ("c*o")
               i = nspec + 1
            CASE ("co*")
               i = nspec + 2
            CASE ("c*o*")
               i = nspec + 3
            CASE DEFAULT
               i = 0
            END SELECT
         ENDIF
         IF (i == 0 .AND. yspec /= '-1') THEN
            PRINT *, "  WARNING:", yspec, " is not in chemistry!"
            CYCLE
         ELSE IF (in_sp(i) == 0) THEN
            PRINT *, "  WARNING: excitation of ", yspec &
                   , " was not computed"
         ELSE
            ind_sp = in_sp(i)
         ENDIF

         ii = 999
         PRINT *, ' Emission lines of: ', yspec
         CALL VIEW_LINES(spec_lin(ind_sp), irec)
         DO WHILE (ii /= 0)
            PRINT *,"Enter line number (0 end)"
            READ *, ii
            IF (ii > spec_lin(ind_sp)%ntr) THEN
               PRINT *, ii, ' > ', spec_lin(ind_sp)%ntr, ' ! - END'
               ii = 0
               EXIT
            ENDIF
            IF (irec == 1) THEN
               WRITE (8,*) ii
            ENDIF

            IF (ii /= 0) THEN
               PRINT *, 'Collect line number:', ii
               iimax = iimax + 1
               y(iimax,0:npo) = spec_lin(ind_sp)%emi(ii,0:npo)
               texty(iimax) = 'EmL.'//TRIM(spec_lin(ind_sp)%nam)//'.'//TRIM(ADJUSTL(ii2c(ii)))
            ELSE
               PRINT *, 'End lines of: ', yspec
               EXIT
            ENDIF

            PRINT *, "Full line properties? (1: yes, 0: no)"
            READ *, jj
            IF (irec == 1) THEN
               WRITE (8,*) jj
            ENDIF
            IF (jj == 1) THEN
               ju = spec_lin(ind_sp)%iup(ii)
               jl = spec_lin(ind_sp)%jlo(ii)

               iimax = iimax + 1
               y(iimax,0:npo) = spec_lin(ind_sp)%abu(0:npo)
               texty(iimax) = TRIM(spec_lin(ind_sp)%nam)//'.abun.'//TRIM(ADJUSTL(ii2c(ii)))
               iimax = iimax + 1
               y(iimax,0:npo) = spec_lin(ind_sp)%vel(0:npo)
               texty(iimax) = TRIM(spec_lin(ind_sp)%nam)//'.vel.'//TRIM(ADJUSTL(ii2c(ii)))
               iimax = iimax + 1
               y(iimax,0:npo) = spec_lin(ind_sp)%xre(ju,0:npo)
               texty(iimax) = TRIM(spec_lin(ind_sp)%nam)//'.xreu.'//TRIM(ADJUSTL(ii2c(ii)))
               iimax = iimax + 1
               y(iimax,0:npo) = spec_lin(ind_sp)%xre(jl,0:npo)
               texty(iimax) = TRIM(spec_lin(ind_sp)%nam)//'.xrel.'//TRIM(ADJUSTL(ii2c(ii)))
               iimax = iimax + 1
               y(iimax,0:npo) = spec_lin(ind_sp)%XXl(ju,0:npo)
               texty(iimax) = TRIM(spec_lin(ind_sp)%nam)//'.XXlu.'//TRIM(ADJUSTL(ii2c(ii)))
               iimax = iimax + 1
               y(iimax,0:npo) = spec_lin(ind_sp)%XXl(jl,0:npo)
               texty(iimax) = TRIM(spec_lin(ind_sp)%nam)//'.XXlr.'//TRIM(ADJUSTL(ii2c(ii)))
               iimax = iimax + 1
               y(iimax,0:npo) = spec_lin(ind_sp)%XXr(ju,0:npo)
               texty(iimax) = TRIM(spec_lin(ind_sp)%nam)//'.XXru.'//TRIM(ADJUSTL(ii2c(ii)))
               iimax = iimax + 1
               y(iimax,0:npo) = spec_lin(ind_sp)%XXr(jl,0:npo)
               texty(iimax) = TRIM(spec_lin(ind_sp)%nam)//'.XXrl.'//TRIM(ADJUSTL(ii2c(ii)))
               iimax = iimax + 1
               y(iimax,0:npo) = spec_lin(ind_sp)%odl(ii,0:npo)
               texty(iimax) = TRIM(spec_lin(ind_sp)%nam)//'.odl.'//TRIM(ADJUSTL(ii2c(ii)))
               iimax = iimax + 1
               y(iimax,0:npo) = spec_lin(ind_sp)%odr(ii,0:npo)
               texty(iimax) = TRIM(spec_lin(ind_sp)%nam)//'.odr.'//TRIM(ADJUSTL(ii2c(ii)))
               iimax = iimax + 1
               y(iimax,0:npo) = spec_lin(ind_sp)%dnu(ii,0:npo)
               texty(iimax) = TRIM(spec_lin(ind_sp)%nam)//'.dnu.'//TRIM(ADJUSTL(ii2c(ii)))
               iimax = iimax + 1
               y(iimax,0:npo) = spec_lin(ind_sp)%emi(ii,0:npo)
               texty(iimax) = TRIM(spec_lin(ind_sp)%nam)//'.emi.'//TRIM(ADJUSTL(ii2c(ii)))
               iimax = iimax + 1
               y(iimax,0:npo) = spec_lin(ind_sp)%pum(0:npo,ii)
               texty(iimax) = TRIM(spec_lin(ind_sp)%nam)//'.pum.'//TRIM(ADJUSTL(ii2c(ii)))
               iimax = iimax + 1
               y(iimax,0:npo) = spec_lin(ind_sp)%jiD(ii,0:npo)
               texty(iimax) = TRIM(spec_lin(ind_sp)%nam)//'.jiD.'//TRIM(ADJUSTL(ii2c(ii)))
               iimax = iimax + 1
               y(iimax,0:npo) = spec_lin(ind_sp)%bel(ii,0:npo)
               texty(iimax) = TRIM(spec_lin(ind_sp)%nam)//'.bel.'//TRIM(ADJUSTL(ii2c(ii)))
               iimax = iimax + 1
               y(iimax,0:npo) = spec_lin(ind_sp)%ber(ii,0:npo)
               texty(iimax) = TRIM(spec_lin(ind_sp)%nam)//'.ber.'//TRIM(ADJUSTL(ii2c(ii)))
               iimax = iimax + 1
               y(iimax,0:npo) = spec_lin(ind_sp)%exl(ii)
               texty(iimax) = TRIM(spec_lin(ind_sp)%nam)//'.exl.'//TRIM(ADJUSTL(ii2c(ii)))
               iimax = iimax + 1
               y(iimax,0:npo) = spec_lin(ind_sp)%exr(ii)
               texty(iimax) = TRIM(spec_lin(ind_sp)%nam)//'.exr.'//TRIM(ADJUSTL(ii2c(ii)))
            ENDIF

         ENDDO
      ENDDO

   ENDIF

END SUBROUTINE EMISSI

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
SUBROUTINE VIEW_LINES(spelin, irec)
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

   USE PXDR_FLAGS
   USE PXDR_CONSTANTES
   USE PXDR_STR_DATA

   IMPLICIT NONE
   TYPE(spectra), INTENT (IN) :: spelin
   INTEGER, INTENT (IN)       :: irec
   INTEGER                    :: ntr, nqn, ntrp
   INTEGER                    :: i, j
   CHARACTER (LEN=40)         :: frmt
   CHARACTER (LEN=1)          :: ld='(', rd=')'

   ntr = spelin%ntr
   nqn = spelin%nqn
   PRINT *, " List length ? (Max:", ntr, ")"
   READ *, ntrp
   IF (irec == 1) THEN
      WRITE (8,*) ntrp
   ENDIF

   PRINT *," num  - ",(spelin%qnam(j),j=1,nqn)   &
          ,"-> ",(spelin%qnam(j),j=1,nqn)

   DO i = 1, MIN(ntrp,spelin%ntr)
      WRITE (frmt,'(a1,"i4,5x,a",i2,",3x,a",i2,a1)') ld, LEN_TRIM(ADJUSTL(spelin%LiHname(i))) &
            , LEN_TRIM(spelin%inftr(i)), rd
      WRITE (*,frmt) i, TRIM(ADJUSTL(spelin%LiHname(i))),TRIM(spelin%inftr(i))
   ENDDO

END SUBROUTINE VIEW_LINES

!%%%%%%%%%%%%%%%%
SUBROUTINE EMIINT
!%%%%%%%%%%%%%%%%

   USE PXDR_FLAGS
   USE PXDR_CONSTANTES
   USE PXDR_CHEM_DATA
   USE PXDR_PROFIL
   USE PXDR_AUXILIAR
   USE PXDR_STR_DATA
   USE PXDR_INTENSITIES
   USE PREP_VAR

   IMPLICIT NONE

   CHARACTER (LEN=lenSpeci) :: yspec
   CHARACTER (LEN=lenIDLIN) :: tampon
   CHARACTER (LEN=50)       :: fichout
   REAL (KIND=dp)           :: xmu
   INTEGER                  :: i, ii
   INTEGER                  :: iupl, jlol
   INTEGER                  :: ind_sp
   INTEGER                  :: flag_AllOutputs  ! Flag to call LDVInt - 1 is used in prep to get lines properties

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

   PRINT *
   PRINT *, ' Give lines file name:'
   READ (*,'(a50)') fichout
   fichout = TRIM(ADJUSTL(fichout))
   IF (irec == 1) THEN
      WRITE (8,'(a50)') fichout
   ENDIF

   fichier = TRIM(out_dir)//fichout
   PRINT *," Lines written in:", fichier
   OPEN (35, file = fichier, status = 'new')

   PRINT *
   PRINT *, ' Do want to save the full line profiles (1: yes, 0: no)'
   READ (*,*) F_W_LINE_PROF
   IF (irec == 1) THEN
      WRITE (8,*) F_W_LINE_PROF
   ENDIF

   PRINT *
   PRINT *, ' Give angle of line of sight (radian) [wrt normal]'
   READ *, xmu
   IF (irec == 1) THEN
      WRITE (8,*) xmu
   ENDIF
   xmu = cos(xmu)
   WRITE (35,'("# mu:",1pe14.6)') xmu
   IF (F_W_LINE_PROF == 0) THEN
      WRITE (35,'("# lev_up-lev_down Freq(MHz) Wave_l(micron) I_int(erg_s-1_cm-2_ster) I_int(K_km_s-1)")')
   ENDIF

   PRINT *, " "
   PRINT *, " Possible species:"
   i = 1
   DO WHILE (i <= nspl)
      IF (MOD(i,3) /= 0) THEN
         WRITE (*,'(a10)',ADVANCE="NO") spec_lin(i)%nam
      ELSE
         WRITE (*,'(a10)') spec_lin(i)%nam
      ENDIF
      i = i + 1
   ENDDO
   WRITE (*,*)

   DO
      PRINT *
      PRINT *, ' Which species?  (end: -1)'
      READ (*,'(a8)') yspec
      yspec = TRIM(ADJUSTL(yspec))
      IF (irec == 1) THEN
         WRITE (8,'(a8)') yspec
      ENDIF
      IF (yspec == '-1') THEN
         PRINT *, "End lines"
         EXIT
      ENDIF

      ind_sp = 0
      DO i = 1, nspl
        IF ( TRIM(ADJUSTL(yspec)) == TRIM(ADJUSTL(spec_lin(i)%nam))) THEN
            ind_sp = i
            EXIT
         ENDIF
      ENDDO
      print *, ind_sp, yspec, spec_lin(ind_sp)%nam
      IF (ind_sp == 0) THEN
         PRINT *, "  WARNING: excitation of ", yspec, " was not computed"
         CYCLE
      ENDIF

      ii = 999
      PRINT *, ' Emission lines of: ', yspec
      IF (F_W_LINE_PROF == 0) THEN
         WRITE (35,'(/,"# ",a8)') yspec
      ENDIF
      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 = ""
            IF (F_W_LINE_PROF == 1) THEN
               tampon = 'Emis.'//TRIM(spec_lin(ind_sp)%nam)//'.'
            ENDIF
            tampon = TRIM(ADJUSTL(tampon))//TRIM(ADJUSTL(spec_lin(ind_sp)%LiHname(ii)))
            flag_AllOutputs = 1
            CALL LDVInt (xmu, spec_lin(ind_sp), ii, tampon, flag_AllOutputs, 0)
         ENDIF
      ENDDO
   ENDDO

   CLOSE (35)

END SUBROUTINE EMIINT

!========================================================================================================
! SUBROUTINE PRINT_INTENSITIES
!========================================================================================================
SUBROUTINE PRINT_INTENSITIES

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

   IMPLICIT NONE

   CHARACTER(len=lenfilename) :: fichout
   INTEGER                    :: i, j, k

      fichout = TRIM(out_dir)//TRIM(modele)//".AllLines"
      OPEN(81,file=fichout,status="unknown",action="write")
      WRITE (81,1080)
      DO i = 1, nspl
         DO j = 1, spec_lin(i)%ntr
            IF (spec_lin(i)%iup(j) <= spec_lin(i)%use) THEN
               WRITE (81,1081) TRIM(spec_lin(i)%spHname), TRIM(spec_lin(i)%LiHname(j)) &
                              , (spec_lin(i)%int(j,k), k = 1, nangle)
            ENDIF
         ENDDO
      ENDDO
      CLOSE(81)
      WRITE(*,*) "All line intensities have been written in : "
      WRITE(*,*) TRIM(fichout)

1080  FORMAT("#  Species                      Transition        &
      &Intensities [erg cm-2 s-1 sr-1] at 0, 10, 20, 30, 40, 50, 60 degrees")
1081  FORMAT(A10,2x,A30,7(2x,1p,E18.6))

END SUBROUTINE PRINT_INTENSITIES

!---------------------------------------------------------
! Computes the full spectrum including continuum and lines
!---------------------------------------------------------
!%%%%%%%%%%%%%%%%%%%
SUBROUTINE FSPECTRUM
!%%%%%%%%%%%%%%%%%%%

   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_INTENSITIES
   USE PREP_VAR

   IMPLICIT NONE

   CHARACTER (LEN=lenIDLIN)                     :: tampon
   CHARACTER (LEN=50)                           :: fichout
   REAL (KIND=dp)                               :: xmu
   REAL (KIND=dp)                               :: lam1, lam2, wl1, wl2
   REAL (KIND=dp)                               :: spec_D, spec_BG
   INTEGER                                      :: j, j1, j2
   INTEGER                                      :: i, itr
   INTEGER                                      :: i_line
   REAL (kind=dp)                               :: wl

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

   ! Recover the incident radiation field
   ! Read from file *.flin (see ETIN90 for creation)
   ! This avoids recomputing it from scratch
   IF (.NOT. ALLOCATED(I_incr_m)) THEN                ! Read file only on first call
      ALLOCATE (I_incr_m(0:nwlg))
      ALLOCATE (I_isot_m(0:nwlg))
      ALLOCATE (I_incr_p(0:nwlg))
      ALLOCATE (I_isot_p(0:nwlg))

      fichier = TRIM(out_dir)//TRIM(modele)//'.flin'
      OPEN (60, file=fichier, status="unknown")
      READ (60,*)
      DO j = 0, nwlg
         READ (60, '(1p,9e15.6E3)') wl, I_incr_m(j), I_isot_m(j) &
                                  , I_incr_p(j), I_isot_p(j)
      ENDDO
      CLOSE (60)
   ENDIF

   ! Output file names built as usual
   PRINT *
   ! Full spectrum
   fichout = TRIM(ADJUSTL(modele))//".spec"
   fichier = TRIM(out_dir)//fichout
   PRINT *," Spectrum written in:", fichier
   OPEN (35, file = fichier, status = 'new')
   WRITE (35, '("Lambda-A  Spec-tot  Emis-Dust  Extern-Trans")')

   ! Integrated line intensities
   fichout = TRIM(ADJUSTL(modele))//".lines"
   fichier = TRIM(out_dir)//fichout
   PRINT *," Lines integrated intensities written in:", fichier
   OPEN (36, file = fichier, status = 'new')

   ! Note: A potential high background source for mu = 1 is not yet included
   PRINT *
   PRINT *, ' Give angle of line of sight (radian) [wrt normal]'
   READ *, xmu
   IF (irec == 1) THEN
      WRITE (8,*) xmu
   ENDIF
   xmu = cos(xmu)
   WRITE (36,'("# mu:",1pe14.6)') xmu

   PRINT *, " "
   PRINT *, " Give lambda min (Angstrom):"
   READ *, lam1
   IF (irec == 1) THEN
      WRITE (8,*) lam1
   ENDIF
   CALL RF_LOCATE (rf_wl, lam1, j1)
   PRINT *, " Give lambda max (Angstrom):"
   READ *, lam2
   IF (irec == 1) THEN
      WRITE (8,*) lam2
   ENDIF
   CALL RF_LOCATE (rf_wl, lam2, j2)
   WRITE (36,'("# Spectrum from ",1pe14.6," to ",e14.6," Angstrom")') lam1, lam2
   WRITE (36,'("# Species_Line   Nu_GHz   Lambda_micron   Int_erg_cm-2_s-1_ster-1   Int_K_km_s-1")')

   ! We scan wavelength in increasing order
   ! If at line center, then a line profile is computed
   ! The line is kept if strong enough. Else use pure continuum contribution
   ! For each wavelength, the intensity is followed by a flag:
   !     1: part of a line profile
   !     0: computed with continuum only
   wl2 = 0.0_dp
   DO j = j1, j2
      IF (rf_wl%Val(j) < wl2) CYCLE
      i_line = 0
 SPC: DO i = 1, nspl
         DO itr = 1, spec_lin(i)%ntr
            IF ((spec_lin(i)%iup(itr) <= spec_lin(i)%use) .AND. &
                (ABS((rf_wl%Val(j) - spec_lin(i)%lac(itr) * 1.0e8_dp) / rf_wl%Val(j)) < 1.0e-8_dp)) THEN
               tampon = TRIM(ADJUSTL(spec_lin(i)%nam))//"_"//TRIM(ADJUSTL(spec_lin(i)%LiHname(itr)))
               CALL LDVInt_l (xmu, spec_lin(i), itr, tampon, wl1, wl2)
               i_line = 1
               EXIT SPC
            ENDIF
         ENDDO
      ENDDO SPC
      IF (i_line == 0) THEN
         CALL LDVInt_c (xmu, rf_wl%Val(j), spec_D, spec_BG)
         WRITE (35, "(1p,4e16.8E3,a2)") rf_wl%Val(j), spec_D+spec_BG, spec_D, spec_BG, " 0"
      ENDIF
   ENDDO

   CLOSE (35)
   CLOSE (36)

END SUBROUTINE FSPECTRUM

END MODULE PREP_EMISSI
