1 | !> @file urban_surface_mod.f90 |
---|
2 | !--------------------------------------------------------------------------------! |
---|
3 | ! This file is part of PALM. |
---|
4 | ! |
---|
5 | ! PALM is free software: you can redistribute it and/or modify it under the |
---|
6 | ! terms of the GNU General Public License as published by the Free Software |
---|
7 | ! Foundation, either version 3 of the License, or (at your option) any later |
---|
8 | ! version. |
---|
9 | ! |
---|
10 | ! PALM is distributed in the hope that it will be useful, but WITHOUT ANY |
---|
11 | ! WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR |
---|
12 | ! A PARTICULAR PURPOSE. See the GNU General Public License for more details. |
---|
13 | ! |
---|
14 | ! You should have received a copy of the GNU General Public License along with |
---|
15 | ! PALM. If not, see <http://www.gnu.org/licenses/>. |
---|
16 | ! |
---|
17 | ! Copyright 2015-2017 Czech Technical University in Prague |
---|
18 | ! Copyright 1997-2017 Leibniz Universitaet Hannover |
---|
19 | !--------------------------------------------------------------------------------! |
---|
20 | ! |
---|
21 | ! Current revisions: |
---|
22 | ! ------------------ |
---|
23 | ! |
---|
24 | ! |
---|
25 | ! Former revisions: |
---|
26 | ! ----------------- |
---|
27 | ! $Id: urban_surface_mod.f90 2318 2017-07-20 17:27:44Z suehring $ |
---|
28 | ! Get topography top index via Function call |
---|
29 | ! |
---|
30 | ! 2317 2017-07-20 17:27:19Z suehring |
---|
31 | ! Bugfix: adjust output of shf. Added support for spinups |
---|
32 | ! |
---|
33 | ! 2287 2017-06-15 16:46:30Z suehring |
---|
34 | ! Bugfix in determination topography-top index |
---|
35 | ! |
---|
36 | ! 2269 2017-06-09 11:57:32Z suehring |
---|
37 | ! Enable restart runs with different number of PEs |
---|
38 | ! Bugfixes nopointer branch |
---|
39 | ! |
---|
40 | ! 2258 2017-06-08 07:55:13Z suehring |
---|
41 | ! Bugfix, add pre-preprocessor directives to enable non-parrallel mode |
---|
42 | ! |
---|
43 | ! 2233 2017-05-30 18:08:54Z suehring |
---|
44 | ! |
---|
45 | ! 2232 2017-05-30 17:47:52Z suehring |
---|
46 | ! Adjustments according to new surface-type structure. Remove usm_wall_heat_flux; |
---|
47 | ! insteat, heat fluxes are directly applied in diffusion_s. |
---|
48 | ! |
---|
49 | ! 2213 2017-04-24 15:10:35Z kanani |
---|
50 | ! Removal of output quantities usm_lad and usm_canopy_hr |
---|
51 | ! |
---|
52 | ! 2209 2017-04-19 09:34:46Z kanani |
---|
53 | ! cpp switch __mpi3 removed, |
---|
54 | ! minor formatting, |
---|
55 | ! small bugfix for division by zero (Krc) |
---|
56 | ! |
---|
57 | ! 2113 2017-01-12 13:40:46Z kanani |
---|
58 | ! cpp switch __mpi3 added for MPI-3 standard code (Ketelsen) |
---|
59 | ! |
---|
60 | ! 2071 2016-11-17 11:22:14Z maronga |
---|
61 | ! Small bugfix (Resler) |
---|
62 | ! |
---|
63 | ! 2031 2016-10-21 15:11:58Z knoop |
---|
64 | ! renamed variable rho to rho_ocean |
---|
65 | ! |
---|
66 | ! 2024 2016-10-12 16:42:37Z kanani |
---|
67 | ! Bugfixes in deallocation of array plantt and reading of csf/csfsurf, |
---|
68 | ! optimization of MPI-RMA operations, |
---|
69 | ! declaration of pcbl as integer, |
---|
70 | ! renamed usm_radnet -> usm_rad_net, usm_canopy_khf -> usm_canopy_hr, |
---|
71 | ! splitted arrays svf -> svf & csf, svfsurf -> svfsurf & csfsurf, |
---|
72 | ! use of new control parameter varnamelength, |
---|
73 | ! added output variables usm_rad_ressw, usm_rad_reslw, |
---|
74 | ! minor formatting changes, |
---|
75 | ! minor optimizations. |
---|
76 | ! |
---|
77 | ! 2011 2016-09-19 17:29:57Z kanani |
---|
78 | ! Major reformatting according to PALM coding standard (comments, blanks, |
---|
79 | ! alphabetical ordering, etc.), |
---|
80 | ! removed debug_prints, |
---|
81 | ! removed auxiliary SUBROUTINE get_usm_info, instead, USM flag urban_surface is |
---|
82 | ! defined in MODULE control_parameters (modules.f90) to avoid circular |
---|
83 | ! dependencies, |
---|
84 | ! renamed canopy_heat_flux to pc_heating_rate, as meaning of quantity changed. |
---|
85 | ! |
---|
86 | ! 2007 2016-08-24 15:47:17Z kanani |
---|
87 | ! Initial revision |
---|
88 | ! |
---|
89 | ! |
---|
90 | ! Description: |
---|
91 | ! ------------ |
---|
92 | ! 2016/6/9 - Initial version of the USM (Urban Surface Model) |
---|
93 | !      authors: Jaroslav Resler, Pavel Krc |
---|
94 | !           (Czech Technical University in Prague and Institute of |
---|
95 | !           Computer Science of the Czech Academy of Sciences, Prague) |
---|
96 | !      with contributions: Michal Belda, Nina Benesova, Ondrej Vlcek |
---|
97 | !      partly inspired by PALM LSM (B. Maronga) |
---|
98 | !      parameterizations of Ra checked with TUF3D (E. S. Krayenhoff) |
---|
99 | !> Module for Urban Surface Model (USM) |
---|
100 | !> The module includes: |
---|
101 | !>Â Â 1. radiation model with direct/diffuse radiation, shading, reflections |
---|
102 | !>Â Â Â Â and integration with plant canopy |
---|
103 | !>Â Â 2. wall and wall surface model |
---|
104 | !>Â Â 3. surface layer energy balance |
---|
105 | !>Â Â 4. anthropogenic heat (only from transportation so far) |
---|
106 | !>Â Â 5. necessary auxiliary subroutines (reading inputs, writing outputs, |
---|
107 | !>Â Â Â Â restart simulations, ...) |
---|
108 | !> It also make use of standard radiation and integrates it into |
---|
109 | !> urban surface model. |
---|
110 | !> |
---|
111 | !> Further work: |
---|
112 | !> ------------- |
---|
113 | !> 1. Reduce number of shape view factors by merging factors for distant surfaces |
---|
114 | !>Â Â under shallow angles. Idea: Iteratively select the smallest shape view |
---|
115 | !>Â Â factor by value (among all sources and targets) which has a similarly |
---|
116 | !>Â Â oriented source neighbor (or near enough) SVF and merge them by adding |
---|
117 | !>Â Â value of the smaller SVF to the larger one and deleting the smaller one. |
---|
118 | !>Â Â This will allow for better scaling at higher resolutions. |
---|
119 | !> |
---|
120 | !> 2. Remove global arrays surfouts, surfoutl and only keep track of radiosity |
---|
121 | !>Â Â from surfaces that are visible from local surfaces (i.e. there is a SVF |
---|
122 | !>Â Â where target is local). To do that, radiosity will be exchanged after each |
---|
123 | !>Â Â reflection step using MPI_Alltoall instead of current MPI_Allgather. |
---|
124 | !> |
---|
125 | !> 3. Temporarily large values of surface heat flux can be observed, up to |
---|
126 | !>Â Â 1.2 Km/s, which seem to be not realistic. |
---|
127 | !> |
---|
128 | !> @todo Revise flux conversion in energy-balance solver |
---|
129 | !> @todo Bugfixing in nopointer branch |
---|
130 | !> @todo Check optimizations for RMA operations |
---|
131 | !> @todo Alternatives for MPI_WIN_ALLOCATE? (causes problems with openmpi) |
---|
132 | !> @todo Check for load imbalances in CPU measures, e.g. for exchange_horiz_prog |
---|
133 | !>Â Â Â Â factor 3 between min and max time |
---|
134 | !------------------------------------------------------------------------------! |
---|
135 | Â MODULE urban_surface_mod |
---|
136 | |
---|
137 |   USE arrays_3d,                               & |
---|
138 |     ONLY: zu, pt, pt_1, pt_2, p, u, v, w, hyp, tend |
---|
139 | |
---|
140 |   USE cloud_parameters,                           & |
---|
141 |     ONLY: cp, r_d |
---|
142 | |
---|
143 |   USE constants,                               & |
---|
144 | Â Â Â Â ONLY:Â pi |
---|
145 | Â Â |
---|
146 |   USE control_parameters,                          & |
---|
147 |     ONLY: coupling_start_time, dz, topography, dt_3d,           & |
---|
148 |         intermediate_timestep_count, initializing_actions,       & |
---|
149 |         intermediate_timestep_count_max, simulated_time, end_time,   & |
---|
150 |         timestep_scheme, tsc, coupling_char, io_blocks, io_group,    & |
---|
151 |         message_string, time_since_reference_point, surface_pressure,  & |
---|
152 |         g, pt_surface, large_scale_forcing, lsf_surf, spinup,      & |
---|
153 |         spinup_pt_mean, spinup_time, time_do3d, dt_do3d,        & |
---|
154 |         average_count_3d, varnamelength, urban_surface |
---|
155 | |
---|
156 |   USE cpulog,                                & |
---|
157 |     ONLY: cpu_log, log_point, log_point_s |
---|
158 | Â Â Â |
---|
159 |   USE grid_variables,                            & |
---|
160 |     ONLY: dx, dy, ddx, ddy, ddx2, ddy2 |
---|
161 | Â Â |
---|
162 |   USE indices,                                & |
---|
163 |     ONLY: nx, ny, nnx, nny, nnz, nxl, nxlg, nxr, nxrg, nyn, nyng, nys,  & |
---|
164 |         nysg, nzb, nzt, nbgp, wall_flags_0 |
---|
165 | |
---|
166 |   USE, INTRINSIC :: iso_c_binding |
---|
167 | |
---|
168 | Â Â USE kinds |
---|
169 | Â Â Â Â Â Â Â |
---|
170 | Â Â USE pegrid |
---|
171 | Â Â |
---|
172 |   USE plant_canopy_model_mod,                        & |
---|
173 |     ONLY: plant_canopy, pch_index,                    & |
---|
174 |         pc_heating_rate, lad_s |
---|
175 | Â Â |
---|
176 |   USE radiation_model_mod,                          & |
---|
177 |     ONLY: radiation, calc_zenith, zenith, day_init, time_utc_init,    & |
---|
178 |         rad_net, rad_sw_in, rad_lw_in, rad_sw_out, rad_lw_out,     & |
---|
179 |         sigma_sb, sun_direction, sun_dir_lat, sun_dir_lon,       & |
---|
180 | Â Â Â Â Â Â Â Â force_radiation_call |
---|
181 | |
---|
182 |   USE statistics,                              & |
---|
183 |     ONLY: hom, statistic_regions |
---|
184 | |
---|
185 | Â Â USE surface_mod |
---|
186 | |
---|
187 | Â Â Â Â Â Â Â Â |
---|
188 | |
---|
189 | Â Â IMPLICIT NONE |
---|
190 | |
---|
191 | !-- configuration parameters (they can be setup in PALM config) |
---|
192 |   LOGICAL                    :: split_diffusion_radiation = .TRUE. !< split direct and diffusion dw radiation |
---|
193 | Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â !< (.F. in case the radiation model already does it)Â Â |
---|
194 |   LOGICAL                    :: usm_energy_balance_land = .TRUE.  !< flag parameter indicating wheather the energy balance is calculated for land and roofs |
---|
195 |   LOGICAL                    :: usm_energy_balance_wall = .TRUE.  !< flag parameter indicating wheather the energy balance is calculated for land and roofs |
---|
196 |   LOGICAL                    :: usm_material_model = .TRUE.    !< flag parameter indicating wheather the model of heat in materials is used |
---|
197 |   LOGICAL                    :: usm_anthropogenic_heat = .FALSE.  !< flag parameter indicating wheather the anthropogenic heat sources (e.g.transportation) are used |
---|
198 |   LOGICAL                    :: force_radiation_call_l = .FALSE.  !< flag parameter for unscheduled radiation model calls |
---|
199 |   LOGICAL                    :: mrt_factors = .FALSE.       !< whether to generate MRT factor files during init |
---|
200 |   LOGICAL                    :: write_svf_on_init = .FALSE. |
---|
201 |   LOGICAL                    :: read_svf_on_init = .FALSE. |
---|
202 |   LOGICAL                    :: usm_lad_rma = .TRUE.        !< use MPI RMA to access LAD for raytracing (instead of global array) |
---|
203 | Â Â |
---|
204 |   INTEGER(iwp)                  :: nrefsteps = 0           !< number of reflection steps to perform |
---|
205 | Â Â |
---|
206 |   INTEGER(iwp)                  :: land_category = 2         !< default category for land surface |
---|
207 |   INTEGER(iwp)                  :: wall_category = 2         !< default category for wall surface over pedestrian zone |
---|
208 |   INTEGER(iwp)                  :: pedestrant_category = 2      !< default category for wall surface in pedestrian zone |
---|
209 |   INTEGER(iwp)                  :: roof_category = 2         !< default category for root surface |
---|
210 |   REAL(wp)                    :: roof_height_limit = 4._wp     !< height for distinguish between land surfaces and roofs |
---|
211 | |
---|
212 |   REAL(wp), PARAMETER              :: ext_coef = 0.6_wp         !< extinction coefficient (a.k.a. alpha) |
---|
213 |   REAL(wp)                    :: ra_horiz_coef = 5.0_wp       !< mysterious coefficient for correction of overestimation |
---|
214 | Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â !< of r_a for horizontal surfaces -> TODO |
---|
215 | Â Â |
---|
216 | !-- parameters of urban surface model |
---|
217 |   INTEGER(iwp), PARAMETER            :: usm_version_len = 10        !< length of identification string of usm version |
---|
218 |   CHARACTER(usm_version_len), PARAMETER     :: usm_version = 'USM v. 1.0'     !< identification of version of binary svf and restart files |
---|
219 |   INTEGER(iwp), PARAMETER            :: svf_code_len = 15         !< length of code for verification of the end of svf file |
---|
220 |   CHARACTER(svf_code_len), PARAMETER       :: svf_code = '*** end svf ***'    !< code for verification of the end of svf file |
---|
221 |   INTEGER(iwp)                  :: nzu                !< number of layers of urban surface (will be calculated) |
---|
222 |   INTEGER(iwp)                  :: nzub,nzut             !< bottom and top layer of urban surface (will be calculated) |
---|
223 |   INTEGER(iwp), PARAMETER            :: nzut_free = 3           !< number of free layers in urban surface layer above top of buildings |
---|
224 |   INTEGER(iwp), PARAMETER            :: ndsvf = 2             !< number of dimensions of real values in SVF |
---|
225 |   INTEGER(iwp), PARAMETER            :: idsvf = 2             !< number of dimensions of integer values in SVF |
---|
226 |   INTEGER(iwp), PARAMETER            :: ndcsf = 2             !< number of dimensions of real values in CSF |
---|
227 |   INTEGER(iwp), PARAMETER            :: idcsf = 2             !< number of dimensions of integer values in CSF |
---|
228 |   INTEGER(iwp), PARAMETER            :: kdcsf = 4             !< number of dimensions of integer values in CSF calculation array |
---|
229 |   INTEGER(iwp), PARAMETER            :: id = 1               !< position of d-index in surfl and surf |
---|
230 |   INTEGER(iwp), PARAMETER            :: iz = 2               !< position of k-index in surfl and surf |
---|
231 |   INTEGER(iwp), PARAMETER            :: iy = 3               !< position of j-index in surfl and surf |
---|
232 |   INTEGER(iwp), PARAMETER            :: ix = 4               !< position of i-index in surfl and surf |
---|
233 |   INTEGER(iwp), PARAMETER            :: iroof = 0             !< 0 - index of ground or roof |
---|
234 |   INTEGER(iwp), PARAMETER            :: isouth = 1             !< 1 - index of south facing wall |
---|
235 |   INTEGER(iwp), PARAMETER            :: inorth = 2             !< 2 - index of north facing wall |
---|
236 |   INTEGER(iwp), PARAMETER            :: iwest = 3             !< 3 - index of west facing wall |
---|
237 |   INTEGER(iwp), PARAMETER            :: ieast = 4             !< 4 - index of east facing wall |
---|
238 |   INTEGER(iwp), PARAMETER            :: isky = 5              !< 5 - index of top border of the urban surface layer ("urban sky") |
---|
239 |   INTEGER(iwp), PARAMETER            :: inorthb = 6            !< 6 - index of free north border of the domain (south facing) |
---|
240 |   INTEGER(iwp), PARAMETER            :: isouthb = 7            !< 7 - index of north south border of the domain (north facing) |
---|
241 |   INTEGER(iwp), PARAMETER            :: ieastb = 8            !< 8 - index of east border of the domain (west facing) |
---|
242 |   INTEGER(iwp), PARAMETER            :: iwestb = 9            !< 9 - index of wast border of the domain (east facing) |
---|
243 |   INTEGER(iwp), DIMENSION(0:9), PARAMETER    :: idir = (/0,0,0,-1,1,0,0,0,-1,1/)  !< surface normal direction x indices |
---|
244 |   INTEGER(iwp), DIMENSION(0:9), PARAMETER    :: jdir = (/0,-1,1,0,0,0,-1,1,0,0/)  !< surface normal direction y indices |
---|
245 |   INTEGER(iwp), DIMENSION(0:9), PARAMETER    :: kdir = (/1,0,0,0,0,-1,0,0,0,0/)  !< surface normal direction z indices |
---|
246 |   REAL(wp), DIMENSION(1:4)            :: ddxy2               !< 1/dx^2 or 1/dy^2 (in surface normal direction) |
---|
247 |   INTEGER(iwp), DIMENSION(1:4,6:9)        :: ijdb                !< start and end of the local domain border coordinates (set in code) |
---|
248 |   LOGICAL, DIMENSION(6:9)            :: isborder              !< is PE on the border of the domain in four corresponding directions |
---|
249 | Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â !< parameter but set in the code |
---|
250 | |
---|
251 | !-- indices and sizes of urban surface model |
---|
252 |   INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE   :: surfl      !< coordinates of i-th local surface in local grid - surfl[:,k] = [d, z, y, x] |
---|
253 |   INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE   :: surf       !< coordinates of i-th surface in grid - surf[:,k] = [d, z, y, x] |
---|
254 |   INTEGER(iwp)                  :: nsurfl      !< number of all surfaces in local processor |
---|
255 |   INTEGER(iwp), DIMENSION(:), ALLOCATABLE    :: nsurfs      !< array of number of all surfaces in individual processors |
---|
256 |   INTEGER(iwp)                  :: startsky     !< start index of block of sky |
---|
257 |   INTEGER(iwp)                  :: endsky      !< end index of block of sky |
---|
258 |   INTEGER(iwp)                  :: nskys      !< number of sky surfaces in local processor |
---|
259 |   INTEGER(iwp)                  :: startland    !< start index of block of land and roof surfaces |
---|
260 |   INTEGER(iwp)                  :: endland     !< end index of block of land and roof surfaces |
---|
261 |   INTEGER(iwp)                  :: nlands      !< number of land and roof surfaces in local processor |
---|
262 |   INTEGER(iwp)                  :: startwall    !< start index of block of wall surfaces |
---|
263 |   INTEGER(iwp)                  :: endwall     !< end index of block of wall surfaces |
---|
264 |   INTEGER(iwp)                  :: nwalls      !< number of wall surfaces in local processor |
---|
265 |   INTEGER(iwp)                  :: startenergy   !< start index of block of real surfaces (land, walls and roofs) |
---|
266 |   INTEGER(iwp)                  :: endenergy    !< end index of block of real surfaces (land, walls and roofs) |
---|
267 |   INTEGER(iwp)                  :: nenergy     !< number of real surfaces in local processor |
---|
268 |   INTEGER(iwp)                  :: nsurf      !< global number of surfaces in index array of surfaces (nsurf = Σproc nsurfs) |
---|
269 |   INTEGER(iwp), DIMENSION(:), ALLOCATABLE    :: surfstart    !< starts of blocks of surfaces for individual processors in array surf |
---|
270 | Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â !< respective block for particular processor is surfstart[iproc]+1 : surfstart[iproc+1] |
---|
271 |   INTEGER(iwp)                  :: nsvfl      !< number of svf for local processor |
---|
272 |   INTEGER(iwp)                  :: ncsfl      !< no. of csf in local processor |
---|
273 | Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â !< needed only during calc_svf but must be here because it is |
---|
274 | Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â !< shared between subroutines usm_calc_svf and usm_raytrace |
---|
275 | |
---|
276 | !-- type for calculation of svf |
---|
277 | Â Â TYPE t_svf |
---|
278 |     INTEGER(iwp)                :: isurflt      !< |
---|
279 |     INTEGER(iwp)                :: isurfs      !< |
---|
280 |     REAL(wp)                  :: rsvf       !< |
---|
281 |     REAL(wp)                  :: rtransp      !< |
---|
282 | Â Â END TYPE |
---|
283 | |
---|
284 | !-- type for calculation of csf |
---|
285 | Â Â TYPE t_csf |
---|
286 |     INTEGER(iwp)                :: ip        !< |
---|
287 |     INTEGER(iwp)                :: itx        !< |
---|
288 |     INTEGER(iwp)                :: ity        !< |
---|
289 |     INTEGER(iwp)                :: itz        !< |
---|
290 |     INTEGER(iwp)                :: isurfs      !< |
---|
291 |     REAL(wp)                  :: rsvf       !< |
---|
292 |     REAL(wp)                  :: rtransp      !< |
---|
293 | Â Â END TYPE |
---|
294 | ! |
---|
295 | !-- Type for surface temperatures at vertical walls. Is not necessary for horizontal walls. |
---|
296 | Â Â TYPE t_surf_vertical |
---|
297 |     REAL(wp), DIMENSION(:), ALLOCATABLE     :: t |
---|
298 | Â Â END TYPE t_surf_vertical |
---|
299 | ! |
---|
300 | !-- Type for wall temperatures at vertical walls. Is not necessary for horizontal walls. |
---|
301 | Â Â TYPE t_wall_vertical |
---|
302 |     REAL(wp), DIMENSION(:,:), ALLOCATABLE    :: t |
---|
303 | Â Â END TYPE t_wall_vertical |
---|
304 | |
---|
305 | !-- arrays for calculation of svf and csf |
---|
306 |   TYPE(t_svf), DIMENSION(:), POINTER       :: asvf       !< pointer to growing svc array |
---|
307 |   TYPE(t_csf), DIMENSION(:), POINTER       :: acsf       !< pointer to growing csf array |
---|
308 |   TYPE(t_svf), DIMENSION(:), ALLOCATABLE, TARGET :: asvf1, asvf2   !< realizations of svf array |
---|
309 |   TYPE(t_csf), DIMENSION(:), ALLOCATABLE, TARGET :: acsf1, acsf2   !< realizations of csf array |
---|
310 |   INTEGER(iwp)                  :: nsvfla      !< dimmension of array allocated for storage of svf in local processor |
---|
311 |   INTEGER(iwp)                  :: ncsfla      !< dimmension of array allocated for storage of csf in local processor |
---|
312 |   INTEGER(iwp)                  :: msvf, mcsf    !< mod for swapping the growing array |
---|
313 |   INTEGER(iwp), PARAMETER            :: gasize = 10000  !< initial size of growing arrays |
---|
314 | !-- temporary arrays for calculation of csf in raytracing |
---|
315 |   INTEGER(iwp)                  :: maxboxesg    !< max number of boxes ray can cross in the domain |
---|
316 |   INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE   :: boxes      !< coordinates of gridboxes being crossed by ray |
---|
317 |   REAL(wp), DIMENSION(:), ALLOCATABLE      :: crlens      !< array of crossing lengths of ray for particular grid boxes |
---|
318 |   INTEGER(iwp), DIMENSION(:), ALLOCATABLE    :: lad_ip      !< array of numbers of process where lad is stored |
---|
319 | #if defined( __parallel ) |
---|
320 |   INTEGER(kind=MPI_ADDRESS_KIND), & |
---|
321 |          DIMENSION(:), ALLOCATABLE    :: lad_disp     !< array of displaycements of lad in local array of proc lad_ip |
---|
322 | #endif |
---|
323 |   REAL(wp), DIMENSION(:), ALLOCATABLE      :: lad_s_ray    !< array of received lad_s for appropriate gridboxes crossed by ray |
---|
324 | |
---|
325 | !-- arrays storing the values of USM |
---|
326 |   INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE   :: svfsurf     !< svfsurf[:,isvf] = index of source and target surface for svf[isvf] |
---|
327 |   REAL(wp), DIMENSION(:,:), ALLOCATABLE     :: svf       !< array of shape view factors+direct irradiation factors for local surfaces |
---|
328 |   REAL(wp), DIMENSION(:), ALLOCATABLE      :: surfins     !< array of sw radiation falling to local surface after i-th reflection |
---|
329 |   REAL(wp), DIMENSION(:), ALLOCATABLE      :: surfinl     !< array of lw radiation for local surface after i-th reflection |
---|
330 | Â Â |
---|
331 | Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â !< Inward radiation is also valid for virtual surfaces (radiation leaving domain) |
---|
332 |   REAL(wp), DIMENSION(:), ALLOCATABLE      :: surfinsw     !< array of sw radiation falling to local surface including radiation from reflections |
---|
333 |   REAL(wp), DIMENSION(:), ALLOCATABLE      :: surfinlw     !< array of lw radiation falling to local surface including radiation from reflections |
---|
334 |   REAL(wp), DIMENSION(:), ALLOCATABLE      :: surfinswdir   !< array of direct sw radiation falling to local surface |
---|
335 |   REAL(wp), DIMENSION(:), ALLOCATABLE      :: surfinswdif   !< array of diffuse sw radiation from sky and model boundary falling to local surface |
---|
336 |   REAL(wp), DIMENSION(:), ALLOCATABLE      :: surfinlwdif   !< array of diffuse lw radiation from sky and model boundary falling to local surface |
---|
337 | Â Â |
---|
338 | Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â !< Outward radiation is only valid for nonvirtual surfaces |
---|
339 |   REAL(wp), DIMENSION(:), ALLOCATABLE      :: surfoutsl    !< array of reflected sw radiation for local surface in i-th reflection |
---|
340 |   REAL(wp), DIMENSION(:), ALLOCATABLE      :: surfoutll    !< array of reflected + emitted lw radiation for local surface in i-th reflection |
---|
341 |   REAL(wp), DIMENSION(:), ALLOCATABLE      :: surfouts     !< array of reflected sw radiation for all surfaces in i-th reflection |
---|
342 |   REAL(wp), DIMENSION(:), ALLOCATABLE      :: surfoutl     !< array of reflected + emitted lw radiation for all surfaces in i-th reflection |
---|
343 |   REAL(wp), DIMENSION(:), ALLOCATABLE      :: surfoutsw    !< array of total sw radiation outgoing from nonvirtual surfaces surfaces after all reflection |
---|
344 |   REAL(wp), DIMENSION(:), ALLOCATABLE      :: surfoutlw    !< array of total lw radiation outgoing from nonvirtual surfaces surfaces after all reflection |
---|
345 |   REAL(wp), DIMENSION(:), ALLOCATABLE      :: surfhf      !< array of total radiation flux incoming to minus outgoing from local surface |
---|
346 |   REAL(wp), DIMENSION(:), ALLOCATABLE      :: rad_net_l    !< local copy of rad_net (net radiation at surface) |
---|
347 | |
---|
348 | !-- arrays for time averages |
---|
349 |   REAL(wp), DIMENSION(:), ALLOCATABLE      :: rad_net_av    !< average of rad_net_l |
---|
350 |   REAL(wp), DIMENSION(:), ALLOCATABLE      :: surfinsw_av   !< average of sw radiation falling to local surface including radiation from reflections |
---|
351 |   REAL(wp), DIMENSION(:), ALLOCATABLE      :: surfinlw_av   !< average of lw radiation falling to local surface including radiation from reflections |
---|
352 |   REAL(wp), DIMENSION(:), ALLOCATABLE      :: surfinswdir_av  !< average of direct sw radiation falling to local surface |
---|
353 |   REAL(wp), DIMENSION(:), ALLOCATABLE      :: surfinswdif_av  !< average of diffuse sw radiation from sky and model boundary falling to local surface |
---|
354 |   REAL(wp), DIMENSION(:), ALLOCATABLE      :: surfinlwdif_av  !< average of diffuse lw radiation from sky and model boundary falling to local surface |
---|
355 |   REAL(wp), DIMENSION(:), ALLOCATABLE      :: surfinswref_av  !< average of sw radiation falling to surface from reflections |
---|
356 |   REAL(wp), DIMENSION(:), ALLOCATABLE      :: surfinlwref_av  !< average of lw radiation falling to surface from reflections |
---|
357 |   REAL(wp), DIMENSION(:), ALLOCATABLE      :: surfoutsw_av   !< average of total sw radiation outgoing from nonvirtual surfaces surfaces after all reflection |
---|
358 |   REAL(wp), DIMENSION(:), ALLOCATABLE      :: surfoutlw_av   !< average of total lw radiation outgoing from nonvirtual surfaces surfaces after all reflection |
---|
359 |   REAL(wp), DIMENSION(:), ALLOCATABLE      :: surfins_av    !< average of array of residua of sw radiation absorbed in surface after last reflection |
---|
360 |   REAL(wp), DIMENSION(:), ALLOCATABLE      :: surfinl_av    !< average of array of residua of lw radiation absorbed in surface after last reflection |
---|
361 |   REAL(wp), DIMENSION(:), ALLOCATABLE      :: surfhf_av    !< average of total radiation flux incoming to minus outgoing from local surface |
---|
362 | Â Â |
---|
363 | !-- block variables needed for calculation of the plant canopy model inside the urban surface model |
---|
364 |   INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE   :: csfsurf     !< csfsurf[:,icsf] = index of target surface and csf grid index for csf[icsf] |
---|
365 |   REAL(wp), DIMENSION(:,:), ALLOCATABLE     :: csf       !< array of plant canopy sink fators + direct irradiation factors (transparency) |
---|
366 | Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â !< for local surfaces |
---|
367 |   INTEGER(wp), DIMENSION(:,:), ALLOCATABLE    :: pcbl       !< k,j,i coordinates of l-th local plant canopy box pcbl[:,l] = [k, j, i] |
---|
368 |   INTEGER(iwp), DIMENSION(:,:,:), ALLOCATABLE  :: gridpcbl     !< index of local pcb[k,j,i] |
---|
369 |   REAL(wp), DIMENSION(:), ALLOCATABLE      :: pcbinsw     !< array of absorbed sw radiation for local plant canopy box |
---|
370 |   REAL(wp), DIMENSION(:), ALLOCATABLE      :: pcbinlw     !< array of absorbed lw radiation for local plant canopy box |
---|
371 |   INTEGER(iwp)                  :: npcbl      !< number of the plant canopy gridboxes in local processor |
---|
372 |   INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE   :: pch       !< heights of the plant canopy |
---|
373 |   INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE   :: pct       !< top layer of the plant canopy |
---|
374 |   REAL(wp), DIMENSION(:,:,:), POINTER      :: usm_lad     !< subset of lad_s within urban surface, transformed to plain Z coordinate |
---|
375 |   REAL(wp), DIMENSION(:), POINTER        :: usm_lad_g    !< usm_lad globalized (used to avoid MPI RMA calls in raytracing) |
---|
376 |   REAL(wp)                    :: prototype_lad  !< prototype leaf area density for computing effective optical depth |
---|
377 |   INTEGER(iwp), DIMENSION(:), ALLOCATABLE    :: nzterr, plantt  !< temporary global arrays for raytracing |
---|
378 | Â Â |
---|
379 | !-- radiation related arrays (it should be better in interface of radiation module of PALM |
---|
380 |   REAL(wp), DIMENSION(:,:), ALLOCATABLE     :: rad_sw_in_dir  !< direct sw radiation |
---|
381 |   REAL(wp), DIMENSION(:,:), ALLOCATABLE     :: rad_sw_in_diff  !< diffusion sw radiation |
---|
382 |   REAL(wp), DIMENSION(:,:), ALLOCATABLE     :: rad_lw_in_diff  !< diffusion lw radiation |
---|
383 | |
---|
384 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! |
---|
385 | !-- anthropogenic heat sources |
---|
386 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! |
---|
387 |   REAL(wp), DIMENSION(:,:), ALLOCATABLE     :: aheat       !< daily average of anthropogenic heat (W/m2) |
---|
388 |   REAL(wp), DIMENSION(:), ALLOCATABLE      :: aheatprof     !< diurnal profile of anthropogenic heat |
---|
389 | |
---|
390 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! |
---|
391 | !-- wall surface model |
---|
392 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! |
---|
393 | !-- wall surface model constants |
---|
394 |   INTEGER(iwp), PARAMETER            :: nzb_wall = 0    !< inner side of the wall model (to be switched) |
---|
395 |   INTEGER(iwp), PARAMETER            :: nzt_wall = 3    !< outer side of the wall model (to be switched) |
---|
396 |   INTEGER(iwp), PARAMETER            :: nzw = 4      !< number of wall layers (fixed for now) |
---|
397 | |
---|
398 |   REAL(wp), DIMENSION(nzb_wall:nzt_wall)     :: zwn_default = (/0.0242_wp, 0.0969_wp, 0.346_wp, 1.0_wp /) |
---|
399 | Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â !< normalized soil, wall and roof layer depths (m/m) |
---|
400 | Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â |
---|
401 |   REAL(wp)                    ::  wall_inner_temperature = 296.0_wp  !< temperature of the inner wall surface (~23 degrees C) (K) |
---|
402 |   REAL(wp)                    ::  roof_inner_temperature = 296.0_wp  !< temperature of the inner roof surface (~23 degrees C) (K) |
---|
403 |   REAL(wp)                    ::  soil_inner_temperature = 283.0_wp  !< temperature of the deep soil (~10 degrees C) (K) |
---|
404 | |
---|
405 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! |
---|
406 | !-- surface and material model variables for walls, ground, roofs |
---|
407 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! |
---|
408 |   REAL(wp), DIMENSION(:), ALLOCATABLE      :: zwn        !< normalized wall layer depths (m) |
---|
409 | |
---|
410 | #if defined( __nopointer ) |
---|
411 |   REAL(wp), DIMENSION(:), ALLOCATABLE, TARGET  :: t_surf_h      !< wall surface temperature (K) at horizontal walls |
---|
412 |   REAL(wp), DIMENSION(:), ALLOCATABLE, TARGET  :: t_surf_h_p     !< progn. wall surface temperature (K) at horizontal walls |
---|
413 | |
---|
414 |   TYPE(t_surf_vertical), DIMENSION(0:3), TARGET :: t_surf_v |
---|
415 |   TYPE(t_surf_vertical), DIMENSION(0:3), TARGET :: t_surf_v_p |
---|
416 | #else |
---|
417 |   REAL(wp), DIMENSION(:), POINTER        :: t_surf_h |
---|
418 |   REAL(wp), DIMENSION(:), POINTER        :: t_surf_h_p |
---|
419 | |
---|
420 |   REAL(wp), DIMENSION(:), ALLOCATABLE, TARGET  :: t_surf_h_1 |
---|
421 |   REAL(wp), DIMENSION(:), ALLOCATABLE, TARGET  :: t_surf_h_2 |
---|
422 | |
---|
423 |   TYPE(t_surf_vertical), DIMENSION(:), POINTER :: t_surf_v |
---|
424 |   TYPE(t_surf_vertical), DIMENSION(:), POINTER :: t_surf_v_p |
---|
425 | |
---|
426 |   TYPE(t_surf_vertical), DIMENSION(0:3), TARGET :: t_surf_v_1 |
---|
427 |   TYPE(t_surf_vertical), DIMENSION(0:3), TARGET :: t_surf_v_2 |
---|
428 | #endif |
---|
429 |   REAL(wp), DIMENSION(:), ALLOCATABLE, TARGET  :: t_surf_av     !< average of wall surface temperature (K) |
---|
430 | |
---|
431 | !-- Temporal tendencies for time stepping      |
---|
432 |   REAL(wp), DIMENSION(:), ALLOCATABLE      :: tt_surface_m    !< surface temperature tendency (K) |
---|
433 | |
---|
434 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! |
---|
435 | !-- Energy balance variables |
---|
436 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! |
---|
437 | !-- parameters of the land, roof and wall surfaces |
---|
438 |   REAL(wp), DIMENSION(:), ALLOCATABLE      :: albedo_surf    !< albedo of the surface |
---|
439 | !-- parameters of the wall surfaces |
---|
440 |   REAL(wp), DIMENSION(:), ALLOCATABLE      :: emiss_surf     !< emissivity of the wall surface |
---|
441 | |
---|
442 | #if defined( __nopointer ) |
---|
443 |   REAL(wp), DIMENSION(:), ALLOCATABLE, TARGET  :: t_wall_h       !< Wall temperature (K) |
---|
444 |   REAL(wp), DIMENSION(:), ALLOCATABLE, TARGET  :: t_wall_h_av     !< Average of t_wall |
---|
445 |   REAL(wp), DIMENSION(:), ALLOCATABLE, TARGET  :: t_wall_h_p      !< Prog. wall temperature (K) |
---|
446 | |
---|
447 |   TYPE(t_wall_vertical), DIMENSION(0:3), TARGET :: t_wall_v       !< Wall temperature (K) |
---|
448 |   TYPE(t_wall_vertical), DIMENSION(0:3), TARGET :: t_wall_v_av     !< Average of t_wall |
---|
449 |   TYPE(t_wall_vertical), DIMENSION(0:3), TARGET :: t_wall_v_p      !< Prog. wall temperature (K) |
---|
450 | #else |
---|
451 |   REAL(wp), DIMENSION(:,:), POINTER        :: t_wall_h, t_wall_h_p |
---|
452 |   REAL(wp), DIMENSION(:,:), ALLOCATABLE, TARGET  :: t_wall_h_av, t_wall_h_1, t_wall_h_2 |
---|
453 | |
---|
454 |   TYPE(t_wall_vertical), DIMENSION(:), POINTER  :: t_wall_v, t_wall_v_p |
---|
455 |   TYPE(t_wall_vertical), DIMENSION(0:3), TARGET :: t_wall_v_av, t_wall_v_1, t_wall_v_2 |
---|
456 | #endif |
---|
457 | |
---|
458 | !-- Wall temporal tendencies for time stepping |
---|
459 |   REAL(wp), DIMENSION(:,:), ALLOCATABLE     :: tt_wall_m     !< t_wall prognostic array |
---|
460 | |
---|
461 | !-- Surface and material parameters classes (surface_type) |
---|
462 | !-- albedo, emissivity, lambda_surf, roughness, thickness, volumetric heat capacity, thermal conductivity |
---|
463 |   INTEGER(iwp)                  :: n_surface_types   !< number of the wall type categories |
---|
464 |   INTEGER(iwp), PARAMETER            :: n_surface_params = 8 !< number of parameters for each type of the wall |
---|
465 |   INTEGER(iwp), PARAMETER            :: ialbedo = 1     !< albedo of the surface |
---|
466 |   INTEGER(iwp), PARAMETER            :: iemiss  = 2     !< emissivity of the surface |
---|
467 |   INTEGER(iwp), PARAMETER            :: ilambdas = 3     !< heat conductivity λS between air and surface ( W m−2 K−1 ) |
---|
468 |   INTEGER(iwp), PARAMETER            :: irough  = 4     !< roughness relative to concrete |
---|
469 |   INTEGER(iwp), PARAMETER            :: icsurf  = 5     !< Surface skin layer heat capacity (J m−2 K−1 ) |
---|
470 |   INTEGER(iwp), PARAMETER            :: ithick  = 6     !< thickness of the surface (wall, roof, land) ( m ) |
---|
471 |   INTEGER(iwp), PARAMETER            :: irhoC  = 7     !< volumetric heat capacity rho*C of the material ( J m−3 K−1 ) |
---|
472 |   INTEGER(iwp), PARAMETER            :: ilambdah = 8     !< thermal conductivity λH of the wall (W m−1 K−1 ) |
---|
473 |   CHARACTER(12), DIMENSION(:), ALLOCATABLE    :: surface_type_names  !< names of wall types (used only for reports) |
---|
474 |   INTEGER(iwp), DIMENSION(:), ALLOCATABLE    :: surface_type_codes  !< codes of wall types |
---|
475 |   REAL(wp), DIMENSION(:,:), ALLOCATABLE     :: surface_params    !< parameters of wall types |
---|
476 | Â Â |
---|
477 |   CHARACTER(len=*), PARAMETER          :: svf_file_name='usm_svf' |
---|
478 | Â Â |
---|
479 | !-- interfaces of subroutines accessed from outside of this module |
---|
480 | Â Â INTERFACE usm_check_data_output |
---|
481 | Â Â Â Â MODULE PROCEDUREÂ usm_check_data_output |
---|
482 | Â Â END INTERFACE usm_check_data_output |
---|
483 | Â Â |
---|
484 | Â Â INTERFACE usm_check_parameters |
---|
485 | Â Â Â Â MODULE PROCEDUREÂ usm_check_parameters |
---|
486 | Â Â END INTERFACE usm_check_parameters |
---|
487 | Â Â |
---|
488 | Â Â INTERFACE usm_data_output_3d |
---|
489 | Â Â Â Â MODULE PROCEDUREÂ usm_data_output_3d |
---|
490 | Â Â END INTERFACE usm_data_output_3d |
---|
491 | Â Â |
---|
492 | Â Â INTERFACE usm_define_netcdf_grid |
---|
493 | Â Â Â Â MODULE PROCEDUREÂ usm_define_netcdf_grid |
---|
494 | Â Â END INTERFACE usm_define_netcdf_grid |
---|
495 | |
---|
496 | Â Â INTERFACE usm_init_urban_surface |
---|
497 | Â Â Â Â MODULE PROCEDUREÂ usm_init_urban_surface |
---|
498 | Â Â END INTERFACE usm_init_urban_surface |
---|
499 | |
---|
500 | Â Â INTERFACE usm_material_heat_model |
---|
501 | Â Â Â Â MODULE PROCEDUREÂ usm_material_heat_model |
---|
502 | Â Â END INTERFACE usm_material_heat_model |
---|
503 | Â Â |
---|
504 | Â Â INTERFACE usm_parin |
---|
505 | Â Â Â Â MODULE PROCEDUREÂ usm_parin |
---|
506 | Â Â END INTERFACE usm_parin |
---|
507 | |
---|
508 | Â Â INTERFACE usm_radiation |
---|
509 | Â Â Â Â MODULE PROCEDUREÂ usm_radiation |
---|
510 | Â Â END INTERFACE usm_radiation |
---|
511 | Â Â |
---|
512 |   INTERFACE usm_read_restart_data |
---|
513 | Â Â Â Â MODULE PROCEDUREÂ usm_read_restart_data |
---|
514 | Â Â END INTERFACE usm_read_restart_data |
---|
515 | |
---|
516 | Â Â INTERFACE usm_surface_energy_balance |
---|
517 | Â Â Â Â MODULE PROCEDUREÂ usm_surface_energy_balance |
---|
518 | Â Â END INTERFACE usm_surface_energy_balance |
---|
519 | Â Â |
---|
520 | Â Â INTERFACE usm_swap_timelevel |
---|
521 | Â Â Â Â MODULE PROCEDUREÂ usm_swap_timelevel |
---|
522 | Â Â END INTERFACE usm_swap_timelevel |
---|
523 | Â Â Â Â |
---|
524 | Â Â INTERFACE usm_write_restart_data |
---|
525 | Â Â Â Â MODULE PROCEDUREÂ usm_write_restart_data |
---|
526 | Â Â END INTERFACE usm_write_restart_data |
---|
527 | Â Â |
---|
528 | Â Â SAVE |
---|
529 | |
---|
530 | Â Â PRIVATEÂ |
---|
531 | Â Â |
---|
532 | !-- Public parameters, constants and initial values |
---|
533 |   PUBLIC split_diffusion_radiation,                     & |
---|
534 |       usm_anthropogenic_heat, usm_material_model, mrt_factors,      & |
---|
535 |       usm_check_parameters,                        & |
---|
536 |       usm_energy_balance_land, usm_energy_balance_wall, nrefsteps,    & |
---|
537 |       usm_init_urban_surface, usm_radiation, usm_read_restart_data,    & |
---|
538 |       usm_surface_energy_balance, usm_material_heat_model,        & |
---|
539 |       usm_swap_timelevel, usm_check_data_output, usm_average_3d_data,   & |
---|
540 |       usm_data_output_3d, usm_define_netcdf_grid, usm_parin,       & |
---|
541 |       usm_write_restart_data,                       & |
---|
542 |       nzub, nzut, ra_horiz_coef, usm_lad_rma,               & |
---|
543 |       land_category, pedestrant_category, wall_category, roof_category,  & |
---|
544 |       write_svf_on_init, read_svf_on_init |
---|
545 | |
---|
546 | |
---|
547 | Â CONTAINS |
---|
548 | |
---|
549 | Â |
---|
550 | !------------------------------------------------------------------------------! |
---|
551 | ! Description: |
---|
552 | ! ------------ |
---|
553 | !> This subroutine creates the necessary indices of the urban surfaces |
---|
554 | !> and plant canopy and it allocates the needed arrays for USM |
---|
555 | !------------------------------------------------------------------------------! |
---|
556 | Â Â SUBROUTINE usm_allocate_urban_surface |
---|
557 | Â Â |
---|
558 | Â Â Â Â IMPLICIT NONE |
---|
559 | Â Â Â Â |
---|
560 |     INTEGER(iwp) :: i, j, k, d, l, ir, jr, ids, m |
---|
561 |     INTEGER(iwp) :: k_topo   !< vertical index indicating topography top for given (j,i) |
---|
562 | Â Â Â Â INTEGER(iwp)Â ::Â k_topo2Â Â !< vertical index indicating topography top for given (j,i) |
---|
563 |     INTEGER(iwp) :: nzubl, nzutl, isurf, ipcgb |
---|
564 | Â Â Â Â INTEGER(iwp)Â ::Â procid |
---|
565 | |
---|
566 | Â Â Â Â |
---|
567 | |
---|
568 | Â Â Â Â |
---|
569 | !--Â Â Â auxiliary vars |
---|
570 | Â Â Â Â ddxy2Â =Â (/ddy2,ddy2,ddx2,ddx2/)Â Â Â !< 1/dx^2 or 1/dy^2 (in surface normal direction) |
---|
571 | Â Â Â Â |
---|
572 |     CALL location_message( '', .TRUE. ) |
---|
573 |     CALL location_message( '  allocation of needed arrays', .TRUE. ) |
---|
574 | ! |
---|
575 | !--Â Â Â Find nzub, nzut, nzu via wall_flag_0 array (nzb_s_inner will be |
---|
576 | !--Â Â Â removed later). The following contruct finds the lowest / largest index |
---|
577 | !--Â Â Â for any upward-facing wall (see bit 12). |
---|
578 |     nzubl = MINVAL(                            & |
---|
579 | Â Â Â Â Â Â Â Â Â Â MAXLOC(Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â & |
---|
580 |              MERGE( 1, 0,                     & |
---|
581 |                  BTEST( wall_flags_0(:,nys:nyn,nxl:nxr), 12 ) & |
---|
582 |                 ), DIM = 1                   & |
---|
583 | Â Â Â Â Â Â Â Â Â Â Â Â Â )Â -Â 1Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â &Â |
---|
584 | Â Â Â Â Â Â Â Â Â Â Â Â Â Â ) |
---|
585 |     nzutl = MAXVAL(                            & |
---|
586 | Â Â Â Â Â Â Â Â Â Â MAXLOC(Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â & |
---|
587 |              MERGE( 1, 0,                     & |
---|
588 |                  BTEST( wall_flags_0(:,nys:nyn,nxl:nxr), 12 ) & |
---|
589 |                 ), DIM = 1                   & |
---|
590 | Â Â Â Â Â Â Â Â Â Â Â Â Â )Â -Â 1Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â & |
---|
591 | Â Â Â Â Â Â Â Â Â Â Â Â Â Â ) |
---|
592 |     nzubl = max(nzubl,nzb) |
---|
593 | |
---|
594 | Â Â Â Â |
---|
595 |     IF ( plant_canopy ) THEN |
---|
596 | !--Â Â Â Â Â allocate needed arrays |
---|
597 | Â Â Â Â Â Â ALLOCATE(Â pct(nys:nyn,nxl:nxr)Â ) |
---|
598 | Â Â Â Â Â Â ALLOCATE(Â pch(nys:nyn,nxl:nxr)Â ) |
---|
599 | |
---|
600 | !--Â Â Â Â Â calculate plant canopy height |
---|
601 |       npcbl = 0 |
---|
602 |       pct = 0.0_wp |
---|
603 |       pch = 0.0_wp |
---|
604 |       DO i = nxl, nxr |
---|
605 |         DO j = nys, nyn |
---|
606 | ! |
---|
607 | !--Â Â Â Â Â Â Â Â Â Find topography top index |
---|
608 |           k_topo = get_topography_top_index( j, i, 's' ) |
---|
609 | |
---|
610 |           DO k = nzt+1, 0, -1 |
---|
611 |             IF ( lad_s(k,j,i) /= 0.0_wp ) THEN |
---|
612 | !--Â Â Â Â Â Â Â Â Â Â Â Â Â we are at the top of the pcs |
---|
613 |               pct(j,i) = k + k_topo |
---|
614 | Â Â Â Â Â Â Â Â Â Â Â Â Â Â pch(j,i)Â =Â k |
---|
615 |               npcbl = npcbl + pch(j,i) |
---|
616 | Â Â Â Â Â Â Â Â Â Â Â Â Â Â EXIT |
---|
617 | Â Â Â Â Â Â Â Â Â Â Â Â ENDIF |
---|
618 | Â Â Â Â Â Â Â Â Â Â ENDDO |
---|
619 | Â Â Â Â Â Â Â Â ENDDO |
---|
620 | Â Â Â Â Â Â ENDDO |
---|
621 | Â Â Â Â Â Â |
---|
622 |       nzutl = max(nzutl, maxval(pct)) |
---|
623 | !--Â Â Â Â Â code of plant canopy model uses parameter pch_index |
---|
624 | !--Â Â Â Â Â we need to setup it here to right value |
---|
625 | !--Â Â Â Â Â (pch_index, lad_s and other arrays in PCM are defined flat) |
---|
626 |       pch_index = maxval(pch) |
---|
627 | |
---|
628 |       prototype_lad = maxval(lad_s) * .9_wp !< better be *1.0 if lad is either 0 or maxval(lad) everywhere |
---|
629 |       IF ( prototype_lad <= 0._wp ) prototype_lad = .3_wp |
---|
630 | Â Â Â Â Â Â !WRITE(message_string, '(a,f6.3)') 'Precomputing effective box optical ' & |
---|
631 |       !  // 'depth using prototype leaf area density = ', prototype_lad |
---|
632 | Â Â Â Â Â Â !CALL message('usm_init_urban_surface', 'PA0520', 0, 0, -1, 6, 0) |
---|
633 | Â Â Â Â ENDIF |
---|
634 | Â Â Â Â |
---|
635 |     nzutl = min(nzutl+nzut_free, nzt) |
---|
636 | Â Â Â Â Â Â Â Â Â |
---|
637 | #if defined( __parallel ) |
---|
638 | Â Â Â Â CALL MPI_AllReduce(nzubl,nzub,1,MPI_INTEGER,MPI_MIN,comm2d,ierr); |
---|
639 | Â Â Â Â CALL MPI_AllReduce(nzutl,nzut,1,MPI_INTEGER,MPI_MAX,comm2d,ierr); |
---|
640 | #else |
---|
641 |     nzub = nzubl |
---|
642 |     nzut = nzutl |
---|
643 | #endif |
---|
644 | |
---|
645 | !--Â Â Â global number of urban layers |
---|
646 |     nzu = nzut - nzub + 1 |
---|
647 | Â Â Â Â |
---|
648 | !--Â Â Â allocate urban surfaces grid |
---|
649 | !--Â Â Â calc number of surfaces in local proc |
---|
650 |     CALL location_message( '  calculation of indices for surfaces', .TRUE. ) |
---|
651 |     nsurfl = 0 |
---|
652 | ! |
---|
653 | !--Â Â Â Number of land- and roof surfaces. Note, since horizontal surface elements |
---|
654 | !--Â Â Â are already counted in surface_mod, in case be simply reused here. |
---|
655 |     startland = 1 |
---|
656 |     nsurfl  = surf_usm_h%ns |
---|
657 |     endland  = nsurfl |
---|
658 |     nlands  = endland-startland+1 |
---|
659 | |
---|
660 | ! |
---|
661 | !--Â Â Â Number of vertical surfaces. As vertical surfaces are already |
---|
662 | !--Â Â Â counted in surface mod, it can be reused here. |
---|
663 |     startwall = nsurfl+1 |
---|
664 |     nsurfl = nsurfl + surf_usm_v(0)%ns + surf_usm_v(1)%ns +    & |
---|
665 |              surf_usm_v(2)%ns + surf_usm_v(3)%ns |
---|
666 |     endwall = nsurfl |
---|
667 |     nwalls = endwall-startwall+1 |
---|
668 | |
---|
669 | Â Â Â Â |
---|
670 | !--   range of energy balance surfaces ! will be treated separately by surf_usm_h and surf_usm_v |
---|
671 |     nenergy = 0 |
---|
672 |     IF ( usm_energy_balance_land ) THEN |
---|
673 |       startenergy = startland |
---|
674 |       nenergy = nenergy + nlands |
---|
675 | Â Â Â Â ELSE |
---|
676 |       startenergy = startwall |
---|
677 | Â Â Â Â ENDIF |
---|
678 |     IF ( usm_energy_balance_wall ) THEN |
---|
679 |       endenergy = endwall |
---|
680 |       nenergy = nenergy + nwalls |
---|
681 | Â Â Â Â ELSE |
---|
682 |       endenergy = endland |
---|
683 | Â Â Â Â ENDIF |
---|
684 | |
---|
685 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!! |
---|
686 | !--Â Â Â block of virtual surfaces |
---|
687 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!! |
---|
688 | !--   calculate sky surfaces ! not used so far! |
---|
689 |     startsky = nsurfl+1 |
---|
690 |     nsurfl = nsurfl+(nxr-nxl+1)*(nyn-nys+1) |
---|
691 |     endsky = nsurfl |
---|
692 |     nskys = endsky-startsky+1 |
---|
693 | Â Â Â Â |
---|
694 | !--Â Â Â border flags |
---|
695 | #if defined( __parallel ) |
---|
696 |     isborder = (/ north_border_pe, south_border_pe, right_border_pe, left_border_pe /) |
---|
697 | #else |
---|
698 |     isborder = (/.TRUE.,.TRUE.,.TRUE.,.TRUE./) |
---|
699 | #endif |
---|
700 | !--Â Â Â fill array of the limits of the local domain borders |
---|
701 |     ijdb = RESHAPE( (/ nxl,nxr,nyn,nyn,nxl,nxr,nys,nys,nxr,nxr,nys,nyn,nxl,nxl,nys,nyn /), (/4, 4/) ) |
---|
702 | !--Â Â Â calulation of the free borders of the domain |
---|
703 |     DO ids = 6,9 |
---|
704 | Â Â Â Â Â Â IFÂ (Â isborder(ids)Â )Â THEN |
---|
705 | !--Â Â Â Â Â Â free border of the domain in direction ids |
---|
706 |        DO i = ijdb(1,ids), ijdb(2,ids) |
---|
707 |          DO j = ijdb(3,ids), ijdb(4,ids) |
---|
708 | |
---|
709 |           k_topo = get_topography_top_index( j, i, 's' ) |
---|
710 |           k_topo2 = get_topography_top_index( j-jdir(ids), i-idir(ids), 's' ) |
---|
711 | |
---|
712 |           k = nzut - MAX( k_topo, k_topo2 ) |
---|
713 |           nsurfl = nsurfl + k |
---|
714 | Â Â Â Â Â Â Â Â Â ENDDO |
---|
715 | Â Â Â Â Â Â Â ENDDO |
---|
716 | Â Â Â Â Â Â ENDIF |
---|
717 | Â Â Â Â ENDDO |
---|
718 | Â Â Â Â |
---|
719 | !--Â Â Â fill gridpcbl and pcbl |
---|
720 |     IF ( plant_canopy ) THEN |
---|
721 |       ALLOCATE( pcbl(iz:ix, 1:npcbl) ) |
---|
722 | Â Â Â Â Â Â ALLOCATE(Â gridpcbl(nzub:nzut,nys:nyn,nxl:nxr)Â ) |
---|
723 | Â Â Â Â Â Â gridpcbl(:,:,:)Â =Â 0 |
---|
724 |       ipcgb = 0 |
---|
725 |       DO i = nxl, nxr |
---|
726 |         DO j = nys, nyn |
---|
727 | ! |
---|
728 | !--Â Â Â Â Â Â Â Â Â Find topography top index |
---|
729 |           k_topo = get_topography_top_index( j, i, 's' ) |
---|
730 | |
---|
731 |           DO k = k_topo + 1, pct(j,i) |
---|
732 |             ipcgb = ipcgb + 1 |
---|
733 | Â Â Â Â Â Â Â Â Â Â Â Â gridpcbl(k,j,i)Â =Â ipcgb |
---|
734 |             pcbl(:,ipcgb) = (/ k, j, i /) |
---|
735 | Â Â Â Â Â Â Â Â Â Â ENDDO |
---|
736 | Â Â Â Â Â Â Â Â ENDDO |
---|
737 | Â Â Â Â Â Â ENDDO |
---|
738 | |
---|
739 |       ALLOCATE( pcbinsw( 1:npcbl ) ) |
---|
740 |       ALLOCATE( pcbinlw( 1:npcbl ) ) |
---|
741 | Â Â Â Â ENDIF |
---|
742 | |
---|
743 | !--Â Â Â fill surfl |
---|
744 | Â Â Â Â ALLOCATE(surfl(5,nsurfl)) |
---|
745 |     isurf = 0 |
---|
746 | Â Â Â Â |
---|
747 | !--Â Â Â add land surfaces or roofs |
---|
748 |     DO i = nxl, nxr |
---|
749 |       DO j = nys, nyn |
---|
750 |         DO m = surf_usm_h%start_index(j,i), surf_usm_h%end_index(j,i) |
---|
751 |          k = surf_usm_h%k(m) |
---|
752 | |
---|
753 |          isurf = isurf + 1 |
---|
754 | Â Â Â Â Â Â Â Â Â surfl(:,isurf)Â =Â (/iroof,k,j,i,m/) |
---|
755 | Â Â Â Â Â Â Â Â ENDDO |
---|
756 | Â Â Â Â Â Â ENDDO |
---|
757 | Â Â Â Â ENDDO |
---|
758 | |
---|
759 | !--Â Â Â add walls |
---|
760 |     DO i = nxl, nxr |
---|
761 |       DO j = nys, nyn |
---|
762 |         l = 0 |
---|
763 |         DO m = surf_usm_v(l)%start_index(j,i), surf_usm_v(l)%end_index(j,i) |
---|
764 |          k = surf_usm_v(l)%k(m) |
---|
765 | |
---|
766 |          isurf     = isurf + 1 |
---|
767 | Â Â Â Â Â Â Â Â Â surfl(:,isurf)Â =Â (/2,k,j,i,m/) |
---|
768 | Â Â Â Â Â Â Â Â ENDDO |
---|
769 |         l = 1 |
---|
770 |         DO m = surf_usm_v(l)%start_index(j,i), surf_usm_v(l)%end_index(j,i) |
---|
771 |          k = surf_usm_v(l)%k(m) |
---|
772 | |
---|
773 |          isurf     = isurf + 1 |
---|
774 | Â Â Â Â Â Â Â Â Â surfl(:,isurf)Â =Â (/1,k,j,i,m/) |
---|
775 | Â Â Â Â Â Â Â Â ENDDO |
---|
776 |         l = 2 |
---|
777 |         DO m = surf_usm_v(l)%start_index(j,i), surf_usm_v(l)%end_index(j,i) |
---|
778 |          k = surf_usm_v(l)%k(m) |
---|
779 | |
---|
780 |          isurf     = isurf + 1 |
---|
781 | Â Â Â Â Â Â Â Â Â surfl(:,isurf)Â =Â (/4,k,j,i,m/) |
---|
782 | Â Â Â Â Â Â Â Â ENDDO |
---|
783 |         l = 3 |
---|
784 |         DO m = surf_usm_v(l)%start_index(j,i), surf_usm_v(l)%end_index(j,i) |
---|
785 |          k = surf_usm_v(l)%k(m) |
---|
786 | |
---|
787 |          isurf     = isurf + 1 |
---|
788 | Â Â Â Â Â Â Â Â Â surfl(:,isurf)Â =Â (/3,k,j,i,m/) |
---|
789 | Â Â Â Â Â Â Â Â ENDDO |
---|
790 | Â Â Â Â Â Â ENDDO |
---|
791 | Â Â Â Â ENDDO |
---|
792 | |
---|
793 | !--Â Â Â add sky |
---|
794 |     DO i = nxl, nxr |
---|
795 |       DO j = nys, nyn |
---|
796 |         isurf = isurf + 1 |
---|
797 |         k = nzut |
---|
798 | Â Â Â Â Â Â Â Â surfl(:,isurf)Â =Â (/isky,k,j,i,-1/) |
---|
799 | Â Â Â Â Â Â ENDDO |
---|
800 | Â Â Â Â ENDDO |
---|
801 | Â Â Â Â |
---|
802 | !--Â Â Â calulation of the free borders of the domain |
---|
803 |     DO ids = 6,9 |
---|
804 | Â Â Â Â Â Â IFÂ (Â isborder(ids)Â )Â THEN |
---|
805 | !--Â Â Â Â Â Â Â free border of the domain in direction ids |
---|
806 |         DO i = ijdb(1,ids), ijdb(2,ids) |
---|
807 |           DO j = ijdb(3,ids), ijdb(4,ids) |
---|
808 |             k_topo = get_topography_top_index( j, i, 's' ) |
---|
809 |             k_topo2 = get_topography_top_index( j-jdir(ids), i-idir(ids), 's' ) |
---|
810 | |
---|
811 |             DO k = MAX(k_topo,k_topo2)+1, nzut |
---|
812 |               isurf = isurf + 1 |
---|
813 | Â Â Â Â Â Â Â Â Â Â Â Â Â Â surfl(:,isurf)Â =Â (/ids,k,j,i,-1/) |
---|
814 | Â Â Â Â Â Â Â Â Â Â Â Â ENDDO |
---|
815 | Â Â Â Â Â Â Â Â Â Â ENDDO |
---|
816 | Â Â Â Â Â Â Â Â ENDDO |
---|
817 | Â Â Â Â Â Â ENDIF |
---|
818 | Â Â Â Â ENDDO |
---|
819 | Â Â Â Â |
---|
820 | !--Â Â Â global array surf of indices of surfaces and displacement index array surfstart |
---|
821 | Â Â Â Â ALLOCATE(nsurfs(0:numprocs-1)) |
---|
822 | Â Â Â Â |
---|
823 | #if defined( __parallel ) |
---|
824 | Â Â Â Â CALL MPI_Allgather(nsurfl,1,MPI_INTEGER,nsurfs,1,MPI_INTEGER,comm2d,ierr) |
---|
825 | #else |
---|
826 | Â Â Â Â nsurfs(0)Â =Â nsurfl |
---|
827 | #endif |
---|
828 | Â Â Â Â ALLOCATE(surfstart(0:numprocs)) |
---|
829 |     k = 0 |
---|
830 | Â Â Â Â DO i=0,numprocs-1 |
---|
831 | Â Â Â Â Â Â surfstart(i)Â =Â k |
---|
832 |       k = k+nsurfs(i) |
---|
833 | Â Â Â Â ENDDO |
---|
834 | Â Â Â Â surfstart(numprocs)Â =Â k |
---|
835 |     nsurf = k |
---|
836 | Â Â Â Â ALLOCATE(surf(5,nsurf)) |
---|
837 | Â Â Â Â |
---|
838 | #if defined( __parallel ) |
---|
839 |     CALL MPI_AllGatherv(surfl, nsurfl*5, MPI_INTEGER, surf, nsurfs*5, surfstart*5, MPI_INTEGER, comm2d, ierr) |
---|
840 | #else |
---|
841 |     surf = surfl |
---|
842 | #endif |
---|
843 | Â Â Â Â |
---|
844 | !-- |
---|
845 | !--Â Â Â allocation of the arrays for direct and diffusion radiation |
---|
846 |     CALL location_message( '  allocation of radiation arrays', .TRUE. ) |
---|
847 | !--Â Â Â rad_sw_in, rad_lw_in are computed in radiation model, |
---|
848 | !--Â Â Â splitting of direct and diffusion part is done |
---|
849 | !--Â Â Â in usm_calc_diffusion_radiation for now |
---|
850 | Â Â Â Â ALLOCATE(Â rad_sw_in_dir(nysg:nyng,nxlg:nxrg)Â ) |
---|
851 | Â Â Â Â ALLOCATE(Â rad_sw_in_diff(nysg:nyng,nxlg:nxrg)Â ) |
---|
852 | Â Â Â Â ALLOCATE(Â rad_lw_in_diff(nysg:nyng,nxlg:nxrg)Â ) |
---|
853 | Â Â Â Â |
---|
854 | !--Â Â Â allocate radiation arrays |
---|
855 | Â Â Â Â ALLOCATE(Â surfins(nsurfl)Â ) |
---|
856 | Â Â Â Â ALLOCATE(Â surfinl(nsurfl)Â ) |
---|
857 | Â Â Â Â ALLOCATE(Â surfinsw(nsurfl)Â ) |
---|
858 | Â Â Â Â ALLOCATE(Â surfinlw(nsurfl)Â ) |
---|
859 | Â Â Â Â ALLOCATE(Â surfinswdir(nsurfl)Â ) |
---|
860 | Â Â Â Â ALLOCATE(Â surfinswdif(nsurfl)Â ) |
---|
861 | Â Â Â Â ALLOCATE(Â surfinlwdif(nsurfl)Â ) |
---|
862 | Â Â Â Â ALLOCATE(Â surfoutsl(startenergy:endenergy)Â ) |
---|
863 | Â Â Â Â ALLOCATE(Â surfoutll(startenergy:endenergy)Â ) |
---|
864 | Â Â Â Â ALLOCATE(Â surfoutsw(startenergy:endenergy)Â ) |
---|
865 | Â Â Â Â ALLOCATE(Â surfoutlw(startenergy:endenergy)Â ) |
---|
866 | Â Â Â Â ALLOCATE(Â surfouts(nsurf)Â )Â !TODO: global surfaces without virtual |
---|
867 | Â Â Â Â ALLOCATE(Â surfoutl(nsurf)Â )Â !TODO: global surfaces without virtual |
---|
868 | |
---|
869 | |
---|
870 | |
---|
871 | ! |
---|
872 | !--Â Â Â Allocate radiation arrays which are part of the new data type. |
---|
873 | !--Â Â Â For horizontal surfaces. |
---|
874 | Â Â Â Â ALLOCATE(Â surf_usm_h%surfhf(1:surf_usm_h%ns)Â Â ) |
---|
875 | Â Â Â Â ALLOCATE(Â surf_usm_h%rad_net_l(1:surf_usm_h%ns)Â ) |
---|
876 | ! |
---|
877 | !--Â New |
---|
878 | Â Â Â Â ALLOCATE(Â surf_usm_h%rad_in_sw(1:surf_usm_h%ns)Â ) |
---|
879 | Â Â Â Â ALLOCATE(Â surf_usm_h%rad_out_sw(1:surf_usm_h%ns)Â ) |
---|
880 | Â Â Â Â ALLOCATE(Â surf_usm_h%rad_in_lw(1:surf_usm_h%ns)Â ) |
---|
881 | Â Â Â Â ALLOCATE(Â surf_usm_h%rad_out_lw(1:surf_usm_h%ns)Â ) |
---|
882 | ! |
---|
883 | !--Â Â Â For vertical surfaces |
---|
884 |     DO l = 0, 3 |
---|
885 | Â Â Â Â Â Â ALLOCATE(Â surf_usm_v(l)%surfhf(1:surf_usm_v(l)%ns)Â Â ) |
---|
886 | Â Â Â Â Â Â ALLOCATE(Â surf_usm_v(l)%rad_net_l(1:surf_usm_v(l)%ns)Â ) |
---|
887 | Â Â Â Â Â Â ALLOCATE(Â surf_usm_v(l)%rad_in_sw(1:surf_usm_v(l)%ns)Â ) |
---|
888 | Â Â Â Â Â Â ALLOCATE(Â surf_usm_v(l)%rad_out_sw(1:surf_usm_v(l)%ns)Â ) |
---|
889 | Â Â Â Â Â Â ALLOCATE(Â surf_usm_v(l)%rad_in_lw(1:surf_usm_v(l)%ns)Â ) |
---|
890 | Â Â Â Â Â Â ALLOCATE(Â surf_usm_v(l)%rad_out_lw(1:surf_usm_v(l)%ns)Â ) |
---|
891 | Â Â Â Â ENDDO |
---|
892 | |
---|
893 | !--Â Â Â Wall surface model |
---|
894 | !--Â Â Â allocate arrays for wall surface model and define pointers |
---|
895 | Â Â Â Â |
---|
896 | !--Â Â Â allocate array of wall types and wall parameters |
---|
897 | Â Â Â Â ALLOCATEÂ (Â surf_usm_h%surface_types(1:surf_usm_h%ns)Â ) |
---|
898 |     DO l = 0, 3 |
---|
899 | Â Â Â Â Â Â ALLOCATE(Â surf_usm_v(l)%surface_types(1:surf_usm_v(l)%ns)Â ) |
---|
900 | Â Â Â Â ENDDO |
---|
901 | Â Â Â Â |
---|
902 | !--Â Â Â broadband albedo of the land, roof and wall surface |
---|
903 | !--Â Â Â for domain border and sky set artifically to 1.0 |
---|
904 | !--Â Â Â what allows us to calculate heat flux leaving over |
---|
905 | !--Â Â Â side and top borders of the domain |
---|
906 | Â Â Â Â ALLOCATEÂ (Â albedo_surf(nsurfl)Â ) |
---|
907 |     albedo_surf = 1.0_wp |
---|
908 | Â Â Â Â ALLOCATEÂ (Â surf_usm_h%albedo_surf(1:surf_usm_h%ns)Â ) |
---|
909 |     DO l = 0, 3 |
---|
910 | Â Â Â Â Â Â ALLOCATE(Â surf_usm_v(l)%albedo_surf(1:surf_usm_v(l)%ns)Â ) |
---|
911 | Â Â Â Â ENDDO |
---|
912 | Â Â Â Â |
---|
913 | !--Â Â Â wall and roof surface parameters. First for horizontal surfaces |
---|
914 | Â Â Â Â ALLOCATEÂ (Â emiss_surf(startenergy:endenergy)Â ) |
---|
915 | |
---|
916 | Â Â Â Â ALLOCATEÂ (Â surf_usm_h%isroof_surf(1:surf_usm_h%ns)Â Â ) |
---|
917 | Â Â Â Â ALLOCATEÂ (Â surf_usm_h%emiss_surf(1:surf_usm_h%ns)Â Â Â ) |
---|
918 | Â Â Â Â ALLOCATEÂ (Â surf_usm_h%lambda_surf(1:surf_usm_h%ns)Â Â ) |
---|
919 | Â Â Â Â ALLOCATEÂ (Â surf_usm_h%c_surface(1:surf_usm_h%ns)Â Â Â ) |
---|
920 | Â Â Â Â ALLOCATEÂ (Â surf_usm_h%roughness_wall(1:surf_usm_h%ns)Â ) |
---|
921 | ! |
---|
922 | !--Â Â Â For vertical surfaces. |
---|
923 |     DO l = 0, 3 |
---|
924 | Â Â Â Â Â Â ALLOCATEÂ (Â surf_usm_v(l)%emiss_surf(1:surf_usm_v(l)%ns)Â Â Â ) |
---|
925 | Â Â Â Â Â Â ALLOCATEÂ (Â surf_usm_v(l)%lambda_surf(1:surf_usm_v(l)%ns)Â Â ) |
---|
926 | Â Â Â Â Â Â ALLOCATEÂ (Â surf_usm_v(l)%c_surface(1:surf_usm_v(l)%ns)Â Â Â ) |
---|
927 | Â Â Â Â Â Â ALLOCATEÂ (Â surf_usm_v(l)%roughness_wall(1:surf_usm_v(l)%ns)Â ) |
---|
928 | Â Â Â Â ENDDO |
---|
929 | Â Â Â Â |
---|
930 | !--Â Â Â allocate wall and roof material parameters. First for horizontal surfaces |
---|
931 | Â Â Â Â ALLOCATEÂ (Â surf_usm_h%thickness_wall(1:surf_usm_h%ns)Â Â Â Â Â Â Â Â ) |
---|
932 | Â Â Â Â ALLOCATEÂ (Â surf_usm_h%lambda_h(nzb_wall:nzt_wall,1:surf_usm_h%ns)Â Â ) |
---|
933 | Â Â Â Â ALLOCATEÂ (Â surf_usm_h%rho_c_wall(nzb_wall:nzt_wall,1:surf_usm_h%ns)Â ) |
---|
934 | ! |
---|
935 | !--Â Â Â For vertical surfaces. |
---|
936 |     DO l = 0, 3 |
---|
937 | Â Â Â Â Â Â ALLOCATEÂ (Â surf_usm_v(l)%thickness_wall(1:surf_usm_v(l)%ns)Â Â Â Â Â Â Â Â ) |
---|
938 | Â Â Â Â Â Â ALLOCATEÂ (Â surf_usm_v(l)%lambda_h(nzb_wall:nzt_wall,1:surf_usm_v(l)%ns)Â Â ) |
---|
939 | Â Â Â Â Â Â ALLOCATEÂ (Â surf_usm_v(l)%rho_c_wall(nzb_wall:nzt_wall,1:surf_usm_v(l)%ns)Â ) |
---|
940 | Â Â Â Â ENDDO |
---|
941 | |
---|
942 | !--Â Â Â allocate wall and roof layers sizes. For horizontal surfaces. |
---|
943 | Â Â Â Â ALLOCATEÂ (Â zwn(nzb_wall:nzt_wall)Â ) |
---|
944 | Â Â Â Â ALLOCATEÂ (Â surf_usm_h%dz_wall(nzb_wall:nzt_wall+1,1:surf_usm_h%ns)Â Â Â ) |
---|
945 | Â Â Â Â ALLOCATEÂ (Â surf_usm_h%ddz_wall(nzb_wall:nzt_wall+1,1:surf_usm_h%ns)Â Â ) |
---|
946 | Â Â Â Â ALLOCATEÂ (Â surf_usm_h%dz_wall_stag(nzb_wall:nzt_wall,1:surf_usm_h%ns)Â ) |
---|
947 | Â Â Â Â ALLOCATEÂ (Â surf_usm_h%ddz_wall_stag(nzb_wall:nzt_wall,1:surf_usm_h%ns)Â ) |
---|
948 | Â Â Â Â ALLOCATEÂ (Â surf_usm_h%zw(nzb_wall:nzt_wall,1:surf_usm_h%ns)Â Â Â Â Â Â ) |
---|
949 | ! |
---|
950 | !--Â Â Â For vertical surfaces. |
---|
951 |     DO l = 0, 3 |
---|
952 | Â Â Â Â Â Â ALLOCATEÂ (Â surf_usm_v(l)%dz_wall(nzb_wall:nzt_wall+1,1:surf_usm_v(l)%ns)Â Â Â ) |
---|
953 | Â Â Â Â Â Â ALLOCATEÂ (Â surf_usm_v(l)%ddz_wall(nzb_wall:nzt_wall+1,1:surf_usm_v(l)%ns)Â Â ) |
---|
954 | Â Â Â Â Â Â ALLOCATEÂ (Â surf_usm_v(l)%dz_wall_stag(nzb_wall:nzt_wall,1:surf_usm_v(l)%ns)Â ) |
---|
955 | Â Â Â Â Â Â ALLOCATEÂ (Â surf_usm_v(l)%ddz_wall_stag(nzb_wall:nzt_wall,1:surf_usm_v(l)%ns)Â ) |
---|
956 | Â Â Â Â Â Â ALLOCATEÂ (Â surf_usm_v(l)%zw(nzb_wall:nzt_wall,1:surf_usm_v(l)%ns)Â Â Â Â Â Â ) |
---|
957 | Â Â Â Â ENDDO |
---|
958 | |
---|
959 | !--Â Â Â allocate wall and roof temperature arrays, for horizontal walls |
---|
960 | #if defined( __nopointer ) |
---|
961 |     IF ( .NOT. ALLOCATED( t_surf_h ) )                   & |
---|
962 | Â Â Â Â Â Â ALLOCATEÂ (Â t_surf_h(1:surf_usm_h%ns)Â ) |
---|
963 |     IF ( .NOT. ALLOCATED( t_surf_h_p ) )                  & |
---|
964 | Â Â Â Â Â Â ALLOCATEÂ (Â t_surf_h_p(1:surf_usm_h%ns)Â ) |
---|
965 |     IF ( .NOT. ALLOCATED( t_wall_h ) )                   &      |
---|
966 | Â Â Â Â Â Â ALLOCATEÂ (Â t_wall_h(nzb_wall:nzt_wall+1,1:surf_usm_h%ns)Â )Â |
---|
967 |     IF ( .NOT. ALLOCATED( t_wall_h_p ) )                  &      |
---|
968 | Â Â Â Â Â Â ALLOCATEÂ (Â t_wall_h_p(nzb_wall:nzt_wall+1,1:surf_usm_h%ns)Â )Â |
---|
969 | #else |
---|
970 | ! |
---|
971 | !--Â Â Â Allocate if required. Note, in case of restarts, some of these arrays |
---|
972 | !--Â Â Â might be already allocated. |
---|
973 |     IF ( .NOT. ALLOCATED( t_surf_h_1 ) )                  & |
---|
974 | Â Â Â Â Â Â ALLOCATEÂ (Â t_surf_h_1(1:surf_usm_h%ns)Â ) |
---|
975 |     IF ( .NOT. ALLOCATED( t_surf_h_2 ) )                  & |
---|
976 | Â Â Â Â Â Â ALLOCATEÂ (Â t_surf_h_2(1:surf_usm_h%ns)Â ) |
---|
977 |     IF ( .NOT. ALLOCATED( t_wall_h_1 ) )                  &      |
---|
978 | Â Â Â Â Â Â ALLOCATEÂ (Â t_wall_h_1(nzb_wall:nzt_wall+1,1:surf_usm_h%ns)Â )Â |
---|
979 |     IF ( .NOT. ALLOCATED( t_wall_h_2 ) )                  &      |
---|
980 | Â Â Â Â Â Â ALLOCATEÂ (Â t_wall_h_2(nzb_wall:nzt_wall+1,1:surf_usm_h%ns)Â )Â Â Â Â Â |
---|
981 | !      |
---|
982 | !--Â Â Â initial assignment of the pointers |
---|
983 |     t_wall_h  => t_wall_h_1;  t_wall_h_p  => t_wall_h_2 |
---|
984 |     t_surf_h => t_surf_h_1; t_surf_h_p => t_surf_h_2      |
---|
985 | #endif |
---|
986 | |
---|
987 | !--Â Â Â allocate wall and roof temperature arrays, for vertical walls if required |
---|
988 | #if defined( __nopointer ) |
---|
989 |     DO l = 0, 3 |
---|
990 |       IF ( .NOT. ALLOCATED( t_surf_v(l)%t ) )               & |
---|
991 | Â Â Â Â Â Â Â ALLOCATEÂ (Â t_surf_v(l)%t(1:surf_usm_v(l)%ns)Â ) |
---|
992 |       IF ( .NOT. ALLOCATED( t_surf_v_p(l)%t ) )              & |
---|
993 | Â Â Â Â Â Â Â ALLOCATEÂ (Â t_surf_v_p(l)%t(1:surf_usm_v(l)%ns)Â ) |
---|
994 |       IF ( .NOT. ALLOCATED( t_wall_v(l)%t ) )               & |
---|
995 | Â Â Â Â Â Â Â ALLOCATEÂ (Â t_wall_v(l)%t(nzb_wall:nzt_wall+1,1:surf_usm_v(l)%ns)Â ) |
---|
996 |       IF ( .NOT. ALLOCATED( t_wall_v_p(l)%t ) )              &         |
---|
997 | Â Â Â Â Â Â Â ALLOCATEÂ (Â t_wall_v_p(l)%t(nzb_wall:nzt_wall+1,1:surf_usm_v(l)%ns)Â ) |
---|
998 | Â Â Â Â ENDDO |
---|
999 | #else |
---|
1000 | ! |
---|
1001 | !--Â Â Â Allocate if required. Note, in case of restarts, some of these arrays |
---|
1002 | !--Â Â Â might be already allocated. |
---|
1003 |     DO l = 0, 3 |
---|
1004 |       IF ( .NOT. ALLOCATED( t_surf_v_1(l)%t ) )              & |
---|
1005 | Â Â Â Â Â Â Â ALLOCATEÂ (Â t_surf_v_1(l)%t(1:surf_usm_v(l)%ns)Â ) |
---|
1006 |       IF ( .NOT. ALLOCATED( t_surf_v_2(l)%t ) )              & |
---|
1007 | Â Â Â Â Â Â Â ALLOCATEÂ (Â t_surf_v_2(l)%t(1:surf_usm_v(l)%ns)Â ) |
---|
1008 |       IF ( .NOT. ALLOCATED( t_wall_v_1(l)%t ) )              &      |
---|
1009 | Â Â Â Â Â Â Â ALLOCATEÂ (Â t_wall_v_1(l)%t(nzb_wall:nzt_wall+1,1:surf_usm_v(l)%ns)Â )Â |
---|
1010 |       IF ( .NOT. ALLOCATED( t_wall_v_2(l)%t ) )              &      |
---|
1011 | Â Â Â Â Â Â Â ALLOCATEÂ (Â t_wall_v_2(l)%t(nzb_wall:nzt_wall+1,1:surf_usm_v(l)%ns)Â )Â |
---|
1012 | Â Â Â Â ENDDO |
---|
1013 | ! |
---|
1014 | !--Â Â Â initial assignment of the pointers |
---|
1015 |     t_wall_v  => t_wall_v_1;  t_wall_v_p  => t_wall_v_2 |
---|
1016 |     t_surf_v => t_surf_v_1; t_surf_v_p => t_surf_v_2 |
---|
1017 | #endif |
---|
1018 | ! |
---|
1019 | !--Â Â Â Allocate intermediate timestep arrays. For horizontal surfaces. |
---|
1020 | Â Â Â Â ALLOCATEÂ (Â surf_usm_h%tt_surface_m(1:surf_usm_h%ns)Â Â Â Â Â Â Â Â Â ) |
---|
1021 | Â Â Â Â ALLOCATEÂ (Â surf_usm_h%tt_wall_m(nzb_wall:nzt_wall+1,1:surf_usm_h%ns)Â ) |
---|
1022 | ! |
---|
1023 | !--Â Â Â Set inital values for prognostic quantities |
---|
1024 |     IF ( ALLOCATED( surf_usm_h%tt_surface_m ) ) surf_usm_h%tt_surface_m = 0.0_wp |
---|
1025 |     IF ( ALLOCATED( surf_usm_h%tt_wall_m  ) ) surf_usm_h%tt_wall_m  = 0.0_wp |
---|
1026 | ! |
---|
1027 | !--Â Â Â Now, for vertical surfaces |
---|
1028 |     DO l = 0, 3 |
---|
1029 | Â Â Â Â Â Â ALLOCATEÂ (Â surf_usm_v(l)%tt_surface_m(1:surf_usm_v(l)%ns)Â Â Â Â Â Â Â Â Â ) |
---|
1030 | Â Â Â Â Â Â ALLOCATEÂ (Â surf_usm_v(l)%tt_wall_m(nzb_wall:nzt_wall+1,1:surf_usm_v(l)%ns)Â ) |
---|
1031 |       IF ( ALLOCATED( surf_usm_v(l)%tt_surface_m ) ) surf_usm_v(l)%tt_surface_m = 0.0_wp |
---|
1032 |       IF ( ALLOCATED( surf_usm_v(l)%tt_wall_m  ) ) surf_usm_v(l)%tt_wall_m  = 0.0_wp |
---|
1033 | Â Â Â Â ENDDO |
---|
1034 | |
---|
1035 | !--Â Â Â allocate wall heat flux output array and set initial values. For horizontal surfaces |
---|
1036 | !     ALLOCATE ( surf_usm_h%wshf(1:surf_usm_h%ns)  ) !can be removed |
---|
1037 | Â Â Â Â ALLOCATEÂ (Â surf_usm_h%wshf_eb(1:surf_usm_h%ns)Â ) |
---|
1038 | Â Â Â Â ALLOCATEÂ (Â surf_usm_h%wghf_eb(1:surf_usm_h%ns)Â ) |
---|
1039 |     IF ( ALLOCATED( surf_usm_h%wshf  ) ) surf_usm_h%wshf  = 0.0_wp |
---|
1040 |     IF ( ALLOCATED( surf_usm_h%wshf_eb ) ) surf_usm_h%wshf_eb = 0.0_wp |
---|
1041 |     IF ( ALLOCATED( surf_usm_h%wghf_eb ) ) surf_usm_h%wghf_eb = 0.0_wp |
---|
1042 | ! |
---|
1043 | !--Â Â Â Now, for vertical surfaces |
---|
1044 |     DO l = 0, 3 |
---|
1045 | !      ALLOCATE ( surf_usm_v(l)%wshf(1:surf_usm_v(l)%ns)  )  ! can be removed |
---|
1046 | Â Â Â Â Â Â ALLOCATEÂ (Â surf_usm_v(l)%wshf_eb(1:surf_usm_v(l)%ns)Â ) |
---|
1047 | Â Â Â Â Â Â ALLOCATEÂ (Â surf_usm_v(l)%wghf_eb(1:surf_usm_v(l)%ns)Â ) |
---|
1048 |       IF ( ALLOCATED( surf_usm_v(l)%wshf  ) ) surf_usm_v(l)%wshf  = 0.0_wp |
---|
1049 |       IF ( ALLOCATED( surf_usm_v(l)%wshf_eb ) ) surf_usm_v(l)%wshf_eb = 0.0_wp |
---|
1050 |       IF ( ALLOCATED( surf_usm_v(l)%wghf_eb ) ) surf_usm_v(l)%wghf_eb = 0.0_wp |
---|
1051 | Â Â Â Â ENDDO |
---|
1052 | Â Â Â Â |
---|
1053 | Â Â END SUBROUTINE usm_allocate_urban_surface |
---|
1054 | |
---|
1055 | |
---|
1056 | |
---|
1057 | !------------------------------------------------------------------------------! |
---|
1058 | ! Description: |
---|
1059 | ! ------------ |
---|
1060 | !> Sum up and time-average urban surface output quantities as well as allocate |
---|
1061 | !> the array necessary for storing the average. |
---|
1062 | !------------------------------------------------------------------------------! |
---|
1063 |   SUBROUTINE usm_average_3d_data( mode, variable ) |
---|
1064 | |
---|
1065 | Â Â Â Â IMPLICIT NONE |
---|
1066 | |
---|
1067 |     CHARACTER (len=*), INTENT(IN) :: mode |
---|
1068 |     CHARACTER (len=*), INTENT(IN) :: variable |
---|
1069 | Â |
---|
1070 |     INTEGER(iwp)                    :: i, j, k, l, m, ids, iwl,istat |
---|
1071 |     CHARACTER (len=varnamelength)           :: var, surfid |
---|
1072 |     INTEGER(iwp), PARAMETER              :: nd = 5 |
---|
1073 |     CHARACTER(len=6), DIMENSION(0:nd-1), PARAMETER   :: dirname = (/ '_roof ', '_south', '_north', '_west ', '_east ' /) |
---|
1074 | |
---|
1075 | !--Â Â Â find the real name of the variable |
---|
1076 |     var = TRIM(variable) |
---|
1077 |     DO i = 0, nd-1 |
---|
1078 |       k = len(TRIM(var)) |
---|
1079 |       j = len(TRIM(dirname(i))) |
---|
1080 | Â Â Â Â Â Â IFÂ (Â var(k-j+1:k)Â ==Â dirname(i)Â )Â THEN |
---|
1081 |         ids = i |
---|
1082 |         var = var(:k-j) |
---|
1083 | Â Â Â Â Â Â Â Â EXIT |
---|
1084 | Â Â Â Â Â Â ENDIF |
---|
1085 | Â Â Â Â ENDDO |
---|
1086 |     IF ( ids == -1 ) THEN |
---|
1087 |       var = TRIM(variable) |
---|
1088 | Â Â Â Â ENDIF |
---|
1089 |     IF ( var(1:11) == 'usm_t_wall_' .AND. len(TRIM(var)) >= 12 ) THEN |
---|
1090 | !--Â Â Â Â Â wall layers |
---|
1091 |       READ(var(12:12), '(I1)', iostat=istat ) iwl |
---|
1092 |       IF ( istat == 0 .AND. iwl >= nzb_wall .AND. iwl <= nzt_wall ) THEN |
---|
1093 |         var = var(1:10) |
---|
1094 | Â Â Â Â Â Â ELSE |
---|
1095 | !--Â Â Â Â Â Â Â wrong wall layer index |
---|
1096 | Â Â Â Â Â Â Â Â RETURN |
---|
1097 | Â Â Â Â Â Â ENDIF |
---|
1098 | Â Â Â Â ENDIF |
---|
1099 | |
---|
1100 |     IF ( mode == 'allocate' ) THEN |
---|
1101 | Â Â Â Â Â Â |
---|
1102 |       SELECT CASE ( TRIM( var ) ) |
---|
1103 | Â Â Â Â Â Â Â Â |
---|
1104 | Â Â Â Â Â Â Â Â CASEÂ (Â 'usm_rad_net'Â ) |
---|
1105 | !--Â Â Â Â Â Â Â Â Â array of complete radiation balance |
---|
1106 |           IF ( .NOT. ALLOCATED(surf_usm_h%rad_net_av) ) THEN |
---|
1107 | Â Â Â Â Â Â Â Â Â Â Â Â ALLOCATE(Â surf_usm_h%rad_net_av(1:surf_usm_h%ns)Â ) |
---|
1108 |             surf_usm_h%rad_net_av = 0.0_wp |
---|
1109 | Â Â Â Â Â Â Â Â Â Â ENDIF |
---|
1110 |           DO l = 0, 3 |
---|
1111 |             IF ( .NOT. ALLOCATED(surf_usm_v(l)%rad_net_av) ) THEN |
---|
1112 | Â Â Â Â Â Â Â Â Â Â Â Â Â Â ALLOCATE(Â surf_usm_v(l)%rad_net_av(1:surf_usm_v(l)%ns)Â ) |
---|
1113 |               surf_usm_v(l)%rad_net_av = 0.0_wp |
---|
1114 | Â Â Â Â Â Â Â Â Â Â Â Â ENDIF |
---|
1115 | Â Â Â Â Â Â Â Â Â Â ENDDO |
---|
1116 | Â Â Â Â Â Â Â Â Â Â |
---|
1117 | Â Â Â Â Â Â Â Â CASEÂ (Â 'usm_rad_insw'Â ) |
---|
1118 | !--Â Â Â Â Â Â Â Â Â array of sw radiation falling to surface after i-th reflection |
---|
1119 |           IF ( .NOT. ALLOCATED(surf_usm_h%surfinsw_av) ) THEN |
---|
1120 | Â Â Â Â Â Â Â Â Â Â Â Â ALLOCATE(Â surf_usm_h%surfinsw_av(1:surf_usm_h%ns)Â ) |
---|
1121 |             surf_usm_h%surfinsw_av = 0.0_wp |
---|
1122 | Â Â Â Â Â Â Â Â Â Â ENDIF |
---|
1123 |           DO l = 0, 3 |
---|
1124 |             IF ( .NOT. ALLOCATED(surf_usm_v(l)%surfinsw_av) ) THEN |
---|
1125 | Â Â Â Â Â Â Â Â Â Â Â Â Â Â ALLOCATE(Â surf_usm_v(l)%surfinsw_av(1:surf_usm_v(l)%ns)Â ) |
---|
1126 |               surf_usm_v(l)%surfinsw_av = 0.0_wp |
---|
1127 | Â Â Â Â Â Â Â Â Â Â Â Â ENDIF |
---|
1128 | Â Â Â Â Â Â Â Â Â Â ENDDO |
---|
1129 | Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â |
---|
1130 | Â Â Â Â Â Â Â Â CASEÂ (Â 'usm_rad_inlw'Â ) |
---|
1131 | !--Â Â Â Â Â Â Â Â Â array of lw radiation falling to surface after i-th reflection |
---|
1132 |           IF ( .NOT. ALLOCATED(surf_usm_h%surfinlw_av) ) THEN |
---|
1133 | Â Â Â Â Â Â Â Â Â Â Â Â ALLOCATE(Â surf_usm_h%surfinlw_av(1:surf_usm_h%ns)Â ) |
---|
1134 |             surf_usm_h%surfinlw_av = 0.0_wp |
---|
1135 | Â Â Â Â Â Â Â Â Â Â ENDIF |
---|
1136 |           DO l = 0, 3 |
---|
1137 |             IF ( .NOT. ALLOCATED(surf_usm_v(l)%surfinlw_av) ) THEN |
---|
1138 | Â Â Â Â Â Â Â Â Â Â Â Â Â Â ALLOCATE(Â surf_usm_v(l)%surfinlw_av(1:surf_usm_v(l)%ns)Â ) |
---|
1139 |               surf_usm_v(l)%surfinlw_av = 0.0_wp |
---|
1140 | Â Â Â Â Â Â Â Â Â Â Â Â ENDIF |
---|
1141 | Â Â Â Â Â Â Â Â Â Â ENDDO |
---|
1142 | |
---|
1143 | Â Â Â Â Â Â Â Â CASEÂ (Â 'usm_rad_inswdir'Â ) |
---|
1144 | !--Â Â Â Â Â Â Â Â Â array of direct sw radiation falling to surface from sun |
---|
1145 |           IF ( .NOT. ALLOCATED(surfinswdir_av) ) THEN |
---|
1146 | Â Â Â Â Â Â Â Â Â Â Â Â ALLOCATE(Â surfinswdir_av(startenergy:endenergy)Â ) |
---|
1147 |             surfinswdir_av = 0.0_wp |
---|
1148 | Â Â Â Â Â Â Â Â Â Â ENDIF |
---|
1149 | |
---|
1150 | Â Â Â Â Â Â Â Â CASEÂ (Â 'usm_rad_inswdif'Â ) |
---|
1151 | !--Â Â Â Â Â Â Â Â Â array of difusion sw radiation falling to surface from sky and borders of the domain |
---|
1152 |           IF ( .NOT. ALLOCATED(surfinswdif_av) ) THEN |
---|
1153 | Â Â Â Â Â Â Â Â Â Â Â Â ALLOCATE(Â surfinswdif_av(startenergy:endenergy)Â ) |
---|
1154 |             surfinswdif_av = 0.0_wp |
---|
1155 | Â Â Â Â Â Â Â Â Â Â ENDIF |
---|
1156 | |
---|
1157 | Â Â Â Â Â Â Â Â CASEÂ (Â 'usm_rad_inswref'Â ) |
---|
1158 | !--Â Â Â Â Â Â Â Â Â array of sw radiation falling to surface from reflections |
---|
1159 |           IF ( .NOT. ALLOCATED(surfinswref_av) ) THEN |
---|
1160 | Â Â Â Â Â Â Â Â Â Â Â Â ALLOCATE(Â surfinswref_av(startenergy:endenergy)Â ) |
---|
1161 |             surfinswref_av = 0.0_wp |
---|
1162 | Â Â Â Â Â Â Â Â Â Â ENDIF |
---|
1163 | |
---|
1164 | Â Â Â Â Â Â Â Â CASEÂ (Â 'usm_rad_inlwdif'Â ) |
---|
1165 | !--Â Â Â Â Â Â Â Â Â array of sw radiation falling to surface after i-th reflection |
---|
1166 |           IF ( .NOT. ALLOCATED(surfinlwdif_av) ) THEN |
---|
1167 | Â Â Â Â Â Â Â Â Â Â Â Â ALLOCATE(Â surfinlwdif_av(startenergy:endenergy)Â ) |
---|
1168 |             surfinlwdif_av = 0.0_wp |
---|
1169 | Â Â Â Â Â Â Â Â Â Â ENDIF |
---|
1170 | |
---|
1171 | Â Â Â Â Â Â Â Â CASEÂ (Â 'usm_rad_inlwref'Â ) |
---|
1172 | !--Â Â Â Â Â Â Â Â Â array of lw radiation falling to surface from reflections |
---|
1173 |           IF ( .NOT. ALLOCATED(surfinlwref_av) ) THEN |
---|
1174 | Â Â Â Â Â Â Â Â Â Â Â Â ALLOCATE(Â surfinlwref_av(startenergy:endenergy)Â ) |
---|
1175 |             surfinlwref_av = 0.0_wp |
---|
1176 | Â Â Â Â Â Â Â Â Â Â ENDIF |
---|
1177 | |
---|
1178 | Â Â Â Â Â Â Â Â CASEÂ (Â 'usm_rad_outsw'Â ) |
---|
1179 | !--Â Â Â Â Â Â Â Â Â array of sw radiation emitted from surface after i-th reflection |
---|
1180 |           IF ( .NOT. ALLOCATED(surfoutsw_av) ) THEN |
---|
1181 | Â Â Â Â Â Â Â Â Â Â Â Â ALLOCATE(Â surfoutsw_av(startenergy:endenergy)Â ) |
---|
1182 |             surfoutsw_av = 0.0_wp |
---|
1183 | Â Â Â Â Â Â Â Â Â Â ENDIF |
---|
1184 | |
---|
1185 | Â Â Â Â Â Â Â Â CASEÂ (Â 'usm_rad_outlw'Â ) |
---|
1186 | !--Â Â Â Â Â Â Â Â Â array of lw radiation emitted from surface after i-th reflection |
---|
1187 |           IF ( .NOT. ALLOCATED(surfoutlw_av) ) THEN |
---|
1188 | Â Â Â Â Â Â Â Â Â Â Â Â ALLOCATE(Â surfoutlw_av(startenergy:endenergy)Â ) |
---|
1189 |             surfoutlw_av = 0.0_wp |
---|
1190 | Â Â Â Â Â Â Â Â Â Â ENDIF |
---|
1191 | Â Â Â Â Â Â Â Â CASEÂ (Â 'usm_rad_ressw'Â ) |
---|
1192 | !--Â Â Â Â Â Â Â Â Â array of residua of sw radiation absorbed in surface after last reflection |
---|
1193 |           IF ( .NOT. ALLOCATED(surfins_av) ) THEN |
---|
1194 | Â Â Â Â Â Â Â Â Â Â Â Â ALLOCATE(Â surfins_av(startenergy:endenergy)Â ) |
---|
1195 |             surfins_av = 0.0_wp |
---|
1196 | Â Â Â Â Â Â Â Â Â Â ENDIF |
---|
1197 | Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â |
---|
1198 | Â Â Â Â Â Â Â Â CASEÂ (Â 'usm_rad_reslw'Â ) |
---|
1199 | !--Â Â Â Â Â Â Â Â Â array of residua of lw radiation absorbed in surface after last reflection |
---|
1200 |           IF ( .NOT. ALLOCATED(surfinl_av) ) THEN |
---|
1201 | Â Â Â Â Â Â Â Â Â Â Â Â ALLOCATE(Â surfinl_av(startenergy:endenergy)Â ) |
---|
1202 |             surfinl_av = 0.0_wp |
---|
1203 | Â Â Â Â Â Â Â Â Â Â ENDIF |
---|
1204 | Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â |
---|
1205 | Â Â Â Â Â Â Â Â CASEÂ (Â 'usm_rad_hf'Â ) |
---|
1206 | !--Â Â Â Â Â Â Â Â Â array of heat flux from radiation for surfaces after i-th reflection |
---|
1207 |           IF ( .NOT. ALLOCATED(surf_usm_h%surfhf_av) ) THEN |
---|
1208 | Â Â Â Â Â Â Â Â Â Â Â Â ALLOCATE(Â surf_usm_h%surfhf_av(1:surf_usm_h%ns)Â ) |
---|
1209 |             surf_usm_h%surfhf_av = 0.0_wp |
---|
1210 | Â Â Â Â Â Â Â Â Â Â ENDIF |
---|
1211 |           DO l = 0, 3 |
---|
1212 |             IF ( .NOT. ALLOCATED(surf_usm_v(l)%surfhf_av) ) THEN |
---|
1213 | Â Â Â Â Â Â Â Â Â Â Â Â Â Â ALLOCATE(Â surf_usm_v(l)%surfhf_av(1:surf_usm_v(l)%ns)Â ) |
---|
1214 |               surf_usm_v(l)%surfhf_av = 0.0_wp |
---|
1215 | Â Â Â Â Â Â Â Â Â Â Â Â ENDIF |
---|
1216 | Â Â Â Â Â Â Â Â Â Â ENDDO |
---|
1217 | |
---|
1218 | Â Â Â Â Â Â Â Â CASEÂ (Â 'usm_wshf'Â ) |
---|
1219 | !--Â Â Â Â Â Â Â Â Â array of sensible heat flux from surfaces |
---|
1220 | !--Â Â Â Â Â Â Â Â Â land surfaces |
---|
1221 |           IF ( .NOT. ALLOCATED(surf_usm_h%wshf_eb_av) ) THEN |
---|
1222 | Â Â Â Â Â Â Â Â Â Â Â Â ALLOCATE(Â surf_usm_h%wshf_eb_av(1:surf_usm_h%ns)Â ) |
---|
1223 |             surf_usm_h%wshf_eb_av = 0.0_wp |
---|
1224 | Â Â Â Â Â Â Â Â Â Â ENDIF |
---|
1225 |           DO l = 0, 3 |
---|
1226 |             IF ( .NOT. ALLOCATED(surf_usm_v(l)%wshf_eb_av) ) THEN |
---|
1227 | Â Â Â Â Â Â Â Â Â Â Â Â Â Â ALLOCATE(Â surf_usm_v(l)%wshf_eb_av(1:surf_usm_v(l)%ns)Â ) |
---|
1228 |               surf_usm_v(l)%wshf_eb_av = 0.0_wp |
---|
1229 | Â Â Â Â Â Â Â Â Â Â Â Â ENDIF |
---|
1230 | Â Â Â Â Â Â Â Â Â Â ENDDO |
---|
1231 | |
---|
1232 | Â Â Â Â Â Â Â Â CASEÂ (Â 'usm_wghf'Â ) |
---|
1233 | !--Â Â Â Â Â Â Â Â Â array of heat flux from ground (wall, roof, land) |
---|
1234 |           IF ( .NOT. ALLOCATED(surf_usm_h%wghf_eb_av) ) THEN |
---|
1235 | Â Â Â Â Â Â Â Â Â Â Â Â ALLOCATE(Â surf_usm_h%wghf_eb_av(1:surf_usm_h%ns)Â ) |
---|
1236 |             surf_usm_h%wghf_eb_av = 0.0_wp |
---|
1237 | Â Â Â Â Â Â Â Â Â Â ENDIF |
---|
1238 |           DO l = 0, 3 |
---|
1239 |             IF ( .NOT. ALLOCATED(surf_usm_v(l)%wghf_eb_av) ) THEN |
---|
1240 | Â Â Â Â Â Â Â Â Â Â Â Â Â Â ALLOCATE(Â surf_usm_v(l)%wghf_eb_av(1:surf_usm_v(l)%ns)Â ) |
---|
1241 |               surf_usm_v(l)%wghf_eb_av = 0.0_wp |
---|
1242 | Â Â Â Â Â Â Â Â Â Â Â Â ENDIF |
---|
1243 | Â Â Â Â Â Â Â Â Â Â ENDDO |
---|
1244 | |
---|
1245 | Â Â Â Â Â Â Â Â CASEÂ (Â 'usm_t_surf'Â ) |
---|
1246 | !--Â Â Â Â Â Â Â Â Â surface temperature for surfaces |
---|
1247 |           IF ( .NOT. ALLOCATED(surf_usm_h%t_surf_av) ) THEN |
---|
1248 | Â Â Â Â Â Â Â Â Â Â Â Â ALLOCATE(Â surf_usm_h%t_surf_av(1:surf_usm_h%ns)Â ) |
---|
1249 |             surf_usm_h%t_surf_av = 0.0_wp |
---|
1250 | Â Â Â Â Â Â Â Â Â Â ENDIF |
---|
1251 |           DO l = 0, 3 |
---|
1252 |             IF ( .NOT. ALLOCATED(surf_usm_v(l)%t_surf_av) ) THEN |
---|
1253 | Â Â Â Â Â Â Â Â Â Â Â Â Â Â ALLOCATE(Â surf_usm_v(l)%t_surf_av(1:surf_usm_v(l)%ns)Â ) |
---|
1254 |               surf_usm_v(l)%t_surf_av = 0.0_wp |
---|
1255 | Â Â Â Â Â Â Â Â Â Â Â Â ENDIF |
---|
1256 | Â Â Â Â Â Â Â Â Â Â ENDDO |
---|
1257 | |
---|
1258 | Â Â Â Â Â Â Â Â CASEÂ (Â 'usm_t_wall'Â ) |
---|
1259 | !--Â Â Â Â Â Â Â Â Â wall temperature for iwl layer of walls and land |
---|
1260 |           IF ( .NOT. ALLOCATED(surf_usm_h%t_wall_av) ) THEN |
---|
1261 | Â Â Â Â Â Â Â Â Â Â Â Â ALLOCATE(Â surf_usm_h%t_wall_av(nzb_wall:nzt_wall,1:surf_usm_h%ns)Â ) |
---|
1262 |             surf_usm_h%t_wall_av = 0.0_wp |
---|
1263 | Â Â Â Â Â Â Â Â Â Â ENDIF |
---|
1264 |           DO l = 0, 3 |
---|
1265 |             IF ( .NOT. ALLOCATED(surf_usm_v(l)%t_wall_av) ) THEN |
---|
1266 | Â Â Â Â Â Â Â Â Â Â Â Â Â Â ALLOCATE(Â surf_usm_v(l)%t_wall_av(nzb_wall:nzt_wall,1:surf_usm_v(l)%ns)Â ) |
---|
1267 |               surf_usm_v(l)%t_wall_av = 0.0_wp |
---|
1268 | Â Â Â Â Â Â Â Â Â Â Â Â ENDIF |
---|
1269 | Â Â Â Â Â Â Â Â Â Â ENDDO |
---|
1270 | |
---|
1271 | Â Â Â Â Â Â Â Â CASE DEFAULT |
---|
1272 | Â Â Â Â Â Â Â Â Â Â CONTINUE |
---|
1273 | |
---|
1274 | Â Â Â Â Â Â END SELECT |
---|
1275 | |
---|
1276 |     ELSEIF ( mode == 'sum' ) THEN |
---|
1277 | Â Â Â Â Â Â |
---|
1278 |       SELECT CASE ( TRIM( var ) ) |
---|
1279 | Â Â Â Â Â Â Â Â |
---|
1280 | Â Â Â Â Â Â Â Â CASEÂ (Â 'usm_rad_net'Â ) |
---|
1281 | !--Â Â Â Â Â Â Â Â Â array of complete radiation balance |
---|
1282 |           DO m = 1, surf_usm_h%ns |
---|
1283 | Â Â Â Â Â Â Â Â Â Â Â Â surf_usm_h%rad_net_av(m)Â =Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â & |
---|
1284 | Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â surf_usm_h%rad_net_av(m)Â +Â Â Â Â Â Â & |
---|
1285 | Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â surf_usm_h%rad_net_l(m) |
---|
1286 | Â Â Â Â Â Â Â Â Â Â ENDDO |
---|
1287 |           DO l = 0, 3 |
---|
1288 |             DO m = 1, surf_usm_v(l)%ns |
---|
1289 | Â Â Â Â Â Â Â Â Â Â Â Â Â surf_usm_v(l)%rad_net_av(m)Â =Â Â Â Â Â Â Â Â Â Â Â Â & |
---|
1290 | Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â surf_usm_v(l)%rad_net_av(m)Â +Â Â Â Â & |
---|
1291 | Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â surf_usm_v(l)%rad_net_l(m) |
---|
1292 | Â Â Â Â Â Â Â Â Â Â Â Â ENDDO |
---|
1293 | Â Â Â Â Â Â Â Â Â Â ENDDO |
---|
1294 | Â Â Â Â Â Â Â Â Â Â |
---|
1295 | Â Â Â Â Â Â Â Â CASEÂ (Â 'usm_rad_insw'Â ) |
---|
1296 | !--Â Â Â Â Â Â Â Â Â array of sw radiation falling to surface after i-th reflection |
---|
1297 |           DO l = startenergy, endenergy |
---|
1298 |             IF ( surfl(id,l) == ids ) THEN |
---|
1299 | Â Â Â Â Â Â Â Â Â Â Â Â Â Â surfinsw_av(l)Â =Â surfinsw_av(l)Â +Â surfinsw(l) |
---|
1300 | Â Â Â Â Â Â Â Â Â Â Â Â ENDIF |
---|
1301 | Â Â Â Â Â Â Â Â Â Â ENDDO |
---|
1302 | Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â |
---|
1303 | Â Â Â Â Â Â Â Â CASEÂ (Â 'usm_rad_inlw'Â ) |
---|
1304 | !--Â Â Â Â Â Â Â Â Â array of lw radiation falling to surface after i-th reflection |
---|
1305 |           DO l = startenergy, endenergy |
---|
1306 |             IF ( surfl(id,l) == ids ) THEN |
---|
1307 | Â Â Â Â Â Â Â Â Â Â Â Â Â Â surfinlw_av(l)Â =Â surfinlw_av(l)Â +Â surfinlw(l) |
---|
1308 | Â Â Â Â Â Â Â Â Â Â Â Â ENDIF |
---|
1309 | Â Â Â Â Â Â Â Â Â Â ENDDO |
---|
1310 | Â Â Â Â Â Â Â Â Â Â |
---|
1311 | Â Â Â Â Â Â Â Â CASEÂ (Â 'usm_rad_inswdir'Â ) |
---|
1312 | !--Â Â Â Â Â Â Â Â Â array of direct sw radiation falling to surface from sun |
---|
1313 |           DO l = startenergy, endenergy |
---|
1314 |             IF ( surfl(id,l) == ids ) THEN |
---|
1315 | Â Â Â Â Â Â Â Â Â Â Â Â Â Â surfinswdir_av(l)Â =Â surfinswdir_av(l)Â +Â surfinswdir(l) |
---|
1316 | Â Â Â Â Â Â Â Â Â Â Â Â ENDIF |
---|
1317 | Â Â Â Â Â Â Â Â Â Â ENDDO |
---|
1318 | Â Â Â Â Â Â Â Â Â Â |
---|
1319 | Â Â Â Â Â Â Â Â CASEÂ (Â 'usm_rad_inswdif'Â ) |
---|
1320 | !--Â Â Â Â Â Â Â Â Â array of difusion sw radiation falling to surface from sky and borders of the domain |
---|
1321 |           DO l = startenergy, endenergy |
---|
1322 |             IF ( surfl(id,l) == ids ) THEN |
---|
1323 | Â Â Â Â Â Â Â Â Â Â Â Â Â Â surfinswdif_av(l)Â =Â surfinswdif_av(l)Â +Â surfinswdif(l) |
---|
1324 | Â Â Â Â Â Â Â Â Â Â Â Â ENDIF |
---|
1325 | Â Â Â Â Â Â Â Â Â Â ENDDO |
---|
1326 | Â Â Â Â Â Â Â Â Â Â |
---|
1327 | Â Â Â Â Â Â Â Â CASEÂ (Â 'usm_rad_inswref'Â ) |
---|
1328 | !--Â Â Â Â Â Â Â Â Â array of sw radiation falling to surface from reflections |
---|
1329 |           DO l = startenergy, endenergy |
---|
1330 |             IF ( surfl(id,l) == ids ) THEN |
---|
1331 | Â Â Â Â Â Â Â Â Â Â Â Â Â Â surfinswref_av(l)Â =Â surfinswref_av(l)Â +Â surfinsw(l)Â -Â & |
---|
1332 | Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â surfinswdir(l)Â -Â surfinswdif(l) |
---|
1333 | Â Â Â Â Â Â Â Â Â Â Â Â ENDIF |
---|
1334 | Â Â Â Â Â Â Â Â Â Â ENDDO |
---|
1335 | |
---|
1336 | Â Â Â Â Â Â Â Â Â Â |
---|
1337 | Â Â Â Â Â Â Â Â CASEÂ (Â 'usm_rad_inlwdif'Â ) |
---|
1338 | !--Â Â Â Â Â Â Â Â Â array of sw radiation falling to surface after i-th reflection |
---|
1339 |           DO l = startenergy, endenergy |
---|
1340 |             IF ( surfl(id,l) == ids ) THEN |
---|
1341 | Â Â Â Â Â Â Â Â Â Â Â Â Â Â surfinswref_av(l)Â =Â surfinswref_av(l)Â +Â surfinsw(l)Â -Â & |
---|
1342 | Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â surfinswdir(l)Â -Â surfinswdif(l) |
---|
1343 | Â Â Â Â Â Â Â Â Â Â Â Â ENDIF |
---|
1344 | Â Â Â Â Â Â Â Â Â Â ENDDO |
---|
1345 | !           |
---|
1346 | Â Â Â Â Â Â Â Â CASEÂ (Â 'usm_rad_inlwref'Â ) |
---|
1347 | !--Â Â Â Â Â Â Â Â Â array of lw radiation falling to surface from reflections |
---|
1348 |           DO l = startenergy, endenergy |
---|
1349 |             IF ( surfl(id,l) == ids ) THEN |
---|
1350 | Â Â Â Â Â Â Â Â Â Â Â Â Â Â surfinlwdif_av(l)Â =Â surfinlwdif_av(l)Â +Â surfinlwdif(l) |
---|
1351 | Â Â Â Â Â Â Â Â Â Â Â Â ENDIF |
---|
1352 | Â Â Â Â Â Â Â Â Â Â ENDDO |
---|
1353 | Â Â Â Â Â Â Â Â Â Â |
---|
1354 | Â Â Â Â Â Â Â Â CASEÂ (Â 'usm_rad_outsw'Â ) |
---|
1355 | !--Â Â Â Â Â Â Â Â Â array of sw radiation emitted from surface after i-th reflection |
---|
1356 |           DO l = startenergy, endenergy |
---|
1357 |             IF ( surfl(id,l) == ids ) THEN |
---|
1358 | Â Â Â Â Â Â Â Â Â Â Â Â Â Â surfinlwref_av(l)Â =Â surfinlwref_av(l)Â +Â & |
---|
1359 | Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â surfinlw(l)Â -Â surfinlwdif(l) |
---|
1360 | Â Â Â Â Â Â Â Â Â Â Â Â ENDIF |
---|
1361 | Â Â Â Â Â Â Â Â Â Â ENDDO |
---|
1362 | Â Â Â Â Â Â Â Â Â Â |
---|
1363 | Â Â Â Â Â Â Â Â CASEÂ (Â 'usm_rad_outlw'Â ) |
---|
1364 | !--Â Â Â Â Â Â Â Â Â array of lw radiation emitted from surface after i-th reflection |
---|
1365 |           DO l = startenergy, endenergy |
---|
1366 |             IF ( surfl(id,l) == ids ) THEN |
---|
1367 | Â Â Â Â Â Â Â Â Â Â Â Â Â Â surfoutsw_av(l)Â =Â surfoutsw_av(l)Â +Â surfoutsw(l) |
---|
1368 | Â Â Â Â Â Â Â Â Â Â Â Â ENDIF |
---|
1369 | Â Â Â Â Â Â Â Â Â Â ENDDO |
---|
1370 | Â Â Â Â Â Â Â Â Â Â |
---|
1371 | Â Â Â Â Â Â Â Â CASEÂ (Â 'usm_rad_ressw'Â ) |
---|
1372 | !--Â Â Â Â Â Â Â Â Â array of residua of sw radiation absorbed in surface after last reflection |
---|
1373 |           DO l = startenergy, endenergy |
---|
1374 |             IF ( surfl(id,l) == ids ) THEN |
---|
1375 | Â Â Â Â Â Â Â Â Â Â Â Â Â Â surfoutlw_av(l)Â =Â surfoutlw_av(l)Â +Â surfoutlw(l) |
---|
1376 | Â Â Â Â Â Â Â Â Â Â Â Â ENDIF |
---|
1377 | Â Â Â Â Â Â Â Â Â Â ENDDO |
---|
1378 | Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â |
---|
1379 | Â Â Â Â Â Â Â Â CASEÂ (Â 'usm_rad_reslw'Â ) |
---|
1380 | !--Â Â Â Â Â Â Â Â Â array of residua of lw radiation absorbed in surface after last reflection |
---|
1381 |           DO l = startenergy, endenergy |
---|
1382 |             IF ( surfl(id,l) == ids ) THEN |
---|
1383 | Â Â Â Â Â Â Â Â Â Â Â Â Â Â surfins_av(l)Â =Â surfins_av(l)Â +Â surfins(l) |
---|
1384 | Â Â Â Â Â Â Â Â Â Â Â Â ENDIF |
---|
1385 | Â Â Â Â Â Â Â Â Â Â ENDDO |
---|
1386 | Â Â Â Â Â Â Â Â Â Â |
---|
1387 | Â Â Â Â Â Â Â Â CASEÂ (Â 'usm_rad_hf'Â ) |
---|
1388 | !--Â Â Â Â Â Â Â Â Â array of heat flux from radiation for surfaces after i-th reflection |
---|
1389 |           DO m = 1, surf_usm_h%ns |
---|
1390 | Â Â Â Â Â Â Â Â Â Â Â Â surf_usm_h%surfhf_av(m)Â =Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â & |
---|
1391 | Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â surf_usm_h%surfhf_av(m)Â +Â Â Â Â Â Â & |
---|
1392 | Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â surf_usm_h%surfhf(m) |
---|
1393 | Â Â Â Â Â Â Â Â Â Â ENDDO |
---|
1394 |           DO l = 0, 3 |
---|
1395 |             DO m = 1, surf_usm_v(l)%ns |
---|
1396 | Â Â Â Â Â Â Â Â Â Â Â Â Â surf_usm_v(l)%surfhf_av(m)Â =Â Â Â Â Â Â Â Â Â Â Â Â Â & |
---|
1397 | Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â surf_usm_v(l)%surfhf_av(m)Â +Â Â Â Â Â & |
---|
1398 | Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â surf_usm_v(l)%surfhf(m) |
---|
1399 | Â Â Â Â Â Â Â Â Â Â Â Â ENDDO |
---|
1400 | Â Â Â Â Â Â Â Â Â Â ENDDO |
---|
1401 | Â Â Â Â Â Â Â Â Â Â |
---|
1402 | Â Â Â Â Â Â Â Â CASEÂ (Â 'usm_wshf'Â ) |
---|
1403 | !--Â Â Â Â Â Â Â Â Â array of sensible heat flux from surfaces (land, roof, wall) |
---|
1404 |           DO m = 1, surf_usm_h%ns |
---|
1405 | Â Â Â Â Â Â Â Â Â Â Â Â surf_usm_h%wshf_eb_av(m)Â =Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â & |
---|
1406 | Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â surf_usm_h%wshf_eb_av(m)Â +Â Â Â Â Â Â & |
---|
1407 | Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â surf_usm_h%wshf_eb(m) |
---|
1408 | Â Â Â Â Â Â Â Â Â Â ENDDO |
---|
1409 |           DO l = 0, 3 |
---|
1410 |             DO m = 1, surf_usm_v(l)%ns |
---|
1411 | Â Â Â Â Â Â Â Â Â Â Â Â Â surf_usm_v(l)%wshf_eb_av(m)Â =Â Â Â Â Â Â Â Â Â Â Â Â & |
---|
1412 | Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â surf_usm_v(l)%wshf_eb_av(m)Â +Â Â Â Â & |
---|
1413 | Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â surf_usm_v(l)%wshf_eb(m) |
---|
1414 | Â Â Â Â Â Â Â Â Â Â Â Â ENDDO |
---|
1415 | Â Â Â Â Â Â Â Â Â Â ENDDO |
---|
1416 | Â Â Â Â Â Â Â Â Â Â |
---|
1417 | Â Â Â Â Â Â Â Â CASEÂ (Â 'usm_wghf'Â ) |
---|
1418 | !--Â Â Â Â Â Â Â Â Â array of heat flux from ground (wall, roof, land) |
---|
1419 |           DO m = 1, surf_usm_h%ns |
---|
1420 | Â Â Â Â Â Â Â Â Â Â Â Â surf_usm_h%wghf_eb_av(m)Â =Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â & |
---|
1421 | Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â surf_usm_h%wghf_eb_av(m)Â +Â Â Â Â Â Â & |
---|
1422 | Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â surf_usm_h%wghf_eb(m) |
---|
1423 | Â Â Â Â Â Â Â Â Â Â ENDDO |
---|
1424 |           DO l = 0, 3 |
---|
1425 |             DO m = 1, surf_usm_v(l)%ns |
---|
1426 | Â Â Â Â Â Â Â Â Â Â Â Â Â surf_usm_v(l)%wghf_eb_av(m)Â =Â Â Â Â Â Â Â Â Â Â Â Â & |
---|
1427 | Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â surf_usm_v(l)%wghf_eb_av(m)Â +Â Â Â Â & |
---|
1428 | Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â surf_usm_v(l)%wghf_eb(m) |
---|
1429 | Â Â Â Â Â Â Â Â Â Â Â Â ENDDO |
---|
1430 | Â Â Â Â Â Â Â Â Â Â ENDDO |
---|
1431 | Â Â Â Â Â Â Â Â Â Â |
---|
1432 | Â Â Â Â Â Â Â Â CASEÂ (Â 'usm_t_surf'Â ) |
---|
1433 | !--Â Â Â Â Â Â Â Â Â surface temperature for surfaces |
---|
1434 |           DO m = 1, surf_usm_h%ns |
---|
1435 | Â Â Â Â Â Â Â Â Â Â Â Â surf_usm_h%t_surf_av(m)Â =Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â &Â |
---|
1436 | Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â surf_usm_h%t_surf_av(m)Â +Â Â Â Â Â Â & |
---|
1437 | Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â t_surf_h(m) |
---|
1438 | Â Â Â Â Â Â Â Â Â Â ENDDO |
---|
1439 |           DO l = 0, 3 |
---|
1440 |             DO m = 1, surf_usm_v(l)%ns |
---|
1441 | Â Â Â Â Â Â Â Â Â Â Â Â Â surf_usm_v(l)%t_surf_av(m)Â =Â Â Â Â Â Â Â Â Â Â Â Â Â & |
---|
1442 | Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â surf_usm_v(l)%t_surf_av(m)Â +Â Â Â Â Â & |
---|
1443 | Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â t_surf_v(l)%t(m) |
---|
1444 | Â Â Â Â Â Â Â Â Â Â Â Â ENDDO |
---|
1445 | Â Â Â Â Â Â Â Â Â Â ENDDO |
---|
1446 | Â Â Â Â Â Â Â Â Â Â |
---|
1447 | Â Â Â Â Â Â Â Â CASEÂ (Â 'usm_t_wall'Â ) |
---|
1448 | !--         wall temperature for iwl layer of walls and land |
---|
1449 |           DO m = 1, surf_usm_h%ns |
---|
1450 | Â Â Â Â Â Â Â Â Â Â Â Â surf_usm_h%t_wall_av(iwl,m)Â =Â Â Â Â Â Â Â Â Â Â Â Â Â Â & |
---|
1451 | Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â surf_usm_h%t_wall_av(iwl,m)Â +Â Â Â Â & |
---|
1452 | Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â t_wall_h(iwl,m) |
---|
1453 | Â Â Â Â Â Â Â Â Â Â ENDDO |
---|
1454 |           DO l = 0, 3 |
---|
1455 |             DO m = 1, surf_usm_v(l)%ns |
---|
1456 | Â Â Â Â Â Â Â Â Â Â Â Â Â surf_usm_v(l)%t_wall_av(iwl,m)Â =Â Â Â Â Â Â Â Â Â Â Â & |
---|
1457 | Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â surf_usm_v(l)%t_wall_av(iwl,m)Â +Â Â Â & |
---|
1458 | Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â t_wall_v(l)%t(iwl,m) |
---|
1459 | Â Â Â Â Â Â Â Â Â Â Â Â ENDDO |
---|
1460 | Â Â Â Â Â Â Â Â Â Â ENDDO |
---|
1461 | Â Â Â Â Â Â Â Â Â Â |
---|
1462 | Â Â Â Â Â Â Â Â CASE DEFAULT |
---|
1463 | Â Â Â Â Â Â Â Â Â Â CONTINUE |
---|
1464 | |
---|
1465 | Â Â Â Â Â Â END SELECT |
---|
1466 | |
---|
1467 |     ELSEIF ( mode == 'average' ) THEN |
---|
1468 | Â Â Â Â Â Â |
---|
1469 |       SELECT CASE ( TRIM( var ) ) |
---|
1470 | Â Â Â Â Â Â Â Â |
---|
1471 | Â Â Â Â Â Â Â Â CASEÂ (Â 'usm_rad_net'Â ) |
---|
1472 | !--Â Â Â Â Â Â Â Â Â array of complete radiation balance |
---|
1473 |           DO m = 1, surf_usm_h%ns |
---|
1474 | Â Â Â Â Â Â Â Â Â Â Â Â surf_usm_h%rad_net_av(m)Â =Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â & |
---|
1475 | Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â surf_usm_h%rad_net_av(m)Â /Â Â Â Â Â Â & |
---|
1476 |                      REAL( average_count_3d, kind=wp ) |
---|
1477 | Â Â Â Â Â Â Â Â Â Â ENDDO |
---|
1478 |           DO l = 0, 3 |
---|
1479 |             DO m = 1, surf_usm_v(l)%ns |
---|
1480 | Â Â Â Â Â Â Â Â Â Â Â Â Â surf_usm_v(l)%rad_net_av(m)Â =Â Â Â Â Â Â Â Â Â Â Â Â & |
---|
1481 | Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â surf_usm_v(l)%rad_net_av(m)Â /Â Â Â Â & |
---|
1482 |                      REAL( average_count_3d, kind=wp ) |
---|
1483 | Â Â Â Â Â Â Â Â Â Â Â Â ENDDO |
---|
1484 | Â Â Â Â Â Â Â Â Â Â ENDDO |
---|
1485 | Â Â Â Â Â Â Â Â Â Â |
---|
1486 | Â Â Â Â Â Â Â Â CASEÂ (Â 'usm_rad_insw'Â ) |
---|
1487 | !--Â Â Â Â Â Â Â Â Â array of sw radiation falling to surface after i-th reflection |
---|
1488 |           DO l = startenergy, endenergy |
---|
1489 |             IF ( surfl(id,l) == ids ) THEN |
---|
1490 |               surfinsw_av(l) = surfinsw_av(l) / REAL( average_count_3d, kind=wp ) |
---|
1491 | Â Â Â Â Â Â Â Â Â Â Â Â ENDIF |
---|
1492 | Â Â Â Â Â Â Â Â Â Â ENDDO |
---|
1493 | Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â |
---|
1494 | Â Â Â Â Â Â Â Â CASEÂ (Â 'usm_rad_inlw'Â ) |
---|
1495 | !--Â Â Â Â Â Â Â Â Â array of lw radiation falling to surface after i-th reflection |
---|
1496 |           DO l = startenergy, endenergy |
---|
1497 |             IF ( surfl(id,l) == ids ) THEN |
---|
1498 |               surfinlw_av(l) = surfinlw_av(l) / REAL( average_count_3d, kind=wp ) |
---|
1499 | Â Â Â Â Â Â Â Â Â Â Â Â ENDIF |
---|
1500 | Â Â Â Â Â Â Â Â Â Â ENDDO |
---|
1501 | Â Â Â Â Â Â Â Â Â Â |
---|
1502 | Â Â Â Â Â Â Â Â CASEÂ (Â 'usm_rad_inswdir'Â ) |
---|
1503 | !--Â Â Â Â Â Â Â Â Â array of direct sw radiation falling to surface from sun |
---|
1504 |           DO l = startenergy, endenergy |
---|
1505 |             IF ( surfl(id,l) == ids ) THEN |
---|
1506 |               surfinswdir_av(l) = surfinswdir_av(l) / REAL( average_count_3d, kind=wp ) |
---|
1507 | Â Â Â Â Â Â Â Â Â Â Â Â ENDIF |
---|
1508 | Â Â Â Â Â Â Â Â Â Â ENDDO |
---|
1509 | Â Â Â Â Â Â Â Â Â Â |
---|
1510 | Â Â Â Â Â Â Â Â CASEÂ (Â 'usm_rad_inswdif'Â ) |
---|
1511 | !--Â Â Â Â Â Â Â Â Â array of difusion sw radiation falling to surface from sky and borders of the domain |
---|
1512 |           DO l = startenergy, endenergy |
---|
1513 |             IF ( surfl(id,l) == ids ) THEN |
---|
1514 |               surfinswdif_av(l) = surfinswdif_av(l) / REAL( average_count_3d, kind=wp ) |
---|
1515 | Â Â Â Â Â Â Â Â Â Â Â Â ENDIF |
---|
1516 | Â Â Â Â Â Â Â Â Â Â ENDDO |
---|
1517 | Â Â Â Â Â Â Â Â Â Â |
---|
1518 | Â Â Â Â Â Â Â Â CASEÂ (Â 'usm_rad_inswref'Â ) |
---|
1519 | !--Â Â Â Â Â Â Â Â Â array of sw radiation falling to surface from reflections |
---|
1520 |           DO l = startenergy, endenergy |
---|
1521 |             IF ( surfl(id,l) == ids ) THEN |
---|
1522 |               surfinswref_av(l) = surfinswref_av(l) / REAL( average_count_3d, kind=wp ) |
---|
1523 | Â Â Â Â Â Â Â Â Â Â Â Â ENDIF |
---|
1524 | Â Â Â Â Â Â Â Â Â Â ENDDO |
---|
1525 | Â Â Â Â Â Â Â Â Â Â |
---|
1526 | Â Â Â Â Â Â Â Â CASEÂ (Â 'usm_rad_inlwdif'Â ) |
---|
1527 | !--Â Â Â Â Â Â Â Â Â array of sw radiation falling to surface after i-th reflection |
---|
1528 |           DO l = startenergy, endenergy |
---|
1529 |             IF ( surfl(id,l) == ids ) THEN |
---|
1530 |               surfinlwdif_av(l) = surfinlwdif_av(l) / REAL( average_count_3d, kind=wp ) |
---|
1531 | Â Â Â Â Â Â Â Â Â Â Â Â ENDIF |
---|
1532 | Â Â Â Â Â Â Â Â Â Â ENDDO |
---|
1533 | Â Â Â Â Â Â Â Â Â Â |
---|
1534 | Â Â Â Â Â Â Â Â CASEÂ (Â 'usm_rad_inlwref'Â ) |
---|
1535 | !--Â Â Â Â Â Â Â Â Â array of lw radiation falling to surface from reflections |
---|
1536 |           DO l = startenergy, endenergy |
---|
1537 |             IF ( surfl(id,l) == ids ) THEN |
---|
1538 |               surfinlwref_av(l) = surfinlwref_av(l) / REAL( average_count_3d, kind=wp ) |
---|
1539 | Â Â Â Â Â Â Â Â Â Â Â Â ENDIF |
---|
1540 | Â Â Â Â Â Â Â Â Â Â ENDDO |
---|
1541 | Â Â Â Â Â Â Â Â Â Â |
---|
1542 | Â Â Â Â Â Â Â Â CASEÂ (Â 'usm_rad_outsw'Â ) |
---|
1543 | !--Â Â Â Â Â Â Â Â Â array of sw radiation emitted from surface after i-th reflection |
---|
1544 |           DO l = startenergy, endenergy |
---|
1545 |             IF ( surfl(id,l) == ids ) THEN |
---|
1546 |               surfoutsw_av(l) = surfoutsw_av(l) / REAL( average_count_3d, kind=wp ) |
---|
1547 | Â Â Â Â Â Â Â Â Â Â Â Â ENDIF |
---|
1548 | Â Â Â Â Â Â Â Â Â Â ENDDO |
---|
1549 | Â Â Â Â Â Â Â Â Â Â |
---|
1550 | Â Â Â Â Â Â Â Â CASEÂ (Â 'usm_rad_outlw'Â ) |
---|
1551 | !--Â Â Â Â Â Â Â Â Â array of lw radiation emitted from surface after i-th reflection |
---|
1552 |           DO l = startenergy, endenergy |
---|
1553 |             IF ( surfl(id,l) == ids ) THEN |
---|
1554 |               surfoutlw_av(l) = surfoutlw_av(l) / REAL( average_count_3d, kind=wp ) |
---|
1555 | Â Â Â Â Â Â Â Â Â Â Â Â ENDIF |
---|
1556 | Â Â Â Â Â Â Â Â Â Â ENDDO |
---|
1557 | Â Â Â Â Â Â Â Â Â Â |
---|
1558 | Â Â Â Â Â Â Â Â CASEÂ (Â 'usm_rad_ressw'Â ) |
---|
1559 | !--Â Â Â Â Â Â Â Â Â array of residua of sw radiation absorbed in surface after last reflection |
---|
1560 |           DO l = startenergy, endenergy |
---|
1561 |             IF ( surfl(id,l) == ids ) THEN |
---|
1562 |               surfins_av(l) = surfins_av(l) / REAL( average_count_3d, kind=wp ) |
---|
1563 | Â Â Â Â Â Â Â Â Â Â Â Â ENDIF |
---|
1564 | Â Â Â Â Â Â Â Â Â Â ENDDO |
---|
1565 | Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â |
---|
1566 | Â Â Â Â Â Â Â Â CASEÂ (Â 'usm_rad_reslw'Â ) |
---|
1567 | !--Â Â Â Â Â Â Â Â Â array of residua of lw radiation absorbed in surface after last reflection |
---|
1568 |           DO l = startenergy, endenergy |
---|
1569 |             IF ( surfl(id,l) == ids ) THEN |
---|
1570 |               surfinl_av(l) = surfinl_av(l) / REAL( average_count_3d, kind=wp ) |
---|
1571 | Â Â Â Â Â Â Â Â Â Â Â Â ENDIF |
---|
1572 | Â Â Â Â Â Â Â Â Â Â ENDDO |
---|
1573 | Â Â Â Â Â Â Â Â Â Â |
---|
1574 | Â Â Â Â Â Â Â Â CASEÂ (Â 'usm_rad_hf'Â ) |
---|
1575 | !--Â Â Â Â Â Â Â Â Â array of heat flux from radiation for surfaces after i-th reflection |
---|
1576 |           DO m = 1, surf_usm_h%ns |
---|
1577 | Â Â Â Â Â Â Â Â Â Â Â Â surf_usm_h%surfhf_av(m)Â =Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â & |
---|
1578 | Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â surf_usm_h%surfhf_av(m)Â /Â Â Â Â Â Â & |
---|
1579 |                      REAL( average_count_3d, kind=wp ) |
---|
1580 | Â Â Â Â Â Â Â Â Â Â ENDDO |
---|
1581 |           DO l = 0, 3 |
---|
1582 |             DO m = 1, surf_usm_v(l)%ns |
---|
1583 | Â Â Â Â Â Â Â Â Â Â Â Â Â surf_usm_v(l)%surfhf_av(m)Â =Â Â Â Â Â Â Â Â Â Â Â Â Â & |
---|
1584 | Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â surf_usm_v(l)%surfhf_av(m)Â /Â Â Â Â Â & |
---|
1585 |                      REAL( average_count_3d, kind=wp ) |
---|
1586 | Â Â Â Â Â Â Â Â Â Â Â Â ENDDO |
---|
1587 | Â Â Â Â Â Â Â Â Â Â ENDDO |
---|
1588 | Â Â Â Â Â Â Â Â Â Â |
---|
1589 | Â Â Â Â Â Â Â Â CASEÂ (Â 'usm_wshf'Â ) |
---|
1590 | !--Â Â Â Â Â Â Â Â Â array of sensible heat flux from surfaces (land, roof, wall) |
---|
1591 |           DO m = 1, surf_usm_h%ns |
---|
1592 | Â Â Â Â Â Â Â Â Â Â Â Â surf_usm_h%wshf_eb_av(m)Â =Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â & |
---|
1593 | Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â surf_usm_h%wshf_eb_av(m)Â /Â Â Â Â Â Â & |
---|
1594 |                      REAL( average_count_3d, kind=wp ) |
---|
1595 | Â Â Â Â Â Â Â Â Â Â ENDDO |
---|
1596 |           DO l = 0, 3 |
---|
1597 |             DO m = 1, surf_usm_v(l)%ns |
---|
1598 | Â Â Â Â Â Â Â Â Â Â Â Â Â surf_usm_v(l)%wshf_eb_av(m)Â =Â Â Â Â Â Â Â Â Â Â Â Â & |
---|
1599 | Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â surf_usm_v(l)%wshf_eb_av(m)Â /Â Â Â Â & |
---|
1600 |                      REAL( average_count_3d, kind=wp ) |
---|
1601 | Â Â Â Â Â Â Â Â Â Â Â Â ENDDO |
---|
1602 | Â Â Â Â Â Â Â Â Â Â ENDDO |
---|
1603 | Â Â Â Â Â Â Â Â Â Â |
---|
1604 | Â Â Â Â Â Â Â Â CASEÂ (Â 'usm_wghf'Â ) |
---|
1605 | !--Â Â Â Â Â Â Â Â Â array of heat flux from ground (wall, roof, land) |
---|
1606 |           DO m = 1, surf_usm_h%ns |
---|
1607 | Â Â Â Â Â Â Â Â Â Â Â Â surf_usm_h%wghf_eb_av(m)Â =Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â & |
---|
1608 | Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â surf_usm_h%wghf_eb_av(m)Â /Â Â Â Â Â Â & |
---|
1609 |                      REAL( average_count_3d, kind=wp ) |
---|
1610 | Â Â Â Â Â Â Â Â Â Â ENDDO |
---|
1611 |           DO l = 0, 3 |
---|
1612 |             DO m = 1, surf_usm_v(l)%ns |
---|
1613 | Â Â Â Â Â Â Â Â Â Â Â Â Â surf_usm_v(l)%wghf_eb_av(m)Â =Â Â Â Â Â Â Â Â Â Â Â Â & |
---|
1614 | Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â surf_usm_v(l)%wghf_eb_av(m)Â /Â Â Â Â & |
---|
1615 |                      REAL( average_count_3d, kind=wp ) |
---|
1616 | Â Â Â Â Â Â Â Â Â Â Â Â ENDDO |
---|
1617 | Â Â Â Â Â Â Â Â Â Â ENDDO |
---|
1618 | Â Â Â Â Â Â Â Â Â Â |
---|
1619 | Â Â Â Â Â Â Â Â CASEÂ (Â 'usm_t_surf'Â ) |
---|
1620 | !--Â Â Â Â Â Â Â Â Â surface temperature for surfaces |
---|
1621 |           DO m = 1, surf_usm_h%ns |
---|
1622 | Â Â Â Â Â Â Â Â Â Â Â Â surf_usm_h%t_surf_av(m)Â =Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â &Â |
---|
1623 | Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â surf_usm_h%t_surf_av(m)Â /Â Â Â Â Â Â & |
---|
1624 |                      REAL( average_count_3d, kind=wp ) |
---|
1625 | Â Â Â Â Â Â Â Â Â Â ENDDO |
---|
1626 |           DO l = 0, 3 |
---|
1627 |             DO m = 1, surf_usm_v(l)%ns |
---|
1628 | Â Â Â Â Â Â Â Â Â Â Â Â Â surf_usm_v(l)%t_surf_av(m)Â =Â Â Â Â Â Â Â Â Â Â Â Â Â & |
---|
1629 | Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â surf_usm_v(l)%t_surf_av(m)Â /Â Â Â Â Â & |
---|
1630 |                      REAL( average_count_3d, kind=wp ) |
---|
1631 | Â Â Â Â Â Â Â Â Â Â Â Â ENDDO |
---|
1632 | Â Â Â Â Â Â Â Â Â Â ENDDO |
---|
1633 | Â Â Â Â Â Â Â Â Â Â |
---|
1634 | Â Â Â Â Â Â Â Â CASEÂ (Â 'usm_t_wall'Â ) |
---|
1635 | !--         wall temperature for iwl layer of walls and land |
---|
1636 |           DO m = 1, surf_usm_h%ns |
---|
1637 | Â Â Â Â Â Â Â Â Â Â Â Â surf_usm_h%t_wall_av(iwl,m)Â =Â Â Â Â Â Â Â Â Â Â Â Â Â Â & |
---|
1638 | Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â surf_usm_h%t_wall_av(iwl,m)Â /Â Â Â Â & |
---|
1639 |                      REAL( average_count_3d, kind=wp ) |
---|
1640 | Â Â Â Â Â Â Â Â Â Â ENDDO |
---|
1641 |           DO l = 0, 3 |
---|
1642 |             DO m = 1, surf_usm_v(l)%ns |
---|
1643 | Â Â Â Â Â Â Â Â Â Â Â Â Â surf_usm_v(l)%t_wall_av(iwl,m)Â =Â Â Â Â Â Â Â Â Â Â Â & |
---|
1644 | Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â surf_usm_v(l)%t_wall_av(iwl,m)Â /Â Â Â & |
---|
1645 |                      REAL( average_count_3d, kind=wp ) |
---|
1646 | Â Â Â Â Â Â Â Â Â Â Â Â ENDDO |
---|
1647 | Â Â Â Â Â Â Â Â Â Â ENDDO |
---|
1648 | |
---|
1649 | Â Â Â Â Â Â END SELECT |
---|
1650 | |
---|
1651 | Â Â Â Â ENDIF |
---|
1652 | |
---|
1653 | Â Â END SUBROUTINE usm_average_3d_data |
---|
1654 | |
---|
1655 | |
---|
1656 | !------------------------------------------------------------------------------! |
---|
1657 | !> Calculates radiation absorbed by box with given size and LAD. |
---|
1658 | !> |
---|
1659 | !> Simulates resol**2 rays (by equally spacing a bounding horizontal square |
---|
1660 | !> conatining all possible rays that would cross the box) and calculates |
---|
1661 | !> average transparency per ray. Returns fraction of absorbed radiation flux |
---|
1662 | !> and area for which this fraction is effective. |
---|
1663 | !------------------------------------------------------------------------------! |
---|
1664 |   PURE SUBROUTINE usm_box_absorb(boxsize, resol, dens, uvec, area, absorb) |
---|
1665 | Â Â Â Â IMPLICIT NONE |
---|
1666 | |
---|
1667 |     REAL(wp), DIMENSION(3), INTENT(in) :: & |
---|
1668 |       boxsize, &   !< z, y, x size of box in m |
---|
1669 |       uvec      !< z, y, x unit vector of incoming flux |
---|
1670 |     INTEGER(iwp), INTENT(in) :: & |
---|
1671 |       resol      !< No. of rays in x and y dimensions |
---|
1672 |     REAL(wp), INTENT(in) :: & |
---|
1673 |       dens      !< box density (e.g. Leaf Area Density) |
---|
1674 |     REAL(wp), INTENT(out) :: & |
---|
1675 |       area, &     !< horizontal area for flux absorbtion |
---|
1676 |       absorb     !< fraction of absorbed flux |
---|
1677 | Â Â Â Â REAL(wp)Â ::Â & |
---|
1678 |       xshift, yshift, & |
---|
1679 |       xmin, xmax, ymin, ymax, & |
---|
1680 |       xorig, yorig, & |
---|
1681 |       dx1, dy1, dz1, dx2, dy2, dz2, & |
---|
1682 |       crdist, & |
---|
1683 | Â Â Â Â Â Â transp |
---|
1684 | Â Â Â Â INTEGER(iwp)Â ::Â & |
---|
1685 |       i, j |
---|
1686 | |
---|
1687 |     xshift = uvec(3) / uvec(1) * boxsize(1) |
---|
1688 |     xmin = min(0._wp, -xshift) |
---|
1689 |     xmax = boxsize(3) + max(0._wp, -xshift) |
---|
1690 |     yshift = uvec(2) / uvec(1) * boxsize(1) |
---|
1691 |     ymin = min(0._wp, -yshift) |
---|
1692 |     ymax = boxsize(2) + max(0._wp, -yshift) |
---|
1693 | |
---|
1694 |     transp = 0._wp |
---|
1695 |     DO i = 1, resol |
---|
1696 |       xorig = xmin + (xmax-xmin) * (i-.5_wp) / resol |
---|
1697 |       DO j = 1, resol |
---|
1698 |         yorig = ymin + (ymax-ymin) * (j-.5_wp) / resol |
---|
1699 | |
---|
1700 | Â Â Â Â Â Â Â Â dz1Â =Â 0._wp |
---|
1701 | Â Â Â Â Â Â Â Â dz2Â =Â boxsize(1)/uvec(1) |
---|
1702 | |
---|
1703 |         IF ( uvec(2) > 0._wp ) THEN |
---|
1704 |           dy1 = -yorig       / uvec(2) !< crossing with y=0 |
---|
1705 | Â Â Â Â Â Â Â Â Â Â dy2Â =Â (boxsize(2)-yorig)Â /Â uvec(2)Â !< crossing with y=boxsize(2) |
---|
1706 |         ELSE IF ( uvec(2) < 0._wp ) THEN |
---|
1707 | Â Â Â Â Â Â Â Â Â Â dy1Â =Â (boxsize(2)-yorig)Â /Â uvec(2)Â !< crossing with y=boxsize(2) |
---|
1708 |           dy2 = -yorig       / uvec(2) !< crossing with y=0 |
---|
1709 | Â Â Â Â Â Â Â Â ELSEÂ !uvec(2)==0 |
---|
1710 | Â Â Â Â Â Â Â Â Â Â dy1Â =Â -huge(1._wp) |
---|
1711 | Â Â Â Â Â Â Â Â Â Â dy2Â =Â huge(1._wp) |
---|
1712 | Â Â Â Â Â Â Â Â ENDIF |
---|
1713 | |
---|
1714 |         IF ( uvec(3) > 0._wp ) THEN |
---|
1715 |           dx1 = -xorig       / uvec(3) !< crossing with x=0 |
---|
1716 | Â Â Â Â Â Â Â Â Â Â dx2Â =Â (boxsize(3)-xorig)Â /Â uvec(3)Â !< crossing with x=boxsize(3) |
---|
1717 |         ELSE IF ( uvec(3) < 0._wp ) THEN |
---|
1718 | Â Â Â Â Â Â Â Â Â Â dx1Â =Â (boxsize(3)-xorig)Â /Â uvec(3)Â !< crossing with x=boxsize(3) |
---|
1719 |           dx2 = -xorig       / uvec(3) !< crossing with x=0 |
---|
1720 | Â Â Â Â Â Â Â Â ELSEÂ !uvec(1)==0 |
---|
1721 | Â Â Â Â Â Â Â Â Â Â dx1Â =Â -huge(1._wp) |
---|
1722 | Â Â Â Â Â Â Â Â Â Â dx2Â =Â huge(1._wp) |
---|
1723 | Â Â Â Â Â Â Â Â ENDIF |
---|
1724 | |
---|
1725 |         crdist = max(0._wp, (min(dz2, dy2, dx2) - max(dz1, dy1, dx1))) |
---|
1726 |         transp = transp + exp(-ext_coef * dens * crdist) |
---|
1727 | Â Â Â Â Â Â ENDDO |
---|
1728 | Â Â Â Â ENDDO |
---|
1729 |     transp = transp / resol**2 |
---|
1730 |     area = (boxsize(3)+xshift)*(boxsize(2)+yshift) |
---|
1731 |     absorb = 1._wp - transp |
---|
1732 | Â Â Â Â |
---|
1733 | Â Â END SUBROUTINE usm_box_absorb |
---|
1734 | Â Â |
---|
1735 | Â Â |
---|
1736 | !------------------------------------------------------------------------------! |
---|
1737 | ! Description: |
---|
1738 | ! ------------ |
---|
1739 | !> This subroutine splits direct and diffusion dw radiation |
---|
1740 | !> It sould not be called in case the radiation model already does it |
---|
1741 | !> It follows <CITATION> |
---|
1742 | !------------------------------------------------------------------------------! |
---|
1743 |   SUBROUTINE usm_calc_diffusion_radiation |
---|
1744 | Â Â |
---|
1745 |     REAL(wp), PARAMETER             :: sol_const = 1367.0_wp  !< solar conbstant |
---|
1746 |     REAL(wp), PARAMETER             :: lowest_solarUp = 0.1_wp !< limit the sun elevation to protect stability of the calculation |
---|
1747 |     INTEGER(iwp)                 :: i, j |
---|
1748 |     REAL(wp), PARAMETER             :: year_seconds = 86400._wp * 365._wp |
---|
1749 |     REAL(wp)                   :: year_angle       !< angle |
---|
1750 |     REAL(wp)                   :: etr           !< extraterestrial radiation |
---|
1751 |     REAL(wp)                   :: corrected_solarUp    !< corrected solar up radiation |
---|
1752 | Â Â Â Â REAL(wp)Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â ::Â horizontalETRÂ Â Â Â Â Â !< horizontal extraterestrial radiation |
---|
1753 |     REAL(wp)                   :: clearnessIndex     !< clearness index |
---|
1754 |     REAL(wp)                   :: diff_frac        !< diffusion fraction of the radiation |
---|
1755 | |
---|
1756 | Â Â Â Â |
---|
1757 | !--Â Â Â Calculate current day and time based on the initial values and simulation time |
---|
1758 |     year_angle = ((day_init*86400) + time_utc_init+time_since_reference_point) & |
---|
1759 |             / year_seconds * 2.0_wp * pi |
---|
1760 | Â Â Â Â |
---|
1761 |     etr = sol_const * (1.00011_wp +                      & |
---|
1762 |              0.034221_wp * cos(year_angle) +             & |
---|
1763 |              0.001280_wp * sin(year_angle) +             & |
---|
1764 |              0.000719_wp * cos(2.0_wp * year_angle) +         & |
---|
1765 |              0.000077_wp * sin(2.0_wp * year_angle)) |
---|
1766 | Â Â Â Â |
---|
1767 | !--Â Â |
---|
1768 | !--Â Â Â Under a very low angle, we keep extraterestrial radiation at |
---|
1769 | !--Â Â Â the last small value, therefore the clearness index will be pushed |
---|
1770 | !--Â Â Â towards 0 while keeping full continuity. |
---|
1771 | !--Â Â |
---|
1772 |     IF ( zenith(0) <= lowest_solarUp ) THEN |
---|
1773 |       corrected_solarUp = lowest_solarUp |
---|
1774 | Â Â Â Â ELSE |
---|
1775 |       corrected_solarUp = zenith(0) |
---|
1776 | Â Â Â Â ENDIF |
---|
1777 | Â Â Â Â |
---|
1778 |     horizontalETR = etr * corrected_solarUp |
---|
1779 | Â Â Â Â |
---|
1780 |     DO i = nxlg, nxrg |
---|
1781 |       DO j = nysg, nyng |
---|
1782 |         clearnessIndex = rad_sw_in(0,j,i) / horizontalETR |
---|
1783 |         diff_frac = 1.0_wp / (1.0_wp + exp(-5.0033_wp + 8.6025_wp * clearnessIndex)) |
---|
1784 | Â Â Â Â Â Â Â Â rad_sw_in_diff(j,i)Â =Â rad_sw_in(0,j,i)Â *Â diff_frac |
---|
1785 |         rad_sw_in_dir(j,i) = rad_sw_in(0,j,i) * (1.0_wp - diff_frac) |
---|
1786 | Â Â Â Â Â Â Â Â rad_lw_in_diff(j,i)Â =Â rad_lw_in(0,j,i) |
---|
1787 | Â Â Â Â Â Â ENDDO |
---|
1788 | Â Â Â Â ENDDO |
---|
1789 | Â Â Â Â |
---|
1790 | Â Â END SUBROUTINE usm_calc_diffusion_radiation |
---|
1791 | Â Â |
---|
1792 | |
---|
1793 | !------------------------------------------------------------------------------! |
---|
1794 | ! Description: |
---|
1795 | ! ------------ |
---|
1796 | !> Calculates shape view factors SVF and plant sink canopy factors PSCF |
---|
1797 | !> !!!!!DESCRIPTION!!!!!!!!!! |
---|
1798 | !------------------------------------------------------------------------------! |
---|
1799 | Â Â SUBROUTINE usm_calc_svf |
---|
1800 | Â Â |
---|
1801 | Â Â Â Â IMPLICIT NONE |
---|
1802 | Â Â Â Â |
---|
1803 |     INTEGER(iwp)                :: i, j, k, l, d, ip, jp |
---|
1804 |     INTEGER(iwp)                :: isvf, ksvf, icsf, kcsf, npcsfl, isvf_surflt, imrtt, imrtf |
---|
1805 |     INTEGER(iwp)                :: sd, td, ioln, iproc |
---|
1806 |     REAL(wp),   DIMENSION(0:9)        :: facearea |
---|
1807 |     INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE  :: nzterrl, planthl |
---|
1808 |     REAL(wp),   DIMENSION(:,:), ALLOCATABLE  :: csflt, pcsflt |
---|
1809 |     INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE  :: kcsflt,kpcsflt |
---|
1810 |     INTEGER(iwp), DIMENSION(:), ALLOCATABLE   :: icsflt,dcsflt,ipcsflt,dpcsflt |
---|
1811 |     REAL(wp), DIMENSION(3)           :: uv |
---|
1812 | Â Â Â Â LOGICALÂ Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â ::Â visible |
---|
1813 |     REAL(wp), DIMENSION(3)           :: sa, ta     !< real coordinates z,y,x of source and target |
---|
1814 |     REAL(wp)                  :: transparency, rirrf, sqdist, svfsum |
---|
1815 |     INTEGER(iwp)                :: isurflt, isurfs, isurflt_prev |
---|
1816 |     INTEGER(iwp)                :: itx, ity, itz |
---|
1817 |     CHARACTER(len=7)              :: pid_char = '' |
---|
1818 |     INTEGER(iwp)                :: win_lad, minfo |
---|
1819 |     REAL(wp), DIMENSION(:,:,:), POINTER     :: lad_s_rma    !< fortran pointer, but lower bounds are 1 |
---|
1820 |     TYPE(c_ptr)                 :: lad_s_rma_p   !< allocated c pointer |
---|
1821 | #if defined( __parallel ) |
---|
1822 | Â Â Â Â INTEGER(kind=MPI_ADDRESS_KIND)Â Â Â Â Â Â Â ::Â size_lad_rma |
---|
1823 | #endif |
---|
1824 | !  |
---|
1825 | !--Â Â Â calculation of the SVF |
---|
1826 |     CALL location_message( '  calculation of SVF and CSF', .TRUE. ) |
---|
1827 | ! |
---|
1828 | !--Â Â Â precalculate face areas for different face directions using normal vector |
---|
1829 |     DO d = 0, 9 |
---|
1830 | Â Â Â Â Â Â facearea(d)Â =Â 1._wp |
---|
1831 | Â Â Â Â Â Â IFÂ (Â idir(d)Â ==Â 0Â )Â facearea(d)Â =Â facearea(d)Â *Â dx |
---|
1832 | Â Â Â Â Â Â IFÂ (Â jdir(d)Â ==Â 0Â )Â facearea(d)Â =Â facearea(d)Â *Â dy |
---|
1833 | Â Â Â Â Â Â IFÂ (Â kdir(d)Â ==Â 0Â )Â facearea(d)Â =Â facearea(d)Â *Â dz |
---|
1834 | Â Â Â Â ENDDO |
---|
1835 | |
---|
1836 | !--Â Â Â initialize variables and temporary arrays for calculation of svf and csf |
---|
1837 |     nsvfl = 0 |
---|
1838 |     ncsfl = 0 |
---|
1839 |     nsvfla = gasize |
---|
1840 |     msvf  = 1 |
---|
1841 | Â Â Â Â ALLOCATE(Â asvf1(nsvfla)Â ) |
---|
1842 |     asvf => asvf1 |
---|
1843 |     IF ( plant_canopy ) THEN |
---|
1844 |       ncsfla = gasize |
---|
1845 |       mcsf  = 1 |
---|
1846 | Â Â Â Â Â Â ALLOCATE(Â acsf1(ncsfla)Â ) |
---|
1847 |       acsf => acsf1 |
---|
1848 | Â Â Â Â ENDIF |
---|
1849 | Â Â Â Â |
---|
1850 | !--Â Â Â initialize temporary terrain and plant canopy height arrays (global 2D array!) |
---|
1851 | Â Â Â Â ALLOCATE(Â nzterr(0:(nx+1)*(ny+1)-1)Â ) |
---|
1852 | #if defined( __parallel ) |
---|
1853 | Â Â Â Â ALLOCATE(Â nzterrl(nys:nyn,nxl:nxr)Â ) |
---|
1854 |     nzterrl = MAXLOC(                           & |
---|
1855 |              MERGE( 1, 0,                     & |
---|
1856 |                  BTEST( wall_flags_0(:,nys:nyn,nxl:nxr), 12 ) & |
---|
1857 |                 ), DIM = 1                   & |
---|
1858 | Â Â Â Â Â Â Â Â Â Â Â Â )Â -Â 1Â ! = nzb_s_inner(nys:nyn,nxl:nxr) |
---|
1859 |     CALL MPI_AllGather( nzterrl, nnx*nny, MPI_INTEGER, & |
---|
1860 |               nzterr, nnx*nny, MPI_INTEGER, comm2d, ierr ) |
---|
1861 | Â Â Â Â DEALLOCATE(nzterrl) |
---|
1862 | #else |
---|
1863 |     nzterr = RESHAPE( MAXLOC(                       & |
---|
1864 |              MERGE( 1, 0,                     & |
---|
1865 |                  BTEST( wall_flags_0(:,nys:nyn,nxl:nxr), 12 ) & |
---|
1866 |                 ), DIM = 1                   & |
---|
1867 |                 ) - 1,                     & |
---|
1868 | Â Â Â Â Â Â Â Â Â Â Â Â Â (/(nx+1)*(ny+1)/)Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â & |
---|
1869 | Â Â Â Â Â Â Â Â Â Â Â Â ) |
---|
1870 | #endif |
---|
1871 |     IF ( plant_canopy ) THEN |
---|
1872 | Â Â Â Â Â Â ALLOCATE(Â plantt(0:(nx+1)*(ny+1)-1)Â ) |
---|
1873 |       maxboxesg = nx + ny + nzu + 1 |
---|
1874 | !--Â Â Â Â Â temporary arrays storing values for csf calculation during raytracing |
---|
1875 |       ALLOCATE( boxes(3, maxboxesg) ) |
---|
1876 | Â Â Â Â Â Â ALLOCATE(Â crlens(maxboxesg)Â ) |
---|
1877 | |
---|
1878 | #if defined( __parallel ) |
---|
1879 | Â Â Â Â Â Â ALLOCATE(Â planthl(nys:nyn,nxl:nxr)Â ) |
---|
1880 |       planthl = pch(nys:nyn,nxl:nxr) |
---|
1881 | Â Â Â Â |
---|
1882 |       CALL MPI_AllGather( planthl, nnx*nny, MPI_INTEGER, & |
---|
1883 |                 plantt, nnx*nny, MPI_INTEGER, comm2d, ierr ) |
---|
1884 |       DEALLOCATE( planthl ) |
---|
1885 | Â Â Â Â Â Â |
---|
1886 | !--Â Â Â Â Â temporary arrays storing values for csf calculation during raytracing |
---|
1887 | Â Â Â Â Â Â ALLOCATE(Â lad_ip(maxboxesg)Â ) |
---|
1888 | Â Â Â Â Â Â ALLOCATE(Â lad_disp(maxboxesg)Â ) |
---|
1889 | |
---|
1890 |       IF ( usm_lad_rma ) THEN |
---|
1891 | Â Â Â Â Â Â Â Â ALLOCATE(Â lad_s_ray(maxboxesg)Â ) |
---|
1892 | Â Â Â Â Â Â Â Â |
---|
1893 | Â Â Â Â Â Â Â Â ! set conditions for RMA communication |
---|
1894 |         CALL MPI_Info_create(minfo, ierr) |
---|
1895 |         CALL MPI_Info_set(minfo, 'accumulate_ordering', '', ierr) |
---|
1896 |         CALL MPI_Info_set(minfo, 'accumulate_ops', 'same_op', ierr) |
---|
1897 |         CALL MPI_Info_set(minfo, 'same_size', 'true', ierr) |
---|
1898 |         CALL MPI_Info_set(minfo, 'same_disp_unit', 'true', ierr) |
---|
1899 | |
---|
1900 | !--Â Â Â Â Â Â Â Allocate and initialize the MPI RMA window |
---|
1901 | !--Â Â Â Â Â Â Â must be in accordance with allocation of lad_s in plant_canopy_model |
---|
1902 | !--Â Â Â Â Â Â Â optimization of memory should be done |
---|
1903 | !--Â Â Â Â Â Â Â Argument X of function c_sizeof(X) needs arbitrary REAL(wp) value, set to 1.0_wp for now |
---|
1904 |         size_lad_rma = c_sizeof(1.0_wp)*nnx*nny*nzu |
---|
1905 |         CALL MPI_Win_allocate(size_lad_rma, c_sizeof(1.0_wp), minfo, comm2d, & |
---|
1906 |                     lad_s_rma_p, win_lad, ierr) |
---|
1907 |         CALL c_f_pointer(lad_s_rma_p, lad_s_rma, (/ nzu, nny, nnx /)) |
---|
1908 |         usm_lad(nzub:, nys:, nxl:) => lad_s_rma(:,:,:) |
---|
1909 | Â Â Â Â Â Â ELSE |
---|
1910 |         ALLOCATE(usm_lad(nzub:nzut, nys:nyn, nxl:nxr)) |
---|
1911 | Â Â Â Â Â Â ENDIF |
---|
1912 | #else |
---|
1913 |       plantt = RESHAPE( pct(nys:nyn,nxl:nxr), (/(nx+1)*(ny+1)/) ) |
---|
1914 |       ALLOCATE(usm_lad(nzub:nzut, nys:nyn, nxl:nxr)) |
---|
1915 | #endif |
---|
1916 | Â Â Â Â Â Â usm_lad(:,:,:)Â =Â 0._wp |
---|
1917 |       DO i = nxl, nxr |
---|
1918 |         DO j = nys, nyn |
---|
1919 |           k = get_topography_top_index( j, i, 's' ) |
---|
1920 | |
---|
1921 |           usm_lad(k:nzut, j, i) = lad_s(0:nzut-k, j, i) |
---|
1922 | Â Â Â Â Â Â Â Â ENDDO |
---|
1923 | Â Â Â Â Â Â ENDDO |
---|
1924 | |
---|
1925 | #if defined( __parallel ) |
---|
1926 |       IF ( usm_lad_rma ) THEN |
---|
1927 |         CALL MPI_Info_free(minfo, ierr) |
---|
1928 |         CALL MPI_Win_lock_all(0, win_lad, ierr) |
---|
1929 | Â Â Â Â Â Â ELSE |
---|
1930 | Â Â Â Â Â Â Â Â ALLOCATE(Â usm_lad_g(0:(nx+1)*(ny+1)*nzu-1)Â ) |
---|
1931 |         CALL MPI_AllGather( usm_lad, nnx*nny*nzu, MPI_REAL, & |
---|
1932 |                   usm_lad_g, nnx*nny*nzu, MPI_REAL, comm2d, ierr ) |
---|
1933 | Â Â Â Â Â Â ENDIF |
---|
1934 | #endif |
---|
1935 | Â Â Â Â ENDIF |
---|
1936 | |
---|
1937 |     IF ( mrt_factors ) THEN |
---|
1938 |       OPEN(153, file='MRT_TARGETS', access='SEQUENTIAL', & |
---|
1939 |           action='READ', status='OLD', form='FORMATTED', err=524) |
---|
1940 |       OPEN(154, file='MRT_FACTORS'//myid_char, access='DIRECT', recl=(5*4+2*8), & |
---|
1941 |           action='WRITE', status='REPLACE', form='UNFORMATTED', err=525) |
---|
1942 |       imrtf = 1 |
---|
1943 | Â Â Â Â Â Â DO |
---|
1944 |         READ(153, *, end=526, err=524) imrtt, i, j, k |
---|
1945 |         IF ( i < nxl .OR. i > nxr & |
---|
1946 |            .OR. j < nys .OR. j > nyn ) CYCLE |
---|
1947 |         ta = (/ REAL(k), REAL(j), REAL(i) /) |
---|
1948 | |
---|
1949 |         DO isurfs = 1, nsurf |
---|
1950 |           IF ( .NOT. usm_facing(i, j, k, -1, & |
---|
1951 |             surf(ix, isurfs), surf(iy, isurfs), & |
---|
1952 |             surf(iz, isurfs), surf(id, isurfs)) ) THEN |
---|
1953 | Â Â Â Â Â Â Â Â Â Â Â Â CYCLE |
---|
1954 | Â Â Â Â Â Â Â Â Â Â ENDIF |
---|
1955 | Â Â Â Â Â Â Â Â Â Â Â |
---|
1956 |           sd = surf(id, isurfs) |
---|
1957 |           sa = (/ REAL(surf(iz, isurfs), wp) - 0.5_wp * kdir(sd), & |
---|
1958 |               REAL(surf(iy, isurfs), wp) - 0.5_wp * jdir(sd), & |
---|
1959 |               REAL(surf(ix, isurfs), wp) - 0.5_wp * idir(sd) /) |
---|
1960 | |
---|
1961 | !--Â Â Â Â Â Â Â Â Â unit vector source -> target |
---|
1962 |           uv = (/ (ta(1)-sa(1))*dz, (ta(2)-sa(2))*dy, (ta(3)-sa(3))*dx /) |
---|
1963 |           sqdist = SUM(uv(:)**2) |
---|
1964 |           uv = uv / SQRT(sqdist) |
---|
1965 | |
---|
1966 | !--Â Â Â Â Â Â Â Â Â irradiance factor - see svf. Here we consider that target face is always normal, |
---|
1967 | !--Â Â Â Â Â Â Â Â Â i.e. the second dot product equals 1 |
---|
1968 |           rirrf = dot_product((/ kdir(sd), jdir(sd), idir(sd) /), uv) & |
---|
1969 |             / (pi * sqdist) * facearea(sd) |
---|
1970 | |
---|
1971 | !--Â Â Â Â Â Â Â Â Â raytrace while not creating any canopy sink factors |
---|
1972 |           CALL usm_raytrace(sa, ta, isurfs, rirrf, 1._wp, .FALSE., & |
---|
1973 |               visible, transparency, win_lad) |
---|
1974 |           IF ( .NOT. visible ) CYCLE |
---|
1975 | |
---|
1976 | Â Â Â Â Â Â Â Â Â Â !rsvf = rirrf * transparency |
---|
1977 |           WRITE(154, rec=imrtf, err=525) INT(imrtt, kind=4), & |
---|
1978 |             INT(surf(id, isurfs), kind=4), & |
---|
1979 |             INT(surf(iz, isurfs), kind=4), & |
---|
1980 |             INT(surf(iy, isurfs), kind=4), & |
---|
1981 |             INT(surf(ix, isurfs), kind=4), & |
---|
1982 |             REAL(rirrf, kind=8), REAL(transparency, kind=8) |
---|
1983 |           imrtf = imrtf + 1 |
---|
1984 | |
---|
1985 | Â Â Â Â Â Â Â Â ENDDOÂ !< isurfs |
---|
1986 | Â Â Â Â Â Â ENDDOÂ !< MRT_TARGETS record |
---|
1987 | |
---|
1988 | 524     message_string = 'error reading file MRT_TARGETS' |
---|
1989 |       CALL message( 'usm_calc_svf', 'PA0524', 1, 2, 0, 6, 0 ) |
---|
1990 | |
---|
1991 | 525     message_string = 'error writing file MRT_FACTORS'//myid_char |
---|
1992 |       CALL message( 'usm_calc_svf', 'PA0525', 1, 2, 0, 6, 0 ) |
---|
1993 | |
---|
1994 | 526Â Â Â Â Â CLOSE(153) |
---|
1995 | Â Â Â Â Â Â CLOSE(154) |
---|
1996 | Â Â Â Â ENDIFÂ !< mrt_factors |
---|
1997 | |
---|
1998 | Â Â Â Â |
---|
1999 |     DO isurflt = 1, nsurfl |
---|
2000 | !--Â Â Â Â Â determine face centers |
---|
2001 |       td = surfl(id, isurflt) |
---|
2002 |       IF ( td >= isky .AND. .NOT. plant_canopy ) CYCLE |
---|
2003 |       ta = (/ REAL(surfl(iz, isurflt), wp) - 0.5_wp * kdir(td), & |
---|
2004 |            REAL(surfl(iy, isurflt), wp) - 0.5_wp * jdir(td), & |
---|
2005 |            REAL(surfl(ix, isurflt), wp) - 0.5_wp * idir(td) /) |
---|
2006 |       DO isurfs = 1, nsurf |
---|
2007 |         IF ( .NOT. usm_facing(surfl(ix, isurflt), surfl(iy, isurflt), & |
---|
2008 |           surfl(iz, isurflt), surfl(id, isurflt), & |
---|
2009 |           surf(ix, isurfs), surf(iy, isurfs), & |
---|
2010 |           surf(iz, isurfs), surf(id, isurfs)) ) THEN |
---|
2011 | Â Â Â Â Â Â Â Â Â Â CYCLE |
---|
2012 | Â Â Â Â Â Â Â Â ENDIF |
---|
2013 | Â Â Â Â Â Â Â Â Â |
---|
2014 |         sd = surf(id, isurfs) |
---|
2015 |         sa = (/ REAL(surf(iz, isurfs), wp) - 0.5_wp * kdir(sd), & |
---|
2016 |             REAL(surf(iy, isurfs), wp) - 0.5_wp * jdir(sd), & |
---|
2017 |             REAL(surf(ix, isurfs), wp) - 0.5_wp * idir(sd) /) |
---|
2018 | |
---|
2019 | !--Â Â Â Â Â Â Â unit vector source -> target |
---|
2020 |         uv = (/ (ta(1)-sa(1))*dz, (ta(2)-sa(2))*dy, (ta(3)-sa(3))*dx /) |
---|
2021 |         sqdist = SUM(uv(:)**2) |
---|
2022 |         uv = uv / SQRT(sqdist) |
---|
2023 | Â Â Â Â Â Â Â Â |
---|
2024 | !--Â Â Â Â Â Â Â irradiance factor (our unshaded shape view factor) = view factor per differential target area * source area |
---|
2025 |         rirrf = dot_product((/ kdir(sd), jdir(sd), idir(sd) /), uv) & ! cosine of source normal and direction |
---|
2026 |           * dot_product((/ kdir(td), jdir(td), idir(td) /), -uv) & ! cosine of target normal and reverse direction |
---|
2027 |           / (pi * sqdist) & ! square of distance between centers |
---|
2028 | Â Â Â Â Â Â Â Â Â Â *Â facearea(sd) |
---|
2029 | |
---|
2030 | !--Â Â Â Â Â Â Â raytrace + process plant canopy sinks within |
---|
2031 |         CALL usm_raytrace(sa, ta, isurfs, rirrf, facearea(td), .TRUE., & |
---|
2032 |             visible, transparency, win_lad) |
---|
2033 | Â Â Â Â Â Â Â Â |
---|
2034 |         IF ( .NOT. visible ) CYCLE |
---|
2035 |         IF ( td >= isky ) CYCLE !< we calculated these only for raytracing |
---|
2036 | Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â !< to find plant canopy sinks, we don't need svf for them |
---|
2037 | Â Â Â Â Â Â Â Â ! rsvf = rirrf * transparency |
---|
2038 | |
---|
2039 | !--Â Â Â Â Â Â Â write to the svf array |
---|
2040 |         nsvfl = nsvfl + 1 |
---|
2041 | !--Â Â Â Â Â Â Â check dimmension of asvf array and enlarge it if needed |
---|
2042 |         IF ( nsvfla < nsvfl ) THEN |
---|
2043 |           k = nsvfla * 2 |
---|
2044 |           IF ( msvf == 0 ) THEN |
---|
2045 |             msvf = 1 |
---|
2046 | Â Â Â Â Â Â Â Â Â Â Â Â ALLOCATE(Â asvf1(k)Â ) |
---|
2047 |             asvf => asvf1 |
---|
2048 | Â Â Â Â Â Â Â Â Â Â Â Â asvf1(1:nsvfla)Â =Â asvf2 |
---|
2049 | Â Â Â Â Â Â Â Â Â Â Â Â DEALLOCATE(Â asvf2Â ) |
---|
2050 | Â Â Â Â Â Â Â Â Â Â ELSE |
---|
2051 |             msvf = 0 |
---|
2052 | Â Â Â Â Â Â Â Â Â Â Â Â ALLOCATE(Â asvf2(k)Â ) |
---|
2053 |             asvf => asvf2 |
---|
2054 | Â Â Â Â Â Â Â Â Â Â Â Â asvf2(1:nsvfla)Â =Â asvf1 |
---|
2055 | Â Â Â Â Â Â Â Â Â Â Â Â DEALLOCATE(Â asvf1Â ) |
---|
2056 | Â Â Â Â Â Â Â Â Â Â ENDIF |
---|
2057 |           nsvfla = k |
---|
2058 | Â Â Â Â Â Â Â Â ENDIF |
---|
2059 | !--Â Â Â Â Â Â Â write svf values into the array |
---|
2060 |         asvf(nsvfl)%isurflt = isurflt |
---|
2061 |         asvf(nsvfl)%isurfs = isurfs |
---|
2062 |         asvf(nsvfl)%rsvf = rirrf !we postopne multiplication by transparency |
---|
2063 |         asvf(nsvfl)%rtransp = transparency !a.k.a. Direct Irradiance Factor |
---|
2064 | Â Â Â Â Â Â ENDDO |
---|
2065 | Â Â Â Â ENDDO |
---|
2066 | |
---|
2067 |     CALL location_message( '  waiting for completion of SVF and CSF calculation in all processes', .TRUE. ) |
---|
2068 | !--Â Â Â deallocate temporary global arrays |
---|
2069 | Â Â Â Â DEALLOCATE(nzterr) |
---|
2070 | Â Â Â Â |
---|
2071 |     IF ( plant_canopy ) THEN |
---|
2072 | !--Â Â Â Â Â finalize mpi_rma communication and deallocate temporary arrays |
---|
2073 | #if defined( __parallel ) |
---|
2074 |       IF ( usm_lad_rma ) THEN |
---|
2075 |         CALL MPI_Win_flush_all(win_lad, ierr) |
---|
2076 | !--Â Â Â Â Â Â Â unlock MPI window |
---|
2077 |         CALL MPI_Win_unlock_all(win_lad, ierr) |
---|
2078 | !--Â Â Â Â Â Â Â free MPI window |
---|
2079 |         CALL MPI_Win_free(win_lad, ierr) |
---|
2080 | Â Â Â Â Â Â Â Â |
---|
2081 | !--Â Â Â Â Â Â Â deallocate temporary arrays storing values for csf calculation during raytracing |
---|
2082 |         DEALLOCATE( lad_s_ray ) |
---|
2083 | !--Â Â Â Â Â Â Â usm_lad is the pointer to lad_s_rma in case of usm_lad_rma |
---|
2084 | !--Â Â Â Â Â Â Â and must not be deallocated here |
---|
2085 | Â Â Â Â Â Â ELSE |
---|
2086 | Â Â Â Â Â Â Â Â DEALLOCATE(usm_lad) |
---|
2087 | Â Â Â Â Â Â Â Â DEALLOCATE(usm_lad_g) |
---|
2088 | Â Â Â Â Â Â ENDIF |
---|
2089 | #else |
---|
2090 | Â Â Â Â Â Â DEALLOCATE(usm_lad) |
---|
2091 | #endif |
---|
2092 |       DEALLOCATE( boxes ) |
---|
2093 |       DEALLOCATE( crlens ) |
---|
2094 |       DEALLOCATE( plantt ) |
---|
2095 | Â Â Â Â ENDIF |
---|
2096 | |
---|
2097 |     CALL location_message( '  calculation of the complete SVF array', .TRUE. ) |
---|
2098 | |
---|
2099 | !--Â Â Â sort svf ( a version of quicksort ) |
---|
2100 | Â Â Â Â CALL quicksort_svf(asvf,1,nsvfl) |
---|
2101 | |
---|
2102 | Â Â Â Â ALLOCATE(Â svf(ndsvf,nsvfl)Â ) |
---|
2103 | Â Â Â Â ALLOCATE(Â svfsurf(idsvf,nsvfl)Â ) |
---|
2104 | |
---|
2105 | Â Â Â Â !< load svf from the structure array to plain arrays |
---|
2106 |     isurflt_prev = -1 |
---|
2107 |     ksvf = 1 |
---|
2108 |     svfsum = 0._wp |
---|
2109 |     DO isvf = 1, nsvfl |
---|
2110 | !--Â Â Â Â Â normalize svf per target face |
---|
2111 |       IF ( asvf(ksvf)%isurflt /= isurflt_prev ) THEN |
---|
2112 |         IF ( isurflt_prev /= -1 .AND. svfsum /= 0._wp ) THEN |
---|
2113 | !--Â Â Â Â Â Â Â Â Â TODO detect and log when normalization differs too much from 1 |
---|
2114 |           svf(1, isvf_surflt:isvf-1) = svf(1, isvf_surflt:isvf-1) / svfsum |
---|
2115 | Â Â Â Â Â Â Â Â ENDIF |
---|
2116 |         isurflt_prev = asvf(ksvf)%isurflt |
---|
2117 |         isvf_surflt = isvf |
---|
2118 |         svfsum = asvf(ksvf)%rsvf !?? / asvf(ksvf)%rtransp |
---|
2119 | Â Â Â Â Â Â ELSE |
---|
2120 |         svfsum = svfsum + asvf(ksvf)%rsvf !?? / asvf(ksvf)%rtransp |
---|
2121 | Â Â Â Â Â Â ENDIF |
---|
2122 | |
---|
2123 |       svf(:, isvf) = (/ asvf(ksvf)%rsvf, asvf(ksvf)%rtransp /) |
---|
2124 |       svfsurf(:, isvf) = (/ asvf(ksvf)%isurflt, asvf(ksvf)%isurfs /) |
---|
2125 | |
---|
2126 | !--Â Â Â Â Â next element |
---|
2127 |       ksvf = ksvf + 1 |
---|
2128 | Â Â Â Â ENDDO |
---|
2129 | |
---|
2130 |     IF ( isurflt_prev /= -1 .AND. svfsum /= 0._wp ) THEN |
---|
2131 | !--Â Â Â Â Â TODO detect and log when normalization differs too much from 1 |
---|
2132 |       svf(1, isvf_surflt:nsvfl) = svf(1, isvf_surflt:nsvfl) / svfsum |
---|
2133 | Â Â Â Â ENDIF |
---|
2134 | |
---|
2135 | !--Â Â Â deallocate temporary asvf array |
---|
2136 | !--Â Â Â DEALLOCATE(asvf) - ifort has a problem with deallocation of allocatable target |
---|
2137 | !--Â Â Â via pointing pointer - we need to test original targets |
---|
2138 | Â Â Â Â IFÂ (Â ALLOCATED(asvf1)Â )Â THEN |
---|
2139 | Â Â Â Â Â Â DEALLOCATE(asvf1) |
---|
2140 | Â Â Â Â ENDIF |
---|
2141 | Â Â Â Â IFÂ (Â ALLOCATED(asvf2)Â )Â THEN |
---|
2142 | Â Â Â Â Â Â DEALLOCATE(asvf2) |
---|
2143 | Â Â Â Â ENDIF |
---|
2144 | |
---|
2145 |     npcsfl = 0 |
---|
2146 |     IF ( plant_canopy ) THEN |
---|
2147 | |
---|
2148 |       CALL location_message( '  calculation of the complete CSF array', .TRUE. ) |
---|
2149 | |
---|
2150 | !--Â Â Â Â Â sort and merge csf for the last time, keeping the array size to minimum |
---|
2151 | Â Â Â Â Â Â CALL usm_merge_and_grow_csf(-1) |
---|
2152 | Â Â Â Â Â Â |
---|
2153 | !--Â Â Â Â Â aggregate csb among processors |
---|
2154 | !--Â Â Â Â Â allocate necessary arrays |
---|
2155 | Â Â Â Â Â Â ALLOCATE(Â csflt(ndcsf,max(ncsfl,ndcsf))Â ) |
---|
2156 | Â Â Â Â Â Â ALLOCATE(Â kcsflt(kdcsf,max(ncsfl,kdcsf))Â ) |
---|
2157 | Â Â Â Â Â Â ALLOCATE(Â icsflt(0:numprocs-1)Â ) |
---|
2158 | Â Â Â Â Â Â ALLOCATE(Â dcsflt(0:numprocs-1)Â ) |
---|
2159 | Â Â Â Â Â Â ALLOCATE(Â ipcsflt(0:numprocs-1)Â ) |
---|
2160 | Â Â Â Â Â Â ALLOCATE(Â dpcsflt(0:numprocs-1)Â ) |
---|
2161 | Â Â Â Â Â Â |
---|
2162 | !--Â Â Â Â Â fill out arrays of csf values and |
---|
2163 | !--Â Â Â Â Â arrays of number of elements and displacements |
---|
2164 | !--Â Â Â Â Â for particular precessors |
---|
2165 |       icsflt = 0 |
---|
2166 |       dcsflt = 0 |
---|
2167 |       ip = -1 |
---|
2168 |       j = -1 |
---|
2169 |       d = 0 |
---|
2170 |       DO kcsf = 1, ncsfl |
---|
2171 |         j = j+1 |
---|
2172 |         IF ( acsf(kcsf)%ip /= ip ) THEN |
---|
2173 | !--Â Â Â Â Â Â Â Â Â new block of the processor |
---|
2174 | !--Â Â Â Â Â Â Â Â Â number of elements of previous block |
---|
2175 | Â Â Â Â Â Â Â Â Â Â IFÂ (Â ip>=0)Â icsflt(ip)Â =Â j |
---|
2176 |           d = d+j |
---|
2177 | !--Â Â Â Â Â Â Â Â Â blank blocks |
---|
2178 |           DO jp = ip+1, acsf(kcsf)%ip-1 |
---|
2179 | !--Â Â Â Â Â Â Â Â Â Â Â number of elements is zero, displacement is equal to previous |
---|
2180 | Â Â Â Â Â Â Â Â Â Â Â Â icsflt(jp)Â =Â 0 |
---|
2181 | Â Â Â Â Â Â Â Â Â Â Â Â dcsflt(jp)Â =Â d |
---|
2182 | Â Â Â Â Â Â Â Â Â Â ENDDO |
---|
2183 | !--Â Â Â Â Â Â Â Â Â the actual block |
---|
2184 |           ip = acsf(kcsf)%ip |
---|
2185 | Â Â Â Â Â Â Â Â Â Â dcsflt(ip)Â =Â d |
---|
2186 |           j = 0 |
---|
2187 | Â Â Â Â Â Â Â Â ENDIF |
---|
2188 | !--Â Â Â Â Â Â Â fill out real values of rsvf, rtransp |
---|
2189 | Â Â Â Â Â Â Â Â csflt(1,kcsf)Â =Â acsf(kcsf)%rsvf |
---|
2190 | Â Â Â Â Â Â Â Â csflt(2,kcsf)Â =Â acsf(kcsf)%rtransp |
---|
2191 | !--Â Â Â Â Â Â Â fill out integer values of itz,ity,itx,isurfs |
---|
2192 | Â Â Â Â Â Â Â Â kcsflt(1,kcsf)Â =Â acsf(kcsf)%itz |
---|
2193 | Â Â Â Â Â Â Â Â kcsflt(2,kcsf)Â =Â acsf(kcsf)%ity |
---|
2194 | Â Â Â Â Â Â Â Â kcsflt(3,kcsf)Â =Â acsf(kcsf)%itx |
---|
2195 | Â Â Â Â Â Â Â Â kcsflt(4,kcsf)Â =Â acsf(kcsf)%isurfs |
---|
2196 | Â Â Â Â Â Â ENDDO |
---|
2197 | !--Â Â Â Â Â last blank blocks at the end of array |
---|
2198 |       j = j+1 |
---|
2199 | Â Â Â Â Â Â IFÂ (Â ip>=0Â )Â icsflt(ip)Â =Â j |
---|
2200 |       d = d+j |
---|
2201 |       DO jp = ip+1, numprocs-1 |
---|
2202 | !--Â Â Â Â Â Â Â number of elements is zero, displacement is equal to previous |
---|
2203 | Â Â Â Â Â Â Â Â icsflt(jp)Â =Â 0 |
---|
2204 | Â Â Â Â Â Â Â Â dcsflt(jp)Â =Â d |
---|
2205 | Â Â Â Â Â Â ENDDO |
---|
2206 | Â Â Â Â Â Â |
---|
2207 | !--Â Â Â Â Â deallocate temporary acsf array |
---|
2208 | !--Â Â Â Â Â DEALLOCATE(acsf) - ifort has a problem with deallocation of allocatable target |
---|
2209 | !--Â Â Â Â Â via pointing pointer - we need to test original targets |
---|
2210 | Â Â Â Â Â Â IFÂ (Â ALLOCATED(acsf1)Â )Â THEN |
---|
2211 | Â Â Â Â Â Â Â Â DEALLOCATE(acsf1) |
---|
2212 | Â Â Â Â Â Â ENDIF |
---|
2213 | Â Â Â Â Â Â IFÂ (Â ALLOCATED(acsf2)Â )Â THEN |
---|
2214 | Â Â Â Â Â Â Â Â DEALLOCATE(acsf2) |
---|
2215 | Â Â Â Â Â Â ENDIF |
---|
2216 | Â Â Â Â Â Â Â Â Â Â |
---|
2217 | #if defined( __parallel ) |
---|
2218 | !--Â Â Â Â Â scatter and gather the number of elements to and from all processor |
---|
2219 | !--Â Â Â Â Â and calculate displacements |
---|
2220 |       CALL MPI_AlltoAll(icsflt,1,MPI_INTEGER,ipcsflt,1,MPI_INTEGER,comm2d, ierr) |
---|
2221 | Â Â Â Â Â Â |
---|
2222 |       npcsfl = SUM(ipcsflt) |
---|
2223 |       d = 0 |
---|
2224 |       DO i = 0, numprocs-1 |
---|
2225 | Â Â Â Â Â Â Â Â dpcsflt(i)Â =Â d |
---|
2226 |         d = d + ipcsflt(i) |
---|
2227 | Â Â Â Â Â Â ENDDO |
---|
2228 | Â Â Â Â |
---|
2229 | !--Â Â Â Â Â exchange csf fields between processors |
---|
2230 | Â Â Â Â Â Â ALLOCATE(Â pcsflt(ndcsf,max(npcsfl,ndcsf))Â ) |
---|
2231 | Â Â Â Â Â Â ALLOCATE(Â kpcsflt(kdcsf,max(npcsfl,kdcsf))Â ) |
---|
2232 |       CALL MPI_AlltoAllv(csflt, ndcsf*icsflt, ndcsf*dcsflt, MPI_REAL, & |
---|
2233 |         pcsflt, ndcsf*ipcsflt, ndcsf*dpcsflt, MPI_REAL, comm2d, ierr) |
---|
2234 |       CALL MPI_AlltoAllv(kcsflt, kdcsf*icsflt, kdcsf*dcsflt, MPI_INTEGER, & |
---|
2235 |         kpcsflt, kdcsf*ipcsflt, kdcsf*dpcsflt, MPI_INTEGER, comm2d, ierr) |
---|
2236 | Â Â Â Â Â Â |
---|
2237 | #else |
---|
2238 |       npcsfl = ncsfl |
---|
2239 | Â Â Â Â Â Â ALLOCATE(Â pcsflt(ndcsf,max(npcsfl,ndcsf))Â ) |
---|
2240 | Â Â Â Â Â Â ALLOCATE(Â kpcsflt(kdcsf,max(npcsfl,kdcsf))Â ) |
---|
2241 |       pcsflt = csflt |
---|
2242 |       kpcsflt = kcsflt |
---|
2243 | #endif |
---|
2244 | |
---|
2245 | !--Â Â Â Â Â deallocate temporary arrays |
---|
2246 |       DEALLOCATE( csflt ) |
---|
2247 |       DEALLOCATE( kcsflt ) |
---|
2248 |       DEALLOCATE( icsflt ) |
---|
2249 |       DEALLOCATE( dcsflt ) |
---|
2250 |       DEALLOCATE( ipcsflt ) |
---|
2251 |       DEALLOCATE( dpcsflt ) |
---|
2252 | |
---|
2253 | !--Â Â Â Â Â sort csf ( a version of quicksort ) |
---|
2254 |       CALL quicksort_csf2(kpcsflt, pcsflt, 1, npcsfl) |
---|
2255 | |
---|
2256 | !--Â Â Â Â Â aggregate canopy sink factor records with identical box & source |
---|
2257 | !--Â Â Â Â Â againg across all values from all processors |
---|
2258 |       IF ( npcsfl > 0 ) THEN |
---|
2259 |         icsf = 1 !< reading index |
---|
2260 |         kcsf = 1 !< writing index |
---|
2261 |         DO while (icsf < npcsfl) |
---|
2262 | !--Â Â Â Â Â Â Â Â Â here kpcsf(kcsf) already has values from kpcsf(icsf) |
---|
2263 |           IF ( kpcsflt(3,icsf) == kpcsflt(3,icsf+1) .AND. & |
---|
2264 |              kpcsflt(2,icsf) == kpcsflt(2,icsf+1) .AND. & |
---|
2265 |              kpcsflt(1,icsf) == kpcsflt(1,icsf+1) .AND. & |
---|
2266 | Â Â Â Â Â Â Â Â Â Â Â Â Â kpcsflt(4,icsf)Â ==Â kpcsflt(4,icsf+1)Â )Â THEN |
---|
2267 | !--Â Â Â Â Â Â Â Â Â Â Â We could simply take either first or second rtransp, both are valid. As a very simple heuristic about which ray |
---|
2268 | !--Â Â Â Â Â Â Â Â Â Â Â probably passes nearer the center of the target box, we choose DIF from the entry with greater CSF, since that |
---|
2269 | !--Â Â Â Â Â Â Â Â Â Â Â might mean that the traced beam passes longer through the canopy box. |
---|
2270 | Â Â Â Â Â Â Â Â Â Â Â Â IFÂ (Â pcsflt(1,kcsf)Â <Â pcsflt(1,icsf+1)Â )Â THEN |
---|
2271 | Â Â Â Â Â Â Â Â Â Â Â Â Â Â pcsflt(2,kcsf)Â =Â pcsflt(2,icsf+1) |
---|
2272 | Â Â Â Â Â Â Â Â Â Â Â Â ENDIF |
---|
2273 | Â Â Â Â Â Â Â Â Â Â Â Â pcsflt(1,kcsf)Â =Â pcsflt(1,kcsf)Â +Â pcsflt(1,icsf+1) |
---|
2274 | |
---|
2275 | !--Â Â Â Â Â Â Â Â Â Â Â advance reading index, keep writing index |
---|
2276 |             icsf = icsf + 1 |
---|
2277 | Â Â Â Â Â Â Â Â Â Â ELSE |
---|
2278 | !--Â Â Â Â Â Â Â Â Â Â Â not identical, just advance and copy |
---|
2279 |             icsf = icsf + 1 |
---|
2280 |             kcsf = kcsf + 1 |
---|
2281 | Â Â Â Â Â Â Â Â Â Â Â Â kpcsflt(:,kcsf)Â =Â kpcsflt(:,icsf) |
---|
2282 | Â Â Â Â Â Â Â Â Â Â Â Â pcsflt(:,kcsf)Â =Â pcsflt(:,icsf) |
---|
2283 | Â Â Â Â Â Â Â Â Â Â ENDIF |
---|
2284 | Â Â Â Â Â Â Â Â ENDDO |
---|
2285 | !--Â Â Â Â Â Â Â last written item is now also the last item in valid part of array |
---|
2286 |         npcsfl = kcsf |
---|
2287 | Â Â Â Â Â Â ENDIF |
---|
2288 | |
---|
2289 |       ncsfl = npcsfl |
---|
2290 |       IF ( ncsfl > 0 ) THEN |
---|
2291 | Â Â Â Â Â Â Â Â ALLOCATE(Â csf(ndcsf,ncsfl)Â ) |
---|
2292 | Â Â Â Â Â Â Â Â ALLOCATE(Â csfsurf(idcsf,ncsfl)Â ) |
---|
2293 |         DO icsf = 1, ncsfl |
---|
2294 | Â Â Â Â Â Â Â Â Â Â csf(:,icsf)Â =Â pcsflt(:,icsf) |
---|
2295 | Â Â Â Â Â Â Â Â Â Â csfsurf(1,icsf)Â =Â gridpcbl(kpcsflt(1,icsf),kpcsflt(2,icsf),kpcsflt(3,icsf)) |
---|
2296 | Â Â Â Â Â Â Â Â Â Â csfsurf(2,icsf)Â =Â kpcsflt(4,icsf) |
---|
2297 | Â Â Â Â Â Â Â Â ENDDO |
---|
2298 | Â Â Â Â Â Â ENDIF |
---|
2299 | Â Â Â Â Â Â |
---|
2300 | !--Â Â Â Â Â deallocation of temporary arrays |
---|
2301 |       DEALLOCATE( pcsflt ) |
---|
2302 |       DEALLOCATE( kpcsflt ) |
---|
2303 | Â Â Â Â Â Â |
---|
2304 | Â Â Â Â ENDIF |
---|
2305 | Â Â Â Â |
---|
2306 | Â Â Â Â RETURN |
---|
2307 | Â Â Â Â |
---|
2308 | 301   WRITE( message_string, * ) & |
---|
2309 |       'I/O error when processing shape view factors / ', & |
---|
2310 | Â Â Â Â Â Â 'plant canopy sink factors / direct irradiance factors.' |
---|
2311 |     CALL message( 'init_urban_surface', 'PA0502', 2, 2, 0, 6, 0 ) |
---|
2312 | Â Â Â Â |
---|
2313 | Â Â END SUBROUTINE usm_calc_svf |
---|
2314 | |
---|
2315 | |
---|
2316 | !------------------------------------------------------------------------------! |
---|
2317 | ! |
---|
2318 | ! Description: |
---|
2319 | ! ------------ |
---|
2320 | !> Subroutine checks variables and assigns units. |
---|
2321 | !> It is caaled out from subroutine check_parameters. |
---|
2322 | !------------------------------------------------------------------------------! |
---|
2323 |   SUBROUTINE usm_check_data_output( variable, unit ) |
---|
2324 | Â Â Â Â |
---|
2325 | Â Â Â Â IMPLICIT NONE |
---|
2326 | Â |
---|
2327 |     CHARACTER (len=*),INTENT(IN)  :: variable !: |
---|
2328 |     CHARACTER (len=*),INTENT(OUT)  :: unit   !: |
---|
2329 | Â Â Â Â |
---|
2330 | Â Â Â Â CHARACTERÂ (len=varnamelength)Â Â ::Â var |
---|
2331 | |
---|
2332 |     var = TRIM(variable) |
---|
2333 |     IF ( var(1:12) == 'usm_rad_net_' .OR. var(1:13) == 'usm_rad_insw_' .OR.    & |
---|
2334 |        var(1:13) == 'usm_rad_inlw_' .OR. var(1:16) == 'usm_rad_inswdir_' .OR.  & |
---|
2335 |        var(1:16) == 'usm_rad_inswdif_' .OR. var(1:16) == 'usm_rad_inswref_' .OR. & |
---|
2336 |        var(1:16) == 'usm_rad_inlwdif_' .OR. var(1:16) == 'usm_rad_inlwref_' .OR. & |
---|
2337 |        var(1:14) == 'usm_rad_outsw_' .OR. var(1:14) == 'usm_rad_outlw_' .OR.   & |
---|
2338 |        var(1:14) == 'usm_rad_ressw_' .OR. var(1:14) == 'usm_rad_reslw_' .OR.   & |
---|
2339 |        var(1:11) == 'usm_rad_hf_' .OR.                       & |
---|
2340 |        var(1:9) == 'usm_wshf_' .OR. var(1:9) == 'usm_wghf_' ) THEN |
---|
2341 |       unit = 'W/m2' |
---|
2342 |     ELSE IF ( var(1:10) == 'usm_t_surf' .OR. var(1:10) == 'usm_t_wall' ) THEN |
---|
2343 |       unit = 'K' |
---|
2344 |     ELSE IF ( var(1:9) == 'usm_surfz' .OR. var(1:7) == 'usm_svf' .OR.       & |
---|
2345 |          var(1:7) == 'usm_dif' .OR. var(1:11) == 'usm_surfcat' .OR.      & |
---|
2346 |          var(1:11) == 'usm_surfalb' .OR. var(1:12) == 'usm_surfemis') THEN |
---|
2347 |       unit = '1' |
---|
2348 | Â Â Â Â ELSE |
---|
2349 |       unit = 'illegal' |
---|
2350 | Â Â Â Â ENDIF |
---|
2351 | |
---|
2352 | Â Â END SUBROUTINE usm_check_data_output |
---|
2353 | |
---|
2354 | |
---|
2355 | !------------------------------------------------------------------------------! |
---|
2356 | ! Description: |
---|
2357 | ! ------------ |
---|
2358 | !> Check parameters routine for urban surface model |
---|
2359 | !------------------------------------------------------------------------------! |
---|
2360 | Â Â SUBROUTINE usm_check_parameters |
---|
2361 | Â Â |
---|
2362 |     USE control_parameters,                         & |
---|
2363 |       ONLY: bc_pt_b, bc_q_b, constant_flux_layer, large_scale_forcing,  & |
---|
2364 |          lsf_surf, topography |
---|
2365 | |
---|
2366 | ! |
---|
2367 | !--Â Â Dirichlet boundary conditions are required as the surface fluxes are |
---|
2368 | !--Â Â calculated from the temperature/humidity gradients in the urban surface |
---|
2369 | !--Â Â model |
---|
2370 |     IF ( bc_pt_b == 'neumann'  .OR.  bc_q_b == 'neumann' ) THEN |
---|
2371 |      message_string = 'urban surface model requires setting of '//    & |
---|
2372 | Â Â Â Â Â Â Â Â Â Â Â Â Â Â 'bc_pt_b = "dirichlet" and '//Â Â Â Â Â Â Â Â Â Â Â & |
---|
2373 |               'bc_q_b = "dirichlet"' |
---|
2374 |      CALL message( 'check_parameters', 'PA0590', 1, 2, 0, 6, 0 ) |
---|
2375 | Â Â Â Â ENDIF |
---|
2376 | |
---|
2377 |     IF ( .NOT. constant_flux_layer ) THEN |
---|
2378 |      message_string = 'urban surface model requires '//          & |
---|
2379 | Â Â Â Â Â Â Â Â Â Â Â Â Â Â 'constant_flux_layer = .T.' |
---|
2380 |      CALL message( 'check_parameters', 'PA0591', 1, 2, 0, 6, 0 ) |
---|
2381 | Â Â Â Â ENDIF |
---|
2382 | !    |
---|
2383 | !--Â Â Surface forcing has to be disabled for LSF in case of enabled |
---|
2384 | !--Â Â urban surface module |
---|
2385 |     IF ( large_scale_forcing ) THEN |
---|
2386 |      lsf_surf = .FALSE. |
---|
2387 | Â Â Â Â ENDIF |
---|
2388 | ! |
---|
2389 | !--Â Â Topography |
---|
2390 |     IF ( topography == 'flat' ) THEN |
---|
2391 |      message_string = 'topography /= "flat" is required '//        & |
---|
2392 | Â Â Â Â Â Â Â Â Â Â Â Â Â Â 'when using the urban surface model' |
---|
2393 |      CALL message( 'check_parameters', 'PA0592', 1, 2, 0, 6, 0 ) |
---|
2394 | Â Â Â Â ENDIF |
---|
2395 | |
---|
2396 | |
---|
2397 | Â Â END SUBROUTINE usm_check_parameters |
---|
2398 | |
---|
2399 | |
---|
2400 | !------------------------------------------------------------------------------! |
---|
2401 | ! |
---|
2402 | ! Description: |
---|
2403 | ! ------------ |
---|
2404 | !> Output of the 3D-arrays in netCDF and/or AVS format |
---|
2405 | !> for variables of urban_surface model. |
---|
2406 | !> It resorts the urban surface module output quantities from surf style |
---|
2407 | !> indexing into temporary 3D array with indices (i,j,k). |
---|
2408 | !> It is called from subroutine data_output_3d. |
---|
2409 | !------------------------------------------------------------------------------! |
---|
2410 |   SUBROUTINE usm_data_output_3d( av, variable, found, local_pf, nzb_do, nzt_do ) |
---|
2411 | Â Â Â Â |
---|
2412 | Â Â Â Â IMPLICIT NONE |
---|
2413 | |
---|
2414 |     INTEGER(iwp), INTENT(IN)    :: av    !< |
---|
2415 |     CHARACTER (len=*), INTENT(IN) :: variable !< |
---|
2416 |     INTEGER(iwp), INTENT(IN)    :: nzb_do  !< lower limit of the data output (usually 0) |
---|
2417 |     INTEGER(iwp), INTENT(IN)    :: nzt_do  !< vertical upper limit of the data output (usually nz_do3d) |
---|
2418 |     LOGICAL, INTENT(OUT)      :: found   !< |
---|
2419 |     REAL(sp), DIMENSION(nxlg:nxrg,nysg:nyng,nzb_do:nzt_do) :: local_pf  !< sp - it has to correspond to module data_output_3d |
---|
2420 |     REAL(wp), DIMENSION(nzb:nzt+1,nysg:nyng,nxlg:nxrg)   :: temp_pf  !< temp array for urban surface output procedure |
---|
2421 | Â Â Â Â |
---|
2422 |     CHARACTER (len=varnamelength)             :: var, surfid |
---|
2423 |     INTEGER(iwp), PARAMETER                :: nd = 5 |
---|
2424 |     CHARACTER(len=6), DIMENSION(0:nd-1), PARAMETER     :: dirname = (/ '_roof ', '_south', '_north', '_west ', '_east ' /) |
---|
2425 |     INTEGER(iwp), DIMENSION(0:nd-1), PARAMETER       :: dirint = (/ iroof, isouth, inorth, iwest, ieast /) |
---|
2426 |     INTEGER(iwp), DIMENSION(0:nd-1)            :: dirstart |
---|
2427 |     INTEGER(iwp), DIMENSION(0:nd-1)            :: dirend |
---|
2428 | Â Â Â Â INTEGER(iwp)Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â ::Â ids,isurf,isvf,isurfs,isurflt |
---|
2429 |     INTEGER(iwp)                      :: is,js,ks,i,j,k,iwl,istat, l, m |
---|
2430 |     INTEGER(iwp)                      :: k_topo  !< topography top index |
---|
2431 | |
---|
2432 |     dirstart = (/ startland, startwall, startwall, startwall, startwall /) |
---|
2433 |     dirend = (/ endland, endwall, endwall, endwall, endwall /) |
---|
2434 | |
---|
2435 |     found = .TRUE. |
---|
2436 |     temp_pf = -1._wp |
---|
2437 | Â Â Â Â |
---|
2438 |     ids = -1 |
---|
2439 |     var = TRIM(variable) |
---|
2440 |     DO i = 0, nd-1 |
---|
2441 |       k = len(TRIM(var)) |
---|
2442 |       j = len(TRIM(dirname(i))) |
---|
2443 | Â Â Â Â Â Â IFÂ (Â var(k-j+1:k)Â ==Â dirname(i)Â )Â THEN |
---|
2444 |         ids = i |
---|
2445 |         var = var(:k-j) |
---|
2446 | Â Â Â Â Â Â Â Â EXIT |
---|
2447 | Â Â Â Â Â Â ENDIF |
---|
2448 | Â Â Â Â ENDDO |
---|
2449 |     IF ( ids == -1 ) THEN |
---|
2450 |       var = TRIM(variable) |
---|
2451 | Â Â Â Â ENDIF |
---|
2452 |     IF ( var(1:11) == 'usm_t_wall_' .AND. len(TRIM(var)) >= 12 ) THEN |
---|
2453 | !--Â Â Â Â Â wall layers |
---|
2454 |       READ(var(12:12), '(I1)', iostat=istat ) iwl |
---|
2455 |       IF ( istat == 0 .AND. iwl >= nzb_wall .AND. iwl <= nzt_wall ) THEN |
---|
2456 |         var = var(1:10) |
---|
2457 | Â Â Â Â Â Â ENDIF |
---|
2458 | Â Â Â Â ENDIF |
---|
2459 |     IF ( (var(1:8) == 'usm_svf_' .OR. var(1:8) == 'usm_dif_') .AND. len(TRIM(var)) >= 13 ) THEN |
---|
2460 | !--Â Â Â Â Â svf values to particular surface |
---|
2461 |       surfid = var(9:) |
---|
2462 |       i = index(surfid,'_') |
---|
2463 |       j = index(surfid(i+1:),'_') |
---|
2464 |       READ(surfid(1:i-1),*, iostat=istat ) is |
---|
2465 |       IF ( istat == 0 ) THEN |
---|
2466 |         READ(surfid(i+1:i+j-1),*, iostat=istat ) js |
---|
2467 | Â Â Â Â Â Â ENDIF |
---|
2468 |       IF ( istat == 0 ) THEN |
---|
2469 |         READ(surfid(i+j+1:),*, iostat=istat ) ks |
---|
2470 | Â Â Â Â Â Â ENDIF |
---|
2471 |       IF ( istat == 0 ) THEN |
---|
2472 |         var = var(1:7) |
---|
2473 | Â Â Â Â Â Â ENDIF |
---|
2474 | Â Â Â Â ENDIF |
---|
2475 | Â Â Â Â |
---|
2476 | Â Â Â Â SELECT CASEÂ (Â TRIM(var)Â ) |
---|
2477 | |
---|
2478 | Â Â Â Â Â CASEÂ (Â 'usm_surfz'Â ) |
---|
2479 | !--Â Â Â Â Â Â array of lw radiation falling to local surface after i-th reflection |
---|
2480 |        DO m = 1, surf_usm_h%ns |
---|
2481 |          i = surf_usm_h%i(m) |
---|
2482 |          j = surf_usm_h%j(m) |
---|
2483 |          k = surf_usm_h%k(m) |
---|
2484 |          temp_pf(0,j,i) = MAX( temp_pf(0,j,i), REAL( k, kind=wp) ) |
---|
2485 | Â Â Â Â Â Â Â ENDDO |
---|
2486 |        DO l = 0, 3 |
---|
2487 |          DO m = 1, surf_usm_v(l)%ns |
---|
2488 |           i = surf_usm_v(l)%i(m) |
---|
2489 |           j = surf_usm_v(l)%j(m) |
---|
2490 |           k = surf_usm_v(l)%k(m) |
---|
2491 |           temp_pf(0,j,i) = MAX( temp_pf(0,j,i), REAL( k, kind=wp) + 1.0_wp ) |
---|
2492 | Â Â Â Â Â Â Â Â Â ENDDO |
---|
2493 | Â Â Â Â Â Â Â ENDDO |
---|
2494 | |
---|
2495 | Â Â Â Â Â CASEÂ (Â 'usm_surfcat'Â ) |
---|
2496 | !--Â Â Â Â Â Â surface category |
---|
2497 |        DO m = 1, surf_usm_h%ns |
---|
2498 |          i = surf_usm_h%i(m) |
---|
2499 |          j = surf_usm_h%j(m) |
---|
2500 |          k = surf_usm_h%k(m) |
---|
2501 | Â Â Â Â Â Â Â Â Â temp_pf(k,j,i)Â =Â surf_usm_h%surface_types(m) |
---|
2502 | Â Â Â Â Â Â Â ENDDO |
---|
2503 |        DO l = 0, 3 |
---|
2504 |          DO m = 1, surf_usm_v(l)%ns |
---|
2505 |           i = surf_usm_v(l)%i(m) |
---|
2506 |           j = surf_usm_v(l)%j(m) |
---|
2507 |           k = surf_usm_v(l)%k(m) |
---|
2508 | Â Â Â Â Â Â Â Â Â Â temp_pf(k,j,i)Â =Â surf_usm_v(l)%surface_types(m) |
---|
2509 | Â Â Â Â Â Â Â Â Â ENDDO |
---|
2510 | Â Â Â Â Â Â Â ENDDO |
---|
2511 | Â Â Â Â Â Â Â |
---|
2512 | Â Â Â Â Â CASEÂ (Â 'usm_surfalb'Â ) |
---|
2513 | !--Â Â Â Â Â Â surface albedo |
---|
2514 |        DO m = 1, surf_usm_h%ns |
---|
2515 |          i = surf_usm_h%i(m) |
---|
2516 |          j = surf_usm_h%j(m) |
---|
2517 |          k = surf_usm_h%k(m) |
---|
2518 | Â Â Â Â Â Â Â Â Â temp_pf(k,j,i)Â =Â surf_usm_h%albedo_surf(m) |
---|
2519 | Â Â Â Â Â Â Â ENDDO |
---|
2520 |        DO l = 0, 3 |
---|
2521 |          DO m = 1, surf_usm_v(l)%ns |
---|
2522 |           i = surf_usm_v(l)%i(m) |
---|
2523 |           j = surf_usm_v(l)%j(m) |
---|
2524 |           k = surf_usm_v(l)%k(m) |
---|
2525 | Â Â Â Â Â Â Â Â Â Â temp_pf(k,j,i)Â =Â surf_usm_v(l)%albedo_surf(m) |
---|
2526 | Â Â Â Â Â Â Â Â Â ENDDO |
---|
2527 | Â Â Â Â Â Â Â ENDDO |
---|
2528 | Â Â Â Â Â Â Â |
---|
2529 | Â Â Â Â Â CASEÂ (Â 'usm_surfemis'Â ) |
---|
2530 | !--Â Â Â Â Â Â surface albedo |
---|
2531 |        DO m = 1, surf_usm_h%ns |
---|
2532 |          i = surf_usm_h%i(m) |
---|
2533 |          j = surf_usm_h%j(m) |
---|
2534 |          k = surf_usm_h%k(m) |
---|
2535 | Â Â Â Â Â Â Â Â Â temp_pf(k,j,i)Â =Â surf_usm_h%emiss_surf(m) |
---|
2536 | Â Â Â Â Â Â Â ENDDO |
---|
2537 |        DO l = 0, 3 |
---|
2538 |          DO m = 1, surf_usm_v(l)%ns |
---|
2539 |           i = surf_usm_v(l)%i(m) |
---|
2540 |           j = surf_usm_v(l)%j(m) |
---|
2541 |           k = surf_usm_v(l)%k(m) |
---|
2542 | Â Â Â Â Â Â Â Â Â Â temp_pf(k,j,i)Â =Â surf_usm_v(l)%emiss_surf(m) |
---|
2543 | Â Â Â Â Â Â Â Â Â ENDDO |
---|
2544 | Â Â Â Â Â Â Â ENDDO |
---|
2545 | ! |
---|
2546 | !-- Not adjusted so far       |
---|
2547 |      CASE ( 'usm_svf', 'usm_dif' ) |
---|
2548 | !--Â Â Â Â Â Â shape view factors or iradiance factors to selected surface |
---|
2549 | Â Â Â Â Â Â Â IFÂ (Â TRIM(var)=='usm_svf'Â )Â THEN |
---|
2550 |          k = 1 |
---|
2551 | Â Â Â Â Â Â Â ELSE |
---|
2552 |          k = 2 |
---|
2553 | Â Â Â Â Â Â Â ENDIF |
---|
2554 |        DO isvf = 1, nsvfl |
---|
2555 |          isurflt = svfsurf(1, isvf) |
---|
2556 |          isurfs = svfsurf(2, isvf) |
---|
2557 | Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â |
---|
2558 |          IF ( surf(ix,isurfs) == is .AND. surf(iy,isurfs) == js .AND.    & |
---|
2559 |             surf(iz,isurfs) == ks .AND. surf(id,isurfs) == ids ) THEN |
---|
2560 | Â !--Â Â Â Â Â Â Â Â Â correct source surface |
---|
2561 | Â Â Â Â Â Â Â Â Â Â Â temp_pf(surfl(iz,isurflt),surfl(iy,isurflt),surfl(ix,isurflt))Â =Â svf(k,isvf) |
---|
2562 | Â Â Â Â Â Â Â Â Â ENDIF |
---|
2563 | Â Â Â Â Â Â Â ENDDO |
---|
2564 | |
---|
2565 | Â Â Â Â Â CASEÂ (Â 'usm_rad_net'Â ) |
---|
2566 | !--Â Â Â Â Â Â array of complete radiation balance |
---|
2567 |        IF ( av == 0 ) THEN |
---|
2568 |          DO m = 1, surf_usm_h%ns |
---|
2569 |           i = surf_usm_h%i(m) |
---|
2570 |           j = surf_usm_h%j(m) |
---|
2571 |           k = surf_usm_h%k(m) |
---|
2572 | Â Â Â Â Â Â Â Â Â Â temp_pf(k,j,i)Â =Â surf_usm_h%rad_net_l(m) |
---|
2573 | Â Â Â Â Â Â Â Â Â ENDDO |
---|
2574 |          DO l = 0, 3 |
---|
2575 |           DO m = 1, surf_usm_v(l)%ns |
---|
2576 |             i = surf_usm_v(l)%i(m) |
---|
2577 |             j = surf_usm_v(l)%j(m) |
---|
2578 |             k = surf_usm_v(l)%k(m) |
---|
2579 | Â Â Â Â Â Â Â Â Â Â Â Â temp_pf(k,j,i)Â =Â surf_usm_v(l)%rad_net_l(m) |
---|
2580 | Â Â Â Â Â Â Â Â Â Â ENDDO |
---|
2581 | Â Â Â Â Â Â Â Â Â ENDDO |
---|
2582 | Â Â Â Â Â Â Â ELSE |
---|
2583 |          DO m = 1, surf_usm_h%ns |
---|
2584 |           i = surf_usm_h%i(m) |
---|
2585 |           j = surf_usm_h%j(m) |
---|
2586 |           k = surf_usm_h%k(m) |
---|
2587 | Â Â Â Â Â Â Â Â Â Â temp_pf(k,j,i)Â =Â surf_usm_h%rad_net_av(m) |
---|
2588 | Â Â Â Â Â Â Â Â Â ENDDO |
---|
2589 |          DO l = 0, 3 |
---|
2590 |           DO m = 1, surf_usm_v(l)%ns |
---|
2591 |             i = surf_usm_v(l)%i(m) |
---|
2592 |             j = surf_usm_v(l)%j(m) |
---|
2593 |             k = surf_usm_v(l)%k(m) |
---|
2594 | Â Â Â Â Â Â Â Â Â Â Â Â temp_pf(k,j,i)Â =Â surf_usm_v(l)%rad_net_av(m) |
---|
2595 | Â Â Â Â Â Â Â Â Â Â ENDDO |
---|
2596 | Â Â Â Â Â Â Â Â Â ENDDO |
---|
2597 | Â Â Â Â Â Â Â ENDIF |
---|
2598 | |
---|
2599 | Â Â Â Â Â CASEÂ (Â 'usm_rad_insw'Â ) |
---|
2600 | !--Â Â Â Â Â Â array of sw radiation falling to surface after i-th reflection |
---|
2601 |        DO isurf = dirstart(ids), dirend(ids) |
---|
2602 |          IF ( surfl(id,isurf) == ids ) THEN |
---|
2603 |           IF ( av == 0 ) THEN |
---|
2604 | Â Â Â Â Â Â Â Â Â Â Â temp_pf(surfl(iz,isurf),surfl(iy,isurf),surfl(ix,isurf))Â =Â surfinsw(isurf) |
---|
2605 | Â Â Â Â Â Â Â Â Â Â ELSE |
---|
2606 | Â Â Â Â Â Â Â Â Â Â Â temp_pf(surfl(iz,isurf),surfl(iy,isurf),surfl(ix,isurf))Â =Â surfinsw_av(isurf) |
---|
2607 | Â Â Â Â Â Â Â Â Â Â ENDIF |
---|
2608 | Â Â Â Â Â Â Â Â Â ENDIF |
---|
2609 | Â Â Â Â Â Â Â ENDDO |
---|
2610 | |
---|
2611 | Â Â Â Â Â CASEÂ (Â 'usm_rad_inlw'Â ) |
---|
2612 | !--Â Â Â Â Â Â array of lw radiation falling to surface after i-th reflection |
---|
2613 |        DO isurf = dirstart(ids), dirend(ids) |
---|
2614 |          IF ( surfl(id,isurf) == ids ) THEN |
---|
2615 |           IF ( av == 0 ) THEN |
---|
2616 | Â Â Â Â Â Â Â Â Â Â Â temp_pf(surfl(iz,isurf),surfl(iy,isurf),surfl(ix,isurf))Â =Â surfinlw(isurf) |
---|
2617 | Â Â Â Â Â Â Â Â Â Â ELSE |
---|
2618 | Â Â Â Â Â Â Â Â Â Â Â temp_pf(surfl(iz,isurf),surfl(iy,isurf),surfl(ix,isurf))Â =Â surfinlw_av(isurf) |
---|
2619 | Â Â Â Â Â Â Â Â Â Â ENDIF |
---|
2620 | Â Â Â Â Â Â Â Â Â ENDIF |
---|
2621 | Â Â Â Â Â Â Â ENDDO |
---|
2622 | |
---|
2623 | Â Â Â Â Â CASEÂ (Â 'usm_rad_inswdir'Â ) |
---|
2624 | !--Â Â Â Â Â Â array of direct sw radiation falling to surface from sun |
---|
2625 |        DO isurf = dirstart(ids), dirend(ids) |
---|
2626 |          IF ( surfl(id,isurf) == ids ) THEN |
---|
2627 |           IF ( av == 0 ) THEN |
---|
2628 | Â Â Â Â Â Â Â Â Â Â Â temp_pf(surfl(iz,isurf),surfl(iy,isurf),surfl(ix,isurf))Â =Â surfinswdir(isurf) |
---|
2629 | Â Â Â Â Â Â Â Â Â Â ELSE |
---|
2630 | Â Â Â Â Â Â Â Â Â Â Â temp_pf(surfl(iz,isurf),surfl(iy,isurf),surfl(ix,isurf))Â =Â surfinswdir_av(isurf) |
---|
2631 | Â Â Â Â Â Â Â Â Â Â ENDIF |
---|
2632 | Â Â Â Â Â Â Â Â Â ENDIF |
---|
2633 | Â Â Â Â Â Â Â ENDDO |
---|
2634 | |
---|
2635 | Â Â Â Â Â CASEÂ (Â 'usm_rad_inswdif'Â ) |
---|
2636 | !--Â Â Â Â Â Â array of difusion sw radiation falling to surface from sky and borders of the domain |
---|
2637 |        DO isurf = dirstart(ids), dirend(ids) |
---|
2638 |          IF ( surfl(id,isurf) == ids ) THEN |
---|
2639 |           IF ( av == 0 ) THEN |
---|
2640 | Â Â Â Â Â Â Â Â Â Â Â temp_pf(surfl(iz,isurf),surfl(iy,isurf),surfl(ix,isurf))Â =Â surfinswdif(isurf) |
---|
2641 | Â Â Â Â Â Â Â Â Â Â ELSE |
---|
2642 | Â Â Â Â Â Â Â Â Â Â Â temp_pf(surfl(iz,isurf),surfl(iy,isurf),surfl(ix,isurf))Â =Â surfinswdif_av(isurf) |
---|
2643 | Â Â Â Â Â Â Â Â Â Â ENDIF |
---|
2644 | Â Â Â Â Â Â Â Â Â ENDIF |
---|
2645 | Â Â Â Â Â Â Â ENDDO |
---|
2646 | |
---|
2647 | Â Â Â Â Â CASEÂ (Â 'usm_rad_inswref'Â ) |
---|
2648 | !--Â Â Â Â Â Â array of sw radiation falling to surface from reflections |
---|
2649 |        DO isurf = dirstart(ids), dirend(ids) |
---|
2650 |          IF ( surfl(id,isurf) == ids ) THEN |
---|
2651 |           IF ( av == 0 ) THEN |
---|
2652 | Â Â Â Â Â Â Â Â Â Â Â temp_pf(surfl(iz,isurf),surfl(iy,isurf),surfl(ix,isurf))Â =Â & |
---|
2653 | Â Â Â Â Â Â Â Â Â Â Â Â surfinsw(isurf)Â -Â surfinswdir(isurf)Â -Â surfinswdif(isurf) |
---|
2654 | Â Â Â Â Â Â Â Â Â Â ELSE |
---|
2655 | Â Â Â Â Â Â Â Â Â Â Â temp_pf(surfl(iz,isurf),surfl(iy,isurf),surfl(ix,isurf))Â =Â surfinswref_av(isurf) |
---|
2656 | Â Â Â Â Â Â Â Â Â Â ENDIF |
---|
2657 | Â Â Â Â Â Â Â Â Â ENDIF |
---|
2658 | Â Â Â Â Â Â Â ENDDO |
---|
2659 | |
---|
2660 | Â Â Â Â Â CASEÂ (Â 'usm_rad_inlwref'Â ) |
---|
2661 | !--Â Â Â Â Â Â array of lw radiation falling to surface from reflections |
---|
2662 |        DO isurf = dirstart(ids), dirend(ids) |
---|
2663 |          IF ( surfl(id,isurf) == ids ) THEN |
---|
2664 |           IF ( av == 0 ) THEN |
---|
2665 | Â Â Â Â Â Â Â Â Â Â Â temp_pf(surfl(iz,isurf),surfl(iy,isurf),surfl(ix,isurf))Â =Â surfinlw(isurf)Â -Â surfinlwdif(isurf) |
---|
2666 | Â Â Â Â Â Â Â Â Â Â ELSE |
---|
2667 | Â Â Â Â Â Â Â Â Â Â Â temp_pf(surfl(iz,isurf),surfl(iy,isurf),surfl(ix,isurf))Â =Â surfinlwref_av(isurf) |
---|
2668 | Â Â Â Â Â Â Â Â Â Â ENDIF |
---|
2669 | Â Â Â Â Â Â Â Â Â ENDIF |
---|
2670 | Â Â Â Â Â Â Â ENDDO |
---|
2671 | |
---|
2672 | Â Â Â Â Â CASEÂ (Â 'usm_rad_outsw'Â ) |
---|
2673 | !--Â Â Â Â Â Â array of sw radiation emitted from surface after i-th reflection |
---|
2674 |        DO isurf = dirstart(ids), dirend(ids) |
---|
2675 |          IF ( surfl(id,isurf) == ids ) THEN |
---|
2676 |           IF ( av == 0 ) THEN |
---|
2677 | Â Â Â Â Â Â Â Â Â Â Â temp_pf(surfl(iz,isurf),surfl(iy,isurf),surfl(ix,isurf))Â =Â surfoutsw(isurf) |
---|
2678 | Â Â Â Â Â Â Â Â Â Â ELSE |
---|
2679 | Â Â Â Â Â Â Â Â Â Â Â temp_pf(surfl(iz,isurf),surfl(iy,isurf),surfl(ix,isurf))Â =Â surfoutsw_av(isurf) |
---|
2680 | Â Â Â Â Â Â Â Â Â Â ENDIF |
---|
2681 | Â Â Â Â Â Â Â Â Â ENDIF |
---|
2682 | Â Â Â Â Â Â Â ENDDO |
---|
2683 | |
---|
2684 | Â Â Â Â Â CASEÂ (Â 'usm_rad_outlw'Â ) |
---|
2685 | !--Â Â Â Â Â Â array of lw radiation emitted from surface after i-th reflection |
---|
2686 |        DO isurf = dirstart(ids), dirend(ids) |
---|
2687 |          IF ( surfl(id,isurf) == ids ) THEN |
---|
2688 |           IF ( av == 0 ) THEN |
---|
2689 | Â Â Â Â Â Â Â Â Â Â Â temp_pf(surfl(iz,isurf),surfl(iy,isurf),surfl(ix,isurf))Â =Â surfoutlw(isurf) |
---|
2690 | Â Â Â Â Â Â Â Â Â Â ELSE |
---|
2691 | Â Â Â Â Â Â Â Â Â Â Â temp_pf(surfl(iz,isurf),surfl(iy,isurf),surfl(ix,isurf))Â =Â surfoutlw_av(isurf) |
---|
2692 | Â Â Â Â Â Â Â Â Â Â ENDIF |
---|
2693 | Â Â Â Â Â Â Â Â Â ENDIF |
---|
2694 | Â Â Â Â Â Â Â ENDDO |
---|
2695 | |
---|
2696 | Â Â Â Â Â CASEÂ (Â 'usm_rad_ressw'Â ) |
---|
2697 | !--Â Â Â Â Â Â average of array of residua of sw radiation absorbed in surface after last reflection |
---|
2698 |        DO isurf = dirstart(ids), dirend(ids) |
---|
2699 |          IF ( surfl(id,isurf) == ids ) THEN |
---|
2700 |           IF ( av == 0 ) THEN |
---|
2701 | Â Â Â Â Â Â Â Â Â Â Â temp_pf(surfl(iz,isurf),surfl(iy,isurf),surfl(ix,isurf))Â =Â surfins(isurf) |
---|
2702 | Â Â Â Â Â Â Â Â Â Â ELSE |
---|
2703 | Â Â Â Â Â Â Â Â Â Â Â temp_pf(surfl(iz,isurf),surfl(iy,isurf),surfl(ix,isurf))Â =Â surfins_av(isurf) |
---|
2704 | Â Â Â Â Â Â Â Â Â Â ENDIF |
---|
2705 | Â Â Â Â Â Â Â Â Â ENDIF |
---|
2706 | Â Â Â Â Â Â Â ENDDO |
---|
2707 | |
---|
2708 | Â Â Â Â Â CASEÂ (Â 'usm_rad_reslw'Â ) |
---|
2709 | !--Â Â Â Â Â Â average of array of residua of lw radiation absorbed in surface after last reflection |
---|
2710 |        DO isurf = dirstart(ids), dirend(ids) |
---|
2711 |          IF ( surfl(id,isurf) == ids ) THEN |
---|
2712 |           IF ( av == 0 ) THEN |
---|
2713 | Â Â Â Â Â Â Â Â Â Â Â temp_pf(surfl(iz,isurf),surfl(iy,isurf),surfl(ix,isurf))Â =Â surfinl(isurf) |
---|
2714 | Â Â Â Â Â Â Â Â Â Â ELSE |
---|
2715 | Â Â Â Â Â Â Â Â Â Â Â temp_pf(surfl(iz,isurf),surfl(iy,isurf),surfl(ix,isurf))Â =Â surfinl_av(isurf) |
---|
2716 | Â Â Â Â Â Â Â Â Â Â ENDIF |
---|
2717 | Â Â Â Â Â Â Â Â Â ENDIF |
---|
2718 | Â Â Â Â Â Â Â ENDDO |
---|
2719 | Â |
---|
2720 | Â Â Â Â Â CASEÂ (Â 'usm_rad_hf'Â ) |
---|
2721 | !--Â Â Â Â Â Â array of heat flux from radiation for surfaces after all reflections |
---|
2722 |        IF ( av == 0 ) THEN |
---|
2723 |          DO m = 1, surf_usm_h%ns |
---|
2724 |           i = surf_usm_h%i(m) |
---|
2725 |           j = surf_usm_h%j(m) |
---|
2726 |           k = surf_usm_h%k(m) |
---|
2727 | Â Â Â Â Â Â Â Â Â Â temp_pf(k,j,i)Â =Â surf_usm_h%surfhf(m) |
---|
2728 | Â Â Â Â Â Â Â Â Â ENDDO |
---|
2729 |          DO l = 0, 3 |
---|
2730 |           DO m = 1, surf_usm_v(l)%ns |
---|
2731 |             i = surf_usm_v(l)%i(m) |
---|
2732 |             j = surf_usm_v(l)%j(m) |
---|
2733 |             k = surf_usm_v(l)%k(m) |
---|
2734 | Â Â Â Â Â Â Â Â Â Â Â Â temp_pf(k,j,i)Â =Â surf_usm_v(l)%surfhf(m) |
---|
2735 | Â Â Â Â Â Â Â Â Â Â ENDDO |
---|
2736 | Â Â Â Â Â Â Â Â Â ENDDO |
---|
2737 | Â Â Â Â Â Â Â ELSE |
---|
2738 |          DO m = 1, surf_usm_h%ns |
---|
2739 |           i = surf_usm_h%i(m) |
---|
2740 |           j = surf_usm_h%j(m) |
---|
2741 |           k = surf_usm_h%k(m) |
---|
2742 | Â Â Â Â Â Â Â Â Â Â temp_pf(k,j,i)Â =Â surf_usm_h%surfhf_av(m) |
---|
2743 | Â Â Â Â Â Â Â Â Â ENDDO |
---|
2744 |          DO l = 0, 3 |
---|
2745 |           DO m = 1, surf_usm_v(l)%ns |
---|
2746 |             i = surf_usm_v(l)%i(m) |
---|
2747 |             j = surf_usm_v(l)%j(m) |
---|
2748 |             k = surf_usm_v(l)%k(m) |
---|
2749 | Â Â Â Â Â Â Â Â Â Â Â Â temp_pf(k,j,i)Â =Â surf_usm_v(l)%surfhf_av(m) |
---|
2750 | Â Â Â Â Â Â Â Â Â Â ENDDO |
---|
2751 | Â Â Â Â Â Â Â Â Â ENDDO |
---|
2752 | Â Â Â Â Â Â Â ENDIF |
---|
2753 | Â |
---|
2754 | Â Â Â Â Â CASEÂ (Â 'usm_wshf'Â ) |
---|
2755 | !--Â Â Â Â Â Â array of sensible heat flux from surfaces |
---|
2756 |        IF ( av == 0 ) THEN |
---|
2757 |          DO m = 1, surf_usm_h%ns |
---|
2758 |           i = surf_usm_h%i(m) |
---|
2759 |           j = surf_usm_h%j(m) |
---|
2760 |           k = surf_usm_h%k(m) |
---|
2761 | Â Â Â Â Â Â Â Â Â Â temp_pf(k,j,i)Â =Â surf_usm_h%wshf_eb(m) |
---|
2762 | Â Â Â Â Â Â Â Â Â ENDDO |
---|
2763 |          DO l = 0, 3 |
---|
2764 |           DO m = 1, surf_usm_v(l)%ns |
---|
2765 |             i = surf_usm_v(l)%i(m) |
---|
2766 |             j = surf_usm_v(l)%j(m) |
---|
2767 |             k = surf_usm_v(l)%k(m) |
---|
2768 | Â Â Â Â Â Â Â Â Â Â Â Â temp_pf(k,j,i)Â =Â surf_usm_v(l)%wshf_eb(m) |
---|
2769 | Â Â Â Â Â Â Â Â Â Â ENDDO |
---|
2770 | Â Â Â Â Â Â Â Â Â ENDDO |
---|
2771 | Â Â Â Â Â Â Â ELSE |
---|
2772 |          DO m = 1, surf_usm_h%ns |
---|
2773 |           i = surf_usm_h%i(m) |
---|
2774 |           j = surf_usm_h%j(m) |
---|
2775 |           k = surf_usm_h%k(m) |
---|
2776 | Â Â Â Â Â Â Â Â Â Â temp_pf(k,j,i)Â =Â surf_usm_h%wshf_eb_av(m) |
---|
2777 | Â Â Â Â Â Â Â Â Â ENDDO |
---|
2778 |          DO l = 0, 3 |
---|
2779 |           DO m = 1, surf_usm_v(l)%ns |
---|
2780 |             i = surf_usm_v(l)%i(m) |
---|
2781 |             j = surf_usm_v(l)%j(m) |
---|
2782 |             k = surf_usm_v(l)%k(m) |
---|
2783 | Â Â Â Â Â Â Â Â Â Â Â Â temp_pf(k,j,i)Â =Â surf_usm_v(l)%wshf_eb_av(m) |
---|
2784 | Â Â Â Â Â Â Â Â Â Â ENDDO |
---|
2785 | Â Â Â Â Â Â Â Â Â ENDDO |
---|
2786 | Â Â Â Â Â Â Â ENDIF |
---|
2787 | |
---|
2788 | |
---|
2789 | Â Â Â Â Â CASEÂ (Â 'usm_wghf'Â ) |
---|
2790 | !--Â Â Â Â Â Â array of heat flux from ground (land, wall, roof) |
---|
2791 |        IF ( av == 0 ) THEN |
---|
2792 |          DO m = 1, surf_usm_h%ns |
---|
2793 |           i = surf_usm_h%i(m) |
---|
2794 |           j = surf_usm_h%j(m) |
---|
2795 |           k = surf_usm_h%k(m) |
---|
2796 | Â Â Â Â Â Â Â Â Â Â temp_pf(k,j,i)Â =Â surf_usm_h%wghf_eb(m) |
---|
2797 | Â Â Â Â Â Â Â Â Â ENDDO |
---|
2798 |          DO l = 0, 3 |
---|
2799 |           DO m = 1, surf_usm_v(l)%ns |
---|
2800 |             i = surf_usm_v(l)%i(m) |
---|
2801 |             j = surf_usm_v(l)%j(m) |
---|
2802 |             k = surf_usm_v(l)%k(m) |
---|
2803 | Â Â Â Â Â Â Â Â Â Â Â Â temp_pf(k,j,i)Â =Â surf_usm_v(l)%wghf_eb(m) |
---|
2804 | Â Â Â Â Â Â Â Â Â Â ENDDO |
---|
2805 | Â Â Â Â Â Â Â Â Â ENDDO |
---|
2806 | Â Â Â Â Â Â Â ELSE |
---|
2807 |          DO m = 1, surf_usm_h%ns |
---|
2808 |           i = surf_usm_h%i(m) |
---|
2809 |           j = surf_usm_h%j(m) |
---|
2810 |           k = surf_usm_h%k(m) |
---|
2811 | Â Â Â Â Â Â Â Â Â Â temp_pf(k,j,i)Â =Â surf_usm_h%wghf_eb_av(m) |
---|
2812 | Â Â Â Â Â Â Â Â Â ENDDO |
---|
2813 |          DO l = 0, 3 |
---|
2814 |           DO m = 1, surf_usm_v(l)%ns |
---|
2815 |             i = surf_usm_v(l)%i(m) |
---|
2816 |             j = surf_usm_v(l)%j(m) |
---|
2817 |             k = surf_usm_v(l)%k(m) |
---|
2818 | Â Â Â Â Â Â Â Â Â Â Â Â temp_pf(k,j,i)Â =Â surf_usm_v(l)%wghf_eb_av(m) |
---|
2819 | Â Â Â Â Â Â Â Â Â Â ENDDO |
---|
2820 | Â Â Â Â Â Â Â Â Â ENDDO |
---|
2821 | Â Â Â Â Â Â Â ENDIF |
---|
2822 | |
---|
2823 | Â Â Â Â Â CASEÂ (Â 'usm_t_surf'Â ) |
---|
2824 | !--Â Â Â Â Â Â surface temperature for surfaces |
---|
2825 |        IF ( av == 0 ) THEN |
---|
2826 |          DO m = 1, surf_usm_h%ns |
---|
2827 |           i = surf_usm_h%i(m) |
---|
2828 |           j = surf_usm_h%j(m) |
---|
2829 |           k = surf_usm_h%k(m) |
---|
2830 | Â Â Â Â Â Â Â Â Â Â temp_pf(k,j,i)Â =Â t_surf_h(m) |
---|
2831 | Â Â Â Â Â Â Â Â Â ENDDO |
---|
2832 |          DO l = 0, 3 |
---|
2833 |           DO m = 1, surf_usm_v(l)%ns |
---|
2834 |             i = surf_usm_v(l)%i(m) |
---|
2835 |             j = surf_usm_v(l)%j(m) |
---|
2836 |             k = surf_usm_v(l)%k(m) |
---|
2837 | Â Â Â Â Â Â Â Â Â Â Â Â temp_pf(k,j,i)Â =Â t_surf_v(l)%t(m) |
---|
2838 | Â Â Â Â Â Â Â Â Â Â ENDDO |
---|
2839 | Â Â Â Â Â Â Â Â Â ENDDO |
---|
2840 | Â Â Â Â Â Â Â ELSE |
---|
2841 |          DO m = 1, surf_usm_h%ns |
---|
2842 |           i = surf_usm_h%i(m) |
---|
2843 |           j = surf_usm_h%j(m) |
---|
2844 |           k = surf_usm_h%k(m) |
---|
2845 | Â Â Â Â Â Â Â Â Â Â temp_pf(k,j,i)Â =Â surf_usm_h%t_surf_av(m) |
---|
2846 | Â Â Â Â Â Â Â Â Â ENDDO |
---|
2847 |          DO l = 0, 3 |
---|
2848 |           DO m = 1, surf_usm_v(l)%ns |
---|
2849 |             i = surf_usm_v(l)%i(m) |
---|
2850 |             j = surf_usm_v(l)%j(m) |
---|
2851 |             k = surf_usm_v(l)%k(m) |
---|
2852 | Â Â Â Â Â Â Â Â Â Â Â Â temp_pf(k,j,i)Â =Â surf_usm_v(l)%t_surf_av(m) |
---|
2853 | Â Â Â Â Â Â Â Â Â Â ENDDO |
---|
2854 | Â Â Â Â Â Â Â Â Â ENDDO |
---|
2855 | Â Â Â Â Â Â Â ENDIF |
---|
2856 | Â Â Â Â Â Â Â |
---|
2857 | Â Â Â Â Â CASEÂ (Â 'usm_t_wall'Â ) |
---|
2858 | !--      wall temperature for iwl layer of walls and land |
---|
2859 |        IF ( av == 0 ) THEN |
---|
2860 |          DO m = 1, surf_usm_h%ns |
---|
2861 |           i = surf_usm_h%i(m) |
---|
2862 |           j = surf_usm_h%j(m) |
---|
2863 |           k = surf_usm_h%k(m) |
---|
2864 | Â Â Â Â Â Â Â Â Â Â temp_pf(k,j,i)Â =Â t_wall_h(iwl,m) |
---|
2865 | Â Â Â Â Â Â Â Â Â ENDDO |
---|
2866 |          DO l = 0, 3 |
---|
2867 |           DO m = 1, surf_usm_v(l)%ns |
---|
2868 |             i = surf_usm_v(l)%i(m) |
---|
2869 |             j = surf_usm_v(l)%j(m) |
---|
2870 |             k = surf_usm_v(l)%k(m) |
---|
2871 | Â Â Â Â Â Â Â Â Â Â Â Â temp_pf(k,j,i)Â =Â t_wall_v(l)%t(iwl,m) |
---|
2872 | Â Â Â Â Â Â Â Â Â Â ENDDO |
---|
2873 | Â Â Â Â Â Â Â Â Â ENDDO |
---|
2874 | Â Â Â Â Â Â Â ELSE |
---|
2875 |          DO m = 1, surf_usm_h%ns |
---|
2876 |           i = surf_usm_h%i(m) |
---|
2877 |           j = surf_usm_h%j(m) |
---|
2878 |           k = surf_usm_h%k(m) |
---|
2879 | Â Â Â Â Â Â Â Â Â Â temp_pf(k,j,i)Â =Â surf_usm_h%t_wall_av(iwl,m) |
---|
2880 | Â Â Â Â Â Â Â Â Â ENDDO |
---|
2881 |          DO l = 0, 3 |
---|
2882 |           DO m = 1, surf_usm_v(l)%ns |
---|
2883 |             i = surf_usm_v(l)%i(m) |
---|
2884 |             j = surf_usm_v(l)%j(m) |
---|
2885 |             k = surf_usm_v(l)%k(m) |
---|
2886 | Â Â Â Â Â Â Â Â Â Â Â Â temp_pf(k,j,i)Â =Â surf_usm_v(l)%t_wall_av(iwl,m) |
---|
2887 | Â Â Â Â Â Â Â Â Â Â ENDDO |
---|
2888 | Â Â Â Â Â Â Â Â Â ENDDO |
---|
2889 | Â Â Â Â Â Â Â ENDIF |
---|
2890 | Â Â Â Â Â Â Â |
---|
2891 | Â Â Â Â Â CASE DEFAULT |
---|
2892 |        found = .FALSE. |
---|
2893 | Â Â Â Â Â Â Â |
---|
2894 | Â Â Â Â END SELECT |
---|
2895 | Â Â Â Â |
---|
2896 | !--Â Â Â fill out array local_pf which is subsequently treated by data_output_3d |
---|
2897 |     CALL exchange_horiz( temp_pf, nbgp ) |
---|
2898 | ! |
---|
2899 | !--Â To Do: why reversed loop order |
---|
2900 |     DO j = nysg,nyng |
---|
2901 |       DO i = nxlg,nxrg |
---|
2902 |         DO k = nzb_do, nzt_do |
---|
2903 | Â Â Â Â Â Â Â Â Â Â local_pf(i,j,k)Â =Â temp_pf(k,j,i) |
---|
2904 | Â Â Â Â Â Â Â Â ENDDO |
---|
2905 | Â Â Â Â Â Â ENDDO |
---|
2906 | Â Â Â Â ENDDO |
---|
2907 | Â Â Â Â |
---|
2908 | Â Â END SUBROUTINE usm_data_output_3d |
---|
2909 | Â Â |
---|
2910 | |
---|
2911 | !------------------------------------------------------------------------------! |
---|
2912 | ! |
---|
2913 | ! Description: |
---|
2914 | ! ------------ |
---|
2915 | !> Soubroutine defines appropriate grid for netcdf variables. |
---|
2916 | !> It is called out from subroutine netcdf. |
---|
2917 | !------------------------------------------------------------------------------! |
---|
2918 |   SUBROUTINE usm_define_netcdf_grid( variable, found, grid_x, grid_y, grid_z ) |
---|
2919 | Â Â |
---|
2920 | Â Â Â Â IMPLICIT NONE |
---|
2921 | |
---|
2922 |     CHARACTER (len=*), INTENT(IN) :: variable  !< |
---|
2923 |     LOGICAL, INTENT(OUT)      :: found    !< |
---|
2924 |     CHARACTER (len=*), INTENT(OUT) :: grid_x   !< |
---|
2925 |     CHARACTER (len=*), INTENT(OUT) :: grid_y   !< |
---|
2926 |     CHARACTER (len=*), INTENT(OUT) :: grid_z   !< |
---|
2927 | |
---|
2928 | Â Â Â Â CHARACTERÂ (len=varnamelength)Â ::Â var |
---|
2929 | |
---|
2930 |     var = TRIM(variable) |
---|
2931 |     IF ( var(1:12) == 'usm_rad_net_' .OR. var(1:13) == 'usm_rad_insw_' .OR.     & |
---|
2932 |        var(1:13) == 'usm_rad_inlw_' .OR. var(1:16) == 'usm_rad_inswdir_' .OR.   & |
---|
2933 |        var(1:16) == 'usm_rad_inswdif_' .OR. var(1:16) == 'usm_rad_inswref_' .OR.  & |
---|
2934 |        var(1:16) == 'usm_rad_inlwdif_' .OR. var(1:16) == 'usm_rad_inlwref_' .OR.  & |
---|
2935 |        var(1:14) == 'usm_rad_outsw_' .OR. var(1:14) == 'usm_rad_outlw_' .OR.    & |
---|
2936 |        var(1:14) == 'usm_rad_ressw_' .OR. var(1:14) == 'usm_rad_reslw_' .OR.    & |
---|
2937 |        var(1:11) == 'usm_rad_hf_' .OR.                        & |
---|
2938 |        var(1:9) == 'usm_wshf_' .OR. var(1:9) == 'usm_wghf_' .OR.          & |
---|
2939 |        var(1:10) == 'usm_t_surf' .OR. var(1:10) == 'usm_t_wall' .OR.        & |
---|
2940 |        var(1:9) == 'usm_surfz' .OR. var(1:7) == 'usm_svf' .OR.           & |
---|
2941 |        var(1:7) == 'usm_dif' .OR. var(1:11) == 'usm_surfcat' .OR.         & |
---|
2942 |        var(1:11) == 'usm_surfalb' .OR. var(1:12) == 'usm_surfemis' ) THEN |
---|
2943 | |
---|
2944 |       found = .TRUE. |
---|
2945 |       grid_x = 'x' |
---|
2946 |       grid_y = 'y' |
---|
2947 |       grid_z = 'zu' |
---|
2948 | Â Â Â Â ELSE |
---|
2949 |       found = .FALSE. |
---|
2950 |       grid_x = 'none' |
---|
2951 |       grid_y = 'none' |
---|
2952 |       grid_z = 'none' |
---|
2953 | Â Â Â Â ENDIF |
---|
2954 | |
---|
2955 | Â Â END SUBROUTINE usm_define_netcdf_grid |
---|
2956 | Â Â |
---|
2957 | Â Â |
---|
2958 | !------------------------------------------------------------------------------! |
---|
2959 | !> Finds first model boundary crossed by a ray |
---|
2960 | !------------------------------------------------------------------------------! |
---|
2961 |   PURE SUBROUTINE usm_find_boundary_face(origin, uvect, bdycross) |
---|
2962 | Â Â |
---|
2963 | Â Â Â Â IMPLICIT NONE |
---|
2964 | Â Â Â Â |
---|
2965 |     INTEGER(iwp) :: d    !< |
---|
2966 |     INTEGER(iwp) :: seldim !< found fist crossing index |
---|
2967 | |
---|
2968 |     INTEGER(iwp), DIMENSION(3)       :: bdyd   !< boundary direction    |
---|
2969 |     INTEGER(iwp), DIMENSION(4), INTENT(out) :: bdycross !< found boundary crossing (d, z, y, x) |
---|
2970 | Â Â Â Â |
---|
2971 |     REAL(wp)                :: bdydim !< |
---|
2972 |     REAL(wp)                :: dist  !< |
---|
2973 | Â Â Â Â |
---|
2974 |     REAL(wp), DIMENSION(3)       :: crossdist !< crossing distance |
---|
2975 |     REAL(wp), DIMENSION(3), INTENT(in) :: origin   !< ray origin |
---|
2976 |     REAL(wp), DIMENSION(3), INTENT(in) :: uvect   !< ray unit vector |
---|
2977 | Â |
---|
2978 | |
---|
2979 |     bdydim    = nzut + .5_wp !< top boundary |
---|
2980 | Â Â Â Â bdyd(1)Â Â Â =Â isky |
---|
2981 |     crossdist(1) = ( bdydim - origin(1) ) / uvect(1) !< subroutine called only when uvect(1)>0 |
---|
2982 | |
---|
2983 |     IF ( uvect(2) == 0._wp ) THEN |
---|
2984 | Â Â Â Â Â crossdist(2)Â =Â huge(1._wp) |
---|
2985 | Â Â Â Â ELSE |
---|
2986 |      IF ( uvect(2) >= 0._wp ) THEN |
---|
2987 |        bdydim = ny + .5_wp !< north global boundary |
---|
2988 | Â Â Â Â Â Â Â bdyd(2)Â =Â inorthb |
---|
2989 | Â Â Â Â Â ELSE |
---|
2990 |        bdydim = -.5_wp !< south global boundary |
---|
2991 | Â Â Â Â Â Â Â bdyd(2)Â =Â isouthb |
---|
2992 | Â Â Â Â Â ENDIF |
---|
2993 |      crossdist(2) = ( bdydim - origin(2) ) / uvect(2) |
---|
2994 | Â Â Â Â ENDIF |
---|
2995 | |
---|
2996 |     IF ( uvect(3) == 0._wp ) THEN |
---|
2997 | Â Â Â Â Â crossdist(3)Â =Â huge(1._wp) |
---|
2998 | Â Â Â Â ELSE |
---|
2999 |      IF ( uvect(3) >= 0._wp ) THEN |
---|
3000 |        bdydim = nx + .5_wp !< east global boundary |
---|
3001 | Â Â Â Â Â Â Â bdyd(3)Â =Â ieastb |
---|
3002 | Â Â Â Â Â ELSE |
---|
3003 |        bdydim = -.5_wp !< west global boundary |
---|
3004 | Â Â Â Â Â Â Â bdyd(3)Â =Â iwestb |
---|
3005 | Â Â Â Â Â ENDIF |
---|
3006 |      crossdist(3) = ( bdydim - origin(3) ) / uvect(3) |
---|
3007 | Â Â Â Â ENDIF |
---|
3008 | |
---|
3009 |     seldim = minloc(crossdist, 1) |
---|
3010 |     dist  = crossdist(seldim) |
---|
3011 |     d   = bdyd(seldim) |
---|
3012 | |
---|
3013 | Â Â Â Â bdycross(1)Â Â =Â d |
---|
3014 |     bdycross(2:4) = NINT( origin(:) + uvect(:) * dist & |
---|
3015 |                     + .5_wp * (/ kdir(d), jdir(d), idir(d) /) ) |
---|
3016 | Â Â Â Â Â Â Â Â Â Â Â Â |
---|
3017 | Â Â END SUBROUTINE |
---|
3018 | |
---|
3019 | |
---|
3020 | !------------------------------------------------------------------------------! |
---|
3021 | !> Determines whether two faces are oriented towards each other |
---|
3022 | !------------------------------------------------------------------------------! |
---|
3023 |   PURE LOGICAL FUNCTION usm_facing(x, y, z, d, x2, y2, z2, d2) |
---|
3024 | Â Â Â Â IMPLICIT NONE |
---|
3025 |     INTEGER(iwp),  INTENT(in) :: x, y, z, d, x2, y2, z2, d2 |
---|
3026 | Â Â Â |
---|
3027 |     usm_facing = .FALSE. |
---|
3028 |     IF ( d==iroof .AND. d2==iroof ) RETURN |
---|
3029 |     IF ( d==isky .AND. d2==isky ) RETURN |
---|
3030 |     IF ( (d==isouth .OR. d==inorthb) .AND. (d2==isouth.OR.d2==inorthb) ) RETURN |
---|
3031 |     IF ( (d==inorth .OR. d==isouthb) .AND. (d2==inorth.OR.d2==isouthb) ) RETURN |
---|
3032 |     IF ( (d==iwest .OR. d==ieastb) .AND. (d2==iwest.OR.d2==ieastb) ) RETURN |
---|
3033 |     IF ( (d==ieast .OR. d==iwestb) .AND. (d2==ieast.OR.d2==iwestb) ) RETURN |
---|
3034 | |
---|
3035 | Â Â Â Â SELECT CASEÂ (d) |
---|
3036 | Â Â Â Â Â Â CASEÂ (iroof)Â Â Â Â Â Â Â Â Â Â !< ground, roof |
---|
3037 |         IF ( z2 < z ) RETURN |
---|
3038 | Â Â Â Â Â Â CASEÂ (isky)Â Â Â Â Â Â Â Â Â Â !< sky |
---|
3039 |         IF ( z2 > z ) RETURN |
---|
3040 |       CASE (isouth, inorthb)     !< south facing |
---|
3041 |         IF ( y2 > y ) RETURN |
---|
3042 |       CASE (inorth, isouthb)     !< north facing |
---|
3043 |         IF ( y2 < y ) RETURN |
---|
3044 |       CASE (iwest, ieastb)      !< west facing |
---|
3045 |         IF ( x2 > x ) RETURN |
---|
3046 |       CASE (ieast, iwestb)      !< east facing |
---|
3047 |         IF ( x2 < x ) RETURN |
---|
3048 | Â Â Â Â END SELECT |
---|
3049 | |
---|
3050 | Â Â Â Â SELECT CASEÂ (d2) |
---|
3051 | Â Â Â Â Â Â CASEÂ (iroof)Â Â Â Â Â Â Â Â Â Â !< ground, roof |
---|
3052 |         IF ( z < z2 ) RETURN |
---|
3053 | Â Â Â Â Â Â CASEÂ (isky)Â Â Â Â Â Â Â Â Â Â !< sky |
---|
3054 |         IF ( z > z2 ) RETURN |
---|
3055 |       CASE (isouth, inorthb)     !< south facing |
---|
3056 |         IF ( y > y2 ) RETURN |
---|
3057 |       CASE (inorth, isouthb)     !< north facing |
---|
3058 |         IF ( y < y2 ) RETURN |
---|
3059 |       CASE (iwest, ieastb)      !< west facing |
---|
3060 |         IF ( x > x2 ) RETURN |
---|
3061 |       CASE (ieast, iwestb)      !< east facing |
---|
3062 |         IF ( x < x2 ) RETURN |
---|
3063 | Â Â Â Â Â Â CASEÂ (-1) |
---|
3064 | Â Â Â Â Â Â Â Â CONTINUE |
---|
3065 | Â Â Â Â END SELECT |
---|
3066 | |
---|
3067 |     usm_facing = .TRUE. |
---|
3068 | Â Â Â Â |
---|
3069 | Â Â END FUNCTION usm_facing |
---|
3070 | Â Â |
---|
3071 | |
---|
3072 | !------------------------------------------------------------------------------! |
---|
3073 | ! Description: |
---|
3074 | ! ------------ |
---|
3075 | !> Initialization of the wall surface model |
---|
3076 | !------------------------------------------------------------------------------! |
---|
3077 | Â Â SUBROUTINE usm_init_material_model |
---|
3078 | |
---|
3079 | Â Â Â Â IMPLICIT NONE |
---|
3080 | |
---|
3081 |     INTEGER(iwp) :: k, l, m      !< running indices |
---|
3082 | Â Â Â Â |
---|
3083 |     CALL location_message( '  initialization of wall surface model', .TRUE. ) |
---|
3084 | Â Â Â Â |
---|
3085 | !--Â Â Â Calculate wall grid spacings. |
---|
3086 | !--Â Â Â Temperature is defined at the center of the wall layers, |
---|
3087 | !--Â Â Â whereas gradients/fluxes are defined at the edges (_stag) |
---|
3088 |     DO k = nzb_wall, nzt_wall |
---|
3089 | Â Â Â Â Â Â zwn(k)Â =Â zwn_default(k) |
---|
3090 | Â Â Â Â ENDDO |
---|
3091 | !    |
---|
3092 | !--Â Â Â apply for all particular surface grids. First for horizontal surfaces |
---|
3093 |     DO m = 1, surf_usm_h%ns |
---|
3094 | Â Â Â Â Â Â surf_usm_h%zw(:,m)Â Â Â Â Â Â Â =Â zwn(:)Â *Â Â Â Â Â Â Â Â Â Â Â Â Â Â & |
---|
3095 | Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â surf_usm_h%thickness_wall(m) |
---|
3096 | Â Â Â Â Â Â surf_usm_h%dz_wall(nzb_wall,m)Â =Â surf_usm_h%zw(nzb_wall,m) |
---|
3097 |       DO k = nzb_wall+1, nzt_wall |
---|
3098 | Â Â Â Â Â Â Â Â surf_usm_h%dz_wall(k,m)Â =Â surf_usm_h%zw(k,m)Â -Â Â Â Â Â Â Â Â Â & |
---|
3099 | Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â surf_usm_h%zw(k-1,m) |
---|
3100 | Â Â Â Â Â Â ENDDO |
---|
3101 | Â Â Â Â Â Â |
---|
3102 | Â Â Â Â Â Â surf_usm_h%dz_wall(nzt_wall+1,m)Â =Â surf_usm_h%dz_wall(nzt_wall,m) |
---|
3103 | |
---|
3104 |       DO k = nzb_wall, nzt_wall-1 |
---|
3105 | Â Â Â Â Â Â Â Â surf_usm_h%dz_wall_stag(k,m)Â =Â 0.5Â *Â (Â Â Â Â Â Â Â Â Â Â Â Â Â & |
---|
3106 | Â Â Â Â Â Â Â Â Â Â Â Â Â Â surf_usm_h%dz_wall(k+1,m)Â +Â surf_usm_h%dz_wall(k,m)Â ) |
---|
3107 | Â Â Â Â Â Â ENDDO |
---|
3108 | Â Â Â Â Â Â surf_usm_h%dz_wall_stag(nzt_wall,m)Â =Â surf_usm_h%dz_wall(nzt_wall,m) |
---|
3109 | Â Â Â Â ENDDO |
---|
3110 |     surf_usm_h%ddz_wall   = 1.0_wp / surf_usm_h%dz_wall |
---|
3111 |     surf_usm_h%ddz_wall_stag = 1.0_wp / surf_usm_h%dz_wall_stag |
---|
3112 | !    |
---|
3113 | !--Â Â Â For vertical surfaces |
---|
3114 |     DO l = 0, 3 |
---|
3115 |       DO m = 1, surf_usm_v(l)%ns |
---|
3116 | Â Â Â Â Â Â Â surf_usm_v(l)%zw(:,m)Â Â Â Â Â Â Â =Â zwn(:)Â *Â Â Â Â Â Â Â Â Â Â Â & |
---|
3117 | Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â surf_usm_v(l)%thickness_wall(m) |
---|
3118 | Â Â Â Â Â Â Â surf_usm_v(l)%dz_wall(nzb_wall,m)Â =Â surf_usm_v(l)%zw(nzb_wall,m) |
---|
3119 |        DO k = nzb_wall+1, nzt_wall |
---|
3120 | Â Â Â Â Â Â Â Â Â surf_usm_v(l)%dz_wall(k,m)Â =Â surf_usm_v(l)%zw(k,m)Â -Â Â Â Â Â & |
---|
3121 | Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â surf_usm_v(l)%zw(k-1,m) |
---|
3122 | Â Â Â Â Â Â Â ENDDO |
---|
3123 | Â Â Â Â Â Â |
---|
3124 | Â Â Â Â Â Â Â surf_usm_v(l)%dz_wall(nzt_wall+1,m)Â =Â Â Â Â Â Â Â Â Â Â Â Â Â Â & |
---|
3125 | Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â surf_usm_v(l)%dz_wall(nzt_wall,m) |
---|
3126 | |
---|
3127 |        DO k = nzb_wall, nzt_wall-1 |
---|
3128 | Â Â Â Â Â Â Â Â Â surf_usm_v(l)%dz_wall_stag(k,m)Â =Â 0.5Â *Â (Â Â Â Â Â Â Â Â Â Â & |
---|
3129 | Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â surf_usm_v(l)%dz_wall(k+1,m)Â +Â & |
---|
3130 | Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â surf_usm_v(l)%dz_wall(k,m)Â ) |
---|
3131 | Â Â Â Â Â Â Â ENDDO |
---|
3132 | Â Â Â Â Â Â Â surf_usm_v(l)%dz_wall_stag(nzt_wall,m)Â =Â Â Â Â Â Â Â Â Â Â Â Â Â & |
---|
3133 | Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â surf_usm_v(l)%dz_wall(nzt_wall,m) |
---|
3134 | Â Â Â Â Â Â ENDDO |
---|
3135 |       surf_usm_v(l)%ddz_wall   = 1.0_wp / surf_usm_v(l)%dz_wall |
---|
3136 |       surf_usm_v(l)%ddz_wall_stag = 1.0_wp / surf_usm_v(l)%dz_wall_stag |
---|
3137 | Â Â Â Â ENDDOÂ Â Â |
---|
3138 | |
---|
3139 | Â Â Â Â |
---|
3140 |     CALL location_message( '  wall structures filed out', .TRUE. ) |
---|
3141 | |
---|
3142 |     CALL location_message( '  initialization of wall surface model finished', .TRUE. ) |
---|
3143 | |
---|
3144 | Â Â END SUBROUTINE usm_init_material_model |
---|
3145 | |
---|
3146 | Â |
---|
3147 | !------------------------------------------------------------------------------! |
---|
3148 | ! Description: |
---|
3149 | ! ------------ |
---|
3150 | !> Initialization of the urban surface model |
---|
3151 | !------------------------------------------------------------------------------! |
---|
3152 | Â Â SUBROUTINE usm_init_urban_surface |
---|
3153 | Â Â |
---|
3154 | Â Â Â Â IMPLICIT NONE |
---|
3155 | |
---|
3156 |     INTEGER(iwp) :: i, j, k, l, m      !< running indices |
---|
3157 |     REAL(wp)   :: c, d, tin, exn |
---|
3158 | Â Â Â Â |
---|
3159 | |
---|
3160 |     CALL cpu_log( log_point_s(78), 'usm_init', 'start' ) |
---|
3161 | !--Â Â Â surface forcing have to be disabled for LSF |
---|
3162 | !--Â Â Â in case of enabled urban surface module |
---|
3163 |     IF ( large_scale_forcing ) THEN |
---|
3164 |       lsf_surf = .FALSE. |
---|
3165 | Â Â Â Â ENDIF |
---|
3166 | Â Â Â Â |
---|
3167 | !--Â Â Â init anthropogenic sources of heat |
---|
3168 | Â Â Â Â CALL usm_allocate_urban_surface() |
---|
3169 | Â Â Â Â |
---|
3170 | !--Â Â Â read the surface_types array somewhere |
---|
3171 | Â Â Â Â CALL usm_read_urban_surface_types() |
---|
3172 | Â Â Â Â |
---|
3173 | !--Â Â Â init material heat model |
---|
3174 | Â Â Â Â CALL usm_init_material_model() |
---|
3175 | Â Â Â Â |
---|
3176 |     IF ( usm_anthropogenic_heat ) THEN |
---|
3177 | !--Â Â Â Â Â init anthropogenic sources of heat (from transportation for now) |
---|
3178 | Â Â Â Â Â Â CALL usm_read_anthropogenic_heat() |
---|
3179 | Â Â Â Â ENDIF |
---|
3180 | Â Â Â Â |
---|
3181 |     IF ( read_svf_on_init ) THEN |
---|
3182 | !--Â Â Â Â Â read svf, csf, svfsurf and csfsurf data from file |
---|
3183 |       CALL location_message( '  Start reading SVF from file', .TRUE. ) |
---|
3184 | Â Â Â Â Â Â CALL usm_read_svf_from_file() |
---|
3185 |       CALL location_message( '  Reading SVF from file has finished', .TRUE. ) |
---|
3186 | Â Â Â Â ELSE |
---|
3187 | !--Â Â Â Â Â calculate SFV and CSF |
---|
3188 |       CALL location_message( '  Start calculation of SVF', .TRUE. ) |
---|
3189 |       CALL cpu_log( log_point_s(79), 'usm_calc_svf', 'start' ) |
---|
3190 | Â Â Â Â Â Â CALL usm_calc_svf() |
---|
3191 |       CALL cpu_log( log_point_s(79), 'usm_calc_svf', 'stop' ) |
---|
3192 |       CALL location_message( '  Calculation of SVF has finished', .TRUE. ) |
---|
3193 | Â Â Â Â ENDIF |
---|
3194 | |
---|
3195 |     IF ( write_svf_on_init ) THEN |
---|
3196 | !--Â Â Â Â Â write svf, csf svfsurf and csfsurf data to file |
---|
3197 |       CALL location_message( '  Store SVF and CSF to file', .TRUE. ) |
---|
3198 | Â Â Â Â Â Â CALL usm_write_svf_to_file() |
---|
3199 | Â Â Â Â ENDIF |
---|
3200 | Â Â Â Â |
---|
3201 |     IF ( plant_canopy ) THEN |
---|
3202 | !--Â Â Â Â Â gridpcbl was only necessary for initialization |
---|
3203 |       DEALLOCATE( gridpcbl ) |
---|
3204 |       IF ( .NOT. ALLOCATED(pc_heating_rate) ) THEN |
---|
3205 | !--Â Â Â Â Â Â Â then pc_heating_rate is allocated in init_plant_canopy |
---|
3206 | !--Â Â Â Â Â Â Â in case of cthf /= 0 => we need to allocate it for our use here |
---|
3207 | Â Â Â Â Â Â Â Â ALLOCATE(Â pc_heating_rate(nzb:nzt+1,nysg:nyng,nxlg:nxrg)Â ) |
---|
3208 | Â Â Â Â Â Â ENDIF |
---|
3209 | Â Â Â Â ENDIF |
---|
3210 | |
---|
3211 | !--Â Â Â Intitialization of the surface and wall/ground/roof temperature |
---|
3212 | |
---|
3213 | !--Â Â Â Initialization for restart runs |
---|
3214 |     IF ( TRIM( initializing_actions ) /= 'read_restart_data' .AND.    & |
---|
3215 |        TRIM( initializing_actions ) /= 'cyclic_fill' ) THEN |
---|
3216 | Â Â Â Â |
---|
3217 | !--Â Â Â Â Â Calculate initial surface temperature from pt of adjacent gridbox |
---|
3218 |       exn = ( surface_pressure / 1000.0_wp )**0.286_wp |
---|
3219 | |
---|
3220 | ! |
---|
3221 | !--Â Â Â Â Â At horizontal surfaces. Please note, t_surf_h is defined on a |
---|
3222 | !--Â Â Â Â Â different data type, but with the same dimension. |
---|
3223 |       DO m = 1, surf_usm_h%ns |
---|
3224 |         i = surf_usm_h%i(m)      |
---|
3225 |         j = surf_usm_h%j(m) |
---|
3226 |         k = surf_usm_h%k(m) |
---|
3227 | |
---|
3228 | Â Â Â Â Â Â Â Â t_surf_h(m)Â =Â pt(k,j,i)Â *Â exn |
---|
3229 | Â Â Â Â Â Â ENDDO |
---|
3230 | ! |
---|
3231 | !--Â Â Â Â Â At vertical surfaces. |
---|
3232 |       DO l = 0, 3 |
---|
3233 |         DO m = 1, surf_usm_v(l)%ns |
---|
3234 |          i = surf_usm_v(l)%i(m)      |
---|
3235 |          j = surf_usm_v(l)%j(m) |
---|
3236 |          k = surf_usm_v(l)%k(m) |
---|
3237 | |
---|
3238 | Â Â Â Â Â Â Â Â Â t_surf_v(l)%t(m)Â =Â pt(k,j,i)Â *Â exn |
---|
3239 | Â Â Â Â Â Â Â Â ENDDO |
---|
3240 | Â Â Â Â Â Â ENDDO |
---|
3241 | |
---|
3242 | Â Â Â |
---|
3243 | !--Â Â Â Â Â initial values for t_wall |
---|
3244 | !--Â Â Â Â Â outer value is set to surface temperature |
---|
3245 | !--Â Â Â Â Â inner value is set to wall_inner_temperature |
---|
3246 | !--Â Â Â Â Â and profile is logaritmic (linear in nz). |
---|
3247 | !--Â Â Â Â Â Horizontal surfaces |
---|
3248 |       DO m = 1, surf_usm_h%ns |
---|
3249 | ! |
---|
3250 | !--Â Â Â Â Â Â Roof |
---|
3251 | Â Â Â Â Â Â Â Â IFÂ (Â surf_usm_h%isroof_surf(m)Â )Â THEN |
---|
3252 |           tin = roof_inner_temperature |
---|
3253 | ! |
---|
3254 | !--Â Â Â Â Â Â Normal land surface |
---|
3255 | Â Â Â Â Â Â Â Â ELSE |
---|
3256 |           tin = soil_inner_temperature |
---|
3257 | Â Â Â Â Â Â Â Â ENDIF |
---|
3258 | |
---|
3259 |         DO k = nzb_wall, nzt_wall+1 |
---|
3260 |           c = REAL( k - nzb_wall, wp ) /               & |
---|
3261 |             REAL( nzt_wall + 1 - nzb_wall , wp ) |
---|
3262 | |
---|
3263 |           t_wall_h(k,m) = ( 1.0_wp - c ) * t_surf_h(m) + c * tin |
---|
3264 | Â Â Â Â Â Â Â Â ENDDO |
---|
3265 | Â Â Â Â Â Â ENDDO |
---|
3266 | ! |
---|
3267 | !--Â Â Â Â Â Vertical surfaces |
---|
3268 |       DO l = 0, 3 |
---|
3269 |         DO m = 1, surf_usm_v(l)%ns |
---|
3270 | ! |
---|
3271 | !--Â Â Â Â Â Â Â Â Inner wall |
---|
3272 |          tin = wall_inner_temperature |
---|
3273 | |
---|
3274 |          DO k = nzb_wall, nzt_wall+1 |
---|
3275 |            c = REAL( k - nzb_wall, wp ) /              & |
---|
3276 |              REAL( nzt_wall + 1 - nzb_wall , wp ) |
---|
3277 | |
---|
3278 |            t_wall_v(l)%t(k,m) = ( 1.0_wp - c ) * t_surf_v(l)%t(m) + & |
---|
3279 |                      c * tin |
---|
3280 | Â Â Â Â Â Â Â Â Â ENDDO |
---|
3281 | Â Â Â Â Â Â Â Â ENDDO |
---|
3282 | Â Â Â Â Â Â ENDDO |
---|
3283 | |
---|
3284 | Â Â Â Â ENDIF |
---|
3285 | Â Â Â Â |
---|
3286 | !--Â Â |
---|
3287 | !--Â Â Â Possibly DO user-defined actions (e.g. define heterogeneous wall surface) |
---|
3288 | Â Â Â Â CALL user_init_urban_surface |
---|
3289 | |
---|
3290 | !--Â Â Â initialize prognostic values for the first timestep |
---|
3291 |     t_surf_h_p = t_surf_h |
---|
3292 |     t_surf_v_p = t_surf_v |
---|
3293 | |
---|
3294 |     t_wall_h_p = t_wall_h |
---|
3295 |     t_wall_v_p = t_wall_v |
---|
3296 | Â Â Â Â |
---|
3297 | !--Â Â Â Adjust radiative fluxes for urban surface at model start |
---|
3298 | Â Â Â Â CALL usm_radiation |
---|
3299 | Â Â Â Â |
---|
3300 |     CALL cpu_log( log_point_s(78), 'usm_init', 'stop' ) |
---|
3301 | |
---|
3302 | Â Â Â Â |
---|
3303 | Â Â END SUBROUTINE usm_init_urban_surface |
---|
3304 | |
---|
3305 | |
---|
3306 | !------------------------------------------------------------------------------! |
---|
3307 | ! Description: |
---|
3308 | ! ------------ |
---|
3309 | ! |
---|
3310 | !> Wall model as part of the urban surface model. The model predicts wall |
---|
3311 | !> temperature. |
---|
3312 | !------------------------------------------------------------------------------! |
---|
3313 | Â Â SUBROUTINE usm_material_heat_model |
---|
3314 | |
---|
3315 | |
---|
3316 | Â Â Â Â IMPLICIT NONE |
---|
3317 | |
---|
3318 |     INTEGER(iwp) :: i,j,k,l,kw, m           !< running indices |
---|
3319 | |
---|
3320 |     REAL(wp), DIMENSION(nzb_wall:nzt_wall) :: wtend !< tendency |
---|
3321 | |
---|
3322 | ! |
---|
3323 | !--   For horizontal surfaces                  |
---|
3324 |     DO m = 1, surf_usm_h%ns |
---|
3325 | ! |
---|
3326 | !--Â Â Â Â Obtain indices |
---|
3327 |       i = surf_usm_h%i(m)      |
---|
3328 |       j = surf_usm_h%j(m) |
---|
3329 |       k = surf_usm_h%k(m) |
---|
3330 | ! |
---|
3331 | !--Â Â Â Â prognostic equation for ground/roof temperature t_wall_h |
---|
3332 | Â Â Â Â Â Â wtend(:)Â =Â 0.0_wp |
---|
3333 |       wtend(nzb_wall) = (1.0_wp / surf_usm_h%rho_c_wall(nzb_wall,m)) *  & |
---|
3334 | Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â (Â surf_usm_h%lambda_h(nzb_wall,m)Â *Â Â Â & |
---|
3335 | Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â (Â t_wall_h(nzb_wall+1,m)Â Â Â Â Â Â Â Â & |
---|
3336 | Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â -Â t_wall_h(nzb_wall,m)Â )Â *Â Â Â Â Â Â Â & |
---|
3337 | Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â surf_usm_h%ddz_wall(nzb_wall+1,m)Â Â Â & |
---|
3338 | Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â +Â surf_usm_h%wghf_eb(m)Â )Â *Â Â Â Â Â Â Â & |
---|
3339 | Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â surf_usm_h%ddz_wall_stag(nzb_wall,m) |
---|
3340 | Â Â Â Â Â Â |
---|
3341 |       DO kw = nzb_wall+1, nzt_wall |
---|
3342 |         wtend(kw) = (1.0_wp / surf_usm_h%rho_c_wall(kw,m))       & |
---|
3343 | Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â *Â (Â Â surf_usm_h%lambda_h(kw,m)Â Â Â Â Â Â Â Â Â & |
---|
3344 | Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â *Â (Â t_wall_h(kw+1,m)Â -Â t_wall_h(kw,m)Â )Â Â Â Â & |
---|
3345 | Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â *Â surf_usm_h%ddz_wall(kw+1,m)Â Â Â Â Â Â Â Â Â & |
---|
3346 | Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â -Â surf_usm_h%lambda_h(kw-1,m)Â Â Â Â Â Â Â Â Â Â & |
---|
3347 | Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â *Â (Â t_wall_h(kw,m)Â -Â t_wall_h(kw-1,m)Â )Â Â Â Â & |
---|
3348 | Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â *Â surf_usm_h%ddz_wall(kw,m)Â Â Â Â Â Â Â Â Â Â & |
---|
3349 | Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â )Â *Â surf_usm_h%ddz_wall_stag(kw,m) |
---|
3350 | Â Â Â Â Â Â ENDDO |
---|
3351 | |
---|
3352 | Â Â Â Â Â Â t_wall_h_p(nzb_wall:nzt_wall,m)Â =Â t_wall_h(nzb_wall:nzt_wall,m)Â Â Â & |
---|
3353 |                  + dt_3d * ( tsc(2)              & |
---|
3354 | Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â *Â wtend(nzb_wall:nzt_wall)Â +Â tsc(3)Â Â Â Â Â Â & |
---|
3355 | Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â *Â surf_usm_h%tt_wall_m(nzb_wall:nzt_wall,m)Â )Â Â |
---|
3356 | Â Â Â Â Â Â |
---|
3357 | ! |
---|
3358 | !--Â Â Â Â calculate t_wall tendencies for the next Runge-Kutta step |
---|
3359 | Â Â Â Â Â Â IFÂ (Â timestep_scheme(1:5)Â ==Â 'runge'Â )Â THEN |
---|
3360 |         IF ( intermediate_timestep_count == 1 ) THEN |
---|
3361 |          DO kw = nzb_wall, nzt_wall |
---|
3362 | Â Â Â Â Â Â Â Â Â Â Â surf_usm_h%tt_wall_m(kw,m)Â =Â wtend(kw) |
---|
3363 | Â Â Â Â Â Â Â Â Â ENDDO |
---|
3364 |         ELSEIF ( intermediate_timestep_count <             & |
---|
3365 |             intermediate_timestep_count_max ) THEN |
---|
3366 |           DO kw = nzb_wall, nzt_wall |
---|
3367 |            surf_usm_h%tt_wall_m(kw,m) = -9.5625_wp * wtend(kw) +  & |
---|
3368 |                      5.3125_wp * surf_usm_h%tt_wall_m(kw,m) |
---|
3369 | Â Â Â Â Â Â Â Â Â Â ENDDO |
---|
3370 | Â Â Â Â Â Â Â Â ENDIF |
---|
3371 | Â Â Â Â Â Â ENDIF |
---|
3372 | Â Â Â Â ENDDO |
---|
3373 | ! |
---|
3374 | !--   For vertical surfaces   |
---|
3375 |     DO l = 0, 3               |
---|
3376 |       DO m = 1, surf_usm_v(l)%ns |
---|
3377 | ! |
---|
3378 | !--Â Â Â Â Â Â Obtain indices |
---|
3379 |        i = surf_usm_v(l)%i(m)      |
---|
3380 |        j = surf_usm_v(l)%j(m) |
---|
3381 |        k = surf_usm_v(l)%k(m) |
---|
3382 | ! |
---|
3383 | !--Â Â Â Â Â Â prognostic equation for wall temperature t_wall_v |
---|
3384 | Â Â Â Â Â Â Â wtend(:)Â =Â 0.0_wp |
---|
3385 |        wtend(nzb_wall) = (1.0_wp / surf_usm_v(l)%rho_c_wall(nzb_wall,m)) * & |
---|
3386 | Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â (Â surf_usm_v(l)%lambda_h(nzb_wall,m)Â *Â Â & |
---|
3387 | Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â (Â t_wall_v(l)%t(nzb_wall+1,m)Â Â Â Â Â & |
---|
3388 | Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â -Â t_wall_v(l)%t(nzb_wall,m)Â )Â *Â Â Â Â & |
---|
3389 | Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â surf_usm_v(l)%ddz_wall(nzb_wall+1,m)Â Â & |
---|
3390 | Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â +Â surf_usm_v(l)%wghf_eb(m)Â )Â *Â Â Â Â Â Â & |
---|
3391 | Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â surf_usm_v(l)%ddz_wall_stag(nzb_wall,m) |
---|
3392 | Â Â Â Â Â Â |
---|
3393 |        DO kw = nzb_wall+1, nzt_wall |
---|
3394 |          wtend(kw) = (1.0_wp / surf_usm_v(l)%rho_c_wall(kw,m))    & |
---|
3395 | Â Â Â Â Â Â Â Â Â Â Â Â Â Â *Â (Â Â surf_usm_v(l)%lambda_h(kw,m)Â Â Â Â Â Â Â Â Â & |
---|
3396 | Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â *Â (Â t_wall_v(l)%t(kw+1,m)Â -Â t_wall_v(l)%t(kw,m)Â )& |
---|
3397 | Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â *Â surf_usm_v(l)%ddz_wall(kw+1,m)Â Â Â Â Â Â Â Â Â & |
---|
3398 | Â Â Â Â Â Â Â Â Â Â Â Â Â Â -Â surf_usm_v(l)%lambda_h(kw-1,m)Â Â Â Â Â Â Â Â Â Â & |
---|
3399 | Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â *Â (Â t_wall_v(l)%t(kw,m)Â -Â t_wall_v(l)%t(kw-1,m)Â )& |
---|
3400 | Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â *Â surf_usm_v(l)%ddz_wall(kw,m)Â Â Â Â Â Â Â Â Â Â & |
---|
3401 | Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â )Â *Â surf_usm_v(l)%ddz_wall_stag(kw,m) |
---|
3402 | Â Â Â Â Â Â Â Â ENDDO |
---|
3403 | |
---|
3404 | Â Â Â Â Â Â Â t_wall_v_p(l)%t(nzb_wall:nzt_wall,m)Â =Â Â Â Â Â Â Â Â Â Â Â Â Â Â & |
---|
3405 | Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â t_wall_v(l)%t(nzb_wall:nzt_wall,m)Â Â Â Â Â & |
---|
3406 |                  + dt_3d * ( tsc(2)              & |
---|
3407 | Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â *Â wtend(nzb_wall:nzt_wall)Â +Â tsc(3)Â Â Â Â Â Â & |
---|
3408 | Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â *Â surf_usm_v(l)%tt_wall_m(nzb_wall:nzt_wall,m)Â )Â Â |
---|
3409 | Â Â Â Â Â Â |
---|
3410 | ! |
---|
3411 | !--Â Â Â Â Â Â calculate t_wall tendencies for the next Runge-Kutta step |
---|
3412 | Â Â Â Â Â Â Â IFÂ (Â timestep_scheme(1:5)Â ==Â 'runge'Â )Â THEN |
---|
3413 |          IF ( intermediate_timestep_count == 1 ) THEN |
---|
3414 |            DO kw = nzb_wall, nzt_wall |
---|
3415 | Â Â Â Â Â Â Â Â Â Â Â Â surf_usm_v(l)%tt_wall_m(kw,m)Â =Â wtend(kw) |
---|
3416 | Â Â Â Â Â Â Â Â Â Â Â ENDDO |
---|
3417 |          ELSEIF ( intermediate_timestep_count <            & |
---|
3418 |               intermediate_timestep_count_max ) THEN |
---|
3419 |            DO kw = nzb_wall, nzt_wall |
---|
3420 | Â Â Â Â Â Â Â Â Â Â Â Â Â surf_usm_v(l)%tt_wall_m(kw,m)Â =Â Â Â Â Â Â Â Â Â Â Â Â & |
---|
3421 |                    - 9.5625_wp * wtend(kw) +         & |
---|
3422 |                     5.3125_wp * surf_usm_v(l)%tt_wall_m(kw,m) |
---|
3423 | Â Â Â Â Â Â Â Â Â Â Â ENDDO |
---|
3424 | Â Â Â Â Â Â Â Â Â ENDIF |
---|
3425 | Â Â Â Â Â Â Â ENDIF |
---|
3426 | Â Â Â Â Â Â ENDDO |
---|
3427 | Â Â Â Â ENDDO |
---|
3428 | |
---|
3429 | Â Â END SUBROUTINE usm_material_heat_model |
---|
3430 | |
---|
3431 | |
---|
3432 | !------------------------------------------------------------------------------! |
---|
3433 | ! Description: |
---|
3434 | ! ------------ |
---|
3435 | !> Parin for &usm_par for urban surface model |
---|
3436 | !------------------------------------------------------------------------------! |
---|
3437 | Â Â SUBROUTINE usm_parin |
---|
3438 | |
---|
3439 | Â Â Â Â IMPLICIT NONE |
---|
3440 | |
---|
3441 |     CHARACTER (LEN=80) :: line !< string containing current line of file PARIN |
---|
3442 | |
---|
3443 | Â Â Â Â NAMELISTÂ /urban_surface_par/Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â & |
---|
3444 |               land_category,                   & |
---|
3445 |               mrt_factors,                    & |
---|
3446 |               nrefsteps,                     & |
---|
3447 |               pedestrant_category,                & |
---|
3448 |               ra_horiz_coef,                   & |
---|
3449 |               read_svf_on_init,                  & |
---|
3450 |               roof_category,                   & |
---|
3451 |               split_diffusion_radiation,             & |
---|
3452 |               urban_surface,                   & |
---|
3453 |               usm_anthropogenic_heat,               & |
---|
3454 |               usm_energy_balance_land,              & |
---|
3455 |               usm_energy_balance_wall,              & |
---|
3456 |               usm_material_model,                 & |
---|
3457 |               usm_lad_rma,                    & |
---|
3458 |               wall_category,                   & |
---|
3459 | Â Â Â Â Â Â Â Â Â Â Â Â Â Â write_svf_on_init |
---|
3460 | |
---|
3461 |     line = ' ' |
---|
3462 | |
---|
3463 | ! |
---|
3464 | !--Â Â Try to find urban surface model package |
---|
3465 | Â Â Â Â REWINDÂ (Â 11Â ) |
---|
3466 |     line = ' ' |
---|
3467 |     DO  WHILE ( INDEX( line, '&urban_surface_par' ) == 0 ) |
---|
3468 |      READ ( 11, '(A)', END=10 ) line |
---|
3469 | Â Â Â Â ENDDO |
---|
3470 | Â Â Â Â BACKSPACEÂ (Â 11Â ) |
---|
3471 | |
---|
3472 | ! |
---|
3473 | !--Â Â Read user-defined namelist |
---|
3474 |     READ ( 11, urban_surface_par ) |
---|
3475 | ! |
---|
3476 | !--Â Â Set flag that indicates that the land surface model is switched on |
---|
3477 |     urban_surface = .TRUE. |
---|
3478 | |
---|
3479 | ! |
---|
3480 | !--Â Â Activate spinup |
---|
3481 |     IF ( spinup_time > 0.0_wp ) THEN |
---|
3482 |      coupling_start_time = spinup_time |
---|
3483 |      end_time = end_time + spinup_time |
---|
3484 |      IF ( spinup_pt_mean == 9999999.9_wp ) THEN |
---|
3485 |        spinup_pt_mean = pt_surface |
---|
3486 | Â Â Â Â Â ENDIF |
---|
3487 |      spinup = .TRUE. |
---|
3488 | Â Â Â Â ENDIF |
---|
3489 | |
---|
3490 | Â 10Â Â CONTINUE |
---|
3491 | |
---|
3492 | Â Â END SUBROUTINE usm_parin |
---|
3493 | |
---|
3494 | |
---|
3495 | !------------------------------------------------------------------------------! |
---|
3496 | ! Description: |
---|
3497 | ! ------------ |
---|
3498 | !> This subroutine calculates interaction of the solar radiation |
---|
3499 | !> with urban surface and updates surface, roofs and walls heatfluxes. |
---|
3500 | !> It also updates rad_sw_out and rad_lw_out. |
---|
3501 | !------------------------------------------------------------------------------! |
---|
3502 | Â Â SUBROUTINE usm_radiation |
---|
3503 | Â Â |
---|
3504 | Â Â Â Â IMPLICIT NONE |
---|
3505 | Â Â Â Â |
---|
3506 |     INTEGER(iwp)        :: i, j, k, kk, is, js, d, ku, refstep, m, mm, l, ll |
---|
3507 |     INTEGER(iwp)        :: nzubl, nzutl, isurf, isurfsrc, isurf1, isvf, icsf, ipcgb |
---|
3508 |     INTEGER(iwp), DIMENSION(4) :: bdycross |
---|
3509 |     REAL(wp), DIMENSION(3,3)  :: mrot      !< grid rotation matrix (xyz) |
---|
3510 |     REAL(wp), DIMENSION(3,0:9) :: vnorm      !< face direction normal vectors (xyz) |
---|
3511 |     REAL(wp), DIMENSION(3)   :: sunorig     !< grid rotated solar direction unit vector (xyz) |
---|
3512 |     REAL(wp), DIMENSION(3)   :: sunorig_grid  !< grid squashed solar direction unit vector (zyx) |
---|
3513 |     REAL(wp), DIMENSION(0:9)  :: costheta    !< direct irradiance factor of solar angle |
---|
3514 |     REAL(wp), DIMENSION(nzub:nzut) :: pchf_prep  !< precalculated factor for canopy temp tendency |
---|
3515 |     REAL(wp), PARAMETER    :: alpha = 0._wp  !< grid rotation (TODO: add to namelist or remove) |
---|
3516 |     REAL(wp)          :: rx, ry, rz |
---|
3517 |     REAL(wp)          :: pc_box_area, pc_abs_frac, pc_abs_eff |
---|
3518 |     INTEGER(iwp)        :: pc_box_dimshift !< transform for best accuracy |
---|
3519 |     INTEGER(iwp), DIMENSION(0:3) :: reorder = (/ 1, 0, 3, 2 /) |
---|
3520 | Â Â Â Â |
---|
3521 | Â Â Â Â |
---|
3522 |     IF ( plant_canopy ) THEN |
---|
3523 |       pchf_prep(:) = r_d * (hyp(nzub:nzut) / 100000.0_wp)**0.286_wp & |
---|
3524 |             / (cp * hyp(nzub:nzut) * dx*dy*dz) !< equals to 1 / (rho * c_p * Vbox * T) |
---|
3525 | Â Â Â Â ENDIF |
---|
3526 | |
---|
3527 |     sun_direction = .TRUE. |
---|
3528 |     CALL calc_zenith !< required also for diffusion radiation |
---|
3529 | |
---|
3530 | !--Â Â Â prepare rotated normal vectors and irradiance factor |
---|
3531 | Â Â Â Â vnorm(1,:)Â =Â idir(:) |
---|
3532 | Â Â Â Â vnorm(2,:)Â =Â jdir(:) |
---|
3533 | Â Â Â Â vnorm(3,:)Â =Â kdir(:) |
---|
3534 |     mrot(1, :) = (/ cos(alpha), -sin(alpha), 0._wp /) |
---|
3535 |     mrot(2, :) = (/ sin(alpha), cos(alpha), 0._wp /) |
---|
3536 |     mrot(3, :) = (/ 0._wp,    0._wp,   1._wp /) |
---|
3537 |     sunorig = (/ sun_dir_lon, sun_dir_lat, zenith(0) /) |
---|
3538 |     sunorig = matmul(mrot, sunorig) |
---|
3539 |     DO d = 0, 9 |
---|
3540 |       costheta(d) = dot_product(sunorig, vnorm(:,d)) |
---|
3541 | Â Â Â Â ENDDO |
---|
3542 | Â Â Â Â |
---|
3543 | Â Â Â Â IFÂ (Â zenith(0)Â >Â 0Â )Â THEN |
---|
3544 | !--Â Â Â Â Â now we will "squash" the sunorig vector by grid box size in |
---|
3545 | !--Â Â Â Â Â each dimension, so that this new direction vector will allow us |
---|
3546 | !--Â Â Â Â Â to traverse the ray path within grid coordinates directly |
---|
3547 |       sunorig_grid = (/ sunorig(3)/dz, sunorig(2)/dy, sunorig(1)/dx /) |
---|
3548 | !--Â Â Â Â Â sunorig_grid = sunorig_grid / norm2(sunorig_grid) |
---|
3549 |       sunorig_grid = sunorig_grid / SQRT(SUM(sunorig_grid**2)) |
---|
3550 | |
---|
3551 |       IF ( plant_canopy ) THEN |
---|
3552 | !--Â Â Â Â Â Â precompute effective box depth with prototype Leaf Area Density |
---|
3553 |         pc_box_dimshift = maxloc(sunorig, 1) - 1 |
---|
3554 |         CALL usm_box_absorb(cshift((/dx,dy,dz/), pc_box_dimshift),   & |
---|
3555 |                   60, prototype_lad,             & |
---|
3556 |                   cshift(sunorig, pc_box_dimshift),      & |
---|
3557 |                   pc_box_area, pc_abs_frac) |
---|
3558 |         pc_box_area = pc_box_area * sunorig(pc_box_dimshift+1) / sunorig(3) |
---|
3559 |         pc_abs_eff = log(1._wp - pc_abs_frac) / prototype_lad |
---|
3560 | Â Â Â Â Â Â ENDIF |
---|
3561 | Â Â Â Â ENDIF |
---|
3562 | Â Â Â Â |
---|
3563 | !--Â Â Â split diffusion and direct part of the solar downward radiation |
---|
3564 | !--Â Â Â comming from radiation model and store it in 2D arrays |
---|
3565 | !--Â Â Â rad_sw_in_diff, rad_sw_in_dir and rad_lw_in_diff |
---|
3566 |     IF ( split_diffusion_radiation ) THEN |
---|
3567 | Â Â Â Â Â Â CALL usm_calc_diffusion_radiation |
---|
3568 | Â Â Â Â ELSE |
---|
3569 |       rad_sw_in_diff = 0.0_wp |
---|
3570 | Â Â Â Â Â Â rad_sw_in_dir(:,:)Â =Â rad_sw_in(0,:,:) |
---|
3571 | Â Â Â Â Â Â rad_lw_in_diff(:,:)Â =Â rad_lw_in(0,:,:) |
---|
3572 | Â Â Â Â ENDIF |
---|
3573 | |
---|
3574 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! |
---|
3575 | !--Â Â Â First pass: direct + diffuse irradiance |
---|
3576 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! |
---|
3577 |     surfinswdir  = 0._wp !nsurfl |
---|
3578 |     surfinswdif  = 0._wp !nsurfl |
---|
3579 |     surfinlwdif  = 0._wp !nsurfl |
---|
3580 |     surfins    = 0._wp !nsurfl |
---|
3581 |     surfinl    = 0._wp !nsurfl |
---|
3582 |     surfoutsl(:) = 0.0_wp !start-end |
---|
3583 |     surfoutll(:) = 0.0_wp !start-end |
---|
3584 | Â Â Â Â |
---|
3585 | !--Â Â Â Set up thermal radiation from surfaces |
---|
3586 | !--Â Â Â emiss_surf is defined only for surfaces for which energy balance is calculated |
---|
3587 | !--Â Â Â Workaround: reorder surface data type back on 1D array including all surfaces, |
---|
3588 | !--Â Â Â which implies to reorder horizontal and vertical surfaces |
---|
3589 | ! |
---|
3590 | !--Â Â Â Horizontal walls |
---|
3591 |     mm = 1 |
---|
3592 |     DO i = nxl, nxr |
---|
3593 |       DO j = nys, nyn |
---|
3594 | |
---|
3595 |        DO m = surf_usm_h%start_index(j,i), surf_usm_h%end_index(j,i) |
---|
3596 |          surfoutll(mm) = surf_usm_h%emiss_surf(m) * sigma_sb  & |
---|
3597 | Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â *Â t_surf_h(m)**4 |
---|
3598 | Â Â Â Â Â Â Â Â Â albedo_surf(mm)Â =Â surf_usm_h%albedo_surf(m) |
---|
3599 | Â Â Â Â Â Â Â Â Â emiss_surf(mm)Â =Â surf_usm_h%emiss_surf(m) |
---|
3600 |          mm = mm + 1 |
---|
3601 | Â Â Â Â Â Â Â ENDDO |
---|
3602 | Â Â Â Â Â Â ENDDO |
---|
3603 | Â Â Â Â ENDDO |
---|
3604 | ! |
---|
3605 | !--Â Â Â Vertical walls |
---|
3606 |     DO i = nxl, nxr |
---|
3607 |       DO j = nys, nyn |
---|
3608 |        DO ll = 0, 3 |
---|
3609 |          l = reorder(ll) |
---|
3610 |          DO m = surf_usm_v(l)%start_index(j,i), surf_usm_v(l)%end_index(j,i) |
---|
3611 |           surfoutll(mm) = surf_usm_v(l)%emiss_surf(m) * sigma_sb  & |
---|
3612 | Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â *Â t_surf_v(l)%t(m)**4 |
---|
3613 | Â Â Â Â Â Â Â Â Â Â albedo_surf(mm)Â =Â surf_usm_v(l)%albedo_surf(m) |
---|
3614 | Â Â Â Â Â Â Â Â Â Â emiss_surf(mm)Â =Â surf_usm_v(l)%emiss_surf(m) |
---|
3615 |           mm = mm + 1 |
---|
3616 | Â Â Â Â Â Â Â Â Â ENDDO |
---|
3617 | Â Â Â Â Â Â Â ENDDO |
---|
3618 | Â Â Â Â Â Â ENDDO |
---|
3619 | Â Â Â Â ENDDO |
---|
3620 | Â Â Â Â |
---|
3621 | #if defined( __parallel ) |
---|
3622 | !--Â Â Â might be optimized and gather only values relevant for current processor |
---|
3623 | Â Â Â Â |
---|
3624 |     CALL MPI_AllGatherv(surfoutll, nenergy, MPI_REAL, & |
---|
3625 |               surfoutl, nsurfs, surfstart, MPI_REAL, comm2d, ierr) !nsurf global |
---|
3626 | #else |
---|
3627 | Â Â Â Â surfoutl(:)Â =Â surfoutll(:)Â !nsurf global |
---|
3628 | #endif |
---|
3629 | Â Â Â Â |
---|
3630 | Â Â Â Â isurf1Â =Â -1Â Â !< previous processed surface |
---|
3631 |     DO isvf = 1, nsvfl |
---|
3632 |       isurf = svfsurf(1, isvf) |
---|
3633 |       k = surfl(iz, isurf) |
---|
3634 |       j = surfl(iy, isurf) |
---|
3635 |       i = surfl(ix, isurf) |
---|
3636 |       isurfsrc = svfsurf(2, isvf) |
---|
3637 |       IF ( zenith(0) > 0 .AND. isurf /= isurf1 ) THEN |
---|
3638 | !--Â Â Â Â Â Â Â locate the virtual surface where the direct solar ray crosses domain boundary |
---|
3639 | !--Â Â Â Â Â Â Â (once per target surface) |
---|
3640 |         d = surfl(id, isurf) |
---|
3641 |         rz = REAL(k, wp) - 0.5_wp * kdir(d) |
---|
3642 |         ry = REAL(j, wp) - 0.5_wp * jdir(d) |
---|
3643 |         rx = REAL(i, wp) - 0.5_wp * idir(d) |
---|
3644 | Â Â Â Â Â Â Â Â |
---|
3645 |         CALL usm_find_boundary_face( (/ rz, ry, rx /), sunorig_grid, bdycross) |
---|
3646 | Â Â Â Â Â Â Â Â |
---|
3647 | Â Â Â Â Â Â Â Â isurf1Â =Â isurf |
---|
3648 | Â Â Â Â Â Â ENDIF |
---|
3649 | |
---|
3650 |       IF ( surf(id, isurfsrc) >= isky ) THEN |
---|
3651 | !--Â Â Â Â Â Â Â diffuse rad from boundary surfaces. Since it is a simply |
---|
3652 | !--Â Â Â Â Â Â Â calculated value, it is not assigned to surfref(s/l), |
---|
3653 | !--Â Â Â Â Â Â Â instead it is used directly here |
---|
3654 | !--Â Â Â Â Â Â Â we consider the radiation from the radiation model falling on surface |
---|
3655 | !--Â Â Â Â Â Â Â as the radiation falling on the top of urban layer into the place of the source surface |
---|
3656 | !--Â Â Â Â Â Â Â we consider it as a very reasonable simplification which allow as avoid |
---|
3657 | !--Â Â Â Â Â Â Â necessity of other global range arrays and some all to all mpi communication |
---|
3658 | Â Â Â Â Â Â Â Â surfinswdif(isurf)Â =Â surfinswdif(isurf)Â +Â rad_sw_in_diff(j,i)Â *Â svf(1,isvf)Â *Â svf(2,isvf) |
---|
3659 | Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â !< canopy shading is applied only to shortwave |
---|
3660 | Â Â Â Â Â Â Â Â surfinlwdif(isurf)Â =Â surfinlwdif(isurf)Â +Â rad_lw_in_diff(j,i)Â *Â svf(1,isvf) |
---|
3661 | Â Â Â Â Â Â ELSE |
---|
3662 | !--Â Â Â Â Â Â Â for surface-to-surface factors we calculate thermal radiation in 1st pass |
---|
3663 | Â Â Â Â Â Â Â Â surfinl(isurf)Â =Â surfinl(isurf)Â +Â svf(1,isvf)Â *Â surfoutl(isurfsrc) |
---|
3664 | Â Â Â Â Â Â ENDIF |
---|
3665 | |
---|
3666 |       IF ( zenith(0) > 0 .AND. all( surf(1:4,isurfsrc) == bdycross ) ) THEN |
---|
3667 | !--Â Â Â Â Â Â Â found svf between model boundary and the face => face isn't shaded |
---|
3668 | Â Â Â Â Â Â Â Â surfinswdir(isurf)Â =Â rad_sw_in_dir(j,i)Â & |
---|
3669 |           * costheta(surfl(id, isurf)) * svf(2,isvf) / zenith(0) |
---|
3670 | |
---|
3671 | Â Â Â Â Â Â ENDIF |
---|
3672 | Â Â Â Â ENDDO |
---|
3673 | |
---|
3674 |     IF ( plant_canopy ) THEN |
---|
3675 | Â Â Â Â |
---|
3676 | Â Â Â Â Â Â pcbinsw(:)Â =Â 0._wp |
---|
3677 |       pcbinlw(:) = 0._wp !< will stay always 0 since we don't absorb lw anymore |
---|
3678 | Â Â Â Â Â Â ! |
---|
3679 | !--Â Â Â Â Â pcsf first pass |
---|
3680 | Â Â Â Â Â Â isurf1Â =Â -1Â !< previous processed pcgb |
---|
3681 |       DO icsf = 1, ncsfl |
---|
3682 |         ipcgb = csfsurf(1, icsf) |
---|
3683 |         i = pcbl(ix,ipcgb) |
---|
3684 |         j = pcbl(iy,ipcgb) |
---|
3685 |         k = pcbl(iz,ipcgb) |
---|
3686 |         isurfsrc = csfsurf(2, icsf) |
---|
3687 | |
---|
3688 |         IF ( zenith(0) > 0 .AND. ipcgb /= isurf1 ) THEN |
---|
3689 | !--Â Â Â Â Â Â Â Â Â locate the virtual surface where the direct solar ray crosses domain boundary |
---|
3690 | !--Â Â Â Â Â Â Â Â Â (once per target PC gridbox) |
---|
3691 |           rz = REAL(k, wp) |
---|
3692 |           ry = REAL(j, wp) |
---|
3693 |           rx = REAL(i, wp) |
---|
3694 |           CALL usm_find_boundary_face( (/ rz, ry, rx /), & |
---|
3695 |             sunorig_grid, bdycross) |
---|
3696 | |
---|
3697 | Â Â Â Â Â Â Â Â Â Â isurf1Â =Â ipcgb |
---|
3698 | Â Â Â Â Â Â Â Â ENDIF |
---|
3699 | |
---|
3700 |         IF ( surf(id, isurfsrc) >= isky ) THEN |
---|
3701 | !--Â Â Â Â Â Â Â Â Â Diffuse rad from boundary surfaces. See comments for svf above. |
---|
3702 | Â Â Â Â Â Â Â Â Â Â pcbinsw(ipcgb)Â =Â pcbinsw(ipcgb)Â +Â csf(1,icsf)Â *Â csf(2,icsf)Â *Â rad_sw_in_diff(j,i) |
---|
3703 | !--Â Â Â Â Â Â Â Â Â canopy shading is applied only to shortwave, therefore no absorbtion for lw |
---|
3704 | !--Â Â Â Â Â Â Â Â Â pcbinlw(ipcgb) = pcbinlw(ipcgb) + svf(1,isvf) * rad_lw_in_diff(j,i) |
---|
3705 | Â Â Â Â Â Â Â Â !ELSE |
---|
3706 | !--Â Â Â Â Â Â Â Â Â Thermal radiation in 1st pass |
---|
3707 | !--Â Â Â Â Â Â Â Â Â pcbinlw(ipcgb) = pcbinlw(ipcgb) + svf(1,isvf) * surfoutl(isurfsrc) |
---|
3708 | Â Â Â Â Â Â Â Â ENDIF |
---|
3709 | |
---|
3710 |         IF ( zenith(0) > 0 .AND. all( surf(1:4,isurfsrc) == bdycross ) ) THEN |
---|
3711 | !--Â Â Â Â Â Â Â Â Â found svf between model boundary and the pcgb => pcgb isn't shaded |
---|
3712 |           pc_abs_frac = 1._wp - exp(pc_abs_eff * lad_s(k,j,i)) |
---|
3713 | Â Â Â Â Â Â Â Â Â Â pcbinsw(ipcgb)Â =Â pcbinsw(ipcgb)Â & |
---|
3714 |             + rad_sw_in_dir(j, i) * pc_box_area * csf(2,icsf) * pc_abs_frac |
---|
3715 | Â Â Â Â Â Â Â Â ENDIF |
---|
3716 | Â Â Â Â Â Â ENDDO |
---|
3717 | Â Â Â Â ENDIF |
---|
3718 | |
---|
3719 | Â Â Â Â surfins(startenergy:endenergy)Â =Â surfinswdir(startenergy:endenergy)Â +Â surfinswdif(startenergy:endenergy) |
---|
3720 | Â Â Â Â surfinl(startenergy:endenergy)Â =Â surfinl(startenergy:endenergy)Â +Â surfinlwdif(startenergy:endenergy) |
---|
3721 | Â Â Â Â surfinsw(:)Â =Â surfins(:) |
---|
3722 | Â Â Â Â surfinlw(:)Â =Â surfinl(:) |
---|
3723 | Â Â Â Â surfoutsw(:)Â =Â 0.0_wp |
---|
3724 | Â Â Â Â surfoutlw(:)Â =Â surfoutll(:) |
---|
3725 | !     surfhf(startenergy:endenergy) = surfinsw(startenergy:endenergy) + surfinlw(startenergy:endenergy) & |
---|
3726 | !                    - surfoutsw(startenergy:endenergy) - surfoutlw(startenergy:endenergy) |
---|
3727 | Â Â Â Â |
---|
3728 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! |
---|
3729 | !--Â Â Â Next passes - reflections |
---|
3730 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! |
---|
3731 |     DO refstep = 1, nrefsteps |
---|
3732 | Â Â Â Â |
---|
3733 | Â Â Â Â Â Â surfoutsl(startenergy:endenergy)Â =Â albedo_surf(startenergy:endenergy)Â *Â surfins(startenergy:endenergy) |
---|
3734 | !--Â Â Â Â Â for non-transparent surfaces, longwave albedo is 1 - emissivity |
---|
3735 |       surfoutll(startenergy:endenergy) = (1._wp - emiss_surf(startenergy:endenergy)) * surfinl(startenergy:endenergy) |
---|
3736 | |
---|
3737 | #if defined( __parallel ) |
---|
3738 |       CALL MPI_AllGatherv(surfoutsl, nsurfl, MPI_REAL, & |
---|
3739 |         surfouts, nsurfs, surfstart, MPI_REAL, comm2d, ierr) |
---|
3740 |       CALL MPI_AllGatherv(surfoutll, nsurfl, MPI_REAL, & |
---|
3741 |         surfoutl, nsurfs, surfstart, MPI_REAL, comm2d, ierr) |
---|
3742 | #else |
---|
3743 | Â Â Â Â Â Â surfouts(:)Â =Â surfoutsl(:) |
---|
3744 | Â Â Â Â Â Â surfoutl(:)Â =Â surfoutll(:) |
---|
3745 | #endif |
---|
3746 | |
---|
3747 | !--Â Â Â Â Â reset for next pass input |
---|
3748 | Â Â Â Â Â Â surfins(:)Â =Â 0._wp |
---|
3749 | Â Â Â Â Â Â surfinl(:)Â =Â 0._wp |
---|
3750 | Â Â Â Â Â Â |
---|
3751 | !--Â Â Â Â Â reflected radiation |
---|
3752 |       DO isvf = 1, nsvfl |
---|
3753 |         isurf = svfsurf(1, isvf) |
---|
3754 |         isurfsrc = svfsurf(2, isvf) |
---|
3755 | |
---|
3756 | !--Â Â Â Â Â Â Â TODO: to remove if, use start+end for isvf |
---|
3757 |         IF ( surf(id, isurfsrc) < isky ) THEN |
---|
3758 | Â Â Â Â Â Â Â Â Â Â surfins(isurf)Â =Â surfins(isurf)Â +Â svf(1,isvf)Â *Â svf(2,isvf)Â *Â surfouts(isurfsrc) |
---|
3759 | Â Â Â Â Â Â Â Â Â Â surfinl(isurf)Â =Â surfinl(isurf)Â +Â svf(1,isvf)Â *Â surfoutl(isurfsrc) |
---|
3760 | Â Â Â Â Â Â Â Â ENDIF |
---|
3761 | Â Â Â Â Â Â ENDDO |
---|
3762 | |
---|
3763 | !--Â Â Â Â Â radiation absorbed by plant canopy |
---|
3764 |       DO icsf = 1, ncsfl |
---|
3765 |         ipcgb = csfsurf(1, icsf) |
---|
3766 |         isurfsrc = csfsurf(2, icsf) |
---|
3767 | |
---|
3768 |         IF ( surf(id, isurfsrc) < isky ) THEN |
---|
3769 | Â Â Â Â Â Â Â Â Â Â pcbinsw(ipcgb)Â =Â pcbinsw(ipcgb)Â +Â csf(1,icsf)Â *Â csf(2,icsf)Â *Â surfouts(isurfsrc) |
---|
3770 | !--Â Â Â Â Â Â Â Â Â pcbinlw(ipcgb) = pcbinlw(ipcgb) + csf(1,icsf) * surfoutl(isurfsrc) |
---|
3771 | Â Â Â Â Â Â Â Â ENDIF |
---|
3772 | Â Â Â Â Â Â ENDDO |
---|
3773 | Â Â Â Â Â Â |
---|
3774 | Â Â Â Â Â Â surfinsw(:)Â =Â surfinsw(:)Â +Â surfins(:) |
---|
3775 | Â Â Â Â Â Â surfinlw(:)Â =Â surfinlw(:)Â +Â surfinl(:) |
---|
3776 | Â Â Â Â Â Â surfoutsw(startenergy:endenergy)Â =Â surfoutsw(startenergy:endenergy)Â +Â surfoutsl(startenergy:endenergy) |
---|
3777 | Â Â Â Â Â Â surfoutlw(startenergy:endenergy)Â =Â surfoutlw(startenergy:endenergy)Â +Â surfoutll(startenergy:endenergy) |
---|
3778 | !       surfhf(startenergy:endenergy) = surfinsw(startenergy:endenergy) + surfinlw(startenergy:endenergy) & |
---|
3779 | !                      - surfoutsw(startenergy:endenergy) - surfoutlw(startenergy:endenergy) |
---|
3780 | Â Â Â Â |
---|
3781 | Â Â Â Â ENDDO |
---|
3782 | |
---|
3783 | !--Â Â Â push heat flux absorbed by plant canopy to respective 3D arrays |
---|
3784 |     IF ( plant_canopy ) THEN |
---|
3785 | Â Â Â Â Â Â pc_heating_rate(:,:,:)Â =Â 0._wp |
---|
3786 |       DO ipcgb = 1, npcbl |
---|
3787 |         j = pcbl(iy, ipcgb) |
---|
3788 |         i = pcbl(ix, ipcgb) |
---|
3789 |         k = pcbl(iz, ipcgb) |
---|
3790 | ! |
---|
3791 | !--Â Â Â Â Â Â Â Following expression equals former kk = k - nzb_s_inner(j,i) |
---|
3792 |         kk = k - ( get_topography_top_index( j, i, 's' ) ) !- lad arrays are defined flat |
---|
3793 |         pc_heating_rate(kk, j, i) = (pcbinsw(ipcgb) + pcbinlw(ipcgb)) & |
---|
3794 |           * pchf_prep(k) * pt(k, j, i) !-- = dT/dt |
---|
3795 | Â Â Â Â Â Â ENDDO |
---|
3796 | Â Â Â Â ENDIF |
---|
3797 | ! |
---|
3798 | !--Â Â Â Transfer radiation arrays required for energy balance to the respective data types |
---|
3799 |     DO i = startenergy, endenergy |
---|
3800 |       m = surfl(5,i)     |
---|
3801 | ! |
---|
3802 | !--Â Â Â Â upward-facing |
---|
3803 | Â Â Â Â Â Â IFÂ (Â surfl(1,i)Â ==Â 0Â )Â THEN |
---|
3804 | Â Â Â Â Â Â Â surf_usm_h%rad_in_sw(m)Â =Â surfinsw(i)Â |
---|
3805 | Â Â Â Â Â Â Â surf_usm_h%rad_out_sw(m)Â =Â surfoutsw(i)Â |
---|
3806 | Â Â Â Â Â Â Â surf_usm_h%rad_in_lw(m)Â =Â surfinlw(i) |
---|
3807 | Â Â Â Â Â Â Â surf_usm_h%rad_out_lw(m)Â =Â surfoutlw(i) |
---|
3808 | ! |
---|
3809 | !--Â Â Â Â southward-facding |
---|
3810 | Â Â Â Â Â Â ELSEIFÂ (Â surfl(1,i)Â ==Â 1Â )Â THEN |
---|
3811 | Â Â Â Â Â Â Â surf_usm_v(1)%rad_in_sw(m)Â =Â surfinsw(i)Â |
---|
3812 | Â Â Â Â Â Â Â surf_usm_v(1)%rad_out_sw(m)Â =Â surfoutsw(i)Â |
---|
3813 | Â Â Â Â Â Â Â surf_usm_v(1)%rad_in_lw(m)Â =Â surfinlw(i) |
---|
3814 | Â Â Â Â Â Â Â surf_usm_v(1)%rad_out_lw(m)Â =Â surfoutlw(i) |
---|
3815 | ! |
---|
3816 | !--Â Â Â Â northward-facding |
---|
3817 | Â Â Â Â Â Â ELSEIFÂ (Â surfl(1,i)Â ==Â 2Â )Â THEN |
---|
3818 | Â Â Â Â Â Â Â surf_usm_v(0)%rad_in_sw(m)Â =Â surfinsw(i)Â |
---|
3819 | Â Â Â Â Â Â Â surf_usm_v(0)%rad_out_sw(m)Â =Â surfoutsw(i)Â |
---|
3820 | Â Â Â Â Â Â Â surf_usm_v(0)%rad_in_lw(m)Â =Â surfinlw(i) |
---|
3821 | Â Â Â Â Â Â Â surf_usm_v(0)%rad_out_lw(m)Â =Â surfoutlw(i) |
---|
3822 | ! |
---|
3823 | !--Â Â Â Â westward-facding |
---|
3824 | Â Â Â Â Â Â ELSEIFÂ (Â surfl(1,i)Â ==Â 3Â )Â THEN |
---|
3825 | Â Â Â Â Â Â Â surf_usm_v(3)%rad_in_sw(m)Â =Â surfinsw(i)Â |
---|
3826 | Â Â Â Â Â Â Â surf_usm_v(3)%rad_out_sw(m)Â =Â surfoutsw(i)Â |
---|
3827 | Â Â Â Â Â Â Â surf_usm_v(3)%rad_in_lw(m)Â =Â surfinlw(i) |
---|
3828 | Â Â Â Â Â Â Â surf_usm_v(3)%rad_out_lw(m)Â =Â surfoutlw(i) |
---|
3829 | ! |
---|
3830 | !--Â Â Â Â eastward-facing |
---|
3831 | Â Â Â Â Â Â ELSEIFÂ (Â surfl(1,i)Â ==Â 4Â )Â THEN |
---|
3832 | Â Â Â Â Â Â Â surf_usm_v(2)%rad_in_sw(m)Â =Â surfinsw(i)Â |
---|
3833 | Â Â Â Â Â Â Â surf_usm_v(2)%rad_out_sw(m)Â =Â surfoutsw(i)Â |
---|
3834 | Â Â Â Â Â Â Â surf_usm_v(2)%rad_in_lw(m)Â =Â surfinlw(i) |
---|
3835 | Â Â Â Â Â Â Â surf_usm_v(2)%rad_out_lw(m)Â =Â surfoutlw(i) |
---|
3836 | Â Â Â Â Â Â ENDIF |
---|
3837 | |
---|
3838 | Â Â Â Â ENDDO |
---|
3839 | |
---|
3840 | |
---|
3841 |     DO m = 1, surf_usm_h%ns |
---|
3842 | Â Â Â Â Â Â surf_usm_h%surfhf(m)Â =Â surf_usm_h%rad_in_sw(m)Â +Â Â Â Â Â Â Â Â Â Â & |
---|
3843 | Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â surf_usm_h%rad_in_lw(m)Â -Â Â Â Â Â Â Â Â Â Â & |
---|
3844 | Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â surf_usm_h%rad_out_sw(m)Â -Â Â Â Â Â Â Â Â Â Â & |
---|
3845 | Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â surf_usm_h%rad_out_lw(m) |
---|
3846 | Â Â Â Â ENDDO |
---|
3847 | |
---|
3848 |     DO l = 0, 3 |
---|
3849 |       DO m = 1, surf_usm_v(l)%ns |
---|
3850 | Â Â Â Â Â Â Â surf_usm_v(l)%surfhf(m)Â =Â surf_usm_v(l)%rad_in_sw(m)Â +Â Â Â Â Â & |
---|
3851 | Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â surf_usm_v(l)%rad_in_lw(m)Â -Â Â Â Â Â & |
---|
3852 | Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â surf_usm_v(l)%rad_out_sw(m)Â -Â Â Â Â Â & |
---|
3853 | Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â Â surf_usm_v(l)%rad_out_lw(m) |
---|
3854 | Â Â Â Â Â Â ENDDO |
---|
3855 | Â Â Â Â ENDDO |
---|
3856 | |
---|
3857 | !--Â Â Â return surface radiation to horizontal surfaces |
---|
3858 | !--Â Â Â to rad_sw_in, rad_lw_in and rad_net for outputs |
---|
3859 | Â Â Â Â !!!!!!!!!! |
---|
3860 | !--Â Â Â we need the original radiation on urban top layer |
---|
3861 | !--Â Â Â for calculation of MRT so we can't do adjustment here for now |
---|
3862 | Â Â Â Â !!!!!!!!!! |
---|
3863 | Â Â Â Â !!!DO isurf = 1, nsurfl |
---|
3864 |     !!!  i = surfl(ix,isurf) |
---|
3865 |     !!!  j = surfl(iy,isurf) |
---|
3866 |     !!!  k = surfl(iz,isurf) |
---|
3867 |     !!!  d = surfl(id,isurf) |
---|
3868 |     !!!  IF ( d==iroof ) THEN |
---|
3869 |     !!!    rad_sw_in(:,j,i) = surfinsw(isurf) |
---|
3870 |     !!!    rad_lw_in(:,j,i) = surfinlw(isurf) |
---|
3871 |     !!!    rad_net(j,i) = rad_sw_in(k,j,i) - rad_sw_out(k,j,i) + rad_lw_in(k,j,i) - rad_lw_out(k,j,i) |
---|
3872 |     !!!  ENDIF |
---|
3873 | Â Â Â Â !!!ENDDO |
---|
3874 | |
---|
3875 | Â Â END SUBROUTINE usm_radiation |
---|
3876 | |
---|
3877 | Â Â |
---|
3878 | !------------------------------------------------------------------------------! |
---|
3879 | ! Description: |
---|
3880 | ! ------------ |
---|
3881 | !> Raytracing for detecting obstacles and calculating compound canopy sink |
---|
3882 | !> factors. (A simple obstacle detection would only need to process faces in |
---|
3883 | !> 3 dimensions without any ordering.) |
---|
3884 | !> Assumtions: |
---|
3885 | !> ----------- |
---|
3886 | !> 1. The ray always originates from a face midpoint (only one coordinate equals |
---|
3887 | !>Â Â *.5, i.e. wall) and doesn't travel parallel to the surface (that would mean |
---|
3888 | !>Â Â shape factor=0). Therefore, the ray may never travel exactly along a face |
---|
3889 | !>Â Â or an edge. |
---|
3890 | !> 2. From grid bottom to urban surface top the grid has to be *equidistant* |
---|
3891 | !>Â Â within each of the dimensions, including vertical (but the resolution |
---|
3892 | !>Â Â doesn't need to be the same in all three dimensions). |
---|
3893 | !------------------------------------------------------------------------------! |
---|
3894 |   SUBROUTINE usm_raytrace(src, targ, isrc, rirrf, atarg, create_csf, visible, transparency, win_lad) |
---|
3895 | Â Â Â Â IMPLICIT NONE |
---|
3896 | |
---|
3897 |     REAL(wp), DIMENSION(3), INTENT(in)   :: src, targ  !< real coordinates z,y,x |
---|
3898 |     INTEGER(iwp), INTENT(in)        :: isrc     !< index of source face for csf |
---|
3899 |     REAL(wp), INTENT(in)          :: rirrf    !< irradiance factor for csf |
---|
3900 |     REAL(wp), INTENT(in)          :: atarg    !< target surface area for csf |
---|
3901 |     LOGICAL, INTENT(in)          :: create_csf  !< whether to generate new CSFs during raytracing |
---|
3902 |     LOGICAL, INTENT(out)          :: visible |
---|
3903 |     REAL(wp), INTENT(out)         :: transparency !< along whole path |
---|
3904 |     INTEGER(iwp), INTENT(in)        :: win_lad |
---|
3905 |     INTEGER(iwp)              :: i, j, k, d |
---|
3906 |     INTEGER(iwp)              :: seldim    !< dimension to be incremented |
---|
3907 |     INTEGER(iwp)              :: ncsb     !< no of written plant canopy sinkboxes |
---|
3908 |     INTEGER(iwp)              :: maxboxes   !< max no of gridboxes visited |
---|
3909 |     REAL(wp)                :: distance   !< euclidean along path |
---|
3910 |     REAL(wp)                :: crlen    !< length of gridbox crossing |
---|
3911 |     REAL(wp)                :: lastdist   !< beginning of current crossing |
---|
3912 |     REAL(wp)                :: nextdist   !< end of current crossing |
---|
3913 |     REAL(wp)                :: realdist   !< distance in meters per unit distance |
---|
3914 |     REAL(wp)                :: crmid    !< midpoint of crossing |
---|
3915 |     REAL(wp)                :: cursink   !< sink factor for current canopy box |
---|
3916 |     REAL(wp), DIMENSION(3)         :: delta    !< path vector |
---|
3917 |     REAL(wp), DIMENSION(3)         :: uvect    !< unit vector |
---|
3918 |     REAL(wp), DIMENSION(3)         :: dimnextdist !< distance for each dimension increments |
---|
3919 |     INTEGER(iwp), DIMENSION(3)       :: box     !< gridbox being crossed |
---|
3920 |     INTEGER(iwp), DIMENSION(3)       :: dimnext   !< next dimension increments along path |
---|
3921 |     INTEGER(iwp), DIMENSION(3)       :: dimdelta |
---|