source: LMDZ6/branches/Ocean_skin/libf/phylmd/ecrad/radiation_config.F90 @ 4013

Last change on this file since 4013 was 3908, checked in by idelkadi, 3 years ago

Online implementation of the radiative transfer code ECRAD in the LMDZ model.

  • Inclusion of the ecrad directory containing the sources of the ECRAD code
    • interface routine : radiation_scheme.F90
  • Adaptation of compilation scripts :
    • compilation under CPP key CPP_ECRAD
    • compilation with option "-rad ecard" or "-ecard true"
    • The "-rad old/rtm/ecran" build option will need to replace the "-rrtm true" and "-ecrad true" options in the future.
  • Runing LMDZ simulations with ecrad, you need :
    • logical key iflag_rrtm = 2 in physiq.def
    • namelist_ecrad (DefLists?)
    • the directory "data" containing the configuration files is temporarily placed in ../libfphylmd/ecrad/
  • Compilation and execution are tested in the 1D case. The repository under svn would allow to continue the implementation work: tests, verification of the results, ...
File size: 83.6 KB
Line 
1! radiation_config.F90 - Derived type to configure the radiation scheme
2!
3! (C) Copyright 2014- ECMWF.
4!
5! This software is licensed under the terms of the Apache Licence Version 2.0
6! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0.
7!
8! In applying this licence, ECMWF does not waive the privileges and immunities
9! granted to it by virtue of its status as an intergovernmental organisation
10! nor does it submit to any jurisdiction.
11!
12! Author:  Robin Hogan
13! Email:   r.j.hogan@ecmwf.int
14!
15! Modifications
16!   2017-07-22  R. Hogan  Added Yi et al. ice optics model
17!   2017-10-23  R. Hogan  Renamed single-character variables
18!   2018-03-15  R. Hogan  Added logicals controlling surface spectral treatment
19!   2018-08-29  R. Hogan  Added monochromatic single-scattering albedo / asymmetry factor
20!   2018-09-03  R. Hogan  Added min_cloud_effective_size
21!   2018-09-04  R. Hogan  Added encroachment_scaling
22!   2018-09-13  R. Hogan  Added IEncroachmentFractal
23!   2019-01-02  R. Hogan  Added Cloudless solvers
24!   2019-01-14  R. Hogan  Added out_of_bounds_[1,2,3]d for checker routines
25!   2019-01-18  R. Hogan  Added albedo weighting
26!   2019-02-03  R. Hogan  Added ability to fix out-of-physical-bounds inputs
27!   2019-02-10  R. Hogan  Renamed "encroachment" to "entrapment"
28!
29! Note: The aim is for ecRad in the IFS to be as similar as possible
30! to the offline version, so if you make any changes to this or any
31! files in this directory, please inform Robin Hogan.
32!
33
34module radiation_config
35
36  use parkind1,                      only : jprb
37
38  use radiation_cloud_optics_data,   only : cloud_optics_type
39  use radiation_aerosol_optics_data, only : aerosol_optics_type
40  use radiation_pdf_sampler,         only : pdf_sampler_type
41  use radiation_cloud_cover,         only : OverlapName, &
42       & IOverlapMaximumRandom, IOverlapExponentialRandom, IOverlapExponential
43
44  implicit none
45  public
46
47  ! Configuration codes: use C-style enumerators to avoid having to
48  ! remember the numbers
49
50  ! Solvers: can be specified for longwave and shortwave
51  ! independently, except for "Homogeneous", which must be the same
52  ! for both
53  enum, bind(c)
54     enumerator ISolverCloudless, ISolverHomogeneous, ISolverMcICA, &
55          &     ISolverSpartacus, ISolverTripleclouds
56  end enum
57  character(len=*), parameter :: SolverName(0:4) = (/ 'Cloudless   ', &
58       &                                              'Homogeneous ', &
59       &                                              'McICA       ', &
60       &                                              'SPARTACUS   ', &
61       &                                              'Tripleclouds' /)
62
63  ! SPARTACUS shortwave solver can treat the reflection of radiation
64  ! back up into different regions in various ways
65  enum, bind(c)
66     enumerator &
67       & IEntrapmentZero, &     ! No entrapment, as Tripleclouds
68       & IEntrapmentEdgeOnly, & ! Only radiation passed through cloud edge is horizontally homogenized
69       & IEntrapmentExplicit, & ! Estimate horiz migration dist, account for fractal clouds
70       & IEntrapmentExplicitNonFractal, & ! As above but ignore fractal nature of clouds
71       & IEntrapmentMaximum ! Complete horizontal homogenization within regions (old SPARTACUS assumption)
72
73  end enum
74 
75  ! Names available in the radiation namelist for variable
76  ! sw_entrapment_name
77  character(len=*), parameter :: EntrapmentName(0:4)   = [ 'Zero       ', &
78       &                                                   'Edge-only  ', &
79       &                                                   'Explicit   ', &
80       &                                                   'Non-fractal', &
81       &                                                   'Maximum    ' ]
82  ! For backwards compatibility, the radiation namelist also supports
83  ! the equivalent variable sw_encroachment_name with the following
84  ! names
85  character(len=*), parameter :: EncroachmentName(0:4) = [ 'Zero    ', &
86       &                                                   'Minimum ', &
87       &                                                   'Fractal ', &
88       &                                                   'Computed', &
89       &                                                   'Maximum ' ]
90
91  ! Two-stream models
92  ! This is not configurable at run-time
93
94  ! Gas models
95  enum, bind(c)
96     enumerator IGasModelMonochromatic, IGasModelIFSRRTMG
97  end enum
98  character(len=*), parameter :: GasModelName(0:1) = (/ 'Monochromatic', &
99       &                                                'RRTMG-IFS    ' /)
100
101  ! Hydrometeor scattering models
102  enum, bind(c)
103     enumerator ILiquidModelMonochromatic, &
104          &     ILiquidModelSOCRATES, ILiquidModelSlingo
105  end enum
106  character(len=*), parameter :: LiquidModelName(0:2) = (/ 'Monochromatic', &
107       &                                                   'SOCRATES     ', &
108       &                                                   'Slingo       ' /)
109
110  enum, bind(c)
111     enumerator IIceModelMonochromatic, IIceModelFu, &
112          &  IIceModelBaran, IIceModelBaran2016, IIceModelBaran2017,   &
113          &  IIceModelYi
114  end enum
115  character(len=*), parameter :: IceModelName(0:5) = (/ 'Monochromatic', &
116       &                                                'Fu-IFS       ', &
117       &                                                'Baran        ', &
118       &                                                'Baran2016    ', &
119       &                                                'Baran2017    ', &
120       &                                                'Yi           ' /)
121
122  ! Cloud PDF distribution shapes
123  enum, bind(c)
124    enumerator IPdfShapeLognormal, IPdfShapeGamma
125  end enum
126  character(len=*), parameter :: PdfShapeName(0:1) = (/ 'Lognormal', &
127       &                                                'Gamma    ' /)
128
129  ! Maximum number of different aerosol types that can be provided
130  integer, parameter :: NMaxAerosolTypes = 256
131
132  ! Maximum number of shortwave albedo and longwave emissivity
133  ! intervals
134  integer, parameter :: NMaxAlbedoIntervals = 256
135
136  ! Length of string buffer for printing config information
137  integer, parameter :: NPrintStringLen = 60
138
139  !---------------------------------------------------------------------
140  ! Derived type containing all the configuration information needed
141  ! to run the radiation scheme.  The intention is that this is fixed
142  ! for a given model run.  The parameters are to list first those
143  ! quantities that can be set directly by the user, for example using a
144  ! namelist, and second those quantities that are computed afterwards
145  ! from the user-supplied numbers, especially the details of the gas
146  ! optics model.
147  type config_type
148    ! USER-CONFIGURABLE PARAMETERS
149
150    ! Override default solar spectrum
151    logical :: use_spectral_solar_scaling = .false.
152
153    ! Directory in which gas, cloud and aerosol data files are to be
154    ! found
155    character(len=511) :: directory_name = '.'
156
157    ! Cloud is deemed to be present in a layer if cloud fraction
158    ! exceeds this value
159    real(jprb) :: cloud_fraction_threshold = 1.0e-6_jprb
160    ! ...and total cloud water mixing ratio exceeds this value
161    real(jprb) :: cloud_mixing_ratio_threshold = 1.0e-9_jprb
162
163    ! Overlap scheme
164    integer :: i_overlap_scheme = IOverlapExponentialRandom
165
166    ! Use the Shonk et al. (2010) "beta" overlap parameter, rather
167    ! than the "alpha" overlap parameter of Hogan and Illingworth
168    ! (2000)?
169    logical :: use_beta_overlap = .false.
170
171    ! Shape of sub-grid cloud water PDF
172    integer :: i_cloud_pdf_shape = IPdfShapeGamma
173
174    ! The ratio of the overlap decorrelation length for cloud
175    ! inhomogeneities to the overlap decorrelation length for cloud
176    ! boundaries.  Observations suggest this has a value of 0.5
177    ! (e.g. from the decorrelation lengths of Hogan and Illingworth
178    ! 2003 and Hogan and Illingworth 2000).
179    real(jprb) :: cloud_inhom_decorr_scaling = 0.5_jprb
180
181    ! Factor controlling how much of the cloud edge length interfaces
182    ! directly between the clear-sky region (region a) and the
183    ! optically thick cloudy region (region c).  If Lxy is the length
184    ! of the interfaces between regions x and y, and Lab and Lbc have
185    ! been computed already, then
186    !   Lac=clear_to_thick_fraction*min(Lab,Lbc).
187    real(jprb) :: clear_to_thick_fraction = 0.0_jprb
188
189    ! Factor allowing lateral transport when the sun is close to
190    ! overhead; consider atand(overhead_sun_factor) to be the number
191    ! of degrees that the sun angle is perturbed from zenith for the
192    ! purposes of computing lateral transport.  A value of up to 0.1
193    ! seems to be necessary to account for the fact that some forward
194    ! scattered radiation is treated as unscattered by delta-Eddington
195    ! scaling; therefore it ought to have the chance to escape.
196    real(jprb) :: overhead_sun_factor = 0.0_jprb
197
198    ! Minimum gas optical depth in a single layer at any wavelength,
199    ! for stability
200    real(jprb) :: min_gas_od_lw = 1.0e-15_jprb
201    real(jprb) :: min_gas_od_sw = 0.0_jprb
202
203    ! Maximum gas optical depth in a layer before that g-point will
204    ! not be considered for 3D treatment: a limit is required to avoid
205    ! expensive computation of matrix exponentials on matrices with
206    ! large elements
207    real(jprb) :: max_gas_od_3d = 8.0_jprb
208
209    ! Maximum total optical depth of a cloudy region for stability:
210    ! optical depth will be capped at this value in the SPARTACUS
211    ! solvers
212    real(jprb) :: max_cloud_od = 16.0_jprb
213
214    ! How much longwave scattering is included?
215    logical :: do_lw_cloud_scattering = .true.
216    logical :: do_lw_aerosol_scattering = .true.
217
218    ! Number of regions used to describe clouds and clear skies. A
219    ! value of 2 means one clear and one cloudy region, so clouds are
220    ! horizontally homogeneous, while a value of 3 means two cloudy
221    ! regions with different optical depth, thereby representing
222    ! inhomogeneity via the Shonk & Hogan (2008) "Tripleclouds"
223    ! method.
224    integer :: nregions = 3
225
226    ! Code specifying the solver to be used: use the enumerations
227    ! defined above
228    integer :: i_solver_sw = ISolverMcICA
229    integer :: i_solver_lw = ISolverMcICA
230
231    ! Do shortwave delta-Eddington scaling on the cloud-aerosol-gas
232    ! mixture (as in the original IFS scheme), rather than the more
233    ! correct approach of separately scaling the cloud and aerosol
234    ! scattering properties before merging with gases.  Note that
235    ! .true. is not compatible with the SPARTACUS solver.
236    logical :: do_sw_delta_scaling_with_gases = .false.
237
238    ! Codes describing the gas and cloud scattering models to use, the
239    ! latter of which is currently not used
240    integer :: i_gas_model = IGasModelIFSRRTMG
241    !     integer :: i_cloud_model
242
243    ! Optics if i_gas_model==IGasModelMonochromatic.
244    ! The wavelength to use for the Planck function in metres. If this
245    ! is positive then the output longwave fluxes will be in units of
246    ! W m-2 um-1.  If this is zero or negative (the default) then
247    ! sigma*T^4 will be used and the output longwave fluxes will be in
248    ! W m-2.
249    real(jprb) :: mono_lw_wavelength = -1.0_jprb
250    ! Total zenith optical depth of the atmosphere in the longwave and
251    ! shortwave, distributed vertically according to the pressure.
252    ! Default is zero.
253    real(jprb) :: mono_lw_total_od = 0.0_jprb
254    real(jprb) :: mono_sw_total_od = 0.0_jprb
255    ! Single-scattering albedo and asymmetry factor: values typical
256    ! for liquid clouds with effective radius of 10 microns, at (SW)
257    ! 0.55 micron wavelength and (LW) 10.7 microns wavelength
258    real(jprb) :: mono_sw_single_scattering_albedo = 0.999999_jprb
259    real(jprb) :: mono_sw_asymmetry_factor = 0.86_jprb
260    real(jprb) :: mono_lw_single_scattering_albedo = 0.538_jprb
261    real(jprb) :: mono_lw_asymmetry_factor = 0.925_jprb
262
263    ! Codes describing particle scattering models
264    integer :: i_liq_model = ILiquidModelSOCRATES
265    integer :: i_ice_model = IIceModelBaran
266   
267    ! The mapping from albedo/emissivity intervals to SW/LW bands can
268    ! either be done by finding the interval containing the central
269    ! wavenumber of the band (nearest neighbour), or by a weighting
270    ! according to the spectral overlap of each interval with each
271    ! band
272    logical :: do_nearest_spectral_sw_albedo = .true.
273    logical :: do_nearest_spectral_lw_emiss  = .true.
274
275    ! User-defined monotonically increasing wavelength bounds (m)
276    ! between input surface albedo/emissivity intervals. Implicitly
277    ! the first interval starts at zero and the last ends at infinity.
278    real(jprb) :: sw_albedo_wavelength_bound(NMaxAlbedoIntervals-1) = -1.0_jprb
279    real(jprb) :: lw_emiss_wavelength_bound( NMaxAlbedoIntervals-1)  = -1.0_jprb
280
281    ! The index to the surface albedo/emissivity intervals for each of
282    ! the wavelength bounds specified in sw_albedo_wavelength_bound
283    ! and lw_emiss_wavelength_bound
284    integer :: i_sw_albedo_index(NMaxAlbedoIntervals) = 0
285    integer :: i_lw_emiss_index (NMaxAlbedoIntervals)  = 0
286
287    ! Do we compute longwave and/or shortwave radiation?
288    logical :: do_lw = .true.
289    logical :: do_sw = .true.
290
291    ! Do we compute clear-sky fluxes and/or solar direct fluxes?
292    logical :: do_clear = .true.
293    logical :: do_sw_direct = .true.
294
295    ! Do we include 3D effects?
296    logical :: do_3d_effects = .true.
297   
298    ! To what extent do we include "entrapment" effects in the
299    ! SPARTACUS solver? This essentially means that in a situation
300    ! like this
301    !
302    ! 000111
303    ! 222222
304    !
305    ! Radiation downwelling from region 1 may be reflected back into
306    ! region 0 due to some degree of homogenization of the radiation
307    ! in region 2.  Hogan and Shonk (2013) referred to this as
308    ! "anomalous horizontal transport" for a 1D model, although for 3D
309    ! calculations it is desirable to include at least some of it. The
310    ! options are described by the IEntrapment* parameters above.
311    integer :: i_3d_sw_entrapment = IEntrapmentExplicit
312
313    ! In the longwave, the equivalent process it either "on" (like
314    ! maximum entrapment) or "off" (like zero entrapment):
315    logical :: do_3d_lw_multilayer_effects = .false.
316
317    ! Do we account for the effective emissivity of the side of
318    ! clouds?
319    logical :: do_lw_side_emissivity = .true.
320
321    ! The 3D transfer rate "X" is such that if transport out of a
322    ! region was the only process occurring then by the base of a
323    ! layer only exp(-X) of the original flux would remain in that
324    ! region. The transfer rate computed geometrically can be very
325    ! high for the clear-sky regions in layers with high cloud
326    ! fraction.  For stability reasons it is necessary to provide a
327    ! maximum possible 3D transfer rate.
328    real(jprb) :: max_3d_transfer_rate = 10.0_jprb
329
330    ! It has also sometimes been found necessary to set a minimum
331    ! cloud effective size for stability (metres)
332    real(jprb) :: min_cloud_effective_size = 100.0_jprb
333
334    ! Given a horizontal migration distance, there is still
335    ! uncertainty about how much entrapment occurs associated with how
336    ! one assumes cloud boundaries line up in adjacent layers. This
337    ! factor can be varied between 0.0 (the boundaries line up to the
338    ! greatest extent possible given the overlap parameter) and 1.0
339    ! (the boundaries line up to the minimum extent possible). In the
340    ! Hogan et al. entrapment paper it is referred to as the overhang
341    ! factor zeta, and a value of 0 matches the Monte Carlo
342    ! calculations best.
343    real(jprb) :: overhang_factor = 0.0_jprb
344
345    ! By default, the Meador & Weaver (1980) expressions are used
346    ! instead of the matrix exponential whenever 3D effects can be
347    ! neglected (e.g. cloud-free layers or clouds with infinitely
348    ! large effective cloud size), but setting the following to true
349    ! uses the matrix exponential everywhere, enabling the two
350    ! methods to be compared. Note that Meador & Weaver will still be
351    ! used for very optically thick g points where the matrix
352    ! exponential can produce incorrect results.
353    logical :: use_expm_everywhere = .false.
354
355    ! Aerosol descriptors: aerosol_type_mapping must be of length
356    ! n_aerosol_types, and contains 0 if that type is to be ignored,
357    ! positive numbers to map on to the indices of hydrophobic
358    ! aerosols in the aerosol optics configuration file, and negative
359    ! numbers to map on to (the negative of) the indices of
360    ! hydrophilic aerosols in the configuration file.
361    logical :: use_aerosols = .false.
362    integer :: n_aerosol_types = 0
363    integer :: i_aerosol_type_map(NMaxAerosolTypes)
364
365    ! Save the gas and cloud optical properties for each g point in
366    ! "radiative_properties.nc"?
367    logical :: do_save_radiative_properties = .false.
368
369    ! Save the flux profiles in each band?
370    logical :: do_save_spectral_flux = .false.
371
372    ! Save the surface downwelling shortwave fluxes in each band?
373    logical :: do_surface_sw_spectral_flux = .true.
374
375    ! Compute the longwave derivatives needed to apply the approximate
376    ! radiation updates of Hogan and Bozzo (2015)
377    logical :: do_lw_derivatives = .false.
378
379    ! Save the flux profiles in each g-point (overrides
380    ! do_save_spectral_flux if TRUE)?
381    logical :: do_save_gpoint_flux = .false.
382
383    ! In the IFS environment, setting up RRTM has already been done
384    ! so not needed to do it again
385    logical :: do_setup_ifsrrtm = .true.
386
387    ! In the IFS environment the old scheme has a bug in the Fu
388    ! longwave ice optics whereby the single scattering albedo is one
389    ! minus what it should be.  Unfortunately fixing it makes
390    ! forecasts worse. Setting the following to true reproduces the
391    ! bug.
392    logical :: do_fu_lw_ice_optics_bug = .false.
393
394    ! Control verbosity: 0=none (no output to standard output; write
395    ! to standard error only if an error occurs), 1=warning, 2=info,
396    ! 3=progress, 4=detailed, 5=debug.  Separate settings for the
397    ! setup of the scheme and the execution of it.
398    integer :: iverbosesetup = 2
399    integer :: iverbose = 1
400
401    ! Are we doing radiative transfer in complex surface canopies
402    ! (streets/vegetation), in which case tailored downward fluxes are
403    ! needed at the top of the canopy?
404    logical :: do_canopy_fluxes_sw = .false.
405    logical :: do_canopy_fluxes_lw = .false.
406    ! If so, do we use the full spectrum as in the atmosphere, or just
407    ! the reduced spectrum in which the shortwave albedo and longwave
408    ! emissivity are provided?
409    logical :: use_canopy_full_spectrum_sw = .false.
410    logical :: use_canopy_full_spectrum_lw = .false.
411    ! Do we treat gas radiative transfer in streets/vegetation?
412    logical :: do_canopy_gases_sw = .false.
413    logical :: do_canopy_gases_lw = .false.
414
415    ! Optics file names for overriding the ones generated from the
416    ! other options. If these remain empty then the generated names
417    ! will be used (see the "consolidate_config" routine below). If
418    ! the user assigns one of these and it starts with a '/' character
419    ! then that will be used instead. If the user assigns one and it
420    ! doesn't start with a '/' character then it will be prepended by
421    ! the contents of directory_name.
422    character(len=511) :: ice_optics_override_file_name = ''
423    character(len=511) :: liq_optics_override_file_name = ''
424    character(len=511) :: aerosol_optics_override_file_name = ''
425
426    ! Optionally override the look-up table file for the cloud-water
427    ! PDF used by the McICA solver
428    character(len=511) :: cloud_pdf_override_file_name = ''
429
430    ! Has "consolidate" been called? 
431    logical :: is_consolidated = .false.
432
433    ! COMPUTED PARAMETERS
434    ! Users of this library should not edit these parameters directly;
435    ! they are set by the "consolidate" routine
436
437    ! Wavenumber range for each band, in cm-1, which will be allocated
438    ! to be of length n_bands_sw or n_bands_lw
439    real(jprb), allocatable, dimension(:) :: wavenumber1_sw
440    real(jprb), allocatable, dimension(:) :: wavenumber2_sw
441    real(jprb), allocatable, dimension(:) :: wavenumber1_lw
442    real(jprb), allocatable, dimension(:) :: wavenumber2_lw
443
444    ! If the nearest surface albedo/emissivity interval is to be used
445    ! for each SW/LW band then the following arrays will be allocated
446    ! to the length of the number of bands and contain the index to
447    ! the relevant interval
448    integer, allocatable, dimension(:) :: i_albedo_from_band_sw
449    integer, allocatable, dimension(:) :: i_emiss_from_band_lw
450
451    ! ...alternatively, this matrix dimensioned
452    ! (n_albedo_intervals,n_bands_sw) providing the weights needed for
453    ! computing the albedo in each ecRad band from the albedo in each
454    ! native albedo band - see radiation_single_level.F90
455    real(jprb), allocatable, dimension(:,:) :: sw_albedo_weights
456    ! ...and similarly in the longwave, dimensioned
457    ! (n_emiss_intervals,n_bands_lw)
458    real(jprb), allocatable, dimension(:,:) :: lw_emiss_weights
459
460    ! Arrays of length the number of g-points that convert from
461    ! g-point to the band index
462    integer, allocatable, dimension(:) :: i_band_from_g_lw
463    integer, allocatable, dimension(:) :: i_band_from_g_sw
464
465    ! We allow for the possibility for g-points to be ordered in terms
466    ! of likely absorption (weakest to strongest) across the shortwave
467    ! or longwave spectrum, in order that in SPARTACUS we select only
468    ! the first n g-points that will not have too large an absorption,
469    ! and therefore matrix exponentials that are both finite and not
470    ! too expensive to compute.  The following two arrays map the
471    ! reordered g-points to the original ones.
472    integer, allocatable, dimension(:) :: i_g_from_reordered_g_lw
473    integer, allocatable, dimension(:) :: i_g_from_reordered_g_sw
474
475    ! The following map the reordered g-points to the bands
476    integer, allocatable, dimension(:) :: i_band_from_reordered_g_lw
477    integer, allocatable, dimension(:) :: i_band_from_reordered_g_sw
478
479    ! The following map the reordered g-points to the spectral
480    ! information being saved: if do_save_gpoint_flux==TRUE then this
481    ! will map on to the original g points, but if only
482    ! do_save_spectral_flux==TRUE then this will map on to the bands
483    integer, pointer, dimension(:) :: i_spec_from_reordered_g_lw
484    integer, pointer, dimension(:) :: i_spec_from_reordered_g_sw
485
486    ! Number of spectral intervals used for the canopy radiative
487    ! transfer calculation; they are either equal to
488    ! n_albedo_intervals/n_emiss_intervals or n_g_sw/n_g_lw
489    integer :: n_canopy_bands_sw = 1
490    integer :: n_canopy_bands_lw = 1
491
492    ! Data structure containing cloud scattering data
493    type(cloud_optics_type)      :: cloud_optics
494
495    ! Data structure containing aerosol scattering data
496    type(aerosol_optics_type)    :: aerosol_optics
497
498    ! Object for sampling from a gamma or lognormal distribution
499    type(pdf_sampler_type)       :: pdf_sampler
500
501    ! Optics file names
502    character(len=511) :: ice_optics_file_name, &
503         &                liq_optics_file_name, &
504         &                aerosol_optics_file_name
505   
506    ! McICA PDF look-up table file name
507    character(len=511) :: cloud_pdf_file_name
508
509    ! Number of gpoints and bands in the shortwave and longwave - set
510    ! to zero as will be set properly later
511    integer :: n_g_sw = 0, n_g_lw = 0
512    integer :: n_bands_sw = 0, n_bands_lw = 0
513
514    ! Number of spectral points to save (equal either to the number of
515    ! g points or the number of bands
516    integer :: n_spec_sw = 0, n_spec_lw = 0
517
518    ! Dimensions to store variables that are only needed if longwave
519    ! scattering is included. "n_g_lw_if_scattering" is equal to
520    ! "n_g_lw" if aerosols are allowed to scatter in the longwave,
521    ! and zero otherwise. "n_bands_lw_if_scattering" is equal to
522    ! "n_bands_lw" if clouds are allowed to scatter in the longwave,
523    ! and zero otherwise.
524    integer :: n_g_lw_if_scattering = 0, n_bands_lw_if_scattering = 0
525
526    ! Treat clouds as horizontally homogeneous within the gribox
527    logical :: is_homogeneous = .false.
528
529    ! If the solvers are both "Cloudless" then we don't need to do any
530    ! cloud processing
531    logical :: do_clouds = .true.
532
533   contains
534     procedure :: read => read_config_from_namelist
535     procedure :: consolidate => consolidate_config
536     procedure :: set  => set_config
537     procedure :: print => print_config
538     procedure :: get_sw_weights
539     procedure :: define_sw_albedo_intervals
540     procedure :: define_lw_emiss_intervals
541     procedure :: consolidate_intervals
542
543  end type config_type
544
545!  procedure, private :: print_logical, print_real, print_int
546
547contains
548
549
550  !---------------------------------------------------------------------
551  ! This subroutine reads configuration data from a namelist file, and
552  ! anything that is not in the namelists will be set to default
553  ! values. If optional output argument "is_success" is present, then
554  ! on error (e.g. missing file) it will be set to .false.; if this
555  ! argument is missing then on error the program will be aborted. You
556  ! may either specify the file_name or the unit of an open file to
557  ! read, but not both.
558  subroutine read_config_from_namelist(this, file_name, unit, is_success)
559
560    use yomhook,      only : lhook, dr_hook
561    use radiation_io, only : nulout, nulerr, nulrad, radiation_abort
562
563    class(config_type), intent(inout)         :: this
564    character(*),       intent(in),  optional :: file_name
565    integer,            intent(in),  optional :: unit
566    logical,            intent(out), optional :: is_success
567
568    integer :: iosopen, iosread ! Status after calling open and read
569
570    ! The following variables are read from the namelists and map
571    ! directly onto members of the config_type derived type
572
573    ! To be read from the radiation_config namelist
574    logical :: do_sw, do_lw, do_clear, do_sw_direct
575    logical :: do_3d_effects, use_expm_everywhere, use_aerosols
576    logical :: do_lw_side_emissivity
577    logical :: do_3d_lw_multilayer_effects, do_fu_lw_ice_optics_bug
578    logical :: do_lw_aerosol_scattering, do_lw_cloud_scattering
579    logical :: do_save_radiative_properties, do_save_spectral_flux
580    logical :: do_save_gpoint_flux, do_surface_sw_spectral_flux
581    logical :: use_beta_overlap, do_lw_derivatives
582    logical :: do_sw_delta_scaling_with_gases
583    logical :: do_canopy_fluxes_sw, do_canopy_fluxes_lw
584    logical :: use_canopy_full_spectrum_sw, use_canopy_full_spectrum_lw
585    logical :: do_canopy_gases_sw, do_canopy_gases_lw
586    integer :: n_regions, iverbose, iverbosesetup, n_aerosol_types
587    real(jprb):: mono_lw_wavelength, mono_lw_total_od, mono_sw_total_od
588    real(jprb):: mono_lw_single_scattering_albedo, mono_sw_single_scattering_albedo
589    real(jprb):: mono_lw_asymmetry_factor, mono_sw_asymmetry_factor
590    real(jprb):: cloud_inhom_decorr_scaling, cloud_fraction_threshold
591    real(jprb):: clear_to_thick_fraction, max_gas_od_3d, max_cloud_od
592    real(jprb):: cloud_mixing_ratio_threshold, overhead_sun_factor
593    real(jprb):: max_3d_transfer_rate, min_cloud_effective_size
594    real(jprb):: overhang_factor, encroachment_scaling
595    character(511) :: directory_name, aerosol_optics_override_file_name
596    character(511) :: liq_optics_override_file_name, ice_optics_override_file_name
597    character(511) :: cloud_pdf_override_file_name
598    character(63)  :: liquid_model_name, ice_model_name, gas_model_name
599    character(63)  :: sw_solver_name, lw_solver_name, overlap_scheme_name
600    character(63)  :: sw_entrapment_name, sw_encroachment_name, cloud_pdf_shape_name
601    integer :: i_aerosol_type_map(NMaxAerosolTypes) ! More than 256 is an error
602
603    logical :: do_nearest_spectral_sw_albedo = .true.
604    logical :: do_nearest_spectral_lw_emiss  = .true.
605    real(jprb) :: sw_albedo_wavelength_bound(NMaxAlbedoIntervals-1)
606    real(jprb) :: lw_emiss_wavelength_bound( NMaxAlbedoIntervals-1)
607    integer :: i_sw_albedo_index(NMaxAlbedoIntervals)
608    integer :: i_lw_emiss_index (NMaxAlbedoIntervals)
609
610    integer :: iunit ! Unit number of namelist file
611
612    namelist /radiation/ do_sw, do_lw, do_sw_direct, &
613         &  do_3d_effects, do_lw_side_emissivity, do_clear, &
614         &  do_save_radiative_properties, sw_entrapment_name, sw_encroachment_name, &
615         &  do_3d_lw_multilayer_effects, do_fu_lw_ice_optics_bug, &
616         &  do_save_spectral_flux, do_save_gpoint_flux, &
617         &  do_surface_sw_spectral_flux, do_lw_derivatives, &
618         &  do_lw_aerosol_scattering, do_lw_cloud_scattering, &
619         &  n_regions, directory_name, gas_model_name, &
620         &  ice_optics_override_file_name, liq_optics_override_file_name, &
621         &  aerosol_optics_override_file_name, cloud_pdf_override_file_name, &
622         &  liquid_model_name, ice_model_name, max_3d_transfer_rate, &
623         &  min_cloud_effective_size, overhang_factor, encroachment_scaling, &
624         &  use_canopy_full_spectrum_sw, use_canopy_full_spectrum_lw, &
625         &  do_canopy_fluxes_sw, do_canopy_fluxes_lw, &
626         &  do_canopy_gases_sw, do_canopy_gases_lw, &
627         &  do_sw_delta_scaling_with_gases, overlap_scheme_name, &
628         &  sw_solver_name, lw_solver_name, use_beta_overlap, &
629         &  use_expm_everywhere, iverbose, iverbosesetup, &
630         &  cloud_inhom_decorr_scaling, cloud_fraction_threshold, &
631         &  clear_to_thick_fraction, max_gas_od_3d, max_cloud_od, &
632         &  cloud_mixing_ratio_threshold, overhead_sun_factor, &
633         &  n_aerosol_types, i_aerosol_type_map, use_aerosols, &
634         &  mono_lw_wavelength, mono_lw_total_od, mono_sw_total_od, &
635         &  mono_lw_single_scattering_albedo, mono_sw_single_scattering_albedo, &
636         &  mono_lw_asymmetry_factor, mono_sw_asymmetry_factor, &
637         &  cloud_pdf_shape_name, &
638         &  do_nearest_spectral_sw_albedo, do_nearest_spectral_lw_emiss, &
639         &  sw_albedo_wavelength_bound, lw_emiss_wavelength_bound, &
640         &  i_sw_albedo_index, i_lw_emiss_index
641
642    real(jprb) :: hook_handle
643
644    if (lhook) call dr_hook('radiation_config:read',0,hook_handle)
645
646    ! Copy default values from the original structure
647    do_sw = this%do_sw
648    do_lw = this%do_lw
649    do_sw_direct = this%do_sw_direct
650    do_3d_effects = this%do_3d_effects
651    do_3d_lw_multilayer_effects = this%do_3d_lw_multilayer_effects
652    do_lw_side_emissivity = this%do_lw_side_emissivity
653    do_clear = this%do_clear
654    do_lw_aerosol_scattering = this%do_lw_aerosol_scattering
655    do_lw_cloud_scattering = this%do_lw_cloud_scattering
656    do_sw_delta_scaling_with_gases = this%do_sw_delta_scaling_with_gases
657    do_fu_lw_ice_optics_bug = this%do_fu_lw_ice_optics_bug
658    do_canopy_fluxes_sw = this%do_canopy_fluxes_sw
659    do_canopy_fluxes_lw = this%do_canopy_fluxes_lw
660    use_canopy_full_spectrum_sw = this%use_canopy_full_spectrum_sw
661    use_canopy_full_spectrum_lw = this%use_canopy_full_spectrum_lw
662    do_canopy_gases_sw = this%do_canopy_gases_sw
663    do_canopy_gases_lw = this%do_canopy_gases_lw
664    n_regions = this%nregions
665    directory_name = this%directory_name
666    cloud_pdf_override_file_name = this%cloud_pdf_override_file_name
667    liq_optics_override_file_name = this%liq_optics_override_file_name
668    ice_optics_override_file_name = this%ice_optics_override_file_name
669    aerosol_optics_override_file_name = this%aerosol_optics_override_file_name
670    use_expm_everywhere = this%use_expm_everywhere
671    use_aerosols = this%use_aerosols
672    do_save_radiative_properties = this%do_save_radiative_properties
673    do_save_spectral_flux = this%do_save_spectral_flux
674    do_save_gpoint_flux = this%do_save_gpoint_flux
675    do_lw_derivatives = this%do_lw_derivatives
676    do_surface_sw_spectral_flux = this%do_surface_sw_spectral_flux
677    iverbose = this%iverbose
678    iverbosesetup = this%iverbosesetup
679    cloud_fraction_threshold = this%cloud_fraction_threshold
680    cloud_mixing_ratio_threshold = this%cloud_mixing_ratio_threshold
681    use_beta_overlap = this%use_beta_overlap
682    cloud_inhom_decorr_scaling = this%cloud_inhom_decorr_scaling
683    clear_to_thick_fraction = this%clear_to_thick_fraction
684    overhead_sun_factor = this%overhead_sun_factor
685    max_gas_od_3d = this%max_gas_od_3d
686    max_cloud_od = this%max_cloud_od
687    max_3d_transfer_rate = this%max_3d_transfer_rate
688    min_cloud_effective_size = this%min_cloud_effective_size
689    overhang_factor = this%overhang_factor
690    encroachment_scaling = -1.0_jprb
691    gas_model_name = '' !DefaultGasModelName
692    liquid_model_name = '' !DefaultLiquidModelName
693    ice_model_name = '' !DefaultIceModelName
694    sw_solver_name = '' !DefaultSwSolverName
695    lw_solver_name = '' !DefaultLwSolverName
696    sw_entrapment_name = ''
697    sw_encroachment_name = ''
698    overlap_scheme_name = ''
699    cloud_pdf_shape_name = ''
700    n_aerosol_types = this%n_aerosol_types
701    mono_lw_wavelength = this%mono_lw_wavelength
702    mono_lw_total_od = this%mono_lw_total_od
703    mono_sw_total_od = this%mono_sw_total_od
704    mono_lw_single_scattering_albedo = this%mono_lw_single_scattering_albedo
705    mono_sw_single_scattering_albedo = this%mono_sw_single_scattering_albedo
706    mono_lw_asymmetry_factor = this%mono_lw_asymmetry_factor
707    mono_sw_asymmetry_factor = this%mono_sw_asymmetry_factor
708    i_aerosol_type_map = this%i_aerosol_type_map
709    do_nearest_spectral_sw_albedo = this%do_nearest_spectral_sw_albedo
710    do_nearest_spectral_lw_emiss  = this%do_nearest_spectral_lw_emiss
711    sw_albedo_wavelength_bound    = this%sw_albedo_wavelength_bound
712    lw_emiss_wavelength_bound     = this%lw_emiss_wavelength_bound
713    i_sw_albedo_index             = this%i_sw_albedo_index
714    i_lw_emiss_index              = this%i_lw_emiss_index
715
716    if (present(file_name) .and. present(unit)) then
717      write(nulerr,'(a)') '*** Error: cannot specify both file_name and unit in call to config_type%read'
718      call radiation_abort('Radiation configuration error')
719    else if (.not. present(file_name) .and. .not. present(unit)) then
720      write(nulerr,'(a)') '*** Error: neither file_name nor unit specified in call to config_type%read'
721      call radiation_abort('Radiation configuration error')
722    end if
723
724    if (present(file_name)) then
725      ! Open the namelist file
726      iunit = nulrad
727      open(unit=iunit, iostat=iosopen, file=trim(file_name))
728    else
729      ! Assume that iunit represents and open file
730      iosopen = 0
731      iunit = unit
732    end if
733
734    if (iosopen /= 0) then
735      ! An error occurred opening the file
736      if (present(is_success)) then
737        is_success = .false.
738        ! We now continue the subroutine so that the default values
739        ! are placed in the config structure
740      else
741        write(nulerr,'(a,a,a)') '*** Error: namelist file "', &
742             &                trim(file_name), '" not found'
743        call radiation_abort('Radiation configuration error')
744      end if
745    else
746      read(unit=iunit, iostat=iosread, nml=radiation)
747      if (iosread /= 0) then
748        ! An error occurred reading the file
749        if (present(is_success)) then
750          is_success = .false.
751          ! We now continue the subroutine so that the default values
752          ! are placed in the config structure
753        else if (present(file_name)) then
754          write(nulerr,'(a,a,a)') '*** Error reading namelist "radiation" from file "', &
755               &      trim(file_name), '"'
756          close(unit=iunit)
757          call radiation_abort('Radiation configuration error')
758        else
759          write(nulerr,'(a,i0)') '*** Error reading namelist "radiation" from unit ', &
760               &      iunit
761          call radiation_abort('Radiation configuration error')
762        end if
763      end if
764
765      if (present(file_name)) then
766        close(unit=iunit)
767      end if
768    end if
769
770    ! Copy namelist data into configuration object
771
772    ! Start with verbosity levels, which should be within limits
773    if (iverbose < 0) then
774      iverbose = 0
775    end if
776    this%iverbose = iverbose
777
778    if (iverbosesetup < 0) then
779      iverbosesetup = 0
780    end if
781    this%iverbosesetup = iverbosesetup
782
783    this%do_lw = do_lw
784    this%do_sw = do_sw
785    this%do_clear = do_clear
786    this%do_sw_direct = do_sw_direct
787    this%do_3d_effects = do_3d_effects
788    this%do_3d_lw_multilayer_effects = do_3d_lw_multilayer_effects
789    this%do_lw_side_emissivity = do_lw_side_emissivity
790    this%use_expm_everywhere = use_expm_everywhere
791    this%use_aerosols = use_aerosols
792    this%do_lw_cloud_scattering = do_lw_cloud_scattering
793    this%do_lw_aerosol_scattering = do_lw_aerosol_scattering
794    this%nregions = n_regions
795    this%do_surface_sw_spectral_flux = do_surface_sw_spectral_flux
796    this%do_sw_delta_scaling_with_gases = do_sw_delta_scaling_with_gases
797    this%do_fu_lw_ice_optics_bug = do_fu_lw_ice_optics_bug
798    this%do_canopy_fluxes_sw = do_canopy_fluxes_sw
799    this%do_canopy_fluxes_lw = do_canopy_fluxes_lw
800    this%use_canopy_full_spectrum_sw = use_canopy_full_spectrum_sw
801    this%use_canopy_full_spectrum_lw = use_canopy_full_spectrum_lw
802    this%do_canopy_gases_sw = do_canopy_gases_sw
803    this%do_canopy_gases_lw = do_canopy_gases_lw
804    this%mono_lw_wavelength = mono_lw_wavelength
805    this%mono_lw_total_od = mono_lw_total_od
806    this%mono_sw_total_od = mono_sw_total_od
807    this%mono_lw_single_scattering_albedo = mono_lw_single_scattering_albedo
808    this%mono_sw_single_scattering_albedo = mono_sw_single_scattering_albedo
809    this%mono_lw_asymmetry_factor = mono_lw_asymmetry_factor
810    this%mono_sw_asymmetry_factor = mono_sw_asymmetry_factor
811    this%use_beta_overlap = use_beta_overlap
812    this%cloud_inhom_decorr_scaling = cloud_inhom_decorr_scaling
813    this%clear_to_thick_fraction = clear_to_thick_fraction
814    this%overhead_sun_factor = overhead_sun_factor
815    this%max_gas_od_3d = max_gas_od_3d
816    this%max_cloud_od = max_cloud_od
817    this%max_3d_transfer_rate = max_3d_transfer_rate
818    this%min_cloud_effective_size = max(1.0e-6_jprb, min_cloud_effective_size)
819    if (encroachment_scaling >= 0.0_jprb) then
820      this%overhang_factor = encroachment_scaling
821      if (iverbose >= 1) then
822        write(nulout, '(a)') 'Warning: radiation namelist parameter "encroachment_scaling" is deprecated: use "overhang_factor"'
823      end if
824    else
825      this%overhang_factor = overhang_factor
826    end if
827    this%directory_name = directory_name
828    this%cloud_pdf_override_file_name = cloud_pdf_override_file_name
829    this%liq_optics_override_file_name = liq_optics_override_file_name
830    this%ice_optics_override_file_name = ice_optics_override_file_name
831    this%aerosol_optics_override_file_name = aerosol_optics_override_file_name
832    this%cloud_fraction_threshold = cloud_fraction_threshold
833    this%cloud_mixing_ratio_threshold = cloud_mixing_ratio_threshold
834    this%n_aerosol_types = n_aerosol_types
835    this%do_save_radiative_properties = do_save_radiative_properties
836    this%do_lw_derivatives = do_lw_derivatives
837    this%do_save_spectral_flux = do_save_spectral_flux
838    this%do_save_gpoint_flux = do_save_gpoint_flux
839    this%do_nearest_spectral_sw_albedo = do_nearest_spectral_sw_albedo
840    this%do_nearest_spectral_lw_emiss  = do_nearest_spectral_lw_emiss
841    this%sw_albedo_wavelength_bound    = sw_albedo_wavelength_bound
842    this%lw_emiss_wavelength_bound     = lw_emiss_wavelength_bound
843    this%i_sw_albedo_index             = i_sw_albedo_index
844    this%i_lw_emiss_index              = i_lw_emiss_index
845
846    if (do_save_gpoint_flux) then
847      ! Saving the fluxes every g-point overrides saving as averaged
848      ! in a band, but this%do_save_spectral_flux needs to be TRUE as
849      ! it is tested inside the solver routines to decide whether to
850      ! save anything
851      this%do_save_spectral_flux = .true.
852    end if
853
854    ! Determine liquid optics model
855    call get_enum_code(liquid_model_name, LiquidModelName, &
856         &            'liquid_model_name', this%i_liq_model)
857
858    ! Determine ice optics model
859    call get_enum_code(ice_model_name, IceModelName, &
860         &            'ice_model_name', this%i_ice_model)
861
862    ! Determine gas optics model
863    call get_enum_code(gas_model_name, GasModelName, &
864         &            'gas_model_name', this%i_gas_model)
865
866    ! Determine solvers
867    call get_enum_code(sw_solver_name, SolverName, &
868         &            'sw_solver_name', this%i_solver_sw)
869    call get_enum_code(lw_solver_name, SolverName, &
870         &            'lw_solver_name', this%i_solver_lw)
871
872    if (len_trim(sw_encroachment_name) > 1) then
873      call get_enum_code(sw_encroachment_name, EncroachmentName, &
874           &             'sw_encroachment_name', this%i_3d_sw_entrapment)
875      write(nulout, '(a)') 'Warning: radiation namelist string "sw_encroachment_name" is deprecated: use "sw_entrapment_name"'
876    else
877      call get_enum_code(sw_entrapment_name, EntrapmentName, &
878           &             'sw_entrapment_name', this%i_3d_sw_entrapment)
879    end if
880
881    ! Determine overlap scheme
882    call get_enum_code(overlap_scheme_name, OverlapName, &
883         &             'overlap_scheme_name', this%i_overlap_scheme)
884   
885    ! Determine cloud PDF shape
886    call get_enum_code(cloud_pdf_shape_name, PdfShapeName, &
887         &             'cloud_pdf_shape_name', this%i_cloud_pdf_shape)
888
889    this%i_aerosol_type_map = 0
890    if (this%use_aerosols) then
891      this%i_aerosol_type_map(1:n_aerosol_types) &
892           &  = i_aerosol_type_map(1:n_aerosol_types)
893    end if
894
895    ! Will clouds be used at all?
896    if ((this%do_sw .and. this%i_solver_sw /= ISolverCloudless) &
897         &  .or. (this%do_lw .and. this%i_solver_lw /= ISolverCloudless)) then
898      this%do_clouds = .true.
899    else
900      this%do_clouds = .false.
901    end if
902
903    ! Normal subroutine exit
904    if (present(is_success)) then
905      is_success = .true.
906    end if
907
908    if (lhook) call dr_hook('radiation_config:read',1,hook_handle)
909
910  end subroutine read_config_from_namelist
911
912
913  !---------------------------------------------------------------------
914  ! This routine is called by radiation_interface:setup_radiation and
915  ! it converts the user specified options into some more specific
916  ! data such as data file names
917  subroutine consolidate_config(this)
918
919    use yomhook,      only : lhook, dr_hook
920    use radiation_io, only : nulout, nulerr, radiation_abort
921
922    class(config_type), intent(inout)         :: this
923
924    real(jprb) :: hook_handle
925
926    if (lhook) call dr_hook('radiation_config:consolidate',0,hook_handle)
927
928    ! Check consistency of models
929    if (this%do_canopy_fluxes_sw .and. .not. this%do_surface_sw_spectral_flux) then
930      if (this%iverbosesetup >= 1) then
931        write(nulout,'(a)') 'Warning: turning on do_surface_sw_spectral_flux as required by do_canopy_fluxes_sw'
932      end if
933      this%do_surface_sw_spectral_flux = .true.
934    end if
935
936    ! Will clouds be used at all?
937    if ((this%do_sw .and. this%i_solver_sw /= ISolverCloudless) &
938         &  .or. (this%do_lw .and. this%i_solver_lw /= ISolverCloudless)) then
939      this%do_clouds = .true.
940    else
941      this%do_clouds = .false.
942    end if
943
944    ! SPARTACUS only works with Exp-Ran overlap scheme
945    if ((       this%i_solver_sw == ISolverSPARTACUS &
946         & .or. this%i_solver_lw == ISolverSPARTACUS &
947         & .or. this%i_solver_sw == ISolverTripleclouds &
948         & .or. this%i_solver_lw == ISolverTripleclouds) &
949         & .and. this%i_overlap_scheme /= IOverlapExponentialRandom) then
950      write(nulerr,'(a)') '*** Error: SPARTACUS/Tripleclouds solvers can only do Exponential-Random overlap'
951      call radiation_abort('Radiation configuration error')
952
953    end if
954
955    ! Set aerosol optics file name
956    if (len_trim(this%aerosol_optics_override_file_name) > 0) then
957      if (this%aerosol_optics_override_file_name(1:1) == '/') then
958        this%aerosol_optics_file_name = trim(this%aerosol_optics_override_file_name)
959      else
960        this%aerosol_optics_file_name = trim(this%directory_name) &
961             &  // '/' // trim(this%aerosol_optics_override_file_name)
962      end if
963    else
964      ! In the IFS, the aerosol optics file should be specified in
965      ! ifs/module/radiation_setup.F90, not here
966      this%aerosol_optics_file_name &
967           &   = trim(this%directory_name) // "/aerosol_ifs_rrtm_45R2.nc"
968    end if
969
970    ! Set liquid optics file name
971    if (len_trim(this%liq_optics_override_file_name) > 0) then
972      if (this%liq_optics_override_file_name(1:1) == '/') then
973        this%liq_optics_file_name = trim(this%liq_optics_override_file_name)
974      else
975        this%liq_optics_file_name = trim(this%directory_name) &
976             &  // '/' // trim(this%liq_optics_override_file_name)
977      end if
978    else if (this%i_liq_model == ILiquidModelSOCRATES) then
979      this%liq_optics_file_name &
980           &  = trim(this%directory_name) // "/socrates_droplet_scattering_rrtm.nc"
981    else if (this%i_liq_model == ILiquidModelSlingo) then
982      this%liq_optics_file_name &
983           &  = trim(this%directory_name) // "/slingo_droplet_scattering_rrtm.nc"
984    end if
985
986    ! Set ice optics file name
987    if (len_trim(this%ice_optics_override_file_name) > 0) then
988      if (this%ice_optics_override_file_name(1:1) == '/') then
989        this%ice_optics_file_name = trim(this%ice_optics_override_file_name)
990      else
991        this%ice_optics_file_name = trim(this%directory_name) &
992             &  // '/' // trim(this%ice_optics_override_file_name)
993      end if
994    else if (this%i_ice_model == IIceModelFu) then
995      this%ice_optics_file_name &
996           &   = trim(this%directory_name) // "/fu_ice_scattering_rrtm.nc"
997    else if (this%i_ice_model == IIceModelBaran) then
998      this%ice_optics_file_name &
999           &   = trim(this%directory_name) // "/baran_ice_scattering_rrtm.nc"
1000    else if (this%i_ice_model == IIceModelBaran2016) then
1001      this%ice_optics_file_name &
1002           &   = trim(this%directory_name) // "/baran2016_ice_scattering_rrtm.nc"
1003    else if (this%i_ice_model == IIceModelBaran2017) then
1004      this%ice_optics_file_name &
1005           &   = trim(this%directory_name) // "/baran2017_ice_scattering_rrtm.nc"
1006    else if (this%i_ice_model == IIceModelYi) then
1007      this%ice_optics_file_name &
1008           &   = trim(this%directory_name) // "/yi_ice_scattering_rrtm.nc"
1009    end if
1010
1011    ! Set cloud-water PDF look-up table file name
1012    if (len_trim(this%cloud_pdf_override_file_name) > 0) then
1013      if (this%cloud_pdf_override_file_name(1:1) == '/') then
1014        this%cloud_pdf_file_name = trim(this%cloud_pdf_override_file_name)
1015      else
1016        this%cloud_pdf_file_name = trim(this%directory_name) &
1017             &  // '/' // trim(this%cloud_pdf_override_file_name)
1018      end if
1019    elseif (this%i_cloud_pdf_shape == IPdfShapeLognormal) then
1020      this%cloud_pdf_file_name = trim(this%directory_name) // "/mcica_lognormal.nc"
1021    else
1022      this%cloud_pdf_file_name = trim(this%directory_name) // "/mcica_gamma.nc"
1023    end if
1024
1025    ! Aerosol data
1026    if (this%n_aerosol_types < 0 &
1027         &  .or. this%n_aerosol_types > NMaxAerosolTypes) then
1028      write(nulerr,'(a,i0)') '*** Error: number of aerosol types must be between 0 and ', &
1029           &  NMaxAerosolTypes
1030      call radiation_abort('Radiation configuration error')
1031    end if
1032
1033    if (this%use_aerosols .and. this%n_aerosol_types == 0) then
1034      if (this%iverbosesetup >= 2) then
1035        write(nulout, '(a)') 'Aerosols on but n_aerosol_types=0: optical properties to be computed outside ecRad'
1036      end if
1037    end if
1038
1039    ! In the monochromatic case we need to override the liquid, ice
1040    ! and aerosol models to ensure compatibility
1041    if (this%i_gas_model == IGasModelMonochromatic) then
1042      this%i_liq_model = ILiquidModelMonochromatic
1043      this%i_ice_model = IIceModelMonochromatic
1044      this%use_aerosols = .false.
1045    end if
1046
1047    ! McICA solver currently can't store full profiles of spectral fluxes
1048    if (this%i_solver_sw == ISolverMcICA) then
1049      this%do_save_spectral_flux = .false.
1050    end if
1051
1052    if (this%i_solver_sw == ISolverSPARTACUS .and. this%do_sw_delta_scaling_with_gases) then
1053      write(nulerr,'(a)') '*** Error: SW delta-Eddington scaling with gases not possible with SPARTACUS solver'
1054      call radiation_abort('Radiation configuration error')
1055    end if
1056
1057    if ((this%do_lw .and. this%do_sw) .and. &
1058         & (     (      this%i_solver_sw == ISolverHomogeneous  &
1059         &        .and. this%i_solver_lw /= ISolverHomogeneous) &
1060         &  .or. (      this%i_solver_sw /= ISolverHomogeneous  &
1061         &        .and. this%i_solver_lw == ISolverHomogeneous) &
1062         & ) ) then
1063      write(nulerr,'(a)') '*** Error: if one solver is "Homogeneous" then the other must be'
1064      call radiation_abort('Radiation configuration error')
1065    end if
1066
1067    ! Set is_homogeneous if the active solvers are homogeneous, since
1068    ! this affects how "in-cloud" water contents are computed
1069    if (        (this%do_sw .and. this%i_solver_sw == ISolverHomogeneous) &
1070         & .or. (this%do_lw .and. this%i_solver_lw == ISolverHomogeneous)) then
1071      this%is_homogeneous = .true.
1072    end if
1073
1074    this%is_consolidated = .true.
1075
1076    if (lhook) call dr_hook('radiation_config:consolidate',1,hook_handle)
1077
1078  end subroutine consolidate_config
1079
1080
1081  !---------------------------------------------------------------------
1082  ! This subroutine sets members of the configuration object via
1083  ! optional arguments, and any member not specified is left
1084  ! untouched. Therefore, this should be called after taking data from
1085  ! the namelist.
1086  subroutine set_config(config, directory_name, &
1087       &  do_lw, do_sw, &
1088       &  do_lw_aerosol_scattering, do_lw_cloud_scattering, &
1089       &  do_sw_direct)
1090
1091    class(config_type), intent(inout):: config
1092    character(len=*), intent(in), optional  :: directory_name
1093    logical, intent(in), optional           :: do_lw, do_sw
1094    logical, intent(in), optional           :: do_lw_aerosol_scattering
1095    logical, intent(in), optional           :: do_lw_cloud_scattering
1096    logical, intent(in), optional           :: do_sw_direct
1097
1098    if (present(do_lw)) then
1099       config%do_lw = do_lw
1100    end if
1101
1102    if(present(do_sw)) then
1103       config%do_sw = do_sw
1104    end if
1105
1106    if (present(do_sw_direct)) then
1107       config%do_sw_direct = do_sw_direct
1108    end if
1109
1110    if (present(directory_name)) then
1111       config%directory_name = trim(directory_name)
1112    end if
1113
1114    if (present(do_lw_aerosol_scattering)) then
1115       config%do_lw_aerosol_scattering = .true.
1116    end if
1117
1118    if (present(do_lw_cloud_scattering)) then
1119       config%do_lw_cloud_scattering = .true.
1120    end if
1121
1122  end subroutine set_config
1123
1124
1125  !---------------------------------------------------------------------
1126  ! Print configuration information to standard output
1127  subroutine print_config(this, iverbose)
1128
1129    use radiation_io, only : nulout
1130
1131    class(config_type), intent(in) :: this
1132
1133    integer, optional,  intent(in) :: iverbose
1134    integer                        :: i_local_verbose
1135
1136    if (present(iverbose)) then
1137      i_local_verbose = iverbose
1138    else
1139      i_local_verbose = this%iverbose
1140    end if
1141
1142    if (i_local_verbose >= 2) then
1143      !---------------------------------------------------------------------
1144      write(nulout, '(a)') 'General settings:'
1145      write(nulout, '(a,a,a)') '  Data files expected in "', &
1146           &                   trim(this%directory_name), '"'
1147      call print_logical('  Clear-sky calculations are', 'do_clear', this%do_clear)
1148      call print_logical('  Saving intermediate radiative properties', &
1149           &   'do_save_radiative_properties', this%do_save_radiative_properties)
1150      call print_logical('  Saving spectral flux profiles', &
1151           &   'do_save_spectral_flux', this%do_save_spectral_flux)
1152      call print_enum('  Gas model is', GasModelName, 'i_gas_model', &
1153           &          this%i_gas_model)
1154      call print_logical('  Aerosols are', 'use_aerosols', this%use_aerosols)
1155      call print_logical('  Clouds are', 'do_clouds', this%do_clouds)
1156
1157      !---------------------------------------------------------------------
1158      write(nulout, '(a)') 'Surface settings:'
1159      if (this%do_sw) then
1160        call print_logical('  Saving surface shortwave spectral fluxes', &
1161             &   'do_surface_sw_spectral_flux', this%do_surface_sw_spectral_flux)
1162        call print_logical('  Saving surface shortwave fluxes in abledo bands', &
1163             &   'do_canopy_fluxes_sw', this%do_canopy_fluxes_sw)
1164      end if
1165      if (this%do_lw) then
1166        call print_logical('  Saving surface longwave fluxes in emissivity bands', &
1167             &   'do_canopy_fluxes_lw', this%do_canopy_fluxes_lw)
1168        call print_logical('  Longwave derivative calculation is', &
1169             &   'do_lw_derivatives',this%do_lw_derivatives)
1170      end if
1171      if (this%do_sw) then
1172        call print_logical('  Nearest-neighbour spectral albedo mapping', &
1173             &   'do_nearest_spectral_sw_albedo', this%do_nearest_spectral_sw_albedo)
1174      end if
1175      if (this%do_lw) then
1176        call print_logical('  Nearest-neighbour spectral emissivity mapping', &
1177             &   'do_nearest_spectral_lw_emiss', this%do_nearest_spectral_lw_emiss)
1178      end if
1179      !---------------------------------------------------------------------
1180      if (this%do_clouds) then
1181        write(nulout, '(a)') 'Cloud settings:'
1182        call print_real('  Cloud fraction threshold', &
1183             &   'cloud_fraction_threshold', this%cloud_fraction_threshold)
1184        call print_real('  Cloud mixing-ratio threshold', &
1185             &   'cloud_mixing_ratio_threshold', this%cloud_mixing_ratio_threshold)
1186        call print_enum('  Liquid optics scheme is', LiquidModelName, &
1187             &          'i_liq_model',this%i_liq_model)
1188        call print_enum('  Ice optics scheme is', IceModelName, &
1189             &          'i_ice_model',this%i_ice_model)
1190        if (this%i_ice_model == IIceModelFu) then
1191          call print_logical('  Longwave ice optics bug in Fu scheme is', &
1192               &   'do_fu_lw_ice_optics_bug',this%do_fu_lw_ice_optics_bug)
1193        end if
1194        call print_enum('  Cloud overlap scheme is', OverlapName, &
1195             &          'i_overlap_scheme',this%i_overlap_scheme)
1196        call print_logical('  Use "beta" overlap parameter is', &
1197             &   'use_beta_overlap', this%use_beta_overlap)
1198        call print_enum('  Cloud PDF shape is', PdfShapeName, &
1199             &          'i_cloud_pdf_shape',this%i_cloud_pdf_shape)
1200        call print_real('  Cloud inhom decorrelation scaling', &
1201             &   'cloud_inhom_decorr_scaling', this%cloud_inhom_decorr_scaling)
1202      end if
1203
1204      !---------------------------------------------------------------------
1205      write(nulout, '(a)') 'Solver settings:'
1206      if (this%do_sw) then
1207        call print_enum('  Shortwave solver is', SolverName, &
1208             &          'i_solver_sw', this%i_solver_sw)
1209       
1210        if (this%i_gas_model == IGasModelMonochromatic) then
1211          call print_real('  Shortwave atmospheric optical depth', &
1212               &   'mono_sw_total_od', this%mono_sw_total_od)
1213          call print_real('  Shortwave particulate single-scattering albedo', &
1214               &   'mono_sw_single_scattering_albedo', &
1215               &   this%mono_sw_single_scattering_albedo)
1216          call print_real('  Shortwave particulate asymmetry factor', &
1217               &   'mono_sw_asymmetry_factor', &
1218               &   this%mono_sw_asymmetry_factor)
1219        end if
1220        call print_logical('  Shortwave delta scaling after merge with gases', &
1221             &   'do_sw_delta_scaling_with_gases', &
1222             &   this%do_sw_delta_scaling_with_gases)
1223      else
1224        call print_logical('  Shortwave calculations are','do_sw',this%do_sw)
1225      end if
1226
1227      if (this%do_lw) then
1228        call print_enum('  Longwave solver is', SolverName, 'i_solver_lw', &
1229             &          this%i_solver_lw)
1230
1231        if (this%i_gas_model == IGasModelMonochromatic) then
1232          if (this%mono_lw_wavelength > 0.0_jprb) then
1233            call print_real('  Longwave effective wavelength (m)', &
1234                 &   'mono_lw_wavelength', this%mono_lw_wavelength)
1235          else
1236            write(nulout,'(a)') '  Longwave fluxes are broadband                              (mono_lw_wavelength<=0)'
1237          end if
1238          call print_real('  Longwave atmospheric optical depth', &
1239               &   'mono_lw_total_od', this%mono_lw_total_od) 
1240          call print_real('  Longwave particulate single-scattering albedo', &
1241               &   'mono_lw_single_scattering_albedo', &
1242               &   this%mono_lw_single_scattering_albedo)
1243          call print_real('  Longwave particulate asymmetry factor', &
1244               &   'mono_lw_asymmetry_factor', &
1245               &   this%mono_lw_asymmetry_factor)
1246        end if
1247        call print_logical('  Longwave cloud scattering is', &
1248             &   'do_lw_cloud_scattering',this%do_lw_cloud_scattering)
1249        call print_logical('  Longwave aerosol scattering is', &
1250             &   'do_lw_aerosol_scattering',this%do_lw_aerosol_scattering)
1251      else
1252        call print_logical('  Longwave calculations are','do_lw', this%do_lw)
1253      end if
1254
1255      if (this%i_solver_sw == ISolverSpartacus &
1256           &  .or. this%i_solver_lw == ISolverSpartacus) then
1257        write(nulout, '(a)') '  SPARTACUS options:'
1258        call print_integer('    Number of regions', 'n_regions', this%nregions)
1259        call print_real('    Max cloud optical depth per layer', &
1260             &   'max_cloud_od', this%max_cloud_od)
1261        call print_enum('    Shortwave entrapment is', EntrapmentName, &
1262             &          'i_3d_sw_entrapment', this%i_3d_sw_entrapment)
1263        call print_logical('    Multilayer longwave horizontal transport is', &
1264             'do_3d_lw_multilayer_effects', this%do_3d_lw_multilayer_effects)
1265        call print_logical('    Use matrix exponential everywhere is', &
1266             &   'use_expm_everywhere', this%use_expm_everywhere)
1267        call print_logical('    3D effects are', 'do_3d_effects', &
1268             &             this%do_3d_effects)
1269
1270        if (this%do_3d_effects) then
1271          call print_logical('    Longwave side emissivity parameterization is', &
1272               &  'do_lw_side_emissivity', this%do_lw_side_emissivity)
1273          call print_real('    Clear-to-thick edge fraction is', &
1274               &  'clear_to_thick_fraction', this%clear_to_thick_fraction)
1275          call print_real('    Overhead sun factor is', &
1276               &  'overhead_sun_factor', this%overhead_sun_factor)
1277          call print_real('    Max gas optical depth for 3D effects', &
1278               &   'max_gas_od_3d', this%max_gas_od_3d)
1279          call print_real('    Max 3D transfer rate', &
1280               &   'max_3d_transfer_rate', this%max_3d_transfer_rate)
1281          call print_real('    Min cloud effective size (m)', &
1282               &   'min_cloud_effective_size', this%min_cloud_effective_size)
1283          call print_real('    Overhang factor', &
1284               &   'overhang_factor', this%overhang_factor)
1285        end if
1286      end if
1287           
1288    end if
1289   
1290  end subroutine print_config
1291
1292
1293
1294  !---------------------------------------------------------------------
1295  ! In order to estimate UV and photosynthetically active radiation,
1296  ! we need weighted sum of fluxes considering wavelength range
1297  ! required.  This routine returns information for how to correctly
1298  ! weight output spectral fluxes for a range of input wavelengths.
1299  ! Note that this is approximate; internally it may be assumed that
1300  ! the energy is uniformly distributed in wavenumber space, for
1301  ! example.  If the character string "weighting_name" is present, and
1302  ! iverbose>=2, then information on the weighting will be provided on
1303  ! nulout.
1304  subroutine get_sw_weights(this, wavelength1, wavelength2, &
1305       &                    nweights, iband, weight, weighting_name)
1306
1307    use parkind1, only : jprb
1308    use radiation_io, only : nulout, nulerr, radiation_abort
1309
1310    class(config_type), intent(in) :: this
1311    ! Range of wavelengths to get weights for (m)
1312    real(jprb), intent(in) :: wavelength1, wavelength2
1313    ! Output number of weights needed
1314    integer,    intent(out)   :: nweights
1315    ! Only write to the first nweights of these arrays: they contain
1316    ! the indices to the non-zero bands, and the weight in each of
1317    ! those bands
1318    integer,    intent(out)   :: iband(:)
1319    real(jprb), intent(out)   :: weight(:)
1320    character(len=*), optional, intent(in) :: weighting_name
1321
1322    ! Internally we deal with wavenumber
1323    real(jprb) :: wavenumber1, wavenumber2 ! cm-1
1324
1325    integer :: jband ! Loop index for spectral band
1326
1327    if (this%n_bands_sw <= 0) then
1328      write(nulerr,'(a)') '*** Error: get_sw_weights called before number of shortwave bands set'
1329      call radiation_abort()     
1330    end if
1331
1332    ! Convert wavelength range (m) to wavenumber (cm-1)
1333    wavenumber1 = 0.01_jprb / wavelength2
1334    wavenumber2 = 0.01_jprb / wavelength1
1335
1336    nweights = 0
1337
1338    do jband = 1,this%n_bands_sw
1339      if (wavenumber1 < this%wavenumber2_sw(jband) &
1340           &  .and. wavenumber2 > this%wavenumber1_sw(jband)) then
1341        nweights = nweights+1
1342        iband(nweights) = jband
1343        weight(nweights) = (min(wavenumber2,this%wavenumber2_sw(jband)) &
1344             &         - max(wavenumber1,this%wavenumber1_sw(jband))) &
1345             & / (this%wavenumber2_sw(jband) - this%wavenumber1_sw(jband))
1346      end if
1347    end do
1348
1349    if (nweights == 0) then
1350      write(nulerr,'(a,e8.4,a,e8.4,a)') '*** Error: wavelength range ', &
1351           &  wavelength1, ' to ', wavelength2, ' m is outside shortwave band'
1352      call radiation_abort()
1353    else if (this%iverbosesetup >= 2 .and. present(weighting_name)) then
1354      write(nulout,'(a,a,a,f6.0,a,f6.0,a)') 'Spectral weights for ', &
1355           &  weighting_name, ' (', wavenumber1, ' to ', &
1356           &  wavenumber2, ' cm-1):'
1357      do jband = 1, nweights
1358        write(nulout, '(a,i0,a,f6.0,a,f6.0,a,f8.4)') '  Shortwave band ', &
1359             &  iband(jband), ' (', this%wavenumber1_sw(iband(jband)), ' to ', &
1360             &  this%wavenumber2_sw(iband(jband)), ' cm-1): ', weight(jband)
1361      end do
1362    end if
1363
1364  end subroutine get_sw_weights
1365
1366
1367  !---------------------------------------------------------------------
1368  ! The input shortwave surface albedo coming in is likely to be in
1369  ! different spectral intervals to the gas model in the radiation
1370  ! scheme. We assume that the input albedo is defined within
1371  ! "ninterval" spectral intervals covering the wavelength range 0 to
1372  ! infinity, but allow for the possibility that two intervals may be
1373  ! indexed back to the same albedo band. 
1374  subroutine define_sw_albedo_intervals(this, ninterval, wavelength_bound, &
1375       &                                i_intervals, do_nearest)
1376
1377    use radiation_io, only : nulerr, radiation_abort
1378
1379    class(config_type),   intent(inout) :: this
1380    ! Number of spectral intervals in which albedo is defined
1381    integer,              intent(in)    :: ninterval
1382    ! Monotonically increasing wavelength bounds between intervals,
1383    ! not including the outer bounds (which are assumed to be zero and
1384    ! infinity)
1385    real(jprb),           intent(in)    :: wavelength_bound(ninterval-1)
1386    ! The albedo indices corresponding to each interval
1387    integer,              intent(in)    :: i_intervals(ninterval)
1388    logical,    optional, intent(in)    :: do_nearest
1389   
1390    if (ninterval > NMaxAlbedoIntervals) then
1391      write(nulerr,'(a,i0,a,i0)') '*** Error: ', ninterval, &
1392           &  ' albedo intervals exceeds maximum of ', NMaxAlbedoIntervals
1393      call radiation_abort();
1394    end if
1395
1396    if (present(do_nearest)) then
1397      this%do_nearest_spectral_sw_albedo = do_nearest
1398    else
1399      this%do_nearest_spectral_sw_albedo = .false.
1400    end if
1401    this%sw_albedo_wavelength_bound(1:ninterval-1) = wavelength_bound(1:ninterval-1)
1402    this%sw_albedo_wavelength_bound(ninterval:)    = -1.0_jprb
1403    this%i_sw_albedo_index(1:ninterval)            = i_intervals(1:ninterval)
1404    this%i_sw_albedo_index(ninterval+1:)           = 0
1405
1406    if (this%is_consolidated) then
1407      call this%consolidate_intervals(.true., &
1408           &  this%do_nearest_spectral_sw_albedo, &
1409           &  this%sw_albedo_wavelength_bound, this%i_sw_albedo_index, &
1410           &  this%wavenumber1_sw, this%wavenumber2_sw, &
1411           &  this%i_albedo_from_band_sw, this%sw_albedo_weights)
1412    end if
1413
1414  end subroutine define_sw_albedo_intervals
1415
1416
1417  !---------------------------------------------------------------------
1418  ! As define_sw_albedo_intervals but for longwave emissivity
1419  subroutine define_lw_emiss_intervals(this, ninterval, wavelength_bound, &
1420       &                                i_intervals, do_nearest)
1421
1422    use radiation_io, only : nulerr, radiation_abort
1423
1424    class(config_type),   intent(inout) :: this
1425    ! Number of spectral intervals in which emissivity is defined
1426    integer,              intent(in)    :: ninterval
1427    ! Monotonically increasing wavelength bounds between intervals,
1428    ! not including the outer bounds (which are assumed to be zero and
1429    ! infinity)
1430    real(jprb),           intent(in)    :: wavelength_bound(ninterval-1)
1431    ! The emissivity indices corresponding to each interval
1432    integer,              intent(in)    :: i_intervals(ninterval)
1433    logical,    optional, intent(in)    :: do_nearest
1434   
1435    if (ninterval > NMaxAlbedoIntervals) then
1436      write(nulerr,'(a,i0,a,i0)') '*** Error: ', ninterval, &
1437           &  ' emissivity intervals exceeds maximum of ', NMaxAlbedoIntervals
1438      call radiation_abort();
1439    end if
1440
1441    if (present(do_nearest)) then
1442      this%do_nearest_spectral_lw_emiss = do_nearest
1443    else
1444      this%do_nearest_spectral_lw_emiss = .false.
1445    end if
1446    this%lw_emiss_wavelength_bound(1:ninterval-1) = wavelength_bound(1:ninterval-1)
1447    this%lw_emiss_wavelength_bound(ninterval:)    = -1.0_jprb
1448    this%i_lw_emiss_index(1:ninterval)            = i_intervals(1:ninterval)
1449    this%i_lw_emiss_index(ninterval+1:)           = 0
1450
1451    if (this%is_consolidated) then
1452      call this%consolidate_intervals(.false., &
1453           &  this%do_nearest_spectral_lw_emiss, &
1454           &  this%lw_emiss_wavelength_bound, this%i_lw_emiss_index, &
1455           &  this%wavenumber1_lw, this%wavenumber2_lw, &
1456           &  this%i_emiss_from_band_lw, this%lw_emiss_weights)
1457    end if
1458
1459  end subroutine define_lw_emiss_intervals
1460
1461
1462  !---------------------------------------------------------------------
1463  ! This routine consolidates either the input shortwave albedo
1464  ! intervals with the shortwave bands, or the input longwave
1465  ! emissivity intervals with the longwave bands, depending on the
1466  ! arguments provided.
1467  subroutine consolidate_intervals(this, is_sw, do_nearest, &
1468       &  wavelength_bound, i_intervals, wavenumber1, wavenumber2, &
1469       &  i_mapping, weights)
1470
1471    use radiation_io, only : nulout, nulerr, radiation_abort
1472
1473    class(config_type),   intent(inout) :: this
1474    ! Is this the shortwave?  Otherwise longwave
1475    logical,    intent(in)    :: is_sw
1476    ! Do we find the nearest albedo interval to the centre of each
1477    ! band, or properly weight the contributions? This can be modified
1478    ! if there is only one albedo intervals.
1479    logical, intent(inout)    :: do_nearest
1480    ! Monotonically increasing wavelength bounds between intervals,
1481    ! not including the outer bounds (which are assumed to be zero and
1482    ! infinity)
1483    real(jprb), intent(in)    :: wavelength_bound(NMaxAlbedoIntervals-1)
1484    ! The albedo band indices corresponding to each interval
1485    integer,    intent(in)    :: i_intervals(NMaxAlbedoIntervals)
1486    ! Start and end wavenumber bounds for the ecRad bands (cm-1)
1487    real(jprb), intent(in)    :: wavenumber1(:), wavenumber2(:)
1488
1489    ! if do_nearest is TRUE then the result is expressed in i_mapping,
1490    ! which will be allocated to have the same length as wavenumber1,
1491    ! and contain the index of the albedo interval corresponding to
1492    ! that band
1493    integer,    allocatable, intent(inout) :: i_mapping(:)
1494    ! ...otherwise the result is expressed in "weights", of
1495    ! size(n_intervals, n_bands) containing how much of each interval
1496    ! contributes to each band.
1497    real(jprb), allocatable, intent(inout) :: weights(:,:)
1498
1499    ! Number and loop index of ecRad bands
1500    integer    :: nband, jband
1501    ! Number and index of albedo/emissivity intervals
1502    integer    :: ninterval, iinterval
1503    ! Sometimes an albedo or emissivity value will be used in more
1504    ! than one interval, so nvalue indicates how many values will
1505    ! actually be provided
1506    integer    :: nvalue
1507    ! Wavenumber bounds of the albedo/emissivity interval
1508    real(jprb) :: wavenumber1_albedo, wavenumber2_albedo
1509    ! Reciprocal of the wavenumber range of the ecRad band
1510    real(jprb) :: recip_dwavenumber ! cm
1511    ! Midpoint/bound of wavenumber band
1512    real(jprb) :: wavenumber_mid, wavenumber_bound ! cm-1
1513   
1514    nband = size(wavenumber1)
1515
1516    ! Count the number of albedo/emissivity intervals
1517    ninterval = 0
1518    do iinterval = 1,NMaxAlbedoIntervals
1519      if (i_intervals(iinterval) > 0) then
1520        ninterval = iinterval
1521      else
1522        exit
1523      end if
1524    end do
1525
1526    if (ninterval < 2) then
1527      ! Zero or one albedo/emissivity intervals found, so we index all
1528      ! bands to one interval
1529      if (allocated(i_mapping)) then
1530        deallocate(i_mapping)
1531      end if
1532      allocate(i_mapping(nband))
1533      i_mapping(:) = 1
1534      do_nearest = .true.
1535      ninterval = 1
1536      nvalue = 1
1537    else
1538      ! Check wavelength is monotonically increasing
1539      do jband = 2,ninterval-1
1540        if (wavelength_bound(jband) <= wavelength_bound(jband-1)) then
1541          if (is_sw) then
1542            write(nulerr, '(a,a)') '*** Error: wavelength bounds for shortwave albedo intervals ', &
1543                 &  'must be monotonically increasing'
1544          else
1545            write(nulerr, '(a,a)') '*** Error: wavelength bounds for longwave emissivity intervals ', &
1546                 &  'must be monotonically increasing'
1547          end if
1548          call radiation_abort()
1549        end if
1550      end do
1551
1552      ! What is the maximum index, indicating the number of
1553      ! albedo/emissivity values to expect?
1554      nvalue = maxval(i_intervals(1:ninterval))
1555     
1556      if (do_nearest) then
1557        ! Simpler nearest-neighbour mapping from band to
1558        ! albedo/emissivity interval
1559        if (allocated(i_mapping)) then
1560          deallocate(i_mapping)
1561        end if
1562        allocate(i_mapping(nband))
1563
1564        ! Loop over bands
1565        do jband = 1,nband
1566          ! Compute mid-point of band in wavenumber space (cm-1)
1567          wavenumber_mid = 0.5_jprb * (wavenumber1(jband) &
1568               &                     + wavenumber2(jband))
1569          iinterval = 1
1570          ! Convert wavelength (m) into wavenumber (cm-1) at the lower
1571          ! bound of the albedo interval
1572          wavenumber_bound = 0.01_jprb / wavelength_bound(iinterval)
1573          ! Find the albedo interval that has the largest overlap with
1574          ! the band; this approach assumes that the albedo intervals
1575          ! are larger than the spectral bands
1576          do while (wavenumber_bound >= wavenumber_mid &
1577               &    .and. iinterval < ninterval)
1578            iinterval = iinterval + 1
1579            if (iinterval < ninterval) then
1580              wavenumber_bound = 0.01_jprb / wavelength_bound(iinterval)
1581            else
1582              ! For the last interval there is no lower bound
1583              wavenumber_bound = 0.0_jprb
1584            end if
1585          end do
1586          ! Save the index of the band corresponding to the albedo
1587          ! interval and move onto the next band
1588          i_mapping(jband) = i_intervals(iinterval)
1589        end do
1590      else
1591        ! More accurate weighting
1592        if (allocated(weights)) then
1593          deallocate(weights)
1594        end if
1595        allocate(weights(nvalue,nband))
1596        weights(:,:) = 0.0_jprb
1597       
1598        ! Loop over bands
1599        do jband = 1,nband
1600          recip_dwavenumber = 1.0_jprb / (wavenumber2(jband) &
1601               &                        - wavenumber1(jband))
1602          ! Find the first overlapping albedo band
1603          iinterval = 1
1604          ! Convert wavelength (m) into wavenumber (cm-1) at the lower
1605          ! bound (in wavenumber space) of the albedo/emissivty interval
1606          wavenumber1_albedo = 0.01_jprb / wavelength_bound(iinterval)
1607          do while (wavenumber1_albedo >= wavenumber2(jband) &
1608               &    .and. iinterval < ninterval)
1609            iinterval = iinterval + 1
1610            wavenumber1_albedo = 0.01_jprb / wavelength_bound(iinterval)
1611          end do
1612         
1613          wavenumber2_albedo = wavenumber2(jband)
1614         
1615          ! Add all overlapping bands
1616          do while (wavenumber2_albedo > wavenumber1(jband) &
1617               &  .and. iinterval <= ninterval)
1618            weights(i_intervals(iinterval),jband) &
1619                 &  = weights(i_intervals(iinterval),jband) &
1620                 &  + recip_dwavenumber &
1621                 &  * (min(wavenumber2_albedo,wavenumber2(jband)) &
1622                 &   - max(wavenumber1_albedo,wavenumber1(jband)))
1623            wavenumber2_albedo = wavenumber1_albedo
1624            iinterval = iinterval + 1
1625            if (iinterval < ninterval) then
1626              wavenumber1_albedo = 0.01_jprb / wavelength_bound(iinterval)
1627            else
1628              wavenumber1_albedo = 0.0_jprb
1629            end if
1630          end do
1631        end do
1632      end if
1633    end if
1634
1635    ! Define how many bands to use for reporting surface downwelling
1636    ! fluxes for canopy radiation scheme
1637    if (is_sw) then
1638      if (this%use_canopy_full_spectrum_sw) then
1639        this%n_canopy_bands_sw = this%n_g_sw
1640      else
1641        this%n_canopy_bands_sw = nvalue
1642      end if
1643    else
1644      if (this%use_canopy_full_spectrum_lw) then
1645        this%n_canopy_bands_lw = this%n_g_lw
1646      else
1647        this%n_canopy_bands_lw = nvalue
1648      end if
1649    end if
1650
1651    if (this%iverbosesetup >= 2) then
1652      if (.not. do_nearest) then
1653        if (is_sw) then
1654          write(nulout, '(a,i0,a,i0,a)') 'Weighting of ', nvalue, ' albedo values in ', &
1655             &  nband, ' shortwave bands (wavenumber ranges in cm-1):'
1656        else
1657          write(nulout, '(a,i0,a,i0,a)') 'Weighting of ', nvalue, ' emissivity values in ', &
1658             &  nband, ' longwave bands (wavenumber ranges in cm-1):'
1659        end if
1660        do jband = 1,nband
1661          write(nulout,'(i6,a,i6,a)',advance='no') nint(wavenumber1(jband)), ' to', &
1662               &                        nint(wavenumber2(jband)), ':'
1663          do iinterval = 1,nvalue
1664            write(nulout,'(f5.2)',advance='no') weights(iinterval,jband)
1665          end do
1666          write(nulout, '()')
1667        end do
1668      else if (ninterval <= 1) then
1669        if (is_sw) then
1670          write(nulout, '(a)') 'All shortwave bands will use the same albedo'
1671        else
1672          write(nulout, '(a)') 'All longwave bands will use the same emissivty'
1673        end if
1674      else
1675        if (is_sw) then
1676          write(nulout, '(a,i0,a)',advance='no') 'Mapping from ', nband, &
1677               &  ' shortwave bands to albedo intervals:'
1678        else
1679          write(nulout, '(a,i0,a)',advance='no') 'Mapping from ', nband, &
1680               &  ' longwave bands to emissivity intervals:'
1681        end if
1682        do jband = 1,nband
1683          write(nulout,'(a,i0)',advance='no') ' ', i_mapping(jband)
1684        end do
1685        write(nulout, '()')
1686      end if
1687    end if
1688
1689  end subroutine consolidate_intervals
1690
1691
1692  !---------------------------------------------------------------------
1693  ! Return the 0-based index for str in enum_str, or abort if it is
1694  ! not found
1695  subroutine get_enum_code(str, enum_str, var_name, icode)
1696
1697    use radiation_io, only : nulerr, radiation_abort
1698
1699    character(len=*), intent(in)  :: str
1700    character(len=*), intent(in)  :: enum_str(0:)
1701    character(len=*), intent(in)  :: var_name
1702    integer,          intent(out) :: icode
1703
1704    integer :: jc
1705    logical :: is_not_found
1706
1707    ! If string is empty then we don't modify icode but assume it has
1708    ! a sensible default value
1709    if (len_trim(str) > 1) then
1710      is_not_found = .true.
1711
1712      do jc = 0,size(enum_str)-1
1713        if (trim(str) == trim(enum_str(jc))) then
1714          icode = jc
1715          is_not_found = .false.
1716          exit
1717        end if
1718      end do
1719      if (is_not_found) then
1720        write(nulerr,'(a,a,a,a,a)',advance='no') '*** Error: ', trim(var_name), &
1721             &  ' must be one of: "', enum_str(0), '"'
1722        do jc = 1,size(enum_str)-1
1723          write(nulerr,'(a,a,a)',advance='no') ', "', trim(enum_str(jc)), '"'
1724        end do
1725        write(nulerr,'(a)') ''
1726        call radiation_abort('Radiation configuration error')
1727      end if
1728    end if
1729
1730  end subroutine get_enum_code
1731
1732
1733  !---------------------------------------------------------------------
1734  ! Print one line of information: logical
1735  subroutine print_logical(message_str, name, val)
1736    use radiation_io, only : nulout
1737    character(len=*),   intent(in) :: message_str
1738    character(len=*),   intent(in) :: name
1739    logical,            intent(in) :: val
1740    character(4)                   :: on_or_off
1741    character(NPrintStringLen)     :: str
1742    if (val) then
1743      on_or_off = ' ON '
1744    else
1745      on_or_off = ' OFF'
1746    end if
1747    write(str, '(a,a4)') message_str, on_or_off
1748    write(nulout,'(a,a,a,a,l1,a)') str, ' (', name, '=', val,')'
1749  end subroutine print_logical
1750
1751
1752  !---------------------------------------------------------------------
1753  ! Print one line of information: integer
1754  subroutine print_integer(message_str, name, val)
1755    use radiation_io, only : nulout
1756    character(len=*),   intent(in) :: message_str
1757    character(len=*),   intent(in) :: name
1758    integer,            intent(in) :: val
1759    character(NPrintStringLen)     :: str
1760    write(str, '(a,a,i0)') message_str, ' = ', val
1761    write(nulout,'(a,a,a,a)') str, ' (', name, ')'
1762  end subroutine print_integer
1763
1764
1765  !---------------------------------------------------------------------
1766  ! Print one line of information: real
1767  subroutine print_real(message_str, name, val)
1768    use parkind1,     only : jprb
1769    use radiation_io, only : nulout
1770    character(len=*),   intent(in) :: message_str
1771    character(len=*),   intent(in) :: name
1772    real(jprb),         intent(in) :: val
1773    character(NPrintStringLen)     :: str
1774    write(str, '(a,a,g8.3)') message_str, ' = ', val
1775    write(nulout,'(a,a,a,a)') str, ' (', name, ')'
1776  end subroutine print_real
1777
1778
1779  !---------------------------------------------------------------------
1780  ! Print one line of information: enum
1781  subroutine print_enum(message_str, enum_str, name, val)
1782    use radiation_io, only : nulout
1783    character(len=*),   intent(in) :: message_str
1784    character(len=*),   intent(in) :: enum_str(0:)
1785    character(len=*),   intent(in) :: name
1786    integer,            intent(in) :: val
1787    character(NPrintStringLen)     :: str
1788    write(str, '(a,a,a,a)') message_str, ' "', trim(enum_str(val)), '"'
1789    write(nulout,'(a,a,a,a,i0,a)') str, ' (', name, '=', val,')'
1790  end subroutine print_enum
1791
1792
1793  !---------------------------------------------------------------------
1794  ! Return .true. if 1D allocatable array "var" is out of physical
1795  ! range specified by boundmin and boundmax, and issue a warning.
1796  ! "do_fix" determines whether erroneous values are fixed to lie
1797  ! within the physical range. To check only a subset of the array,
1798  ! specify i1 and i2 for the range.
1799  function out_of_bounds_1d(var, var_name, boundmin, boundmax, do_fix, i1, i2) result (is_bad)
1800
1801    use radiation_io,     only : nulout
1802
1803    real(jprb), allocatable, intent(inout) :: var(:)
1804    character(len=*),        intent(in) :: var_name
1805    real(jprb),              intent(in) :: boundmin, boundmax
1806    logical,                 intent(in) :: do_fix
1807    integer,       optional, intent(in) :: i1, i2
1808
1809    logical                       :: is_bad
1810
1811    real(jprb) :: varmin, varmax
1812
1813    is_bad = .false.
1814
1815    if (allocated(var)) then
1816
1817      if (present(i1) .and. present(i2)) then
1818        varmin = minval(var(i1:i2))
1819        varmax = maxval(var(i1:i2))
1820      else
1821        varmin = minval(var)
1822        varmax = maxval(var)
1823      end if
1824
1825      if (varmin < boundmin .or. varmax > boundmax) then
1826        write(nulout,'(a,a,a,g12.4,a,g12.4,a,g12.4,a,g12.4)',advance='no') &
1827             &  '*** Warning: ', var_name, ' range', varmin, ' to', varmax, &
1828             &  ' is out of physical range', boundmin, 'to', boundmax
1829        is_bad = .true.
1830        if (do_fix) then
1831          if (present(i1) .and. present(i2)) then
1832            var(i1:i2) = max(boundmin, min(boundmax, var(i1:i2)))
1833          else
1834            var = max(boundmin, min(boundmax, var))
1835          end if
1836          write(nulout,'(a)') ': corrected'
1837        else
1838          write(nulout,'(1x)')
1839        end if
1840      end if
1841
1842    end if
1843   
1844  end function out_of_bounds_1d
1845
1846
1847  !---------------------------------------------------------------------
1848  ! Return .true. if 2D allocatable array "var" is out of physical
1849  ! range specified by boundmin and boundmax, and issue a warning.  To
1850  ! check only a subset of the array, specify i1 and i2 for the range
1851  ! of the first dimension and j1 and j2 for the range of the second.
1852  function out_of_bounds_2d(var, var_name, boundmin, boundmax, do_fix, &
1853       &                    i1, i2, j1, j2) result (is_bad)
1854
1855    use radiation_io,     only : nulout
1856
1857    real(jprb), allocatable, intent(inout) :: var(:,:)
1858    character(len=*),        intent(in) :: var_name
1859    real(jprb),              intent(in) :: boundmin, boundmax
1860    logical,                 intent(in) :: do_fix
1861    integer,       optional, intent(in) :: i1, i2, j1, j2
1862
1863    ! Local copies of indices
1864    integer :: ii1, ii2, jj1, jj2
1865
1866    logical                       :: is_bad
1867
1868    real(jprb) :: varmin, varmax
1869
1870    is_bad = .false.
1871
1872    if (allocated(var)) then
1873
1874      if (present(i1) .and. present(i2)) then
1875        ii1 = i1
1876        ii2 = i2
1877      else
1878        ii1 = lbound(var,1)
1879        ii2 = ubound(var,1)
1880      end if
1881      if (present(j1) .and. present(j2)) then
1882        jj1 = j1
1883        jj2 = j2
1884      else
1885        jj1 = lbound(var,2)
1886        jj2 = ubound(var,2)
1887      end if
1888      varmin = minval(var(ii1:ii2,jj1:jj2))
1889      varmax = maxval(var(ii1:ii2,jj1:jj2))
1890
1891      if (varmin < boundmin .or. varmax > boundmax) then
1892        write(nulout,'(a,a,a,g12.4,a,g12.4,a,g12.4,a,g12.4)',advance='no') &
1893             &  '*** Warning: ', var_name, ' range', varmin, ' to', varmax,&
1894             &  ' is out of physical range', boundmin, 'to', boundmax
1895        is_bad = .true.
1896        if (do_fix) then
1897          var(ii1:ii2,jj1:jj2) = max(boundmin, min(boundmax, var(ii1:ii2,jj1:jj2)))
1898          write(nulout,'(a)') ': corrected'
1899        else
1900          write(nulout,'(1x)')
1901        end if
1902      end if
1903
1904    end if
1905   
1906  end function out_of_bounds_2d
1907
1908
1909  !---------------------------------------------------------------------
1910  ! Return .true. if 3D allocatable array "var" is out of physical
1911  ! range specified by boundmin and boundmax, and issue a warning.  To
1912  ! check only a subset of the array, specify i1 and i2 for the range
1913  ! of the first dimension, j1 and j2 for the second and k1 and k2 for
1914  ! the third.
1915  function out_of_bounds_3d(var, var_name, boundmin, boundmax, do_fix, &
1916       &                    i1, i2, j1, j2, k1, k2) result (is_bad)
1917
1918    use radiation_io,     only : nulout
1919
1920    real(jprb), allocatable, intent(inout) :: var(:,:,:)
1921    character(len=*),        intent(in) :: var_name
1922    real(jprb),              intent(in) :: boundmin, boundmax
1923    logical,                 intent(in) :: do_fix
1924    integer,       optional, intent(in) :: i1, i2, j1, j2, k1, k2
1925
1926    ! Local copies of indices
1927    integer :: ii1, ii2, jj1, jj2, kk1, kk2
1928
1929    logical                       :: is_bad
1930
1931    real(jprb) :: varmin, varmax
1932
1933    is_bad = .false.
1934
1935    if (allocated(var)) then
1936
1937      if (present(i1) .and. present(i2)) then
1938        ii1 = i1
1939        ii2 = i2
1940      else
1941        ii1 = lbound(var,1)
1942        ii2 = ubound(var,1)
1943      end if
1944      if (present(j1) .and. present(j2)) then
1945        jj1 = j1
1946        jj2 = j2
1947      else
1948        jj1 = lbound(var,2)
1949        jj2 = ubound(var,2)
1950      end if
1951      if (present(k1) .and. present(k2)) then
1952        kk1 = k1
1953        kk2 = k2
1954      else
1955        kk1 = lbound(var,3)
1956        kk2 = ubound(var,3)
1957      end if
1958      varmin = minval(var(ii1:ii2,jj1:jj2,kk1:kk2))
1959      varmax = maxval(var(ii1:ii2,jj1:jj2,kk1:kk2))
1960
1961      if (varmin < boundmin .or. varmax > boundmax) then
1962        write(nulout,'(a,a,a,g12.4,a,g12.4,a,g12.4,a,g12.4)',advance='no') &
1963             &  '*** Warning: ', var_name, ' range', varmin, ' to', varmax,&
1964             &  ' is out of physical range', boundmin, 'to', boundmax
1965        is_bad = .true.
1966        if (do_fix) then
1967          var(ii1:ii2,jj1:jj2,kk1:kk2) = max(boundmin, min(boundmax, &
1968               &                             var(ii1:ii2,jj1:jj2,kk1:kk2)))
1969          write(nulout,'(a)') ': corrected'
1970        else
1971          write(nulout,'(1x)')
1972        end if
1973      end if
1974
1975    end if
1976   
1977  end function out_of_bounds_3d
1978
1979
1980end module radiation_config
Note: See TracBrowser for help on using the repository browser.