source: LMDZ6/branches/Amaury_dev/libf/phylmd/ecrad.v1.5.1/radiation_mcica_sw.F90

Last change on this file was 5159, checked in by abarral, 3 months ago

Put dimensions.h and paramet.h into modules

File size: 15.2 KB
RevLine 
[3908]1! radiation_mcica_sw.F90 - Monte-Carlo Independent Column Approximation shortwave solver
[5159]2
[3908]3! (C) Copyright 2015- ECMWF.
[5159]4
[3908]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.
[5159]7
[3908]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.
[5159]11
[3908]12! Author:  Robin Hogan
13! Email:   r.j.hogan@ecmwf.int
[5159]14
[3908]15! Modifications
16!   2017-04-11  R. Hogan  Receive albedos at g-points
17!   2017-04-22  R. Hogan  Store surface fluxes at all g-points
18!   2017-10-23  R. Hogan  Renamed single-character variables
19
20module radiation_mcica_sw
21
22  public
23
24contains
25
26  ! Provides elemental function "delta_eddington"
27#include "radiation_delta_eddington.h"
28
29  !---------------------------------------------------------------------
30  ! Shortwave Monte Carlo Independent Column Approximation
31  ! (McICA). This implementation performs a clear-sky and a cloudy-sky
32  ! calculation, and then weights the two to get the all-sky fluxes
33  ! according to the total cloud cover. This method reduces noise for
34  ! low cloud cover situations, and exploits the clear-sky
35  ! calculations that are usually performed for diagnostic purposes
36  ! simultaneously. The cloud generator has been carefully written
37  ! such that the stochastic cloud field satisfies the prescribed
38  ! overlap parameter accounting for this weighting.
39  subroutine solver_mcica_sw(nlev,istartcol,iendcol, &
40       &  config, single_level, cloud, &
41       &  od, ssa, g, od_cloud, ssa_cloud, g_cloud, &
42       &  albedo_direct, albedo_diffuse, incoming_sw, &
43       &  flux)
44
45    use parkind1, only           : jprb
46    use yomhook,  only           : lhook, dr_hook
47
48    use radiation_io,   only           : nulerr, radiation_abort
49    use radiation_config, only         : config_type
50    use radiation_single_level, only   : single_level_type
51    use radiation_cloud, only          : cloud_type
52    use radiation_flux, only           : flux_type
53    use radiation_two_stream, only     : calc_two_stream_gammas_sw, &
54         &                               calc_reflectance_transmittance_sw
55    use radiation_adding_ica_sw, only  : adding_ica_sw
56    use radiation_cloud_generator, only: cloud_generator
57
58    implicit none
59
60    ! Inputs
61    integer, intent(in) :: nlev               ! number of model levels
62    integer, intent(in) :: istartcol, iendcol ! range of columns to process
63    type(config_type),        intent(in) :: config
64    type(single_level_type),  intent(in) :: single_level
65    type(cloud_type),         intent(in) :: cloud
66
67    ! Gas and aerosol optical depth, single-scattering albedo and
68    ! asymmetry factor at each shortwave g-point
69    real(jprb), intent(in), dimension(config%n_g_sw, nlev, istartcol:iendcol) :: &
70         &  od, ssa, g
71
72    ! Cloud and precipitation optical depth, single-scattering albedo and
73    ! asymmetry factor in each shortwave band
74    real(jprb), intent(in), dimension(config%n_bands_sw,nlev,istartcol:iendcol)   :: &
75         &  od_cloud, ssa_cloud, g_cloud
76
77    ! Direct and diffuse surface albedos, and the incoming shortwave
78    ! flux into a plane perpendicular to the incoming radiation at
79    ! top-of-atmosphere in each of the shortwave g points
80    real(jprb), intent(in), dimension(config%n_g_sw,istartcol:iendcol) :: &
81         &  albedo_direct, albedo_diffuse, incoming_sw
82
83    ! Output
84    type(flux_type), intent(inout):: flux
85
86    ! Local variables
87
88    ! Cosine of solar zenith angle
89    real(jprb)                                 :: cos_sza
90
91    ! Diffuse reflectance and transmittance for each layer in clear
92    ! and all skies
93    real(jprb), dimension(config%n_g_sw, nlev) :: ref_clear, trans_clear, reflectance, transmittance
94
95    ! Fraction of direct beam scattered by a layer into the upwelling
96    ! or downwelling diffuse streams, in clear and all skies
97    real(jprb), dimension(config%n_g_sw, nlev) :: ref_dir_clear, trans_dir_diff_clear, ref_dir, trans_dir_diff
98
99    ! Transmittance for the direct beam in clear and all skies
100    real(jprb), dimension(config%n_g_sw, nlev) :: trans_dir_dir_clear, trans_dir_dir
101
102    ! Fluxes per g point
103    real(jprb), dimension(config%n_g_sw, nlev+1) :: flux_up, flux_dn_diffuse, flux_dn_direct
104
105    ! Combined gas+aerosol+cloud optical depth, single scattering
106    ! albedo and asymmetry factor
107    real(jprb), dimension(config%n_g_sw) :: od_total, ssa_total, g_total
108
109    ! Combined scattering optical depth
110    real(jprb) :: scat_od
111
112    ! Two-stream coefficients
113    real(jprb), dimension(config%n_g_sw) :: gamma1, gamma2, gamma3
114
115    ! Optical depth scaling from the cloud generator, zero indicating
116    ! clear skies
117    real(jprb), dimension(config%n_g_sw,nlev) :: od_scaling
118
119    ! Modified optical depth after McICA scaling to represent cloud
120    ! inhomogeneity
121    real(jprb), dimension(config%n_g_sw) :: od_cloud_new
122
123    ! Total cloud cover output from the cloud generator
124    real(jprb) :: total_cloud_cover
125
126    ! Number of g points
127    integer :: ng
128
129    ! Loop indices for level, column and g point
130    integer :: jlev, jcol, jg
131
132    real(jprb) :: hook_handle
133
134    if (lhook) call dr_hook('radiation_mcica_sw:solver_mcica_sw',0,hook_handle)
135
136    if (.not. config%do_clear) then
137      write(nulerr,'(a)') '*** Error: shortwave McICA requires clear-sky calculation to be performed'
138      call radiation_abort()     
139    end if
140
141    ng = config%n_g_sw
142
143    ! Loop through columns
[5158]144    DO jcol = istartcol,iendcol
[3908]145      ! Only perform calculation if sun above the horizon
146      if (single_level%cos_sza(jcol) > 0.0_jprb) then
147        cos_sza = single_level%cos_sza(jcol)
148
149        ! Clear-sky calculation - first compute clear-sky reflectance,
150        ! transmittance etc at each model level
151        if (.not. config%do_sw_delta_scaling_with_gases) then
152          ! Delta-Eddington scaling has already been performed to the
153          ! aerosol part of od, ssa and g
[5158]154          DO jlev = 1,nlev
[3908]155            call calc_two_stream_gammas_sw(ng, &
156                 &  cos_sza, ssa(:,jlev,jcol), g(:,jlev,jcol), &
157                 &  gamma1, gamma2, gamma3)
158            call calc_reflectance_transmittance_sw(ng, &
159                 &  cos_sza, od(:,jlev,jcol), ssa(:,jlev,jcol), &
160                 &  gamma1, gamma2, gamma3, &
161                 &  ref_clear(:,jlev), trans_clear(:,jlev), &
162                 &  ref_dir_clear(:,jlev), trans_dir_diff_clear(:,jlev), &
163                 &  trans_dir_dir_clear(:,jlev) )
164          end do
165        else
166          ! Apply delta-Eddington scaling to the aerosol-gas mixture
[5158]167          DO jlev = 1,nlev
[3908]168            od_total  =  od(:,jlev,jcol)
169            ssa_total = ssa(:,jlev,jcol)
170            g_total   =   g(:,jlev,jcol)
171            call delta_eddington(od_total, ssa_total, g_total)
172            call calc_two_stream_gammas_sw(ng, &
173                 &  cos_sza, ssa_total, g_total, &
174                 &  gamma1, gamma2, gamma3)
175            call calc_reflectance_transmittance_sw(ng, &
176                 &  cos_sza, od_total, ssa_total, &
177                 &  gamma1, gamma2, gamma3, &
178                 &  ref_clear(:,jlev), trans_clear(:,jlev), &
179                 &  ref_dir_clear(:,jlev), trans_dir_diff_clear(:,jlev), &
180                 &  trans_dir_dir_clear(:,jlev) )
181          end do
182        end if
183
184        ! Use adding method to compute fluxes
185        call adding_ica_sw(ng, nlev, incoming_sw(:,jcol), &
186             &  albedo_diffuse(:,jcol), albedo_direct(:,jcol), spread(cos_sza,1,ng), &
187             &  ref_clear, trans_clear, ref_dir_clear, trans_dir_diff_clear, &
188             &  trans_dir_dir_clear, flux_up, flux_dn_diffuse, flux_dn_direct)
189       
190        ! Sum over g-points to compute and save clear-sky broadband
191        ! fluxes
192        flux%sw_up_clear(jcol,:) = sum(flux_up,1)
193        if (allocated(flux%sw_dn_direct_clear)) then
194          flux%sw_dn_direct_clear(jcol,:) &
195               &  = sum(flux_dn_direct,1)
196          flux%sw_dn_clear(jcol,:) = sum(flux_dn_diffuse,1) &
197               &  + flux%sw_dn_direct_clear(jcol,:)
198        else
199          flux%sw_dn_clear(jcol,:) = sum(flux_dn_diffuse,1) &
200               &  + sum(flux_dn_direct,1)
201        end if
202        ! Store spectral downwelling fluxes at surface
203        flux%sw_dn_diffuse_surf_clear_g(:,jcol) = flux_dn_diffuse(:,nlev+1)
204        flux%sw_dn_direct_surf_clear_g(:,jcol)  = flux_dn_direct(:,nlev+1)
205
206        ! Do cloudy-sky calculation
207        call cloud_generator(ng, nlev, config%i_overlap_scheme, &
208             &  single_level%iseed(jcol), &
209             &  config%cloud_fraction_threshold, &
210             &  cloud%fraction(jcol,:), cloud%overlap_param(jcol,:), &
211             &  config%cloud_inhom_decorr_scaling, cloud%fractional_std(jcol,:), &
212             &  config%pdf_sampler, od_scaling, total_cloud_cover, &
[4489]213             &  use_beta_overlap=config%use_beta_overlap, &
214             &  use_vectorizable_generator=config%use_vectorizable_generator)
[3908]215
216        ! Store total cloud cover
217        flux%cloud_cover_sw(jcol) = total_cloud_cover
218       
219        if (total_cloud_cover >= config%cloud_fraction_threshold) then
220          ! Total-sky calculation
[5158]221          DO jlev = 1,nlev
[3908]222            ! Compute combined gas+aerosol+cloud optical properties
223            if (cloud%fraction(jcol,jlev) >= config%cloud_fraction_threshold) then
[5158]224              DO jg = 1,ng
[4489]225                od_cloud_new(jg) = od_scaling(jg,jlev) &
226                   &  * od_cloud(config%i_band_from_reordered_g_sw(jg),jlev,jcol)
227                od_total(jg)  = od(jg,jlev,jcol) + od_cloud_new(jg)
228                ssa_total(jg) = 0.0_jprb
229                g_total(jg)   = 0.0_jprb
230
231                ! In single precision we need to protect against the
232                ! case that od_total > 0.0 and ssa_total > 0.0 but
233                ! od_total*ssa_total == 0 due to underflow
[3908]234                if (od_total(jg) > 0.0_jprb) then
235                  scat_od = ssa(jg,jlev,jcol)*od(jg,jlev,jcol) &
236                       &     + ssa_cloud(config%i_band_from_reordered_g_sw(jg),jlev,jcol) &
237                       &     *  od_cloud_new(jg)
238                  ssa_total(jg) = scat_od / od_total(jg)
239                  if (scat_od > 0.0_jprb) then
240                    g_total(jg) = (g(jg,jlev,jcol)*ssa(jg,jlev,jcol)*od(jg,jlev,jcol) &
241                         &     +   g_cloud(config%i_band_from_reordered_g_sw(jg),jlev,jcol) &
242                         &     * ssa_cloud(config%i_band_from_reordered_g_sw(jg),jlev,jcol) &
243                         &     *  od_cloud_new(jg)) &
244                         &     / scat_od
245                  end if
246                end if
247              end do
248
249              ! Apply delta-Eddington scaling to the cloud-aerosol-gas
250              ! mixture
251              if (config%do_sw_delta_scaling_with_gases) then
252                call delta_eddington(od_total, ssa_total, g_total)
253              end if
254
255             ! Compute cloudy-sky reflectance, transmittance etc at
256              ! each model level
257              call calc_two_stream_gammas_sw(ng, &
258                   &  cos_sza, ssa_total, g_total, &
259                   &  gamma1, gamma2, gamma3)
260
261              call calc_reflectance_transmittance_sw(ng, &
262                   &  cos_sza, od_total, ssa_total, &
263                   &  gamma1, gamma2, gamma3, &
264                   &  reflectance(:,jlev), transmittance(:,jlev), &
265                   &  ref_dir(:,jlev), trans_dir_diff(:,jlev), &
266                   &  trans_dir_dir(:,jlev) )
267
268            else
269              ! Clear-sky layer: copy over clear-sky values
270              reflectance(:,jlev) = ref_clear(:,jlev)
271              transmittance(:,jlev) = trans_clear(:,jlev)
272              ref_dir(:,jlev) = ref_dir_clear(:,jlev)
273              trans_dir_diff(:,jlev) = trans_dir_diff_clear(:,jlev)
274              trans_dir_dir(:,jlev) = trans_dir_dir_clear(:,jlev)
275            end if
276          end do
277           
278          ! Use adding method to compute fluxes for an overcast sky
279          call adding_ica_sw(ng, nlev, incoming_sw(:,jcol), &
280               &  albedo_diffuse(:,jcol), albedo_direct(:,jcol), spread(cos_sza,1,ng), &
281               &  reflectance, transmittance, ref_dir, trans_dir_diff, &
282               &  trans_dir_dir, flux_up, flux_dn_diffuse, flux_dn_direct)
283         
284          ! Store overcast broadband fluxes
285          flux%sw_up(jcol,:) = sum(flux_up,1)
286          if (allocated(flux%sw_dn_direct)) then
287            flux%sw_dn_direct(jcol,:) = sum(flux_dn_direct,1)
288            flux%sw_dn(jcol,:) = sum(flux_dn_diffuse,1) &
289                 &  + flux%sw_dn_direct(jcol,:)
290          else
291            flux%sw_dn(jcol,:) = sum(flux_dn_diffuse,1) &
292                 &  + sum(flux_dn_direct,1)
293          end if
294
295          ! Cloudy flux profiles currently assume completely overcast
296          ! skies; perform weighted average with clear-sky profile
297          flux%sw_up(jcol,:) =  total_cloud_cover *flux%sw_up(jcol,:) &
298               &  + (1.0_jprb - total_cloud_cover)*flux%sw_up_clear(jcol,:)
299          flux%sw_dn(jcol,:) =  total_cloud_cover *flux%sw_dn(jcol,:) &
300               &  + (1.0_jprb - total_cloud_cover)*flux%sw_dn_clear(jcol,:)
301          if (allocated(flux%sw_dn_direct)) then
302            flux%sw_dn_direct(jcol,:) = total_cloud_cover *flux%sw_dn_direct(jcol,:) &
303                 &  + (1.0_jprb - total_cloud_cover)*flux%sw_dn_direct_clear(jcol,:)
304          end if
305          ! Likewise for surface spectral fluxes
306          flux%sw_dn_diffuse_surf_g(:,jcol) = flux_dn_diffuse(:,nlev+1)
307          flux%sw_dn_direct_surf_g(:,jcol)  = flux_dn_direct(:,nlev+1)
308          flux%sw_dn_diffuse_surf_g(:,jcol) = total_cloud_cover *flux%sw_dn_diffuse_surf_g(:,jcol) &
309               &     + (1.0_jprb - total_cloud_cover)*flux%sw_dn_diffuse_surf_clear_g(:,jcol)
310          flux%sw_dn_direct_surf_g(:,jcol) = total_cloud_cover *flux%sw_dn_direct_surf_g(:,jcol) &
311               &     + (1.0_jprb - total_cloud_cover)*flux%sw_dn_direct_surf_clear_g(:,jcol)
312         
313        else
314          ! No cloud in profile and clear-sky fluxes already
315          ! calculated: copy them over
316          flux%sw_up(jcol,:) = flux%sw_up_clear(jcol,:)
317          flux%sw_dn(jcol,:) = flux%sw_dn_clear(jcol,:)
318          if (allocated(flux%sw_dn_direct)) then
319            flux%sw_dn_direct(jcol,:) = flux%sw_dn_direct_clear(jcol,:)
320          end if
321          flux%sw_dn_diffuse_surf_g(:,jcol) = flux%sw_dn_diffuse_surf_clear_g(:,jcol)
322          flux%sw_dn_direct_surf_g(:,jcol)  = flux%sw_dn_direct_surf_clear_g(:,jcol)
323
324        end if ! Cloud is present in profile
325
326      else
327        ! Set fluxes to zero if sun is below the horizon
328        flux%sw_up(jcol,:) = 0.0_jprb
329        flux%sw_dn(jcol,:) = 0.0_jprb
330        if (allocated(flux%sw_dn_direct)) then
331          flux%sw_dn_direct(jcol,:) = 0.0_jprb
332        end if
333        flux%sw_up_clear(jcol,:) = 0.0_jprb
334        flux%sw_dn_clear(jcol,:) = 0.0_jprb
335        if (allocated(flux%sw_dn_direct_clear)) then
336          flux%sw_dn_direct_clear(jcol,:) = 0.0_jprb
337        end if
338        flux%sw_dn_diffuse_surf_g(:,jcol) = 0.0_jprb
339        flux%sw_dn_direct_surf_g(:,jcol)  = 0.0_jprb
340        flux%sw_dn_diffuse_surf_clear_g(:,jcol) = 0.0_jprb
341        flux%sw_dn_direct_surf_clear_g(:,jcol)  = 0.0_jprb
342      end if ! Sun above horizon
343
344    end do ! Loop over columns
345
346    if (lhook) call dr_hook('radiation_mcica_sw:solver_mcica_sw',1,hook_handle)
347   
348  end subroutine solver_mcica_sw
349
350end module radiation_mcica_sw
Note: See TracBrowser for help on using the repository browser.