1 | !> @file radiation_model_mod.f90 |
---|
2 | !------------------------------------------------------------------------------! |
---|
3 | ! This file is part of the PALM model system. |
---|
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-2018 Institute of Computer Science of the |
---|
18 | ! Czech Academy of Sciences, Prague |
---|
19 | ! Copyright 2015-2018 Czech Technical University in Prague |
---|
20 | ! Copyright 1997-2018 Leibniz Universitaet Hannover |
---|
21 | !------------------------------------------------------------------------------! |
---|
22 | ! |
---|
23 | ! Current revisions: |
---|
24 | ! ------------------ |
---|
25 | ! |
---|
26 | ! |
---|
27 | ! Former revisions: |
---|
28 | ! ----------------- |
---|
29 | ! $Id: radiation_model_mod.f90 3528 2018-11-15 19:07:11Z gronemeier $ |
---|
30 | ! Add an epsilon value to compare values in if statement to fix possible |
---|
31 | ! precsion related errors in raytrace routines. |
---|
32 | ! |
---|
33 | ! 3524 2018-11-14 13:36:44Z raasch |
---|
34 | ! missing cpp-directives added |
---|
35 | ! |
---|
36 | ! 3495 2018-11-06 15:22:17Z kanani |
---|
37 | ! Resort control_parameters ONLY list, |
---|
38 | ! From branch radiation@3491 moh.hefny: |
---|
39 | ! bugfix in calculating the apparent solar positions by updating |
---|
40 | ! the simulated time so that the actual time is correct. |
---|
41 | ! |
---|
42 | ! 3464 2018-10-30 18:08:55Z kanani |
---|
43 | ! From branch resler@3462, pavelkrc: |
---|
44 | ! add MRT shaping function for human |
---|
45 | ! |
---|
46 | ! 3449 2018-10-29 19:36:56Z suehring |
---|
47 | ! New RTM version 3.0: (Pavel Krc, Jaroslav Resler, ICS, Prague) |
---|
48 | ! - Interaction of plant canopy with LW radiation |
---|
49 | ! - Transpiration from resolved plant canopy dependent on radiation |
---|
50 | ! called from RTM |
---|
51 | ! |
---|
52 | ! |
---|
53 | ! 3435 2018-10-26 18:25:44Z gronemeier |
---|
54 | ! - workaround: return unit=illegal in check_data_output for certain variables |
---|
55 | ! when check called from init_masks |
---|
56 | ! - Use pointer in masked output to reduce code redundancies |
---|
57 | ! - Add terrain-following masked output |
---|
58 | ! |
---|
59 | ! 3424 2018-10-25 07:29:10Z gronemeier |
---|
60 | ! bugfix: add rad_lw_in, rad_lw_out, rad_sw_out to radiation_check_data_output |
---|
61 | ! |
---|
62 | ! 3378 2018-10-19 12:34:59Z kanani |
---|
63 | ! merge from radiation branch (r3362) into trunk |
---|
64 | ! (moh.hefny): |
---|
65 | ! - removed read/write_svf_on_init and read_dist_max_svf (not used anymore) |
---|
66 | ! - bugfix nzut > nzpt in calculating maxboxes |
---|
67 | ! |
---|
68 | ! 3372 2018-10-18 14:03:19Z raasch |
---|
69 | ! bugfix: kind type of 2nd argument of mpi_win_allocate changed, misplaced |
---|
70 | ! __parallel directive |
---|
71 | ! |
---|
72 | ! 3351 2018-10-15 18:40:42Z suehring |
---|
73 | ! Do not overwrite values of spectral and broadband albedo during initialization |
---|
74 | ! if they are already initialized in the urban-surface model via ASCII input. |
---|
75 | ! |
---|
76 | ! 3337 2018-10-12 15:17:09Z kanani |
---|
77 | ! - New RTM version 2.9: (Pavel Krc, Jaroslav Resler, ICS, Prague) |
---|
78 | ! added calculation of the MRT inside the RTM module |
---|
79 | ! MRT fluxes are consequently used in the new biometeorology module |
---|
80 | ! for calculation of biological indices (MRT, PET) |
---|
81 | ! Fixes of v. 2.5 and SVN trunk: |
---|
82 | ! - proper initialization of rad_net_l |
---|
83 | ! - make arrays nsurfs and surfstart TARGET to prevent some MPI problems |
---|
84 | ! - initialization of arrays used in MPI one-sided operation as 1-D arrays |
---|
85 | ! to prevent problems with some MPI/compiler combinations |
---|
86 | ! - fix indexing of target displacement in subroutine request_itarget to |
---|
87 | ! consider nzub |
---|
88 | ! - fix LAD dimmension range in PCB calculation |
---|
89 | ! - check ierr in all MPI calls |
---|
90 | ! - use proper per-gridbox sky and diffuse irradiance |
---|
91 | ! - fix shading for reflected irradiance |
---|
92 | ! - clear away the residuals of "atmospheric surfaces" implementation |
---|
93 | ! - fix rounding bug in raytrace_2d introduced in SVN trunk |
---|
94 | ! - New RTM version 2.5: (Pavel Krc, Jaroslav Resler, ICS, Prague) |
---|
95 | ! can use angular discretization for all SVF |
---|
96 | ! (i.e. reflected and emitted radiation in addition to direct and diffuse), |
---|
97 | ! allowing for much better scaling wih high resoltion and/or complex terrain |
---|
98 | ! - Unite array grow factors |
---|
99 | ! - Fix slightly shifted terrain height in raytrace_2d |
---|
100 | ! - Use more efficient MPI_Win_allocate for reverse gridsurf index |
---|
101 | ! - Fix random MPI RMA bugs on Intel compilers |
---|
102 | ! - Fix approx. double plant canopy sink values for reflected radiation |
---|
103 | ! - Fix mostly missing plant canopy sinks for direct radiation |
---|
104 | ! - Fix discretization errors for plant canopy sink in diffuse radiation |
---|
105 | ! - Fix rounding errors in raytrace_2d |
---|
106 | ! |
---|
107 | ! 3274 2018-09-24 15:42:55Z knoop |
---|
108 | ! Modularization of all bulk cloud physics code components |
---|
109 | ! |
---|
110 | ! 3272 2018-09-24 10:16:32Z suehring |
---|
111 | ! - split direct and diffusion shortwave radiation using RRTMG rather than using |
---|
112 | ! calc_diffusion_radiation, in case of RRTMG |
---|
113 | ! - removed the namelist variable split_diffusion_radiation. Now splitting depends |
---|
114 | ! on the choise of radiation radiation scheme |
---|
115 | ! - removed calculating the rdiation flux for surfaces at the radiation scheme |
---|
116 | ! in case of using RTM since it will be calculated anyway in the radiation |
---|
117 | ! interaction routine. |
---|
118 | ! - set SW radiation flux for surfaces to zero at night in case of no RTM is used |
---|
119 | ! - precalculate the unit vector yxdir of ray direction to avoid the temporarly |
---|
120 | ! array allocation during the subroutine call |
---|
121 | ! - fixed a bug in calculating the max number of boxes ray can cross in the domain |
---|
122 | ! |
---|
123 | ! 3264 2018-09-20 13:54:11Z moh.hefny |
---|
124 | ! Bugfix in raytrace_2d calls |
---|
125 | ! |
---|
126 | ! 3248 2018-09-14 09:42:06Z sward |
---|
127 | ! Minor formating changes |
---|
128 | ! |
---|
129 | ! 3246 2018-09-13 15:14:50Z sward |
---|
130 | ! Added error handling for input namelist via parin_fail_message |
---|
131 | ! |
---|
132 | ! 3241 2018-09-12 15:02:00Z raasch |
---|
133 | ! unused variables removed or commented |
---|
134 | ! |
---|
135 | ! 3233 2018-09-07 13:21:24Z schwenkel |
---|
136 | ! Adapted for the use of cloud_droplets |
---|
137 | ! |
---|
138 | ! 3230 2018-09-05 09:29:05Z schwenkel |
---|
139 | ! Bugfix in radiation_constant_surf: changed (10.0 - emissivity_urb) to |
---|
140 | ! (1.0 - emissivity_urb) |
---|
141 | ! |
---|
142 | ! 3226 2018-08-31 12:27:09Z suehring |
---|
143 | ! Bugfixes in calculation of sky-view factors and canopy-sink factors. |
---|
144 | ! |
---|
145 | ! 3186 2018-07-30 17:07:14Z suehring |
---|
146 | ! Remove print statement |
---|
147 | ! |
---|
148 | ! 3180 2018-07-27 11:00:56Z suehring |
---|
149 | ! Revise concept for calculation of effective radiative temperature and mapping |
---|
150 | ! of radiative heating |
---|
151 | ! |
---|
152 | ! 3175 2018-07-26 14:07:38Z suehring |
---|
153 | ! Bugfix for commit 3172 |
---|
154 | ! |
---|
155 | ! 3173 2018-07-26 12:55:23Z suehring |
---|
156 | ! Revise output of surface radiation quantities in case of overhanging |
---|
157 | ! structures |
---|
158 | ! |
---|
159 | ! 3172 2018-07-26 12:06:06Z suehring |
---|
160 | ! Bugfixes: |
---|
161 | ! - temporal work-around for calculation of effective radiative surface |
---|
162 | ! temperature |
---|
163 | ! - prevent positive solar radiation during nighttime |
---|
164 | ! |
---|
165 | ! 3170 2018-07-25 15:19:37Z suehring |
---|
166 | ! Bugfix, map signle-column radiation forcing profiles on top of any topography |
---|
167 | ! |
---|
168 | ! 3156 2018-07-19 16:30:54Z knoop |
---|
169 | ! Bugfix: replaced usage of the pt array with the surf%pt_surface array |
---|
170 | ! |
---|
171 | ! 3137 2018-07-17 06:44:21Z maronga |
---|
172 | ! String length for trace_names fixed |
---|
173 | ! |
---|
174 | ! 3127 2018-07-15 08:01:25Z maronga |
---|
175 | ! A few pavement parameters updated. |
---|
176 | ! |
---|
177 | ! 3123 2018-07-12 16:21:53Z suehring |
---|
178 | ! Correct working precision for INTEGER number |
---|
179 | ! |
---|
180 | ! 3122 2018-07-11 21:46:41Z maronga |
---|
181 | ! Bugfix: maximum distance for raytracing was set to -999 m by default, |
---|
182 | ! effectively switching off all surface reflections when max_raytracing_dist |
---|
183 | ! was not explicitly set in namelist |
---|
184 | ! |
---|
185 | ! 3117 2018-07-11 09:59:11Z maronga |
---|
186 | ! Bugfix: water vapor was not transfered to RRTMG when bulk_cloud_model = .F. |
---|
187 | ! Bugfix: changed the calculation of RRTMG boundary conditions (Mohamed Salim) |
---|
188 | ! Bugfix: dry residual atmosphere is replaced by standard RRTMG atmosphere |
---|
189 | ! |
---|
190 | ! 3116 2018-07-10 14:31:58Z suehring |
---|
191 | ! Output of long/shortwave radiation at surface |
---|
192 | ! |
---|
193 | ! 3107 2018-07-06 15:55:51Z suehring |
---|
194 | ! Bugfix, missing index for dz |
---|
195 | ! |
---|
196 | ! 3066 2018-06-12 08:55:55Z Giersch |
---|
197 | ! Error message revised |
---|
198 | ! |
---|
199 | ! 3065 2018-06-12 07:03:02Z Giersch |
---|
200 | ! dz was replaced by dz(1), error message concerning vertical stretching was |
---|
201 | ! added |
---|
202 | ! |
---|
203 | ! 3049 2018-05-29 13:52:36Z Giersch |
---|
204 | ! Error messages revised |
---|
205 | ! |
---|
206 | ! 3045 2018-05-28 07:55:41Z Giersch |
---|
207 | ! Error message revised |
---|
208 | ! |
---|
209 | ! 3026 2018-05-22 10:30:53Z schwenkel |
---|
210 | ! Changed the name specific humidity to mixing ratio, since we are computing |
---|
211 | ! mixing ratios. |
---|
212 | ! |
---|
213 | ! 3016 2018-05-09 10:53:37Z Giersch |
---|
214 | ! Revised structure of reading svf data according to PALM coding standard: |
---|
215 | ! svf_code_field/len and fsvf removed, error messages PA0493 and PA0494 added, |
---|
216 | ! allocation status of output arrays checked. |
---|
217 | ! |
---|
218 | ! 3014 2018-05-09 08:42:38Z maronga |
---|
219 | ! Introduced plant canopy height similar to urban canopy height to limit |
---|
220 | ! the memory requirement to allocate lad. |
---|
221 | ! Deactivated automatic setting of minimum raytracing distance. |
---|
222 | ! |
---|
223 | ! 3004 2018-04-27 12:33:25Z Giersch |
---|
224 | ! Further allocation checks implemented (averaged data will be assigned to fill |
---|
225 | ! values if no allocation happened so far) |
---|
226 | ! |
---|
227 | ! 2995 2018-04-19 12:13:16Z Giersch |
---|
228 | ! IF-statement in radiation_init removed so that the calculation of radiative |
---|
229 | ! fluxes at model start is done in any case, bugfix in |
---|
230 | ! radiation_presimulate_solar_pos (end_time is the sum of end_time and the |
---|
231 | ! spinup_time specified in the p3d_file ), list of variables/fields that have |
---|
232 | ! to be written out or read in case of restarts has been extended |
---|
233 | ! |
---|
234 | ! 2977 2018-04-17 10:27:57Z kanani |
---|
235 | ! Implement changes from branch radiation (r2948-2971) with minor modifications, |
---|
236 | ! plus some formatting. |
---|
237 | ! (moh.hefny): |
---|
238 | ! - replaced plant_canopy by npcbl to check tree existence to avoid weird |
---|
239 | ! allocation of related arrays (after domain decomposition some domains |
---|
240 | ! contains no trees although plant_canopy (global parameter) is still TRUE). |
---|
241 | ! - added a namelist parameter to force RTM settings |
---|
242 | ! - enabled the option to switch radiation reflections off |
---|
243 | ! - renamed surf_reflections to surface_reflections |
---|
244 | ! - removed average_radiation flag from the namelist (now it is implicitly set |
---|
245 | ! in init_3d_model according to RTM) |
---|
246 | ! - edited read and write sky view factors and CSF routines to account for |
---|
247 | ! the sub-domains which may not contain any of them |
---|
248 | ! |
---|
249 | ! 2967 2018-04-13 11:22:08Z raasch |
---|
250 | ! bugfix: missing parallel cpp-directives added |
---|
251 | ! |
---|
252 | ! 2964 2018-04-12 16:04:03Z Giersch |
---|
253 | ! Error message PA0491 has been introduced which could be previously found in |
---|
254 | ! check_open. The variable numprocs_previous_run is only known in case of |
---|
255 | ! initializing_actions == read_restart_data |
---|
256 | ! |
---|
257 | ! 2963 2018-04-12 14:47:44Z suehring |
---|
258 | ! - Introduce index for vegetation/wall, pavement/green-wall and water/window |
---|
259 | ! surfaces, for clearer access of surface fraction, albedo, emissivity, etc. . |
---|
260 | ! - Minor bugfix in initialization of albedo for window surfaces |
---|
261 | ! |
---|
262 | ! 2944 2018-04-03 16:20:18Z suehring |
---|
263 | ! Fixed bad commit |
---|
264 | ! |
---|
265 | ! 2943 2018-04-03 16:17:10Z suehring |
---|
266 | ! No read of nsurfl from SVF file since it is calculated in |
---|
267 | ! radiation_interaction_init, |
---|
268 | ! allocation of arrays in radiation_read_svf only if not yet allocated, |
---|
269 | ! update of 2920 revision comment. |
---|
270 | ! |
---|
271 | ! 2932 2018-03-26 09:39:22Z maronga |
---|
272 | ! renamed radiation_par to radiation_parameters |
---|
273 | ! |
---|
274 | ! 2930 2018-03-23 16:30:46Z suehring |
---|
275 | ! Remove default surfaces from radiation model, does not make much sense to |
---|
276 | ! apply radiation model without energy-balance solvers; Further, add check for |
---|
277 | ! this. |
---|
278 | ! |
---|
279 | ! 2920 2018-03-22 11:22:01Z kanani |
---|
280 | ! - Bugfix: Initialize pcbl array (=-1) |
---|
281 | ! RTM version 2.0 (Jaroslav Resler, Pavel Krc, Mohamed Salim): |
---|
282 | ! - new major version of radiation interactions |
---|
283 | ! - substantially enhanced performance and scalability |
---|
284 | ! - processing of direct and diffuse solar radiation separated from reflected |
---|
285 | ! radiation, removed virtual surfaces |
---|
286 | ! - new type of sky discretization by azimuth and elevation angles |
---|
287 | ! - diffuse radiation processed cumulatively using sky view factor |
---|
288 | ! - used precalculated apparent solar positions for direct irradiance |
---|
289 | ! - added new 2D raytracing process for processing whole vertical column at once |
---|
290 | ! to increase memory efficiency and decrease number of MPI RMA operations |
---|
291 | ! - enabled limiting the number of view factors between surfaces by the distance |
---|
292 | ! and value |
---|
293 | ! - fixing issues induced by transferring radiation interactions from |
---|
294 | ! urban_surface_mod to radiation_mod |
---|
295 | ! - bugfixes and other minor enhancements |
---|
296 | ! |
---|
297 | ! 2906 2018-03-19 08:56:40Z Giersch |
---|
298 | ! NAMELIST paramter read/write_svf_on_init have been removed, functions |
---|
299 | ! check_open and close_file are used now for opening/closing files related to |
---|
300 | ! svf data, adjusted unit number and error numbers |
---|
301 | ! |
---|
302 | ! 2894 2018-03-15 09:17:58Z Giersch |
---|
303 | ! Calculations of the index range of the subdomain on file which overlaps with |
---|
304 | ! the current subdomain are already done in read_restart_data_mod |
---|
305 | ! radiation_read_restart_data was renamed to radiation_rrd_local and |
---|
306 | ! radiation_last_actions was renamed to radiation_wrd_local, variable named |
---|
307 | ! found has been introduced for checking if restart data was found, reading |
---|
308 | ! of restart strings has been moved completely to read_restart_data_mod, |
---|
309 | ! radiation_rrd_local is already inside the overlap loop programmed in |
---|
310 | ! read_restart_data_mod, the marker *** end rad *** is not necessary anymore, |
---|
311 | ! strings and their respective lengths are written out and read now in case of |
---|
312 | ! restart runs to get rid of prescribed character lengths (Giersch) |
---|
313 | ! |
---|
314 | ! 2809 2018-02-15 09:55:58Z suehring |
---|
315 | ! Bugfix for gfortran: Replace the function C_SIZEOF with STORAGE_SIZE |
---|
316 | ! |
---|
317 | ! 2753 2018-01-16 14:16:49Z suehring |
---|
318 | ! Tile approach for spectral albedo implemented. |
---|
319 | ! |
---|
320 | ! 2746 2018-01-15 12:06:04Z suehring |
---|
321 | ! Move flag plant canopy to modules |
---|
322 | ! |
---|
323 | ! 2724 2018-01-05 12:12:38Z maronga |
---|
324 | ! Set default of average_radiation to .FALSE. |
---|
325 | ! |
---|
326 | ! 2723 2018-01-05 09:27:03Z maronga |
---|
327 | ! Bugfix in calculation of rad_lw_out (clear-sky). First grid level was used |
---|
328 | ! instead of the surface value |
---|
329 | ! |
---|
330 | ! 2718 2018-01-02 08:49:38Z maronga |
---|
331 | ! Corrected "Former revisions" section |
---|
332 | ! |
---|
333 | ! 2707 2017-12-18 18:34:46Z suehring |
---|
334 | ! Changes from last commit documented |
---|
335 | ! |
---|
336 | ! 2706 2017-12-18 18:33:49Z suehring |
---|
337 | ! Bugfix, in average radiation case calculate exner function before using it. |
---|
338 | ! |
---|
339 | ! 2701 2017-12-15 15:40:50Z suehring |
---|
340 | ! Changes from last commit documented |
---|
341 | ! |
---|
342 | ! 2698 2017-12-14 18:46:24Z suehring |
---|
343 | ! Bugfix in get_topography_top_index |
---|
344 | ! |
---|
345 | ! 2696 2017-12-14 17:12:51Z kanani |
---|
346 | ! - Change in file header (GPL part) |
---|
347 | ! - Improved reading/writing of SVF from/to file (BM) |
---|
348 | ! - Bugfixes concerning RRTMG as well as average_radiation options (M. Salim) |
---|
349 | ! - Revised initialization of surface albedo and some minor bugfixes (MS) |
---|
350 | ! - Update net radiation after running radiation interaction routine (MS) |
---|
351 | ! - Revisions from M Salim included |
---|
352 | ! - Adjustment to topography and surface structure (MS) |
---|
353 | ! - Initialization of albedo and surface emissivity via input file (MS) |
---|
354 | ! - albedo_pars extended (MS) |
---|
355 | ! |
---|
356 | ! 2604 2017-11-06 13:29:00Z schwenkel |
---|
357 | ! bugfix for calculation of effective radius using morrison microphysics |
---|
358 | ! |
---|
359 | ! 2601 2017-11-02 16:22:46Z scharf |
---|
360 | ! added emissivity to namelist |
---|
361 | ! |
---|
362 | ! 2575 2017-10-24 09:57:58Z maronga |
---|
363 | ! Bugfix: calculation of shortwave and longwave albedos for RRTMG swapped |
---|
364 | ! |
---|
365 | ! 2547 2017-10-16 12:41:56Z schwenkel |
---|
366 | ! extended by cloud_droplets option, minor bugfix and correct calculation of |
---|
367 | ! cloud droplet number concentration |
---|
368 | ! |
---|
369 | ! 2544 2017-10-13 18:09:32Z maronga |
---|
370 | ! Moved date and time quantitis to separate module date_and_time_mod |
---|
371 | ! |
---|
372 | ! 2512 2017-10-04 08:26:59Z raasch |
---|
373 | ! upper bounds of cross section and 3d output changed from nx+1,ny+1 to nx,ny |
---|
374 | ! no output of ghost layer data |
---|
375 | ! |
---|
376 | ! 2504 2017-09-27 10:36:13Z maronga |
---|
377 | ! Updates pavement types and albedo parameters |
---|
378 | ! |
---|
379 | ! 2328 2017-08-03 12:34:22Z maronga |
---|
380 | ! Emissivity can now be set individually for each pixel. |
---|
381 | ! Albedo type can be inferred from land surface model. |
---|
382 | ! Added default albedo type for bare soil |
---|
383 | ! |
---|
384 | ! 2318 2017-07-20 17:27:44Z suehring |
---|
385 | ! Get topography top index via Function call |
---|
386 | ! |
---|
387 | ! 2317 2017-07-20 17:27:19Z suehring |
---|
388 | ! Improved syntax layout |
---|
389 | ! |
---|
390 | ! 2298 2017-06-29 09:28:18Z raasch |
---|
391 | ! type of write_binary changed from CHARACTER to LOGICAL |
---|
392 | ! |
---|
393 | ! 2296 2017-06-28 07:53:56Z maronga |
---|
394 | ! Added output of rad_sw_out for radiation_scheme = 'constant' |
---|
395 | ! |
---|
396 | ! 2270 2017-06-09 12:18:47Z maronga |
---|
397 | ! Numbering changed (2 timeseries removed) |
---|
398 | ! |
---|
399 | ! 2249 2017-06-06 13:58:01Z sward |
---|
400 | ! Allow for RRTMG runs without humidity/cloud physics |
---|
401 | ! |
---|
402 | ! 2248 2017-06-06 13:52:54Z sward |
---|
403 | ! Error no changed |
---|
404 | ! |
---|
405 | ! 2233 2017-05-30 18:08:54Z suehring |
---|
406 | ! |
---|
407 | ! 2232 2017-05-30 17:47:52Z suehring |
---|
408 | ! Adjustments to new topography concept |
---|
409 | ! Bugfix in read restart |
---|
410 | ! |
---|
411 | ! 2200 2017-04-11 11:37:51Z suehring |
---|
412 | ! Bugfix in call of exchange_horiz_2d and read restart data |
---|
413 | ! |
---|
414 | ! 2163 2017-03-01 13:23:15Z schwenkel |
---|
415 | ! Bugfix in radiation_check_data_output |
---|
416 | ! |
---|
417 | ! 2157 2017-02-22 15:10:35Z suehring |
---|
418 | ! Bugfix in read_restart data |
---|
419 | ! |
---|
420 | ! 2011 2016-09-19 17:29:57Z kanani |
---|
421 | ! Removed CALL of auxiliary SUBROUTINE get_usm_info, |
---|
422 | ! flag urban_surface is now defined in module control_parameters. |
---|
423 | ! |
---|
424 | ! 2007 2016-08-24 15:47:17Z kanani |
---|
425 | ! Added calculation of solar directional vector for new urban surface |
---|
426 | ! model, |
---|
427 | ! accounted for urban_surface model in radiation_check_parameters, |
---|
428 | ! correction of comments for zenith angle. |
---|
429 | ! |
---|
430 | ! 2000 2016-08-20 18:09:15Z knoop |
---|
431 | ! Forced header and separation lines into 80 columns |
---|
432 | ! |
---|
433 | ! 1976 2016-07-27 13:28:04Z maronga |
---|
434 | ! Output of 2D/3D/masked data is now directly done within this module. The |
---|
435 | ! radiation schemes have been simplified for better usability so that |
---|
436 | ! rad_lw_in, rad_lw_out, rad_sw_in, and rad_sw_out are available independent of |
---|
437 | ! the radiation code used. |
---|
438 | ! |
---|
439 | ! 1856 2016-04-13 12:56:17Z maronga |
---|
440 | ! Bugfix: allocation of rad_lw_out for radiation_scheme = 'clear-sky' |
---|
441 | ! |
---|
442 | ! 1853 2016-04-11 09:00:35Z maronga |
---|
443 | ! Added routine for radiation_scheme = constant. |
---|
444 | ! |
---|
445 | ! 1849 2016-04-08 11:33:18Z hoffmann |
---|
446 | ! Adapted for modularization of microphysics |
---|
447 | ! |
---|
448 | ! 1826 2016-04-07 12:01:39Z maronga |
---|
449 | ! Further modularization. |
---|
450 | ! |
---|
451 | ! 1788 2016-03-10 11:01:04Z maronga |
---|
452 | ! Added new albedo class for pavements / roads. |
---|
453 | ! |
---|
454 | ! 1783 2016-03-06 18:36:17Z raasch |
---|
455 | ! palm-netcdf-module removed in order to avoid a circular module dependency, |
---|
456 | ! netcdf-variables moved to netcdf-module, new routine netcdf_handle_error_rad |
---|
457 | ! added |
---|
458 | ! |
---|
459 | ! 1757 2016-02-22 15:49:32Z maronga |
---|
460 | ! Added parameter unscheduled_radiation_calls. Bugfix: interpolation of sounding |
---|
461 | ! profiles for pressure and temperature above the LES domain. |
---|
462 | ! |
---|
463 | ! 1709 2015-11-04 14:47:01Z maronga |
---|
464 | ! Bugfix: set initial value for rrtm_lwuflx_dt to zero, small formatting |
---|
465 | ! corrections |
---|
466 | ! |
---|
467 | ! 1701 2015-11-02 07:43:04Z maronga |
---|
468 | ! Bugfixes: wrong index for output of timeseries, setting of nz_snd_end |
---|
469 | ! |
---|
470 | ! 1691 2015-10-26 16:17:44Z maronga |
---|
471 | ! Added option for spin-up runs without radiation (skip_time_do_radiation). Bugfix |
---|
472 | ! in calculation of pressure profiles. Bugfix in calculation of trace gas profiles. |
---|
473 | ! Added output of radiative heating rates. |
---|
474 | ! |
---|
475 | ! 1682 2015-10-07 23:56:08Z knoop |
---|
476 | ! Code annotations made doxygen readable |
---|
477 | ! |
---|
478 | ! 1606 2015-06-29 10:43:37Z maronga |
---|
479 | ! Added preprocessor directive __netcdf to allow for compiling without netCDF. |
---|
480 | ! Note, however, that RRTMG cannot be used without netCDF. |
---|
481 | ! |
---|
482 | ! 1590 2015-05-08 13:56:27Z maronga |
---|
483 | ! Bugfix: definition of character strings requires same length for all elements |
---|
484 | ! |
---|
485 | ! 1587 2015-05-04 14:19:01Z maronga |
---|
486 | ! Added albedo class for snow |
---|
487 | ! |
---|
488 | ! 1585 2015-04-30 07:05:52Z maronga |
---|
489 | ! Added support for RRTMG |
---|
490 | ! |
---|
491 | ! 1571 2015-03-12 16:12:49Z maronga |
---|
492 | ! Added missing KIND attribute. Removed upper-case variable names |
---|
493 | ! |
---|
494 | ! 1551 2015-03-03 14:18:16Z maronga |
---|
495 | ! Added support for data output. Various variables have been renamed. Added |
---|
496 | ! interface for different radiation schemes (currently: clear-sky, constant, and |
---|
497 | ! RRTM (not yet implemented). |
---|
498 | ! |
---|
499 | ! 1496 2014-12-02 17:25:50Z maronga |
---|
500 | ! Initial revision |
---|
501 | ! |
---|
502 | ! |
---|
503 | ! Description: |
---|
504 | ! ------------ |
---|
505 | !> Radiation models and interfaces |
---|
506 | !> @todo Replace dz(1) appropriatly to account for grid stretching |
---|
507 | !> @todo move variable definitions used in radiation_init only to the subroutine |
---|
508 | !> as they are no longer required after initialization. |
---|
509 | !> @todo Output of full column vertical profiles used in RRTMG |
---|
510 | !> @todo Output of other rrtm arrays (such as volume mixing ratios) |
---|
511 | !> @todo Check for mis-used NINT() calls in raytrace_2d |
---|
512 | !> RESULT: Original was correct (carefully verified formula), the change |
---|
513 | !> to INT broke raytracing -- P. Krc |
---|
514 | !> @todo Optimize radiation_tendency routines |
---|
515 | !> |
---|
516 | !> @note Many variables have a leading dummy dimension (0:0) in order to |
---|
517 | !> match the assume-size shape expected by the RRTMG model. |
---|
518 | !------------------------------------------------------------------------------! |
---|
519 | MODULE radiation_model_mod |
---|
520 | |
---|
521 | USE arrays_3d, & |
---|
522 | ONLY: dzw, hyp, nc, pt, p, q, ql, u, v, w, zu, zw, exner, d_exner |
---|
523 | |
---|
524 | USE basic_constants_and_equations_mod, & |
---|
525 | ONLY: c_p, g, lv_d_cp, l_v, pi, r_d, rho_l, solar_constant, & |
---|
526 | barometric_formula |
---|
527 | |
---|
528 | USE calc_mean_profile_mod, & |
---|
529 | ONLY: calc_mean_profile |
---|
530 | |
---|
531 | USE control_parameters, & |
---|
532 | ONLY: cloud_droplets, coupling_char, dz, dt_spinup, end_time, & |
---|
533 | humidity, & |
---|
534 | initializing_actions, io_blocks, io_group, & |
---|
535 | land_surface, large_scale_forcing, & |
---|
536 | latitude, longitude, lsf_surf, & |
---|
537 | message_string, plant_canopy, pt_surface, & |
---|
538 | rho_surface, simulated_time, spinup_time, surface_pressure, & |
---|
539 | time_since_reference_point, urban_surface |
---|
540 | |
---|
541 | USE cpulog, & |
---|
542 | ONLY: cpu_log, log_point, log_point_s |
---|
543 | |
---|
544 | USE grid_variables, & |
---|
545 | ONLY: ddx, ddy, dx, dy |
---|
546 | |
---|
547 | USE date_and_time_mod, & |
---|
548 | ONLY: calc_date_and_time, d_hours_day, d_seconds_hour, day_of_year, & |
---|
549 | d_seconds_year, day_of_year_init, time_utc_init, time_utc |
---|
550 | |
---|
551 | USE indices, & |
---|
552 | ONLY: nnx, nny, nx, nxl, nxlg, nxr, nxrg, ny, nyn, nyng, nys, nysg, & |
---|
553 | nzb, nzt |
---|
554 | |
---|
555 | USE, INTRINSIC :: iso_c_binding |
---|
556 | |
---|
557 | USE kinds |
---|
558 | |
---|
559 | USE bulk_cloud_model_mod, & |
---|
560 | ONLY: bulk_cloud_model, microphysics_morrison, na_init, nc_const, sigma_gc |
---|
561 | |
---|
562 | #if defined ( __netcdf ) |
---|
563 | USE NETCDF |
---|
564 | #endif |
---|
565 | |
---|
566 | USE netcdf_data_input_mod, & |
---|
567 | ONLY: albedo_type_f, albedo_pars_f, building_type_f, pavement_type_f, & |
---|
568 | vegetation_type_f, water_type_f |
---|
569 | |
---|
570 | USE plant_canopy_model_mod, & |
---|
571 | ONLY: lad_s, pc_heating_rate, pc_transpiration_rate, pc_latent_rate, & |
---|
572 | plant_canopy_transpiration, pcm_calc_transpiration_rate |
---|
573 | |
---|
574 | USE pegrid |
---|
575 | |
---|
576 | #if defined ( __rrtmg ) |
---|
577 | USE parrrsw, & |
---|
578 | ONLY: naerec, nbndsw |
---|
579 | |
---|
580 | USE parrrtm, & |
---|
581 | ONLY: nbndlw |
---|
582 | |
---|
583 | USE rrtmg_lw_init, & |
---|
584 | ONLY: rrtmg_lw_ini |
---|
585 | |
---|
586 | USE rrtmg_sw_init, & |
---|
587 | ONLY: rrtmg_sw_ini |
---|
588 | |
---|
589 | USE rrtmg_lw_rad, & |
---|
590 | ONLY: rrtmg_lw |
---|
591 | |
---|
592 | USE rrtmg_sw_rad, & |
---|
593 | ONLY: rrtmg_sw |
---|
594 | #endif |
---|
595 | USE statistics, & |
---|
596 | ONLY: hom |
---|
597 | |
---|
598 | USE surface_mod, & |
---|
599 | ONLY: get_topography_top_index, get_topography_top_index_ji, & |
---|
600 | ind_pav_green, ind_veg_wall, ind_wat_win, & |
---|
601 | surf_lsm_h, surf_lsm_v, surf_type, surf_usm_h, surf_usm_v |
---|
602 | |
---|
603 | IMPLICIT NONE |
---|
604 | |
---|
605 | CHARACTER(10) :: radiation_scheme = 'clear-sky' ! 'constant', 'clear-sky', or 'rrtmg' |
---|
606 | |
---|
607 | ! |
---|
608 | !-- Predefined Land surface classes (albedo_type) after Briegleb (1992) |
---|
609 | CHARACTER(37), DIMENSION(0:33), PARAMETER :: albedo_type_name = (/ & |
---|
610 | 'user defined ', & ! 0 |
---|
611 | 'ocean ', & ! 1 |
---|
612 | 'mixed farming, tall grassland ', & ! 2 |
---|
613 | 'tall/medium grassland ', & ! 3 |
---|
614 | 'evergreen shrubland ', & ! 4 |
---|
615 | 'short grassland/meadow/shrubland ', & ! 5 |
---|
616 | 'evergreen needleleaf forest ', & ! 6 |
---|
617 | 'mixed deciduous evergreen forest ', & ! 7 |
---|
618 | 'deciduous forest ', & ! 8 |
---|
619 | 'tropical evergreen broadleaved forest', & ! 9 |
---|
620 | 'medium/tall grassland/woodland ', & ! 10 |
---|
621 | 'desert, sandy ', & ! 11 |
---|
622 | 'desert, rocky ', & ! 12 |
---|
623 | 'tundra ', & ! 13 |
---|
624 | 'land ice ', & ! 14 |
---|
625 | 'sea ice ', & ! 15 |
---|
626 | 'snow ', & ! 16 |
---|
627 | 'bare soil ', & ! 17 |
---|
628 | 'asphalt/concrete mix ', & ! 18 |
---|
629 | 'asphalt (asphalt concrete) ', & ! 19 |
---|
630 | 'concrete (Portland concrete) ', & ! 20 |
---|
631 | 'sett ', & ! 21 |
---|
632 | 'paving stones ', & ! 22 |
---|
633 | 'cobblestone ', & ! 23 |
---|
634 | 'metal ', & ! 24 |
---|
635 | 'wood ', & ! 25 |
---|
636 | 'gravel ', & ! 26 |
---|
637 | 'fine gravel ', & ! 27 |
---|
638 | 'pebblestone ', & ! 28 |
---|
639 | 'woodchips ', & ! 29 |
---|
640 | 'tartan (sports) ', & ! 30 |
---|
641 | 'artifical turf (sports) ', & ! 31 |
---|
642 | 'clay (sports) ', & ! 32 |
---|
643 | 'building (dummy) ' & ! 33 |
---|
644 | /) |
---|
645 | |
---|
646 | REAL(wp), PARAMETER :: sigma_sb = 5.67037321E-8_wp !< Stefan-Boltzmann constant |
---|
647 | |
---|
648 | INTEGER(iwp) :: albedo_type = 9999999, & !< Albedo surface type |
---|
649 | dots_rad = 0 !< starting index for timeseries output |
---|
650 | |
---|
651 | LOGICAL :: unscheduled_radiation_calls = .TRUE., & !< flag parameter indicating whether additional calls of the radiation code are allowed |
---|
652 | constant_albedo = .FALSE., & !< flag parameter indicating whether the albedo may change depending on zenith |
---|
653 | force_radiation_call = .FALSE., & !< flag parameter for unscheduled radiation calls |
---|
654 | lw_radiation = .TRUE., & !< flag parameter indicating whether longwave radiation shall be calculated |
---|
655 | radiation = .FALSE., & !< flag parameter indicating whether the radiation model is used |
---|
656 | sun_up = .TRUE., & !< flag parameter indicating whether the sun is up or down |
---|
657 | sw_radiation = .TRUE., & !< flag parameter indicating whether shortwave radiation shall be calculated |
---|
658 | sun_direction = .FALSE., & !< flag parameter indicating whether solar direction shall be calculated |
---|
659 | average_radiation = .FALSE., & !< flag to set the calculation of radiation averaging for the domain |
---|
660 | radiation_interactions = .FALSE., & !< flag to activiate RTM (TRUE only if vertical urban/land surface and trees exist) |
---|
661 | surface_reflections = .TRUE., & !< flag to switch the calculation of radiation interaction between surfaces. |
---|
662 | !< When it switched off, only the effect of buildings and trees shadow |
---|
663 | !< will be considered. However fewer SVFs are expected. |
---|
664 | radiation_interactions_on = .TRUE. !< namelist flag to force RTM activiation regardless to vertical urban/land surface and trees |
---|
665 | |
---|
666 | REAL(wp) :: albedo = 9999999.9_wp, & !< NAMELIST alpha |
---|
667 | albedo_lw_dif = 9999999.9_wp, & !< NAMELIST aldif |
---|
668 | albedo_lw_dir = 9999999.9_wp, & !< NAMELIST aldir |
---|
669 | albedo_sw_dif = 9999999.9_wp, & !< NAMELIST asdif |
---|
670 | albedo_sw_dir = 9999999.9_wp, & !< NAMELIST asdir |
---|
671 | decl_1, & !< declination coef. 1 |
---|
672 | decl_2, & !< declination coef. 2 |
---|
673 | decl_3, & !< declination coef. 3 |
---|
674 | dt_radiation = 0.0_wp, & !< radiation model timestep |
---|
675 | emissivity = 9999999.9_wp, & !< NAMELIST surface emissivity |
---|
676 | lon = 0.0_wp, & !< longitude in radians |
---|
677 | lat = 0.0_wp, & !< latitude in radians |
---|
678 | net_radiation = 0.0_wp, & !< net radiation at surface |
---|
679 | skip_time_do_radiation = 0.0_wp, & !< Radiation model is not called before this time |
---|
680 | sky_trans, & !< sky transmissivity |
---|
681 | time_radiation = 0.0_wp !< time since last call of radiation code |
---|
682 | |
---|
683 | |
---|
684 | REAL(wp), DIMENSION(0:0) :: zenith, & !< cosine of solar zenith angle |
---|
685 | sun_dir_lat, & !< solar directional vector in latitudes |
---|
686 | sun_dir_lon !< solar directional vector in longitudes |
---|
687 | |
---|
688 | REAL(wp), DIMENSION(:,:), ALLOCATABLE :: rad_net_av !< average of net radiation (rad_net) at surface |
---|
689 | REAL(wp), DIMENSION(:,:), ALLOCATABLE :: rad_lw_in_xy_av !< average of incoming longwave radiation at surface |
---|
690 | REAL(wp), DIMENSION(:,:), ALLOCATABLE :: rad_lw_out_xy_av !< average of outgoing longwave radiation at surface |
---|
691 | REAL(wp), DIMENSION(:,:), ALLOCATABLE :: rad_sw_in_xy_av !< average of incoming shortwave radiation at surface |
---|
692 | REAL(wp), DIMENSION(:,:), ALLOCATABLE :: rad_sw_out_xy_av !< average of outgoing shortwave radiation at surface |
---|
693 | ! |
---|
694 | !-- Land surface albedos for solar zenith angle of 60° after Briegleb (1992) |
---|
695 | !-- (shortwave, longwave, broadband): sw, lw, bb, |
---|
696 | REAL(wp), DIMENSION(0:2,1:33), PARAMETER :: albedo_pars = RESHAPE( (/& |
---|
697 | 0.06_wp, 0.06_wp, 0.06_wp, & ! 1 |
---|
698 | 0.09_wp, 0.28_wp, 0.19_wp, & ! 2 |
---|
699 | 0.11_wp, 0.33_wp, 0.23_wp, & ! 3 |
---|
700 | 0.11_wp, 0.33_wp, 0.23_wp, & ! 4 |
---|
701 | 0.14_wp, 0.34_wp, 0.25_wp, & ! 5 |
---|
702 | 0.06_wp, 0.22_wp, 0.14_wp, & ! 6 |
---|
703 | 0.06_wp, 0.27_wp, 0.17_wp, & ! 7 |
---|
704 | 0.06_wp, 0.31_wp, 0.19_wp, & ! 8 |
---|
705 | 0.06_wp, 0.22_wp, 0.14_wp, & ! 9 |
---|
706 | 0.06_wp, 0.28_wp, 0.18_wp, & ! 10 |
---|
707 | 0.35_wp, 0.51_wp, 0.43_wp, & ! 11 |
---|
708 | 0.24_wp, 0.40_wp, 0.32_wp, & ! 12 |
---|
709 | 0.10_wp, 0.27_wp, 0.19_wp, & ! 13 |
---|
710 | 0.90_wp, 0.65_wp, 0.77_wp, & ! 14 |
---|
711 | 0.90_wp, 0.65_wp, 0.77_wp, & ! 15 |
---|
712 | 0.95_wp, 0.70_wp, 0.82_wp, & ! 16 |
---|
713 | 0.08_wp, 0.08_wp, 0.08_wp, & ! 17 |
---|
714 | 0.17_wp, 0.17_wp, 0.17_wp, & ! 18 |
---|
715 | 0.17_wp, 0.17_wp, 0.17_wp, & ! 19 |
---|
716 | 0.30_wp, 0.30_wp, 0.30_wp, & ! 20 |
---|
717 | 0.17_wp, 0.17_wp, 0.17_wp, & ! 21 |
---|
718 | 0.17_wp, 0.17_wp, 0.17_wp, & ! 22 |
---|
719 | 0.17_wp, 0.17_wp, 0.17_wp, & ! 23 |
---|
720 | 0.17_wp, 0.17_wp, 0.17_wp, & ! 24 |
---|
721 | 0.17_wp, 0.17_wp, 0.17_wp, & ! 25 |
---|
722 | 0.17_wp, 0.17_wp, 0.17_wp, & ! 26 |
---|
723 | 0.17_wp, 0.17_wp, 0.17_wp, & ! 27 |
---|
724 | 0.17_wp, 0.17_wp, 0.17_wp, & ! 28 |
---|
725 | 0.17_wp, 0.17_wp, 0.17_wp, & ! 29 |
---|
726 | 0.17_wp, 0.17_wp, 0.17_wp, & ! 30 |
---|
727 | 0.17_wp, 0.17_wp, 0.17_wp, & ! 31 |
---|
728 | 0.17_wp, 0.17_wp, 0.17_wp, & ! 32 |
---|
729 | 0.17_wp, 0.17_wp, 0.17_wp & ! 33 |
---|
730 | /), (/ 3, 33 /) ) |
---|
731 | |
---|
732 | REAL(wp), DIMENSION(:,:,:), ALLOCATABLE, TARGET :: & |
---|
733 | rad_lw_cs_hr, & !< longwave clear sky radiation heating rate (K/s) |
---|
734 | rad_lw_cs_hr_av, & !< average of rad_lw_cs_hr |
---|
735 | rad_lw_hr, & !< longwave radiation heating rate (K/s) |
---|
736 | rad_lw_hr_av, & !< average of rad_sw_hr |
---|
737 | rad_lw_in, & !< incoming longwave radiation (W/m2) |
---|
738 | rad_lw_in_av, & !< average of rad_lw_in |
---|
739 | rad_lw_out, & !< outgoing longwave radiation (W/m2) |
---|
740 | rad_lw_out_av, & !< average of rad_lw_out |
---|
741 | rad_sw_cs_hr, & !< shortwave clear sky radiation heating rate (K/s) |
---|
742 | rad_sw_cs_hr_av, & !< average of rad_sw_cs_hr |
---|
743 | rad_sw_hr, & !< shortwave radiation heating rate (K/s) |
---|
744 | rad_sw_hr_av, & !< average of rad_sw_hr |
---|
745 | rad_sw_in, & !< incoming shortwave radiation (W/m2) |
---|
746 | rad_sw_in_av, & !< average of rad_sw_in |
---|
747 | rad_sw_out, & !< outgoing shortwave radiation (W/m2) |
---|
748 | rad_sw_out_av !< average of rad_sw_out |
---|
749 | |
---|
750 | |
---|
751 | ! |
---|
752 | !-- Variables and parameters used in RRTMG only |
---|
753 | #if defined ( __rrtmg ) |
---|
754 | CHARACTER(LEN=12) :: rrtm_input_file = "RAD_SND_DATA" !< name of the NetCDF input file (sounding data) |
---|
755 | |
---|
756 | |
---|
757 | ! |
---|
758 | !-- Flag parameters for RRTMGS (should not be changed) |
---|
759 | INTEGER(iwp), PARAMETER :: rrtm_idrv = 1, & !< flag for longwave upward flux calculation option (0,1) |
---|
760 | rrtm_inflglw = 2, & !< flag for lw cloud optical properties (0,1,2) |
---|
761 | rrtm_iceflglw = 0, & !< flag for lw ice particle specifications (0,1,2,3) |
---|
762 | rrtm_liqflglw = 1, & !< flag for lw liquid droplet specifications |
---|
763 | rrtm_inflgsw = 2, & !< flag for sw cloud optical properties (0,1,2) |
---|
764 | rrtm_iceflgsw = 0, & !< flag for sw ice particle specifications (0,1,2,3) |
---|
765 | rrtm_liqflgsw = 1 !< flag for sw liquid droplet specifications |
---|
766 | |
---|
767 | ! |
---|
768 | !-- The following variables should be only changed with care, as this will |
---|
769 | !-- require further setting of some variables, which is currently not |
---|
770 | !-- implemented (aerosols, ice phase). |
---|
771 | INTEGER(iwp) :: nzt_rad, & !< upper vertical limit for radiation calculations |
---|
772 | rrtm_icld = 0, & !< cloud flag (0: clear sky column, 1: cloudy column) |
---|
773 | rrtm_iaer = 0 !< aerosol option flag (0: no aerosol layers, for lw only: 6 (requires setting of rrtm_sw_ecaer), 10: one or more aerosol layers (not implemented) |
---|
774 | |
---|
775 | INTEGER(iwp) :: nc_stat !< local variable for storin the result of netCDF calls for error message handling |
---|
776 | |
---|
777 | LOGICAL :: snd_exists = .FALSE. !< flag parameter to check whether a user-defined input files exists |
---|
778 | |
---|
779 | REAL(wp), PARAMETER :: mol_mass_air_d_wv = 1.607793_wp !< molecular weight dry air / water vapor |
---|
780 | |
---|
781 | REAL(wp), DIMENSION(:), ALLOCATABLE :: hyp_snd, & !< hypostatic pressure from sounding data (hPa) |
---|
782 | rrtm_tsfc, & !< dummy array for storing surface temperature |
---|
783 | t_snd !< actual temperature from sounding data (hPa) |
---|
784 | |
---|
785 | REAL(wp), DIMENSION(:,:), ALLOCATABLE :: rrtm_ccl4vmr, & !< CCL4 volume mixing ratio (g/mol) |
---|
786 | rrtm_cfc11vmr, & !< CFC11 volume mixing ratio (g/mol) |
---|
787 | rrtm_cfc12vmr, & !< CFC12 volume mixing ratio (g/mol) |
---|
788 | rrtm_cfc22vmr, & !< CFC22 volume mixing ratio (g/mol) |
---|
789 | rrtm_ch4vmr, & !< CH4 volume mixing ratio |
---|
790 | rrtm_cicewp, & !< in-cloud ice water path (g/m²) |
---|
791 | rrtm_cldfr, & !< cloud fraction (0,1) |
---|
792 | rrtm_cliqwp, & !< in-cloud liquid water path (g/m²) |
---|
793 | rrtm_co2vmr, & !< CO2 volume mixing ratio (g/mol) |
---|
794 | rrtm_emis, & !< surface emissivity (0-1) |
---|
795 | rrtm_h2ovmr, & !< H2O volume mixing ratio |
---|
796 | rrtm_n2ovmr, & !< N2O volume mixing ratio |
---|
797 | rrtm_o2vmr, & !< O2 volume mixing ratio |
---|
798 | rrtm_o3vmr, & !< O3 volume mixing ratio |
---|
799 | rrtm_play, & !< pressure layers (hPa, zu-grid) |
---|
800 | rrtm_plev, & !< pressure layers (hPa, zw-grid) |
---|
801 | rrtm_reice, & !< cloud ice effective radius (microns) |
---|
802 | rrtm_reliq, & !< cloud water drop effective radius (microns) |
---|
803 | rrtm_tlay, & !< actual temperature (K, zu-grid) |
---|
804 | rrtm_tlev, & !< actual temperature (K, zw-grid) |
---|
805 | rrtm_lwdflx, & !< RRTM output of incoming longwave radiation flux (W/m2) |
---|
806 | rrtm_lwdflxc, & !< RRTM output of outgoing clear sky longwave radiation flux (W/m2) |
---|
807 | rrtm_lwuflx, & !< RRTM output of outgoing longwave radiation flux (W/m2) |
---|
808 | rrtm_lwuflxc, & !< RRTM output of incoming clear sky longwave radiation flux (W/m2) |
---|
809 | rrtm_lwuflx_dt, & !< RRTM output of incoming clear sky longwave radiation flux (W/m2) |
---|
810 | rrtm_lwuflxc_dt,& !< RRTM output of outgoing clear sky longwave radiation flux (W/m2) |
---|
811 | rrtm_lwhr, & !< RRTM output of longwave radiation heating rate (K/d) |
---|
812 | rrtm_lwhrc, & !< RRTM output of incoming longwave clear sky radiation heating rate (K/d) |
---|
813 | rrtm_swdflx, & !< RRTM output of incoming shortwave radiation flux (W/m2) |
---|
814 | rrtm_swdflxc, & !< RRTM output of outgoing clear sky shortwave radiation flux (W/m2) |
---|
815 | rrtm_swuflx, & !< RRTM output of outgoing shortwave radiation flux (W/m2) |
---|
816 | rrtm_swuflxc, & !< RRTM output of incoming clear sky shortwave radiation flux (W/m2) |
---|
817 | rrtm_swhr, & !< RRTM output of shortwave radiation heating rate (K/d) |
---|
818 | rrtm_swhrc, & !< RRTM output of incoming shortwave clear sky radiation heating rate (K/d) |
---|
819 | rrtm_dirdflux, & !< RRTM output of incoming direct shortwave (W/m2) |
---|
820 | rrtm_difdflux !< RRTM output of incoming diffuse shortwave (W/m2) |
---|
821 | |
---|
822 | REAL(wp), DIMENSION(1) :: rrtm_aldif, & !< surface albedo for longwave diffuse radiation |
---|
823 | rrtm_aldir, & !< surface albedo for longwave direct radiation |
---|
824 | rrtm_asdif, & !< surface albedo for shortwave diffuse radiation |
---|
825 | rrtm_asdir !< surface albedo for shortwave direct radiation |
---|
826 | |
---|
827 | ! |
---|
828 | !-- Definition of arrays that are currently not used for calling RRTMG (due to setting of flag parameters) |
---|
829 | REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: rad_lw_cs_in, & !< incoming clear sky longwave radiation (W/m2) (not used) |
---|
830 | rad_lw_cs_out, & !< outgoing clear sky longwave radiation (W/m2) (not used) |
---|
831 | rad_sw_cs_in, & !< incoming clear sky shortwave radiation (W/m2) (not used) |
---|
832 | rad_sw_cs_out, & !< outgoing clear sky shortwave radiation (W/m2) (not used) |
---|
833 | rrtm_lw_tauaer, & !< lw aerosol optical depth |
---|
834 | rrtm_lw_taucld, & !< lw in-cloud optical depth |
---|
835 | rrtm_sw_taucld, & !< sw in-cloud optical depth |
---|
836 | rrtm_sw_ssacld, & !< sw in-cloud single scattering albedo |
---|
837 | rrtm_sw_asmcld, & !< sw in-cloud asymmetry parameter |
---|
838 | rrtm_sw_fsfcld, & !< sw in-cloud forward scattering fraction |
---|
839 | rrtm_sw_tauaer, & !< sw aerosol optical depth |
---|
840 | rrtm_sw_ssaaer, & !< sw aerosol single scattering albedo |
---|
841 | rrtm_sw_asmaer, & !< sw aerosol asymmetry parameter |
---|
842 | rrtm_sw_ecaer !< sw aerosol optical detph at 0.55 microns (rrtm_iaer = 6 only) |
---|
843 | |
---|
844 | #endif |
---|
845 | ! |
---|
846 | !-- Parameters of urban and land surface models |
---|
847 | INTEGER(iwp) :: nzu !< number of layers of urban surface (will be calculated) |
---|
848 | INTEGER(iwp) :: nzp !< number of layers of plant canopy (will be calculated) |
---|
849 | INTEGER(iwp) :: nzub,nzut !< bottom and top layer of urban surface (will be calculated) |
---|
850 | INTEGER(iwp) :: nzpt !< top layer of plant canopy (will be calculated) |
---|
851 | !-- parameters of urban and land surface models |
---|
852 | INTEGER(iwp), PARAMETER :: nzut_free = 3 !< number of free layers above top of of topography |
---|
853 | INTEGER(iwp), PARAMETER :: ndsvf = 2 !< number of dimensions of real values in SVF |
---|
854 | INTEGER(iwp), PARAMETER :: idsvf = 2 !< number of dimensions of integer values in SVF |
---|
855 | INTEGER(iwp), PARAMETER :: ndcsf = 1 !< number of dimensions of real values in CSF |
---|
856 | INTEGER(iwp), PARAMETER :: idcsf = 2 !< number of dimensions of integer values in CSF |
---|
857 | INTEGER(iwp), PARAMETER :: kdcsf = 4 !< number of dimensions of integer values in CSF calculation array |
---|
858 | INTEGER(iwp), PARAMETER :: id = 1 !< position of d-index in surfl and surf |
---|
859 | INTEGER(iwp), PARAMETER :: iz = 2 !< position of k-index in surfl and surf |
---|
860 | INTEGER(iwp), PARAMETER :: iy = 3 !< position of j-index in surfl and surf |
---|
861 | INTEGER(iwp), PARAMETER :: ix = 4 !< position of i-index in surfl and surf |
---|
862 | |
---|
863 | INTEGER(iwp), PARAMETER :: nsurf_type = 10 !< number of surf types incl. phys.(land+urban) & (atm.,sky,boundary) surfaces - 1 |
---|
864 | |
---|
865 | INTEGER(iwp), PARAMETER :: iup_u = 0 !< 0 - index of urban upward surface (ground or roof) |
---|
866 | INTEGER(iwp), PARAMETER :: idown_u = 1 !< 1 - index of urban downward surface (overhanging) |
---|
867 | INTEGER(iwp), PARAMETER :: inorth_u = 2 !< 2 - index of urban northward facing wall |
---|
868 | INTEGER(iwp), PARAMETER :: isouth_u = 3 !< 3 - index of urban southward facing wall |
---|
869 | INTEGER(iwp), PARAMETER :: ieast_u = 4 !< 4 - index of urban eastward facing wall |
---|
870 | INTEGER(iwp), PARAMETER :: iwest_u = 5 !< 5 - index of urban westward facing wall |
---|
871 | |
---|
872 | INTEGER(iwp), PARAMETER :: iup_l = 6 !< 6 - index of land upward surface (ground or roof) |
---|
873 | INTEGER(iwp), PARAMETER :: inorth_l = 7 !< 7 - index of land northward facing wall |
---|
874 | INTEGER(iwp), PARAMETER :: isouth_l = 8 !< 8 - index of land southward facing wall |
---|
875 | INTEGER(iwp), PARAMETER :: ieast_l = 9 !< 9 - index of land eastward facing wall |
---|
876 | INTEGER(iwp), PARAMETER :: iwest_l = 10 !< 10- index of land westward facing wall |
---|
877 | |
---|
878 | INTEGER(iwp), DIMENSION(0:nsurf_type), PARAMETER :: idir = (/0, 0,0, 0,1,-1,0,0, 0,1,-1/) !< surface normal direction x indices |
---|
879 | INTEGER(iwp), DIMENSION(0:nsurf_type), PARAMETER :: jdir = (/0, 0,1,-1,0, 0,0,1,-1,0, 0/) !< surface normal direction y indices |
---|
880 | INTEGER(iwp), DIMENSION(0:nsurf_type), PARAMETER :: kdir = (/1,-1,0, 0,0, 0,1,0, 0,0, 0/) !< surface normal direction z indices |
---|
881 | REAL(wp), DIMENSION(0:nsurf_type) :: facearea !< area of single face in respective |
---|
882 | !< direction (will be calc'd) |
---|
883 | |
---|
884 | |
---|
885 | !-- indices and sizes of urban and land surface models |
---|
886 | INTEGER(iwp) :: startland !< start index of block of land and roof surfaces |
---|
887 | INTEGER(iwp) :: endland !< end index of block of land and roof surfaces |
---|
888 | INTEGER(iwp) :: nlands !< number of land and roof surfaces in local processor |
---|
889 | INTEGER(iwp) :: startwall !< start index of block of wall surfaces |
---|
890 | INTEGER(iwp) :: endwall !< end index of block of wall surfaces |
---|
891 | INTEGER(iwp) :: nwalls !< number of wall surfaces in local processor |
---|
892 | |
---|
893 | !-- indices and sizes of urban and land surface models |
---|
894 | INTEGER(iwp), DIMENSION(:), ALLOCATABLE,TARGET :: surfl_l !< coordinates of i-th local surface in local grid - surfl[:,k] = [d, z, y, x] |
---|
895 | INTEGER(iwp), DIMENSION(:), ALLOCATABLE,TARGET :: surf_l !< coordinates of i-th surface in grid - surf[:,k] = [d, z, y, x] |
---|
896 | INTEGER(iwp), DIMENSION(:,:), POINTER :: surfl !< coordinates of i-th local surface in local grid - surfl[:,k] = [d, z, y, x] |
---|
897 | INTEGER(iwp), DIMENSION(:,:), POINTER :: surf !< coordinates of i-th surface in grid - surf[:,k] = [d, z, y, x] |
---|
898 | INTEGER(iwp) :: nsurfl !< number of all surfaces in local processor |
---|
899 | INTEGER(iwp), DIMENSION(:), ALLOCATABLE,TARGET :: nsurfs !< array of number of all surfaces in individual processors |
---|
900 | INTEGER(iwp) :: nsurf !< global number of surfaces in index array of surfaces (nsurf = proc nsurfs) |
---|
901 | INTEGER(iwp), DIMENSION(:), ALLOCATABLE,TARGET :: surfstart !< starts of blocks of surfaces for individual processors in array surf (indexed from 1) |
---|
902 | !< respective block for particular processor is surfstart[iproc+1]+1 : surfstart[iproc+1]+nsurfs[iproc+1] |
---|
903 | |
---|
904 | !-- block variables needed for calculation of the plant canopy model inside the urban surface model |
---|
905 | INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE :: pct !< top layer of the plant canopy |
---|
906 | INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE :: pch !< heights of the plant canopy |
---|
907 | INTEGER(iwp) :: npcbl = 0 !< number of the plant canopy gridboxes in local processor |
---|
908 | INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE :: pcbl !< k,j,i coordinates of l-th local plant canopy box pcbl[:,l] = [k, j, i] |
---|
909 | REAL(wp), DIMENSION(:), ALLOCATABLE :: pcbinsw !< array of absorbed sw radiation for local plant canopy box |
---|
910 | REAL(wp), DIMENSION(:), ALLOCATABLE :: pcbinswdir !< array of absorbed direct sw radiation for local plant canopy box |
---|
911 | REAL(wp), DIMENSION(:), ALLOCATABLE :: pcbinswdif !< array of absorbed diffusion sw radiation for local plant canopy box |
---|
912 | REAL(wp), DIMENSION(:), ALLOCATABLE :: pcbinlw !< array of absorbed lw radiation for local plant canopy box |
---|
913 | |
---|
914 | !-- configuration parameters (they can be setup in PALM config) |
---|
915 | LOGICAL :: raytrace_mpi_rma = .TRUE. !< use MPI RMA to access LAD and gridsurf from remote processes during raytracing |
---|
916 | LOGICAL :: rad_angular_discretization = .TRUE.!< whether to use fixed resolution discretization of view factors for |
---|
917 | !< reflected radiation (as opposed to all mutually visible pairs) |
---|
918 | LOGICAL :: plant_lw_interact = .TRUE. !< whether plant canopy interacts with LW radiation (in addition to SW) |
---|
919 | INTEGER(iwp) :: mrt_nlevels = 0 !< number of vertical boxes above surface for which to calculate MRT |
---|
920 | LOGICAL :: mrt_skip_roof = .TRUE. !< do not calculate MRT above roof surfaces |
---|
921 | LOGICAL :: mrt_include_sw = .TRUE. !< should MRT calculation include SW radiation as well? |
---|
922 | LOGICAL :: mrt_geom_human = .TRUE. !< MRT direction weights simulate human body instead of a sphere |
---|
923 | INTEGER(iwp) :: nrefsteps = 3 !< number of reflection steps to perform |
---|
924 | REAL(wp), PARAMETER :: ext_coef = 0.6_wp !< extinction coefficient (a.k.a. alpha) |
---|
925 | INTEGER(iwp), PARAMETER :: rad_version_len = 10 !< length of identification string of rad version |
---|
926 | CHARACTER(rad_version_len), PARAMETER :: rad_version = 'RAD v. 3.0' !< identification of version of binary svf and restart files |
---|
927 | INTEGER(iwp) :: raytrace_discrete_elevs = 40 !< number of discretization steps for elevation (nadir to zenith) |
---|
928 | INTEGER(iwp) :: raytrace_discrete_azims = 80 !< number of discretization steps for azimuth (out of 360 degrees) |
---|
929 | REAL(wp) :: max_raytracing_dist = -999.0_wp !< maximum distance for raytracing (in metres) |
---|
930 | REAL(wp) :: min_irrf_value = 1e-6_wp !< minimum potential irradiance factor value for raytracing |
---|
931 | REAL(wp), DIMENSION(1:30) :: svfnorm_report_thresh = 1e21_wp !< thresholds of SVF normalization values to report |
---|
932 | INTEGER(iwp) :: svfnorm_report_num !< number of SVF normalization thresholds to report |
---|
933 | |
---|
934 | !-- radiation related arrays to be used in radiation_interaction routine |
---|
935 | REAL(wp), DIMENSION(:,:), ALLOCATABLE :: rad_sw_in_dir !< direct sw radiation |
---|
936 | REAL(wp), DIMENSION(:,:), ALLOCATABLE :: rad_sw_in_diff !< diffusion sw radiation |
---|
937 | REAL(wp), DIMENSION(:,:), ALLOCATABLE :: rad_lw_in_diff !< diffusion lw radiation |
---|
938 | |
---|
939 | !-- parameters required for RRTMG lower boundary condition |
---|
940 | REAL(wp) :: albedo_urb !< albedo value retuned to RRTMG boundary cond. |
---|
941 | REAL(wp) :: emissivity_urb !< emissivity value retuned to RRTMG boundary cond. |
---|
942 | REAL(wp) :: t_rad_urb !< temperature value retuned to RRTMG boundary cond. |
---|
943 | |
---|
944 | !-- type for calculation of svf |
---|
945 | TYPE t_svf |
---|
946 | INTEGER(iwp) :: isurflt !< |
---|
947 | INTEGER(iwp) :: isurfs !< |
---|
948 | REAL(wp) :: rsvf !< |
---|
949 | REAL(wp) :: rtransp !< |
---|
950 | END TYPE |
---|
951 | |
---|
952 | !-- type for calculation of csf |
---|
953 | TYPE t_csf |
---|
954 | INTEGER(iwp) :: ip !< |
---|
955 | INTEGER(iwp) :: itx !< |
---|
956 | INTEGER(iwp) :: ity !< |
---|
957 | INTEGER(iwp) :: itz !< |
---|
958 | INTEGER(iwp) :: isurfs !< Idx of source face / -1 for sky |
---|
959 | REAL(wp) :: rcvf !< Canopy view factor for faces / |
---|
960 | !< canopy sink factor for sky (-1) |
---|
961 | END TYPE |
---|
962 | |
---|
963 | !-- arrays storing the values of USM |
---|
964 | INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE :: svfsurf !< svfsurf[:,isvf] = index of target and source surface for svf[isvf] |
---|
965 | REAL(wp), DIMENSION(:,:), ALLOCATABLE :: svf !< array of shape view factors+direct irradiation factors for local surfaces |
---|
966 | REAL(wp), DIMENSION(:), ALLOCATABLE :: surfins !< array of sw radiation falling to local surface after i-th reflection |
---|
967 | REAL(wp), DIMENSION(:), ALLOCATABLE :: surfinl !< array of lw radiation for local surface after i-th reflection |
---|
968 | |
---|
969 | REAL(wp), DIMENSION(:), ALLOCATABLE :: skyvf !< array of sky view factor for each local surface |
---|
970 | REAL(wp), DIMENSION(:), ALLOCATABLE :: skyvft !< array of sky view factor including transparency for each local surface |
---|
971 | REAL(wp), DIMENSION(:,:), ALLOCATABLE :: dsitrans !< dsidir[isvfl,i] = path transmittance of i-th |
---|
972 | !< direction of direct solar irradiance per target surface |
---|
973 | REAL(wp), DIMENSION(:,:), ALLOCATABLE :: dsitransc !< dtto per plant canopy box |
---|
974 | REAL(wp), DIMENSION(:,:), ALLOCATABLE :: dsidir !< dsidir[:,i] = unit vector of i-th |
---|
975 | !< direction of direct solar irradiance |
---|
976 | INTEGER(iwp) :: ndsidir !< number of apparent solar directions used |
---|
977 | INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE :: dsidir_rev !< dsidir_rev[ielev,iazim] = i for dsidir or -1 if not present |
---|
978 | |
---|
979 | INTEGER(iwp) :: nmrtbl !< No. of local grid boxes for which MRT is calculated |
---|
980 | INTEGER(iwp) :: nmrtf !< number of MRT factors for local processor |
---|
981 | INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE :: mrtbl !< coordinates of i-th local MRT box - surfl[:,i] = [z, y, x] |
---|
982 | INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE :: mrtfsurf !< mrtfsurf[:,imrtf] = index of target MRT box and source surface for mrtf[imrtf] |
---|
983 | REAL(wp), DIMENSION(:), ALLOCATABLE :: mrtf !< array of MRT factors for each local MRT box |
---|
984 | REAL(wp), DIMENSION(:), ALLOCATABLE :: mrtft !< array of MRT factors including transparency for each local MRT box |
---|
985 | REAL(wp), DIMENSION(:), ALLOCATABLE :: mrtsky !< array of sky view factor for each local MRT box |
---|
986 | REAL(wp), DIMENSION(:), ALLOCATABLE :: mrtskyt !< array of sky view factor including transparency for each local MRT box |
---|
987 | REAL(wp), DIMENSION(:,:), ALLOCATABLE :: mrtdsit !< array of direct solar transparencies for each local MRT box |
---|
988 | REAL(wp), DIMENSION(:), ALLOCATABLE :: mrtinsw !< mean SW radiant flux for each MRT box |
---|
989 | REAL(wp), DIMENSION(:), ALLOCATABLE :: mrtinlw !< mean LW radiant flux for each MRT box |
---|
990 | REAL(wp), DIMENSION(:), ALLOCATABLE :: mrt !< mean radiant temperature for each MRT box |
---|
991 | REAL(wp), DIMENSION(:), ALLOCATABLE :: mrtinsw_av !< time average mean SW radiant flux for each MRT box |
---|
992 | REAL(wp), DIMENSION(:), ALLOCATABLE :: mrtinlw_av !< time average mean LW radiant flux for each MRT box |
---|
993 | REAL(wp), DIMENSION(:), ALLOCATABLE :: mrt_av !< time average mean radiant temperature for each MRT box |
---|
994 | |
---|
995 | REAL(wp), DIMENSION(:), ALLOCATABLE :: surfinsw !< array of sw radiation falling to local surface including radiation from reflections |
---|
996 | REAL(wp), DIMENSION(:), ALLOCATABLE :: surfinlw !< array of lw radiation falling to local surface including radiation from reflections |
---|
997 | REAL(wp), DIMENSION(:), ALLOCATABLE :: surfinswdir !< array of direct sw radiation falling to local surface |
---|
998 | REAL(wp), DIMENSION(:), ALLOCATABLE :: surfinswdif !< array of diffuse sw radiation from sky and model boundary falling to local surface |
---|
999 | REAL(wp), DIMENSION(:), ALLOCATABLE :: surfinlwdif !< array of diffuse lw radiation from sky and model boundary falling to local surface |
---|
1000 | |
---|
1001 | !< Outward radiation is only valid for nonvirtual surfaces |
---|
1002 | REAL(wp), DIMENSION(:), ALLOCATABLE :: surfoutsl !< array of reflected sw radiation for local surface in i-th reflection |
---|
1003 | REAL(wp), DIMENSION(:), ALLOCATABLE :: surfoutll !< array of reflected + emitted lw radiation for local surface in i-th reflection |
---|
1004 | REAL(wp), DIMENSION(:), ALLOCATABLE :: surfouts !< array of reflected sw radiation for all surfaces in i-th reflection |
---|
1005 | REAL(wp), DIMENSION(:), ALLOCATABLE :: surfoutl !< array of reflected + emitted lw radiation for all surfaces in i-th reflection |
---|
1006 | REAL(wp), DIMENSION(:), ALLOCATABLE :: surfinlg !< global array of incoming lw radiation from plant canopy |
---|
1007 | REAL(wp), DIMENSION(:), ALLOCATABLE :: surfoutsw !< array of total sw radiation outgoing from nonvirtual surfaces surfaces after all reflection |
---|
1008 | REAL(wp), DIMENSION(:), ALLOCATABLE :: surfoutlw !< array of total lw radiation outgoing from nonvirtual surfaces surfaces after all reflection |
---|
1009 | REAL(wp), DIMENSION(:), ALLOCATABLE :: surfemitlwl !< array of emitted lw radiation for local surface used to calculate effective surface temperature for radiation model |
---|
1010 | |
---|
1011 | !-- block variables needed for calculation of the plant canopy model inside the urban surface model |
---|
1012 | INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE :: csfsurf !< csfsurf[:,icsf] = index of target surface and csf grid index for csf[icsf] |
---|
1013 | REAL(wp), DIMENSION(:,:), ALLOCATABLE :: csf !< array of plant canopy sink fators + direct irradiation factors (transparency) |
---|
1014 | REAL(wp), DIMENSION(:,:,:), POINTER :: sub_lad !< subset of lad_s within urban surface, transformed to plain Z coordinate |
---|
1015 | REAL(wp), DIMENSION(:), POINTER :: sub_lad_g !< sub_lad globalized (used to avoid MPI RMA calls in raytracing) |
---|
1016 | REAL(wp) :: prototype_lad !< prototype leaf area density for computing effective optical depth |
---|
1017 | INTEGER(iwp), DIMENSION(:), ALLOCATABLE :: nzterr, plantt !< temporary global arrays for raytracing |
---|
1018 | INTEGER(iwp) :: plantt_max |
---|
1019 | |
---|
1020 | !-- arrays and variables for calculation of svf and csf |
---|
1021 | TYPE(t_svf), DIMENSION(:), POINTER :: asvf !< pointer to growing svc array |
---|
1022 | TYPE(t_csf), DIMENSION(:), POINTER :: acsf !< pointer to growing csf array |
---|
1023 | TYPE(t_svf), DIMENSION(:), POINTER :: amrtf !< pointer to growing mrtf array |
---|
1024 | TYPE(t_svf), DIMENSION(:), ALLOCATABLE, TARGET :: asvf1, asvf2 !< realizations of svf array |
---|
1025 | TYPE(t_csf), DIMENSION(:), ALLOCATABLE, TARGET :: acsf1, acsf2 !< realizations of csf array |
---|
1026 | TYPE(t_svf), DIMENSION(:), ALLOCATABLE, TARGET :: amrtf1, amrtf2 !< realizations of mftf array |
---|
1027 | INTEGER(iwp) :: nsvfla !< dimmension of array allocated for storage of svf in local processor |
---|
1028 | INTEGER(iwp) :: ncsfla !< dimmension of array allocated for storage of csf in local processor |
---|
1029 | INTEGER(iwp) :: nmrtfa !< dimmension of array allocated for storage of mrt |
---|
1030 | INTEGER(iwp) :: msvf, mcsf, mmrtf!< mod for swapping the growing array |
---|
1031 | INTEGER(iwp), PARAMETER :: gasize = 100000 !< initial size of growing arrays |
---|
1032 | REAL(wp), PARAMETER :: grow_factor = 1.4_wp !< growth factor of growing arrays |
---|
1033 | INTEGER(iwp) :: nsvfl !< number of svf for local processor |
---|
1034 | INTEGER(iwp) :: ncsfl !< no. of csf in local processor |
---|
1035 | !< needed only during calc_svf but must be here because it is |
---|
1036 | !< shared between subroutines calc_svf and raytrace |
---|
1037 | INTEGER(iwp), DIMENSION(:,:,:,:), POINTER :: gridsurf !< reverse index of local surfl[d,k,j,i] (for case rad_angular_discretization) |
---|
1038 | INTEGER(iwp), DIMENSION(:,:,:), ALLOCATABLE :: gridpcbl !< reverse index of local pcbl[k,j,i] |
---|
1039 | INTEGER(iwp), PARAMETER :: nsurf_type_u = 6 !< number of urban surf types (used in gridsurf) |
---|
1040 | |
---|
1041 | !-- temporary arrays for calculation of csf in raytracing |
---|
1042 | INTEGER(iwp) :: maxboxesg !< max number of boxes ray can cross in the domain |
---|
1043 | INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE :: boxes !< coordinates of gridboxes being crossed by ray |
---|
1044 | REAL(wp), DIMENSION(:), ALLOCATABLE :: crlens !< array of crossing lengths of ray for particular grid boxes |
---|
1045 | INTEGER(iwp), DIMENSION(:), ALLOCATABLE :: lad_ip !< array of numbers of process where lad is stored |
---|
1046 | #if defined( __parallel ) |
---|
1047 | INTEGER(kind=MPI_ADDRESS_KIND), & |
---|
1048 | DIMENSION(:), ALLOCATABLE :: lad_disp !< array of displaycements of lad in local array of proc lad_ip |
---|
1049 | INTEGER(iwp) :: win_lad !< MPI RMA window for leaf area density |
---|
1050 | INTEGER(iwp) :: win_gridsurf !< MPI RMA window for reverse grid surface index |
---|
1051 | #endif |
---|
1052 | REAL(wp), DIMENSION(:), ALLOCATABLE :: lad_s_ray !< array of received lad_s for appropriate gridboxes crossed by ray |
---|
1053 | INTEGER(iwp), DIMENSION(:), ALLOCATABLE :: target_surfl |
---|
1054 | INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE :: rt2_track |
---|
1055 | REAL(wp), DIMENSION(:,:), ALLOCATABLE :: rt2_track_lad |
---|
1056 | REAL(wp), DIMENSION(:), ALLOCATABLE :: rt2_track_dist |
---|
1057 | REAL(wp), DIMENSION(:), ALLOCATABLE :: rt2_dist |
---|
1058 | |
---|
1059 | |
---|
1060 | |
---|
1061 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! |
---|
1062 | !-- Energy balance variables |
---|
1063 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! |
---|
1064 | !-- parameters of the land, roof and wall surfaces |
---|
1065 | REAL(wp), DIMENSION(:), ALLOCATABLE :: albedo_surf !< albedo of the surface |
---|
1066 | REAL(wp), DIMENSION(:), ALLOCATABLE :: emiss_surf !< emissivity of the wall surface |
---|
1067 | |
---|
1068 | |
---|
1069 | INTERFACE radiation_check_data_output |
---|
1070 | MODULE PROCEDURE radiation_check_data_output |
---|
1071 | END INTERFACE radiation_check_data_output |
---|
1072 | |
---|
1073 | INTERFACE radiation_check_data_output_pr |
---|
1074 | MODULE PROCEDURE radiation_check_data_output_pr |
---|
1075 | END INTERFACE radiation_check_data_output_pr |
---|
1076 | |
---|
1077 | INTERFACE radiation_check_parameters |
---|
1078 | MODULE PROCEDURE radiation_check_parameters |
---|
1079 | END INTERFACE radiation_check_parameters |
---|
1080 | |
---|
1081 | INTERFACE radiation_clearsky |
---|
1082 | MODULE PROCEDURE radiation_clearsky |
---|
1083 | END INTERFACE radiation_clearsky |
---|
1084 | |
---|
1085 | INTERFACE radiation_constant |
---|
1086 | MODULE PROCEDURE radiation_constant |
---|
1087 | END INTERFACE radiation_constant |
---|
1088 | |
---|
1089 | INTERFACE radiation_control |
---|
1090 | MODULE PROCEDURE radiation_control |
---|
1091 | END INTERFACE radiation_control |
---|
1092 | |
---|
1093 | INTERFACE radiation_3d_data_averaging |
---|
1094 | MODULE PROCEDURE radiation_3d_data_averaging |
---|
1095 | END INTERFACE radiation_3d_data_averaging |
---|
1096 | |
---|
1097 | INTERFACE radiation_data_output_2d |
---|
1098 | MODULE PROCEDURE radiation_data_output_2d |
---|
1099 | END INTERFACE radiation_data_output_2d |
---|
1100 | |
---|
1101 | INTERFACE radiation_data_output_3d |
---|
1102 | MODULE PROCEDURE radiation_data_output_3d |
---|
1103 | END INTERFACE radiation_data_output_3d |
---|
1104 | |
---|
1105 | INTERFACE radiation_data_output_mask |
---|
1106 | MODULE PROCEDURE radiation_data_output_mask |
---|
1107 | END INTERFACE radiation_data_output_mask |
---|
1108 | |
---|
1109 | INTERFACE radiation_define_netcdf_grid |
---|
1110 | MODULE PROCEDURE radiation_define_netcdf_grid |
---|
1111 | END INTERFACE radiation_define_netcdf_grid |
---|
1112 | |
---|
1113 | INTERFACE radiation_header |
---|
1114 | MODULE PROCEDURE radiation_header |
---|
1115 | END INTERFACE radiation_header |
---|
1116 | |
---|
1117 | INTERFACE radiation_init |
---|
1118 | MODULE PROCEDURE radiation_init |
---|
1119 | END INTERFACE radiation_init |
---|
1120 | |
---|
1121 | INTERFACE radiation_parin |
---|
1122 | MODULE PROCEDURE radiation_parin |
---|
1123 | END INTERFACE radiation_parin |
---|
1124 | |
---|
1125 | INTERFACE radiation_rrtmg |
---|
1126 | MODULE PROCEDURE radiation_rrtmg |
---|
1127 | END INTERFACE radiation_rrtmg |
---|
1128 | |
---|
1129 | INTERFACE radiation_tendency |
---|
1130 | MODULE PROCEDURE radiation_tendency |
---|
1131 | MODULE PROCEDURE radiation_tendency_ij |
---|
1132 | END INTERFACE radiation_tendency |
---|
1133 | |
---|
1134 | INTERFACE radiation_rrd_local |
---|
1135 | MODULE PROCEDURE radiation_rrd_local |
---|
1136 | END INTERFACE radiation_rrd_local |
---|
1137 | |
---|
1138 | INTERFACE radiation_wrd_local |
---|
1139 | MODULE PROCEDURE radiation_wrd_local |
---|
1140 | END INTERFACE radiation_wrd_local |
---|
1141 | |
---|
1142 | INTERFACE radiation_interaction |
---|
1143 | MODULE PROCEDURE radiation_interaction |
---|
1144 | END INTERFACE radiation_interaction |
---|
1145 | |
---|
1146 | INTERFACE radiation_interaction_init |
---|
1147 | MODULE PROCEDURE radiation_interaction_init |
---|
1148 | END INTERFACE radiation_interaction_init |
---|
1149 | |
---|
1150 | INTERFACE radiation_presimulate_solar_pos |
---|
1151 | MODULE PROCEDURE radiation_presimulate_solar_pos |
---|
1152 | END INTERFACE radiation_presimulate_solar_pos |
---|
1153 | |
---|
1154 | INTERFACE radiation_radflux_gridbox |
---|
1155 | MODULE PROCEDURE radiation_radflux_gridbox |
---|
1156 | END INTERFACE radiation_radflux_gridbox |
---|
1157 | |
---|
1158 | INTERFACE radiation_calc_svf |
---|
1159 | MODULE PROCEDURE radiation_calc_svf |
---|
1160 | END INTERFACE radiation_calc_svf |
---|
1161 | |
---|
1162 | INTERFACE radiation_write_svf |
---|
1163 | MODULE PROCEDURE radiation_write_svf |
---|
1164 | END INTERFACE radiation_write_svf |
---|
1165 | |
---|
1166 | INTERFACE radiation_read_svf |
---|
1167 | MODULE PROCEDURE radiation_read_svf |
---|
1168 | END INTERFACE radiation_read_svf |
---|
1169 | |
---|
1170 | |
---|
1171 | SAVE |
---|
1172 | |
---|
1173 | PRIVATE |
---|
1174 | |
---|
1175 | ! |
---|
1176 | !-- Public functions / NEEDS SORTING |
---|
1177 | PUBLIC radiation_check_data_output, radiation_check_data_output_pr, & |
---|
1178 | radiation_check_parameters, radiation_control, & |
---|
1179 | radiation_header, radiation_init, radiation_parin, & |
---|
1180 | radiation_3d_data_averaging, radiation_tendency, & |
---|
1181 | radiation_data_output_2d, radiation_data_output_3d, & |
---|
1182 | radiation_define_netcdf_grid, radiation_wrd_local, & |
---|
1183 | radiation_rrd_local, radiation_data_output_mask, & |
---|
1184 | radiation_radflux_gridbox, radiation_calc_svf, radiation_write_svf, & |
---|
1185 | radiation_interaction, radiation_interaction_init, & |
---|
1186 | radiation_read_svf, radiation_presimulate_solar_pos |
---|
1187 | |
---|
1188 | |
---|
1189 | |
---|
1190 | ! |
---|
1191 | !-- Public variables and constants / NEEDS SORTING |
---|
1192 | PUBLIC albedo, albedo_type, decl_1, decl_2, decl_3, dots_rad, dt_radiation,& |
---|
1193 | emissivity, force_radiation_call, lat, lon, mrt_geom_human, & |
---|
1194 | mrt_include_sw, mrt_nlevels, mrtbl, mrtinsw, mrtinlw, nmrtbl, & |
---|
1195 | rad_net_av, radiation, radiation_scheme, rad_lw_in, & |
---|
1196 | rad_lw_in_av, rad_lw_out, rad_lw_out_av, & |
---|
1197 | rad_lw_cs_hr, rad_lw_cs_hr_av, rad_lw_hr, rad_lw_hr_av, rad_sw_in, & |
---|
1198 | rad_sw_in_av, rad_sw_out, rad_sw_out_av, rad_sw_cs_hr, & |
---|
1199 | rad_sw_cs_hr_av, rad_sw_hr, rad_sw_hr_av, sigma_sb, solar_constant, & |
---|
1200 | skip_time_do_radiation, time_radiation, unscheduled_radiation_calls,& |
---|
1201 | zenith, calc_zenith, sun_direction, sun_dir_lat, sun_dir_lon, & |
---|
1202 | nrefsteps, nsvfl, svf, & |
---|
1203 | svfsurf, surfinsw, surfinlw, surfins, surfinl, surfinswdir, & |
---|
1204 | surfinswdif, surfoutsw, surfoutlw, surfinlwdif, rad_sw_in_dir, & |
---|
1205 | rad_sw_in_diff, rad_lw_in_diff, surfouts, surfoutl, surfoutsl, & |
---|
1206 | surfoutll, idir, jdir, kdir, id, iz, iy, ix, & |
---|
1207 | surf, surfl, nsurfl, pcbinswdir, pcbinswdif, pcbinsw, pcbinlw, & |
---|
1208 | iup_u, inorth_u, isouth_u, ieast_u, iwest_u, & |
---|
1209 | iup_l, inorth_l, isouth_l, ieast_l, iwest_l, & |
---|
1210 | nsurf_type, nzub, nzut, nzu, pch, nsurf, & |
---|
1211 | idsvf, ndsvf, idcsf, ndcsf, kdcsf, pct, & |
---|
1212 | radiation_interactions, startwall, startland, endland, endwall, & |
---|
1213 | skyvf, skyvft, radiation_interactions_on, average_radiation, npcbl, & |
---|
1214 | pcbl |
---|
1215 | |
---|
1216 | #if defined ( __rrtmg ) |
---|
1217 | PUBLIC rrtm_aldif, rrtm_aldir, rrtm_asdif, rrtm_asdir |
---|
1218 | #endif |
---|
1219 | |
---|
1220 | CONTAINS |
---|
1221 | |
---|
1222 | |
---|
1223 | !------------------------------------------------------------------------------! |
---|
1224 | ! Description: |
---|
1225 | ! ------------ |
---|
1226 | !> This subroutine controls the calls of the radiation schemes |
---|
1227 | !------------------------------------------------------------------------------! |
---|
1228 | SUBROUTINE radiation_control |
---|
1229 | |
---|
1230 | |
---|
1231 | IMPLICIT NONE |
---|
1232 | |
---|
1233 | |
---|
1234 | SELECT CASE ( TRIM( radiation_scheme ) ) |
---|
1235 | |
---|
1236 | CASE ( 'constant' ) |
---|
1237 | CALL radiation_constant |
---|
1238 | |
---|
1239 | CASE ( 'clear-sky' ) |
---|
1240 | CALL radiation_clearsky |
---|
1241 | |
---|
1242 | CASE ( 'rrtmg' ) |
---|
1243 | CALL radiation_rrtmg |
---|
1244 | |
---|
1245 | CASE DEFAULT |
---|
1246 | |
---|
1247 | END SELECT |
---|
1248 | |
---|
1249 | |
---|
1250 | END SUBROUTINE radiation_control |
---|
1251 | |
---|
1252 | !------------------------------------------------------------------------------! |
---|
1253 | ! Description: |
---|
1254 | ! ------------ |
---|
1255 | !> Check data output for radiation model |
---|
1256 | !------------------------------------------------------------------------------! |
---|
1257 | SUBROUTINE radiation_check_data_output( var, unit, i, ilen, k ) |
---|
1258 | |
---|
1259 | |
---|
1260 | USE control_parameters, & |
---|
1261 | ONLY: data_output, message_string |
---|
1262 | |
---|
1263 | IMPLICIT NONE |
---|
1264 | |
---|
1265 | CHARACTER (LEN=*) :: unit !< |
---|
1266 | CHARACTER (LEN=*) :: var !< |
---|
1267 | |
---|
1268 | INTEGER(iwp) :: i |
---|
1269 | INTEGER(iwp) :: ilen |
---|
1270 | INTEGER(iwp) :: k |
---|
1271 | |
---|
1272 | SELECT CASE ( TRIM( var ) ) |
---|
1273 | |
---|
1274 | CASE ( 'rad_lw_cs_hr', 'rad_lw_hr', 'rad_lw_in', 'rad_lw_out', & |
---|
1275 | 'rad_sw_cs_hr', 'rad_sw_hr', 'rad_sw_in', 'rad_sw_out' ) |
---|
1276 | IF ( .NOT. radiation .OR. radiation_scheme /= 'rrtmg' ) THEN |
---|
1277 | message_string = '"output of "' // TRIM( var ) // '" requi' // & |
---|
1278 | 'res radiation = .TRUE. and ' // & |
---|
1279 | 'radiation_scheme = "rrtmg"' |
---|
1280 | CALL message( 'check_parameters', 'PA0406', 1, 2, 0, 6, 0 ) |
---|
1281 | ENDIF |
---|
1282 | unit = 'K/h' |
---|
1283 | |
---|
1284 | CASE ( 'rad_net*', 'rrtm_aldif*', 'rrtm_aldir*', 'rrtm_asdif*', & |
---|
1285 | 'rrtm_asdir*', 'rad_lw_in*', 'rad_lw_out*', 'rad_sw_in*', & |
---|
1286 | 'rad_sw_out*') |
---|
1287 | IF ( i == 0 .AND. ilen == 0 .AND. k == 0) THEN |
---|
1288 | ! Workaround for masked output (calls with i=ilen=k=0) |
---|
1289 | unit = 'illegal' |
---|
1290 | RETURN |
---|
1291 | ENDIF |
---|
1292 | IF ( k == 0 .OR. data_output(i)(ilen-2:ilen) /= '_xy' ) THEN |
---|
1293 | message_string = 'illegal value for data_output: "' // & |
---|
1294 | TRIM( var ) // '" & only 2d-horizontal ' // & |
---|
1295 | 'cross sections are allowed for this value' |
---|
1296 | CALL message( 'check_parameters', 'PA0111', 1, 2, 0, 6, 0 ) |
---|
1297 | ENDIF |
---|
1298 | IF ( .NOT. radiation .OR. radiation_scheme /= "rrtmg" ) THEN |
---|
1299 | IF ( TRIM( var ) == 'rrtm_aldif*' .OR. & |
---|
1300 | TRIM( var ) == 'rrtm_aldir*' .OR. & |
---|
1301 | TRIM( var ) == 'rrtm_asdif*' .OR. & |
---|
1302 | TRIM( var ) == 'rrtm_asdir*' ) & |
---|
1303 | THEN |
---|
1304 | message_string = 'output of "' // TRIM( var ) // '" require'& |
---|
1305 | // 's radiation = .TRUE. and radiation_sch'& |
---|
1306 | // 'eme = "rrtmg"' |
---|
1307 | CALL message( 'check_parameters', 'PA0409', 1, 2, 0, 6, 0 ) |
---|
1308 | ENDIF |
---|
1309 | ENDIF |
---|
1310 | |
---|
1311 | IF ( TRIM( var ) == 'rad_net*' ) unit = 'W/m2' |
---|
1312 | IF ( TRIM( var ) == 'rad_lw_in*' ) unit = 'W/m2' |
---|
1313 | IF ( TRIM( var ) == 'rad_lw_out*' ) unit = 'W/m2' |
---|
1314 | IF ( TRIM( var ) == 'rad_sw_in*' ) unit = 'W/m2' |
---|
1315 | IF ( TRIM( var ) == 'rad_sw_out*' ) unit = 'W/m2' |
---|
1316 | IF ( TRIM( var ) == 'rad_sw_in' ) unit = 'W/m2' |
---|
1317 | IF ( TRIM( var ) == 'rrtm_aldif*' ) unit = '' |
---|
1318 | IF ( TRIM( var ) == 'rrtm_aldir*' ) unit = '' |
---|
1319 | IF ( TRIM( var ) == 'rrtm_asdif*' ) unit = '' |
---|
1320 | IF ( TRIM( var ) == 'rrtm_asdir*' ) unit = '' |
---|
1321 | |
---|
1322 | CASE ( 'rad_mrt', 'rad_mrt_sw', 'rad_mrt_lw' ) |
---|
1323 | |
---|
1324 | IF ( i == 0 .AND. ilen == 0 .AND. k == 0) THEN |
---|
1325 | ! Workaround for masked output (calls with i=ilen=k=0) |
---|
1326 | unit = 'illegal' |
---|
1327 | RETURN |
---|
1328 | ENDIF |
---|
1329 | |
---|
1330 | IF ( .NOT. radiation ) THEN |
---|
1331 | message_string = 'output of "' // TRIM( var ) // '" require'& |
---|
1332 | // 's radiation = .TRUE.' |
---|
1333 | CALL message( 'check_parameters', 'PA0509', 1, 2, 0, 6, 0 ) |
---|
1334 | ENDIF |
---|
1335 | IF ( mrt_nlevels == 0 ) THEN |
---|
1336 | message_string = 'output of "' // TRIM( var ) // '" require'& |
---|
1337 | // 's mrt_nlevels > 0' |
---|
1338 | CALL message( 'check_parameters', 'PA0510', 1, 2, 0, 6, 0 ) |
---|
1339 | ENDIF |
---|
1340 | IF ( TRIM( var ) == 'rad_mrt_sw' .AND. .NOT. mrt_include_sw ) THEN |
---|
1341 | message_string = 'output of "' // TRIM( var ) // '" require'& |
---|
1342 | // 's rad_mrt_sw = .TRUE.' |
---|
1343 | CALL message( 'check_parameters', 'PA0511', 1, 2, 0, 6, 0 ) |
---|
1344 | ENDIF |
---|
1345 | IF ( TRIM( var ) == 'rad_mrt' ) THEN |
---|
1346 | unit = 'K' |
---|
1347 | ELSE |
---|
1348 | unit = 'W m-2' |
---|
1349 | ENDIF |
---|
1350 | |
---|
1351 | CASE DEFAULT |
---|
1352 | unit = 'illegal' |
---|
1353 | |
---|
1354 | END SELECT |
---|
1355 | |
---|
1356 | |
---|
1357 | END SUBROUTINE radiation_check_data_output |
---|
1358 | |
---|
1359 | !------------------------------------------------------------------------------! |
---|
1360 | ! Description: |
---|
1361 | ! ------------ |
---|
1362 | !> Check data output of profiles for radiation model |
---|
1363 | !------------------------------------------------------------------------------! |
---|
1364 | SUBROUTINE radiation_check_data_output_pr( variable, var_count, unit, & |
---|
1365 | dopr_unit ) |
---|
1366 | |
---|
1367 | USE arrays_3d, & |
---|
1368 | ONLY: zu |
---|
1369 | |
---|
1370 | USE control_parameters, & |
---|
1371 | ONLY: data_output_pr, message_string |
---|
1372 | |
---|
1373 | USE indices |
---|
1374 | |
---|
1375 | USE profil_parameter |
---|
1376 | |
---|
1377 | USE statistics |
---|
1378 | |
---|
1379 | IMPLICIT NONE |
---|
1380 | |
---|
1381 | CHARACTER (LEN=*) :: unit !< |
---|
1382 | CHARACTER (LEN=*) :: variable !< |
---|
1383 | CHARACTER (LEN=*) :: dopr_unit !< local value of dopr_unit |
---|
1384 | |
---|
1385 | INTEGER(iwp) :: var_count !< |
---|
1386 | |
---|
1387 | SELECT CASE ( TRIM( variable ) ) |
---|
1388 | |
---|
1389 | CASE ( 'rad_net' ) |
---|
1390 | IF ( ( .NOT. radiation ) .OR. radiation_scheme == 'constant' )& |
---|
1391 | THEN |
---|
1392 | message_string = 'data_output_pr = ' // & |
---|
1393 | TRIM( data_output_pr(var_count) ) // ' is' // & |
---|
1394 | 'not available for radiation = .FALSE. or ' //& |
---|
1395 | 'radiation_scheme = "constant"' |
---|
1396 | CALL message( 'check_parameters', 'PA0408', 1, 2, 0, 6, 0 ) |
---|
1397 | ELSE |
---|
1398 | dopr_index(var_count) = 99 |
---|
1399 | dopr_unit = 'W/m2' |
---|
1400 | hom(:,2,99,:) = SPREAD( zw, 2, statistic_regions+1 ) |
---|
1401 | unit = dopr_unit |
---|
1402 | ENDIF |
---|
1403 | |
---|
1404 | CASE ( 'rad_lw_in' ) |
---|
1405 | IF ( ( .NOT. radiation) .OR. radiation_scheme == 'constant' ) & |
---|
1406 | THEN |
---|
1407 | message_string = 'data_output_pr = ' // & |
---|
1408 | TRIM( data_output_pr(var_count) ) // ' is' // & |
---|
1409 | 'not available for radiation = .FALSE. or ' //& |
---|
1410 | 'radiation_scheme = "constant"' |
---|
1411 | CALL message( 'check_parameters', 'PA0408', 1, 2, 0, 6, 0 ) |
---|
1412 | ELSE |
---|
1413 | dopr_index(var_count) = 100 |
---|
1414 | dopr_unit = 'W/m2' |
---|
1415 | hom(:,2,100,:) = SPREAD( zw, 2, statistic_regions+1 ) |
---|
1416 | unit = dopr_unit |
---|
1417 | ENDIF |
---|
1418 | |
---|
1419 | CASE ( 'rad_lw_out' ) |
---|
1420 | IF ( ( .NOT. radiation ) .OR. radiation_scheme == 'constant' ) & |
---|
1421 | THEN |
---|
1422 | message_string = 'data_output_pr = ' // & |
---|
1423 | TRIM( data_output_pr(var_count) ) // ' is' // & |
---|
1424 | 'not available for radiation = .FALSE. or ' //& |
---|
1425 | 'radiation_scheme = "constant"' |
---|
1426 | CALL message( 'check_parameters', 'PA0408', 1, 2, 0, 6, 0 ) |
---|
1427 | ELSE |
---|
1428 | dopr_index(var_count) = 101 |
---|
1429 | dopr_unit = 'W/m2' |
---|
1430 | hom(:,2,101,:) = SPREAD( zw, 2, statistic_regions+1 ) |
---|
1431 | unit = dopr_unit |
---|
1432 | ENDIF |
---|
1433 | |
---|
1434 | CASE ( 'rad_sw_in' ) |
---|
1435 | IF ( ( .NOT. radiation ) .OR. radiation_scheme == 'constant' ) & |
---|
1436 | THEN |
---|
1437 | message_string = 'data_output_pr = ' // & |
---|
1438 | TRIM( data_output_pr(var_count) ) // ' is' // & |
---|
1439 | 'not available for radiation = .FALSE. or ' //& |
---|
1440 | 'radiation_scheme = "constant"' |
---|
1441 | CALL message( 'check_parameters', 'PA0408', 1, 2, 0, 6, 0 ) |
---|
1442 | ELSE |
---|
1443 | dopr_index(var_count) = 102 |
---|
1444 | dopr_unit = 'W/m2' |
---|
1445 | hom(:,2,102,:) = SPREAD( zw, 2, statistic_regions+1 ) |
---|
1446 | unit = dopr_unit |
---|
1447 | ENDIF |
---|
1448 | |
---|
1449 | CASE ( 'rad_sw_out') |
---|
1450 | IF ( ( .NOT. radiation ) .OR. radiation_scheme == 'constant' )& |
---|
1451 | THEN |
---|
1452 | message_string = 'data_output_pr = ' // & |
---|
1453 | TRIM( data_output_pr(var_count) ) // ' is' // & |
---|
1454 | 'not available for radiation = .FALSE. or ' //& |
---|
1455 | 'radiation_scheme = "constant"' |
---|
1456 | CALL message( 'check_parameters', 'PA0408', 1, 2, 0, 6, 0 ) |
---|
1457 | ELSE |
---|
1458 | dopr_index(var_count) = 103 |
---|
1459 | dopr_unit = 'W/m2' |
---|
1460 | hom(:,2,103,:) = SPREAD( zw, 2, statistic_regions+1 ) |
---|
1461 | unit = dopr_unit |
---|
1462 | ENDIF |
---|
1463 | |
---|
1464 | CASE ( 'rad_lw_cs_hr' ) |
---|
1465 | IF ( ( .NOT. radiation ) .OR. radiation_scheme /= 'rrtmg' ) & |
---|
1466 | THEN |
---|
1467 | message_string = 'data_output_pr = ' // & |
---|
1468 | TRIM( data_output_pr(var_count) ) // ' is' // & |
---|
1469 | 'not available for radiation = .FALSE. or ' //& |
---|
1470 | 'radiation_scheme /= "rrtmg"' |
---|
1471 | CALL message( 'check_parameters', 'PA0413', 1, 2, 0, 6, 0 ) |
---|
1472 | ELSE |
---|
1473 | dopr_index(var_count) = 104 |
---|
1474 | dopr_unit = 'K/h' |
---|
1475 | hom(:,2,104,:) = SPREAD( zu, 2, statistic_regions+1 ) |
---|
1476 | unit = dopr_unit |
---|
1477 | ENDIF |
---|
1478 | |
---|
1479 | CASE ( 'rad_lw_hr' ) |
---|
1480 | IF ( ( .NOT. radiation ) .OR. radiation_scheme /= 'rrtmg' ) & |
---|
1481 | THEN |
---|
1482 | message_string = 'data_output_pr = ' // & |
---|
1483 | TRIM( data_output_pr(var_count) ) // ' is' // & |
---|
1484 | 'not available for radiation = .FALSE. or ' //& |
---|
1485 | 'radiation_scheme /= "rrtmg"' |
---|
1486 | CALL message( 'check_parameters', 'PA0413', 1, 2, 0, 6, 0 ) |
---|
1487 | ELSE |
---|
1488 | dopr_index(var_count) = 105 |
---|
1489 | dopr_unit = 'K/h' |
---|
1490 | hom(:,2,105,:) = SPREAD( zu, 2, statistic_regions+1 ) |
---|
1491 | unit = dopr_unit |
---|
1492 | ENDIF |
---|
1493 | |
---|
1494 | CASE ( 'rad_sw_cs_hr' ) |
---|
1495 | IF ( ( .NOT. radiation ) .OR. radiation_scheme /= 'rrtmg' ) & |
---|
1496 | THEN |
---|
1497 | message_string = 'data_output_pr = ' // & |
---|
1498 | TRIM( data_output_pr(var_count) ) // ' is' // & |
---|
1499 | 'not available for radiation = .FALSE. or ' //& |
---|
1500 | 'radiation_scheme /= "rrtmg"' |
---|
1501 | CALL message( 'check_parameters', 'PA0413', 1, 2, 0, 6, 0 ) |
---|
1502 | ELSE |
---|
1503 | dopr_index(var_count) = 106 |
---|
1504 | dopr_unit = 'K/h' |
---|
1505 | hom(:,2,106,:) = SPREAD( zu, 2, statistic_regions+1 ) |
---|
1506 | unit = dopr_unit |
---|
1507 | ENDIF |
---|
1508 | |
---|
1509 | CASE ( 'rad_sw_hr' ) |
---|
1510 | IF ( ( .NOT. radiation ) .OR. radiation_scheme /= 'rrtmg' ) & |
---|
1511 | THEN |
---|
1512 | message_string = 'data_output_pr = ' // & |
---|
1513 | TRIM( data_output_pr(var_count) ) // ' is' // & |
---|
1514 | 'not available for radiation = .FALSE. or ' //& |
---|
1515 | 'radiation_scheme /= "rrtmg"' |
---|
1516 | CALL message( 'check_parameters', 'PA0413', 1, 2, 0, 6, 0 ) |
---|
1517 | ELSE |
---|
1518 | dopr_index(var_count) = 107 |
---|
1519 | dopr_unit = 'K/h' |
---|
1520 | hom(:,2,107,:) = SPREAD( zu, 2, statistic_regions+1 ) |
---|
1521 | unit = dopr_unit |
---|
1522 | ENDIF |
---|
1523 | |
---|
1524 | |
---|
1525 | CASE DEFAULT |
---|
1526 | unit = 'illegal' |
---|
1527 | |
---|
1528 | END SELECT |
---|
1529 | |
---|
1530 | |
---|
1531 | END SUBROUTINE radiation_check_data_output_pr |
---|
1532 | |
---|
1533 | |
---|
1534 | !------------------------------------------------------------------------------! |
---|
1535 | ! Description: |
---|
1536 | ! ------------ |
---|
1537 | !> Check parameters routine for radiation model |
---|
1538 | !------------------------------------------------------------------------------! |
---|
1539 | SUBROUTINE radiation_check_parameters |
---|
1540 | |
---|
1541 | USE control_parameters, & |
---|
1542 | ONLY: land_surface, message_string, urban_surface |
---|
1543 | |
---|
1544 | USE netcdf_data_input_mod, & |
---|
1545 | ONLY: input_pids_static |
---|
1546 | |
---|
1547 | IMPLICIT NONE |
---|
1548 | |
---|
1549 | ! |
---|
1550 | !-- In case no urban-surface or land-surface model is applied, usage of |
---|
1551 | !-- a radiation model make no sense. |
---|
1552 | IF ( .NOT. land_surface .AND. .NOT. urban_surface ) THEN |
---|
1553 | message_string = 'Usage of radiation module is only allowed if ' // & |
---|
1554 | 'land-surface and/or urban-surface model is applied.' |
---|
1555 | CALL message( 'check_parameters', 'PA0486', 1, 2, 0, 6, 0 ) |
---|
1556 | ENDIF |
---|
1557 | |
---|
1558 | IF ( radiation_scheme /= 'constant' .AND. & |
---|
1559 | radiation_scheme /= 'clear-sky' .AND. & |
---|
1560 | radiation_scheme /= 'rrtmg' ) THEN |
---|
1561 | message_string = 'unknown radiation_scheme = '// & |
---|
1562 | TRIM( radiation_scheme ) |
---|
1563 | CALL message( 'check_parameters', 'PA0405', 1, 2, 0, 6, 0 ) |
---|
1564 | ELSEIF ( radiation_scheme == 'rrtmg' ) THEN |
---|
1565 | #if ! defined ( __rrtmg ) |
---|
1566 | message_string = 'radiation_scheme = "rrtmg" requires ' // & |
---|
1567 | 'compilation of PALM with pre-processor ' // & |
---|
1568 | 'directive -D__rrtmg' |
---|
1569 | CALL message( 'check_parameters', 'PA0407', 1, 2, 0, 6, 0 ) |
---|
1570 | #endif |
---|
1571 | #if defined ( __rrtmg ) && ! defined( __netcdf ) |
---|
1572 | message_string = 'radiation_scheme = "rrtmg" requires ' // & |
---|
1573 | 'the use of NetCDF (preprocessor directive ' // & |
---|
1574 | '-D__netcdf' |
---|
1575 | CALL message( 'check_parameters', 'PA0412', 1, 2, 0, 6, 0 ) |
---|
1576 | #endif |
---|
1577 | |
---|
1578 | ENDIF |
---|
1579 | ! |
---|
1580 | !-- Checks performed only if data is given via namelist only. |
---|
1581 | IF ( .NOT. input_pids_static ) THEN |
---|
1582 | IF ( albedo_type == 0 .AND. albedo == 9999999.9_wp .AND. & |
---|
1583 | radiation_scheme == 'clear-sky') THEN |
---|
1584 | message_string = 'radiation_scheme = "clear-sky" in combination'//& |
---|
1585 | 'with albedo_type = 0 requires setting of'// & |
---|
1586 | 'albedo /= 9999999.9' |
---|
1587 | CALL message( 'check_parameters', 'PA0410', 1, 2, 0, 6, 0 ) |
---|
1588 | ENDIF |
---|
1589 | |
---|
1590 | IF ( albedo_type == 0 .AND. radiation_scheme == 'rrtmg' .AND. & |
---|
1591 | ( albedo_lw_dif == 9999999.9_wp .OR. albedo_lw_dir == 9999999.9_wp& |
---|
1592 | .OR. albedo_sw_dif == 9999999.9_wp .OR. albedo_sw_dir == 9999999.9_wp& |
---|
1593 | ) ) THEN |
---|
1594 | message_string = 'radiation_scheme = "rrtmg" in combination' // & |
---|
1595 | 'with albedo_type = 0 requires setting of ' // & |
---|
1596 | 'albedo_lw_dif /= 9999999.9' // & |
---|
1597 | 'albedo_lw_dir /= 9999999.9' // & |
---|
1598 | 'albedo_sw_dif /= 9999999.9 and' // & |
---|
1599 | 'albedo_sw_dir /= 9999999.9' |
---|
1600 | CALL message( 'check_parameters', 'PA0411', 1, 2, 0, 6, 0 ) |
---|
1601 | ENDIF |
---|
1602 | ENDIF |
---|
1603 | ! |
---|
1604 | !-- Parallel rad_angular_discretization without raytrace_mpi_rma is not implemented |
---|
1605 | #if defined( __parallel ) |
---|
1606 | IF ( rad_angular_discretization .AND. .NOT. raytrace_mpi_rma ) THEN |
---|
1607 | message_string = 'rad_angular_discretization can only be used ' // & |
---|
1608 | 'together with raytrace_mpi_rma or when ' // & |
---|
1609 | 'no parallelization is applied.' |
---|
1610 | CALL message( 'check_parameters', 'PA0486', 1, 2, 0, 6, 0 ) |
---|
1611 | ENDIF |
---|
1612 | #endif |
---|
1613 | |
---|
1614 | IF ( cloud_droplets .AND. radiation_scheme == 'rrtmg' .AND. & |
---|
1615 | average_radiation ) THEN |
---|
1616 | message_string = 'average_radiation = .T. with radiation_scheme'// & |
---|
1617 | '= "rrtmg" in combination cloud_droplets = .T.'// & |
---|
1618 | 'is not implementd' |
---|
1619 | CALL message( 'check_parameters', 'PA0560', 1, 2, 0, 6, 0 ) |
---|
1620 | ENDIF |
---|
1621 | |
---|
1622 | ! |
---|
1623 | !-- Incialize svf normalization reporting histogram |
---|
1624 | svfnorm_report_num = 1 |
---|
1625 | DO WHILE ( svfnorm_report_thresh(svfnorm_report_num) < 1e20_wp & |
---|
1626 | .AND. svfnorm_report_num <= 30 ) |
---|
1627 | svfnorm_report_num = svfnorm_report_num + 1 |
---|
1628 | ENDDO |
---|
1629 | svfnorm_report_num = svfnorm_report_num - 1 |
---|
1630 | |
---|
1631 | |
---|
1632 | |
---|
1633 | END SUBROUTINE radiation_check_parameters |
---|
1634 | |
---|
1635 | |
---|
1636 | !------------------------------------------------------------------------------! |
---|
1637 | ! Description: |
---|
1638 | ! ------------ |
---|
1639 | !> Initialization of the radiation model |
---|
1640 | !------------------------------------------------------------------------------! |
---|
1641 | SUBROUTINE radiation_init |
---|
1642 | |
---|
1643 | IMPLICIT NONE |
---|
1644 | |
---|
1645 | INTEGER(iwp) :: i !< running index x-direction |
---|
1646 | INTEGER(iwp) :: ioff !< offset in x between surface element reference grid point in atmosphere and actual surface |
---|
1647 | INTEGER(iwp) :: j !< running index y-direction |
---|
1648 | INTEGER(iwp) :: joff !< offset in y between surface element reference grid point in atmosphere and actual surface |
---|
1649 | INTEGER(iwp) :: l !< running index for orientation of vertical surfaces |
---|
1650 | INTEGER(iwp) :: m !< running index for surface elements |
---|
1651 | #if defined( __rrtmg ) |
---|
1652 | INTEGER(iwp) :: ind_type !< running index for subgrid-surface tiles |
---|
1653 | #endif |
---|
1654 | |
---|
1655 | ! |
---|
1656 | !-- Allocate array for storing the surface net radiation |
---|
1657 | IF ( .NOT. ALLOCATED ( surf_lsm_h%rad_net ) .AND. & |
---|
1658 | surf_lsm_h%ns > 0 ) THEN |
---|
1659 | ALLOCATE( surf_lsm_h%rad_net(1:surf_lsm_h%ns) ) |
---|
1660 | surf_lsm_h%rad_net = 0.0_wp |
---|
1661 | ENDIF |
---|
1662 | IF ( .NOT. ALLOCATED ( surf_usm_h%rad_net ) .AND. & |
---|
1663 | surf_usm_h%ns > 0 ) THEN |
---|
1664 | ALLOCATE( surf_usm_h%rad_net(1:surf_usm_h%ns) ) |
---|
1665 | surf_usm_h%rad_net = 0.0_wp |
---|
1666 | ENDIF |
---|
1667 | DO l = 0, 3 |
---|
1668 | IF ( .NOT. ALLOCATED ( surf_lsm_v(l)%rad_net ) .AND. & |
---|
1669 | surf_lsm_v(l)%ns > 0 ) THEN |
---|
1670 | ALLOCATE( surf_lsm_v(l)%rad_net(1:surf_lsm_v(l)%ns) ) |
---|
1671 | surf_lsm_v(l)%rad_net = 0.0_wp |
---|
1672 | ENDIF |
---|
1673 | IF ( .NOT. ALLOCATED ( surf_usm_v(l)%rad_net ) .AND. & |
---|
1674 | surf_usm_v(l)%ns > 0 ) THEN |
---|
1675 | ALLOCATE( surf_usm_v(l)%rad_net(1:surf_usm_v(l)%ns) ) |
---|
1676 | surf_usm_v(l)%rad_net = 0.0_wp |
---|
1677 | ENDIF |
---|
1678 | ENDDO |
---|
1679 | |
---|
1680 | |
---|
1681 | ! |
---|
1682 | !-- Allocate array for storing the surface longwave (out) radiation change |
---|
1683 | IF ( .NOT. ALLOCATED ( surf_lsm_h%rad_lw_out_change_0 ) .AND. & |
---|
1684 | surf_lsm_h%ns > 0 ) THEN |
---|
1685 | ALLOCATE( surf_lsm_h%rad_lw_out_change_0(1:surf_lsm_h%ns) ) |
---|
1686 | surf_lsm_h%rad_lw_out_change_0 = 0.0_wp |
---|
1687 | ENDIF |
---|
1688 | IF ( .NOT. ALLOCATED ( surf_usm_h%rad_lw_out_change_0 ) .AND. & |
---|
1689 | surf_usm_h%ns > 0 ) THEN |
---|
1690 | ALLOCATE( surf_usm_h%rad_lw_out_change_0(1:surf_usm_h%ns) ) |
---|
1691 | surf_usm_h%rad_lw_out_change_0 = 0.0_wp |
---|
1692 | ENDIF |
---|
1693 | DO l = 0, 3 |
---|
1694 | IF ( .NOT. ALLOCATED ( surf_lsm_v(l)%rad_lw_out_change_0 ) .AND. & |
---|
1695 | surf_lsm_v(l)%ns > 0 ) THEN |
---|
1696 | ALLOCATE( surf_lsm_v(l)%rad_lw_out_change_0(1:surf_lsm_v(l)%ns) ) |
---|
1697 | surf_lsm_v(l)%rad_lw_out_change_0 = 0.0_wp |
---|
1698 | ENDIF |
---|
1699 | IF ( .NOT. ALLOCATED ( surf_usm_v(l)%rad_lw_out_change_0 ) .AND. & |
---|
1700 | surf_usm_v(l)%ns > 0 ) THEN |
---|
1701 | ALLOCATE( surf_usm_v(l)%rad_lw_out_change_0(1:surf_usm_v(l)%ns) ) |
---|
1702 | surf_usm_v(l)%rad_lw_out_change_0 = 0.0_wp |
---|
1703 | ENDIF |
---|
1704 | ENDDO |
---|
1705 | |
---|
1706 | ! |
---|
1707 | !-- Allocate surface arrays for incoming/outgoing short/longwave radiation |
---|
1708 | IF ( .NOT. ALLOCATED ( surf_lsm_h%rad_sw_in ) .AND. & |
---|
1709 | surf_lsm_h%ns > 0 ) THEN |
---|
1710 | ALLOCATE( surf_lsm_h%rad_sw_in(1:surf_lsm_h%ns) ) |
---|
1711 | ALLOCATE( surf_lsm_h%rad_sw_out(1:surf_lsm_h%ns) ) |
---|
1712 | ALLOCATE( surf_lsm_h%rad_lw_in(1:surf_lsm_h%ns) ) |
---|
1713 | ALLOCATE( surf_lsm_h%rad_lw_out(1:surf_lsm_h%ns) ) |
---|
1714 | surf_lsm_h%rad_sw_in = 0.0_wp |
---|
1715 | surf_lsm_h%rad_sw_out = 0.0_wp |
---|
1716 | surf_lsm_h%rad_lw_in = 0.0_wp |
---|
1717 | surf_lsm_h%rad_lw_out = 0.0_wp |
---|
1718 | ENDIF |
---|
1719 | IF ( .NOT. ALLOCATED ( surf_usm_h%rad_sw_in ) .AND. & |
---|
1720 | surf_usm_h%ns > 0 ) THEN |
---|
1721 | ALLOCATE( surf_usm_h%rad_sw_in(1:surf_usm_h%ns) ) |
---|
1722 | ALLOCATE( surf_usm_h%rad_sw_out(1:surf_usm_h%ns) ) |
---|
1723 | ALLOCATE( surf_usm_h%rad_lw_in(1:surf_usm_h%ns) ) |
---|
1724 | ALLOCATE( surf_usm_h%rad_lw_out(1:surf_usm_h%ns) ) |
---|
1725 | surf_usm_h%rad_sw_in = 0.0_wp |
---|
1726 | surf_usm_h%rad_sw_out = 0.0_wp |
---|
1727 | surf_usm_h%rad_lw_in = 0.0_wp |
---|
1728 | surf_usm_h%rad_lw_out = 0.0_wp |
---|
1729 | ENDIF |
---|
1730 | DO l = 0, 3 |
---|
1731 | IF ( .NOT. ALLOCATED ( surf_lsm_v(l)%rad_sw_in ) .AND. & |
---|
1732 | surf_lsm_v(l)%ns > 0 ) THEN |
---|
1733 | ALLOCATE( surf_lsm_v(l)%rad_sw_in(1:surf_lsm_v(l)%ns) ) |
---|
1734 | ALLOCATE( surf_lsm_v(l)%rad_sw_out(1:surf_lsm_v(l)%ns) ) |
---|
1735 | ALLOCATE( surf_lsm_v(l)%rad_lw_in(1:surf_lsm_v(l)%ns) ) |
---|
1736 | ALLOCATE( surf_lsm_v(l)%rad_lw_out(1:surf_lsm_v(l)%ns) ) |
---|
1737 | surf_lsm_v(l)%rad_sw_in = 0.0_wp |
---|
1738 | surf_lsm_v(l)%rad_sw_out = 0.0_wp |
---|
1739 | surf_lsm_v(l)%rad_lw_in = 0.0_wp |
---|
1740 | surf_lsm_v(l)%rad_lw_out = 0.0_wp |
---|
1741 | ENDIF |
---|
1742 | IF ( .NOT. ALLOCATED ( surf_usm_v(l)%rad_sw_in ) .AND. & |
---|
1743 | surf_usm_v(l)%ns > 0 ) THEN |
---|
1744 | ALLOCATE( surf_usm_v(l)%rad_sw_in(1:surf_usm_v(l)%ns) ) |
---|
1745 | ALLOCATE( surf_usm_v(l)%rad_sw_out(1:surf_usm_v(l)%ns) ) |
---|
1746 | ALLOCATE( surf_usm_v(l)%rad_lw_in(1:surf_usm_v(l)%ns) ) |
---|
1747 | ALLOCATE( surf_usm_v(l)%rad_lw_out(1:surf_usm_v(l)%ns) ) |
---|
1748 | surf_usm_v(l)%rad_sw_in = 0.0_wp |
---|
1749 | surf_usm_v(l)%rad_sw_out = 0.0_wp |
---|
1750 | surf_usm_v(l)%rad_lw_in = 0.0_wp |
---|
1751 | surf_usm_v(l)%rad_lw_out = 0.0_wp |
---|
1752 | ENDIF |
---|
1753 | ENDDO |
---|
1754 | ! |
---|
1755 | !-- Fix net radiation in case of radiation_scheme = 'constant' |
---|
1756 | IF ( radiation_scheme == 'constant' ) THEN |
---|
1757 | IF ( ALLOCATED( surf_lsm_h%rad_net ) ) & |
---|
1758 | surf_lsm_h%rad_net = net_radiation |
---|
1759 | IF ( ALLOCATED( surf_usm_h%rad_net ) ) & |
---|
1760 | surf_usm_h%rad_net = net_radiation |
---|
1761 | ! |
---|
1762 | !-- Todo: weight with inclination angle |
---|
1763 | DO l = 0, 3 |
---|
1764 | IF ( ALLOCATED( surf_lsm_v(l)%rad_net ) ) & |
---|
1765 | surf_lsm_v(l)%rad_net = net_radiation |
---|
1766 | IF ( ALLOCATED( surf_usm_v(l)%rad_net ) ) & |
---|
1767 | surf_usm_v(l)%rad_net = net_radiation |
---|
1768 | ENDDO |
---|
1769 | ! radiation = .FALSE. |
---|
1770 | ! |
---|
1771 | !-- Calculate orbital constants |
---|
1772 | ELSE |
---|
1773 | decl_1 = SIN(23.45_wp * pi / 180.0_wp) |
---|
1774 | decl_2 = 2.0_wp * pi / 365.0_wp |
---|
1775 | decl_3 = decl_2 * 81.0_wp |
---|
1776 | lat = latitude * pi / 180.0_wp |
---|
1777 | lon = longitude * pi / 180.0_wp |
---|
1778 | ENDIF |
---|
1779 | |
---|
1780 | IF ( radiation_scheme == 'clear-sky' .OR. & |
---|
1781 | radiation_scheme == 'constant') THEN |
---|
1782 | |
---|
1783 | |
---|
1784 | ! |
---|
1785 | !-- Allocate arrays for incoming/outgoing short/longwave radiation |
---|
1786 | IF ( .NOT. ALLOCATED ( rad_sw_in ) ) THEN |
---|
1787 | ALLOCATE ( rad_sw_in(0:0,nysg:nyng,nxlg:nxrg) ) |
---|
1788 | ENDIF |
---|
1789 | IF ( .NOT. ALLOCATED ( rad_sw_out ) ) THEN |
---|
1790 | ALLOCATE ( rad_sw_out(0:0,nysg:nyng,nxlg:nxrg) ) |
---|
1791 | ENDIF |
---|
1792 | |
---|
1793 | IF ( .NOT. ALLOCATED ( rad_lw_in ) ) THEN |
---|
1794 | ALLOCATE ( rad_lw_in(0:0,nysg:nyng,nxlg:nxrg) ) |
---|
1795 | ENDIF |
---|
1796 | IF ( .NOT. ALLOCATED ( rad_lw_out ) ) THEN |
---|
1797 | ALLOCATE ( rad_lw_out(0:0,nysg:nyng,nxlg:nxrg) ) |
---|
1798 | ENDIF |
---|
1799 | |
---|
1800 | ! |
---|
1801 | !-- Allocate average arrays for incoming/outgoing short/longwave radiation |
---|
1802 | IF ( .NOT. ALLOCATED ( rad_sw_in_av ) ) THEN |
---|
1803 | ALLOCATE ( rad_sw_in_av(0:0,nysg:nyng,nxlg:nxrg) ) |
---|
1804 | ENDIF |
---|
1805 | IF ( .NOT. ALLOCATED ( rad_sw_out_av ) ) THEN |
---|
1806 | ALLOCATE ( rad_sw_out_av(0:0,nysg:nyng,nxlg:nxrg) ) |
---|
1807 | ENDIF |
---|
1808 | |
---|
1809 | IF ( .NOT. ALLOCATED ( rad_lw_in_av ) ) THEN |
---|
1810 | ALLOCATE ( rad_lw_in_av(0:0,nysg:nyng,nxlg:nxrg) ) |
---|
1811 | ENDIF |
---|
1812 | IF ( .NOT. ALLOCATED ( rad_lw_out_av ) ) THEN |
---|
1813 | ALLOCATE ( rad_lw_out_av(0:0,nysg:nyng,nxlg:nxrg) ) |
---|
1814 | ENDIF |
---|
1815 | ! |
---|
1816 | !-- Allocate arrays for broadband albedo, and level 1 initialization |
---|
1817 | !-- via namelist paramter, unless not already allocated. |
---|
1818 | IF ( .NOT. ALLOCATED(surf_lsm_h%albedo) ) THEN |
---|
1819 | ALLOCATE( surf_lsm_h%albedo(0:2,1:surf_lsm_h%ns) ) |
---|
1820 | surf_lsm_h%albedo = albedo |
---|
1821 | ENDIF |
---|
1822 | IF ( .NOT. ALLOCATED(surf_usm_h%albedo) ) THEN |
---|
1823 | ALLOCATE( surf_usm_h%albedo(0:2,1:surf_usm_h%ns) ) |
---|
1824 | surf_usm_h%albedo = albedo |
---|
1825 | ENDIF |
---|
1826 | |
---|
1827 | DO l = 0, 3 |
---|
1828 | IF ( .NOT. ALLOCATED( surf_lsm_v(l)%albedo ) ) THEN |
---|
1829 | ALLOCATE( surf_lsm_v(l)%albedo(0:2,1:surf_lsm_v(l)%ns) ) |
---|
1830 | surf_lsm_v(l)%albedo = albedo |
---|
1831 | ENDIF |
---|
1832 | IF ( .NOT. ALLOCATED( surf_usm_v(l)%albedo ) ) THEN |
---|
1833 | ALLOCATE( surf_usm_v(l)%albedo(0:2,1:surf_usm_v(l)%ns) ) |
---|
1834 | surf_usm_v(l)%albedo = albedo |
---|
1835 | ENDIF |
---|
1836 | ENDDO |
---|
1837 | ! |
---|
1838 | !-- Level 2 initialization of broadband albedo via given albedo_type. |
---|
1839 | !-- Only if albedo_type is non-zero. In case of urban surface and |
---|
1840 | !-- input data is read from ASCII file, albedo_type will be zero, so that |
---|
1841 | !-- albedo won't be overwritten. |
---|
1842 | DO m = 1, surf_lsm_h%ns |
---|
1843 | IF ( surf_lsm_h%albedo_type(ind_veg_wall,m) /= 0 ) & |
---|
1844 | surf_lsm_h%albedo(ind_veg_wall,m) = & |
---|
1845 | albedo_pars(2,surf_lsm_h%albedo_type(ind_veg_wall,m)) |
---|
1846 | IF ( surf_lsm_h%albedo_type(ind_pav_green,m) /= 0 ) & |
---|
1847 | surf_lsm_h%albedo(ind_pav_green,m) = & |
---|
1848 | albedo_pars(2,surf_lsm_h%albedo_type(ind_pav_green,m)) |
---|
1849 | IF ( surf_lsm_h%albedo_type(ind_wat_win,m) /= 0 ) & |
---|
1850 | surf_lsm_h%albedo(ind_wat_win,m) = & |
---|
1851 | albedo_pars(2,surf_lsm_h%albedo_type(ind_wat_win,m)) |
---|
1852 | ENDDO |
---|
1853 | DO m = 1, surf_usm_h%ns |
---|
1854 | IF ( surf_usm_h%albedo_type(ind_veg_wall,m) /= 0 ) & |
---|
1855 | surf_usm_h%albedo(ind_veg_wall,m) = & |
---|
1856 | albedo_pars(2,surf_usm_h%albedo_type(ind_veg_wall,m)) |
---|
1857 | IF ( surf_usm_h%albedo_type(ind_pav_green,m) /= 0 ) & |
---|
1858 | surf_usm_h%albedo(ind_pav_green,m) = & |
---|
1859 | albedo_pars(2,surf_usm_h%albedo_type(ind_pav_green,m)) |
---|
1860 | IF ( surf_usm_h%albedo_type(ind_wat_win,m) /= 0 ) & |
---|
1861 | surf_usm_h%albedo(ind_wat_win,m) = & |
---|
1862 | albedo_pars(2,surf_usm_h%albedo_type(ind_wat_win,m)) |
---|
1863 | ENDDO |
---|
1864 | |
---|
1865 | DO l = 0, 3 |
---|
1866 | DO m = 1, surf_lsm_v(l)%ns |
---|
1867 | IF ( surf_lsm_v(l)%albedo_type(ind_veg_wall,m) /= 0 ) & |
---|
1868 | surf_lsm_v(l)%albedo(ind_veg_wall,m) = & |
---|
1869 | albedo_pars(2,surf_lsm_v(l)%albedo_type(ind_veg_wall,m)) |
---|
1870 | IF ( surf_lsm_v(l)%albedo_type(ind_pav_green,m) /= 0 ) & |
---|
1871 | surf_lsm_v(l)%albedo(ind_pav_green,m) = & |
---|
1872 | albedo_pars(2,surf_lsm_v(l)%albedo_type(ind_pav_green,m)) |
---|
1873 | IF ( surf_lsm_v(l)%albedo_type(ind_wat_win,m) /= 0 ) & |
---|
1874 | surf_lsm_v(l)%albedo(ind_wat_win,m) = & |
---|
1875 | albedo_pars(2,surf_lsm_v(l)%albedo_type(ind_wat_win,m)) |
---|
1876 | ENDDO |
---|
1877 | DO m = 1, surf_usm_v(l)%ns |
---|
1878 | IF ( surf_usm_v(l)%albedo_type(ind_veg_wall,m) /= 0 ) & |
---|
1879 | surf_usm_v(l)%albedo(ind_veg_wall,m) = & |
---|
1880 | albedo_pars(2,surf_usm_v(l)%albedo_type(ind_veg_wall,m)) |
---|
1881 | IF ( surf_usm_v(l)%albedo_type(ind_pav_green,m) /= 0 ) & |
---|
1882 | surf_usm_v(l)%albedo(ind_pav_green,m) = & |
---|
1883 | albedo_pars(2,surf_usm_v(l)%albedo_type(ind_pav_green,m)) |
---|
1884 | IF ( surf_usm_v(l)%albedo_type(ind_wat_win,m) /= 0 ) & |
---|
1885 | surf_usm_v(l)%albedo(ind_wat_win,m) = & |
---|
1886 | albedo_pars(2,surf_usm_v(l)%albedo_type(ind_wat_win,m)) |
---|
1887 | ENDDO |
---|
1888 | ENDDO |
---|
1889 | |
---|
1890 | ! |
---|
1891 | !-- Level 3 initialization at grid points where albedo type is zero. |
---|
1892 | !-- This case, albedo is taken from file. In case of constant radiation |
---|
1893 | !-- or clear sky, only broadband albedo is given. |
---|
1894 | IF ( albedo_pars_f%from_file ) THEN |
---|
1895 | ! |
---|
1896 | !-- Horizontal surfaces |
---|
1897 | DO m = 1, surf_lsm_h%ns |
---|
1898 | i = surf_lsm_h%i(m) |
---|
1899 | j = surf_lsm_h%j(m) |
---|
1900 | IF ( albedo_pars_f%pars_xy(0,j,i) /= albedo_pars_f%fill ) THEN |
---|
1901 | IF ( surf_lsm_h%albedo_type(ind_veg_wall,m) == 0 ) & |
---|
1902 | surf_lsm_h%albedo(ind_veg_wall,m) = albedo_pars_f%pars_xy(0,j,i) |
---|
1903 | IF ( surf_lsm_h%albedo_type(ind_pav_green,m) == 0 ) & |
---|
1904 | surf_lsm_h%albedo(ind_pav_green,m) = albedo_pars_f%pars_xy(0,j,i) |
---|
1905 | IF ( surf_lsm_h%albedo_type(ind_wat_win,m) == 0 ) & |
---|
1906 | surf_lsm_h%albedo(ind_wat_win,m) = albedo_pars_f%pars_xy(0,j,i) |
---|
1907 | ENDIF |
---|
1908 | ENDDO |
---|
1909 | DO m = 1, surf_usm_h%ns |
---|
1910 | i = surf_usm_h%i(m) |
---|
1911 | j = surf_usm_h%j(m) |
---|
1912 | IF ( albedo_pars_f%pars_xy(0,j,i) /= albedo_pars_f%fill ) THEN |
---|
1913 | IF ( surf_usm_h%albedo_type(ind_veg_wall,m) == 0 ) & |
---|
1914 | surf_usm_h%albedo(ind_veg_wall,m) = albedo_pars_f%pars_xy(0,j,i) |
---|
1915 | IF ( surf_usm_h%albedo_type(ind_pav_green,m) == 0 ) & |
---|
1916 | surf_usm_h%albedo(ind_pav_green,m) = albedo_pars_f%pars_xy(0,j,i) |
---|
1917 | IF ( surf_usm_h%albedo_type(ind_wat_win,m) == 0 ) & |
---|
1918 | surf_usm_h%albedo(ind_wat_win,m) = albedo_pars_f%pars_xy(0,j,i) |
---|
1919 | ENDIF |
---|
1920 | ENDDO |
---|
1921 | ! |
---|
1922 | !-- Vertical surfaces |
---|
1923 | DO l = 0, 3 |
---|
1924 | |
---|
1925 | ioff = surf_lsm_v(l)%ioff |
---|
1926 | joff = surf_lsm_v(l)%joff |
---|
1927 | DO m = 1, surf_lsm_v(l)%ns |
---|
1928 | i = surf_lsm_v(l)%i(m) + ioff |
---|
1929 | j = surf_lsm_v(l)%j(m) + joff |
---|
1930 | IF ( albedo_pars_f%pars_xy(0,j,i) /= albedo_pars_f%fill ) THEN |
---|
1931 | IF ( surf_lsm_v(l)%albedo_type(ind_veg_wall,m) == 0 ) & |
---|
1932 | surf_lsm_v(l)%albedo(ind_veg_wall,m) = albedo_pars_f%pars_xy(0,j,i) |
---|
1933 | IF ( surf_lsm_v(l)%albedo_type(ind_pav_green,m) == 0 ) & |
---|
1934 | surf_lsm_v(l)%albedo(ind_pav_green,m) = albedo_pars_f%pars_xy(0,j,i) |
---|
1935 | IF ( surf_lsm_v(l)%albedo_type(ind_wat_win,m) == 0 ) & |
---|
1936 | surf_lsm_v(l)%albedo(ind_wat_win,m) = albedo_pars_f%pars_xy(0,j,i) |
---|
1937 | ENDIF |
---|
1938 | ENDDO |
---|
1939 | |
---|
1940 | ioff = surf_usm_v(l)%ioff |
---|
1941 | joff = surf_usm_v(l)%joff |
---|
1942 | DO m = 1, surf_usm_h%ns |
---|
1943 | i = surf_usm_h%i(m) + joff |
---|
1944 | j = surf_usm_h%j(m) + joff |
---|
1945 | IF ( albedo_pars_f%pars_xy(0,j,i) /= albedo_pars_f%fill ) THEN |
---|
1946 | IF ( surf_usm_v(l)%albedo_type(ind_veg_wall,m) == 0 ) & |
---|
1947 | surf_usm_v(l)%albedo(ind_veg_wall,m) = albedo_pars_f%pars_xy(0,j,i) |
---|
1948 | IF ( surf_usm_v(l)%albedo_type(ind_pav_green,m) == 0 ) & |
---|
1949 | surf_usm_v(l)%albedo(ind_pav_green,m) = albedo_pars_f%pars_xy(0,j,i) |
---|
1950 | IF ( surf_usm_v(l)%albedo_type(ind_wat_win,m) == 0 ) & |
---|
1951 | surf_lsm_v(l)%albedo(ind_wat_win,m) = albedo_pars_f%pars_xy(0,j,i) |
---|
1952 | ENDIF |
---|
1953 | ENDDO |
---|
1954 | ENDDO |
---|
1955 | |
---|
1956 | ENDIF |
---|
1957 | ! |
---|
1958 | !-- Initialization actions for RRTMG |
---|
1959 | ELSEIF ( radiation_scheme == 'rrtmg' ) THEN |
---|
1960 | #if defined ( __rrtmg ) |
---|
1961 | ! |
---|
1962 | !-- Allocate albedos for short/longwave radiation, horizontal surfaces |
---|
1963 | !-- for wall/green/window (USM) or vegetation/pavement/water surfaces |
---|
1964 | !-- (LSM). |
---|
1965 | ALLOCATE ( surf_lsm_h%aldif(0:2,1:surf_lsm_h%ns) ) |
---|
1966 | ALLOCATE ( surf_lsm_h%aldir(0:2,1:surf_lsm_h%ns) ) |
---|
1967 | ALLOCATE ( surf_lsm_h%asdif(0:2,1:surf_lsm_h%ns) ) |
---|
1968 | ALLOCATE ( surf_lsm_h%asdir(0:2,1:surf_lsm_h%ns) ) |
---|
1969 | ALLOCATE ( surf_lsm_h%rrtm_aldif(0:2,1:surf_lsm_h%ns) ) |
---|
1970 | ALLOCATE ( surf_lsm_h%rrtm_aldir(0:2,1:surf_lsm_h%ns) ) |
---|
1971 | ALLOCATE ( surf_lsm_h%rrtm_asdif(0:2,1:surf_lsm_h%ns) ) |
---|
1972 | ALLOCATE ( surf_lsm_h%rrtm_asdir(0:2,1:surf_lsm_h%ns) ) |
---|
1973 | |
---|
1974 | ALLOCATE ( surf_usm_h%aldif(0:2,1:surf_usm_h%ns) ) |
---|
1975 | ALLOCATE ( surf_usm_h%aldir(0:2,1:surf_usm_h%ns) ) |
---|
1976 | ALLOCATE ( surf_usm_h%asdif(0:2,1:surf_usm_h%ns) ) |
---|
1977 | ALLOCATE ( surf_usm_h%asdir(0:2,1:surf_usm_h%ns) ) |
---|
1978 | ALLOCATE ( surf_usm_h%rrtm_aldif(0:2,1:surf_usm_h%ns) ) |
---|
1979 | ALLOCATE ( surf_usm_h%rrtm_aldir(0:2,1:surf_usm_h%ns) ) |
---|
1980 | ALLOCATE ( surf_usm_h%rrtm_asdif(0:2,1:surf_usm_h%ns) ) |
---|
1981 | ALLOCATE ( surf_usm_h%rrtm_asdir(0:2,1:surf_usm_h%ns) ) |
---|
1982 | |
---|
1983 | ! |
---|
1984 | !-- Allocate broadband albedo (temporary for the current radiation |
---|
1985 | !-- implementations) |
---|
1986 | IF ( .NOT. ALLOCATED(surf_lsm_h%albedo) ) & |
---|
1987 | ALLOCATE( surf_lsm_h%albedo(0:2,1:surf_lsm_h%ns) ) |
---|
1988 | IF ( .NOT. ALLOCATED(surf_usm_h%albedo) ) & |
---|
1989 | ALLOCATE( surf_usm_h%albedo(0:2,1:surf_usm_h%ns) ) |
---|
1990 | |
---|
1991 | ! |
---|
1992 | !-- Allocate albedos for short/longwave radiation, vertical surfaces |
---|
1993 | DO l = 0, 3 |
---|
1994 | |
---|
1995 | ALLOCATE ( surf_lsm_v(l)%aldif(0:2,1:surf_lsm_v(l)%ns) ) |
---|
1996 | ALLOCATE ( surf_lsm_v(l)%aldir(0:2,1:surf_lsm_v(l)%ns) ) |
---|
1997 | ALLOCATE ( surf_lsm_v(l)%asdif(0:2,1:surf_lsm_v(l)%ns) ) |
---|
1998 | ALLOCATE ( surf_lsm_v(l)%asdir(0:2,1:surf_lsm_v(l)%ns) ) |
---|
1999 | |
---|
2000 | ALLOCATE ( surf_lsm_v(l)%rrtm_aldif(0:2,1:surf_lsm_v(l)%ns) ) |
---|
2001 | ALLOCATE ( surf_lsm_v(l)%rrtm_aldir(0:2,1:surf_lsm_v(l)%ns) ) |
---|
2002 | ALLOCATE ( surf_lsm_v(l)%rrtm_asdif(0:2,1:surf_lsm_v(l)%ns) ) |
---|
2003 | ALLOCATE ( surf_lsm_v(l)%rrtm_asdir(0:2,1:surf_lsm_v(l)%ns) ) |
---|
2004 | |
---|
2005 | ALLOCATE ( surf_usm_v(l)%aldif(0:2,1:surf_usm_v(l)%ns) ) |
---|
2006 | ALLOCATE ( surf_usm_v(l)%aldir(0:2,1:surf_usm_v(l)%ns) ) |
---|
2007 | ALLOCATE ( surf_usm_v(l)%asdif(0:2,1:surf_usm_v(l)%ns) ) |
---|
2008 | ALLOCATE ( surf_usm_v(l)%asdir(0:2,1:surf_usm_v(l)%ns) ) |
---|
2009 | |
---|
2010 | ALLOCATE ( surf_usm_v(l)%rrtm_aldif(0:2,1:surf_usm_v(l)%ns) ) |
---|
2011 | ALLOCATE ( surf_usm_v(l)%rrtm_aldir(0:2,1:surf_usm_v(l)%ns) ) |
---|
2012 | ALLOCATE ( surf_usm_v(l)%rrtm_asdif(0:2,1:surf_usm_v(l)%ns) ) |
---|
2013 | ALLOCATE ( surf_usm_v(l)%rrtm_asdir(0:2,1:surf_usm_v(l)%ns) ) |
---|
2014 | ! |
---|
2015 | !-- Allocate broadband albedo (temporary for the current radiation |
---|
2016 | !-- implementations) |
---|
2017 | IF ( .NOT. ALLOCATED( surf_lsm_v(l)%albedo ) ) & |
---|
2018 | ALLOCATE( surf_lsm_v(l)%albedo(0:2,1:surf_lsm_v(l)%ns) ) |
---|
2019 | IF ( .NOT. ALLOCATED( surf_usm_v(l)%albedo ) ) & |
---|
2020 | ALLOCATE( surf_usm_v(l)%albedo(0:2,1:surf_usm_v(l)%ns) ) |
---|
2021 | |
---|
2022 | ENDDO |
---|
2023 | ! |
---|
2024 | !-- Level 1 initialization of spectral albedos via namelist |
---|
2025 | !-- paramters. Please note, this case all surface tiles are initialized |
---|
2026 | !-- the same. |
---|
2027 | IF ( surf_lsm_h%ns > 0 ) THEN |
---|
2028 | surf_lsm_h%aldif = albedo_lw_dif |
---|
2029 | surf_lsm_h%aldir = albedo_lw_dir |
---|
2030 | surf_lsm_h%asdif = albedo_sw_dif |
---|
2031 | surf_lsm_h%asdir = albedo_sw_dir |
---|
2032 | surf_lsm_h%albedo = albedo_sw_dif |
---|
2033 | ENDIF |
---|
2034 | IF ( surf_usm_h%ns > 0 ) THEN |
---|
2035 | IF ( surf_usm_h%albedo_from_ascii ) THEN |
---|
2036 | surf_usm_h%aldif = surf_usm_h%albedo |
---|
2037 | surf_usm_h%aldir = surf_usm_h%albedo |
---|
2038 | surf_usm_h%asdif = surf_usm_h%albedo |
---|
2039 | surf_usm_h%asdir = surf_usm_h%albedo |
---|
2040 | ELSE |
---|
2041 | surf_usm_h%aldif = albedo_lw_dif |
---|
2042 | surf_usm_h%aldir = albedo_lw_dir |
---|
2043 | surf_usm_h%asdif = albedo_sw_dif |
---|
2044 | surf_usm_h%asdir = albedo_sw_dir |
---|
2045 | surf_usm_h%albedo = albedo_sw_dif |
---|
2046 | ENDIF |
---|
2047 | ENDIF |
---|
2048 | |
---|
2049 | DO l = 0, 3 |
---|
2050 | |
---|
2051 | IF ( surf_lsm_v(l)%ns > 0 ) THEN |
---|
2052 | surf_lsm_v(l)%aldif = albedo_lw_dif |
---|
2053 | surf_lsm_v(l)%aldir = albedo_lw_dir |
---|
2054 | surf_lsm_v(l)%asdif = albedo_sw_dif |
---|
2055 | surf_lsm_v(l)%asdir = albedo_sw_dir |
---|
2056 | surf_lsm_v(l)%albedo = albedo_sw_dif |
---|
2057 | ENDIF |
---|
2058 | |
---|
2059 | IF ( surf_usm_v(l)%ns > 0 ) THEN |
---|
2060 | IF ( surf_usm_v(l)%albedo_from_ascii ) THEN |
---|
2061 | surf_usm_v(l)%aldif = surf_usm_v(l)%albedo |
---|
2062 | surf_usm_v(l)%aldir = surf_usm_v(l)%albedo |
---|
2063 | surf_usm_v(l)%asdif = surf_usm_v(l)%albedo |
---|
2064 | surf_usm_v(l)%asdir = surf_usm_v(l)%albedo |
---|
2065 | ELSE |
---|
2066 | surf_usm_v(l)%aldif = albedo_lw_dif |
---|
2067 | surf_usm_v(l)%aldir = albedo_lw_dir |
---|
2068 | surf_usm_v(l)%asdif = albedo_sw_dif |
---|
2069 | surf_usm_v(l)%asdir = albedo_sw_dir |
---|
2070 | ENDIF |
---|
2071 | ENDIF |
---|
2072 | ENDDO |
---|
2073 | |
---|
2074 | ! |
---|
2075 | !-- Level 2 initialization of spectral albedos via albedo_type. |
---|
2076 | !-- Please note, for natural- and urban-type surfaces, a tile approach |
---|
2077 | !-- is applied so that the resulting albedo is calculated via the weighted |
---|
2078 | !-- average of respective surface fractions. |
---|
2079 | DO m = 1, surf_lsm_h%ns |
---|
2080 | ! |
---|
2081 | !-- Spectral albedos for vegetation/pavement/water surfaces |
---|
2082 | DO ind_type = 0, 2 |
---|
2083 | IF ( surf_lsm_h%albedo_type(ind_type,m) /= 0 ) THEN |
---|
2084 | surf_lsm_h%aldif(ind_type,m) = & |
---|
2085 | albedo_pars(0,surf_lsm_h%albedo_type(ind_type,m)) |
---|
2086 | surf_lsm_h%asdif(ind_type,m) = & |
---|
2087 | albedo_pars(1,surf_lsm_h%albedo_type(ind_type,m)) |
---|
2088 | surf_lsm_h%aldir(ind_type,m) = & |
---|
2089 | albedo_pars(0,surf_lsm_h%albedo_type(ind_type,m)) |
---|
2090 | surf_lsm_h%asdir(ind_type,m) = & |
---|
2091 | albedo_pars(1,surf_lsm_h%albedo_type(ind_type,m)) |
---|
2092 | surf_lsm_h%albedo(ind_type,m) = & |
---|
2093 | albedo_pars(2,surf_lsm_h%albedo_type(ind_type,m)) |
---|
2094 | ENDIF |
---|
2095 | ENDDO |
---|
2096 | |
---|
2097 | ENDDO |
---|
2098 | ! |
---|
2099 | !-- For urban surface only if albedo has not been already initialized |
---|
2100 | !-- in the urban-surface model via the ASCII file. |
---|
2101 | IF ( .NOT. surf_usm_h%albedo_from_ascii ) THEN |
---|
2102 | DO m = 1, surf_usm_h%ns |
---|
2103 | ! |
---|
2104 | !-- Spectral albedos for wall/green/window surfaces |
---|
2105 | DO ind_type = 0, 2 |
---|
2106 | IF ( surf_usm_h%albedo_type(ind_type,m) /= 0 ) THEN |
---|
2107 | surf_usm_h%aldif(ind_type,m) = & |
---|
2108 | albedo_pars(0,surf_usm_h%albedo_type(ind_type,m)) |
---|
2109 | surf_usm_h%asdif(ind_type,m) = & |
---|
2110 | albedo_pars(1,surf_usm_h%albedo_type(ind_type,m)) |
---|
2111 | surf_usm_h%aldir(ind_type,m) = & |
---|
2112 | albedo_pars(0,surf_usm_h%albedo_type(ind_type,m)) |
---|
2113 | surf_usm_h%asdir(ind_type,m) = & |
---|
2114 | albedo_pars(1,surf_usm_h%albedo_type(ind_type,m)) |
---|
2115 | surf_usm_h%albedo(ind_type,m) = & |
---|
2116 | albedo_pars(2,surf_usm_h%albedo_type(ind_type,m)) |
---|
2117 | ENDIF |
---|
2118 | ENDDO |
---|
2119 | |
---|
2120 | ENDDO |
---|
2121 | ENDIF |
---|
2122 | |
---|
2123 | DO l = 0, 3 |
---|
2124 | |
---|
2125 | DO m = 1, surf_lsm_v(l)%ns |
---|
2126 | ! |
---|
2127 | !-- Spectral albedos for vegetation/pavement/water surfaces |
---|
2128 | DO ind_type = 0, 2 |
---|
2129 | IF ( surf_lsm_v(l)%albedo_type(ind_type,m) /= 0 ) THEN |
---|
2130 | surf_lsm_v(l)%aldif(ind_type,m) = & |
---|
2131 | albedo_pars(0,surf_lsm_v(l)%albedo_type(ind_type,m)) |
---|
2132 | surf_lsm_v(l)%asdif(ind_type,m) = & |
---|
2133 | albedo_pars(1,surf_lsm_v(l)%albedo_type(ind_type,m)) |
---|
2134 | surf_lsm_v(l)%aldir(ind_type,m) = & |
---|
2135 | albedo_pars(0,surf_lsm_v(l)%albedo_type(ind_type,m)) |
---|
2136 | surf_lsm_v(l)%asdir(ind_type,m) = & |
---|
2137 | albedo_pars(1,surf_lsm_v(l)%albedo_type(ind_type,m)) |
---|
2138 | surf_lsm_v(l)%albedo(ind_type,m) = & |
---|
2139 | albedo_pars(2,surf_lsm_v(l)%albedo_type(ind_type,m)) |
---|
2140 | ENDIF |
---|
2141 | ENDDO |
---|
2142 | ENDDO |
---|
2143 | ! |
---|
2144 | !-- For urban surface only if albedo has not been already initialized |
---|
2145 | !-- in the urban-surface model via the ASCII file. |
---|
2146 | IF ( .NOT. surf_usm_v(l)%albedo_from_ascii ) THEN |
---|
2147 | DO m = 1, surf_usm_v(l)%ns |
---|
2148 | ! |
---|
2149 | !-- Spectral albedos for wall/green/window surfaces |
---|
2150 | DO ind_type = 0, 2 |
---|
2151 | IF ( surf_usm_v(l)%albedo_type(ind_type,m) /= 0 ) THEN |
---|
2152 | surf_usm_v(l)%aldif(ind_type,m) = & |
---|
2153 | albedo_pars(0,surf_usm_v(l)%albedo_type(ind_type,m)) |
---|
2154 | surf_usm_v(l)%asdif(ind_type,m) = & |
---|
2155 | albedo_pars(1,surf_usm_v(l)%albedo_type(ind_type,m)) |
---|
2156 | surf_usm_v(l)%aldir(ind_type,m) = & |
---|
2157 | albedo_pars(0,surf_usm_v(l)%albedo_type(ind_type,m)) |
---|
2158 | surf_usm_v(l)%asdir(ind_type,m) = & |
---|
2159 | albedo_pars(1,surf_usm_v(l)%albedo_type(ind_type,m)) |
---|
2160 | surf_usm_v(l)%albedo(ind_type,m) = & |
---|
2161 | albedo_pars(2,surf_usm_v(l)%albedo_type(ind_type,m)) |
---|
2162 | ENDIF |
---|
2163 | ENDDO |
---|
2164 | |
---|
2165 | ENDDO |
---|
2166 | ENDIF |
---|
2167 | ENDDO |
---|
2168 | ! |
---|
2169 | !-- Level 3 initialization at grid points where albedo type is zero. |
---|
2170 | !-- This case, spectral albedos are taken from file if available |
---|
2171 | IF ( albedo_pars_f%from_file ) THEN |
---|
2172 | ! |
---|
2173 | !-- Horizontal |
---|
2174 | DO m = 1, surf_lsm_h%ns |
---|
2175 | i = surf_lsm_h%i(m) |
---|
2176 | j = surf_lsm_h%j(m) |
---|
2177 | ! |
---|
2178 | !-- Spectral albedos for vegetation/pavement/water surfaces |
---|
2179 | DO ind_type = 0, 2 |
---|
2180 | IF ( surf_lsm_h%albedo_type(ind_type,m) == 0 ) THEN |
---|
2181 | IF ( albedo_pars_f%pars_xy(1,j,i) /= albedo_pars_f%fill )& |
---|
2182 | surf_lsm_h%albedo(ind_type,m) = & |
---|
2183 | albedo_pars_f%pars_xy(1,j,i) |
---|
2184 | IF ( albedo_pars_f%pars_xy(1,j,i) /= albedo_pars_f%fill )& |
---|
2185 | surf_lsm_h%aldir(ind_type,m) = & |
---|
2186 | albedo_pars_f%pars_xy(1,j,i) |
---|
2187 | IF ( albedo_pars_f%pars_xy(2,j,i) /= albedo_pars_f%fill )& |
---|
2188 | surf_lsm_h%aldif(ind_type,m) = & |
---|
2189 | albedo_pars_f%pars_xy(2,j,i) |
---|
2190 | IF ( albedo_pars_f%pars_xy(3,j,i) /= albedo_pars_f%fill )& |
---|
2191 | surf_lsm_h%asdir(ind_type,m) = & |
---|
2192 | albedo_pars_f%pars_xy(3,j,i) |
---|
2193 | IF ( albedo_pars_f%pars_xy(4,j,i) /= albedo_pars_f%fill )& |
---|
2194 | surf_lsm_h%asdif(ind_type,m) = & |
---|
2195 | albedo_pars_f%pars_xy(4,j,i) |
---|
2196 | ENDIF |
---|
2197 | ENDDO |
---|
2198 | ENDDO |
---|
2199 | ! |
---|
2200 | !-- For urban surface only if albedo has not been already initialized |
---|
2201 | !-- in the urban-surface model via the ASCII file. |
---|
2202 | IF ( .NOT. surf_usm_h%albedo_from_ascii ) THEN |
---|
2203 | DO m = 1, surf_usm_h%ns |
---|
2204 | i = surf_usm_h%i(m) |
---|
2205 | j = surf_usm_h%j(m) |
---|
2206 | ! |
---|
2207 | !-- Spectral albedos for wall/green/window surfaces |
---|
2208 | DO ind_type = 0, 2 |
---|
2209 | IF ( surf_usm_h%albedo_type(ind_type,m) == 0 ) THEN |
---|
2210 | IF ( albedo_pars_f%pars_xy(1,j,i) /= albedo_pars_f%fill )& |
---|
2211 | surf_usm_h%albedo(ind_type,m) = & |
---|
2212 | albedo_pars_f%pars_xy(1,j,i) |
---|
2213 | IF ( albedo_pars_f%pars_xy(1,j,i) /= albedo_pars_f%fill )& |
---|
2214 | surf_usm_h%aldir(ind_type,m) = & |
---|
2215 | albedo_pars_f%pars_xy(1,j,i) |
---|
2216 | IF ( albedo_pars_f%pars_xy(2,j,i) /= albedo_pars_f%fill )& |
---|
2217 | surf_usm_h%aldif(ind_type,m) = & |
---|
2218 | albedo_pars_f%pars_xy(2,j,i) |
---|
2219 | IF ( albedo_pars_f%pars_xy(3,j,i) /= albedo_pars_f%fill )& |
---|
2220 | surf_usm_h%asdir(ind_type,m) = & |
---|
2221 | albedo_pars_f%pars_xy(3,j,i) |
---|
2222 | IF ( albedo_pars_f%pars_xy(4,j,i) /= albedo_pars_f%fill )& |
---|
2223 | surf_usm_h%asdif(ind_type,m) = & |
---|
2224 | albedo_pars_f%pars_xy(4,j,i) |
---|
2225 | ENDIF |
---|
2226 | ENDDO |
---|
2227 | |
---|
2228 | ENDDO |
---|
2229 | ENDIF |
---|
2230 | ! |
---|
2231 | !-- Vertical |
---|
2232 | DO l = 0, 3 |
---|
2233 | ioff = surf_lsm_v(l)%ioff |
---|
2234 | joff = surf_lsm_v(l)%joff |
---|
2235 | |
---|
2236 | DO m = 1, surf_lsm_v(l)%ns |
---|
2237 | i = surf_lsm_v(l)%i(m) |
---|
2238 | j = surf_lsm_v(l)%j(m) |
---|
2239 | ! |
---|
2240 | !-- Spectral albedos for vegetation/pavement/water surfaces |
---|
2241 | DO ind_type = 0, 2 |
---|
2242 | IF ( surf_lsm_v(l)%albedo_type(ind_type,m) == 0 ) THEN |
---|
2243 | IF ( albedo_pars_f%pars_xy(1,j+joff,i+ioff) /= & |
---|
2244 | albedo_pars_f%fill ) & |
---|
2245 | surf_lsm_v(l)%albedo(ind_type,m) = & |
---|
2246 | albedo_pars_f%pars_xy(1,j+joff,i+ioff) |
---|
2247 | IF ( albedo_pars_f%pars_xy(1,j+joff,i+ioff) /= & |
---|
2248 | albedo_pars_f%fill ) & |
---|
2249 | surf_lsm_v(l)%aldir(ind_type,m) = & |
---|
2250 | albedo_pars_f%pars_xy(1,j+joff,i+ioff) |
---|
2251 | IF ( albedo_pars_f%pars_xy(2,j+joff,i+ioff) /= & |
---|
2252 | albedo_pars_f%fill ) & |
---|
2253 | surf_lsm_v(l)%aldif(ind_type,m) = & |
---|
2254 | albedo_pars_f%pars_xy(2,j+joff,i+ioff) |
---|
2255 | IF ( albedo_pars_f%pars_xy(3,j+joff,i+ioff) /= & |
---|
2256 | albedo_pars_f%fill ) & |
---|
2257 | surf_lsm_v(l)%asdir(ind_type,m) = & |
---|
2258 | albedo_pars_f%pars_xy(3,j+joff,i+ioff) |
---|
2259 | IF ( albedo_pars_f%pars_xy(4,j+joff,i+ioff) /= & |
---|
2260 | albedo_pars_f%fill ) & |
---|
2261 | surf_lsm_v(l)%asdif(ind_type,m) = & |
---|
2262 | albedo_pars_f%pars_xy(4,j+joff,i+ioff) |
---|
2263 | ENDIF |
---|
2264 | ENDDO |
---|
2265 | ENDDO |
---|
2266 | ! |
---|
2267 | !-- For urban surface only if albedo has not been already initialized |
---|
2268 | !-- in the urban-surface model via the ASCII file. |
---|
2269 | IF ( .NOT. surf_usm_v(l)%albedo_from_ascii ) THEN |
---|
2270 | ioff = surf_usm_v(l)%ioff |
---|
2271 | joff = surf_usm_v(l)%joff |
---|
2272 | |
---|
2273 | DO m = 1, surf_usm_v(l)%ns |
---|
2274 | i = surf_usm_v(l)%i(m) |
---|
2275 | j = surf_usm_v(l)%j(m) |
---|
2276 | ! |
---|
2277 | !-- Spectral albedos for wall/green/window surfaces |
---|
2278 | DO ind_type = 0, 2 |
---|
2279 | IF ( surf_usm_v(l)%albedo_type(ind_type,m) == 0 ) THEN |
---|
2280 | IF ( albedo_pars_f%pars_xy(1,j+joff,i+ioff) /= & |
---|
2281 | albedo_pars_f%fill ) & |
---|
2282 | surf_usm_v(l)%albedo(ind_type,m) = & |
---|
2283 | albedo_pars_f%pars_xy(1,j+joff,i+ioff) |
---|
2284 | IF ( albedo_pars_f%pars_xy(1,j+joff,i+ioff) /= & |
---|
2285 | albedo_pars_f%fill ) & |
---|
2286 | surf_usm_v(l)%aldir(ind_type,m) = & |
---|
2287 | albedo_pars_f%pars_xy(1,j+joff,i+ioff) |
---|
2288 | IF ( albedo_pars_f%pars_xy(2,j+joff,i+ioff) /= & |
---|
2289 | albedo_pars_f%fill ) & |
---|
2290 | surf_usm_v(l)%aldif(ind_type,m) = & |
---|
2291 | albedo_pars_f%pars_xy(2,j+joff,i+ioff) |
---|
2292 | IF ( albedo_pars_f%pars_xy(3,j+joff,i+ioff) /= & |
---|
2293 | albedo_pars_f%fill ) & |
---|
2294 | surf_usm_v(l)%asdir(ind_type,m) = & |
---|
2295 | albedo_pars_f%pars_xy(3,j+joff,i+ioff) |
---|
2296 | IF ( albedo_pars_f%pars_xy(4,j+joff,i+ioff) /= & |
---|
2297 | albedo_pars_f%fill ) & |
---|
2298 | surf_usm_v(l)%asdif(ind_type,m) = & |
---|
2299 | albedo_pars_f%pars_xy(4,j+joff,i+ioff) |
---|
2300 | ENDIF |
---|
2301 | ENDDO |
---|
2302 | |
---|
2303 | ENDDO |
---|
2304 | ENDIF |
---|
2305 | ENDDO |
---|
2306 | |
---|
2307 | ENDIF |
---|
2308 | |
---|
2309 | ! |
---|
2310 | !-- Calculate initial values of current (cosine of) the zenith angle and |
---|
2311 | !-- whether the sun is up |
---|
2312 | CALL calc_zenith |
---|
2313 | ! |
---|
2314 | !-- Calculate initial surface albedo for different surfaces |
---|
2315 | IF ( .NOT. constant_albedo ) THEN |
---|
2316 | #if defined( __netcdf ) |
---|
2317 | ! |
---|
2318 | !-- Horizontally aligned natural and urban surfaces |
---|
2319 | CALL calc_albedo( surf_lsm_h ) |
---|
2320 | CALL calc_albedo( surf_usm_h ) |
---|
2321 | ! |
---|
2322 | !-- Vertically aligned natural and urban surfaces |
---|
2323 | DO l = 0, 3 |
---|
2324 | CALL calc_albedo( surf_lsm_v(l) ) |
---|
2325 | CALL calc_albedo( surf_usm_v(l) ) |
---|
2326 | ENDDO |
---|
2327 | #endif |
---|
2328 | ELSE |
---|
2329 | ! |
---|
2330 | !-- Initialize sun-inclination independent spectral albedos |
---|
2331 | !-- Horizontal surfaces |
---|
2332 | IF ( surf_lsm_h%ns > 0 ) THEN |
---|
2333 | surf_lsm_h%rrtm_aldir = surf_lsm_h%aldir |
---|
2334 | surf_lsm_h%rrtm_asdir = surf_lsm_h%asdir |
---|
2335 | surf_lsm_h%rrtm_aldif = surf_lsm_h%aldif |
---|
2336 | surf_lsm_h%rrtm_asdif = surf_lsm_h%asdif |
---|
2337 | ENDIF |
---|
2338 | IF ( surf_usm_h%ns > 0 ) THEN |
---|
2339 | surf_usm_h%rrtm_aldir = surf_usm_h%aldir |
---|
2340 | surf_usm_h%rrtm_asdir = surf_usm_h%asdir |
---|
2341 | surf_usm_h%rrtm_aldif = surf_usm_h%aldif |
---|
2342 | surf_usm_h%rrtm_asdif = surf_usm_h%asdif |
---|
2343 | ENDIF |
---|
2344 | ! |
---|
2345 | !-- Vertical surfaces |
---|
2346 | DO l = 0, 3 |
---|
2347 | IF ( surf_lsm_v(l)%ns > 0 ) THEN |
---|
2348 | surf_lsm_v(l)%rrtm_aldir = surf_lsm_v(l)%aldir |
---|
2349 | surf_lsm_v(l)%rrtm_asdir = surf_lsm_v(l)%asdir |
---|
2350 | surf_lsm_v(l)%rrtm_aldif = surf_lsm_v(l)%aldif |
---|
2351 | surf_lsm_v(l)%rrtm_asdif = surf_lsm_v(l)%asdif |
---|
2352 | ENDIF |
---|
2353 | IF ( surf_usm_v(l)%ns > 0 ) THEN |
---|
2354 | surf_usm_v(l)%rrtm_aldir = surf_usm_v(l)%aldir |
---|
2355 | surf_usm_v(l)%rrtm_asdir = surf_usm_v(l)%asdir |
---|
2356 | surf_usm_v(l)%rrtm_aldif = surf_usm_v(l)%aldif |
---|
2357 | surf_usm_v(l)%rrtm_asdif = surf_usm_v(l)%asdif |
---|
2358 | ENDIF |
---|
2359 | ENDDO |
---|
2360 | |
---|
2361 | ENDIF |
---|
2362 | |
---|
2363 | ! |
---|
2364 | !-- Allocate 3d arrays of radiative fluxes and heating rates |
---|
2365 | IF ( .NOT. ALLOCATED ( rad_sw_in ) ) THEN |
---|
2366 | ALLOCATE ( rad_sw_in(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) |
---|
2367 | rad_sw_in = 0.0_wp |
---|
2368 | ENDIF |
---|
2369 | |
---|
2370 | IF ( .NOT. ALLOCATED ( rad_sw_in_av ) ) THEN |
---|
2371 | ALLOCATE ( rad_sw_in_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) |
---|
2372 | ENDIF |
---|
2373 | |
---|
2374 | IF ( .NOT. ALLOCATED ( rad_sw_out ) ) THEN |
---|
2375 | ALLOCATE ( rad_sw_out(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) |
---|
2376 | rad_sw_out = 0.0_wp |
---|
2377 | ENDIF |
---|
2378 | |
---|
2379 | IF ( .NOT. ALLOCATED ( rad_sw_out_av ) ) THEN |
---|
2380 | ALLOCATE ( rad_sw_out_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) |
---|
2381 | ENDIF |
---|
2382 | |
---|
2383 | IF ( .NOT. ALLOCATED ( rad_sw_hr ) ) THEN |
---|
2384 | ALLOCATE ( rad_sw_hr(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) |
---|
2385 | rad_sw_hr = 0.0_wp |
---|
2386 | ENDIF |
---|
2387 | |
---|
2388 | IF ( .NOT. ALLOCATED ( rad_sw_hr_av ) ) THEN |
---|
2389 | ALLOCATE ( rad_sw_hr_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) |
---|
2390 | rad_sw_hr_av = 0.0_wp |
---|
2391 | ENDIF |
---|
2392 | |
---|
2393 | IF ( .NOT. ALLOCATED ( rad_sw_cs_hr ) ) THEN |
---|
2394 | ALLOCATE ( rad_sw_cs_hr(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) |
---|
2395 | rad_sw_cs_hr = 0.0_wp |
---|
2396 | ENDIF |
---|
2397 | |
---|
2398 | IF ( .NOT. ALLOCATED ( rad_sw_cs_hr_av ) ) THEN |
---|
2399 | ALLOCATE ( rad_sw_cs_hr_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) |
---|
2400 | rad_sw_cs_hr_av = 0.0_wp |
---|
2401 | ENDIF |
---|
2402 | |
---|
2403 | IF ( .NOT. ALLOCATED ( rad_lw_in ) ) THEN |
---|
2404 | ALLOCATE ( rad_lw_in(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) |
---|
2405 | rad_lw_in = 0.0_wp |
---|
2406 | ENDIF |
---|
2407 | |
---|
2408 | IF ( .NOT. ALLOCATED ( rad_lw_in_av ) ) THEN |
---|
2409 | ALLOCATE ( rad_lw_in_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) |
---|
2410 | ENDIF |
---|
2411 | |
---|
2412 | IF ( .NOT. ALLOCATED ( rad_lw_out ) ) THEN |
---|
2413 | ALLOCATE ( rad_lw_out(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) |
---|
2414 | rad_lw_out = 0.0_wp |
---|
2415 | ENDIF |
---|
2416 | |
---|
2417 | IF ( .NOT. ALLOCATED ( rad_lw_out_av ) ) THEN |
---|
2418 | ALLOCATE ( rad_lw_out_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) |
---|
2419 | ENDIF |
---|
2420 | |
---|
2421 | IF ( .NOT. ALLOCATED ( rad_lw_hr ) ) THEN |
---|
2422 | ALLOCATE ( rad_lw_hr(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) |
---|
2423 | rad_lw_hr = 0.0_wp |
---|
2424 | ENDIF |
---|
2425 | |
---|
2426 | IF ( .NOT. ALLOCATED ( rad_lw_hr_av ) ) THEN |
---|
2427 | ALLOCATE ( rad_lw_hr_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) |
---|
2428 | rad_lw_hr_av = 0.0_wp |
---|
2429 | ENDIF |
---|
2430 | |
---|
2431 | IF ( .NOT. ALLOCATED ( rad_lw_cs_hr ) ) THEN |
---|
2432 | ALLOCATE ( rad_lw_cs_hr(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) |
---|
2433 | rad_lw_cs_hr = 0.0_wp |
---|
2434 | ENDIF |
---|
2435 | |
---|
2436 | IF ( .NOT. ALLOCATED ( rad_lw_cs_hr_av ) ) THEN |
---|
2437 | ALLOCATE ( rad_lw_cs_hr_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) |
---|
2438 | rad_lw_cs_hr_av = 0.0_wp |
---|
2439 | ENDIF |
---|
2440 | |
---|
2441 | ALLOCATE ( rad_sw_cs_in(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) |
---|
2442 | ALLOCATE ( rad_sw_cs_out(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) |
---|
2443 | rad_sw_cs_in = 0.0_wp |
---|
2444 | rad_sw_cs_out = 0.0_wp |
---|
2445 | |
---|
2446 | ALLOCATE ( rad_lw_cs_in(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) |
---|
2447 | ALLOCATE ( rad_lw_cs_out(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) |
---|
2448 | rad_lw_cs_in = 0.0_wp |
---|
2449 | rad_lw_cs_out = 0.0_wp |
---|
2450 | |
---|
2451 | ! |
---|
2452 | !-- Allocate 1-element array for surface temperature |
---|
2453 | !-- (RRTMG anticipates an array as passed argument). |
---|
2454 | ALLOCATE ( rrtm_tsfc(1) ) |
---|
2455 | ! |
---|
2456 | !-- Allocate surface emissivity. |
---|
2457 | !-- Values will be given directly before calling rrtm_lw. |
---|
2458 | ALLOCATE ( rrtm_emis(0:0,1:nbndlw+1) ) |
---|
2459 | |
---|
2460 | ! |
---|
2461 | !-- Initialize RRTMG |
---|
2462 | IF ( lw_radiation ) CALL rrtmg_lw_ini ( c_p ) |
---|
2463 | IF ( sw_radiation ) CALL rrtmg_sw_ini ( c_p ) |
---|
2464 | |
---|
2465 | ! |
---|
2466 | !-- Set input files for RRTMG |
---|
2467 | INQUIRE(FILE="RAD_SND_DATA", EXIST=snd_exists) |
---|
2468 | IF ( .NOT. snd_exists ) THEN |
---|
2469 | rrtm_input_file = "rrtmg_lw.nc" |
---|
2470 | ENDIF |
---|
2471 | |
---|
2472 | ! |
---|
2473 | !-- Read vertical layers for RRTMG from sounding data |
---|
2474 | !-- The routine provides nzt_rad, hyp_snd(1:nzt_rad), |
---|
2475 | !-- t_snd(nzt+2:nzt_rad), rrtm_play(1:nzt_rad), rrtm_plev(1_nzt_rad+1), |
---|
2476 | !-- rrtm_tlay(nzt+2:nzt_rad), rrtm_tlev(nzt+2:nzt_rad+1) |
---|
2477 | CALL read_sounding_data |
---|
2478 | |
---|
2479 | ! |
---|
2480 | !-- Read trace gas profiles from file. This routine provides |
---|
2481 | !-- the rrtm_ arrays (1:nzt_rad+1) |
---|
2482 | CALL read_trace_gas_data |
---|
2483 | #endif |
---|
2484 | ENDIF |
---|
2485 | |
---|
2486 | ! |
---|
2487 | !-- Perform user actions if required |
---|
2488 | CALL user_init_radiation |
---|
2489 | |
---|
2490 | ! |
---|
2491 | !-- Calculate radiative fluxes at model start |
---|
2492 | SELECT CASE ( TRIM( radiation_scheme ) ) |
---|
2493 | |
---|
2494 | CASE ( 'rrtmg' ) |
---|
2495 | CALL radiation_rrtmg |
---|
2496 | |
---|
2497 | CASE ( 'clear-sky' ) |
---|
2498 | CALL radiation_clearsky |
---|
2499 | |
---|
2500 | CASE ( 'constant' ) |
---|
2501 | CALL radiation_constant |
---|
2502 | |
---|
2503 | CASE DEFAULT |
---|
2504 | |
---|
2505 | END SELECT |
---|
2506 | |
---|
2507 | RETURN |
---|
2508 | |
---|
2509 | END SUBROUTINE radiation_init |
---|
2510 | |
---|
2511 | |
---|
2512 | !------------------------------------------------------------------------------! |
---|
2513 | ! Description: |
---|
2514 | ! ------------ |
---|
2515 | !> A simple clear sky radiation model |
---|
2516 | !------------------------------------------------------------------------------! |
---|
2517 | SUBROUTINE radiation_clearsky |
---|
2518 | |
---|
2519 | |
---|
2520 | IMPLICIT NONE |
---|
2521 | |
---|
2522 | INTEGER(iwp) :: l !< running index for surface orientation |
---|
2523 | REAL(wp) :: pt1 !< potential temperature at first grid level or mean value at urban layer top |
---|
2524 | REAL(wp) :: pt1_l !< potential temperature at first grid level or mean value at urban layer top at local subdomain |
---|
2525 | REAL(wp) :: ql1 !< liquid water mixing ratio at first grid level or mean value at urban layer top |
---|
2526 | REAL(wp) :: ql1_l !< liquid water mixing ratio at first grid level or mean value at urban layer top at local subdomain |
---|
2527 | |
---|
2528 | TYPE(surf_type), POINTER :: surf !< pointer on respective surface type, used to generalize routine |
---|
2529 | |
---|
2530 | ! |
---|
2531 | !-- Calculate current zenith angle |
---|
2532 | CALL calc_zenith |
---|
2533 | |
---|
2534 | ! |
---|
2535 | !-- Calculate sky transmissivity |
---|
2536 | sky_trans = 0.6_wp + 0.2_wp * zenith(0) |
---|
2537 | |
---|
2538 | ! |
---|
2539 | !-- Calculate value of the Exner function at model surface |
---|
2540 | ! |
---|
2541 | !-- In case averaged radiation is used, calculate mean temperature and |
---|
2542 | !-- liquid water mixing ratio at the urban-layer top. |
---|
2543 | IF ( average_radiation ) THEN |
---|
2544 | pt1 = 0.0_wp |
---|
2545 | IF ( bulk_cloud_model .OR. cloud_droplets ) ql1 = 0.0_wp |
---|
2546 | |
---|
2547 | pt1_l = SUM( pt(nzut,nys:nyn,nxl:nxr) ) |
---|
2548 | IF ( bulk_cloud_model .OR. cloud_droplets ) ql1_l = SUM( ql(nzut,nys:nyn,nxl:nxr) ) |
---|
2549 | |
---|
2550 | #if defined( __parallel ) |
---|
2551 | IF ( collective_wait ) CALL MPI_BARRIER( comm2d, ierr ) |
---|
2552 | CALL MPI_ALLREDUCE( pt1_l, pt1, 1, MPI_REAL, MPI_SUM, comm2d, ierr ) |
---|
2553 | IF ( ierr /= 0 ) THEN |
---|
2554 | WRITE(9,*) 'Error MPI_AllReduce1:', ierr, pt1_l, pt1 |
---|
2555 | FLUSH(9) |
---|
2556 | ENDIF |
---|
2557 | |
---|
2558 | IF ( bulk_cloud_model .OR. cloud_droplets ) THEN |
---|
2559 | CALL MPI_ALLREDUCE( ql1_l, ql1, 1, MPI_REAL, MPI_SUM, comm2d, ierr ) |
---|
2560 | IF ( ierr /= 0 ) THEN |
---|
2561 | WRITE(9,*) 'Error MPI_AllReduce2:', ierr, ql1_l, ql1 |
---|
2562 | FLUSH(9) |
---|
2563 | ENDIF |
---|
2564 | ENDIF |
---|
2565 | #else |
---|
2566 | pt1 = pt1_l |
---|
2567 | IF ( bulk_cloud_model .OR. cloud_droplets ) ql1 = ql1_l |
---|
2568 | #endif |
---|
2569 | |
---|
2570 | IF ( bulk_cloud_model .OR. cloud_droplets ) pt1 = pt1 + lv_d_cp / exner(nzut) * ql1 |
---|
2571 | ! |
---|
2572 | !-- Finally, divide by number of grid points |
---|
2573 | pt1 = pt1 / REAL( ( nx + 1 ) * ( ny + 1 ), KIND=wp ) |
---|
2574 | ENDIF |
---|
2575 | ! |
---|
2576 | !-- Call clear-sky calculation for each surface orientation. |
---|
2577 | !-- First, horizontal surfaces |
---|
2578 | surf => surf_lsm_h |
---|
2579 | CALL radiation_clearsky_surf |
---|
2580 | surf => surf_usm_h |
---|
2581 | CALL radiation_clearsky_surf |
---|
2582 | ! |
---|
2583 | !-- Vertical surfaces |
---|
2584 | DO l = 0, 3 |
---|
2585 | surf => surf_lsm_v(l) |
---|
2586 | CALL radiation_clearsky_surf |
---|
2587 | surf => surf_usm_v(l) |
---|
2588 | CALL radiation_clearsky_surf |
---|
2589 | ENDDO |
---|
2590 | |
---|
2591 | CONTAINS |
---|
2592 | |
---|
2593 | SUBROUTINE radiation_clearsky_surf |
---|
2594 | |
---|
2595 | IMPLICIT NONE |
---|
2596 | |
---|
2597 | INTEGER(iwp) :: i !< index x-direction |
---|
2598 | INTEGER(iwp) :: j !< index y-direction |
---|
2599 | INTEGER(iwp) :: k !< index z-direction |
---|
2600 | INTEGER(iwp) :: m !< running index for surface elements |
---|
2601 | |
---|
2602 | IF ( surf%ns < 1 ) RETURN |
---|
2603 | |
---|
2604 | ! |
---|
2605 | !-- Calculate radiation fluxes and net radiation (rad_net) assuming |
---|
2606 | !-- homogeneous urban radiation conditions. |
---|
2607 | IF ( average_radiation ) THEN |
---|
2608 | |
---|
2609 | k = nzut |
---|
2610 | |
---|
2611 | surf%rad_sw_in = solar_constant * sky_trans * zenith(0) |
---|
2612 | surf%rad_sw_out = albedo_urb * surf%rad_sw_in |
---|
2613 | |
---|
2614 | surf%rad_lw_in = 0.8_wp * sigma_sb * (pt1 * exner(k+1))**4 |
---|
2615 | |
---|
2616 | surf%rad_lw_out = emissivity_urb * sigma_sb * (t_rad_urb)**4 & |
---|
2617 | + (1.0_wp - emissivity_urb) * surf%rad_lw_in |
---|
2618 | |
---|
2619 | surf%rad_net = surf%rad_sw_in - surf%rad_sw_out & |
---|
2620 | + surf%rad_lw_in - surf%rad_lw_out |
---|
2621 | |
---|
2622 | surf%rad_lw_out_change_0 = 3.0_wp * emissivity_urb * sigma_sb & |
---|
2623 | * (t_rad_urb)**3 |
---|
2624 | |
---|
2625 | ! |
---|
2626 | !-- Calculate radiation fluxes and net radiation (rad_net) for each surface |
---|
2627 | !-- element. |
---|
2628 | ELSE |
---|
2629 | |
---|
2630 | DO m = 1, surf%ns |
---|
2631 | i = surf%i(m) |
---|
2632 | j = surf%j(m) |
---|
2633 | k = surf%k(m) |
---|
2634 | |
---|
2635 | surf%rad_sw_in(m) = solar_constant * sky_trans * zenith(0) |
---|
2636 | |
---|
2637 | ! |
---|
2638 | !-- Weighted average according to surface fraction. |
---|
2639 | !-- ATTENTION: when radiation interactions are switched on the |
---|
2640 | !-- calculated fluxes below are not actually used as they are |
---|
2641 | !-- overwritten in radiation_interaction. |
---|
2642 | surf%rad_sw_out(m) = ( surf%frac(ind_veg_wall,m) * & |
---|
2643 | surf%albedo(ind_veg_wall,m) & |
---|
2644 | + surf%frac(ind_pav_green,m) * & |
---|
2645 | surf%albedo(ind_pav_green,m) & |
---|
2646 | + surf%frac(ind_wat_win,m) * & |
---|
2647 | surf%albedo(ind_wat_win,m) ) & |
---|
2648 | * surf%rad_sw_in(m) |
---|
2649 | |
---|
2650 | surf%rad_lw_out(m) = ( surf%frac(ind_veg_wall,m) * & |
---|
2651 | surf%emissivity(ind_veg_wall,m) & |
---|
2652 | + surf%frac(ind_pav_green,m) * & |
---|
2653 | surf%emissivity(ind_pav_green,m) & |
---|
2654 | + surf%frac(ind_wat_win,m) * & |
---|
2655 | surf%emissivity(ind_wat_win,m) & |
---|
2656 | ) & |
---|
2657 | * sigma_sb & |
---|
2658 | * ( surf%pt_surface(m) * exner(nzb) )**4 |
---|
2659 | |
---|
2660 | surf%rad_lw_out_change_0(m) = & |
---|
2661 | ( surf%frac(ind_veg_wall,m) * & |
---|
2662 | surf%emissivity(ind_veg_wall,m) & |
---|
2663 | + surf%frac(ind_pav_green,m) * & |
---|
2664 | surf%emissivity(ind_pav_green,m) & |
---|
2665 | + surf%frac(ind_wat_win,m) * & |
---|
2666 | surf%emissivity(ind_wat_win,m) & |
---|
2667 | ) * 3.0_wp * sigma_sb & |
---|
2668 | * ( surf%pt_surface(m) * exner(nzb) )** 3 |
---|
2669 | |
---|
2670 | |
---|
2671 | IF ( bulk_cloud_model .OR. cloud_droplets ) THEN |
---|
2672 | pt1 = pt(k,j,i) + lv_d_cp / exner(k) * ql(k,j,i) |
---|
2673 | surf%rad_lw_in(m) = 0.8_wp * sigma_sb * (pt1 * exner(k))**4 |
---|
2674 | ELSE |
---|
2675 | surf%rad_lw_in(m) = 0.8_wp * sigma_sb * (pt(k,j,i) * exner(k))**4 |
---|
2676 | ENDIF |
---|
2677 | |
---|
2678 | surf%rad_net(m) = surf%rad_sw_in(m) - surf%rad_sw_out(m) & |
---|
2679 | + surf%rad_lw_in(m) - surf%rad_lw_out(m) |
---|
2680 | |
---|
2681 | ENDDO |
---|
2682 | |
---|
2683 | ENDIF |
---|
2684 | |
---|
2685 | ! |
---|
2686 | !-- Fill out values in radiation arrays |
---|
2687 | DO m = 1, surf%ns |
---|
2688 | i = surf%i(m) |
---|
2689 | j = surf%j(m) |
---|
2690 | rad_sw_in(0,j,i) = surf%rad_sw_in(m) |
---|
2691 | rad_sw_out(0,j,i) = surf%rad_sw_out(m) |
---|
2692 | rad_lw_in(0,j,i) = surf%rad_lw_in(m) |
---|
2693 | rad_lw_out(0,j,i) = surf%rad_lw_out(m) |
---|
2694 | ENDDO |
---|
2695 | |
---|
2696 | END SUBROUTINE radiation_clearsky_surf |
---|
2697 | |
---|
2698 | END SUBROUTINE radiation_clearsky |
---|
2699 | |
---|
2700 | |
---|
2701 | !------------------------------------------------------------------------------! |
---|
2702 | ! Description: |
---|
2703 | ! ------------ |
---|
2704 | !> This scheme keeps the prescribed net radiation constant during the run |
---|
2705 | !------------------------------------------------------------------------------! |
---|
2706 | SUBROUTINE radiation_constant |
---|
2707 | |
---|
2708 | |
---|
2709 | IMPLICIT NONE |
---|
2710 | |
---|
2711 | INTEGER(iwp) :: l !< running index for surface orientation |
---|
2712 | |
---|
2713 | REAL(wp) :: pt1 !< potential temperature at first grid level or mean value at urban layer top |
---|
2714 | REAL(wp) :: pt1_l !< potential temperature at first grid level or mean value at urban layer top at local subdomain |
---|
2715 | REAL(wp) :: ql1 !< liquid water mixing ratio at first grid level or mean value at urban layer top |
---|
2716 | REAL(wp) :: ql1_l !< liquid water mixing ratio at first grid level or mean value at urban layer top at local subdomain |
---|
2717 | |
---|
2718 | TYPE(surf_type), POINTER :: surf !< pointer on respective surface type, used to generalize routine |
---|
2719 | |
---|
2720 | ! |
---|
2721 | !-- In case averaged radiation is used, calculate mean temperature and |
---|
2722 | !-- liquid water mixing ratio at the urban-layer top. |
---|
2723 | IF ( average_radiation ) THEN |
---|
2724 | pt1 = 0.0_wp |
---|
2725 | IF ( bulk_cloud_model .OR. cloud_droplets ) ql1 = 0.0_wp |
---|
2726 | |
---|
2727 | pt1_l = SUM( pt(nzut,nys:nyn,nxl:nxr) ) |
---|
2728 | IF ( bulk_cloud_model .OR. cloud_droplets ) ql1_l = SUM( ql(nzut,nys:nyn,nxl:nxr) ) |
---|
2729 | |
---|
2730 | #if defined( __parallel ) |
---|
2731 | IF ( collective_wait ) CALL MPI_BARRIER( comm2d, ierr ) |
---|
2732 | CALL MPI_ALLREDUCE( pt1_l, pt1, 1, MPI_REAL, MPI_SUM, comm2d, ierr ) |
---|
2733 | IF ( ierr /= 0 ) THEN |
---|
2734 | WRITE(9,*) 'Error MPI_AllReduce3:', ierr, pt1_l, pt1 |
---|
2735 | FLUSH(9) |
---|
2736 | ENDIF |
---|
2737 | IF ( bulk_cloud_model .OR. cloud_droplets ) THEN |
---|
2738 | CALL MPI_ALLREDUCE( ql1_l, ql1, 1, MPI_REAL, MPI_SUM, comm2d, ierr ) |
---|
2739 | IF ( ierr /= 0 ) THEN |
---|
2740 | WRITE(9,*) 'Error MPI_AllReduce4:', ierr, ql1_l, ql1 |
---|
2741 | FLUSH(9) |
---|
2742 | ENDIF |
---|
2743 | ENDIF |
---|
2744 | #else |
---|
2745 | pt1 = pt1_l |
---|
2746 | IF ( bulk_cloud_model .OR. cloud_droplets ) ql1 = ql1_l |
---|
2747 | #endif |
---|
2748 | IF ( bulk_cloud_model .OR. cloud_droplets ) pt1 = pt1 + lv_d_cp / exner(nzut+1) * ql1 |
---|
2749 | ! |
---|
2750 | !-- Finally, divide by number of grid points |
---|
2751 | pt1 = pt1 / REAL( ( nx + 1 ) * ( ny + 1 ), KIND=wp ) |
---|
2752 | ENDIF |
---|
2753 | |
---|
2754 | ! |
---|
2755 | !-- First, horizontal surfaces |
---|
2756 | surf => surf_lsm_h |
---|
2757 | CALL radiation_constant_surf |
---|
2758 | surf => surf_usm_h |
---|
2759 | CALL radiation_constant_surf |
---|
2760 | ! |
---|
2761 | !-- Vertical surfaces |
---|
2762 | DO l = 0, 3 |
---|
2763 | surf => surf_lsm_v(l) |
---|
2764 | CALL radiation_constant_surf |
---|
2765 | surf => surf_usm_v(l) |
---|
2766 | CALL radiation_constant_surf |
---|
2767 | ENDDO |
---|
2768 | |
---|
2769 | CONTAINS |
---|
2770 | |
---|
2771 | SUBROUTINE radiation_constant_surf |
---|
2772 | |
---|
2773 | IMPLICIT NONE |
---|
2774 | |
---|
2775 | INTEGER(iwp) :: i !< index x-direction |
---|
2776 | INTEGER(iwp) :: ioff !< offset between surface element and adjacent grid point along x |
---|
2777 | INTEGER(iwp) :: j !< index y-direction |
---|
2778 | INTEGER(iwp) :: joff !< offset between surface element and adjacent grid point along y |
---|
2779 | INTEGER(iwp) :: k !< index z-direction |
---|
2780 | INTEGER(iwp) :: koff !< offset between surface element and adjacent grid point along z |
---|
2781 | INTEGER(iwp) :: m !< running index for surface elements |
---|
2782 | |
---|
2783 | IF ( surf%ns < 1 ) RETURN |
---|
2784 | |
---|
2785 | !-- Calculate homogenoeus urban radiation fluxes |
---|
2786 | IF ( average_radiation ) THEN |
---|
2787 | |
---|
2788 | surf%rad_net = net_radiation |
---|
2789 | |
---|
2790 | surf%rad_lw_in = 0.8_wp * sigma_sb * (pt1 * exner(nzut+1))**4 |
---|
2791 | |
---|
2792 | surf%rad_lw_out = emissivity_urb * sigma_sb * (t_rad_urb)**4 & |
---|
2793 | + ( 1.0_wp - emissivity_urb ) & ! shouldn't be this a bulk value -- emissivity_urb? |
---|
2794 | * surf%rad_lw_in |
---|
2795 | |
---|
2796 | surf%rad_lw_out_change_0 = 3.0_wp * emissivity_urb * sigma_sb & |
---|
2797 | * t_rad_urb**3 |
---|
2798 | |
---|
2799 | surf%rad_sw_in = ( surf%rad_net - surf%rad_lw_in & |
---|
2800 | + surf%rad_lw_out ) & |
---|
2801 | / ( 1.0_wp - albedo_urb ) |
---|
2802 | |
---|
2803 | surf%rad_sw_out = albedo_urb * surf%rad_sw_in |
---|
2804 | |
---|
2805 | ! |
---|
2806 | !-- Calculate radiation fluxes for each surface element |
---|
2807 | ELSE |
---|
2808 | ! |
---|
2809 | !-- Determine index offset between surface element and adjacent |
---|
2810 | !-- atmospheric grid point |
---|
2811 | ioff = surf%ioff |
---|
2812 | joff = surf%joff |
---|
2813 | koff = surf%koff |
---|
2814 | |
---|
2815 | ! |
---|
2816 | !-- Prescribe net radiation and estimate the remaining radiative fluxes |
---|
2817 | DO m = 1, surf%ns |
---|
2818 | i = surf%i(m) |
---|
2819 | j = surf%j(m) |
---|
2820 | k = surf%k(m) |
---|
2821 | |
---|
2822 | surf%rad_net(m) = net_radiation |
---|
2823 | |
---|
2824 | IF ( bulk_cloud_model .OR. cloud_droplets ) THEN |
---|
2825 | pt1 = pt(k,j,i) + lv_d_cp / exner(k) * ql(k,j,i) |
---|
2826 | surf%rad_lw_in(m) = 0.8_wp * sigma_sb * (pt1 * exner(k))**4 |
---|
2827 | ELSE |
---|
2828 | surf%rad_lw_in(m) = 0.8_wp * sigma_sb * & |
---|
2829 | ( pt(k,j,i) * exner(k) )**4 |
---|
2830 | ENDIF |
---|
2831 | |
---|
2832 | ! |
---|
2833 | !-- Weighted average according to surface fraction. |
---|
2834 | surf%rad_lw_out(m) = ( surf%frac(ind_veg_wall,m) * & |
---|
2835 | surf%emissivity(ind_veg_wall,m) & |
---|
2836 | + surf%frac(ind_pav_green,m) * & |
---|
2837 | surf%emissivity(ind_pav_green,m) & |
---|
2838 | + surf%frac(ind_wat_win,m) * & |
---|
2839 | surf%emissivity(ind_wat_win,m) & |
---|
2840 | ) & |
---|
2841 | * sigma_sb & |
---|
2842 | * ( surf%pt_surface(m) * exner(nzb) )**4 |
---|
2843 | |
---|
2844 | surf%rad_sw_in(m) = ( surf%rad_net(m) - surf%rad_lw_in(m) & |
---|
2845 | + surf%rad_lw_out(m) ) & |
---|
2846 | / ( 1.0_wp - & |
---|
2847 | ( surf%frac(ind_veg_wall,m) * & |
---|
2848 | surf%albedo(ind_veg_wall,m) & |
---|
2849 | + surf%frac(ind_pav_green,m) * & |
---|
2850 | surf%albedo(ind_pav_green,m) & |
---|
2851 | + surf%frac(ind_wat_win,m) * & |
---|
2852 | surf%albedo(ind_wat_win,m) ) & |
---|
2853 | ) |
---|
2854 | |
---|
2855 | surf%rad_sw_out(m) = ( surf%frac(ind_veg_wall,m) * & |
---|
2856 | surf%albedo(ind_veg_wall,m) & |
---|
2857 | + surf%frac(ind_pav_green,m) * & |
---|
2858 | surf%albedo(ind_pav_green,m) & |
---|
2859 | + surf%frac(ind_wat_win,m) * & |
---|
2860 | surf%albedo(ind_wat_win,m) ) & |
---|
2861 | * surf%rad_sw_in(m) |
---|
2862 | |
---|
2863 | ENDDO |
---|
2864 | |
---|
2865 | ENDIF |
---|
2866 | |
---|
2867 | ! |
---|
2868 | !-- Fill out values in radiation arrays |
---|
2869 | DO m = 1, surf%ns |
---|
2870 | i = surf%i(m) |
---|
2871 | j = surf%j(m) |
---|
2872 | rad_sw_in(0,j,i) = surf%rad_sw_in(m) |
---|
2873 | rad_sw_out(0,j,i) = surf%rad_sw_out(m) |
---|
2874 | rad_lw_in(0,j,i) = surf%rad_lw_in(m) |
---|
2875 | rad_lw_out(0,j,i) = surf%rad_lw_out(m) |
---|
2876 | ENDDO |
---|
2877 | |
---|
2878 | END SUBROUTINE radiation_constant_surf |
---|
2879 | |
---|
2880 | |
---|
2881 | END SUBROUTINE radiation_constant |
---|
2882 | |
---|
2883 | !------------------------------------------------------------------------------! |
---|
2884 | ! Description: |
---|
2885 | ! ------------ |
---|
2886 | !> Header output for radiation model |
---|
2887 | !------------------------------------------------------------------------------! |
---|
2888 | SUBROUTINE radiation_header ( io ) |
---|
2889 | |
---|
2890 | |
---|
2891 | IMPLICIT NONE |
---|
2892 | |
---|
2893 | INTEGER(iwp), INTENT(IN) :: io !< Unit of the output file |
---|
2894 | |
---|
2895 | |
---|
2896 | |
---|
2897 | ! |
---|
2898 | !-- Write radiation model header |
---|
2899 | WRITE( io, 3 ) |
---|
2900 | |
---|
2901 | IF ( radiation_scheme == "constant" ) THEN |
---|
2902 | WRITE( io, 4 ) net_radiation |
---|
2903 | ELSEIF ( radiation_scheme == "clear-sky" ) THEN |
---|
2904 | WRITE( io, 5 ) |
---|
2905 | ELSEIF ( radiation_scheme == "rrtmg" ) THEN |
---|
2906 | WRITE( io, 6 ) |
---|
2907 | IF ( .NOT. lw_radiation ) WRITE( io, 10 ) |
---|
2908 | IF ( .NOT. sw_radiation ) WRITE( io, 11 ) |
---|
2909 | ENDIF |
---|
2910 | |
---|
2911 | IF ( albedo_type_f%from_file .OR. vegetation_type_f%from_file .OR. & |
---|
2912 | pavement_type_f%from_file .OR. water_type_f%from_file .OR. & |
---|
2913 | building_type_f%from_file ) THEN |
---|
2914 | WRITE( io, 13 ) |
---|
2915 | ELSE |
---|
2916 | IF ( albedo_type == 0 ) THEN |
---|
2917 | WRITE( io, 7 ) albedo |
---|
2918 | ELSE |
---|
2919 | WRITE( io, 8 ) TRIM( albedo_type_name(albedo_type) ) |
---|
2920 | ENDIF |
---|
2921 | ENDIF |
---|
2922 | IF ( constant_albedo ) THEN |
---|
2923 | WRITE( io, 9 ) |
---|
2924 | ENDIF |
---|
2925 | |
---|
2926 | WRITE( io, 12 ) dt_radiation |
---|
2927 | |
---|
2928 | |
---|
2929 | 3 FORMAT (//' Radiation model information:'/ & |
---|
2930 | ' ----------------------------'/) |
---|
2931 | 4 FORMAT (' --> Using constant net radiation: net_radiation = ', F6.2, & |
---|
2932 | // 'W/m**2') |
---|
2933 | 5 FORMAT (' --> Simple radiation scheme for clear sky is used (no clouds,',& |
---|
2934 | ' default)') |
---|
2935 | 6 FORMAT (' --> RRTMG scheme is used') |
---|
2936 | 7 FORMAT (/' User-specific surface albedo: albedo =', F6.3) |
---|
2937 | 8 FORMAT (/' Albedo is set for land surface type: ', A) |
---|
2938 | 9 FORMAT (/' --> Albedo is fixed during the run') |
---|
2939 | 10 FORMAT (/' --> Longwave radiation is disabled') |
---|
2940 | 11 FORMAT (/' --> Shortwave radiation is disabled.') |
---|
2941 | 12 FORMAT (' Timestep: dt_radiation = ', F6.2, ' s') |
---|
2942 | 13 FORMAT (/' Albedo is set individually for each xy-location, according ', & |
---|
2943 | 'to given surface type.') |
---|
2944 | |
---|
2945 | |
---|
2946 | END SUBROUTINE radiation_header |
---|
2947 | |
---|
2948 | |
---|
2949 | !------------------------------------------------------------------------------! |
---|
2950 | ! Description: |
---|
2951 | ! ------------ |
---|
2952 | !> Parin for &radiation_parameters for radiation model |
---|
2953 | !------------------------------------------------------------------------------! |
---|
2954 | SUBROUTINE radiation_parin |
---|
2955 | |
---|
2956 | |
---|
2957 | IMPLICIT NONE |
---|
2958 | |
---|
2959 | CHARACTER (LEN=80) :: line !< dummy string that contains the current line of the parameter file |
---|
2960 | |
---|
2961 | NAMELIST /radiation_par/ albedo, albedo_lw_dif, albedo_lw_dir, & |
---|
2962 | albedo_sw_dif, albedo_sw_dir, albedo_type, & |
---|
2963 | constant_albedo, dt_radiation, emissivity, & |
---|
2964 | lw_radiation, max_raytracing_dist, & |
---|
2965 | min_irrf_value, mrt_geom_human, & |
---|
2966 | mrt_include_sw, mrt_nlevels, & |
---|
2967 | mrt_skip_roof, net_radiation, nrefsteps, & |
---|
2968 | plant_lw_interact, rad_angular_discretization,& |
---|
2969 | radiation_interactions_on, radiation_scheme, & |
---|
2970 | raytrace_discrete_azims, & |
---|
2971 | raytrace_discrete_elevs, raytrace_mpi_rma, & |
---|
2972 | skip_time_do_radiation, surface_reflections, & |
---|
2973 | svfnorm_report_thresh, sw_radiation, & |
---|
2974 | unscheduled_radiation_calls |
---|
2975 | |
---|
2976 | |
---|
2977 | NAMELIST /radiation_parameters/ albedo, albedo_lw_dif, albedo_lw_dir, & |
---|
2978 | albedo_sw_dif, albedo_sw_dir, albedo_type, & |
---|
2979 | constant_albedo, dt_radiation, emissivity, & |
---|
2980 | lw_radiation, max_raytracing_dist, & |
---|
2981 | min_irrf_value, mrt_geom_human, & |
---|
2982 | mrt_include_sw, mrt_nlevels, & |
---|
2983 | mrt_skip_roof, net_radiation, nrefsteps, & |
---|
2984 | plant_lw_interact, rad_angular_discretization,& |
---|
2985 | radiation_interactions_on, radiation_scheme, & |
---|
2986 | raytrace_discrete_azims, & |
---|
2987 | raytrace_discrete_elevs, raytrace_mpi_rma, & |
---|
2988 | skip_time_do_radiation, surface_reflections, & |
---|
2989 | svfnorm_report_thresh, sw_radiation, & |
---|
2990 | unscheduled_radiation_calls |
---|
2991 | |
---|
2992 | line = ' ' |
---|
2993 | |
---|
2994 | ! |
---|
2995 | !-- Try to find radiation model namelist |
---|
2996 | REWIND ( 11 ) |
---|
2997 | line = ' ' |
---|
2998 | DO WHILE ( INDEX( line, '&radiation_parameters' ) == 0 ) |
---|
2999 | READ ( 11, '(A)', END=12 ) line |
---|
3000 | ENDDO |
---|
3001 | BACKSPACE ( 11 ) |
---|
3002 | |
---|
3003 | ! |
---|
3004 | !-- Read user-defined namelist |
---|
3005 | READ ( 11, radiation_parameters, ERR = 10 ) |
---|
3006 | |
---|
3007 | ! |
---|
3008 | !-- Set flag that indicates that the radiation model is switched on |
---|
3009 | radiation = .TRUE. |
---|
3010 | |
---|
3011 | GOTO 14 |
---|
3012 | |
---|
3013 | 10 BACKSPACE( 11 ) |
---|
3014 | READ( 11 , '(A)') line |
---|
3015 | CALL parin_fail_message( 'radiation_parameters', line ) |
---|
3016 | ! |
---|
3017 | !-- Try to find old namelist |
---|
3018 | 12 REWIND ( 11 ) |
---|
3019 | line = ' ' |
---|
3020 | DO WHILE ( INDEX( line, '&radiation_par' ) == 0 ) |
---|
3021 | READ ( 11, '(A)', END=14 ) line |
---|
3022 | ENDDO |
---|
3023 | BACKSPACE ( 11 ) |
---|
3024 | |
---|
3025 | ! |
---|
3026 | !-- Read user-defined namelist |
---|
3027 | READ ( 11, radiation_par, ERR = 13, END = 14 ) |
---|
3028 | |
---|
3029 | message_string = 'namelist radiation_par is deprecated and will be ' // & |
---|
3030 | 'removed in near future. Please use namelist ' // & |
---|
3031 | 'radiation_parameters instead' |
---|
3032 | CALL message( 'radiation_parin', 'PA0487', 0, 1, 0, 6, 0 ) |
---|
3033 | |
---|
3034 | ! |
---|
3035 | !-- Set flag that indicates that the radiation model is switched on |
---|
3036 | radiation = .TRUE. |
---|
3037 | |
---|
3038 | IF ( .NOT. radiation_interactions_on .AND. surface_reflections ) THEN |
---|
3039 | message_string = 'surface_reflections is allowed only when ' // & |
---|
3040 | 'radiation_interactions_on is set to TRUE' |
---|
3041 | CALL message( 'radiation_parin', 'PA0293',1, 2, 0, 6, 0 ) |
---|
3042 | ENDIF |
---|
3043 | |
---|
3044 | GOTO 14 |
---|
3045 | |
---|
3046 | 13 BACKSPACE( 11 ) |
---|
3047 | READ( 11 , '(A)') line |
---|
3048 | CALL parin_fail_message( 'radiation_par', line ) |
---|
3049 | |
---|
3050 | 14 CONTINUE |
---|
3051 | |
---|
3052 | END SUBROUTINE radiation_parin |
---|
3053 | |
---|
3054 | |
---|
3055 | !------------------------------------------------------------------------------! |
---|
3056 | ! Description: |
---|
3057 | ! ------------ |
---|
3058 | !> Implementation of the RRTMG radiation_scheme |
---|
3059 | !------------------------------------------------------------------------------! |
---|
3060 | SUBROUTINE radiation_rrtmg |
---|
3061 | |
---|
3062 | #if defined ( __rrtmg ) |
---|
3063 | USE indices, & |
---|
3064 | ONLY: nbgp |
---|
3065 | |
---|
3066 | USE particle_attributes, & |
---|
3067 | ONLY: grid_particles, number_of_particles, particles, & |
---|
3068 | particle_advection_start, prt_count |
---|
3069 | |
---|
3070 | IMPLICIT NONE |
---|
3071 | |
---|
3072 | |
---|
3073 | INTEGER(iwp) :: i, j, k, l, m, n !< loop indices |
---|
3074 | INTEGER(iwp) :: k_topo !< topography top index |
---|
3075 | |
---|
3076 | REAL(wp) :: nc_rad, & !< number concentration of cloud droplets |
---|
3077 | s_r2, & !< weighted sum over all droplets with r^2 |
---|
3078 | s_r3 !< weighted sum over all droplets with r^3 |
---|
3079 | |
---|
3080 | REAL(wp), DIMENSION(0:nzt+1) :: pt_av, q_av, ql_av |
---|
3081 | ! |
---|
3082 | !-- Just dummy arguments |
---|
3083 | REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: rrtm_lw_taucld_dum, & |
---|
3084 | rrtm_lw_tauaer_dum, & |
---|
3085 | rrtm_sw_taucld_dum, & |
---|
3086 | rrtm_sw_ssacld_dum, & |
---|
3087 | rrtm_sw_asmcld_dum, & |
---|
3088 | rrtm_sw_fsfcld_dum, & |
---|
3089 | rrtm_sw_tauaer_dum, & |
---|
3090 | rrtm_sw_ssaaer_dum, & |
---|
3091 | rrtm_sw_asmaer_dum, & |
---|
3092 | rrtm_sw_ecaer_dum |
---|
3093 | |
---|
3094 | ! |
---|
3095 | !-- Calculate current (cosine of) zenith angle and whether the sun is up |
---|
3096 | CALL calc_zenith |
---|
3097 | ! |
---|
3098 | !-- Calculate surface albedo. In case average radiation is applied, |
---|
3099 | !-- this is not required. |
---|
3100 | #if defined( __netcdf ) |
---|
3101 | IF ( .NOT. constant_albedo ) THEN |
---|
3102 | ! |
---|
3103 | !-- Horizontally aligned default, natural and urban surfaces |
---|
3104 | CALL calc_albedo( surf_lsm_h ) |
---|
3105 | CALL calc_albedo( surf_usm_h ) |
---|
3106 | ! |
---|
3107 | !-- Vertically aligned default, natural and urban surfaces |
---|
3108 | DO l = 0, 3 |
---|
3109 | CALL calc_albedo( surf_lsm_v(l) ) |
---|
3110 | CALL calc_albedo( surf_usm_v(l) ) |
---|
3111 | ENDDO |
---|
3112 | ENDIF |
---|
3113 | #endif |
---|
3114 | |
---|
3115 | ! |
---|
3116 | !-- Prepare input data for RRTMG |
---|
3117 | |
---|
3118 | ! |
---|
3119 | !-- In case of large scale forcing with surface data, calculate new pressure |
---|
3120 | !-- profile. nzt_rad might be modified by these calls and all required arrays |
---|
3121 | !-- will then be re-allocated |
---|
3122 | IF ( large_scale_forcing .AND. lsf_surf ) THEN |
---|
3123 | CALL read_sounding_data |
---|
3124 | CALL read_trace_gas_data |
---|
3125 | ENDIF |
---|
3126 | |
---|
3127 | |
---|
3128 | IF ( average_radiation ) THEN |
---|
3129 | |
---|
3130 | rrtm_asdir(1) = albedo_urb |
---|
3131 | rrtm_asdif(1) = albedo_urb |
---|
3132 | rrtm_aldir(1) = albedo_urb |
---|
3133 | rrtm_aldif(1) = albedo_urb |
---|
3134 | |
---|
3135 | rrtm_emis = emissivity_urb |
---|
3136 | ! |
---|
3137 | !-- Calculate mean pt profile. Actually, only one height level is required. |
---|
3138 | CALL calc_mean_profile( pt, 4 ) |
---|
3139 | pt_av = hom(:, 1, 4, 0) |
---|
3140 | |
---|
3141 | IF ( humidity ) THEN |
---|
3142 | CALL calc_mean_profile( q, 41 ) |
---|
3143 | q_av = hom(:, 1, 41, 0) |
---|
3144 | ENDIF |
---|
3145 | ! |
---|
3146 | !-- Prepare profiles of temperature and H2O volume mixing ratio |
---|
3147 | rrtm_tlev(0,nzb+1) = t_rad_urb |
---|
3148 | |
---|
3149 | IF ( bulk_cloud_model ) THEN |
---|
3150 | |
---|
3151 | CALL calc_mean_profile( ql, 54 ) |
---|
3152 | ! average ql is now in hom(:, 1, 54, 0) |
---|
3153 | ql_av = hom(:, 1, 54, 0) |
---|
3154 | |
---|
3155 | DO k = nzb+1, nzt+1 |
---|
3156 | rrtm_tlay(0,k) = pt_av(k) * ( (hyp(k) ) / 100000._wp & |
---|
3157 | )**.286_wp + lv_d_cp * ql_av(k) |
---|
3158 | rrtm_h2ovmr(0,k) = mol_mass_air_d_wv * (q_av(k) - ql_av(k)) |
---|
3159 | ENDDO |
---|
3160 | ELSE |
---|
3161 | DO k = nzb+1, nzt+1 |
---|
3162 | rrtm_tlay(0,k) = pt_av(k) * ( (hyp(k) ) / 100000._wp & |
---|
3163 | )**.286_wp |
---|
3164 | ENDDO |
---|
3165 | |
---|
3166 | IF ( humidity ) THEN |
---|
3167 | DO k = nzb+1, nzt+1 |
---|
3168 | rrtm_h2ovmr(0,k) = mol_mass_air_d_wv * q_av(k) |
---|
3169 | ENDDO |
---|
3170 | ELSE |
---|
3171 | rrtm_h2ovmr(0,nzb+1:nzt+1) = 0.0_wp |
---|
3172 | ENDIF |
---|
3173 | ENDIF |
---|
3174 | |
---|
3175 | ! |
---|
3176 | !-- Avoid temperature/humidity jumps at the top of the LES domain by |
---|
3177 | !-- linear interpolation from nzt+2 to nzt+7 |
---|
3178 | DO k = nzt+2, nzt+7 |
---|
3179 | rrtm_tlay(0,k) = rrtm_tlay(0,nzt+1) & |
---|
3180 | + ( rrtm_tlay(0,nzt+8) - rrtm_tlay(0,nzt+1) ) & |
---|
3181 | / ( rrtm_play(0,nzt+8) - rrtm_play(0,nzt+1) ) & |
---|
3182 | * ( rrtm_play(0,k) - rrtm_play(0,nzt+1) ) |
---|
3183 | |
---|
3184 | rrtm_h2ovmr(0,k) = rrtm_h2ovmr(0,nzt+1) & |
---|
3185 | + ( rrtm_h2ovmr(0,nzt+8) - rrtm_h2ovmr(0,nzt+1) )& |
---|
3186 | / ( rrtm_play(0,nzt+8) - rrtm_play(0,nzt+1) )& |
---|
3187 | * ( rrtm_play(0,k) - rrtm_play(0,nzt+1) ) |
---|
3188 | |
---|
3189 | ENDDO |
---|
3190 | |
---|
3191 | !-- Linear interpolate to zw grid |
---|
3192 | DO k = nzb+2, nzt+8 |
---|
3193 | rrtm_tlev(0,k) = rrtm_tlay(0,k-1) + (rrtm_tlay(0,k) - & |
---|
3194 | rrtm_tlay(0,k-1)) & |
---|
3195 | / ( rrtm_play(0,k) - rrtm_play(0,k-1) ) & |
---|
3196 | * ( rrtm_plev(0,k) - rrtm_play(0,k-1) ) |
---|
3197 | ENDDO |
---|
3198 | |
---|
3199 | |
---|
3200 | ! |
---|
3201 | !-- Calculate liquid water path and cloud fraction for each column. |
---|
3202 | !-- Note that LWP is required in g/m² instead of kg/kg m. |
---|
3203 | rrtm_cldfr = 0.0_wp |
---|
3204 | rrtm_reliq = 0.0_wp |
---|
3205 | rrtm_cliqwp = 0.0_wp |
---|
3206 | rrtm_icld = 0 |
---|
3207 | |
---|
3208 | IF ( bulk_cloud_model ) THEN |
---|
3209 | DO k = nzb+1, nzt+1 |
---|
3210 | rrtm_cliqwp(0,k) = ql_av(k) * 1000._wp * & |
---|
3211 | (rrtm_plev(0,k) - rrtm_plev(0,k+1)) & |
---|
3212 | * 100._wp / g |
---|
3213 | |
---|
3214 | IF ( rrtm_cliqwp(0,k) > 0._wp ) THEN |
---|
3215 | rrtm_cldfr(0,k) = 1._wp |
---|
3216 | IF ( rrtm_icld == 0 ) rrtm_icld = 1 |
---|
3217 | |
---|
3218 | ! |
---|
3219 | !-- Calculate cloud droplet effective radius |
---|
3220 | rrtm_reliq(0,k) = 1.0E6_wp * ( 3.0_wp * ql_av(k) & |
---|
3221 | * rho_surface & |
---|
3222 | / ( 4.0_wp * pi * nc_const * rho_l ) & |
---|
3223 | )**0.33333333333333_wp & |
---|
3224 | * EXP( LOG( sigma_gc )**2 ) |
---|
3225 | ! |
---|
3226 | !-- Limit effective radius |
---|
3227 | IF ( rrtm_reliq(0,k) > 0.0_wp ) THEN |
---|
3228 | rrtm_reliq(0,k) = MAX(rrtm_reliq(0,k),2.5_wp) |
---|
3229 | rrtm_reliq(0,k) = MIN(rrtm_reliq(0,k),60.0_wp) |
---|
3230 | ENDIF |
---|
3231 | ENDIF |
---|
3232 | ENDDO |
---|
3233 | ENDIF |
---|
3234 | |
---|
3235 | ! |
---|
3236 | !-- Set surface temperature |
---|
3237 | rrtm_tsfc = t_rad_urb |
---|
3238 | |
---|
3239 | IF ( lw_radiation ) THEN |
---|
3240 | |
---|
3241 | CALL rrtmg_lw( 1, nzt_rad , rrtm_icld , rrtm_idrv ,& |
---|
3242 | rrtm_play , rrtm_plev , rrtm_tlay , rrtm_tlev ,& |
---|
3243 | rrtm_tsfc , rrtm_h2ovmr , rrtm_o3vmr , rrtm_co2vmr ,& |
---|
3244 | rrtm_ch4vmr , rrtm_n2ovmr , rrtm_o2vmr , rrtm_cfc11vmr ,& |
---|
3245 | rrtm_cfc12vmr , rrtm_cfc22vmr, rrtm_ccl4vmr , rrtm_emis ,& |
---|
3246 | rrtm_inflglw , rrtm_iceflglw, rrtm_liqflglw, rrtm_cldfr ,& |
---|
3247 | rrtm_lw_taucld , rrtm_cicewp , rrtm_cliqwp , rrtm_reice ,& |
---|
3248 | rrtm_reliq , rrtm_lw_tauaer, & |
---|
3249 | rrtm_lwuflx , rrtm_lwdflx , rrtm_lwhr , & |
---|
3250 | rrtm_lwuflxc , rrtm_lwdflxc , rrtm_lwhrc , & |
---|
3251 | rrtm_lwuflx_dt , rrtm_lwuflxc_dt ) |
---|
3252 | |
---|
3253 | ! |
---|
3254 | !-- Save fluxes |
---|
3255 | DO k = nzb, nzt+1 |
---|
3256 | rad_lw_in(k,:,:) = rrtm_lwdflx(0,k) |
---|
3257 | rad_lw_out(k,:,:) = rrtm_lwuflx(0,k) |
---|
3258 | ENDDO |
---|
3259 | rad_lw_in_diff(:,:) = rad_lw_in(0,:,:) |
---|
3260 | ! |
---|
3261 | !-- Save heating rates (convert from K/d to K/h). |
---|
3262 | !-- Further, even though an aggregated radiation is computed, map |
---|
3263 | !-- signle-column profiles on top of any topography, in order to |
---|
3264 | !-- obtain correct near surface radiation heating/cooling rates. |
---|
3265 | DO i = nxl, nxr |
---|
3266 | DO j = nys, nyn |
---|
3267 | k_topo = get_topography_top_index_ji( j, i, 's' ) |
---|
3268 | DO k = k_topo+1, nzt+1 |
---|
3269 | rad_lw_hr(k,j,i) = rrtm_lwhr(0,k-k_topo) * d_hours_day |
---|
3270 | rad_lw_cs_hr(k,j,i) = rrtm_lwhrc(0,k-k_topo) * d_hours_day |
---|
3271 | ENDDO |
---|
3272 | ENDDO |
---|
3273 | ENDDO |
---|
3274 | |
---|
3275 | ENDIF |
---|
3276 | |
---|
3277 | IF ( sw_radiation .AND. sun_up ) THEN |
---|
3278 | CALL rrtmg_sw( 1, nzt_rad , rrtm_icld , rrtm_iaer ,& |
---|
3279 | rrtm_play , rrtm_plev , rrtm_tlay , rrtm_tlev ,& |
---|
3280 | rrtm_tsfc , rrtm_h2ovmr , rrtm_o3vmr , rrtm_co2vmr ,& |
---|
3281 | rrtm_ch4vmr , rrtm_n2ovmr , rrtm_o2vmr , rrtm_asdir ,& |
---|
3282 | rrtm_asdif , rrtm_aldir , rrtm_aldif , zenith ,& |
---|
3283 | 0.0_wp , day_of_year , solar_constant, rrtm_inflgsw ,& |
---|
3284 | rrtm_iceflgsw , rrtm_liqflgsw , rrtm_cldfr , rrtm_sw_taucld ,& |
---|
3285 | rrtm_sw_ssacld , rrtm_sw_asmcld, rrtm_sw_fsfcld, rrtm_cicewp ,& |
---|
3286 | rrtm_cliqwp , rrtm_reice , rrtm_reliq , rrtm_sw_tauaer ,& |
---|
3287 | rrtm_sw_ssaaer , rrtm_sw_asmaer, rrtm_sw_ecaer , rrtm_swuflx ,& |
---|
3288 | rrtm_swdflx , rrtm_swhr , rrtm_swuflxc , rrtm_swdflxc ,& |
---|
3289 | rrtm_swhrc , rrtm_dirdflux , rrtm_difdflux ) |
---|
3290 | |
---|
3291 | ! |
---|
3292 | !-- Save fluxes: |
---|
3293 | !-- - whole domain |
---|
3294 | DO k = nzb, nzt+1 |
---|
3295 | rad_sw_in(k,:,:) = rrtm_swdflx(0,k) |
---|
3296 | rad_sw_out(k,:,:) = rrtm_swuflx(0,k) |
---|
3297 | ENDDO |
---|
3298 | !-- - direct and diffuse SW at urban-surface-layer (required by RTM) |
---|
3299 | rad_sw_in_dir(:,:) = rrtm_dirdflux(0,nzb) |
---|
3300 | rad_sw_in_diff(:,:) = rrtm_difdflux(0,nzb) |
---|
3301 | |
---|
3302 | ! |
---|
3303 | !-- Save heating rates (convert from K/d to K/s) |
---|
3304 | DO k = nzb+1, nzt+1 |
---|
3305 | rad_sw_hr(k,:,:) = rrtm_swhr(0,k) * d_hours_day |
---|
3306 | rad_sw_cs_hr(k,:,:) = rrtm_swhrc(0,k) * d_hours_day |
---|
3307 | ENDDO |
---|
3308 | ! |
---|
3309 | !-- Solar radiation is zero during night |
---|
3310 | ELSE |
---|
3311 | rad_sw_in = 0.0_wp |
---|
3312 | rad_sw_out = 0.0_wp |
---|
3313 | rad_sw_in_dir(:,:) = 0.0_wp |
---|
3314 | rad_sw_in_diff(:,:) = 0.0_wp |
---|
3315 | ENDIF |
---|
3316 | ! |
---|
3317 | !-- RRTMG is called for each (j,i) grid point separately, starting at the |
---|
3318 | !-- highest topography level. Here no RTM is used since average_radiation is false |
---|
3319 | ELSE |
---|
3320 | ! |
---|
3321 | !-- Loop over all grid points |
---|
3322 | DO i = nxl, nxr |
---|
3323 | DO j = nys, nyn |
---|
3324 | |
---|
3325 | ! |
---|
3326 | !-- Prepare profiles of temperature and H2O volume mixing ratio |
---|
3327 | DO m = surf_lsm_h%start_index(j,i), surf_lsm_h%end_index(j,i) |
---|
3328 | rrtm_tlev(0,nzb+1) = surf_lsm_h%pt_surface(m) * exner(nzb) |
---|
3329 | ENDDO |
---|
3330 | DO m = surf_usm_h%start_index(j,i), surf_usm_h%end_index(j,i) |
---|
3331 | rrtm_tlev(0,nzb+1) = surf_usm_h%pt_surface(m) * exner(nzb) |
---|
3332 | ENDDO |
---|
3333 | |
---|
3334 | |
---|
3335 | IF ( bulk_cloud_model ) THEN |
---|
3336 | DO k = nzb+1, nzt+1 |
---|
3337 | rrtm_tlay(0,k) = pt(k,j,i) * exner(k) & |
---|
3338 | + lv_d_cp * ql(k,j,i) |
---|
3339 | rrtm_h2ovmr(0,k) = mol_mass_air_d_wv * (q(k,j,i) - ql(k,j,i)) |
---|
3340 | ENDDO |
---|
3341 | ELSEIF ( cloud_droplets ) THEN |
---|
3342 | DO k = nzb+1, nzt+1 |
---|
3343 | rrtm_tlay(0,k) = pt(k,j,i) * exner(k) & |
---|
3344 | + lv_d_cp * ql(k,j,i) |
---|
3345 | rrtm_h2ovmr(0,k) = mol_mass_air_d_wv * q(k,j,i) |
---|
3346 | ENDDO |
---|
3347 | ELSE |
---|
3348 | DO k = nzb+1, nzt+1 |
---|
3349 | rrtm_tlay(0,k) = pt(k,j,i) * exner(k) |
---|
3350 | ENDDO |
---|
3351 | |
---|
3352 | IF ( humidity ) THEN |
---|
3353 | DO k = nzb+1, nzt+1 |
---|
3354 | rrtm_h2ovmr(0,k) = mol_mass_air_d_wv * q(k,j,i) |
---|
3355 | ENDDO |
---|
3356 | ELSE |
---|
3357 | rrtm_h2ovmr(0,nzb+1:nzt+1) = 0.0_wp |
---|
3358 | ENDIF |
---|
3359 | ENDIF |
---|
3360 | |
---|
3361 | ! |
---|
3362 | !-- Avoid temperature/humidity jumps at the top of the LES domain by |
---|
3363 | !-- linear interpolation from nzt+2 to nzt+7 |
---|
3364 | DO k = nzt+2, nzt+7 |
---|
3365 | rrtm_tlay(0,k) = rrtm_tlay(0,nzt+1) & |
---|
3366 | + ( rrtm_tlay(0,nzt+8) - rrtm_tlay(0,nzt+1) ) & |
---|
3367 | / ( rrtm_play(0,nzt+8) - rrtm_play(0,nzt+1) ) & |
---|
3368 | * ( rrtm_play(0,k) - rrtm_play(0,nzt+1) ) |
---|
3369 | |
---|
3370 | rrtm_h2ovmr(0,k) = rrtm_h2ovmr(0,nzt+1) & |
---|
3371 | + ( rrtm_h2ovmr(0,nzt+8) - rrtm_h2ovmr(0,nzt+1) )& |
---|
3372 | / ( rrtm_play(0,nzt+8) - rrtm_play(0,nzt+1) )& |
---|
3373 | * ( rrtm_play(0,k) - rrtm_play(0,nzt+1) ) |
---|
3374 | |
---|
3375 | ENDDO |
---|
3376 | |
---|
3377 | !-- Linear interpolate to zw grid |
---|
3378 | DO k = nzb+2, nzt+8 |
---|
3379 | rrtm_tlev(0,k) = rrtm_tlay(0,k-1) + (rrtm_tlay(0,k) - & |
---|
3380 | rrtm_tlay(0,k-1)) & |
---|
3381 | / ( rrtm_play(0,k) - rrtm_play(0,k-1) ) & |
---|
3382 | * ( rrtm_plev(0,k) - rrtm_play(0,k-1) ) |
---|
3383 | ENDDO |
---|
3384 | |
---|
3385 | |
---|
3386 | ! |
---|
3387 | !-- Calculate liquid water path and cloud fraction for each column. |
---|
3388 | !-- Note that LWP is required in g/m² instead of kg/kg m. |
---|
3389 | rrtm_cldfr = 0.0_wp |
---|
3390 | rrtm_reliq = 0.0_wp |
---|
3391 | rrtm_cliqwp = 0.0_wp |
---|
3392 | rrtm_icld = 0 |
---|
3393 | |
---|
3394 | IF ( bulk_cloud_model .OR. cloud_droplets ) THEN |
---|
3395 | DO k = nzb+1, nzt+1 |
---|
3396 | rrtm_cliqwp(0,k) = ql(k,j,i) * 1000.0_wp * & |
---|
3397 | (rrtm_plev(0,k) - rrtm_plev(0,k+1)) & |
---|
3398 | * 100.0_wp / g |
---|
3399 | |
---|
3400 | IF ( rrtm_cliqwp(0,k) > 0.0_wp ) THEN |
---|
3401 | rrtm_cldfr(0,k) = 1.0_wp |
---|
3402 | IF ( rrtm_icld == 0 ) rrtm_icld = 1 |
---|
3403 | |
---|
3404 | ! |
---|
3405 | !-- Calculate cloud droplet effective radius |
---|
3406 | IF ( bulk_cloud_model ) THEN |
---|
3407 | ! |
---|
3408 | !-- Calculete effective droplet radius. In case of using |
---|
3409 | !-- cloud_scheme = 'morrison' and a non reasonable number |
---|
3410 | !-- of cloud droplets the inital aerosol number |
---|
3411 | !-- concentration is considered. |
---|
3412 | IF ( microphysics_morrison ) THEN |
---|
3413 | IF ( nc(k,j,i) > 1.0E-20_wp ) THEN |
---|
3414 | nc_rad = nc(k,j,i) |
---|
3415 | ELSE |
---|
3416 | nc_rad = na_init |
---|
3417 | ENDIF |
---|
3418 | ELSE |
---|
3419 | nc_rad = nc_const |
---|
3420 | ENDIF |
---|
3421 | |
---|
3422 | rrtm_reliq(0,k) = 1.0E6_wp * ( 3.0_wp * ql(k,j,i) & |
---|
3423 | * rho_surface & |
---|
3424 | / ( 4.0_wp * pi * nc_rad * rho_l ) & |
---|
3425 | )**0.33333333333333_wp & |
---|
3426 | * EXP( LOG( sigma_gc )**2 ) |
---|
3427 | |
---|
3428 | ELSEIF ( cloud_droplets ) THEN |
---|
3429 | number_of_particles = prt_count(k,j,i) |
---|
3430 | |
---|
3431 | IF (number_of_particles <= 0) CYCLE |
---|
3432 | particles => grid_particles(k,j,i)%particles(1:number_of_particles) |
---|
3433 | s_r2 = 0.0_wp |
---|
3434 | s_r3 = 0.0_wp |
---|
3435 | |
---|
3436 | DO n = 1, number_of_particles |
---|
3437 | IF ( particles(n)%particle_mask ) THEN |
---|
3438 | s_r2 = s_r2 + particles(n)%radius**2 * & |
---|
3439 | particles(n)%weight_factor |
---|
3440 | s_r3 = s_r3 + particles(n)%radius**3 * & |
---|
3441 | particles(n)%weight_factor |
---|
3442 | ENDIF |
---|
3443 | ENDDO |
---|
3444 | |
---|
3445 | IF ( s_r2 > 0.0_wp ) rrtm_reliq(0,k) = s_r3 / s_r2 |
---|
3446 | |
---|
3447 | ENDIF |
---|
3448 | |
---|
3449 | ! |
---|
3450 | !-- Limit effective radius |
---|
3451 | IF ( rrtm_reliq(0,k) > 0.0_wp ) THEN |
---|
3452 | rrtm_reliq(0,k) = MAX(rrtm_reliq(0,k),2.5_wp) |
---|
3453 | rrtm_reliq(0,k) = MIN(rrtm_reliq(0,k),60.0_wp) |
---|
3454 | ENDIF |
---|
3455 | ENDIF |
---|
3456 | ENDDO |
---|
3457 | ENDIF |
---|
3458 | |
---|
3459 | ! |
---|
3460 | !-- Write surface emissivity and surface temperature at current |
---|
3461 | !-- surface element on RRTMG-shaped array. |
---|
3462 | !-- Please note, as RRTMG is a single column model, surface attributes |
---|
3463 | !-- are only obtained from horizontally aligned surfaces (for |
---|
3464 | !-- simplicity). Taking surface attributes from horizontal and |
---|
3465 | !-- vertical walls would lead to multiple solutions. |
---|
3466 | !-- Moreover, for natural- and urban-type surfaces, several surface |
---|
3467 | !-- classes can exist at a surface element next to each other. |
---|
3468 | !-- To obtain bulk parameters, apply a weighted average for these |
---|
3469 | !-- surfaces. |
---|
3470 | DO m = surf_lsm_h%start_index(j,i), surf_lsm_h%end_index(j,i) |
---|
3471 | rrtm_emis = surf_lsm_h%frac(ind_veg_wall,m) * & |
---|
3472 | surf_lsm_h%emissivity(ind_veg_wall,m) + & |
---|
3473 | surf_lsm_h%frac(ind_pav_green,m) * & |
---|
3474 | surf_lsm_h%emissivity(ind_pav_green,m) + & |
---|
3475 | surf_lsm_h%frac(ind_wat_win,m) * & |
---|
3476 | surf_lsm_h%emissivity(ind_wat_win,m) |
---|
3477 | rrtm_tsfc = surf_lsm_h%pt_surface(m) * exner(nzb) |
---|
3478 | ENDDO |
---|
3479 | DO m = surf_usm_h%start_index(j,i), surf_usm_h%end_index(j,i) |
---|
3480 | rrtm_emis = surf_usm_h%frac(ind_veg_wall,m) * & |
---|
3481 | surf_usm_h%emissivity(ind_veg_wall,m) + & |
---|
3482 | surf_usm_h%frac(ind_pav_green,m) * & |
---|
3483 | surf_usm_h%emissivity(ind_pav_green,m) + & |
---|
3484 | surf_usm_h%frac(ind_wat_win,m) * & |
---|
3485 | surf_usm_h%emissivity(ind_wat_win,m) |
---|
3486 | rrtm_tsfc = surf_usm_h%pt_surface(m) * exner(nzb) |
---|
3487 | ENDDO |
---|
3488 | ! |
---|
3489 | !-- Obtain topography top index (lower bound of RRTMG) |
---|
3490 | k_topo = get_topography_top_index_ji( j, i, 's' ) |
---|
3491 | |
---|
3492 | IF ( lw_radiation ) THEN |
---|
3493 | ! |
---|
3494 | !-- Due to technical reasons, copy optical depth to dummy arguments |
---|
3495 | !-- which are allocated on the exact size as the rrtmg_lw is called. |
---|
3496 | !-- As one dimesion is allocated with zero size, compiler complains |
---|
3497 | !-- that rank of the array does not match that of the |
---|
3498 | !-- assumed-shaped arguments in the RRTMG library. In order to |
---|
3499 | !-- avoid this, write to dummy arguments and give pass the entire |
---|
3500 | !-- dummy array. Seems to be the only existing work-around. |
---|
3501 | ALLOCATE( rrtm_lw_taucld_dum(1:nbndlw+1,0:0,k_topo+1:nzt_rad+1) ) |
---|
3502 | ALLOCATE( rrtm_lw_tauaer_dum(0:0,k_topo+1:nzt_rad+1,1:nbndlw+1) ) |
---|
3503 | |
---|
3504 | rrtm_lw_taucld_dum = & |
---|
3505 | rrtm_lw_taucld(1:nbndlw+1,0:0,k_topo+1:nzt_rad+1) |
---|
3506 | rrtm_lw_tauaer_dum = & |
---|
3507 | rrtm_lw_tauaer(0:0,k_topo+1:nzt_rad+1,1:nbndlw+1) |
---|
3508 | |
---|
3509 | CALL rrtmg_lw( 1, & |
---|
3510 | nzt_rad-k_topo, & |
---|
3511 | rrtm_icld, & |
---|
3512 | rrtm_idrv, & |
---|
3513 | rrtm_play(:,k_topo+1:nzt_rad+1), & |
---|
3514 | rrtm_plev(:,k_topo+1:nzt_rad+2), & |
---|
3515 | rrtm_tlay(:,k_topo+1:nzt_rad+1), & |
---|
3516 | rrtm_tlev(:,k_topo+1:nzt_rad+2), & |
---|
3517 | rrtm_tsfc, & |
---|
3518 | rrtm_h2ovmr(:,k_topo+1:nzt_rad+1), & |
---|
3519 | rrtm_o3vmr(:,k_topo+1:nzt_rad+1), & |
---|
3520 | rrtm_co2vmr(:,k_topo+1:nzt_rad+1), & |
---|
3521 | rrtm_ch4vmr(:,k_topo+1:nzt_rad+1), & |
---|
3522 | rrtm_n2ovmr(:,k_topo+1:nzt_rad+1), & |
---|
3523 | rrtm_o2vmr(:,k_topo+1:nzt_rad+1), & |
---|
3524 | rrtm_cfc11vmr(:,k_topo+1:nzt_rad+1), & |
---|
3525 | rrtm_cfc12vmr(:,k_topo+1:nzt_rad+1), & |
---|
3526 | rrtm_cfc22vmr(:,k_topo+1:nzt_rad+1), & |
---|
3527 | rrtm_ccl4vmr(:,k_topo+1:nzt_rad+1), & |
---|
3528 | rrtm_emis, & |
---|
3529 | rrtm_inflglw, & |
---|
3530 | rrtm_iceflglw, & |
---|
3531 | rrtm_liqflglw, & |
---|
3532 | rrtm_cldfr(:,k_topo+1:nzt_rad+1), & |
---|
3533 | rrtm_lw_taucld_dum, & |
---|
3534 | rrtm_cicewp(:,k_topo+1:nzt_rad+1), & |
---|
3535 | rrtm_cliqwp(:,k_topo+1:nzt_rad+1), & |
---|
3536 | rrtm_reice(:,k_topo+1:nzt_rad+1), & |
---|
3537 | rrtm_reliq(:,k_topo+1:nzt_rad+1), & |
---|
3538 | rrtm_lw_tauaer_dum, & |
---|
3539 | rrtm_lwuflx(:,k_topo:nzt_rad+1), & |
---|
3540 | rrtm_lwdflx(:,k_topo:nzt_rad+1), & |
---|
3541 | rrtm_lwhr(:,k_topo+1:nzt_rad+1), & |
---|
3542 | rrtm_lwuflxc(:,k_topo:nzt_rad+1), & |
---|
3543 | rrtm_lwdflxc(:,k_topo:nzt_rad+1), & |
---|
3544 | rrtm_lwhrc(:,k_topo+1:nzt_rad+1), & |
---|
3545 | rrtm_lwuflx_dt(:,k_topo:nzt_rad+1), & |
---|
3546 | rrtm_lwuflxc_dt(:,k_topo:nzt_rad+1) ) |
---|
3547 | |
---|
3548 | DEALLOCATE ( rrtm_lw_taucld_dum ) |
---|
3549 | DEALLOCATE ( rrtm_lw_tauaer_dum ) |
---|
3550 | ! |
---|
3551 | !-- Save fluxes |
---|
3552 | DO k = k_topo, nzt+1 |
---|
3553 | rad_lw_in(k,j,i) = rrtm_lwdflx(0,k) |
---|
3554 | rad_lw_out(k,j,i) = rrtm_lwuflx(0,k) |
---|
3555 | ENDDO |
---|
3556 | |
---|
3557 | ! |
---|
3558 | !-- Save heating rates (convert from K/d to K/h) |
---|
3559 | DO k = k_topo+1, nzt+1 |
---|
3560 | rad_lw_hr(k,j,i) = rrtm_lwhr(0,k-k_topo) * d_hours_day |
---|
3561 | rad_lw_cs_hr(k,j,i) = rrtm_lwhrc(0,k-k_topo) * d_hours_day |
---|
3562 | ENDDO |
---|
3563 | |
---|
3564 | ! |
---|
3565 | !-- Save surface radiative fluxes and change in LW heating rate |
---|
3566 | !-- onto respective surface elements |
---|
3567 | !-- Horizontal surfaces |
---|
3568 | DO m = surf_lsm_h%start_index(j,i), & |
---|
3569 | surf_lsm_h%end_index(j,i) |
---|
3570 | surf_lsm_h%rad_lw_in(m) = rrtm_lwdflx(0,k_topo) |
---|
3571 | surf_lsm_h%rad_lw_out(m) = rrtm_lwuflx(0,k_topo) |
---|
3572 | surf_lsm_h%rad_lw_out_change_0(m) = rrtm_lwuflx_dt(0,k_topo) |
---|
3573 | ENDDO |
---|
3574 | DO m = surf_usm_h%start_index(j,i), & |
---|
3575 | surf_usm_h%end_index(j,i) |
---|
3576 | surf_usm_h%rad_lw_in(m) = rrtm_lwdflx(0,k_topo) |
---|
3577 | surf_usm_h%rad_lw_out(m) = rrtm_lwuflx(0,k_topo) |
---|
3578 | surf_usm_h%rad_lw_out_change_0(m) = rrtm_lwuflx_dt(0,k_topo) |
---|
3579 | ENDDO |
---|
3580 | ! |
---|
3581 | !-- Vertical surfaces. Fluxes are obtain at vertical level of the |
---|
3582 | !-- respective surface element |
---|
3583 | DO l = 0, 3 |
---|
3584 | DO m = surf_lsm_v(l)%start_index(j,i), & |
---|
3585 | surf_lsm_v(l)%end_index(j,i) |
---|
3586 | k = surf_lsm_v(l)%k(m) |
---|
3587 | surf_lsm_v(l)%rad_lw_in(m) = rrtm_lwdflx(0,k) |
---|
3588 | surf_lsm_v(l)%rad_lw_out(m) = rrtm_lwuflx(0,k) |
---|
3589 | surf_lsm_v(l)%rad_lw_out_change_0(m) = rrtm_lwuflx_dt(0,k) |
---|
3590 | ENDDO |
---|
3591 | DO m = surf_usm_v(l)%start_index(j,i), & |
---|
3592 | surf_usm_v(l)%end_index(j,i) |
---|
3593 | k = surf_usm_v(l)%k(m) |
---|
3594 | surf_usm_v(l)%rad_lw_in(m) = rrtm_lwdflx(0,k) |
---|
3595 | surf_usm_v(l)%rad_lw_out(m) = rrtm_lwuflx(0,k) |
---|
3596 | surf_usm_v(l)%rad_lw_out_change_0(m) = rrtm_lwuflx_dt(0,k) |
---|
3597 | ENDDO |
---|
3598 | ENDDO |
---|
3599 | |
---|
3600 | ENDIF |
---|
3601 | |
---|
3602 | IF ( sw_radiation .AND. sun_up ) THEN |
---|
3603 | ! |
---|
3604 | !-- Get albedo for direct/diffusive long/shortwave radiation at |
---|
3605 | !-- current (y,x)-location from surface variables. |
---|
3606 | !-- Only obtain it from horizontal surfaces, as RRTMG is a single |
---|
3607 | !-- column model |
---|
3608 | !-- (Please note, only one loop will entered, controlled by |
---|
3609 | !-- start-end index.) |
---|
3610 | DO m = surf_lsm_h%start_index(j,i), & |
---|
3611 | surf_lsm_h%end_index(j,i) |
---|
3612 | rrtm_asdir(1) = SUM( surf_lsm_h%frac(:,m) * & |
---|
3613 | surf_lsm_h%rrtm_asdir(:,m) ) |
---|
3614 | rrtm_asdif(1) = SUM( surf_lsm_h%frac(:,m) * & |
---|
3615 | surf_lsm_h%rrtm_asdif(:,m) ) |
---|
3616 | rrtm_aldir(1) = SUM( surf_lsm_h%frac(:,m) * & |
---|
3617 | surf_lsm_h%rrtm_aldir(:,m) ) |
---|
3618 | rrtm_aldif(1) = SUM( surf_lsm_h%frac(:,m) * & |
---|
3619 | surf_lsm_h%rrtm_aldif(:,m) ) |
---|
3620 | ENDDO |
---|
3621 | DO m = surf_usm_h%start_index(j,i), & |
---|
3622 | surf_usm_h%end_index(j,i) |
---|
3623 | rrtm_asdir(1) = SUM( surf_usm_h%frac(:,m) * & |
---|
3624 | surf_usm_h%rrtm_asdir(:,m) ) |
---|
3625 | rrtm_asdif(1) = SUM( surf_usm_h%frac(:,m) * & |
---|
3626 | surf_usm_h%rrtm_asdif(:,m) ) |
---|
3627 | rrtm_aldir(1) = SUM( surf_usm_h%frac(:,m) * & |
---|
3628 | surf_usm_h%rrtm_aldir(:,m) ) |
---|
3629 | rrtm_aldif(1) = SUM( surf_usm_h%frac(:,m) * & |
---|
3630 | surf_usm_h%rrtm_aldif(:,m) ) |
---|
3631 | ENDDO |
---|
3632 | ! |
---|
3633 | !-- Due to technical reasons, copy optical depths and other |
---|
3634 | !-- to dummy arguments which are allocated on the exact size as the |
---|
3635 | !-- rrtmg_sw is called. |
---|
3636 | !-- As one dimesion is allocated with zero size, compiler complains |
---|
3637 | !-- that rank of the array does not match that of the |
---|
3638 | !-- assumed-shaped arguments in the RRTMG library. In order to |
---|
3639 | !-- avoid this, write to dummy arguments and give pass the entire |
---|
3640 | !-- dummy array. Seems to be the only existing work-around. |
---|
3641 | ALLOCATE( rrtm_sw_taucld_dum(1:nbndsw+1,0:0,k_topo+1:nzt_rad+1) ) |
---|
3642 | ALLOCATE( rrtm_sw_ssacld_dum(1:nbndsw+1,0:0,k_topo+1:nzt_rad+1) ) |
---|
3643 | ALLOCATE( rrtm_sw_asmcld_dum(1:nbndsw+1,0:0,k_topo+1:nzt_rad+1) ) |
---|
3644 | ALLOCATE( rrtm_sw_fsfcld_dum(1:nbndsw+1,0:0,k_topo+1:nzt_rad+1) ) |
---|
3645 | ALLOCATE( rrtm_sw_tauaer_dum(0:0,k_topo+1:nzt_rad+1,1:nbndsw+1) ) |
---|
3646 | ALLOCATE( rrtm_sw_ssaaer_dum(0:0,k_topo+1:nzt_rad+1,1:nbndsw+1) ) |
---|
3647 | ALLOCATE( rrtm_sw_asmaer_dum(0:0,k_topo+1:nzt_rad+1,1:nbndsw+1) ) |
---|
3648 | ALLOCATE( rrtm_sw_ecaer_dum(0:0,k_topo+1:nzt_rad+1,1:naerec+1) ) |
---|
3649 | |
---|
3650 | rrtm_sw_taucld_dum = rrtm_sw_taucld(1:nbndsw+1,0:0,k_topo+1:nzt_rad+1) |
---|
3651 | rrtm_sw_ssacld_dum = rrtm_sw_ssacld(1:nbndsw+1,0:0,k_topo+1:nzt_rad+1) |
---|
3652 | rrtm_sw_asmcld_dum = rrtm_sw_asmcld(1:nbndsw+1,0:0,k_topo+1:nzt_rad+1) |
---|
3653 | rrtm_sw_fsfcld_dum = rrtm_sw_fsfcld(1:nbndsw+1,0:0,k_topo+1:nzt_rad+1) |
---|
3654 | rrtm_sw_tauaer_dum = rrtm_sw_tauaer(0:0,k_topo+1:nzt_rad+1,1:nbndsw+1) |
---|
3655 | rrtm_sw_ssaaer_dum = rrtm_sw_ssaaer(0:0,k_topo+1:nzt_rad+1,1:nbndsw+1) |
---|
3656 | rrtm_sw_asmaer_dum = rrtm_sw_asmaer(0:0,k_topo+1:nzt_rad+1,1:nbndsw+1) |
---|
3657 | rrtm_sw_ecaer_dum = rrtm_sw_ecaer(0:0,k_topo+1:nzt_rad+1,1:naerec+1) |
---|
3658 | |
---|
3659 | CALL rrtmg_sw( 1, & |
---|
3660 | nzt_rad-k_topo, & |
---|
3661 | rrtm_icld, & |
---|
3662 | rrtm_iaer, & |
---|
3663 | rrtm_play(:,k_topo+1:nzt_rad+1), & |
---|
3664 | rrtm_plev(:,k_topo+1:nzt_rad+2), & |
---|
3665 | rrtm_tlay(:,k_topo+1:nzt_rad+1), & |
---|
3666 | rrtm_tlev(:,k_topo+1:nzt_rad+2), & |
---|
3667 | rrtm_tsfc, & |
---|
3668 | rrtm_h2ovmr(:,k_topo+1:nzt_rad+1), & |
---|
3669 | rrtm_o3vmr(:,k_topo+1:nzt_rad+1), & |
---|
3670 | rrtm_co2vmr(:,k_topo+1:nzt_rad+1), & |
---|
3671 | rrtm_ch4vmr(:,k_topo+1:nzt_rad+1), & |
---|
3672 | rrtm_n2ovmr(:,k_topo+1:nzt_rad+1), & |
---|
3673 | rrtm_o2vmr(:,k_topo+1:nzt_rad+1), & |
---|
3674 | rrtm_asdir, & |
---|
3675 | rrtm_asdif, & |
---|
3676 | rrtm_aldir, & |
---|
3677 | rrtm_aldif, & |
---|
3678 | zenith, & |
---|
3679 | 0.0_wp, & |
---|
3680 | day_of_year, & |
---|
3681 | solar_constant, & |
---|
3682 | rrtm_inflgsw, & |
---|
3683 | rrtm_iceflgsw, & |
---|
3684 | rrtm_liqflgsw, & |
---|
3685 | rrtm_cldfr(:,k_topo+1:nzt_rad+1), & |
---|
3686 | rrtm_sw_taucld_dum, & |
---|
3687 | rrtm_sw_ssacld_dum, & |
---|
3688 | rrtm_sw_asmcld_dum, & |
---|
3689 | rrtm_sw_fsfcld_dum, & |
---|
3690 | rrtm_cicewp(:,k_topo+1:nzt_rad+1), & |
---|
3691 | rrtm_cliqwp(:,k_topo+1:nzt_rad+1), & |
---|
3692 | rrtm_reice(:,k_topo+1:nzt_rad+1), & |
---|
3693 | rrtm_reliq(:,k_topo+1:nzt_rad+1), & |
---|
3694 | rrtm_sw_tauaer_dum, & |
---|
3695 | rrtm_sw_ssaaer_dum, & |
---|
3696 | rrtm_sw_asmaer_dum, & |
---|
3697 | rrtm_sw_ecaer_dum, & |
---|
3698 | rrtm_swuflx(:,k_topo:nzt_rad+1), & |
---|
3699 | rrtm_swdflx(:,k_topo:nzt_rad+1), & |
---|
3700 | rrtm_swhr(:,k_topo+1:nzt_rad+1), & |
---|
3701 | rrtm_swuflxc(:,k_topo:nzt_rad+1), & |
---|
3702 | rrtm_swdflxc(:,k_topo:nzt_rad+1), & |
---|
3703 | rrtm_swhrc(:,k_topo+1:nzt_rad+1), & |
---|
3704 | rrtm_dirdflux(:,k_topo:nzt_rad+1), & |
---|
3705 | rrtm_difdflux(:,k_topo:nzt_rad+1) ) |
---|
3706 | |
---|
3707 | DEALLOCATE( rrtm_sw_taucld_dum ) |
---|
3708 | DEALLOCATE( rrtm_sw_ssacld_dum ) |
---|
3709 | DEALLOCATE( rrtm_sw_asmcld_dum ) |
---|
3710 | DEALLOCATE( rrtm_sw_fsfcld_dum ) |
---|
3711 | DEALLOCATE( rrtm_sw_tauaer_dum ) |
---|
3712 | DEALLOCATE( rrtm_sw_ssaaer_dum ) |
---|
3713 | DEALLOCATE( rrtm_sw_asmaer_dum ) |
---|
3714 | DEALLOCATE( rrtm_sw_ecaer_dum ) |
---|
3715 | ! |
---|
3716 | !-- Save fluxes |
---|
3717 | DO k = nzb, nzt+1 |
---|
3718 | rad_sw_in(k,j,i) = rrtm_swdflx(0,k) |
---|
3719 | rad_sw_out(k,j,i) = rrtm_swuflx(0,k) |
---|
3720 | ENDDO |
---|
3721 | ! |
---|
3722 | !-- Save heating rates (convert from K/d to K/s) |
---|
3723 | DO k = nzb+1, nzt+1 |
---|
3724 | rad_sw_hr(k,j,i) = rrtm_swhr(0,k) * d_hours_day |
---|
3725 | rad_sw_cs_hr(k,j,i) = rrtm_swhrc(0,k) * d_hours_day |
---|
3726 | ENDDO |
---|
3727 | |
---|
3728 | ! |
---|
3729 | !-- Save surface radiative fluxes onto respective surface elements |
---|
3730 | !-- Horizontal surfaces |
---|
3731 | DO m = surf_lsm_h%start_index(j,i), & |
---|
3732 | surf_lsm_h%end_index(j,i) |
---|
3733 | surf_lsm_h%rad_sw_in(m) = rrtm_swdflx(0,k_topo) |
---|
3734 | surf_lsm_h%rad_sw_out(m) = rrtm_swuflx(0,k_topo) |
---|
3735 | ENDDO |
---|
3736 | DO m = surf_usm_h%start_index(j,i), & |
---|
3737 | surf_usm_h%end_index(j,i) |
---|
3738 | surf_usm_h%rad_sw_in(m) = rrtm_swdflx(0,k_topo) |
---|
3739 | surf_usm_h%rad_sw_out(m) = rrtm_swuflx(0,k_topo) |
---|
3740 | ENDDO |
---|
3741 | ! |
---|
3742 | !-- Vertical surfaces. Fluxes are obtain at respective vertical |
---|
3743 | !-- level of the surface element |
---|
3744 | DO l = 0, 3 |
---|
3745 | DO m = surf_lsm_v(l)%start_index(j,i), & |
---|
3746 | surf_lsm_v(l)%end_index(j,i) |
---|
3747 | k = surf_lsm_v(l)%k(m) |
---|
3748 | surf_lsm_v(l)%rad_sw_in(m) = rrtm_swdflx(0,k) |
---|
3749 | surf_lsm_v(l)%rad_sw_out(m) = rrtm_swuflx(0,k) |
---|
3750 | ENDDO |
---|
3751 | DO m = surf_usm_v(l)%start_index(j,i), & |
---|
3752 | surf_usm_v(l)%end_index(j,i) |
---|
3753 | k = surf_usm_v(l)%k(m) |
---|
3754 | surf_usm_v(l)%rad_sw_in(m) = rrtm_swdflx(0,k) |
---|
3755 | surf_usm_v(l)%rad_sw_out(m) = rrtm_swuflx(0,k) |
---|
3756 | ENDDO |
---|
3757 | ENDDO |
---|
3758 | ! |
---|
3759 | !-- Solar radiation is zero during night |
---|
3760 | ELSE |
---|
3761 | rad_sw_in = 0.0_wp |
---|
3762 | rad_sw_out = 0.0_wp |
---|
3763 | !-- !!!!!!!! ATTENSION !!!!!!!!!!!!!!! |
---|
3764 | !-- Surface radiative fluxes should be also set to zero here |
---|
3765 | !-- Save surface radiative fluxes onto respective surface elements |
---|
3766 | !-- Horizontal surfaces |
---|
3767 | DO m = surf_lsm_h%start_index(j,i), & |
---|
3768 | surf_lsm_h%end_index(j,i) |
---|
3769 | surf_lsm_h%rad_sw_in(m) = 0.0_wp |
---|
3770 | surf_lsm_h%rad_sw_out(m) = 0.0_wp |
---|
3771 | ENDDO |
---|
3772 | DO m = surf_usm_h%start_index(j,i), & |
---|
3773 | surf_usm_h%end_index(j,i) |
---|
3774 | surf_usm_h%rad_sw_in(m) = 0.0_wp |
---|
3775 | surf_usm_h%rad_sw_out(m) = 0.0_wp |
---|
3776 | ENDDO |
---|
3777 | ! |
---|
3778 | !-- Vertical surfaces. Fluxes are obtain at respective vertical |
---|
3779 | !-- level of the surface element |
---|
3780 | DO l = 0, 3 |
---|
3781 | DO m = surf_lsm_v(l)%start_index(j,i), & |
---|
3782 | surf_lsm_v(l)%end_index(j,i) |
---|
3783 | k = surf_lsm_v(l)%k(m) |
---|
3784 | surf_lsm_v(l)%rad_sw_in(m) = 0.0_wp |
---|
3785 | surf_lsm_v(l)%rad_sw_out(m) = 0.0_wp |
---|
3786 | ENDDO |
---|
3787 | DO m = surf_usm_v(l)%start_index(j,i), & |
---|
3788 | surf_usm_v(l)%end_index(j,i) |
---|
3789 | k = surf_usm_v(l)%k(m) |
---|
3790 | surf_usm_v(l)%rad_sw_in(m) = 0.0_wp |
---|
3791 | surf_usm_v(l)%rad_sw_out(m) = 0.0_wp |
---|
3792 | ENDDO |
---|
3793 | ENDDO |
---|
3794 | ENDIF |
---|
3795 | |
---|
3796 | ENDDO |
---|
3797 | ENDDO |
---|
3798 | |
---|
3799 | ENDIF |
---|
3800 | ! |
---|
3801 | !-- Finally, calculate surface net radiation for surface elements. |
---|
3802 | IF ( .NOT. radiation_interactions ) THEN |
---|
3803 | !-- First, for horizontal surfaces |
---|
3804 | DO m = 1, surf_lsm_h%ns |
---|
3805 | surf_lsm_h%rad_net(m) = surf_lsm_h%rad_sw_in(m) & |
---|
3806 | - surf_lsm_h%rad_sw_out(m) & |
---|
3807 | + surf_lsm_h%rad_lw_in(m) & |
---|
3808 | - surf_lsm_h%rad_lw_out(m) |
---|
3809 | ENDDO |
---|
3810 | DO m = 1, surf_usm_h%ns |
---|
3811 | surf_usm_h%rad_net(m) = surf_usm_h%rad_sw_in(m) & |
---|
3812 | - surf_usm_h%rad_sw_out(m) & |
---|
3813 | + surf_usm_h%rad_lw_in(m) & |
---|
3814 | - surf_usm_h%rad_lw_out(m) |
---|
3815 | ENDDO |
---|
3816 | ! |
---|
3817 | !-- Vertical surfaces. |
---|
3818 | !-- Todo: weight with azimuth and zenith angle according to their orientation! |
---|
3819 | DO l = 0, 3 |
---|
3820 | DO m = 1, surf_lsm_v(l)%ns |
---|
3821 | surf_lsm_v(l)%rad_net(m) = surf_lsm_v(l)%rad_sw_in(m) & |
---|
3822 | - surf_lsm_v(l)%rad_sw_out(m) & |
---|
3823 | + surf_lsm_v(l)%rad_lw_in(m) & |
---|
3824 | - surf_lsm_v(l)%rad_lw_out(m) |
---|
3825 | ENDDO |
---|
3826 | DO m = 1, surf_usm_v(l)%ns |
---|
3827 | surf_usm_v(l)%rad_net(m) = surf_usm_v(l)%rad_sw_in(m) & |
---|
3828 | - surf_usm_v(l)%rad_sw_out(m) & |
---|
3829 | + surf_usm_v(l)%rad_lw_in(m) & |
---|
3830 | - surf_usm_v(l)%rad_lw_out(m) |
---|
3831 | ENDDO |
---|
3832 | ENDDO |
---|
3833 | ENDIF |
---|
3834 | |
---|
3835 | |
---|
3836 | CALL exchange_horiz( rad_lw_in, nbgp ) |
---|
3837 | CALL exchange_horiz( rad_lw_out, nbgp ) |
---|
3838 | CALL exchange_horiz( rad_lw_hr, nbgp ) |
---|
3839 | CALL exchange_horiz( rad_lw_cs_hr, nbgp ) |
---|
3840 | |
---|
3841 | CALL exchange_horiz( rad_sw_in, nbgp ) |
---|
3842 | CALL exchange_horiz( rad_sw_out, nbgp ) |
---|
3843 | CALL exchange_horiz( rad_sw_hr, nbgp ) |
---|
3844 | CALL exchange_horiz( rad_sw_cs_hr, nbgp ) |
---|
3845 | |
---|
3846 | #endif |
---|
3847 | |
---|
3848 | END SUBROUTINE radiation_rrtmg |
---|
3849 | |
---|
3850 | |
---|
3851 | !------------------------------------------------------------------------------! |
---|
3852 | ! Description: |
---|
3853 | ! ------------ |
---|
3854 | !> Calculate the cosine of the zenith angle (variable is called zenith) |
---|
3855 | !------------------------------------------------------------------------------! |
---|
3856 | SUBROUTINE calc_zenith |
---|
3857 | |
---|
3858 | IMPLICIT NONE |
---|
3859 | |
---|
3860 | REAL(wp) :: declination, & !< solar declination angle |
---|
3861 | hour_angle !< solar hour angle |
---|
3862 | ! |
---|
3863 | !-- Calculate current day and time based on the initial values and simulation |
---|
3864 | !-- time |
---|
3865 | CALL calc_date_and_time |
---|
3866 | |
---|
3867 | ! |
---|
3868 | !-- Calculate solar declination and hour angle |
---|
3869 | declination = ASIN( decl_1 * SIN(decl_2 * REAL(day_of_year, KIND=wp) - decl_3) ) |
---|
3870 | hour_angle = 2.0_wp * pi * (time_utc / 86400.0_wp) + lon - pi |
---|
3871 | |
---|
3872 | ! |
---|
3873 | !-- Calculate cosine of solar zenith angle |
---|
3874 | zenith(0) = SIN(lat) * SIN(declination) + COS(lat) * COS(declination) & |
---|
3875 | * COS(hour_angle) |
---|
3876 | zenith(0) = MAX(0.0_wp,zenith(0)) |
---|
3877 | |
---|
3878 | ! |
---|
3879 | !-- Calculate solar directional vector |
---|
3880 | IF ( sun_direction ) THEN |
---|
3881 | |
---|
3882 | ! |
---|
3883 | !-- Direction in longitudes equals to sin(solar_azimuth) * sin(zenith) |
---|
3884 | sun_dir_lon(0) = -SIN(hour_angle) * COS(declination) |
---|
3885 | |
---|
3886 | ! |
---|
3887 | !-- Direction in latitues equals to cos(solar_azimuth) * sin(zenith) |
---|
3888 | sun_dir_lat(0) = SIN(declination) * COS(lat) - COS(hour_angle) & |
---|
3889 | * COS(declination) * SIN(lat) |
---|
3890 | ENDIF |
---|
3891 | |
---|
3892 | ! |
---|
3893 | !-- Check if the sun is up (otheriwse shortwave calculations can be skipped) |
---|
3894 | IF ( zenith(0) > 0.0_wp ) THEN |
---|
3895 | sun_up = .TRUE. |
---|
3896 | ELSE |
---|
3897 | sun_up = .FALSE. |
---|
3898 | END IF |
---|
3899 | |
---|
3900 | END SUBROUTINE calc_zenith |
---|
3901 | |
---|
3902 | #if defined ( __rrtmg ) && defined ( __netcdf ) |
---|
3903 | !------------------------------------------------------------------------------! |
---|
3904 | ! Description: |
---|
3905 | ! ------------ |
---|
3906 | !> Calculates surface albedo components based on Briegleb (1992) and |
---|
3907 | !> Briegleb et al. (1986) |
---|
3908 | !------------------------------------------------------------------------------! |
---|
3909 | SUBROUTINE calc_albedo( surf ) |
---|
3910 | |
---|
3911 | IMPLICIT NONE |
---|
3912 | |
---|
3913 | INTEGER(iwp) :: ind_type !< running index surface tiles |
---|
3914 | INTEGER(iwp) :: m !< running index surface elements |
---|
3915 | |
---|
3916 | TYPE(surf_type) :: surf !< treated surfaces |
---|
3917 | |
---|
3918 | IF ( sun_up .AND. .NOT. average_radiation ) THEN |
---|
3919 | |
---|
3920 | DO m = 1, surf%ns |
---|
3921 | ! |
---|
3922 | !-- Loop over surface elements |
---|
3923 | DO ind_type = 0, SIZE( surf%albedo_type, 1 ) - 1 |
---|
3924 | |
---|
3925 | ! |
---|
3926 | !-- Ocean |
---|
3927 | IF ( surf%albedo_type(ind_type,m) == 1 ) THEN |
---|
3928 | surf%rrtm_aldir(ind_type,m) = 0.026_wp / & |
---|
3929 | ( zenith(0)**1.7_wp + 0.065_wp )& |
---|
3930 | + 0.15_wp * ( zenith(0) - 0.1_wp ) & |
---|
3931 | * ( zenith(0) - 0.5_wp ) & |
---|
3932 | * ( zenith(0) - 1.0_wp ) |
---|
3933 | surf%rrtm_asdir(ind_type,m) = surf%rrtm_aldir(ind_type,m) |
---|
3934 | ! |
---|
3935 | !-- Snow |
---|
3936 | ELSEIF ( surf%albedo_type(ind_type,m) == 16 ) THEN |
---|
3937 | IF ( zenith(0) < 0.5_wp ) THEN |
---|
3938 | surf%rrtm_aldir(ind_type,m) = & |
---|
3939 | 0.5_wp * ( 1.0_wp - surf%aldif(ind_type,m) ) & |
---|
3940 | * ( 3.0_wp / ( 1.0_wp + 4.0_wp & |
---|
3941 | * zenith(0) ) ) - 1.0_wp |
---|
3942 | surf%rrtm_asdir(ind_type,m) = & |
---|
3943 | 0.5_wp * ( 1.0_wp - surf%asdif(ind_type,m) ) & |
---|
3944 | * ( 3.0_wp / ( 1.0_wp + 4.0_wp & |
---|
3945 | * zenith(0) ) ) - 1.0_wp |
---|
3946 | |
---|
3947 | surf%rrtm_aldir(ind_type,m) = & |
---|
3948 | MIN(0.98_wp, surf%rrtm_aldir(ind_type,m)) |
---|
3949 | surf%rrtm_asdir(ind_type,m) = & |
---|
3950 | MIN(0.98_wp, surf%rrtm_asdir(ind_type,m)) |
---|
3951 | ELSE |
---|
3952 | surf%rrtm_aldir(ind_type,m) = surf%aldif(ind_type,m) |
---|
3953 | surf%rrtm_asdir(ind_type,m) = surf%asdif(ind_type,m) |
---|
3954 | ENDIF |
---|
3955 | ! |
---|
3956 | !-- Sea ice |
---|
3957 | ELSEIF ( surf%albedo_type(ind_type,m) == 15 ) THEN |
---|
3958 | surf%rrtm_aldir(ind_type,m) = surf%aldif(ind_type,m) |
---|
3959 | surf%rrtm_asdir(ind_type,m) = surf%asdif(ind_type,m) |
---|
3960 | |
---|
3961 | ! |
---|
3962 | !-- Asphalt |
---|
3963 | ELSEIF ( surf%albedo_type(ind_type,m) == 17 ) THEN |
---|
3964 | surf%rrtm_aldir(ind_type,m) = surf%aldif(ind_type,m) |
---|
3965 | surf%rrtm_asdir(ind_type,m) = surf%asdif(ind_type,m) |
---|
3966 | |
---|
3967 | |
---|
3968 | ! |
---|
3969 | !-- Bare soil |
---|
3970 | ELSEIF ( surf%albedo_type(ind_type,m) == 18 ) THEN |
---|
3971 | surf%rrtm_aldir(ind_type,m) = surf%aldif(ind_type,m) |
---|
3972 | surf%rrtm_asdir(ind_type,m) = surf%asdif(ind_type,m) |
---|
3973 | |
---|
3974 | ! |
---|
3975 | !-- Land surfaces |
---|
3976 | ELSE |
---|
3977 | SELECT CASE ( surf%albedo_type(ind_type,m) ) |
---|
3978 | |
---|
3979 | ! |
---|
3980 | !-- Surface types with strong zenith dependence |
---|
3981 | CASE ( 1, 2, 3, 4, 11, 12, 13 ) |
---|
3982 | surf%rrtm_aldir(ind_type,m) = & |
---|
3983 | surf%aldif(ind_type,m) * 1.4_wp / & |
---|
3984 | ( 1.0_wp + 0.8_wp * zenith(0) ) |
---|
3985 | surf%rrtm_asdir(ind_type,m) = & |
---|
3986 | surf%asdif(ind_type,m) * 1.4_wp / & |
---|
3987 | ( 1.0_wp + 0.8_wp * zenith(0) ) |
---|
3988 | ! |
---|
3989 | !-- Surface types with weak zenith dependence |
---|
3990 | CASE ( 5, 6, 7, 8, 9, 10, 14 ) |
---|
3991 | surf%rrtm_aldir(ind_type,m) = & |
---|
3992 | surf%aldif(ind_type,m) * 1.1_wp / & |
---|
3993 | ( 1.0_wp + 0.2_wp * zenith(0) ) |
---|
3994 | surf%rrtm_asdir(ind_type,m) = & |
---|
3995 | surf%asdif(ind_type,m) * 1.1_wp / & |
---|
3996 | ( 1.0_wp + 0.2_wp * zenith(0) ) |
---|
3997 | |
---|
3998 | CASE DEFAULT |
---|
3999 | |
---|
4000 | END SELECT |
---|
4001 | ENDIF |
---|
4002 | ! |
---|
4003 | !-- Diffusive albedo is taken from Table 2 |
---|
4004 | surf%rrtm_aldif(ind_type,m) = surf%aldif(ind_type,m) |
---|
4005 | surf%rrtm_asdif(ind_type,m) = surf%asdif(ind_type,m) |
---|
4006 | ENDDO |
---|
4007 | ENDDO |
---|
4008 | ! |
---|
4009 | !-- Set albedo in case of average radiation |
---|
4010 | ELSEIF ( sun_up .AND. average_radiation ) THEN |
---|
4011 | surf%rrtm_asdir = albedo_urb |
---|
4012 | surf%rrtm_asdif = albedo_urb |
---|
4013 | surf%rrtm_aldir = albedo_urb |
---|
4014 | surf%rrtm_aldif = albedo_urb |
---|
4015 | ! |
---|
4016 | !-- Darkness |
---|
4017 | ELSE |
---|
4018 | surf%rrtm_aldir = 0.0_wp |
---|
4019 | surf%rrtm_asdir = 0.0_wp |
---|
4020 | surf%rrtm_aldif = 0.0_wp |
---|
4021 | surf%rrtm_asdif = 0.0_wp |
---|
4022 | ENDIF |
---|
4023 | |
---|
4024 | END SUBROUTINE calc_albedo |
---|
4025 | |
---|
4026 | !------------------------------------------------------------------------------! |
---|
4027 | ! Description: |
---|
4028 | ! ------------ |
---|
4029 | !> Read sounding data (pressure and temperature) from RADIATION_DATA. |
---|
4030 | !------------------------------------------------------------------------------! |
---|
4031 | SUBROUTINE read_sounding_data |
---|
4032 | |
---|
4033 | IMPLICIT NONE |
---|
4034 | |
---|
4035 | INTEGER(iwp) :: id, & !< NetCDF id of input file |
---|
4036 | id_dim_zrad, & !< pressure level id in the NetCDF file |
---|
4037 | id_var, & !< NetCDF variable id |
---|
4038 | k, & !< loop index |
---|
4039 | nz_snd, & !< number of vertical levels in the sounding data |
---|
4040 | nz_snd_start, & !< start vertical index for sounding data to be used |
---|
4041 | nz_snd_end !< end vertical index for souding data to be used |
---|
4042 | |
---|
4043 | REAL(wp) :: t_surface !< actual surface temperature |
---|
4044 | |
---|
4045 | REAL(wp), DIMENSION(:), ALLOCATABLE :: hyp_snd_tmp, & !< temporary hydrostatic pressure profile (sounding) |
---|
4046 | t_snd_tmp !< temporary temperature profile (sounding) |
---|
4047 | |
---|
4048 | ! |
---|
4049 | !-- In case of updates, deallocate arrays first (sufficient to check one |
---|
4050 | !-- array as the others are automatically allocated). This is required |
---|
4051 | !-- because nzt_rad might change during the update |
---|
4052 | IF ( ALLOCATED ( hyp_snd ) ) THEN |
---|
4053 | DEALLOCATE( hyp_snd ) |
---|
4054 | DEALLOCATE( t_snd ) |
---|
4055 | DEALLOCATE ( rrtm_play ) |
---|
4056 | DEALLOCATE ( rrtm_plev ) |
---|
4057 | DEALLOCATE ( rrtm_tlay ) |
---|
4058 | DEALLOCATE ( rrtm_tlev ) |
---|
4059 | |
---|
4060 | DEALLOCATE ( rrtm_cicewp ) |
---|
4061 | DEALLOCATE ( rrtm_cldfr ) |
---|
4062 | DEALLOCATE ( rrtm_cliqwp ) |
---|
4063 | DEALLOCATE ( rrtm_reice ) |
---|
4064 | DEALLOCATE ( rrtm_reliq ) |
---|
4065 | DEALLOCATE ( rrtm_lw_taucld ) |
---|
4066 | DEALLOCATE ( rrtm_lw_tauaer ) |
---|
4067 | |
---|
4068 | DEALLOCATE ( rrtm_lwdflx ) |
---|
4069 | DEALLOCATE ( rrtm_lwdflxc ) |
---|
4070 | DEALLOCATE ( rrtm_lwuflx ) |
---|
4071 | DEALLOCATE ( rrtm_lwuflxc ) |
---|
4072 | DEALLOCATE ( rrtm_lwuflx_dt ) |
---|
4073 | DEALLOCATE ( rrtm_lwuflxc_dt ) |
---|
4074 | DEALLOCATE ( rrtm_lwhr ) |
---|
4075 | DEALLOCATE ( rrtm_lwhrc ) |
---|
4076 | |
---|
4077 | DEALLOCATE ( rrtm_sw_taucld ) |
---|
4078 | DEALLOCATE ( rrtm_sw_ssacld ) |
---|
4079 | DEALLOCATE ( rrtm_sw_asmcld ) |
---|
4080 | DEALLOCATE ( rrtm_sw_fsfcld ) |
---|
4081 | DEALLOCATE ( rrtm_sw_tauaer ) |
---|
4082 | DEALLOCATE ( rrtm_sw_ssaaer ) |
---|
4083 | DEALLOCATE ( rrtm_sw_asmaer ) |
---|
4084 | DEALLOCATE ( rrtm_sw_ecaer ) |
---|
4085 | |
---|
4086 | DEALLOCATE ( rrtm_swdflx ) |
---|
4087 | DEALLOCATE ( rrtm_swdflxc ) |
---|
4088 | DEALLOCATE ( rrtm_swuflx ) |
---|
4089 | DEALLOCATE ( rrtm_swuflxc ) |
---|
4090 | DEALLOCATE ( rrtm_swhr ) |
---|
4091 | DEALLOCATE ( rrtm_swhrc ) |
---|
4092 | DEALLOCATE ( rrtm_dirdflux ) |
---|
4093 | DEALLOCATE ( rrtm_difdflux ) |
---|
4094 | |
---|
4095 | ENDIF |
---|
4096 | |
---|
4097 | ! |
---|
4098 | !-- Open file for reading |
---|
4099 | nc_stat = NF90_OPEN( rrtm_input_file, NF90_NOWRITE, id ) |
---|
4100 | CALL netcdf_handle_error_rad( 'read_sounding_data', 549 ) |
---|
4101 | |
---|
4102 | ! |
---|
4103 | !-- Inquire dimension of z axis and save in nz_snd |
---|
4104 | nc_stat = NF90_INQ_DIMID( id, "Pressure", id_dim_zrad ) |
---|
4105 | nc_stat = NF90_INQUIRE_DIMENSION( id, id_dim_zrad, len = nz_snd ) |
---|
4106 | CALL netcdf_handle_error_rad( 'read_sounding_data', 551 ) |
---|
4107 | |
---|
4108 | ! |
---|
4109 | ! !-- Allocate temporary array for storing pressure data |
---|
4110 | ALLOCATE( hyp_snd_tmp(1:nz_snd) ) |
---|
4111 | hyp_snd_tmp = 0.0_wp |
---|
4112 | |
---|
4113 | |
---|
4114 | !-- Read pressure from file |
---|
4115 | nc_stat = NF90_INQ_VARID( id, "Pressure", id_var ) |
---|
4116 | nc_stat = NF90_GET_VAR( id, id_var, hyp_snd_tmp(:), start = (/1/), & |
---|
4117 | count = (/nz_snd/) ) |
---|
4118 | CALL netcdf_handle_error_rad( 'read_sounding_data', 552 ) |
---|
4119 | |
---|
4120 | ! |
---|
4121 | !-- Allocate temporary array for storing temperature data |
---|
4122 | ALLOCATE( t_snd_tmp(1:nz_snd) ) |
---|
4123 | t_snd_tmp = 0.0_wp |
---|
4124 | |
---|
4125 | ! |
---|
4126 | !-- Read temperature from file |
---|
4127 | nc_stat = NF90_INQ_VARID( id, "ReferenceTemperature", id_var ) |
---|
4128 | nc_stat = NF90_GET_VAR( id, id_var, t_snd_tmp(:), start = (/1/), & |
---|
4129 | count = (/nz_snd/) ) |
---|
4130 | CALL netcdf_handle_error_rad( 'read_sounding_data', 553 ) |
---|
4131 | |
---|
4132 | ! |
---|
4133 | !-- Calculate start of sounding data |
---|
4134 | nz_snd_start = nz_snd + 1 |
---|
4135 | nz_snd_end = nz_snd + 1 |
---|
4136 | |
---|
4137 | ! |
---|
4138 | !-- Start filling vertical dimension at 10hPa above the model domain (hyp is |
---|
4139 | !-- in Pa, hyp_snd in hPa). |
---|
4140 | DO k = 1, nz_snd |
---|
4141 | IF ( hyp_snd_tmp(k) < ( hyp(nzt+1) - 1000.0_wp) * 0.01_wp ) THEN |
---|
4142 | nz_snd_start = k |
---|
4143 | EXIT |
---|
4144 | END IF |
---|
4145 | END DO |
---|
4146 | |
---|
4147 | IF ( nz_snd_start <= nz_snd ) THEN |
---|
4148 | nz_snd_end = nz_snd |
---|
4149 | END IF |
---|
4150 | |
---|
4151 | |
---|
4152 | ! |
---|
4153 | !-- Calculate of total grid points for RRTMG calculations |
---|
4154 | nzt_rad = nzt + nz_snd_end - nz_snd_start + 1 |
---|
4155 | |
---|
4156 | ! |
---|
4157 | !-- Save data above LES domain in hyp_snd, t_snd |
---|
4158 | ALLOCATE( hyp_snd(nzb+1:nzt_rad) ) |
---|
4159 | ALLOCATE( t_snd(nzb+1:nzt_rad) ) |
---|
4160 | hyp_snd = 0.0_wp |
---|
4161 | t_snd = 0.0_wp |
---|
4162 | |
---|
4163 | hyp_snd(nzt+2:nzt_rad) = hyp_snd_tmp(nz_snd_start+1:nz_snd_end) |
---|
4164 | t_snd(nzt+2:nzt_rad) = t_snd_tmp(nz_snd_start+1:nz_snd_end) |
---|
4165 | |
---|
4166 | nc_stat = NF90_CLOSE( id ) |
---|
4167 | |
---|
4168 | ! |
---|
4169 | !-- Calculate pressure levels on zu and zw grid. Sounding data is added at |
---|
4170 | !-- top of the LES domain. This routine does not consider horizontal or |
---|
4171 | !-- vertical variability of pressure and temperature |
---|
4172 | ALLOCATE ( rrtm_play(0:0,nzb+1:nzt_rad+1) ) |
---|
4173 | ALLOCATE ( rrtm_plev(0:0,nzb+1:nzt_rad+2) ) |
---|
4174 | |
---|
4175 | t_surface = pt_surface * exner(nzb) |
---|
4176 | DO k = nzb+1, nzt+1 |
---|
4177 | rrtm_play(0,k) = hyp(k) * 0.01_wp |
---|
4178 | rrtm_plev(0,k) = barometric_formula(zw(k-1), & |
---|
4179 | pt_surface * exner(nzb), & |
---|
4180 | surface_pressure ) |
---|
4181 | ENDDO |
---|
4182 | |
---|
4183 | DO k = nzt+2, nzt_rad |
---|
4184 | rrtm_play(0,k) = hyp_snd(k) |
---|
4185 | rrtm_plev(0,k) = 0.5_wp * ( rrtm_play(0,k) + rrtm_play(0,k-1) ) |
---|
4186 | ENDDO |
---|
4187 | rrtm_plev(0,nzt_rad+1) = MAX( 0.5 * hyp_snd(nzt_rad), & |
---|
4188 | 1.5 * hyp_snd(nzt_rad) & |
---|
4189 | - 0.5 * hyp_snd(nzt_rad-1) ) |
---|
4190 | rrtm_plev(0,nzt_rad+2) = MIN( 1.0E-4_wp, & |
---|
4191 | 0.25_wp * rrtm_plev(0,nzt_rad+1) ) |
---|
4192 | |
---|
4193 | rrtm_play(0,nzt_rad+1) = 0.5 * rrtm_plev(0,nzt_rad+1) |
---|
4194 | |
---|
4195 | ! |
---|
4196 | !-- Calculate temperature/humidity levels at top of the LES domain. |
---|
4197 | !-- Currently, the temperature is taken from sounding data (might lead to a |
---|
4198 | !-- temperature jump at interface. To do: Humidity is currently not |
---|
4199 | !-- calculated above the LES domain. |
---|
4200 | ALLOCATE ( rrtm_tlay(0:0,nzb+1:nzt_rad+1) ) |
---|
4201 | ALLOCATE ( rrtm_tlev(0:0,nzb+1:nzt_rad+2) ) |
---|
4202 | |
---|
4203 | DO k = nzt+8, nzt_rad |
---|
4204 | rrtm_tlay(0,k) = t_snd(k) |
---|
4205 | ENDDO |
---|
4206 | rrtm_tlay(0,nzt_rad+1) = 2.0_wp * rrtm_tlay(0,nzt_rad) & |
---|
4207 | - rrtm_tlay(0,nzt_rad-1) |
---|
4208 | DO k = nzt+9, nzt_rad+1 |
---|
4209 | rrtm_tlev(0,k) = rrtm_tlay(0,k-1) + (rrtm_tlay(0,k) & |
---|
4210 | - rrtm_tlay(0,k-1)) & |
---|
4211 | / ( rrtm_play(0,k) - rrtm_play(0,k-1) ) & |
---|
4212 | * ( rrtm_plev(0,k) - rrtm_play(0,k-1) ) |
---|
4213 | ENDDO |
---|
4214 | |
---|
4215 | rrtm_tlev(0,nzt_rad+2) = 2.0_wp * rrtm_tlay(0,nzt_rad+1) & |
---|
4216 | - rrtm_tlev(0,nzt_rad) |
---|
4217 | ! |
---|
4218 | !-- Allocate remaining RRTMG arrays |
---|
4219 | ALLOCATE ( rrtm_cicewp(0:0,nzb+1:nzt_rad+1) ) |
---|
4220 | ALLOCATE ( rrtm_cldfr(0:0,nzb+1:nzt_rad+1) ) |
---|
4221 | ALLOCATE ( rrtm_cliqwp(0:0,nzb+1:nzt_rad+1) ) |
---|
4222 | ALLOCATE ( rrtm_reice(0:0,nzb+1:nzt_rad+1) ) |
---|
4223 | ALLOCATE ( rrtm_reliq(0:0,nzb+1:nzt_rad+1) ) |
---|
4224 | ALLOCATE ( rrtm_lw_taucld(1:nbndlw+1,0:0,nzb+1:nzt_rad+1) ) |
---|
4225 | ALLOCATE ( rrtm_lw_tauaer(0:0,nzb+1:nzt_rad+1,1:nbndlw+1) ) |
---|
4226 | ALLOCATE ( rrtm_sw_taucld(1:nbndsw+1,0:0,nzb+1:nzt_rad+1) ) |
---|
4227 | ALLOCATE ( rrtm_sw_ssacld(1:nbndsw+1,0:0,nzb+1:nzt_rad+1) ) |
---|
4228 | ALLOCATE ( rrtm_sw_asmcld(1:nbndsw+1,0:0,nzb+1:nzt_rad+1) ) |
---|
4229 | ALLOCATE ( rrtm_sw_fsfcld(1:nbndsw+1,0:0,nzb+1:nzt_rad+1) ) |
---|
4230 | ALLOCATE ( rrtm_sw_tauaer(0:0,nzb+1:nzt_rad+1,1:nbndsw+1) ) |
---|
4231 | ALLOCATE ( rrtm_sw_ssaaer(0:0,nzb+1:nzt_rad+1,1:nbndsw+1) ) |
---|
4232 | ALLOCATE ( rrtm_sw_asmaer(0:0,nzb+1:nzt_rad+1,1:nbndsw+1) ) |
---|
4233 | ALLOCATE ( rrtm_sw_ecaer(0:0,nzb+1:nzt_rad+1,1:naerec+1) ) |
---|
4234 | |
---|
4235 | ! |
---|
4236 | !-- The ice phase is currently not considered in PALM |
---|
4237 | rrtm_cicewp = 0.0_wp |
---|
4238 | rrtm_reice = 0.0_wp |
---|
4239 | |
---|
4240 | ! |
---|
4241 | !-- Set other parameters (move to NAMELIST parameters in the future) |
---|
4242 | rrtm_lw_tauaer = 0.0_wp |
---|
4243 | rrtm_lw_taucld = 0.0_wp |
---|
4244 | rrtm_sw_taucld = 0.0_wp |
---|
4245 | rrtm_sw_ssacld = 0.0_wp |
---|
4246 | rrtm_sw_asmcld = 0.0_wp |
---|
4247 | rrtm_sw_fsfcld = 0.0_wp |
---|
4248 | rrtm_sw_tauaer = 0.0_wp |
---|
4249 | rrtm_sw_ssaaer = 0.0_wp |
---|
4250 | rrtm_sw_asmaer = 0.0_wp |
---|
4251 | rrtm_sw_ecaer = 0.0_wp |
---|
4252 | |
---|
4253 | |
---|
4254 | ALLOCATE ( rrtm_swdflx(0:0,nzb:nzt_rad+1) ) |
---|
4255 | ALLOCATE ( rrtm_swuflx(0:0,nzb:nzt_rad+1) ) |
---|
4256 | ALLOCATE ( rrtm_swhr(0:0,nzb+1:nzt_rad+1) ) |
---|
4257 | ALLOCATE ( rrtm_swuflxc(0:0,nzb:nzt_rad+1) ) |
---|
4258 | ALLOCATE ( rrtm_swdflxc(0:0,nzb:nzt_rad+1) ) |
---|
4259 | ALLOCATE ( rrtm_swhrc(0:0,nzb+1:nzt_rad+1) ) |
---|
4260 | ALLOCATE ( rrtm_dirdflux(0:0,nzb:nzt_rad+1) ) |
---|
4261 | ALLOCATE ( rrtm_difdflux(0:0,nzb:nzt_rad+1) ) |
---|
4262 | |
---|
4263 | rrtm_swdflx = 0.0_wp |
---|
4264 | rrtm_swuflx = 0.0_wp |
---|
4265 | rrtm_swhr = 0.0_wp |
---|
4266 | rrtm_swuflxc = 0.0_wp |
---|
4267 | rrtm_swdflxc = 0.0_wp |
---|
4268 | rrtm_swhrc = 0.0_wp |
---|
4269 | rrtm_dirdflux = 0.0_wp |
---|
4270 | rrtm_difdflux = 0.0_wp |
---|
4271 | |
---|
4272 | ALLOCATE ( rrtm_lwdflx(0:0,nzb:nzt_rad+1) ) |
---|
4273 | ALLOCATE ( rrtm_lwuflx(0:0,nzb:nzt_rad+1) ) |
---|
4274 | ALLOCATE ( rrtm_lwhr(0:0,nzb+1:nzt_rad+1) ) |
---|
4275 | ALLOCATE ( rrtm_lwuflxc(0:0,nzb:nzt_rad+1) ) |
---|
4276 | ALLOCATE ( rrtm_lwdflxc(0:0,nzb:nzt_rad+1) ) |
---|
4277 | ALLOCATE ( rrtm_lwhrc(0:0,nzb+1:nzt_rad+1) ) |
---|
4278 | |
---|
4279 | rrtm_lwdflx = 0.0_wp |
---|
4280 | rrtm_lwuflx = 0.0_wp |
---|
4281 | rrtm_lwhr = 0.0_wp |
---|
4282 | rrtm_lwuflxc = 0.0_wp |
---|
4283 | rrtm_lwdflxc = 0.0_wp |
---|
4284 | rrtm_lwhrc = 0.0_wp |
---|
4285 | |
---|
4286 | ALLOCATE ( rrtm_lwuflx_dt(0:0,nzb:nzt_rad+1) ) |
---|
4287 | ALLOCATE ( rrtm_lwuflxc_dt(0:0,nzb:nzt_rad+1) ) |
---|
4288 | |
---|
4289 | rrtm_lwuflx_dt = 0.0_wp |
---|
4290 | rrtm_lwuflxc_dt = 0.0_wp |
---|
4291 | |
---|
4292 | END SUBROUTINE read_sounding_data |
---|
4293 | |
---|
4294 | |
---|
4295 | !------------------------------------------------------------------------------! |
---|
4296 | ! Description: |
---|
4297 | ! ------------ |
---|
4298 | !> Read trace gas data from file |
---|
4299 | !------------------------------------------------------------------------------! |
---|
4300 | SUBROUTINE read_trace_gas_data |
---|
4301 | |
---|
4302 | USE rrsw_ncpar |
---|
4303 | |
---|
4304 | IMPLICIT NONE |
---|
4305 | |
---|
4306 | INTEGER(iwp), PARAMETER :: num_trace_gases = 10 !< number of trace gases (absorbers) |
---|
4307 | |
---|
4308 | CHARACTER(LEN=5), DIMENSION(num_trace_gases), PARAMETER :: & !< trace gas names |
---|
4309 | trace_names = (/'O3 ', 'CO2 ', 'CH4 ', 'N2O ', 'O2 ', & |
---|
4310 | 'CFC11', 'CFC12', 'CFC22', 'CCL4 ', 'H2O '/) |
---|
4311 | |
---|
4312 | INTEGER(iwp) :: id, & !< NetCDF id |
---|
4313 | k, & !< loop index |
---|
4314 | m, & !< loop index |
---|
4315 | n, & !< loop index |
---|
4316 | nabs, & !< number of absorbers |
---|
4317 | np, & !< number of pressure levels |
---|
4318 | id_abs, & !< NetCDF id of the respective absorber |
---|
4319 | id_dim, & !< NetCDF id of asborber's dimension |
---|
4320 | id_var !< NetCDf id ot the absorber |
---|
4321 | |
---|
4322 | REAL(wp) :: p_mls_l, p_mls_u, p_wgt_l, p_wgt_u, p_mls_m |
---|
4323 | |
---|
4324 | |
---|
4325 | REAL(wp), DIMENSION(:), ALLOCATABLE :: p_mls, & !< pressure levels for the absorbers |
---|
4326 | rrtm_play_tmp, & !< temporary array for pressure zu-levels |
---|
4327 | rrtm_plev_tmp, & !< temporary array for pressure zw-levels |
---|
4328 | trace_path_tmp !< temporary array for storing trace gas path data |
---|
4329 | |
---|
4330 | REAL(wp), DIMENSION(:,:), ALLOCATABLE :: trace_mls, & !< array for storing the absorber amounts |
---|
4331 | trace_mls_path, & !< array for storing trace gas path data |
---|
4332 | trace_mls_tmp !< temporary array for storing trace gas data |
---|
4333 | |
---|
4334 | |
---|
4335 | ! |
---|
4336 | !-- In case of updates, deallocate arrays first (sufficient to check one |
---|
4337 | !-- array as the others are automatically allocated) |
---|
4338 | IF ( ALLOCATED ( rrtm_o3vmr ) ) THEN |
---|
4339 | DEALLOCATE ( rrtm_o3vmr ) |
---|
4340 | DEALLOCATE ( rrtm_co2vmr ) |
---|
4341 | DEALLOCATE ( rrtm_ch4vmr ) |
---|
4342 | DEALLOCATE ( rrtm_n2ovmr ) |
---|
4343 | DEALLOCATE ( rrtm_o2vmr ) |
---|
4344 | DEALLOCATE ( rrtm_cfc11vmr ) |
---|
4345 | DEALLOCATE ( rrtm_cfc12vmr ) |
---|
4346 | DEALLOCATE ( rrtm_cfc22vmr ) |
---|
4347 | DEALLOCATE ( rrtm_ccl4vmr ) |
---|
4348 | DEALLOCATE ( rrtm_h2ovmr ) |
---|
4349 | ENDIF |
---|
4350 | |
---|
4351 | ! |
---|
4352 | !-- Allocate trace gas profiles |
---|
4353 | ALLOCATE ( rrtm_o3vmr(0:0,1:nzt_rad+1) ) |
---|
4354 | ALLOCATE ( rrtm_co2vmr(0:0,1:nzt_rad+1) ) |
---|
4355 | ALLOCATE ( rrtm_ch4vmr(0:0,1:nzt_rad+1) ) |
---|
4356 | ALLOCATE ( rrtm_n2ovmr(0:0,1:nzt_rad+1) ) |
---|
4357 | ALLOCATE ( rrtm_o2vmr(0:0,1:nzt_rad+1) ) |
---|
4358 | ALLOCATE ( rrtm_cfc11vmr(0:0,1:nzt_rad+1) ) |
---|
4359 | ALLOCATE ( rrtm_cfc12vmr(0:0,1:nzt_rad+1) ) |
---|
4360 | ALLOCATE ( rrtm_cfc22vmr(0:0,1:nzt_rad+1) ) |
---|
4361 | ALLOCATE ( rrtm_ccl4vmr(0:0,1:nzt_rad+1) ) |
---|
4362 | ALLOCATE ( rrtm_h2ovmr(0:0,1:nzt_rad+1) ) |
---|
4363 | |
---|
4364 | ! |
---|
4365 | !-- Open file for reading |
---|
4366 | nc_stat = NF90_OPEN( rrtm_input_file, NF90_NOWRITE, id ) |
---|
4367 | CALL netcdf_handle_error_rad( 'read_trace_gas_data', 549 ) |
---|
4368 | ! |
---|
4369 | !-- Inquire dimension ids and dimensions |
---|
4370 | nc_stat = NF90_INQ_DIMID( id, "Pressure", id_dim ) |
---|
4371 | CALL netcdf_handle_error_rad( 'read_trace_gas_data', 550 ) |
---|
4372 | nc_stat = NF90_INQUIRE_DIMENSION( id, id_dim, len = np) |
---|
4373 | CALL netcdf_handle_error_rad( 'read_trace_gas_data', 550 ) |
---|
4374 | |
---|
4375 | nc_stat = NF90_INQ_DIMID( id, "Absorber", id_dim ) |
---|
4376 | CALL netcdf_handle_error_rad( 'read_trace_gas_data', 550 ) |
---|
4377 | nc_stat = NF90_INQUIRE_DIMENSION( id, id_dim, len = nabs ) |
---|
4378 | CALL netcdf_handle_error_rad( 'read_trace_gas_data', 550 ) |
---|
4379 | |
---|
4380 | |
---|
4381 | ! |
---|
4382 | !-- Allocate pressure, and trace gas arrays |
---|
4383 | ALLOCATE( p_mls(1:np) ) |
---|
4384 | ALLOCATE( trace_mls(1:num_trace_gases,1:np) ) |
---|
4385 | ALLOCATE( trace_mls_tmp(1:nabs,1:np) ) |
---|
4386 | |
---|
4387 | |
---|
4388 | nc_stat = NF90_INQ_VARID( id, "Pressure", id_var ) |
---|
4389 | CALL netcdf_handle_error_rad( 'read_trace_gas_data', 550 ) |
---|
4390 | nc_stat = NF90_GET_VAR( id, id_var, p_mls ) |
---|
4391 | CALL netcdf_handle_error_rad( 'read_trace_gas_data', 550 ) |
---|
4392 | |
---|
4393 | nc_stat = NF90_INQ_VARID( id, "AbsorberAmountMLS", id_var ) |
---|
4394 | CALL netcdf_handle_error_rad( 'read_trace_gas_data', 550 ) |
---|
4395 | nc_stat = NF90_GET_VAR( id, id_var, trace_mls_tmp ) |
---|
4396 | CALL netcdf_handle_error_rad( 'read_trace_gas_data', 550 ) |
---|
4397 | |
---|
4398 | |
---|
4399 | ! |
---|
4400 | !-- Write absorber amounts (mls) to trace_mls |
---|
4401 | DO n = 1, num_trace_gases |
---|
4402 | CALL getAbsorberIndex( TRIM( trace_names(n) ), id_abs ) |
---|
4403 | |
---|
4404 | trace_mls(n,1:np) = trace_mls_tmp(id_abs,1:np) |
---|
4405 | |
---|
4406 | ! |
---|
4407 | !-- Replace missing values by zero |
---|
4408 | WHERE ( trace_mls(n,:) > 2.0_wp ) |
---|
4409 | trace_mls(n,:) = 0.0_wp |
---|
4410 | END WHERE |
---|
4411 | END DO |
---|
4412 | |
---|
4413 | DEALLOCATE ( trace_mls_tmp ) |
---|
4414 | |
---|
4415 | nc_stat = NF90_CLOSE( id ) |
---|
4416 | CALL netcdf_handle_error_rad( 'read_trace_gas_data', 551 ) |
---|
4417 | |
---|
4418 | ! |
---|
4419 | !-- Add extra pressure level for calculations of the trace gas paths |
---|
4420 | ALLOCATE ( rrtm_play_tmp(1:nzt_rad+1) ) |
---|
4421 | ALLOCATE ( rrtm_plev_tmp(1:nzt_rad+2) ) |
---|
4422 | |
---|
4423 | rrtm_play_tmp(1:nzt_rad) = rrtm_play(0,1:nzt_rad) |
---|
4424 | rrtm_plev_tmp(1:nzt_rad+1) = rrtm_plev(0,1:nzt_rad+1) |
---|
4425 | rrtm_play_tmp(nzt_rad+1) = rrtm_plev(0,nzt_rad+1) * 0.5_wp |
---|
4426 | rrtm_plev_tmp(nzt_rad+2) = MIN( 1.0E-4_wp, 0.25_wp & |
---|
4427 | * rrtm_plev(0,nzt_rad+1) ) |
---|
4428 | |
---|
4429 | ! |
---|
4430 | !-- Calculate trace gas path (zero at surface) with interpolation to the |
---|
4431 | !-- sounding levels |
---|
4432 | ALLOCATE ( trace_mls_path(1:nzt_rad+2,1:num_trace_gases) ) |
---|
4433 | |
---|
4434 | trace_mls_path(nzb+1,:) = 0.0_wp |
---|
4435 | |
---|
4436 | DO k = nzb+2, nzt_rad+2 |
---|
4437 | DO m = 1, num_trace_gases |
---|
4438 | trace_mls_path(k,m) = trace_mls_path(k-1,m) |
---|
4439 | |
---|
4440 | ! |
---|
4441 | !-- When the pressure level is higher than the trace gas pressure |
---|
4442 | !-- level, assume that |
---|
4443 | IF ( rrtm_plev_tmp(k-1) > p_mls(1) ) THEN |
---|
4444 | |
---|
4445 | trace_mls_path(k,m) = trace_mls_path(k,m) + trace_mls(m,1) & |
---|
4446 | * ( rrtm_plev_tmp(k-1) & |
---|
4447 | - MAX( p_mls(1), rrtm_plev_tmp(k) ) & |
---|
4448 | ) / g |
---|
4449 | ENDIF |
---|
4450 | |
---|
4451 | ! |
---|
4452 | !-- Integrate for each sounding level from the contributing p_mls |
---|
4453 | !-- levels |
---|
4454 | DO n = 2, np |
---|
4455 | ! |
---|
4456 | !-- Limit p_mls so that it is within the model level |
---|
4457 | p_mls_u = MIN( rrtm_plev_tmp(k-1), & |
---|
4458 | MAX( rrtm_plev_tmp(k), p_mls(n) ) ) |
---|
4459 | p_mls_l = MIN( rrtm_plev_tmp(k-1), & |
---|
4460 | MAX( rrtm_plev_tmp(k), p_mls(n-1) ) ) |
---|
4461 | |
---|
4462 | IF ( p_mls_l > p_mls_u ) THEN |
---|
4463 | |
---|
4464 | ! |
---|
4465 | !-- Calculate weights for interpolation |
---|
4466 | p_mls_m = 0.5_wp * (p_mls_l + p_mls_u) |
---|
4467 | p_wgt_u = (p_mls(n-1) - p_mls_m) / (p_mls(n-1) - p_mls(n)) |
---|
4468 | p_wgt_l = (p_mls_m - p_mls(n)) / (p_mls(n-1) - p_mls(n)) |
---|
4469 | |
---|
4470 | ! |
---|
4471 | !-- Add level to trace gas path |
---|
4472 | trace_mls_path(k,m) = trace_mls_path(k,m) & |
---|
4473 | + ( p_wgt_u * trace_mls(m,n) & |
---|
4474 | + p_wgt_l * trace_mls(m,n-1) ) & |
---|
4475 | * (p_mls_l - p_mls_u) / g |
---|
4476 | ENDIF |
---|
4477 | ENDDO |
---|
4478 | |
---|
4479 | IF ( rrtm_plev_tmp(k) < p_mls(np) ) THEN |
---|
4480 | trace_mls_path(k,m) = trace_mls_path(k,m) + trace_mls(m,np) & |
---|
4481 | * ( MIN( rrtm_plev_tmp(k-1), p_mls(np) ) & |
---|
4482 | - rrtm_plev_tmp(k) & |
---|
4483 | ) / g |
---|
4484 | ENDIF |
---|
4485 | ENDDO |
---|
4486 | ENDDO |
---|
4487 | |
---|
4488 | |
---|
4489 | ! |
---|
4490 | !-- Prepare trace gas path profiles |
---|
4491 | ALLOCATE ( trace_path_tmp(1:nzt_rad+1) ) |
---|
4492 | |
---|
4493 | DO m = 1, num_trace_gases |
---|
4494 | |
---|
4495 | trace_path_tmp(1:nzt_rad+1) = ( trace_mls_path(2:nzt_rad+2,m) & |
---|
4496 | - trace_mls_path(1:nzt_rad+1,m) ) * g & |
---|
4497 | / ( rrtm_plev_tmp(1:nzt_rad+1) & |
---|
4498 | - rrtm_plev_tmp(2:nzt_rad+2) ) |
---|
4499 | |
---|
4500 | ! |
---|
4501 | !-- Save trace gas paths to the respective arrays |
---|
4502 | SELECT CASE ( TRIM( trace_names(m) ) ) |
---|
4503 | |
---|
4504 | CASE ( 'O3' ) |
---|
4505 | |
---|
4506 | rrtm_o3vmr(0,:) = trace_path_tmp(:) |
---|
4507 | |
---|
4508 | CASE ( 'CO2' ) |
---|
4509 | |
---|
4510 | rrtm_co2vmr(0,:) = trace_path_tmp(:) |
---|
4511 | |
---|
4512 | CASE ( 'CH4' ) |
---|
4513 | |
---|
4514 | rrtm_ch4vmr(0,:) = trace_path_tmp(:) |
---|
4515 | |
---|
4516 | CASE ( 'N2O' ) |
---|
4517 | |
---|
4518 | rrtm_n2ovmr(0,:) = trace_path_tmp(:) |
---|
4519 | |
---|
4520 | CASE ( 'O2' ) |
---|
4521 | |
---|
4522 | rrtm_o2vmr(0,:) = trace_path_tmp(:) |
---|
4523 | |
---|
4524 | CASE ( 'CFC11' ) |
---|
4525 | |
---|
4526 | rrtm_cfc11vmr(0,:) = trace_path_tmp(:) |
---|
4527 | |
---|
4528 | CASE ( 'CFC12' ) |
---|
4529 | |
---|
4530 | rrtm_cfc12vmr(0,:) = trace_path_tmp(:) |
---|
4531 | |
---|
4532 | CASE ( 'CFC22' ) |
---|
4533 | |
---|
4534 | rrtm_cfc22vmr(0,:) = trace_path_tmp(:) |
---|
4535 | |
---|
4536 | CASE ( 'CCL4' ) |
---|
4537 | |
---|
4538 | rrtm_ccl4vmr(0,:) = trace_path_tmp(:) |
---|
4539 | |
---|
4540 | CASE ( 'H2O' ) |
---|
4541 | |
---|
4542 | rrtm_h2ovmr(0,:) = trace_path_tmp(:) |
---|
4543 | |
---|
4544 | CASE DEFAULT |
---|
4545 | |
---|
4546 | END SELECT |
---|
4547 | |
---|
4548 | ENDDO |
---|
4549 | |
---|
4550 | DEALLOCATE ( trace_path_tmp ) |
---|
4551 | DEALLOCATE ( trace_mls_path ) |
---|
4552 | DEALLOCATE ( rrtm_play_tmp ) |
---|
4553 | DEALLOCATE ( rrtm_plev_tmp ) |
---|
4554 | DEALLOCATE ( trace_mls ) |
---|
4555 | DEALLOCATE ( p_mls ) |
---|
4556 | |
---|
4557 | END SUBROUTINE read_trace_gas_data |
---|
4558 | |
---|
4559 | |
---|
4560 | SUBROUTINE netcdf_handle_error_rad( routine_name, errno ) |
---|
4561 | |
---|
4562 | USE control_parameters, & |
---|
4563 | ONLY: message_string |
---|
4564 | |
---|
4565 | USE NETCDF |
---|
4566 | |
---|
4567 | USE pegrid |
---|
4568 | |
---|
4569 | IMPLICIT NONE |
---|
4570 | |
---|
4571 | CHARACTER(LEN=6) :: message_identifier |
---|
4572 | CHARACTER(LEN=*) :: routine_name |
---|
4573 | |
---|
4574 | INTEGER(iwp) :: errno |
---|
4575 | |
---|
4576 | IF ( nc_stat /= NF90_NOERR ) THEN |
---|
4577 | |
---|
4578 | WRITE( message_identifier, '(''NC'',I4.4)' ) errno |
---|
4579 | message_string = TRIM( NF90_STRERROR( nc_stat ) ) |
---|
4580 | |
---|
4581 | CALL message( routine_name, message_identifier, 2, 2, 0, 6, 1 ) |
---|
4582 | |
---|
4583 | ENDIF |
---|
4584 | |
---|
4585 | END SUBROUTINE netcdf_handle_error_rad |
---|
4586 | #endif |
---|
4587 | |
---|
4588 | |
---|
4589 | !------------------------------------------------------------------------------! |
---|
4590 | ! Description: |
---|
4591 | ! ------------ |
---|
4592 | !> Calculate temperature tendency due to radiative cooling/heating. |
---|
4593 | !> Cache-optimized version. |
---|
4594 | !------------------------------------------------------------------------------! |
---|
4595 | SUBROUTINE radiation_tendency_ij ( i, j, tend ) |
---|
4596 | |
---|
4597 | IMPLICIT NONE |
---|
4598 | |
---|
4599 | INTEGER(iwp) :: i, j, k !< loop indices |
---|
4600 | |
---|
4601 | REAL(wp), DIMENSION(nzb:nzt+1,nysg:nyng,nxlg:nxrg) :: tend !< pt tendency term |
---|
4602 | |
---|
4603 | IF ( radiation_scheme == 'rrtmg' ) THEN |
---|
4604 | #if defined ( __rrtmg ) |
---|
4605 | ! |
---|
4606 | !-- Calculate tendency based on heating rate |
---|
4607 | DO k = nzb+1, nzt+1 |
---|
4608 | tend(k,j,i) = tend(k,j,i) + (rad_lw_hr(k,j,i) + rad_sw_hr(k,j,i)) & |
---|
4609 | * d_exner(k) * d_seconds_hour |
---|
4610 | ENDDO |
---|
4611 | #endif |
---|
4612 | ENDIF |
---|
4613 | |
---|
4614 | END SUBROUTINE radiation_tendency_ij |
---|
4615 | |
---|
4616 | |
---|
4617 | !------------------------------------------------------------------------------! |
---|
4618 | ! Description: |
---|
4619 | ! ------------ |
---|
4620 | !> Calculate temperature tendency due to radiative cooling/heating. |
---|
4621 | !> Vector-optimized version |
---|
4622 | !------------------------------------------------------------------------------! |
---|
4623 | SUBROUTINE radiation_tendency ( tend ) |
---|
4624 | |
---|
4625 | USE indices, & |
---|
4626 | ONLY: nxl, nxr, nyn, nys |
---|
4627 | |
---|
4628 | IMPLICIT NONE |
---|
4629 | |
---|
4630 | INTEGER(iwp) :: i, j, k !< loop indices |
---|
4631 | |
---|
4632 | REAL(wp), DIMENSION(nzb:nzt+1,nysg:nyng,nxlg:nxrg) :: tend !< pt tendency term |
---|
4633 | |
---|
4634 | IF ( radiation_scheme == 'rrtmg' ) THEN |
---|
4635 | #if defined ( __rrtmg ) |
---|
4636 | ! |
---|
4637 | !-- Calculate tendency based on heating rate |
---|
4638 | DO i = nxl, nxr |
---|
4639 | DO j = nys, nyn |
---|
4640 | DO k = nzb+1, nzt+1 |
---|
4641 | tend(k,j,i) = tend(k,j,i) + ( rad_lw_hr(k,j,i) & |
---|
4642 | + rad_sw_hr(k,j,i) ) * d_exner(k) & |
---|
4643 | * d_seconds_hour |
---|
4644 | ENDDO |
---|
4645 | ENDDO |
---|
4646 | ENDDO |
---|
4647 | #endif |
---|
4648 | ENDIF |
---|
4649 | |
---|
4650 | |
---|
4651 | END SUBROUTINE radiation_tendency |
---|
4652 | |
---|
4653 | !------------------------------------------------------------------------------! |
---|
4654 | ! Description: |
---|
4655 | ! ------------ |
---|
4656 | !> This subroutine calculates interaction of the solar radiation |
---|
4657 | !> with urban and land surfaces and updates all surface heatfluxes. |
---|
4658 | !> It calculates also the required parameters for RRTMG lower BC. |
---|
4659 | !> |
---|
4660 | !> For more info. see Resler et al. 2017 |
---|
4661 | !> |
---|
4662 | !> The new version 2.0 was radically rewriten, the discretization scheme |
---|
4663 | !> has been changed. This new version significantly improves effectivity |
---|
4664 | !> of the paralelization and the scalability of the model. |
---|
4665 | !------------------------------------------------------------------------------! |
---|
4666 | |
---|
4667 | SUBROUTINE radiation_interaction |
---|
4668 | |
---|
4669 | IMPLICIT NONE |
---|
4670 | |
---|
4671 | INTEGER(iwp) :: i, j, k, kk, is, js, d, ku, refstep, m, mm, l, ll |
---|
4672 | INTEGER(iwp) :: isurf, isurfsrc, isvf, icsf, ipcgb |
---|
4673 | INTEGER(iwp) :: imrt, imrtf |
---|
4674 | INTEGER(iwp) :: isd !< solar direction number |
---|
4675 | INTEGER(iwp) :: pc_box_dimshift !< transform for best accuracy |
---|
4676 | INTEGER(iwp), DIMENSION(0:3) :: reorder = (/ 1, 0, 3, 2 /) |
---|
4677 | |
---|
4678 | REAL(wp), DIMENSION(3,3) :: mrot !< grid rotation matrix (zyx) |
---|
4679 | REAL(wp), DIMENSION(3,0:nsurf_type):: vnorm !< face direction normal vectors (zyx) |
---|
4680 | REAL(wp), DIMENSION(3) :: sunorig !< grid rotated solar direction unit vector (zyx) |
---|
4681 | REAL(wp), DIMENSION(3) :: sunorig_grid !< grid squashed solar direction unit vector (zyx) |
---|
4682 | REAL(wp), DIMENSION(0:nsurf_type) :: costheta !< direct irradiance factor of solar angle |
---|
4683 | REAL(wp), DIMENSION(nzub:nzut) :: pchf_prep !< precalculated factor for canopy temperature tendency |
---|
4684 | REAL(wp), PARAMETER :: alpha = 0._wp !< grid rotation (TODO: add to namelist or remove) |
---|
4685 | REAL(wp) :: pc_box_area, pc_abs_frac, pc_abs_eff |
---|
4686 | REAL(wp) :: asrc !< area of source face |
---|
4687 | REAL(wp) :: pcrad !< irradiance from plant canopy |
---|
4688 | REAL(wp) :: pabsswl = 0.0_wp !< total absorbed SW radiation energy in local processor (W) |
---|
4689 | REAL(wp) :: pabssw = 0.0_wp !< total absorbed SW radiation energy in all processors (W) |
---|
4690 | REAL(wp) :: pabslwl = 0.0_wp !< total absorbed LW radiation energy in local processor (W) |
---|
4691 | REAL(wp) :: pabslw = 0.0_wp !< total absorbed LW radiation energy in all processors (W) |
---|
4692 | REAL(wp) :: pemitlwl = 0.0_wp !< total emitted LW radiation energy in all processors (W) |
---|
4693 | REAL(wp) :: pemitlw = 0.0_wp !< total emitted LW radiation energy in all processors (W) |
---|
4694 | REAL(wp) :: pinswl = 0.0_wp !< total received SW radiation energy in local processor (W) |
---|
4695 | REAL(wp) :: pinsw = 0.0_wp !< total received SW radiation energy in all processor (W) |
---|
4696 | REAL(wp) :: pinlwl = 0.0_wp !< total received LW radiation energy in local processor (W) |
---|
4697 | REAL(wp) :: pinlw = 0.0_wp !< total received LW radiation energy in all processor (W) |
---|
4698 | REAL(wp) :: emiss_sum_surfl !< sum of emissisivity of surfaces in local processor |
---|
4699 | REAL(wp) :: emiss_sum_surf !< sum of emissisivity of surfaces in all processor |
---|
4700 | REAL(wp) :: area_surfl !< total area of surfaces in local processor |
---|
4701 | REAL(wp) :: area_surf !< total area of surfaces in all processor |
---|
4702 | REAL(wp) :: area_hor !< total horizontal area of domain in all processor |
---|
4703 | |
---|
4704 | #if ! defined( __nopointer ) |
---|
4705 | IF ( plant_canopy ) THEN |
---|
4706 | pchf_prep(:) = r_d * exner(nzub:nzut) & |
---|
4707 | / (c_p * hyp(nzub:nzut) * dx*dy*dz(1)) !< equals to 1 / (rho * c_p * Vbox * T) |
---|
4708 | ENDIF |
---|
4709 | #endif |
---|
4710 | sun_direction = .TRUE. |
---|
4711 | CALL calc_zenith !< required also for diffusion radiation |
---|
4712 | |
---|
4713 | !-- prepare rotated normal vectors and irradiance factor |
---|
4714 | vnorm(1,:) = kdir(:) |
---|
4715 | vnorm(2,:) = jdir(:) |
---|
4716 | vnorm(3,:) = idir(:) |
---|
4717 | mrot(1, :) = (/ 1._wp, 0._wp, 0._wp /) |
---|
4718 | mrot(2, :) = (/ 0._wp, COS(alpha), SIN(alpha) /) |
---|
4719 | mrot(3, :) = (/ 0._wp, -SIN(alpha), COS(alpha) /) |
---|
4720 | sunorig = (/ zenith(0), sun_dir_lat, sun_dir_lon /) |
---|
4721 | sunorig = MATMUL(mrot, sunorig) |
---|
4722 | DO d = 0, nsurf_type |
---|
4723 | costheta(d) = DOT_PRODUCT(sunorig, vnorm(:,d)) |
---|
4724 | ENDDO |
---|
4725 | |
---|
4726 | IF ( zenith(0) > 0 ) THEN |
---|
4727 | !-- now we will "squash" the sunorig vector by grid box size in |
---|
4728 | !-- each dimension, so that this new direction vector will allow us |
---|
4729 | !-- to traverse the ray path within grid coordinates directly |
---|
4730 | sunorig_grid = (/ sunorig(1)/dz(1), sunorig(2)/dy, sunorig(3)/dx /) |
---|
4731 | !-- sunorig_grid = sunorig_grid / norm2(sunorig_grid) |
---|
4732 | sunorig_grid = sunorig_grid / SQRT(SUM(sunorig_grid**2)) |
---|
4733 | |
---|
4734 | IF ( npcbl > 0 ) THEN |
---|
4735 | !-- precompute effective box depth with prototype Leaf Area Density |
---|
4736 | pc_box_dimshift = MAXLOC(ABS(sunorig), 1) - 1 |
---|
4737 | CALL box_absorb(CSHIFT((/dz(1),dy,dx/), pc_box_dimshift), & |
---|
4738 | 60, prototype_lad, & |
---|
4739 | CSHIFT(ABS(sunorig), pc_box_dimshift), & |
---|
4740 | pc_box_area, pc_abs_frac) |
---|
4741 | pc_box_area = pc_box_area * ABS(sunorig(pc_box_dimshift+1) & |
---|
4742 | / sunorig(1)) |
---|
4743 | pc_abs_eff = LOG(1._wp - pc_abs_frac) / prototype_lad |
---|
4744 | ENDIF |
---|
4745 | ENDIF |
---|
4746 | |
---|
4747 | !-- if radiation scheme is not RRTMG, split diffusion and direct part of the solar downward radiation |
---|
4748 | !-- comming from radiation model and store it in 2D arrays |
---|
4749 | IF ( radiation_scheme /= 'rrtmg' ) CALL calc_diffusion_radiation |
---|
4750 | |
---|
4751 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! |
---|
4752 | !-- First pass: direct + diffuse irradiance + thermal |
---|
4753 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! |
---|
4754 | surfinswdir = 0._wp !nsurfl |
---|
4755 | surfins = 0._wp !nsurfl |
---|
4756 | surfinl = 0._wp !nsurfl |
---|
4757 | surfoutsl(:) = 0.0_wp !start-end |
---|
4758 | surfoutll(:) = 0.0_wp !start-end |
---|
4759 | IF ( nmrtbl > 0 ) THEN |
---|
4760 | mrtinsw(:) = 0._wp |
---|
4761 | mrtinlw(:) = 0._wp |
---|
4762 | ENDIF |
---|
4763 | surfinlg(:) = 0._wp !global |
---|
4764 | |
---|
4765 | |
---|
4766 | !-- Set up thermal radiation from surfaces |
---|
4767 | !-- emiss_surf is defined only for surfaces for which energy balance is calculated |
---|
4768 | !-- Workaround: reorder surface data type back on 1D array including all surfaces, |
---|
4769 | !-- which implies to reorder horizontal and vertical surfaces |
---|
4770 | ! |
---|
4771 | !-- Horizontal walls |
---|
4772 | mm = 1 |
---|
4773 | DO i = nxl, nxr |
---|
4774 | DO j = nys, nyn |
---|
4775 | !-- urban |
---|
4776 | DO m = surf_usm_h%start_index(j,i), surf_usm_h%end_index(j,i) |
---|
4777 | surfoutll(mm) = SUM ( surf_usm_h%frac(:,m) * & |
---|
4778 | surf_usm_h%emissivity(:,m) ) & |
---|
4779 | * sigma_sb & |
---|
4780 | * surf_usm_h%pt_surface(m)**4 |
---|
4781 | albedo_surf(mm) = SUM ( surf_usm_h%frac(:,m) * & |
---|
4782 | surf_usm_h%albedo(:,m) ) |
---|
4783 | emiss_surf(mm) = SUM ( surf_usm_h%frac(:,m) * & |
---|
4784 | surf_usm_h%emissivity(:,m) ) |
---|
4785 | mm = mm + 1 |
---|
4786 | ENDDO |
---|
4787 | !-- land |
---|
4788 | DO m = surf_lsm_h%start_index(j,i), surf_lsm_h%end_index(j,i) |
---|
4789 | surfoutll(mm) = SUM ( surf_lsm_h%frac(:,m) * & |
---|
4790 | surf_lsm_h%emissivity(:,m) ) & |
---|
4791 | * sigma_sb & |
---|
4792 | * surf_lsm_h%pt_surface(m)**4 |
---|
4793 | albedo_surf(mm) = SUM ( surf_lsm_h%frac(:,m) * & |
---|
4794 | surf_lsm_h%albedo(:,m) ) |
---|
4795 | emiss_surf(mm) = SUM ( surf_lsm_h%frac(:,m) * & |
---|
4796 | surf_lsm_h%emissivity(:,m) ) |
---|
4797 | mm = mm + 1 |
---|
4798 | ENDDO |
---|
4799 | ENDDO |
---|
4800 | ENDDO |
---|
4801 | ! |
---|
4802 | !-- Vertical walls |
---|
4803 | DO i = nxl, nxr |
---|
4804 | DO j = nys, nyn |
---|
4805 | DO ll = 0, 3 |
---|
4806 | l = reorder(ll) |
---|
4807 | !-- urban |
---|
4808 | DO m = surf_usm_v(l)%start_index(j,i), & |
---|
4809 | surf_usm_v(l)%end_index(j,i) |
---|
4810 | surfoutll(mm) = SUM ( surf_usm_v(l)%frac(:,m) * & |
---|
4811 | surf_usm_v(l)%emissivity(:,m) ) & |
---|
4812 | * sigma_sb & |
---|
4813 | * surf_usm_v(l)%pt_surface(m)**4 |
---|
4814 | albedo_surf(mm) = SUM ( surf_usm_v(l)%frac(:,m) * & |
---|
4815 | surf_usm_v(l)%albedo(:,m) ) |
---|
4816 | emiss_surf(mm) = SUM ( surf_usm_v(l)%frac(:,m) * & |
---|
4817 | surf_usm_v(l)%emissivity(:,m) ) |
---|
4818 | mm = mm + 1 |
---|
4819 | ENDDO |
---|
4820 | !-- land |
---|
4821 | DO m = surf_lsm_v(l)%start_index(j,i), & |
---|
4822 | surf_lsm_v(l)%end_index(j,i) |
---|
4823 | surfoutll(mm) = SUM ( surf_lsm_v(l)%frac(:,m) * & |
---|
4824 | surf_lsm_v(l)%emissivity(:,m) ) & |
---|
4825 | * sigma_sb & |
---|
4826 | * surf_lsm_v(l)%pt_surface(m)**4 |
---|
4827 | albedo_surf(mm) = SUM ( surf_lsm_v(l)%frac(:,m) * & |
---|
4828 | surf_lsm_v(l)%albedo(:,m) ) |
---|
4829 | emiss_surf(mm) = SUM ( surf_lsm_v(l)%frac(:,m) * & |
---|
4830 | surf_lsm_v(l)%emissivity(:,m) ) |
---|
4831 | mm = mm + 1 |
---|
4832 | ENDDO |
---|
4833 | ENDDO |
---|
4834 | ENDDO |
---|
4835 | ENDDO |
---|
4836 | |
---|
4837 | #if defined( __parallel ) |
---|
4838 | !-- might be optimized and gather only values relevant for current processor |
---|
4839 | CALL MPI_AllGatherv(surfoutll, nsurfl, MPI_REAL, & |
---|
4840 | surfoutl, nsurfs, surfstart, MPI_REAL, comm2d, ierr) !nsurf global |
---|
4841 | IF ( ierr /= 0 ) THEN |
---|
4842 | WRITE(9,*) 'Error MPI_AllGatherv1:', ierr, SIZE(surfoutll), nsurfl, & |
---|
4843 | SIZE(surfoutl), nsurfs, surfstart |
---|
4844 | FLUSH(9) |
---|
4845 | ENDIF |
---|
4846 | #else |
---|
4847 | surfoutl(:) = surfoutll(:) !nsurf global |
---|
4848 | #endif |
---|
4849 | |
---|
4850 | IF ( surface_reflections) THEN |
---|
4851 | DO isvf = 1, nsvfl |
---|
4852 | isurf = svfsurf(1, isvf) |
---|
4853 | k = surfl(iz, isurf) |
---|
4854 | j = surfl(iy, isurf) |
---|
4855 | i = surfl(ix, isurf) |
---|
4856 | isurfsrc = svfsurf(2, isvf) |
---|
4857 | ! |
---|
4858 | !-- For surface-to-surface factors we calculate thermal radiation in 1st pass |
---|
4859 | IF ( plant_lw_interact ) THEN |
---|
4860 | surfinl(isurf) = surfinl(isurf) + svf(1,isvf) * svf(2,isvf) * surfoutl(isurfsrc) |
---|
4861 | ELSE |
---|
4862 | surfinl(isurf) = surfinl(isurf) + svf(1,isvf) * surfoutl(isurfsrc) |
---|
4863 | ENDIF |
---|
4864 | ENDDO |
---|
4865 | ENDIF |
---|
4866 | ! |
---|
4867 | !-- diffuse radiation using sky view factor |
---|
4868 | DO isurf = 1, nsurfl |
---|
4869 | j = surfl(iy, isurf) |
---|
4870 | i = surfl(ix, isurf) |
---|
4871 | surfinswdif(isurf) = rad_sw_in_diff(j,i) * skyvft(isurf) |
---|
4872 | IF ( plant_lw_interact ) THEN |
---|
4873 | surfinlwdif(isurf) = rad_lw_in_diff(j,i) * skyvft(isurf) |
---|
4874 | ELSE |
---|
4875 | surfinlwdif(isurf) = rad_lw_in_diff(j,i) * skyvf(isurf) |
---|
4876 | ENDIF |
---|
4877 | ENDDO |
---|
4878 | ! |
---|
4879 | !-- MRT diffuse irradiance |
---|
4880 | DO imrt = 1, nmrtbl |
---|
4881 | j = mrtbl(iy, imrt) |
---|
4882 | i = mrtbl(ix, imrt) |
---|
4883 | mrtinsw(imrt) = mrtskyt(imrt) * rad_sw_in_diff(j,i) |
---|
4884 | mrtinlw(imrt) = mrtsky(imrt) * rad_lw_in_diff(j,i) |
---|
4885 | ENDDO |
---|
4886 | |
---|
4887 | !-- direct radiation |
---|
4888 | IF ( zenith(0) > 0 ) THEN |
---|
4889 | !--Identify solar direction vector (discretized number) 1) |
---|
4890 | !-- |
---|
4891 | j = FLOOR(ACOS(zenith(0)) / pi * raytrace_discrete_elevs) |
---|
4892 | i = MODULO(NINT(ATAN2(sun_dir_lon(0), sun_dir_lat(0)) & |
---|
4893 | / (2._wp*pi) * raytrace_discrete_azims-.5_wp, iwp), & |
---|
4894 | raytrace_discrete_azims) |
---|
4895 | isd = dsidir_rev(j, i) |
---|
4896 | !-- TODO: check if isd = -1 to report that this solar position is not precalculated |
---|
4897 | DO isurf = 1, nsurfl |
---|
4898 | j = surfl(iy, isurf) |
---|
4899 | i = surfl(ix, isurf) |
---|
4900 | surfinswdir(isurf) = rad_sw_in_dir(j,i) * & |
---|
4901 | costheta(surfl(id, isurf)) * dsitrans(isurf, isd) / zenith(0) |
---|
4902 | ENDDO |
---|
4903 | ! |
---|
4904 | !-- MRT direct irradiance |
---|
4905 | DO imrt = 1, nmrtbl |
---|
4906 | j = mrtbl(iy, imrt) |
---|
4907 | i = mrtbl(ix, imrt) |
---|
4908 | mrtinsw(imrt) = mrtinsw(imrt) + mrtdsit(imrt, isd) * rad_sw_in_dir(j,i) & |
---|
4909 | / zenith(0) / 4._wp ! normal to sphere |
---|
4910 | ENDDO |
---|
4911 | ENDIF |
---|
4912 | ! |
---|
4913 | !-- MRT first pass thermal |
---|
4914 | DO imrtf = 1, nmrtf |
---|
4915 | imrt = mrtfsurf(1, imrtf) |
---|
4916 | isurfsrc = mrtfsurf(2, imrtf) |
---|
4917 | mrtinlw(imrt) = mrtinlw(imrt) + mrtf(imrtf) * surfoutl(isurfsrc) |
---|
4918 | ENDDO |
---|
4919 | |
---|
4920 | IF ( npcbl > 0 ) THEN |
---|
4921 | |
---|
4922 | pcbinswdir(:) = 0._wp |
---|
4923 | pcbinswdif(:) = 0._wp |
---|
4924 | pcbinlw(:) = 0._wp |
---|
4925 | ! |
---|
4926 | !-- pcsf first pass |
---|
4927 | DO icsf = 1, ncsfl |
---|
4928 | ipcgb = csfsurf(1, icsf) |
---|
4929 | i = pcbl(ix,ipcgb) |
---|
4930 | j = pcbl(iy,ipcgb) |
---|
4931 | k = pcbl(iz,ipcgb) |
---|
4932 | isurfsrc = csfsurf(2, icsf) |
---|
4933 | |
---|
4934 | IF ( isurfsrc == -1 ) THEN |
---|
4935 | ! |
---|
4936 | !-- Diffuse rad from sky. |
---|
4937 | pcbinswdif(ipcgb) = csf(1,icsf) * rad_sw_in_diff(j,i) |
---|
4938 | ! |
---|
4939 | !-- Absorbed diffuse LW from sky minus emitted to sky |
---|
4940 | IF ( plant_lw_interact ) THEN |
---|
4941 | pcbinlw(ipcgb) = csf(1,icsf) & |
---|
4942 | * (rad_lw_in_diff(j, i) & |
---|
4943 | - sigma_sb * (pt(k,j,i)*exner(k))**4) |
---|
4944 | ENDIF |
---|
4945 | ! |
---|
4946 | !-- Direct rad |
---|
4947 | IF ( zenith(0) > 0 ) THEN |
---|
4948 | !-- Estimate directed box absorption |
---|
4949 | pc_abs_frac = 1._wp - exp(pc_abs_eff * lad_s(k,j,i)) |
---|
4950 | ! |
---|
4951 | !-- isd has already been established, see 1) |
---|
4952 | pcbinswdir(ipcgb) = rad_sw_in_dir(j, i) * pc_box_area & |
---|
4953 | * pc_abs_frac * dsitransc(ipcgb, isd) |
---|
4954 | ENDIF |
---|
4955 | ELSE |
---|
4956 | IF ( plant_lw_interact ) THEN |
---|
4957 | ! |
---|
4958 | !-- Thermal emission from plan canopy towards respective face |
---|
4959 | pcrad = sigma_sb * (pt(k,j,i) * exner(k))**4 * csf(1,icsf) |
---|
4960 | surfinlg(isurfsrc) = surfinlg(isurfsrc) + pcrad |
---|
4961 | ! |
---|
4962 | !-- Remove the flux above + absorb LW from first pass from surfaces |
---|
4963 | asrc = facearea(surf(id, isurfsrc)) |
---|
4964 | pcbinlw(ipcgb) = pcbinlw(ipcgb) & |
---|
4965 | + (csf(1,icsf) * surfoutl(isurfsrc) & ! Absorb from first pass surf emit |
---|
4966 | - pcrad) & ! Remove emitted heatflux |
---|
4967 | * asrc |
---|
4968 | ENDIF |
---|
4969 | ENDIF |
---|
4970 | ENDDO |
---|
4971 | |
---|
4972 | pcbinsw(:) = pcbinswdir(:) + pcbinswdif(:) |
---|
4973 | ENDIF |
---|
4974 | |
---|
4975 | IF ( plant_lw_interact ) THEN |
---|
4976 | ! |
---|
4977 | !-- Exchange incoming lw radiation from plant canopy |
---|
4978 | #if defined( __parallel ) |
---|
4979 | CALL MPI_Allreduce(MPI_IN_PLACE, surfinlg, nsurf, MPI_REAL, MPI_SUM, comm2d, ierr) |
---|
4980 | IF ( ierr /= 0 ) THEN |
---|
4981 | WRITE (9,*) 'Error MPI_Allreduce:', ierr |
---|
4982 | FLUSH(9) |
---|
4983 | ENDIF |
---|
4984 | surfinl(:) = surfinl(:) + surfinlg(surfstart(myid)+1:surfstart(myid+1)) |
---|
4985 | #else |
---|
4986 | surfinl(:) = surfinl(:) + surfinlg(:) |
---|
4987 | #endif |
---|
4988 | ENDIF |
---|
4989 | |
---|
4990 | surfins = surfinswdir + surfinswdif |
---|
4991 | surfinl = surfinl + surfinlwdif |
---|
4992 | surfinsw = surfins |
---|
4993 | surfinlw = surfinl |
---|
4994 | surfoutsw = 0.0_wp |
---|
4995 | surfoutlw = surfoutll |
---|
4996 | surfemitlwl = surfoutll |
---|
4997 | |
---|
4998 | IF ( .NOT. surface_reflections ) THEN |
---|
4999 | ! |
---|
5000 | !-- Set nrefsteps to 0 to disable reflections |
---|
5001 | nrefsteps = 0 |
---|
5002 | surfoutsl = albedo_surf * surfins |
---|
5003 | surfoutll = (1._wp - emiss_surf) * surfinl |
---|
5004 | surfoutsw = surfoutsw + surfoutsl |
---|
5005 | surfoutlw = surfoutlw + surfoutll |
---|
5006 | ENDIF |
---|
5007 | |
---|
5008 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! |
---|
5009 | !-- Next passes - reflections |
---|
5010 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! |
---|
5011 | DO refstep = 1, nrefsteps |
---|
5012 | |
---|
5013 | surfoutsl = albedo_surf * surfins |
---|
5014 | !-- for non-transparent surfaces, longwave albedo is 1 - emissivity |
---|
5015 | surfoutll = (1._wp - emiss_surf) * surfinl |
---|
5016 | |
---|
5017 | #if defined( __parallel ) |
---|
5018 | CALL MPI_AllGatherv(surfoutsl, nsurfl, MPI_REAL, & |
---|
5019 | surfouts, nsurfs, surfstart, MPI_REAL, comm2d, ierr) |
---|
5020 | IF ( ierr /= 0 ) THEN |
---|
5021 | WRITE(9,*) 'Error MPI_AllGatherv2:', ierr, SIZE(surfoutsl), nsurfl, & |
---|
5022 | SIZE(surfouts), nsurfs, surfstart |
---|
5023 | FLUSH(9) |
---|
5024 | ENDIF |
---|
5025 | |
---|
5026 | CALL MPI_AllGatherv(surfoutll, nsurfl, MPI_REAL, & |
---|
5027 | surfoutl, nsurfs, surfstart, MPI_REAL, comm2d, ierr) |
---|
5028 | IF ( ierr /= 0 ) THEN |
---|
5029 | WRITE(9,*) 'Error MPI_AllGatherv3:', ierr, SIZE(surfoutll), nsurfl, & |
---|
5030 | SIZE(surfoutl), nsurfs, surfstart |
---|
5031 | FLUSH(9) |
---|
5032 | ENDIF |
---|
5033 | |
---|
5034 | #else |
---|
5035 | surfouts = surfoutsl |
---|
5036 | surfoutl = surfoutll |
---|
5037 | #endif |
---|
5038 | |
---|
5039 | !-- reset for next pass input |
---|
5040 | surfins = 0._wp |
---|
5041 | surfinl = 0._wp |
---|
5042 | |
---|
5043 | !-- reflected radiation |
---|
5044 | DO isvf = 1, nsvfl |
---|
5045 | isurf = svfsurf(1, isvf) |
---|
5046 | isurfsrc = svfsurf(2, isvf) |
---|
5047 | surfins(isurf) = surfins(isurf) + svf(1,isvf) * svf(2,isvf) * surfouts(isurfsrc) |
---|
5048 | IF ( plant_lw_interact ) THEN |
---|
5049 | surfinl(isurf) = surfinl(isurf) + svf(1,isvf) * svf(2,isvf) * surfoutl(isurfsrc) |
---|
5050 | ELSE |
---|
5051 | surfinl(isurf) = surfinl(isurf) + svf(1,isvf) * surfoutl(isurfsrc) |
---|
5052 | ENDIF |
---|
5053 | ENDDO |
---|
5054 | ! |
---|
5055 | !-- NOTE: PC absorbtion and MRT from reflected can both be done at once |
---|
5056 | !-- after all reflections if we do one more MPI_ALLGATHERV on surfout. |
---|
5057 | !-- Advantage: less local computation. Disadvantage: one more collective |
---|
5058 | !-- MPI call. |
---|
5059 | ! |
---|
5060 | !-- Radiation absorbed by plant canopy |
---|
5061 | DO icsf = 1, ncsfl |
---|
5062 | ipcgb = csfsurf(1, icsf) |
---|
5063 | isurfsrc = csfsurf(2, icsf) |
---|
5064 | IF ( isurfsrc == -1 ) CYCLE ! sky->face only in 1st pass, not here |
---|
5065 | ! |
---|
5066 | !-- Calculate source surface area. If the `surf' array is removed |
---|
5067 | !-- before timestepping starts (future version), then asrc must be |
---|
5068 | !-- stored within `csf' |
---|
5069 | asrc = facearea(surf(id, isurfsrc)) |
---|
5070 | pcbinsw(ipcgb) = pcbinsw(ipcgb) + csf(1,icsf) * surfouts(isurfsrc) * asrc |
---|
5071 | IF ( plant_lw_interact ) THEN |
---|
5072 | pcbinlw(ipcgb) = pcbinlw(ipcgb) + csf(1,icsf) * surfoutl(isurfsrc) * asrc |
---|
5073 | ENDIF |
---|
5074 | ENDDO |
---|
5075 | ! |
---|
5076 | !-- MRT reflected |
---|
5077 | DO imrtf = 1, nmrtf |
---|
5078 | imrt = mrtfsurf(1, imrtf) |
---|
5079 | isurfsrc = mrtfsurf(2, imrtf) |
---|
5080 | mrtinsw(imrt) = mrtinsw(imrt) + mrtft(imrtf) * surfouts(isurfsrc) |
---|
5081 | mrtinlw(imrt) = mrtinlw(imrt) + mrtf(imrtf) * surfoutl(isurfsrc) |
---|
5082 | ENDDO |
---|
5083 | |
---|
5084 | surfinsw = surfinsw + surfins |
---|
5085 | surfinlw = surfinlw + surfinl |
---|
5086 | surfoutsw = surfoutsw + surfoutsl |
---|
5087 | surfoutlw = surfoutlw + surfoutll |
---|
5088 | |
---|
5089 | ENDDO ! refstep |
---|
5090 | |
---|
5091 | !-- push heat flux absorbed by plant canopy to respective 3D arrays |
---|
5092 | IF ( npcbl > 0 ) THEN |
---|
5093 | pc_heating_rate(:,:,:) = 0.0_wp |
---|
5094 | DO ipcgb = 1, npcbl |
---|
5095 | j = pcbl(iy, ipcgb) |
---|
5096 | i = pcbl(ix, ipcgb) |
---|
5097 | k = pcbl(iz, ipcgb) |
---|
5098 | ! |
---|
5099 | !-- Following expression equals former kk = k - nzb_s_inner(j,i) |
---|
5100 | kk = k - get_topography_top_index_ji( j, i, 's' ) !- lad arrays are defined flat |
---|
5101 | pc_heating_rate(kk, j, i) = (pcbinsw(ipcgb) + pcbinlw(ipcgb)) & |
---|
5102 | * pchf_prep(k) * pt(k, j, i) !-- = dT/dt |
---|
5103 | ENDDO |
---|
5104 | |
---|
5105 | IF ( humidity .AND. plant_canopy_transpiration ) THEN |
---|
5106 | !-- Calculation of plant canopy transpiration rate and correspondidng latent heat rate |
---|
5107 | pc_transpiration_rate(:,:,:) = 0.0_wp |
---|
5108 | pc_latent_rate(:,:,:) = 0.0_wp |
---|
5109 | DO ipcgb = 1, npcbl |
---|
5110 | i = pcbl(ix, ipcgb) |
---|
5111 | j = pcbl(iy, ipcgb) |
---|
5112 | k = pcbl(iz, ipcgb) |
---|
5113 | kk = k - get_topography_top_index_ji( j, i, 's' ) !- lad arrays are defined flat |
---|
5114 | CALL pcm_calc_transpiration_rate( i, j, k, kk, pcbinsw(ipcgb), pcbinlw(ipcgb), & |
---|
5115 | pc_transpiration_rate(kk,j,i), pc_latent_rate(kk,j,i) ) |
---|
5116 | ENDDO |
---|
5117 | ENDIF |
---|
5118 | ENDIF |
---|
5119 | ! |
---|
5120 | !-- Calculate black body MRT (after all reflections) |
---|
5121 | IF ( nmrtbl > 0 ) THEN |
---|
5122 | IF ( mrt_include_sw ) THEN |
---|
5123 | mrt(:) = ((mrtinsw(:) + mrtinlw(:)) / sigma_sb) ** .25_wp |
---|
5124 | ELSE |
---|
5125 | mrt(:) = (mrtinlw(:) / sigma_sb) ** .25_wp |
---|
5126 | ENDIF |
---|
5127 | ENDIF |
---|
5128 | ! |
---|
5129 | !-- Transfer radiation arrays required for energy balance to the respective data types |
---|
5130 | DO i = 1, nsurfl |
---|
5131 | m = surfl(5,i) |
---|
5132 | ! |
---|
5133 | !-- (1) Urban surfaces |
---|
5134 | !-- upward-facing |
---|
5135 | IF ( surfl(1,i) == iup_u ) THEN |
---|
5136 | surf_usm_h%rad_sw_in(m) = surfinsw(i) |
---|
5137 | surf_usm_h%rad_sw_out(m) = surfoutsw(i) |
---|
5138 | surf_usm_h%rad_lw_in(m) = surfinlw(i) |
---|
5139 | surf_usm_h%rad_lw_out(m) = surfoutlw(i) |
---|
5140 | surf_usm_h%rad_net(m) = surfinsw(i) - surfoutsw(i) + & |
---|
5141 | surfinlw(i) - surfoutlw(i) |
---|
5142 | surf_usm_h%rad_net_l(m) = surf_usm_h%rad_net(m) |
---|
5143 | ! |
---|
5144 | !-- northward-facding |
---|
5145 | ELSEIF ( surfl(1,i) == inorth_u ) THEN |
---|
5146 | surf_usm_v(0)%rad_sw_in(m) = surfinsw(i) |
---|
5147 | surf_usm_v(0)%rad_sw_out(m) = surfoutsw(i) |
---|
5148 | surf_usm_v(0)%rad_lw_in(m) = surfinlw(i) |
---|
5149 | surf_usm_v(0)%rad_lw_out(m) = surfoutlw(i) |
---|
5150 | surf_usm_v(0)%rad_net(m) = surfinsw(i) - surfoutsw(i) + & |
---|
5151 | surfinlw(i) - surfoutlw(i) |
---|
5152 | surf_usm_v(0)%rad_net_l(m) = surf_usm_v(0)%rad_net(m) |
---|
5153 | ! |
---|
5154 | !-- southward-facding |
---|
5155 | ELSEIF ( surfl(1,i) == isouth_u ) THEN |
---|
5156 | surf_usm_v(1)%rad_sw_in(m) = surfinsw(i) |
---|
5157 | surf_usm_v(1)%rad_sw_out(m) = surfoutsw(i) |
---|
5158 | surf_usm_v(1)%rad_lw_in(m) = surfinlw(i) |
---|
5159 | surf_usm_v(1)%rad_lw_out(m) = surfoutlw(i) |
---|
5160 | surf_usm_v(1)%rad_net(m) = surfinsw(i) - surfoutsw(i) + & |
---|
5161 | surfinlw(i) - surfoutlw(i) |
---|
5162 | surf_usm_v(1)%rad_net_l(m) = surf_usm_v(1)%rad_net(m) |
---|
5163 | ! |
---|
5164 | !-- eastward-facing |
---|
5165 | ELSEIF ( surfl(1,i) == ieast_u ) THEN |
---|
5166 | surf_usm_v(2)%rad_sw_in(m) = surfinsw(i) |
---|
5167 | surf_usm_v(2)%rad_sw_out(m) = surfoutsw(i) |
---|
5168 | surf_usm_v(2)%rad_lw_in(m) = surfinlw(i) |
---|
5169 | surf_usm_v(2)%rad_lw_out(m) = surfoutlw(i) |
---|
5170 | surf_usm_v(2)%rad_net(m) = surfinsw(i) - surfoutsw(i) + & |
---|
5171 | surfinlw(i) - surfoutlw(i) |
---|
5172 | surf_usm_v(2)%rad_net_l(m) = surf_usm_v(2)%rad_net(m) |
---|
5173 | ! |
---|
5174 | !-- westward-facding |
---|
5175 | ELSEIF ( surfl(1,i) == iwest_u ) THEN |
---|
5176 | surf_usm_v(3)%rad_sw_in(m) = surfinsw(i) |
---|
5177 | surf_usm_v(3)%rad_sw_out(m) = surfoutsw(i) |
---|
5178 | surf_usm_v(3)%rad_lw_in(m) = surfinlw(i) |
---|
5179 | surf_usm_v(3)%rad_lw_out(m) = surfoutlw(i) |
---|
5180 | surf_usm_v(3)%rad_net(m) = surfinsw(i) - surfoutsw(i) + & |
---|
5181 | surfinlw(i) - surfoutlw(i) |
---|
5182 | surf_usm_v(3)%rad_net_l(m) = surf_usm_v(3)%rad_net(m) |
---|
5183 | ! |
---|
5184 | !-- (2) land surfaces |
---|
5185 | !-- upward-facing |
---|
5186 | ELSEIF ( surfl(1,i) == iup_l ) THEN |
---|
5187 | surf_lsm_h%rad_sw_in(m) = surfinsw(i) |
---|
5188 | surf_lsm_h%rad_sw_out(m) = surfoutsw(i) |
---|
5189 | surf_lsm_h%rad_lw_in(m) = surfinlw(i) |
---|
5190 | surf_lsm_h%rad_lw_out(m) = surfoutlw(i) |
---|
5191 | surf_lsm_h%rad_net(m) = surfinsw(i) - surfoutsw(i) + & |
---|
5192 | surfinlw(i) - surfoutlw(i) |
---|
5193 | ! |
---|
5194 | !-- northward-facding |
---|
5195 | ELSEIF ( surfl(1,i) == inorth_l ) THEN |
---|
5196 | surf_lsm_v(0)%rad_sw_in(m) = surfinsw(i) |
---|
5197 | surf_lsm_v(0)%rad_sw_out(m) = surfoutsw(i) |
---|
5198 | surf_lsm_v(0)%rad_lw_in(m) = surfinlw(i) |
---|
5199 | surf_lsm_v(0)%rad_lw_out(m) = surfoutlw(i) |
---|
5200 | surf_lsm_v(0)%rad_net(m) = surfinsw(i) - surfoutsw(i) + & |
---|
5201 | surfinlw(i) - surfoutlw(i) |
---|
5202 | ! |
---|
5203 | !-- southward-facding |
---|
5204 | ELSEIF ( surfl(1,i) == isouth_l ) THEN |
---|
5205 | surf_lsm_v(1)%rad_sw_in(m) = surfinsw(i) |
---|
5206 | surf_lsm_v(1)%rad_sw_out(m) = surfoutsw(i) |
---|
5207 | surf_lsm_v(1)%rad_lw_in(m) = surfinlw(i) |
---|
5208 | surf_lsm_v(1)%rad_lw_out(m) = surfoutlw(i) |
---|
5209 | surf_lsm_v(1)%rad_net(m) = surfinsw(i) - surfoutsw(i) + & |
---|
5210 | surfinlw(i) - surfoutlw(i) |
---|
5211 | ! |
---|
5212 | !-- eastward-facing |
---|
5213 | ELSEIF ( surfl(1,i) == ieast_l ) THEN |
---|
5214 | surf_lsm_v(2)%rad_sw_in(m) = surfinsw(i) |
---|
5215 | surf_lsm_v(2)%rad_sw_out(m) = surfoutsw(i) |
---|
5216 | surf_lsm_v(2)%rad_lw_in(m) = surfinlw(i) |
---|
5217 | surf_lsm_v(2)%rad_lw_out(m) = surfoutlw(i) |
---|
5218 | surf_lsm_v(2)%rad_net(m) = surfinsw(i) - surfoutsw(i) + & |
---|
5219 | surfinlw(i) - surfoutlw(i) |
---|
5220 | ! |
---|
5221 | !-- westward-facing |
---|
5222 | ELSEIF ( surfl(1,i) == iwest_l ) THEN |
---|
5223 | surf_lsm_v(3)%rad_sw_in(m) = surfinsw(i) |
---|
5224 | surf_lsm_v(3)%rad_sw_out(m) = surfoutsw(i) |
---|
5225 | surf_lsm_v(3)%rad_lw_in(m) = surfinlw(i) |
---|
5226 | surf_lsm_v(3)%rad_lw_out(m) = surfoutlw(i) |
---|
5227 | surf_lsm_v(3)%rad_net(m) = surfinsw(i) - surfoutsw(i) + & |
---|
5228 | surfinlw(i) - surfoutlw(i) |
---|
5229 | ENDIF |
---|
5230 | |
---|
5231 | ENDDO |
---|
5232 | |
---|
5233 | DO m = 1, surf_usm_h%ns |
---|
5234 | surf_usm_h%surfhf(m) = surf_usm_h%rad_sw_in(m) + & |
---|
5235 | surf_usm_h%rad_lw_in(m) - & |
---|
5236 | surf_usm_h%rad_sw_out(m) - & |
---|
5237 | surf_usm_h%rad_lw_out(m) |
---|
5238 | ENDDO |
---|
5239 | DO m = 1, surf_lsm_h%ns |
---|
5240 | surf_lsm_h%surfhf(m) = surf_lsm_h%rad_sw_in(m) + & |
---|
5241 | surf_lsm_h%rad_lw_in(m) - & |
---|
5242 | surf_lsm_h%rad_sw_out(m) - & |
---|
5243 | surf_lsm_h%rad_lw_out(m) |
---|
5244 | ENDDO |
---|
5245 | |
---|
5246 | DO l = 0, 3 |
---|
5247 | !-- urban |
---|
5248 | DO m = 1, surf_usm_v(l)%ns |
---|
5249 | surf_usm_v(l)%surfhf(m) = surf_usm_v(l)%rad_sw_in(m) + & |
---|
5250 | surf_usm_v(l)%rad_lw_in(m) - & |
---|
5251 | surf_usm_v(l)%rad_sw_out(m) - & |
---|
5252 | surf_usm_v(l)%rad_lw_out(m) |
---|
5253 | ENDDO |
---|
5254 | !-- land |
---|
5255 | DO m = 1, surf_lsm_v(l)%ns |
---|
5256 | surf_lsm_v(l)%surfhf(m) = surf_lsm_v(l)%rad_sw_in(m) + & |
---|
5257 | surf_lsm_v(l)%rad_lw_in(m) - & |
---|
5258 | surf_lsm_v(l)%rad_sw_out(m) - & |
---|
5259 | surf_lsm_v(l)%rad_lw_out(m) |
---|
5260 | |
---|
5261 | ENDDO |
---|
5262 | ENDDO |
---|
5263 | ! |
---|
5264 | !-- Calculate the average temperature, albedo, and emissivity for urban/land |
---|
5265 | !-- domain when using average_radiation in the respective radiation model |
---|
5266 | |
---|
5267 | !-- calculate horizontal area |
---|
5268 | ! !!! ATTENTION!!! uniform grid is assumed here |
---|
5269 | area_hor = (nx+1) * (ny+1) * dx * dy |
---|
5270 | ! |
---|
5271 | !-- absorbed/received SW & LW and emitted LW energy of all physical |
---|
5272 | !-- surfaces (land and urban) in local processor |
---|
5273 | pinswl = 0._wp |
---|
5274 | pinlwl = 0._wp |
---|
5275 | pabsswl = 0._wp |
---|
5276 | pabslwl = 0._wp |
---|
5277 | pemitlwl = 0._wp |
---|
5278 | emiss_sum_surfl = 0._wp |
---|
5279 | area_surfl = 0._wp |
---|
5280 | DO i = 1, nsurfl |
---|
5281 | d = surfl(id, i) |
---|
5282 | !-- received SW & LW |
---|
5283 | pinswl = pinswl + (surfinswdir(i) + surfinswdif(i)) * facearea(d) |
---|
5284 | pinlwl = pinlwl + surfinlwdif(i) * facearea(d) |
---|
5285 | !-- absorbed SW & LW |
---|
5286 | pabsswl = pabsswl + (1._wp - albedo_surf(i)) * & |
---|
5287 | surfinsw(i) * facearea(d) |
---|
5288 | pabslwl = pabslwl + emiss_surf(i) * surfinlw(i) * facearea(d) |
---|
5289 | !-- emitted LW |
---|
5290 | pemitlwl = pemitlwl + surfemitlwl(i) * facearea(d) |
---|
5291 | !-- emissivity and area sum |
---|
5292 | emiss_sum_surfl = emiss_sum_surfl + emiss_surf(i) * facearea(d) |
---|
5293 | area_surfl = area_surfl + facearea(d) |
---|
5294 | END DO |
---|
5295 | ! |
---|
5296 | !-- add the absorbed SW energy by plant canopy |
---|
5297 | IF ( npcbl > 0 ) THEN |
---|
5298 | pabsswl = pabsswl + SUM(pcbinsw) |
---|
5299 | pabslwl = pabslwl + SUM(pcbinlw) |
---|
5300 | pinswl = pinswl + SUM(pcbinswdir) + SUM(pcbinswdif) |
---|
5301 | ENDIF |
---|
5302 | ! |
---|
5303 | !-- gather all rad flux energy in all processors |
---|
5304 | #if defined( __parallel ) |
---|
5305 | CALL MPI_ALLREDUCE( pinswl, pinsw, 1, MPI_REAL, MPI_SUM, comm2d, ierr) |
---|
5306 | IF ( ierr /= 0 ) THEN |
---|
5307 | WRITE(9,*) 'Error MPI_AllReduce5:', ierr, pinswl, pinsw |
---|
5308 | FLUSH(9) |
---|
5309 | ENDIF |
---|
5310 | CALL MPI_ALLREDUCE( pinlwl, pinlw, 1, MPI_REAL, MPI_SUM, comm2d, ierr) |
---|
5311 | IF ( ierr /= 0 ) THEN |
---|
5312 | WRITE(9,*) 'Error MPI_AllReduce6:', ierr, pinlwl, pinlw |
---|
5313 | FLUSH(9) |
---|
5314 | ENDIF |
---|
5315 | CALL MPI_ALLREDUCE( pabsswl, pabssw, 1, MPI_REAL, MPI_SUM, comm2d, ierr ) |
---|
5316 | IF ( ierr /= 0 ) THEN |
---|
5317 | WRITE(9,*) 'Error MPI_AllReduce7:', ierr, pabsswl, pabssw |
---|
5318 | FLUSH(9) |
---|
5319 | ENDIF |
---|
5320 | CALL MPI_ALLREDUCE( pabslwl, pabslw, 1, MPI_REAL, MPI_SUM, comm2d, ierr ) |
---|
5321 | IF ( ierr /= 0 ) THEN |
---|
5322 | WRITE(9,*) 'Error MPI_AllReduce8:', ierr, pabslwl, pabslw |
---|
5323 | FLUSH(9) |
---|
5324 | ENDIF |
---|
5325 | CALL MPI_ALLREDUCE( pemitlwl, pemitlw, 1, MPI_REAL, MPI_SUM, comm2d, ierr ) |
---|
5326 | IF ( ierr /= 0 ) THEN |
---|
5327 | WRITE(9,*) 'Error MPI_AllReduce8:', ierr, pemitlwl, pemitlw |
---|
5328 | FLUSH(9) |
---|
5329 | ENDIF |
---|
5330 | CALL MPI_ALLREDUCE( emiss_sum_surfl, emiss_sum_surf, 1, MPI_REAL, MPI_SUM, comm2d, ierr ) |
---|
5331 | IF ( ierr /= 0 ) THEN |
---|
5332 | WRITE(9,*) 'Error MPI_AllReduce9:', ierr, emiss_sum_surfl, emiss_sum_surf |
---|
5333 | FLUSH(9) |
---|
5334 | ENDIF |
---|
5335 | CALL MPI_ALLREDUCE( area_surfl, area_surf, 1, MPI_REAL, MPI_SUM, comm2d, ierr ) |
---|
5336 | IF ( ierr /= 0 ) THEN |
---|
5337 | WRITE(9,*) 'Error MPI_AllReduce10:', ierr, area_surfl, area_surf |
---|
5338 | FLUSH(9) |
---|
5339 | ENDIF |
---|
5340 | #else |
---|
5341 | pinsw = pinswl |
---|
5342 | pinlw = pinlwl |
---|
5343 | pabssw = pabsswl |
---|
5344 | pabslw = pabslwl |
---|
5345 | pemitlw = pemitlwl |
---|
5346 | emiss_sum_surf = emiss_sum_surfl |
---|
5347 | area_surf = area_surfl |
---|
5348 | #endif |
---|
5349 | |
---|
5350 | !-- (1) albedo |
---|
5351 | IF ( pinsw /= 0.0_wp ) & |
---|
5352 | albedo_urb = (pinsw - pabssw) / pinsw |
---|
5353 | !-- (2) average emmsivity |
---|
5354 | IF ( area_surf /= 0.0_wp ) & |
---|
5355 | emissivity_urb = emiss_sum_surf / area_surf |
---|
5356 | ! |
---|
5357 | !-- Temporally comment out calculation of effective radiative temperature. |
---|
5358 | !-- See below for more explanation. |
---|
5359 | !-- (3) temperature |
---|
5360 | !-- first we calculate an effective horizontal area to account for |
---|
5361 | !-- the effect of vertical surfaces (which contributes to LW emission) |
---|
5362 | !-- We simply use the ratio of the total LW to the incoming LW flux |
---|
5363 | area_hor = pinlw/rad_lw_in_diff(nyn,nxl) |
---|
5364 | t_rad_urb = ( (pemitlw - pabslw + emissivity_urb*pinlw) / & |
---|
5365 | (emissivity_urb*sigma_sb * area_hor) )**0.25_wp |
---|
5366 | |
---|
5367 | CONTAINS |
---|
5368 | |
---|
5369 | !------------------------------------------------------------------------------! |
---|
5370 | !> Calculates radiation absorbed by box with given size and LAD. |
---|
5371 | !> |
---|
5372 | !> Simulates resol**2 rays (by equally spacing a bounding horizontal square |
---|
5373 | !> conatining all possible rays that would cross the box) and calculates |
---|
5374 | !> average transparency per ray. Returns fraction of absorbed radiation flux |
---|
5375 | !> and area for which this fraction is effective. |
---|
5376 | !------------------------------------------------------------------------------! |
---|
5377 | PURE SUBROUTINE box_absorb(boxsize, resol, dens, uvec, area, absorb) |
---|
5378 | IMPLICIT NONE |
---|
5379 | |
---|
5380 | REAL(wp), DIMENSION(3), INTENT(in) :: & |
---|
5381 | boxsize, & !< z, y, x size of box in m |
---|
5382 | uvec !< z, y, x unit vector of incoming flux |
---|
5383 | INTEGER(iwp), INTENT(in) :: & |
---|
5384 | resol !< No. of rays in x and y dimensions |
---|
5385 | REAL(wp), INTENT(in) :: & |
---|
5386 | dens !< box density (e.g. Leaf Area Density) |
---|
5387 | REAL(wp), INTENT(out) :: & |
---|
5388 | area, & !< horizontal area for flux absorbtion |
---|
5389 | absorb !< fraction of absorbed flux |
---|
5390 | REAL(wp) :: & |
---|
5391 | xshift, yshift, & |
---|
5392 | xmin, xmax, ymin, ymax, & |
---|
5393 | xorig, yorig, & |
---|
5394 | dx1, dy1, dz1, dx2, dy2, dz2, & |
---|
5395 | crdist, & |
---|
5396 | transp |
---|
5397 | INTEGER(iwp) :: & |
---|
5398 | i, j |
---|
5399 | |
---|
5400 | xshift = uvec(3) / uvec(1) * boxsize(1) |
---|
5401 | xmin = min(0._wp, -xshift) |
---|
5402 | xmax = boxsize(3) + max(0._wp, -xshift) |
---|
5403 | yshift = uvec(2) / uvec(1) * boxsize(1) |
---|
5404 | ymin = min(0._wp, -yshift) |
---|
5405 | ymax = boxsize(2) + max(0._wp, -yshift) |
---|
5406 | |
---|
5407 | transp = 0._wp |
---|
5408 | DO i = 1, resol |
---|
5409 | xorig = xmin + (xmax-xmin) * (i-.5_wp) / resol |
---|
5410 | DO j = 1, resol |
---|
5411 | yorig = ymin + (ymax-ymin) * (j-.5_wp) / resol |
---|
5412 | |
---|
5413 | dz1 = 0._wp |
---|
5414 | dz2 = boxsize(1)/uvec(1) |
---|
5415 | |
---|
5416 | IF ( uvec(2) > 0._wp ) THEN |
---|
5417 | dy1 = -yorig / uvec(2) !< crossing with y=0 |
---|
5418 | dy2 = (boxsize(2)-yorig) / uvec(2) !< crossing with y=boxsize(2) |
---|
5419 | ELSE !uvec(2)==0 |
---|
5420 | dy1 = -huge(1._wp) |
---|
5421 | dy2 = huge(1._wp) |
---|
5422 | ENDIF |
---|
5423 | |
---|
5424 | IF ( uvec(3) > 0._wp ) THEN |
---|
5425 | dx1 = -xorig / uvec(3) !< crossing with x=0 |
---|
5426 | dx2 = (boxsize(3)-xorig) / uvec(3) !< crossing with x=boxsize(3) |
---|
5427 | ELSE !uvec(3)==0 |
---|
5428 | dx1 = -huge(1._wp) |
---|
5429 | dx2 = huge(1._wp) |
---|
5430 | ENDIF |
---|
5431 | |
---|
5432 | crdist = max(0._wp, (min(dz2, dy2, dx2) - max(dz1, dy1, dx1))) |
---|
5433 | transp = transp + exp(-ext_coef * dens * crdist) |
---|
5434 | ENDDO |
---|
5435 | ENDDO |
---|
5436 | transp = transp / resol**2 |
---|
5437 | area = (boxsize(3)+xshift)*(boxsize(2)+yshift) |
---|
5438 | absorb = 1._wp - transp |
---|
5439 | |
---|
5440 | END SUBROUTINE box_absorb |
---|
5441 | |
---|
5442 | !------------------------------------------------------------------------------! |
---|
5443 | ! Description: |
---|
5444 | ! ------------ |
---|
5445 | !> This subroutine splits direct and diffusion dw radiation |
---|
5446 | !> It sould not be called in case the radiation model already does it |
---|
5447 | !> It follows <CITATION> |
---|
5448 | !------------------------------------------------------------------------------! |
---|
5449 | SUBROUTINE calc_diffusion_radiation |
---|
5450 | |
---|
5451 | REAL(wp), PARAMETER :: lowest_solarUp = 0.1_wp !< limit the sun elevation to protect stability of the calculation |
---|
5452 | INTEGER(iwp) :: i, j |
---|
5453 | REAL(wp) :: year_angle !< angle |
---|
5454 | REAL(wp) :: etr !< extraterestrial radiation |
---|
5455 | REAL(wp) :: corrected_solarUp !< corrected solar up radiation |
---|
5456 | REAL(wp) :: horizontalETR !< horizontal extraterestrial radiation |
---|
5457 | REAL(wp) :: clearnessIndex !< clearness index |
---|
5458 | REAL(wp) :: diff_frac !< diffusion fraction of the radiation |
---|
5459 | |
---|
5460 | |
---|
5461 | !-- Calculate current day and time based on the initial values and simulation time |
---|
5462 | year_angle = ( (day_of_year_init * 86400) + time_utc_init & |
---|
5463 | + time_since_reference_point ) * d_seconds_year & |
---|
5464 | * 2.0_wp * pi |
---|
5465 | |
---|
5466 | etr = solar_constant * (1.00011_wp + & |
---|
5467 | 0.034221_wp * cos(year_angle) + & |
---|
5468 | 0.001280_wp * sin(year_angle) + & |
---|
5469 | 0.000719_wp * cos(2.0_wp * year_angle) + & |
---|
5470 | 0.000077_wp * sin(2.0_wp * year_angle)) |
---|
5471 | |
---|
5472 | !-- |
---|
5473 | !-- Under a very low angle, we keep extraterestrial radiation at |
---|
5474 | !-- the last small value, therefore the clearness index will be pushed |
---|
5475 | !-- towards 0 while keeping full continuity. |
---|
5476 | !-- |
---|
5477 | IF ( zenith(0) <= lowest_solarUp ) THEN |
---|
5478 | corrected_solarUp = lowest_solarUp |
---|
5479 | ELSE |
---|
5480 | corrected_solarUp = zenith(0) |
---|
5481 | ENDIF |
---|
5482 | |
---|
5483 | horizontalETR = etr * corrected_solarUp |
---|
5484 | |
---|
5485 | DO i = nxl, nxr |
---|
5486 | DO j = nys, nyn |
---|
5487 | clearnessIndex = rad_sw_in(0,j,i) / horizontalETR |
---|
5488 | diff_frac = 1.0_wp / (1.0_wp + exp(-5.0033_wp + 8.6025_wp * clearnessIndex)) |
---|
5489 | rad_sw_in_diff(j,i) = rad_sw_in(0,j,i) * diff_frac |
---|
5490 | rad_sw_in_dir(j,i) = rad_sw_in(0,j,i) * (1.0_wp - diff_frac) |
---|
5491 | rad_lw_in_diff(j,i) = rad_lw_in(0,j,i) |
---|
5492 | ENDDO |
---|
5493 | ENDDO |
---|
5494 | |
---|
5495 | END SUBROUTINE calc_diffusion_radiation |
---|
5496 | |
---|
5497 | |
---|
5498 | END SUBROUTINE radiation_interaction |
---|
5499 | |
---|
5500 | !------------------------------------------------------------------------------! |
---|
5501 | ! Description: |
---|
5502 | ! ------------ |
---|
5503 | !> This subroutine initializes structures needed for radiative transfer |
---|
5504 | !> model. This model calculates transformation processes of the |
---|
5505 | !> radiation inside urban and land canopy layer. The module includes also |
---|
5506 | !> the interaction of the radiation with the resolved plant canopy. |
---|
5507 | !> |
---|
5508 | !> For more info. see Resler et al. 2017 |
---|
5509 | !> |
---|
5510 | !> The new version 2.0 was radically rewriten, the discretization scheme |
---|
5511 | !> has been changed. This new version significantly improves effectivity |
---|
5512 | !> of the paralelization and the scalability of the model. |
---|
5513 | !> |
---|
5514 | !------------------------------------------------------------------------------! |
---|
5515 | SUBROUTINE radiation_interaction_init |
---|
5516 | |
---|
5517 | USE control_parameters, & |
---|
5518 | ONLY: dz_stretch_level_start |
---|
5519 | |
---|
5520 | USE netcdf_data_input_mod, & |
---|
5521 | ONLY: leaf_area_density_f |
---|
5522 | |
---|
5523 | USE plant_canopy_model_mod, & |
---|
5524 | ONLY: pch_index, lad_s |
---|
5525 | |
---|
5526 | IMPLICIT NONE |
---|
5527 | |
---|
5528 | INTEGER(iwp) :: i, j, k, l, m, d |
---|
5529 | INTEGER(iwp) :: k_topo !< vertical index indicating topography top for given (j,i) |
---|
5530 | INTEGER(iwp) :: nzptl, nzubl, nzutl, isurf, ipcgb, imrt |
---|
5531 | REAL(wp) :: mrl |
---|
5532 | #if defined( __parallel ) |
---|
5533 | INTEGER(iwp), DIMENSION(:), POINTER :: gridsurf_rma !< fortran pointer, but lower bounds are 1 |
---|
5534 | TYPE(c_ptr) :: gridsurf_rma_p !< allocated c pointer |
---|
5535 | INTEGER(iwp) :: minfo !< MPI RMA window info handle |
---|
5536 | #endif |
---|
5537 | |
---|
5538 | ! |
---|
5539 | !-- precalculate face areas for different face directions using normal vector |
---|
5540 | DO d = 0, nsurf_type |
---|
5541 | facearea(d) = 1._wp |
---|
5542 | IF ( idir(d) == 0 ) facearea(d) = facearea(d) * dx |
---|
5543 | IF ( jdir(d) == 0 ) facearea(d) = facearea(d) * dy |
---|
5544 | IF ( kdir(d) == 0 ) facearea(d) = facearea(d) * dz(1) |
---|
5545 | ENDDO |
---|
5546 | ! |
---|
5547 | !-- Find nzub, nzut, nzu via wall_flag_0 array (nzb_s_inner will be |
---|
5548 | !-- removed later). The following contruct finds the lowest / largest index |
---|
5549 | !-- for any upward-facing wall (see bit 12). |
---|
5550 | nzubl = MINVAL( get_topography_top_index( 's' ) ) |
---|
5551 | nzutl = MAXVAL( get_topography_top_index( 's' ) ) |
---|
5552 | |
---|
5553 | nzubl = MAX( nzubl, nzb ) |
---|
5554 | |
---|
5555 | IF ( plant_canopy ) THEN |
---|
5556 | !-- allocate needed arrays |
---|
5557 | ALLOCATE( pct(nys:nyn,nxl:nxr) ) |
---|
5558 | ALLOCATE( pch(nys:nyn,nxl:nxr) ) |
---|
5559 | |
---|
5560 | !-- calculate plant canopy height |
---|
5561 | npcbl = 0 |
---|
5562 | pct = 0 |
---|
5563 | pch = 0 |
---|
5564 | DO i = nxl, nxr |
---|
5565 | DO j = nys, nyn |
---|
5566 | ! |
---|
5567 | !-- Find topography top index |
---|
5568 | k_topo = get_topography_top_index_ji( j, i, 's' ) |
---|
5569 | |
---|
5570 | DO k = nzt+1, 0, -1 |
---|
5571 | IF ( lad_s(k,j,i) /= 0.0_wp ) THEN |
---|
5572 | !-- we are at the top of the pcs |
---|
5573 | pct(j,i) = k + k_topo |
---|
5574 | pch(j,i) = k |
---|
5575 | npcbl = npcbl + pch(j,i) |
---|
5576 | EXIT |
---|
5577 | ENDIF |
---|
5578 | ENDDO |
---|
5579 | ENDDO |
---|
5580 | ENDDO |
---|
5581 | |
---|
5582 | nzutl = MAX( nzutl, MAXVAL( pct ) ) |
---|
5583 | nzptl = MAXVAL( pct ) |
---|
5584 | !-- code of plant canopy model uses parameter pch_index |
---|
5585 | !-- we need to setup it here to right value |
---|
5586 | !-- (pch_index, lad_s and other arrays in PCM are defined flat) |
---|
5587 | pch_index = MERGE( leaf_area_density_f%nz - 1, MAXVAL( pch ), & |
---|
5588 | leaf_area_density_f%from_file ) |
---|
5589 | |
---|
5590 | prototype_lad = MAXVAL( lad_s ) * .9_wp !< better be *1.0 if lad is either 0 or maxval(lad) everywhere |
---|
5591 | IF ( prototype_lad <= 0._wp ) prototype_lad = .3_wp |
---|
5592 | !WRITE(message_string, '(a,f6.3)') 'Precomputing effective box optical ' & |
---|
5593 | ! // 'depth using prototype leaf area density = ', prototype_lad |
---|
5594 | !CALL message('usm_init_urban_surface', 'PA0520', 0, 0, -1, 6, 0) |
---|
5595 | ENDIF |
---|
5596 | |
---|
5597 | nzutl = MIN( nzutl + nzut_free, nzt ) |
---|
5598 | |
---|
5599 | #if defined( __parallel ) |
---|
5600 | CALL MPI_AllReduce(nzubl, nzub, 1, MPI_INTEGER, MPI_MIN, comm2d, ierr ) |
---|
5601 | IF ( ierr /= 0 ) THEN |
---|
5602 | WRITE(9,*) 'Error MPI_AllReduce11:', ierr, nzubl, nzub |
---|
5603 | FLUSH(9) |
---|
5604 | ENDIF |
---|
5605 | CALL MPI_AllReduce(nzutl, nzut, 1, MPI_INTEGER, MPI_MAX, comm2d, ierr ) |
---|
5606 | IF ( ierr /= 0 ) THEN |
---|
5607 | WRITE(9,*) 'Error MPI_AllReduce12:', ierr, nzutl, nzut |
---|
5608 | FLUSH(9) |
---|
5609 | ENDIF |
---|
5610 | CALL MPI_AllReduce(nzptl, nzpt, 1, MPI_INTEGER, MPI_MAX, comm2d, ierr ) |
---|
5611 | IF ( ierr /= 0 ) THEN |
---|
5612 | WRITE(9,*) 'Error MPI_AllReduce13:', ierr, nzptl, nzpt |
---|
5613 | FLUSH(9) |
---|
5614 | ENDIF |
---|
5615 | #else |
---|
5616 | nzub = nzubl |
---|
5617 | nzut = nzutl |
---|
5618 | nzpt = nzptl |
---|
5619 | #endif |
---|
5620 | ! |
---|
5621 | !-- Stretching (non-uniform grid spacing) is not considered in the radiation |
---|
5622 | !-- model. Therefore, vertical stretching has to be applied above the area |
---|
5623 | !-- where the parts of the radiation model which assume constant grid spacing |
---|
5624 | !-- are active. ABS (...) is required because the default value of |
---|
5625 | !-- dz_stretch_level_start is -9999999.9_wp (negative). |
---|
5626 | IF ( ABS( dz_stretch_level_start(1) ) <= zw(nzut) ) THEN |
---|
5627 | WRITE( message_string, * ) 'The lowest level where vertical ', & |
---|
5628 | 'stretching is applied have to be ', & |
---|
5629 | 'greater than ', zw(nzut) |
---|
5630 | CALL message( 'radiation_interaction_init', 'PA0496', 1, 2, 0, 6, 0 ) |
---|
5631 | ENDIF |
---|
5632 | ! |
---|
5633 | !-- global number of urban and plant layers |
---|
5634 | nzu = nzut - nzub + 1 |
---|
5635 | nzp = nzpt - nzub + 1 |
---|
5636 | ! |
---|
5637 | !-- check max_raytracing_dist relative to urban surface layer height |
---|
5638 | mrl = 2.0_wp * nzu * dz(1) |
---|
5639 | !-- set max_raytracing_dist to double the urban surface layer height, if not set |
---|
5640 | IF ( max_raytracing_dist == -999.0_wp ) THEN |
---|
5641 | max_raytracing_dist = mrl |
---|
5642 | ENDIF |
---|
5643 | !-- check if max_raytracing_dist set too low (here we only warn the user. Other |
---|
5644 | ! option is to correct the value again to double the urban surface layer height) |
---|
5645 | IF ( max_raytracing_dist < mrl ) THEN |
---|
5646 | WRITE(message_string, '(a,f6.1)') 'Max_raytracing_dist is set less than ', & |
---|
5647 | 'double the urban surface layer height, i.e. ', mrl |
---|
5648 | CALL message('radiation_interaction_init', 'PA0521', 0, 0, -1, 6, 0) |
---|
5649 | ENDIF |
---|
5650 | ! IF ( max_raytracing_dist <= mrl ) THEN |
---|
5651 | ! IF ( max_raytracing_dist /= -999.0_wp ) THEN |
---|
5652 | ! !-- max_raytracing_dist too low |
---|
5653 | ! WRITE(message_string, '(a,f6.1)') 'Max_raytracing_dist too low, ' & |
---|
5654 | ! // 'override to value ', mrl |
---|
5655 | ! CALL message('radiation_interaction_init', 'PA0521', 0, 0, -1, 6, 0) |
---|
5656 | ! ENDIF |
---|
5657 | ! max_raytracing_dist = mrl |
---|
5658 | ! ENDIF |
---|
5659 | ! |
---|
5660 | !-- allocate urban surfaces grid |
---|
5661 | !-- calc number of surfaces in local proc |
---|
5662 | CALL location_message( ' calculation of indices for surfaces', .TRUE. ) |
---|
5663 | nsurfl = 0 |
---|
5664 | ! |
---|
5665 | !-- Number of horizontal surfaces including land- and roof surfaces in both USM and LSM. Note that |
---|
5666 | !-- All horizontal surface elements are already counted in surface_mod. |
---|
5667 | startland = 1 |
---|
5668 | nsurfl = surf_usm_h%ns + surf_lsm_h%ns |
---|
5669 | endland = nsurfl |
---|
5670 | nlands = endland - startland + 1 |
---|
5671 | |
---|
5672 | ! |
---|
5673 | !-- Number of vertical surfaces in both USM and LSM. Note that all vertical surface elements are |
---|
5674 | !-- already counted in surface_mod. |
---|
5675 | startwall = nsurfl+1 |
---|
5676 | DO i = 0,3 |
---|
5677 | nsurfl = nsurfl + surf_usm_v(i)%ns + surf_lsm_v(i)%ns |
---|
5678 | ENDDO |
---|
5679 | endwall = nsurfl |
---|
5680 | nwalls = endwall - startwall + 1 |
---|
5681 | |
---|
5682 | !-- fill gridpcbl and pcbl |
---|
5683 | IF ( npcbl > 0 ) THEN |
---|
5684 | ALLOCATE( pcbl(iz:ix, 1:npcbl) ) |
---|
5685 | ALLOCATE( gridpcbl(nzub:nzpt,nys:nyn,nxl:nxr) ) |
---|
5686 | pcbl = -1 |
---|
5687 | gridpcbl(:,:,:) = 0 |
---|
5688 | ipcgb = 0 |
---|
5689 | DO i = nxl, nxr |
---|
5690 | DO j = nys, nyn |
---|
5691 | ! |
---|
5692 | !-- Find topography top index |
---|
5693 | k_topo = get_topography_top_index_ji( j, i, 's' ) |
---|
5694 | |
---|
5695 | DO k = k_topo + 1, pct(j,i) |
---|
5696 | ipcgb = ipcgb + 1 |
---|
5697 | gridpcbl(k,j,i) = ipcgb |
---|
5698 | pcbl(:,ipcgb) = (/ k, j, i /) |
---|
5699 | ENDDO |
---|
5700 | ENDDO |
---|
5701 | ENDDO |
---|
5702 | ALLOCATE( pcbinsw( 1:npcbl ) ) |
---|
5703 | ALLOCATE( pcbinswdir( 1:npcbl ) ) |
---|
5704 | ALLOCATE( pcbinswdif( 1:npcbl ) ) |
---|
5705 | ALLOCATE( pcbinlw( 1:npcbl ) ) |
---|
5706 | ENDIF |
---|
5707 | |
---|
5708 | !-- fill surfl (the ordering of local surfaces given by the following |
---|
5709 | !-- cycles must not be altered, certain file input routines may depend |
---|
5710 | !-- on it) |
---|
5711 | ALLOCATE(surfl_l(5*nsurfl)) ! is it necessary to allocate it with (5,nsurfl)? |
---|
5712 | surfl(1:5,1:nsurfl) => surfl_l(1:5*nsurfl) |
---|
5713 | isurf = 0 |
---|
5714 | IF ( rad_angular_discretization ) THEN |
---|
5715 | ! |
---|
5716 | !-- Allocate and fill the reverse indexing array gridsurf |
---|
5717 | #if defined( __parallel ) |
---|
5718 | ! |
---|
5719 | !-- raytrace_mpi_rma is asserted |
---|
5720 | |
---|
5721 | CALL MPI_Info_create(minfo, ierr) |
---|
5722 | IF ( ierr /= 0 ) THEN |
---|
5723 | WRITE(9,*) 'Error MPI_Info_create1:', ierr |
---|
5724 | FLUSH(9) |
---|
5725 | ENDIF |
---|
5726 | CALL MPI_Info_set(minfo, 'accumulate_ordering', '', ierr) |
---|
5727 | IF ( ierr /= 0 ) THEN |
---|
5728 | WRITE(9,*) 'Error MPI_Info_set1:', ierr |
---|
5729 | FLUSH(9) |
---|
5730 | ENDIF |
---|
5731 | CALL MPI_Info_set(minfo, 'accumulate_ops', 'same_op', ierr) |
---|
5732 | IF ( ierr /= 0 ) THEN |
---|
5733 | WRITE(9,*) 'Error MPI_Info_set2:', ierr |
---|
5734 | FLUSH(9) |
---|
5735 | ENDIF |
---|
5736 | CALL MPI_Info_set(minfo, 'same_size', 'true', ierr) |
---|
5737 | IF ( ierr /= 0 ) THEN |
---|
5738 | WRITE(9,*) 'Error MPI_Info_set3:', ierr |
---|
5739 | FLUSH(9) |
---|
5740 | ENDIF |
---|
5741 | CALL MPI_Info_set(minfo, 'same_disp_unit', 'true', ierr) |
---|
5742 | IF ( ierr /= 0 ) THEN |
---|
5743 | WRITE(9,*) 'Error MPI_Info_set4:', ierr |
---|
5744 | FLUSH(9) |
---|
5745 | ENDIF |
---|
5746 | |
---|
5747 | CALL MPI_Win_allocate(INT(STORAGE_SIZE(1_iwp)/8*nsurf_type_u*nzu*nny*nnx, & |
---|
5748 | kind=MPI_ADDRESS_KIND), STORAGE_SIZE(1_iwp)/8, & |
---|
5749 | minfo, comm2d, gridsurf_rma_p, win_gridsurf, ierr) |
---|
5750 | IF ( ierr /= 0 ) THEN |
---|
5751 | WRITE(9,*) 'Error MPI_Win_allocate1:', ierr, & |
---|
5752 | INT(STORAGE_SIZE(1_iwp)/8*nsurf_type_u*nzu*nny*nnx,kind=MPI_ADDRESS_KIND), & |
---|
5753 | STORAGE_SIZE(1_iwp)/8, win_gridsurf |
---|
5754 | FLUSH(9) |
---|
5755 | ENDIF |
---|
5756 | |
---|
5757 | CALL MPI_Info_free(minfo, ierr) |
---|
5758 | IF ( ierr /= 0 ) THEN |
---|
5759 | WRITE(9,*) 'Error MPI_Info_free1:', ierr |
---|
5760 | FLUSH(9) |
---|
5761 | ENDIF |
---|
5762 | |
---|
5763 | ! |
---|
5764 | !-- On Intel compilers, calling c_f_pointer to transform a C pointer |
---|
5765 | !-- directly to a multi-dimensional Fotran pointer leads to strange |
---|
5766 | !-- errors on dimension boundaries. However, transforming to a 1D |
---|
5767 | !-- pointer and then redirecting a multidimensional pointer to it works |
---|
5768 | !-- fine. |
---|
5769 | CALL c_f_pointer(gridsurf_rma_p, gridsurf_rma, (/ nsurf_type_u*nzu*nny*nnx /)) |
---|
5770 | gridsurf(0:nsurf_type_u-1, nzub:nzut, nys:nyn, nxl:nxr) => & |
---|
5771 | gridsurf_rma(1:nsurf_type_u*nzu*nny*nnx) |
---|
5772 | #else |
---|
5773 | ALLOCATE(gridsurf(0:nsurf_type_u-1,nzub:nzut,nys:nyn,nxl:nxr) ) |
---|
5774 | #endif |
---|
5775 | gridsurf(:,:,:,:) = -999 |
---|
5776 | ENDIF |
---|
5777 | |
---|
5778 | !-- add horizontal surface elements (land and urban surfaces) |
---|
5779 | !-- TODO: add urban overhanging surfaces (idown_u) |
---|
5780 | DO i = nxl, nxr |
---|
5781 | DO j = nys, nyn |
---|
5782 | DO m = surf_usm_h%start_index(j,i), surf_usm_h%end_index(j,i) |
---|
5783 | k = surf_usm_h%k(m) |
---|
5784 | isurf = isurf + 1 |
---|
5785 | surfl(:,isurf) = (/iup_u,k,j,i,m/) |
---|
5786 | IF ( rad_angular_discretization ) THEN |
---|
5787 | gridsurf(iup_u,k,j,i) = isurf |
---|
5788 | ENDIF |
---|
5789 | ENDDO |
---|
5790 | |
---|
5791 | DO m = surf_lsm_h%start_index(j,i), surf_lsm_h%end_index(j,i) |
---|
5792 | k = surf_lsm_h%k(m) |
---|
5793 | isurf = isurf + 1 |
---|
5794 | surfl(:,isurf) = (/iup_l,k,j,i,m/) |
---|
5795 | IF ( rad_angular_discretization ) THEN |
---|
5796 | gridsurf(iup_u,k,j,i) = isurf |
---|
5797 | ENDIF |
---|
5798 | ENDDO |
---|
5799 | |
---|
5800 | ENDDO |
---|
5801 | ENDDO |
---|
5802 | |
---|
5803 | !-- add vertical surface elements (land and urban surfaces) |
---|
5804 | !-- TODO: remove the hard coding of l = 0 to l = idirection |
---|
5805 | DO i = nxl, nxr |
---|
5806 | DO j = nys, nyn |
---|
5807 | l = 0 |
---|
5808 | DO m = surf_usm_v(l)%start_index(j,i), surf_usm_v(l)%end_index(j,i) |
---|
5809 | k = surf_usm_v(l)%k(m) |
---|
5810 | isurf = isurf + 1 |
---|
5811 | surfl(:,isurf) = (/inorth_u,k,j,i,m/) |
---|
5812 | IF ( rad_angular_discretization ) THEN |
---|
5813 | gridsurf(inorth_u,k,j,i) = isurf |
---|
5814 | ENDIF |
---|
5815 | ENDDO |
---|
5816 | DO m = surf_lsm_v(l)%start_index(j,i), surf_lsm_v(l)%end_index(j,i) |
---|
5817 | k = surf_lsm_v(l)%k(m) |
---|
5818 | isurf = isurf + 1 |
---|
5819 | surfl(:,isurf) = (/inorth_l,k,j,i,m/) |
---|
5820 | IF ( rad_angular_discretization ) THEN |
---|
5821 | gridsurf(inorth_u,k,j,i) = isurf |
---|
5822 | ENDIF |
---|
5823 | ENDDO |
---|
5824 | |
---|
5825 | l = 1 |
---|
5826 | DO m = surf_usm_v(l)%start_index(j,i), surf_usm_v(l)%end_index(j,i) |
---|
5827 | k = surf_usm_v(l)%k(m) |
---|
5828 | isurf = isurf + 1 |
---|
5829 | surfl(:,isurf) = (/isouth_u,k,j,i,m/) |
---|
5830 | IF ( rad_angular_discretization ) THEN |
---|
5831 | gridsurf(isouth_u,k,j,i) = isurf |
---|
5832 | ENDIF |
---|
5833 | ENDDO |
---|
5834 | DO m = surf_lsm_v(l)%start_index(j,i), surf_lsm_v(l)%end_index(j,i) |
---|
5835 | k = surf_lsm_v(l)%k(m) |
---|
5836 | isurf = isurf + 1 |
---|
5837 | surfl(:,isurf) = (/isouth_l,k,j,i,m/) |
---|
5838 | IF ( rad_angular_discretization ) THEN |
---|
5839 | gridsurf(isouth_u,k,j,i) = isurf |
---|
5840 | ENDIF |
---|
5841 | ENDDO |
---|
5842 | |
---|
5843 | l = 2 |
---|
5844 | DO m = surf_usm_v(l)%start_index(j,i), surf_usm_v(l)%end_index(j,i) |
---|
5845 | k = surf_usm_v(l)%k(m) |
---|
5846 | isurf = isurf + 1 |
---|
5847 | surfl(:,isurf) = (/ieast_u,k,j,i,m/) |
---|
5848 | IF ( rad_angular_discretization ) THEN |
---|
5849 | gridsurf(ieast_u,k,j,i) = isurf |
---|
5850 | ENDIF |
---|
5851 | ENDDO |
---|
5852 | DO m = surf_lsm_v(l)%start_index(j,i), surf_lsm_v(l)%end_index(j,i) |
---|
5853 | k = surf_lsm_v(l)%k(m) |
---|
5854 | isurf = isurf + 1 |
---|
5855 | surfl(:,isurf) = (/ieast_l,k,j,i,m/) |
---|
5856 | IF ( rad_angular_discretization ) THEN |
---|
5857 | gridsurf(ieast_u,k,j,i) = isurf |
---|
5858 | ENDIF |
---|
5859 | ENDDO |
---|
5860 | |
---|
5861 | l = 3 |
---|
5862 | DO m = surf_usm_v(l)%start_index(j,i), surf_usm_v(l)%end_index(j,i) |
---|
5863 | k = surf_usm_v(l)%k(m) |
---|
5864 | isurf = isurf + 1 |
---|
5865 | surfl(:,isurf) = (/iwest_u,k,j,i,m/) |
---|
5866 | IF ( rad_angular_discretization ) THEN |
---|
5867 | gridsurf(iwest_u,k,j,i) = isurf |
---|
5868 | ENDIF |
---|
5869 | ENDDO |
---|
5870 | DO m = surf_lsm_v(l)%start_index(j,i), surf_lsm_v(l)%end_index(j,i) |
---|
5871 | k = surf_lsm_v(l)%k(m) |
---|
5872 | isurf = isurf + 1 |
---|
5873 | surfl(:,isurf) = (/iwest_l,k,j,i,m/) |
---|
5874 | IF ( rad_angular_discretization ) THEN |
---|
5875 | gridsurf(iwest_u,k,j,i) = isurf |
---|
5876 | ENDIF |
---|
5877 | ENDDO |
---|
5878 | ENDDO |
---|
5879 | ENDDO |
---|
5880 | ! |
---|
5881 | !-- Add local MRT boxes for specified number of levels |
---|
5882 | nmrtbl = 0 |
---|
5883 | IF ( mrt_nlevels > 0 ) THEN |
---|
5884 | DO i = nxl, nxr |
---|
5885 | DO j = nys, nyn |
---|
5886 | DO m = surf_usm_h%start_index(j,i), surf_usm_h%end_index(j,i) |
---|
5887 | ! |
---|
5888 | !-- Skip roof if requested |
---|
5889 | IF ( mrt_skip_roof .AND. surf_usm_h%isroof_surf(m) ) CYCLE |
---|
5890 | ! |
---|
5891 | !-- Cycle over specified no of levels |
---|
5892 | nmrtbl = nmrtbl + mrt_nlevels |
---|
5893 | ENDDO |
---|
5894 | ! |
---|
5895 | !-- Dtto for LSM |
---|
5896 | DO m = surf_lsm_h%start_index(j,i), surf_lsm_h%end_index(j,i) |
---|
5897 | nmrtbl = nmrtbl + mrt_nlevels |
---|
5898 | ENDDO |
---|
5899 | ENDDO |
---|
5900 | ENDDO |
---|
5901 | |
---|
5902 | ALLOCATE( mrtbl(iz:ix,nmrtbl), mrtsky(nmrtbl), mrtskyt(nmrtbl), & |
---|
5903 | mrtinsw(nmrtbl), mrtinlw(nmrtbl), mrt(nmrtbl) ) |
---|
5904 | |
---|
5905 | imrt = 0 |
---|
5906 | DO i = nxl, nxr |
---|
5907 | DO j = nys, nyn |
---|
5908 | DO m = surf_usm_h%start_index(j,i), surf_usm_h%end_index(j,i) |
---|
5909 | ! |
---|
5910 | !-- Skip roof if requested |
---|
5911 | IF ( mrt_skip_roof .AND. surf_usm_h%isroof_surf(m) ) CYCLE |
---|
5912 | ! |
---|
5913 | !-- Cycle over specified no of levels |
---|
5914 | l = surf_usm_h%k(m) |
---|
5915 | DO k = l, l + mrt_nlevels - 1 |
---|
5916 | imrt = imrt + 1 |
---|
5917 | mrtbl(:,imrt) = (/k,j,i/) |
---|
5918 | ENDDO |
---|
5919 | ENDDO |
---|
5920 | ! |
---|
5921 | !-- Dtto for LSM |
---|
5922 | DO m = surf_lsm_h%start_index(j,i), surf_lsm_h%end_index(j,i) |
---|
5923 | l = surf_lsm_h%k(m) |
---|
5924 | DO k = l, l + mrt_nlevels - 1 |
---|
5925 | imrt = imrt + 1 |
---|
5926 | mrtbl(:,imrt) = (/k,j,i/) |
---|
5927 | ENDDO |
---|
5928 | ENDDO |
---|
5929 | ENDDO |
---|
5930 | ENDDO |
---|
5931 | ENDIF |
---|
5932 | |
---|
5933 | ! |
---|
5934 | !-- broadband albedo of the land, roof and wall surface |
---|
5935 | !-- for domain border and sky set artifically to 1.0 |
---|
5936 | !-- what allows us to calculate heat flux leaving over |
---|
5937 | !-- side and top borders of the domain |
---|
5938 | ALLOCATE ( albedo_surf(nsurfl) ) |
---|
5939 | albedo_surf = 1.0_wp |
---|
5940 | ! |
---|
5941 | !-- Also allocate further array for emissivity with identical order of |
---|
5942 | !-- surface elements as radiation arrays. |
---|
5943 | ALLOCATE ( emiss_surf(nsurfl) ) |
---|
5944 | |
---|
5945 | |
---|
5946 | ! |
---|
5947 | !-- global array surf of indices of surfaces and displacement index array surfstart |
---|
5948 | ALLOCATE(nsurfs(0:numprocs-1)) |
---|
5949 | |
---|
5950 | #if defined( __parallel ) |
---|
5951 | CALL MPI_Allgather(nsurfl,1,MPI_INTEGER,nsurfs,1,MPI_INTEGER,comm2d,ierr) |
---|
5952 | IF ( ierr /= 0 ) THEN |
---|
5953 | WRITE(9,*) 'Error MPI_AllGather1:', ierr, nsurfl, nsurfs |
---|
5954 | FLUSH(9) |
---|
5955 | ENDIF |
---|
5956 | |
---|
5957 | #else |
---|
5958 | nsurfs(0) = nsurfl |
---|
5959 | #endif |
---|
5960 | ALLOCATE(surfstart(0:numprocs)) |
---|
5961 | k = 0 |
---|
5962 | DO i=0,numprocs-1 |
---|
5963 | surfstart(i) = k |
---|
5964 | k = k+nsurfs(i) |
---|
5965 | ENDDO |
---|
5966 | surfstart(numprocs) = k |
---|
5967 | nsurf = k |
---|
5968 | ALLOCATE(surf_l(5*nsurf)) |
---|
5969 | surf(1:5,1:nsurf) => surf_l(1:5*nsurf) |
---|
5970 | |
---|
5971 | #if defined( __parallel ) |
---|
5972 | CALL MPI_AllGatherv(surfl_l, nsurfl*5, MPI_INTEGER, surf_l, nsurfs*5, & |
---|
5973 | surfstart(0:numprocs-1)*5, MPI_INTEGER, comm2d, ierr) |
---|
5974 | IF ( ierr /= 0 ) THEN |
---|
5975 | WRITE(9,*) 'Error MPI_AllGatherv4:', ierr, SIZE(surfl_l), nsurfl*5, & |
---|
5976 | SIZE(surf_l), nsurfs*5, surfstart(0:numprocs-1)*5 |
---|
5977 | FLUSH(9) |
---|
5978 | ENDIF |
---|
5979 | #else |
---|
5980 | surf = surfl |
---|
5981 | #endif |
---|
5982 | |
---|
5983 | !-- |
---|
5984 | !-- allocation of the arrays for direct and diffusion radiation |
---|
5985 | CALL location_message( ' allocation of radiation arrays', .TRUE. ) |
---|
5986 | !-- rad_sw_in, rad_lw_in are computed in radiation model, |
---|
5987 | !-- splitting of direct and diffusion part is done |
---|
5988 | !-- in calc_diffusion_radiation for now |
---|
5989 | |
---|
5990 | ALLOCATE( rad_sw_in_dir(nysg:nyng,nxlg:nxrg) ) |
---|
5991 | ALLOCATE( rad_sw_in_diff(nysg:nyng,nxlg:nxrg) ) |
---|
5992 | ALLOCATE( rad_lw_in_diff(nysg:nyng,nxlg:nxrg) ) |
---|
5993 | rad_sw_in_dir = 0.0_wp |
---|
5994 | rad_sw_in_diff = 0.0_wp |
---|
5995 | rad_lw_in_diff = 0.0_wp |
---|
5996 | |
---|
5997 | !-- allocate radiation arrays |
---|
5998 | ALLOCATE( surfins(nsurfl) ) |
---|
5999 | ALLOCATE( surfinl(nsurfl) ) |
---|
6000 | ALLOCATE( surfinsw(nsurfl) ) |
---|
6001 | ALLOCATE( surfinlw(nsurfl) ) |
---|
6002 | ALLOCATE( surfinswdir(nsurfl) ) |
---|
6003 | ALLOCATE( surfinswdif(nsurfl) ) |
---|
6004 | ALLOCATE( surfinlwdif(nsurfl) ) |
---|
6005 | ALLOCATE( surfoutsl(nsurfl) ) |
---|
6006 | ALLOCATE( surfoutll(nsurfl) ) |
---|
6007 | ALLOCATE( surfoutsw(nsurfl) ) |
---|
6008 | ALLOCATE( surfoutlw(nsurfl) ) |
---|
6009 | ALLOCATE( surfouts(nsurf) ) |
---|
6010 | ALLOCATE( surfoutl(nsurf) ) |
---|
6011 | ALLOCATE( surfinlg(nsurf) ) |
---|
6012 | ALLOCATE( skyvf(nsurfl) ) |
---|
6013 | ALLOCATE( skyvft(nsurfl) ) |
---|
6014 | ALLOCATE( surfemitlwl(nsurfl) ) |
---|
6015 | |
---|
6016 | ! |
---|
6017 | !-- In case of average_radiation, aggregated surface albedo and emissivity, |
---|
6018 | !-- also set initial value for t_rad_urb. |
---|
6019 | !-- For now set an arbitrary initial value. |
---|
6020 | IF ( average_radiation ) THEN |
---|
6021 | albedo_urb = 0.1_wp |
---|
6022 | emissivity_urb = 0.9_wp |
---|
6023 | t_rad_urb = pt_surface |
---|
6024 | ENDIF |
---|
6025 | |
---|
6026 | END SUBROUTINE radiation_interaction_init |
---|
6027 | |
---|
6028 | !------------------------------------------------------------------------------! |
---|
6029 | ! Description: |
---|
6030 | ! ------------ |
---|
6031 | !> Calculates shape view factors (SVF), plant sink canopy factors (PCSF), |
---|
6032 | !> sky-view factors, discretized path for direct solar radiation, MRT factors |
---|
6033 | !> and other preprocessed data needed for radiation_interaction. |
---|
6034 | !------------------------------------------------------------------------------! |
---|
6035 | SUBROUTINE radiation_calc_svf |
---|
6036 | |
---|
6037 | IMPLICIT NONE |
---|
6038 | |
---|
6039 | INTEGER(iwp) :: i, j, k, d, ip, jp |
---|
6040 | INTEGER(iwp) :: isvf, ksvf, icsf, kcsf, npcsfl, isvf_surflt, imrt, imrtf, ipcgb |
---|
6041 | INTEGER(iwp) :: sd, td |
---|
6042 | INTEGER(iwp) :: iaz, izn !< azimuth, zenith counters |
---|
6043 | INTEGER(iwp) :: naz, nzn !< azimuth, zenith num of steps |
---|
6044 | REAL(wp) :: az0, zn0 !< starting azimuth/zenith |
---|
6045 | REAL(wp) :: azs, zns !< azimuth/zenith cycle step |
---|
6046 | REAL(wp) :: az1, az2 !< relative azimuth of section borders |
---|
6047 | REAL(wp) :: azmid !< ray (center) azimuth |
---|
6048 | REAL(wp) :: yxlen !< |yxdir| |
---|
6049 | REAL(wp), DIMENSION(2) :: yxdir !< y,x *unit* vector of ray direction (in grid units) |
---|
6050 | REAL(wp), DIMENSION(:), ALLOCATABLE :: zdirs !< directions in z (tangent of elevation) |
---|
6051 | REAL(wp), DIMENSION(:), ALLOCATABLE :: zcent !< zenith angle centers |
---|
6052 | REAL(wp), DIMENSION(:), ALLOCATABLE :: zbdry !< zenith angle boundaries |
---|
6053 | REAL(wp), DIMENSION(:), ALLOCATABLE :: vffrac !< view factor fractions for individual rays |
---|
6054 | REAL(wp), DIMENSION(:), ALLOCATABLE :: vffrac0 !< dtto (original values) |
---|
6055 | REAL(wp), DIMENSION(:), ALLOCATABLE :: ztransp !< array of transparency in z steps |
---|
6056 | INTEGER(iwp) :: lowest_free_ray !< index into zdirs |
---|
6057 | INTEGER(iwp), DIMENSION(:), ALLOCATABLE :: itarget !< face indices of detected obstacles |
---|
6058 | INTEGER(iwp) :: itarg0, itarg1 |
---|
6059 | |
---|
6060 | INTEGER(iwp) :: udim |
---|
6061 | INTEGER(iwp), DIMENSION(:), ALLOCATABLE,TARGET:: nzterrl_l |
---|
6062 | INTEGER(iwp), DIMENSION(:,:), POINTER :: nzterrl |
---|
6063 | REAL(wp), DIMENSION(:), ALLOCATABLE,TARGET:: csflt_l, pcsflt_l |
---|
6064 | REAL(wp), DIMENSION(:,:), POINTER :: csflt, pcsflt |
---|
6065 | INTEGER(iwp), DIMENSION(:), ALLOCATABLE,TARGET:: kcsflt_l,kpcsflt_l |
---|
6066 | INTEGER(iwp), DIMENSION(:,:), POINTER :: kcsflt,kpcsflt |
---|
6067 | INTEGER(iwp), DIMENSION(:), ALLOCATABLE :: icsflt,dcsflt,ipcsflt,dpcsflt |
---|
6068 | REAL(wp), DIMENSION(3) :: uv |
---|
6069 | LOGICAL :: visible |
---|
6070 | REAL(wp), DIMENSION(3) :: sa, ta !< real coordinates z,y,x of source and target |
---|
6071 | REAL(wp) :: difvf !< differential view factor |
---|
6072 | REAL(wp) :: transparency, rirrf, sqdist, svfsum |
---|
6073 | INTEGER(iwp) :: isurflt, isurfs, isurflt_prev |
---|
6074 | INTEGER(idp) :: ray_skip_maxdist, ray_skip_minval !< skipped raytracing counts |
---|
6075 | INTEGER(iwp) :: max_track_len !< maximum 2d track length |
---|
6076 | INTEGER(iwp) :: minfo |
---|
6077 | REAL(wp), DIMENSION(:), POINTER :: lad_s_rma !< fortran 1D pointer |
---|
6078 | TYPE(c_ptr) :: lad_s_rma_p !< allocated c pointer |
---|
6079 | #if defined( __parallel ) |
---|
6080 | INTEGER(kind=MPI_ADDRESS_KIND) :: size_lad_rma |
---|
6081 | #endif |
---|
6082 | ! |
---|
6083 | INTEGER(iwp), DIMENSION(0:svfnorm_report_num) :: svfnorm_counts |
---|
6084 | CHARACTER(200) :: msg |
---|
6085 | |
---|
6086 | !-- calculation of the SVF |
---|
6087 | CALL location_message( ' calculation of SVF and CSF', .TRUE. ) |
---|
6088 | CALL radiation_write_debug_log('Start calculation of SVF and CSF') |
---|
6089 | |
---|
6090 | !-- initialize variables and temporary arrays for calculation of svf and csf |
---|
6091 | nsvfl = 0 |
---|
6092 | ncsfl = 0 |
---|
6093 | nsvfla = gasize |
---|
6094 | msvf = 1 |
---|
6095 | ALLOCATE( asvf1(nsvfla) ) |
---|
6096 | asvf => asvf1 |
---|
6097 | IF ( plant_canopy ) THEN |
---|
6098 | ncsfla = gasize |
---|
6099 | mcsf = 1 |
---|
6100 | ALLOCATE( acsf1(ncsfla) ) |
---|
6101 | acsf => acsf1 |
---|
6102 | ENDIF |
---|
6103 | nmrtf = 0 |
---|
6104 | IF ( mrt_nlevels > 0 ) THEN |
---|
6105 | nmrtfa = gasize |
---|
6106 | mmrtf = 1 |
---|
6107 | ALLOCATE ( amrtf1(nmrtfa) ) |
---|
6108 | amrtf => amrtf1 |
---|
6109 | ENDIF |
---|
6110 | ray_skip_maxdist = 0 |
---|
6111 | ray_skip_minval = 0 |
---|
6112 | |
---|
6113 | !-- initialize temporary terrain and plant canopy height arrays (global 2D array!) |
---|
6114 | ALLOCATE( nzterr(0:(nx+1)*(ny+1)-1) ) |
---|
6115 | #if defined( __parallel ) |
---|
6116 | !ALLOCATE( nzterrl(nys:nyn,nxl:nxr) ) |
---|
6117 | ALLOCATE( nzterrl_l((nyn-nys+1)*(nxr-nxl+1)) ) |
---|
6118 | nzterrl(nys:nyn,nxl:nxr) => nzterrl_l(1:(nyn-nys+1)*(nxr-nxl+1)) |
---|
6119 | nzterrl = get_topography_top_index( 's' ) |
---|
6120 | CALL MPI_AllGather( nzterrl_l, nnx*nny, MPI_INTEGER, & |
---|
6121 | nzterr, nnx*nny, MPI_INTEGER, comm2d, ierr ) |
---|
6122 | IF ( ierr /= 0 ) THEN |
---|
6123 | WRITE(9,*) 'Error MPI_AllGather1:', ierr, SIZE(nzterrl_l), nnx*nny, & |
---|
6124 | SIZE(nzterr), nnx*nny |
---|
6125 | FLUSH(9) |
---|
6126 | ENDIF |
---|
6127 | DEALLOCATE(nzterrl_l) |
---|
6128 | #else |
---|
6129 | nzterr = RESHAPE( get_topography_top_index( 's' ), (/(nx+1)*(ny+1)/) ) |
---|
6130 | #endif |
---|
6131 | IF ( plant_canopy ) THEN |
---|
6132 | ALLOCATE( plantt(0:(nx+1)*(ny+1)-1) ) |
---|
6133 | maxboxesg = nx + ny + nzp + 1 |
---|
6134 | max_track_len = nx + ny + 1 |
---|
6135 | !-- temporary arrays storing values for csf calculation during raytracing |
---|
6136 | ALLOCATE( boxes(3, maxboxesg) ) |
---|
6137 | ALLOCATE( crlens(maxboxesg) ) |
---|
6138 | |
---|
6139 | #if defined( __parallel ) |
---|
6140 | CALL MPI_AllGather( pct, nnx*nny, MPI_INTEGER, & |
---|
6141 | plantt, nnx*nny, MPI_INTEGER, comm2d, ierr ) |
---|
6142 | IF ( ierr /= 0 ) THEN |
---|
6143 | WRITE(9,*) 'Error MPI_AllGather2:', ierr, SIZE(pct), nnx*nny, & |
---|
6144 | SIZE(plantt), nnx*nny |
---|
6145 | FLUSH(9) |
---|
6146 | ENDIF |
---|
6147 | |
---|
6148 | !-- temporary arrays storing values for csf calculation during raytracing |
---|
6149 | ALLOCATE( lad_ip(maxboxesg) ) |
---|
6150 | ALLOCATE( lad_disp(maxboxesg) ) |
---|
6151 | |
---|
6152 | IF ( raytrace_mpi_rma ) THEN |
---|
6153 | ALLOCATE( lad_s_ray(maxboxesg) ) |
---|
6154 | |
---|
6155 | ! set conditions for RMA communication |
---|
6156 | CALL MPI_Info_create(minfo, ierr) |
---|
6157 | IF ( ierr /= 0 ) THEN |
---|
6158 | WRITE(9,*) 'Error MPI_Info_create2:', ierr |
---|
6159 | FLUSH(9) |
---|
6160 | ENDIF |
---|
6161 | CALL MPI_Info_set(minfo, 'accumulate_ordering', '', ierr) |
---|
6162 | IF ( ierr /= 0 ) THEN |
---|
6163 | WRITE(9,*) 'Error MPI_Info_set5:', ierr |
---|
6164 | FLUSH(9) |
---|
6165 | ENDIF |
---|
6166 | CALL MPI_Info_set(minfo, 'accumulate_ops', 'same_op', ierr) |
---|
6167 | IF ( ierr /= 0 ) THEN |
---|
6168 | WRITE(9,*) 'Error MPI_Info_set6:', ierr |
---|
6169 | FLUSH(9) |
---|
6170 | ENDIF |
---|
6171 | CALL MPI_Info_set(minfo, 'same_size', 'true', ierr) |
---|
6172 | IF ( ierr /= 0 ) THEN |
---|
6173 | WRITE(9,*) 'Error MPI_Info_set7:', ierr |
---|
6174 | FLUSH(9) |
---|
6175 | ENDIF |
---|
6176 | CALL MPI_Info_set(minfo, 'same_disp_unit', 'true', ierr) |
---|
6177 | IF ( ierr /= 0 ) THEN |
---|
6178 | WRITE(9,*) 'Error MPI_Info_set8:', ierr |
---|
6179 | FLUSH(9) |
---|
6180 | ENDIF |
---|
6181 | |
---|
6182 | !-- Allocate and initialize the MPI RMA window |
---|
6183 | !-- must be in accordance with allocation of lad_s in plant_canopy_model |
---|
6184 | !-- optimization of memory should be done |
---|
6185 | !-- Argument X of function STORAGE_SIZE(X) needs arbitrary REAL(wp) value, set to 1.0_wp for now |
---|
6186 | size_lad_rma = STORAGE_SIZE(1.0_wp)/8*nnx*nny*nzp |
---|
6187 | CALL MPI_Win_allocate(size_lad_rma, STORAGE_SIZE(1.0_wp)/8, minfo, comm2d, & |
---|
6188 | lad_s_rma_p, win_lad, ierr) |
---|
6189 | IF ( ierr /= 0 ) THEN |
---|
6190 | WRITE(9,*) 'Error MPI_Win_allocate2:', ierr, size_lad_rma, & |
---|
6191 | STORAGE_SIZE(1.0_wp)/8, win_lad |
---|
6192 | FLUSH(9) |
---|
6193 | ENDIF |
---|
6194 | CALL c_f_pointer(lad_s_rma_p, lad_s_rma, (/ nzp*nny*nnx /)) |
---|
6195 | sub_lad(nzub:nzpt, nys:nyn, nxl:nxr) => lad_s_rma(1:nzp*nny*nnx) |
---|
6196 | ELSE |
---|
6197 | ALLOCATE(sub_lad(nzub:nzpt, nys:nyn, nxl:nxr)) |
---|
6198 | ENDIF |
---|
6199 | #else |
---|
6200 | plantt = RESHAPE( pct(nys:nyn,nxl:nxr), (/(nx+1)*(ny+1)/) ) |
---|
6201 | ALLOCATE(sub_lad(nzub:nzpt, nys:nyn, nxl:nxr)) |
---|
6202 | #endif |
---|
6203 | plantt_max = MAXVAL(plantt) |
---|
6204 | ALLOCATE( rt2_track(2, max_track_len), rt2_track_lad(nzub:plantt_max, max_track_len), & |
---|
6205 | rt2_track_dist(0:max_track_len), rt2_dist(plantt_max-nzub+2) ) |
---|
6206 | |
---|
6207 | sub_lad(:,:,:) = 0._wp |
---|
6208 | DO i = nxl, nxr |
---|
6209 | DO j = nys, nyn |
---|
6210 | k = get_topography_top_index_ji( j, i, 's' ) |
---|
6211 | |
---|
6212 | sub_lad(k:nzpt, j, i) = lad_s(0:nzpt-k, j, i) |
---|
6213 | ENDDO |
---|
6214 | ENDDO |
---|
6215 | |
---|
6216 | #if defined( __parallel ) |
---|
6217 | IF ( raytrace_mpi_rma ) THEN |
---|
6218 | CALL MPI_Info_free(minfo, ierr) |
---|
6219 | IF ( ierr /= 0 ) THEN |
---|
6220 | WRITE(9,*) 'Error MPI_Info_free2:', ierr |
---|
6221 | FLUSH(9) |
---|
6222 | ENDIF |
---|
6223 | CALL MPI_Win_lock_all(0, win_lad, ierr) |
---|
6224 | IF ( ierr /= 0 ) THEN |
---|
6225 | WRITE(9,*) 'Error MPI_Win_lock_all1:', ierr, win_lad |
---|
6226 | FLUSH(9) |
---|
6227 | ENDIF |
---|
6228 | |
---|
6229 | ELSE |
---|
6230 | ALLOCATE( sub_lad_g(0:(nx+1)*(ny+1)*nzp-1) ) |
---|
6231 | CALL MPI_AllGather( sub_lad, nnx*nny*nzp, MPI_REAL, & |
---|
6232 | sub_lad_g, nnx*nny*nzp, MPI_REAL, comm2d, ierr ) |
---|
6233 | IF ( ierr /= 0 ) THEN |
---|
6234 | WRITE(9,*) 'Error MPI_AllGather3:', ierr, SIZE(sub_lad), & |
---|
6235 | nnx*nny*nzp, SIZE(sub_lad_g), nnx*nny*nzp |
---|
6236 | FLUSH(9) |
---|
6237 | ENDIF |
---|
6238 | ENDIF |
---|
6239 | #endif |
---|
6240 | ENDIF |
---|
6241 | |
---|
6242 | !-- prepare the MPI_Win for collecting the surface indices |
---|
6243 | !-- from the reverse index arrays gridsurf from processors of target surfaces |
---|
6244 | #if defined( __parallel ) |
---|
6245 | IF ( rad_angular_discretization ) THEN |
---|
6246 | ! |
---|
6247 | !-- raytrace_mpi_rma is asserted |
---|
6248 | CALL MPI_Win_lock_all(0, win_gridsurf, ierr) |
---|
6249 | IF ( ierr /= 0 ) THEN |
---|
6250 | WRITE(9,*) 'Error MPI_Win_lock_all2:', ierr, win_gridsurf |
---|
6251 | FLUSH(9) |
---|
6252 | ENDIF |
---|
6253 | ENDIF |
---|
6254 | #endif |
---|
6255 | |
---|
6256 | |
---|
6257 | !--Directions opposite to face normals are not even calculated, |
---|
6258 | !--they must be preset to 0 |
---|
6259 | !-- |
---|
6260 | dsitrans(:,:) = 0._wp |
---|
6261 | |
---|
6262 | DO isurflt = 1, nsurfl |
---|
6263 | !-- determine face centers |
---|
6264 | td = surfl(id, isurflt) |
---|
6265 | ta = (/ REAL(surfl(iz, isurflt), wp) - 0.5_wp * kdir(td), & |
---|
6266 | REAL(surfl(iy, isurflt), wp) - 0.5_wp * jdir(td), & |
---|
6267 | REAL(surfl(ix, isurflt), wp) - 0.5_wp * idir(td) /) |
---|
6268 | |
---|
6269 | !--Calculate sky view factor and raytrace DSI paths |
---|
6270 | skyvf(isurflt) = 0._wp |
---|
6271 | skyvft(isurflt) = 0._wp |
---|
6272 | |
---|
6273 | !--Select a proper half-sphere for 2D raytracing |
---|
6274 | SELECT CASE ( td ) |
---|
6275 | CASE ( iup_u, iup_l ) |
---|
6276 | az0 = 0._wp |
---|
6277 | naz = raytrace_discrete_azims |
---|
6278 | azs = 2._wp * pi / REAL(naz, wp) |
---|
6279 | zn0 = 0._wp |
---|
6280 | nzn = raytrace_discrete_elevs / 2 |
---|
6281 | zns = pi / 2._wp / REAL(nzn, wp) |
---|
6282 | CASE ( isouth_u, isouth_l ) |
---|
6283 | az0 = pi / 2._wp |
---|
6284 | naz = raytrace_discrete_azims / 2 |
---|
6285 | azs = pi / REAL(naz, wp) |
---|
6286 | zn0 = 0._wp |
---|
6287 | nzn = raytrace_discrete_elevs |
---|
6288 | zns = pi / REAL(nzn, wp) |
---|
6289 | CASE ( inorth_u, inorth_l ) |
---|
6290 | az0 = - pi / 2._wp |
---|
6291 | naz = raytrace_discrete_azims / 2 |
---|
6292 | azs = pi / REAL(naz, wp) |
---|
6293 | zn0 = 0._wp |
---|
6294 | nzn = raytrace_discrete_elevs |
---|
6295 | zns = pi / REAL(nzn, wp) |
---|
6296 | CASE ( iwest_u, iwest_l ) |
---|
6297 | az0 = pi |
---|
6298 | naz = raytrace_discrete_azims / 2 |
---|
6299 | azs = pi / REAL(naz, wp) |
---|
6300 | zn0 = 0._wp |
---|
6301 | nzn = raytrace_discrete_elevs |
---|
6302 | zns = pi / REAL(nzn, wp) |
---|
6303 | CASE ( ieast_u, ieast_l ) |
---|
6304 | az0 = 0._wp |
---|
6305 | naz = raytrace_discrete_azims / 2 |
---|
6306 | azs = pi / REAL(naz, wp) |
---|
6307 | zn0 = 0._wp |
---|
6308 | nzn = raytrace_discrete_elevs |
---|
6309 | zns = pi / REAL(nzn, wp) |
---|
6310 | CASE DEFAULT |
---|
6311 | WRITE(message_string, *) 'ERROR: the surface type ', td, & |
---|
6312 | ' is not supported for calculating',& |
---|
6313 | ' SVF' |
---|
6314 | CALL message( 'radiation_calc_svf', 'PA0488', 1, 2, 0, 6, 0 ) |
---|
6315 | END SELECT |
---|
6316 | |
---|
6317 | ALLOCATE ( zdirs(1:nzn), zcent(1:nzn), zbdry(0:nzn), vffrac(1:nzn*naz), & |
---|
6318 | ztransp(1:nzn*naz), itarget(1:nzn*naz) ) !FIXME allocate itarget only |
---|
6319 | !in case of rad_angular_discretization |
---|
6320 | |
---|
6321 | itarg0 = 1 |
---|
6322 | itarg1 = nzn |
---|
6323 | zcent(:) = (/( zn0+(REAL(izn,wp)-.5_wp)*zns, izn=1, nzn )/) |
---|
6324 | zbdry(:) = (/( zn0+REAL(izn,wp)*zns, izn=0, nzn )/) |
---|
6325 | IF ( td == iup_u .OR. td == iup_l ) THEN |
---|
6326 | vffrac(1:nzn) = (COS(2 * zbdry(0:nzn-1)) - COS(2 * zbdry(1:nzn))) / 2._wp / REAL(naz, wp) |
---|
6327 | ! |
---|
6328 | !-- For horizontal target, vf fractions are constant per azimuth |
---|
6329 | DO iaz = 1, naz-1 |
---|
6330 | vffrac(iaz*nzn+1:(iaz+1)*nzn) = vffrac(1:nzn) |
---|
6331 | ENDDO |
---|
6332 | !-- sum of whole vffrac equals 1, verified |
---|
6333 | ENDIF |
---|
6334 | ! |
---|
6335 | !-- Calculate sky-view factor and direct solar visibility using 2D raytracing |
---|
6336 | DO iaz = 1, naz |
---|
6337 | azmid = az0 + (REAL(iaz, wp) - .5_wp) * azs |
---|
6338 | IF ( td /= iup_u .AND. td /= iup_l ) THEN |
---|
6339 | az2 = REAL(iaz, wp) * azs - pi/2._wp |
---|
6340 | az1 = az2 - azs |
---|
6341 | !TODO precalculate after 1st line |
---|
6342 | vffrac(itarg0:itarg1) = (SIN(az2) - SIN(az1)) & |
---|
6343 | * (zbdry(1:nzn) - zbdry(0:nzn-1) & |
---|
6344 | + SIN(zbdry(0:nzn-1))*COS(zbdry(0:nzn-1)) & |
---|
6345 | - SIN(zbdry(1:nzn))*COS(zbdry(1:nzn))) & |
---|
6346 | / (2._wp * pi) |
---|
6347 | !-- sum of whole vffrac equals 1, verified |
---|
6348 | ENDIF |
---|
6349 | yxdir(:) = (/ COS(azmid) / dy, SIN(azmid) / dx /) |
---|
6350 | yxlen = SQRT(SUM(yxdir(:)**2)) |
---|
6351 | zdirs(:) = COS(zcent(:)) / (dz(1) * yxlen * SIN(zcent(:))) |
---|
6352 | yxdir(:) = yxdir(:) / yxlen |
---|
6353 | |
---|
6354 | CALL raytrace_2d(ta, yxdir, nzn, zdirs, & |
---|
6355 | surfstart(myid) + isurflt, facearea(td), & |
---|
6356 | vffrac(itarg0:itarg1), .TRUE., .TRUE., & |
---|
6357 | .FALSE., lowest_free_ray, & |
---|
6358 | ztransp(itarg0:itarg1), & |
---|
6359 | itarget(itarg0:itarg1)) |
---|
6360 | |
---|
6361 | skyvf(isurflt) = skyvf(isurflt) + & |
---|
6362 | SUM(vffrac(itarg0:itarg0+lowest_free_ray-1)) |
---|
6363 | skyvft(isurflt) = skyvft(isurflt) + & |
---|
6364 | SUM(ztransp(itarg0:itarg0+lowest_free_ray-1) & |
---|
6365 | * vffrac(itarg0:itarg0+lowest_free_ray-1)) |
---|
6366 | |
---|
6367 | !-- Save direct solar transparency |
---|
6368 | j = MODULO(NINT(azmid/ & |
---|
6369 | (2._wp*pi)*raytrace_discrete_azims-.5_wp, iwp), & |
---|
6370 | raytrace_discrete_azims) |
---|
6371 | |
---|
6372 | DO k = 1, raytrace_discrete_elevs/2 |
---|
6373 | i = dsidir_rev(k-1, j) |
---|
6374 | IF ( i /= -1 .AND. k <= lowest_free_ray ) & |
---|
6375 | dsitrans(isurflt, i) = ztransp(itarg0+k-1) |
---|
6376 | ENDDO |
---|
6377 | |
---|
6378 | ! |
---|
6379 | !-- Advance itarget indices |
---|
6380 | itarg0 = itarg1 + 1 |
---|
6381 | itarg1 = itarg1 + nzn |
---|
6382 | ENDDO |
---|
6383 | |
---|
6384 | IF ( rad_angular_discretization ) THEN |
---|
6385 | !-- sort itarget by face id |
---|
6386 | CALL quicksort_itarget(itarget,vffrac,ztransp,1,nzn*naz) |
---|
6387 | ! |
---|
6388 | !-- find the first valid position |
---|
6389 | itarg0 = 1 |
---|
6390 | DO WHILE ( itarg0 <= nzn*naz ) |
---|
6391 | IF ( itarget(itarg0) /= -1 ) EXIT |
---|
6392 | itarg0 = itarg0 + 1 |
---|
6393 | ENDDO |
---|
6394 | |
---|
6395 | DO i = itarg0, nzn*naz |
---|
6396 | ! |
---|
6397 | !-- For duplicate values, only sum up vf fraction value |
---|
6398 | IF ( i < nzn*naz ) THEN |
---|
6399 | IF ( itarget(i+1) == itarget(i) ) THEN |
---|
6400 | vffrac(i+1) = vffrac(i+1) + vffrac(i) |
---|
6401 | CYCLE |
---|
6402 | ENDIF |
---|
6403 | ENDIF |
---|
6404 | ! |
---|
6405 | !-- write to the svf array |
---|
6406 | nsvfl = nsvfl + 1 |
---|
6407 | !-- check dimmension of asvf array and enlarge it if needed |
---|
6408 | IF ( nsvfla < nsvfl ) THEN |
---|
6409 | k = CEILING(REAL(nsvfla, kind=wp) * grow_factor) |
---|
6410 | IF ( msvf == 0 ) THEN |
---|
6411 | msvf = 1 |
---|
6412 | ALLOCATE( asvf1(k) ) |
---|
6413 | asvf => asvf1 |
---|
6414 | asvf1(1:nsvfla) = asvf2 |
---|
6415 | DEALLOCATE( asvf2 ) |
---|
6416 | ELSE |
---|
6417 | msvf = 0 |
---|
6418 | ALLOCATE( asvf2(k) ) |
---|
6419 | asvf => asvf2 |
---|
6420 | asvf2(1:nsvfla) = asvf1 |
---|
6421 | DEALLOCATE( asvf1 ) |
---|
6422 | ENDIF |
---|
6423 | |
---|
6424 | WRITE (msg,'(A,3I12)') 'Grow asvf:',nsvfl,nsvfla,k |
---|
6425 | CALL radiation_write_debug_log( msg ) |
---|
6426 | |
---|
6427 | nsvfla = k |
---|
6428 | ENDIF |
---|
6429 | !-- write svf values into the array |
---|
6430 | asvf(nsvfl)%isurflt = isurflt |
---|
6431 | asvf(nsvfl)%isurfs = itarget(i) |
---|
6432 | asvf(nsvfl)%rsvf = vffrac(i) |
---|
6433 | asvf(nsvfl)%rtransp = ztransp(i) |
---|
6434 | END DO |
---|
6435 | |
---|
6436 | ENDIF ! rad_angular_discretization |
---|
6437 | |
---|
6438 | DEALLOCATE ( zdirs, zcent, zbdry, vffrac, ztransp, itarget ) !FIXME itarget shall be allocated only |
---|
6439 | !in case of rad_angular_discretization |
---|
6440 | ! |
---|
6441 | !-- Following calculations only required for surface_reflections |
---|
6442 | IF ( surface_reflections .AND. .NOT. rad_angular_discretization ) THEN |
---|
6443 | |
---|
6444 | DO isurfs = 1, nsurf |
---|
6445 | IF ( .NOT. surface_facing(surfl(ix, isurflt), surfl(iy, isurflt), & |
---|
6446 | surfl(iz, isurflt), surfl(id, isurflt), & |
---|
6447 | surf(ix, isurfs), surf(iy, isurfs), & |
---|
6448 | surf(iz, isurfs), surf(id, isurfs)) ) THEN |
---|
6449 | CYCLE |
---|
6450 | ENDIF |
---|
6451 | |
---|
6452 | sd = surf(id, isurfs) |
---|
6453 | sa = (/ REAL(surf(iz, isurfs), wp) - 0.5_wp * kdir(sd), & |
---|
6454 | REAL(surf(iy, isurfs), wp) - 0.5_wp * jdir(sd), & |
---|
6455 | REAL(surf(ix, isurfs), wp) - 0.5_wp * idir(sd) /) |
---|
6456 | |
---|
6457 | !-- unit vector source -> target |
---|
6458 | uv = (/ (ta(1)-sa(1))*dz(1), (ta(2)-sa(2))*dy, (ta(3)-sa(3))*dx /) |
---|
6459 | sqdist = SUM(uv(:)**2) |
---|
6460 | uv = uv / SQRT(sqdist) |
---|
6461 | |
---|
6462 | !-- reject raytracing above max distance |
---|
6463 | IF ( SQRT(sqdist) > max_raytracing_dist ) THEN |
---|
6464 | ray_skip_maxdist = ray_skip_maxdist + 1 |
---|
6465 | CYCLE |
---|
6466 | ENDIF |
---|
6467 | |
---|
6468 | difvf = dot_product((/ kdir(sd), jdir(sd), idir(sd) /), uv) & ! cosine of source normal and direction |
---|
6469 | * dot_product((/ kdir(td), jdir(td), idir(td) /), -uv) & ! cosine of target normal and reverse direction |
---|
6470 | / (pi * sqdist) ! square of distance between centers |
---|
6471 | ! |
---|
6472 | !-- irradiance factor (our unshaded shape view factor) = view factor per differential target area * source area |
---|
6473 | rirrf = difvf * facearea(sd) |
---|
6474 | |
---|
6475 | !-- reject raytracing for potentially too small view factor values |
---|
6476 | IF ( rirrf < min_irrf_value ) THEN |
---|
6477 | ray_skip_minval = ray_skip_minval + 1 |
---|
6478 | CYCLE |
---|
6479 | ENDIF |
---|
6480 | |
---|
6481 | !-- raytrace + process plant canopy sinks within |
---|
6482 | CALL raytrace(sa, ta, isurfs, difvf, facearea(td), .TRUE., & |
---|
6483 | visible, transparency) |
---|
6484 | |
---|
6485 | IF ( .NOT. visible ) CYCLE |
---|
6486 | ! rsvf = rirrf * transparency |
---|
6487 | |
---|
6488 | !-- write to the svf array |
---|
6489 | nsvfl = nsvfl + 1 |
---|
6490 | !-- check dimmension of asvf array and enlarge it if needed |
---|
6491 | IF ( nsvfla < nsvfl ) THEN |
---|
6492 | k = CEILING(REAL(nsvfla, kind=wp) * grow_factor) |
---|
6493 | IF ( msvf == 0 ) THEN |
---|
6494 | msvf = 1 |
---|
6495 | ALLOCATE( asvf1(k) ) |
---|
6496 | asvf => asvf1 |
---|
6497 | asvf1(1:nsvfla) = asvf2 |
---|
6498 | DEALLOCATE( asvf2 ) |
---|
6499 | ELSE |
---|
6500 | msvf = 0 |
---|
6501 | ALLOCATE( asvf2(k) ) |
---|
6502 | asvf => asvf2 |
---|
6503 | asvf2(1:nsvfla) = asvf1 |
---|
6504 | DEALLOCATE( asvf1 ) |
---|
6505 | ENDIF |
---|
6506 | |
---|
6507 | WRITE(msg,'(A,3I12)') 'Grow asvf:',nsvfl,nsvfla,k |
---|
6508 | CALL radiation_write_debug_log( msg ) |
---|
6509 | |
---|
6510 | nsvfla = k |
---|
6511 | ENDIF |
---|
6512 | !-- write svf values into the array |
---|
6513 | asvf(nsvfl)%isurflt = isurflt |
---|
6514 | asvf(nsvfl)%isurfs = isurfs |
---|
6515 | asvf(nsvfl)%rsvf = rirrf !we postopne multiplication by transparency |
---|
6516 | asvf(nsvfl)%rtransp = transparency !a.k.a. Direct Irradiance Factor |
---|
6517 | ENDDO |
---|
6518 | ENDIF |
---|
6519 | ENDDO |
---|
6520 | |
---|
6521 | !-- |
---|
6522 | !-- Raytrace to canopy boxes to fill dsitransc TODO optimize |
---|
6523 | dsitransc(:,:) = 0._wp |
---|
6524 | az0 = 0._wp |
---|
6525 | naz = raytrace_discrete_azims |
---|
6526 | azs = 2._wp * pi / REAL(naz, wp) |
---|
6527 | zn0 = 0._wp |
---|
6528 | nzn = raytrace_discrete_elevs / 2 |
---|
6529 | zns = pi / 2._wp / REAL(nzn, wp) |
---|
6530 | ALLOCATE ( zdirs(1:nzn), zcent(1:nzn), vffrac(1:nzn), ztransp(1:nzn), & |
---|
6531 | itarget(1:nzn) ) |
---|
6532 | zcent(:) = (/( zn0+(REAL(izn,wp)-.5_wp)*zns, izn=1, nzn )/) |
---|
6533 | vffrac(:) = 0._wp |
---|
6534 | |
---|
6535 | DO ipcgb = 1, npcbl |
---|
6536 | ta = (/ REAL(pcbl(iz, ipcgb), wp), & |
---|
6537 | REAL(pcbl(iy, ipcgb), wp), & |
---|
6538 | REAL(pcbl(ix, ipcgb), wp) /) |
---|
6539 | !-- Calculate direct solar visibility using 2D raytracing |
---|
6540 | DO iaz = 1, naz |
---|
6541 | azmid = az0 + (REAL(iaz, wp) - .5_wp) * azs |
---|
6542 | yxdir(:) = (/ COS(azmid) / dy, SIN(azmid) / dx /) |
---|
6543 | yxlen = SQRT(SUM(yxdir(:)**2)) |
---|
6544 | zdirs(:) = COS(zcent(:)) / (dz(1) * yxlen * SIN(zcent(:))) |
---|
6545 | yxdir(:) = yxdir(:) / yxlen |
---|
6546 | CALL raytrace_2d(ta, yxdir, nzn, zdirs, & |
---|
6547 | -999, -999._wp, vffrac, .FALSE., .FALSE., .TRUE., & |
---|
6548 | lowest_free_ray, ztransp, itarget) |
---|
6549 | |
---|
6550 | !-- Save direct solar transparency |
---|
6551 | j = MODULO(NINT(azmid/ & |
---|
6552 | (2._wp*pi)*raytrace_discrete_azims-.5_wp, iwp), & |
---|
6553 | raytrace_discrete_azims) |
---|
6554 | DO k = 1, raytrace_discrete_elevs/2 |
---|
6555 | i = dsidir_rev(k-1, j) |
---|
6556 | IF ( i /= -1 .AND. k <= lowest_free_ray ) & |
---|
6557 | dsitransc(ipcgb, i) = ztransp(k) |
---|
6558 | ENDDO |
---|
6559 | ENDDO |
---|
6560 | ENDDO |
---|
6561 | DEALLOCATE ( zdirs, zcent, vffrac, ztransp, itarget ) |
---|
6562 | !-- |
---|
6563 | !-- Raytrace to MRT boxes |
---|
6564 | IF ( nmrtbl > 0 ) THEN |
---|
6565 | mrtdsit(:,:) = 0._wp |
---|
6566 | mrtsky(:) = 0._wp |
---|
6567 | mrtskyt(:) = 0._wp |
---|
6568 | az0 = 0._wp |
---|
6569 | naz = raytrace_discrete_azims |
---|
6570 | azs = 2._wp * pi / REAL(naz, wp) |
---|
6571 | zn0 = 0._wp |
---|
6572 | nzn = raytrace_discrete_elevs |
---|
6573 | zns = pi / REAL(nzn, wp) |
---|
6574 | ALLOCATE ( zdirs(1:nzn), zcent(1:nzn), zbdry(0:nzn), vffrac(1:nzn*naz), vffrac0(1:nzn), & |
---|
6575 | ztransp(1:nzn*naz), itarget(1:nzn*naz) ) !FIXME allocate itarget only |
---|
6576 | !in case of rad_angular_discretization |
---|
6577 | |
---|
6578 | zcent(:) = (/( zn0+(REAL(izn,wp)-.5_wp)*zns, izn=1, nzn )/) |
---|
6579 | zbdry(:) = (/( zn0+REAL(izn,wp)*zns, izn=0, nzn )/) |
---|
6580 | vffrac0(:) = (COS(zbdry(0:nzn-1)) - COS(zbdry(1:nzn))) / 2._wp / REAL(naz, wp) |
---|
6581 | ! |
---|
6582 | !--Modify direction weights to simulate human body (lower weight for top-down) |
---|
6583 | IF ( mrt_geom_human ) THEN |
---|
6584 | vffrac0(:) = vffrac0(:) * MAX(0._wp, SIN(zcent(:))*0.88_wp + COS(zcent(:))*0.12_wp) |
---|
6585 | vffrac0(:) = vffrac0(:) / (SUM(vffrac0) * REAL(naz, wp)) |
---|
6586 | ENDIF |
---|
6587 | |
---|
6588 | DO imrt = 1, nmrtbl |
---|
6589 | ta = (/ REAL(mrtbl(iz, imrt), wp), & |
---|
6590 | REAL(mrtbl(iy, imrt), wp), & |
---|
6591 | REAL(mrtbl(ix, imrt), wp) /) |
---|
6592 | ! |
---|
6593 | !-- vf fractions are constant per azimuth |
---|
6594 | DO iaz = 0, naz-1 |
---|
6595 | vffrac(iaz*nzn+1:(iaz+1)*nzn) = vffrac0(:) |
---|
6596 | ENDDO |
---|
6597 | !-- sum of whole vffrac equals 1, verified |
---|
6598 | itarg0 = 1 |
---|
6599 | itarg1 = nzn |
---|
6600 | ! |
---|
6601 | !-- Calculate sky-view factor and direct solar visibility using 2D raytracing |
---|
6602 | DO iaz = 1, naz |
---|
6603 | azmid = az0 + (REAL(iaz, wp) - .5_wp) * azs |
---|
6604 | yxdir(:) = (/ COS(azmid) / dy, SIN(azmid) / dx /) |
---|
6605 | yxlen = SQRT(SUM(yxdir(:)**2)) |
---|
6606 | zdirs(:) = COS(zcent(:)) / (dz(1) * yxlen * SIN(zcent(:))) |
---|
6607 | yxdir(:) = yxdir(:) / yxlen |
---|
6608 | |
---|
6609 | CALL raytrace_2d(ta, yxdir, nzn, zdirs, & |
---|
6610 | -999, -999._wp, vffrac(itarg0:itarg1), .TRUE., & |
---|
6611 | .FALSE., .TRUE., lowest_free_ray, & |
---|
6612 | ztransp(itarg0:itarg1), & |
---|
6613 | itarget(itarg0:itarg1)) |
---|
6614 | |
---|
6615 | !-- Sky view factors for MRT |
---|
6616 | mrtsky(imrt) = mrtsky(imrt) + & |
---|
6617 | SUM(vffrac(itarg0:itarg0+lowest_free_ray-1)) |
---|
6618 | mrtskyt(imrt) = mrtskyt(imrt) + & |
---|
6619 | SUM(ztransp(itarg0:itarg0+lowest_free_ray-1) & |
---|
6620 | * vffrac(itarg0:itarg0+lowest_free_ray-1)) |
---|
6621 | !-- Direct solar transparency for MRT |
---|
6622 | j = MODULO(NINT(azmid/ & |
---|
6623 | (2._wp*pi)*raytrace_discrete_azims-.5_wp, iwp), & |
---|
6624 | raytrace_discrete_azims) |
---|
6625 | DO k = 1, raytrace_discrete_elevs/2 |
---|
6626 | i = dsidir_rev(k-1, j) |
---|
6627 | IF ( i /= -1 .AND. k <= lowest_free_ray ) & |
---|
6628 | mrtdsit(imrt, i) = ztransp(itarg0+k-1) |
---|
6629 | ENDDO |
---|
6630 | ! |
---|
6631 | !-- Advance itarget indices |
---|
6632 | itarg0 = itarg1 + 1 |
---|
6633 | itarg1 = itarg1 + nzn |
---|
6634 | ENDDO |
---|
6635 | |
---|
6636 | !-- sort itarget by face id |
---|
6637 | CALL quicksort_itarget(itarget,vffrac,ztransp,1,nzn*naz) |
---|
6638 | ! |
---|
6639 | !-- find the first valid position |
---|
6640 | itarg0 = 1 |
---|
6641 | DO WHILE ( itarg0 <= nzn*naz ) |
---|
6642 | IF ( itarget(itarg0) /= -1 ) EXIT |
---|
6643 | itarg0 = itarg0 + 1 |
---|
6644 | ENDDO |
---|
6645 | |
---|
6646 | DO i = itarg0, nzn*naz |
---|
6647 | ! |
---|
6648 | !-- For duplicate values, only sum up vf fraction value |
---|
6649 | IF ( i < nzn*naz ) THEN |
---|
6650 | IF ( itarget(i+1) == itarget(i) ) THEN |
---|
6651 | vffrac(i+1) = vffrac(i+1) + vffrac(i) |
---|
6652 | CYCLE |
---|
6653 | ENDIF |
---|
6654 | ENDIF |
---|
6655 | ! |
---|
6656 | !-- write to the mrtf array |
---|
6657 | nmrtf = nmrtf + 1 |
---|
6658 | !-- check dimmension of mrtf array and enlarge it if needed |
---|
6659 | IF ( nmrtfa < nmrtf ) THEN |
---|
6660 | k = CEILING(REAL(nmrtfa, kind=wp) * grow_factor) |
---|
6661 | IF ( mmrtf == 0 ) THEN |
---|
6662 | mmrtf = 1 |
---|
6663 | ALLOCATE( amrtf1(k) ) |
---|
6664 | amrtf => amrtf1 |
---|
6665 | amrtf1(1:nmrtfa) = amrtf2 |
---|
6666 | DEALLOCATE( amrtf2 ) |
---|
6667 | ELSE |
---|
6668 | mmrtf = 0 |
---|
6669 | ALLOCATE( amrtf2(k) ) |
---|
6670 | amrtf => amrtf2 |
---|
6671 | amrtf2(1:nmrtfa) = amrtf1 |
---|
6672 | DEALLOCATE( amrtf1 ) |
---|
6673 | ENDIF |
---|
6674 | |
---|
6675 | WRITE (msg,'(A,3I12)') 'Grow amrtf:', nmrtf, nmrtfa, k |
---|
6676 | CALL radiation_write_debug_log( msg ) |
---|
6677 | |
---|
6678 | nmrtfa = k |
---|
6679 | ENDIF |
---|
6680 | !-- write mrtf values into the array |
---|
6681 | amrtf(nmrtf)%isurflt = imrt |
---|
6682 | amrtf(nmrtf)%isurfs = itarget(i) |
---|
6683 | amrtf(nmrtf)%rsvf = vffrac(i) |
---|
6684 | amrtf(nmrtf)%rtransp = ztransp(i) |
---|
6685 | ENDDO ! itarg |
---|
6686 | |
---|
6687 | ENDDO ! imrt |
---|
6688 | DEALLOCATE ( zdirs, zcent, zbdry, vffrac, vffrac0, ztransp, itarget ) |
---|
6689 | ! |
---|
6690 | !-- Move MRT factors to final arrays |
---|
6691 | ALLOCATE ( mrtf(nmrtf), mrtft(nmrtf), mrtfsurf(2,nmrtf) ) |
---|
6692 | DO imrtf = 1, nmrtf |
---|
6693 | mrtf(imrtf) = amrtf(imrtf)%rsvf |
---|
6694 | mrtft(imrtf) = amrtf(imrtf)%rsvf * amrtf(imrtf)%rtransp |
---|
6695 | mrtfsurf(:,imrtf) = (/amrtf(imrtf)%isurflt, amrtf(imrtf)%isurfs /) |
---|
6696 | ENDDO |
---|
6697 | IF ( ALLOCATED(amrtf1) ) DEALLOCATE( amrtf1 ) |
---|
6698 | IF ( ALLOCATED(amrtf2) ) DEALLOCATE( amrtf2 ) |
---|
6699 | ENDIF ! nmrtbl > 0 |
---|
6700 | |
---|
6701 | IF ( rad_angular_discretization ) THEN |
---|
6702 | #if defined( __parallel ) |
---|
6703 | !-- finalize MPI_RMA communication established to get global index of the surface from grid indices |
---|
6704 | !-- flush all MPI window pending requests |
---|
6705 | CALL MPI_Win_flush_all(win_gridsurf, ierr) |
---|
6706 | IF ( ierr /= 0 ) THEN |
---|
6707 | WRITE(9,*) 'Error MPI_Win_flush_all1:', ierr, win_gridsurf |
---|
6708 | FLUSH(9) |
---|
6709 | ENDIF |
---|
6710 | !-- unlock MPI window |
---|
6711 | CALL MPI_Win_unlock_all(win_gridsurf, ierr) |
---|
6712 | IF ( ierr /= 0 ) THEN |
---|
6713 | WRITE(9,*) 'Error MPI_Win_unlock_all1:', ierr, win_gridsurf |
---|
6714 | FLUSH(9) |
---|
6715 | ENDIF |
---|
6716 | !-- free MPI window |
---|
6717 | CALL MPI_Win_free(win_gridsurf, ierr) |
---|
6718 | IF ( ierr /= 0 ) THEN |
---|
6719 | WRITE(9,*) 'Error MPI_Win_free1:', ierr, win_gridsurf |
---|
6720 | FLUSH(9) |
---|
6721 | ENDIF |
---|
6722 | #else |
---|
6723 | DEALLOCATE ( gridsurf ) |
---|
6724 | #endif |
---|
6725 | ENDIF |
---|
6726 | |
---|
6727 | CALL radiation_write_debug_log( 'End of calculation SVF' ) |
---|
6728 | WRITE(msg, *) 'Raytracing skipped for maximum distance of ', & |
---|
6729 | max_raytracing_dist, ' m on ', ray_skip_maxdist, ' pairs.' |
---|
6730 | CALL radiation_write_debug_log( msg ) |
---|
6731 | WRITE(msg, *) 'Raytracing skipped for minimum potential value of ', & |
---|
6732 | min_irrf_value , ' on ', ray_skip_minval, ' pairs.' |
---|
6733 | CALL radiation_write_debug_log( msg ) |
---|
6734 | |
---|
6735 | CALL location_message( ' waiting for completion of SVF and CSF calculation in all processes', .TRUE. ) |
---|
6736 | !-- deallocate temporary global arrays |
---|
6737 | DEALLOCATE(nzterr) |
---|
6738 | |
---|
6739 | IF ( plant_canopy ) THEN |
---|
6740 | !-- finalize mpi_rma communication and deallocate temporary arrays |
---|
6741 | #if defined( __parallel ) |
---|
6742 | IF ( raytrace_mpi_rma ) THEN |
---|
6743 | CALL MPI_Win_flush_all(win_lad, ierr) |
---|
6744 | IF ( ierr /= 0 ) THEN |
---|
6745 | WRITE(9,*) 'Error MPI_Win_flush_all2:', ierr, win_lad |
---|
6746 | FLUSH(9) |
---|
6747 | ENDIF |
---|
6748 | !-- unlock MPI window |
---|
6749 | CALL MPI_Win_unlock_all(win_lad, ierr) |
---|
6750 | IF ( ierr /= 0 ) THEN |
---|
6751 | WRITE(9,*) 'Error MPI_Win_unlock_all2:', ierr, win_lad |
---|
6752 | FLUSH(9) |
---|
6753 | ENDIF |
---|
6754 | !-- free MPI window |
---|
6755 | CALL MPI_Win_free(win_lad, ierr) |
---|
6756 | IF ( ierr /= 0 ) THEN |
---|
6757 | WRITE(9,*) 'Error MPI_Win_free2:', ierr, win_lad |
---|
6758 | FLUSH(9) |
---|
6759 | ENDIF |
---|
6760 | !-- deallocate temporary arrays storing values for csf calculation during raytracing |
---|
6761 | DEALLOCATE( lad_s_ray ) |
---|
6762 | !-- sub_lad is the pointer to lad_s_rma in case of raytrace_mpi_rma |
---|
6763 | !-- and must not be deallocated here |
---|
6764 | ELSE |
---|
6765 | DEALLOCATE(sub_lad) |
---|
6766 | DEALLOCATE(sub_lad_g) |
---|
6767 | ENDIF |
---|
6768 | #else |
---|
6769 | DEALLOCATE(sub_lad) |
---|
6770 | #endif |
---|
6771 | DEALLOCATE( boxes ) |
---|
6772 | DEALLOCATE( crlens ) |
---|
6773 | DEALLOCATE( plantt ) |
---|
6774 | DEALLOCATE( rt2_track, rt2_track_lad, rt2_track_dist, rt2_dist ) |
---|
6775 | ENDIF |
---|
6776 | |
---|
6777 | CALL location_message( ' calculation of the complete SVF array', .TRUE. ) |
---|
6778 | |
---|
6779 | IF ( rad_angular_discretization ) THEN |
---|
6780 | CALL radiation_write_debug_log( 'Load svf from the structure array to plain arrays' ) |
---|
6781 | ALLOCATE( svf(ndsvf,nsvfl) ) |
---|
6782 | ALLOCATE( svfsurf(idsvf,nsvfl) ) |
---|
6783 | |
---|
6784 | DO isvf = 1, nsvfl |
---|
6785 | svf(:, isvf) = (/ asvf(isvf)%rsvf, asvf(isvf)%rtransp /) |
---|
6786 | svfsurf(:, isvf) = (/ asvf(isvf)%isurflt, asvf(isvf)%isurfs /) |
---|
6787 | ENDDO |
---|
6788 | ELSE |
---|
6789 | CALL radiation_write_debug_log( 'Start SVF sort' ) |
---|
6790 | !-- sort svf ( a version of quicksort ) |
---|
6791 | CALL quicksort_svf(asvf,1,nsvfl) |
---|
6792 | |
---|
6793 | !< load svf from the structure array to plain arrays |
---|
6794 | CALL radiation_write_debug_log( 'Load svf from the structure array to plain arrays' ) |
---|
6795 | ALLOCATE( svf(ndsvf,nsvfl) ) |
---|
6796 | ALLOCATE( svfsurf(idsvf,nsvfl) ) |
---|
6797 | svfnorm_counts(:) = 0._wp |
---|
6798 | isurflt_prev = -1 |
---|
6799 | ksvf = 1 |
---|
6800 | svfsum = 0._wp |
---|
6801 | DO isvf = 1, nsvfl |
---|
6802 | !-- normalize svf per target face |
---|
6803 | IF ( asvf(ksvf)%isurflt /= isurflt_prev ) THEN |
---|
6804 | IF ( isurflt_prev /= -1 .AND. svfsum /= 0._wp ) THEN |
---|
6805 | !< update histogram of logged svf normalization values |
---|
6806 | i = searchsorted(svfnorm_report_thresh, svfsum / (1._wp-skyvf(isurflt_prev))) |
---|
6807 | svfnorm_counts(i) = svfnorm_counts(i) + 1 |
---|
6808 | |
---|
6809 | svf(1, isvf_surflt:isvf-1) = svf(1, isvf_surflt:isvf-1) / svfsum * (1._wp-skyvf(isurflt_prev)) |
---|
6810 | ENDIF |
---|
6811 | isurflt_prev = asvf(ksvf)%isurflt |
---|
6812 | isvf_surflt = isvf |
---|
6813 | svfsum = asvf(ksvf)%rsvf !?? / asvf(ksvf)%rtransp |
---|
6814 | ELSE |
---|
6815 | svfsum = svfsum + asvf(ksvf)%rsvf !?? / asvf(ksvf)%rtransp |
---|
6816 | ENDIF |
---|
6817 | |
---|
6818 | svf(:, isvf) = (/ asvf(ksvf)%rsvf, asvf(ksvf)%rtransp /) |
---|
6819 | svfsurf(:, isvf) = (/ asvf(ksvf)%isurflt, asvf(ksvf)%isurfs /) |
---|
6820 | |
---|
6821 | !-- next element |
---|
6822 | ksvf = ksvf + 1 |
---|
6823 | ENDDO |
---|
6824 | |
---|
6825 | IF ( isurflt_prev /= -1 .AND. svfsum /= 0._wp ) THEN |
---|
6826 | i = searchsorted(svfnorm_report_thresh, svfsum / (1._wp-skyvf(isurflt_prev))) |
---|
6827 | svfnorm_counts(i) = svfnorm_counts(i) + 1 |
---|
6828 | |
---|
6829 | svf(1, isvf_surflt:nsvfl) = svf(1, isvf_surflt:nsvfl) / svfsum * (1._wp-skyvf(isurflt_prev)) |
---|
6830 | ENDIF |
---|
6831 | WRITE(9, *) 'SVF normalization histogram:', svfnorm_counts, & |
---|
6832 | 'on thresholds:', svfnorm_report_thresh(1:svfnorm_report_num), '(val < thresh <= val)' |
---|
6833 | !TODO we should be able to deallocate skyvf, from now on we only need skyvft |
---|
6834 | ENDIF ! rad_angular_discretization |
---|
6835 | |
---|
6836 | !-- deallocate temporary asvf array |
---|
6837 | !-- DEALLOCATE(asvf) - ifort has a problem with deallocation of allocatable target |
---|
6838 | !-- via pointing pointer - we need to test original targets |
---|
6839 | IF ( ALLOCATED(asvf1) ) THEN |
---|
6840 | DEALLOCATE(asvf1) |
---|
6841 | ENDIF |
---|
6842 | IF ( ALLOCATED(asvf2) ) THEN |
---|
6843 | DEALLOCATE(asvf2) |
---|
6844 | ENDIF |
---|
6845 | |
---|
6846 | npcsfl = 0 |
---|
6847 | IF ( plant_canopy ) THEN |
---|
6848 | |
---|
6849 | CALL location_message( ' calculation of the complete CSF array', .TRUE. ) |
---|
6850 | CALL radiation_write_debug_log( 'Calculation of the complete CSF array' ) |
---|
6851 | !-- sort and merge csf for the last time, keeping the array size to minimum |
---|
6852 | CALL merge_and_grow_csf(-1) |
---|
6853 | |
---|
6854 | !-- aggregate csb among processors |
---|
6855 | !-- allocate necessary arrays |
---|
6856 | udim = max(ncsfl,1) |
---|
6857 | ALLOCATE( csflt_l(ndcsf*udim) ) |
---|
6858 | csflt(1:ndcsf,1:udim) => csflt_l(1:ndcsf*udim) |
---|
6859 | ALLOCATE( kcsflt_l(kdcsf*udim) ) |
---|
6860 | kcsflt(1:kdcsf,1:udim) => kcsflt_l(1:kdcsf*udim) |
---|
6861 | ALLOCATE( icsflt(0:numprocs-1) ) |
---|
6862 | ALLOCATE( dcsflt(0:numprocs-1) ) |
---|
6863 | ALLOCATE( ipcsflt(0:numprocs-1) ) |
---|
6864 | ALLOCATE( dpcsflt(0:numprocs-1) ) |
---|
6865 | |
---|
6866 | !-- fill out arrays of csf values and |
---|
6867 | !-- arrays of number of elements and displacements |
---|
6868 | !-- for particular precessors |
---|
6869 | icsflt = 0 |
---|
6870 | dcsflt = 0 |
---|
6871 | ip = -1 |
---|
6872 | j = -1 |
---|
6873 | d = 0 |
---|
6874 | DO kcsf = 1, ncsfl |
---|
6875 | j = j+1 |
---|
6876 | IF ( acsf(kcsf)%ip /= ip ) THEN |
---|
6877 | !-- new block of the processor |
---|
6878 | !-- number of elements of previous block |
---|
6879 | IF ( ip>=0) icsflt(ip) = j |
---|
6880 | d = d+j |
---|
6881 | !-- blank blocks |
---|
6882 | DO jp = ip+1, acsf(kcsf)%ip-1 |
---|
6883 | !-- number of elements is zero, displacement is equal to previous |
---|
6884 | icsflt(jp) = 0 |
---|
6885 | dcsflt(jp) = d |
---|
6886 | ENDDO |
---|
6887 | !-- the actual block |
---|
6888 | ip = acsf(kcsf)%ip |
---|
6889 | dcsflt(ip) = d |
---|
6890 | j = 0 |
---|
6891 | ENDIF |
---|
6892 | csflt(1,kcsf) = acsf(kcsf)%rcvf |
---|
6893 | !-- fill out integer values of itz,ity,itx,isurfs |
---|
6894 | kcsflt(1,kcsf) = acsf(kcsf)%itz |
---|
6895 | kcsflt(2,kcsf) = acsf(kcsf)%ity |
---|
6896 | kcsflt(3,kcsf) = acsf(kcsf)%itx |
---|
6897 | kcsflt(4,kcsf) = acsf(kcsf)%isurfs |
---|
6898 | ENDDO |
---|
6899 | !-- last blank blocks at the end of array |
---|
6900 | j = j+1 |
---|
6901 | IF ( ip>=0 ) icsflt(ip) = j |
---|
6902 | d = d+j |
---|
6903 | DO jp = ip+1, numprocs-1 |
---|
6904 | !-- number of elements is zero, displacement is equal to previous |
---|
6905 | icsflt(jp) = 0 |
---|
6906 | dcsflt(jp) = d |
---|
6907 | ENDDO |
---|
6908 | |
---|
6909 | !-- deallocate temporary acsf array |
---|
6910 | !-- DEALLOCATE(acsf) - ifort has a problem with deallocation of allocatable target |
---|
6911 | !-- via pointing pointer - we need to test original targets |
---|
6912 | IF ( ALLOCATED(acsf1) ) THEN |
---|
6913 | DEALLOCATE(acsf1) |
---|
6914 | ENDIF |
---|
6915 | IF ( ALLOCATED(acsf2) ) THEN |
---|
6916 | DEALLOCATE(acsf2) |
---|
6917 | ENDIF |
---|
6918 | |
---|
6919 | #if defined( __parallel ) |
---|
6920 | !-- scatter and gather the number of elements to and from all processor |
---|
6921 | !-- and calculate displacements |
---|
6922 | CALL radiation_write_debug_log( 'Scatter and gather the number of elements to and from all processor' ) |
---|
6923 | CALL MPI_AlltoAll(icsflt,1,MPI_INTEGER,ipcsflt,1,MPI_INTEGER,comm2d, ierr) |
---|
6924 | IF ( ierr /= 0 ) THEN |
---|
6925 | WRITE(9,*) 'Error MPI_AlltoAll1:', ierr, SIZE(icsflt), SIZE(ipcsflt) |
---|
6926 | FLUSH(9) |
---|
6927 | ENDIF |
---|
6928 | |
---|
6929 | npcsfl = SUM(ipcsflt) |
---|
6930 | d = 0 |
---|
6931 | DO i = 0, numprocs-1 |
---|
6932 | dpcsflt(i) = d |
---|
6933 | d = d + ipcsflt(i) |
---|
6934 | ENDDO |
---|
6935 | |
---|
6936 | !-- exchange csf fields between processors |
---|
6937 | CALL radiation_write_debug_log( 'Exchange csf fields between processors' ) |
---|
6938 | udim = max(npcsfl,1) |
---|
6939 | ALLOCATE( pcsflt_l(ndcsf*udim) ) |
---|
6940 | pcsflt(1:ndcsf,1:udim) => pcsflt_l(1:ndcsf*udim) |
---|
6941 | ALLOCATE( kpcsflt_l(kdcsf*udim) ) |
---|
6942 | kpcsflt(1:kdcsf,1:udim) => kpcsflt_l(1:kdcsf*udim) |
---|
6943 | CALL MPI_AlltoAllv(csflt_l, ndcsf*icsflt, ndcsf*dcsflt, MPI_REAL, & |
---|
6944 | pcsflt_l, ndcsf*ipcsflt, ndcsf*dpcsflt, MPI_REAL, comm2d, ierr) |
---|
6945 | IF ( ierr /= 0 ) THEN |
---|
6946 | WRITE(9,*) 'Error MPI_AlltoAllv1:', ierr, SIZE(ipcsflt), ndcsf*icsflt, & |
---|
6947 | ndcsf*dcsflt, SIZE(pcsflt_l),ndcsf*ipcsflt, ndcsf*dpcsflt |
---|
6948 | FLUSH(9) |
---|
6949 | ENDIF |
---|
6950 | |
---|
6951 | CALL MPI_AlltoAllv(kcsflt_l, kdcsf*icsflt, kdcsf*dcsflt, MPI_INTEGER, & |
---|
6952 | kpcsflt_l, kdcsf*ipcsflt, kdcsf*dpcsflt, MPI_INTEGER, comm2d, ierr) |
---|
6953 | IF ( ierr /= 0 ) THEN |
---|
6954 | WRITE(9,*) 'Error MPI_AlltoAllv2:', ierr, SIZE(kcsflt_l),kdcsf*icsflt, & |
---|
6955 | kdcsf*dcsflt, SIZE(kpcsflt_l), kdcsf*ipcsflt, kdcsf*dpcsflt |
---|
6956 | FLUSH(9) |
---|
6957 | ENDIF |
---|
6958 | |
---|
6959 | #else |
---|
6960 | npcsfl = ncsfl |
---|
6961 | ALLOCATE( pcsflt(ndcsf,max(npcsfl,ndcsf)) ) |
---|
6962 | ALLOCATE( kpcsflt(kdcsf,max(npcsfl,kdcsf)) ) |
---|
6963 | pcsflt = csflt |
---|
6964 | kpcsflt = kcsflt |
---|
6965 | #endif |
---|
6966 | |
---|
6967 | !-- deallocate temporary arrays |
---|
6968 | DEALLOCATE( csflt_l ) |
---|
6969 | DEALLOCATE( kcsflt_l ) |
---|
6970 | DEALLOCATE( icsflt ) |
---|
6971 | DEALLOCATE( dcsflt ) |
---|
6972 | DEALLOCATE( ipcsflt ) |
---|
6973 | DEALLOCATE( dpcsflt ) |
---|
6974 | |
---|
6975 | !-- sort csf ( a version of quicksort ) |
---|
6976 | CALL radiation_write_debug_log( 'Sort csf' ) |
---|
6977 | CALL quicksort_csf2(kpcsflt, pcsflt, 1, npcsfl) |
---|
6978 | |
---|
6979 | !-- aggregate canopy sink factor records with identical box & source |
---|
6980 | !-- againg across all values from all processors |
---|
6981 | CALL radiation_write_debug_log( 'Aggregate canopy sink factor records with identical box' ) |
---|
6982 | |
---|
6983 | IF ( npcsfl > 0 ) THEN |
---|
6984 | icsf = 1 !< reading index |
---|
6985 | kcsf = 1 !< writing index |
---|
6986 | DO while (icsf < npcsfl) |
---|
6987 | !-- here kpcsf(kcsf) already has values from kpcsf(icsf) |
---|
6988 | IF ( kpcsflt(3,icsf) == kpcsflt(3,icsf+1) .AND. & |
---|
6989 | kpcsflt(2,icsf) == kpcsflt(2,icsf+1) .AND. & |
---|
6990 | kpcsflt(1,icsf) == kpcsflt(1,icsf+1) .AND. & |
---|
6991 | kpcsflt(4,icsf) == kpcsflt(4,icsf+1) ) THEN |
---|
6992 | |
---|
6993 | pcsflt(1,kcsf) = pcsflt(1,kcsf) + pcsflt(1,icsf+1) |
---|
6994 | |
---|
6995 | !-- advance reading index, keep writing index |
---|
6996 | icsf = icsf + 1 |
---|
6997 | ELSE |
---|
6998 | !-- not identical, just advance and copy |
---|
6999 | icsf = icsf + 1 |
---|
7000 | kcsf = kcsf + 1 |
---|
7001 | kpcsflt(:,kcsf) = kpcsflt(:,icsf) |
---|
7002 | pcsflt(:,kcsf) = pcsflt(:,icsf) |
---|
7003 | ENDIF |
---|
7004 | ENDDO |
---|
7005 | !-- last written item is now also the last item in valid part of array |
---|
7006 | npcsfl = kcsf |
---|
7007 | ENDIF |
---|
7008 | |
---|
7009 | ncsfl = npcsfl |
---|
7010 | IF ( ncsfl > 0 ) THEN |
---|
7011 | ALLOCATE( csf(ndcsf,ncsfl) ) |
---|
7012 | ALLOCATE( csfsurf(idcsf,ncsfl) ) |
---|
7013 | DO icsf = 1, ncsfl |
---|
7014 | csf(:,icsf) = pcsflt(:,icsf) |
---|
7015 | csfsurf(1,icsf) = gridpcbl(kpcsflt(1,icsf),kpcsflt(2,icsf),kpcsflt(3,icsf)) |
---|
7016 | csfsurf(2,icsf) = kpcsflt(4,icsf) |
---|
7017 | ENDDO |
---|
7018 | ENDIF |
---|
7019 | |
---|
7020 | !-- deallocation of temporary arrays |
---|
7021 | IF ( npcbl > 0 ) DEALLOCATE( gridpcbl ) |
---|
7022 | DEALLOCATE( pcsflt_l ) |
---|
7023 | DEALLOCATE( kpcsflt_l ) |
---|
7024 | CALL radiation_write_debug_log( 'End of aggregate csf' ) |
---|
7025 | |
---|
7026 | ENDIF |
---|
7027 | |
---|
7028 | #if defined( __parallel ) |
---|
7029 | CALL MPI_BARRIER( comm2d, ierr ) |
---|
7030 | #endif |
---|
7031 | CALL radiation_write_debug_log( 'End of radiation_calc_svf (after mpi_barrier)' ) |
---|
7032 | |
---|
7033 | RETURN |
---|
7034 | |
---|
7035 | ! WRITE( message_string, * ) & |
---|
7036 | ! 'I/O error when processing shape view factors / ', & |
---|
7037 | ! 'plant canopy sink factors / direct irradiance factors.' |
---|
7038 | ! CALL message( 'init_urban_surface', 'PA0502', 2, 2, 0, 6, 0 ) |
---|
7039 | |
---|
7040 | END SUBROUTINE radiation_calc_svf |
---|
7041 | |
---|
7042 | |
---|
7043 | !------------------------------------------------------------------------------! |
---|
7044 | ! Description: |
---|
7045 | ! ------------ |
---|
7046 | !> Raytracing for detecting obstacles and calculating compound canopy sink |
---|
7047 | !> factors. (A simple obstacle detection would only need to process faces in |
---|
7048 | !> 3 dimensions without any ordering.) |
---|
7049 | !> Assumtions: |
---|
7050 | !> ----------- |
---|
7051 | !> 1. The ray always originates from a face midpoint (only one coordinate equals |
---|
7052 | !> *.5, i.e. wall) and doesn't travel parallel to the surface (that would mean |
---|
7053 | !> shape factor=0). Therefore, the ray may never travel exactly along a face |
---|
7054 | !> or an edge. |
---|
7055 | !> 2. From grid bottom to urban surface top the grid has to be *equidistant* |
---|
7056 | !> within each of the dimensions, including vertical (but the resolution |
---|
7057 | !> doesn't need to be the same in all three dimensions). |
---|
7058 | !------------------------------------------------------------------------------! |
---|
7059 | SUBROUTINE raytrace(src, targ, isrc, difvf, atarg, create_csf, visible, transparency) |
---|
7060 | IMPLICIT NONE |
---|
7061 | |
---|
7062 | REAL(wp), DIMENSION(3), INTENT(in) :: src, targ !< real coordinates z,y,x |
---|
7063 | INTEGER(iwp), INTENT(in) :: isrc !< index of source face for csf |
---|
7064 | REAL(wp), INTENT(in) :: difvf !< differential view factor for csf |
---|
7065 | REAL(wp), INTENT(in) :: atarg !< target surface area for csf |
---|
7066 | LOGICAL, INTENT(in) :: create_csf !< whether to generate new CSFs during raytracing |
---|
7067 | LOGICAL, INTENT(out) :: visible |
---|
7068 | REAL(wp), INTENT(out) :: transparency !< along whole path |
---|
7069 | INTEGER(iwp) :: i, k, d |
---|
7070 | INTEGER(iwp) :: seldim !< dimension to be incremented |
---|
7071 | INTEGER(iwp) :: ncsb !< no of written plant canopy sinkboxes |
---|
7072 | INTEGER(iwp) :: maxboxes !< max no of gridboxes visited |
---|
7073 | REAL(wp) :: distance !< euclidean along path |
---|
7074 | REAL(wp) :: crlen !< length of gridbox crossing |
---|
7075 | REAL(wp) :: lastdist !< beginning of current crossing |
---|
7076 | REAL(wp) :: nextdist !< end of current crossing |
---|
7077 | REAL(wp) :: realdist !< distance in meters per unit distance |
---|
7078 | REAL(wp) :: crmid !< midpoint of crossing |
---|
7079 | REAL(wp) :: cursink !< sink factor for current canopy box |
---|
7080 | REAL(wp), DIMENSION(3) :: delta !< path vector |
---|
7081 | REAL(wp), DIMENSION(3) :: uvect !< unit vector |
---|
7082 | REAL(wp), DIMENSION(3) :: dimnextdist !< distance for each dimension increments |
---|
7083 | INTEGER(iwp), DIMENSION(3) :: box !< gridbox being crossed |
---|
7084 | INTEGER(iwp), DIMENSION(3) :: dimnext !< next dimension increments along path |
---|
7085 | INTEGER(iwp), DIMENSION(3) :: dimdelta !< dimension direction = +- 1 |
---|
7086 | INTEGER(iwp) :: px, py !< number of processors in x and y dir before |
---|
7087 | !< the processor in the question |
---|
7088 | INTEGER(iwp) :: ip !< number of processor where gridbox reside |
---|
7089 | INTEGER(iwp) :: ig !< 1D index of gridbox in global 2D array |
---|
7090 | |
---|
7091 | REAL(wp) :: eps = 1E-10_wp !< epsilon for value comparison |
---|
7092 | REAL(wp) :: lad_s_target !< recieved lad_s of particular grid box |
---|
7093 | |
---|
7094 | ! |
---|
7095 | !-- Maximum number of gridboxes visited equals to maximum number of boundaries crossed in each dimension plus one. That's also |
---|
7096 | !-- the maximum number of plant canopy boxes written. We grow the acsf array accordingly using exponential factor. |
---|
7097 | maxboxes = SUM(ABS(NINT(targ, iwp) - NINT(src, iwp))) + 1 |
---|
7098 | IF ( plant_canopy .AND. ncsfl + maxboxes > ncsfla ) THEN |
---|
7099 | !-- use this code for growing by fixed exponential increments (equivalent to case where ncsfl always increases by 1) |
---|
7100 | !-- k = CEILING(grow_factor ** real(CEILING(log(real(ncsfl + maxboxes, kind=wp)) & |
---|
7101 | !-- / log(grow_factor)), kind=wp)) |
---|
7102 | !-- or use this code to simply always keep some extra space after growing |
---|
7103 | k = CEILING(REAL(ncsfl + maxboxes, kind=wp) * grow_factor) |
---|
7104 | |
---|
7105 | CALL merge_and_grow_csf(k) |
---|
7106 | ENDIF |
---|
7107 | |
---|
7108 | transparency = 1._wp |
---|
7109 | ncsb = 0 |
---|
7110 | |
---|
7111 | delta(:) = targ(:) - src(:) |
---|
7112 | distance = SQRT(SUM(delta(:)**2)) |
---|
7113 | IF ( distance == 0._wp ) THEN |
---|
7114 | visible = .TRUE. |
---|
7115 | RETURN |
---|
7116 | ENDIF |
---|
7117 | uvect(:) = delta(:) / distance |
---|
7118 | realdist = SQRT(SUM( (uvect(:)*(/dz(1),dy,dx/))**2 )) |
---|
7119 | |
---|
7120 | lastdist = 0._wp |
---|
7121 | |
---|
7122 | !-- Since all face coordinates have values *.5 and we'd like to use |
---|
7123 | !-- integers, all these have .5 added |
---|
7124 | DO d = 1, 3 |
---|
7125 | IF ( uvect(d) == 0._wp ) THEN |
---|
7126 | dimnext(d) = 999999999 |
---|
7127 | dimdelta(d) = 999999999 |
---|
7128 | dimnextdist(d) = 1.0E20_wp |
---|
7129 | ELSE IF ( uvect(d) > 0._wp ) THEN |
---|
7130 | dimnext(d) = CEILING(src(d) + .5_wp) |
---|
7131 | dimdelta(d) = 1 |
---|
7132 | dimnextdist(d) = (dimnext(d) - .5_wp - src(d)) / uvect(d) |
---|
7133 | ELSE |
---|
7134 | dimnext(d) = FLOOR(src(d) + .5_wp) |
---|
7135 | dimdelta(d) = -1 |
---|
7136 | dimnextdist(d) = (dimnext(d) - .5_wp - src(d)) / uvect(d) |
---|
7137 | ENDIF |
---|
7138 | ENDDO |
---|
7139 | |
---|
7140 | DO |
---|
7141 | !-- along what dimension will the next wall crossing be? |
---|
7142 | seldim = minloc(dimnextdist, 1) |
---|
7143 | nextdist = dimnextdist(seldim) |
---|
7144 | IF ( nextdist > distance ) nextdist = distance |
---|
7145 | |
---|
7146 | crlen = nextdist - lastdist |
---|
7147 | IF ( crlen > .001_wp ) THEN |
---|
7148 | crmid = (lastdist + nextdist) * .5_wp |
---|
7149 | box = NINT(src(:) + uvect(:) * crmid, iwp) |
---|
7150 | |
---|
7151 | !-- calculate index of the grid with global indices (box(2),box(3)) |
---|
7152 | !-- in the array nzterr and plantt and id of the coresponding processor |
---|
7153 | px = box(3)/nnx |
---|
7154 | py = box(2)/nny |
---|
7155 | ip = px*pdims(2)+py |
---|
7156 | ig = ip*nnx*nny + (box(3)-px*nnx)*nny + box(2)-py*nny |
---|
7157 | IF ( box(1) <= nzterr(ig) ) THEN |
---|
7158 | visible = .FALSE. |
---|
7159 | RETURN |
---|
7160 | ENDIF |
---|
7161 | |
---|
7162 | IF ( plant_canopy ) THEN |
---|
7163 | IF ( box(1) <= plantt(ig) ) THEN |
---|
7164 | ncsb = ncsb + 1 |
---|
7165 | boxes(:,ncsb) = box |
---|
7166 | crlens(ncsb) = crlen |
---|
7167 | #if defined( __parallel ) |
---|
7168 | lad_ip(ncsb) = ip |
---|
7169 | lad_disp(ncsb) = (box(3)-px*nnx)*(nny*nzp) + (box(2)-py*nny)*nzp + box(1)-nzub |
---|
7170 | #endif |
---|
7171 | ENDIF |
---|
7172 | ENDIF |
---|
7173 | ENDIF |
---|
7174 | |
---|
7175 | IF ( ABS(distance - nextdist) < eps ) EXIT |
---|
7176 | lastdist = nextdist |
---|
7177 | dimnext(seldim) = dimnext(seldim) + dimdelta(seldim) |
---|
7178 | dimnextdist(seldim) = (dimnext(seldim) - .5_wp - src(seldim)) / uvect(seldim) |
---|
7179 | ENDDO |
---|
7180 | |
---|
7181 | IF ( plant_canopy ) THEN |
---|
7182 | #if defined( __parallel ) |
---|
7183 | IF ( raytrace_mpi_rma ) THEN |
---|
7184 | !-- send requests for lad_s to appropriate processor |
---|
7185 | CALL cpu_log( log_point_s(77), 'rad_rma_lad', 'start' ) |
---|
7186 | DO i = 1, ncsb |
---|
7187 | CALL MPI_Get(lad_s_ray(i), 1, MPI_REAL, lad_ip(i), lad_disp(i), & |
---|
7188 | 1, MPI_REAL, win_lad, ierr) |
---|
7189 | IF ( ierr /= 0 ) THEN |
---|
7190 | WRITE(9,*) 'Error MPI_Get1:', ierr, lad_s_ray(i), & |
---|
7191 | lad_ip(i), lad_disp(i), win_lad |
---|
7192 | FLUSH(9) |
---|
7193 | ENDIF |
---|
7194 | ENDDO |
---|
7195 | |
---|
7196 | !-- wait for all pending local requests complete |
---|
7197 | CALL MPI_Win_flush_local_all(win_lad, ierr) |
---|
7198 | IF ( ierr /= 0 ) THEN |
---|
7199 | WRITE(9,*) 'Error MPI_Win_flush_local_all1:', ierr, win_lad |
---|
7200 | FLUSH(9) |
---|
7201 | ENDIF |
---|
7202 | CALL cpu_log( log_point_s(77), 'rad_rma_lad', 'stop' ) |
---|
7203 | |
---|
7204 | ENDIF |
---|
7205 | #endif |
---|
7206 | |
---|
7207 | !-- calculate csf and transparency |
---|
7208 | DO i = 1, ncsb |
---|
7209 | #if defined( __parallel ) |
---|
7210 | IF ( raytrace_mpi_rma ) THEN |
---|
7211 | lad_s_target = lad_s_ray(i) |
---|
7212 | ELSE |
---|
7213 | lad_s_target = sub_lad_g(lad_ip(i)*nnx*nny*nzp + lad_disp(i)) |
---|
7214 | ENDIF |
---|
7215 | #else |
---|
7216 | lad_s_target = sub_lad(boxes(1,i),boxes(2,i),boxes(3,i)) |
---|
7217 | #endif |
---|
7218 | cursink = 1._wp - exp(-ext_coef * lad_s_target * crlens(i)*realdist) |
---|
7219 | |
---|
7220 | IF ( create_csf ) THEN |
---|
7221 | !-- write svf values into the array |
---|
7222 | ncsfl = ncsfl + 1 |
---|
7223 | acsf(ncsfl)%ip = lad_ip(i) |
---|
7224 | acsf(ncsfl)%itx = boxes(3,i) |
---|
7225 | acsf(ncsfl)%ity = boxes(2,i) |
---|
7226 | acsf(ncsfl)%itz = boxes(1,i) |
---|
7227 | acsf(ncsfl)%isurfs = isrc |
---|
7228 | acsf(ncsfl)%rcvf = cursink*transparency*difvf*atarg |
---|
7229 | ENDIF !< create_csf |
---|
7230 | |
---|
7231 | transparency = transparency * (1._wp - cursink) |
---|
7232 | |
---|
7233 | ENDDO |
---|
7234 | ENDIF |
---|
7235 | |
---|
7236 | visible = .TRUE. |
---|
7237 | |
---|
7238 | END SUBROUTINE raytrace |
---|
7239 | |
---|
7240 | |
---|
7241 | !------------------------------------------------------------------------------! |
---|
7242 | ! Description: |
---|
7243 | ! ------------ |
---|
7244 | !> A new, more efficient version of ray tracing algorithm that processes a whole |
---|
7245 | !> arc instead of a single ray. |
---|
7246 | !> |
---|
7247 | !> In all comments, horizon means tangent of horizon angle, i.e. |
---|
7248 | !> vertical_delta / horizontal_distance |
---|
7249 | !------------------------------------------------------------------------------! |
---|
7250 | SUBROUTINE raytrace_2d(origin, yxdir, nrays, zdirs, iorig, aorig, vffrac, & |
---|
7251 | calc_svf, create_csf, skip_1st_pcb, & |
---|
7252 | lowest_free_ray, transparency, itarget) |
---|
7253 | IMPLICIT NONE |
---|
7254 | |
---|
7255 | REAL(wp), DIMENSION(3), INTENT(IN) :: origin !< z,y,x coordinates of ray origin |
---|
7256 | REAL(wp), DIMENSION(2), INTENT(IN) :: yxdir !< y,x *unit* vector of ray direction (in grid units) |
---|
7257 | INTEGER(iwp) :: nrays !< number of rays (z directions) to raytrace |
---|
7258 | REAL(wp), DIMENSION(nrays), INTENT(IN) :: zdirs !< list of z directions to raytrace (z/hdist, grid, zenith->nadir) |
---|
7259 | INTEGER(iwp), INTENT(in) :: iorig !< index of origin face for csf |
---|
7260 | REAL(wp), INTENT(in) :: aorig !< origin face area for csf |
---|
7261 | REAL(wp), DIMENSION(nrays), INTENT(in) :: vffrac !< view factor fractions of each ray for csf |
---|
7262 | LOGICAL, INTENT(in) :: calc_svf !< whether to calculate SFV (identify obstacle surfaces) |
---|
7263 | LOGICAL, INTENT(in) :: create_csf !< whether to create canopy sink factors |
---|
7264 | LOGICAL, INTENT(in) :: skip_1st_pcb !< whether to skip first plant canopy box during raytracing |
---|
7265 | INTEGER(iwp), INTENT(out) :: lowest_free_ray !< index into zdirs |
---|
7266 | REAL(wp), DIMENSION(nrays), INTENT(OUT) :: transparency !< transparencies of zdirs paths |
---|
7267 | INTEGER(iwp), DIMENSION(nrays), INTENT(OUT) :: itarget !< global indices of target faces for zdirs |
---|
7268 | |
---|
7269 | INTEGER(iwp), DIMENSION(nrays) :: target_procs |
---|
7270 | REAL(wp) :: horizon !< highest horizon found after raytracing (z/hdist) |
---|
7271 | INTEGER(iwp) :: i, k, l, d |
---|
7272 | INTEGER(iwp) :: seldim !< dimension to be incremented |
---|
7273 | REAL(wp), DIMENSION(2) :: yxorigin !< horizontal copy of origin (y,x) |
---|
7274 | REAL(wp) :: distance !< euclidean along path |
---|
7275 | REAL(wp) :: lastdist !< beginning of current crossing |
---|
7276 | REAL(wp) :: nextdist !< end of current crossing |
---|
7277 | REAL(wp) :: crmid !< midpoint of crossing |
---|
7278 | REAL(wp) :: horz_entry !< horizon at entry to column |
---|
7279 | REAL(wp) :: horz_exit !< horizon at exit from column |
---|
7280 | REAL(wp) :: bdydim !< boundary for current dimension |
---|
7281 | REAL(wp), DIMENSION(2) :: crossdist !< distances to boundary for dimensions |
---|
7282 | REAL(wp), DIMENSION(2) :: dimnextdist !< distance for each dimension increments |
---|
7283 | INTEGER(iwp), DIMENSION(2) :: column !< grid column being crossed |
---|
7284 | INTEGER(iwp), DIMENSION(2) :: dimnext !< next dimension increments along path |
---|
7285 | INTEGER(iwp), DIMENSION(2) :: dimdelta !< dimension direction = +- 1 |
---|
7286 | INTEGER(iwp) :: px, py !< number of processors in x and y dir before |
---|
7287 | !< the processor in the question |
---|
7288 | INTEGER(iwp) :: ip !< number of processor where gridbox reside |
---|
7289 | INTEGER(iwp) :: ig !< 1D index of gridbox in global 2D array |
---|
7290 | INTEGER(iwp) :: wcount !< RMA window item count |
---|
7291 | INTEGER(iwp) :: maxboxes !< max no of CSF created |
---|
7292 | INTEGER(iwp) :: nly !< maximum plant canopy height |
---|
7293 | INTEGER(iwp) :: ntrack |
---|
7294 | |
---|
7295 | INTEGER(iwp) :: zb0 |
---|
7296 | INTEGER(iwp) :: zb1 |
---|
7297 | INTEGER(iwp) :: nz |
---|
7298 | INTEGER(iwp) :: iz |
---|
7299 | INTEGER(iwp) :: zsgn |
---|
7300 | INTEGER(iwp) :: lowest_lad !< lowest column cell for which we need LAD |
---|
7301 | INTEGER(iwp) :: lastdir !< wall direction before hitting this column |
---|
7302 | INTEGER(iwp), DIMENSION(2) :: lastcolumn |
---|
7303 | |
---|
7304 | #if defined( __parallel ) |
---|
7305 | INTEGER(MPI_ADDRESS_KIND) :: wdisp !< RMA window displacement |
---|
7306 | #endif |
---|
7307 | |
---|
7308 | REAL(wp) :: eps = 1E-10_wp !< epsilon for value comparison |
---|
7309 | REAL(wp) :: zbottom, ztop !< urban surface boundary in real numbers |
---|
7310 | REAL(wp) :: zorig !< z coordinate of ray column entry |
---|
7311 | REAL(wp) :: zexit !< z coordinate of ray column exit |
---|
7312 | REAL(wp) :: qdist !< ratio of real distance to z coord difference |
---|
7313 | REAL(wp) :: dxxyy !< square of real horizontal distance |
---|
7314 | REAL(wp) :: curtrans !< transparency of current PC box crossing |
---|
7315 | |
---|
7316 | |
---|
7317 | |
---|
7318 | yxorigin(:) = origin(2:3) |
---|
7319 | transparency(:) = 1._wp !-- Pre-set the all rays to transparent before reducing |
---|
7320 | horizon = -HUGE(1._wp) |
---|
7321 | lowest_free_ray = nrays |
---|
7322 | IF ( rad_angular_discretization .AND. calc_svf ) THEN |
---|
7323 | ALLOCATE(target_surfl(nrays)) |
---|
7324 | target_surfl(:) = -1 |
---|
7325 | lastdir = -999 |
---|
7326 | lastcolumn(:) = -999 |
---|
7327 | ENDIF |
---|
7328 | |
---|
7329 | !-- Determine distance to boundary (in 2D xy) |
---|
7330 | IF ( yxdir(1) > 0._wp ) THEN |
---|
7331 | bdydim = ny + .5_wp !< north global boundary |
---|
7332 | crossdist(1) = (bdydim - yxorigin(1)) / yxdir(1) |
---|
7333 | ELSEIF ( yxdir(1) == 0._wp ) THEN |
---|
7334 | crossdist(1) = HUGE(1._wp) |
---|
7335 | ELSE |
---|
7336 | bdydim = -.5_wp !< south global boundary |
---|
7337 | crossdist(1) = (bdydim - yxorigin(1)) / yxdir(1) |
---|
7338 | ENDIF |
---|
7339 | |
---|
7340 | IF ( yxdir(2) >= 0._wp ) THEN |
---|
7341 | bdydim = nx + .5_wp !< east global boundary |
---|
7342 | crossdist(2) = (bdydim - yxorigin(2)) / yxdir(2) |
---|
7343 | ELSEIF ( yxdir(2) == 0._wp ) THEN |
---|
7344 | crossdist(2) = HUGE(1._wp) |
---|
7345 | ELSE |
---|
7346 | bdydim = -.5_wp !< west global boundary |
---|
7347 | crossdist(2) = (bdydim - yxorigin(2)) / yxdir(2) |
---|
7348 | ENDIF |
---|
7349 | distance = minval(crossdist, 1) |
---|
7350 | |
---|
7351 | IF ( plant_canopy ) THEN |
---|
7352 | rt2_track_dist(0) = 0._wp |
---|
7353 | rt2_track_lad(:,:) = 0._wp |
---|
7354 | nly = plantt_max - nzub + 1 |
---|
7355 | ENDIF |
---|
7356 | |
---|
7357 | lastdist = 0._wp |
---|
7358 | |
---|
7359 | !-- Since all face coordinates have values *.5 and we'd like to use |
---|
7360 | !-- integers, all these have .5 added |
---|
7361 | DO d = 1, 2 |
---|
7362 | IF ( yxdir(d) == 0._wp ) THEN |
---|
7363 | dimnext(d) = HUGE(1_iwp) |
---|
7364 | dimdelta(d) = HUGE(1_iwp) |
---|
7365 | dimnextdist(d) = HUGE(1._wp) |
---|
7366 | ELSE IF ( yxdir(d) > 0._wp ) THEN |
---|
7367 | dimnext(d) = FLOOR(yxorigin(d) + .5_wp) + 1 |
---|
7368 | dimdelta(d) = 1 |
---|
7369 | dimnextdist(d) = (dimnext(d) - .5_wp - yxorigin(d)) / yxdir(d) |
---|
7370 | ELSE |
---|
7371 | dimnext(d) = CEILING(yxorigin(d) + .5_wp) - 1 |
---|
7372 | dimdelta(d) = -1 |
---|
7373 | dimnextdist(d) = (dimnext(d) - .5_wp - yxorigin(d)) / yxdir(d) |
---|
7374 | ENDIF |
---|
7375 | ENDDO |
---|
7376 | |
---|
7377 | ntrack = 0 |
---|
7378 | DO |
---|
7379 | !-- along what dimension will the next wall crossing be? |
---|
7380 | seldim = minloc(dimnextdist, 1) |
---|
7381 | nextdist = dimnextdist(seldim) |
---|
7382 | IF ( nextdist > distance ) nextdist = distance |
---|
7383 | |
---|
7384 | IF ( nextdist > lastdist ) THEN |
---|
7385 | ntrack = ntrack + 1 |
---|
7386 | crmid = (lastdist + nextdist) * .5_wp |
---|
7387 | column = NINT(yxorigin(:) + yxdir(:) * crmid, iwp) |
---|
7388 | |
---|
7389 | !-- calculate index of the grid with global indices (column(1),column(2)) |
---|
7390 | !-- in the array nzterr and plantt and id of the coresponding processor |
---|
7391 | px = column(2)/nnx |
---|
7392 | py = column(1)/nny |
---|
7393 | ip = px*pdims(2)+py |
---|
7394 | ig = ip*nnx*nny + (column(2)-px*nnx)*nny + column(1)-py*nny |
---|
7395 | |
---|
7396 | IF ( lastdist == 0._wp ) THEN |
---|
7397 | horz_entry = -HUGE(1._wp) |
---|
7398 | ELSE |
---|
7399 | horz_entry = (REAL(nzterr(ig), wp) + .5_wp - origin(1)) / lastdist |
---|
7400 | ENDIF |
---|
7401 | horz_exit = (REAL(nzterr(ig), wp) + .5_wp - origin(1)) / nextdist |
---|
7402 | |
---|
7403 | IF ( rad_angular_discretization .AND. calc_svf ) THEN |
---|
7404 | ! |
---|
7405 | !-- Identify vertical obstacles hit by rays in current column |
---|
7406 | DO WHILE ( lowest_free_ray > 0 ) |
---|
7407 | IF ( zdirs(lowest_free_ray) > horz_entry ) EXIT |
---|
7408 | ! |
---|
7409 | !-- This may only happen after 1st column, so lastdir and lastcolumn are valid |
---|
7410 | CALL request_itarget(lastdir, & |
---|
7411 | CEILING(-0.5_wp + origin(1) + zdirs(lowest_free_ray)*lastdist), & |
---|
7412 | lastcolumn(1), lastcolumn(2), & |
---|
7413 | target_surfl(lowest_free_ray), target_procs(lowest_free_ray)) |
---|
7414 | lowest_free_ray = lowest_free_ray - 1 |
---|
7415 | ENDDO |
---|
7416 | ! |
---|
7417 | !-- Identify horizontal obstacles hit by rays in current column |
---|
7418 | DO WHILE ( lowest_free_ray > 0 ) |
---|
7419 | IF ( zdirs(lowest_free_ray) > horz_exit ) EXIT |
---|
7420 | CALL request_itarget(iup_u, nzterr(ig)+1, column(1), column(2), & |
---|
7421 | target_surfl(lowest_free_ray), & |
---|
7422 | target_procs(lowest_free_ray)) |
---|
7423 | lowest_free_ray = lowest_free_ray - 1 |
---|
7424 | ENDDO |
---|
7425 | ENDIF |
---|
7426 | |
---|
7427 | horizon = MAX(horizon, horz_entry, horz_exit) |
---|
7428 | |
---|
7429 | IF ( plant_canopy ) THEN |
---|
7430 | rt2_track(:, ntrack) = column(:) |
---|
7431 | rt2_track_dist(ntrack) = nextdist |
---|
7432 | ENDIF |
---|
7433 | ENDIF |
---|
7434 | |
---|
7435 | IF ( ABS(distance - nextdist) < eps ) EXIT |
---|
7436 | |
---|
7437 | IF ( rad_angular_discretization .AND. calc_svf ) THEN |
---|
7438 | ! |
---|
7439 | !-- Save wall direction of coming building column (= this air column) |
---|
7440 | IF ( seldim == 1 ) THEN |
---|
7441 | IF ( dimdelta(seldim) == 1 ) THEN |
---|
7442 | lastdir = isouth_u |
---|
7443 | ELSE |
---|
7444 | lastdir = inorth_u |
---|
7445 | ENDIF |
---|
7446 | ELSE |
---|
7447 | IF ( dimdelta(seldim) == 1 ) THEN |
---|
7448 | lastdir = iwest_u |
---|
7449 | ELSE |
---|
7450 | lastdir = ieast_u |
---|
7451 | ENDIF |
---|
7452 | ENDIF |
---|
7453 | lastcolumn = column |
---|
7454 | ENDIF |
---|
7455 | lastdist = nextdist |
---|
7456 | dimnext(seldim) = dimnext(seldim) + dimdelta(seldim) |
---|
7457 | dimnextdist(seldim) = (dimnext(seldim) - .5_wp - yxorigin(seldim)) / yxdir(seldim) |
---|
7458 | ENDDO |
---|
7459 | |
---|
7460 | IF ( plant_canopy ) THEN |
---|
7461 | !-- Request LAD WHERE applicable |
---|
7462 | !-- |
---|
7463 | #if defined( __parallel ) |
---|
7464 | IF ( raytrace_mpi_rma ) THEN |
---|
7465 | !-- send requests for lad_s to appropriate processor |
---|
7466 | !CALL cpu_log( log_point_s(77), 'usm_init_rma', 'start' ) |
---|
7467 | DO i = 1, ntrack |
---|
7468 | px = rt2_track(2,i)/nnx |
---|
7469 | py = rt2_track(1,i)/nny |
---|
7470 | ip = px*pdims(2)+py |
---|
7471 | ig = ip*nnx*nny + (rt2_track(2,i)-px*nnx)*nny + rt2_track(1,i)-py*nny |
---|
7472 | |
---|
7473 | IF ( rad_angular_discretization .AND. calc_svf ) THEN |
---|
7474 | ! |
---|
7475 | !-- For fixed view resolution, we need plant canopy even for rays |
---|
7476 | !-- to opposing surfaces |
---|
7477 | lowest_lad = nzterr(ig) + 1 |
---|
7478 | ELSE |
---|
7479 | ! |
---|
7480 | !-- We only need LAD for rays directed above horizon (to sky) |
---|
7481 | lowest_lad = CEILING( -0.5_wp + origin(1) + & |
---|
7482 | MIN( horizon * rt2_track_dist(i-1), & ! entry |
---|
7483 | horizon * rt2_track_dist(i) ) ) ! exit |
---|
7484 | ENDIF |
---|
7485 | ! |
---|
7486 | !-- Skip asking for LAD where all plant canopy is under requested level |
---|
7487 | IF ( plantt(ig) < lowest_lad ) CYCLE |
---|
7488 | |
---|
7489 | wdisp = (rt2_track(2,i)-px*nnx)*(nny*nzp) + (rt2_track(1,i)-py*nny)*nzp + lowest_lad-nzub |
---|
7490 | wcount = plantt(ig)-lowest_lad+1 |
---|
7491 | ! TODO send request ASAP - even during raytracing |
---|
7492 | CALL MPI_Get(rt2_track_lad(lowest_lad:plantt(ig), i), wcount, MPI_REAL, ip, & |
---|
7493 | wdisp, wcount, MPI_REAL, win_lad, ierr) |
---|
7494 | IF ( ierr /= 0 ) THEN |
---|
7495 | WRITE(9,*) 'Error MPI_Get2:', ierr, rt2_track_lad(lowest_lad:plantt(ig), i), & |
---|
7496 | wcount, ip, wdisp, win_lad |
---|
7497 | FLUSH(9) |
---|
7498 | ENDIF |
---|
7499 | ENDDO |
---|
7500 | |
---|
7501 | !-- wait for all pending local requests complete |
---|
7502 | ! TODO WAIT selectively for each column later when needed |
---|
7503 | CALL MPI_Win_flush_local_all(win_lad, ierr) |
---|
7504 | IF ( ierr /= 0 ) THEN |
---|
7505 | WRITE(9,*) 'Error MPI_Win_flush_local_all2:', ierr, win_lad |
---|
7506 | FLUSH(9) |
---|
7507 | ENDIF |
---|
7508 | !CALL cpu_log( log_point_s(77), 'usm_init_rma', 'stop' ) |
---|
7509 | |
---|
7510 | ELSE ! raytrace_mpi_rma = .F. |
---|
7511 | DO i = 1, ntrack |
---|
7512 | px = rt2_track(2,i)/nnx |
---|
7513 | py = rt2_track(1,i)/nny |
---|
7514 | ip = px*pdims(2)+py |
---|
7515 | ig = ip*nnx*nny*nzp + (rt2_track(2,i)-px*nnx)*(nny*nzp) + (rt2_track(1,i)-py*nny)*nzp |
---|
7516 | rt2_track_lad(nzub:plantt_max, i) = sub_lad_g(ig:ig+nly-1) |
---|
7517 | ENDDO |
---|
7518 | ENDIF |
---|
7519 | #else |
---|
7520 | DO i = 1, ntrack |
---|
7521 | rt2_track_lad(nzub:plantt_max, i) = sub_lad(rt2_track(1,i), rt2_track(2,i), nzub:plantt_max) |
---|
7522 | ENDDO |
---|
7523 | #endif |
---|
7524 | ENDIF ! plant_canopy |
---|
7525 | |
---|
7526 | IF ( rad_angular_discretization .AND. calc_svf ) THEN |
---|
7527 | #if defined( __parallel ) |
---|
7528 | !-- wait for all gridsurf requests to complete |
---|
7529 | CALL MPI_Win_flush_local_all(win_gridsurf, ierr) |
---|
7530 | IF ( ierr /= 0 ) THEN |
---|
7531 | WRITE(9,*) 'Error MPI_Win_flush_local_all3:', ierr, win_gridsurf |
---|
7532 | FLUSH(9) |
---|
7533 | ENDIF |
---|
7534 | #endif |
---|
7535 | ! |
---|
7536 | !-- recalculate local surf indices into global ones |
---|
7537 | DO i = 1, nrays |
---|
7538 | IF ( target_surfl(i) == -1 ) THEN |
---|
7539 | itarget(i) = -1 |
---|
7540 | ELSE |
---|
7541 | itarget(i) = target_surfl(i) + surfstart(target_procs(i)) |
---|
7542 | ENDIF |
---|
7543 | ENDDO |
---|
7544 | |
---|
7545 | DEALLOCATE( target_surfl ) |
---|
7546 | |
---|
7547 | ELSE |
---|
7548 | itarget(:) = -1 |
---|
7549 | ENDIF ! rad_angular_discretization |
---|
7550 | |
---|
7551 | IF ( plant_canopy ) THEN |
---|
7552 | !-- Skip the PCB around origin if requested (for MRT, the PCB might not be there) |
---|
7553 | !-- |
---|
7554 | IF ( skip_1st_pcb .AND. NINT(origin(1)) <= plantt_max ) THEN |
---|
7555 | rt2_track_lad(NINT(origin(1), iwp), 1) = 0._wp |
---|
7556 | ENDIF |
---|
7557 | |
---|
7558 | !-- Assert that we have space allocated for CSFs |
---|
7559 | !-- |
---|
7560 | maxboxes = (ntrack + MAX(CEILING(origin(1)-.5_wp) - nzub, & |
---|
7561 | nzut - CEILING(origin(1)-.5_wp))) * nrays |
---|
7562 | IF ( ncsfl + maxboxes > ncsfla ) THEN |
---|
7563 | !-- use this code for growing by fixed exponential increments (equivalent to case where ncsfl always increases by 1) |
---|
7564 | !-- k = CEILING(grow_factor ** real(CEILING(log(real(ncsfl + maxboxes, kind=wp)) & |
---|
7565 | !-- / log(grow_factor)), kind=wp)) |
---|
7566 | !-- or use this code to simply always keep some extra space after growing |
---|
7567 | k = CEILING(REAL(ncsfl + maxboxes, kind=wp) * grow_factor) |
---|
7568 | CALL merge_and_grow_csf(k) |
---|
7569 | ENDIF |
---|
7570 | |
---|
7571 | !-- Calculate transparencies and store new CSFs |
---|
7572 | !-- |
---|
7573 | zbottom = REAL(nzub, wp) - .5_wp |
---|
7574 | ztop = REAL(plantt_max, wp) + .5_wp |
---|
7575 | |
---|
7576 | !-- Reverse direction of radiation (face->sky), only when calc_svf |
---|
7577 | !-- |
---|
7578 | IF ( calc_svf ) THEN |
---|
7579 | DO i = 1, ntrack ! for each column |
---|
7580 | dxxyy = ((dy*yxdir(1))**2 + (dx*yxdir(2))**2) * (rt2_track_dist(i)-rt2_track_dist(i-1))**2 |
---|
7581 | px = rt2_track(2,i)/nnx |
---|
7582 | py = rt2_track(1,i)/nny |
---|
7583 | ip = px*pdims(2)+py |
---|
7584 | |
---|
7585 | DO k = 1, nrays ! for each ray |
---|
7586 | ! |
---|
7587 | !-- NOTE 6778: |
---|
7588 | !-- With traditional svf discretization, CSFs under the horizon |
---|
7589 | !-- (i.e. for surface to surface radiation) are created in |
---|
7590 | !-- raytrace(). With rad_angular_discretization, we must create |
---|
7591 | !-- CSFs under horizon only for one direction, otherwise we would |
---|
7592 | !-- have duplicate amount of energy. Although we could choose |
---|
7593 | !-- either of the two directions (they differ only by |
---|
7594 | !-- discretization error with no bias), we choose the the backward |
---|
7595 | !-- direction, because it tends to cumulate high canopy sink |
---|
7596 | !-- factors closer to raytrace origin, i.e. it should potentially |
---|
7597 | !-- cause less moiree. |
---|
7598 | IF ( .NOT. rad_angular_discretization ) THEN |
---|
7599 | IF ( zdirs(k) <= horizon ) CYCLE |
---|
7600 | ENDIF |
---|
7601 | |
---|
7602 | zorig = origin(1) + zdirs(k) * rt2_track_dist(i-1) |
---|
7603 | IF ( zorig <= zbottom .OR. zorig >= ztop ) CYCLE |
---|
7604 | |
---|
7605 | zsgn = INT(SIGN(1._wp, zdirs(k)), iwp) |
---|
7606 | rt2_dist(1) = 0._wp |
---|
7607 | IF ( zdirs(k) == 0._wp ) THEN ! ray is exactly horizontal |
---|
7608 | nz = 2 |
---|
7609 | rt2_dist(nz) = SQRT(dxxyy) |
---|
7610 | iz = CEILING(-.5_wp + zorig, iwp) |
---|
7611 | ELSE |
---|
7612 | zexit = MIN(MAX(origin(1) + zdirs(k) * rt2_track_dist(i), zbottom), ztop) |
---|
7613 | |
---|
7614 | zb0 = FLOOR( zorig * zsgn - .5_wp) + 1 ! because it must be greater than orig |
---|
7615 | zb1 = CEILING(zexit * zsgn - .5_wp) - 1 ! because it must be smaller than exit |
---|
7616 | nz = MAX(zb1 - zb0 + 3, 2) |
---|
7617 | rt2_dist(nz) = SQRT(((zexit-zorig)*dz(1))**2 + dxxyy) |
---|
7618 | qdist = rt2_dist(nz) / (zexit-zorig) |
---|
7619 | rt2_dist(2:nz-1) = (/( ((REAL(l, wp) + .5_wp) * zsgn - zorig) * qdist , l = zb0, zb1 )/) |
---|
7620 | iz = zb0 * zsgn |
---|
7621 | ENDIF |
---|
7622 | |
---|
7623 | DO l = 2, nz |
---|
7624 | IF ( rt2_track_lad(iz, i) > 0._wp ) THEN |
---|
7625 | curtrans = exp(-ext_coef * rt2_track_lad(iz, i) * (rt2_dist(l)-rt2_dist(l-1))) |
---|
7626 | |
---|
7627 | IF ( create_csf ) THEN |
---|
7628 | ncsfl = ncsfl + 1 |
---|
7629 | acsf(ncsfl)%ip = ip |
---|
7630 | acsf(ncsfl)%itx = rt2_track(2,i) |
---|
7631 | acsf(ncsfl)%ity = rt2_track(1,i) |
---|
7632 | acsf(ncsfl)%itz = iz |
---|
7633 | acsf(ncsfl)%isurfs = iorig |
---|
7634 | acsf(ncsfl)%rcvf = (1._wp - curtrans)*transparency(k)*vffrac(k) |
---|
7635 | ENDIF |
---|
7636 | |
---|
7637 | transparency(k) = transparency(k) * curtrans |
---|
7638 | ENDIF |
---|
7639 | iz = iz + zsgn |
---|
7640 | ENDDO ! l = 1, nz - 1 |
---|
7641 | ENDDO ! k = 1, nrays |
---|
7642 | ENDDO ! i = 1, ntrack |
---|
7643 | |
---|
7644 | transparency(1:lowest_free_ray) = 1._wp !-- Reset rays above horizon to transparent (see NOTE 6778) |
---|
7645 | ENDIF |
---|
7646 | |
---|
7647 | !-- Forward direction of radiation (sky->face), always |
---|
7648 | !-- |
---|
7649 | DO i = ntrack, 1, -1 ! for each column backwards |
---|
7650 | dxxyy = ((dy*yxdir(1))**2 + (dx*yxdir(2))**2) * (rt2_track_dist(i)-rt2_track_dist(i-1))**2 |
---|
7651 | px = rt2_track(2,i)/nnx |
---|
7652 | py = rt2_track(1,i)/nny |
---|
7653 | ip = px*pdims(2)+py |
---|
7654 | |
---|
7655 | DO k = 1, nrays ! for each ray |
---|
7656 | ! |
---|
7657 | !-- See NOTE 6778 above |
---|
7658 | IF ( zdirs(k) <= horizon ) CYCLE |
---|
7659 | |
---|
7660 | zexit = origin(1) + zdirs(k) * rt2_track_dist(i-1) |
---|
7661 | IF ( zexit <= zbottom .OR. zexit >= ztop ) CYCLE |
---|
7662 | |
---|
7663 | zsgn = -INT(SIGN(1._wp, zdirs(k)), iwp) |
---|
7664 | rt2_dist(1) = 0._wp |
---|
7665 | IF ( zdirs(k) == 0._wp ) THEN ! ray is exactly horizontal |
---|
7666 | nz = 2 |
---|
7667 | rt2_dist(nz) = SQRT(dxxyy) |
---|
7668 | iz = NINT(zexit, iwp) |
---|
7669 | ELSE |
---|
7670 | zorig = MIN(MAX(origin(1) + zdirs(k) * rt2_track_dist(i), zbottom), ztop) |
---|
7671 | |
---|
7672 | zb0 = FLOOR( zorig * zsgn - .5_wp) + 1 ! because it must be greater than orig |
---|
7673 | zb1 = CEILING(zexit * zsgn - .5_wp) - 1 ! because it must be smaller than exit |
---|
7674 | nz = MAX(zb1 - zb0 + 3, 2) |
---|
7675 | rt2_dist(nz) = SQRT(((zexit-zorig)*dz(1))**2 + dxxyy) |
---|
7676 | qdist = rt2_dist(nz) / (zexit-zorig) |
---|
7677 | rt2_dist(2:nz-1) = (/( ((REAL(l, wp) + .5_wp) * zsgn - zorig) * qdist , l = zb0, zb1 )/) |
---|
7678 | iz = zb0 * zsgn |
---|
7679 | ENDIF |
---|
7680 | |
---|
7681 | DO l = 2, nz |
---|
7682 | IF ( rt2_track_lad(iz, i) > 0._wp ) THEN |
---|
7683 | curtrans = exp(-ext_coef * rt2_track_lad(iz, i) * (rt2_dist(l)-rt2_dist(l-1))) |
---|
7684 | |
---|
7685 | IF ( create_csf ) THEN |
---|
7686 | ncsfl = ncsfl + 1 |
---|
7687 | acsf(ncsfl)%ip = ip |
---|
7688 | acsf(ncsfl)%itx = rt2_track(2,i) |
---|
7689 | acsf(ncsfl)%ity = rt2_track(1,i) |
---|
7690 | acsf(ncsfl)%itz = iz |
---|
7691 | IF ( itarget(k) /= -1 ) ERROR STOP !FIXME remove after test |
---|
7692 | acsf(ncsfl)%isurfs = -1 |
---|
7693 | acsf(ncsfl)%rcvf = (1._wp - curtrans)*transparency(k)*aorig*vffrac(k) |
---|
7694 | ENDIF ! create_csf |
---|
7695 | |
---|
7696 | transparency(k) = transparency(k) * curtrans |
---|
7697 | ENDIF |
---|
7698 | iz = iz + zsgn |
---|
7699 | ENDDO ! l = 1, nz - 1 |
---|
7700 | ENDDO ! k = 1, nrays |
---|
7701 | ENDDO ! i = 1, ntrack |
---|
7702 | ENDIF ! plant_canopy |
---|
7703 | |
---|
7704 | IF ( .NOT. (rad_angular_discretization .AND. calc_svf) ) THEN |
---|
7705 | ! |
---|
7706 | !-- Just update lowest_free_ray according to horizon |
---|
7707 | DO WHILE ( lowest_free_ray > 0 ) |
---|
7708 | IF ( zdirs(lowest_free_ray) > horizon ) EXIT |
---|
7709 | lowest_free_ray = lowest_free_ray - 1 |
---|
7710 | ENDDO |
---|
7711 | ENDIF |
---|
7712 | |
---|
7713 | CONTAINS |
---|
7714 | |
---|
7715 | SUBROUTINE request_itarget( d, z, y, x, isurfl, iproc ) |
---|
7716 | |
---|
7717 | INTEGER(iwp), INTENT(in) :: d, z, y, x |
---|
7718 | INTEGER(iwp), TARGET, INTENT(out) :: isurfl |
---|
7719 | INTEGER(iwp), INTENT(out) :: iproc |
---|
7720 | #if defined( __parallel ) |
---|
7721 | #else |
---|
7722 | INTEGER(iwp) :: target_displ !< index of the grid in the local gridsurf array |
---|
7723 | #endif |
---|
7724 | INTEGER(iwp) :: px, py !< number of processors in x and y direction |
---|
7725 | !< before the processor in the question |
---|
7726 | #if defined( __parallel ) |
---|
7727 | INTEGER(KIND=MPI_ADDRESS_KIND) :: target_displ !< index of the grid in the local gridsurf array |
---|
7728 | |
---|
7729 | ! |
---|
7730 | !-- Calculate target processor and index in the remote local target gridsurf array |
---|
7731 | px = x / nnx |
---|
7732 | py = y / nny |
---|
7733 | iproc = px * pdims(2) + py |
---|
7734 | target_displ = ((x-px*nnx) * nny + y - py*nny ) * nzu * nsurf_type_u +& |
---|
7735 | ( z-nzub ) * nsurf_type_u + d |
---|
7736 | ! |
---|
7737 | !-- Send MPI_Get request to obtain index target_surfl(i) |
---|
7738 | CALL MPI_GET( isurfl, 1, MPI_INTEGER, iproc, target_displ, & |
---|
7739 | 1, MPI_INTEGER, win_gridsurf, ierr) |
---|
7740 | IF ( ierr /= 0 ) THEN |
---|
7741 | WRITE( 9,* ) 'Error MPI_Get3:', ierr, isurfl, iproc, target_displ, & |
---|
7742 | win_gridsurf |
---|
7743 | FLUSH( 9 ) |
---|
7744 | ENDIF |
---|
7745 | #else |
---|
7746 | !-- set index target_surfl(i) |
---|
7747 | isurfl = gridsurf(d,z,y,x) |
---|
7748 | #endif |
---|
7749 | |
---|
7750 | END SUBROUTINE request_itarget |
---|
7751 | |
---|
7752 | END SUBROUTINE raytrace_2d |
---|
7753 | |
---|
7754 | |
---|
7755 | !------------------------------------------------------------------------------! |
---|
7756 | ! |
---|
7757 | ! Description: |
---|
7758 | ! ------------ |
---|
7759 | !> Calculates apparent solar positions for all timesteps and stores discretized |
---|
7760 | !> positions. |
---|
7761 | !------------------------------------------------------------------------------! |
---|
7762 | SUBROUTINE radiation_presimulate_solar_pos |
---|
7763 | IMPLICIT NONE |
---|
7764 | |
---|
7765 | INTEGER(iwp) :: it, i, j |
---|
7766 | REAL(wp) :: tsrp_prev |
---|
7767 | REAL(wp) :: simulated_time_prev |
---|
7768 | REAL(wp), DIMENSION(:,:), ALLOCATABLE :: dsidir_tmp !< dsidir_tmp[:,i] = unit vector of i-th |
---|
7769 | !< appreant solar direction |
---|
7770 | |
---|
7771 | ALLOCATE ( dsidir_rev(0:raytrace_discrete_elevs/2-1, & |
---|
7772 | 0:raytrace_discrete_azims-1) ) |
---|
7773 | dsidir_rev(:,:) = -1 |
---|
7774 | ALLOCATE ( dsidir_tmp(3, & |
---|
7775 | raytrace_discrete_elevs/2*raytrace_discrete_azims) ) |
---|
7776 | ndsidir = 0 |
---|
7777 | |
---|
7778 | ! |
---|
7779 | !-- We will artificialy update time_since_reference_point and return to |
---|
7780 | !-- true value later |
---|
7781 | tsrp_prev = time_since_reference_point |
---|
7782 | simulated_time_prev = simulated_time |
---|
7783 | sun_direction = .TRUE. |
---|
7784 | |
---|
7785 | ! |
---|
7786 | !-- Process spinup time if configured |
---|
7787 | IF ( spinup_time > 0._wp ) THEN |
---|
7788 | DO it = 0, CEILING(spinup_time / dt_spinup) |
---|
7789 | time_since_reference_point = -spinup_time + REAL(it, wp) * dt_spinup |
---|
7790 | simulated_time = simulated_time + dt_spinup |
---|
7791 | CALL simulate_pos |
---|
7792 | ENDDO |
---|
7793 | ENDIF |
---|
7794 | ! |
---|
7795 | !-- Process simulation time |
---|
7796 | DO it = 0, CEILING(( end_time - spinup_time ) / dt_radiation) |
---|
7797 | time_since_reference_point = REAL(it, wp) * dt_radiation |
---|
7798 | simulated_time = simulated_time + dt_spinup |
---|
7799 | CALL simulate_pos |
---|
7800 | ENDDO |
---|
7801 | |
---|
7802 | time_since_reference_point = tsrp_prev |
---|
7803 | simulated_time = simulated_time_prev |
---|
7804 | |
---|
7805 | !-- Allocate global vars which depend on ndsidir |
---|
7806 | ALLOCATE ( dsidir ( 3, ndsidir ) ) |
---|
7807 | dsidir(:,:) = dsidir_tmp(:, 1:ndsidir) |
---|
7808 | DEALLOCATE ( dsidir_tmp ) |
---|
7809 | |
---|
7810 | ALLOCATE ( dsitrans(nsurfl, ndsidir) ) |
---|
7811 | ALLOCATE ( dsitransc(npcbl, ndsidir) ) |
---|
7812 | IF ( nmrtbl > 0 ) ALLOCATE ( mrtdsit(nmrtbl, ndsidir) ) |
---|
7813 | |
---|
7814 | WRITE ( message_string, * ) 'Precalculated', ndsidir, ' solar positions', & |
---|
7815 | 'from', it, ' timesteps.' |
---|
7816 | CALL message( 'radiation_presimulate_solar_pos', 'UI0013', 0, 0, 0, 6, 0 ) |
---|
7817 | |
---|
7818 | CONTAINS |
---|
7819 | |
---|
7820 | !------------------------------------------------------------------------! |
---|
7821 | ! Description: |
---|
7822 | ! ------------ |
---|
7823 | !> Simuates a single position |
---|
7824 | !------------------------------------------------------------------------! |
---|
7825 | SUBROUTINE simulate_pos |
---|
7826 | IMPLICIT NONE |
---|
7827 | ! |
---|
7828 | !-- Update apparent solar position based on modified t_s_r_p |
---|
7829 | CALL calc_zenith |
---|
7830 | IF ( zenith(0) > 0 ) THEN |
---|
7831 | !-- |
---|
7832 | !-- Identify solar direction vector (discretized number) 1) |
---|
7833 | i = MODULO(NINT(ATAN2(sun_dir_lon(0), sun_dir_lat(0)) & |
---|
7834 | / (2._wp*pi) * raytrace_discrete_azims-.5_wp, iwp), & |
---|
7835 | raytrace_discrete_azims) |
---|
7836 | j = FLOOR(ACOS(zenith(0)) / pi * raytrace_discrete_elevs) |
---|
7837 | IF ( dsidir_rev(j, i) == -1 ) THEN |
---|
7838 | ndsidir = ndsidir + 1 |
---|
7839 | dsidir_tmp(:, ndsidir) = & |
---|
7840 | (/ COS((REAL(j,wp)+.5_wp) * pi / raytrace_discrete_elevs), & |
---|
7841 | SIN((REAL(j,wp)+.5_wp) * pi / raytrace_discrete_elevs) & |
---|
7842 | * COS((REAL(i,wp)+.5_wp) * 2_wp*pi / raytrace_discrete_azims), & |
---|
7843 | SIN((REAL(j,wp)+.5_wp) * pi / raytrace_discrete_elevs) & |
---|
7844 | * SIN((REAL(i,wp)+.5_wp) * 2_wp*pi / raytrace_discrete_azims) /) |
---|
7845 | dsidir_rev(j, i) = ndsidir |
---|
7846 | ENDIF |
---|
7847 | ENDIF |
---|
7848 | END SUBROUTINE simulate_pos |
---|
7849 | |
---|
7850 | END SUBROUTINE radiation_presimulate_solar_pos |
---|
7851 | |
---|
7852 | |
---|
7853 | |
---|
7854 | !------------------------------------------------------------------------------! |
---|
7855 | ! Description: |
---|
7856 | ! ------------ |
---|
7857 | !> Determines whether two faces are oriented towards each other. Since the |
---|
7858 | !> surfaces follow the gird box surfaces, it checks first whether the two surfaces |
---|
7859 | !> are directed in the same direction, then it checks if the two surfaces are |
---|
7860 | !> located in confronted direction but facing away from each other, e.g. <--| |--> |
---|
7861 | !------------------------------------------------------------------------------! |
---|
7862 | PURE LOGICAL FUNCTION surface_facing(x, y, z, d, x2, y2, z2, d2) |
---|
7863 | IMPLICIT NONE |
---|
7864 | INTEGER(iwp), INTENT(in) :: x, y, z, d, x2, y2, z2, d2 |
---|
7865 | |
---|
7866 | surface_facing = .FALSE. |
---|
7867 | |
---|
7868 | !-- first check: are the two surfaces directed in the same direction |
---|
7869 | IF ( (d==iup_u .OR. d==iup_l ) & |
---|
7870 | .AND. (d2==iup_u .OR. d2==iup_l) ) RETURN |
---|
7871 | IF ( (d==isouth_u .OR. d==isouth_l ) & |
---|
7872 | .AND. (d2==isouth_u .OR. d2==isouth_l) ) RETURN |
---|
7873 | IF ( (d==inorth_u .OR. d==inorth_l ) & |
---|
7874 | .AND. (d2==inorth_u .OR. d2==inorth_l) ) RETURN |
---|
7875 | IF ( (d==iwest_u .OR. d==iwest_l ) & |
---|
7876 | .AND. (d2==iwest_u .OR. d2==iwest_l ) ) RETURN |
---|
7877 | IF ( (d==ieast_u .OR. d==ieast_l ) & |
---|
7878 | .AND. (d2==ieast_u .OR. d2==ieast_l ) ) RETURN |
---|
7879 | |
---|
7880 | !-- second check: are surfaces facing away from each other |
---|
7881 | SELECT CASE (d) |
---|
7882 | CASE (iup_u, iup_l) !< upward facing surfaces |
---|
7883 | IF ( z2 < z ) RETURN |
---|
7884 | CASE (isouth_u, isouth_l) !< southward facing surfaces |
---|
7885 | IF ( y2 > y ) RETURN |
---|
7886 | CASE (inorth_u, inorth_l) !< northward facing surfaces |
---|
7887 | IF ( y2 < y ) RETURN |
---|
7888 | CASE (iwest_u, iwest_l) !< westward facing surfaces |
---|
7889 | IF ( x2 > x ) RETURN |
---|
7890 | CASE (ieast_u, ieast_l) !< eastward facing surfaces |
---|
7891 | IF ( x2 < x ) RETURN |
---|
7892 | END SELECT |
---|
7893 | |
---|
7894 | SELECT CASE (d2) |
---|
7895 | CASE (iup_u) !< ground, roof |
---|
7896 | IF ( z < z2 ) RETURN |
---|
7897 | CASE (isouth_u, isouth_l) !< south facing |
---|
7898 | IF ( y > y2 ) RETURN |
---|
7899 | CASE (inorth_u, inorth_l) !< north facing |
---|
7900 | IF ( y < y2 ) RETURN |
---|
7901 | CASE (iwest_u, iwest_l) !< west facing |
---|
7902 | IF ( x > x2 ) RETURN |
---|
7903 | CASE (ieast_u, ieast_l) !< east facing |
---|
7904 | IF ( x < x2 ) RETURN |
---|
7905 | CASE (-1) |
---|
7906 | CONTINUE |
---|
7907 | END SELECT |
---|
7908 | |
---|
7909 | surface_facing = .TRUE. |
---|
7910 | |
---|
7911 | END FUNCTION surface_facing |
---|
7912 | |
---|
7913 | |
---|
7914 | !------------------------------------------------------------------------------! |
---|
7915 | ! |
---|
7916 | ! Description: |
---|
7917 | ! ------------ |
---|
7918 | !> Soubroutine reads svf and svfsurf data from saved file |
---|
7919 | !> SVF means sky view factors and CSF means canopy sink factors |
---|
7920 | !------------------------------------------------------------------------------! |
---|
7921 | SUBROUTINE radiation_read_svf |
---|
7922 | |
---|
7923 | IMPLICIT NONE |
---|
7924 | |
---|
7925 | CHARACTER(rad_version_len) :: rad_version_field |
---|
7926 | |
---|
7927 | INTEGER(iwp) :: i |
---|
7928 | INTEGER(iwp) :: ndsidir_from_file = 0 |
---|
7929 | INTEGER(iwp) :: npcbl_from_file = 0 |
---|
7930 | INTEGER(iwp) :: nsurfl_from_file = 0 |
---|
7931 | |
---|
7932 | DO i = 0, io_blocks-1 |
---|
7933 | IF ( i == io_group ) THEN |
---|
7934 | |
---|
7935 | ! |
---|
7936 | !-- numprocs_previous_run is only known in case of reading restart |
---|
7937 | !-- data. If a new initial run which reads svf data is started the |
---|
7938 | !-- following query will be skipped |
---|
7939 | IF ( initializing_actions == 'read_restart_data' ) THEN |
---|
7940 | |
---|
7941 | IF ( numprocs_previous_run /= numprocs ) THEN |
---|
7942 | WRITE( message_string, * ) 'A different number of ', & |
---|
7943 | 'processors between the run ', & |
---|
7944 | 'that has written the svf data ',& |
---|
7945 | 'and the one that will read it ',& |
---|
7946 | 'is not allowed' |
---|
7947 | CALL message( 'check_open', 'PA0491', 1, 2, 0, 6, 0 ) |
---|
7948 | ENDIF |
---|
7949 | |
---|
7950 | ENDIF |
---|
7951 | |
---|
7952 | ! |
---|
7953 | !-- Open binary file |
---|
7954 | CALL check_open( 88 ) |
---|
7955 | |
---|
7956 | ! |
---|
7957 | !-- read and check version |
---|
7958 | READ ( 88 ) rad_version_field |
---|
7959 | IF ( TRIM(rad_version_field) /= TRIM(rad_version) ) THEN |
---|
7960 | WRITE( message_string, * ) 'Version of binary SVF file "', & |
---|
7961 | TRIM(rad_version_field), '" does not match ', & |
---|
7962 | 'the version of model "', TRIM(rad_version), '"' |
---|
7963 | CALL message( 'radiation_read_svf', 'PA0482', 1, 2, 0, 6, 0 ) |
---|
7964 | ENDIF |
---|
7965 | |
---|
7966 | ! |
---|
7967 | !-- read nsvfl, ncsfl, nsurfl |
---|
7968 | READ ( 88 ) nsvfl, ncsfl, nsurfl_from_file, npcbl_from_file, & |
---|
7969 | ndsidir_from_file |
---|
7970 | |
---|
7971 | IF ( nsvfl < 0 .OR. ncsfl < 0 ) THEN |
---|
7972 | WRITE( message_string, * ) 'Wrong number of SVF or CSF' |
---|
7973 | CALL message( 'radiation_read_svf', 'PA0483', 1, 2, 0, 6, 0 ) |
---|
7974 | ELSE |
---|
7975 | WRITE(message_string,*) ' Number of SVF, CSF, and nsurfl ',& |
---|
7976 | 'to read', nsvfl, ncsfl, & |
---|
7977 | nsurfl_from_file |
---|
7978 | CALL location_message( message_string, .TRUE. ) |
---|
7979 | ENDIF |
---|
7980 | |
---|
7981 | IF ( nsurfl_from_file /= nsurfl ) THEN |
---|
7982 | WRITE( message_string, * ) 'nsurfl from SVF file does not ', & |
---|
7983 | 'match calculated nsurfl from ', & |
---|
7984 | 'radiation_interaction_init' |
---|
7985 | CALL message( 'radiation_read_svf', 'PA0490', 1, 2, 0, 6, 0 ) |
---|
7986 | ENDIF |
---|
7987 | |
---|
7988 | IF ( npcbl_from_file /= npcbl ) THEN |
---|
7989 | WRITE( message_string, * ) 'npcbl from SVF file does not ', & |
---|
7990 | 'match calculated npcbl from ', & |
---|
7991 | 'radiation_interaction_init' |
---|
7992 | CALL message( 'radiation_read_svf', 'PA0493', 1, 2, 0, 6, 0 ) |
---|
7993 | ENDIF |
---|
7994 | |
---|
7995 | IF ( ndsidir_from_file /= ndsidir ) THEN |
---|
7996 | WRITE( message_string, * ) 'ndsidir from SVF file does not ', & |
---|
7997 | 'match calculated ndsidir from ', & |
---|
7998 | 'radiation_presimulate_solar_pos' |
---|
7999 | CALL message( 'radiation_read_svf', 'PA0494', 1, 2, 0, 6, 0 ) |
---|
8000 | ENDIF |
---|
8001 | |
---|
8002 | ! |
---|
8003 | !-- Arrays skyvf, skyvft, dsitrans and dsitransc are allready |
---|
8004 | !-- allocated in radiation_interaction_init and |
---|
8005 | !-- radiation_presimulate_solar_pos |
---|
8006 | IF ( nsurfl > 0 ) THEN |
---|
8007 | READ(88) skyvf |
---|
8008 | READ(88) skyvft |
---|
8009 | READ(88) dsitrans |
---|
8010 | ENDIF |
---|
8011 | |
---|
8012 | IF ( plant_canopy .AND. npcbl > 0 ) THEN |
---|
8013 | READ ( 88 ) dsitransc |
---|
8014 | ENDIF |
---|
8015 | |
---|
8016 | ! |
---|
8017 | !-- The allocation of svf, svfsurf, csf and csfsurf happens in routine |
---|
8018 | !-- radiation_calc_svf which is not called if the program enters |
---|
8019 | !-- radiation_read_svf. Therefore these arrays has to allocate in the |
---|
8020 | !-- following |
---|
8021 | IF ( nsvfl > 0 ) THEN |
---|
8022 | ALLOCATE( svf(ndsvf,nsvfl) ) |
---|
8023 | ALLOCATE( svfsurf(idsvf,nsvfl) ) |
---|
8024 | READ(88) svf |
---|
8025 | READ(88) svfsurf |
---|
8026 | ENDIF |
---|
8027 | |
---|
8028 | IF ( plant_canopy .AND. ncsfl > 0 ) THEN |
---|
8029 | ALLOCATE( csf(ndcsf,ncsfl) ) |
---|
8030 | ALLOCATE( csfsurf(idcsf,ncsfl) ) |
---|
8031 | READ(88) csf |
---|
8032 | READ(88) csfsurf |
---|
8033 | ENDIF |
---|
8034 | |
---|
8035 | ! |
---|
8036 | !-- Close binary file |
---|
8037 | CALL close_file( 88 ) |
---|
8038 | |
---|
8039 | ENDIF |
---|
8040 | #if defined( __parallel ) |
---|
8041 | CALL MPI_BARRIER( comm2d, ierr ) |
---|
8042 | #endif |
---|
8043 | ENDDO |
---|
8044 | |
---|
8045 | END SUBROUTINE radiation_read_svf |
---|
8046 | |
---|
8047 | |
---|
8048 | !------------------------------------------------------------------------------! |
---|
8049 | ! |
---|
8050 | ! Description: |
---|
8051 | ! ------------ |
---|
8052 | !> Subroutine stores svf, svfsurf, csf and csfsurf data to a file. |
---|
8053 | !------------------------------------------------------------------------------! |
---|
8054 | SUBROUTINE radiation_write_svf |
---|
8055 | |
---|
8056 | IMPLICIT NONE |
---|
8057 | |
---|
8058 | INTEGER(iwp) :: i |
---|
8059 | |
---|
8060 | DO i = 0, io_blocks-1 |
---|
8061 | IF ( i == io_group ) THEN |
---|
8062 | ! |
---|
8063 | !-- Open binary file |
---|
8064 | CALL check_open( 89 ) |
---|
8065 | |
---|
8066 | WRITE ( 89 ) rad_version |
---|
8067 | WRITE ( 89 ) nsvfl, ncsfl, nsurfl, npcbl, ndsidir |
---|
8068 | IF ( nsurfl > 0 ) THEN |
---|
8069 | WRITE ( 89 ) skyvf |
---|
8070 | WRITE ( 89 ) skyvft |
---|
8071 | WRITE ( 89 ) dsitrans |
---|
8072 | ENDIF |
---|
8073 | IF ( npcbl > 0 ) THEN |
---|
8074 | WRITE ( 89 ) dsitransc |
---|
8075 | ENDIF |
---|
8076 | IF ( nsvfl > 0 ) THEN |
---|
8077 | WRITE ( 89 ) svf |
---|
8078 | WRITE ( 89 ) svfsurf |
---|
8079 | ENDIF |
---|
8080 | IF ( plant_canopy .AND. ncsfl > 0 ) THEN |
---|
8081 | WRITE ( 89 ) csf |
---|
8082 | WRITE ( 89 ) csfsurf |
---|
8083 | ENDIF |
---|
8084 | |
---|
8085 | ! |
---|
8086 | !-- Close binary file |
---|
8087 | CALL close_file( 89 ) |
---|
8088 | |
---|
8089 | ENDIF |
---|
8090 | #if defined( __parallel ) |
---|
8091 | CALL MPI_BARRIER( comm2d, ierr ) |
---|
8092 | #endif |
---|
8093 | ENDDO |
---|
8094 | END SUBROUTINE radiation_write_svf |
---|
8095 | |
---|
8096 | !------------------------------------------------------------------------------! |
---|
8097 | ! |
---|
8098 | ! Description: |
---|
8099 | ! ------------ |
---|
8100 | !> Block of auxiliary subroutines: |
---|
8101 | !> 1. quicksort and corresponding comparison |
---|
8102 | !> 2. merge_and_grow_csf for implementation of "dynamical growing" |
---|
8103 | !> array for csf |
---|
8104 | !------------------------------------------------------------------------------! |
---|
8105 | !-- quicksort.f -*-f90-*- |
---|
8106 | !-- Author: t-nissie, adaptation J.Resler |
---|
8107 | !-- License: GPLv3 |
---|
8108 | !-- Gist: https://gist.github.com/t-nissie/479f0f16966925fa29ea |
---|
8109 | RECURSIVE SUBROUTINE quicksort_itarget(itarget, vffrac, ztransp, first, last) |
---|
8110 | IMPLICIT NONE |
---|
8111 | INTEGER(iwp), DIMENSION(:), INTENT(INOUT) :: itarget |
---|
8112 | REAL(wp), DIMENSION(:), INTENT(INOUT) :: vffrac, ztransp |
---|
8113 | INTEGER(iwp), INTENT(IN) :: first, last |
---|
8114 | INTEGER(iwp) :: x, t |
---|
8115 | INTEGER(iwp) :: i, j |
---|
8116 | REAL(wp) :: tr |
---|
8117 | |
---|
8118 | IF ( first>=last ) RETURN |
---|
8119 | x = itarget((first+last)/2) |
---|
8120 | i = first |
---|
8121 | j = last |
---|
8122 | DO |
---|
8123 | DO WHILE ( itarget(i) < x ) |
---|
8124 | i=i+1 |
---|
8125 | ENDDO |
---|
8126 | DO WHILE ( x < itarget(j) ) |
---|
8127 | j=j-1 |
---|
8128 | ENDDO |
---|
8129 | IF ( i >= j ) EXIT |
---|
8130 | t = itarget(i); itarget(i) = itarget(j); itarget(j) = t |
---|
8131 | tr = vffrac(i); vffrac(i) = vffrac(j); vffrac(j) = tr |
---|
8132 | tr = ztransp(i); ztransp(i) = ztransp(j); ztransp(j) = tr |
---|
8133 | i=i+1 |
---|
8134 | j=j-1 |
---|
8135 | ENDDO |
---|
8136 | IF ( first < i-1 ) CALL quicksort_itarget(itarget, vffrac, ztransp, first, i-1) |
---|
8137 | IF ( j+1 < last ) CALL quicksort_itarget(itarget, vffrac, ztransp, j+1, last) |
---|
8138 | END SUBROUTINE quicksort_itarget |
---|
8139 | |
---|
8140 | PURE FUNCTION svf_lt(svf1,svf2) result (res) |
---|
8141 | TYPE (t_svf), INTENT(in) :: svf1,svf2 |
---|
8142 | LOGICAL :: res |
---|
8143 | IF ( svf1%isurflt < svf2%isurflt .OR. & |
---|
8144 | (svf1%isurflt == svf2%isurflt .AND. svf1%isurfs < svf2%isurfs) ) THEN |
---|
8145 | res = .TRUE. |
---|
8146 | ELSE |
---|
8147 | res = .FALSE. |
---|
8148 | ENDIF |
---|
8149 | END FUNCTION svf_lt |
---|
8150 | |
---|
8151 | |
---|
8152 | !-- quicksort.f -*-f90-*- |
---|
8153 | !-- Author: t-nissie, adaptation J.Resler |
---|
8154 | !-- License: GPLv3 |
---|
8155 | !-- Gist: https://gist.github.com/t-nissie/479f0f16966925fa29ea |
---|
8156 | RECURSIVE SUBROUTINE quicksort_svf(svfl, first, last) |
---|
8157 | IMPLICIT NONE |
---|
8158 | TYPE(t_svf), DIMENSION(:), INTENT(INOUT) :: svfl |
---|
8159 | INTEGER(iwp), INTENT(IN) :: first, last |
---|
8160 | TYPE(t_svf) :: x, t |
---|
8161 | INTEGER(iwp) :: i, j |
---|
8162 | |
---|
8163 | IF ( first>=last ) RETURN |
---|
8164 | x = svfl( (first+last) / 2 ) |
---|
8165 | i = first |
---|
8166 | j = last |
---|
8167 | DO |
---|
8168 | DO while ( svf_lt(svfl(i),x) ) |
---|
8169 | i=i+1 |
---|
8170 | ENDDO |
---|
8171 | DO while ( svf_lt(x,svfl(j)) ) |
---|
8172 | j=j-1 |
---|
8173 | ENDDO |
---|
8174 | IF ( i >= j ) EXIT |
---|
8175 | t = svfl(i); svfl(i) = svfl(j); svfl(j) = t |
---|
8176 | i=i+1 |
---|
8177 | j=j-1 |
---|
8178 | ENDDO |
---|
8179 | IF ( first < i-1 ) CALL quicksort_svf(svfl, first, i-1) |
---|
8180 | IF ( j+1 < last ) CALL quicksort_svf(svfl, j+1, last) |
---|
8181 | END SUBROUTINE quicksort_svf |
---|
8182 | |
---|
8183 | PURE FUNCTION csf_lt(csf1,csf2) result (res) |
---|
8184 | TYPE (t_csf), INTENT(in) :: csf1,csf2 |
---|
8185 | LOGICAL :: res |
---|
8186 | IF ( csf1%ip < csf2%ip .OR. & |
---|
8187 | (csf1%ip == csf2%ip .AND. csf1%itx < csf2%itx) .OR. & |
---|
8188 | (csf1%ip == csf2%ip .AND. csf1%itx == csf2%itx .AND. csf1%ity < csf2%ity) .OR. & |
---|
8189 | (csf1%ip == csf2%ip .AND. csf1%itx == csf2%itx .AND. csf1%ity == csf2%ity .AND. & |
---|
8190 | csf1%itz < csf2%itz) .OR. & |
---|
8191 | (csf1%ip == csf2%ip .AND. csf1%itx == csf2%itx .AND. csf1%ity == csf2%ity .AND. & |
---|
8192 | csf1%itz == csf2%itz .AND. csf1%isurfs < csf2%isurfs) ) THEN |
---|
8193 | res = .TRUE. |
---|
8194 | ELSE |
---|
8195 | res = .FALSE. |
---|
8196 | ENDIF |
---|
8197 | END FUNCTION csf_lt |
---|
8198 | |
---|
8199 | |
---|
8200 | !-- quicksort.f -*-f90-*- |
---|
8201 | !-- Author: t-nissie, adaptation J.Resler |
---|
8202 | !-- License: GPLv3 |
---|
8203 | !-- Gist: https://gist.github.com/t-nissie/479f0f16966925fa29ea |
---|
8204 | RECURSIVE SUBROUTINE quicksort_csf(csfl, first, last) |
---|
8205 | IMPLICIT NONE |
---|
8206 | TYPE(t_csf), DIMENSION(:), INTENT(INOUT) :: csfl |
---|
8207 | INTEGER(iwp), INTENT(IN) :: first, last |
---|
8208 | TYPE(t_csf) :: x, t |
---|
8209 | INTEGER(iwp) :: i, j |
---|
8210 | |
---|
8211 | IF ( first>=last ) RETURN |
---|
8212 | x = csfl( (first+last)/2 ) |
---|
8213 | i = first |
---|
8214 | j = last |
---|
8215 | DO |
---|
8216 | DO while ( csf_lt(csfl(i),x) ) |
---|
8217 | i=i+1 |
---|
8218 | ENDDO |
---|
8219 | DO while ( csf_lt(x,csfl(j)) ) |
---|
8220 | j=j-1 |
---|
8221 | ENDDO |
---|
8222 | IF ( i >= j ) EXIT |
---|
8223 | t = csfl(i); csfl(i) = csfl(j); csfl(j) = t |
---|
8224 | i=i+1 |
---|
8225 | j=j-1 |
---|
8226 | ENDDO |
---|
8227 | IF ( first < i-1 ) CALL quicksort_csf(csfl, first, i-1) |
---|
8228 | IF ( j+1 < last ) CALL quicksort_csf(csfl, j+1, last) |
---|
8229 | END SUBROUTINE quicksort_csf |
---|
8230 | |
---|
8231 | |
---|
8232 | SUBROUTINE merge_and_grow_csf(newsize) |
---|
8233 | INTEGER(iwp), INTENT(in) :: newsize !< new array size after grow, must be >= ncsfl |
---|
8234 | !< or -1 to shrink to minimum |
---|
8235 | INTEGER(iwp) :: iread, iwrite |
---|
8236 | TYPE(t_csf), DIMENSION(:), POINTER :: acsfnew |
---|
8237 | CHARACTER(100) :: msg |
---|
8238 | |
---|
8239 | IF ( newsize == -1 ) THEN |
---|
8240 | !-- merge in-place |
---|
8241 | acsfnew => acsf |
---|
8242 | ELSE |
---|
8243 | !-- allocate new array |
---|
8244 | IF ( mcsf == 0 ) THEN |
---|
8245 | ALLOCATE( acsf1(newsize) ) |
---|
8246 | acsfnew => acsf1 |
---|
8247 | ELSE |
---|
8248 | ALLOCATE( acsf2(newsize) ) |
---|
8249 | acsfnew => acsf2 |
---|
8250 | ENDIF |
---|
8251 | ENDIF |
---|
8252 | |
---|
8253 | IF ( ncsfl >= 1 ) THEN |
---|
8254 | !-- sort csf in place (quicksort) |
---|
8255 | CALL quicksort_csf(acsf,1,ncsfl) |
---|
8256 | |
---|
8257 | !-- while moving to a new array, aggregate canopy sink factor records with identical box & source |
---|
8258 | acsfnew(1) = acsf(1) |
---|
8259 | iwrite = 1 |
---|
8260 | DO iread = 2, ncsfl |
---|
8261 | !-- here acsf(kcsf) already has values from acsf(icsf) |
---|
8262 | IF ( acsfnew(iwrite)%itx == acsf(iread)%itx & |
---|
8263 | .AND. acsfnew(iwrite)%ity == acsf(iread)%ity & |
---|
8264 | .AND. acsfnew(iwrite)%itz == acsf(iread)%itz & |
---|
8265 | .AND. acsfnew(iwrite)%isurfs == acsf(iread)%isurfs ) THEN |
---|
8266 | |
---|
8267 | acsfnew(iwrite)%rcvf = acsfnew(iwrite)%rcvf + acsf(iread)%rcvf |
---|
8268 | !-- advance reading index, keep writing index |
---|
8269 | ELSE |
---|
8270 | !-- not identical, just advance and copy |
---|
8271 | iwrite = iwrite + 1 |
---|
8272 | acsfnew(iwrite) = acsf(iread) |
---|
8273 | ENDIF |
---|
8274 | ENDDO |
---|
8275 | ncsfl = iwrite |
---|
8276 | ENDIF |
---|
8277 | |
---|
8278 | IF ( newsize == -1 ) THEN |
---|
8279 | !-- allocate new array and copy shrinked data |
---|
8280 | IF ( mcsf == 0 ) THEN |
---|
8281 | ALLOCATE( acsf1(ncsfl) ) |
---|
8282 | acsf1(1:ncsfl) = acsf2(1:ncsfl) |
---|
8283 | ELSE |
---|
8284 | ALLOCATE( acsf2(ncsfl) ) |
---|
8285 | acsf2(1:ncsfl) = acsf1(1:ncsfl) |
---|
8286 | ENDIF |
---|
8287 | ENDIF |
---|
8288 | |
---|
8289 | !-- deallocate old array |
---|
8290 | IF ( mcsf == 0 ) THEN |
---|
8291 | mcsf = 1 |
---|
8292 | acsf => acsf1 |
---|
8293 | DEALLOCATE( acsf2 ) |
---|
8294 | ELSE |
---|
8295 | mcsf = 0 |
---|
8296 | acsf => acsf2 |
---|
8297 | DEALLOCATE( acsf1 ) |
---|
8298 | ENDIF |
---|
8299 | ncsfla = newsize |
---|
8300 | |
---|
8301 | WRITE(msg,'(A,2I12)') 'Grow acsf2:',ncsfl,ncsfla |
---|
8302 | CALL radiation_write_debug_log( msg ) |
---|
8303 | |
---|
8304 | END SUBROUTINE merge_and_grow_csf |
---|
8305 | |
---|
8306 | |
---|
8307 | !-- quicksort.f -*-f90-*- |
---|
8308 | !-- Author: t-nissie, adaptation J.Resler |
---|
8309 | !-- License: GPLv3 |
---|
8310 | !-- Gist: https://gist.github.com/t-nissie/479f0f16966925fa29ea |
---|
8311 | RECURSIVE SUBROUTINE quicksort_csf2(kpcsflt, pcsflt, first, last) |
---|
8312 | IMPLICIT NONE |
---|
8313 | INTEGER(iwp), DIMENSION(:,:), INTENT(INOUT) :: kpcsflt |
---|
8314 | REAL(wp), DIMENSION(:,:), INTENT(INOUT) :: pcsflt |
---|
8315 | INTEGER(iwp), INTENT(IN) :: first, last |
---|
8316 | REAL(wp), DIMENSION(ndcsf) :: t2 |
---|
8317 | INTEGER(iwp), DIMENSION(kdcsf) :: x, t1 |
---|
8318 | INTEGER(iwp) :: i, j |
---|
8319 | |
---|
8320 | IF ( first>=last ) RETURN |
---|
8321 | x = kpcsflt(:, (first+last)/2 ) |
---|
8322 | i = first |
---|
8323 | j = last |
---|
8324 | DO |
---|
8325 | DO while ( csf_lt2(kpcsflt(:,i),x) ) |
---|
8326 | i=i+1 |
---|
8327 | ENDDO |
---|
8328 | DO while ( csf_lt2(x,kpcsflt(:,j)) ) |
---|
8329 | j=j-1 |
---|
8330 | ENDDO |
---|
8331 | IF ( i >= j ) EXIT |
---|
8332 | t1 = kpcsflt(:,i); kpcsflt(:,i) = kpcsflt(:,j); kpcsflt(:,j) = t1 |
---|
8333 | t2 = pcsflt(:,i); pcsflt(:,i) = pcsflt(:,j); pcsflt(:,j) = t2 |
---|
8334 | i=i+1 |
---|
8335 | j=j-1 |
---|
8336 | ENDDO |
---|
8337 | IF ( first < i-1 ) CALL quicksort_csf2(kpcsflt, pcsflt, first, i-1) |
---|
8338 | IF ( j+1 < last ) CALL quicksort_csf2(kpcsflt, pcsflt, j+1, last) |
---|
8339 | END SUBROUTINE quicksort_csf2 |
---|
8340 | |
---|
8341 | |
---|
8342 | PURE FUNCTION csf_lt2(item1, item2) result(res) |
---|
8343 | INTEGER(iwp), DIMENSION(kdcsf), INTENT(in) :: item1, item2 |
---|
8344 | LOGICAL :: res |
---|
8345 | res = ( (item1(3) < item2(3)) & |
---|
8346 | .OR. (item1(3) == item2(3) .AND. item1(2) < item2(2)) & |
---|
8347 | .OR. (item1(3) == item2(3) .AND. item1(2) == item2(2) .AND. item1(1) < item2(1)) & |
---|
8348 | .OR. (item1(3) == item2(3) .AND. item1(2) == item2(2) .AND. item1(1) == item2(1) & |
---|
8349 | .AND. item1(4) < item2(4)) ) |
---|
8350 | END FUNCTION csf_lt2 |
---|
8351 | |
---|
8352 | PURE FUNCTION searchsorted(athresh, val) result(ind) |
---|
8353 | REAL(wp), DIMENSION(:), INTENT(IN) :: athresh |
---|
8354 | REAL(wp), INTENT(IN) :: val |
---|
8355 | INTEGER(iwp) :: ind |
---|
8356 | INTEGER(iwp) :: i |
---|
8357 | |
---|
8358 | DO i = LBOUND(athresh, 1), UBOUND(athresh, 1) |
---|
8359 | IF ( val < athresh(i) ) THEN |
---|
8360 | ind = i - 1 |
---|
8361 | RETURN |
---|
8362 | ENDIF |
---|
8363 | ENDDO |
---|
8364 | ind = UBOUND(athresh, 1) |
---|
8365 | END FUNCTION searchsorted |
---|
8366 | |
---|
8367 | !------------------------------------------------------------------------------! |
---|
8368 | ! Description: |
---|
8369 | ! ------------ |
---|
8370 | ! |
---|
8371 | !> radiation_radflux_gridbox subroutine gives the sw and lw radiation fluxes at the |
---|
8372 | !> faces of a gridbox defined at i,j,k and located in the urban layer. |
---|
8373 | !> The total sw and the diffuse sw radiation as well as the lw radiation fluxes at |
---|
8374 | !> the gridbox 6 faces are stored in sw_gridbox, swd_gridbox, and lw_gridbox arrays, |
---|
8375 | !> respectively, in the following order: |
---|
8376 | !> up_face, down_face, north_face, south_face, east_face, west_face |
---|
8377 | !> |
---|
8378 | !> The subroutine reports also how successful was the search process via the parameter |
---|
8379 | !> i_feedback as follow: |
---|
8380 | !> - i_feedback = 1 : successful |
---|
8381 | !> - i_feedback = -1 : unsuccessful; the requisted point is outside the urban domain |
---|
8382 | !> - i_feedback = 0 : uncomplete; some gridbox faces fluxes are missing |
---|
8383 | !> |
---|
8384 | !> |
---|
8385 | !> It is called outside from usm_urban_surface_mod whenever the radiation fluxes |
---|
8386 | !> are needed. |
---|
8387 | !> |
---|
8388 | !> This routine is not used so far. However, it may serve as an interface for radiation |
---|
8389 | !> fluxes of urban and land surfaces |
---|
8390 | !> |
---|
8391 | !> TODO: |
---|
8392 | !> - Compare performance when using some combination of the Fortran intrinsic |
---|
8393 | !> functions, e.g. MINLOC, MAXLOC, ALL, ANY and COUNT functions, which search |
---|
8394 | !> surfl array for elements meeting user-specified criterion, i.e. i,j,k |
---|
8395 | !> - Report non-found or incomplete radiation fluxes arrays , if any, at the |
---|
8396 | !> gridbox faces in an error message form |
---|
8397 | !> |
---|
8398 | !------------------------------------------------------------------------------! |
---|
8399 | SUBROUTINE radiation_radflux_gridbox(i,j,k,sw_gridbox,swd_gridbox,lw_gridbox,i_feedback) |
---|
8400 | |
---|
8401 | IMPLICIT NONE |
---|
8402 | |
---|
8403 | INTEGER(iwp), INTENT(in) :: i,j,k !< gridbox indices at which fluxes are required |
---|
8404 | INTEGER(iwp) :: ii,jj,kk,d !< surface indices and type |
---|
8405 | INTEGER(iwp) :: l !< surface id |
---|
8406 | REAL(wp) , DIMENSION(1:6), INTENT(out) :: sw_gridbox,lw_gridbox !< total sw and lw radiation fluxes of 6 faces of a gridbox, w/m2 |
---|
8407 | REAL(wp) , DIMENSION(1:6), INTENT(out) :: swd_gridbox !< diffuse sw radiation from sky and model boundary of 6 faces of a gridbox, w/m2 |
---|
8408 | INTEGER(iwp), INTENT(out) :: i_feedback !< feedback to report how the search was successful |
---|
8409 | |
---|
8410 | |
---|
8411 | !-- initialize variables |
---|
8412 | i_feedback = -999999 |
---|
8413 | sw_gridbox = -999999.9_wp |
---|
8414 | lw_gridbox = -999999.9_wp |
---|
8415 | swd_gridbox = -999999.9_wp |
---|
8416 | |
---|
8417 | !-- check the requisted grid indices |
---|
8418 | IF ( k < nzb .OR. k > nzut .OR. & |
---|
8419 | j < nysg .OR. j > nyng .OR. & |
---|
8420 | i < nxlg .OR. i > nxrg & |
---|
8421 | ) THEN |
---|
8422 | i_feedback = -1 |
---|
8423 | RETURN |
---|
8424 | ENDIF |
---|
8425 | |
---|
8426 | !-- search for the required grid and formulate the fluxes at the 6 gridbox faces |
---|
8427 | DO l = 1, nsurfl |
---|
8428 | ii = surfl(ix,l) |
---|
8429 | jj = surfl(iy,l) |
---|
8430 | kk = surfl(iz,l) |
---|
8431 | |
---|
8432 | IF ( ii == i .AND. jj == j .AND. kk == k ) THEN |
---|
8433 | d = surfl(id,l) |
---|
8434 | |
---|
8435 | SELECT CASE ( d ) |
---|
8436 | |
---|
8437 | CASE (iup_u,iup_l) !- gridbox up_facing face |
---|
8438 | sw_gridbox(1) = surfinsw(l) |
---|
8439 | lw_gridbox(1) = surfinlw(l) |
---|
8440 | swd_gridbox(1) = surfinswdif(l) |
---|
8441 | |
---|
8442 | CASE (inorth_u,inorth_l) !- gridbox north_facing face |
---|
8443 | sw_gridbox(3) = surfinsw(l) |
---|
8444 | lw_gridbox(3) = surfinlw(l) |
---|
8445 | swd_gridbox(3) = surfinswdif(l) |
---|
8446 | |
---|
8447 | CASE (isouth_u,isouth_l) !- gridbox south_facing face |
---|
8448 | sw_gridbox(4) = surfinsw(l) |
---|
8449 | lw_gridbox(4) = surfinlw(l) |
---|
8450 | swd_gridbox(4) = surfinswdif(l) |
---|
8451 | |
---|
8452 | CASE (ieast_u,ieast_l) !- gridbox east_facing face |
---|
8453 | sw_gridbox(5) = surfinsw(l) |
---|
8454 | lw_gridbox(5) = surfinlw(l) |
---|
8455 | swd_gridbox(5) = surfinswdif(l) |
---|
8456 | |
---|
8457 | CASE (iwest_u,iwest_l) !- gridbox west_facing face |
---|
8458 | sw_gridbox(6) = surfinsw(l) |
---|
8459 | lw_gridbox(6) = surfinlw(l) |
---|
8460 | swd_gridbox(6) = surfinswdif(l) |
---|
8461 | |
---|
8462 | END SELECT |
---|
8463 | |
---|
8464 | ENDIF |
---|
8465 | |
---|
8466 | IF ( ALL( sw_gridbox(:) /= -999999.9_wp ) ) EXIT |
---|
8467 | ENDDO |
---|
8468 | |
---|
8469 | !-- check the completeness of the fluxes at all gidbox faces |
---|
8470 | !-- TODO: report non-found or incomplete rad fluxes arrays in an error message form |
---|
8471 | IF ( ANY( sw_gridbox(:) <= -999999.9_wp ) .OR. & |
---|
8472 | ANY( swd_gridbox(:) <= -999999.9_wp ) .OR. & |
---|
8473 | ANY( lw_gridbox(:) <= -999999.9_wp ) ) THEN |
---|
8474 | i_feedback = 0 |
---|
8475 | ELSE |
---|
8476 | i_feedback = 1 |
---|
8477 | ENDIF |
---|
8478 | |
---|
8479 | RETURN |
---|
8480 | |
---|
8481 | END SUBROUTINE radiation_radflux_gridbox |
---|
8482 | |
---|
8483 | !------------------------------------------------------------------------------! |
---|
8484 | ! |
---|
8485 | ! Description: |
---|
8486 | ! ------------ |
---|
8487 | !> Subroutine for averaging 3D data |
---|
8488 | !------------------------------------------------------------------------------! |
---|
8489 | SUBROUTINE radiation_3d_data_averaging( mode, variable ) |
---|
8490 | |
---|
8491 | |
---|
8492 | USE control_parameters |
---|
8493 | |
---|
8494 | USE indices |
---|
8495 | |
---|
8496 | USE kinds |
---|
8497 | |
---|
8498 | IMPLICIT NONE |
---|
8499 | |
---|
8500 | CHARACTER (LEN=*) :: mode !< |
---|
8501 | CHARACTER (LEN=*) :: variable !< |
---|
8502 | |
---|
8503 | LOGICAL :: match_lsm !< flag indicating natural-type surface |
---|
8504 | LOGICAL :: match_usm !< flag indicating urban-type surface |
---|
8505 | |
---|
8506 | INTEGER(iwp) :: i !< |
---|
8507 | INTEGER(iwp) :: j !< |
---|
8508 | INTEGER(iwp) :: k !< |
---|
8509 | INTEGER(iwp) :: l, m !< index of current surface element |
---|
8510 | |
---|
8511 | IF ( mode == 'allocate' ) THEN |
---|
8512 | |
---|
8513 | SELECT CASE ( TRIM( variable ) ) |
---|
8514 | |
---|
8515 | CASE ( 'rad_net*' ) |
---|
8516 | IF ( .NOT. ALLOCATED( rad_net_av ) ) THEN |
---|
8517 | ALLOCATE( rad_net_av(nysg:nyng,nxlg:nxrg) ) |
---|
8518 | ENDIF |
---|
8519 | rad_net_av = 0.0_wp |
---|
8520 | |
---|
8521 | CASE ( 'rad_lw_in*' ) |
---|
8522 | IF ( .NOT. ALLOCATED( rad_lw_in_xy_av ) ) THEN |
---|
8523 | ALLOCATE( rad_lw_in_xy_av(nysg:nyng,nxlg:nxrg) ) |
---|
8524 | ENDIF |
---|
8525 | rad_lw_in_xy_av = 0.0_wp |
---|
8526 | |
---|
8527 | CASE ( 'rad_lw_out*' ) |
---|
8528 | IF ( .NOT. ALLOCATED( rad_lw_out_xy_av ) ) THEN |
---|
8529 | ALLOCATE( rad_lw_out_xy_av(nysg:nyng,nxlg:nxrg) ) |
---|
8530 | ENDIF |
---|
8531 | rad_lw_out_xy_av = 0.0_wp |
---|
8532 | |
---|
8533 | CASE ( 'rad_sw_in*' ) |
---|
8534 | IF ( .NOT. ALLOCATED( rad_sw_in_xy_av ) ) THEN |
---|
8535 | ALLOCATE( rad_sw_in_xy_av(nysg:nyng,nxlg:nxrg) ) |
---|
8536 | ENDIF |
---|
8537 | rad_sw_in_xy_av = 0.0_wp |
---|
8538 | |
---|
8539 | CASE ( 'rad_sw_out*' ) |
---|
8540 | IF ( .NOT. ALLOCATED( rad_sw_out_xy_av ) ) THEN |
---|
8541 | ALLOCATE( rad_sw_out_xy_av(nysg:nyng,nxlg:nxrg) ) |
---|
8542 | ENDIF |
---|
8543 | rad_sw_out_xy_av = 0.0_wp |
---|
8544 | |
---|
8545 | CASE ( 'rad_lw_in' ) |
---|
8546 | IF ( .NOT. ALLOCATED( rad_lw_in_av ) ) THEN |
---|
8547 | ALLOCATE( rad_lw_in_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) |
---|
8548 | ENDIF |
---|
8549 | rad_lw_in_av = 0.0_wp |
---|
8550 | |
---|
8551 | CASE ( 'rad_lw_out' ) |
---|
8552 | IF ( .NOT. ALLOCATED( rad_lw_out_av ) ) THEN |
---|
8553 | ALLOCATE( rad_lw_in_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) |
---|
8554 | ENDIF |
---|
8555 | rad_lw_out_av = 0.0_wp |
---|
8556 | |
---|
8557 | CASE ( 'rad_lw_cs_hr' ) |
---|
8558 | IF ( .NOT. ALLOCATED( rad_lw_cs_hr_av ) ) THEN |
---|
8559 | ALLOCATE( rad_lw_cs_hr_av(nzb+1:nzt+1,nysg:nyng,nxlg:nxrg) ) |
---|
8560 | ENDIF |
---|
8561 | rad_lw_cs_hr_av = 0.0_wp |
---|
8562 | |
---|
8563 | CASE ( 'rad_lw_hr' ) |
---|
8564 | IF ( .NOT. ALLOCATED( rad_lw_hr_av ) ) THEN |
---|
8565 | ALLOCATE( rad_lw_hr_av(nzb+1:nzt+1,nysg:nyng,nxlg:nxrg) ) |
---|
8566 | ENDIF |
---|
8567 | rad_lw_hr_av = 0.0_wp |
---|
8568 | |
---|
8569 | CASE ( 'rad_sw_in' ) |
---|
8570 | IF ( .NOT. ALLOCATED( rad_sw_in_av ) ) THEN |
---|
8571 | ALLOCATE( rad_sw_in_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) |
---|
8572 | ENDIF |
---|
8573 | rad_sw_in_av = 0.0_wp |
---|
8574 | |
---|
8575 | CASE ( 'rad_sw_out' ) |
---|
8576 | IF ( .NOT. ALLOCATED( rad_sw_out_av ) ) THEN |
---|
8577 | ALLOCATE( rad_sw_out_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) |
---|
8578 | ENDIF |
---|
8579 | rad_sw_out_av = 0.0_wp |
---|
8580 | |
---|
8581 | CASE ( 'rad_sw_cs_hr' ) |
---|
8582 | IF ( .NOT. ALLOCATED( rad_sw_cs_hr_av ) ) THEN |
---|
8583 | ALLOCATE( rad_sw_cs_hr_av(nzb+1:nzt+1,nysg:nyng,nxlg:nxrg) ) |
---|
8584 | ENDIF |
---|
8585 | rad_sw_cs_hr_av = 0.0_wp |
---|
8586 | |
---|
8587 | CASE ( 'rad_sw_hr' ) |
---|
8588 | IF ( .NOT. ALLOCATED( rad_sw_hr_av ) ) THEN |
---|
8589 | ALLOCATE( rad_sw_hr_av(nzb+1:nzt+1,nysg:nyng,nxlg:nxrg) ) |
---|
8590 | ENDIF |
---|
8591 | rad_sw_hr_av = 0.0_wp |
---|
8592 | |
---|
8593 | CASE ( 'rad_mrt_sw' ) |
---|
8594 | IF ( .NOT. ALLOCATED( mrtinsw_av ) ) THEN |
---|
8595 | ALLOCATE( mrtinsw_av(nmrtbl) ) |
---|
8596 | ENDIF |
---|
8597 | mrtinsw_av = 0.0_wp |
---|
8598 | |
---|
8599 | CASE ( 'rad_mrt_lw' ) |
---|
8600 | IF ( .NOT. ALLOCATED( mrtinlw_av ) ) THEN |
---|
8601 | ALLOCATE( mrtinlw_av(nmrtbl) ) |
---|
8602 | ENDIF |
---|
8603 | mrtinlw_av = 0.0_wp |
---|
8604 | |
---|
8605 | CASE ( 'rad_mrt' ) |
---|
8606 | IF ( .NOT. ALLOCATED( mrt_av ) ) THEN |
---|
8607 | ALLOCATE( mrt_av(nmrtbl) ) |
---|
8608 | ENDIF |
---|
8609 | mrt_av = 0.0_wp |
---|
8610 | |
---|
8611 | CASE DEFAULT |
---|
8612 | CONTINUE |
---|
8613 | |
---|
8614 | END SELECT |
---|
8615 | |
---|
8616 | ELSEIF ( mode == 'sum' ) THEN |
---|
8617 | |
---|
8618 | SELECT CASE ( TRIM( variable ) ) |
---|
8619 | |
---|
8620 | CASE ( 'rad_net*' ) |
---|
8621 | IF ( ALLOCATED( rad_net_av ) ) THEN |
---|
8622 | DO i = nxl, nxr |
---|
8623 | DO j = nys, nyn |
---|
8624 | match_lsm = surf_lsm_h%start_index(j,i) <= & |
---|
8625 | surf_lsm_h%end_index(j,i) |
---|
8626 | match_usm = surf_usm_h%start_index(j,i) <= & |
---|
8627 | surf_usm_h%end_index(j,i) |
---|
8628 | |
---|
8629 | IF ( match_lsm .AND. .NOT. match_usm ) THEN |
---|
8630 | m = surf_lsm_h%end_index(j,i) |
---|
8631 | rad_net_av(j,i) = rad_net_av(j,i) + & |
---|
8632 | surf_lsm_h%rad_net(m) |
---|
8633 | ELSEIF ( match_usm ) THEN |
---|
8634 | m = surf_usm_h%end_index(j,i) |
---|
8635 | rad_net_av(j,i) = rad_net_av(j,i) + & |
---|
8636 | surf_usm_h%rad_net(m) |
---|
8637 | ENDIF |
---|
8638 | ENDDO |
---|
8639 | ENDDO |
---|
8640 | ENDIF |
---|
8641 | |
---|
8642 | CASE ( 'rad_lw_in*' ) |
---|
8643 | IF ( ALLOCATED( rad_lw_in_xy_av ) ) THEN |
---|
8644 | DO i = nxl, nxr |
---|
8645 | DO j = nys, nyn |
---|
8646 | match_lsm = surf_lsm_h%start_index(j,i) <= & |
---|
8647 | surf_lsm_h%end_index(j,i) |
---|
8648 | match_usm = surf_usm_h%start_index(j,i) <= & |
---|
8649 | surf_usm_h%end_index(j,i) |
---|
8650 | |
---|
8651 | IF ( match_lsm .AND. .NOT. match_usm ) THEN |
---|
8652 | m = surf_lsm_h%end_index(j,i) |
---|
8653 | rad_lw_in_xy_av(j,i) = rad_lw_in_xy_av(j,i) + & |
---|
8654 | surf_lsm_h%rad_lw_in(m) |
---|
8655 | ELSEIF ( match_usm ) THEN |
---|
8656 | m = surf_usm_h%end_index(j,i) |
---|
8657 | rad_lw_in_xy_av(j,i) = rad_lw_in_xy_av(j,i) + & |
---|
8658 | surf_usm_h%rad_lw_in(m) |
---|
8659 | ENDIF |
---|
8660 | ENDDO |
---|
8661 | ENDDO |
---|
8662 | ENDIF |
---|
8663 | |
---|
8664 | CASE ( 'rad_lw_out*' ) |
---|
8665 | IF ( ALLOCATED( rad_lw_out_xy_av ) ) THEN |
---|
8666 | DO i = nxl, nxr |
---|
8667 | DO j = nys, nyn |
---|
8668 | match_lsm = surf_lsm_h%start_index(j,i) <= & |
---|
8669 | surf_lsm_h%end_index(j,i) |
---|
8670 | match_usm = surf_usm_h%start_index(j,i) <= & |
---|
8671 | surf_usm_h%end_index(j,i) |
---|
8672 | |
---|
8673 | IF ( match_lsm .AND. .NOT. match_usm ) THEN |
---|
8674 | m = surf_lsm_h%end_index(j,i) |
---|
8675 | rad_lw_out_xy_av(j,i) = rad_lw_out_xy_av(j,i) + & |
---|
8676 | surf_lsm_h%rad_lw_out(m) |
---|
8677 | ELSEIF ( match_usm ) THEN |
---|
8678 | m = surf_usm_h%end_index(j,i) |
---|
8679 | rad_lw_out_xy_av(j,i) = rad_lw_out_xy_av(j,i) + & |
---|
8680 | surf_usm_h%rad_lw_out(m) |
---|
8681 | ENDIF |
---|
8682 | ENDDO |
---|
8683 | ENDDO |
---|
8684 | ENDIF |
---|
8685 | |
---|
8686 | CASE ( 'rad_sw_in*' ) |
---|
8687 | IF ( ALLOCATED( rad_sw_in_xy_av ) ) THEN |
---|
8688 | DO i = nxl, nxr |
---|
8689 | DO j = nys, nyn |
---|
8690 | match_lsm = surf_lsm_h%start_index(j,i) <= & |
---|
8691 | surf_lsm_h%end_index(j,i) |
---|
8692 | match_usm = surf_usm_h%start_index(j,i) <= & |
---|
8693 | surf_usm_h%end_index(j,i) |
---|
8694 | |
---|
8695 | IF ( match_lsm .AND. .NOT. match_usm ) THEN |
---|
8696 | m = surf_lsm_h%end_index(j,i) |
---|
8697 | rad_sw_in_xy_av(j,i) = rad_sw_in_xy_av(j,i) + & |
---|
8698 | surf_lsm_h%rad_sw_in(m) |
---|
8699 | ELSEIF ( match_usm ) THEN |
---|
8700 | m = surf_usm_h%end_index(j,i) |
---|
8701 | rad_sw_in_xy_av(j,i) = rad_sw_in_xy_av(j,i) + & |
---|
8702 | surf_usm_h%rad_sw_in(m) |
---|
8703 | ENDIF |
---|
8704 | ENDDO |
---|
8705 | ENDDO |
---|
8706 | ENDIF |
---|
8707 | |
---|
8708 | CASE ( 'rad_sw_out*' ) |
---|
8709 | IF ( ALLOCATED( rad_sw_out_xy_av ) ) THEN |
---|
8710 | DO i = nxl, nxr |
---|
8711 | DO j = nys, nyn |
---|
8712 | match_lsm = surf_lsm_h%start_index(j,i) <= & |
---|
8713 | surf_lsm_h%end_index(j,i) |
---|
8714 | match_usm = surf_usm_h%start_index(j,i) <= & |
---|
8715 | surf_usm_h%end_index(j,i) |
---|
8716 | |
---|
8717 | IF ( match_lsm .AND. .NOT. match_usm ) THEN |
---|
8718 | m = surf_lsm_h%end_index(j,i) |
---|
8719 | rad_sw_out_xy_av(j,i) = rad_sw_out_xy_av(j,i) + & |
---|
8720 | surf_lsm_h%rad_sw_out(m) |
---|
8721 | ELSEIF ( match_usm ) THEN |
---|
8722 | m = surf_usm_h%end_index(j,i) |
---|
8723 | rad_sw_out_xy_av(j,i) = rad_sw_out_xy_av(j,i) + & |
---|
8724 | surf_usm_h%rad_sw_out(m) |
---|
8725 | ENDIF |
---|
8726 | ENDDO |
---|
8727 | ENDDO |
---|
8728 | ENDIF |
---|
8729 | |
---|
8730 | CASE ( 'rad_lw_in' ) |
---|
8731 | IF ( ALLOCATED( rad_lw_in_av ) ) THEN |
---|
8732 | DO i = nxlg, nxrg |
---|
8733 | DO j = nysg, nyng |
---|
8734 | DO k = nzb, nzt+1 |
---|
8735 | rad_lw_in_av(k,j,i) = rad_lw_in_av(k,j,i) & |
---|
8736 | + rad_lw_in(k,j,i) |
---|
8737 | ENDDO |
---|
8738 | ENDDO |
---|
8739 | ENDDO |
---|
8740 | ENDIF |
---|
8741 | |
---|
8742 | CASE ( 'rad_lw_out' ) |
---|
8743 | IF ( ALLOCATED( rad_lw_out_av ) ) THEN |
---|
8744 | DO i = nxlg, nxrg |
---|
8745 | DO j = nysg, nyng |
---|
8746 | DO k = nzb, nzt+1 |
---|
8747 | rad_lw_out_av(k,j,i) = rad_lw_out_av(k,j,i) & |
---|
8748 | + rad_lw_out(k,j,i) |
---|
8749 | ENDDO |
---|
8750 | ENDDO |
---|
8751 | ENDDO |
---|
8752 | ENDIF |
---|
8753 | |
---|
8754 | CASE ( 'rad_lw_cs_hr' ) |
---|
8755 | IF ( ALLOCATED( rad_lw_cs_hr_av ) ) THEN |
---|
8756 | DO i = nxlg, nxrg |
---|
8757 | DO j = nysg, nyng |
---|
8758 | DO k = nzb, nzt+1 |
---|
8759 | rad_lw_cs_hr_av(k,j,i) = rad_lw_cs_hr_av(k,j,i) & |
---|
8760 | + rad_lw_cs_hr(k,j,i) |
---|
8761 | ENDDO |
---|
8762 | ENDDO |
---|
8763 | ENDDO |
---|
8764 | ENDIF |
---|
8765 | |
---|
8766 | CASE ( 'rad_lw_hr' ) |
---|
8767 | IF ( ALLOCATED( rad_lw_hr_av ) ) THEN |
---|
8768 | DO i = nxlg, nxrg |
---|
8769 | DO j = nysg, nyng |
---|
8770 | DO k = nzb, nzt+1 |
---|
8771 | rad_lw_hr_av(k,j,i) = rad_lw_hr_av(k,j,i) & |
---|
8772 | + rad_lw_hr(k,j,i) |
---|
8773 | ENDDO |
---|
8774 | ENDDO |
---|
8775 | ENDDO |
---|
8776 | ENDIF |
---|
8777 | |
---|
8778 | CASE ( 'rad_sw_in' ) |
---|
8779 | IF ( ALLOCATED( rad_sw_in_av ) ) THEN |
---|
8780 | DO i = nxlg, nxrg |
---|
8781 | DO j = nysg, nyng |
---|
8782 | DO k = nzb, nzt+1 |
---|
8783 | rad_sw_in_av(k,j,i) = rad_sw_in_av(k,j,i) & |
---|
8784 | + rad_sw_in(k,j,i) |
---|
8785 | ENDDO |
---|
8786 | ENDDO |
---|
8787 | ENDDO |
---|
8788 | ENDIF |
---|
8789 | |
---|
8790 | CASE ( 'rad_sw_out' ) |
---|
8791 | IF ( ALLOCATED( rad_sw_out_av ) ) THEN |
---|
8792 | DO i = nxlg, nxrg |
---|
8793 | DO j = nysg, nyng |
---|
8794 | DO k = nzb, nzt+1 |
---|
8795 | rad_sw_out_av(k,j,i) = rad_sw_out_av(k,j,i) & |
---|
8796 | + rad_sw_out(k,j,i) |
---|
8797 | ENDDO |
---|
8798 | ENDDO |
---|
8799 | ENDDO |
---|
8800 | ENDIF |
---|
8801 | |
---|
8802 | CASE ( 'rad_sw_cs_hr' ) |
---|
8803 | IF ( ALLOCATED( rad_sw_cs_hr_av ) ) THEN |
---|
8804 | DO i = nxlg, nxrg |
---|
8805 | DO j = nysg, nyng |
---|
8806 | DO k = nzb, nzt+1 |
---|
8807 | rad_sw_cs_hr_av(k,j,i) = rad_sw_cs_hr_av(k,j,i) & |
---|
8808 | + rad_sw_cs_hr(k,j,i) |
---|
8809 | ENDDO |
---|
8810 | ENDDO |
---|
8811 | ENDDO |
---|
8812 | ENDIF |
---|
8813 | |
---|
8814 | CASE ( 'rad_sw_hr' ) |
---|
8815 | IF ( ALLOCATED( rad_sw_hr_av ) ) THEN |
---|
8816 | DO i = nxlg, nxrg |
---|
8817 | DO j = nysg, nyng |
---|
8818 | DO k = nzb, nzt+1 |
---|
8819 | rad_sw_hr_av(k,j,i) = rad_sw_hr_av(k,j,i) & |
---|
8820 | + rad_sw_hr(k,j,i) |
---|
8821 | ENDDO |
---|
8822 | ENDDO |
---|
8823 | ENDDO |
---|
8824 | ENDIF |
---|
8825 | |
---|
8826 | CASE ( 'rad_mrt_sw' ) |
---|
8827 | IF ( ALLOCATED( mrtinsw_av ) ) THEN |
---|
8828 | mrtinsw_av(:) = mrtinsw_av(:) + mrtinsw(:) |
---|
8829 | ENDIF |
---|
8830 | |
---|
8831 | CASE ( 'rad_mrt_lw' ) |
---|
8832 | IF ( ALLOCATED( mrtinlw_av ) ) THEN |
---|
8833 | mrtinlw_av(:) = mrtinlw_av(:) + mrtinlw(:) |
---|
8834 | ENDIF |
---|
8835 | |
---|
8836 | CASE ( 'rad_mrt' ) |
---|
8837 | IF ( ALLOCATED( mrt_av ) ) THEN |
---|
8838 | mrt_av(:) = mrt_av(:) + mrt(:) |
---|
8839 | ENDIF |
---|
8840 | |
---|
8841 | CASE DEFAULT |
---|
8842 | CONTINUE |
---|
8843 | |
---|
8844 | END SELECT |
---|
8845 | |
---|
8846 | ELSEIF ( mode == 'average' ) THEN |
---|
8847 | |
---|
8848 | SELECT CASE ( TRIM( variable ) ) |
---|
8849 | |
---|
8850 | CASE ( 'rad_net*' ) |
---|
8851 | IF ( ALLOCATED( rad_net_av ) ) THEN |
---|
8852 | DO i = nxlg, nxrg |
---|
8853 | DO j = nysg, nyng |
---|
8854 | rad_net_av(j,i) = rad_net_av(j,i) & |
---|
8855 | / REAL( average_count_3d, KIND=wp ) |
---|
8856 | ENDDO |
---|
8857 | ENDDO |
---|
8858 | ENDIF |
---|
8859 | |
---|
8860 | CASE ( 'rad_lw_in*' ) |
---|
8861 | IF ( ALLOCATED( rad_lw_in_xy_av ) ) THEN |
---|
8862 | DO i = nxlg, nxrg |
---|
8863 | DO j = nysg, nyng |
---|
8864 | rad_lw_in_xy_av(j,i) = rad_lw_in_xy_av(j,i) & |
---|
8865 | / REAL( average_count_3d, KIND=wp ) |
---|
8866 | ENDDO |
---|
8867 | ENDDO |
---|
8868 | ENDIF |
---|
8869 | |
---|
8870 | CASE ( 'rad_lw_out*' ) |
---|
8871 | IF ( ALLOCATED( rad_lw_out_xy_av ) ) THEN |
---|
8872 | DO i = nxlg, nxrg |
---|
8873 | DO j = nysg, nyng |
---|
8874 | rad_lw_out_xy_av(j,i) = rad_lw_out_xy_av(j,i) & |
---|
8875 | / REAL( average_count_3d, KIND=wp ) |
---|
8876 | ENDDO |
---|
8877 | ENDDO |
---|
8878 | ENDIF |
---|
8879 | |
---|
8880 | CASE ( 'rad_sw_in*' ) |
---|
8881 | IF ( ALLOCATED( rad_sw_in_xy_av ) ) THEN |
---|
8882 | DO i = nxlg, nxrg |
---|
8883 | DO j = nysg, nyng |
---|
8884 | rad_sw_in_xy_av(j,i) = rad_sw_in_xy_av(j,i) & |
---|
8885 | / REAL( average_count_3d, KIND=wp ) |
---|
8886 | ENDDO |
---|
8887 | ENDDO |
---|
8888 | ENDIF |
---|
8889 | |
---|
8890 | CASE ( 'rad_sw_out*' ) |
---|
8891 | IF ( ALLOCATED( rad_sw_out_xy_av ) ) THEN |
---|
8892 | DO i = nxlg, nxrg |
---|
8893 | DO j = nysg, nyng |
---|
8894 | rad_sw_out_xy_av(j,i) = rad_sw_out_xy_av(j,i) & |
---|
8895 | / REAL( average_count_3d, KIND=wp ) |
---|
8896 | ENDDO |
---|
8897 | ENDDO |
---|
8898 | ENDIF |
---|
8899 | |
---|
8900 | CASE ( 'rad_lw_in' ) |
---|
8901 | IF ( ALLOCATED( rad_lw_in_av ) ) THEN |
---|
8902 | DO i = nxlg, nxrg |
---|
8903 | DO j = nysg, nyng |
---|
8904 | DO k = nzb, nzt+1 |
---|
8905 | rad_lw_in_av(k,j,i) = rad_lw_in_av(k,j,i) & |
---|
8906 | / REAL( average_count_3d, KIND=wp ) |
---|
8907 | ENDDO |
---|
8908 | ENDDO |
---|
8909 | ENDDO |
---|
8910 | ENDIF |
---|
8911 | |
---|
8912 | CASE ( 'rad_lw_out' ) |
---|
8913 | IF ( ALLOCATED( rad_lw_out_av ) ) THEN |
---|
8914 | DO i = nxlg, nxrg |
---|
8915 | DO j = nysg, nyng |
---|
8916 | DO k = nzb, nzt+1 |
---|
8917 | rad_lw_out_av(k,j,i) = rad_lw_out_av(k,j,i) & |
---|
8918 | / REAL( average_count_3d, KIND=wp ) |
---|
8919 | ENDDO |
---|
8920 | ENDDO |
---|
8921 | ENDDO |
---|
8922 | ENDIF |
---|
8923 | |
---|
8924 | CASE ( 'rad_lw_cs_hr' ) |
---|
8925 | IF ( ALLOCATED( rad_lw_cs_hr_av ) ) THEN |
---|
8926 | DO i = nxlg, nxrg |
---|
8927 | DO j = nysg, nyng |
---|
8928 | DO k = nzb, nzt+1 |
---|
8929 | rad_lw_cs_hr_av(k,j,i) = rad_lw_cs_hr_av(k,j,i) & |
---|
8930 | / REAL( average_count_3d, KIND=wp ) |
---|
8931 | ENDDO |
---|
8932 | ENDDO |
---|
8933 | ENDDO |
---|
8934 | ENDIF |
---|
8935 | |
---|
8936 | CASE ( 'rad_lw_hr' ) |
---|
8937 | IF ( ALLOCATED( rad_lw_hr_av ) ) THEN |
---|
8938 | DO i = nxlg, nxrg |
---|
8939 | DO j = nysg, nyng |
---|
8940 | DO k = nzb, nzt+1 |
---|
8941 | rad_lw_hr_av(k,j,i) = rad_lw_hr_av(k,j,i) & |
---|
8942 | / REAL( average_count_3d, KIND=wp ) |
---|
8943 | ENDDO |
---|
8944 | ENDDO |
---|
8945 | ENDDO |
---|
8946 | ENDIF |
---|
8947 | |
---|
8948 | CASE ( 'rad_sw_in' ) |
---|
8949 | IF ( ALLOCATED( rad_sw_in_av ) ) THEN |
---|
8950 | DO i = nxlg, nxrg |
---|
8951 | DO j = nysg, nyng |
---|
8952 | DO k = nzb, nzt+1 |
---|
8953 | rad_sw_in_av(k,j,i) = rad_sw_in_av(k,j,i) & |
---|
8954 | / REAL( average_count_3d, KIND=wp ) |
---|
8955 | ENDDO |
---|
8956 | ENDDO |
---|
8957 | ENDDO |
---|
8958 | ENDIF |
---|
8959 | |
---|
8960 | CASE ( 'rad_sw_out' ) |
---|
8961 | IF ( ALLOCATED( rad_sw_out_av ) ) THEN |
---|
8962 | DO i = nxlg, nxrg |
---|
8963 | DO j = nysg, nyng |
---|
8964 | DO k = nzb, nzt+1 |
---|
8965 | rad_sw_out_av(k,j,i) = rad_sw_out_av(k,j,i) & |
---|
8966 | / REAL( average_count_3d, KIND=wp ) |
---|
8967 | ENDDO |
---|
8968 | ENDDO |
---|
8969 | ENDDO |
---|
8970 | ENDIF |
---|
8971 | |
---|
8972 | CASE ( 'rad_sw_cs_hr' ) |
---|
8973 | IF ( ALLOCATED( rad_sw_cs_hr_av ) ) THEN |
---|
8974 | DO i = nxlg, nxrg |
---|
8975 | DO j = nysg, nyng |
---|
8976 | DO k = nzb, nzt+1 |
---|
8977 | rad_sw_cs_hr_av(k,j,i) = rad_sw_cs_hr_av(k,j,i) & |
---|
8978 | / REAL( average_count_3d, KIND=wp ) |
---|
8979 | ENDDO |
---|
8980 | ENDDO |
---|
8981 | ENDDO |
---|
8982 | ENDIF |
---|
8983 | |
---|
8984 | CASE ( 'rad_sw_hr' ) |
---|
8985 | IF ( ALLOCATED( rad_sw_hr_av ) ) THEN |
---|
8986 | DO i = nxlg, nxrg |
---|
8987 | DO j = nysg, nyng |
---|
8988 | DO k = nzb, nzt+1 |
---|
8989 | rad_sw_hr_av(k,j,i) = rad_sw_hr_av(k,j,i) & |
---|
8990 | / REAL( average_count_3d, KIND=wp ) |
---|
8991 | ENDDO |
---|
8992 | ENDDO |
---|
8993 | ENDDO |
---|
8994 | ENDIF |
---|
8995 | |
---|
8996 | CASE ( 'rad_mrt_sw' ) |
---|
8997 | IF ( ALLOCATED( mrtinsw_av ) ) THEN |
---|
8998 | mrtinsw_av(:) = mrtinsw_av(:) / REAL( average_count_3d, KIND=wp ) |
---|
8999 | ENDIF |
---|
9000 | |
---|
9001 | CASE ( 'rad_mrt_lw' ) |
---|
9002 | IF ( ALLOCATED( mrtinlw_av ) ) THEN |
---|
9003 | mrtinlw_av(:) = mrtinlw_av(:) / REAL( average_count_3d, KIND=wp ) |
---|
9004 | ENDIF |
---|
9005 | |
---|
9006 | CASE ( 'rad_mrt' ) |
---|
9007 | IF ( ALLOCATED( mrt_av ) ) THEN |
---|
9008 | mrt_av(:) = mrt_av(:) / REAL( average_count_3d, KIND=wp ) |
---|
9009 | ENDIF |
---|
9010 | |
---|
9011 | END SELECT |
---|
9012 | |
---|
9013 | ENDIF |
---|
9014 | |
---|
9015 | END SUBROUTINE radiation_3d_data_averaging |
---|
9016 | |
---|
9017 | |
---|
9018 | !------------------------------------------------------------------------------! |
---|
9019 | ! |
---|
9020 | ! Description: |
---|
9021 | ! ------------ |
---|
9022 | !> Subroutine defining appropriate grid for netcdf variables. |
---|
9023 | !> It is called out from subroutine netcdf. |
---|
9024 | !------------------------------------------------------------------------------! |
---|
9025 | SUBROUTINE radiation_define_netcdf_grid( var, found, grid_x, grid_y, grid_z ) |
---|
9026 | |
---|
9027 | IMPLICIT NONE |
---|
9028 | |
---|
9029 | CHARACTER (LEN=*), INTENT(IN) :: var !< |
---|
9030 | LOGICAL, INTENT(OUT) :: found !< |
---|
9031 | CHARACTER (LEN=*), INTENT(OUT) :: grid_x !< |
---|
9032 | CHARACTER (LEN=*), INTENT(OUT) :: grid_y !< |
---|
9033 | CHARACTER (LEN=*), INTENT(OUT) :: grid_z !< |
---|
9034 | |
---|
9035 | found = .TRUE. |
---|
9036 | |
---|
9037 | ! |
---|
9038 | !-- Check for the grid |
---|
9039 | SELECT CASE ( TRIM( var ) ) |
---|
9040 | |
---|
9041 | CASE ( 'rad_lw_cs_hr', 'rad_lw_hr', 'rad_sw_cs_hr', 'rad_sw_hr', & |
---|
9042 | 'rad_lw_cs_hr_xy', 'rad_lw_hr_xy', 'rad_sw_cs_hr_xy', & |
---|
9043 | 'rad_sw_hr_xy', 'rad_lw_cs_hr_xz', 'rad_lw_hr_xz', & |
---|
9044 | 'rad_sw_cs_hr_xz', 'rad_sw_hr_xz', 'rad_lw_cs_hr_yz', & |
---|
9045 | 'rad_lw_hr_yz', 'rad_sw_cs_hr_yz', 'rad_sw_hr_yz', & |
---|
9046 | 'rad_mrt', 'rad_mrt_sw', 'rad_mrt_lw' ) |
---|
9047 | grid_x = 'x' |
---|
9048 | grid_y = 'y' |
---|
9049 | grid_z = 'zu' |
---|
9050 | |
---|
9051 | CASE ( 'rad_lw_in', 'rad_lw_out', 'rad_sw_in', 'rad_sw_out', & |
---|
9052 | 'rad_lw_in_xy', 'rad_lw_out_xy', 'rad_sw_in_xy','rad_sw_out_xy', & |
---|
9053 | 'rad_lw_in_xz', 'rad_lw_out_xz', 'rad_sw_in_xz','rad_sw_out_xz', & |
---|
9054 | 'rad_lw_in_yz', 'rad_lw_out_yz', 'rad_sw_in_yz','rad_sw_out_yz' ) |
---|
9055 | grid_x = 'x' |
---|
9056 | grid_y = 'y' |
---|
9057 | grid_z = 'zw' |
---|
9058 | |
---|
9059 | |
---|
9060 | CASE DEFAULT |
---|
9061 | found = .FALSE. |
---|
9062 | grid_x = 'none' |
---|
9063 | grid_y = 'none' |
---|
9064 | grid_z = 'none' |
---|
9065 | |
---|
9066 | END SELECT |
---|
9067 | |
---|
9068 | END SUBROUTINE radiation_define_netcdf_grid |
---|
9069 | |
---|
9070 | !------------------------------------------------------------------------------! |
---|
9071 | ! |
---|
9072 | ! Description: |
---|
9073 | ! ------------ |
---|
9074 | !> Subroutine defining 2D output variables |
---|
9075 | !------------------------------------------------------------------------------! |
---|
9076 | SUBROUTINE radiation_data_output_2d( av, variable, found, grid, mode, & |
---|
9077 | local_pf, two_d, nzb_do, nzt_do ) |
---|
9078 | |
---|
9079 | USE indices |
---|
9080 | |
---|
9081 | USE kinds |
---|
9082 | |
---|
9083 | |
---|
9084 | IMPLICIT NONE |
---|
9085 | |
---|
9086 | CHARACTER (LEN=*) :: grid !< |
---|
9087 | CHARACTER (LEN=*) :: mode !< |
---|
9088 | CHARACTER (LEN=*) :: variable !< |
---|
9089 | |
---|
9090 | INTEGER(iwp) :: av !< |
---|
9091 | INTEGER(iwp) :: i !< |
---|
9092 | INTEGER(iwp) :: j !< |
---|
9093 | INTEGER(iwp) :: k !< |
---|
9094 | INTEGER(iwp) :: m !< index of surface element at grid point (j,i) |
---|
9095 | INTEGER(iwp) :: nzb_do !< |
---|
9096 | INTEGER(iwp) :: nzt_do !< |
---|
9097 | |
---|
9098 | LOGICAL :: found !< |
---|
9099 | LOGICAL :: two_d !< flag parameter that indicates 2D variables (horizontal cross sections) |
---|
9100 | |
---|
9101 | REAL(wp) :: fill_value = -999.0_wp !< value for the _FillValue attribute |
---|
9102 | |
---|
9103 | REAL(wp), DIMENSION(nxl:nxr,nys:nyn,nzb_do:nzt_do) :: local_pf !< |
---|
9104 | |
---|
9105 | found = .TRUE. |
---|
9106 | |
---|
9107 | SELECT CASE ( TRIM( variable ) ) |
---|
9108 | |
---|
9109 | CASE ( 'rad_net*_xy' ) ! 2d-array |
---|
9110 | IF ( av == 0 ) THEN |
---|
9111 | DO i = nxl, nxr |
---|
9112 | DO j = nys, nyn |
---|
9113 | ! |
---|
9114 | !-- Obtain rad_net from its respective surface type |
---|
9115 | !-- Natural-type surfaces |
---|
9116 | DO m = surf_lsm_h%start_index(j,i), & |
---|
9117 | surf_lsm_h%end_index(j,i) |
---|
9118 | local_pf(i,j,nzb+1) = surf_lsm_h%rad_net(m) |
---|
9119 | ENDDO |
---|
9120 | ! |
---|
9121 | !-- Urban-type surfaces |
---|
9122 | DO m = surf_usm_h%start_index(j,i), & |
---|
9123 | surf_usm_h%end_index(j,i) |
---|
9124 | local_pf(i,j,nzb+1) = surf_usm_h%rad_net(m) |
---|
9125 | ENDDO |
---|
9126 | ENDDO |
---|
9127 | ENDDO |
---|
9128 | ELSE |
---|
9129 | IF ( .NOT. ALLOCATED( rad_net_av ) ) THEN |
---|
9130 | ALLOCATE( rad_net_av(nysg:nyng,nxlg:nxrg) ) |
---|
9131 | rad_net_av = REAL( fill_value, KIND = wp ) |
---|
9132 | ENDIF |
---|
9133 | DO i = nxl, nxr |
---|
9134 | DO j = nys, nyn |
---|
9135 | local_pf(i,j,nzb+1) = rad_net_av(j,i) |
---|
9136 | ENDDO |
---|
9137 | ENDDO |
---|
9138 | ENDIF |
---|
9139 | two_d = .TRUE. |
---|
9140 | grid = 'zu1' |
---|
9141 | |
---|
9142 | CASE ( 'rad_lw_in*_xy' ) ! 2d-array |
---|
9143 | IF ( av == 0 ) THEN |
---|
9144 | DO i = nxl, nxr |
---|
9145 | DO j = nys, nyn |
---|
9146 | ! |
---|
9147 | !-- Obtain rad_net from its respective surface type |
---|
9148 | !-- Natural-type surfaces |
---|
9149 | DO m = surf_lsm_h%start_index(j,i), & |
---|
9150 | surf_lsm_h%end_index(j,i) |
---|
9151 | local_pf(i,j,nzb+1) = surf_lsm_h%rad_lw_in(m) |
---|
9152 | ENDDO |
---|
9153 | ! |
---|
9154 | !-- Urban-type surfaces |
---|
9155 | DO m = surf_usm_h%start_index(j,i), & |
---|
9156 | surf_usm_h%end_index(j,i) |
---|
9157 | local_pf(i,j,nzb+1) = surf_usm_h%rad_lw_in(m) |
---|
9158 | ENDDO |
---|
9159 | ENDDO |
---|
9160 | ENDDO |
---|
9161 | ELSE |
---|
9162 | IF ( .NOT. ALLOCATED( rad_lw_in_xy_av ) ) THEN |
---|
9163 | ALLOCATE( rad_lw_in_xy_av(nysg:nyng,nxlg:nxrg) ) |
---|
9164 | rad_lw_in_xy_av = REAL( fill_value, KIND = wp ) |
---|
9165 | ENDIF |
---|
9166 | DO i = nxl, nxr |
---|
9167 | DO j = nys, nyn |
---|
9168 | local_pf(i,j,nzb+1) = rad_lw_in_xy_av(j,i) |
---|
9169 | ENDDO |
---|
9170 | ENDDO |
---|
9171 | ENDIF |
---|
9172 | two_d = .TRUE. |
---|
9173 | grid = 'zu1' |
---|
9174 | |
---|
9175 | CASE ( 'rad_lw_out*_xy' ) ! 2d-array |
---|
9176 | IF ( av == 0 ) THEN |
---|
9177 | DO i = nxl, nxr |
---|
9178 | DO j = nys, nyn |
---|
9179 | ! |
---|
9180 | !-- Obtain rad_net from its respective surface type |
---|
9181 | !-- Natural-type surfaces |
---|
9182 | DO m = surf_lsm_h%start_index(j,i), & |
---|
9183 | surf_lsm_h%end_index(j,i) |
---|
9184 | local_pf(i,j,nzb+1) = surf_lsm_h%rad_lw_out(m) |
---|
9185 | ENDDO |
---|
9186 | ! |
---|
9187 | !-- Urban-type surfaces |
---|
9188 | DO m = surf_usm_h%start_index(j,i), & |
---|
9189 | surf_usm_h%end_index(j,i) |
---|
9190 | local_pf(i,j,nzb+1) = surf_usm_h%rad_lw_out(m) |
---|
9191 | ENDDO |
---|
9192 | ENDDO |
---|
9193 | ENDDO |
---|
9194 | ELSE |
---|
9195 | IF ( .NOT. ALLOCATED( rad_lw_out_xy_av ) ) THEN |
---|
9196 | ALLOCATE( rad_lw_out_xy_av(nysg:nyng,nxlg:nxrg) ) |
---|
9197 | rad_lw_out_xy_av = REAL( fill_value, KIND = wp ) |
---|
9198 | ENDIF |
---|
9199 | DO i = nxl, nxr |
---|
9200 | DO j = nys, nyn |
---|
9201 | local_pf(i,j,nzb+1) = rad_lw_out_xy_av(j,i) |
---|
9202 | ENDDO |
---|
9203 | ENDDO |
---|
9204 | ENDIF |
---|
9205 | two_d = .TRUE. |
---|
9206 | grid = 'zu1' |
---|
9207 | |
---|
9208 | CASE ( 'rad_sw_in*_xy' ) ! 2d-array |
---|
9209 | IF ( av == 0 ) THEN |
---|
9210 | DO i = nxl, nxr |
---|
9211 | DO j = nys, nyn |
---|
9212 | ! |
---|
9213 | !-- Obtain rad_net from its respective surface type |
---|
9214 | !-- Natural-type surfaces |
---|
9215 | DO m = surf_lsm_h%start_index(j,i), & |
---|
9216 | surf_lsm_h%end_index(j,i) |
---|
9217 | local_pf(i,j,nzb+1) = surf_lsm_h%rad_sw_in(m) |
---|
9218 | ENDDO |
---|
9219 | ! |
---|
9220 | !-- Urban-type surfaces |
---|
9221 | DO m = surf_usm_h%start_index(j,i), & |
---|
9222 | surf_usm_h%end_index(j,i) |
---|
9223 | local_pf(i,j,nzb+1) = surf_usm_h%rad_sw_in(m) |
---|
9224 | ENDDO |
---|
9225 | ENDDO |
---|
9226 | ENDDO |
---|
9227 | ELSE |
---|
9228 | IF ( .NOT. ALLOCATED( rad_sw_in_xy_av ) ) THEN |
---|
9229 | ALLOCATE( rad_sw_in_xy_av(nysg:nyng,nxlg:nxrg) ) |
---|
9230 | rad_sw_in_xy_av = REAL( fill_value, KIND = wp ) |
---|
9231 | ENDIF |
---|
9232 | DO i = nxl, nxr |
---|
9233 | DO j = nys, nyn |
---|
9234 | local_pf(i,j,nzb+1) = rad_sw_in_xy_av(j,i) |
---|
9235 | ENDDO |
---|
9236 | ENDDO |
---|
9237 | ENDIF |
---|
9238 | two_d = .TRUE. |
---|
9239 | grid = 'zu1' |
---|
9240 | |
---|
9241 | CASE ( 'rad_sw_out*_xy' ) ! 2d-array |
---|
9242 | IF ( av == 0 ) THEN |
---|
9243 | DO i = nxl, nxr |
---|
9244 | DO j = nys, nyn |
---|
9245 | ! |
---|
9246 | !-- Obtain rad_net from its respective surface type |
---|
9247 | !-- Natural-type surfaces |
---|
9248 | DO m = surf_lsm_h%start_index(j,i), & |
---|
9249 | surf_lsm_h%end_index(j,i) |
---|
9250 | local_pf(i,j,nzb+1) = surf_lsm_h%rad_sw_out(m) |
---|
9251 | ENDDO |
---|
9252 | ! |
---|
9253 | !-- Urban-type surfaces |
---|
9254 | DO m = surf_usm_h%start_index(j,i), & |
---|
9255 | surf_usm_h%end_index(j,i) |
---|
9256 | local_pf(i,j,nzb+1) = surf_usm_h%rad_sw_out(m) |
---|
9257 | ENDDO |
---|
9258 | ENDDO |
---|
9259 | ENDDO |
---|
9260 | ELSE |
---|
9261 | IF ( .NOT. ALLOCATED( rad_sw_out_xy_av ) ) THEN |
---|
9262 | ALLOCATE( rad_sw_out_xy_av(nysg:nyng,nxlg:nxrg) ) |
---|
9263 | rad_sw_out_xy_av = REAL( fill_value, KIND = wp ) |
---|
9264 | ENDIF |
---|
9265 | DO i = nxl, nxr |
---|
9266 | DO j = nys, nyn |
---|
9267 | local_pf(i,j,nzb+1) = rad_sw_out_xy_av(j,i) |
---|
9268 | ENDDO |
---|
9269 | ENDDO |
---|
9270 | ENDIF |
---|
9271 | two_d = .TRUE. |
---|
9272 | grid = 'zu1' |
---|
9273 | |
---|
9274 | CASE ( 'rad_lw_in_xy', 'rad_lw_in_xz', 'rad_lw_in_yz' ) |
---|
9275 | IF ( av == 0 ) THEN |
---|
9276 | DO i = nxl, nxr |
---|
9277 | DO j = nys, nyn |
---|
9278 | DO k = nzb_do, nzt_do |
---|
9279 | local_pf(i,j,k) = rad_lw_in(k,j,i) |
---|
9280 | ENDDO |
---|
9281 | ENDDO |
---|
9282 | ENDDO |
---|
9283 | ELSE |
---|
9284 | IF ( .NOT. ALLOCATED( rad_lw_in_av ) ) THEN |
---|
9285 | ALLOCATE( rad_lw_in_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) |
---|
9286 | rad_lw_in_av = REAL( fill_value, KIND = wp ) |
---|
9287 | ENDIF |
---|
9288 | DO i = nxl, nxr |
---|
9289 | DO j = nys, nyn |
---|
9290 | DO k = nzb_do, nzt_do |
---|
9291 | local_pf(i,j,k) = rad_lw_in_av(k,j,i) |
---|
9292 | ENDDO |
---|
9293 | ENDDO |
---|
9294 | ENDDO |
---|
9295 | ENDIF |
---|
9296 | IF ( mode == 'xy' ) grid = 'zu' |
---|
9297 | |
---|
9298 | CASE ( 'rad_lw_out_xy', 'rad_lw_out_xz', 'rad_lw_out_yz' ) |
---|
9299 | IF ( av == 0 ) THEN |
---|
9300 | DO i = nxl, nxr |
---|
9301 | DO j = nys, nyn |
---|
9302 | DO k = nzb_do, nzt_do |
---|
9303 | local_pf(i,j,k) = rad_lw_out(k,j,i) |
---|
9304 | ENDDO |
---|
9305 | ENDDO |
---|
9306 | ENDDO |
---|
9307 | ELSE |
---|
9308 | IF ( .NOT. ALLOCATED( rad_lw_out_av ) ) THEN |
---|
9309 | ALLOCATE( rad_lw_out_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) |
---|
9310 | rad_lw_out_av = REAL( fill_value, KIND = wp ) |
---|
9311 | ENDIF |
---|
9312 | DO i = nxl, nxr |
---|
9313 | DO j = nys, nyn |
---|
9314 | DO k = nzb_do, nzt_do |
---|
9315 | local_pf(i,j,k) = rad_lw_out_av(k,j,i) |
---|
9316 | ENDDO |
---|
9317 | ENDDO |
---|
9318 | ENDDO |
---|
9319 | ENDIF |
---|
9320 | IF ( mode == 'xy' ) grid = 'zu' |
---|
9321 | |
---|
9322 | CASE ( 'rad_lw_cs_hr_xy', 'rad_lw_cs_hr_xz', 'rad_lw_cs_hr_yz' ) |
---|
9323 | IF ( av == 0 ) THEN |
---|
9324 | DO i = nxl, nxr |
---|
9325 | DO j = nys, nyn |
---|
9326 | DO k = nzb_do, nzt_do |
---|
9327 | local_pf(i,j,k) = rad_lw_cs_hr(k,j,i) |
---|
9328 | ENDDO |
---|
9329 | ENDDO |
---|
9330 | ENDDO |
---|
9331 | ELSE |
---|
9332 | IF ( .NOT. ALLOCATED( rad_lw_cs_hr_av ) ) THEN |
---|
9333 | ALLOCATE( rad_lw_cs_hr_av(nzb+1:nzt+1,nysg:nyng,nxlg:nxrg) ) |
---|
9334 | rad_lw_cs_hr_av = REAL( fill_value, KIND = wp ) |
---|
9335 | ENDIF |
---|
9336 | DO i = nxl, nxr |
---|
9337 | DO j = nys, nyn |
---|
9338 | DO k = nzb_do, nzt_do |
---|
9339 | local_pf(i,j,k) = rad_lw_cs_hr_av(k,j,i) |
---|
9340 | ENDDO |
---|
9341 | ENDDO |
---|
9342 | ENDDO |
---|
9343 | ENDIF |
---|
9344 | IF ( mode == 'xy' ) grid = 'zw' |
---|
9345 | |
---|
9346 | CASE ( 'rad_lw_hr_xy', 'rad_lw_hr_xz', 'rad_lw_hr_yz' ) |
---|
9347 | IF ( av == 0 ) THEN |
---|
9348 | DO i = nxl, nxr |
---|
9349 | DO j = nys, nyn |
---|
9350 | DO k = nzb_do, nzt_do |
---|
9351 | local_pf(i,j,k) = rad_lw_hr(k,j,i) |
---|
9352 | ENDDO |
---|
9353 | ENDDO |
---|
9354 | ENDDO |
---|
9355 | ELSE |
---|
9356 | IF ( .NOT. ALLOCATED( rad_lw_hr_av ) ) THEN |
---|
9357 | ALLOCATE( rad_lw_hr_av(nzb+1:nzt+1,nysg:nyng,nxlg:nxrg) ) |
---|
9358 | rad_lw_hr_av= REAL( fill_value, KIND = wp ) |
---|
9359 | ENDIF |
---|
9360 | DO i = nxl, nxr |
---|
9361 | DO j = nys, nyn |
---|
9362 | DO k = nzb_do, nzt_do |
---|
9363 | local_pf(i,j,k) = rad_lw_hr_av(k,j,i) |
---|
9364 | ENDDO |
---|
9365 | ENDDO |
---|
9366 | ENDDO |
---|
9367 | ENDIF |
---|
9368 | IF ( mode == 'xy' ) grid = 'zw' |
---|
9369 | |
---|
9370 | CASE ( 'rad_sw_in_xy', 'rad_sw_in_xz', 'rad_sw_in_yz' ) |
---|
9371 | IF ( av == 0 ) THEN |
---|
9372 | DO i = nxl, nxr |
---|
9373 | DO j = nys, nyn |
---|
9374 | DO k = nzb_do, nzt_do |
---|
9375 | local_pf(i,j,k) = rad_sw_in(k,j,i) |
---|
9376 | ENDDO |
---|
9377 | ENDDO |
---|
9378 | ENDDO |
---|
9379 | ELSE |
---|
9380 | IF ( .NOT. ALLOCATED( rad_sw_in_av ) ) THEN |
---|
9381 | ALLOCATE( rad_sw_in_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) |
---|
9382 | rad_sw_in_av = REAL( fill_value, KIND = wp ) |
---|
9383 | ENDIF |
---|
9384 | DO i = nxl, nxr |
---|
9385 | DO j = nys, nyn |
---|
9386 | DO k = nzb_do, nzt_do |
---|
9387 | local_pf(i,j,k) = rad_sw_in_av(k,j,i) |
---|
9388 | ENDDO |
---|
9389 | ENDDO |
---|
9390 | ENDDO |
---|
9391 | ENDIF |
---|
9392 | IF ( mode == 'xy' ) grid = 'zu' |
---|
9393 | |
---|
9394 | CASE ( 'rad_sw_out_xy', 'rad_sw_out_xz', 'rad_sw_out_yz' ) |
---|
9395 | IF ( av == 0 ) THEN |
---|
9396 | DO i = nxl, nxr |
---|
9397 | DO j = nys, nyn |
---|
9398 | DO k = nzb_do, nzt_do |
---|
9399 | local_pf(i,j,k) = rad_sw_out(k,j,i) |
---|
9400 | ENDDO |
---|
9401 | ENDDO |
---|
9402 | ENDDO |
---|
9403 | ELSE |
---|
9404 | IF ( .NOT. ALLOCATED( rad_sw_out_av ) ) THEN |
---|
9405 | ALLOCATE( rad_sw_out_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) |
---|
9406 | rad_sw_out_av = REAL( fill_value, KIND = wp ) |
---|
9407 | ENDIF |
---|
9408 | DO i = nxl, nxr |
---|
9409 | DO j = nys, nyn |
---|
9410 | DO k = nzb, nzt+1 |
---|
9411 | local_pf(i,j,k) = rad_sw_out_av(k,j,i) |
---|
9412 | ENDDO |
---|
9413 | ENDDO |
---|
9414 | ENDDO |
---|
9415 | ENDIF |
---|
9416 | IF ( mode == 'xy' ) grid = 'zu' |
---|
9417 | |
---|
9418 | CASE ( 'rad_sw_cs_hr_xy', 'rad_sw_cs_hr_xz', 'rad_sw_cs_hr_yz' ) |
---|
9419 | IF ( av == 0 ) THEN |
---|
9420 | DO i = nxl, nxr |
---|
9421 | DO j = nys, nyn |
---|
9422 | DO k = nzb_do, nzt_do |
---|
9423 | local_pf(i,j,k) = rad_sw_cs_hr(k,j,i) |
---|
9424 | ENDDO |
---|
9425 | ENDDO |
---|
9426 | ENDDO |
---|
9427 | ELSE |
---|
9428 | IF ( .NOT. ALLOCATED( rad_sw_cs_hr_av ) ) THEN |
---|
9429 | ALLOCATE( rad_sw_cs_hr_av(nzb+1:nzt+1,nysg:nyng,nxlg:nxrg) ) |
---|
9430 | rad_sw_cs_hr_av = REAL( fill_value, KIND = wp ) |
---|
9431 | ENDIF |
---|
9432 | DO i = nxl, nxr |
---|
9433 | DO j = nys, nyn |
---|
9434 | DO k = nzb_do, nzt_do |
---|
9435 | local_pf(i,j,k) = rad_sw_cs_hr_av(k,j,i) |
---|
9436 | ENDDO |
---|
9437 | ENDDO |
---|
9438 | ENDDO |
---|
9439 | ENDIF |
---|
9440 | IF ( mode == 'xy' ) grid = 'zw' |
---|
9441 | |
---|
9442 | CASE ( 'rad_sw_hr_xy', 'rad_sw_hr_xz', 'rad_sw_hr_yz' ) |
---|
9443 | IF ( av == 0 ) THEN |
---|
9444 | DO i = nxl, nxr |
---|
9445 | DO j = nys, nyn |
---|
9446 | DO k = nzb_do, nzt_do |
---|
9447 | local_pf(i,j,k) = rad_sw_hr(k,j,i) |
---|
9448 | ENDDO |
---|
9449 | ENDDO |
---|
9450 | ENDDO |
---|
9451 | ELSE |
---|
9452 | IF ( .NOT. ALLOCATED( rad_sw_hr_av ) ) THEN |
---|
9453 | ALLOCATE( rad_sw_hr_av(nzb+1:nzt+1,nysg:nyng,nxlg:nxrg) ) |
---|
9454 | rad_sw_hr_av = REAL( fill_value, KIND = wp ) |
---|
9455 | ENDIF |
---|
9456 | DO i = nxl, nxr |
---|
9457 | DO j = nys, nyn |
---|
9458 | DO k = nzb_do, nzt_do |
---|
9459 | local_pf(i,j,k) = rad_sw_hr_av(k,j,i) |
---|
9460 | ENDDO |
---|
9461 | ENDDO |
---|
9462 | ENDDO |
---|
9463 | ENDIF |
---|
9464 | IF ( mode == 'xy' ) grid = 'zw' |
---|
9465 | |
---|
9466 | CASE DEFAULT |
---|
9467 | found = .FALSE. |
---|
9468 | grid = 'none' |
---|
9469 | |
---|
9470 | END SELECT |
---|
9471 | |
---|
9472 | END SUBROUTINE radiation_data_output_2d |
---|
9473 | |
---|
9474 | |
---|
9475 | !------------------------------------------------------------------------------! |
---|
9476 | ! |
---|
9477 | ! Description: |
---|
9478 | ! ------------ |
---|
9479 | !> Subroutine defining 3D output variables |
---|
9480 | !------------------------------------------------------------------------------! |
---|
9481 | SUBROUTINE radiation_data_output_3d( av, variable, found, local_pf, nzb_do, nzt_do ) |
---|
9482 | |
---|
9483 | |
---|
9484 | USE indices |
---|
9485 | |
---|
9486 | USE kinds |
---|
9487 | |
---|
9488 | |
---|
9489 | IMPLICIT NONE |
---|
9490 | |
---|
9491 | CHARACTER (LEN=*) :: variable !< |
---|
9492 | |
---|
9493 | INTEGER(iwp) :: av !< |
---|
9494 | INTEGER(iwp) :: i, j, k, l !< |
---|
9495 | INTEGER(iwp) :: nzb_do !< |
---|
9496 | INTEGER(iwp) :: nzt_do !< |
---|
9497 | |
---|
9498 | LOGICAL :: found !< |
---|
9499 | |
---|
9500 | REAL(wp) :: fill_value = -999.0_wp !< value for the _FillValue attribute |
---|
9501 | |
---|
9502 | REAL(sp), DIMENSION(nxl:nxr,nys:nyn,nzb_do:nzt_do) :: local_pf !< |
---|
9503 | |
---|
9504 | found = .TRUE. |
---|
9505 | |
---|
9506 | |
---|
9507 | SELECT CASE ( TRIM( variable ) ) |
---|
9508 | |
---|
9509 | CASE ( 'rad_sw_in' ) |
---|
9510 | IF ( av == 0 ) THEN |
---|
9511 | DO i = nxl, nxr |
---|
9512 | DO j = nys, nyn |
---|
9513 | DO k = nzb_do, nzt_do |
---|
9514 | local_pf(i,j,k) = rad_sw_in(k,j,i) |
---|
9515 | ENDDO |
---|
9516 | ENDDO |
---|
9517 | ENDDO |
---|
9518 | ELSE |
---|
9519 | IF ( .NOT. ALLOCATED( rad_sw_in_av ) ) THEN |
---|
9520 | ALLOCATE( rad_sw_in_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) |
---|
9521 | rad_sw_in_av = REAL( fill_value, KIND = wp ) |
---|
9522 | ENDIF |
---|
9523 | DO i = nxl, nxr |
---|
9524 | DO j = nys, nyn |
---|
9525 | DO k = nzb_do, nzt_do |
---|
9526 | local_pf(i,j,k) = rad_sw_in_av(k,j,i) |
---|
9527 | ENDDO |
---|
9528 | ENDDO |
---|
9529 | ENDDO |
---|
9530 | ENDIF |
---|
9531 | |
---|
9532 | CASE ( 'rad_sw_out' ) |
---|
9533 | IF ( av == 0 ) THEN |
---|
9534 | DO i = nxl, nxr |
---|
9535 | DO j = nys, nyn |
---|
9536 | DO k = nzb_do, nzt_do |
---|
9537 | local_pf(i,j,k) = rad_sw_out(k,j,i) |
---|
9538 | ENDDO |
---|
9539 | ENDDO |
---|
9540 | ENDDO |
---|
9541 | ELSE |
---|
9542 | IF ( .NOT. ALLOCATED( rad_sw_out_av ) ) THEN |
---|
9543 | ALLOCATE( rad_sw_out_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) |
---|
9544 | rad_sw_out_av = REAL( fill_value, KIND = wp ) |
---|
9545 | ENDIF |
---|
9546 | DO i = nxl, nxr |
---|
9547 | DO j = nys, nyn |
---|
9548 | DO k = nzb_do, nzt_do |
---|
9549 | local_pf(i,j,k) = rad_sw_out_av(k,j,i) |
---|
9550 | ENDDO |
---|
9551 | ENDDO |
---|
9552 | ENDDO |
---|
9553 | ENDIF |
---|
9554 | |
---|
9555 | CASE ( 'rad_sw_cs_hr' ) |
---|
9556 | IF ( av == 0 ) THEN |
---|
9557 | DO i = nxl, nxr |
---|
9558 | DO j = nys, nyn |
---|
9559 | DO k = nzb_do, nzt_do |
---|
9560 | local_pf(i,j,k) = rad_sw_cs_hr(k,j,i) |
---|
9561 | ENDDO |
---|
9562 | ENDDO |
---|
9563 | ENDDO |
---|
9564 | ELSE |
---|
9565 | IF ( .NOT. ALLOCATED( rad_sw_cs_hr_av ) ) THEN |
---|
9566 | ALLOCATE( rad_sw_cs_hr_av(nzb+1:nzt+1,nysg:nyng,nxlg:nxrg) ) |
---|
9567 | rad_sw_cs_hr_av = REAL( fill_value, KIND = wp ) |
---|
9568 | ENDIF |
---|
9569 | DO i = nxl, nxr |
---|
9570 | DO j = nys, nyn |
---|
9571 | DO k = nzb_do, nzt_do |
---|
9572 | local_pf(i,j,k) = rad_sw_cs_hr_av(k,j,i) |
---|
9573 | ENDDO |
---|
9574 | ENDDO |
---|
9575 | ENDDO |
---|
9576 | ENDIF |
---|
9577 | |
---|
9578 | CASE ( 'rad_sw_hr' ) |
---|
9579 | IF ( av == 0 ) THEN |
---|
9580 | DO i = nxl, nxr |
---|
9581 | DO j = nys, nyn |
---|
9582 | DO k = nzb_do, nzt_do |
---|
9583 | local_pf(i,j,k) = rad_sw_hr(k,j,i) |
---|
9584 | ENDDO |
---|
9585 | ENDDO |
---|
9586 | ENDDO |
---|
9587 | ELSE |
---|
9588 | IF ( .NOT. ALLOCATED( rad_sw_hr_av ) ) THEN |
---|
9589 | ALLOCATE( rad_sw_hr_av(nzb+1:nzt+1,nysg:nyng,nxlg:nxrg) ) |
---|
9590 | rad_sw_hr_av = REAL( fill_value, KIND = wp ) |
---|
9591 | ENDIF |
---|
9592 | DO i = nxl, nxr |
---|
9593 | DO j = nys, nyn |
---|
9594 | DO k = nzb_do, nzt_do |
---|
9595 | local_pf(i,j,k) = rad_sw_hr_av(k,j,i) |
---|
9596 | ENDDO |
---|
9597 | ENDDO |
---|
9598 | ENDDO |
---|
9599 | ENDIF |
---|
9600 | |
---|
9601 | CASE ( 'rad_lw_in' ) |
---|
9602 | IF ( av == 0 ) THEN |
---|
9603 | DO i = nxl, nxr |
---|
9604 | DO j = nys, nyn |
---|
9605 | DO k = nzb_do, nzt_do |
---|
9606 | local_pf(i,j,k) = rad_lw_in(k,j,i) |
---|
9607 | ENDDO |
---|
9608 | ENDDO |
---|
9609 | ENDDO |
---|
9610 | ELSE |
---|
9611 | IF ( .NOT. ALLOCATED( rad_lw_in_av ) ) THEN |
---|
9612 | ALLOCATE( rad_lw_in_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) |
---|
9613 | rad_lw_in_av = REAL( fill_value, KIND = wp ) |
---|
9614 | ENDIF |
---|
9615 | DO i = nxl, nxr |
---|
9616 | DO j = nys, nyn |
---|
9617 | DO k = nzb_do, nzt_do |
---|
9618 | local_pf(i,j,k) = rad_lw_in_av(k,j,i) |
---|
9619 | ENDDO |
---|
9620 | ENDDO |
---|
9621 | ENDDO |
---|
9622 | ENDIF |
---|
9623 | |
---|
9624 | CASE ( 'rad_lw_out' ) |
---|
9625 | IF ( av == 0 ) THEN |
---|
9626 | DO i = nxl, nxr |
---|
9627 | DO j = nys, nyn |
---|
9628 | DO k = nzb_do, nzt_do |
---|
9629 | local_pf(i,j,k) = rad_lw_out(k,j,i) |
---|
9630 | ENDDO |
---|
9631 | ENDDO |
---|
9632 | ENDDO |
---|
9633 | ELSE |
---|
9634 | IF ( .NOT. ALLOCATED( rad_lw_out_av ) ) THEN |
---|
9635 | ALLOCATE( rad_lw_out_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) |
---|
9636 | rad_lw_out_av = REAL( fill_value, KIND = wp ) |
---|
9637 | ENDIF |
---|
9638 | DO i = nxl, nxr |
---|
9639 | DO j = nys, nyn |
---|
9640 | DO k = nzb_do, nzt_do |
---|
9641 | local_pf(i,j,k) = rad_lw_out_av(k,j,i) |
---|
9642 | ENDDO |
---|
9643 | ENDDO |
---|
9644 | ENDDO |
---|
9645 | ENDIF |
---|
9646 | |
---|
9647 | CASE ( 'rad_lw_cs_hr' ) |
---|
9648 | IF ( av == 0 ) THEN |
---|
9649 | DO i = nxl, nxr |
---|
9650 | DO j = nys, nyn |
---|
9651 | DO k = nzb_do, nzt_do |
---|
9652 | local_pf(i,j,k) = rad_lw_cs_hr(k,j,i) |
---|
9653 | ENDDO |
---|
9654 | ENDDO |
---|
9655 | ENDDO |
---|
9656 | ELSE |
---|
9657 | IF ( .NOT. ALLOCATED( rad_lw_cs_hr_av ) ) THEN |
---|
9658 | ALLOCATE( rad_lw_cs_hr_av(nzb+1:nzt+1,nysg:nyng,nxlg:nxrg) ) |
---|
9659 | rad_lw_cs_hr_av = REAL( fill_value, KIND = wp ) |
---|
9660 | ENDIF |
---|
9661 | DO i = nxl, nxr |
---|
9662 | DO j = nys, nyn |
---|
9663 | DO k = nzb_do, nzt_do |
---|
9664 | local_pf(i,j,k) = rad_lw_cs_hr_av(k,j,i) |
---|
9665 | ENDDO |
---|
9666 | ENDDO |
---|
9667 | ENDDO |
---|
9668 | ENDIF |
---|
9669 | |
---|
9670 | CASE ( 'rad_lw_hr' ) |
---|
9671 | IF ( av == 0 ) THEN |
---|
9672 | DO i = nxl, nxr |
---|
9673 | DO j = nys, nyn |
---|
9674 | DO k = nzb_do, nzt_do |
---|
9675 | local_pf(i,j,k) = rad_lw_hr(k,j,i) |
---|
9676 | ENDDO |
---|
9677 | ENDDO |
---|
9678 | ENDDO |
---|
9679 | ELSE |
---|
9680 | IF ( .NOT. ALLOCATED( rad_lw_hr_av ) ) THEN |
---|
9681 | ALLOCATE( rad_lw_hr_av(nzb+1:nzt+1,nysg:nyng,nxlg:nxrg) ) |
---|
9682 | rad_lw_hr_av = REAL( fill_value, KIND = wp ) |
---|
9683 | ENDIF |
---|
9684 | DO i = nxl, nxr |
---|
9685 | DO j = nys, nyn |
---|
9686 | DO k = nzb_do, nzt_do |
---|
9687 | local_pf(i,j,k) = rad_lw_hr_av(k,j,i) |
---|
9688 | ENDDO |
---|
9689 | ENDDO |
---|
9690 | ENDDO |
---|
9691 | ENDIF |
---|
9692 | |
---|
9693 | CASE ( 'rad_mrt_sw' ) |
---|
9694 | local_pf = REAL( fill_value, KIND = wp ) |
---|
9695 | IF ( av == 0 ) THEN |
---|
9696 | DO l = 1, nmrtbl |
---|
9697 | i = mrtbl(ix,l) |
---|
9698 | j = mrtbl(iy,l) |
---|
9699 | k = mrtbl(iz,l) |
---|
9700 | local_pf(i,j,k) = mrtinsw(l) |
---|
9701 | ENDDO |
---|
9702 | ELSE |
---|
9703 | IF ( ALLOCATED( mrtinsw_av ) ) THEN |
---|
9704 | DO l = 1, nmrtbl |
---|
9705 | i = mrtbl(ix,l) |
---|
9706 | j = mrtbl(iy,l) |
---|
9707 | k = mrtbl(iz,l) |
---|
9708 | local_pf(i,j,k) = mrtinsw_av(l) |
---|
9709 | ENDDO |
---|
9710 | ENDIF |
---|
9711 | ENDIF |
---|
9712 | |
---|
9713 | CASE ( 'rad_mrt_lw' ) |
---|
9714 | local_pf = REAL( fill_value, KIND = wp ) |
---|
9715 | IF ( av == 0 ) THEN |
---|
9716 | DO l = 1, nmrtbl |
---|
9717 | i = mrtbl(ix,l) |
---|
9718 | j = mrtbl(iy,l) |
---|
9719 | k = mrtbl(iz,l) |
---|
9720 | local_pf(i,j,k) = mrtinlw(l) |
---|
9721 | ENDDO |
---|
9722 | ELSE |
---|
9723 | IF ( ALLOCATED( mrtinlw_av ) ) THEN |
---|
9724 | DO l = 1, nmrtbl |
---|
9725 | i = mrtbl(ix,l) |
---|
9726 | j = mrtbl(iy,l) |
---|
9727 | k = mrtbl(iz,l) |
---|
9728 | local_pf(i,j,k) = mrtinlw_av(l) |
---|
9729 | ENDDO |
---|
9730 | ENDIF |
---|
9731 | ENDIF |
---|
9732 | |
---|
9733 | CASE ( 'rad_mrt' ) |
---|
9734 | local_pf = REAL( fill_value, KIND = wp ) |
---|
9735 | IF ( av == 0 ) THEN |
---|
9736 | DO l = 1, nmrtbl |
---|
9737 | i = mrtbl(ix,l) |
---|
9738 | j = mrtbl(iy,l) |
---|
9739 | k = mrtbl(iz,l) |
---|
9740 | local_pf(i,j,k) = mrt(l) |
---|
9741 | ENDDO |
---|
9742 | ELSE |
---|
9743 | IF ( ALLOCATED( mrt_av ) ) THEN |
---|
9744 | DO l = 1, nmrtbl |
---|
9745 | i = mrtbl(ix,l) |
---|
9746 | j = mrtbl(iy,l) |
---|
9747 | k = mrtbl(iz,l) |
---|
9748 | local_pf(i,j,k) = mrt_av(l) |
---|
9749 | ENDDO |
---|
9750 | ENDIF |
---|
9751 | ENDIF |
---|
9752 | |
---|
9753 | CASE DEFAULT |
---|
9754 | found = .FALSE. |
---|
9755 | |
---|
9756 | END SELECT |
---|
9757 | |
---|
9758 | |
---|
9759 | END SUBROUTINE radiation_data_output_3d |
---|
9760 | |
---|
9761 | !------------------------------------------------------------------------------! |
---|
9762 | ! |
---|
9763 | ! Description: |
---|
9764 | ! ------------ |
---|
9765 | !> Subroutine defining masked data output |
---|
9766 | !------------------------------------------------------------------------------! |
---|
9767 | SUBROUTINE radiation_data_output_mask( av, variable, found, local_pf ) |
---|
9768 | |
---|
9769 | USE control_parameters |
---|
9770 | |
---|
9771 | USE indices |
---|
9772 | |
---|
9773 | USE kinds |
---|
9774 | |
---|
9775 | |
---|
9776 | IMPLICIT NONE |
---|
9777 | |
---|
9778 | CHARACTER (LEN=*) :: variable !< |
---|
9779 | |
---|
9780 | CHARACTER(LEN=5) :: grid !< flag to distinquish between staggered grids |
---|
9781 | |
---|
9782 | INTEGER(iwp) :: av !< |
---|
9783 | INTEGER(iwp) :: i !< |
---|
9784 | INTEGER(iwp) :: j !< |
---|
9785 | INTEGER(iwp) :: k !< |
---|
9786 | INTEGER(iwp) :: topo_top_ind !< k index of highest horizontal surface |
---|
9787 | |
---|
9788 | LOGICAL :: found !< true if output array was found |
---|
9789 | LOGICAL :: resorted !< true if array is resorted |
---|
9790 | |
---|
9791 | |
---|
9792 | REAL(wp), & |
---|
9793 | DIMENSION(mask_size_l(mid,1),mask_size_l(mid,2),mask_size_l(mid,3)) :: & |
---|
9794 | local_pf !< |
---|
9795 | |
---|
9796 | REAL(wp), DIMENSION(:,:,:), POINTER :: to_be_resorted !< points to array which needs to be resorted for output |
---|
9797 | |
---|
9798 | |
---|
9799 | found = .TRUE. |
---|
9800 | grid = 's' |
---|
9801 | resorted = .FALSE. |
---|
9802 | |
---|
9803 | SELECT CASE ( TRIM( variable ) ) |
---|
9804 | |
---|
9805 | |
---|
9806 | CASE ( 'rad_lw_in' ) |
---|
9807 | IF ( av == 0 ) THEN |
---|
9808 | to_be_resorted => rad_lw_in |
---|
9809 | ELSE |
---|
9810 | to_be_resorted => rad_lw_in_av |
---|
9811 | ENDIF |
---|
9812 | |
---|
9813 | CASE ( 'rad_lw_out' ) |
---|
9814 | IF ( av == 0 ) THEN |
---|
9815 | to_be_resorted => rad_lw_out |
---|
9816 | ELSE |
---|
9817 | to_be_resorted => rad_lw_out_av |
---|
9818 | ENDIF |
---|
9819 | |
---|
9820 | CASE ( 'rad_lw_cs_hr' ) |
---|
9821 | IF ( av == 0 ) THEN |
---|
9822 | to_be_resorted => rad_lw_cs_hr |
---|
9823 | ELSE |
---|
9824 | to_be_resorted => rad_lw_cs_hr_av |
---|
9825 | ENDIF |
---|
9826 | |
---|
9827 | CASE ( 'rad_lw_hr' ) |
---|
9828 | IF ( av == 0 ) THEN |
---|
9829 | to_be_resorted => rad_lw_hr |
---|
9830 | ELSE |
---|
9831 | to_be_resorted => rad_lw_hr_av |
---|
9832 | ENDIF |
---|
9833 | |
---|
9834 | CASE ( 'rad_sw_in' ) |
---|
9835 | IF ( av == 0 ) THEN |
---|
9836 | to_be_resorted => rad_sw_in |
---|
9837 | ELSE |
---|
9838 | to_be_resorted => rad_sw_in_av |
---|
9839 | ENDIF |
---|
9840 | |
---|
9841 | CASE ( 'rad_sw_out' ) |
---|
9842 | IF ( av == 0 ) THEN |
---|
9843 | to_be_resorted => rad_sw_out |
---|
9844 | ELSE |
---|
9845 | to_be_resorted => rad_sw_out_av |
---|
9846 | ENDIF |
---|
9847 | |
---|
9848 | CASE ( 'rad_sw_cs_hr' ) |
---|
9849 | IF ( av == 0 ) THEN |
---|
9850 | to_be_resorted => rad_sw_cs_hr |
---|
9851 | ELSE |
---|
9852 | to_be_resorted => rad_sw_cs_hr_av |
---|
9853 | ENDIF |
---|
9854 | |
---|
9855 | CASE ( 'rad_sw_hr' ) |
---|
9856 | IF ( av == 0 ) THEN |
---|
9857 | to_be_resorted => rad_sw_hr |
---|
9858 | ELSE |
---|
9859 | to_be_resorted => rad_sw_hr_av |
---|
9860 | ENDIF |
---|
9861 | |
---|
9862 | CASE DEFAULT |
---|
9863 | found = .FALSE. |
---|
9864 | |
---|
9865 | END SELECT |
---|
9866 | |
---|
9867 | ! |
---|
9868 | !-- Resort the array to be output, if not done above |
---|
9869 | IF ( .NOT. resorted ) THEN |
---|
9870 | IF ( .NOT. mask_surface(mid) ) THEN |
---|
9871 | ! |
---|
9872 | !-- Default masked output |
---|
9873 | DO i = 1, mask_size_l(mid,1) |
---|
9874 | DO j = 1, mask_size_l(mid,2) |
---|
9875 | DO k = 1, mask_size_l(mid,3) |
---|
9876 | local_pf(i,j,k) = to_be_resorted(mask_k(mid,k), & |
---|
9877 | mask_j(mid,j),mask_i(mid,i)) |
---|
9878 | ENDDO |
---|
9879 | ENDDO |
---|
9880 | ENDDO |
---|
9881 | |
---|
9882 | ELSE |
---|
9883 | ! |
---|
9884 | !-- Terrain-following masked output |
---|
9885 | DO i = 1, mask_size_l(mid,1) |
---|
9886 | DO j = 1, mask_size_l(mid,2) |
---|
9887 | ! |
---|
9888 | !-- Get k index of highest horizontal surface |
---|
9889 | topo_top_ind = get_topography_top_index_ji( mask_j(mid,j), & |
---|
9890 | mask_i(mid,i), & |
---|
9891 | grid ) |
---|
9892 | ! |
---|
9893 | !-- Save output array |
---|
9894 | DO k = 1, mask_size_l(mid,3) |
---|
9895 | local_pf(i,j,k) = to_be_resorted( & |
---|
9896 | MIN( topo_top_ind+mask_k(mid,k), & |
---|
9897 | nzt+1 ), & |
---|
9898 | mask_j(mid,j), & |
---|
9899 | mask_i(mid,i) ) |
---|
9900 | ENDDO |
---|
9901 | ENDDO |
---|
9902 | ENDDO |
---|
9903 | |
---|
9904 | ENDIF |
---|
9905 | ENDIF |
---|
9906 | |
---|
9907 | |
---|
9908 | |
---|
9909 | END SUBROUTINE radiation_data_output_mask |
---|
9910 | |
---|
9911 | |
---|
9912 | !------------------------------------------------------------------------------! |
---|
9913 | ! Description: |
---|
9914 | ! ------------ |
---|
9915 | !> Subroutine writes local (subdomain) restart data |
---|
9916 | !------------------------------------------------------------------------------! |
---|
9917 | SUBROUTINE radiation_wrd_local |
---|
9918 | |
---|
9919 | |
---|
9920 | IMPLICIT NONE |
---|
9921 | |
---|
9922 | |
---|
9923 | IF ( ALLOCATED( rad_net_av ) ) THEN |
---|
9924 | CALL wrd_write_string( 'rad_net_av' ) |
---|
9925 | WRITE ( 14 ) rad_net_av |
---|
9926 | ENDIF |
---|
9927 | |
---|
9928 | IF ( ALLOCATED( rad_lw_in_xy_av ) ) THEN |
---|
9929 | CALL wrd_write_string( 'rad_lw_in_xy_av' ) |
---|
9930 | WRITE ( 14 ) rad_lw_in_xy_av |
---|
9931 | ENDIF |
---|
9932 | |
---|
9933 | IF ( ALLOCATED( rad_lw_out_xy_av ) ) THEN |
---|
9934 | CALL wrd_write_string( 'rad_lw_out_xy_av' ) |
---|
9935 | WRITE ( 14 ) rad_lw_out_xy_av |
---|
9936 | ENDIF |
---|
9937 | |
---|
9938 | IF ( ALLOCATED( rad_sw_in_xy_av ) ) THEN |
---|
9939 | CALL wrd_write_string( 'rad_sw_in_xy_av' ) |
---|
9940 | WRITE ( 14 ) rad_sw_in_xy_av |
---|
9941 | ENDIF |
---|
9942 | |
---|
9943 | IF ( ALLOCATED( rad_sw_out_xy_av ) ) THEN |
---|
9944 | CALL wrd_write_string( 'rad_sw_out_xy_av' ) |
---|
9945 | WRITE ( 14 ) rad_sw_out_xy_av |
---|
9946 | ENDIF |
---|
9947 | |
---|
9948 | IF ( ALLOCATED( rad_lw_in ) ) THEN |
---|
9949 | CALL wrd_write_string( 'rad_lw_in' ) |
---|
9950 | WRITE ( 14 ) rad_lw_in |
---|
9951 | ENDIF |
---|
9952 | |
---|
9953 | IF ( ALLOCATED( rad_lw_in_av ) ) THEN |
---|
9954 | CALL wrd_write_string( 'rad_lw_in_av' ) |
---|
9955 | WRITE ( 14 ) rad_lw_in_av |
---|
9956 | ENDIF |
---|
9957 | |
---|
9958 | IF ( ALLOCATED( rad_lw_out ) ) THEN |
---|
9959 | CALL wrd_write_string( 'rad_lw_out' ) |
---|
9960 | WRITE ( 14 ) rad_lw_out |
---|
9961 | ENDIF |
---|
9962 | |
---|
9963 | IF ( ALLOCATED( rad_lw_out_av) ) THEN |
---|
9964 | CALL wrd_write_string( 'rad_lw_out_av' ) |
---|
9965 | WRITE ( 14 ) rad_lw_out_av |
---|
9966 | ENDIF |
---|
9967 | |
---|
9968 | IF ( ALLOCATED( rad_lw_cs_hr) ) THEN |
---|
9969 | CALL wrd_write_string( 'rad_lw_cs_hr' ) |
---|
9970 | WRITE ( 14 ) rad_lw_cs_hr |
---|
9971 | ENDIF |
---|
9972 | |
---|
9973 | IF ( ALLOCATED( rad_lw_cs_hr_av) ) THEN |
---|
9974 | CALL wrd_write_string( 'rad_lw_cs_hr_av' ) |
---|
9975 | WRITE ( 14 ) rad_lw_cs_hr_av |
---|
9976 | ENDIF |
---|
9977 | |
---|
9978 | IF ( ALLOCATED( rad_lw_hr) ) THEN |
---|
9979 | CALL wrd_write_string( 'rad_lw_hr' ) |
---|
9980 | WRITE ( 14 ) rad_lw_hr |
---|
9981 | ENDIF |
---|
9982 | |
---|
9983 | IF ( ALLOCATED( rad_lw_hr_av) ) THEN |
---|
9984 | CALL wrd_write_string( 'rad_lw_hr_av' ) |
---|
9985 | WRITE ( 14 ) rad_lw_hr_av |
---|
9986 | ENDIF |
---|
9987 | |
---|
9988 | IF ( ALLOCATED( rad_sw_in) ) THEN |
---|
9989 | CALL wrd_write_string( 'rad_sw_in' ) |
---|
9990 | WRITE ( 14 ) rad_sw_in |
---|
9991 | ENDIF |
---|
9992 | |
---|
9993 | IF ( ALLOCATED( rad_sw_in_av) ) THEN |
---|
9994 | CALL wrd_write_string( 'rad_sw_in_av' ) |
---|
9995 | WRITE ( 14 ) rad_sw_in_av |
---|
9996 | ENDIF |
---|
9997 | |
---|
9998 | IF ( ALLOCATED( rad_sw_out) ) THEN |
---|
9999 | CALL wrd_write_string( 'rad_sw_out' ) |
---|
10000 | WRITE ( 14 ) rad_sw_out |
---|
10001 | ENDIF |
---|
10002 | |
---|
10003 | IF ( ALLOCATED( rad_sw_out_av) ) THEN |
---|
10004 | CALL wrd_write_string( 'rad_sw_out_av' ) |
---|
10005 | WRITE ( 14 ) rad_sw_out_av |
---|
10006 | ENDIF |
---|
10007 | |
---|
10008 | IF ( ALLOCATED( rad_sw_cs_hr) ) THEN |
---|
10009 | CALL wrd_write_string( 'rad_sw_cs_hr' ) |
---|
10010 | WRITE ( 14 ) rad_sw_cs_hr |
---|
10011 | ENDIF |
---|
10012 | |
---|
10013 | IF ( ALLOCATED( rad_sw_cs_hr_av) ) THEN |
---|
10014 | CALL wrd_write_string( 'rad_sw_cs_hr_av' ) |
---|
10015 | WRITE ( 14 ) rad_sw_cs_hr_av |
---|
10016 | ENDIF |
---|
10017 | |
---|
10018 | IF ( ALLOCATED( rad_sw_hr) ) THEN |
---|
10019 | CALL wrd_write_string( 'rad_sw_hr' ) |
---|
10020 | WRITE ( 14 ) rad_sw_hr |
---|
10021 | ENDIF |
---|
10022 | |
---|
10023 | IF ( ALLOCATED( rad_sw_hr_av) ) THEN |
---|
10024 | CALL wrd_write_string( 'rad_sw_hr_av' ) |
---|
10025 | WRITE ( 14 ) rad_sw_hr_av |
---|
10026 | ENDIF |
---|
10027 | |
---|
10028 | |
---|
10029 | END SUBROUTINE radiation_wrd_local |
---|
10030 | |
---|
10031 | !------------------------------------------------------------------------------! |
---|
10032 | ! Description: |
---|
10033 | ! ------------ |
---|
10034 | !> Subroutine reads local (subdomain) restart data |
---|
10035 | !------------------------------------------------------------------------------! |
---|
10036 | SUBROUTINE radiation_rrd_local( i, k, nxlf, nxlc, nxl_on_file, nxrf, nxrc, & |
---|
10037 | nxr_on_file, nynf, nync, nyn_on_file, nysf, & |
---|
10038 | nysc, nys_on_file, tmp_2d, tmp_3d, found ) |
---|
10039 | |
---|
10040 | |
---|
10041 | USE control_parameters |
---|
10042 | |
---|
10043 | USE indices |
---|
10044 | |
---|
10045 | USE kinds |
---|
10046 | |
---|
10047 | USE pegrid |
---|
10048 | |
---|
10049 | |
---|
10050 | IMPLICIT NONE |
---|
10051 | |
---|
10052 | INTEGER(iwp) :: i !< |
---|
10053 | INTEGER(iwp) :: k !< |
---|
10054 | INTEGER(iwp) :: nxlc !< |
---|
10055 | INTEGER(iwp) :: nxlf !< |
---|
10056 | INTEGER(iwp) :: nxl_on_file !< |
---|
10057 | INTEGER(iwp) :: nxrc !< |
---|
10058 | INTEGER(iwp) :: nxrf !< |
---|
10059 | INTEGER(iwp) :: nxr_on_file !< |
---|
10060 | INTEGER(iwp) :: nync !< |
---|
10061 | INTEGER(iwp) :: nynf !< |
---|
10062 | INTEGER(iwp) :: nyn_on_file !< |
---|
10063 | INTEGER(iwp) :: nysc !< |
---|
10064 | INTEGER(iwp) :: nysf !< |
---|
10065 | INTEGER(iwp) :: nys_on_file !< |
---|
10066 | |
---|
10067 | LOGICAL, INTENT(OUT) :: found |
---|
10068 | |
---|
10069 | REAL(wp), DIMENSION(nys_on_file-nbgp:nyn_on_file+nbgp,nxl_on_file-nbgp:nxr_on_file+nbgp) :: tmp_2d !< |
---|
10070 | |
---|
10071 | REAL(wp), DIMENSION(nzb:nzt+1,nys_on_file-nbgp:nyn_on_file+nbgp,nxl_on_file-nbgp:nxr_on_file+nbgp) :: tmp_3d !< |
---|
10072 | |
---|
10073 | REAL(wp), DIMENSION(0:0,nys_on_file-nbgp:nyn_on_file+nbgp,nxl_on_file-nbgp:nxr_on_file+nbgp) :: tmp_3d2 !< |
---|
10074 | |
---|
10075 | |
---|
10076 | found = .TRUE. |
---|
10077 | |
---|
10078 | |
---|
10079 | SELECT CASE ( restart_string(1:length) ) |
---|
10080 | |
---|
10081 | CASE ( 'rad_net_av' ) |
---|
10082 | IF ( .NOT. ALLOCATED( rad_net_av ) ) THEN |
---|
10083 | ALLOCATE( rad_net_av(nysg:nyng,nxlg:nxrg) ) |
---|
10084 | ENDIF |
---|
10085 | IF ( k == 1 ) READ ( 13 ) tmp_2d |
---|
10086 | rad_net_av(nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = & |
---|
10087 | tmp_2d(nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp) |
---|
10088 | |
---|
10089 | CASE ( 'rad_lw_in_xy_av' ) |
---|
10090 | IF ( .NOT. ALLOCATED( rad_lw_in_xy_av ) ) THEN |
---|
10091 | ALLOCATE( rad_lw_in_xy_av(nysg:nyng,nxlg:nxrg) ) |
---|
10092 | ENDIF |
---|
10093 | IF ( k == 1 ) READ ( 13 ) tmp_2d |
---|
10094 | rad_lw_in_xy_av(nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = & |
---|
10095 | tmp_2d(nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp) |
---|
10096 | |
---|
10097 | CASE ( 'rad_lw_out_xy_av' ) |
---|
10098 | IF ( .NOT. ALLOCATED( rad_lw_out_xy_av ) ) THEN |
---|
10099 | ALLOCATE( rad_lw_out_xy_av(nysg:nyng,nxlg:nxrg) ) |
---|
10100 | ENDIF |
---|
10101 | IF ( k == 1 ) READ ( 13 ) tmp_2d |
---|
10102 | rad_lw_out_xy_av(nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = & |
---|
10103 | tmp_2d(nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp) |
---|
10104 | |
---|
10105 | CASE ( 'rad_sw_in_xy_av' ) |
---|
10106 | IF ( .NOT. ALLOCATED( rad_sw_in_xy_av ) ) THEN |
---|
10107 | ALLOCATE( rad_sw_in_xy_av(nysg:nyng,nxlg:nxrg) ) |
---|
10108 | ENDIF |
---|
10109 | IF ( k == 1 ) READ ( 13 ) tmp_2d |
---|
10110 | rad_sw_in_xy_av(nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = & |
---|
10111 | tmp_2d(nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp) |
---|
10112 | |
---|
10113 | CASE ( 'rad_sw_out_xy_av' ) |
---|
10114 | IF ( .NOT. ALLOCATED( rad_sw_out_xy_av ) ) THEN |
---|
10115 | ALLOCATE( rad_sw_out_xy_av(nysg:nyng,nxlg:nxrg) ) |
---|
10116 | ENDIF |
---|
10117 | IF ( k == 1 ) READ ( 13 ) tmp_2d |
---|
10118 | rad_sw_out_xy_av(nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = & |
---|
10119 | tmp_2d(nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp) |
---|
10120 | |
---|
10121 | CASE ( 'rad_lw_in' ) |
---|
10122 | IF ( .NOT. ALLOCATED( rad_lw_in ) ) THEN |
---|
10123 | IF ( radiation_scheme == 'clear-sky' .OR. & |
---|
10124 | radiation_scheme == 'constant') THEN |
---|
10125 | ALLOCATE( rad_lw_in(0:0,nysg:nyng,nxlg:nxrg) ) |
---|
10126 | ELSE |
---|
10127 | ALLOCATE( rad_lw_in(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) |
---|
10128 | ENDIF |
---|
10129 | ENDIF |
---|
10130 | IF ( k == 1 ) THEN |
---|
10131 | IF ( radiation_scheme == 'clear-sky' .OR. & |
---|
10132 | radiation_scheme == 'constant') THEN |
---|
10133 | READ ( 13 ) tmp_3d2 |
---|
10134 | rad_lw_in(0:0,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = & |
---|
10135 | tmp_3d2(0:0,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp) |
---|
10136 | ELSE |
---|
10137 | READ ( 13 ) tmp_3d |
---|
10138 | rad_lw_in(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = & |
---|
10139 | tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp) |
---|
10140 | ENDIF |
---|
10141 | ENDIF |
---|
10142 | |
---|
10143 | CASE ( 'rad_lw_in_av' ) |
---|
10144 | IF ( .NOT. ALLOCATED( rad_lw_in_av ) ) THEN |
---|
10145 | IF ( radiation_scheme == 'clear-sky' .OR. & |
---|
10146 | radiation_scheme == 'constant') THEN |
---|
10147 | ALLOCATE( rad_lw_in_av(0:0,nysg:nyng,nxlg:nxrg) ) |
---|
10148 | ELSE |
---|
10149 | ALLOCATE( rad_lw_in_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) |
---|
10150 | ENDIF |
---|
10151 | ENDIF |
---|
10152 | IF ( k == 1 ) THEN |
---|
10153 | IF ( radiation_scheme == 'clear-sky' .OR. & |
---|
10154 | radiation_scheme == 'constant') THEN |
---|
10155 | READ ( 13 ) tmp_3d2 |
---|
10156 | rad_lw_in_av(0:0,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) =& |
---|
10157 | tmp_3d2(0:0,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp) |
---|
10158 | ELSE |
---|
10159 | READ ( 13 ) tmp_3d |
---|
10160 | rad_lw_in_av(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = & |
---|
10161 | tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp) |
---|
10162 | ENDIF |
---|
10163 | ENDIF |
---|
10164 | |
---|
10165 | CASE ( 'rad_lw_out' ) |
---|
10166 | IF ( .NOT. ALLOCATED( rad_lw_out ) ) THEN |
---|
10167 | IF ( radiation_scheme == 'clear-sky' .OR. & |
---|
10168 | radiation_scheme == 'constant') THEN |
---|
10169 | ALLOCATE( rad_lw_out(0:0,nysg:nyng,nxlg:nxrg) ) |
---|
10170 | ELSE |
---|
10171 | ALLOCATE( rad_lw_out(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) |
---|
10172 | ENDIF |
---|
10173 | ENDIF |
---|
10174 | IF ( k == 1 ) THEN |
---|
10175 | IF ( radiation_scheme == 'clear-sky' .OR. & |
---|
10176 | radiation_scheme == 'constant') THEN |
---|
10177 | READ ( 13 ) tmp_3d2 |
---|
10178 | rad_lw_out(0:0,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = & |
---|
10179 | tmp_3d2(0:0,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp) |
---|
10180 | ELSE |
---|
10181 | READ ( 13 ) tmp_3d |
---|
10182 | rad_lw_out(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = & |
---|
10183 | tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp) |
---|
10184 | ENDIF |
---|
10185 | ENDIF |
---|
10186 | |
---|
10187 | CASE ( 'rad_lw_out_av' ) |
---|
10188 | IF ( .NOT. ALLOCATED( rad_lw_out_av ) ) THEN |
---|
10189 | IF ( radiation_scheme == 'clear-sky' .OR. & |
---|
10190 | radiation_scheme == 'constant') THEN |
---|
10191 | ALLOCATE( rad_lw_out_av(0:0,nysg:nyng,nxlg:nxrg) ) |
---|
10192 | ELSE |
---|
10193 | ALLOCATE( rad_lw_out_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) |
---|
10194 | ENDIF |
---|
10195 | ENDIF |
---|
10196 | IF ( k == 1 ) THEN |
---|
10197 | IF ( radiation_scheme == 'clear-sky' .OR. & |
---|
10198 | radiation_scheme == 'constant') THEN |
---|
10199 | READ ( 13 ) tmp_3d2 |
---|
10200 | rad_lw_out_av(0:0,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) & |
---|
10201 | = tmp_3d2(0:0,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp) |
---|
10202 | ELSE |
---|
10203 | READ ( 13 ) tmp_3d |
---|
10204 | rad_lw_out_av(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = & |
---|
10205 | tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp) |
---|
10206 | ENDIF |
---|
10207 | ENDIF |
---|
10208 | |
---|
10209 | CASE ( 'rad_lw_cs_hr' ) |
---|
10210 | IF ( .NOT. ALLOCATED( rad_lw_cs_hr ) ) THEN |
---|
10211 | ALLOCATE( rad_lw_cs_hr(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) |
---|
10212 | ENDIF |
---|
10213 | IF ( k == 1 ) READ ( 13 ) tmp_3d |
---|
10214 | rad_lw_cs_hr(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = & |
---|
10215 | tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp) |
---|
10216 | |
---|
10217 | CASE ( 'rad_lw_cs_hr_av' ) |
---|
10218 | IF ( .NOT. ALLOCATED( rad_lw_cs_hr_av ) ) THEN |
---|
10219 | ALLOCATE( rad_lw_cs_hr_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) |
---|
10220 | ENDIF |
---|
10221 | IF ( k == 1 ) READ ( 13 ) tmp_3d |
---|
10222 | rad_lw_cs_hr_av(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = & |
---|
10223 | tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp) |
---|
10224 | |
---|
10225 | CASE ( 'rad_lw_hr' ) |
---|
10226 | IF ( .NOT. ALLOCATED( rad_lw_hr ) ) THEN |
---|
10227 | ALLOCATE( rad_lw_hr(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) |
---|
10228 | ENDIF |
---|
10229 | IF ( k == 1 ) READ ( 13 ) tmp_3d |
---|
10230 | rad_lw_hr(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = & |
---|
10231 | tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp) |
---|
10232 | |
---|
10233 | CASE ( 'rad_lw_hr_av' ) |
---|
10234 | IF ( .NOT. ALLOCATED( rad_lw_hr_av ) ) THEN |
---|
10235 | ALLOCATE( rad_lw_hr_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) |
---|
10236 | ENDIF |
---|
10237 | IF ( k == 1 ) READ ( 13 ) tmp_3d |
---|
10238 | rad_lw_hr_av(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = & |
---|
10239 | tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp) |
---|
10240 | |
---|
10241 | CASE ( 'rad_sw_in' ) |
---|
10242 | IF ( .NOT. ALLOCATED( rad_sw_in ) ) THEN |
---|
10243 | IF ( radiation_scheme == 'clear-sky' .OR. & |
---|
10244 | radiation_scheme == 'constant') THEN |
---|
10245 | ALLOCATE( rad_sw_in(0:0,nysg:nyng,nxlg:nxrg) ) |
---|
10246 | ELSE |
---|
10247 | ALLOCATE( rad_sw_in(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) |
---|
10248 | ENDIF |
---|
10249 | ENDIF |
---|
10250 | IF ( k == 1 ) THEN |
---|
10251 | IF ( radiation_scheme == 'clear-sky' .OR. & |
---|
10252 | radiation_scheme == 'constant') THEN |
---|
10253 | READ ( 13 ) tmp_3d2 |
---|
10254 | rad_sw_in(0:0,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = & |
---|
10255 | tmp_3d2(0:0,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp) |
---|
10256 | ELSE |
---|
10257 | READ ( 13 ) tmp_3d |
---|
10258 | rad_sw_in(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = & |
---|
10259 | tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp) |
---|
10260 | ENDIF |
---|
10261 | ENDIF |
---|
10262 | |
---|
10263 | CASE ( 'rad_sw_in_av' ) |
---|
10264 | IF ( .NOT. ALLOCATED( rad_sw_in_av ) ) THEN |
---|
10265 | IF ( radiation_scheme == 'clear-sky' .OR. & |
---|
10266 | radiation_scheme == 'constant') THEN |
---|
10267 | ALLOCATE( rad_sw_in_av(0:0,nysg:nyng,nxlg:nxrg) ) |
---|
10268 | ELSE |
---|
10269 | ALLOCATE( rad_sw_in_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) |
---|
10270 | ENDIF |
---|
10271 | ENDIF |
---|
10272 | IF ( k == 1 ) THEN |
---|
10273 | IF ( radiation_scheme == 'clear-sky' .OR. & |
---|
10274 | radiation_scheme == 'constant') THEN |
---|
10275 | READ ( 13 ) tmp_3d2 |
---|
10276 | rad_sw_in_av(0:0,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) =& |
---|
10277 | tmp_3d2(0:0,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp) |
---|
10278 | ELSE |
---|
10279 | READ ( 13 ) tmp_3d |
---|
10280 | rad_sw_in_av(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = & |
---|
10281 | tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp) |
---|
10282 | ENDIF |
---|
10283 | ENDIF |
---|
10284 | |
---|
10285 | CASE ( 'rad_sw_out' ) |
---|
10286 | IF ( .NOT. ALLOCATED( rad_sw_out ) ) THEN |
---|
10287 | IF ( radiation_scheme == 'clear-sky' .OR. & |
---|
10288 | radiation_scheme == 'constant') THEN |
---|
10289 | ALLOCATE( rad_sw_out(0:0,nysg:nyng,nxlg:nxrg) ) |
---|
10290 | ELSE |
---|
10291 | ALLOCATE( rad_sw_out(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) |
---|
10292 | ENDIF |
---|
10293 | ENDIF |
---|
10294 | IF ( k == 1 ) THEN |
---|
10295 | IF ( radiation_scheme == 'clear-sky' .OR. & |
---|
10296 | radiation_scheme == 'constant') THEN |
---|
10297 | READ ( 13 ) tmp_3d2 |
---|
10298 | rad_sw_out(0:0,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = & |
---|
10299 | tmp_3d2(0:0,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp) |
---|
10300 | ELSE |
---|
10301 | READ ( 13 ) tmp_3d |
---|
10302 | rad_sw_out(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = & |
---|
10303 | tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp) |
---|
10304 | ENDIF |
---|
10305 | ENDIF |
---|
10306 | |
---|
10307 | CASE ( 'rad_sw_out_av' ) |
---|
10308 | IF ( .NOT. ALLOCATED( rad_sw_out_av ) ) THEN |
---|
10309 | IF ( radiation_scheme == 'clear-sky' .OR. & |
---|
10310 | radiation_scheme == 'constant') THEN |
---|
10311 | ALLOCATE( rad_sw_out_av(0:0,nysg:nyng,nxlg:nxrg) ) |
---|
10312 | ELSE |
---|
10313 | ALLOCATE( rad_sw_out_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) |
---|
10314 | ENDIF |
---|
10315 | ENDIF |
---|
10316 | IF ( k == 1 ) THEN |
---|
10317 | IF ( radiation_scheme == 'clear-sky' .OR. & |
---|
10318 | radiation_scheme == 'constant') THEN |
---|
10319 | READ ( 13 ) tmp_3d2 |
---|
10320 | rad_sw_out_av(0:0,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) & |
---|
10321 | = tmp_3d2(0:0,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp) |
---|
10322 | ELSE |
---|
10323 | READ ( 13 ) tmp_3d |
---|
10324 | rad_sw_out_av(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = & |
---|
10325 | tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp) |
---|
10326 | ENDIF |
---|
10327 | ENDIF |
---|
10328 | |
---|
10329 | CASE ( 'rad_sw_cs_hr' ) |
---|
10330 | IF ( .NOT. ALLOCATED( rad_sw_cs_hr ) ) THEN |
---|
10331 | ALLOCATE( rad_sw_cs_hr(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) |
---|
10332 | ENDIF |
---|
10333 | IF ( k == 1 ) READ ( 13 ) tmp_3d |
---|
10334 | rad_sw_cs_hr(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = & |
---|
10335 | tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp) |
---|
10336 | |
---|
10337 | CASE ( 'rad_sw_cs_hr_av' ) |
---|
10338 | IF ( .NOT. ALLOCATED( rad_sw_cs_hr_av ) ) THEN |
---|
10339 | ALLOCATE( rad_sw_cs_hr_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) |
---|
10340 | ENDIF |
---|
10341 | IF ( k == 1 ) READ ( 13 ) tmp_3d |
---|
10342 | rad_sw_cs_hr_av(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = & |
---|
10343 | tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp) |
---|
10344 | |
---|
10345 | CASE ( 'rad_sw_hr' ) |
---|
10346 | IF ( .NOT. ALLOCATED( rad_sw_hr ) ) THEN |
---|
10347 | ALLOCATE( rad_sw_hr(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) |
---|
10348 | ENDIF |
---|
10349 | IF ( k == 1 ) READ ( 13 ) tmp_3d |
---|
10350 | rad_sw_hr(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = & |
---|
10351 | tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp) |
---|
10352 | |
---|
10353 | CASE ( 'rad_sw_hr_av' ) |
---|
10354 | IF ( .NOT. ALLOCATED( rad_sw_hr_av ) ) THEN |
---|
10355 | ALLOCATE( rad_sw_hr_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) |
---|
10356 | ENDIF |
---|
10357 | IF ( k == 1 ) READ ( 13 ) tmp_3d |
---|
10358 | rad_lw_hr_av(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = & |
---|
10359 | tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp) |
---|
10360 | |
---|
10361 | CASE DEFAULT |
---|
10362 | |
---|
10363 | found = .FALSE. |
---|
10364 | |
---|
10365 | END SELECT |
---|
10366 | |
---|
10367 | END SUBROUTINE radiation_rrd_local |
---|
10368 | |
---|
10369 | !------------------------------------------------------------------------------! |
---|
10370 | ! Description: |
---|
10371 | ! ------------ |
---|
10372 | !> Subroutine writes debug information |
---|
10373 | !------------------------------------------------------------------------------! |
---|
10374 | SUBROUTINE radiation_write_debug_log ( message ) |
---|
10375 | !> it writes debug log with time stamp |
---|
10376 | CHARACTER(*) :: message |
---|
10377 | CHARACTER(15) :: dtc |
---|
10378 | CHARACTER(8) :: date |
---|
10379 | CHARACTER(10) :: time |
---|
10380 | CHARACTER(5) :: zone |
---|
10381 | CALL date_and_time(date, time, zone) |
---|
10382 | dtc = date(7:8)//','//time(1:2)//':'//time(3:4)//':'//time(5:10) |
---|
10383 | WRITE(9,'(2A)') dtc, TRIM(message) |
---|
10384 | FLUSH(9) |
---|
10385 | END SUBROUTINE radiation_write_debug_log |
---|
10386 | |
---|
10387 | END MODULE radiation_model_mod |
---|