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

USE PXDR_CONSTANTES
USE PXDR_AUXILIAR

IMPLICIT NONE

   ! Draine's files give log grids for Q_abs, Q_scat, g. Change the following PARAMETERs if you change file.
   INTEGER, PARAMETER, PUBLIC                            :: nptmax=88            ! Number of radius pts max
   INTEGER, PARAMETER, PUBLIC                            :: npwmax=682           ! Number of wlgth pts max

   ! Grains data base. Read in READ_DRAINE_FILES
   INTEGER, PUBLIC                                       :: np_r                 ! Number of radius pts READ
   INTEGER, PUBLIC                                       :: np_w                 ! Number of wlgth pts READ

   REAL (KIND=dp), PUBLIC                                :: r_min, r_max
   REAL (KIND=dp), PUBLIC, DIMENSION (nptmax)            :: radgr
   REAL (KIND=dp), PUBLIC, DIMENSION (0:npwmax+1)        :: wavgrd
   INTEGER, PUBLIC                                       :: jwlmin_gr, jwlmax_gr ! range of wl used in wavgrd

   ! Optical properties
   REAL (KIND=dp), PUBLIC, DIMENSION (nptmax,0:npwmax+1) :: Qabs_Gra, Qsca_Gra, g_Gra
   REAL (KIND=dp), PUBLIC, DIMENSION (nptmax,0:npwmax+1) :: Qabs_Sil, Qsca_Sil, g_Sil
   REAL (KIND=dp), PUBLIC, DIMENSION (:,:), ALLOCATABLE  :: Qabs_Dr, Qsca_Dr, g_Dr
   REAL (KIND=dp), PUBLIC, DIMENSION (:,:), ALLOCATABLE  :: Qabs_FM, Qsca_FM
   REAL (KIND=dp), PUBLIC, DIMENSION (:,:), ALLOCATABLE  :: Qabs_Du, Qsca_Du
   REAL (KIND=dp), PUBLIC, DIMENSION (:,:), ALLOCATABLE  :: Q_abs, Q_emi
   REAL (KIND=dp), PUBLIC, DIMENSION (:,:), ALLOCATABLE  :: Cheat_Dr, Cheat_FM, Cheat_Du

   ! Heat capacities: from a mix of dustem's data over log grids of dust temperature
   INTEGER, PARAMETER, PUBLIC                            :: ntemax=30
   INTEGER, PUBLIC                                       :: np_t                 ! Number of temperature pts READ
   REAL (KIND=dp), PUBLIC, DIMENSION (nptmax)            :: radgr_hc
   REAL (KIND=dp), PUBLIC, DIMENSION (ntemax)            :: tempgrd
   REAL (KIND=dp), PUBLIC, DIMENSION (nptmax,ntemax)     :: Cheat_Gra,Cheat_Sil

CONTAINS

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!     READING DATA FILES GIVEN BY DRAINE FOR GRAPHITE AND SILICATES
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
SUBROUTINE READ_DRAINE_FILES
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

   USE PXDR_FLAGS
   USE PXDR_CONSTANTES

   IMPLICIT NONE

   INTEGER                           :: i, j
   REAL (KIND=dp)                    :: toto

   !======================================================================================
   !             READING  GRAPHITE and SILICATE IN FILE:  Mix_Qcoef_BG_10_2013
   !======================================================================================

   fichier = TRIM(data_dir)//'Grains/Mix_Qcoef_BG_10_2013.dat'
   WRITE (iscrn,*) "    * Read grains data from Draine's datafiles "//TRIM(fichier)

   ! -------------------------------------------------------------------------------------
   ! Read and test the nb of points (in dust radius and wavelength) contained in datafile
   ! -------------------------------------------------------------------------------------
   OPEN (iwrtmp, file=fichier, status='old')
   READ (iwrtmp,'(3/,i4,2e10.3)') np_r, r_min, r_max
   READ (iwrtmp,*)                np_w
   IF (np_r /= nptmax) THEN
      PRINT *, " !!! WRONG number of radii !!!"
      STOP
   ENDIF
   IF (np_w /= npwmax) THEN
      PRINT *, " !!! WRONG number of wavelengths !!!"
      STOP
   ENDIF

   ! -------------------------------------------------------------------------------------
   ! Read dust properties in the datafile (graphite and silicate)
   ! -------------------------------------------------------------------------------------
   DO i = 1, np_r
      READ (iwrtmp,*) radgr(i)
      READ (iwrtmp,*)
      DO j = np_w, 1, -1
         READ (iwrtmp,*) wavgrd(j), Qabs_Gra(i,j), Qsca_Gra(i,j), g_Gra(i,j) &
                  , toto, Qabs_Sil(i,j), Qsca_Sil(i,j), g_Sil(i,j)
         IF (toto /= wavgrd(j)) THEN
            PRINT *, " pb lecture!"
         ENDIF
      ENDDO
   ENDDO
   CLOSE(iwrtmp)
   radgr(:)  = radgr(:) * 1.0e-4_dp ! Convert from micrometer to cm
   wavgrd(:) = wavgrd(:) * 1.0e4_dp ! Convert from micrometer to Angstrom

   !======================================================================================
   !             READING HEAT CAPACITIES IN FILE: Mix_hcapa_BG_10_2013
   !======================================================================================

   fichier = TRIM(data_dir)//'Grains/Mix_hcapa_BG_10_2013.dat'
   WRITE (iscrn,*) "    * Read heat capacities from a mix of dustem's data: "//TRIM(fichier)

   ! -------------------------------------------------------------------------------------
   ! Read and test the nb of points (in temperature) contained in datafile
   ! -------------------------------------------------------------------------------------
   OPEN (iwrtmp, file=fichier, status='old')
   READ (iwrtmp,*) np_t
   READ (iwrtmp,*)
   IF (np_t /= ntemax) THEN
      PRINT *, " !!! WRONG number of temperatures !!!"
      STOP
   ENDIF

   ! -------------------------------------------------------------------------------------
   ! Read heat capacities in the datafile  (graphite and silicate)
   ! -------------------------------------------------------------------------------------
   DO i = 1, np_r
      READ (iwrtmp,*) radgr_hc(i)
      radgr_hc(i) = radgr_hc(i) * 1.0e-4_dp ! Convert from micrometer to cm
!     IF(radgr_hc(i) /= radgr(i)) THEN
      IF(ABS(radgr_hc(i) - radgr(i))/radgr(i) > 1.0e-10_dp) THEN
         PRINT *, "grains radii in Mix_hcapa_BG_10_2013.dat differ from those in Mix_Qcoef_BG_10_2013.dat"
         STOP
      ENDIF
      READ (iwrtmp,*)
      DO j = 1, np_t
         READ (iwrtmp,*) tempgrd(j), Cheat_Gra(i,j), Cheat_Sil(i,j)
      ENDDO
      READ(iwrtmp,*)
      ! multiply by the grain volume
      Cheat_Gra(i,:) = Cheat_Gra(i,:) * 4.0_dp/3.0_dp * xpi * radgr(i)**3.0_dp
      Cheat_Sil(i,:) = Cheat_Sil(i,:) * 4.0_dp/3.0_dp * xpi * radgr(i)**3.0_dp
   ENDDO
   CLOSE(iwrtmp)

END SUBROUTINE READ_DRAINE_FILES

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
REAL(KIND=dp)  FUNCTION Q_inter(Qx,x,a,i0)
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

   IMPLICIT NONE

   REAL(KIND=dp), DIMENSION(:), INTENT (IN)               :: Qx
   REAL(KIND=dp), DIMENSION(:), INTENT (IN)               :: x
   REAL(KIND=dp), INTENT (IN)                             :: a
   INTEGER, INTENT (IN)                                   :: i0

   !Bug - found by Marcellino - 28 II 2012
   !Q_inter = Qx(i0) + (Qx(i0+1)-Qx(i0)) * ((x(i0+1)-a) / (x(i0+1)-x(i0)))
   Q_inter = Qx(i0) + (Qx(i0+1)-Qx(i0)) * ((a-x(i0)) / (x(i0+1)-x(i0)))

END FUNCTION Q_inter

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
SUBROUTINE MIXGRSI (wlmin, wlmax)
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

   USE PXDR_FLAGS
   USE PXDR_CONSTANTES
   USE PXDR_PROFIL
   USE PXDR_AUXILIAR
   USE PXDR_STR_DATA

   IMPLICIT NONE

   REAL (KIND=dp), INTENT (IN) :: wlmin, wlmax
   INTEGER                     :: jmin, jmax
   REAL (KIND=dp)              :: Qg1, Qg2, Qs1, Qs2
   INTEGER                     :: i0, i, j, mm
   INTEGER                     :: il1, il2
   REAL (KIND=dp)              :: pente

   WRITE (iscrn,*) "    * Mix grains properties"
   ! Find range in wavelength grid
   jmin = 0
   jmax = 0
   DO i = 1, np_w-1
      IF (wavgrd(i) <= wlmin .AND. wavgrd(i+1) > wlmin) THEN
         jmin = i
      ENDIF
      IF (wavgrd(i) <= wlmax .AND. wavgrd(i+1) > wlmax) THEN
         jmax = i
         EXIT
      ENDIF
   ENDDO
   IF (jmax == 0) THEN
      jmax = np_w
      wavgrd(np_w+1) = wlmax
      pente = LOG(Qabs_Gra(1,np_w)/Qabs_Gra(1,np_w-1)) / LOG(wavgrd(np_w)/wavgrd(np_w-1))
      Qabs_Gra(:,np_w+1) = Qabs_Gra(:,np_w) * (wlmax/wavgrd(np_w))**pente
      pente = LOG(Qsca_Gra(1,np_w)/Qsca_Gra(1,np_w-1)) / LOG(wavgrd(np_w)/wavgrd(np_w-1))
      Qsca_Gra(:,np_w+1) = Qsca_Gra(:,np_w) * (wlmax/wavgrd(np_w))**pente
      ! -----------------------------------------
      ! problem with the following extrapolation
      ! g badly extrapolated for large Gra grains
      ! no need for a complex function since only
      ! one point - Rayleigh's diffusion g->0
      ! BG 04/2013
      ! -----------------------------------------
      ! g_Gra(:,np_w+1) = g_Gra(:,np_w)
      g_Gra(:,np_w+1) = 0.0_dp
      pente = LOG(Qabs_Sil(1,np_w)/Qabs_Sil(1,np_w-1)) / LOG(wavgrd(np_w)/wavgrd(np_w-1))
      Qabs_Sil(:,np_w+1) = Qabs_Sil(:,np_w) * (wlmax/wavgrd(np_w))**pente
      pente = LOG(Qsca_Sil(1,np_w)/Qsca_Sil(1,np_w-1)) / LOG(wavgrd(np_w)/wavgrd(np_w-1))
      Qsca_Sil(:,np_w+1) = Qsca_Sil(:,np_w) * (wlmax/wavgrd(np_w))**pente
      ! -----------------------------------------
      ! problem with the following extrapolation
      ! g badly extrapolated for large Sil grains
      ! no need for a complex function since only
      ! one point - Rayleigh's diffusion g->0
      ! BG 04/2013
      ! -----------------------------------------
      ! g_Sil(:,np_w+1) = g_Sil(:,np_w)
      g_Sil(:,np_w+1) = 0.0_dp
   ENDIF
   ! If wavgrd(jmin) < wlmin, we interpolate to it to avoid any point below
   ! See version 1.6 for wavelength below wl_lym 
   IF (wavgrd(jmin) < wlmin) THEN
      pente = (wavgrd(jmin+1) - wlmin) / (wavgrd(jmin+1) - wavgrd(jmin))
      Qabs_Gra(:,jmin) = Qabs_Gra(:,jmin) + (Qabs_Gra(:,jmin+1) - Qabs_Gra(:,jmin)) * pente
      Qsca_Gra(:,jmin) = Qsca_Gra(:,jmin) + (Qsca_Gra(:,jmin+1) - Qsca_Gra(:,jmin)) * pente
      g_Gra(:,jmin) = g_Gra(:,jmin) + (g_Gra(:,jmin+1) - g_Gra(:,jmin)) * pente
      Qabs_Sil(:,jmin) = Qabs_Sil(:,jmin) + (Qabs_Sil(:,jmin+1) - Qabs_Sil(:,jmin)) * pente
      Qsca_Sil(:,jmin) = Qsca_Sil(:,jmin) + (Qsca_Sil(:,jmin+1) - Qsca_Sil(:,jmin)) * pente
      g_Sil(:,jmin) = g_Sil(:,jmin) + (g_Sil(:,jmin+1) - g_Sil(:,jmin)) * pente
      wavgrd(jmin) = wlmin
   ENDIF

   ALLOCATE (Qabs_Dr(jmin:jmax+1,npg))
   ALLOCATE (Qsca_Dr(jmin:jmax+1,npg))
   ALLOCATE (g_Dr   (jmin:jmax+1,npg))
   ALLOCATE (Qabs_FM(jmin:jmax+1,npg))
   ALLOCATE (Qsca_FM(jmin:jmax+1,npg))
   ALLOCATE (Qabs_Du(jmin:jmax+1,npg))
   ALLOCATE (Qsca_Du(jmin:jmax+1,npg))
   ALLOCATE (Q_abs  (jmin:jmax+1,npg))
   ALLOCATE (Q_emi  (jmin:jmax+1,npg))
   Qabs_Dr = 0.0_dp
   Qsca_Dr = 0.0_dp
   g_Dr    = 0.0_dp
   Qabs_FM = 0.0_dp
   Qsca_FM = 0.0_dp
   Qabs_Du = 0.0_dp
   Qsca_Du = 0.0_dp
   Q_abs   = 0.0_dp
   Q_emi   = 0.0_dp

   DO mm = 1, npg
      IF (adust(mm) < radgr(1) .OR. adust(mm) > radgr(np_r)) THEN
         PRINT *, " Radius out of range:", mm, adust(mm), radgr(1), " -", radgr(np_r)
         STOP
      ENDIF

      i0 = 1
      DO
         IF (radgr(i0+1) > adust(mm) .AND. radgr(i0) <= adust(mm)) THEN
            EXIT
         ENDIF
         i0 = i0 + 1
      ENDDO

      ! Absorption ---------------------------------------
      !---------------------------------------------------
      Qg1 = Q_inter(Qabs_Gra(:,jmin)  ,radgr,adust(mm),i0)
      Qg2 = Q_inter(Qabs_Gra(:,jmin+1),radgr,adust(mm),i0)
      Qs1 = Q_inter(Qabs_Sil(:,jmin)  ,radgr,adust(mm),i0)
      Qs2 = Q_inter(Qabs_Sil(:,jmin+1),radgr,adust(mm),i0)
      Qabs_Dr(jmin,mm) = (1.0_dp-amix) * (Qg1 + (Qg2-Qg1) * (wlmin-wavgrd(jmin)) / (wavgrd(jmin+1)-wavgrd(jmin))) &
                       +         amix  * (Qs1 + (Qs2-Qs1) * (wlmin-wavgrd(jmin)) / (wavgrd(jmin+1)-wavgrd(jmin)))
      DO j = jmin+1, jmax
         Qg1 = Q_inter(Qabs_Gra(:,j),radgr,adust(mm),i0)
         Qs1 = Q_inter(Qabs_Sil(:,j),radgr,adust(mm),i0)
         Qabs_Dr(j,mm) = (1.0_dp-amix) * Qg1 + amix * Qs1
      ENDDO
      Qg1 = Q_inter(Qabs_Gra(:,jmax)  ,radgr,adust(mm),i0)
      Qg2 = Q_inter(Qabs_Gra(:,jmax+1),radgr,adust(mm),i0)
      Qs1 = Q_inter(Qabs_Sil(:,jmax)  ,radgr,adust(mm),i0)
      Qs2 = Q_inter(Qabs_Sil(:,jmax+1),radgr,adust(mm),i0)
      Qabs_Dr(jmax+1,mm) = (1.0_dp-amix) * (Qg1 + (Qg2-Qg1) * (wlmax-wavgrd(jmax)) / (wavgrd(jmax+1)-wavgrd(jmax))) &
                         +         amix  * (Qs1 + (Qs2-Qs1) * (wlmax-wavgrd(jmax)) / (wavgrd(jmax+1)-wavgrd(jmax)))

      ! Scattering ---------------------------------------
      !---------------------------------------------------
      Qg1 = Q_inter(Qsca_Gra(:,jmin)  ,radgr,adust(mm),i0)
      Qg2 = Q_inter(Qsca_Gra(:,jmin+1),radgr,adust(mm),i0)
      Qs1 = Q_inter(Qsca_Sil(:,jmin)  ,radgr,adust(mm),i0)
      Qs2 = Q_inter(Qsca_Sil(:,jmin+1),radgr,adust(mm),i0)
      Qsca_Dr(jmin,mm) = (1.0_dp-amix) * (Qg1 + (Qg2-Qg1) * (wlmin-wavgrd(jmin)) / (wavgrd(jmin+1)-wavgrd(jmin))) &
                       +         amix  * (Qs1 + (Qs2-Qs1) * (wlmin-wavgrd(jmin)) / (wavgrd(jmin+1)-wavgrd(jmin)))
      DO j = jmin+1, jmax
         Qg1 = Q_inter(Qsca_Gra(:,j),radgr,adust(mm),i0)
         Qs1 = Q_inter(Qsca_Sil(:,j),radgr,adust(mm),i0)
         Qsca_Dr(j,mm) = (1.0_dp-amix) * Qg1 + amix * Qs1
      ENDDO
      Qg1 = Q_inter(Qsca_Gra(:,jmax)  ,radgr,adust(mm),i0)
      Qg2 = Q_inter(Qsca_Gra(:,jmax+1),radgr,adust(mm),i0)
      Qs1 = Q_inter(Qsca_Sil(:,jmax)  ,radgr,adust(mm),i0)
      Qs2 = Q_inter(Qsca_Sil(:,jmax+1),radgr,adust(mm),i0)
      Qsca_Dr(jmax+1,mm) = (1.0_dp-amix) * (Qg1 + (Qg2-Qg1) * (wlmax-wavgrd(jmax)) / (wavgrd(jmax+1)-wavgrd(jmax))) &
                         +         amix  * (Qs1 + (Qs2-Qs1) * (wlmax-wavgrd(jmax)) / (wavgrd(jmax+1)-wavgrd(jmax)))

      ! Anisotropy factor --------------------------------
      !---------------------------------------------------
      Qg1 = Q_inter(g_Gra(:,jmin)  ,radgr,adust(mm),i0)
      Qg2 = Q_inter(g_Gra(:,jmin+1),radgr,adust(mm),i0)
      Qs1 = Q_inter(g_Sil(:,jmin)  ,radgr,adust(mm),i0)
      Qs2 = Q_inter(g_Sil(:,jmin+1),radgr,adust(mm),i0)
      g_Dr(jmin,mm) = (1.0_dp-amix) * (Qg1 + (Qg2-Qg1) * (wlmin-wavgrd(jmin)) / (wavgrd(jmin+1)-wavgrd(jmin))) &
                    +         amix  * (Qs1 + (Qs2-Qs1) * (wlmin-wavgrd(jmin)) / (wavgrd(jmin+1)-wavgrd(jmin)))
      DO j = jmin+1, jmax
         Qg1 = Q_inter(g_Gra(:,j),radgr,adust(mm),i0)
         Qs1 = Q_inter(g_Sil(:,j),radgr,adust(mm),i0)
         g_Dr(j,mm) = (1.0_dp-amix) * Qg1 + amix * Qs1
      ENDDO
      Qg1 = Q_inter(g_Gra(:,jmax)  ,radgr,adust(mm),i0)
      Qg2 = Q_inter(g_Gra(:,jmax+1),radgr,adust(mm),i0)
      Qs1 = Q_inter(g_Sil(:,jmax)  ,radgr,adust(mm),i0)
      Qs2 = Q_inter(g_Sil(:,jmax+1),radgr,adust(mm),i0)
      g_Dr(jmax+1,mm) = (1.0_dp-amix) * (Qg1 + (Qg2-Qg1) * (wlmax-wavgrd(jmax)) / (wavgrd(jmax+1)-wavgrd(jmax))) &
                      +         amix  * (Qs1 + (Qs2-Qs1) * (wlmax-wavgrd(jmax)) / (wavgrd(jmax+1)-wavgrd(jmax)))
   ENDDO

   jwlmin_gr = jmin
   jwlmax_gr = jmax

   ! -------------------------------------------------------------------------------------
   ! Interpolate heat capacities on both the temperature grid and the size grid of grains
   ! -------------------------------------------------------------------------------------
   ALLOCATE (Cheat_Dr(nTd,npg))
   ALLOCATE (Cheat_FM(nTd,npg))
   ALLOCATE (Cheat_Du(nTd,npg))
   Cheat_Dr = 0.0_dp
   Cheat_FM = 0.0_dp
   Cheat_Du = 0.0_dp
   il1 = 1
   DO mm = 1, npg
      il2 = 1
      DO j = 1, nTd
         CALL INTERP_BILIN_GEN ( LOG(adust(mm)), LOG(Tdposs(j)), il1, il2, LOG(radgr), 1, np_r, &
                               & LOG(tempgrd), 1, np_t, LOG(Cheat_Gra(1:np_r,1:np_t)),Qg1)
         CALL INTERP_BILIN_GEN ( LOG(adust(mm)), LOG(Tdposs(j)), il1, il2, LOG(radgr), 1, np_r, &
                               & LOG(tempgrd), 1, np_t, LOG(Cheat_Sil(1:np_r,1:np_t)),Qs1)
         Qg1 = EXP(Qg1)
         Qs1 = EXP(Qs1)
         Cheat_Dr(j,mm) = (1.0_dp-amix) * Qg1 + amix * Qs1
      ENDDO
   ENDDO
   Cheat_FM = Cheat_Dr

   ! -------------------------------------------------------------------------------------
   ! Compute the dust energy & wavlgth grids based on heat capacities and temperature grid
   ! -------------------------------------------------------------------------------------
   Edposs(:,:) = 0.0_dp
   DO mm = 1, npg
      Edposs(mm,1) = Cheat_Dr(1,mm) * Tdposs(1)/2.0_dp
      DO j = 2, nTd
         Edposs(mm,j) = Edposs(mm,j-1) + (Cheat_Dr(j-1,mm)+Cheat_Dr(j,mm))*(Tdposs(j)-Tdposs(j-1))/2.0_dp
      ENDDO
   ENDDO
   DO mm = 1, npg
      DO j = 2, nTd-1
         D_Edposs(j,mm) = (Edposs(mm,j+1) - Edposs(mm,j-1)) * 0.5_dp
      ENDDO
   ENDDO
   ldposs(:,:) = xhp * clum / Edposs(:,:) * 1.e8_dp

END SUBROUTINE MIXGRSI

END MODULE PXDR_DRAINE_DUST

