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

!%%%%%%%%%%%
PROGRAM rf
!%%%%%%%%%%%

  IMPLICIT NONE
  INTEGER, PARAMETER                           :: dp = SELECTED_REAL_KIND(P=15)
  CHARACTER (len=255)                          :: fichier, fichout
  INTEGER                                      :: nwl       ! Number of points in the wavelength grid
  INTEGER                                      :: nav       ! Number of points in the AV grid
  INTEGER                                      :: n, i, ii
  INTEGER                                      :: n1, n2
  REAL (kind=dp), ALLOCATABLE, DIMENSION (:)   :: wl
  REAL (kind=dp), ALLOCATABLE, DIMENSION (:)   :: av
  REAL (kind=dp)                               :: av0, wl0
  INTEGER                                      :: iscal
  REAL (kind=dp), ALLOCATABLE, DIMENSION (:,:) :: urf       ! Energy density (erg cm-3 Ang-1)
  REAL (kind=dp), ALLOCATABLE, DIMENSION (:,:) :: albed     ! Albedo
  REAL (kind=dp), ALLOCATABLE, DIMENSION (:,:) :: g_absL

  PRINT *, " file name?"
  READ *, fichier
  OPEN(44, FILE=fichier, STATUS="unknown", FORM = 'unformatted')
  PRINT *, TRIM(fichier)//" opened"

  READ (44) nwl
  PRINT *, nwl, " points in the wavelength grid"

  ALLOCATE (wl(nwl))
  READ (44) wl

  nav = 0
  DO
     READ (44, END=100) av0, wl
     nav = nav + 1
  END DO
100 CLOSE (44)

  PRINT *,nav," points in the Av grid"

  ALLOCATE (urf(nav,nwl))
  ALLOCATE (albed(nav,nwl))
  ALLOCATE (g_absL(nav,nwl))
  ALLOCATE (av(nav))

  OPEN(44, FILE=fichier, STATUS="unknown", FORM = 'unformatted')
  READ (44) nwl
  READ (44) wl
  DO n=1,nav
     READ (44, END=100) av(n), urf(n,:), albed(n,:), g_absL(n,:)
     !PRINT *,n, av(n)
  END DO

  CLOSE (44)

  PRINT *, " Which graph?"
  PRINT *, " 1 - Av"
  PRINT *, " 2 - WL"
  PRINT *, " 3 - 2D"
  PRINT *, " 4 - ISRF in Dustem format"
  READ *, ii

  SELECT CASE (ii)
  CASE (1)
     PRINT *, " Enter Av:"
     READ *, av0
     DO n = 1, nav
        IF (av(n) > av0) EXIT
     END DO
     n = n - 1
     fichout = "rf_out_Av_"//R_to_C(av0)//".dat"
     print *, fichout
     OPEN (10, FILE=fichout, STATUS="unknown")
     WRITE (10, '("# Av =",1pe16.8)') av(n)
     DO i = 1, nwl
        WRITE (10,'(1P,4e16.7e3)') wl(i), urf(n,i), albed(n,i), g_absL(n,i)
     END DO
     CLOSE (10)

  CASE (2)
     PRINT *, " Enter Wavelength (Ang):"
     READ *, wl0
     DO n = 1, nwl
        IF (wl(n) > wl0) EXIT
     END DO
     n = n - 1
     fichout = "rf_out_WL_"//R_to_C(wl0)//".dat"
     print *, fichout
     OPEN (10, FILE=fichout, STATUS="unknown")
     WRITE (10, '("# WL =",1pe16.8)') wl(n)
     DO i = 1, nav
        WRITE (10,'(1P,4e16.7e3)') av(i), urf(i,n), albed(i,n), g_absL(i,n)
     END DO
     CLOSE (10)

  CASE (3)
     PRINT *, " Enter Wave Length min:"
     READ *, wl0
     DO n = 1, nwl
        IF (wl(n) > wl0) EXIT
     END DO
     n1 = n - 1
     PRINT *, " Enter Wave Length max:"
     READ *, wl0
     DO n = 1, nwl
        IF (wl(n) > wl0) EXIT
     END DO
     n2 = n - 1
     PRINT *, " Scaling of R.F.?(1: yes, 0: no)"
     READ *, iscal
     fichout = "rf_out_2D.dat"
     print *, fichout
     OPEN (10, FILE=fichout, STATUS="unknown")
     DO n = n1, n2
        IF (iscal == 1) THEN
           DO i = 1, nav
              WRITE (10,'(1P,5e16.7e3)') av(i), wl(n), urf(i,n)/urf(i,n1), albed(i,n), g_absL(i,n)
           END DO
        ELSE
           DO i = 1, nav
              WRITE (10,'(1P,5e16.7e3)') av(i), wl(n), urf(i,n), albed(i,n), g_absL(i,n)
           END DO
        ENDIF
        WRITE (10, '(" ")')
     END DO
     CLOSE (10)

  CASE (4)
     !------------------------------------------------------------------------------------
     ! Export radiation field for DustEM
     ! DustEM uses I_nu in erg cm-2 s-1 Hz-1
     ! I_nu (erg cm-2 s-1 Hz-1) = urf (erg cm-3 Ang-1) * lambda**2 (Ang) * 1E-8
     !------------------------------------------------------------------------------------
     PRINT *, " Enter Av:"
     READ *, av0
     DO n=1,nav
        IF (av(n) > av0) EXIT
     END DO
     n = n - 1
     OPEN (10, FILE="ISRF.dat", STATUS="unknown")
     WRITE (10, '("# -----------------------------------------------------")') 
     WRITE (10, '("# Incident spectrum extracted from the Meudon PDR code")')
     WRITE (10, '("#")')
     WRITE (10, '("# Radiation field extracted at Av = ",1pe16.8)') av(n)
     WRITE (10, '("# Wavelength in microns, I_nu in erg cm-2 s-1 Hz-1")')
     WRITE (10, '("# -----------------------------------------------------")')
     WRITE (10, '(I10)') nwl
     DO i = 1, nwl
        IF (wl(i) >= 911.0_dp) THEN
           WRITE (10,'(1P,2e16.7e3)') wl(i)*1.0e-4_dp, urf(n,i)*1.0e-8_dp * wl(i)**2
        ENDIF
     END DO
     CLOSE (10)

  END SELECT

  DEALLOCATE (wl)
  DEALLOCATE (av)
  DEALLOCATE (urf)
  DEALLOCATE (albed)
  DEALLOCATE (g_absL)

CONTAINS

  CHARACTER (LEN=12) FUNCTION R_to_C(x)

     IMPLICIT NONE
     REAL (KIND=dp), INTENT (IN) :: x
     CHARACTER (LEN=12)          :: c

     WRITE (c,"(1pE12.6)") x

     R_to_C = c

  END FUNCTION R_to_C

END PROGRAM rf

