source: LMDZ6/trunk/libf/phylmd/ecrad.v1.5.1/radiation_interface.F90 @ 5229

Last change on this file since 5229 was 4489, checked in by lguez, 20 months ago

Merge LMDZ_ECRad branch back into trunk!

File size: 27.7 KB
Line 
1! radiation_interface.F90 - Public interface to 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-04-11  R. Hogan  Changes to enable generalized surface description
17!   2017-09-08  R. Hogan  Reverted some changes
18!
19! To use the radiation scheme, create a configuration_type object,
20! call "setup_radiation" on it once to load the look-up-tables and
21! data describing how gas and hydrometeor absorption/scattering are to
22! be represented, and call "radiation" multiple times on different
23! input profiles.
24
25module radiation_interface
26
27  implicit none
28
29  public  :: setup_radiation, set_gas_units, radiation
30  private :: radiation_reverse
31
32contains
33
34  !---------------------------------------------------------------------
35  ! Load the look-up-tables and data describing how gas and
36  ! hydrometeor absorption/scattering are to be represented
37  subroutine setup_radiation(config)
38
39    use parkind1,         only : jprb
40    use yomhook,          only : lhook, dr_hook
41    use radiation_config, only : config_type, ISolverMcICA, &
42         &   IGasModelMonochromatic, IGasModelIFSRRTMG, IGasModelECCKD
43    use radiation_spectral_definition, only &
44         &  : SolarReferenceTemperature, TerrestrialReferenceTemperature
45
46    ! Currently there are two gas absorption models: RRTMG (default)
47    ! and monochromatic
48    use radiation_monochromatic,  only : &
49         &   setup_gas_optics_mono     => setup_gas_optics, &
50         &   setup_cloud_optics_mono   => setup_cloud_optics, &
51         &   setup_aerosol_optics_mono => setup_aerosol_optics
52    use radiation_ifs_rrtm,       only :  setup_gas_optics_rrtmg => setup_gas_optics
53    use radiation_ecckd_interface,only :  setup_gas_optics_ecckd => setup_gas_optics
54    use radiation_cloud_optics,   only :  setup_cloud_optics
55    use radiation_general_cloud_optics, only :  setup_general_cloud_optics
56    use radiation_aerosol_optics, only :  setup_aerosol_optics
57
58    type(config_type), intent(inout) :: config
59
60    real(jprb) :: hook_handle
61
62    if (lhook) call dr_hook('radiation_interface:setup_radiation',0,hook_handle)
63
64    ! Consolidate configuration data, including setting data file
65    ! names
66    call config%consolidate()
67
68    ! Load the look-up tables from files in the specified directory
69    if (config%i_gas_model == IGasModelMonochromatic) then
70      call setup_gas_optics_mono(config, trim(config%directory_name))
71    else if (config%i_gas_model == IGasModelIFSRRTMG) then
72      call setup_gas_optics_rrtmg(config, trim(config%directory_name))
73    else if (config%i_gas_model == IGasModelECCKD) then
74      call setup_gas_optics_ecckd(config)
75    end if
76
77    ! Whether or not the "radiation" subroutine needs ssa_lw and g_lw
78    ! arrays depends on whether longwave scattering by aerosols is to
79    ! be included.  If not, one of the array dimensions will be set to
80    ! zero.
81    if (config%do_lw_aerosol_scattering) then
82      config%n_g_lw_if_scattering = config%n_g_lw
83    else
84      config%n_g_lw_if_scattering = 0
85    end if
86
87    ! Whether or not the "radiation" subroutine needs ssa_lw_cloud and
88    ! g_lw_cloud arrays depends on whether longwave scattering by
89    ! hydrometeors is to be included.  If not, one of the array
90    ! dimensions will be set to zero.
91    if (config%do_lw_cloud_scattering) then
92      config%n_bands_lw_if_scattering = config%n_bands_lw
93    else
94      config%n_bands_lw_if_scattering = 0
95    end if
96
97    ! If we have longwave scattering and McICA then even if there is
98    ! no aerosol, it is convenient if single scattering albedo and
99    ! g factor arrays are allocated before the call to
100    ! solver_lw as they will be needed.
101    if (config%do_lw_cloud_scattering &
102         &  .and. config%i_solver_lw == ISolverMcICA) then
103      config%n_g_lw_if_scattering = config%n_g_lw
104    end if
105
106    ! Consolidate the albedo/emissivity intervals with the shortwave
107    ! and longwave spectral bands
108    if (config%do_sw) then
109      call config%consolidate_sw_albedo_intervals
110    end if
111    if (config%do_lw) then
112      call config%consolidate_lw_emiss_intervals
113    end if
114
115    if (config%do_clouds) then
116      if (config%i_gas_model == IGasModelMonochromatic) then
117        !      call setup_cloud_optics_mono(config)
118      elseif (config%use_general_cloud_optics) then
119        call setup_general_cloud_optics(config)
120      else
121        call setup_cloud_optics(config)
122      end if
123    end if
124
125    if (config%use_aerosols) then
126      if (config%i_gas_model == IGasModelMonochromatic) then
127!        call setup_aerosol_optics_mono(config)
128      else
129        call setup_aerosol_optics(config)
130      end if
131    end if
132
133    ! Load cloud water PDF look-up table for McICA
134    if (         config%i_solver_sw == ISolverMcICA &
135         &  .or. config%i_solver_lw == ISolverMcICA) then
136      call config%pdf_sampler%setup(config%cloud_pdf_file_name, &
137           &                        iverbose=config%iverbosesetup)
138    end if
139
140    if (lhook) call dr_hook('radiation_interface:setup_radiation',1,hook_handle)
141
142  end subroutine setup_radiation
143
144
145  !---------------------------------------------------------------------
146  ! Scale the gas mixing ratios so that they have the units (and
147  ! possibly scale factors) required by the specific gas absorption
148  ! model.  This subroutine simply passes the gas object on to the
149  ! module of the currently active gas model.
150  subroutine set_gas_units(config, gas)
151   
152    use radiation_config
153    use radiation_gas,             only : gas_type
154    use radiation_monochromatic,   only : set_gas_units_mono  => set_gas_units
155    use radiation_ifs_rrtm,        only : set_gas_units_ifs   => set_gas_units
156    use radiation_ecckd_interface, only : set_gas_units_ecckd => set_gas_units
157
158    type(config_type), intent(in)    :: config
159    type(gas_type),    intent(inout) :: gas
160
161    if (config%i_gas_model == IGasModelMonochromatic) then
162      call set_gas_units_mono(gas)
163    elseif (config%i_gas_model == IGasModelECCKD) then
164      call set_gas_units_ecckd(gas)
165    else
166      call set_gas_units_ifs(gas)
167    end if
168
169  end subroutine set_gas_units
170
171
172  !---------------------------------------------------------------------
173  ! Run the radiation scheme according to the configuration in the
174  ! config object. There are ncol profiles of which only istartcol to
175  ! iendcol are to be processed, and there are nlev model levels.  The
176  ! output fluxes are written to the flux object, and all other
177  ! objects contain the input variables.  The variables may be defined
178  ! either in order of increasing or decreasing pressure, but if in
179  ! order of decreasing pressure then radiation_reverse will be called
180  ! to reverse the order for the computation and then reverse the
181  ! order of the output fluxes to match the inputs.
182  subroutine radiation(ncol, nlev, istartcol, iendcol, config, &
183       &  single_level, thermodynamics, gas, cloud, aerosol, flux)
184
185    use parkind1,                 only : jprb
186    use yomhook,                  only : lhook, dr_hook
187
188    use radiation_io,             only : nulout
189    use radiation_config,         only : config_type, &
190         &   IGasModelMonochromatic, IGasModelIFSRRTMG, &
191         &   ISolverMcICA, ISolverSpartacus, ISolverHomogeneous, &
192         &   ISolverTripleclouds
193    use radiation_single_level,   only : single_level_type
194    use radiation_thermodynamics, only : thermodynamics_type
195    use radiation_gas,            only : gas_type
196    use radiation_cloud,          only : cloud_type
197    use radiation_aerosol,        only : aerosol_type
198    use radiation_flux,           only : flux_type
199    use radiation_spartacus_sw,   only : solver_spartacus_sw
200    use radiation_spartacus_lw,   only : solver_spartacus_lw
201    use radiation_tripleclouds_sw,only : solver_tripleclouds_sw
202    use radiation_tripleclouds_lw,only : solver_tripleclouds_lw
203    use radiation_mcica_sw,       only : solver_mcica_sw
204    use radiation_mcica_lw,       only : solver_mcica_lw
205    use radiation_cloudless_sw,   only : solver_cloudless_sw
206    use radiation_cloudless_lw,   only : solver_cloudless_lw
207    use radiation_homogeneous_sw, only : solver_homogeneous_sw
208    use radiation_homogeneous_lw, only : solver_homogeneous_lw
209    use radiation_save,           only : save_radiative_properties
210
211    ! Treatment of gas and hydrometeor optics
212    use radiation_monochromatic,  only : &
213         &   gas_optics_mono         => gas_optics, &
214         &   cloud_optics_mono       => cloud_optics, &
215         &   add_aerosol_optics_mono => add_aerosol_optics
216    use radiation_ifs_rrtm,       only : gas_optics_rrtmg => gas_optics
217    use radiation_ecckd_interface,only : gas_optics_ecckd => gas_optics
218    use radiation_cloud_optics,   only : cloud_optics
219    use radiation_general_cloud_optics, only : general_cloud_optics
220    use radiation_aerosol_optics, only : add_aerosol_optics
221
222    ! Inputs
223    integer, intent(in) :: ncol               ! number of columns
224    integer, intent(in) :: nlev               ! number of model levels
225    integer, intent(in) :: istartcol, iendcol ! range of columns to process
226    type(config_type),        intent(in)   :: config
227    type(single_level_type),  intent(in)   :: single_level
228    type(thermodynamics_type),intent(in)   :: thermodynamics
229    type(gas_type),           intent(in)   :: gas
230    type(cloud_type),         intent(inout):: cloud
231    type(aerosol_type),       intent(in)   :: aerosol
232    ! Output
233    type(flux_type),          intent(inout):: flux
234
235
236    ! Local variables
237
238    ! Layer optical depth, single scattering albedo and asymmetry factor of
239    ! gases and aerosols at each longwave g-point, where the latter
240    ! two variables are only defined if aerosol longwave scattering is
241    ! enabled (otherwise both are treated as zero).
242    real(jprb), dimension(config%n_g_lw,nlev,istartcol:iendcol) :: od_lw
243    real(jprb), dimension(config%n_g_lw_if_scattering,nlev,istartcol:iendcol) :: &
244         &  ssa_lw, g_lw
245
246    ! Layer in-cloud optical depth, single scattering albedo and
247    ! asymmetry factor of hydrometeors in each longwave band, where
248    ! the latter two variables are only defined if hydrometeor
249    ! longwave scattering is enabled (otherwise both are treated as
250    ! zero).
251    real(jprb), dimension(config%n_bands_lw,nlev,istartcol:iendcol) :: od_lw_cloud
252    real(jprb), dimension(config%n_bands_lw_if_scattering,nlev,istartcol:iendcol) :: &
253         &  ssa_lw_cloud, g_lw_cloud
254
255    ! Layer optical depth, single scattering albedo and asymmetry factor of
256    ! gases and aerosols at each shortwave g-point
257    real(jprb), dimension(config%n_g_sw,nlev,istartcol:iendcol) :: od_sw, ssa_sw, g_sw
258
259    ! Layer in-cloud optical depth, single scattering albedo and
260    ! asymmetry factor of hydrometeors in each shortwave band
261    real(jprb), dimension(config%n_bands_sw,nlev,istartcol:iendcol)   :: &
262         &  od_sw_cloud, ssa_sw_cloud, g_sw_cloud
263
264    ! The Planck function (emitted flux from a black body) at half
265    ! levels
266    real(jprb), dimension(config%n_g_lw,nlev+1,istartcol:iendcol) :: planck_hl
267
268    ! The longwave emission from and albedo of the surface in each
269    ! longwave g-point; note that these are weighted averages of the
270    ! values from individual tiles
271    real(jprb), dimension(config%n_g_lw, istartcol:iendcol) :: lw_emission
272    real(jprb), dimension(config%n_g_lw, istartcol:iendcol) :: lw_albedo
273
274    ! Direct and diffuse shortwave surface albedo in each shortwave
275    ! g-point; note that these are weighted averages of the values
276    ! from individual tiles
277    real(jprb), dimension(config%n_g_sw, istartcol:iendcol) :: sw_albedo_direct
278    real(jprb), dimension(config%n_g_sw, istartcol:iendcol) :: sw_albedo_diffuse
279
280    ! The incoming shortwave flux into a plane perpendicular to the
281    ! incoming radiation at top-of-atmosphere in each of the shortwave
282    ! g-points
283    real(jprb), dimension(config%n_g_sw,istartcol:iendcol) :: incoming_sw
284
285    character(len=100) :: rad_prop_file_name
286    character(*), parameter :: rad_prop_base_file_name = "radiative_properties"
287
288    real(jprb) :: hook_handle
289
290    if (lhook) call dr_hook('radiation_interface:radiation',0,hook_handle)
291
292    if (thermodynamics%pressure_hl(istartcol,2) &
293         &  < thermodynamics%pressure_hl(istartcol,1)) then
294      ! Input arrays are arranged in order of decreasing pressure /
295      ! increasing height: the following subroutine reverses them,
296      ! call the radiation scheme and then reverses the returned
297      ! fluxes
298      call radiation_reverse(ncol, nlev, istartcol, iendcol, config, &
299           &  single_level, thermodynamics, gas, cloud, aerosol, flux)
300    else
301
302      ! Input arrays arranged in order of increasing pressure /
303      ! decreasing height: progress normally
304
305      ! Extract surface albedos at each gridpoint
306      call single_level%get_albedos(istartcol, iendcol, config, &
307           &                        sw_albedo_direct, sw_albedo_diffuse, &
308           &                        lw_albedo)
309
310      ! Compute gas absorption optical depth in shortwave and
311      ! longwave, shortwave single scattering albedo (i.e. fraction of
312      ! extinction due to Rayleigh scattering), Planck functions and
313      ! incoming shortwave flux at each g-point, for the specified
314      ! range of atmospheric columns
315      if (config%i_gas_model == IGasModelMonochromatic) then
316        call gas_optics_mono(ncol,nlev,istartcol,iendcol, config, &
317             &  single_level, thermodynamics, gas, lw_albedo, &
318             &  od_lw, od_sw, ssa_sw, &
319             &  planck_hl, lw_emission, incoming_sw)
320      else if (config%i_gas_model == IGasModelIFSRRTMG) then
321        call gas_optics_rrtmg(ncol,nlev,istartcol,iendcol, config, &
322             &  single_level, thermodynamics, gas, &
323             &  od_lw, od_sw, ssa_sw, lw_albedo=lw_albedo, &
324             &  planck_hl=planck_hl, lw_emission=lw_emission, &
325             &  incoming_sw=incoming_sw)
326      else
327        call gas_optics_ecckd(ncol,nlev,istartcol,iendcol, config, &
328             &  single_level, thermodynamics, gas, &
329             &  od_lw, od_sw, ssa_sw, lw_albedo=lw_albedo, &
330             &  planck_hl=planck_hl, lw_emission=lw_emission, &
331             &  incoming_sw=incoming_sw)
332      end if
333
334      if (config%do_clouds) then
335        ! Crop the cloud fraction to remove clouds that have too small
336        ! a fraction or water content; after this, we can safely
337        ! assume that a cloud is present if cloud%fraction > 0.0.
338        call cloud%crop_cloud_fraction(istartcol, iendcol, &
339             &            config%cloud_fraction_threshold, &
340             &            config%cloud_mixing_ratio_threshold)
341
342        ! Compute hydrometeor absorption/scattering properties in each
343        ! shortwave and longwave band
344        if (config%i_gas_model == IGasModelMonochromatic) then
345          call cloud_optics_mono(nlev, istartcol, iendcol, &
346               &  config, thermodynamics, cloud, &
347               &  od_lw_cloud, ssa_lw_cloud, g_lw_cloud, &
348               &  od_sw_cloud, ssa_sw_cloud, g_sw_cloud)
349        elseif (config%use_general_cloud_optics) then
350          call general_cloud_optics(nlev, istartcol, iendcol, &
351               &  config, thermodynamics, cloud, &
352               &  od_lw_cloud, ssa_lw_cloud, g_lw_cloud, &
353               &  od_sw_cloud, ssa_sw_cloud, g_sw_cloud)
354        else
355          call cloud_optics(nlev, istartcol, iendcol, &
356               &  config, thermodynamics, cloud, &
357               &  od_lw_cloud, ssa_lw_cloud, g_lw_cloud, &
358               &  od_sw_cloud, ssa_sw_cloud, g_sw_cloud)
359        end if
360      end if ! do_clouds
361
362      if (config%use_aerosols) then
363        if (config%i_gas_model == IGasModelMonochromatic) then
364!          call add_aerosol_optics_mono(nlev,istartcol,iendcol, &
365!               &  config, thermodynamics, gas, aerosol, &
366!               &  od_lw, ssa_lw, g_lw, od_sw, ssa_sw, g_sw)
367        else
368          call add_aerosol_optics(nlev,istartcol,iendcol, &
369               &  config, thermodynamics, gas, aerosol, &
370               &  od_lw, ssa_lw, g_lw, od_sw, ssa_sw, g_sw)
371        end if
372      else
373        g_sw(:,:,istartcol:iendcol) = 0.0_jprb
374        if (config%do_lw_aerosol_scattering) then
375          ssa_lw(:,:,istartcol:iendcol) = 0.0_jprb
376          g_lw(:,:,istartcol:iendcol)   = 0.0_jprb
377        end if
378      end if
379
380      ! For diagnostic purposes, save these intermediate variables to
381      ! a NetCDF file
382      if (config%do_save_radiative_properties) then
383        if (istartcol == 1 .and. iendcol == ncol) then
384          rad_prop_file_name = rad_prop_base_file_name // ".nc"
385        else
386          write(rad_prop_file_name,'(a,a,i4.4,a,i4.4,a)') &
387               &  rad_prop_base_file_name, '_', istartcol, '-',iendcol,'.nc'
388        end if
389        call save_radiative_properties(trim(rad_prop_file_name), &
390             &  nlev, istartcol, iendcol, &
391             &  config, single_level, thermodynamics, cloud, &
392             &  planck_hl, lw_emission, lw_albedo, &
393             &  sw_albedo_direct, sw_albedo_diffuse, incoming_sw, &
394             &  od_lw, ssa_lw, g_lw, od_sw, ssa_sw, g_sw, &
395             &  od_lw_cloud, ssa_lw_cloud, g_lw_cloud, &
396             &  od_sw_cloud, ssa_sw_cloud, g_sw_cloud)
397      end if
398
399      if (config%do_lw) then
400        if (config%iverbose >= 2) then
401          write(nulout,'(a)') 'Computing longwave fluxes'
402        end if
403
404        if (config%i_solver_lw == ISolverMcICA) then
405          ! Compute fluxes using the McICA longwave solver
406          call solver_mcica_lw(nlev,istartcol,iendcol, &
407               &  config, single_level, cloud, &
408               &  od_lw, ssa_lw, g_lw, od_lw_cloud, ssa_lw_cloud, &
409               &  g_lw_cloud, planck_hl, lw_emission, lw_albedo, flux)
410        else if (config%i_solver_lw == ISolverSPARTACUS) then
411          ! Compute fluxes using the SPARTACUS longwave solver
412          call solver_spartacus_lw(nlev,istartcol,iendcol, &
413               &  config, thermodynamics, cloud, &
414               &  od_lw, ssa_lw, g_lw, od_lw_cloud, ssa_lw_cloud, g_lw_cloud, &
415               &  planck_hl, lw_emission, lw_albedo, flux)
416        else if (config%i_solver_lw == ISolverTripleclouds) then
417          ! Compute fluxes using the Tripleclouds longwave solver
418          call solver_tripleclouds_lw(nlev,istartcol,iendcol, &
419               &  config, cloud, &
420               &  od_lw, ssa_lw, g_lw, od_lw_cloud, ssa_lw_cloud, g_lw_cloud, &
421               &  planck_hl, lw_emission, lw_albedo, flux)
422        elseif (config%i_solver_lw == ISolverHomogeneous) then
423          ! Compute fluxes using the homogeneous solver
424          call solver_homogeneous_lw(nlev,istartcol,iendcol, &
425               &  config, cloud, &
426               &  od_lw, ssa_lw, g_lw, od_lw_cloud, ssa_lw_cloud, &
427               &  g_lw_cloud, planck_hl, lw_emission, lw_albedo, flux)
428        else
429          ! Compute fluxes using the cloudless solver
430          call solver_cloudless_lw(nlev,istartcol,iendcol, &
431               &  config, od_lw, ssa_lw, g_lw, &
432               &  planck_hl, lw_emission, lw_albedo, flux)
433        end if
434      end if
435
436      if (config%do_sw) then
437        if (config%iverbose >= 2) then
438          write(nulout,'(a)') 'Computing shortwave fluxes'
439        end if
440
441        if (config%i_solver_sw == ISolverMcICA) then
442          ! Compute fluxes using the McICA shortwave solver
443          call solver_mcica_sw(nlev,istartcol,iendcol, &
444               &  config, single_level, cloud, &
445               &  od_sw, ssa_sw, g_sw, od_sw_cloud, ssa_sw_cloud, &
446               &  g_sw_cloud, sw_albedo_direct, sw_albedo_diffuse, &
447               &  incoming_sw, flux)
448        else if (config%i_solver_sw == ISolverSPARTACUS) then
449          ! Compute fluxes using the SPARTACUS shortwave solver
450          call solver_spartacus_sw(nlev,istartcol,iendcol, &
451               &  config, single_level, thermodynamics, cloud, &
452               &  od_sw, ssa_sw, g_sw, od_sw_cloud, ssa_sw_cloud, &
453               &  g_sw_cloud, sw_albedo_direct, sw_albedo_diffuse, &
454               &  incoming_sw, flux)
455        else if (config%i_solver_sw == ISolverTripleclouds) then
456          ! Compute fluxes using the Tripleclouds shortwave solver
457          call solver_tripleclouds_sw(nlev,istartcol,iendcol, &
458               &  config, single_level, cloud, &
459               &  od_sw, ssa_sw, g_sw, od_sw_cloud, ssa_sw_cloud, &
460               &  g_sw_cloud, sw_albedo_direct, sw_albedo_diffuse, &
461               &  incoming_sw, flux)
462        elseif (config%i_solver_sw == ISolverHomogeneous) then
463          ! Compute fluxes using the homogeneous solver
464          call solver_homogeneous_sw(nlev,istartcol,iendcol, &
465               &  config, single_level, cloud, &
466               &  od_sw, ssa_sw, g_sw, od_sw_cloud, ssa_sw_cloud, &
467               &  g_sw_cloud, sw_albedo_direct, sw_albedo_diffuse, &
468               &  incoming_sw, flux)
469        else
470          ! Compute fluxes using the cloudless solver
471          call solver_cloudless_sw(nlev,istartcol,iendcol, &
472               &  config, single_level, od_sw, ssa_sw, g_sw, &
473               &  sw_albedo_direct, sw_albedo_diffuse, &
474               &  incoming_sw, flux)
475        end if
476      end if
477
478      ! Store surface downwelling fluxes in bands from fluxes in g
479      ! points
480      call flux%calc_surface_spectral(config, istartcol, iendcol)
481
482    end if
483   
484    if (lhook) call dr_hook('radiation_interface:radiation',1,hook_handle)
485
486  end subroutine radiation
487
488
489  !---------------------------------------------------------------------
490  ! If the input arrays are arranged in order of decreasing pressure /
491  ! increasing height then this subroutine reverses them, calls the
492  ! radiation scheme and then reverses the returned fluxes. Since this
493  ! subroutine calls, and is called by "radiation", it must be in this
494  ! module to avoid circular dependencies.
495  subroutine radiation_reverse(ncol, nlev, istartcol, iendcol, config, &
496       &  single_level, thermodynamics, gas, cloud, aerosol, flux)
497 
498    use parkind1, only : jprb
499
500    use radiation_io,             only : nulout
501    use radiation_config,         only : config_type
502    use radiation_single_level,   only : single_level_type
503    use radiation_thermodynamics, only : thermodynamics_type
504    use radiation_gas,            only : gas_type
505    use radiation_cloud,          only : cloud_type
506    use radiation_aerosol,        only : aerosol_type
507    use radiation_flux,           only : flux_type
508
509    ! Inputs
510    integer, intent(in) :: ncol               ! number of columns
511    integer, intent(in) :: nlev               ! number of model levels
512    integer, intent(in) :: istartcol, iendcol ! range of columns to process
513    type(config_type),        intent(in) :: config
514    type(single_level_type),  intent(in) :: single_level
515    type(thermodynamics_type),intent(in) :: thermodynamics
516    type(gas_type),           intent(in) :: gas
517    type(cloud_type),         intent(in) :: cloud
518    type(aerosol_type),       intent(in) :: aerosol
519    ! Output
520    type(flux_type),          intent(inout):: flux
521
522    ! Reversed data structures
523    type(thermodynamics_type) :: thermodynamics_rev
524    type(gas_type)            :: gas_rev
525    type(cloud_type)          :: cloud_rev
526    type(aerosol_type)        :: aerosol_rev
527    type(flux_type)           :: flux_rev
528
529    ! Start and end levels for aerosol data
530    integer :: istartlev, iendlev
531
532    if (config%iverbose >= 2) then
533      write(nulout,'(a)') 'Reversing arrays to be in order of increasing pressure'
534    end if
535
536    ! Allocate reversed arrays
537    call thermodynamics_rev%allocate(ncol, nlev)
538    call cloud_rev%allocate(ncol, nlev)
539    call flux_rev%allocate(config, istartcol, iendcol, nlev)
540    if (allocated(aerosol%mixing_ratio)) then
541      istartlev = nlev + 1 - aerosol%iendlev
542      iendlev   = nlev + 1 - aerosol%istartlev
543      call aerosol_rev%allocate(ncol, istartlev, iendlev, &
544           &                    config%n_aerosol_types)
545    end if
546
547    ! Fill reversed thermodynamic arrays
548    thermodynamics_rev%pressure_hl(istartcol:iendcol,:) &
549         &  = thermodynamics%pressure_hl(istartcol:iendcol, nlev+1:1:-1)
550    thermodynamics_rev%temperature_hl(istartcol:iendcol,:) &
551         &  = thermodynamics%temperature_hl(istartcol:iendcol, nlev+1:1:-1)
552
553    ! Fill reversed gas arrays
554    call gas%reverse(istartcol, iendcol, gas_rev)
555
556    if (config%do_clouds) then
557      ! Fill reversed cloud arrays
558      cloud_rev%q_liq(istartcol:iendcol,:) &
559           &  = cloud%q_liq(istartcol:iendcol,nlev:1:-1)
560      cloud_rev%re_liq(istartcol:iendcol,:) &
561           &  = cloud%re_liq(istartcol:iendcol,nlev:1:-1)
562      cloud_rev%q_ice(istartcol:iendcol,:) &
563           &  = cloud%q_ice(istartcol:iendcol,nlev:1:-1)
564      cloud_rev%re_ice(istartcol:iendcol,:) &
565           &  = cloud%re_ice(istartcol:iendcol,nlev:1:-1)
566      cloud_rev%fraction(istartcol:iendcol,:) &
567           &  = cloud%fraction(istartcol:iendcol,nlev:1:-1)
568      cloud_rev%overlap_param(istartcol:iendcol,:) &
569           &  = cloud%overlap_param(istartcol:iendcol,nlev-1:1:-1)
570      if (allocated(cloud%fractional_std)) then
571        cloud_rev%fractional_std(istartcol:iendcol,:) &
572             &  = cloud%fractional_std(istartcol:iendcol,nlev:1:-1)
573      else
574        cloud_rev%fractional_std(istartcol:iendcol,:) = 0.0_jprb       
575      end if
576      if (allocated(cloud%inv_cloud_effective_size)) then
577        cloud_rev%inv_cloud_effective_size(istartcol:iendcol,:) &
578             &  = cloud%inv_cloud_effective_size(istartcol:iendcol,nlev:1:-1)
579      else
580        cloud_rev%inv_cloud_effective_size(istartcol:iendcol,:) = 0.0_jprb
581      end if
582    end if
583
584    if (allocated(aerosol%mixing_ratio)) then
585      aerosol_rev%mixing_ratio(:,istartlev:iendlev,:) &
586           &  = aerosol%mixing_ratio(:,aerosol%iendlev:aerosol%istartlev:-1,:)
587    end if
588
589    ! Run radiation scheme on reversed profiles
590    call radiation(ncol, nlev,istartcol,iendcol, &
591         &  config, single_level, thermodynamics_rev, gas_rev, &
592         &  cloud_rev, aerosol_rev, flux_rev)
593
594    ! Reorder fluxes
595    if (allocated(flux%lw_up)) then
596      flux%lw_up(istartcol:iendcol,:) &
597           &  = flux_rev%lw_up(istartcol:iendcol,nlev+1:1:-1)
598      flux%lw_dn(istartcol:iendcol,:) &
599           &  = flux_rev%lw_dn(istartcol:iendcol,nlev+1:1:-1)
600      if (allocated(flux%lw_up_clear)) then
601        flux%lw_up_clear(istartcol:iendcol,:) &
602             &  = flux_rev%lw_up_clear(istartcol:iendcol,nlev+1:1:-1)
603        flux%lw_dn_clear(istartcol:iendcol,:) &
604             &  = flux_rev%lw_dn_clear(istartcol:iendcol,nlev+1:1:-1)
605      end if
606    end if
607    if (allocated(flux%sw_up)) then
608      flux%sw_up(istartcol:iendcol,:) &
609           &  = flux_rev%sw_up(istartcol:iendcol,nlev+1:1:-1)
610      flux%sw_dn(istartcol:iendcol,:) &
611           &  = flux_rev%sw_dn(istartcol:iendcol,nlev+1:1:-1)
612      if (allocated(flux%sw_dn_direct)) then
613        flux%sw_dn_direct(istartcol:iendcol,:) &
614             &  = flux_rev%sw_dn_direct(istartcol:iendcol,nlev+1:1:-1)
615      end if
616      if (allocated(flux%sw_up_clear)) then
617        flux%sw_up_clear(istartcol:iendcol,:) &
618             &  = flux_rev%sw_up_clear(istartcol:iendcol,nlev+1:1:-1)
619        flux%sw_dn_clear(istartcol:iendcol,:) &
620             &  = flux_rev%sw_dn_clear(istartcol:iendcol,nlev+1:1:-1)
621        if (allocated(flux%sw_dn_direct_clear)) then
622          flux%sw_dn_direct_clear(istartcol:iendcol,:) &
623               &  = flux_rev%sw_dn_direct_clear(istartcol:iendcol,nlev+1:1:-1)
624        end if
625      end if
626    end if
627
628    ! Deallocate reversed arrays
629    call thermodynamics_rev%deallocate
630    call gas_rev%deallocate
631    call cloud_rev%deallocate
632    call flux_rev%deallocate
633    if (allocated(aerosol%mixing_ratio)) then
634      call aerosol_rev%deallocate
635    end if
636
637  end subroutine radiation_reverse
638
639end module radiation_interface
Note: See TracBrowser for help on using the repository browser.