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

  PRIVATE

  PUBLIC :: EXCIT

CONTAINS

!%%%%%%%%%%%%%%%
SUBROUTINE EXCIT
!%%%%%%%%%%%%%%%

   USE PXDR_FLAGS
   USE PXDR_CONSTANTES
   USE PXDR_CHEM_DATA
   USE PXDR_PROFIL
   USE PREP_VAR

   IMPLICIT NONE

   REAL (KIND=dp) :: avj(12)
   INTEGER        :: jop(12)
   INTEGER        :: ans
   INTEGER        :: iopt_min, iopt_max, iopt_deb
   INTEGER        :: jjmax, lev, ju, i, jj, j
   REAL (KIND=dp) :: taucher, taupre, avcher, taulim
   REAL (KIND=dp) :: avchermax, avchermin
   REAL (KIND=dp) :: delta1, delta2, deltatau
   REAL (KIND=dp) :: gstat

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

   PRINT *, " Which excitation diagram do you whish?"
   PRINT *, " 1- up to a specific point ?"
   PRINT *, " 2- In a given interval ?"
   PRINT *, " 3- Over the whole cloud ?"
   READ *, ans
   IF (irec == 1) THEN
      WRITE (8,*) ans
   ENDIF

   IF (ans == 3) THEN
      taulim = tau(2)
      jj = 0
      DO j = 1, npo
        IF (tau(j) > taulim) THEN
          jj = jj + 1
          jop(jj) = j - 1
          taulim = taulim * 10.0_dp
        ENDIF
      ENDDO
      IF (jop(jj) < npo) THEN
         jj = jj + 1
         jop(jj) = npo
      ENDIF
   ELSE IF (ans == 2) THEN
      Avmax = tau(npo) * tautav
      PRINT *, " Give lower Av"
      PRINT *, " Av max is:", Avmax
      READ  *, avchermin ! Limite inferieure de Av
      IF (irec == 1) THEN
         WRITE(8,*) avchermin
      ENDIF
      PRINT *, " Give upper Av"
      PRINT *, " Av max is:", Avmax
      READ *,avchermax ! Limite superieure de Av
      IF (irec == 1) THEN
         WRITE(8,*) avchermax
      ENDIF

      ! Recherche du point correspondant au Av minimal
      taucher = avchermin / tautav
      i = 1
      DO WHILE( (tau(i) < taucher) .OR. (i > npo) )
         i = i + 1
      ENDDO
      taupre = tau(i-1)
      ! le tau cherche est compris entre tau(i-1) et tau(i)
      ! On determine duquel des deux il est le plus proche
      delta1 = ABS(taupre - taucher)
      delta2 = ABS(tau(i) - taucher)
      IF (delta1 < delta2) THEN
         iopt_min = i-1
      ELSE
         iopt_min = i
      ENDIF
      PRINT *,'Av min found = ', tau(iopt_min) * tautav

      ! Recherche du point correspondant au Av maximal
      taucher = avchermax / tautav

      i = 1
      DO WHILE ( (tau(i) < taucher) .OR. (i > npo) )
         i = i + 1
      ENDDO
      ! le tau cherche est compris entre tau(i-1) et tau(i)
      ! On determine duquel des deux il est le plus proche
      taupre = tau(i-1)
      delta1 = ABS(taupre - taucher)
      delta2 = ABS(tau(i) - taucher)
      IF (delta1 < delta2) THEN
         iopt_max = i-1
      ELSE
         iopt_max = i
      ENDIF
      PRINT *,'Av max found = ', tau(iopt_max) * tautav

      ! On va sortir jjmax diag d'excitation tous les deltatau
      ! entre Avmin et Avmax
      jjmax = 10
      deltatau = (tau(iopt_max) - tau(iopt_min)) / (jjmax -1)

      ! premier diagramme a Avmin
      jj = 1
      jop(jj) = iopt_min

      ! on cherche les 9 points suivants
      taucher = tau(iopt_min) + deltatau * jj ! tau recherche
      iopt_deb = iopt_min + 1
      jj=2
      DO j = iopt_deb, iopt_max+1
         IF (tau(j) > taucher)  THEN
            delta1 = ABS(taupre - taucher)
            delta2 = ABS(tau(j) - taucher)
            IF (delta1 < delta2) THEN
               jop(jj) = j-1
            ELSE
               jop(jj) = j
            ENDIF

            ! Calcule sur prochain tau a chercher
            ! REM : Dans le cas d'un intervalle Avmin, Avmax
            ! ayant moins de jjmax points, il se peut qu'on reecrive
            ! plusieurs fois les memes Av. Ce test est fait pour les
            ! supprimer
            IF (tau(jop(jj)) == (tau(jop(jj-1)))) THEN
               jj = jj + 1
               taucher = tau(iopt_min) + deltatau * (jj-1)
               jj = jj - 1
            ELSE
               jj = jj + 1
               taucher = tau(iopt_min) + deltatau * (jj-1)
            ENDIF
         ENDIF
      ENDDO
      jj = jj-1 ! on a incremente une fois de trop jj
   ELSE IF (ans == 1) THEN
      jj = 1
      Avmax = tau(npo) * tautav
      PRINT *, " At which point do you want the excitation diag ?"
      PRINT *, " Enter a value lower than", Avmax
      READ *, avcher
      IF (irec == 1) THEN
         WRITE (8,*) avcher
      ENDIF
      taucher = avcher / tautav

      ! Recherche du tau souhaite
      i = 1
      DO WHILE( (tau(i) < taucher) .OR. (i > npo) )
         i = i + 1
      ENDDO
      taupre = tau(i-1)

      delta1 = ABS(taupre - taucher)
      delta2 = ABS(tau(i) - taucher)
      IF (delta1 < delta2) THEN
         jop(jj) = i-1
      ELSE
         jop(jj) = i
      ENDIF
   ENDIF

   fichier = TRIM(out_dir)//TRIM(modele)//'.exc'
   OPEN (18, file=fichier, status = "unknown")

   DO j = 1, jj
      avj(j) = tau(jop(j)) * tautav
   ENDDO

   WRITE(18,1002) (avj(j),j=1,jj)
 1002 FORMAT(2x,'num', 4x,'v',4x,'j',3x,'energie K',2x,'Av',1p,E10.3,2x,9(1p,E10.3,3x))

   DO lev = 1, l0h2
      ju = njl_h2(lev)
      IF (ju <= njh2) THEN
         IF (MOD(ju,2) == 1) THEN
            gstat = (2.0_dp*DBLE(ju)+1.0_dp) * 3.0_dp
         ELSE
            gstat = 2.0_dp*DBLE(ju)+1.0_dp
         ENDIF
         WRITE (18,'(3i5,1p,13e12.3)') &
               lev, nvl_h2(lev), ju, spec_lin(in_sp(i_h2))%elk(lev) &
             , (spec_lin(in_sp(i_h2))%CoD(lev,jop(j))/gstat, j=1,jj)
      ENDIF
   ENDDO

   PRINT *,' Results written in:', fichier
   CLOSE (18)

END SUBROUTINE EXCIT

END MODULE PREP_EXCIT
