#define TRACEBACK write (gol,'("in ",a," (",a,i6,")")') rname, __FILE__, __LINE__ ; call goErr #define IF_NOTOK_RETURN(action) if (status/=0) then; TRACEBACK; action; return; end if #define IF_ERROR_RETURN(action) if (status> 0) then; TRACEBACK; action; return; end if ! #include "tm5.inc" ! !----------------------------------------------------------------------------- ! TM5 ! !----------------------------------------------------------------------------- !BOP ! ! !MODULE: OPTICS ! ! !DESCRIPTION: Optics module to calculate optical depth from m7 output, ! based on the AOP_Package op Michael Kahnert. ! ! The optics code should be used in the following way (see ! examples in photolysis.F90, ecearth_optics.F90, and ! user_output_aerocom.F90): ! ! 1) prepare the optics calculation by calling ! 'OPTICS_INIT' --> lookuptables etc. ! this routine reads the wavelengths, lookupable and calculates ! refr. indices at these wavelengths. ! ! 2) allocate AOP arrays aop_out_ext/a/g with ! (n_gridcells, n_wavelengths, n_split), with: ! 'n_split' = 1 for (split == .false.) or ! 'n_split' = 11 for (split == .true. ), ie. ! partial contributions by ! Total, SO4, BC, OC, SS, DU, NO3, Water, Fine, Fine Dust, Fine SS ! additional fields are also provided for split==.true. in ! aop_out_add, which has to have size ! (n_gridcells, n_wavelengths, n_add) with nadd = 2 for ! surface PM10 dry extinction and surface PM10 dry absorption ! 3) Compute AOP for current conditions by calling 'OPTICS_AOP_GET' ! 4) done: 'OPTICS_DONE' ! ! IMPORTANT: *) Skipped the ZOOM options! (temporary) ! *) OC is actually POM. Remember converting OC to POM ! when sending it to optics_calculate_aop !\\ !\\ ! !INTERFACE: ! MODULE OPTICS ! ! !USES: ! use GO, only : gol, goErr, goPr Use mo_aero_m7, only : nmod Use global_data, only : rcfile use GO, only : TrcFile, Init, Done, ReadRc Use Dims, only : nregions IMPLICIT NONE PRIVATE ! ! !PUBLIC MEMBER FUNCTIONS: ! public :: optics_init, optics_done ! init/done methods for a wavelendep object public :: optics_aop_get ! compute aerosol optical properties ! ! !PRIVATE DATA MEMBERS: ! type(TrcFile) :: rcF character(len=256) :: lookuptable, refractive_indices ! ! !PUBLIC TYPES: ! ! wavelength type (to be used by methods using the optics) type, public :: wavelendep real :: wl ! user requested wavelength unit = um (e.g. 0.550) real, dimension(6) :: n ! SO4, BC, OC, SS, DU, WATER real, dimension(6) :: k ! SO4, BC, OC, SS, DU, WATER logical :: split, insitu end type wavelendep ! ! !PRIVATE TYPES: ! ! AOP input type and field type aopi real, dimension(nmod) :: SO4, NO3, BC, OC, SS, DU, H2O, numdens, rg, rgd end type aopi type(aopi), dimension(:), allocatable :: aop_in ! characteristics of the lookup-tables integer, parameter :: n_rii = 15 integer, parameter :: n_rir = 40 integer, parameter :: n_x = 100 real,dimension(n_rii) :: lkval ! -log img part refr. index real,dimension(n_rii) :: kval ! img part refr. index, 10^(-lkval) real,dimension(n_rir) :: n1r ! real part refr. index Real, Dimension(n_x) :: xs Real, Dimension(n_x,n_rir,n_rii),Target :: cext_159, a_159, g_159 real, dimension(n_x,n_rir,n_rii),Target :: cext_200, a_200, g_200 character(len=*), parameter :: mname = 'Optics' ! lookup table information for interpolation to wavelength properties Integer, Parameter :: opacdim = 61 ! Wavelength dimension of OPAC data Integer, Parameter :: echamhamdim = 49 ! Wavelength dimension of ECHAM-HAM data Integer, Parameter :: segelsteindim = 1261 ! Wavelength dimension of Segelstein data Real, Dimension(:,:), allocatable :: opac, echamham, segelstein ! ! !REVISION HISTORY: ! Implemented by Maarten Krol 03/2009 ! Extended by Joost Aan de Brugh ! ! 6 Feb 2011 - Achim Strunk - complete revision ! - worked on DECOUPLING optics routines ! from (optics)_output, in order to ! (re)establish a flexible way of using it ! - remaining parts have been moved to ! (the new routine) user_output_optics ! ! 24 Jun 2011 - Achim Strunk - added NO3 explicitly in order to allow ! for a slightly better split of the ! optical properties of (SO4+NO3) ! 20 Jun 2012 - P. Le Sager - adapted for lon-lat MPI domain decomposition ! ! !REMARKS: ! !EOP !------------------------------------------------------------------------ CONTAINS !-------------------------------------------------------------------------- ! TM5 ! !-------------------------------------------------------------------------- !BOP ! ! !IROUTINE: OPTICS_INIT ! ! !DESCRIPTION: Initialize a wavelendep object: Input/lookuptables are ! opened and read in, and wavelength dependent parameters are ! calculated. !\\ !\\ ! !INTERFACE: ! SUBROUTINE OPTICS_INIT( nwav, wdep, status ) ! ! !USES: ! USE MDF, ONLY : MDF_OPEN, MDF_NETCDF, MDF_READ, MDF_Get_Var, MDF_Close, MDF_Inq_VarID ! ! !INPUT PARAMETERS: ! integer, intent(in) :: nwav ! ! !OUTPUT PARAMETERS: ! type(wavelendep), dimension(nwav), intent(inout) :: wdep integer, intent(out) :: status ! ! !REMARKS: read by each core (FIXME?) ! !EOP !------------------------------------------------------------------------ !BOC integer :: fid, varid, i character(len=*), parameter :: rname = mname//'/Optics_Init' ! --- begin -------------------------------- allocate( opac (7, opacdim ) ) allocate( echamham (5, echamhamdim ) ) allocate( segelstein(3, segelsteindim) ) ! get filenames from rcfile call Init( rcF, rcfile, status ) IF_NOTOK_RETURN(status=1) call ReadRc( rcF, 'optics.lookuptable', lookuptable, status ) IF_NOTOK_RETURN(status=1) call ReadRc( rcF, 'optics.refractive_indices', refractive_indices, status ) IF_NOTOK_RETURN(status=1) ! read lookup table CALL MDF_Open( TRIM(lookuptable), MDF_NETCDF, MDF_READ, fid, status ) IF_NOTOK_RETURN(status=1) CALL MDF_Inq_VarID( fid, 'mr', varid, status ) IF_NOTOK_RETURN(status=1) CALL MDF_Get_Var( fid, varid, n1r, status ) IF_NOTOK_RETURN(status=1) CALL MDF_Inq_VarID( fid, 'mi', varid, status ) IF_NOTOK_RETURN(status=1) CALL MDF_Get_Var( fid, varid, kval, status ) IF_NOTOK_RETURN(status=1) lkval = -log10(kval) CALL MDF_Inq_VarID( fid, 'x', varid, status ) IF_NOTOK_RETURN(status=1) CALL MDF_Get_Var( fid, varid, xs, status ) IF_NOTOK_RETURN(status=1) CALL MDF_Inq_VarID( fid, 'ext_159', varid, status ) IF_NOTOK_RETURN(status=1) CALL MDF_Get_Var( fid, varid, cext_159, status ) IF_NOTOK_RETURN(status=1) CALL MDF_Inq_VarID( fid, 'ext_200', varid, status ) IF_NOTOK_RETURN(status=1) CALL MDF_Get_Var( fid, varid, cext_200, status ) IF_NOTOK_RETURN(status=1) CALL MDF_Inq_VarID( fid, 'a_159', varid, status ) IF_NOTOK_RETURN(status=1) CALL MDF_Get_Var( fid, varid, a_159, status ) IF_NOTOK_RETURN(status=1) CALL MDF_Inq_VarID( fid, 'a_200', varid, status ) IF_NOTOK_RETURN(status=1) CALL MDF_Get_Var( fid, varid, a_200, status ) IF_NOTOK_RETURN(status=1) CALL MDF_Inq_VarID( fid, 'g_159', varid, status ) IF_NOTOK_RETURN(status=1) CALL MDF_Get_Var( fid, varid, g_159, status ) IF_NOTOK_RETURN(status=1) CALL MDF_Inq_VarID( fid, 'g_200', varid, status ) IF_NOTOK_RETURN(status=1) CALL MDF_Get_Var( fid, varid, g_200, status ) IF_NOTOK_RETURN(status=1) CALL MDF_Close( fid, status ) IF_NOTOK_RETURN(status=1) ! Read refractive indices CALL MDF_Open( TRIM(refractive_indices), MDF_NETCDF, MDF_READ, fid, status ) IF_NOTOK_RETURN(status=1) ! Get Opac data CALL MDF_Inq_VarID( fid, 'Opac', varid, status ) IF_NOTOK_RETURN(status=1) CALL MDF_Get_Var( fid, varid, opac, status ) IF_NOTOK_RETURN(status=1) ! Get ECHAM-HAM data CALL MDF_Inq_VarID( fid, 'ECHAM-HAM', varid, status ) IF_NOTOK_RETURN(status=1) CALL MDF_Get_Var( fid, varid, echamham, status ) IF_NOTOK_RETURN(status=1) ! Get Segelstein data CALL MDF_Inq_VarID( fid, 'Segelstein', varid, status ) IF_NOTOK_RETURN(status=1) CALL MDF_Get_Var( fid, varid, segelstein, status ) IF_NOTOK_RETURN(status=1) CALL MDF_Close( fid, status ) IF_NOTOK_RETURN(status=1) call optics_wavelen_init( wdep, status ) IF_ERROR_RETURN( status=1 ) write(gol,*) 'Optical parameters:'; call goPr do i = 1, nwav write(gol,*) 'Wavelength :', wdep(i)%wl ; call goPr write(gol,*) ' SO4 (real/img) :', wdep(i)%n(1), wdep(i)%k(1) ; call goPr write(gol,*) ' BC (real/img) :', wdep(i)%n(2), wdep(i)%k(2) ; call goPr write(gol,*) ' OC (real/img) :', wdep(i)%n(3), wdep(i)%k(3) ; call goPr write(gol,*) ' SS (real/img) :', wdep(i)%n(4), wdep(i)%k(4) ; call goPr write(gol,*) ' DU (real/img) :', wdep(i)%n(5), wdep(i)%k(5) ; call goPr write(gol,*) ' H2O (real/img) :', wdep(i)%n(6), wdep(i)%k(6) ; call goPr enddo ! Done ! ------------- call Done( rcF, status ) IF_NOTOK_RETURN(status=1) deallocate( opac, echamham, segelstein ) status = 0 END SUBROUTINE OPTICS_INIT !EOC !-------------------------------------------------------------------------- ! TM5 ! !-------------------------------------------------------------------------- !BOP ! ! !IROUTINE: OPTICS_DONE ! ! !DESCRIPTION: dummy for now !\\ !\\ ! !INTERFACE: ! SUBROUTINE OPTICS_DONE( status ) ! ! !OUTPUT PARAMETERS: ! integer, intent(out) :: status ! ! !REVISION HISTORY: ! 6 Feb 2011 - Achim Strunk - ! ! !REMARKS: ! !EOP !------------------------------------------------------------------------ !BOC ! ok status = 0 END SUBROUTINE OPTICS_DONE !EOC !-------------------------------------------------------------------------- ! TM5 ! !-------------------------------------------------------------------------- !BOP ! ! !IROUTINE: OPTICS_WAVELEN_INIT ! ! !DESCRIPTION: Initialise parameters which are depending on given ! wavelengths. !\\ !\\ ! !INTERFACE: ! SUBROUTINE OPTICS_WAVELEN_INIT( wdep, status ) ! ! !INPUT/OUTPUT PARAMETERS: ! ! wavelength properties (wavelength itself and real/img part of refractive index) type(wavelendep), intent(inout), dimension(:) :: wdep ! ! !OUTPUT PARAMETERS: ! integer, intent(out) :: status ! ! !REVISION HISTORY: ! 6 Feb 2011 - Achim Strunk - ! ! !REMARKS: ! !EOP !------------------------------------------------------------------------ !BOC character(len=*), parameter :: rname = mname//'/optics_wavelen_init' integer :: nwl, i, idx real :: wl, h real :: nscale, kscale ! Real part n and imaginary part k of refractive index ! for each wavelength: !>>> TvN ! The refractive index for 'sulfate' is taken from ! the OPAC database (Hess et al., 1998; ! Koepke et al., MPI report no. 243, 1997). ! The value used is that of 'sulfate solution', ! i.e. particles consisting of 75% of sulfuric acid (H2SO4), ! based on Fenn et al. (chapter 18 in Handbook of Geophysics ! and Space Environment, 1985). ! This is in line with Kinne et al. (JGR, 2003), ! who write that refractive indices for sulfate ! are usually based on 75% sulfuric acid solution. ! Actually, the OPAC refractive index agrees very well ! with the expression given by Boucher and Anderson (JGR, 1995) ! for H2SO4 at visible wavelengths. ! Thus, the OPAC data can be considered to apply to pure H2SO4, ! which is consistent of our application of mixing rules. ! For BC, the OPAC refractive index is scaled to one of ! the values proposed by Bond and Bergstrom (2006), ! valid at 550 nm (see their Table 5). ! Selected values for high, medium and low absorption are ! 1.95 + 0.79 i, 1.85 + 0.71 i, and 1.75 + 0.63 i, respectively. ! We select the low-absorption value, ! because it produces results in best agreement ! with AAOD from MODIS Collection 6 Deep Blue. ! Note that the medium-absorption value 1.85 + 0.71 i ! was used in ECHAM simulations by Stier et al. (2007), ! and found to give reasonable results. ! Lowenthal et al. (Atmos. Environ., 2000) ! give a value of 1.90 + 0.6 i. ! The reference value used in the scaling ! is the OPAC value at 550 nm: 1.75 + 0.44 i. ! It would be better to include the scaling ! in the input file. !nscale = 1.0 ! for using OPAC !kscale = 1.0 ! for using OPAC !nscale = 1.95/1.75 !kscale = 0.79/0.44 nscale = 1.85/1.75 kscale = 0.71/0.44 !nscale = 1.75/1.75 !kscale = 0.63/0.44 !<<< TvN nwl = size(wdep) do i = 1, nwl wl = wdep(i)%wl ! Interpolate Opac data findOpac: Do idx = 1,opacdim If(opac(1,idx) .gt. wl) exit findOpac End Do findOpac If(idx .gt. opacdim) then idx = opacdim h = 1.0 Else If(idx .eq. 1) then idx = 2 h = 0.0 Else h = (wl-opac(1,idx-1))/(opac(1,idx)-opac(1,idx-1)) End If ! SO4 wdep(i)%n(1) = opac(2,idx-1)+h*(opac(2,idx)-opac(2,idx-1)) wdep(i)%k(1) = opac(3,idx-1)+h*(opac(3,idx)-opac(3,idx-1)) ! BC !>>> TvN !wdep(i)%n(2) = opac(4,idx-1)+h*(opac(4,idx)-opac(4,idx-1)) !wdep(i)%k(2) = opac(5,idx-1)+h*(opac(5,idx)-opac(5,idx-1)) wdep(i)%n(2) = nscale * ( opac(4,idx-1)+h*(opac(4,idx)-opac(4,idx-1)) ) wdep(i)%k(2) = kscale * ( opac(5,idx-1)+h*(opac(5,idx)-opac(5,idx-1)) ) !<<< TvN ! SS wdep(i)%n(4) = opac(6,idx-1)+h*(opac(6,idx)-opac(6,idx-1)) wdep(i)%k(4) = opac(7,idx-1)+h*(opac(7,idx)-opac(7,idx-1)) ! Interpolate ECHAM-HAM data findEchamham: Do idx = 1,echamhamdim If(echamham(1,idx) .gt. wl) exit findEchamham End Do findEchamham If(idx .gt. echamhamdim) then idx = echamhamdim h = 1.0 Else If(idx .eq. 1) then idx = 2 h = 0.0 Else h = (wl-echamham(1,idx-1))/(echamham(1,idx)-echamham(1,idx-1)) End If ! OC !>>> TvN ! The 'ECHAM-HAM' data currently used for POM ! are based on the data from Fenn et al. (1985) ! for the 'water soluble' component, ! but at a reduced number of wavelengths up to 15 um. ! It would be better to use the original table ! in the input file. !<<< TvN wdep(i)%n(3) = echamham(2,idx-1)+h*(echamham(2,idx)-echamham(2,idx-1)) wdep(i)%k(3) = echamham(3,idx-1)+h*(echamham(3,idx)-echamham(3,idx-1)) ! DU wdep(i)%n(5) = echamham(4,idx-1)+h*(echamham(4,idx)-echamham(4,idx-1)) wdep(i)%k(5) = echamham(5,idx-1)+h*(echamham(5,idx)-echamham(5,idx-1)) ! Interpolate Segelstein data findSegelstein: Do idx = 1,segelsteindim If(segelstein(1,idx) .gt. wl) exit findSegelstein End Do findSegelstein If(idx .gt. segelsteindim) then idx = segelsteindim h = 1.0 Else If(idx .eq. 1) then idx = 2 h = 0.0 Else h = (wl-segelstein(1,idx-1))/(segelstein(1,idx)-segelstein(1,idx-1)) End If ! H2O wdep(i)%n(6) = segelstein(2,idx-1)+h*(segelstein(2,idx)-segelstein(2,idx-1)) wdep(i)%k(6) = segelstein(3,idx-1)+h*(segelstein(3,idx)-segelstein(3,idx-1)) enddo status=0 END SUBROUTINE OPTICS_WAVELEN_INIT !EOC !-------------------------------------------------------------------------- ! TM5 ! !-------------------------------------------------------------------------- !BOP ! ! !IROUTINE: OPTICS_GET ! ! !DESCRIPTION: Main optical properties routine. Here the interpolated ! values for extinction coefficient, single scattering ! albedo and assymetry parameter are retrieved and returned. !\\ !\\ ! !INTERFACE: ! PURE SUBROUTINE OPTICS_GET(m_eff, xg, Cext, a, g, cext_table, a_table, g_table, status, gol ) ! ! !INPUT PARAMETERS: ! complex, intent(in) :: m_eff real, intent(in) :: xg real, dimension(:,:,:), intent(in) :: cext_table, a_table, g_table ! ! !OUTPUT PARAMETERS: ! real, intent(out) :: Cext, a, g integer, intent(inout) :: status character(len=*), intent(inout) :: gol ! ! !REVISION HISTORY: ! 15 Jul 2010 - P. Le Sager - Added check on i_n (out-of-bound) ! 6 Feb 2011 - Achim Strunk - ! ! !REMARKS: ! - By using "pure" subroutine, we cannot use any of the goPr, goErr, ! IF_NOTOK_RETURN, ... routines. Traceback is limited: ! 1) only one statement can be recorded in variable gol ! 2) the calling routine should issue the "call goErr" ! !EOP !------------------------------------------------------------------------ !BOC real :: n, k, n1, k1, dk1, dk2, lk real :: modrad, modrad1, dr, dr1, slope, cext1, a1, g1 integer :: i integer :: i_n, i_k, i_knew character(len=*), parameter :: rname = mname//'/Optics_Get' ! --- begin -------------------------------- status = 0 n=real(m_eff) k=imag(m_eff) if(k.lt.kval(1))then k1=kval(1) i_knew=1 elseif(k.gt.kval(15))then k1=kval(15) i_knew=15 else get_k: do i=2,15 if(k.lt.kval(i))then dk1=k-kval(i-1) dk2=kval(i)-k if(dk1.le.dk2)then k1=kval(i-1) i_knew=i-1 else k1=kval(i) i_knew=i endif exit get_k endif enddo get_k endif lk=-log10(k1) !#n1=float(int(50*n+0.5))/50. !do i_n = 1, n_rir ! if (abs(n1 - n1r(i_n)) < 1e-4) exit !enddo !i_n = 1 + int((n-1.12)*50+0.5) !AJS: I guess n is a number on the (increasing) n1r axis; search nearest index: i_n = size(n1r) do i = 1, size(n1r) if ( n <= n1r(i) ) then i_n = i exit end if end do if ( i_n > 1 ) then if ( abs(n-n1r(i_n-1)) < abs(n-n1r(i_n)) ) i_n = i_n - 1 else if ( i_n < n_rir ) then if ( abs(n-n1r(i_n+1)) < abs(n-n1r(i_n)) ) i_n = i_n + 1 end if do i_k = 1, n_rii if (abs(lk - lkval(i_k)) < 1e-4) exit enddo ! ! PLS - test : ik can be determined without the preceding loop "do i_k = 1, n_rii" ! if (i_k.ne.i_knew) then ! status = 1 ! write (gol,'(" PLSPLS ik NE iknew = ",2(i2,2x))')i_k,i_knew ! endif ! following the "get_k" loop above, the only way to get into this is to ! have a NaN for k in the first place ? if (i_k > n_rii) then status = 1 write(gol,*)'FATAL ERROR: i_k value outside LUT' ! write (gol,'(" lk = ",E16.4)')lk ! write (gol,'(" k1 = ",E16.4)')k1 ! write (gol,'(" k = ",E16.4)')k ! write (gol,'(" n = ",E16.4)')n ! do i_n = 1, 15 ! write (gol,'(" lkval(",i2,") = ",E16.4)')i_n,lkval(i_n) ! call goPr ! write (gol,'(" kval(",i2,") = ",E16.4)')i_n,kval(i_n) ! call goPr ! enddo return endif ! Added check (15-7-2010 - P. Le Sager) if (i_n > n_rir) then status = 1 write(gol,*)'FATAL ERROR: i_n value out of range' return endif !>>> TvN ! Since xs(1) equals zero a problem may occur when xg is negative, ! because modrad.gt.xg would become true for i=1 in that case, ! while modrad1, Cext1, a1 and g1 are not yet set. ! It is not clear if negative xg values can ever occur, ! but if they do that should be prevented when calculating rg. ! ! However, the problem may perhaps already occur ! when xg equals zero, because of the finite machine precision. ! ! In any case, it is desired to initialize modrad1, Cext1, a1 and g1. ! Cext1, a1 and g1 should be set to their table entries for i=1, ! which are all zero: Cext1 = cext_table(1,i_n,i_k) a1 = a_table(1,i_n,i_k) g1 = g_table(1,i_n,i_k) ! modrad1 can be initialized to any value different from xs(1), ! to prevent division by zero. modrad1=xs(1)-9.99e-4 ! This combination will force slope to zero ! and Cext, a and g to the table entries for i=1 (zero), ! in case modrad.gt.xg is true for i=1. !<<< TvN get_values: do i = 1, n_x modrad = xs(i) a = a_table(i,i_n, i_k) g = g_table(i,i_n, i_k) cext = cext_table(i,i_n, i_k) ! With small concentrations, like in the stratosphere, M7 does not trust its radii. ! See m7_averageproperties -> zinsvol. The M7-radius goes to zero ! Modrad may never be larger than xg the first time. Modrad1 is not set, ! will be zero (or something worse) and dr will be zero (or something worse). ! slope is demolished, makeing all values NaN. Therefore, it is modrad .gt. xg ! instead of modrad .ge. xg ! ! PLS-TRANSLATION - It boils down to: "on the first iteration of this loop, if modrad=xg and ! you go into the if-statement below, you are in trouble, because modrad1 can be ! anything. To prevent that, replace GE with GT to avoid going into the if-statement at the ! first iteration." ! if(modrad.gt.xg)then dr=modrad-modrad1 dr1=xg-modrad1 slope=(Cext-Cext1)/dr Cext=Cext1+slope*dr1 slope=(a-a1)/dr a=a1+slope*dr1 slope=(g-g1)/dr g=g1+slope*dr1 exit get_values endif modrad1=modrad Cext1=Cext a1=a g1=g enddo get_values END SUBROUTINE OPTICS_GET !EOC !-------------------------------------------------------------------------- ! TM5 ! !-------------------------------------------------------------------------- !BOP ! ! !IROUTINE: GET_REFR_IDX ! ! !DESCRIPTION: Compute refractive index of internally mixed aerosols by use ! of effective medium theory for the size-dependent aerosol ! mixtures assumed in M7. !\\ !\\ ! !INTERFACE: ! PURE SUBROUTINE GET_REFR_IDX(wdep, SO4, BC, OC, SS, DU, water, mode, m_eff, status, gol) ! ! !USES: ! use binas, only: rol use chem_param, only: ss_density, dust_density, carbon_density use chem_param, only: pom_density, so4_density ! ! !INPUT PARAMETERS: ! type(wavelendep), intent(in) :: wdep ! wavelength properties (wavelength, re/img part of refractive index) real, intent(in) :: SO4, BC, OC ! mass mixing ratios or concentrations of sulphate, black carbon, organic carbon real, intent(in) :: SS, DU, water ! sea salt, dust, and water integer, intent(in) :: mode ! mode number (M7) ! ! !OUTPUT PARAMETERS: ! complex, intent(out) :: m_eff ! effective refractive index of mixture integer, intent(out) :: status character(len=*), intent(inout) :: gol ! ! !REVISION HISTORY: ! 12 Aug 2008 - Michael Kahnert, SMHI ! 6 Feb 2011 - Achim Strunk - ! ! !REMARKS: ! - see remarks of OPTICS_GET subroutine about PURE routine ! !EOP !------------------------------------------------------------------------ !BOC character(len=*), parameter :: rname = mname//'/get_refr_idx' ! refractive indices complex :: m_SO4, m_BC, m_OC, m_SS, m_DU, m_water ! volume fractions real :: v_SO4, v_BC, v_OC, v_SS, v_DU, v_water, water_iv integer :: i_test real :: vtot, v2 complex :: m00, m0, m1, m2 real :: rpls, ipls ! --- begin -------------------------------- ! Get the refractive indices from the lookup-tables and put them into complex numbers. m_so4 = cmplx( wdep%n(1),wdep%k(1) ) ! H2-SO4 + NH4NO3 m_bc = cmplx( wdep%n(2),wdep%k(2) ) ! BC m_oc = cmplx( wdep%n(3),wdep%k(3) ) ! POM m_ss = cmplx( wdep%n(4),wdep%k(4) ) ! SS m_du = cmplx( wdep%n(5),wdep%k(5) ) ! DU m_water = cmplx( wdep%n(6),wdep%k(6) ) ! Water status = 0 ! no mixing for mode=6,7: if(mode.ge.6)then m_eff=m_DU return endif ! compute volume fractions: v_SO4=0. v_BC=0. v_OC=0. v_SS=0. v_DU=0. v_water=0. vtot=0. ! Added sanity check (15-7-2010 - P. Le Sager) : Avoid negative water ! mixing ratio! ! The bruggeman logically assumes that v_water is between 0 and 1, but ! this is never checked in the call chain : ! ECEarth_Optics_Step -> calculate_aop -> get_refr_idx [here] -> ! Bruggeman ! We do it here, with a warning since it reflects a problem upstream: if(water.lt.0.0)then !write (gol,*)" WARNING - [Get_refr_idx] : negative relative humidity..." ; call goPr !write (gol,*)" WARNING - [Get_refr_idx] : .....set to 0" ; call goPr water_iv=0.0 else water_iv=water endif if(mode.le.4)then v_SO4=SO4/so4_density v_water=water_iv/rol vtot=vtot+v_SO4+v_water endif if(mode.ge.2.and.mode.le.5)then v_BC=BC/carbon_density v_OC=OC/pom_density vtot=vtot+v_BC+v_OC endif if(mode.ge.3.and.mode.le.4)then v_SS=SS/ss_density vtot=vtot+v_SS endif if(mode.ge.3.and.mode.ne.5)then v_DU=DU/dust_density vtot=vtot+v_DU endif ! If vtot is zero, we will get 0.0/0.0's causing NaNs. In that case, the ! refractive index does not matter and will be set to (1.0,1.0e-9). The ! reason not to take (1.0,0.0) is that someone with humour might take ! the logarithm of the imaginary part. Dust particles get their usual ! refractive index, because they already returned m_DU. But that does ! not matter, because there are zero aerosols in this case. If (vtot .eq. 0.0) Then m_eff = Cmplx(1.0,1.0e-9) Else v_SO4=v_SO4/vtot v_BC=v_BC/vtot v_OC=v_OC/vtot v_SS=v_SS/vtot v_DU=v_DU/vtot v_water=v_water/vtot !----------------------------------------------------------------------- ! effective medium computations for each mode !----------------------------------------------------------------------- if(mode.eq.1)then ! Bruggeman mixing rule for SO4 and water: m1=m_SO4 m2=m_water v2=v_water call Bruggeman(m1,m2,v2,m0) elseif(mode.eq.2)then ! iterative Bruggeman mixing rule for SO4, OC, and water: m1=m_SO4 m2=m_OC vtot=v_SO4+v_OC v2=v_OC/vtot call Bruggeman(m1,m2,v2,m00) m1=m00 m2=m_water vtot=vtot+v_water v2=v_water/vtot call Bruggeman(m1,m2,v2,m00) ! Maxwell-Garnett mixing rule for BC inclusions: m1=m00 m2=m_BC v2=v_BC call Maxwell_Garnett(m1,m2,v2,m0) elseif(mode.eq.3.or.mode.eq.4)then ! iterative Bruggeman mixing rule for SO4, OC, SS, and water: m1=m_SO4 m2=m_OC vtot=v_SO4+v_OC if ( vtot < TINY( vtot ) ) then v2=0.0 else v2=v_OC/vtot end if call Bruggeman(m1,m2,v2,m00) m1=m00 m2=m_SS vtot=vtot+v_SS if ( vtot < TINY( vtot ) ) then v2=0.0 else v2=v_SS/vtot end if call Bruggeman(m1,m2,v2,m00) m1=m00 m2=m_water vtot=vtot+v_water v2=v_water/vtot call Bruggeman(m1,m2,v2,m00) ! iterative Maxwell-Garnett mixing rule for BC and dust ! inclusions: m1=m00 m2=m_BC vtot=vtot+v_BC if ( vtot < TINY( vtot ) ) then v2=0.0 else v2=v_BC/vtot end if call Maxwell_Garnett(m1,m2,v2,m00) m1=m00 m2=m_DU v2=v_DU call Maxwell_Garnett(m1,m2,v2,m0) elseif(mode.eq.5)then ! Maxwell-Garnett mixing rule for BC inclusions: m1=m_OC m2=m_BC v2=v_BC call Maxwell_Garnett(m1,m2,v2,m0) endif m_eff = m0 End If ! Debug : trap for a NAN (13-7-2010 - P. Le Sager) rpls=real(m_eff) ipls=imag(m_eff) IF ((rpls.NE.rpls).or.(ipls.NE.ipls)) then status = 1 write (gol,'(" GET_REFR_IDX-NAN: ", 3(E16.4,2x),i4,2x,6(E16.4,2x))') rpls, ipls, vtot, mode,& & SO4,BC,OC,SS,DU,water endif END SUBROUTINE GET_REFR_IDX !EOC !-------------------------------------------------------------------------- ! TM5 ! !-------------------------------------------------------------------------- !BOP ! ! !IROUTINE: BRUGGEMAN ! ! !DESCRIPTION: Compute effective refractive index of a mixture of 2 components ! by use of the Bruggeman mixing rule !\\ !\\ ! !INTERFACE: ! PURE SUBROUTINE BRUGGEMAN(m1,m2,v2,m0) ! ! !INPUT PARAMETERS: ! complex, intent(in) :: m1,m2 real, intent(in) :: v2 ! ! !OUTPUT PARAMETERS: ! complex, intent(out) :: m0 ! ! !REVISION HISTORY: ! 12 Aug 2008 - Michael Kahnert, SMHI ! 6 Feb 2011 - Achim Strunk - ! ! !REMARKS: ! !EOP !------------------------------------------------------------------------ !BOC complex m1s,m2s,mt real fac1,fac2 if(v2.eq.1.0)then m0=m2 return elseif(v2.eq.0.0)then m0=m1 return endif fac1=2.-3.*v2 fac2=3.*v2-1. m1s=m1**2 m2s=m2**2 mt=m1s*fac1+m2s*fac2 m0=1./16.*mt**2+0.5*m1s*m2s m0=csqrt(m0) m0=m0+0.25*mt m0=csqrt(m0) END SUBROUTINE BRUGGEMAN !EOC !-------------------------------------------------------------------------- ! TM5 ! !-------------------------------------------------------------------------- !BOP ! ! !IROUTINE: MAXWELL_GARNETT ! ! !DESCRIPTION: Compute effective refractive index for a medium consisting of ! a matrix with refractive index m1 and inclusions with refractive ! index m2 and volume fraction v2 by use of the Maxwell-Garnett ! mixing rule. !\\ !\\ ! !INTERFACE: ! PURE SUBROUTINE MAXWELL_GARNETT( m1, m2, v2, m0) ! ! !INPUT PARAMETERS: ! complex, intent(in) :: m1, m2 real, intent(in) :: v2 ! ! !OUTPUT PARAMETERS: ! complex, intent(out) :: m0 ! ! !REVISION HISTORY: ! 12 Aug 2008 - Michael Kahnert, SMHI ! 6 Feb 2011 - Achim Strunk - ! ! !REMARKS: ! !EOP !------------------------------------------------------------------------ !BOC complex :: m1s,m2s real :: fac1,fac2 fac1=3.0-2.0*v2 fac2=3.0-v2 m1s=m1**2 m2s=m2**2 m0=m2s*(fac1*m1s+2.0*v2*m2s)/(v2*m1s+fac2*m2s) m0=csqrt(m0) END SUBROUTINE MAXWELL_GARNETT !EOC !-------------------------------------------------------------------------- ! TM5 ! !-------------------------------------------------------------------------- !BOP ! ! !IROUTINE: OPTICS_CALCULATE_AOP ! ! !DESCRIPTION: This routine writes on aop_out_* (module wide parameters) ! the retrieved aerosol properties. The caller has to ensure ! that these fields have been allocated properly. ! IMPORTANT: OC is actually POM. ! Remember converting OC to POM when sending it to this method. !\\ !\\ ! !INTERFACE: ! SUBROUTINE OPTICS_CALCULATE_AOP( nwl, wdep, lvec, aop_out_ext, aop_out_a, aop_out_g, status, aop_out_add ) ! ! !USES: ! use binas, only : rol, twopi use chem_param, only : ss_density, dust_density, carbon_density use chem_param, only : pom_density, so4_density Use mo_aero_m7, only : nmod, cmedr2mmedr, sigma ! ! !INPUT PARAMETERS: ! integer, intent(in) :: nwl type(wavelendep), intent(in), dimension(nwl) :: wdep ! wavelength depending properties integer, intent(in) :: lvec ! ! !OUTPUT PARAMETERS: ! Real, Dimension(:,:,:), intent(out) :: aop_out_ext ! extinctions Real, Dimension(:,:), intent(out) :: aop_out_a ! single scattering albedo Real, Dimension(:,:), intent(out) :: aop_out_g ! assymetry factor integer, intent(out) :: status Real, Dimension(:,:,:), intent(out), optional :: aop_out_add ! additional parameters ! ! !REVISION HISTORY: ! 12 Aug 2008 - Michael Kahnert, SMHI ! 6 Feb 2011 - Achim Strunk - ! 23 Jan 2013 - Narcisa Banda - included OMP (PLS: commented in TM5-MP) ! ! !REMARKS: ! !EOP !------------------------------------------------------------------------ !BOC real, dimension(:), allocatable :: NCsca, incext real :: Cexti, ai, gi, NCscai, xg complex :: m_eff real, dimension(:), allocatable :: lnsigma integer :: i, imode, ivec!, lss, lee integer :: statusomp Logical :: coarse real :: totvoldry, modfrac ! real :: t1, t2 , omp_get_wtime Real, Dimension(:,:,:), Pointer :: cext_table, a_table, g_table ! --- const ------------------------------ character(len=*), parameter :: rname = mname//'/optics_calculate_AOP' ! --- begin -------------------------------- allocate( NCsca ( lvec ) ) ! allocate( NCscai( lvec ) ) ! allocate( Cexti ( lvec ) ) ! allocate( ai ( lvec ) ) ! allocate( gi ( lvec ) ) ! allocate( xg ( lvec ) ) ! allocate( m_eff ( lvec ) ) allocate( incext( lvec ) ) !t1= omp_get_wtime() status = 0 !pls! !$OMP PARALLEL & !pls! !$OMP default (none) & !pls! !$OMP shared (nwl, lvec, NCsca, incext, & !pls! !$OMP wdep, aop_in, aop_out_Ext, aop_out_g, aop_out_a, aop_out_add, sigma, cmedr2mmedr,& !pls! !$OMP cext_200, a_200, g_200, cext_159, a_159, g_159, status, gol) & !pls! !$OMP private (lnsigma, i, imode, modfrac, coarse, totvoldry, lss, lee, ivec, & !pls! !$OMP NCscai, Cexti, ai, gi, xg, m_eff, cext_table, a_table, g_table, statusomp ) !pls! call my_omp_domain (1, lvec, lss, lee) ! Sulphate based on OPAC (Hess et al., 1998): !======================================================================= ! Get refractive indices of each component at the given wavelength: !======================================================================= do i = 1, nwl ! loop over wavelengths if( wdep(i)%split .or. wdep(i)%insitu ) then allocate( lnsigma( nmod ) ) lnsigma = log(sigma) end if aop_out_Ext(:,i,:) = 0.0 aop_out_g (:,i) = 0.0 aop_out_a (:,i) = 0.0 if( wdep(i)%insitu ) aop_out_add(:,i,:) = 0.0 NCsca (:) = 0.0 do imode = 1, 7 ! loop over M7 modes coarse = (imode .eq. 4 .or. imode .eq. 7) If (coarse) then cext_table => cext_200 a_table => a_200 g_table => g_200 Else cext_table => cext_159 a_table => a_159 g_table => g_159 End if !======================================================================= ! Compute effective refractive index of internally mixed aerosols ! for each grid cell and mode: !======================================================================= do ivec = 1, lvec call get_refr_idx( wdep(i), & aop_in(ivec)%SO4(imode) + aop_in(ivec)%NO3(imode), & ! H2-SO4 + NH4NO3 aop_in(ivec)%BC (imode), aop_in(ivec)%OC (imode), & aop_in(ivec)%SS (imode), aop_in(ivec)%DU (imode), & aop_in(ivec)%h2o(imode), imode, m_eff, statusomp, gol) if (statusomp ==1) then call GoErr status = 1 IF_ERROR_RETURN( status=1 ) endif ! cmk added towpi for new netcdf lookup table xg = twopi*aop_in(ivec)%rg(imode) / wdep(i)%wl !======================================================================= ! get aerosol optical properties from data base for each mode !======================================================================= call Optics_Get(m_eff, xg, Cexti, ai, gi, cext_table, a_table, g_table, statusomp, gol ) if (statusomp ==1) then call GoErr status = 1 IF_ERROR_RETURN( status=1 ) endif ! Multiply Cext with lambda^2 to get the cross section. Cexti = Cexti*(wdep(i)%wl**2) ! this here is extinction coefficient in this mode incext(ivec) = aop_in(ivec)%numdens(imode) * Cexti ! sum up partial coefficients Aop_out_ext(ivec,i,1) = Aop_out_Ext(ivec,i,1) + incext(ivec) ! scattering portion NCscai = ai * incext(ivec) ! sum up weights for average (both albedo and asymmetry) NCsca (ivec) = NCsca (ivec) + NCscai aop_out_g(ivec,i) = aop_out_g(ivec,i) + NCscai * gi end do ! Split extinction to separate contributions from constituents in modes. ! A volume mixing is assumed (in contrast to the explicit mixing in get_refr_ind). if( wdep(i)%split .or. wdep(i)%insitu) then do ivec = 1, lvec if (wdep(i)%split) then ! The fine-mode contributions to the extinction ! includes the contributions from particles ! with (wet) diameters smaller than 1 micron. ! For wet particles, only part of the accumulation mode ! should be included, and the coarse mode should be excluded. if (.not.coarse) then ! Currently, the contribution of the accumulation mode ! is approximated using weighting by volume scaling factor modfrac. ! For extinction, area weighting would probably be more appropriate!! if (imode .eq. 3 .or. imode .eq. 6 ) then ! - convert number mean radius to volume mean radius (by cmedr2mmedr(imode)) ! - 1 micron diameter --> radius is 0.5 microns (rg is also in microns) modfrac = 0.5 + 0.5 * ERF( log( 0.5 / (aop_in(ivec)%rg(imode) * cmedr2mmedr(imode)) ) / & (sqrt(2.0) * lnsigma(imode)) ) else ! Include full nucleation and Aitken mode contributions. modfrac = 1.0 endif aop_out_ext(ivec,i,9) = aop_out_ext(ivec,i,9) + modfrac * incext(ivec) endif ! total volume from so4/no3/bc/oc/ss/du in this mode (ATTENTION: DRY!!) ! take no3 as so4 totvoldry = aop_in(ivec)%so4(imode)/so4_density + aop_in(ivec)%no3(imode)/so4_density + & aop_in(ivec)%bc (imode)/carbon_density + aop_in(ivec)%oc (imode)/pom_density + & aop_in(ivec)%ss (imode)/ss_density + aop_in(ivec)%du (imode)/dust_density ! check whether there is some volume available ! otherwise assign zeros to extinction increments if( totvoldry < tiny(totvoldry) ) then write(gol,'("WARNING: no volume in mode (",i3,"). assigning zero extinctions")') imode; call goPr cycle end if ! H2-SO4 contribution aop_out_ext(ivec,i,2) = aop_out_ext(ivec,i,2) + incext(ivec) * (aop_in(ivec)%so4(imode)/so4_density ) / totvoldry ! BC contribution aop_out_ext(ivec,i,3) = aop_out_ext(ivec,i,3) + incext(ivec) * (aop_in(ivec)%bc (imode)/carbon_density) / totvoldry ! POM contribution aop_out_ext(ivec,i,4) = aop_out_ext(ivec,i,4) + incext(ivec) * (aop_in(ivec)%oc (imode)/pom_density ) / totvoldry ! SS contribution aop_out_ext(ivec,i,5) = aop_out_ext(ivec,i,5) + incext(ivec) * (aop_in(ivec)%ss (imode)/ss_density ) / totvoldry ! DU contribution aop_out_ext(ivec,i,6) = aop_out_ext(ivec,i,6) + incext(ivec) * (aop_in(ivec)%du (imode)/dust_density ) / totvoldry ! NH4NO3 contribution aop_out_ext(ivec,i,7) = aop_out_ext(ivec,i,7) + incext(ivec) * (aop_in(ivec)%no3(imode)/so4_density ) / totvoldry ! Fine-mode contributions for dust and sea salt if (.not.coarse) then aop_out_ext(ivec,i,10) = aop_out_ext(ivec,i,10) + incext(ivec) * (aop_in(ivec)%du (imode)/dust_density ) / totvoldry * modfrac aop_out_ext(ivec,i,11) = aop_out_ext(ivec,i,11) + incext(ivec) * (aop_in(ivec)%ss (imode)/ss_density ) / totvoldry * modfrac endif endif ! Water contribution: ! Get optical properties without water, the difference will be extinction due to ! water existence ! - mis-use gi for this gi = 0.0 call get_refr_idx( wdep(i), & aop_in(ivec)%SO4(imode) + aop_in(ivec)%NO3(imode), & aop_in(ivec)%BC (imode), aop_in(ivec)%OC (imode), & aop_in(ivec)%SS (imode), aop_in(ivec)%DU (imode), & gi, imode, m_eff, statusomp, gol) if (statusomp ==1) then status = 1 call GoErr IF_NOTOK_RETURN(status = 1) endif ! here we need the dry radius!!! !>>> TvN ! 2*pi should be included (see comment above) !xg = aop_in(ivec)%rgd(imode) / wdep(i)%wl xg = twopi*aop_in(ivec)%rgd(imode) / wdep(i)%wl !<<< TvN call Optics_Get(m_eff, xg, Cexti, ai, gi, cext_table, a_table, g_table, statusomp, gol ) if (statusomp ==1) then call GoErr status = 1 IF_ERROR_RETURN( status=1 ) endif Cexti = Cexti*(wdep(i)%wl**2) if (wdep(i)%split) then ! add difference to water subarray Aop_out_ext(ivec,i,8) = aop_out_ext(ivec,i,8) + (incext(ivec) - aop_in(ivec)%numdens(imode) * Cexti) endif if (wdep(i)%insitu) then ! Surface dry extinction and absorption: !>>> TvN ! Remove cut off for the total values: !modfrac = 0.5 + 0.5 * ERF( log( 5.0 / (aop_in(ivec)%rgd(imode) * cmedr2mmedr(imode)) ) / & ! (sqrt(2.0) * lnsigma(imode)) ) ! extinction and absorption (extinction-scattering): !Aop_out_add(ivec,i,1) = aop_out_add(ivec,i,1) + modfrac * aop_in(ivec)%numdens(imode) * Cexti !Aop_out_add(ivec,i,2) = aop_out_add(ivec,i,2) + modfrac * aop_in(ivec)%numdens(imode) * Cexti * (1. - ai) aop_out_add(ivec,i,1) = aop_out_add(ivec,i,1) + aop_in(ivec)%numdens(imode) * Cexti aop_out_add(ivec,i,2) = aop_out_add(ivec,i,2) + aop_in(ivec)%numdens(imode) * Cexti * (1. - ai) aop_out_add(ivec,i,3) = aop_out_add(ivec,i,3) + aop_in(ivec)%numdens(imode) * Cexti * ai * gi ! Add fine-mode contributions ! For dry aerosol, the fine-mode optical properties include ! the full accumulation mode, but not the coarse mode: if (.not.coarse) then aop_out_add(ivec,i,4) = aop_out_add(ivec,i,4) + aop_in(ivec)%numdens(imode) * Cexti aop_out_add(ivec,i,5) = aop_out_add(ivec,i,5) + aop_in(ivec)%numdens(imode) * Cexti * (1. - ai) endif !<<< TvN endif end do ! ivec end if enddo ! modes ! take into account small extinction values where( Aop_out_Ext(:,i,1) > tiny(0.0) ) Aop_out_a(:,i) = NCsca(:) / Aop_out_Ext(:,i,1) elsewhere ! No extinction -> Fill 1.0 for albedo because it looks clean. Aop_out_a(:,i) = 1.0 endwhere ! take into account small extinction values where( NCsca(:) > tiny(0.0) ) Aop_out_g(:,i) = Aop_out_g(:,i) / NCsca(:) elsewhere ! No scattering at all -> Fill 1.0 for asymmetry because it looks clean. Aop_out_g(:,i) = 1.0 endwhere ! convert um**2/m**3 into 1/m Aop_out_Ext(:,i,:) = Aop_out_Ext(:,i,:) * 1e-12 if( wdep(i)%insitu) then ! take into account small extinction values where( aop_out_add(:,i,1) - aop_out_add(:,i,2) > tiny(0.0) ) aop_out_add(:,i,3) = aop_out_add(:,i,3) / (aop_out_add(:,i,1)-aop_out_add(:,i,2)) elsewhere ! No scattering at all -> Fill 1.0 for asymmetry because it looks clean. aop_out_add(:,i,3) = 1.0 endwhere Aop_out_add(:,i,1) = aop_out_add(:,i,1) * 1e-12 Aop_out_add(:,i,2) = aop_out_add(:,i,2) * 1e-12 Aop_out_add(:,i,4) = aop_out_add(:,i,4) * 1e-12 Aop_out_add(:,i,5) = aop_out_add(:,i,5) * 1e-12 endif if( wdep(i)%split .or. wdep(i)%insitu ) then deallocate( lnsigma ) endif !======================================================================= enddo ! loop over wavelengths Nullify(Cext_table) Nullify(a_table) Nullify(g_table) !$OMP END PARALLEL if (status==1) then call goPr IF_NOTOK_RETURN(status=1) endif !do imode = 1,7 ! print *, 'Radius,mode :', imode, sum(aop_in(:)%rg(imode))/lvec ! print *, 'numden,mode :', imode, sum(aop_in(:)%numdens(imode))/lvec !enddo deallocate( NCsca, incext ) !do i = 1,nwl ! print *, 'AOD per grid box:', wdep(i)%wl, sum(Aop_out_Ext(:,i,1))/lvec !enddo ! ok status = 0 END SUBROUTINE OPTICS_CALCULATE_AOP !EOC !-------------------------------------------------------------------------- ! TM5 ! !-------------------------------------------------------------------------- !BOP ! ! !IROUTINE: OPTICS_AOP_GET ! ! !DESCRIPTION: Initialise the fields "aop_in" and then calculate the ! optical properties through a call to optics_calculate_aop. !\\ !\\ ! !INTERFACE: ! SUBROUTINE OPTICS_AOP_GET( lvec, region, nwav, wdep, ncontr, aop_out_ext, aop_out_a, aop_out_g, & status, aop_out_add ) ! ! !USES: ! USE TM5_DISTGRID, ONLY : dgrid, Get_DistGrid use Meteo, only : Set Use Meteodata, only : gph_dat, m_dat Use Dims, only : im, jm, lm use global_data, only : region_dat, mass_dat Use chem_param, only : inus_n, iso4nus, nmod use chem_param, only : iais_n, iso4ais, ibcais, ipomais Use chem_param, only : iacs_n, iso4acs, ibcacs, ipomacs, issacs, iduacs, ino3_a use chem_param, only : imsa use chem_param, only : icos_n, iso4cos, ibccos, ipomcos, isscos, iducos use chem_param, only : iaii_n, ibcaii, ipomaii use chem_param, only : iaci_n, icoi_n, iduaci, iducoi use chem_param, only : h2so4_factor, nh4no3_factor use chem_param, only : so4_density, nh4no3_density, msa_density Use m7_data, only : h2o_mode, rw_mode, rwd_mode ! ! !INPUT PARAMETERS: ! Integer, Intent(In) :: region, lvec Integer, Intent(In) :: nwav, ncontr type(wavelendep), dimension(nwav), Intent(In) :: wdep ! ! !OUTPUT PARAMETERS: ! real, dimension(lvec,nwav,ncontr), intent(out) :: aop_out_ext ! extinctions real, dimension(lvec,nwav), intent(out) :: aop_out_a ! single scattering albedo real, dimension(lvec,nwav), intent(out) :: aop_out_g ! assymetry factor integer, intent(out) :: status real, dimension(:,:,:), intent(out), optional :: aop_out_add ! additional parameters ! ! !REVISION HISTORY: ! 29 Nov 2010 - Achim Strunk - v0 ! 24 Jun 2011 - Achim Strunk - Added NO3 to allow for explicit ! AOD split of (SO4+NO3) ! 20 Jun 2012 - P. Le Sager - adapted for lon-lat MPI domain decomposition ! ! !REMARKS: ! !EOP !------------------------------------------------------------------------ !BOC character(len=*), parameter :: rname = mname//'/optics_aop_get' real, dimension(:,:,:,:), pointer :: rm real, dimension(:,:,:), pointer :: m real, dimension(:,:,:), allocatable :: volume Integer :: i, j, l, iloop, i1, i2, j1, j2, lmr ! --- start ------------------------------ ! ensure met fields being available call Set( gph_dat(region), status, used=.true. ) ! air & tracers mass m => m_dat(region)%data rm => mass_dat(region)%rm ! tile grid size CALL GET_DISTGRID( dgrid(region), I_STRT=i1, I_STOP=i2, J_STRT=j1, J_STOP=j2 ) lmr=lm(region) !lvec = (i2-i1+1)*(j2-j1+1)*lmr allocate( aop_in(lvec) ) do i = 1, nmod aop_in(:)%so4 (i) = 0.0 ; aop_in(:)%bc (i) = 0.0 aop_in(:)%oc (i) = 0.0 ; aop_in(:)%ss (i) = 0.0 aop_in(:)%du (i) = 0.0 ; aop_in(:)%h2o(i) = 0.0 aop_in(:)%numdens(i) = 0.0 ; aop_in(:)%rg (i) = 0.0 aop_in(:)%rgd (i) = 0.0 ; aop_in(:)%no3(i) = 0.0 end do !>>> TvN ! In M7 sulphate is assumed to be H2-SO4 with corresponding particle density so4_density ! The sulphate mass should therefore also include the small contribution from the H atoms ! NUS !aop_in(:)%so4(1) = reshape( 1.e9 * rm(i1:i2,j1:j2,:,iso4nus) / m(i1:i2,j1:j2,:), (/lvec/) ) aop_in(:)%so4(1) = reshape( 1.e9 * h2so4_factor * rm(i1:i2,j1:j2,:,iso4nus) / m(i1:i2,j1:j2,:), (/lvec/) ) ! AIS !aop_in(:)%so4(2) = reshape( 1.e9 * rm(i1:i2,j1:j2,:,iso4ais) / m(i1:i2,j1:j2,:), (/lvec/) ) aop_in(:)%so4(2) = reshape( 1.e9 * h2so4_factor * rm(i1:i2,j1:j2,:,iso4ais) / m(i1:i2,j1:j2,:), (/lvec/) ) aop_in(:)%bc (2) = reshape( 1.e9 * rm(i1:i2,j1:j2,:,ibcais ) / m(i1:i2,j1:j2,:), (/lvec/) ) aop_in(:)%oc (2) = reshape( 1.e9 * rm(i1:i2,j1:j2,:,ipomais) / m(i1:i2,j1:j2,:), (/lvec/) ) ! ACS (additional: NO3) ! The contribution from methane sulfonate (MSA-) aerosol is added ! to that for sulfate. ! As the addition is done by volume, ! we need to account for the difference in densities ! (as done below for ammonium nitrate). !aop_in(:)%so4(3) = reshape( 1.e9 * rm(i1:i2,j1:j2,:,iso4acs) / m(i1:i2,j1:j2,:), (/lvec/) ) aop_in(:)%so4(3) = reshape( 1.e9 * ( h2so4_factor * rm(i1:i2,j1:j2,:,iso4acs) + & (so4_density / msa_density) * rm(i1:i2,j1:j2,:,imsa) ) / & m(i1:i2,j1:j2,:), (/lvec/) ) ! Since nh4no3_density is the density of NH4NO3, the contribution from NH4 should be included. ! Moreover, assuming the same refractive index for NH4NO3 as for H2-SO4, ! the contributions from both components can be added by volume; ! thus we need to account for the difference in densities. ! Estimates of the refractive index of NH4NO3 are available from literature ! (e.g. Lowenthal et al., Atmos. Environ., 2000). ! For practical purposes, it can be set equal to the value used for sulfate, ! i.e. the value for a solution containing 75% H2SO4 (Fenn et al., 1985). !aop_in(:)%no3(3) = reshape( 1.e9 * rm(i1:i2,j1:j2,:,ino3_a ) / m(i1:i2,j1:j2,:), (/lvec/) ) aop_in(:)%no3(3) = reshape( 1.e9 * nh4no3_factor * (so4_density / nh4no3_density) * & rm(i1:i2,j1:j2,:,ino3_a ) / m(i1:i2,j1:j2,:), (/lvec/) ) aop_in(:)%bc (3) = reshape( 1.e9 * rm(i1:i2,j1:j2,:,ibcacs ) / m(i1:i2,j1:j2,:), (/lvec/) ) aop_in(:)%oc (3) = reshape( 1.e9 * rm(i1:i2,j1:j2,:,ipomacs) / m(i1:i2,j1:j2,:), (/lvec/) ) aop_in(:)%ss (3) = reshape( 1.e9 * rm(i1:i2,j1:j2,:,issacs ) / m(i1:i2,j1:j2,:), (/lvec/) ) aop_in(:)%du (3) = reshape( 1.e9 * rm(i1:i2,j1:j2,:,iduacs ) / m(i1:i2,j1:j2,:), (/lvec/) ) ! COS !aop_in(:)%so4(4) = reshape( 1.e9 * rm(i1:i2,j1:j2,:,iso4cos) / m(i1:i2,j1:j2,:), (/lvec/) ) aop_in(:)%so4(4) = reshape( 1.e9 * h2so4_factor * rm(i1:i2,j1:j2,:,iso4cos) / m(i1:i2,j1:j2,:), (/lvec/) ) !<<< TvN aop_in(:)%bc (4) = reshape( 1.e9 * rm(i1:i2,j1:j2,:,ibccos ) / m(i1:i2,j1:j2,:), (/lvec/) ) aop_in(:)%oc (4) = reshape( 1.e9 * rm(i1:i2,j1:j2,:,ipomcos) / m(i1:i2,j1:j2,:), (/lvec/) ) aop_in(:)%ss (4) = reshape( 1.e9 * rm(i1:i2,j1:j2,:,isscos ) / m(i1:i2,j1:j2,:), (/lvec/) ) aop_in(:)%du (4) = reshape( 1.e9 * rm(i1:i2,j1:j2,:,iducos ) / m(i1:i2,j1:j2,:), (/lvec/) ) ! AII aop_in(:)%bc (5) = reshape( 1.e9 * rm(i1:i2,j1:j2,:,ibcaii ) / m(i1:i2,j1:j2,:), (/lvec/) ) aop_in(:)%oc (5) = reshape( 1.e9 * rm(i1:i2,j1:j2,:,ipomaii) / m(i1:i2,j1:j2,:), (/lvec/) ) ! ACI aop_in(:)%du (6) = reshape( 1.e9 * rm(i1:i2,j1:j2,:,iduaci ) / m(i1:i2,j1:j2,:), (/lvec/) ) ! COI aop_in(:)%du (7) = reshape( 1.e9 * rm(i1:i2,j1:j2,:,iducoi ) / m(i1:i2,j1:j2,:), (/lvec/) ) ! Water in (hydrophillic) modes aop_in(:)%h2o(1) = reshape( 1.e9 * h2o_mode(region,1)%d3(i1:i2,j1:j2,:) / m(i1:i2,j1:j2,:), (/lvec/) ) aop_in(:)%h2o(2) = reshape( 1.e9 * h2o_mode(region,2)%d3(i1:i2,j1:j2,:) / m(i1:i2,j1:j2,:), (/lvec/) ) aop_in(:)%h2o(3) = reshape( 1.e9 * h2o_mode(region,3)%d3(i1:i2,j1:j2,:) / m(i1:i2,j1:j2,:), (/lvec/) ) aop_in(:)%h2o(4) = reshape( 1.e9 * h2o_mode(region,4)%d3(i1:i2,j1:j2,:) / m(i1:i2,j1:j2,:), (/lvec/) ) aop_in(:)%rg (1) = reshape( 1.e6 * rw_mode (region,1)%d3(i1:i2,j1:j2,:), (/lvec/) ) aop_in(:)%rg (2) = reshape( 1.e6 * rw_mode (region,2)%d3(i1:i2,j1:j2,:), (/lvec/) ) aop_in(:)%rg (3) = reshape( 1.e6 * rw_mode (region,3)%d3(i1:i2,j1:j2,:), (/lvec/) ) aop_in(:)%rg (4) = reshape( 1.e6 * rw_mode (region,4)%d3(i1:i2,j1:j2,:), (/lvec/) ) aop_in(:)%rg (5) = reshape( 1.e6 * rw_mode (region,5)%d3(i1:i2,j1:j2,:), (/lvec/) ) aop_in(:)%rg (6) = reshape( 1.e6 * rw_mode (region,6)%d3(i1:i2,j1:j2,:), (/lvec/) ) aop_in(:)%rg (7) = reshape( 1.e6 * rw_mode (region,7)%d3(i1:i2,j1:j2,:), (/lvec/) ) ! dry radius for soluble modes / rest equals the usual radii aop_in(:)%rgd(1) = reshape( 1.e6 * rwd_mode(region,1)%d3(i1:i2,j1:j2,:), (/lvec/) ) aop_in(:)%rgd(2) = reshape( 1.e6 * rwd_mode(region,2)%d3(i1:i2,j1:j2,:), (/lvec/) ) aop_in(:)%rgd(3) = reshape( 1.e6 * rwd_mode(region,3)%d3(i1:i2,j1:j2,:), (/lvec/) ) aop_in(:)%rgd(4) = reshape( 1.e6 * rwd_mode(region,4)%d3(i1:i2,j1:j2,:), (/lvec/) ) aop_in(:)%rgd(5) = aop_in(:)%rg (5) aop_in(:)%rgd(6) = aop_in(:)%rg (6) aop_in(:)%rgd(7) = aop_in(:)%rg (7) ! volume for number density allocate( volume( i1:i2, j1:j2, 1:lmr ) ) do j = j1, j2 volume(:,j,:) = ( gph_dat(region)%data(i1:i2, j, 2:lmr+1) - & gph_dat(region)%data(i1:i2, j, 1:lmr ) ) * & region_dat(region)%dxyp(j) ! m3 end do aop_in(:)%numdens(1) = reshape( rm(i1:i2,j1:j2,:,inus_n) / volume, (/lvec/) ) aop_in(:)%numdens(2) = reshape( rm(i1:i2,j1:j2,:,iais_n) / volume, (/lvec/) ) aop_in(:)%numdens(3) = reshape( rm(i1:i2,j1:j2,:,iacs_n) / volume, (/lvec/) ) aop_in(:)%numdens(4) = reshape( rm(i1:i2,j1:j2,:,icos_n) / volume, (/lvec/) ) aop_in(:)%numdens(5) = reshape( rm(i1:i2,j1:j2,:,iaii_n) / volume, (/lvec/) ) aop_in(:)%numdens(6) = reshape( rm(i1:i2,j1:j2,:,iaci_n) / volume, (/lvec/) ) aop_in(:)%numdens(7) = reshape( rm(i1:i2,j1:j2,:,icoi_n) / volume, (/lvec/) ) deallocate( volume ) ! check valid ranges in particle sizes (might be zero) where( aop_in%rg (1) .lt. 1.E-15 ) aop_in%rg (1) = 1.E-15 where( aop_in%rgd(1) .lt. 1.E-15 ) aop_in%rgd(1) = 1.E-15 where( aop_in%rg (2) .lt. 1.E-15 ) aop_in%rg (2) = 1.E-15 where( aop_in%rgd(2) .lt. 1.E-15 ) aop_in%rgd(2) = 1.E-15 where( aop_in%rg (3) .lt. 1.E-15 ) aop_in%rg (3) = 1.E-15 where( aop_in%rgd(3) .lt. 1.E-15 ) aop_in%rgd(3) = 1.E-15 where( aop_in%rg (4) .lt. 1.E-15 ) aop_in%rg (4) = 1.E-15 where( aop_in%rgd(4) .lt. 1.E-15 ) aop_in%rgd(4) = 1.E-15 where( aop_in%rg (5) .lt. 1.E-15 ) aop_in%rg (5) = 1.E-15 where( aop_in%rgd(5) .lt. 1.E-15 ) aop_in%rgd(5) = 1.E-15 where( aop_in%rg (6) .lt. 1.E-15 ) aop_in%rg (6) = 1.E-15 where( aop_in%rgd(6) .lt. 1.E-15 ) aop_in%rgd(6) = 1.E-15 where( aop_in%rg (7) .lt. 1.E-15 ) aop_in%rg (7) = 1.E-15 where( aop_in%rgd(7) .lt. 1.E-15 ) aop_in%rgd(7) = 1.E-15 nullify(rm) nullify(m) ! if (present(aop_out_add)) then call optics_calculate_aop( nwav, wdep, lvec, aop_out_ext, aop_out_a, aop_out_g, status, aop_out_add ) else call optics_calculate_aop( nwav, wdep, lvec, aop_out_ext, aop_out_a, aop_out_g, status ) endif IF_NOTOK_RETURN(status=1) ! OK Deallocate( aop_in ) status = 0 END SUBROUTINE OPTICS_AOP_GET !EOC END MODULE OPTICS