!> @file radiation_model_mod.f90 !------------------------------------------------------------------------------! ! This file is part of the PALM model system. ! ! PALM is free software: you can redistribute it and/or modify it under the ! terms of the GNU General Public License as published by the Free Software ! Foundation, either version 3 of the License, or (at your option) any later ! version. ! ! PALM is distributed in the hope that it will be useful, but WITHOUT ANY ! WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR ! A PARTICULAR PURPOSE. See the GNU General Public License for more details. ! ! You should have received a copy of the GNU General Public License along with ! PALM. If not, see . ! ! Copyright 1997-2017 Leibniz Universitaet Hannover !------------------------------------------------------------------------------! ! ! Current revisions: ! ----------------- ! ! ! Former revisions: ! ----------------- ! $Id: radiation_model_mod.f90 2716 2017-12-29 16:35:59Z kanani $ ! Corrected "Former revisions" section ! ! 2707 2017-12-18 18:34:46Z suehring ! Changes from last commit documented ! ! 2706 2017-12-18 18:33:49Z suehring ! Bugfix, in average radiation case calculate exner function before using it. ! ! 2701 2017-12-15 15:40:50Z suehring ! Changes from last commit documented ! ! 2698 2017-12-14 18:46:24Z suehring ! Bugfix in get_topography_top_index ! ! 2696 2017-12-14 17:12:51Z kanani ! - Change in file header (GPL part) ! - Improved reading/writing of SVF from/to file (BM) ! - Bugfixes concerning RRTMG as well as average_radiation options (M. Salim) ! - Revised initialization of surface albedo and some minor bugfixes (MS) ! - Update net radiation after running radiation interaction routine (MS) ! - Revisions from M Salim included ! - Adjustment to topography and surface structure (MS) ! - Initialization of albedo and surface emissivity via input file (MS) ! - albedo_pars extended (MS) ! ! 2604 2017-11-06 13:29:00Z schwenkel ! bugfix for calculation of effective radius using morrison microphysics ! ! 2601 2017-11-02 16:22:46Z scharf ! added emissivity to namelist ! ! 2575 2017-10-24 09:57:58Z maronga ! Bugfix: calculation of shortwave and longwave albedos for RRTMG swapped ! ! 2547 2017-10-16 12:41:56Z schwenkel ! extended by cloud_droplets option, minor bugfix and correct calculation of ! cloud droplet number concentration ! ! 2544 2017-10-13 18:09:32Z maronga ! Moved date and time quantitis to separate module date_and_time_mod ! ! 2512 2017-10-04 08:26:59Z raasch ! upper bounds of cross section and 3d output changed from nx+1,ny+1 to nx,ny ! no output of ghost layer data ! ! 2504 2017-09-27 10:36:13Z maronga ! Updates pavement types and albedo parameters ! ! 2328 2017-08-03 12:34:22Z maronga ! Emissivity can now be set individually for each pixel. ! Albedo type can be inferred from land surface model. ! Added default albedo type for bare soil ! ! 2318 2017-07-20 17:27:44Z suehring ! Get topography top index via Function call ! ! 2317 2017-07-20 17:27:19Z suehring ! Improved syntax layout ! ! 2298 2017-06-29 09:28:18Z raasch ! type of write_binary changed from CHARACTER to LOGICAL ! ! 2296 2017-06-28 07:53:56Z maronga ! Added output of rad_sw_out for radiation_scheme = 'constant' ! ! 2270 2017-06-09 12:18:47Z maronga ! Numbering changed (2 timeseries removed) ! ! 2249 2017-06-06 13:58:01Z sward ! Allow for RRTMG runs without humidity/cloud physics ! ! 2248 2017-06-06 13:52:54Z sward ! Error no changed ! ! 2233 2017-05-30 18:08:54Z suehring ! ! 2232 2017-05-30 17:47:52Z suehring ! Adjustments to new topography concept ! Bugfix in read restart ! ! 2200 2017-04-11 11:37:51Z suehring ! Bugfix in call of exchange_horiz_2d and read restart data ! ! 2163 2017-03-01 13:23:15Z schwenkel ! Bugfix in radiation_check_data_output ! ! 2157 2017-02-22 15:10:35Z suehring ! Bugfix in read_restart data ! ! 2011 2016-09-19 17:29:57Z kanani ! Removed CALL of auxiliary SUBROUTINE get_usm_info, ! flag urban_surface is now defined in module control_parameters. ! ! 2007 2016-08-24 15:47:17Z kanani ! Added calculation of solar directional vector for new urban surface ! model, ! accounted for urban_surface model in radiation_check_parameters, ! correction of comments for zenith angle. ! ! 2000 2016-08-20 18:09:15Z knoop ! Forced header and separation lines into 80 columns ! ! 1976 2016-07-27 13:28:04Z maronga ! Output of 2D/3D/masked data is now directly done within this module. The ! radiation schemes have been simplified for better usability so that ! rad_lw_in, rad_lw_out, rad_sw_in, and rad_sw_out are available independent of ! the radiation code used. ! ! 1856 2016-04-13 12:56:17Z maronga ! Bugfix: allocation of rad_lw_out for radiation_scheme = 'clear-sky' ! ! 1853 2016-04-11 09:00:35Z maronga ! Added routine for radiation_scheme = constant. ! ! 1849 2016-04-08 11:33:18Z hoffmann ! Adapted for modularization of microphysics ! ! 1826 2016-04-07 12:01:39Z maronga ! Further modularization. ! ! 1788 2016-03-10 11:01:04Z maronga ! Added new albedo class for pavements / roads. ! ! 1783 2016-03-06 18:36:17Z raasch ! palm-netcdf-module removed in order to avoid a circular module dependency, ! netcdf-variables moved to netcdf-module, new routine netcdf_handle_error_rad ! added ! ! 1757 2016-02-22 15:49:32Z maronga ! Added parameter unscheduled_radiation_calls. Bugfix: interpolation of sounding ! profiles for pressure and temperature above the LES domain. ! ! 1709 2015-11-04 14:47:01Z maronga ! Bugfix: set initial value for rrtm_lwuflx_dt to zero, small formatting ! corrections ! ! 1701 2015-11-02 07:43:04Z maronga ! Bugfixes: wrong index for output of timeseries, setting of nz_snd_end ! ! 1691 2015-10-26 16:17:44Z maronga ! Added option for spin-up runs without radiation (skip_time_do_radiation). Bugfix ! in calculation of pressure profiles. Bugfix in calculation of trace gas profiles. ! Added output of radiative heating rates. ! ! 1682 2015-10-07 23:56:08Z knoop ! Code annotations made doxygen readable ! ! 1606 2015-06-29 10:43:37Z maronga ! Added preprocessor directive __netcdf to allow for compiling without netCDF. ! Note, however, that RRTMG cannot be used without netCDF. ! ! 1590 2015-05-08 13:56:27Z maronga ! Bugfix: definition of character strings requires same length for all elements ! ! 1587 2015-05-04 14:19:01Z maronga ! Added albedo class for snow ! ! 1585 2015-04-30 07:05:52Z maronga ! Added support for RRTMG ! ! 1571 2015-03-12 16:12:49Z maronga ! Added missing KIND attribute. Removed upper-case variable names ! ! 1551 2015-03-03 14:18:16Z maronga ! Added support for data output. Various variables have been renamed. Added ! interface for different radiation schemes (currently: clear-sky, constant, and ! RRTM (not yet implemented). ! ! 1496 2014-12-02 17:25:50Z maronga ! Initial revision ! ! ! Description: ! ------------ !> Radiation models and interfaces !> @todo move variable definitions used in radiation_init only to the subroutine !> as they are no longer required after initialization. !> @todo Output of full column vertical profiles used in RRTMG !> @todo Output of other rrtm arrays (such as volume mixing ratios) !> @todo Adapt for use with topography !> @todo Optimize radiation_tendency routines !> !> @note Many variables have a leading dummy dimension (0:0) in order to !> match the assume-size shape expected by the RRTMG model. !------------------------------------------------------------------------------! MODULE radiation_model_mod USE arrays_3d, & ONLY: dzw, hyp, nc, pt, q, ql, zu, zw USE calc_mean_profile_mod, & ONLY: calc_mean_profile USE cloud_parameters, & ONLY: cp, l_d_cp, r_d, rho_l USE constants, & ONLY: pi USE control_parameters, & ONLY: cloud_droplets, cloud_physics, coupling_char, dz, g, & initializing_actions, io_blocks, io_group, & latitude, longitude, large_scale_forcing, lsf_surf, & message_string, microphysics_morrison, pt_surface, & rho_surface, surface_pressure, time_since_reference_point USE cpulog, & ONLY: cpu_log, log_point, log_point_s USE grid_variables, & ONLY: ddx, ddy, dx, dy USE date_and_time_mod, & ONLY: calc_date_and_time, d_hours_day, d_seconds_hour, day_of_year, & time_utc USE indices, & ONLY: nnx, nny, nx, nxl, nxlg, nxr, nxrg, ny, nyn, nyng, nys, nysg, & nzb, nzt USE, INTRINSIC :: iso_c_binding USE kinds USE microphysics_mod, & ONLY: na_init, nc_const, sigma_gc #if defined ( __netcdf ) USE NETCDF #endif USE netcdf_data_input_mod, & ONLY: albedo_type_f, albedo_pars_f, building_type_f, pavement_type_f, & vegetation_type_f, water_type_f USE plant_canopy_model_mod, & ONLY: plant_canopy, pc_heating_rate, lad_s, usm_lad_rma USE pegrid #if defined ( __rrtmg ) USE parrrsw, & ONLY: naerec, nbndsw USE parrrtm, & ONLY: nbndlw USE rrtmg_lw_init, & ONLY: rrtmg_lw_ini USE rrtmg_sw_init, & ONLY: rrtmg_sw_ini USE rrtmg_lw_rad, & ONLY: rrtmg_lw USE rrtmg_sw_rad, & ONLY: rrtmg_sw #endif USE statistics, & ONLY: hom USE surface_mod, & ONLY: get_topography_top_index, get_topography_top_index_ji, & surf_def_h, surf_def_v, surf_lsm_h, & surf_lsm_v, surf_type, surf_usm_h, surf_usm_v IMPLICIT NONE CHARACTER(10) :: radiation_scheme = 'clear-sky' ! 'constant', 'clear-sky', or 'rrtmg' ! !-- Predefined Land surface classes (albedo_type) after Briegleb (1992) CHARACTER(37), DIMENSION(0:33), PARAMETER :: albedo_type_name = (/ & 'user defined ', & ! 0 'ocean ', & ! 1 'mixed farming, tall grassland ', & ! 2 'tall/medium grassland ', & ! 3 'evergreen shrubland ', & ! 4 'short grassland/meadow/shrubland ', & ! 5 'evergreen needleleaf forest ', & ! 6 'mixed deciduous evergreen forest ', & ! 7 'deciduous forest ', & ! 8 'tropical evergreen broadleaved forest', & ! 9 'medium/tall grassland/woodland ', & ! 10 'desert, sandy ', & ! 11 'desert, rocky ', & ! 12 'tundra ', & ! 13 'land ice ', & ! 14 'sea ice ', & ! 15 'snow ', & ! 16 'bare soil ', & ! 17 'asphalt/concrete mix ', & ! 18 'asphalt (asphalt concrete) ', & ! 19 'concrete (Portland concrete) ', & ! 20 'sett ', & ! 21 'paving stones ', & ! 22 'cobblestone ', & ! 23 'metal ', & ! 24 'wood ', & ! 25 'gravel ', & ! 26 'fine gravel ', & ! 27 'pebblestone ', & ! 28 'woodchips ', & ! 29 'tartan (sports) ', & ! 30 'artifical turf (sports) ', & ! 31 'clay (sports) ', & ! 32 'building (dummy) ' & ! 33 /) INTEGER(iwp) :: albedo_type = 9999999, & !< Albedo surface type dots_rad = 0 !< starting index for timeseries output LOGICAL :: unscheduled_radiation_calls = .TRUE., & !< flag parameter indicating whether additional calls of the radiation code are allowed constant_albedo = .FALSE., & !< flag parameter indicating whether the albedo may change depending on zenith force_radiation_call = .FALSE., & !< flag parameter for unscheduled radiation calls lw_radiation = .TRUE., & !< flag parameter indicating whether longwave radiation shall be calculated radiation = .FALSE., & !< flag parameter indicating whether the radiation model is used sun_up = .TRUE., & !< flag parameter indicating whether the sun is up or down sw_radiation = .TRUE., & !< flag parameter indicating whether shortwave radiation shall be calculated sun_direction = .FALSE., & !< flag parameter indicating whether solar direction shall be calculated average_radiation = .TRUE., & !< flag to set the calculation of radiation averaging for the domain atm_surfaces = .FALSE., & !< flag parameter indicating wheather surfaces of atmospheric cells will be considered in calculating SVF radiation_interactions = .TRUE., & !< flag to control if radiation interactions via sky-view factors shall be considered surf_reflections = .TRUE. !< flag to switch the calculation of radiation interaction between surfaces. !< When it switched off, only the effect of buildings and trees shadow will !< will be considered. However fewer SVFs are expected. REAL(wp), PARAMETER :: sigma_sb = 5.67037321E-8_wp, & !< Stefan-Boltzmann constant solar_constant = 1368.0_wp !< solar constant at top of atmosphere REAL(wp) :: albedo = 9999999.9_wp, & !< NAMELIST alpha albedo_lw_dif = 9999999.9_wp, & !< NAMELIST aldif albedo_lw_dir = 9999999.9_wp, & !< NAMELIST aldir albedo_sw_dif = 9999999.9_wp, & !< NAMELIST asdif albedo_sw_dir = 9999999.9_wp, & !< NAMELIST asdir decl_1, & !< declination coef. 1 decl_2, & !< declination coef. 2 decl_3, & !< declination coef. 3 dt_radiation = 0.0_wp, & !< radiation model timestep emissivity = 9999999.9_wp, & !< NAMELIST surface emissivity lon = 0.0_wp, & !< longitude in radians lat = 0.0_wp, & !< latitude in radians net_radiation = 0.0_wp, & !< net radiation at surface skip_time_do_radiation = 0.0_wp, & !< Radiation model is not called before this time sky_trans, & !< sky transmissivity time_radiation = 0.0_wp !< time since last call of radiation code REAL(wp), DIMENSION(0:0) :: zenith, & !< cosine of solar zenith angle sun_dir_lat, & !< solar directional vector in latitudes sun_dir_lon !< solar directional vector in longitudes REAL(wp), DIMENSION(:,:), ALLOCATABLE :: rad_net_av !< average of rad_net ! !-- Land surface albedos for solar zenith angle of 60° after Briegleb (1992) !-- (shortwave, longwave, broadband): sw, lw, bb, REAL(wp), DIMENSION(0:2,1:33), PARAMETER :: albedo_pars = RESHAPE( (/& 0.06_wp, 0.06_wp, 0.06_wp, & ! 1 0.09_wp, 0.28_wp, 0.19_wp, & ! 2 0.11_wp, 0.33_wp, 0.23_wp, & ! 3 0.11_wp, 0.33_wp, 0.23_wp, & ! 4 0.14_wp, 0.34_wp, 0.25_wp, & ! 5 0.06_wp, 0.22_wp, 0.14_wp, & ! 6 0.06_wp, 0.27_wp, 0.17_wp, & ! 7 0.06_wp, 0.31_wp, 0.19_wp, & ! 8 0.06_wp, 0.22_wp, 0.14_wp, & ! 9 0.06_wp, 0.28_wp, 0.18_wp, & ! 10 0.35_wp, 0.51_wp, 0.43_wp, & ! 11 0.24_wp, 0.40_wp, 0.32_wp, & ! 12 0.10_wp, 0.27_wp, 0.19_wp, & ! 13 0.90_wp, 0.65_wp, 0.77_wp, & ! 14 0.90_wp, 0.65_wp, 0.77_wp, & ! 15 0.95_wp, 0.70_wp, 0.82_wp, & ! 16 0.08_wp, 0.08_wp, 0.08_wp, & ! 17 0.17_wp, 0.17_wp, 0.17_wp, & ! 18 0.17_wp, 0.17_wp, 0.17_wp, & ! 19 0.17_wp, 0.17_wp, 0.17_wp, & ! 20 0.17_wp, 0.17_wp, 0.17_wp, & ! 21 0.17_wp, 0.17_wp, 0.17_wp, & ! 22 0.17_wp, 0.17_wp, 0.17_wp, & ! 23 0.17_wp, 0.17_wp, 0.17_wp, & ! 24 0.17_wp, 0.17_wp, 0.17_wp, & ! 25 0.17_wp, 0.17_wp, 0.17_wp, & ! 26 0.17_wp, 0.17_wp, 0.17_wp, & ! 27 0.17_wp, 0.17_wp, 0.17_wp, & ! 28 0.17_wp, 0.17_wp, 0.17_wp, & ! 29 0.17_wp, 0.17_wp, 0.17_wp, & ! 30 0.17_wp, 0.17_wp, 0.17_wp, & ! 31 0.17_wp, 0.17_wp, 0.17_wp, & ! 32 0.17_wp, 0.17_wp, 0.17_wp & ! 33 /), (/ 3, 33 /) ) REAL(wp), DIMENSION(:,:,:), ALLOCATABLE, TARGET :: & rad_lw_cs_hr, & !< longwave clear sky radiation heating rate (K/s) rad_lw_cs_hr_av, & !< average of rad_lw_cs_hr rad_lw_hr, & !< longwave radiation heating rate (K/s) rad_lw_hr_av, & !< average of rad_sw_hr rad_lw_in, & !< incoming longwave radiation (W/m2) rad_lw_in_av, & !< average of rad_lw_in rad_lw_out, & !< outgoing longwave radiation (W/m2) rad_lw_out_av, & !< average of rad_lw_out rad_sw_cs_hr, & !< shortwave clear sky radiation heating rate (K/s) rad_sw_cs_hr_av, & !< average of rad_sw_cs_hr rad_sw_hr, & !< shortwave radiation heating rate (K/s) rad_sw_hr_av, & !< average of rad_sw_hr rad_sw_in, & !< incoming shortwave radiation (W/m2) rad_sw_in_av, & !< average of rad_sw_in rad_sw_out, & !< outgoing shortwave radiation (W/m2) rad_sw_out_av !< average of rad_sw_out ! !-- Variables and parameters used in RRTMG only #if defined ( __rrtmg ) CHARACTER(LEN=12) :: rrtm_input_file = "RAD_SND_DATA" !< name of the NetCDF input file (sounding data) ! !-- Flag parameters for RRTMGS (should not be changed) INTEGER(iwp), PARAMETER :: rrtm_idrv = 1, & !< flag for longwave upward flux calculation option (0,1) rrtm_inflglw = 2, & !< flag for lw cloud optical properties (0,1,2) rrtm_iceflglw = 0, & !< flag for lw ice particle specifications (0,1,2,3) rrtm_liqflglw = 1, & !< flag for lw liquid droplet specifications rrtm_inflgsw = 2, & !< flag for sw cloud optical properties (0,1,2) rrtm_iceflgsw = 0, & !< flag for sw ice particle specifications (0,1,2,3) rrtm_liqflgsw = 1 !< flag for sw liquid droplet specifications ! !-- The following variables should be only changed with care, as this will !-- require further setting of some variables, which is currently not !-- implemented (aerosols, ice phase). INTEGER(iwp) :: nzt_rad, & !< upper vertical limit for radiation calculations rrtm_icld = 0, & !< cloud flag (0: clear sky column, 1: cloudy column) 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) INTEGER(iwp) :: nc_stat !< local variable for storin the result of netCDF calls for error message handling LOGICAL :: snd_exists = .FALSE. !< flag parameter to check whether a user-defined input files exists REAL(wp), PARAMETER :: mol_mass_air_d_wv = 1.607793_wp !< molecular weight dry air / water vapor REAL(wp), DIMENSION(:), ALLOCATABLE :: hyp_snd, & !< hypostatic pressure from sounding data (hPa) q_snd, & !< specific humidity from sounding data (kg/kg) - dummy at the moment rrtm_tsfc, & !< dummy array for storing surface temperature t_snd !< actual temperature from sounding data (hPa) REAL(wp), DIMENSION(:,:), ALLOCATABLE :: rrtm_ccl4vmr, & !< CCL4 volume mixing ratio (g/mol) rrtm_cfc11vmr, & !< CFC11 volume mixing ratio (g/mol) rrtm_cfc12vmr, & !< CFC12 volume mixing ratio (g/mol) rrtm_cfc22vmr, & !< CFC22 volume mixing ratio (g/mol) rrtm_ch4vmr, & !< CH4 volume mixing ratio rrtm_cicewp, & !< in-cloud ice water path (g/m²) rrtm_cldfr, & !< cloud fraction (0,1) rrtm_cliqwp, & !< in-cloud liquid water path (g/m²) rrtm_co2vmr, & !< CO2 volume mixing ratio (g/mol) rrtm_emis, & !< surface emissivity (0-1) rrtm_h2ovmr, & !< H2O volume mixing ratio rrtm_n2ovmr, & !< N2O volume mixing ratio rrtm_o2vmr, & !< O2 volume mixing ratio rrtm_o3vmr, & !< O3 volume mixing ratio rrtm_play, & !< pressure layers (hPa, zu-grid) rrtm_plev, & !< pressure layers (hPa, zw-grid) rrtm_reice, & !< cloud ice effective radius (microns) rrtm_reliq, & !< cloud water drop effective radius (microns) rrtm_tlay, & !< actual temperature (K, zu-grid) rrtm_tlev, & !< actual temperature (K, zw-grid) rrtm_lwdflx, & !< RRTM output of incoming longwave radiation flux (W/m2) rrtm_lwdflxc, & !< RRTM output of outgoing clear sky longwave radiation flux (W/m2) rrtm_lwuflx, & !< RRTM output of outgoing longwave radiation flux (W/m2) rrtm_lwuflxc, & !< RRTM output of incoming clear sky longwave radiation flux (W/m2) rrtm_lwuflx_dt, & !< RRTM output of incoming clear sky longwave radiation flux (W/m2) rrtm_lwuflxc_dt,& !< RRTM output of outgoing clear sky longwave radiation flux (W/m2) rrtm_lwhr, & !< RRTM output of longwave radiation heating rate (K/d) rrtm_lwhrc, & !< RRTM output of incoming longwave clear sky radiation heating rate (K/d) rrtm_swdflx, & !< RRTM output of incoming shortwave radiation flux (W/m2) rrtm_swdflxc, & !< RRTM output of outgoing clear sky shortwave radiation flux (W/m2) rrtm_swuflx, & !< RRTM output of outgoing shortwave radiation flux (W/m2) rrtm_swuflxc, & !< RRTM output of incoming clear sky shortwave radiation flux (W/m2) rrtm_swhr, & !< RRTM output of shortwave radiation heating rate (K/d) rrtm_swhrc !< RRTM output of incoming shortwave clear sky radiation heating rate (K/d) REAL(wp), DIMENSION(1) :: rrtm_aldif, & !< surface albedo for longwave diffuse radiation rrtm_aldir, & !< surface albedo for longwave direct radiation rrtm_asdif, & !< surface albedo for shortwave diffuse radiation rrtm_asdir !< surface albedo for shortwave direct radiation ! !-- Definition of arrays that are currently not used for calling RRTMG (due to setting of flag parameters) REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: rad_lw_cs_in, & !< incoming clear sky longwave radiation (W/m2) (not used) rad_lw_cs_out, & !< outgoing clear sky longwave radiation (W/m2) (not used) rad_sw_cs_in, & !< incoming clear sky shortwave radiation (W/m2) (not used) rad_sw_cs_out, & !< outgoing clear sky shortwave radiation (W/m2) (not used) rrtm_lw_tauaer, & !< lw aerosol optical depth rrtm_lw_taucld, & !< lw in-cloud optical depth rrtm_sw_taucld, & !< sw in-cloud optical depth rrtm_sw_ssacld, & !< sw in-cloud single scattering albedo rrtm_sw_asmcld, & !< sw in-cloud asymmetry parameter rrtm_sw_fsfcld, & !< sw in-cloud forward scattering fraction rrtm_sw_tauaer, & !< sw aerosol optical depth rrtm_sw_ssaaer, & !< sw aerosol single scattering albedo rrtm_sw_asmaer, & !< sw aerosol asymmetry parameter rrtm_sw_ecaer !< sw aerosol optical detph at 0.55 microns (rrtm_iaer = 6 only) #endif ! !-- Parameters of urban and land surface models INTEGER(iwp) :: nzu !< number of layers of urban surface (will be calculated) INTEGER(iwp) :: nzub,nzut !< bottom and top layer of urban surface (will be calculated) !-- parameters of urban and land surface models INTEGER(iwp), PARAMETER :: nzut_free = 3 !< number of free layers above top of of topography INTEGER(iwp), PARAMETER :: ndsvf = 2 !< number of dimensions of real values in SVF INTEGER(iwp), PARAMETER :: idsvf = 2 !< number of dimensions of integer values in SVF INTEGER(iwp), PARAMETER :: ndcsf = 2 !< number of dimensions of real values in CSF INTEGER(iwp), PARAMETER :: idcsf = 2 !< number of dimensions of integer values in CSF INTEGER(iwp), PARAMETER :: kdcsf = 4 !< number of dimensions of integer values in CSF calculation array INTEGER(iwp), PARAMETER :: id = 1 !< position of d-index in surfl and surf INTEGER(iwp), PARAMETER :: iz = 2 !< position of k-index in surfl and surf INTEGER(iwp), PARAMETER :: iy = 3 !< position of j-index in surfl and surf INTEGER(iwp), PARAMETER :: ix = 4 !< position of i-index in surfl and surf INTEGER(iwp), PARAMETER :: nsurf_type = 21 !< number of surf types incl. phys.(land+urban) & (atm.,sky,boundary) surfaces - 1 INTEGER(iwp), PARAMETER :: iup_u = 0 !< 0 - index of urban ubward surface (ground or roof) INTEGER(iwp), PARAMETER :: idown_u = 1 !< 1 - index of urban downward surface (overhanging) INTEGER(iwp), PARAMETER :: inorth_u = 2 !< 2 - index of urban northward facing wall INTEGER(iwp), PARAMETER :: isouth_u = 3 !< 3 - index of urban southward facing wall INTEGER(iwp), PARAMETER :: ieast_u = 4 !< 4 - index of urban eastward facing wall INTEGER(iwp), PARAMETER :: iwest_u = 5 !< 5 - index of urban westward facing wall INTEGER(iwp), PARAMETER :: iup_l = 6 !< 6 - index of land ubward surface (ground or roof) INTEGER(iwp), PARAMETER :: inorth_l = 7 !< 7 - index of land northward facing wall INTEGER(iwp), PARAMETER :: isouth_l = 8 !< 8 - index of land southward facing wall INTEGER(iwp), PARAMETER :: ieast_l = 9 !< 9 - index of land eastward facing wall INTEGER(iwp), PARAMETER :: iwest_l = 10 !< 10- index of land westward facing wall INTEGER(iwp), PARAMETER :: iup_a = 11 !< 11- index of atm. cell ubward virtual surface INTEGER(iwp), PARAMETER :: idown_a = 12 !< 12- index of atm. cell downward virtual surface INTEGER(iwp), PARAMETER :: inorth_a = 13 !< 13- index of atm. cell northward facing virtual surface INTEGER(iwp), PARAMETER :: isouth_a = 14 !< 14- index of atm. cell southward facing virtual surface INTEGER(iwp), PARAMETER :: ieast_a = 15 !< 15- index of atm. cell eastward facing virtual surface INTEGER(iwp), PARAMETER :: iwest_a = 16 !< 16- index of atm. cell westward facing virtual surface INTEGER(iwp), PARAMETER :: isky = 17 !< 17 - index of top border of the urban surface layer ("urban sky") INTEGER(iwp), PARAMETER :: inorth_b = 18 !< 18 - index of free north border of the domain (south facing) INTEGER(iwp), PARAMETER :: isouth_b = 19 !< 19 - index of north south border of the domain (north facing) INTEGER(iwp), PARAMETER :: ieast_b = 20 !< 20 - index of east border of the domain (west facing) INTEGER(iwp), PARAMETER :: iwest_b = 21 !< 21 - index of wast border of the domain (east facing) INTEGER(iwp), DIMENSION(0:nsurf_type), PARAMETER :: idir = (/0, 0,0, 0,1,-1,0,0, 0,1,-1,0, 0,0, 0,1,-1, 0, 0,0,-1,1/) !< surface normal direction x indices INTEGER(iwp), DIMENSION(0:nsurf_type), PARAMETER :: jdir = (/0, 0,1,-1,0, 0,0,1,-1,0, 0,0, 0,1,-1,0, 0, 0,-1,1, 0,0/) !< surface normal direction y indices INTEGER(iwp), DIMENSION(0:nsurf_type), PARAMETER :: kdir = (/1,-1,0, 0,0, 0,1,0, 0,0, 0,1,-1,0, 0,0, 0,-1, 0,0, 0,0/) !< surface normal direction z indices !< parameter but set in the code !-- indices and sizes of urban and land surface models INTEGER(iwp) :: nskys !< number of sky surfaces in local processor INTEGER(iwp) :: startland !< start index of block of land and roof surfaces!-- block variables needed for calculation of the plant canopy model inside the urban surface model INTEGER(iwp) :: endland !< end index of block of land and roof surfaces INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE :: pct !< top layer of the plant canopy INTEGER(iwp) :: nlands !< number of land and roof surfaces in local processor INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE :: pch !< heights of the plant canopy INTEGER(iwp) :: startwall !< start index of block of wall surfaces INTEGER(iwp) :: npcbl !< number of the plant canopy gridboxes in local processor INTEGER(iwp) :: endwall !< end index of block of wall surfaces INTEGER(wp), DIMENSION(:,:), ALLOCATABLE :: pcbl !< k,j,i coordinates of l-th local plant canopy box pcbl[:,l] = [k, j, INTEGER(iwp) :: nwalls !< number of wall surfaces in local processor REAL(wp), DIMENSION(:), ALLOCATABLE :: pcbinsw !< array of absorbed sw radiation for local plant canopy box INTEGER(iwp) :: nborder !< number of border surfaces in local processor REAL(wp), DIMENSION(:), ALLOCATABLE :: pcbinlw !< array of absorbed lw radiation for local plant canopy box !-- indices and sizes of urban and land surface models INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE :: surfl !< coordinates of i-th local surface in local grid - surfl[:,k] = [d, z, y, x] INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE :: surf !< coordinates of i-th surface in grid - surf[:,k] = [d, z, y, x] INTEGER(iwp) :: nsurfl !< number of all surfaces in local processor INTEGER(iwp), DIMENSION(:), ALLOCATABLE :: nsurfs !< array of number of all surfaces in individual processors INTEGER(iwp) :: startsky !< start index of block of sky INTEGER(iwp) :: endsky !< end index of block of sky INTEGER(iwp) :: startenergy !< start index of block of real surfaces (land, walls and roofs) INTEGER(iwp) :: endenergy !< end index of block of real surfaces (land, walls and roofs) INTEGER(iwp) :: nenergy !< number of real surfaces in local processor INTEGER(iwp) :: nsurf !< global number of surfaces in index array of surfaces (nsurf = proc nsurfs) INTEGER(iwp) :: startborder !< start index of block of border INTEGER(iwp) :: endborder !< end index of block of border INTEGER(iwp), DIMENSION(:), ALLOCATABLE :: surfstart !< starts of blocks of surfaces for individual processors in array surf !< respective block for particular processor is surfstart[iproc]+1 : surfstart[iproc+1] !-- block variables needed for calculation of the plant canopy model inside the urban surface model INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE :: pct !< top layer of the plant canopy INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE :: pch !< heights of the plant canopy INTEGER(iwp) :: npcbl !< number of the plant canopy gridboxes in local processor INTEGER(wp), DIMENSION(:,:), ALLOCATABLE :: pcbl !< k,j,i coordinates of l-th local plant canopy box pcbl[:,l] = [k, j, i] REAL(wp), DIMENSION(:), ALLOCATABLE :: pcbinsw !< array of absorbed sw radiation for local plant canopy box REAL(wp), DIMENSION(:), ALLOCATABLE :: pcbinlw !< array of absorbed lw radiation for local plant canopy box !-- configuration parameters (they can be setup in PALM config) LOGICAL :: split_diffusion_radiation = .TRUE. !< split direct and diffusion dw radiation !< (.F. in case the radiation model already does it) LOGICAL :: energy_balance_surf_h = .TRUE. !< flag parameter indicating wheather the energy balance is calculated for horizontal surfaces LOGICAL :: energy_balance_surf_v = .TRUE. !< flag parameter indicating wheather the energy balance is calculated for vertical surfaces LOGICAL :: read_svf_on_init = .FALSE. !< flag parameter indicating wheather SVFs will be read from a file at initialization LOGICAL :: write_svf_on_init = .FALSE. !< flag parameter indicating wheather SVFs will be written out to a file LOGICAL :: mrt_factors = .FALSE. !< whether to generate MRT factor files during init INTEGER(iwp) :: nrefsteps = 0 !< number of reflection steps to perform REAL(wp), PARAMETER :: ext_coef = 0.6_wp !< extinction coefficient (a.k.a. alpha) INTEGER(iwp), PARAMETER :: svf_code_len = 15 !< length of code for verification of the end of svf file CHARACTER(svf_code_len), PARAMETER :: svf_code = '*** end svf ***' !< code for verification of the end of svf file INTEGER(iwp), PARAMETER :: usm_version_len = 10 !< length of identification string of usm version CHARACTER(usm_version_len), PARAMETER :: usm_version = 'USM v. 1.0' !< identification of version of binary svf and restart files !-- radiation related arrays to be used in radiation_interaction routine REAL(wp), DIMENSION(:,:), ALLOCATABLE :: rad_sw_in_dir !< direct sw radiation REAL(wp), DIMENSION(:,:), ALLOCATABLE :: rad_sw_in_diff !< diffusion sw radiation REAL(wp), DIMENSION(:,:), ALLOCATABLE :: rad_lw_in_diff !< diffusion lw radiation !-- parameters required for RRTMG lower boundary condition REAL(wp) :: albedo_urb !< albedo value retuned to RRTMG boundary cond. REAL(wp) :: emissivity_urb !< emissivity value retuned to RRTMG boundary cond. REAL(wp) :: t_rad_urb !< temperature value retuned to RRTMG boundary cond. !-- type for calculation of svf TYPE t_svf INTEGER(iwp) :: isurflt !< INTEGER(iwp) :: isurfs !< REAL(wp) :: rsvf !< REAL(wp) :: rtransp !< END TYPE !-- type for calculation of csf TYPE t_csf INTEGER(iwp) :: ip !< INTEGER(iwp) :: itx !< INTEGER(iwp) :: ity !< INTEGER(iwp) :: itz !< INTEGER(iwp) :: isurfs !< REAL(wp) :: rsvf !< REAL(wp) :: rtransp !< END TYPE !-- arrays storing the values of USM INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE :: svfsurf !< svfsurf[:,isvf] = index of source and target surface for svf[isvf] REAL(wp), DIMENSION(:,:), ALLOCATABLE :: svf !< array of shape view factors+direct irradiation factors for local surfaces REAL(wp), DIMENSION(:), ALLOCATABLE :: surfins !< array of sw radiation falling to local surface after i-th reflection REAL(wp), DIMENSION(:), ALLOCATABLE :: surfinl !< array of lw radiation for local surface after i-th reflection !< Inward radiation is also valid for virtual surfaces (radiation leaving domain) REAL(wp), DIMENSION(:), ALLOCATABLE :: surfinsw !< array of sw radiation falling to local surface including radiation from reflections REAL(wp), DIMENSION(:), ALLOCATABLE :: surfinlw !< array of lw radiation falling to local surface including radiation from reflections REAL(wp), DIMENSION(:), ALLOCATABLE :: surfinswdir !< array of direct sw radiation falling to local surface REAL(wp), DIMENSION(:), ALLOCATABLE :: surfinswdif !< array of diffuse sw radiation from sky and model boundary falling to local surface REAL(wp), DIMENSION(:), ALLOCATABLE :: surfinlwdif !< array of diffuse lw radiation from sky and model boundary falling to local surface !< Outward radiation is only valid for nonvirtual surfaces REAL(wp), DIMENSION(:), ALLOCATABLE :: surfoutsl !< array of reflected sw radiation for local surface in i-th reflection REAL(wp), DIMENSION(:), ALLOCATABLE :: surfoutll !< array of reflected + emitted lw radiation for local surface in i-th reflection REAL(wp), DIMENSION(:), ALLOCATABLE :: surfouts !< array of reflected sw radiation for all surfaces in i-th reflection REAL(wp), DIMENSION(:), ALLOCATABLE :: surfoutl !< array of reflected + emitted lw radiation for all surfaces in i-th reflection REAL(wp), DIMENSION(:), ALLOCATABLE :: surfoutsw !< array of total sw radiation outgoing from nonvirtual surfaces surfaces after all reflection REAL(wp), DIMENSION(:), ALLOCATABLE :: surfoutlw !< array of total lw radiation outgoing from nonvirtual surfaces surfaces after all reflection REAL(wp), DIMENSION(:), ALLOCATABLE :: surfhf !< array of total radiation flux incoming to minus outgoing from local surface REAL(wp), DIMENSION(:), ALLOCATABLE :: rad_net_l !< local copy of rad_net (net radiation at surface) !-- block variables needed for calculation of the plant canopy model inside the urban surface model INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE :: csfsurf !< csfsurf[:,icsf] = index of target surface and csf grid index for csf[icsf] REAL(wp), DIMENSION(:,:), ALLOCATABLE :: csf !< array of plant canopy sink fators + direct irradiation factors (transparency) REAL(wp), DIMENSION(:,:,:), POINTER :: usm_lad !< subset of lad_s within urban surface, transformed to plain Z coordinate REAL(wp), DIMENSION(:), POINTER :: usm_lad_g !< usm_lad globalized (used to avoid MPI RMA calls in raytracing) INTEGER(iwp), DIMENSION(:), ALLOCATABLE :: nzterr, plantt !< temporary global arrays for raytracing !-- arrays and variables for calculation of svf and csf TYPE(t_svf), DIMENSION(:), POINTER :: asvf !< pointer to growing svc array TYPE(t_csf), DIMENSION(:), POINTER :: acsf !< pointer to growing csf array TYPE(t_svf), DIMENSION(:), ALLOCATABLE, TARGET :: asvf1, asvf2 !< realizations of svf array TYPE(t_csf), DIMENSION(:), ALLOCATABLE, TARGET :: acsf1, acsf2 !< realizations of csf array INTEGER(iwp) :: nsvfla !< dimmension of array allocated for storage of svf in local processor INTEGER(iwp) :: ncsfla !< dimmension of array allocated for storage of csf in local processor INTEGER(iwp) :: msvf, mcsf !< mod for swapping the growing array INTEGER(iwp), PARAMETER :: gasize = 10000 !< initial size of growing arrays REAL(wp) :: dist_max_svf = -9999.0 !< maximum distance to calculate the minimum svf to be considered. It is !< used to avoid very small SVFs resulting from too far surfaces with mutual visibility INTEGER(iwp) :: nsvfl !< number of svf for local processor INTEGER(iwp) :: ncsfl !< no. of csf in local processor !< needed only during calc_svf but must be here because it is !< shared between subroutines usm_calc_svf and usm_raytrace INTEGER(iwp), DIMENSION(:,:,:), ALLOCATABLE :: gridpcbl !< index of local pcb[k,j,i] !-- temporary arrays for calculation of csf in raytracing INTEGER(iwp) :: maxboxesg !< max number of boxes ray can cross in the domain INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE :: boxes !< coordinates of gridboxes being crossed by ray REAL(wp), DIMENSION(:), ALLOCATABLE :: crlens !< array of crossing lengths of ray for particular grid boxes INTEGER(iwp), DIMENSION(:), ALLOCATABLE :: lad_ip !< array of numbers of process where lad is stored #if defined( __parallel ) INTEGER(kind=MPI_ADDRESS_KIND), & DIMENSION(:), ALLOCATABLE :: lad_disp !< array of displaycements of lad in local array of proc lad_ip #endif REAL(wp), DIMENSION(:), ALLOCATABLE :: lad_s_ray !< array of received lad_s for appropriate gridboxes crossed by ray !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !-- Energy balance variables !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !-- parameters of the land, roof and wall surfaces REAL(wp), DIMENSION(:), ALLOCATABLE :: albedo_surf !< albedo of the surface REAL(wp), DIMENSION(:), ALLOCATABLE :: emiss_surf !< emissivity of the wall surface INTERFACE radiation_check_data_output MODULE PROCEDURE radiation_check_data_output END INTERFACE radiation_check_data_output INTERFACE radiation_check_data_output_pr MODULE PROCEDURE radiation_check_data_output_pr END INTERFACE radiation_check_data_output_pr INTERFACE radiation_check_parameters MODULE PROCEDURE radiation_check_parameters END INTERFACE radiation_check_parameters INTERFACE radiation_clearsky MODULE PROCEDURE radiation_clearsky END INTERFACE radiation_clearsky INTERFACE radiation_constant MODULE PROCEDURE radiation_constant END INTERFACE radiation_constant INTERFACE radiation_control MODULE PROCEDURE radiation_control END INTERFACE radiation_control INTERFACE radiation_3d_data_averaging MODULE PROCEDURE radiation_3d_data_averaging END INTERFACE radiation_3d_data_averaging INTERFACE radiation_data_output_2d MODULE PROCEDURE radiation_data_output_2d END INTERFACE radiation_data_output_2d INTERFACE radiation_data_output_3d MODULE PROCEDURE radiation_data_output_3d END INTERFACE radiation_data_output_3d INTERFACE radiation_data_output_mask MODULE PROCEDURE radiation_data_output_mask END INTERFACE radiation_data_output_mask INTERFACE radiation_define_netcdf_grid MODULE PROCEDURE radiation_define_netcdf_grid END INTERFACE radiation_define_netcdf_grid INTERFACE radiation_header MODULE PROCEDURE radiation_header END INTERFACE radiation_header INTERFACE radiation_init MODULE PROCEDURE radiation_init END INTERFACE radiation_init INTERFACE radiation_parin MODULE PROCEDURE radiation_parin END INTERFACE radiation_parin INTERFACE radiation_rrtmg MODULE PROCEDURE radiation_rrtmg END INTERFACE radiation_rrtmg INTERFACE radiation_tendency MODULE PROCEDURE radiation_tendency MODULE PROCEDURE radiation_tendency_ij END INTERFACE radiation_tendency INTERFACE radiation_read_restart_data MODULE PROCEDURE radiation_read_restart_data END INTERFACE radiation_read_restart_data INTERFACE radiation_last_actions MODULE PROCEDURE radiation_last_actions END INTERFACE radiation_last_actions INTERFACE radiation_interaction MODULE PROCEDURE radiation_interaction END INTERFACE radiation_interaction INTERFACE radiation_interaction_init MODULE PROCEDURE radiation_interaction_init END INTERFACE radiation_interaction_init INTERFACE radiation_radflux_gridbox MODULE PROCEDURE radiation_radflux_gridbox END INTERFACE radiation_radflux_gridbox INTERFACE radiation_calc_svf MODULE PROCEDURE radiation_calc_svf END INTERFACE radiation_calc_svf INTERFACE radiation_write_svf MODULE PROCEDURE radiation_write_svf END INTERFACE radiation_write_svf INTERFACE radiation_read_svf MODULE PROCEDURE radiation_read_svf END INTERFACE radiation_read_svf SAVE PRIVATE ! !-- Public functions / NEEDS SORTING PUBLIC radiation_check_data_output, radiation_check_data_output_pr, & radiation_check_parameters, radiation_control, & radiation_header, radiation_init, radiation_parin, & radiation_3d_data_averaging, radiation_tendency, & radiation_data_output_2d, radiation_data_output_3d, & radiation_define_netcdf_grid, radiation_last_actions, & radiation_read_restart_data, radiation_data_output_mask, & radiation_radflux_gridbox, radiation_calc_svf, radiation_write_svf, & radiation_interaction, radiation_interaction_init, & radiation_read_svf ! !-- Public variables and constants / NEEDS SORTING PUBLIC albedo, albedo_type, decl_1, decl_2, decl_3, dots_rad, dt_radiation,& emissivity, force_radiation_call, & lat, lon, rad_net_av, radiation, radiation_scheme, rad_lw_in, & rad_lw_in_av, rad_lw_out, rad_lw_out_av, & rad_lw_cs_hr, rad_lw_cs_hr_av, rad_lw_hr, rad_lw_hr_av, rad_sw_in, & rad_sw_in_av, rad_sw_out, rad_sw_out_av, rad_sw_cs_hr, & rad_sw_cs_hr_av, rad_sw_hr, rad_sw_hr_av, sigma_sb, solar_constant, & skip_time_do_radiation, time_radiation, unscheduled_radiation_calls,& zenith, calc_zenith, sun_direction, sun_dir_lat, sun_dir_lon, & split_diffusion_radiation, & energy_balance_surf_h, energy_balance_surf_v, write_svf_on_init, & read_svf_on_init, nrefsteps, mrt_factors, dist_max_svf, nsvfl, svf, & svfsurf, surfinsw, surfinlw, surfins, surfinl, surfinswdir, & surfinswdif, surfoutsw, surfoutlw, surfinlwdif, rad_sw_in_dir, & rad_sw_in_diff, rad_lw_in_diff, surfouts, surfoutl, surfoutsl, & surfoutll, idir, jdir, kdir, id, iz, iy, ix, isky, nenergy, nsurfs, & surfstart, surf, surfl, nsurfl, pcbinsw, pcbinlw, pcbl, npcbl, & startenergy, endenergy, iup_u, inorth_u, isouth_u, ieast_u, iwest_u,& iup_l, inorth_l, isouth_l, ieast_l, iwest_l, startsky, endsky, & startborder, endborder, nsurf_type, nzub, nzut, inorth_b,idown_a, & isouth_b, ieast_b, iwest_b, nzu, pch, nsurf, iup_a, inorth_a, & isouth_a, ieast_a, iwest_a, idsvf, ndsvf, idcsf, ndcsf, kdcsf, pct, & radiation_interactions, startwall, startland, endland, endwall #if defined ( __rrtmg ) PUBLIC rrtm_aldif, rrtm_aldir, rrtm_asdif, rrtm_asdir #endif CONTAINS !------------------------------------------------------------------------------! ! Description: ! ------------ !> This subroutine controls the calls of the radiation schemes !------------------------------------------------------------------------------! SUBROUTINE radiation_control IMPLICIT NONE SELECT CASE ( TRIM( radiation_scheme ) ) CASE ( 'constant' ) CALL radiation_constant CASE ( 'clear-sky' ) CALL radiation_clearsky CASE ( 'rrtmg' ) CALL radiation_rrtmg CASE DEFAULT END SELECT END SUBROUTINE radiation_control !------------------------------------------------------------------------------! ! Description: ! ------------ !> Check data output for radiation model !------------------------------------------------------------------------------! SUBROUTINE radiation_check_data_output( var, unit, i, ilen, k ) USE control_parameters, & ONLY: data_output, message_string IMPLICIT NONE CHARACTER (LEN=*) :: unit !< CHARACTER (LEN=*) :: var !< INTEGER(iwp) :: i INTEGER(iwp) :: ilen INTEGER(iwp) :: k SELECT CASE ( TRIM( var ) ) CASE ( 'rad_lw_cs_hr', 'rad_lw_hr', 'rad_sw_cs_hr', 'rad_sw_hr' ) IF ( .NOT. radiation .OR. radiation_scheme /= 'rrtmg' ) THEN message_string = '"output of "' // TRIM( var ) // '" requi' // & 'res radiation = .TRUE. and ' // & 'radiation_scheme = "rrtmg"' CALL message( 'check_parameters', 'PA0406', 1, 2, 0, 6, 0 ) ENDIF unit = 'K/h' CASE ( 'rad_net*', 'rrtm_aldif*', 'rrtm_aldir*', 'rrtm_asdif*', & 'rrtm_asdir*' ) IF ( k == 0 .OR. data_output(i)(ilen-2:ilen) /= '_xy' ) THEN message_string = 'illegal value for data_output: "' // & TRIM( var ) // '" & only 2d-horizontal ' // & 'cross sections are allowed for this value' CALL message( 'check_parameters', 'PA0111', 1, 2, 0, 6, 0 ) ENDIF IF ( .NOT. radiation .OR. radiation_scheme /= "rrtmg" ) THEN IF ( TRIM( var ) == 'rrtm_aldif*' .OR. & TRIM( var ) == 'rrtm_aldir*' .OR. & TRIM( var ) == 'rrtm_asdif*' .OR. & TRIM( var ) == 'rrtm_asdir*' ) & THEN message_string = 'output of "' // TRIM( var ) // '" require'& // 's radiation = .TRUE. and radiation_sch'& // 'eme = "rrtmg"' CALL message( 'check_parameters', 'PA0409', 1, 2, 0, 6, 0 ) ENDIF ENDIF IF ( TRIM( var ) == 'rad_net*' ) unit = 'W/m2' IF ( TRIM( var ) == 'rrtm_aldif*' ) unit = '' IF ( TRIM( var ) == 'rrtm_aldir*' ) unit = '' IF ( TRIM( var ) == 'rrtm_asdif*' ) unit = '' IF ( TRIM( var ) == 'rrtm_asdir*' ) unit = '' CASE DEFAULT unit = 'illegal' END SELECT END SUBROUTINE radiation_check_data_output !------------------------------------------------------------------------------! ! Description: ! ------------ !> Check data output of profiles for radiation model !------------------------------------------------------------------------------! SUBROUTINE radiation_check_data_output_pr( variable, var_count, unit, & dopr_unit ) USE arrays_3d, & ONLY: zu USE control_parameters, & ONLY: data_output_pr, message_string USE indices USE profil_parameter USE statistics IMPLICIT NONE CHARACTER (LEN=*) :: unit !< CHARACTER (LEN=*) :: variable !< CHARACTER (LEN=*) :: dopr_unit !< local value of dopr_unit INTEGER(iwp) :: user_pr_index !< INTEGER(iwp) :: var_count !< SELECT CASE ( TRIM( variable ) ) CASE ( 'rad_net' ) IF ( ( .NOT. radiation ) .OR. radiation_scheme == 'constant' )& THEN message_string = 'data_output_pr = ' // & TRIM( data_output_pr(var_count) ) // ' is' // & 'not available for radiation = .FALSE. or ' //& 'radiation_scheme = "constant"' CALL message( 'check_parameters', 'PA0408', 1, 2, 0, 6, 0 ) ELSE dopr_index(var_count) = 99 dopr_unit = 'W/m2' hom(:,2,99,:) = SPREAD( zw, 2, statistic_regions+1 ) unit = dopr_unit ENDIF CASE ( 'rad_lw_in' ) IF ( ( .NOT. radiation) .OR. radiation_scheme == 'constant' ) & THEN message_string = 'data_output_pr = ' // & TRIM( data_output_pr(var_count) ) // ' is' // & 'not available for radiation = .FALSE. or ' //& 'radiation_scheme = "constant"' CALL message( 'check_parameters', 'PA0408', 1, 2, 0, 6, 0 ) ELSE dopr_index(var_count) = 100 dopr_unit = 'W/m2' hom(:,2,100,:) = SPREAD( zw, 2, statistic_regions+1 ) unit = dopr_unit ENDIF CASE ( 'rad_lw_out' ) IF ( ( .NOT. radiation ) .OR. radiation_scheme == 'constant' ) & THEN message_string = 'data_output_pr = ' // & TRIM( data_output_pr(var_count) ) // ' is' // & 'not available for radiation = .FALSE. or ' //& 'radiation_scheme = "constant"' CALL message( 'check_parameters', 'PA0408', 1, 2, 0, 6, 0 ) ELSE dopr_index(var_count) = 101 dopr_unit = 'W/m2' hom(:,2,101,:) = SPREAD( zw, 2, statistic_regions+1 ) unit = dopr_unit ENDIF CASE ( 'rad_sw_in' ) IF ( ( .NOT. radiation ) .OR. radiation_scheme == 'constant' ) & THEN message_string = 'data_output_pr = ' // & TRIM( data_output_pr(var_count) ) // ' is' // & 'not available for radiation = .FALSE. or ' //& 'radiation_scheme = "constant"' CALL message( 'check_parameters', 'PA0408', 1, 2, 0, 6, 0 ) ELSE dopr_index(var_count) = 102 dopr_unit = 'W/m2' hom(:,2,102,:) = SPREAD( zw, 2, statistic_regions+1 ) unit = dopr_unit ENDIF CASE ( 'rad_sw_out') IF ( ( .NOT. radiation ) .OR. radiation_scheme == 'constant' )& THEN message_string = 'data_output_pr = ' // & TRIM( data_output_pr(var_count) ) // ' is' // & 'not available for radiation = .FALSE. or ' //& 'radiation_scheme = "constant"' CALL message( 'check_parameters', 'PA0408', 1, 2, 0, 6, 0 ) ELSE dopr_index(var_count) = 103 dopr_unit = 'W/m2' hom(:,2,103,:) = SPREAD( zw, 2, statistic_regions+1 ) unit = dopr_unit ENDIF CASE ( 'rad_lw_cs_hr' ) IF ( ( .NOT. radiation ) .OR. radiation_scheme /= 'rrtmg' ) & THEN message_string = 'data_output_pr = ' // & TRIM( data_output_pr(var_count) ) // ' is' // & 'not available for radiation = .FALSE. or ' //& 'radiation_scheme /= "rrtmg"' CALL message( 'check_parameters', 'PA0413', 1, 2, 0, 6, 0 ) ELSE dopr_index(var_count) = 104 dopr_unit = 'K/h' hom(:,2,104,:) = SPREAD( zu, 2, statistic_regions+1 ) unit = dopr_unit ENDIF CASE ( 'rad_lw_hr' ) IF ( ( .NOT. radiation ) .OR. radiation_scheme /= 'rrtmg' ) & THEN message_string = 'data_output_pr = ' // & TRIM( data_output_pr(var_count) ) // ' is' // & 'not available for radiation = .FALSE. or ' //& 'radiation_scheme /= "rrtmg"' CALL message( 'check_parameters', 'PA0413', 1, 2, 0, 6, 0 ) ELSE dopr_index(var_count) = 105 dopr_unit = 'K/h' hom(:,2,105,:) = SPREAD( zu, 2, statistic_regions+1 ) unit = dopr_unit ENDIF CASE ( 'rad_sw_cs_hr' ) IF ( ( .NOT. radiation ) .OR. radiation_scheme /= 'rrtmg' ) & THEN message_string = 'data_output_pr = ' // & TRIM( data_output_pr(var_count) ) // ' is' // & 'not available for radiation = .FALSE. or ' //& 'radiation_scheme /= "rrtmg"' CALL message( 'check_parameters', 'PA0413', 1, 2, 0, 6, 0 ) ELSE dopr_index(var_count) = 106 dopr_unit = 'K/h' hom(:,2,106,:) = SPREAD( zu, 2, statistic_regions+1 ) unit = dopr_unit ENDIF CASE ( 'rad_sw_hr' ) IF ( ( .NOT. radiation ) .OR. radiation_scheme /= 'rrtmg' ) & THEN message_string = 'data_output_pr = ' // & TRIM( data_output_pr(var_count) ) // ' is' // & 'not available for radiation = .FALSE. or ' //& 'radiation_scheme /= "rrtmg"' CALL message( 'check_parameters', 'PA0413', 1, 2, 0, 6, 0 ) ELSE dopr_index(var_count) = 107 dopr_unit = 'K/h' hom(:,2,107,:) = SPREAD( zu, 2, statistic_regions+1 ) unit = dopr_unit ENDIF CASE DEFAULT unit = 'illegal' END SELECT END SUBROUTINE radiation_check_data_output_pr !------------------------------------------------------------------------------! ! Description: ! ------------ !> Check parameters routine for radiation model !------------------------------------------------------------------------------! SUBROUTINE radiation_check_parameters USE control_parameters, & ONLY: message_string, topography, urban_surface USE netcdf_data_input_mod, & ONLY: input_pids_static IMPLICIT NONE IF ( radiation_scheme /= 'constant' .AND. & radiation_scheme /= 'clear-sky' .AND. & radiation_scheme /= 'rrtmg' ) THEN message_string = 'unknown radiation_scheme = '// & TRIM( radiation_scheme ) CALL message( 'check_parameters', 'PA0405', 1, 2, 0, 6, 0 ) ELSEIF ( radiation_scheme == 'rrtmg' ) THEN #if ! defined ( __rrtmg ) message_string = 'radiation_scheme = "rrtmg" requires ' // & 'compilation of PALM with pre-processor ' // & 'directive -D__rrtmg' CALL message( 'check_parameters', 'PA0407', 1, 2, 0, 6, 0 ) #endif #if defined ( __rrtmg ) && ! defined( __netcdf ) message_string = 'radiation_scheme = "rrtmg" requires ' // & 'the use of NetCDF (preprocessor directive ' // & '-D__netcdf' CALL message( 'check_parameters', 'PA0412', 1, 2, 0, 6, 0 ) #endif ENDIF ! !-- Checks performed only if data is given via namelist only. IF ( .NOT. input_pids_static ) THEN IF ( albedo_type == 0 .AND. albedo == 9999999.9_wp .AND. & radiation_scheme == 'clear-sky') THEN message_string = 'radiation_scheme = "clear-sky" in combination' //& 'with albedo_type = 0 requires setting of albedo'//& ' /= 9999999.9' CALL message( 'check_parameters', 'PA0410', 1, 2, 0, 6, 0 ) ENDIF IF ( albedo_type == 0 .AND. radiation_scheme == 'rrtmg' .AND. & ( albedo_lw_dif == 9999999.9_wp .OR. albedo_lw_dir == 9999999.9_wp& .OR. albedo_sw_dif == 9999999.9_wp .OR. albedo_sw_dir == 9999999.9_wp& ) ) THEN message_string = 'radiation_scheme = "rrtmg" in combination' // & 'with albedo_type = 0 requires setting of ' // & 'albedo_lw_dif /= 9999999.9' // & 'albedo_lw_dir /= 9999999.9' // & 'albedo_sw_dif /= 9999999.9 and' // & 'albedo_sw_dir /= 9999999.9' CALL message( 'check_parameters', 'PA0411', 1, 2, 0, 6, 0 ) ENDIF ENDIF ! !-- Radiation interactions IF ( urban_surface .AND. .NOT. radiation_interactions ) THEN message_string = 'radiation_interactions = .T. is required '// & 'when using the urban surface model' CALL message( 'check_parameters', 'PA0999', 1, 2, 0, 6, 0 ) ENDIF END SUBROUTINE radiation_check_parameters !------------------------------------------------------------------------------! ! Description: ! ------------ !> Initialization of the radiation model !------------------------------------------------------------------------------! SUBROUTINE radiation_init IMPLICIT NONE INTEGER(iwp) :: i !< running index x-direction INTEGER(iwp) :: ind_type !< index of natural land-surface type with respect to albedo array INTEGER(iwp) :: ioff !< offset in x between surface element reference grid point in atmosphere and actual surface INTEGER(iwp) :: j !< running index y-direction INTEGER(iwp) :: joff !< offset in y between surface element reference grid point in atmosphere and actual surface INTEGER(iwp) :: l !< running index for orientation of vertical surfaces INTEGER(iwp) :: m !< running index for surface elements ! !-- Allocate array for storing the surface net radiation IF ( .NOT. ALLOCATED ( surf_def_h(0)%rad_net ) .AND. & surf_def_h(0)%ns > 0 ) THEN ALLOCATE( surf_def_h(0)%rad_net(1:surf_def_h(0)%ns) ) surf_def_h(0)%rad_net = 0.0_wp ENDIF IF ( .NOT. ALLOCATED ( surf_lsm_h%rad_net ) .AND. & surf_lsm_h%ns > 0 ) THEN ALLOCATE( surf_lsm_h%rad_net(1:surf_lsm_h%ns) ) surf_lsm_h%rad_net = 0.0_wp ENDIF IF ( .NOT. ALLOCATED ( surf_usm_h%rad_net ) .AND. & surf_usm_h%ns > 0 ) THEN ALLOCATE( surf_usm_h%rad_net(1:surf_usm_h%ns) ) surf_usm_h%rad_net = 0.0_wp ENDIF DO l = 0, 3 IF ( .NOT. ALLOCATED ( surf_def_v(l)%rad_net ) .AND. & surf_def_v(l)%ns > 0 ) THEN ALLOCATE( surf_def_v(l)%rad_net(1:surf_def_v(l)%ns) ) surf_def_v(l)%rad_net = 0.0_wp ENDIF IF ( .NOT. ALLOCATED ( surf_lsm_v(l)%rad_net ) .AND. & surf_lsm_v(l)%ns > 0 ) THEN ALLOCATE( surf_lsm_v(l)%rad_net(1:surf_lsm_v(l)%ns) ) surf_lsm_v(l)%rad_net = 0.0_wp ENDIF IF ( .NOT. ALLOCATED ( surf_usm_v(l)%rad_net ) .AND. & surf_usm_v(l)%ns > 0 ) THEN ALLOCATE( surf_usm_v(l)%rad_net(1:surf_usm_v(l)%ns) ) surf_usm_v(l)%rad_net = 0.0_wp ENDIF ENDDO ! !-- Allocate array for storing the surface longwave (out) radiation change IF ( .NOT. ALLOCATED ( surf_def_h(0)%rad_lw_out_change_0 ) .AND. & surf_def_h(0)%ns > 0 ) THEN ALLOCATE( surf_def_h(0)%rad_lw_out_change_0(1:surf_def_h(0)%ns) ) surf_def_h(0)%rad_lw_out_change_0 = 0.0_wp ENDIF IF ( .NOT. ALLOCATED ( surf_lsm_h%rad_lw_out_change_0 ) .AND. & surf_lsm_h%ns > 0 ) THEN ALLOCATE( surf_lsm_h%rad_lw_out_change_0(1:surf_lsm_h%ns) ) surf_lsm_h%rad_lw_out_change_0 = 0.0_wp ENDIF IF ( .NOT. ALLOCATED ( surf_usm_h%rad_lw_out_change_0 ) .AND. & surf_usm_h%ns > 0 ) THEN ALLOCATE( surf_usm_h%rad_lw_out_change_0(1:surf_usm_h%ns) ) surf_usm_h%rad_lw_out_change_0 = 0.0_wp ENDIF DO l = 0, 3 IF ( .NOT. ALLOCATED ( surf_def_v(l)%rad_lw_out_change_0 ) .AND. & surf_def_v(l)%ns > 0 ) THEN ALLOCATE( surf_def_v(l)%rad_lw_out_change_0(1:surf_def_v(l)%ns) ) surf_def_v(l)%rad_lw_out_change_0 = 0.0_wp ENDIF IF ( .NOT. ALLOCATED ( surf_lsm_v(l)%rad_lw_out_change_0 ) .AND. & surf_lsm_v(l)%ns > 0 ) THEN ALLOCATE( surf_lsm_v(l)%rad_lw_out_change_0(1:surf_lsm_v(l)%ns) ) surf_lsm_v(l)%rad_lw_out_change_0 = 0.0_wp ENDIF IF ( .NOT. ALLOCATED ( surf_usm_v(l)%rad_lw_out_change_0 ) .AND. & surf_usm_v(l)%ns > 0 ) THEN ALLOCATE( surf_usm_v(l)%rad_lw_out_change_0(1:surf_usm_v(l)%ns) ) surf_usm_v(l)%rad_lw_out_change_0 = 0.0_wp ENDIF ENDDO ! !-- Allocate surface arrays for incoming/outgoing short/longwave radiation IF ( .NOT. ALLOCATED ( surf_def_h(0)%rad_sw_in ) .AND. & surf_def_h(0)%ns > 0 ) THEN ALLOCATE( surf_def_h(0)%rad_sw_in(1:surf_def_h(0)%ns) ) ALLOCATE( surf_def_h(0)%rad_sw_out(1:surf_def_h(0)%ns) ) ALLOCATE( surf_def_h(0)%rad_lw_in(1:surf_def_h(0)%ns) ) ALLOCATE( surf_def_h(0)%rad_lw_out(1:surf_def_h(0)%ns) ) surf_def_h(0)%rad_sw_in = 0.0_wp surf_def_h(0)%rad_sw_out = 0.0_wp surf_def_h(0)%rad_lw_in = 0.0_wp surf_def_h(0)%rad_lw_out = 0.0_wp ENDIF IF ( .NOT. ALLOCATED ( surf_lsm_h%rad_sw_in ) .AND. & surf_lsm_h%ns > 0 ) THEN ALLOCATE( surf_lsm_h%rad_sw_in(1:surf_lsm_h%ns) ) ALLOCATE( surf_lsm_h%rad_sw_out(1:surf_lsm_h%ns) ) ALLOCATE( surf_lsm_h%rad_lw_in(1:surf_lsm_h%ns) ) ALLOCATE( surf_lsm_h%rad_lw_out(1:surf_lsm_h%ns) ) surf_lsm_h%rad_sw_in = 0.0_wp surf_lsm_h%rad_sw_out = 0.0_wp surf_lsm_h%rad_lw_in = 0.0_wp surf_lsm_h%rad_lw_out = 0.0_wp ENDIF IF ( .NOT. ALLOCATED ( surf_usm_h%rad_sw_in ) .AND. & surf_usm_h%ns > 0 ) THEN ALLOCATE( surf_usm_h%rad_sw_in(1:surf_usm_h%ns) ) ALLOCATE( surf_usm_h%rad_sw_out(1:surf_usm_h%ns) ) ALLOCATE( surf_usm_h%rad_lw_in(1:surf_usm_h%ns) ) ALLOCATE( surf_usm_h%rad_lw_out(1:surf_usm_h%ns) ) surf_usm_h%rad_sw_in = 0.0_wp surf_usm_h%rad_sw_out = 0.0_wp surf_usm_h%rad_lw_in = 0.0_wp surf_usm_h%rad_lw_out = 0.0_wp ENDIF DO l = 0, 3 IF ( .NOT. ALLOCATED ( surf_def_v(l)%rad_sw_in ) .AND. & surf_def_v(l)%ns > 0 ) THEN ALLOCATE( surf_def_v(l)%rad_sw_in(1:surf_def_v(l)%ns) ) ALLOCATE( surf_def_v(l)%rad_sw_out(1:surf_def_v(l)%ns) ) ALLOCATE( surf_def_v(l)%rad_lw_in(1:surf_def_v(l)%ns) ) ALLOCATE( surf_def_v(l)%rad_lw_out(1:surf_def_v(l)%ns) ) surf_def_v(l)%rad_sw_in = 0.0_wp surf_def_v(l)%rad_sw_out = 0.0_wp surf_def_v(l)%rad_lw_in = 0.0_wp surf_def_v(l)%rad_lw_out = 0.0_wp ENDIF IF ( .NOT. ALLOCATED ( surf_lsm_v(l)%rad_sw_in ) .AND. & surf_lsm_v(l)%ns > 0 ) THEN ALLOCATE( surf_lsm_v(l)%rad_sw_in(1:surf_lsm_v(l)%ns) ) ALLOCATE( surf_lsm_v(l)%rad_sw_out(1:surf_lsm_v(l)%ns) ) ALLOCATE( surf_lsm_v(l)%rad_lw_in(1:surf_lsm_v(l)%ns) ) ALLOCATE( surf_lsm_v(l)%rad_lw_out(1:surf_lsm_v(l)%ns) ) surf_lsm_v(l)%rad_sw_in = 0.0_wp surf_lsm_v(l)%rad_sw_out = 0.0_wp surf_lsm_v(l)%rad_lw_in = 0.0_wp surf_lsm_v(l)%rad_lw_out = 0.0_wp ENDIF IF ( .NOT. ALLOCATED ( surf_usm_v(l)%rad_sw_in ) .AND. & surf_usm_v(l)%ns > 0 ) THEN ALLOCATE( surf_usm_v(l)%rad_sw_in(1:surf_usm_v(l)%ns) ) ALLOCATE( surf_usm_v(l)%rad_sw_out(1:surf_usm_v(l)%ns) ) ALLOCATE( surf_usm_v(l)%rad_lw_in(1:surf_usm_v(l)%ns) ) ALLOCATE( surf_usm_v(l)%rad_lw_out(1:surf_usm_v(l)%ns) ) surf_usm_v(l)%rad_sw_in = 0.0_wp surf_usm_v(l)%rad_sw_out = 0.0_wp surf_usm_v(l)%rad_lw_in = 0.0_wp surf_usm_v(l)%rad_lw_out = 0.0_wp ENDIF ENDDO ! !-- If necessary, allocate surface attribute albedo_type. !-- Only for default-surfaces, In case urban- or land-surface scheme is !-- utilized, this has been already allocated. For default surfaces, !-- no tile approach between different surface fractions is considered, !-- so first dimension is allocated with zero. !-- Initialize them with namelist parameter. ALLOCATE ( surf_def_h(0)%albedo_type(0:0,1:surf_def_h(0)%ns) ) surf_def_h(0)%albedo_type = albedo_type DO l = 0, 3 ALLOCATE ( surf_def_v(l)%albedo_type(0:0,1:surf_def_v(l)%ns) ) surf_def_v(l)%albedo_type = albedo_type ENDDO ! !-- If available, overwrite albedo_type by values read from file. !-- Again, only required for default-type surfaces. IF ( albedo_type_f%from_file ) THEN DO i = nxl, nxr DO j = nys, nyn IF ( albedo_type_f%var(j,i) /= albedo_type_f%fill ) THEN DO m = surf_def_h(0)%start_index(j,i), & surf_def_h(0)%end_index(j,i) surf_def_h(0)%albedo_type(0,m) = albedo_type_f%var(j,i) ENDDO DO l = 0, 3 ioff = surf_def_v(l)%ioff joff = surf_def_v(l)%joff DO m = surf_def_v(l)%start_index(j,i), & surf_def_v(l)%end_index(j,i) surf_def_v(l)%albedo_type(0,m) = & albedo_type_f%var(j+joff,i+ioff) ENDDO ENDDO ENDIF ENDDO ENDDO ENDIF ! !-- If necessary, allocate surface attribute emissivity. !-- Only for default-type surfaces. In case urband- or !-- land-surface scheme is utilized, this has been already allocated. !-- Initialize them with namelist parameter. ALLOCATE ( surf_def_h(0)%emissivity(0:0,1:surf_def_h(0)%ns) ) surf_def_h(0)%emissivity = emissivity DO l = 0, 3 ALLOCATE ( surf_def_v(l)%emissivity(0:0,1:surf_def_v(l)%ns) ) ENDDO ! !-- Fix net radiation in case of radiation_scheme = 'constant' IF ( radiation_scheme == 'constant' ) THEN IF ( ALLOCATED( surf_def_h(0)%rad_net ) ) & surf_def_h(0)%rad_net = net_radiation IF ( ALLOCATED( surf_lsm_h%rad_net ) ) & surf_lsm_h%rad_net = net_radiation IF ( ALLOCATED( surf_usm_h%rad_net ) ) & surf_usm_h%rad_net = net_radiation ! !-- Todo: weight with inclination angle DO l = 0, 3 IF ( ALLOCATED( surf_def_v(l)%rad_net ) ) & surf_def_v(l)%rad_net = net_radiation IF ( ALLOCATED( surf_lsm_v(l)%rad_net ) ) & surf_lsm_v(l)%rad_net = net_radiation IF ( ALLOCATED( surf_usm_v(l)%rad_net ) ) & surf_usm_v(l)%rad_net = net_radiation ENDDO ! radiation = .FALSE. ! !-- Calculate orbital constants ELSE decl_1 = SIN(23.45_wp * pi / 180.0_wp) decl_2 = 2.0_wp * pi / 365.0_wp decl_3 = decl_2 * 81.0_wp lat = latitude * pi / 180.0_wp lon = longitude * pi / 180.0_wp ENDIF IF ( radiation_scheme == 'clear-sky' .OR. & radiation_scheme == 'constant') THEN ! !-- Allocate average arrays for incoming/outgoing short/longwave radiation IF ( .NOT. ALLOCATED ( rad_sw_in_av ) ) THEN ALLOCATE ( rad_sw_in_av(0:0,nysg:nyng,nxlg:nxrg) ) ENDIF IF ( .NOT. ALLOCATED ( rad_sw_out_av ) ) THEN ALLOCATE ( rad_sw_out_av(0:0,nysg:nyng,nxlg:nxrg) ) ENDIF IF ( .NOT. ALLOCATED ( rad_lw_in_av ) ) THEN ALLOCATE ( rad_lw_in_av(0:0,nysg:nyng,nxlg:nxrg) ) ENDIF IF ( .NOT. ALLOCATED ( rad_lw_out_av ) ) THEN ALLOCATE ( rad_lw_out_av(0:0,nysg:nyng,nxlg:nxrg) ) ENDIF ! !-- Allocate arrays for broadband albedo, and level 1 initialization !-- via namelist paramter. IF ( .NOT. ALLOCATED(surf_def_h(0)%albedo) ) & ALLOCATE( surf_def_h(0)%albedo(0:0,1:surf_def_h(0)%ns) ) IF ( .NOT. ALLOCATED(surf_lsm_h%albedo) ) & ALLOCATE( surf_lsm_h%albedo(0:2,1:surf_lsm_h%ns) ) IF ( .NOT. ALLOCATED(surf_usm_h%albedo) ) & ALLOCATE( surf_usm_h%albedo(0:2,1:surf_usm_h%ns) ) surf_def_h(0)%albedo = albedo surf_lsm_h%albedo = albedo surf_usm_h%albedo = albedo DO l = 0, 3 IF ( .NOT. ALLOCATED( surf_def_v(l)%albedo ) ) & ALLOCATE( surf_def_v(l)%albedo(0:0,1:surf_def_v(l)%ns) ) IF ( .NOT. ALLOCATED( surf_lsm_v(l)%albedo ) ) & ALLOCATE( surf_lsm_v(l)%albedo(0:2,1:surf_lsm_v(l)%ns) ) IF ( .NOT. ALLOCATED( surf_usm_v(l)%albedo ) ) & ALLOCATE( surf_usm_v(l)%albedo(0:2,1:surf_usm_v(l)%ns) ) surf_def_v(l)%albedo = albedo surf_lsm_v(l)%albedo = albedo surf_usm_v(l)%albedo = albedo ENDDO ! !-- Level 2 initialization of broadband albedo via given albedo_type. !-- Only if albedo_type is non-zero DO m = 1, surf_def_h(0)%ns IF ( surf_def_h(0)%albedo_type(0,m) /= 0 ) & surf_def_h(0)%albedo(0,m) = & albedo_pars(2,surf_def_h(0)%albedo_type(0,m)) ENDDO DO m = 1, surf_lsm_h%ns IF ( surf_lsm_h%albedo_type(0,m) /= 0 ) & surf_lsm_h%albedo(0,m) = & albedo_pars(2,surf_lsm_h%albedo_type(0,m)) IF ( surf_lsm_h%albedo_type(1,m) /= 0 ) & surf_lsm_h%albedo(1,m) = & albedo_pars(2,surf_lsm_h%albedo_type(1,m)) IF ( surf_lsm_h%albedo_type(2,m) /= 0 ) & surf_lsm_h%albedo(2,m) = & albedo_pars(2,surf_lsm_h%albedo_type(2,m)) ENDDO DO m = 1, surf_usm_h%ns IF ( surf_usm_h%albedo_type(0,m) /= 0 ) & surf_usm_h%albedo(0,m) = & albedo_pars(2,surf_usm_h%albedo_type(0,m)) IF ( surf_usm_h%albedo_type(1,m) /= 0 ) & surf_usm_h%albedo(1,m) = & albedo_pars(2,surf_usm_h%albedo_type(1,m)) IF ( surf_usm_h%albedo_type(2,m) /= 0 ) & surf_usm_h%albedo(2,m) = & albedo_pars(2,surf_usm_h%albedo_type(2,m)) ENDDO DO l = 0, 3 DO m = 1, surf_def_v(l)%ns IF ( surf_def_v(l)%albedo_type(0,m) /= 0 ) & surf_def_v(l)%albedo(0,m) = & albedo_pars(2,surf_def_v(l)%albedo_type(0,m)) ENDDO DO m = 1, surf_lsm_v(l)%ns IF ( surf_lsm_v(l)%albedo_type(0,m) /= 0 ) & surf_lsm_v(l)%albedo(0,m) = & albedo_pars(2,surf_lsm_v(l)%albedo_type(0,m)) IF ( surf_lsm_v(l)%albedo_type(1,m) /= 0 ) & surf_lsm_v(l)%albedo(1,m) = & albedo_pars(2,surf_lsm_v(l)%albedo_type(1,m)) IF ( surf_lsm_v(l)%albedo_type(2,m) /= 0 ) & surf_lsm_v(l)%albedo(2,m) = & albedo_pars(2,surf_lsm_v(l)%albedo_type(2,m)) ENDDO DO m = 1, surf_usm_v(l)%ns IF ( surf_usm_v(l)%albedo_type(0,m) /= 0 ) & surf_usm_v(l)%albedo(0,m) = & albedo_pars(2,surf_usm_v(l)%albedo_type(0,m)) IF ( surf_usm_v(l)%albedo_type(1,m) /= 0 ) & surf_usm_v(l)%albedo(1,m) = & albedo_pars(2,surf_usm_v(l)%albedo_type(1,m)) IF ( surf_usm_v(l)%albedo_type(2,m) /= 0 ) & surf_usm_v(l)%albedo(2,m) = & albedo_pars(2,surf_usm_v(l)%albedo_type(2,m)) ENDDO ENDDO ! !-- Level 3 initialization at grid points where albedo type is zero. !-- This case, albedo is taken from file. In case of constant radiation !-- or clear sky, only broadband albedo is given. IF ( albedo_pars_f%from_file ) THEN ! !-- Horizontal surfaces DO m = 1, surf_def_h(0)%ns i = surf_def_h(0)%i(m) j = surf_def_h(0)%j(m) IF ( albedo_pars_f%pars_xy(0,j,i) /= albedo_pars_f%fill .AND. & surf_def_h(0)%albedo_type(0,m) == 0 ) THEN surf_def_h(0)%albedo(0,m) = albedo_pars_f%pars_xy(0,j,i) ENDIF ENDDO DO m = 1, surf_lsm_h%ns i = surf_lsm_h%i(m) j = surf_lsm_h%j(m) IF ( albedo_pars_f%pars_xy(0,j,i) /= albedo_pars_f%fill ) THEN IF ( surf_lsm_h%albedo_type(0,m) == 0 ) & surf_lsm_h%albedo(0,m) = albedo_pars_f%pars_xy(0,j,i) IF ( surf_lsm_h%albedo_type(1,m) == 0 ) & surf_lsm_h%albedo(1,m) = albedo_pars_f%pars_xy(0,j,i) IF ( surf_lsm_h%albedo_type(2,m) == 0 ) & surf_lsm_h%albedo(2,m) = albedo_pars_f%pars_xy(0,j,i) ENDIF ENDDO DO m = 1, surf_usm_h%ns i = surf_usm_h%i(m) j = surf_usm_h%j(m) IF ( albedo_pars_f%pars_xy(0,j,i) /= albedo_pars_f%fill ) THEN IF ( surf_usm_h%albedo_type(0,m) == 0 ) & surf_usm_h%albedo(0,m) = albedo_pars_f%pars_xy(0,j,i) IF ( surf_usm_h%albedo_type(1,m) == 0 ) & surf_usm_h%albedo(1,m) = albedo_pars_f%pars_xy(0,j,i) IF ( surf_usm_h%albedo_type(2,m) == 0 ) & surf_usm_h%albedo(2,m) = albedo_pars_f%pars_xy(0,j,i) ENDIF ENDDO ! !-- Vertical surfaces DO l = 0, 3 ioff = surf_def_v(l)%ioff joff = surf_def_v(l)%joff DO m = 1, surf_def_v(l)%ns i = surf_def_v(l)%i(m) + ioff j = surf_def_v(l)%j(m) + joff IF ( albedo_pars_f%pars_xy(0,j,i) /= albedo_pars_f%fill .AND. & surf_def_v(l)%albedo_type(0,m) == 0 ) THEN surf_def_v(l)%albedo(0,m) = albedo_pars_f%pars_xy(0,j,i) ENDIF ENDDO ioff = surf_lsm_v(l)%ioff joff = surf_lsm_v(l)%joff DO m = 1, surf_lsm_v(l)%ns i = surf_lsm_v(l)%i(m) + ioff j = surf_lsm_v(l)%j(m) + joff IF ( albedo_pars_f%pars_xy(0,j,i) /= albedo_pars_f%fill ) THEN IF ( surf_lsm_v(l)%albedo_type(0,m) == 0 ) & surf_lsm_v(l)%albedo(1,m) = albedo_pars_f%pars_xy(0,j,i) IF ( surf_lsm_v(l)%albedo_type(1,m) == 0 ) & surf_lsm_v(l)%albedo(1,m) = albedo_pars_f%pars_xy(0,j,i) IF ( surf_lsm_v(l)%albedo_type(2,m) == 0 ) & surf_lsm_v(l)%albedo(2,m) = albedo_pars_f%pars_xy(0,j,i) ENDIF ENDDO ioff = surf_usm_v(l)%ioff joff = surf_usm_v(l)%joff DO m = 1, surf_usm_h%ns i = surf_usm_h%i(m) + joff j = surf_usm_h%j(m) + joff IF ( albedo_pars_f%pars_xy(0,j,i) /= albedo_pars_f%fill ) THEN IF ( surf_usm_v(l)%albedo_type(0,m) == 0 ) & surf_usm_v(l)%albedo(1,m) = albedo_pars_f%pars_xy(0,j,i) IF ( surf_usm_v(l)%albedo_type(1,m) == 0 ) & surf_usm_v(l)%albedo(1,m) = albedo_pars_f%pars_xy(0,j,i) IF ( surf_usm_v(l)%albedo_type(2,m) == 0 ) & surf_lsm_v(l)%albedo(2,m) = albedo_pars_f%pars_xy(0,j,i) ENDIF ENDDO ENDDO ENDIF ! !-- Initialization actions for RRTMG ELSEIF ( radiation_scheme == 'rrtmg' ) THEN #if defined ( __rrtmg ) ! !-- Allocate albedos for short/longwave radiation, horizontal surfaces. ALLOCATE ( surf_def_h(0)%aldif(1:surf_def_h(0)%ns) ) ALLOCATE ( surf_def_h(0)%aldir(1:surf_def_h(0)%ns) ) ALLOCATE ( surf_def_h(0)%asdif(1:surf_def_h(0)%ns) ) ALLOCATE ( surf_def_h(0)%asdir(1:surf_def_h(0)%ns) ) ALLOCATE ( surf_def_h(0)%rrtm_aldif(1:surf_def_h(0)%ns) ) ALLOCATE ( surf_def_h(0)%rrtm_aldir(1:surf_def_h(0)%ns) ) ALLOCATE ( surf_def_h(0)%rrtm_asdif(1:surf_def_h(0)%ns) ) ALLOCATE ( surf_def_h(0)%rrtm_asdir(1:surf_def_h(0)%ns) ) ALLOCATE ( surf_lsm_h%aldif(1:surf_lsm_h%ns) ) ALLOCATE ( surf_lsm_h%aldir(1:surf_lsm_h%ns) ) ALLOCATE ( surf_lsm_h%asdif(1:surf_lsm_h%ns) ) ALLOCATE ( surf_lsm_h%asdir(1:surf_lsm_h%ns) ) ALLOCATE ( surf_lsm_h%rrtm_aldif(1:surf_lsm_h%ns) ) ALLOCATE ( surf_lsm_h%rrtm_aldir(1:surf_lsm_h%ns) ) ALLOCATE ( surf_lsm_h%rrtm_asdif(1:surf_lsm_h%ns) ) ALLOCATE ( surf_lsm_h%rrtm_asdir(1:surf_lsm_h%ns) ) ALLOCATE ( surf_usm_h%aldif(1:surf_usm_h%ns) ) ALLOCATE ( surf_usm_h%aldir(1:surf_usm_h%ns) ) ALLOCATE ( surf_usm_h%asdif(1:surf_usm_h%ns) ) ALLOCATE ( surf_usm_h%asdir(1:surf_usm_h%ns) ) ALLOCATE ( surf_usm_h%rrtm_aldif(1:surf_usm_h%ns) ) ALLOCATE ( surf_usm_h%rrtm_aldir(1:surf_usm_h%ns) ) ALLOCATE ( surf_usm_h%rrtm_asdif(1:surf_usm_h%ns) ) ALLOCATE ( surf_usm_h%rrtm_asdir(1:surf_usm_h%ns) ) ! !-- Allocate broadband albedo (temporary for the current radiation !-- implementations) IF ( .NOT. ALLOCATED(surf_def_h(0)%albedo) ) & ALLOCATE( surf_def_h(0)%albedo(0:0,1:surf_def_h(0)%ns) ) IF ( .NOT. ALLOCATED(surf_lsm_h%albedo) ) & ALLOCATE( surf_lsm_h%albedo(0:2,1:surf_lsm_h%ns) ) IF ( .NOT. ALLOCATED(surf_usm_h%albedo) ) & ALLOCATE( surf_usm_h%albedo(0:2,1:surf_usm_h%ns) ) ! !-- Allocate albedos for short/longwave radiation, vertical surfaces DO l = 0, 3 ALLOCATE ( surf_def_v(l)%aldif(1:surf_def_v(l)%ns) ) ALLOCATE ( surf_def_v(l)%aldir(1:surf_def_v(l)%ns) ) ALLOCATE ( surf_def_v(l)%asdif(1:surf_def_v(l)%ns) ) ALLOCATE ( surf_def_v(l)%asdir(1:surf_def_v(l)%ns) ) ALLOCATE ( surf_def_v(l)%rrtm_aldif(1:surf_def_v(l)%ns) ) ALLOCATE ( surf_def_v(l)%rrtm_aldir(1:surf_def_v(l)%ns) ) ALLOCATE ( surf_def_v(l)%rrtm_asdif(1:surf_def_v(l)%ns) ) ALLOCATE ( surf_def_v(l)%rrtm_asdir(1:surf_def_v(l)%ns) ) ALLOCATE ( surf_lsm_v(l)%aldif(1:surf_lsm_v(l)%ns) ) ALLOCATE ( surf_lsm_v(l)%aldir(1:surf_lsm_v(l)%ns) ) ALLOCATE ( surf_lsm_v(l)%asdif(1:surf_lsm_v(l)%ns) ) ALLOCATE ( surf_lsm_v(l)%asdir(1:surf_lsm_v(l)%ns) ) ALLOCATE ( surf_lsm_v(l)%rrtm_aldif(1:surf_lsm_v(l)%ns) ) ALLOCATE ( surf_lsm_v(l)%rrtm_aldir(1:surf_lsm_v(l)%ns) ) ALLOCATE ( surf_lsm_v(l)%rrtm_asdif(1:surf_lsm_v(l)%ns) ) ALLOCATE ( surf_lsm_v(l)%rrtm_asdir(1:surf_lsm_v(l)%ns) ) ALLOCATE ( surf_usm_v(l)%aldif(1:surf_usm_v(l)%ns) ) ALLOCATE ( surf_usm_v(l)%aldir(1:surf_usm_v(l)%ns) ) ALLOCATE ( surf_usm_v(l)%asdif(1:surf_usm_v(l)%ns) ) ALLOCATE ( surf_usm_v(l)%asdir(1:surf_usm_v(l)%ns) ) ALLOCATE ( surf_usm_v(l)%rrtm_aldif(1:surf_usm_v(l)%ns) ) ALLOCATE ( surf_usm_v(l)%rrtm_aldir(1:surf_usm_v(l)%ns) ) ALLOCATE ( surf_usm_v(l)%rrtm_asdif(1:surf_usm_v(l)%ns) ) ALLOCATE ( surf_usm_v(l)%rrtm_asdir(1:surf_usm_v(l)%ns) ) ! !-- Allocate broadband albedo (temporary for the current radiation !-- implementations) IF ( .NOT. ALLOCATED( surf_def_v(l)%albedo ) ) & ALLOCATE( surf_def_v(l)%albedo(0,1:surf_def_v(l)%ns) ) IF ( .NOT. ALLOCATED( surf_lsm_v(l)%albedo ) ) & ALLOCATE( surf_lsm_v(l)%albedo(0:2,1:surf_lsm_v(l)%ns) ) IF ( .NOT. ALLOCATED( surf_usm_v(l)%albedo ) ) & ALLOCATE( surf_usm_v(l)%albedo(0:2,1:surf_usm_v(l)%ns) ) ENDDO ! !-- Level 1 initialization of spectral albedos via namelist !-- paramters IF ( surf_def_h(0)%ns > 0 ) THEN surf_def_h(0)%aldif = albedo_lw_dif surf_def_h(0)%aldir = albedo_lw_dir surf_def_h(0)%asdif = albedo_sw_dif surf_def_h(0)%asdir = albedo_sw_dir surf_def_h(0)%albedo = albedo_sw_dif ENDIF IF ( surf_lsm_h%ns > 0 ) THEN surf_lsm_h%aldif = albedo_lw_dif surf_lsm_h%aldir = albedo_lw_dir surf_lsm_h%asdif = albedo_sw_dif surf_lsm_h%asdir = albedo_sw_dir surf_lsm_h%albedo = albedo_sw_dif ENDIF IF ( surf_usm_h%ns > 0 ) THEN surf_usm_h%aldif = albedo_lw_dif surf_usm_h%aldir = albedo_lw_dir surf_usm_h%asdif = albedo_sw_dif surf_usm_h%asdir = albedo_sw_dir surf_usm_h%albedo = albedo_sw_dif ENDIF DO l = 0, 3 IF ( surf_def_v(l)%ns > 0 ) THEN surf_def_v(l)%aldif = albedo_lw_dif surf_def_v(l)%aldir = albedo_lw_dir surf_def_v(l)%asdif = albedo_sw_dif surf_def_v(l)%asdir = albedo_sw_dir surf_def_v(l)%albedo = albedo_sw_dif ENDIF IF ( surf_lsm_v(l)%ns > 0 ) THEN surf_lsm_v(l)%aldif = albedo_lw_dif surf_lsm_v(l)%aldir = albedo_lw_dir surf_lsm_v(l)%asdif = albedo_sw_dif surf_lsm_v(l)%asdir = albedo_sw_dir surf_lsm_v(l)%albedo = albedo_sw_dif ENDIF IF ( surf_usm_v(l)%ns > 0 ) THEN surf_usm_v(l)%aldif = albedo_lw_dif surf_usm_v(l)%aldir = albedo_lw_dir surf_usm_v(l)%asdif = albedo_sw_dif surf_usm_v(l)%asdir = albedo_sw_dir surf_usm_v(l)%albedo = albedo_sw_dif ENDIF ENDDO ! !-- Level 2 initialization of spectral albedos via albedo_type. !-- Only diffusive albedos (why?) DO m = 1, surf_def_h(0)%ns IF ( surf_def_h(0)%albedo_type(0,m) /= 0 ) THEN surf_def_h(0)%aldif(m) = & albedo_pars(0,surf_def_h(0)%albedo_type(0,m)) surf_def_h(0)%asdif(m) = & albedo_pars(1,surf_def_h(0)%albedo_type(0,m)) surf_def_h(0)%aldir(m) = & albedo_pars(0,surf_def_h(0)%albedo_type(0,m)) surf_def_h(0)%asdir(m) = & albedo_pars(1,surf_def_h(0)%albedo_type(0,m)) surf_def_h(0)%albedo(0,m) = & albedo_pars(2,surf_def_h(0)%albedo_type(0,m)) ENDIF ENDDO DO m = 1, surf_lsm_h%ns ! !-- Determine surface type IF ( surf_lsm_h%vegetation_surface(m) ) ind_type = 0 IF ( surf_lsm_h%pavement_surface(m) ) ind_type = 1 IF ( surf_lsm_h%water_surface(m) ) ind_type = 2 IF ( surf_lsm_h%albedo_type(ind_type,m) /= 0 ) THEN surf_lsm_h%aldif(m) = & albedo_pars(0,surf_lsm_h%albedo_type(ind_type,m)) surf_lsm_h%asdif(m) = & albedo_pars(1,surf_lsm_h%albedo_type(ind_type,m)) surf_lsm_h%aldir(m) = & albedo_pars(0,surf_lsm_h%albedo_type(ind_type,m)) surf_lsm_h%asdir(m) = & albedo_pars(1,surf_lsm_h%albedo_type(ind_type,m)) surf_lsm_h%albedo(:,m) = & albedo_pars(2,surf_lsm_h%albedo_type(ind_type,m)) ENDIF ENDDO DO m = 1, surf_usm_h%ns ! !-- Initialize spectral albedos for urban-type surfaces. Please note, !-- for urban surfaces a tile approach is applied, so that the !-- resulting albedo should be calculated via the weighted average of !-- respective surface fractions. However, for the moment the albedo !-- is set to the wall-surface value. IF ( surf_usm_h%albedo_type(0,m) /= 0 ) THEN surf_usm_h%aldif(m) = & albedo_pars(0,surf_usm_h%albedo_type(0,m)) surf_usm_h%asdif(m) = & albedo_pars(1,surf_usm_h%albedo_type(0,m)) surf_usm_h%aldir(m) = & albedo_pars(0,surf_usm_h%albedo_type(0,m)) surf_usm_h%asdir(m) = & albedo_pars(1,surf_usm_h%albedo_type(0,m)) surf_usm_h%albedo(:,m) = & albedo_pars(2,surf_usm_h%albedo_type(0,m)) ENDIF ENDDO DO l = 0, 3 DO m = 1, surf_def_v(l)%ns IF ( surf_def_v(l)%albedo_type(0,m) /= 0 ) THEN surf_def_v(l)%aldif(m) = & albedo_pars(0,surf_def_v(l)%albedo_type(0,m)) surf_def_v(l)%asdif(m) = & albedo_pars(1,surf_def_v(l)%albedo_type(0,m)) surf_def_v(l)%aldir(m) = & albedo_pars(0,surf_def_v(l)%albedo_type(0,m)) surf_def_v(l)%asdir(m) = & albedo_pars(1,surf_def_v(l)%albedo_type(0,m)) surf_def_v(l)%albedo(:,m) = & albedo_pars(2,surf_def_v(l)%albedo_type(0,m)) ENDIF ENDDO DO m = 1, surf_lsm_v(l)%ns IF ( surf_lsm_v(l)%vegetation_surface(m) ) ind_type = 0 IF ( surf_lsm_v(l)%pavement_surface(m) ) ind_type = 1 IF ( surf_lsm_v(l)%water_surface(m) ) ind_type = 2 IF ( surf_lsm_v(l)%albedo_type(0,m) /= 0 ) THEN surf_lsm_v(l)%aldif(m) = & albedo_pars(0,surf_lsm_v(l)%albedo_type(ind_type,m)) surf_lsm_v(l)%asdif(m) = & albedo_pars(1,surf_lsm_v(l)%albedo_type(ind_type,m)) surf_lsm_v(l)%aldir(m) = & albedo_pars(0,surf_lsm_v(l)%albedo_type(ind_type,m)) surf_lsm_v(l)%asdir(m) = & albedo_pars(1,surf_lsm_v(l)%albedo_type(ind_type,m)) surf_lsm_v(l)%albedo(:,m) = & albedo_pars(2,surf_lsm_v(l)%albedo_type(ind_type,m)) ENDIF ENDDO DO m = 1, surf_usm_v(l)%ns ! !-- Initialize spectral albedos for urban-type surfaces. Please note, !-- for urban surfaces a tile approach is applied, so that the !-- resulting albedo should be calculated via the weighted average of !-- respective surface fractions. However, for the moment the albedo !-- is set to the wall-surface value. IF ( surf_usm_v(l)%albedo_type(0,m) /= 0 ) THEN surf_usm_v(l)%aldif(m) = & albedo_pars(0,surf_usm_v(l)%albedo_type(0,m)) surf_usm_v(l)%asdif(m) = & albedo_pars(1,surf_usm_v(l)%albedo_type(0,m)) surf_usm_v(l)%aldir(m) = & albedo_pars(0,surf_usm_v(l)%albedo_type(0,m)) surf_usm_v(l)%asdir(m) = & albedo_pars(1,surf_usm_v(l)%albedo_type(0,m)) surf_usm_v(l)%albedo(:,m) = & albedo_pars(2,surf_usm_v(l)%albedo_type(0,m)) ENDIF ENDDO ENDDO ! !-- Level 3 initialization at grid points where albedo type is zero. !-- This case, spectral albedos are taken from file if available IF ( albedo_pars_f%from_file ) THEN ! !-- Horizontal DO m = 1, surf_def_h(0)%ns i = surf_def_h(0)%i(m) j = surf_def_h(0)%j(m) IF ( surf_def_h(0)%albedo_type(0,m) == 0 ) THEN IF ( albedo_pars_f%pars_xy(1,j,i) /= albedo_pars_f%fill ) & surf_def_h(0)%albedo(0,m) = albedo_pars_f%pars_xy(1,j,i) IF ( albedo_pars_f%pars_xy(1,j,i) /= albedo_pars_f%fill ) & surf_def_h(0)%aldir(m) = albedo_pars_f%pars_xy(1,j,i) IF ( albedo_pars_f%pars_xy(2,j,i) /= albedo_pars_f%fill ) & surf_def_h(0)%aldif(m) = albedo_pars_f%pars_xy(2,j,i) IF ( albedo_pars_f%pars_xy(3,j,i) /= albedo_pars_f%fill ) & surf_def_h(0)%asdir(m) = albedo_pars_f%pars_xy(3,j,i) IF ( albedo_pars_f%pars_xy(4,j,i) /= albedo_pars_f%fill ) & surf_def_h(0)%asdif(m) = albedo_pars_f%pars_xy(4,j,i) ENDIF ENDDO DO m = 1, surf_lsm_h%ns i = surf_lsm_h%i(m) j = surf_lsm_h%j(m) IF ( surf_lsm_h%vegetation_surface(m) ) ind_type = 0 IF ( surf_lsm_h%pavement_surface(m) ) ind_type = 1 IF ( surf_lsm_h%water_surface(m) ) ind_type = 2 IF ( surf_lsm_h%albedo_type(ind_type,m) == 0 ) THEN IF ( albedo_pars_f%pars_xy(1,j,i) /= albedo_pars_f%fill ) & surf_lsm_h%albedo(ind_type,m) = albedo_pars_f%pars_xy(1,j,i) IF ( albedo_pars_f%pars_xy(1,j,i) /= albedo_pars_f%fill ) & surf_lsm_h%aldir(m) = albedo_pars_f%pars_xy(1,j,i) IF ( albedo_pars_f%pars_xy(2,j,i) /= albedo_pars_f%fill ) & surf_lsm_h%aldif(m) = albedo_pars_f%pars_xy(2,j,i) IF ( albedo_pars_f%pars_xy(3,j,i) /= albedo_pars_f%fill ) & surf_lsm_h%asdir(m) = albedo_pars_f%pars_xy(3,j,i) IF ( albedo_pars_f%pars_xy(4,j,i) /= albedo_pars_f%fill ) & surf_lsm_h%asdif(m) = albedo_pars_f%pars_xy(4,j,i) ENDIF ENDDO DO m = 1, surf_usm_h%ns i = surf_usm_h%i(m) j = surf_usm_h%j(m) ! !-- At the moment, consider only wall surfaces (index 0) IF ( surf_usm_h%albedo_type(0,m) == 0 ) THEN IF ( albedo_pars_f%pars_xy(1,j,i) /= albedo_pars_f%fill ) & surf_usm_h%albedo(:,m) = albedo_pars_f%pars_xy(1,j,i) IF ( albedo_pars_f%pars_xy(1,j,i) /= albedo_pars_f%fill ) & surf_usm_h%aldir(m) = albedo_pars_f%pars_xy(1,j,i) IF ( albedo_pars_f%pars_xy(2,j,i) /= albedo_pars_f%fill ) & surf_usm_h%aldif(m) = albedo_pars_f%pars_xy(2,j,i) IF ( albedo_pars_f%pars_xy(3,j,i) /= albedo_pars_f%fill ) & surf_usm_h%asdir(m) = albedo_pars_f%pars_xy(3,j,i) IF ( albedo_pars_f%pars_xy(4,j,i) /= albedo_pars_f%fill ) & surf_usm_h%asdif(m) = albedo_pars_f%pars_xy(4,j,i) ENDIF ENDDO ! !-- Vertical DO l = 0, 3 ioff = surf_def_v(l)%ioff joff = surf_def_v(l)%joff DO m = 1, surf_def_v(l)%ns i = surf_def_v(l)%i(m) j = surf_def_v(l)%j(m) IF ( surf_def_v(l)%albedo_type(0,m) == 0 ) THEN IF ( albedo_pars_f%pars_xy(1,j+joff,i+ioff) /= & albedo_pars_f%fill ) & surf_def_v(l)%albedo(0,m) = & albedo_pars_f%pars_xy(1,j+joff,i+ioff) IF ( albedo_pars_f%pars_xy(1,j+joff,i+ioff) /= & albedo_pars_f%fill ) & surf_def_v(l)%aldir(m) = & albedo_pars_f%pars_xy(1,j+joff,i+ioff) IF ( albedo_pars_f%pars_xy(2,j+joff,i+ioff) /= & albedo_pars_f%fill ) & surf_def_v(l)%aldif(m) = & albedo_pars_f%pars_xy(2,j+joff,i+ioff) IF ( albedo_pars_f%pars_xy(3,j+joff,i+ioff) /= & albedo_pars_f%fill ) & surf_def_v(l)%asdir(m) = & albedo_pars_f%pars_xy(3,j+joff,i+ioff) IF ( albedo_pars_f%pars_xy(4,j+joff,i+ioff) /= & albedo_pars_f%fill ) & surf_def_v(l)%asdif(m) = & albedo_pars_f%pars_xy(4,j+joff,i+ioff) ENDIF ENDDO ioff = surf_lsm_v(l)%ioff joff = surf_lsm_v(l)%joff DO m = 1, surf_lsm_v(l)%ns i = surf_lsm_v(l)%i(m) j = surf_lsm_v(l)%j(m) IF ( surf_lsm_v(l)%vegetation_surface(m) ) ind_type = 0 IF ( surf_lsm_v(l)%pavement_surface(m) ) ind_type = 1 IF ( surf_lsm_v(l)%water_surface(m) ) ind_type = 2 IF ( surf_lsm_v(l)%albedo_type(ind_type,m) == 0 ) THEN IF ( albedo_pars_f%pars_xy(1,j+joff,i+ioff) /= & albedo_pars_f%fill ) & surf_lsm_v(l)%albedo(:,m) = & albedo_pars_f%pars_xy(1,j+joff,i+ioff) IF ( albedo_pars_f%pars_xy(1,j+joff,i+ioff) /= & albedo_pars_f%fill ) & surf_lsm_v(l)%aldir(m) = & albedo_pars_f%pars_xy(1,j+joff,i+ioff) IF ( albedo_pars_f%pars_xy(2,j+joff,i+ioff) /= & albedo_pars_f%fill ) & surf_lsm_v(l)%aldif(m) = & albedo_pars_f%pars_xy(2,j+joff,i+ioff) IF ( albedo_pars_f%pars_xy(3,j+joff,i+ioff) /= & albedo_pars_f%fill ) & surf_lsm_v(l)%asdir(m) = & albedo_pars_f%pars_xy(3,j+joff,i+ioff) IF ( albedo_pars_f%pars_xy(4,j+joff,i+ioff) /= & albedo_pars_f%fill ) & surf_lsm_v(l)%asdif(m) = & albedo_pars_f%pars_xy(4,j+joff,i+ioff) ENDIF ENDDO ioff = surf_usm_v(l)%ioff joff = surf_usm_v(l)%joff DO m = 1, surf_usm_v(l)%ns i = surf_usm_v(l)%i(m) j = surf_usm_v(l)%j(m) !-- At the moment, consider only wall surfaces (index 0) IF ( surf_usm_v(l)%albedo_type(0,m) == 0 ) THEN IF ( albedo_pars_f%pars_xy(1,j+joff,i+ioff) /= & albedo_pars_f%fill ) & surf_usm_v(l)%albedo(:,m) = & albedo_pars_f%pars_xy(1,j+joff,i+ioff) IF ( albedo_pars_f%pars_xy(1,j+joff,i+ioff) /= & albedo_pars_f%fill ) & surf_usm_v(l)%aldir(m) = & albedo_pars_f%pars_xy(1,j+joff,i+ioff) IF ( albedo_pars_f%pars_xy(2,j+joff,i+ioff) /= & albedo_pars_f%fill ) & surf_usm_v(l)%aldif(m) = & albedo_pars_f%pars_xy(2,j+joff,i+ioff) IF ( albedo_pars_f%pars_xy(3,j+joff,i+ioff) /= & albedo_pars_f%fill ) & surf_usm_v(l)%asdir(m) = & albedo_pars_f%pars_xy(3,j+joff,i+ioff) IF ( albedo_pars_f%pars_xy(4,j+joff,i+ioff) /= & albedo_pars_f%fill ) & surf_usm_v(l)%asdif(m) = & albedo_pars_f%pars_xy(4,j+joff,i+ioff) ENDIF ENDDO ENDDO ENDIF ! !-- Calculate initial values of current (cosine of) the zenith angle and !-- whether the sun is up CALL calc_zenith ! !-- Calculate initial surface albedo for different surfaces IF ( .NOT. constant_albedo ) THEN ! !-- Horizontally aligned default, natural and urban surfaces CALL calc_albedo( surf_def_h(0) ) CALL calc_albedo( surf_lsm_h ) CALL calc_albedo( surf_usm_h ) ! !-- Vertically aligned default, natural and urban surfaces DO l = 0, 3 CALL calc_albedo( surf_def_v(l) ) CALL calc_albedo( surf_lsm_v(l) ) CALL calc_albedo( surf_usm_v(l) ) ENDDO ELSE ! !-- Initialize sun-inclination independent spectral albedos !-- Horizontal surfaces IF ( surf_def_h(0)%ns > 0 ) THEN surf_def_h(0)%rrtm_aldir = surf_def_h(0)%aldir surf_def_h(0)%rrtm_asdir = surf_def_h(0)%asdir surf_def_h(0)%rrtm_aldif = surf_def_h(0)%aldif surf_def_h(0)%rrtm_asdif = surf_def_h(0)%asdif ENDIF IF ( surf_lsm_h%ns > 0 ) THEN surf_lsm_h%rrtm_aldir = surf_lsm_h%aldir surf_lsm_h%rrtm_asdir = surf_lsm_h%asdir surf_lsm_h%rrtm_aldif = surf_lsm_h%aldif surf_lsm_h%rrtm_asdif = surf_lsm_h%asdif ENDIF IF ( surf_usm_h%ns > 0 ) THEN surf_usm_h%rrtm_aldir = surf_usm_h%aldir surf_usm_h%rrtm_asdir = surf_usm_h%asdir surf_usm_h%rrtm_aldif = surf_usm_h%aldif surf_usm_h%rrtm_asdif = surf_usm_h%asdif ENDIF ! !-- Vertical surfaces DO l = 0, 3 IF ( surf_def_h(0)%ns > 0 ) THEN surf_def_v(l)%rrtm_aldir = surf_def_v(l)%aldir surf_def_v(l)%rrtm_asdir = surf_def_v(l)%asdir surf_def_v(l)%rrtm_aldif = surf_def_v(l)%aldif surf_def_v(l)%rrtm_asdif = surf_def_v(l)%asdif ENDIF IF ( surf_lsm_v(l)%ns > 0 ) THEN surf_lsm_v(l)%rrtm_aldir = surf_lsm_v(l)%aldir surf_lsm_v(l)%rrtm_asdir = surf_lsm_v(l)%asdir surf_lsm_v(l)%rrtm_aldif = surf_lsm_v(l)%aldif surf_lsm_v(l)%rrtm_asdif = surf_lsm_v(l)%asdif ENDIF IF ( surf_usm_v(l)%ns > 0 ) THEN surf_usm_v(l)%rrtm_aldir = surf_usm_v(l)%aldir surf_usm_v(l)%rrtm_asdir = surf_usm_v(l)%asdir surf_usm_v(l)%rrtm_aldif = surf_usm_v(l)%aldif surf_usm_v(l)%rrtm_asdif = surf_usm_v(l)%asdif ENDIF ENDDO ENDIF ! !-- Allocate 3d arrays of radiative fluxes and heating rates IF ( .NOT. ALLOCATED ( rad_sw_in ) ) THEN ALLOCATE ( rad_sw_in(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) rad_sw_in = 0.0_wp ENDIF IF ( .NOT. ALLOCATED ( rad_sw_in_av ) ) THEN ALLOCATE ( rad_sw_in_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) ENDIF IF ( .NOT. ALLOCATED ( rad_sw_out ) ) THEN ALLOCATE ( rad_sw_out(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) rad_sw_out = 0.0_wp ENDIF IF ( .NOT. ALLOCATED ( rad_sw_out_av ) ) THEN ALLOCATE ( rad_sw_out_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) ENDIF IF ( .NOT. ALLOCATED ( rad_sw_hr ) ) THEN ALLOCATE ( rad_sw_hr(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) rad_sw_hr = 0.0_wp ENDIF IF ( .NOT. ALLOCATED ( rad_sw_hr_av ) ) THEN ALLOCATE ( rad_sw_hr_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) rad_sw_hr_av = 0.0_wp ENDIF IF ( .NOT. ALLOCATED ( rad_sw_cs_hr ) ) THEN ALLOCATE ( rad_sw_cs_hr(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) rad_sw_cs_hr = 0.0_wp ENDIF IF ( .NOT. ALLOCATED ( rad_sw_cs_hr_av ) ) THEN ALLOCATE ( rad_sw_cs_hr_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) rad_sw_cs_hr_av = 0.0_wp ENDIF IF ( .NOT. ALLOCATED ( rad_lw_in ) ) THEN ALLOCATE ( rad_lw_in(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) rad_lw_in = 0.0_wp ENDIF IF ( .NOT. ALLOCATED ( rad_lw_in_av ) ) THEN ALLOCATE ( rad_lw_in_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) ENDIF IF ( .NOT. ALLOCATED ( rad_lw_out ) ) THEN ALLOCATE ( rad_lw_out(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) rad_lw_out = 0.0_wp ENDIF IF ( .NOT. ALLOCATED ( rad_lw_out_av ) ) THEN ALLOCATE ( rad_lw_out_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) ENDIF IF ( .NOT. ALLOCATED ( rad_lw_hr ) ) THEN ALLOCATE ( rad_lw_hr(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) rad_lw_hr = 0.0_wp ENDIF IF ( .NOT. ALLOCATED ( rad_lw_hr_av ) ) THEN ALLOCATE ( rad_lw_hr_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) rad_lw_hr_av = 0.0_wp ENDIF IF ( .NOT. ALLOCATED ( rad_lw_cs_hr ) ) THEN ALLOCATE ( rad_lw_cs_hr(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) rad_lw_cs_hr = 0.0_wp ENDIF IF ( .NOT. ALLOCATED ( rad_lw_cs_hr_av ) ) THEN ALLOCATE ( rad_lw_cs_hr_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) rad_lw_cs_hr_av = 0.0_wp ENDIF ALLOCATE ( rad_sw_cs_in(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) ALLOCATE ( rad_sw_cs_out(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) rad_sw_cs_in = 0.0_wp rad_sw_cs_out = 0.0_wp ALLOCATE ( rad_lw_cs_in(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) ALLOCATE ( rad_lw_cs_out(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) rad_lw_cs_in = 0.0_wp rad_lw_cs_out = 0.0_wp ! !-- Allocate 1-element array for surface temperature !-- (RRTMG anticipates an array as passed argument). ALLOCATE ( rrtm_tsfc(1) ) ! !-- Allocate surface emissivity. !-- Values will be given directly before calling rrtm_lw. ALLOCATE ( rrtm_emis(0:0,1:nbndlw+1) ) ! !-- Initialize RRTMG IF ( lw_radiation ) CALL rrtmg_lw_ini ( cp ) IF ( sw_radiation ) CALL rrtmg_sw_ini ( cp ) ! !-- Set input files for RRTMG INQUIRE(FILE="RAD_SND_DATA", EXIST=snd_exists) IF ( .NOT. snd_exists ) THEN rrtm_input_file = "rrtmg_lw.nc" ENDIF ! !-- Read vertical layers for RRTMG from sounding data !-- The routine provides nzt_rad, hyp_snd(1:nzt_rad), !-- t_snd(nzt+2:nzt_rad), rrtm_play(1:nzt_rad), rrtm_plev(1_nzt_rad+1), !-- rrtm_tlay(nzt+2:nzt_rad), rrtm_tlev(nzt+2:nzt_rad+1) CALL read_sounding_data ! !-- Read trace gas profiles from file. This routine provides !-- the rrtm_ arrays (1:nzt_rad+1) CALL read_trace_gas_data #endif ENDIF ! !-- Perform user actions if required CALL user_init_radiation ! !-- Calculate radiative fluxes at model start IF ( TRIM( initializing_actions ) /= 'read_restart_data' ) THEN SELECT CASE ( radiation_scheme ) CASE ( 'rrtmg' ) CALL radiation_rrtmg CASE ( 'clear-sky' ) CALL radiation_clearsky CASE ( 'constant' ) CALL radiation_constant CASE DEFAULT END SELECT ENDIF RETURN END SUBROUTINE radiation_init !------------------------------------------------------------------------------! ! Description: ! ------------ !> A simple clear sky radiation model !------------------------------------------------------------------------------! SUBROUTINE radiation_clearsky IMPLICIT NONE INTEGER(iwp) :: l !< running index for surface orientation REAL(wp) :: exn !< Exner functions at surface REAL(wp) :: exn1 !< Exner functions at first grid level or at urban layer top REAL(wp) :: pt1 !< potential temperature at first grid level or mean value at urban layer top REAL(wp) :: pt1_l !< potential temperature at first grid level or mean value at urban layer top at local subdomain REAL(wp) :: ql1 !< liquid water mixing ratio at first grid level or mean value at urban layer top REAL(wp) :: ql1_l !< liquid water mixing ratio at first grid level or mean value at urban layer top at local subdomain TYPE(surf_type), POINTER :: surf !< pointer on respective surface type, used to generalize routine ! !-- Calculate current zenith angle CALL calc_zenith ! !-- Calculate sky transmissivity sky_trans = 0.6_wp + 0.2_wp * zenith(0) ! !-- Calculate value of the Exner function at model surface exn = (surface_pressure / 1000.0_wp )**0.286_wp ! !-- In case averaged radiation is used, calculate mean temperature and !-- liquid water mixing ratio at the urban-layer top. IF ( average_radiation ) THEN pt1 = 0.0_wp IF ( cloud_physics ) ql1 = 0.0_wp pt1_l = SUM( pt(nzut,nys:nyn,nxl:nxr) ) IF ( cloud_physics ) ql1_l = SUM( ql(nzut,nys:nyn,nxl:nxr) ) #if defined( __parallel ) IF ( collective_wait ) CALL MPI_BARRIER( comm2d, ierr ) CALL MPI_ALLREDUCE( pt1_l, pt1, 1, MPI_REAL, MPI_SUM, comm2d, ierr ) IF ( cloud_physics ) & CALL MPI_ALLREDUCE( ql1_l, ql1, 1, MPI_REAL, MPI_SUM, comm2d, ierr ) #else pt1 = pt1_l IF ( cloud_physics ) ql1 = ql1_l #endif exn1 = ( hyp(nzut) / 100000.0_wp )**0.286_wp IF ( cloud_physics ) pt1 = pt1 + l_d_cp / exn1 * ql1 ! !-- Finally, divide by number of grid points pt1 = pt1 / REAL( ( nx + 1 ) * ( ny + 1 ), KIND=wp ) ENDIF ! !-- Call clear-sky calculation for each surface orientation. !-- First, horizontal surfaces surf => surf_def_h(0) CALL radiation_clearsky_surf surf => surf_lsm_h CALL radiation_clearsky_surf surf => surf_usm_h CALL radiation_clearsky_surf ! !-- Vertical surfaces DO l = 0, 3 surf => surf_def_v(l) CALL radiation_clearsky_surf surf => surf_lsm_v(l) CALL radiation_clearsky_surf surf => surf_usm_v(l) CALL radiation_clearsky_surf ENDDO CONTAINS SUBROUTINE radiation_clearsky_surf IMPLICIT NONE INTEGER(iwp) :: i !< index x-direction INTEGER(iwp) :: ioff !< offset between surface element and adjacent grid point along x INTEGER(iwp) :: j !< index y-direction INTEGER(iwp) :: joff !< offset between surface element and adjacent grid point along y INTEGER(iwp) :: k !< index z-direction INTEGER(iwp) :: koff !< offset between surface element and adjacent grid point along z INTEGER(iwp) :: m !< running index for surface elements IF ( surf%ns < 1 ) RETURN ! !-- Calculate radiation fluxes and net radiation (rad_net) assuming !-- homogeneous urban radiation conditions. IF ( average_radiation ) THEN k = nzut ! !-- MS: Why k+1 ? !-- MS: @Mohamed: emissivity belongs now to surface type with 3 different values for each !-- surface element (due to tile approach). exn1 = ( hyp(k+1) / 100000.0_wp )**0.286_wp surf%rad_sw_in = solar_constant * sky_trans * zenith(0) surf%rad_sw_out = albedo_urb * surf%rad_sw_in surf%rad_lw_in = 0.8_wp * sigma_sb * (pt1 * exn1)**4 surf%rad_lw_out = emissivity_urb * sigma_sb * (t_rad_urb)**4 & + (1.0_wp - emissivity_urb) * surf%rad_lw_in surf%rad_net = surf%rad_sw_in - surf%rad_sw_out & + surf%rad_lw_in - surf%rad_lw_out surf%rad_lw_out_change_0 = 3.0_wp * emissivity_urb * sigma_sb & * (t_rad_urb)**3 ! !-- Calculate radiation fluxes and net radiation (rad_net) for each surface !-- element. ELSE ! !-- Determine index offset between surface element and adjacent !-- atmospheric grid point (depends on surface orientation). ioff = surf%ioff joff = surf%joff koff = surf%koff DO m = 1, surf%ns i = surf%i(m) j = surf%j(m) k = surf%k(m) exn1 = (hyp(k) / 100000.0_wp )**0.286_wp surf%rad_sw_in(m) = solar_constant * sky_trans * zenith(0) ! !-- Weighted average according to surface fraction. !-- In case no surface fraction is given ( default-type ) !-- no weighted averaging is performed ( only one surface type per !-- surface element ). IF ( ALLOCATED( surf%frac ) ) THEN surf%rad_sw_out(m) = ( surf%frac(0,m) * surf%albedo(0,m) & + surf%frac(1,m) * surf%albedo(1,m) & + surf%frac(2,m) * surf%albedo(2,m) ) & * surf%rad_sw_in(m) surf%rad_lw_out(m) = ( surf%frac(0,m) * surf%emissivity(0,m)& + surf%frac(1,m) * surf%emissivity(1,m)& + surf%frac(2,m) * surf%emissivity(2,m)& ) & * sigma_sb & * ( pt(k+koff,j+joff,i+ioff) * exn )**4 surf%rad_lw_out_change_0(m) = & ( surf%frac(0,m) * surf%emissivity(0,m) & + surf%frac(1,m) * surf%emissivity(1,m) & + surf%frac(2,m) * surf%emissivity(2,m) & ) * 3.0_wp * sigma_sb & * ( pt(k+koff,j+joff,i+ioff) * exn )** 3 ELSE surf%rad_sw_out(m) = surf%albedo(0,m) * surf%rad_sw_in(m) surf%rad_lw_out(m) = surf%emissivity(0,m) & * sigma_sb & * ( pt(k+koff,j+joff,i+ioff) * exn )**4 surf%rad_lw_out_change_0(m) = surf%emissivity(0,m) & * 3.0_wp * sigma_sb & * ( pt(k+koff,j+joff,i+ioff) * exn )** 3 ENDIF IF ( cloud_physics ) THEN pt1 = pt(k,j,i) + l_d_cp / exn1 * ql(k,j,i) surf%rad_lw_in(m) = 0.8_wp * sigma_sb * (pt1 * exn1)**4 ELSE surf%rad_lw_in(m) = 0.8_wp * sigma_sb * (pt(k,j,i) * exn1)**4 ENDIF surf%rad_net(m) = surf%rad_sw_in(m) - surf%rad_sw_out(m) & + surf%rad_lw_in(m) - surf%rad_lw_out(m) ENDDO ENDIF END SUBROUTINE radiation_clearsky_surf END SUBROUTINE radiation_clearsky !------------------------------------------------------------------------------! ! Description: ! ------------ !> This scheme keeps the prescribed net radiation constant during the run !------------------------------------------------------------------------------! SUBROUTINE radiation_constant IMPLICIT NONE INTEGER(iwp) :: l !< running index for surface orientation REAL(wp) :: exn !< Exner functions at surface REAL(wp) :: exn1 !< Exner functions at first grid level REAL(wp) :: pt1 !< potential temperature at first grid level or mean value at urban layer top REAL(wp) :: pt1_l !< potential temperature at first grid level or mean value at urban layer top at local subdomain REAL(wp) :: ql1 !< liquid water mixing ratio at first grid level or mean value at urban layer top REAL(wp) :: ql1_l !< liquid water mixing ratio at first grid level or mean value at urban layer top at local subdomain TYPE(surf_type), POINTER :: surf !< pointer on respective surface type, used to generalize routine ! !-- Calculate value of the Exner function exn = (surface_pressure / 1000.0_wp )**0.286_wp ! !-- In case averaged radiation is used, calculate mean temperature and !-- liquid water mixing ratio at the urban-layer top. IF ( average_radiation ) THEN pt1 = 0.0_wp IF ( cloud_physics ) ql1 = 0.0_wp pt1_l = SUM( pt(nzut,nys:nyn,nxl:nxr) ) IF ( cloud_physics ) ql1_l = SUM( ql(nzut,nys:nyn,nxl:nxr) ) #if defined( __parallel ) IF ( collective_wait ) CALL MPI_BARRIER( comm2d, ierr ) CALL MPI_ALLREDUCE( pt1_l, pt1, 1, MPI_REAL, MPI_SUM, comm2d, ierr ) IF ( cloud_physics ) & CALL MPI_ALLREDUCE( ql1_l, ql1, 1, MPI_REAL, MPI_SUM, comm2d, ierr ) #else pt1 = pt1_l IF ( cloud_physics ) ql1 = ql1_l #endif IF ( cloud_physics ) pt1 = pt1 + l_d_cp / exn1 * ql1 ! !-- Finally, divide by number of grid points pt1 = pt1 / REAL( ( nx + 1 ) * ( ny + 1 ), KIND=wp ) ENDIF ! !-- First, horizontal surfaces surf => surf_def_h(0) CALL radiation_constant_surf surf => surf_lsm_h CALL radiation_constant_surf surf => surf_usm_h CALL radiation_constant_surf ! !-- Vertical surfaces DO l = 0, 3 surf => surf_def_v(l) CALL radiation_constant_surf surf => surf_lsm_v(l) CALL radiation_constant_surf surf => surf_usm_v(l) CALL radiation_constant_surf ENDDO CONTAINS SUBROUTINE radiation_constant_surf IMPLICIT NONE INTEGER(iwp) :: i !< index x-direction INTEGER(iwp) :: ioff !< offset between surface element and adjacent grid point along x INTEGER(iwp) :: j !< index y-direction INTEGER(iwp) :: joff !< offset between surface element and adjacent grid point along y INTEGER(iwp) :: k !< index z-direction INTEGER(iwp) :: koff !< offset between surface element and adjacent grid point along z INTEGER(iwp) :: m !< running index for surface elements IF ( surf%ns < 1 ) RETURN !-- Calculate homogenoeus urban radiation fluxes IF ( average_radiation ) THEN ! set height above canopy k = nzut surf%rad_net = net_radiation ! MS: Wyh k + 1 ? exn1 = (hyp(k+1) / 100000.0_wp )**0.286_wp surf%rad_lw_in = 0.8_wp * sigma_sb * (pt1 * exn1)**4 surf%rad_lw_out = emissivity_urb * sigma_sb * (t_rad_urb)**4 & + ( 10.0_wp - emissivity_urb ) & ! shouldn't be this a bulk value -- emissivity_urb? * surf%rad_lw_in surf%rad_lw_out_change_0 = 3.0_wp * emissivity_urb * sigma_sb & * t_rad_urb**3 surf%rad_sw_in = ( surf%rad_net - surf%rad_lw_in & + surf%rad_lw_out ) & / ( 1.0_wp - albedo_urb ) surf%rad_sw_out = albedo_urb * surf%rad_sw_in ! !-- Calculate radiation fluxes for each surface element ELSE ! !-- Determine index offset between surface element and adjacent !-- atmospheric grid point ioff = surf%ioff joff = surf%joff koff = surf%koff ! !-- Prescribe net radiation and estimate the remaining radiative fluxes DO m = 1, surf%ns i = surf%i(m) j = surf%j(m) k = surf%k(m) surf%rad_net(m) = net_radiation exn1 = (hyp(k) / 100000.0_wp )**0.286_wp IF ( cloud_physics ) THEN pt1 = pt(k,j,i) + l_d_cp / exn1 * ql(k,j,i) surf%rad_lw_in(m) = 0.8_wp * sigma_sb * (pt1 * exn1)**4 ELSE surf%rad_lw_in(m) = 0.8_wp * sigma_sb * & ( pt(k,j,i) * exn1 )**4 ENDIF ! !-- Weighted average according to surface fraction. !-- In case no surface fraction is given ( default-type ) !-- no weighted averaging is performed ( only one surface type per !-- surface element ). IF ( ALLOCATED( surf%frac ) ) THEN surf%rad_lw_out(m) = ( surf%frac(0,m) * surf%emissivity(0,m)& + surf%frac(1,m) * surf%emissivity(1,m)& + surf%frac(2,m) * surf%emissivity(2,m)& ) & * sigma_sb & * ( pt(k+koff,j+joff,i+ioff) * exn )**4 surf%rad_sw_in(m) = ( surf%rad_net(m) - surf%rad_lw_in(m) & + surf%rad_lw_out(m) ) & / ( 1.0_wp - & ( surf%frac(0,m) * surf%albedo(0,m) +& surf%frac(1,m) * surf%albedo(1,m) +& surf%frac(1,m) * surf%albedo(1,m) )& ) surf%rad_sw_out(m) = ( surf%frac(0,m) * surf%albedo(0,m) & + surf%frac(1,m) * surf%albedo(1,m) & + surf%frac(2,m) * surf%albedo(2,m) ) & * surf%rad_sw_in(m) ELSE surf%rad_lw_out(m) = surf%emissivity(0,m) & * sigma_sb & * ( pt(k+koff,j+joff,i+ioff) * exn )**4 surf%rad_sw_in(m) = ( surf%rad_net(m) - surf%rad_lw_in(m) & + surf%rad_lw_out(m) ) & / ( 1.0_wp - & ( surf%frac(0,m) * surf%albedo(0,m) )& ) surf%rad_sw_out(m) = ( surf%frac(0,m) * surf%albedo(0,m) ) & * surf%rad_sw_in(m) ENDIF ENDDO ENDIF END SUBROUTINE radiation_constant_surf END SUBROUTINE radiation_constant !------------------------------------------------------------------------------! ! Description: ! ------------ !> Header output for radiation model !------------------------------------------------------------------------------! SUBROUTINE radiation_header ( io ) IMPLICIT NONE INTEGER(iwp), INTENT(IN) :: io !< Unit of the output file ! !-- Write radiation model header WRITE( io, 3 ) IF ( radiation_scheme == "constant" ) THEN WRITE( io, 4 ) net_radiation ELSEIF ( radiation_scheme == "clear-sky" ) THEN WRITE( io, 5 ) ELSEIF ( radiation_scheme == "rrtmg" ) THEN WRITE( io, 6 ) IF ( .NOT. lw_radiation ) WRITE( io, 10 ) IF ( .NOT. sw_radiation ) WRITE( io, 11 ) ENDIF IF ( albedo_type_f%from_file .OR. vegetation_type_f%from_file .OR. & pavement_type_f%from_file .OR. water_type_f%from_file .OR. & building_type_f%from_file ) THEN WRITE( io, 13 ) ELSE IF ( albedo_type == 0 ) THEN WRITE( io, 7 ) albedo ELSE WRITE( io, 8 ) TRIM( albedo_type_name(albedo_type) ) ENDIF ENDIF IF ( constant_albedo ) THEN WRITE( io, 9 ) ENDIF WRITE( io, 12 ) dt_radiation 3 FORMAT (//' Radiation model information:'/ & ' ----------------------------'/) 4 FORMAT (' --> Using constant net radiation: net_radiation = ', F6.2, & // 'W/m**2') 5 FORMAT (' --> Simple radiation scheme for clear sky is used (no clouds,',& ' default)') 6 FORMAT (' --> RRTMG scheme is used') 7 FORMAT (/' User-specific surface albedo: albedo =', F6.3) 8 FORMAT (/' Albedo is set for land surface type: ', A) 9 FORMAT (/' --> Albedo is fixed during the run') 10 FORMAT (/' --> Longwave radiation is disabled') 11 FORMAT (/' --> Shortwave radiation is disabled.') 12 FORMAT (' Timestep: dt_radiation = ', F6.2, ' s') 13 FORMAT (/' Albedo is set individually for each xy-location, according ' & 'to given surface type.') END SUBROUTINE radiation_header !------------------------------------------------------------------------------! ! Description: ! ------------ !> Parin for &radiation_par for radiation model !------------------------------------------------------------------------------! SUBROUTINE radiation_parin IMPLICIT NONE CHARACTER (LEN=80) :: line !< dummy string that contains the current line of the parameter file NAMELIST /radiation_par/ albedo, albedo_type, albedo_lw_dir, & albedo_lw_dif, albedo_sw_dir, albedo_sw_dif, & constant_albedo, dt_radiation, emissivity, & lw_radiation, net_radiation, & radiation_scheme, skip_time_do_radiation, & sw_radiation, unscheduled_radiation_calls, & split_diffusion_radiation, & energy_balance_surf_h, & energy_balance_surf_v, & read_svf_on_init, & nrefsteps, & write_svf_on_init, & mrt_factors, & dist_max_svf, & average_radiation, & radiation_interactions, atm_surfaces, & surf_reflections line = ' ' ! !-- Try to find radiation model package REWIND ( 11 ) line = ' ' DO WHILE ( INDEX( line, '&radiation_par' ) == 0 ) READ ( 11, '(A)', END=10 ) line ENDDO BACKSPACE ( 11 ) ! !-- Read user-defined namelist READ ( 11, radiation_par ) ! !-- Set flag that indicates that the radiation model is switched on radiation = .TRUE. 10 CONTINUE END SUBROUTINE radiation_parin !------------------------------------------------------------------------------! ! Description: ! ------------ !> Implementation of the RRTMG radiation_scheme !------------------------------------------------------------------------------! SUBROUTINE radiation_rrtmg USE indices, & ONLY: nbgp USE particle_attributes, & ONLY: grid_particles, number_of_particles, particles, & particle_advection_start, prt_count IMPLICIT NONE #if defined ( __rrtmg ) INTEGER(iwp) :: i, j, k, l, m, n !< loop indices INTEGER(iwp) :: k_topo !< topography top index REAL(wp) :: nc_rad, & !< number concentration of cloud droplets s_r2, & !< weighted sum over all droplets with r^2 s_r3 !< weighted sum over all droplets with r^3 REAL(wp), DIMENSION(0:nzt+1) :: pt_av, q_av, ql_av ! !-- Just dummy arguments REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: rrtm_lw_taucld_dum, & rrtm_lw_tauaer_dum, & rrtm_sw_taucld_dum, & rrtm_sw_ssacld_dum, & rrtm_sw_asmcld_dum, & rrtm_sw_fsfcld_dum, & rrtm_sw_tauaer_dum, & rrtm_sw_ssaaer_dum, & rrtm_sw_asmaer_dum, & rrtm_sw_ecaer_dum ! !-- Calculate current (cosine of) zenith angle and whether the sun is up CALL calc_zenith ! !-- Calculate surface albedo. In case average radiation is applied, !-- this is not required. IF ( .NOT. constant_albedo ) THEN ! !-- Horizontally aligned default, natural and urban surfaces CALL calc_albedo( surf_def_h(0) ) CALL calc_albedo( surf_lsm_h ) CALL calc_albedo( surf_usm_h ) ! !-- Vertically aligned default, natural and urban surfaces DO l = 0, 3 CALL calc_albedo( surf_def_v(l) ) CALL calc_albedo( surf_lsm_v(l) ) CALL calc_albedo( surf_usm_v(l) ) ENDDO ENDIF ! !-- Prepare input data for RRTMG ! !-- In case of large scale forcing with surface data, calculate new pressure !-- profile. nzt_rad might be modified by these calls and all required arrays !-- will then be re-allocated IF ( large_scale_forcing .AND. lsf_surf ) THEN CALL read_sounding_data CALL read_trace_gas_data ENDIF IF ( average_radiation ) THEN rrtm_asdir(1) = albedo_urb rrtm_asdif(1) = albedo_urb rrtm_aldir(1) = albedo_urb rrtm_aldif(1) = albedo_urb rrtm_emis = emissivity_urb ! !-- Calculate mean pt profile. Actually, only one height level is required. CALL calc_mean_profile( pt, 4 ) pt_av = hom(:, 1, 4, 0) ! !-- Prepare profiles of temperature and H2O volume mixing ratio rrtm_tlev(0,nzb+1) = t_rad_urb IF ( cloud_physics ) THEN CALL calc_mean_profile( q, 41 ) ! average q is now in hom(:, 1, 41, 0) q_av = hom(:, 1, 41, 0) CALL calc_mean_profile( ql, 54 ) ! average ql is now in hom(:, 1, 54, 0) ql_av = hom(:, 1, 54, 0) DO k = nzb+1, nzt+1 rrtm_tlay(0,k) = pt_av(k) * ( (hyp(k) ) / 100000._wp & )**.286_wp + l_d_cp * ql_av(k) rrtm_h2ovmr(0,k) = mol_mass_air_d_wv * (q_av(k) - ql_av(k)) ENDDO ELSE DO k = nzb+1, nzt+1 rrtm_tlay(0,k) = pt_av(k) * ( (hyp(k) ) / 100000._wp & )**.286_wp rrtm_h2ovmr(0,k) = 0._wp ENDDO ENDIF ! !-- Avoid temperature/humidity jumps at the top of the LES domain by !-- linear interpolation from nzt+2 to nzt+7 DO k = nzt+2, nzt+7 rrtm_tlay(0,k) = rrtm_tlay(0,nzt+1) & + ( rrtm_tlay(0,nzt+8) - rrtm_tlay(0,nzt+1) ) & / ( rrtm_play(0,nzt+8) - rrtm_play(0,nzt+1) ) & * ( rrtm_play(0,k) - rrtm_play(0,nzt+1) ) rrtm_h2ovmr(0,k) = rrtm_h2ovmr(0,nzt+1) & + ( rrtm_h2ovmr(0,nzt+8) - rrtm_h2ovmr(0,nzt+1) )& / ( rrtm_play(0,nzt+8) - rrtm_play(0,nzt+1) )& * ( rrtm_play(0,k) - rrtm_play(0,nzt+1) ) ENDDO !-- Linear interpolate to zw grid DO k = nzb+2, nzt+8 rrtm_tlev(0,k) = rrtm_tlay(0,k-1) + (rrtm_tlay(0,k) - & rrtm_tlay(0,k-1)) & / ( rrtm_play(0,k) - rrtm_play(0,k-1) ) & * ( rrtm_plev(0,k) - rrtm_play(0,k-1) ) ENDDO ! !-- Calculate liquid water path and cloud fraction for each column. !-- Note that LWP is required in g/m² instead of kg/kg m. rrtm_cldfr = 0.0_wp rrtm_reliq = 0.0_wp rrtm_cliqwp = 0.0_wp rrtm_icld = 0 IF ( cloud_physics ) THEN DO k = nzb+1, nzt+1 rrtm_cliqwp(0,k) = ql_av(k) * 1000._wp * & (rrtm_plev(0,k) - rrtm_plev(0,k+1)) & * 100._wp / g IF ( rrtm_cliqwp(0,k) > 0._wp ) THEN rrtm_cldfr(0,k) = 1._wp IF ( rrtm_icld == 0 ) rrtm_icld = 1 ! !-- Calculate cloud droplet effective radius IF ( cloud_physics ) THEN rrtm_reliq(0,k) = 1.0E6_wp * ( 3._wp * ql_av(k) & * rho_surface & / ( 4._wp * pi * nc_const * rho_l )& )**.33333333333333_wp & * EXP( LOG( sigma_gc )**2 ) ENDIF ! !-- Limit effective radius IF ( rrtm_reliq(0,k) > 0.0_wp ) THEN rrtm_reliq(0,k) = MAX(rrtm_reliq(0,k),2.5_wp) rrtm_reliq(0,k) = MIN(rrtm_reliq(0,k),60.0_wp) ENDIF ENDIF ENDDO ENDIF ! !-- Set surface temperature rrtm_tsfc = t_rad_urb IF ( lw_radiation ) THEN CALL rrtmg_lw( 1, nzt_rad , rrtm_icld , rrtm_idrv ,& rrtm_play , rrtm_plev , rrtm_tlay , rrtm_tlev ,& rrtm_tsfc , rrtm_h2ovmr , rrtm_o3vmr , rrtm_co2vmr ,& rrtm_ch4vmr , rrtm_n2ovmr , rrtm_o2vmr , rrtm_cfc11vmr ,& rrtm_cfc12vmr , rrtm_cfc22vmr, rrtm_ccl4vmr , rrtm_emis ,& rrtm_inflglw , rrtm_iceflglw, rrtm_liqflglw, rrtm_cldfr ,& rrtm_lw_taucld , rrtm_cicewp , rrtm_cliqwp , rrtm_reice ,& rrtm_reliq , rrtm_lw_tauaer, & rrtm_lwuflx , rrtm_lwdflx , rrtm_lwhr , & rrtm_lwuflxc , rrtm_lwdflxc , rrtm_lwhrc , & rrtm_lwuflx_dt , rrtm_lwuflxc_dt ) ! !-- Save fluxes DO k = nzb, nzt+1 rad_lw_in(k,:,:) = rrtm_lwdflx(0,k) rad_lw_out(k,:,:) = rrtm_lwuflx(0,k) ENDDO ! !-- Save heating rates (convert from K/d to K/h) DO k = nzb+1, nzt+1 rad_lw_hr(k,:,:) = rrtm_lwhr(0,k) * d_hours_day rad_lw_cs_hr(k,:,:) = rrtm_lwhrc(0,k) * d_hours_day ENDDO ! !-- Save surface radiative fluxes and change in LW heating rate !-- onto respective surface elements !-- Horizontal surfaces IF ( surf_def_h(0)%ns > 0 ) THEN surf_def_h(0)%rad_lw_in = rrtm_lwdflx(0,nzb) surf_def_h(0)%rad_lw_out = rrtm_lwuflx(0,nzb) surf_def_h(0)%rad_lw_out_change_0 = rrtm_lwuflx_dt(0,nzb) ENDIF IF ( surf_lsm_h%ns > 0 ) THEN surf_lsm_h%rad_lw_in = rrtm_lwdflx(0,nzb) surf_lsm_h%rad_lw_out = rrtm_lwuflx(0,nzb) surf_lsm_h%rad_lw_out_change_0 = rrtm_lwuflx_dt(0,nzb) ENDIF IF ( surf_usm_h%ns > 0 ) THEN surf_usm_h%rad_lw_in = rrtm_lwdflx(0,nzb) surf_usm_h%rad_lw_out = rrtm_lwuflx(0,nzb) surf_usm_h%rad_lw_out_change_0 = rrtm_lwuflx_dt(0,nzb) ENDIF ! !-- Vertical surfaces. DO l = 0, 3 IF ( surf_def_v(l)%ns > 0 ) THEN surf_def_v(l)%rad_lw_in = rrtm_lwdflx(0,nzb) surf_def_v(l)%rad_lw_out = rrtm_lwuflx(0,nzb) surf_def_v(l)%rad_lw_out_change_0 = rrtm_lwuflx_dt(0,nzb) ENDIF IF ( surf_lsm_v(l)%ns > 0 ) THEN surf_lsm_v(l)%rad_lw_in = rrtm_lwdflx(0,nzb) surf_lsm_v(l)%rad_lw_out = rrtm_lwuflx(0,nzb) surf_lsm_v(l)%rad_lw_out_change_0 = rrtm_lwuflx_dt(0,nzb) ENDIF IF ( surf_usm_v(l)%ns > 0 ) THEN surf_usm_v(l)%rad_lw_in = rrtm_lwdflx(0,nzb) surf_usm_v(l)%rad_lw_out = rrtm_lwuflx(0,nzb) surf_usm_v(l)%rad_lw_out_change_0 = rrtm_lwuflx_dt(0,nzb) ENDIF ENDDO ENDIF IF ( sw_radiation .AND. sun_up ) THEN CALL rrtmg_sw( 1, nzt_rad , rrtm_icld , rrtm_iaer ,& rrtm_play , rrtm_plev , rrtm_tlay , rrtm_tlev ,& rrtm_tsfc , rrtm_h2ovmr , rrtm_o3vmr , rrtm_co2vmr ,& rrtm_ch4vmr , rrtm_n2ovmr , rrtm_o2vmr , rrtm_asdir ,& rrtm_asdif , rrtm_aldir , rrtm_aldif , zenith, & 0.0_wp , day_of_year , solar_constant, rrtm_inflgsw,& rrtm_iceflgsw , rrtm_liqflgsw, rrtm_cldfr , rrtm_sw_taucld ,& rrtm_sw_ssacld , rrtm_sw_asmcld, rrtm_sw_fsfcld, rrtm_cicewp ,& rrtm_cliqwp , rrtm_reice , rrtm_reliq , rrtm_sw_tauaer ,& rrtm_sw_ssaaer , rrtm_sw_asmaer , rrtm_sw_ecaer , & rrtm_swuflx , rrtm_swdflx , rrtm_swhr , & rrtm_swuflxc , rrtm_swdflxc , rrtm_swhrc ) ! !-- Save fluxes DO k = nzb, nzt+1 rad_sw_in(k,:,:) = rrtm_swdflx(0,k) rad_sw_out(k,:,:) = rrtm_swuflx(0,k) ENDDO ! !-- Save heating rates (convert from K/d to K/s) DO k = nzb+1, nzt+1 rad_sw_hr(k,:,:) = rrtm_swhr(0,k) * d_hours_day rad_sw_cs_hr(k,:,:) = rrtm_swhrc(0,k) * d_hours_day ENDDO ! !-- Save surface radiative fluxes onto respective surface elements !-- Horizontal surfaces IF ( surf_def_h(0)%ns > 0 ) THEN surf_def_h(0)%rad_lw_in = rrtm_swdflx(0,nzb) surf_def_h(0)%rad_lw_out = rrtm_swuflx(0,nzb) ENDIF IF ( surf_lsm_h%ns > 0 ) THEN surf_lsm_h%rad_sw_in = rrtm_swdflx(0,nzb) surf_lsm_h%rad_sw_out = rrtm_swuflx(0,nzb) ENDIF IF ( surf_usm_h%ns > 0 ) THEN surf_usm_h%rad_sw_in = rrtm_swdflx(0,nzb) surf_usm_h%rad_sw_out = rrtm_swuflx(0,nzb) ENDIF ! !-- Vertical surfaces. Fluxes are obtain at respective vertical !-- level of the surface element DO l = 0, 3 IF ( surf_def_v(l)%ns > 0 ) THEN surf_def_v(l)%rad_sw_in = rrtm_swdflx(0,nzb) surf_def_v(l)%rad_sw_out = rrtm_swuflx(0,nzb) ENDIF IF ( surf_lsm_v(l)%ns > 0 ) THEN surf_lsm_v(l)%rad_sw_in = rrtm_swdflx(0,nzb) surf_lsm_v(l)%rad_sw_out = rrtm_swuflx(0,nzb) ENDIF IF ( surf_usm_v(l)%ns > 0 ) THEN surf_usm_v(l)%rad_sw_in = rrtm_swdflx(0,nzb) surf_usm_v(l)%rad_sw_out = rrtm_swuflx(0,nzb) ENDIF ENDDO ENDIF ! !-- RRTMG is called for each (j,i) grid point separately, starting at the !-- highest topography level ELSE ! !-- Loop over all grid points DO i = nxl, nxr DO j = nys, nyn ! !-- Prepare profiles of temperature and H2O volume mixing ratio rrtm_tlev(0,nzb+1) = pt(nzb,j,i) * ( surface_pressure & / 1000.0_wp )**0.286_wp IF ( cloud_physics ) THEN DO k = nzb+1, nzt+1 rrtm_tlay(0,k) = pt(k,j,i) * ( (hyp(k) ) / 100000.0_wp & )**0.286_wp + l_d_cp * ql(k,j,i) rrtm_h2ovmr(0,k) = mol_mass_air_d_wv * (q(k,j,i) - ql(k,j,i)) ENDDO ELSE DO k = nzb+1, nzt+1 rrtm_tlay(0,k) = pt(k,j,i) * ( (hyp(k) ) / 100000.0_wp & )**0.286_wp rrtm_h2ovmr(0,k) = 0.0_wp ENDDO ENDIF ! !-- Avoid temperature/humidity jumps at the top of the LES domain by !-- linear interpolation from nzt+2 to nzt+7 DO k = nzt+2, nzt+7 rrtm_tlay(0,k) = rrtm_tlay(0,nzt+1) & + ( rrtm_tlay(0,nzt+8) - rrtm_tlay(0,nzt+1) ) & / ( rrtm_play(0,nzt+8) - rrtm_play(0,nzt+1) ) & * ( rrtm_play(0,k) - rrtm_play(0,nzt+1) ) rrtm_h2ovmr(0,k) = rrtm_h2ovmr(0,nzt+1) & + ( rrtm_h2ovmr(0,nzt+8) - rrtm_h2ovmr(0,nzt+1) )& / ( rrtm_play(0,nzt+8) - rrtm_play(0,nzt+1) )& * ( rrtm_play(0,k) - rrtm_play(0,nzt+1) ) ENDDO !-- Linear interpolate to zw grid DO k = nzb+2, nzt+8 rrtm_tlev(0,k) = rrtm_tlay(0,k-1) + (rrtm_tlay(0,k) - & rrtm_tlay(0,k-1)) & / ( rrtm_play(0,k) - rrtm_play(0,k-1) ) & * ( rrtm_plev(0,k) - rrtm_play(0,k-1) ) ENDDO ! !-- Calculate liquid water path and cloud fraction for each column. !-- Note that LWP is required in g/m² instead of kg/kg m. rrtm_cldfr = 0.0_wp rrtm_reliq = 0.0_wp rrtm_cliqwp = 0.0_wp rrtm_icld = 0 IF ( cloud_physics .OR. cloud_droplets ) THEN DO k = nzb+1, nzt+1 rrtm_cliqwp(0,k) = ql(k,j,i) * 1000.0_wp * & (rrtm_plev(0,k) - rrtm_plev(0,k+1)) & * 100.0_wp / g IF ( rrtm_cliqwp(0,k) > 0.0_wp ) THEN rrtm_cldfr(0,k) = 1.0_wp IF ( rrtm_icld == 0 ) rrtm_icld = 1 ! !-- Calculate cloud droplet effective radius IF ( cloud_physics ) THEN ! !-- Calculete effective droplet radius. In case of using !-- cloud_scheme = 'morrison' and a non reasonable number !-- of cloud droplets the inital aerosol number !-- concentration is considered. IF ( microphysics_morrison ) THEN IF ( nc(k,j,i) > 1.0E-20_wp ) THEN nc_rad = nc(k,j,i) ELSE nc_rad = na_init ENDIF ELSE nc_rad = nc_const ENDIF rrtm_reliq(0,k) = 1.0E6_wp * ( 3.0_wp * ql(k,j,i) & * rho_surface & / ( 4.0_wp * pi * nc_rad * rho_l ) & )**0.33333333333333_wp & * EXP( LOG( sigma_gc )**2 ) ELSEIF ( cloud_droplets ) THEN number_of_particles = prt_count(k,j,i) IF (number_of_particles <= 0) CYCLE particles => grid_particles(k,j,i)%particles(1:number_of_particles) s_r2 = 0.0_wp s_r3 = 0.0_wp DO n = 1, number_of_particles IF ( particles(n)%particle_mask ) THEN s_r2 = s_r2 + particles(n)%radius**2 * & particles(n)%weight_factor s_r3 = s_r3 + particles(n)%radius**3 * & particles(n)%weight_factor ENDIF ENDDO IF ( s_r2 > 0.0_wp ) rrtm_reliq(0,k) = s_r3 / s_r2 ENDIF ! !-- Limit effective radius IF ( rrtm_reliq(0,k) > 0.0_wp ) THEN rrtm_reliq(0,k) = MAX(rrtm_reliq(0,k),2.5_wp) rrtm_reliq(0,k) = MIN(rrtm_reliq(0,k),60.0_wp) ENDIF ENDIF ENDDO ENDIF ! !-- Write surface emissivity and surface temperature at current !-- surface element on RRTMG-shaped array. !-- Please note, as RRTMG is a single column model, surface attributes !-- are only obtained from horizontally aligned surfaces (for !-- simplicity). Taking surface attributes from horizontal and !-- vertical walls would lead to multiple solutions. !-- Moreover, for natural- and urban-type surfaces, several surface !-- classes can exist at a surface element next to each other. !-- To obtain bulk parameters, apply a weighted average for these !-- surfaces. DO m = surf_def_h(0)%start_index(j,i), surf_def_h(0)%end_index(j,i) rrtm_emis = surf_def_h(0)%emissivity(0,m) rrtm_tsfc = pt(surf_def_h(0)%k(m)+surf_def_h(0)%koff,j,i) * & (surface_pressure / 1000.0_wp )**0.286_wp ENDDO DO m = surf_lsm_h%start_index(j,i), surf_lsm_h%end_index(j,i) rrtm_emis = surf_lsm_h%frac(0,m) * surf_lsm_h%emissivity(0,m) +& surf_lsm_h%frac(1,m) * surf_lsm_h%emissivity(1,m) +& surf_lsm_h%frac(2,m) * surf_lsm_h%emissivity(2,m) rrtm_tsfc = pt(surf_lsm_h%k(m)+surf_lsm_h%koff,j,i) * & (surface_pressure / 1000.0_wp )**0.286_wp ENDDO DO m = surf_usm_h%start_index(j,i), surf_usm_h%end_index(j,i) rrtm_emis = surf_usm_h%frac(0,m) * surf_usm_h%emissivity(0,m) +& surf_usm_h%frac(1,m) * surf_usm_h%emissivity(1,m) +& surf_usm_h%frac(2,m) * surf_usm_h%emissivity(2,m) rrtm_tsfc = pt(surf_usm_h%k(m)+surf_usm_h%koff,j,i) * & (surface_pressure / 1000.0_wp )**0.286_wp ENDDO ! !-- Obtain topography top index (lower bound of RRTMG) k_topo = get_topography_top_index_ji( j, i, 's' ) IF ( lw_radiation ) THEN ! !-- Due to technical reasons, copy optical depth to dummy arguments !-- which are allocated on the exact size as the rrtmg_lw is called. !-- As one dimesion is allocated with zero size, compiler complains !-- that rank of the array does not match that of the !-- assumed-shaped arguments in the RRTMG library. In order to !-- avoid this, write to dummy arguments and give pass the entire !-- dummy array. Seems to be the only existing work-around. ALLOCATE( rrtm_lw_taucld_dum(1:nbndlw+1,0:0,k_topo+1:nzt_rad+1) ) ALLOCATE( rrtm_lw_tauaer_dum(0:0,k_topo+1:nzt_rad+1,1:nbndlw+1) ) rrtm_lw_taucld_dum = & rrtm_lw_taucld(1:nbndlw+1,0:0,k_topo+1:nzt_rad+1) rrtm_lw_tauaer_dum = & rrtm_lw_tauaer(0:0,k_topo+1:nzt_rad+1,1:nbndlw+1) CALL rrtmg_lw( 1, & nzt_rad-k_topo, & rrtm_icld, & rrtm_idrv, & rrtm_play(:,k_topo+1:nzt_rad+1), & rrtm_plev(:,k_topo+1:nzt_rad+2), & rrtm_tlay(:,k_topo+1:nzt_rad+1), & rrtm_tlev(:,k_topo+1:nzt_rad+2), & rrtm_tsfc, & rrtm_h2ovmr(:,k_topo+1:nzt_rad+1), & rrtm_o3vmr(:,k_topo+1:nzt_rad+1), & rrtm_co2vmr(:,k_topo+1:nzt_rad+1), & rrtm_ch4vmr(:,k_topo+1:nzt_rad+1), & rrtm_n2ovmr(:,k_topo+1:nzt_rad+1), & rrtm_o2vmr(:,k_topo+1:nzt_rad+1), & rrtm_cfc11vmr(:,k_topo+1:nzt_rad+1), & rrtm_cfc12vmr(:,k_topo+1:nzt_rad+1), & rrtm_cfc22vmr(:,k_topo+1:nzt_rad+1), & rrtm_ccl4vmr(:,k_topo+1:nzt_rad+1), & rrtm_emis, & rrtm_inflglw, & rrtm_iceflglw, & rrtm_liqflglw, & rrtm_cldfr(:,k_topo+1:nzt_rad+1), & rrtm_lw_taucld_dum, & rrtm_cicewp(:,k_topo+1:nzt_rad+1), & rrtm_cliqwp(:,k_topo+1:nzt_rad+1), & rrtm_reice(:,k_topo+1:nzt_rad+1), & rrtm_reliq(:,k_topo+1:nzt_rad+1), & rrtm_lw_tauaer_dum, & rrtm_lwuflx(:,k_topo:nzt_rad+1), & rrtm_lwdflx(:,k_topo:nzt_rad+1), & rrtm_lwhr(:,k_topo+1:nzt_rad+1), & rrtm_lwuflxc(:,k_topo:nzt_rad+1), & rrtm_lwdflxc(:,k_topo:nzt_rad+1), & rrtm_lwhrc(:,k_topo+1:nzt_rad+1), & rrtm_lwuflx_dt(:,k_topo:nzt_rad+1), & rrtm_lwuflxc_dt(:,k_topo:nzt_rad+1) ) DEALLOCATE ( rrtm_lw_taucld_dum ) DEALLOCATE ( rrtm_lw_tauaer_dum ) ! !-- Save fluxes DO k = k_topo, nzt+1 rad_lw_in(k,j,i) = rrtm_lwdflx(0,k) rad_lw_out(k,j,i) = rrtm_lwuflx(0,k) ENDDO ! !-- Save heating rates (convert from K/d to K/h) DO k = k_topo+1, nzt+1 rad_lw_hr(k,j,i) = rrtm_lwhr(0,k) * d_hours_day rad_lw_cs_hr(k,j,i) = rrtm_lwhrc(0,k) * d_hours_day ENDDO ! !-- Save surface radiative fluxes and change in LW heating rate !-- onto respective surface elements !-- Horizontal surfaces DO m = surf_def_h(0)%start_index(j,i), & surf_def_h(0)%end_index(j,i) surf_def_h(0)%rad_lw_in(m) = rrtm_lwdflx(0,k_topo) surf_def_h(0)%rad_lw_out(m) = rrtm_lwuflx(0,k_topo) surf_def_h(0)%rad_lw_out_change_0(m) = rrtm_lwuflx_dt(0,k_topo) ENDDO DO m = surf_lsm_h%start_index(j,i), & surf_lsm_h%end_index(j,i) surf_lsm_h%rad_lw_in(m) = rrtm_lwdflx(0,k_topo) surf_lsm_h%rad_lw_out(m) = rrtm_lwuflx(0,k_topo) surf_lsm_h%rad_lw_out_change_0(m) = rrtm_lwuflx_dt(0,k_topo) ENDDO DO m = surf_usm_h%start_index(j,i), & surf_usm_h%end_index(j,i) surf_usm_h%rad_lw_in(m) = rrtm_lwdflx(0,k_topo) surf_usm_h%rad_lw_out(m) = rrtm_lwuflx(0,k_topo) surf_usm_h%rad_lw_out_change_0(m) = rrtm_lwuflx_dt(0,k_topo) ENDDO ! !-- Vertical surfaces. Fluxes are obtain at vertical level of the !-- respective surface element DO l = 0, 3 DO m = surf_def_v(l)%start_index(j,i), & surf_def_v(l)%end_index(j,i) k = surf_def_v(l)%k(m) surf_def_v(l)%rad_lw_in(m) = rrtm_lwdflx(0,k) surf_def_v(l)%rad_lw_out(m) = rrtm_lwuflx(0,k) surf_def_v(l)%rad_lw_out_change_0(m) = rrtm_lwuflx_dt(0,k) ENDDO DO m = surf_lsm_v(l)%start_index(j,i), & surf_lsm_v(l)%end_index(j,i) k = surf_lsm_v(l)%k(m) surf_lsm_v(l)%rad_lw_in(m) = rrtm_lwdflx(0,k) surf_lsm_v(l)%rad_lw_out(m) = rrtm_lwuflx(0,k) surf_lsm_v(l)%rad_lw_out_change_0(m) = rrtm_lwuflx_dt(0,k) ENDDO DO m = surf_usm_v(l)%start_index(j,i), & surf_usm_v(l)%end_index(j,i) k = surf_usm_v(l)%k(m) surf_usm_v(l)%rad_lw_in(m) = rrtm_lwdflx(0,k) surf_usm_v(l)%rad_lw_out(m) = rrtm_lwuflx(0,k) surf_usm_v(l)%rad_lw_out_change_0(m) = rrtm_lwuflx_dt(0,k) ENDDO ENDDO ENDIF IF ( sw_radiation .AND. sun_up ) THEN ! !-- Get albedo for direct/diffusive long/shortwave radiation at !-- current (y,x)-location from surface variables. !-- Only obtain it from horizontal surfaces, as RRTMG is a single !-- column model !-- (Please note, only one loop will entered, controlled by !-- start-end index.) DO m = surf_def_h(0)%start_index(j,i), & surf_def_h(0)%end_index(j,i) rrtm_asdir(1) = surf_def_h(0)%rrtm_asdir(m) rrtm_asdif(1) = surf_def_h(0)%rrtm_asdif(m) rrtm_aldir(1) = surf_def_h(0)%rrtm_aldir(m) rrtm_aldif(1) = surf_def_h(0)%rrtm_aldif(m) ENDDO DO m = surf_lsm_h%start_index(j,i), & surf_lsm_h%end_index(j,i) rrtm_asdir(1) = surf_lsm_h%rrtm_asdir(m) rrtm_asdif(1) = surf_lsm_h%rrtm_asdif(m) rrtm_aldir(1) = surf_lsm_h%rrtm_aldir(m) rrtm_aldif(1) = surf_lsm_h%rrtm_aldif(m) ENDDO DO m = surf_usm_h%start_index(j,i), & surf_usm_h%end_index(j,i) rrtm_asdir(1) = surf_usm_h%rrtm_asdir(m) rrtm_asdif(1) = surf_usm_h%rrtm_asdif(m) rrtm_aldir(1) = surf_usm_h%rrtm_aldir(m) rrtm_aldif(1) = surf_usm_h%rrtm_aldif(m) ENDDO ! !-- Due to technical reasons, copy optical depths and other !-- to dummy arguments which are allocated on the exact size as the !-- rrtmg_sw is called. !-- As one dimesion is allocated with zero size, compiler complains !-- that rank of the array does not match that of the !-- assumed-shaped arguments in the RRTMG library. In order to !-- avoid this, write to dummy arguments and give pass the entire !-- dummy array. Seems to be the only existing work-around. ALLOCATE( rrtm_sw_taucld_dum(1:nbndsw+1,0:0,k_topo+1:nzt_rad+1) ) ALLOCATE( rrtm_sw_ssacld_dum(1:nbndsw+1,0:0,k_topo+1:nzt_rad+1) ) ALLOCATE( rrtm_sw_asmcld_dum(1:nbndsw+1,0:0,k_topo+1:nzt_rad+1) ) ALLOCATE( rrtm_sw_fsfcld_dum(1:nbndsw+1,0:0,k_topo+1:nzt_rad+1) ) ALLOCATE( rrtm_sw_tauaer_dum(0:0,k_topo+1:nzt_rad+1,1:nbndsw+1) ) ALLOCATE( rrtm_sw_ssaaer_dum(0:0,k_topo+1:nzt_rad+1,1:nbndsw+1) ) ALLOCATE( rrtm_sw_asmaer_dum(0:0,k_topo+1:nzt_rad+1,1:nbndsw+1) ) ALLOCATE( rrtm_sw_ecaer_dum(0:0,k_topo+1:nzt_rad+1,1:naerec+1) ) rrtm_sw_taucld_dum = rrtm_sw_taucld(1:nbndsw+1,0:0,k_topo+1:nzt_rad+1) rrtm_sw_ssacld_dum = rrtm_sw_ssacld(1:nbndsw+1,0:0,k_topo+1:nzt_rad+1) rrtm_sw_asmcld_dum = rrtm_sw_asmcld(1:nbndsw+1,0:0,k_topo+1:nzt_rad+1) rrtm_sw_fsfcld_dum = rrtm_sw_fsfcld(1:nbndsw+1,0:0,k_topo+1:nzt_rad+1) rrtm_sw_tauaer_dum = rrtm_sw_tauaer(0:0,k_topo+1:nzt_rad+1,1:nbndsw+1) rrtm_sw_ssaaer_dum = rrtm_sw_ssaaer(0:0,k_topo+1:nzt_rad+1,1:nbndsw+1) rrtm_sw_asmaer_dum = rrtm_sw_asmaer(0:0,k_topo+1:nzt_rad+1,1:nbndsw+1) rrtm_sw_ecaer_dum = rrtm_sw_ecaer(0:0,k_topo+1:nzt_rad+1,1:naerec+1) CALL rrtmg_sw( 1, & nzt_rad-k_topo, & rrtm_icld, & rrtm_iaer, & rrtm_play(:,k_topo+1:nzt_rad+1), & rrtm_plev(:,k_topo+1:nzt_rad+2), & rrtm_tlay(:,k_topo+1:nzt_rad+1), & rrtm_tlev(:,k_topo+1:nzt_rad+2), & rrtm_tsfc, & rrtm_h2ovmr(:,k_topo+1:nzt_rad+1), & rrtm_o3vmr(:,k_topo+1:nzt_rad+1), & rrtm_co2vmr(:,k_topo+1:nzt_rad+1), & rrtm_ch4vmr(:,k_topo+1:nzt_rad+1), & rrtm_n2ovmr(:,k_topo+1:nzt_rad+1), & rrtm_o2vmr(:,k_topo+1:nzt_rad+1), & rrtm_asdir, & rrtm_asdif, & rrtm_aldir, & rrtm_aldif, & zenith, & 0.0_wp, & day_of_year, & solar_constant, & rrtm_inflgsw, & rrtm_iceflgsw, & rrtm_liqflgsw, & rrtm_cldfr(:,k_topo+1:nzt_rad+1), & rrtm_sw_taucld_dum, & rrtm_sw_ssacld_dum, & rrtm_sw_asmcld_dum, & rrtm_sw_fsfcld_dum, & rrtm_cicewp(:,k_topo+1:nzt_rad+1), & rrtm_cliqwp(:,k_topo+1:nzt_rad+1), & rrtm_reice(:,k_topo+1:nzt_rad+1), & rrtm_reliq(:,k_topo+1:nzt_rad+1), & rrtm_sw_tauaer_dum, & rrtm_sw_ssaaer_dum, & rrtm_sw_asmaer_dum, & rrtm_sw_ecaer_dum, & rrtm_swuflx(:,k_topo:nzt_rad+1), & rrtm_swdflx(:,k_topo:nzt_rad+1), & rrtm_swhr(:,k_topo+1:nzt_rad+1), & rrtm_swuflxc(:,k_topo:nzt_rad+1), & rrtm_swdflxc(:,k_topo:nzt_rad+1), & rrtm_swhrc(:,k_topo+1:nzt_rad+1) ) DEALLOCATE( rrtm_sw_taucld_dum ) DEALLOCATE( rrtm_sw_ssacld_dum ) DEALLOCATE( rrtm_sw_asmcld_dum ) DEALLOCATE( rrtm_sw_fsfcld_dum ) DEALLOCATE( rrtm_sw_tauaer_dum ) DEALLOCATE( rrtm_sw_ssaaer_dum ) DEALLOCATE( rrtm_sw_asmaer_dum ) DEALLOCATE( rrtm_sw_ecaer_dum ) ! !-- Save fluxes DO k = nzb, nzt+1 rad_sw_in(k,j,i) = rrtm_swdflx(0,k) rad_sw_out(k,j,i) = rrtm_swuflx(0,k) ENDDO ! !-- Save heating rates (convert from K/d to K/s) DO k = nzb+1, nzt+1 rad_sw_hr(k,j,i) = rrtm_swhr(0,k) * d_hours_day rad_sw_cs_hr(k,j,i) = rrtm_swhrc(0,k) * d_hours_day ENDDO ! !-- Save surface radiative fluxes onto respective surface elements !-- Horizontal surfaces DO m = surf_def_h(0)%start_index(j,i), & surf_def_h(0)%end_index(j,i) surf_def_h(0)%rad_sw_in(m) = rrtm_swdflx(0,k_topo) surf_def_h(0)%rad_sw_out(m) = rrtm_swuflx(0,k_topo) ENDDO DO m = surf_lsm_h%start_index(j,i), & surf_lsm_h%end_index(j,i) surf_lsm_h%rad_sw_in(m) = rrtm_swdflx(0,k_topo) surf_lsm_h%rad_sw_out(m) = rrtm_swuflx(0,k_topo) ENDDO DO m = surf_usm_h%start_index(j,i), & surf_usm_h%end_index(j,i) surf_usm_h%rad_sw_in(m) = rrtm_swdflx(0,k_topo) surf_usm_h%rad_sw_out(m) = rrtm_swuflx(0,k_topo) ENDDO ! !-- Vertical surfaces. Fluxes are obtain at respective vertical !-- level of the surface element DO l = 0, 3 DO m = surf_def_v(l)%start_index(j,i), & surf_def_v(l)%end_index(j,i) k = surf_def_v(l)%k(m) surf_def_v(l)%rad_sw_in(m) = rrtm_swdflx(0,k) surf_def_v(l)%rad_sw_out(m) = rrtm_swuflx(0,k) ENDDO DO m = surf_lsm_v(l)%start_index(j,i), & surf_lsm_v(l)%end_index(j,i) k = surf_lsm_v(l)%k(m) surf_lsm_v(l)%rad_sw_in(m) = rrtm_swdflx(0,k) surf_lsm_v(l)%rad_sw_out(m) = rrtm_swuflx(0,k) ENDDO DO m = surf_usm_v(l)%start_index(j,i), & surf_usm_v(l)%end_index(j,i) k = surf_usm_v(l)%k(m) surf_usm_v(l)%rad_sw_in(m) = rrtm_swdflx(0,k) surf_usm_v(l)%rad_sw_out(m) = rrtm_swuflx(0,k) ENDDO ENDDO ENDIF ENDDO ENDDO ENDIF ! !-- Finally, calculate surface net radiation for surface elements. !-- First, for horizontal surfaces DO m = 1, surf_def_h(0)%ns surf_def_h(0)%rad_net(m) = surf_def_h(0)%rad_sw_in(m) & - surf_def_h(0)%rad_sw_out(m) & + surf_def_h(0)%rad_lw_in(m) & - surf_def_h(0)%rad_lw_out(m) ENDDO DO m = 1, surf_lsm_h%ns surf_lsm_h%rad_net(m) = surf_lsm_h%rad_sw_in(m) & - surf_lsm_h%rad_sw_out(m) & + surf_lsm_h%rad_lw_in(m) & - surf_lsm_h%rad_lw_out(m) ENDDO DO m = 1, surf_usm_h%ns surf_usm_h%rad_net(m) = surf_usm_h%rad_sw_in(m) & - surf_usm_h%rad_sw_out(m) & + surf_usm_h%rad_lw_in(m) & - surf_usm_h%rad_lw_out(m) ENDDO ! !-- Vertical surfaces. !-- Todo: weight with azimuth and zenith angle according to their orientation! DO l = 0, 3 DO m = 1, surf_def_v(l)%ns surf_def_v(l)%rad_net(m) = surf_def_v(l)%rad_sw_in(m) & - surf_def_v(l)%rad_sw_out(m) & + surf_def_v(l)%rad_lw_in(m) & - surf_def_v(l)%rad_lw_out(m) ENDDO DO m = 1, surf_lsm_v(l)%ns surf_lsm_v(l)%rad_net(m) = surf_lsm_v(l)%rad_sw_in(m) & - surf_lsm_v(l)%rad_sw_out(m) & + surf_lsm_v(l)%rad_lw_in(m) & - surf_lsm_v(l)%rad_lw_out(m) ENDDO DO m = 1, surf_usm_v(l)%ns surf_usm_v(l)%rad_net(m) = surf_usm_v(l)%rad_sw_in(m) & - surf_usm_v(l)%rad_sw_out(m) & + surf_usm_v(l)%rad_lw_in(m) & - surf_usm_v(l)%rad_lw_out(m) ENDDO ENDDO CALL exchange_horiz( rad_lw_in, nbgp ) CALL exchange_horiz( rad_lw_out, nbgp ) CALL exchange_horiz( rad_lw_hr, nbgp ) CALL exchange_horiz( rad_lw_cs_hr, nbgp ) CALL exchange_horiz( rad_sw_in, nbgp ) CALL exchange_horiz( rad_sw_out, nbgp ) CALL exchange_horiz( rad_sw_hr, nbgp ) CALL exchange_horiz( rad_sw_cs_hr, nbgp ) #endif END SUBROUTINE radiation_rrtmg !------------------------------------------------------------------------------! ! Description: ! ------------ !> Calculate the cosine of the zenith angle (variable is called zenith) !------------------------------------------------------------------------------! SUBROUTINE calc_zenith IMPLICIT NONE REAL(wp) :: declination, & !< solar declination angle hour_angle !< solar hour angle ! !-- Calculate current day and time based on the initial values and simulation !-- time CALL calc_date_and_time ! !-- Calculate solar declination and hour angle declination = ASIN( decl_1 * SIN(decl_2 * REAL(day_of_year, KIND=wp) - decl_3) ) hour_angle = 2.0_wp * pi * (time_utc / 86400.0_wp) + lon - pi ! !-- Calculate cosine of solar zenith angle zenith(0) = SIN(lat) * SIN(declination) + COS(lat) * COS(declination) & * COS(hour_angle) zenith(0) = MAX(0.0_wp,zenith(0)) ! !-- Calculate solar directional vector IF ( sun_direction ) THEN ! !-- Direction in longitudes equals to sin(solar_azimuth) * sin(zenith) sun_dir_lon(0) = -SIN(hour_angle) * COS(declination) ! !-- Direction in latitues equals to cos(solar_azimuth) * sin(zenith) sun_dir_lat(0) = SIN(declination) * COS(lat) - COS(hour_angle) & * COS(declination) * SIN(lat) ENDIF ! !-- Check if the sun is up (otheriwse shortwave calculations can be skipped) IF ( zenith(0) > 0.0_wp ) THEN sun_up = .TRUE. ELSE sun_up = .FALSE. END IF END SUBROUTINE calc_zenith #if defined ( __rrtmg ) && defined ( __netcdf ) !------------------------------------------------------------------------------! ! Description: ! ------------ !> Calculates surface albedo components based on Briegleb (1992) and !> Briegleb et al. (1986) !------------------------------------------------------------------------------! SUBROUTINE calc_albedo( surf ) IMPLICIT NONE INTEGER(iwp) :: m !< running index surface elements TYPE(surf_type) :: surf !< treated surfaces IF ( sun_up .AND. .NOT. average_radiation) THEN DO m = 1, surf%ns ! !-- Ocean IF ( surf%albedo_type(0,m) == 1 ) THEN surf%rrtm_aldir(m) = 0.026_wp / & ( zenith(0)**1.7_wp + 0.065_wp ) & + 0.15_wp * ( zenith(0) - 0.1_wp ) & * ( zenith(0) - 0.5_wp ) & * ( zenith(0) - 1.0_wp ) surf%rrtm_asdir(m) = surf%rrtm_aldir(m) ! !-- Snow ELSEIF ( surf%albedo_type(0,m) == 16 ) THEN IF ( zenith(0) < 0.5_wp ) THEN surf%rrtm_aldir(m) = 0.5_wp * (1.0_wp - surf%aldif(m)) & * ( 3.0_wp / (1.0_wp + 4.0_wp & * zenith(0))) - 1.0_wp surf%rrtm_asdir(m) = 0.5_wp * (1.0_wp - surf%asdif(m)) & * ( 3.0_wp / (1.0_wp + 4.0_wp & * zenith(0))) - 1.0_wp surf%rrtm_aldir(m) = MIN(0.98_wp, surf%rrtm_aldir(m)) surf%rrtm_asdir(m) = MIN(0.98_wp, surf%rrtm_asdir(m)) ELSE surf%rrtm_aldir(m) = surf%aldif(m) surf%rrtm_asdir(m) = surf%asdif(m) ENDIF ! !-- Sea ice ELSEIF ( surf%albedo_type(0,m) == 15 ) THEN surf%rrtm_aldir(m) = surf%aldif(m) surf%rrtm_asdir(m) = surf%asdif(m) ! !-- Asphalt ELSEIF ( surf%albedo_type(0,m) == 17 ) THEN surf%rrtm_aldir(m) = surf%aldif(m) surf%rrtm_asdir(m) = surf%asdif(m) ! !-- Bare soil ELSEIF ( surf%albedo_type(0,m) == 18 ) THEN surf%rrtm_aldir(m) = surf%aldif(m) surf%rrtm_asdir(m) = surf%asdif(m) ! !-- Land surfaces ELSE SELECT CASE ( surf%albedo_type(0,m) ) ! !-- Surface types with strong zenith dependence CASE ( 1, 2, 3, 4, 11, 12, 13 ) surf%rrtm_aldir(m) = surf%aldif(m) * 1.4_wp / & (1.0_wp + 0.8_wp * zenith(0)) surf%rrtm_asdir(m) = surf%asdif(m) * 1.4_wp / & (1.0_wp + 0.8_wp * zenith(0)) ! !-- Surface types with weak zenith dependence CASE ( 5, 6, 7, 8, 9, 10, 14 ) surf%rrtm_aldir(m) = surf%aldif(m) * 1.1_wp / & (1.0_wp + 0.2_wp * zenith(0)) surf%rrtm_asdir(m) = surf%asdif(m) * 1.1_wp / & (1.0_wp + 0.2_wp * zenith(0)) CASE DEFAULT END SELECT ENDIF ! !-- Diffusive albedo is taken from Table 2 surf%rrtm_aldif(m) = surf%aldif(m) surf%rrtm_asdif(m) = surf%asdif(m) ENDDO ! !-- Set albedo in case of average radiation ELSEIF ( sun_up .AND. average_radiation ) THEN surf%rrtm_asdir = albedo_urb surf%rrtm_asdif = albedo_urb surf%rrtm_aldir = albedo_urb surf%rrtm_aldif = albedo_urb ! !-- Darkness ELSE surf%rrtm_aldir = 0.0_wp surf%rrtm_asdir = 0.0_wp surf%rrtm_aldif = 0.0_wp surf%rrtm_asdif = 0.0_wp ENDIF END SUBROUTINE calc_albedo !------------------------------------------------------------------------------! ! Description: ! ------------ !> Read sounding data (pressure and temperature) from RADIATION_DATA. !------------------------------------------------------------------------------! SUBROUTINE read_sounding_data IMPLICIT NONE INTEGER(iwp) :: id, & !< NetCDF id of input file id_dim_zrad, & !< pressure level id in the NetCDF file id_var, & !< NetCDF variable id k, & !< loop index nz_snd, & !< number of vertical levels in the sounding data nz_snd_start, & !< start vertical index for sounding data to be used nz_snd_end !< end vertical index for souding data to be used REAL(wp) :: t_surface !< actual surface temperature REAL(wp), DIMENSION(:), ALLOCATABLE :: hyp_snd_tmp, & !< temporary hydrostatic pressure profile (sounding) t_snd_tmp !< temporary temperature profile (sounding) ! !-- In case of updates, deallocate arrays first (sufficient to check one !-- array as the others are automatically allocated). This is required !-- because nzt_rad might change during the update IF ( ALLOCATED ( hyp_snd ) ) THEN DEALLOCATE( hyp_snd ) DEALLOCATE( t_snd ) DEALLOCATE( q_snd ) DEALLOCATE ( rrtm_play ) DEALLOCATE ( rrtm_plev ) DEALLOCATE ( rrtm_tlay ) DEALLOCATE ( rrtm_tlev ) DEALLOCATE ( rrtm_h2ovmr ) DEALLOCATE ( rrtm_cicewp ) DEALLOCATE ( rrtm_cldfr ) DEALLOCATE ( rrtm_cliqwp ) DEALLOCATE ( rrtm_reice ) DEALLOCATE ( rrtm_reliq ) DEALLOCATE ( rrtm_lw_taucld ) DEALLOCATE ( rrtm_lw_tauaer ) DEALLOCATE ( rrtm_lwdflx ) DEALLOCATE ( rrtm_lwdflxc ) DEALLOCATE ( rrtm_lwuflx ) DEALLOCATE ( rrtm_lwuflxc ) DEALLOCATE ( rrtm_lwuflx_dt ) DEALLOCATE ( rrtm_lwuflxc_dt ) DEALLOCATE ( rrtm_lwhr ) DEALLOCATE ( rrtm_lwhrc ) DEALLOCATE ( rrtm_sw_taucld ) DEALLOCATE ( rrtm_sw_ssacld ) DEALLOCATE ( rrtm_sw_asmcld ) DEALLOCATE ( rrtm_sw_fsfcld ) DEALLOCATE ( rrtm_sw_tauaer ) DEALLOCATE ( rrtm_sw_ssaaer ) DEALLOCATE ( rrtm_sw_asmaer ) DEALLOCATE ( rrtm_sw_ecaer ) DEALLOCATE ( rrtm_swdflx ) DEALLOCATE ( rrtm_swdflxc ) DEALLOCATE ( rrtm_swuflx ) DEALLOCATE ( rrtm_swuflxc ) DEALLOCATE ( rrtm_swhr ) DEALLOCATE ( rrtm_swhrc ) ENDIF ! !-- Open file for reading nc_stat = NF90_OPEN( rrtm_input_file, NF90_NOWRITE, id ) CALL netcdf_handle_error_rad( 'read_sounding_data', 549 ) ! !-- Inquire dimension of z axis and save in nz_snd nc_stat = NF90_INQ_DIMID( id, "Pressure", id_dim_zrad ) nc_stat = NF90_INQUIRE_DIMENSION( id, id_dim_zrad, len = nz_snd ) CALL netcdf_handle_error_rad( 'read_sounding_data', 551 ) ! ! !-- Allocate temporary array for storing pressure data ALLOCATE( hyp_snd_tmp(1:nz_snd) ) hyp_snd_tmp = 0.0_wp !-- Read pressure from file nc_stat = NF90_INQ_VARID( id, "Pressure", id_var ) nc_stat = NF90_GET_VAR( id, id_var, hyp_snd_tmp(:), start = (/1/), & count = (/nz_snd/) ) CALL netcdf_handle_error_rad( 'read_sounding_data', 552 ) ! !-- Allocate temporary array for storing temperature data ALLOCATE( t_snd_tmp(1:nz_snd) ) t_snd_tmp = 0.0_wp ! !-- Read temperature from file nc_stat = NF90_INQ_VARID( id, "ReferenceTemperature", id_var ) nc_stat = NF90_GET_VAR( id, id_var, t_snd_tmp(:), start = (/1/), & count = (/nz_snd/) ) CALL netcdf_handle_error_rad( 'read_sounding_data', 553 ) ! !-- Calculate start of sounding data nz_snd_start = nz_snd + 1 nz_snd_end = nz_snd + 1 ! !-- Start filling vertical dimension at 10hPa above the model domain (hyp is !-- in Pa, hyp_snd in hPa). DO k = 1, nz_snd IF ( hyp_snd_tmp(k) < ( hyp(nzt+1) - 1000.0_wp) * 0.01_wp ) THEN nz_snd_start = k EXIT END IF END DO IF ( nz_snd_start <= nz_snd ) THEN nz_snd_end = nz_snd END IF ! !-- Calculate of total grid points for RRTMG calculations nzt_rad = nzt + nz_snd_end - nz_snd_start + 1 ! !-- Save data above LES domain in hyp_snd, t_snd and q_snd !-- Note: q_snd_tmp is not calculated at the moment (dry residual atmosphere) ALLOCATE( hyp_snd(nzb+1:nzt_rad) ) ALLOCATE( t_snd(nzb+1:nzt_rad) ) ALLOCATE( q_snd(nzb+1:nzt_rad) ) hyp_snd = 0.0_wp t_snd = 0.0_wp q_snd = 0.0_wp hyp_snd(nzt+2:nzt_rad) = hyp_snd_tmp(nz_snd_start+1:nz_snd_end) t_snd(nzt+2:nzt_rad) = t_snd_tmp(nz_snd_start+1:nz_snd_end) nc_stat = NF90_CLOSE( id ) ! !-- Calculate pressure levels on zu and zw grid. Sounding data is added at !-- top of the LES domain. This routine does not consider horizontal or !-- vertical variability of pressure and temperature ALLOCATE ( rrtm_play(0:0,nzb+1:nzt_rad+1) ) ALLOCATE ( rrtm_plev(0:0,nzb+1:nzt_rad+2) ) t_surface = pt_surface * ( surface_pressure / 1000.0_wp )**0.286_wp DO k = nzb+1, nzt+1 rrtm_play(0,k) = hyp(k) * 0.01_wp rrtm_plev(0,k) = surface_pressure * ( (t_surface - g/cp * zw(k-1)) / & t_surface )**(1.0_wp/0.286_wp) ENDDO DO k = nzt+2, nzt_rad rrtm_play(0,k) = hyp_snd(k) rrtm_plev(0,k) = 0.5_wp * ( rrtm_play(0,k) + rrtm_play(0,k-1) ) ENDDO rrtm_plev(0,nzt_rad+1) = MAX( 0.5 * hyp_snd(nzt_rad), & 1.5 * hyp_snd(nzt_rad) & - 0.5 * hyp_snd(nzt_rad-1) ) rrtm_plev(0,nzt_rad+2) = MIN( 1.0E-4_wp, & 0.25_wp * rrtm_plev(0,nzt_rad+1) ) rrtm_play(0,nzt_rad+1) = 0.5 * rrtm_plev(0,nzt_rad+1) ! !-- Calculate temperature/humidity levels at top of the LES domain. !-- Currently, the temperature is taken from sounding data (might lead to a !-- temperature jump at interface. To do: Humidity is currently not !-- calculated above the LES domain. ALLOCATE ( rrtm_tlay(0:0,nzb+1:nzt_rad+1) ) ALLOCATE ( rrtm_tlev(0:0,nzb+1:nzt_rad+2) ) ALLOCATE ( rrtm_h2ovmr(0:0,nzb+1:nzt_rad+1) ) DO k = nzt+8, nzt_rad rrtm_tlay(0,k) = t_snd(k) rrtm_h2ovmr(0,k) = q_snd(k) ENDDO rrtm_tlay(0,nzt_rad+1) = 2.0_wp * rrtm_tlay(0,nzt_rad) & - rrtm_tlay(0,nzt_rad-1) DO k = nzt+9, nzt_rad+1 rrtm_tlev(0,k) = rrtm_tlay(0,k-1) + (rrtm_tlay(0,k) & - rrtm_tlay(0,k-1)) & / ( rrtm_play(0,k) - rrtm_play(0,k-1) ) & * ( rrtm_plev(0,k) - rrtm_play(0,k-1) ) ENDDO rrtm_h2ovmr(0,nzt_rad+1) = rrtm_h2ovmr(0,nzt_rad) rrtm_tlev(0,nzt_rad+2) = 2.0_wp * rrtm_tlay(0,nzt_rad+1) & - rrtm_tlev(0,nzt_rad) ! !-- Allocate remaining RRTMG arrays ALLOCATE ( rrtm_cicewp(0:0,nzb+1:nzt_rad+1) ) ALLOCATE ( rrtm_cldfr(0:0,nzb+1:nzt_rad+1) ) ALLOCATE ( rrtm_cliqwp(0:0,nzb+1:nzt_rad+1) ) ALLOCATE ( rrtm_reice(0:0,nzb+1:nzt_rad+1) ) ALLOCATE ( rrtm_reliq(0:0,nzb+1:nzt_rad+1) ) ALLOCATE ( rrtm_lw_taucld(1:nbndlw+1,0:0,nzb+1:nzt_rad+1) ) ALLOCATE ( rrtm_lw_tauaer(0:0,nzb+1:nzt_rad+1,1:nbndlw+1) ) ALLOCATE ( rrtm_sw_taucld(1:nbndsw+1,0:0,nzb+1:nzt_rad+1) ) ALLOCATE ( rrtm_sw_ssacld(1:nbndsw+1,0:0,nzb+1:nzt_rad+1) ) ALLOCATE ( rrtm_sw_asmcld(1:nbndsw+1,0:0,nzb+1:nzt_rad+1) ) ALLOCATE ( rrtm_sw_fsfcld(1:nbndsw+1,0:0,nzb+1:nzt_rad+1) ) ALLOCATE ( rrtm_sw_tauaer(0:0,nzb+1:nzt_rad+1,1:nbndsw+1) ) ALLOCATE ( rrtm_sw_ssaaer(0:0,nzb+1:nzt_rad+1,1:nbndsw+1) ) ALLOCATE ( rrtm_sw_asmaer(0:0,nzb+1:nzt_rad+1,1:nbndsw+1) ) ALLOCATE ( rrtm_sw_ecaer(0:0,nzb+1:nzt_rad+1,1:naerec+1) ) ! !-- The ice phase is currently not considered in PALM rrtm_cicewp = 0.0_wp rrtm_reice = 0.0_wp ! !-- Set other parameters (move to NAMELIST parameters in the future) rrtm_lw_tauaer = 0.0_wp rrtm_lw_taucld = 0.0_wp rrtm_sw_taucld = 0.0_wp rrtm_sw_ssacld = 0.0_wp rrtm_sw_asmcld = 0.0_wp rrtm_sw_fsfcld = 0.0_wp rrtm_sw_tauaer = 0.0_wp rrtm_sw_ssaaer = 0.0_wp rrtm_sw_asmaer = 0.0_wp rrtm_sw_ecaer = 0.0_wp ALLOCATE ( rrtm_swdflx(0:0,nzb:nzt_rad+1) ) ALLOCATE ( rrtm_swuflx(0:0,nzb:nzt_rad+1) ) ALLOCATE ( rrtm_swhr(0:0,nzb+1:nzt_rad+1) ) ALLOCATE ( rrtm_swuflxc(0:0,nzb:nzt_rad+1) ) ALLOCATE ( rrtm_swdflxc(0:0,nzb:nzt_rad+1) ) ALLOCATE ( rrtm_swhrc(0:0,nzb+1:nzt_rad+1) ) rrtm_swdflx = 0.0_wp rrtm_swuflx = 0.0_wp rrtm_swhr = 0.0_wp rrtm_swuflxc = 0.0_wp rrtm_swdflxc = 0.0_wp rrtm_swhrc = 0.0_wp ALLOCATE ( rrtm_lwdflx(0:0,nzb:nzt_rad+1) ) ALLOCATE ( rrtm_lwuflx(0:0,nzb:nzt_rad+1) ) ALLOCATE ( rrtm_lwhr(0:0,nzb+1:nzt_rad+1) ) ALLOCATE ( rrtm_lwuflxc(0:0,nzb:nzt_rad+1) ) ALLOCATE ( rrtm_lwdflxc(0:0,nzb:nzt_rad+1) ) ALLOCATE ( rrtm_lwhrc(0:0,nzb+1:nzt_rad+1) ) rrtm_lwdflx = 0.0_wp rrtm_lwuflx = 0.0_wp rrtm_lwhr = 0.0_wp rrtm_lwuflxc = 0.0_wp rrtm_lwdflxc = 0.0_wp rrtm_lwhrc = 0.0_wp ALLOCATE ( rrtm_lwuflx_dt(0:0,nzb:nzt_rad+1) ) ALLOCATE ( rrtm_lwuflxc_dt(0:0,nzb:nzt_rad+1) ) rrtm_lwuflx_dt = 0.0_wp rrtm_lwuflxc_dt = 0.0_wp END SUBROUTINE read_sounding_data !------------------------------------------------------------------------------! ! Description: ! ------------ !> Read trace gas data from file !------------------------------------------------------------------------------! SUBROUTINE read_trace_gas_data USE rrsw_ncpar IMPLICIT NONE INTEGER(iwp), PARAMETER :: num_trace_gases = 9 !< number of trace gases (absorbers) CHARACTER(LEN=5), DIMENSION(num_trace_gases), PARAMETER :: & !< trace gas names trace_names = (/'O3 ', 'CO2 ', 'CH4 ', 'N2O ', 'O2 ', & 'CFC11', 'CFC12', 'CFC22', 'CCL4 '/) INTEGER(iwp) :: id, & !< NetCDF id k, & !< loop index m, & !< loop index n, & !< loop index nabs, & !< number of absorbers np, & !< number of pressure levels id_abs, & !< NetCDF id of the respective absorber id_dim, & !< NetCDF id of asborber's dimension id_var !< NetCDf id ot the absorber REAL(wp) :: p_mls_l, p_mls_u, p_wgt_l, p_wgt_u, p_mls_m REAL(wp), DIMENSION(:), ALLOCATABLE :: p_mls, & !< pressure levels for the absorbers rrtm_play_tmp, & !< temporary array for pressure zu-levels rrtm_plev_tmp, & !< temporary array for pressure zw-levels trace_path_tmp !< temporary array for storing trace gas path data REAL(wp), DIMENSION(:,:), ALLOCATABLE :: trace_mls, & !< array for storing the absorber amounts trace_mls_path, & !< array for storing trace gas path data trace_mls_tmp !< temporary array for storing trace gas data ! !-- In case of updates, deallocate arrays first (sufficient to check one !-- array as the others are automatically allocated) IF ( ALLOCATED ( rrtm_o3vmr ) ) THEN DEALLOCATE ( rrtm_o3vmr ) DEALLOCATE ( rrtm_co2vmr ) DEALLOCATE ( rrtm_ch4vmr ) DEALLOCATE ( rrtm_n2ovmr ) DEALLOCATE ( rrtm_o2vmr ) DEALLOCATE ( rrtm_cfc11vmr ) DEALLOCATE ( rrtm_cfc12vmr ) DEALLOCATE ( rrtm_cfc22vmr ) DEALLOCATE ( rrtm_ccl4vmr ) ENDIF ! !-- Allocate trace gas profiles ALLOCATE ( rrtm_o3vmr(0:0,1:nzt_rad+1) ) ALLOCATE ( rrtm_co2vmr(0:0,1:nzt_rad+1) ) ALLOCATE ( rrtm_ch4vmr(0:0,1:nzt_rad+1) ) ALLOCATE ( rrtm_n2ovmr(0:0,1:nzt_rad+1) ) ALLOCATE ( rrtm_o2vmr(0:0,1:nzt_rad+1) ) ALLOCATE ( rrtm_cfc11vmr(0:0,1:nzt_rad+1) ) ALLOCATE ( rrtm_cfc12vmr(0:0,1:nzt_rad+1) ) ALLOCATE ( rrtm_cfc22vmr(0:0,1:nzt_rad+1) ) ALLOCATE ( rrtm_ccl4vmr(0:0,1:nzt_rad+1) ) ! !-- Open file for reading nc_stat = NF90_OPEN( rrtm_input_file, NF90_NOWRITE, id ) CALL netcdf_handle_error_rad( 'read_trace_gas_data', 549 ) ! !-- Inquire dimension ids and dimensions nc_stat = NF90_INQ_DIMID( id, "Pressure", id_dim ) CALL netcdf_handle_error_rad( 'read_trace_gas_data', 550 ) nc_stat = NF90_INQUIRE_DIMENSION( id, id_dim, len = np) CALL netcdf_handle_error_rad( 'read_trace_gas_data', 550 ) nc_stat = NF90_INQ_DIMID( id, "Absorber", id_dim ) CALL netcdf_handle_error_rad( 'read_trace_gas_data', 550 ) nc_stat = NF90_INQUIRE_DIMENSION( id, id_dim, len = nabs ) CALL netcdf_handle_error_rad( 'read_trace_gas_data', 550 ) ! !-- Allocate pressure, and trace gas arrays ALLOCATE( p_mls(1:np) ) ALLOCATE( trace_mls(1:num_trace_gases,1:np) ) ALLOCATE( trace_mls_tmp(1:nabs,1:np) ) nc_stat = NF90_INQ_VARID( id, "Pressure", id_var ) CALL netcdf_handle_error_rad( 'read_trace_gas_data', 550 ) nc_stat = NF90_GET_VAR( id, id_var, p_mls ) CALL netcdf_handle_error_rad( 'read_trace_gas_data', 550 ) nc_stat = NF90_INQ_VARID( id, "AbsorberAmountMLS", id_var ) CALL netcdf_handle_error_rad( 'read_trace_gas_data', 550 ) nc_stat = NF90_GET_VAR( id, id_var, trace_mls_tmp ) CALL netcdf_handle_error_rad( 'read_trace_gas_data', 550 ) ! !-- Write absorber amounts (mls) to trace_mls DO n = 1, num_trace_gases CALL getAbsorberIndex( TRIM( trace_names(n) ), id_abs ) trace_mls(n,1:np) = trace_mls_tmp(id_abs,1:np) ! !-- Replace missing values by zero WHERE ( trace_mls(n,:) > 2.0_wp ) trace_mls(n,:) = 0.0_wp END WHERE END DO DEALLOCATE ( trace_mls_tmp ) nc_stat = NF90_CLOSE( id ) CALL netcdf_handle_error_rad( 'read_trace_gas_data', 551 ) ! !-- Add extra pressure level for calculations of the trace gas paths ALLOCATE ( rrtm_play_tmp(1:nzt_rad+1) ) ALLOCATE ( rrtm_plev_tmp(1:nzt_rad+2) ) rrtm_play_tmp(1:nzt_rad) = rrtm_play(0,1:nzt_rad) rrtm_plev_tmp(1:nzt_rad+1) = rrtm_plev(0,1:nzt_rad+1) rrtm_play_tmp(nzt_rad+1) = rrtm_plev(0,nzt_rad+1) * 0.5_wp rrtm_plev_tmp(nzt_rad+2) = MIN( 1.0E-4_wp, 0.25_wp & * rrtm_plev(0,nzt_rad+1) ) ! !-- Calculate trace gas path (zero at surface) with interpolation to the !-- sounding levels ALLOCATE ( trace_mls_path(1:nzt_rad+2,1:num_trace_gases) ) trace_mls_path(nzb+1,:) = 0.0_wp DO k = nzb+2, nzt_rad+2 DO m = 1, num_trace_gases trace_mls_path(k,m) = trace_mls_path(k-1,m) ! !-- When the pressure level is higher than the trace gas pressure !-- level, assume that IF ( rrtm_plev_tmp(k-1) > p_mls(1) ) THEN trace_mls_path(k,m) = trace_mls_path(k,m) + trace_mls(m,1) & * ( rrtm_plev_tmp(k-1) & - MAX( p_mls(1), rrtm_plev_tmp(k) ) & ) / g ENDIF ! !-- Integrate for each sounding level from the contributing p_mls !-- levels DO n = 2, np ! !-- Limit p_mls so that it is within the model level p_mls_u = MIN( rrtm_plev_tmp(k-1), & MAX( rrtm_plev_tmp(k), p_mls(n) ) ) p_mls_l = MIN( rrtm_plev_tmp(k-1), & MAX( rrtm_plev_tmp(k), p_mls(n-1) ) ) IF ( p_mls_l > p_mls_u ) THEN ! !-- Calculate weights for interpolation p_mls_m = 0.5_wp * (p_mls_l + p_mls_u) p_wgt_u = (p_mls(n-1) - p_mls_m) / (p_mls(n-1) - p_mls(n)) p_wgt_l = (p_mls_m - p_mls(n)) / (p_mls(n-1) - p_mls(n)) ! !-- Add level to trace gas path trace_mls_path(k,m) = trace_mls_path(k,m) & + ( p_wgt_u * trace_mls(m,n) & + p_wgt_l * trace_mls(m,n-1) ) & * (p_mls_l - p_mls_u) / g ENDIF ENDDO IF ( rrtm_plev_tmp(k) < p_mls(np) ) THEN trace_mls_path(k,m) = trace_mls_path(k,m) + trace_mls(m,np) & * ( MIN( rrtm_plev_tmp(k-1), p_mls(np) ) & - rrtm_plev_tmp(k) & ) / g ENDIF ENDDO ENDDO ! !-- Prepare trace gas path profiles ALLOCATE ( trace_path_tmp(1:nzt_rad+1) ) DO m = 1, num_trace_gases trace_path_tmp(1:nzt_rad+1) = ( trace_mls_path(2:nzt_rad+2,m) & - trace_mls_path(1:nzt_rad+1,m) ) * g & / ( rrtm_plev_tmp(1:nzt_rad+1) & - rrtm_plev_tmp(2:nzt_rad+2) ) ! !-- Save trace gas paths to the respective arrays SELECT CASE ( TRIM( trace_names(m) ) ) CASE ( 'O3' ) rrtm_o3vmr(0,:) = trace_path_tmp(:) CASE ( 'CO2' ) rrtm_co2vmr(0,:) = trace_path_tmp(:) CASE ( 'CH4' ) rrtm_ch4vmr(0,:) = trace_path_tmp(:) CASE ( 'N2O' ) rrtm_n2ovmr(0,:) = trace_path_tmp(:) CASE ( 'O2' ) rrtm_o2vmr(0,:) = trace_path_tmp(:) CASE ( 'CFC11' ) rrtm_cfc11vmr(0,:) = trace_path_tmp(:) CASE ( 'CFC12' ) rrtm_cfc12vmr(0,:) = trace_path_tmp(:) CASE ( 'CFC22' ) rrtm_cfc22vmr(0,:) = trace_path_tmp(:) CASE ( 'CCL4' ) rrtm_ccl4vmr(0,:) = trace_path_tmp(:) CASE DEFAULT END SELECT ENDDO DEALLOCATE ( trace_path_tmp ) DEALLOCATE ( trace_mls_path ) DEALLOCATE ( rrtm_play_tmp ) DEALLOCATE ( rrtm_plev_tmp ) DEALLOCATE ( trace_mls ) DEALLOCATE ( p_mls ) END SUBROUTINE read_trace_gas_data SUBROUTINE netcdf_handle_error_rad( routine_name, errno ) USE control_parameters, & ONLY: message_string USE NETCDF USE pegrid IMPLICIT NONE CHARACTER(LEN=6) :: message_identifier CHARACTER(LEN=*) :: routine_name INTEGER(iwp) :: errno IF ( nc_stat /= NF90_NOERR ) THEN WRITE( message_identifier, '(''NC'',I4.4)' ) errno message_string = TRIM( NF90_STRERROR( nc_stat ) ) CALL message( routine_name, message_identifier, 2, 2, 0, 6, 1 ) ENDIF END SUBROUTINE netcdf_handle_error_rad #endif !------------------------------------------------------------------------------! ! Description: ! ------------ !> Calculate temperature tendency due to radiative cooling/heating. !> Cache-optimized version. !------------------------------------------------------------------------------! SUBROUTINE radiation_tendency_ij ( i, j, tend ) USE cloud_parameters, & ONLY: pt_d_t IMPLICIT NONE INTEGER(iwp) :: i, j, k !< loop indices REAL(wp), DIMENSION(nzb:nzt+1,nysg:nyng,nxlg:nxrg) :: tend !< pt tendency term IF ( radiation_scheme == 'rrtmg' ) THEN #if defined ( __rrtmg ) ! !-- Calculate tendency based on heating rate DO k = nzb+1, nzt+1 tend(k,j,i) = tend(k,j,i) + (rad_lw_hr(k,j,i) + rad_sw_hr(k,j,i)) & * pt_d_t(k) * d_seconds_hour ENDDO #endif ENDIF END SUBROUTINE radiation_tendency_ij !------------------------------------------------------------------------------! ! Description: ! ------------ !> Calculate temperature tendency due to radiative cooling/heating. !> Vector-optimized version !------------------------------------------------------------------------------! SUBROUTINE radiation_tendency ( tend ) USE cloud_parameters, & ONLY: pt_d_t USE indices, & ONLY: nxl, nxr, nyn, nys IMPLICIT NONE INTEGER(iwp) :: i, j, k !< loop indices REAL(wp), DIMENSION(nzb:nzt+1,nysg:nyng,nxlg:nxrg) :: tend !< pt tendency term IF ( radiation_scheme == 'rrtmg' ) THEN #if defined ( __rrtmg ) ! !-- Calculate tendency based on heating rate DO i = nxl, nxr DO j = nys, nyn DO k = nzb+1, nzt+1 tend(k,j,i) = tend(k,j,i) + ( rad_lw_hr(k,j,i) & + rad_sw_hr(k,j,i) ) * pt_d_t(k) & * d_seconds_hour ENDDO ENDDO ENDDO #endif ENDIF END SUBROUTINE radiation_tendency !------------------------------------------------------------------------------! ! Description: ! ------------ !> This subroutine calculates interaction of the solar radiation !> with urban and land surfaces and updates all surface heatfluxes, including !> the vertual atmospheric cell faces. It calculates also the required parameters !> for RRTMG lower BC. !> !> For more info. see Resler et al. 2017 !> !------------------------------------------------------------------------------! SUBROUTINE radiation_interaction_init USE netcdf_data_input_mod, & ONLY: leaf_area_density_f USE plant_canopy_model_mod, & ONLY: plant_canopy, pch_index, & pc_heating_rate, lad_s, prototype_lad, usm_lad_rma IMPLICIT NONE INTEGER(iwp) :: i, j, k, d, l, ir, jr, ids, m INTEGER(iwp) :: k_topo !< vertical index indicating topography top for given (j,i) INTEGER(iwp) :: k_topo2 !< vertical index indicating topography top for given (j,i) INTEGER(iwp) :: nzubl, nzutl, isurf, ipcgb INTEGER(iwp) :: procid INTEGER(iwp), DIMENSION(1:4,inorth_b:iwest_b) :: ijdb !< start and end of the local domain border coordinates (set in code) LOGICAL, DIMENSION(inorth_b:iwest_b) :: isborder !< is PE on the border of the domain in four corresponding directions ! !-- Find nzub, nzut, nzu via wall_flag_0 array (nzb_s_inner will be !-- removed later). The following contruct finds the lowest / largest index !-- for any upward-facing wall (see bit 12). nzubl = MINVAL( get_topography_top_index( 's' ) ) nzutl = MAXVAL( get_topography_top_index( 's' ) ) nzubl = MAX( nzubl, nzb ) IF ( plant_canopy ) THEN !-- allocate needed arrays ALLOCATE( pct(nys:nyn,nxl:nxr) ) ALLOCATE( pch(nys:nyn,nxl:nxr) ) !-- calculate plant canopy height npcbl = 0 pct = 0 pch = 0 DO i = nxl, nxr DO j = nys, nyn ! !-- Find topography top index k_topo = get_topography_top_index_ji( j, i, 's' ) DO k = nzt+1, 0, -1 IF ( lad_s(k,j,i) /= 0.0_wp ) THEN !-- we are at the top of the pcs pct(j,i) = k + k_topo pch(j,i) = k npcbl = npcbl + pch(j,i) EXIT ENDIF ENDDO ENDDO ENDDO nzutl = MAX( nzutl, MAXVAL( pct ) ) !-- code of plant canopy model uses parameter pch_index !-- we need to setup it here to right value !-- (pch_index, lad_s and other arrays in PCM are defined flat) pch_index = MERGE( leaf_area_density_f%nz - 1, MAXVAL( pch ), & leaf_area_density_f%from_file ) prototype_lad = MAXVAL( lad_s ) * .9_wp !< better be *1.0 if lad is either 0 or maxval(lad) everywhere IF ( prototype_lad <= 0._wp ) prototype_lad = .3_wp !WRITE(message_string, '(a,f6.3)') 'Precomputing effective box optical ' & ! // 'depth using prototype leaf area density = ', prototype_lad !CALL message('usm_init_urban_surface', 'PA0520', 0, 0, -1, 6, 0) ENDIF nzutl = MIN( nzutl + nzut_free, nzt ) #if defined( __parallel ) CALL MPI_AllReduce(nzubl, nzub, 1, MPI_INTEGER, MPI_MIN, comm2d, ierr ) CALL MPI_AllReduce(nzutl, nzut, 1, MPI_INTEGER, MPI_MAX, comm2d, ierr ) #else nzub = nzubl nzut = nzutl #endif ! !-- global number of urban layers nzu = nzut - nzub + 1 ! !-- allocate urban surfaces grid !-- calc number of surfaces in local proc CALL location_message( ' calculation of indices for surfaces', .TRUE. ) nsurfl = 0 ! !-- Number of horizontal surfaces including land- and roof surfaces in both USM and LSM. Note that !-- All horizontal surface elements are already counted in surface_mod. startland = 1 nsurfl = surf_usm_h%ns + surf_lsm_h%ns endland = nsurfl nlands = endland - startland + 1 ! !-- Number of vertical surfaces in both USM and LSM. Note that all vertical surface elements are !-- already counted in surface_mod. startwall = nsurfl+1 DO i = 0,3 nsurfl = nsurfl + surf_usm_v(i)%ns + surf_lsm_v(i)%ns ENDDO endwall = nsurfl nwalls = endwall - startwall + 1 !-- range of energy balance surfaces ! will be treated separately by surf_usm_h and surf_usm_v !-- Do we really need usm_energy_balance_land??!! !-- !!! Attention: if usm_energy_balance_land = false then only vertical surfaces will be considered here nenergy = 0 IF ( energy_balance_surf_h ) THEN startenergy = startland nenergy = nenergy + nlands ELSE startenergy = startwall ENDIF IF ( energy_balance_surf_v ) THEN endenergy = endwall nenergy = nenergy + nwalls ELSE endenergy = endland ENDIF !!!!!!!!!!!!!!!!!!!!!!!!!!!!! !-- block of virtual surfaces !!!!!!!!!!!!!!!!!!!!!!!!!!!!! !-- calculate sky surfaces ! not used so far! startsky = nsurfl+1 nsurfl = nsurfl+(nxr-nxl+1)*(nyn-nys+1) endsky = nsurfl nskys = endsky-startsky+1 !-- border flags #if defined( __parallel ) isborder = (/ north_border_pe, south_border_pe, right_border_pe, left_border_pe /) #else isborder = (/.TRUE.,.TRUE.,.TRUE.,.TRUE./) #endif !-- fill array of the limits of the local domain borders ijdb = RESHAPE( (/ nxl,nxr,nyn,nyn,nxl,nxr,nys,nys,nxr,nxr,nys,nyn,nxl,nxl,nys,nyn /), (/4, 4/) ) !-- calulation of the free borders of the domain startborder = nsurfl + 1 DO ids = inorth_b,iwest_b IF ( isborder(ids) ) THEN !-- free border of the domain in direction ids DO i = ijdb(1,ids), ijdb(2,ids) DO j = ijdb(3,ids), ijdb(4,ids) k_topo = get_topography_top_index_ji( j, i, 's' ) k_topo2 = get_topography_top_index_ji( j-jdir(ids), i-idir(ids), 's' ) k = nzut - MAX( k_topo, k_topo2 ) nsurfl = nsurfl + k ENDDO ENDDO ENDIF ENDDO endborder = nsurfl nborder = endborder - startborder + 1 !-- calulation of the atmospheric virtual surfaces !-- each atmospheric cell has 6 faces IF ( atm_surfaces ) THEN DO i = nxl, nxr DO j = nys, nyn !-- Find topography top index k_topo = get_topography_top_index_ji( j, i, 's' ) k = nzut - k_topo nsurfl = nsurfl + 6 * k ENDDO ENDDO !-- exclude the local physical surfaces nsurfl = nsurfl - nlands - nwalls !-- exclude the local virtual surfaces nsurfl = nsurfl - nskys - nborder ENDIF !-- fill gridpcbl and pcbl IF ( plant_canopy ) THEN ALLOCATE( pcbl(iz:ix, 1:npcbl) ) ALLOCATE( gridpcbl(nzub:nzut,nys:nyn,nxl:nxr) ) gridpcbl(:,:,:) = 0 ipcgb = 0 DO i = nxl, nxr DO j = nys, nyn ! !-- Find topography top index k_topo = get_topography_top_index_ji( j, i, 's' ) DO k = k_topo + 1, pct(j,i) ipcgb = ipcgb + 1 gridpcbl(k,j,i) = ipcgb pcbl(:,ipcgb) = (/ k, j, i /) ENDDO ENDDO ENDDO ALLOCATE( pcbinsw( 1:npcbl ) ) ALLOCATE( pcbinlw( 1:npcbl ) ) ENDIF !-- fill surfl ALLOCATE(surfl(5,nsurfl)) ! is it mecessary to allocate it with (5,nsurfl)? isurf = 0 !-- add horizontal surface elements (land and urban surfaces) !-- TODO: add urban overhanging surfaces (idown_u) DO i = nxl, nxr DO j = nys, nyn DO m = surf_usm_h%start_index(j,i), surf_usm_h%end_index(j,i) k = surf_usm_h%k(m) isurf = isurf + 1 surfl(:,isurf) = (/iup_u,k,j,i,m/) ENDDO DO m = surf_lsm_h%start_index(j,i), surf_lsm_h%end_index(j,i) k = surf_lsm_h%k(m) isurf = isurf + 1 surfl(:,isurf) = (/iup_l,k,j,i,m/) ENDDO ENDDO ENDDO !-- add vertical surface elements (land and urban surfaces) !-- TODO: remove the hard coding of l = 0 to l = idirection DO i = nxl, nxr DO j = nys, nyn l = 0 DO m = surf_usm_v(l)%start_index(j,i), surf_usm_v(l)%end_index(j,i) k = surf_usm_v(l)%k(m) isurf = isurf + 1 surfl(:,isurf) = (/inorth_u,k,j,i,m/) ENDDO DO m = surf_lsm_v(l)%start_index(j,i), surf_lsm_v(l)%end_index(j,i) k = surf_lsm_v(l)%k(m) isurf = isurf + 1 surfl(:,isurf) = (/inorth_l,k,j,i,m/) ENDDO l = 1 DO m = surf_usm_v(l)%start_index(j,i), surf_usm_v(l)%end_index(j,i) k = surf_usm_v(l)%k(m) isurf = isurf + 1 surfl(:,isurf) = (/isouth_u,k,j,i,m/) ENDDO DO m = surf_lsm_v(l)%start_index(j,i), surf_lsm_v(l)%end_index(j,i) k = surf_lsm_v(l)%k(m) isurf = isurf + 1 surfl(:,isurf) = (/isouth_l,k,j,i,m/) ENDDO l = 2 DO m = surf_usm_v(l)%start_index(j,i), surf_usm_v(l)%end_index(j,i) k = surf_usm_v(l)%k(m) isurf = isurf + 1 surfl(:,isurf) = (/ieast_u,k,j,i,m/) ENDDO DO m = surf_lsm_v(l)%start_index(j,i), surf_lsm_v(l)%end_index(j,i) k = surf_lsm_v(l)%k(m) isurf = isurf + 1 surfl(:,isurf) = (/ieast_l,k,j,i,m/) ENDDO l = 3 DO m = surf_usm_v(l)%start_index(j,i), surf_usm_v(l)%end_index(j,i) k = surf_usm_v(l)%k(m) isurf = isurf + 1 surfl(:,isurf) = (/iwest_u,k,j,i,m/) ENDDO DO m = surf_lsm_v(l)%start_index(j,i), surf_lsm_v(l)%end_index(j,i) k = surf_lsm_v(l)%k(m) isurf = isurf + 1 surfl(:,isurf) = (/iwest_l,k,j,i,m/) ENDDO ENDDO ENDDO !-- add sky DO i = nxl, nxr DO j = nys, nyn isurf = isurf + 1 k = nzut surfl(:,isurf) = (/isky,k,j,i,-1/) ENDDO ENDDO !-- calulation of the free borders of the domain DO ids = inorth_b,iwest_b IF ( isborder(ids) ) THEN !-- free border of the domain in direction ids DO i = ijdb(1,ids), ijdb(2,ids) DO j = ijdb(3,ids), ijdb(4,ids) k_topo = get_topography_top_index_ji( j, i, 's' ) k_topo2 = get_topography_top_index_ji( j-jdir(ids), i-idir(ids), 's' ) DO k = MAX(k_topo,k_topo2)+1, nzut isurf = isurf + 1 surfl(:,isurf) = (/ids,k,j,i,-1/) ENDDO ENDDO ENDDO ENDIF ENDDO !-- adding the atmospheric virtual surfaces IF ( atm_surfaces ) THEN !-- TODO: use flags to identfy atmospheric cells and its coresponding surfaces !-- add horizontal surface DO i = nxl, nxr DO j = nys, nyn k_topo = get_topography_top_index_ji( j, i, 's' ) !-- add upward surface DO k = (k_topo+1), nzut-1 isurf = isurf + 1 surfl(:,isurf) = (/iup_a,k+1,j,i,-1/) ENDDO !-- add downward surface DO k = (k_topo+1), nzut-1 isurf = isurf + 1 surfl(:,isurf) = (/idown_a,k,j,i,-1/) ENDDO ENDDO ENDDO !-- add vertical surfaces DO i = nxl, nxr DO j = nys, nyn k_topo = get_topography_top_index_ji( j, i, 's' ) !-- north IF ( j /= ny ) THEN ids = inorth_a jr = min(max(j-jdir(ids),0),ny) ir = min(max(i-idir(ids),0),nx) k_topo2 = get_topography_top_index_ji( jr, ir, 's' ) DO k = MAX(k_topo,k_topo2)+1, nzut isurf = isurf + 1 surfl(:,isurf) = (/inorth_a,k,j,i,-1/) ENDDO END IF !-- south IF ( j /= 0 ) THEN ids = isouth_a jr = min(max(j-jdir(ids),0),ny) ir = min(max(i-idir(ids),0),nx) k_topo2 = get_topography_top_index_ji( jr, ir, 's' ) DO k = MAX(k_topo,k_topo2)+1, nzut isurf = isurf + 1 surfl(:,isurf) = (/isouth_a,k,j,i,-1/) ENDDO END IF !-- east IF ( i /= nx ) THEN ids = ieast_a jr = min(max(j-jdir(ids),0),ny) ir = min(max(i-idir(ids),0),nx) k_topo2 = get_topography_top_index_ji( jr, ir, 's' ) DO k = MAX(k_topo,k_topo2)+1, nzut isurf = isurf + 1 surfl(:,isurf) = (/ieast_a,k,j,i,-1/) ENDDO END IF !-- west IF ( i /= 0 ) THEN ids = iwest_a jr = min(max(j-jdir(ids),0),ny) ir = min(max(i-idir(ids),0),nx) k_topo2 = get_topography_top_index_ji( jr, ir, 's' ) DO k = MAX(k_topo,k_topo2)+1, nzut isurf = isurf + 1 surfl(:,isurf) = (/iwest_a,k,j,i,-1/) ENDDO END IF ENDDO ENDDO ENDIF ! !-- broadband albedo of the land, roof and wall surface !-- for domain border and sky set artifically to 1.0 !-- what allows us to calculate heat flux leaving over !-- side and top borders of the domain ALLOCATE ( albedo_surf(nsurfl) ) albedo_surf = 1.0_wp ! !-- Also allocate further array for emissivity with identical order of !-- surface elements as radiation arrays. !-- MS: Why startenergy:endenergy and albedo surf from 1:nsurfl ? ALLOCATE ( emiss_surf(startenergy:endenergy) ) ! !-- global array surf of indices of surfaces and displacement index array surfstart ALLOCATE(nsurfs(0:numprocs-1)) #if defined( __parallel ) CALL MPI_Allgather(nsurfl,1,MPI_INTEGER,nsurfs,1,MPI_INTEGER,comm2d,ierr) #else nsurfs(0) = nsurfl #endif ALLOCATE(surfstart(0:numprocs)) k = 0 DO i=0,numprocs-1 surfstart(i) = k k = k+nsurfs(i) ENDDO surfstart(numprocs) = k nsurf = k ALLOCATE(surf(5,nsurf)) #if defined( __parallel ) CALL MPI_AllGatherv(surfl, nsurfl*5, MPI_INTEGER, surf, nsurfs*5, surfstart*5, MPI_INTEGER, comm2d, ierr) #else surf = surfl #endif !-- !-- allocation of the arrays for direct and diffusion radiation CALL location_message( ' allocation of radiation arrays', .TRUE. ) !-- rad_sw_in, rad_lw_in are computed in radiation model, !-- splitting of direct and diffusion part is done !-- in usm_calc_diffusion_radiation for now ALLOCATE( rad_sw_in_dir(nysg:nyng,nxlg:nxrg) ) ALLOCATE( rad_sw_in_diff(nysg:nyng,nxlg:nxrg) ) ALLOCATE( rad_lw_in_diff(nysg:nyng,nxlg:nxrg) ) rad_sw_in_dir = 0.0_wp rad_sw_in_diff = 0.0_wp rad_lw_in_diff = 0.0_wp !-- allocate radiation arrays ALLOCATE( surfins(nsurfl) ) ALLOCATE( surfinl(nsurfl) ) ALLOCATE( surfinsw(nsurfl) ) ALLOCATE( surfinlw(nsurfl) ) ALLOCATE( surfinswdir(nsurfl) ) ALLOCATE( surfinswdif(nsurfl) ) ALLOCATE( surfinlwdif(nsurfl) ) ALLOCATE( surfoutsl(startenergy:endenergy) ) ALLOCATE( surfoutll(startenergy:endenergy) ) ALLOCATE( surfoutsw(startenergy:endenergy) ) ALLOCATE( surfoutlw(startenergy:endenergy) ) ALLOCATE( surfouts(nsurf) ) !TODO: global surfaces without virtual ALLOCATE( surfoutl(nsurf) ) !TODO: global surfaces without virtual ! !-- @Mohamed !-- In case of average_radiation, aggregated surface albedo and emissivity, !-- also set initial value of t_rad_urb. !-- For the moment set an arbitrary initial value. IF ( average_radiation ) THEN albedo_urb = 0.5_wp emissivity_urb = 0.5_wp t_rad_urb = pt_surface ENDIF END SUBROUTINE radiation_interaction_init !------------------------------------------------------------------------------! ! Description: ! ------------ !> This subroutine calculates interaction of the solar radiation !> with urban and land surfaces and updates all surface heatfluxes, including !> the vertual atmospheric cell faces. It calculates also the required parameters !> for RRTMG lower BC. !> !> For more info. see Resler et al. 2017 !> !------------------------------------------------------------------------------! SUBROUTINE radiation_interaction USE control_parameters USE plant_canopy_model_mod, & ONLY: prototype_lad IMPLICIT NONE INTEGER(iwp) :: i, j, k, kk, is, js, d, ku, refstep, m, mm, l, ll INTEGER(iwp) :: ii, jj !< running indices INTEGER(iwp) :: nzubl, nzutl, isurf, isurfsrc, isurf1, isvf, icsf, ipcgb INTEGER(iwp), DIMENSION(4) :: bdycross REAL(wp), DIMENSION(3,3) :: mrot !< grid rotation matrix (xyz) REAL(wp), DIMENSION(3,0:nsurf_type) :: vnorm !< face direction normal vectors (xyz) REAL(wp), DIMENSION(3) :: sunorig !< grid rotated solar direction unit vector (xyz) REAL(wp), DIMENSION(3) :: sunorig_grid !< grid squashed solar direction unit vector (zyx) REAL(wp), DIMENSION(0:nsurf_type) :: costheta !< direct irradiance factor of solar angle REAL(wp), DIMENSION(nzub:nzut) :: pchf_prep !< precalculated factor for canopy temp tendency REAL(wp), PARAMETER :: alpha = 0._wp !< grid rotation (TODO: add to namelist or remove) REAL(wp) :: rx, ry, rz REAL(wp) :: pc_box_area, pc_abs_frac, pc_abs_eff INTEGER(iwp) :: pc_box_dimshift !< transform for best accuracy INTEGER(iwp), DIMENSION(0:3) :: reorder = (/ 1, 0, 3, 2 /) REAL(wp), DIMENSION(0:nsurf_type) :: facearea REAL(wp) :: pabsswl = 0.0_wp !< total absorbed SW radiation energy in local processor (W) REAL(wp) :: pabssw = 0.0_wp !< total absorbed SW radiation energy in all processors (W) REAL(wp) :: pabslwl = 0.0_wp !< total absorbed LW radiation energy in local processor (W) REAL(wp) :: pabslw = 0.0_wp !< total absorbed LW radiation energy in all processors (W) REAL(wp) :: pemitlwl = 0.0_wp !< total emitted LW radiation energy in all processors (W) REAL(wp) :: pemitlw = 0.0_wp !< total emitted LW radiation energy in all processors (W) REAL(wp) :: pinswl = 0.0_wp !< total received SW radiation energy in local processor (W) REAL(wp) :: pinsw = 0.0_wp !< total received SW radiation energy in all processor (W) REAL(wp) :: pinlwl = 0.0_wp !< total received LW radiation energy in local processor (W) REAL(wp) :: pinlw = 0.0_wp !< total received LW radiation energy in all processor (W) REAL(wp) :: emiss_sum_surfl !< sum of emissisivity of surfaces in local processor REAL(wp) :: emiss_sum_surf !< sum of emissisivity of surfaces in all processor REAL(wp) :: area_surfl !< total area of surfaces in local processor REAL(wp) :: area_surf !< total area of surfaces in all processor IF ( plant_canopy ) THEN pchf_prep(:) = r_d * (hyp(nzub:nzut) / 100000.0_wp)**0.286_wp & / (cp * hyp(nzub:nzut) * dx*dy*dz) !< equals to 1 / (rho * c_p * Vbox * T) ENDIF sun_direction = .TRUE. CALL calc_zenith !< required also for diffusion radiation !-- prepare rotated normal vectors and irradiance factor vnorm(1,:) = idir(:) vnorm(2,:) = jdir(:) vnorm(3,:) = kdir(:) mrot(1, :) = (/ cos(alpha), -sin(alpha), 0._wp /) mrot(2, :) = (/ sin(alpha), cos(alpha), 0._wp /) mrot(3, :) = (/ 0._wp, 0._wp, 1._wp /) sunorig = (/ sun_dir_lon, sun_dir_lat, zenith(0) /) sunorig = matmul(mrot, sunorig) DO d = 0, nsurf_type costheta(d) = dot_product(sunorig, vnorm(:,d)) ENDDO IF ( zenith(0) > 0 ) THEN !-- now we will "squash" the sunorig vector by grid box size in !-- each dimension, so that this new direction vector will allow us !-- to traverse the ray path within grid coordinates directly sunorig_grid = (/ sunorig(3)/dz, sunorig(2)/dy, sunorig(1)/dx /) !-- sunorig_grid = sunorig_grid / norm2(sunorig_grid) sunorig_grid = sunorig_grid / SQRT(SUM(sunorig_grid**2)) IF ( plant_canopy ) THEN !-- precompute effective box depth with prototype Leaf Area Density pc_box_dimshift = maxloc(sunorig, 1) - 1 CALL box_absorb(cshift((/dx,dy,dz/), pc_box_dimshift), & 60, prototype_lad, & cshift(sunorig, pc_box_dimshift), & pc_box_area, pc_abs_frac) pc_box_area = pc_box_area * sunorig(pc_box_dimshift+1) / sunorig(3) pc_abs_eff = log(1._wp - pc_abs_frac) / prototype_lad ENDIF ENDIF !-- split diffusion and direct part of the solar downward radiation !-- comming from radiation model and store it in 2D arrays !-- rad_sw_in_diff, rad_sw_in_dir and rad_lw_in_diff IF ( split_diffusion_radiation ) THEN CALL calc_diffusion_radiation ELSE DO i = nxl, nxr DO j = nys, nyn DO m = surf_def_h(0)%start_index(j,i), & surf_def_h(0)%end_index(j,i) rad_sw_in_diff(j,i) = 0.0_wp rad_sw_in_dir(j,i) = surf_def_h(0)%rad_sw_in(m) rad_lw_in_diff(j,i) = surf_def_h(0)%rad_lw_in(m) ENDDO DO m = surf_lsm_h%start_index(j,i), & surf_lsm_h%end_index(j,i) rad_sw_in_diff(j,i) = 0.0_wp rad_sw_in_dir(j,i) = surf_lsm_h%rad_sw_in(m) rad_lw_in_diff(j,i) = surf_lsm_h%rad_lw_in(m) ENDDO DO m = surf_usm_h%start_index(j,i), & surf_usm_h%end_index(j,i) rad_sw_in_diff(j,i) = 0.0_wp rad_sw_in_dir(j,i) = surf_usm_h%rad_sw_in(m) rad_lw_in_diff(j,i) = surf_usm_h%rad_lw_in(m) ENDDO ENDDO ENDDO ENDIF !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !-- First pass: direct + diffuse irradiance !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! surfinswdir = 0._wp !nsurfl surfinswdif = 0._wp !nsurfl surfinlwdif = 0._wp !nsurfl surfins = 0._wp !nsurfl surfinl = 0._wp !nsurfl surfoutsl(:) = 0.0_wp !start-end surfoutll(:) = 0.0_wp !start-end !-- Set up thermal radiation from surfaces !-- emiss_surf is defined only for surfaces for which energy balance is calculated !-- Workaround: reorder surface data type back on 1D array including all surfaces, !-- which implies to reorder horizontal and vertical surfaces ! !-- Horizontal walls mm = 1 DO i = nxl, nxr DO j = nys, nyn !-- urban DO m = surf_usm_h%start_index(j,i), surf_usm_h%end_index(j,i) surfoutll(mm) = SUM ( surf_usm_h%frac(:,m) * & surf_usm_h%emissivity(:,m) ) & * sigma_sb & * surf_usm_h%pt_surface(m)**4 albedo_surf(mm) = SUM ( surf_usm_h%frac(:,m) * & surf_usm_h%albedo(:,m) ) emiss_surf(mm) = SUM ( surf_usm_h%frac(:,m) * & surf_usm_h%emissivity(:,m) ) mm = mm + 1 ENDDO !-- land DO m = surf_lsm_h%start_index(j,i), surf_lsm_h%end_index(j,i) surfoutll(mm) = SUM ( surf_lsm_h%frac(:,m) * & surf_lsm_h%emissivity(:,m) ) & * sigma_sb & * surf_lsm_h%pt_surface(m)**4 albedo_surf(mm) = SUM ( surf_lsm_h%frac(:,m) * & surf_lsm_h%albedo(:,m) ) emiss_surf(mm) = SUM ( surf_lsm_h%frac(:,m) * & surf_lsm_h%emissivity(:,m) ) mm = mm + 1 ENDDO ENDDO ENDDO ! !-- Vertical walls DO i = nxl, nxr DO j = nys, nyn DO ll = 0, 3 l = reorder(ll) !-- urban DO m = surf_usm_v(l)%start_index(j,i), & surf_usm_v(l)%end_index(j,i) surfoutll(mm) = SUM ( surf_usm_v(l)%frac(:,m) * & surf_usm_v(l)%emissivity(:,m) ) & * sigma_sb & * surf_usm_v(l)%pt_surface(m)**4 albedo_surf(mm) = SUM ( surf_usm_v(l)%frac(:,m) * & surf_usm_v(l)%albedo(:,m) ) emiss_surf(mm) = SUM ( surf_usm_v(l)%frac(:,m) * & surf_usm_v(l)%emissivity(:,m) ) mm = mm + 1 ENDDO !-- land DO m = surf_lsm_v(l)%start_index(j,i), & surf_lsm_v(l)%end_index(j,i) surfoutll(mm) = SUM ( surf_lsm_v(l)%frac(:,m) * & surf_lsm_v(l)%emissivity(:,m) ) & * sigma_sb & * surf_lsm_v(l)%pt_surface(m)**4 albedo_surf(mm) = SUM ( surf_lsm_v(l)%frac(:,m) * & surf_lsm_v(l)%albedo(:,m) ) emiss_surf(mm) = SUM ( surf_lsm_v(l)%frac(:,m) * & surf_lsm_v(l)%emissivity(:,m) ) mm = mm + 1 ENDDO ENDDO ENDDO ENDDO #if defined( __parallel ) !-- might be optimized and gather only values relevant for current processor CALL MPI_AllGatherv(surfoutll, nenergy, MPI_REAL, & surfoutl, nsurfs, surfstart, MPI_REAL, comm2d, ierr) !nsurf global #else surfoutl(:) = surfoutll(:) !nsurf global #endif isurf1 = -1 !< previous processed surface DO isvf = 1, nsvfl isurf = svfsurf(1, isvf) k = surfl(iz, isurf) j = surfl(iy, isurf) i = surfl(ix, isurf) isurfsrc = svfsurf(2, isvf) IF ( zenith(0) > 0 .AND. isurf /= isurf1 ) THEN !-- locate the virtual surface where the direct solar ray crosses domain boundary !-- (once per target surface) d = surfl(id, isurf) rz = REAL(k, wp) - 0.5_wp * kdir(d) ry = REAL(j, wp) - 0.5_wp * jdir(d) rx = REAL(i, wp) - 0.5_wp * idir(d) CALL find_boundary_face( (/ rz, ry, rx /), sunorig_grid, bdycross) isurf1 = isurf ENDIF IF ( surf(id, isurfsrc) >= isky ) THEN !-- diffuse rad from boundary surfaces. Since it is a simply !-- calculated value, it is not assigned to surfref(s/l), !-- instead it is used directly here !-- we consider the radiation from the radiation model falling on surface !-- as the radiation falling on the top of urban layer into the place of the source surface !-- we consider it as a very reasonable simplification which allow as avoid !-- necessity of other global range arrays and some all to all mpi communication surfinswdif(isurf) = surfinswdif(isurf) + rad_sw_in_diff(j,i) * svf(1,isvf) * svf(2,isvf) !< canopy shading is applied only to shortwave surfinlwdif(isurf) = surfinlwdif(isurf) + rad_lw_in_diff(j,i) * svf(1,isvf) ELSE !-- for surface-to-surface factors we calculate thermal radiation in 1st pass surfinl(isurf) = surfinl(isurf) + svf(1,isvf) * surfoutl(isurfsrc) ENDIF IF ( zenith(0) > 0 .AND. all( surf(1:4,isurfsrc) == bdycross ) ) THEN !-- found svf between model boundary and the face => face isn't shaded surfinswdir(isurf) = rad_sw_in_dir(j,i) & * costheta(surfl(id, isurf)) * svf(2,isvf) / zenith(0) ENDIF ENDDO IF ( plant_canopy ) THEN pcbinsw(:) = 0._wp pcbinlw(:) = 0._wp !< will stay always 0 since we don't absorb lw anymore ! !-- pcsf first pass isurf1 = -1 !< previous processed pcgb DO icsf = 1, ncsfl ipcgb = csfsurf(1, icsf) i = pcbl(ix,ipcgb) j = pcbl(iy,ipcgb) k = pcbl(iz,ipcgb) isurfsrc = csfsurf(2, icsf) IF ( zenith(0) > 0 .AND. ipcgb /= isurf1 ) THEN !-- locate the virtual surface where the direct solar ray crosses domain boundary !-- (once per target PC gridbox) rz = REAL(k, wp) ry = REAL(j, wp) rx = REAL(i, wp) CALL find_boundary_face( (/ rz, ry, rx /), & sunorig_grid, bdycross) isurf1 = ipcgb ENDIF IF ( surf(id, isurfsrc) >= isky ) THEN !-- Diffuse rad from boundary surfaces. See comments for svf above. pcbinsw(ipcgb) = pcbinsw(ipcgb) + csf(1,icsf) * csf(2,icsf) * rad_sw_in_diff(j,i) !-- canopy shading is applied only to shortwave, therefore no absorbtion for lw !-- pcbinlw(ipcgb) = pcbinlw(ipcgb) + svf(1,isvf) * rad_lw_in_diff(j,i) !ELSE !-- Thermal radiation in 1st pass !-- pcbinlw(ipcgb) = pcbinlw(ipcgb) + svf(1,isvf) * surfoutl(isurfsrc) ENDIF IF ( zenith(0) > 0 .AND. ALL( surf(1:4,isurfsrc) == bdycross ) ) THEN !-- found svf between model boundary and the pcgb => pcgb isn't shaded pc_abs_frac = 1._wp - EXP(pc_abs_eff * lad_s(k,j,i)) pcbinsw(ipcgb) = pcbinsw(ipcgb) & + rad_sw_in_dir(j, i) * pc_box_area * csf(2,icsf) * pc_abs_frac ENDIF ENDDO ENDIF surfins(startenergy:endenergy) = surfinswdir(startenergy:endenergy) + surfinswdif(startenergy:endenergy) surfinl(startenergy:endenergy) = surfinl(startenergy:endenergy) + surfinlwdif(startenergy:endenergy) surfinsw(:) = surfins(:) surfinlw(:) = surfinl(:) surfoutsw(:) = 0.0_wp surfoutlw(:) = surfoutll(:) ! surfhf(startenergy:endenergy) = surfinsw(startenergy:endenergy) + surfinlw(startenergy:endenergy) & ! - surfoutsw(startenergy:endenergy) - surfoutlw(startenergy:endenergy) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !-- Next passes - reflections !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! DO refstep = 1, nrefsteps surfoutsl(startenergy:endenergy) = albedo_surf(startenergy:endenergy) * surfins(startenergy:endenergy) !-- for non-transparent surfaces, longwave albedo is 1 - emissivity surfoutll(startenergy:endenergy) = (1._wp - emiss_surf(startenergy:endenergy)) * surfinl(startenergy:endenergy) #if defined( __parallel ) CALL MPI_AllGatherv(surfoutsl, nsurfl, MPI_REAL, & surfouts, nsurfs, surfstart, MPI_REAL, comm2d, ierr) CALL MPI_AllGatherv(surfoutll, nsurfl, MPI_REAL, & surfoutl, nsurfs, surfstart, MPI_REAL, comm2d, ierr) #else surfouts(:) = surfoutsl(:) surfoutl(:) = surfoutll(:) #endif !-- reset for next pass input surfins(:) = 0._wp surfinl(:) = 0._wp !-- reflected radiation DO isvf = 1, nsvfl isurf = svfsurf(1, isvf) isurfsrc = svfsurf(2, isvf) !-- TODO: to remove if, use start+end for isvf IF ( surf(id, isurfsrc) < isky ) THEN surfins(isurf) = surfins(isurf) + svf(1,isvf) * svf(2,isvf) * surfouts(isurfsrc) surfinl(isurf) = surfinl(isurf) + svf(1,isvf) * surfoutl(isurfsrc) ENDIF ENDDO !-- radiation absorbed by plant canopy DO icsf = 1, ncsfl ipcgb = csfsurf(1, icsf) isurfsrc = csfsurf(2, icsf) IF ( surf(id, isurfsrc) < isky ) THEN pcbinsw(ipcgb) = pcbinsw(ipcgb) + csf(1,icsf) * csf(2,icsf) * surfouts(isurfsrc) !-- pcbinlw(ipcgb) = pcbinlw(ipcgb) + csf(1,icsf) * surfoutl(isurfsrc) ENDIF ENDDO surfinsw(:) = surfinsw(:) + surfins(:) surfinlw(:) = surfinlw(:) + surfinl(:) surfoutsw(startenergy:endenergy) = surfoutsw(startenergy:endenergy) + surfoutsl(startenergy:endenergy) surfoutlw(startenergy:endenergy) = surfoutlw(startenergy:endenergy) + surfoutll(startenergy:endenergy) ! surfhf(startenergy:endenergy) = surfinsw(startenergy:endenergy) + surfinlw(startenergy:endenergy) & ! - surfoutsw(startenergy:endenergy) - surfoutlw(startenergy:endenergy) ENDDO !-- push heat flux absorbed by plant canopy to respective 3D arrays IF ( plant_canopy ) THEN pc_heating_rate(:,:,:) = 0._wp DO ipcgb = 1, npcbl j = pcbl(iy, ipcgb) i = pcbl(ix, ipcgb) k = pcbl(iz, ipcgb) ! !-- Following expression equals former kk = k - nzb_s_inner(j,i) kk = k - get_topography_top_index_ji( j, i, 's' ) !- lad arrays are defined flat pc_heating_rate(kk, j, i) = (pcbinsw(ipcgb) + pcbinlw(ipcgb)) & * pchf_prep(k) * pt(k, j, i) !-- = dT/dt ENDDO ENDIF ! !-- Transfer radiation arrays required for energy balance to the respective data types DO i = startenergy, endenergy m = surfl(5,i) ! !-- (1) Urban surfaces !-- upward-facing IF ( surfl(1,i) == iup_u ) THEN surf_usm_h%rad_sw_in(m) = surfinsw(i) surf_usm_h%rad_sw_out(m) = surfoutsw(i) surf_usm_h%rad_lw_in(m) = surfinlw(i) surf_usm_h%rad_lw_out(m) = surfoutlw(i) surf_usm_h%rad_net(m) = surfinsw(i) - surfoutsw(i) + & surfinlw(i) - surfoutlw(i) ! !-- northward-facding ELSEIF ( surfl(1,i) == inorth_u ) THEN surf_usm_v(0)%rad_sw_in(m) = surfinsw(i) surf_usm_v(0)%rad_sw_out(m) = surfoutsw(i) surf_usm_v(0)%rad_lw_in(m) = surfinlw(i) surf_usm_v(0)%rad_lw_out(m) = surfoutlw(i) surf_usm_v(0)%rad_net(m) = surfinsw(i) - surfoutsw(i) + & surfinlw(i) - surfoutlw(i) ! !-- southward-facding ELSEIF ( surfl(1,i) == isouth_u ) THEN surf_usm_v(1)%rad_sw_in(m) = surfinsw(i) surf_usm_v(1)%rad_sw_out(m) = surfoutsw(i) surf_usm_v(1)%rad_lw_in(m) = surfinlw(i) surf_usm_v(1)%rad_lw_out(m) = surfoutlw(i) surf_usm_v(1)%rad_net(m) = surfinsw(i) - surfoutsw(i) + & surfinlw(i) - surfoutlw(i) ! !-- eastward-facing ELSEIF ( surfl(1,i) == ieast_u ) THEN surf_usm_v(2)%rad_sw_in(m) = surfinsw(i) surf_usm_v(2)%rad_sw_out(m) = surfoutsw(i) surf_usm_v(2)%rad_lw_in(m) = surfinlw(i) surf_usm_v(2)%rad_lw_out(m) = surfoutlw(i) surf_usm_v(2)%rad_net(m) = surfinsw(i) - surfoutsw(i) + & surfinlw(i) - surfoutlw(i) ! !-- westward-facding ELSEIF ( surfl(1,i) == iwest_u ) THEN surf_usm_v(3)%rad_sw_in(m) = surfinsw(i) surf_usm_v(3)%rad_sw_out(m) = surfoutsw(i) surf_usm_v(3)%rad_lw_in(m) = surfinlw(i) surf_usm_v(3)%rad_lw_out(m) = surfoutlw(i) surf_usm_v(3)%rad_net(m) = surfinsw(i) - surfoutsw(i) + & surfinlw(i) - surfoutlw(i) ! !-- (2) land surfaces !-- upward-facing ELSEIF ( surfl(1,i) == iup_l ) THEN surf_lsm_h%rad_sw_in(m) = surfinsw(i) surf_lsm_h%rad_sw_out(m) = surfoutsw(i) surf_lsm_h%rad_lw_in(m) = surfinlw(i) surf_lsm_h%rad_lw_out(m) = surfoutlw(i) surf_lsm_h%rad_net(m) = surfinsw(i) - surfoutsw(i) + & surfinlw(i) - surfoutlw(i) ! !-- northward-facding ELSEIF ( surfl(1,i) == inorth_l ) THEN surf_lsm_v(0)%rad_sw_in(m) = surfinsw(i) surf_lsm_v(0)%rad_sw_out(m) = surfoutsw(i) surf_lsm_v(0)%rad_lw_in(m) = surfinlw(i) surf_lsm_v(0)%rad_lw_out(m) = surfoutlw(i) surf_lsm_v(0)%rad_net(m) = surfinsw(i) - surfoutsw(i) + & surfinlw(i) - surfoutlw(i) ! !-- southward-facding ELSEIF ( surfl(1,i) == isouth_l ) THEN surf_lsm_v(1)%rad_sw_in(m) = surfinsw(i) surf_lsm_v(1)%rad_sw_out(m) = surfoutsw(i) surf_lsm_v(1)%rad_lw_in(m) = surfinlw(i) surf_lsm_v(1)%rad_lw_out(m) = surfoutlw(i) surf_lsm_v(1)%rad_net(m) = surfinsw(i) - surfoutsw(i) + & surfinlw(i) - surfoutlw(i) ! !-- eastward-facing ELSEIF ( surfl(1,i) == ieast_l ) THEN surf_lsm_v(2)%rad_sw_in(m) = surfinsw(i) surf_lsm_v(2)%rad_sw_out(m) = surfoutsw(i) surf_lsm_v(2)%rad_lw_in(m) = surfinlw(i) surf_lsm_v(2)%rad_lw_out(m) = surfoutlw(i) surf_lsm_v(2)%rad_net(m) = surfinsw(i) - surfoutsw(i) + & surfinlw(i) - surfoutlw(i) ! !-- westward-facding ELSEIF ( surfl(1,i) == iwest_l ) THEN surf_lsm_v(3)%rad_sw_in(m) = surfinsw(i) surf_lsm_v(3)%rad_sw_out(m) = surfoutsw(i) surf_lsm_v(3)%rad_lw_in(m) = surfinlw(i) surf_lsm_v(3)%rad_lw_out(m) = surfoutlw(i) surf_lsm_v(3)%rad_net(m) = surfinsw(i) - surfoutsw(i) + & surfinlw(i) - surfoutlw(i) ENDIF ENDDO DO m = 1, surf_usm_h%ns surf_usm_h%surfhf(m) = surf_usm_h%rad_sw_in(m) + & surf_usm_h%rad_lw_in(m) - & surf_usm_h%rad_sw_out(m) - & surf_usm_h%rad_lw_out(m) ENDDO DO m = 1, surf_lsm_h%ns surf_lsm_h%surfhf(m) = surf_lsm_h%rad_sw_in(m) + & surf_lsm_h%rad_lw_in(m) - & surf_lsm_h%rad_sw_out(m) - & surf_lsm_h%rad_lw_out(m) ENDDO DO l = 0, 3 !-- urban DO m = 1, surf_usm_v(l)%ns surf_usm_v(l)%surfhf(m) = surf_usm_v(l)%rad_sw_in(m) + & surf_usm_v(l)%rad_lw_in(m) - & surf_usm_v(l)%rad_sw_out(m) - & surf_usm_v(l)%rad_lw_out(m) ENDDO !-- land DO m = 1, surf_lsm_v(l)%ns surf_lsm_v(l)%surfhf(m) = surf_lsm_v(l)%rad_sw_in(m) + & surf_lsm_v(l)%rad_lw_in(m) - & surf_lsm_v(l)%rad_sw_out(m) - & surf_lsm_v(l)%rad_lw_out(m) ENDDO ENDDO ! !-- Calculate the average temperature, albedo, and emissivity for urban/land domain !-- in case of using average_radiation in the respective radiation model IF ( average_radiation ) THEN !-- !-- precalculate face areas for different face directions using normal vector !-- TODO: make facearea a globale variable because it is used in more than one subroutine DO d = 0, nsurf_type facearea(d) = 1._wp IF ( idir(d) == 0 ) facearea(d) = facearea(d) * dx IF ( jdir(d) == 0 ) facearea(d) = facearea(d) * dy IF ( kdir(d) == 0 ) facearea(d) = facearea(d) * dz ENDDO ! !-- total absorbed SW & LW and emitted LW energy by all physical surfaces (land and urban) in local processor pabsswl = 0._wp pabslwl = 0._wp pemitlwl = 0._wp emiss_sum_surfl = 0._wp area_surfl = 0._wp DO i = startenergy, endenergy d = surfl(id, i) pabsswl = pabsswl + (1._wp - albedo_surf(i)) * surfinsw(i) * facearea(d) pabslwl = pabslwl + emiss_surf(i) * surfinlw(i) * facearea(d) pemitlwl = pemitlwl + surfoutlw(i) * facearea(d) emiss_sum_surfl = emiss_sum_surfl + emiss_surf(i) * facearea(d) area_surfl = area_surfl + facearea(d) END DO ! !-- add the absorbed SW energy by plant canopy IF ( plant_canopy ) THEN pabsswl = pabsswl + SUM(pcbinsw) pabslwl = pabslwl + SUM(pcbinlw) ENDIF ! !-- gather all absorbed SW energy in all processors #if defined( __parallel ) CALL MPI_ALLREDUCE( pabsswl, pabssw, 1, MPI_REAL, MPI_SUM, comm2d, ierr ) CALL MPI_ALLREDUCE( pabslwl, pabslw, 1, MPI_REAL, MPI_SUM, comm2d, ierr ) CALL MPI_ALLREDUCE( pemitlwl, pemitlw, 1, MPI_REAL, MPI_SUM, comm2d, ierr ) CALL MPI_ALLREDUCE( emiss_sum_surfl, emiss_sum_surf, 1, MPI_REAL, MPI_SUM, comm2d, ierr ) CALL MPI_ALLREDUCE( area_surfl, area_surf, 1, MPI_REAL, MPI_SUM, comm2d, ierr ) #else pabssw = pabsswl pabslwl = pabslw pemitlwl = pemitlw emiss_sum_surf = emiss_sum_surfl area_surf = area_surfl #endif ! !-- total received SW energy in local processor !!!!!! cos??!!!! pinswl = 0._wp pinlwl = 0._wp !-- sky DO i = startsky, endsky d = surfl(id, i) ii = surfl(ix, i) jj = surfl(iy, i) pinswl = pinswl + (rad_sw_in_dir(jj,ii) + rad_sw_in_diff(jj,ii)) * facearea(d) pinlwl = pinlwl + rad_lw_in_diff(jj,ii) * facearea(d) ENDDO !-- boundary DO i = startborder, endborder d = surfl(id, i) ii = surfl(ix, i) jj = surfl(iy, i) pinswl = pinswl + (rad_sw_in_dir(jj,ii) + rad_sw_in_diff(jj,ii)) * facearea(d) pinlwl = pinlwl + rad_lw_in_diff(jj,ii) * facearea(d) ENDDO !-- gather all received SW energy in all processors #if defined( __parallel ) CALL MPI_ALLREDUCE( pinswl, pinsw, 1, MPI_REAL, MPI_SUM, comm2d, ierr) CALL MPI_ALLREDUCE( pinlwl, pinlw, 1, MPI_REAL, MPI_SUM, comm2d, ierr) #else pinsw = pinswl pinlw = pinlwl #endif !-- (1) albedo IF ( pinsw /= 0.0_wp ) albedo_urb = 1._wp - pabssw / pinsw !-- (2) average emmsivity emissivity_urb = emiss_sum_surf / area_surf !-- (3) temerature t_rad_urb = ((pemitlw - pabslw + emissivity_urb*pinlw)/(emissivity_urb*sigma_sb*area_surf))**0.25_wp ENDIF !-- return surface radiation to horizontal surfaces !-- to rad_sw_in, rad_lw_in and rad_net for outputs !!!!!!!!!! !-- we need the original radiation on urban top layer !-- for calculation of MRT so we can't do adjustment here for now !!!!!!!!!! !!!DO isurf = 1, nsurfl !!! i = surfl(ix,isurf) !!! j = surfl(iy,isurf) !!! k = surfl(iz,isurf) !!! d = surfl(id,isurf) !!! IF ( d==iroof ) THEN !!! rad_sw_in(:,j,i) = surfinsw(isurf) !!! rad_lw_in(:,j,i) = surfinlw(isurf) !!! rad_net(j,i) = rad_sw_in(k,j,i) - rad_sw_out(k,j,i) + rad_lw_in(k,j,i) - rad_lw_out(k,j,i) !!! ENDIF !!!ENDDO CONTAINS !------------------------------------------------------------------------------! ! Description: ! ------------ !> This subroutine splits direct and diffusion dw radiation !> It sould not be called in case the radiation model already does it !> It follows !------------------------------------------------------------------------------! SUBROUTINE calc_diffusion_radiation USE date_and_time_mod, & ONLY: day_of_year_init, time_utc_init REAL(wp), PARAMETER :: sol_const = 1367.0_wp !< solar conbstant REAL(wp), PARAMETER :: lowest_solarUp = 0.1_wp !< limit the sun elevation to protect stability of the calculation INTEGER(iwp) :: i, j REAL(wp), PARAMETER :: year_seconds = 86400._wp * 365._wp REAL(wp) :: year_angle !< angle REAL(wp) :: etr !< extraterestrial radiation REAL(wp) :: corrected_solarUp !< corrected solar up radiation REAL(wp) :: horizontalETR !< horizontal extraterestrial radiation REAL(wp) :: clearnessIndex !< clearness index REAL(wp) :: diff_frac !< diffusion fraction of the radiation !-- Calculate current day and time based on the initial values and simulation time year_angle = ((day_of_year_init*86400) & + time_utc_init+time_since_reference_point) & / year_seconds * 2.0_wp * pi etr = sol_const * (1.00011_wp + & 0.034221_wp * cos(year_angle) + & 0.001280_wp * sin(year_angle) + & 0.000719_wp * cos(2.0_wp * year_angle) + & 0.000077_wp * sin(2.0_wp * year_angle)) !-- !-- Under a very low angle, we keep extraterestrial radiation at !-- the last small value, therefore the clearness index will be pushed !-- towards 0 while keeping full continuity. !-- IF ( zenith(0) <= lowest_solarUp ) THEN corrected_solarUp = lowest_solarUp ELSE corrected_solarUp = zenith(0) ENDIF horizontalETR = etr * corrected_solarUp DO i = nxl, nxr DO j = nys, nyn DO m = surf_def_h(0)%start_index(j,i), & surf_def_h(0)%end_index(j,i) clearnessIndex = surf_def_h(0)%rad_sw_in(m) / horizontalETR diff_frac = 1.0_wp / & (1.0_wp + exp(-5.0033_wp + 8.6025_wp * clearnessIndex)) rad_sw_in_diff(j,i) = surf_def_h(0)%rad_sw_in(m) * diff_frac rad_sw_in_dir(j,i) = surf_def_h(0)%rad_sw_in(m) * & (1.0_wp - diff_frac) rad_lw_in_diff(j,i) = surf_def_h(0)%rad_lw_in(m) ENDDO DO m = surf_lsm_h%start_index(j,i), & surf_lsm_h%end_index(j,i) clearnessIndex = surf_lsm_h%rad_sw_in(m) / horizontalETR diff_frac = 1.0_wp / & (1.0_wp + exp(-5.0033_wp + 8.6025_wp * clearnessIndex)) rad_sw_in_diff(j,i) = surf_lsm_h%rad_sw_in(m) * diff_frac rad_sw_in_dir(j,i) = surf_lsm_h%rad_sw_in(m) * & (1.0_wp - diff_frac) rad_lw_in_diff(j,i) = surf_lsm_h%rad_lw_in(m) ENDDO DO m = surf_usm_h%start_index(j,i), & surf_usm_h%end_index(j,i) clearnessIndex = surf_usm_h%rad_sw_in(m) / horizontalETR diff_frac = 1.0_wp / & (1.0_wp + exp(-5.0033_wp + 8.6025_wp * clearnessIndex)) rad_sw_in_diff(j,i) = surf_usm_h%rad_sw_in(m) * diff_frac rad_sw_in_dir(j,i) = surf_usm_h%rad_sw_in(m) * & (1.0_wp - diff_frac) rad_lw_in_diff(j,i) = surf_usm_h%rad_lw_in(m) ENDDO ENDDO ENDDO END SUBROUTINE calc_diffusion_radiation !------------------------------------------------------------------------------! !> Finds first model boundary crossed by a ray !------------------------------------------------------------------------------! PURE SUBROUTINE find_boundary_face(origin, uvect, bdycross) IMPLICIT NONE INTEGER(iwp) :: d !< INTEGER(iwp) :: seldim !< found fist crossing index INTEGER(iwp), DIMENSION(3) :: bdyd !< boundary direction INTEGER(iwp), DIMENSION(4), INTENT(out) :: bdycross !< found boundary crossing (d, z, y, x) REAL(wp) :: bdydim !< REAL(wp) :: dist !< REAL(wp), DIMENSION(3) :: crossdist !< crossing distance REAL(wp), DIMENSION(3), INTENT(in) :: origin !< ray origin REAL(wp), DIMENSION(3), INTENT(in) :: uvect !< ray unit vector bdydim = nzut + .5_wp !< top boundary bdyd(1) = isky crossdist(1) = ( bdydim - origin(1) ) / uvect(1) !< subroutine called only when uvect(1)>0 IF ( uvect(2) == 0._wp ) THEN crossdist(2) = huge(1._wp) ELSE IF ( uvect(2) >= 0._wp ) THEN bdydim = ny + .5_wp !< north global boundary bdyd(2) = inorth_b ELSE bdydim = -.5_wp !< south global boundary bdyd(2) = isouth_b ENDIF crossdist(2) = ( bdydim - origin(2) ) / uvect(2) ENDIF IF ( uvect(3) == 0._wp ) THEN crossdist(3) = huge(1._wp) ELSE IF ( uvect(3) >= 0._wp ) THEN bdydim = nx + .5_wp !< east global boundary bdyd(3) = ieast_b ELSE bdydim = -.5_wp !< west global boundary bdyd(3) = iwest_b ENDIF crossdist(3) = ( bdydim - origin(3) ) / uvect(3) ENDIF seldim = minloc(crossdist, 1) dist = crossdist(seldim) d = bdyd(seldim) bdycross(1) = d bdycross(2:4) = NINT( origin(:) + uvect(:) * dist & + .5_wp * (/ kdir(d), jdir(d), idir(d) /) ) END SUBROUTINE find_boundary_face !------------------------------------------------------------------------------! !> Calculates radiation absorbed by box with given size and LAD. !> !> Simulates resol**2 rays (by equally spacing a bounding horizontal square !> conatining all possible rays that would cross the box) and calculates !> average transparency per ray. Returns fraction of absorbed radiation flux !> and area for which this fraction is effective. !------------------------------------------------------------------------------! PURE SUBROUTINE box_absorb(boxsize, resol, dens, uvec, area, absorb) IMPLICIT NONE REAL(wp), DIMENSION(3), INTENT(in) :: & boxsize, & !< z, y, x size of box in m uvec !< z, y, x unit vector of incoming flux INTEGER(iwp), INTENT(in) :: & resol !< No. of rays in x and y dimensions REAL(wp), INTENT(in) :: & dens !< box density (e.g. Leaf Area Density) REAL(wp), INTENT(out) :: & area, & !< horizontal area for flux absorbtion absorb !< fraction of absorbed flux REAL(wp) :: & xshift, yshift, & xmin, xmax, ymin, ymax, & xorig, yorig, & dx1, dy1, dz1, dx2, dy2, dz2, & crdist, & transp INTEGER(iwp) :: & i, j xshift = uvec(3) / uvec(1) * boxsize(1) xmin = min(0._wp, -xshift) xmax = boxsize(3) + max(0._wp, -xshift) yshift = uvec(2) / uvec(1) * boxsize(1) ymin = min(0._wp, -yshift) ymax = boxsize(2) + max(0._wp, -yshift) transp = 0._wp DO i = 1, resol xorig = xmin + (xmax-xmin) * (i-.5_wp) / resol DO j = 1, resol yorig = ymin + (ymax-ymin) * (j-.5_wp) / resol dz1 = 0._wp dz2 = boxsize(1)/uvec(1) IF ( uvec(2) > 0._wp ) THEN dy1 = -yorig / uvec(2) !< crossing with y=0 dy2 = (boxsize(2)-yorig) / uvec(2) !< crossing with y=boxsize(2) ELSE IF ( uvec(2) < 0._wp ) THEN dy1 = (boxsize(2)-yorig) / uvec(2) !< crossing with y=boxsize(2) dy2 = -yorig / uvec(2) !< crossing with y=0 ELSE !uvec(2)==0 dy1 = -huge(1._wp) dy2 = huge(1._wp) ENDIF IF ( uvec(3) > 0._wp ) THEN dx1 = -xorig / uvec(3) !< crossing with x=0 dx2 = (boxsize(3)-xorig) / uvec(3) !< crossing with x=boxsize(3) ELSE IF ( uvec(3) < 0._wp ) THEN dx1 = (boxsize(3)-xorig) / uvec(3) !< crossing with x=boxsize(3) dx2 = -xorig / uvec(3) !< crossing with x=0 ELSE !uvec(1)==0 dx1 = -huge(1._wp) dx2 = huge(1._wp) ENDIF crdist = max(0._wp, (min(dz2, dy2, dx2) - max(dz1, dy1, dx1))) transp = transp + exp(-ext_coef * dens * crdist) ENDDO ENDDO transp = transp / resol**2 area = (boxsize(3)+xshift)*(boxsize(2)+yshift) absorb = 1._wp - transp END SUBROUTINE box_absorb END SUBROUTINE radiation_interaction !------------------------------------------------------------------------------! ! Description: ! ------------ !> Calculates shape view factors SVF and plant sink canopy factors PSCF !> !!!!!DESCRIPTION!!!!!!!!!! !------------------------------------------------------------------------------! SUBROUTINE radiation_calc_svf IMPLICIT NONE INTEGER(iwp) :: i, j, k, l, d, ip, jp INTEGER(iwp) :: isvf, ksvf, icsf, kcsf, npcsfl, isvf_surflt, imrtt, imrtf INTEGER(iwp) :: sd, td, ioln, iproc REAL(wp), DIMENSION(0:nsurf_type) :: facearea INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE :: nzterrl, planthl REAL(wp), DIMENSION(:,:), ALLOCATABLE :: csflt, pcsflt INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE :: kcsflt,kpcsflt INTEGER(iwp), DIMENSION(:), ALLOCATABLE :: icsflt,dcsflt,ipcsflt,dpcsflt REAL(wp), DIMENSION(3) :: uv LOGICAL :: visible REAL(wp), DIMENSION(3) :: sa, ta !< real coordinates z,y,x of source and target REAL(wp) :: transparency, rirrf, sqdist, svfsum INTEGER(iwp) :: isurflt, isurfs, isurflt_prev INTEGER(iwp) :: itx, ity, itz CHARACTER(len=7) :: pid_char = '' INTEGER(iwp) :: win_lad, minfo REAL(wp), DIMENSION(:,:,:), POINTER :: lad_s_rma !< fortran pointer, but lower bounds are 1 TYPE(c_ptr) :: lad_s_rma_p !< allocated c pointer #if defined( __parallel ) INTEGER(kind=MPI_ADDRESS_KIND) :: size_lad_rma #endif REAL(wp), DIMENSION(0:nsurf_type) :: svf_threshold !< threshold to ignore very small svf between far surfaces ! !-- calculation of the SVF CALL location_message( ' calculation of SVF and CSF', .TRUE. ) CALL cpu_log( log_point_s(79), 'radiation_calc_svf', 'start' ) ! !-- precalculate face areas for different face directions using normal vector DO d = 0, nsurf_type facearea(d) = 1._wp IF ( idir(d) == 0 ) facearea(d) = facearea(d) * dx IF ( jdir(d) == 0 ) facearea(d) = facearea(d) * dy IF ( kdir(d) == 0 ) facearea(d) = facearea(d) * dz ENDDO !-- calculate the svf threshold svf_threshold = 0._wp IF ( dist_max_svf > 0._wp ) THEN DO d = 0, nsurf_type sqdist = dist_max_svf * dist_max_svf svf_threshold(d) = 1._wp / (pi * sqdist) * facearea(d) ENDDO ENDIF !-- initialize variables and temporary arrays for calculation of svf and csf nsvfl = 0 ncsfl = 0 nsvfla = gasize msvf = 1 ALLOCATE( asvf1(nsvfla) ) asvf => asvf1 IF ( plant_canopy ) THEN ncsfla = gasize mcsf = 1 ALLOCATE( acsf1(ncsfla) ) acsf => acsf1 ENDIF !-- initialize temporary terrain and plant canopy height arrays (global 2D array!) ALLOCATE( nzterr(0:(nx+1)*(ny+1)-1) ) #if defined( __parallel ) ALLOCATE( nzterrl(nys:nyn,nxl:nxr) ) nzterrl = get_topography_top_index( 's' ) CALL MPI_AllGather( nzterrl, nnx*nny, MPI_INTEGER, & nzterr, nnx*nny, MPI_INTEGER, comm2d, ierr ) DEALLOCATE(nzterrl) #else nzterr = RESHAPE( get_topography_top_index( 's' ), (/(nx+1)*(ny+1)/) ) #endif IF ( plant_canopy ) THEN ALLOCATE( plantt(0:(nx+1)*(ny+1)-1) ) maxboxesg = nx + ny + nzu + 1 !-- temporary arrays storing values for csf calculation during raytracing ALLOCATE( boxes(3, maxboxesg) ) ALLOCATE( crlens(maxboxesg) ) #if defined( __parallel ) ALLOCATE( planthl(nys:nyn,nxl:nxr) ) planthl = pch(nys:nyn,nxl:nxr) CALL MPI_AllGather( planthl, nnx*nny, MPI_INTEGER, & plantt, nnx*nny, MPI_INTEGER, comm2d, ierr ) DEALLOCATE( planthl ) !-- temporary arrays storing values for csf calculation during raytracing ALLOCATE( lad_ip(maxboxesg) ) ALLOCATE( lad_disp(maxboxesg) ) IF ( usm_lad_rma ) THEN ALLOCATE( lad_s_ray(maxboxesg) ) ! set conditions for RMA communication CALL MPI_Info_create(minfo, ierr) CALL MPI_Info_set(minfo, 'accumulate_ordering', '', ierr) CALL MPI_Info_set(minfo, 'accumulate_ops', 'same_op', ierr) CALL MPI_Info_set(minfo, 'same_size', 'true', ierr) CALL MPI_Info_set(minfo, 'same_disp_unit', 'true', ierr) !-- Allocate and initialize the MPI RMA window !-- must be in accordance with allocation of lad_s in plant_canopy_model !-- optimization of memory should be done !-- Argument X of function c_sizeof(X) needs arbitrary REAL(wp) value, set to 1.0_wp for now size_lad_rma = c_sizeof(1.0_wp)*nnx*nny*nzu CALL MPI_Win_allocate(size_lad_rma, c_sizeof(1.0_wp), minfo, comm2d, & lad_s_rma_p, win_lad, ierr) CALL c_f_pointer(lad_s_rma_p, lad_s_rma, (/ nzu, nny, nnx /)) usm_lad(nzub:, nys:, nxl:) => lad_s_rma(:,:,:) ELSE ALLOCATE(usm_lad(nzub:nzut, nys:nyn, nxl:nxr)) ENDIF #else plantt = RESHAPE( pct(nys:nyn,nxl:nxr), (/(nx+1)*(ny+1)/) ) ALLOCATE(usm_lad(nzub:nzut, nys:nyn, nxl:nxr)) #endif usm_lad(:,:,:) = 0._wp DO i = nxl, nxr DO j = nys, nyn k = get_topography_top_index_ji( j, i, 's' ) usm_lad(k:nzut, j, i) = lad_s(0:nzut-k, j, i) ENDDO ENDDO #if defined( __parallel ) IF ( usm_lad_rma ) THEN CALL MPI_Info_free(minfo, ierr) CALL MPI_Win_lock_all(0, win_lad, ierr) ELSE ALLOCATE( usm_lad_g(0:(nx+1)*(ny+1)*nzu-1) ) CALL MPI_AllGather( usm_lad, nnx*nny*nzu, MPI_REAL, & usm_lad_g, nnx*nny*nzu, MPI_REAL, comm2d, ierr ) ENDIF #endif ENDIF IF ( mrt_factors ) THEN OPEN(153, file='MRT_TARGETS', access='SEQUENTIAL', & action='READ', status='OLD', form='FORMATTED', err=524) OPEN(154, file='MRT_FACTORS'//myid_char, access='DIRECT', recl=(5*4+2*8), & action='WRITE', status='REPLACE', form='UNFORMATTED', err=525) imrtf = 1 DO READ(153, *, end=526, err=524) imrtt, i, j, k IF ( i < nxl .OR. i > nxr & .OR. j < nys .OR. j > nyn ) CYCLE ta = (/ REAL(k), REAL(j), REAL(i) /) DO isurfs = 1, nsurf IF ( .NOT. surface_facing(i, j, k, -1, & surf(ix, isurfs), surf(iy, isurfs), & surf(iz, isurfs), surf(id, isurfs)) ) THEN CYCLE ENDIF sd = surf(id, isurfs) sa = (/ REAL(surf(iz, isurfs), wp) - 0.5_wp * kdir(sd), & REAL(surf(iy, isurfs), wp) - 0.5_wp * jdir(sd), & REAL(surf(ix, isurfs), wp) - 0.5_wp * idir(sd) /) !-- unit vector source -> target uv = (/ (ta(1)-sa(1))*dz, (ta(2)-sa(2))*dy, (ta(3)-sa(3))*dx /) sqdist = SUM(uv(:)**2) uv = uv / SQRT(sqdist) !-- irradiance factor - see svf. Here we consider that target face is always normal, !-- i.e. the second dot product equals 1 rirrf = dot_product((/ kdir(sd), jdir(sd), idir(sd) /), uv) & / (pi * sqdist) * facearea(sd) !-- raytrace while not creating any canopy sink factors CALL raytrace(sa, ta, isurfs, rirrf, 1._wp, .FALSE., & visible, transparency, win_lad) IF ( .NOT. visible ) CYCLE !rsvf = rirrf * transparency WRITE(154, rec=imrtf, err=525) INT(imrtt, kind=4), & INT(surf(id, isurfs), kind=4), & INT(surf(iz, isurfs), kind=4), & INT(surf(iy, isurfs), kind=4), & INT(surf(ix, isurfs), kind=4), & REAL(rirrf, kind=8), REAL(transparency, kind=8) imrtf = imrtf + 1 ENDDO !< isurfs ENDDO !< MRT_TARGETS record 524 message_string = 'error reading file MRT_TARGETS' CALL message( 'radiation_calc_svf', 'PA0524', 1, 2, 0, 6, 0 ) 525 message_string = 'error writing file MRT_FACTORS'//myid_char CALL message( 'radiation_calc_svf', 'PA0525', 1, 2, 0, 6, 0 ) 526 CLOSE(153) CLOSE(154) ENDIF !< mrt_factors DO isurflt = 1, nsurfl !-- determine face centers td = surfl(id, isurflt) IF ( td >= isky .AND. .NOT. plant_canopy ) CYCLE ta = (/ REAL(surfl(iz, isurflt), wp) - 0.5_wp * kdir(td), & REAL(surfl(iy, isurflt), wp) - 0.5_wp * jdir(td), & REAL(surfl(ix, isurflt), wp) - 0.5_wp * idir(td) /) DO isurfs = 1, nsurf !-- cycle for atmospheric surfaces since they are not source surfaces sd = surf(id, isurfs) IF ( sd > iwest_l .AND. sd < isky ) CYCLE !-- if reflections between target surfaces (urban and land) are neglected (surf_reflection set to !-- FALSE) cycle. This will reduce the number of SVFs and keep SVFs between only ertual surfaces to !-- physical surfaces IF ( .NOT. surf_reflections .AND. sd < isky ) CYCLE !-- cycle if the target and the source surfaces are not facing each other IF ( .NOT. surface_facing(surfl(ix, isurflt), surfl(iy, isurflt), & surfl(iz, isurflt), surfl(id, isurflt), & surf(ix, isurfs), surf(iy, isurfs), & surf(iz, isurfs), surf(id, isurfs)) ) THEN CYCLE ENDIF sa = (/ REAL(surf(iz, isurfs), wp) - 0.5_wp * kdir(sd), & REAL(surf(iy, isurfs), wp) - 0.5_wp * jdir(sd), & REAL(surf(ix, isurfs), wp) - 0.5_wp * idir(sd) /) !-- unit vector source -> target uv = (/ (ta(1)-sa(1))*dz, (ta(2)-sa(2))*dy, (ta(3)-sa(3))*dx /) sqdist = SUM(uv(:)**2) uv = uv / SQRT(sqdist) !-- irradiance factor (our unshaded shape view factor) = view factor per differential target area * source area rirrf = dot_product((/ kdir(sd), jdir(sd), idir(sd) /), uv) & ! cosine of source normal and direction * dot_product((/ kdir(td), jdir(td), idir(td) /), -uv) & ! cosine of target normal and reverse direction / (pi * sqdist) & ! square of distance between centers * facearea(sd) !-- skip svf less than svf_threshold IF ( rirrf < svf_threshold(sd) .AND. sd < isky ) CYCLE !-- raytrace + process plant canopy sinks within CALL raytrace(sa, ta, isurfs, rirrf, facearea(td), .TRUE., & visible, transparency, win_lad) IF ( .NOT. visible ) CYCLE IF ( td >= isky ) CYCLE !< we calculated these only for raytracing !< to find plant canopy sinks, we don't need svf for them !-- write to the svf array nsvfl = nsvfl + 1 !-- check dimmension of asvf array and enlarge it if needed IF ( nsvfla < nsvfl ) THEN k = nsvfla * 2 IF ( msvf == 0 ) THEN msvf = 1 ALLOCATE( asvf1(k) ) asvf => asvf1 asvf1(1:nsvfla) = asvf2 DEALLOCATE( asvf2 ) ELSE msvf = 0 ALLOCATE( asvf2(k) ) asvf => asvf2 asvf2(1:nsvfla) = asvf1 DEALLOCATE( asvf1 ) ENDIF nsvfla = k ENDIF !-- write svf values into the array asvf(nsvfl)%isurflt = isurflt asvf(nsvfl)%isurfs = isurfs asvf(nsvfl)%rsvf = rirrf !we postopne multiplication by transparency asvf(nsvfl)%rtransp = transparency !a.k.a. Direct Irradiance Factor ENDDO ENDDO CALL location_message( ' waiting for completion of SVF and CSF calculation in all processes', .TRUE. ) !-- deallocate temporary global arrays DEALLOCATE(nzterr) IF ( plant_canopy ) THEN !-- finalize mpi_rma communication and deallocate temporary arrays #if defined( __parallel ) IF ( usm_lad_rma ) THEN CALL MPI_Win_flush_all(win_lad, ierr) !-- unlock MPI window CALL MPI_Win_unlock_all(win_lad, ierr) !-- free MPI window CALL MPI_Win_free(win_lad, ierr) !-- deallocate temporary arrays storing values for csf calculation during raytracing DEALLOCATE( lad_s_ray ) !-- usm_lad is the pointer to lad_s_rma in case of usm_lad_rma !-- and must not be deallocated here ELSE DEALLOCATE(usm_lad) DEALLOCATE(usm_lad_g) ENDIF #else DEALLOCATE(usm_lad) #endif DEALLOCATE( boxes ) DEALLOCATE( crlens ) DEALLOCATE( plantt ) ENDIF CALL location_message( ' calculation of the complete SVF array', .TRUE. ) !-- sort svf ( a version of quicksort ) CALL quicksort_svf(asvf,1,nsvfl) ALLOCATE( svf(ndsvf,nsvfl) ) ALLOCATE( svfsurf(idsvf,nsvfl) ) !< load svf from the structure array to plain arrays isurflt_prev = -1 ksvf = 1 svfsum = 0._wp DO isvf = 1, nsvfl !-- normalize svf per target face IF ( asvf(ksvf)%isurflt /= isurflt_prev ) THEN IF ( isurflt_prev /= -1 .AND. svfsum /= 0._wp ) THEN !-- TODO detect and log when normalization differs too much from 1 svf(1, isvf_surflt:isvf-1) = svf(1, isvf_surflt:isvf-1) / svfsum ENDIF isurflt_prev = asvf(ksvf)%isurflt isvf_surflt = isvf svfsum = asvf(ksvf)%rsvf !?? / asvf(ksvf)%rtransp ELSE svfsum = svfsum + asvf(ksvf)%rsvf !?? / asvf(ksvf)%rtransp ENDIF svf(:, isvf) = (/ asvf(ksvf)%rsvf, asvf(ksvf)%rtransp /) svfsurf(:, isvf) = (/ asvf(ksvf)%isurflt, asvf(ksvf)%isurfs /) !-- next element ksvf = ksvf + 1 ENDDO IF ( isurflt_prev /= -1 .AND. svfsum /= 0._wp ) THEN !-- TODO detect and log when normalization differs too much from 1 svf(1, isvf_surflt:nsvfl) = svf(1, isvf_surflt:nsvfl) / svfsum ENDIF !-- deallocate temporary asvf array !-- DEALLOCATE(asvf) - ifort has a problem with deallocation of allocatable target !-- via pointing pointer - we need to test original targets IF ( ALLOCATED(asvf1) ) THEN DEALLOCATE(asvf1) ENDIF IF ( ALLOCATED(asvf2) ) THEN DEALLOCATE(asvf2) ENDIF npcsfl = 0 IF ( plant_canopy ) THEN CALL location_message( ' calculation of the complete CSF array', .TRUE. ) !-- sort and merge csf for the last time, keeping the array size to minimum CALL merge_and_grow_csf(-1) !-- aggregate csb among processors !-- allocate necessary arrays ALLOCATE( csflt(ndcsf,max(ncsfl,ndcsf)) ) ALLOCATE( kcsflt(kdcsf,max(ncsfl,kdcsf)) ) ALLOCATE( icsflt(0:numprocs-1) ) ALLOCATE( dcsflt(0:numprocs-1) ) ALLOCATE( ipcsflt(0:numprocs-1) ) ALLOCATE( dpcsflt(0:numprocs-1) ) !-- fill out arrays of csf values and !-- arrays of number of elements and displacements !-- for particular precessors icsflt = 0 dcsflt = 0 ip = -1 j = -1 d = 0 DO kcsf = 1, ncsfl j = j+1 IF ( acsf(kcsf)%ip /= ip ) THEN !-- new block of the processor !-- number of elements of previous block IF ( ip>=0) icsflt(ip) = j d = d+j !-- blank blocks DO jp = ip+1, acsf(kcsf)%ip-1 !-- number of elements is zero, displacement is equal to previous icsflt(jp) = 0 dcsflt(jp) = d ENDDO !-- the actual block ip = acsf(kcsf)%ip dcsflt(ip) = d j = 0 ENDIF !-- fill out real values of rsvf, rtransp csflt(1,kcsf) = acsf(kcsf)%rsvf csflt(2,kcsf) = acsf(kcsf)%rtransp !-- fill out integer values of itz,ity,itx,isurfs kcsflt(1,kcsf) = acsf(kcsf)%itz kcsflt(2,kcsf) = acsf(kcsf)%ity kcsflt(3,kcsf) = acsf(kcsf)%itx kcsflt(4,kcsf) = acsf(kcsf)%isurfs ENDDO !-- last blank blocks at the end of array j = j+1 IF ( ip>=0 ) icsflt(ip) = j d = d+j DO jp = ip+1, numprocs-1 !-- number of elements is zero, displacement is equal to previous icsflt(jp) = 0 dcsflt(jp) = d ENDDO !-- deallocate temporary acsf array !-- DEALLOCATE(acsf) - ifort has a problem with deallocation of allocatable target !-- via pointing pointer - we need to test original targets IF ( ALLOCATED(acsf1) ) THEN DEALLOCATE(acsf1) ENDIF IF ( ALLOCATED(acsf2) ) THEN DEALLOCATE(acsf2) ENDIF #if defined( __parallel ) !-- scatter and gather the number of elements to and from all processor !-- and calculate displacements CALL MPI_AlltoAll(icsflt,1,MPI_INTEGER,ipcsflt,1,MPI_INTEGER,comm2d, ierr) npcsfl = SUM(ipcsflt) d = 0 DO i = 0, numprocs-1 dpcsflt(i) = d d = d + ipcsflt(i) ENDDO !-- exchange csf fields between processors ALLOCATE( pcsflt(ndcsf,max(npcsfl,ndcsf)) ) ALLOCATE( kpcsflt(kdcsf,max(npcsfl,kdcsf)) ) CALL MPI_AlltoAllv(csflt, ndcsf*icsflt, ndcsf*dcsflt, MPI_REAL, & pcsflt, ndcsf*ipcsflt, ndcsf*dpcsflt, MPI_REAL, comm2d, ierr) CALL MPI_AlltoAllv(kcsflt, kdcsf*icsflt, kdcsf*dcsflt, MPI_INTEGER, & kpcsflt, kdcsf*ipcsflt, kdcsf*dpcsflt, MPI_INTEGER, comm2d, ierr) #else npcsfl = ncsfl ALLOCATE( pcsflt(ndcsf,max(npcsfl,ndcsf)) ) ALLOCATE( kpcsflt(kdcsf,max(npcsfl,kdcsf)) ) pcsflt = csflt kpcsflt = kcsflt #endif !-- deallocate temporary arrays DEALLOCATE( csflt ) DEALLOCATE( kcsflt ) DEALLOCATE( icsflt ) DEALLOCATE( dcsflt ) DEALLOCATE( ipcsflt ) DEALLOCATE( dpcsflt ) !-- sort csf ( a version of quicksort ) CALL quicksort_csf2(kpcsflt, pcsflt, 1, npcsfl) !-- aggregate canopy sink factor records with identical box & source !-- againg across all values from all processors IF ( npcsfl > 0 ) THEN icsf = 1 !< reading index kcsf = 1 !< writing index DO while (icsf < npcsfl) !-- here kpcsf(kcsf) already has values from kpcsf(icsf) IF ( kpcsflt(3,icsf) == kpcsflt(3,icsf+1) .AND. & kpcsflt(2,icsf) == kpcsflt(2,icsf+1) .AND. & kpcsflt(1,icsf) == kpcsflt(1,icsf+1) .AND. & kpcsflt(4,icsf) == kpcsflt(4,icsf+1) ) THEN !-- We could simply take either first or second rtransp, both are valid. As a very simple heuristic about which ray !-- probably passes nearer the center of the target box, we choose DIF from the entry with greater CSF, since that !-- might mean that the traced beam passes longer through the canopy box. IF ( pcsflt(1,kcsf) < pcsflt(1,icsf+1) ) THEN pcsflt(2,kcsf) = pcsflt(2,icsf+1) ENDIF pcsflt(1,kcsf) = pcsflt(1,kcsf) + pcsflt(1,icsf+1) !-- advance reading index, keep writing index icsf = icsf + 1 ELSE !-- not identical, just advance and copy icsf = icsf + 1 kcsf = kcsf + 1 kpcsflt(:,kcsf) = kpcsflt(:,icsf) pcsflt(:,kcsf) = pcsflt(:,icsf) ENDIF ENDDO !-- last written item is now also the last item in valid part of array npcsfl = kcsf ENDIF ncsfl = npcsfl IF ( ncsfl > 0 ) THEN ALLOCATE( csf(ndcsf,ncsfl) ) ALLOCATE( csfsurf(idcsf,ncsfl) ) DO icsf = 1, ncsfl csf(:,icsf) = pcsflt(:,icsf) csfsurf(1,icsf) = gridpcbl(kpcsflt(1,icsf),kpcsflt(2,icsf),kpcsflt(3,icsf)) csfsurf(2,icsf) = kpcsflt(4,icsf) ENDDO ENDIF !-- deallocation of temporary arrays DEALLOCATE( pcsflt ) DEALLOCATE( kpcsflt ) IF ( ALLOCATED( gridpcbl ) ) DEALLOCATE( gridpcbl ) ENDIF RETURN 301 WRITE( message_string, * ) & 'I/O error when processing shape view factors / ', & 'plant canopy sink factors / direct irradiance factors.' CALL message( 'init_urban_surface', 'PA0502', 2, 2, 0, 6, 0 ) CALL cpu_log( log_point_s(79), 'radiation_calc_svf', 'stop' ) END SUBROUTINE radiation_calc_svf !------------------------------------------------------------------------------! ! Description: ! ------------ !> Raytracing for detecting obstacles and calculating compound canopy sink !> factors. (A simple obstacle detection would only need to process faces in !> 3 dimensions without any ordering.) !> Assumtions: !> ----------- !> 1. The ray always originates from a face midpoint (only one coordinate equals !> *.5, i.e. wall) and doesn't travel parallel to the surface (that would mean !> shape factor=0). Therefore, the ray may never travel exactly along a face !> or an edge. !> 2. From grid bottom to urban surface top the grid has to be *equidistant* !> within each of the dimensions, including vertical (but the resolution !> doesn't need to be the same in all three dimensions). !------------------------------------------------------------------------------! SUBROUTINE raytrace(src, targ, isrc, rirrf, atarg, create_csf, visible, transparency, win_lad) IMPLICIT NONE REAL(wp), DIMENSION(3), INTENT(in) :: src, targ !< real coordinates z,y,x INTEGER(iwp), INTENT(in) :: isrc !< index of source face for csf REAL(wp), INTENT(in) :: rirrf !< irradiance factor for csf REAL(wp), INTENT(in) :: atarg !< target surface area for csf LOGICAL, INTENT(in) :: create_csf !< whether to generate new CSFs during raytracing LOGICAL, INTENT(out) :: visible REAL(wp), INTENT(out) :: transparency !< along whole path INTEGER(iwp), INTENT(in) :: win_lad INTEGER(iwp) :: i, j, k, d INTEGER(iwp) :: seldim !< dimension to be incremented INTEGER(iwp) :: ncsb !< no of written plant canopy sinkboxes INTEGER(iwp) :: maxboxes !< max no of gridboxes visited REAL(wp) :: distance !< euclidean along path REAL(wp) :: crlen !< length of gridbox crossing REAL(wp) :: lastdist !< beginning of current crossing REAL(wp) :: nextdist !< end of current crossing REAL(wp) :: realdist !< distance in meters per unit distance REAL(wp) :: crmid !< midpoint of crossing REAL(wp) :: cursink !< sink factor for current canopy box REAL(wp), DIMENSION(3) :: delta !< path vector REAL(wp), DIMENSION(3) :: uvect !< unit vector REAL(wp), DIMENSION(3) :: dimnextdist !< distance for each dimension increments INTEGER(iwp), DIMENSION(3) :: box !< gridbox being crossed INTEGER(iwp), DIMENSION(3) :: dimnext !< next dimension increments along path INTEGER(iwp), DIMENSION(3) :: dimdelta !< dimension direction = +- 1 INTEGER(iwp) :: px, py !< number of processors in x and y dir before !< the processor in the question INTEGER(iwp) :: ip !< number of processor where gridbox reside INTEGER(iwp) :: ig !< 1D index of gridbox in global 2D array REAL(wp) :: lad_s_target !< recieved lad_s of particular grid box REAL(wp), PARAMETER :: grow_factor = 1.5_wp !< factor of expansion of grow arrays ! !-- Maximum number of gridboxes visited equals to maximum number of boundaries crossed in each dimension plus one. That's also !-- the maximum number of plant canopy boxes written. We grow the acsf array accordingly using exponential factor. maxboxes = SUM(ABS(NINT(targ) - NINT(src))) + 1 IF ( plant_canopy .AND. ncsfl + maxboxes > ncsfla ) THEN !-- use this code for growing by fixed exponential increments (equivalent to case where ncsfl always increases by 1) !-- k = CEILING(grow_factor ** real(CEILING(log(real(ncsfl + maxboxes, kind=wp)) & !-- / log(grow_factor)), kind=wp)) !-- or use this code to simply always keep some extra space after growing k = CEILING(REAL(ncsfl + maxboxes, kind=wp) * grow_factor) CALL merge_and_grow_csf(k) ENDIF transparency = 1._wp ncsb = 0 delta(:) = targ(:) - src(:) distance = SQRT(SUM(delta(:)**2)) IF ( distance == 0._wp ) THEN visible = .TRUE. RETURN ENDIF uvect(:) = delta(:) / distance realdist = SQRT(SUM( (uvect(:)*(/dz,dy,dx/))**2 )) lastdist = 0._wp !-- Since all face coordinates have values *.5 and we'd like to use !-- integers, all these have .5 added DO d = 1, 3 IF ( uvect(d) == 0._wp ) THEN dimnext(d) = 999999999 dimdelta(d) = 999999999 dimnextdist(d) = 1.0E20_wp ELSE IF ( uvect(d) > 0._wp ) THEN dimnext(d) = CEILING(src(d) + .5_wp) dimdelta(d) = 1 dimnextdist(d) = (dimnext(d) - .5_wp - src(d)) / uvect(d) ELSE dimnext(d) = FLOOR(src(d) + .5_wp) dimdelta(d) = -1 dimnextdist(d) = (dimnext(d) - .5_wp - src(d)) / uvect(d) ENDIF ENDDO DO !-- along what dimension will the next wall crossing be? seldim = minloc(dimnextdist, 1) nextdist = dimnextdist(seldim) IF ( nextdist > distance ) nextdist = distance crlen = nextdist - lastdist IF ( crlen > .001_wp ) THEN crmid = (lastdist + nextdist) * .5_wp box = NINT(src(:) + uvect(:) * crmid) !-- calculate index of the grid with global indices (box(2),box(3)) !-- in the array nzterr and plantt and id of the coresponding processor px = box(3)/nnx py = box(2)/nny ip = px*pdims(2)+py ig = ip*nnx*nny + (box(3)-px*nnx)*nny + box(2)-py*nny IF ( box(1) <= nzterr(ig) ) THEN visible = .FALSE. RETURN ENDIF IF ( plant_canopy ) THEN IF ( box(1) <= plantt(ig) ) THEN ncsb = ncsb + 1 boxes(:,ncsb) = box crlens(ncsb) = crlen #if defined( __parallel ) lad_ip(ncsb) = ip lad_disp(ncsb) = (box(3)-px*nnx)*(nny*nzu) + (box(2)-py*nny)*nzu + box(1)-nzub #endif ENDIF ENDIF ENDIF IF ( nextdist >= distance ) EXIT lastdist = nextdist dimnext(seldim) = dimnext(seldim) + dimdelta(seldim) dimnextdist(seldim) = (dimnext(seldim) - .5_wp - src(seldim)) / uvect(seldim) ENDDO IF ( plant_canopy ) THEN #if defined( __parallel ) IF ( usm_lad_rma ) THEN !-- send requests for lad_s to appropriate processor CALL cpu_log( log_point_s(77), 'usm_init_rma', 'start' ) DO i = 1, ncsb CALL MPI_Get(lad_s_ray(i), 1, MPI_REAL, lad_ip(i), lad_disp(i), & 1, MPI_REAL, win_lad, ierr) IF ( ierr /= 0 ) THEN WRITE(message_string, *) 'MPI error ', ierr, ' at MPI_Get' CALL message( 'raytrace', 'PA0519', 1, 2, 0, 6, 0 ) ENDIF ENDDO !-- wait for all pending local requests complete CALL MPI_Win_flush_local_all(win_lad, ierr) IF ( ierr /= 0 ) THEN WRITE(message_string, *) 'MPI error ', ierr, ' at MPI_Win_flush_local_all' CALL message( 'raytrace', 'PA0519', 1, 2, 0, 6, 0 ) ENDIF CALL cpu_log( log_point_s(77), 'usm_init_rma', 'stop' ) ENDIF #endif !-- calculate csf and transparency DO i = 1, ncsb #if defined( __parallel ) IF ( usm_lad_rma ) THEN lad_s_target = lad_s_ray(i) ELSE lad_s_target = usm_lad_g(lad_ip(i)*nnx*nny*nzu + lad_disp(i)) ENDIF #else lad_s_target = usm_lad(boxes(1,i),boxes(2,i),boxes(3,i)) #endif cursink = 1._wp - exp(-ext_coef * lad_s_target * crlens(i)*realdist) IF ( create_csf ) THEN !-- write svf values into the array ncsfl = ncsfl + 1 acsf(ncsfl)%ip = lad_ip(i) acsf(ncsfl)%itx = boxes(3,i) acsf(ncsfl)%ity = boxes(2,i) acsf(ncsfl)%itz = boxes(1,i) acsf(ncsfl)%isurfs = isrc acsf(ncsfl)%rsvf = REAL(cursink*rirrf*atarg, wp) !-- we postpone multiplication by transparency acsf(ncsfl)%rtransp = REAL(transparency, wp) ENDIF !< create_csf transparency = transparency * (1._wp - cursink) ENDDO ENDIF visible = .TRUE. END SUBROUTINE raytrace !------------------------------------------------------------------------------! ! Description: ! ------------ !> Determines whether two faces are oriented towards each other. Since the !> surfaces follow the gird box surfaces, it checks first whether the two surfaces !> are directed in the same direction, then it checks if the two surfaces are !> located in confronted direction but facing away from each other, e.g. <--| |--> !------------------------------------------------------------------------------! PURE LOGICAL FUNCTION surface_facing(x, y, z, d, x2, y2, z2, d2) IMPLICIT NONE INTEGER(iwp), INTENT(in) :: x, y, z, d, x2, y2, z2, d2 surface_facing = .FALSE. !-- first check: are the two surfaces directed in the same direction IF ( (d==iup_u .OR. d==iup_l .OR. d==iup_a ) & .AND. (d2==iup_u .OR. d2==iup_l) ) RETURN IF ( (d==isky .OR. d==idown_a) .AND. d2==isky ) RETURN IF ( (d==isouth_u .OR. d==isouth_l .OR. d==isouth_a .OR. d==inorth_b ) & .AND. (d2==isouth_u .OR. d2==isouth_l .OR. d2==inorth_b) ) RETURN IF ( (d==inorth_u .OR. d==inorth_l .OR. d==inorth_a .OR. d==isouth_b ) & .AND. (d2==inorth_u .OR. d2==inorth_l .OR. d2==isouth_b) ) RETURN IF ( (d==iwest_u .OR. d==iwest_l .OR. d==iwest_a .OR. d==ieast_b ) & .AND. (d2==iwest_u .OR. d2==iwest_l .OR. d2==ieast_b ) ) RETURN IF ( (d==ieast_u .OR. d==ieast_l .OR. d==ieast_a .OR. d==iwest_b ) & .AND. (d2==ieast_u .OR. d2==ieast_l .OR. d2==iwest_b ) ) RETURN !-- second check: are surfaces facing away from each other SELECT CASE (d) CASE (iup_u, iup_l, iup_a) !< upward facing surfaces IF ( z2 < z ) RETURN CASE (isky, idown_a) !< downward facing surfaces IF ( z2 > z ) RETURN CASE (isouth_u, isouth_l, isouth_a, inorth_b) !< southward facing surfaces IF ( y2 > y ) RETURN CASE (inorth_u, inorth_l, inorth_a, isouth_b) !< northward facing surfaces IF ( y2 < y ) RETURN CASE (iwest_u, iwest_l, iwest_a, ieast_b) !< westward facing surfaces IF ( x2 > x ) RETURN CASE (ieast_u, ieast_l, ieast_a, iwest_b) !< eastward facing surfaces IF ( x2 < x ) RETURN END SELECT SELECT CASE (d2) CASE (iup_u) !< ground, roof IF ( z < z2 ) RETURN CASE (isky) !< sky IF ( z > z2 ) RETURN CASE (isouth_u, isouth_l, inorth_b) !< south facing IF ( y > y2 ) RETURN CASE (inorth_u, inorth_l, isouth_b) !< north facing IF ( y < y2 ) RETURN CASE (iwest_u, iwest_l, ieast_b) !< west facing IF ( x > x2 ) RETURN CASE (ieast_u, ieast_l, iwest_b) !< east facing IF ( x < x2 ) RETURN CASE (-1) CONTINUE END SELECT surface_facing = .TRUE. END FUNCTION surface_facing !------------------------------------------------------------------------------! ! ! Description: ! ------------ !> Soubroutine reads svf and svfsurf data from saved file !------------------------------------------------------------------------------! SUBROUTINE radiation_read_svf IMPLICIT NONE INTEGER(iwp) :: fsvf = 89 INTEGER(iwp) :: i CHARACTER(usm_version_len) :: usm_version_field CHARACTER(svf_code_len) :: svf_code_field DO i = 0, io_blocks-1 IF ( i == io_group ) THEN OPEN ( fsvf, FILE='SVFIN'//TRIM(coupling_char)//'/'//myid_char,& form='unformatted', status='old' ) !-- read and check version READ ( fsvf ) usm_version_field IF ( TRIM(usm_version_field) /= TRIM(usm_version) ) THEN WRITE( message_string, * ) 'Version of binary SVF file "', & TRIM(usm_version_field), '" does not match ', & 'the version of model "', TRIM(usm_version), '"' CALL message( 'radiation_read_svf', 'UI0012', 1, 2, 0, 6, 0 ) ENDIF !-- read nsvfl, ncsfl READ ( fsvf ) nsvfl, ncsfl IF ( nsvfl <= 0 .OR. ncsfl < 0 ) THEN WRITE( message_string, * ) 'Wrong number of SVF or CSF' CALL message( 'radiation_read_svf', 'UI0012', 1, 2, 0, 6, 0 ) ELSE WRITE(message_string,*) ' Number of SVF and CSF to read', nsvfl, ncsfl CALL location_message( message_string, .TRUE. ) ENDIF ALLOCATE(svf(ndsvf,nsvfl)) ALLOCATE(svfsurf(idsvf,nsvfl)) READ(fsvf) svf READ(fsvf) svfsurf IF ( plant_canopy ) THEN ALLOCATE(csf(ndcsf,ncsfl)) ALLOCATE(csfsurf(idcsf,ncsfl)) READ(fsvf) csf READ(fsvf) csfsurf ENDIF READ ( fsvf ) svf_code_field IF ( TRIM(svf_code_field) /= TRIM(svf_code) ) THEN WRITE( message_string, * ) 'Wrong structure of binary svf file' CALL message( 'radiation_read_svf', 'UI0012', 1, 2, 0, 6, 0 ) ENDIF CLOSE (fsvf) ENDIF #if defined( __parallel ) CALL MPI_BARRIER( comm2d, ierr ) #endif ENDDO END SUBROUTINE radiation_read_svf !------------------------------------------------------------------------------! ! ! Description: ! ------------ !> Subroutine stores svf, svfsurf, csf and csfsurf data to a file. !------------------------------------------------------------------------------! SUBROUTINE radiation_write_svf IMPLICIT NONE INTEGER(iwp) :: fsvf = 89 INTEGER(iwp) :: i DO i = 0, io_blocks-1 IF ( i == io_group ) THEN OPEN ( fsvf, FILE='SVFOUT'//TRIM( coupling_char )//'/'//myid_char, & form='unformatted', status='new' ) WRITE ( fsvf ) usm_version WRITE ( fsvf ) nsvfl, ncsfl WRITE ( fsvf ) svf WRITE ( fsvf ) svfsurf IF ( plant_canopy ) THEN WRITE ( fsvf ) csf WRITE ( fsvf ) csfsurf ENDIF WRITE ( fsvf ) TRIM(svf_code) CLOSE (fsvf) #if defined( __parallel ) CALL MPI_BARRIER( comm2d, ierr ) #endif ENDIF ENDDO END SUBROUTINE radiation_write_svf !------------------------------------------------------------------------------! ! Description: ! ------------ ! !> radiation_radflux_gridbox subroutine gives the sw and lw radiation fluxes at the !> faces of a gridbox defined at i,j,k and located in the urban layer. !> The total sw and the diffuse sw radiation as well as the lw radiation fluxes at !> the gridbox 6 faces are stored in sw_gridbox, swd_gridbox, and lw_gridbox arrays, !> respectively, in the following order: !> up_face, down_face, north_face, south_face, east_face, west_face !> !> The subroutine reports also how successful was the search process via the parameter !> i_feedback as follow: !> - i_feedback = 1 : successful !> - i_feedback = -1 : unsuccessful; the requisted point is outside the urban domain !> - i_feedback = 0 : uncomplete; some gridbox faces fluxes are missing !> !> !> It is called outside from usm_urban_surface_mod whenever the radiation fluxes !> are needed. !> !> TODO: !> - Compare performance when using some combination of the Fortran intrinsic !> functions, e.g. MINLOC, MAXLOC, ALL, ANY and COUNT functions, which search !> surfl array for elements meeting user-specified criterion, i.e. i,j,k !> - Report non-found or incomplete radiation fluxes arrays , if any, at the !> gridbox faces in an error message form !> !------------------------------------------------------------------------------! SUBROUTINE radiation_radflux_gridbox(i,j,k,sw_gridbox,swd_gridbox,lw_gridbox,i_feedback) IMPLICIT NONE INTEGER(iwp), INTENT(in) :: i,j,k !< gridbox indices at which fluxes are required INTEGER(iwp) :: ii,jj,kk,d !< surface indices and type INTEGER(iwp) :: l !< surface id 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 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 INTEGER(iwp), INTENT(out) :: i_feedback !< feedback to report how the search was successful !-- initialize variables i_feedback = -999999 sw_gridbox = -999999.9_wp lw_gridbox = -999999.9_wp swd_gridbox = -999999.9_wp !-- check the requisted grid indices IF ( k < nzb .OR. k > nzut .OR. & j < nysg .OR. j > nyng .OR. & i < nxlg .OR. i > nxrg & ) THEN i_feedback = -1 RETURN ENDIF !-- search for the required grid and formulate the fluxes at the 6 gridbox faces DO l = 1, nsurfl ii = surfl(ix,l) jj = surfl(iy,l) kk = surfl(iz,l) IF ( ii == i .AND. jj == j .AND. kk == k ) THEN d = surfl(id,l) SELECT CASE ( d ) CASE (iup_u,iup_l,iup_a) !- gridbox up_facing face sw_gridbox(1) = surfinsw(l) lw_gridbox(1) = surfinlw(l) swd_gridbox(1) = surfinswdif(l) CASE (isky,idown_a) !- gridbox down_facing face sw_gridbox(2) = surfinsw(l) lw_gridbox(2) = surfinlw(l) swd_gridbox(2) = surfinswdif(l) CASE (inorth_u,inorth_l,inorth_a,isouth_b) !- gridbox north_facing face sw_gridbox(3) = surfinsw(l) lw_gridbox(3) = surfinlw(l) swd_gridbox(3) = surfinswdif(l) CASE (isouth_u,isouth_l,isouth_a,inorth_b) !- gridbox south_facing face sw_gridbox(4) = surfinsw(l) lw_gridbox(4) = surfinlw(l) swd_gridbox(4) = surfinswdif(l) CASE (ieast_u,ieast_l,ieast_a,iwest_b) !- gridbox east_facing face sw_gridbox(5) = surfinsw(l) lw_gridbox(5) = surfinlw(l) swd_gridbox(5) = surfinswdif(l) CASE (iwest_u,iwest_l,iwest_a,ieast_b) !- gridbox west_facing face sw_gridbox(6) = surfinsw(l) lw_gridbox(6) = surfinlw(l) swd_gridbox(6) = surfinswdif(l) END SELECT ENDIF IF ( ALL( sw_gridbox(:) /= -999999.9_wp ) ) EXIT ENDDO !-- check the completeness of the fluxes at all gidbox faces !-- TODO: report non-found or incomplete rad fluxes arrays in an error message form IF ( ANY( sw_gridbox(:) <= -999999.9_wp ) .OR. & ANY( swd_gridbox(:) <= -999999.9_wp ) .OR. & ANY( lw_gridbox(:) <= -999999.9_wp ) ) THEN i_feedback = 0 ELSE i_feedback = 1 ENDIF RETURN END SUBROUTINE radiation_radflux_gridbox !------------------------------------------------------------------------------! ! ! Description: ! ------------ !> Block of auxiliary subroutines: !> 1. quicksort and corresponding comparison !> 2. merge_and_grow_csf for implementation of "dynamical growing" !> array for csf !------------------------------------------------------------------------------! PURE FUNCTION svf_lt(svf1,svf2) result (res) TYPE (t_svf), INTENT(in) :: svf1,svf2 LOGICAL :: res IF ( svf1%isurflt < svf2%isurflt .OR. & (svf1%isurflt == svf2%isurflt .AND. svf1%isurfs < svf2%isurfs) ) THEN res = .TRUE. ELSE res = .FALSE. ENDIF END FUNCTION svf_lt !-- quicksort.f -*-f90-*- !-- Author: t-nissie, adaptation J.Resler !-- License: GPLv3 !-- Gist: https://gist.github.com/t-nissie/479f0f16966925fa29ea RECURSIVE SUBROUTINE quicksort_svf(svfl, first, last) IMPLICIT NONE TYPE(t_svf), DIMENSION(:), INTENT(INOUT) :: svfl INTEGER(iwp), INTENT(IN) :: first, last TYPE(t_svf) :: x, t INTEGER(iwp) :: i, j IF ( first>=last ) RETURN x = svfl( (first+last) / 2 ) i = first j = last DO DO while ( svf_lt(svfl(i),x) ) i=i+1 ENDDO DO while ( svf_lt(x,svfl(j)) ) j=j-1 ENDDO IF ( i >= j ) EXIT t = svfl(i); svfl(i) = svfl(j); svfl(j) = t i=i+1 j=j-1 ENDDO IF ( first < i-1 ) CALL quicksort_svf(svfl, first, i-1) IF ( j+1 < last ) CALL quicksort_svf(svfl, j+1, last) END SUBROUTINE quicksort_svf PURE FUNCTION csf_lt(csf1,csf2) result (res) TYPE (t_csf), INTENT(in) :: csf1,csf2 LOGICAL :: res IF ( csf1%ip < csf2%ip .OR. & (csf1%ip == csf2%ip .AND. csf1%itx < csf2%itx) .OR. & (csf1%ip == csf2%ip .AND. csf1%itx == csf2%itx .AND. csf1%ity < csf2%ity) .OR. & (csf1%ip == csf2%ip .AND. csf1%itx == csf2%itx .AND. csf1%ity == csf2%ity .AND. & csf1%itz < csf2%itz) .OR. & (csf1%ip == csf2%ip .AND. csf1%itx == csf2%itx .AND. csf1%ity == csf2%ity .AND. & csf1%itz == csf2%itz .AND. csf1%isurfs < csf2%isurfs) ) THEN res = .TRUE. ELSE res = .FALSE. ENDIF END FUNCTION csf_lt !-- quicksort.f -*-f90-*- !-- Author: t-nissie, adaptation J.Resler !-- License: GPLv3 !-- Gist: https://gist.github.com/t-nissie/479f0f16966925fa29ea RECURSIVE SUBROUTINE quicksort_csf(csfl, first, last) IMPLICIT NONE TYPE(t_csf), DIMENSION(:), INTENT(INOUT) :: csfl INTEGER(iwp), INTENT(IN) :: first, last TYPE(t_csf) :: x, t INTEGER(iwp) :: i, j IF ( first>=last ) RETURN x = csfl( (first+last)/2 ) i = first j = last DO DO while ( csf_lt(csfl(i),x) ) i=i+1 ENDDO DO while ( csf_lt(x,csfl(j)) ) j=j-1 ENDDO IF ( i >= j ) EXIT t = csfl(i); csfl(i) = csfl(j); csfl(j) = t i=i+1 j=j-1 ENDDO IF ( first < i-1 ) CALL quicksort_csf(csfl, first, i-1) IF ( j+1 < last ) CALL quicksort_csf(csfl, j+1, last) END SUBROUTINE quicksort_csf SUBROUTINE merge_and_grow_csf(newsize) INTEGER(iwp), INTENT(in) :: newsize !< new array size after grow, must be >= ncsfl !< or -1 to shrink to minimum INTEGER(iwp) :: iread, iwrite TYPE(t_csf), DIMENSION(:), POINTER :: acsfnew IF ( newsize == -1 ) THEN !-- merge in-place acsfnew => acsf ELSE !-- allocate new array IF ( mcsf == 0 ) THEN ALLOCATE( acsf1(newsize) ) acsfnew => acsf1 ELSE ALLOCATE( acsf2(newsize) ) acsfnew => acsf2 ENDIF ENDIF IF ( ncsfl >= 1 ) THEN !-- sort csf in place (quicksort) CALL quicksort_csf(acsf,1,ncsfl) !-- while moving to a new array, aggregate canopy sink factor records with identical box & source acsfnew(1) = acsf(1) iwrite = 1 DO iread = 2, ncsfl !-- here acsf(kcsf) already has values from acsf(icsf) IF ( acsfnew(iwrite)%itx == acsf(iread)%itx & .AND. acsfnew(iwrite)%ity == acsf(iread)%ity & .AND. acsfnew(iwrite)%itz == acsf(iread)%itz & .AND. acsfnew(iwrite)%isurfs == acsf(iread)%isurfs ) THEN !-- We could simply take either first or second rtransp, both are valid. As a very simple heuristic about which ray !-- probably passes nearer the center of the target box, we choose DIF from the entry with greater CSF, since that !-- might mean that the traced beam passes longer through the canopy box. IF ( acsfnew(iwrite)%rsvf < acsf(iread)%rsvf ) THEN acsfnew(iwrite)%rtransp = acsf(iread)%rtransp ENDIF acsfnew(iwrite)%rsvf = acsfnew(iwrite)%rsvf + acsf(iread)%rsvf !-- advance reading index, keep writing index ELSE !-- not identical, just advance and copy iwrite = iwrite + 1 acsfnew(iwrite) = acsf(iread) ENDIF ENDDO ncsfl = iwrite ENDIF IF ( newsize == -1 ) THEN !-- allocate new array and copy shrinked data IF ( mcsf == 0 ) THEN ALLOCATE( acsf1(ncsfl) ) acsf1(1:ncsfl) = acsf2(1:ncsfl) ELSE ALLOCATE( acsf2(ncsfl) ) acsf2(1:ncsfl) = acsf1(1:ncsfl) ENDIF ENDIF !-- deallocate old array IF ( mcsf == 0 ) THEN mcsf = 1 acsf => acsf1 DEALLOCATE( acsf2 ) ELSE mcsf = 0 acsf => acsf2 DEALLOCATE( acsf1 ) ENDIF ncsfla = newsize END SUBROUTINE merge_and_grow_csf !-- quicksort.f -*-f90-*- !-- Author: t-nissie, adaptation J.Resler !-- License: GPLv3 !-- Gist: https://gist.github.com/t-nissie/479f0f16966925fa29ea RECURSIVE SUBROUTINE quicksort_csf2(kpcsflt, pcsflt, first, last) IMPLICIT NONE INTEGER(iwp), DIMENSION(:,:), INTENT(INOUT) :: kpcsflt REAL(wp), DIMENSION(:,:), INTENT(INOUT) :: pcsflt INTEGER(iwp), INTENT(IN) :: first, last REAL(wp), DIMENSION(ndcsf) :: t2 INTEGER(iwp), DIMENSION(kdcsf) :: x, t1 INTEGER(iwp) :: i, j IF ( first>=last ) RETURN x = kpcsflt(:, (first+last)/2 ) i = first j = last DO DO while ( csf_lt2(kpcsflt(:,i),x) ) i=i+1 ENDDO DO while ( csf_lt2(x,kpcsflt(:,j)) ) j=j-1 ENDDO IF ( i >= j ) EXIT t1 = kpcsflt(:,i); kpcsflt(:,i) = kpcsflt(:,j); kpcsflt(:,j) = t1 t2 = pcsflt(:,i); pcsflt(:,i) = pcsflt(:,j); pcsflt(:,j) = t2 i=i+1 j=j-1 ENDDO IF ( first < i-1 ) CALL quicksort_csf2(kpcsflt, pcsflt, first, i-1) IF ( j+1 < last ) CALL quicksort_csf2(kpcsflt, pcsflt, j+1, last) END SUBROUTINE quicksort_csf2 PURE FUNCTION csf_lt2(item1, item2) result(res) INTEGER(iwp), DIMENSION(kdcsf), INTENT(in) :: item1, item2 LOGICAL :: res res = ( (item1(3) < item2(3)) & .OR. (item1(3) == item2(3) .AND. item1(2) < item2(2)) & .OR. (item1(3) == item2(3) .AND. item1(2) == item2(2) .AND. item1(1) < item2(1)) & .OR. (item1(3) == item2(3) .AND. item1(2) == item2(2) .AND. item1(1) == item2(1) & .AND. item1(4) < item2(4)) ) END FUNCTION csf_lt2 !------------------------------------------------------------------------------! ! ! Description: ! ------------ !> Subroutine for averaging 3D data !------------------------------------------------------------------------------! SUBROUTINE radiation_3d_data_averaging( mode, variable ) USE control_parameters USE indices USE kinds IMPLICIT NONE CHARACTER (LEN=*) :: mode !< CHARACTER (LEN=*) :: variable !< INTEGER(iwp) :: i !< INTEGER(iwp) :: j !< INTEGER(iwp) :: k !< INTEGER(iwp) :: m !< index of current surface element IF ( mode == 'allocate' ) THEN SELECT CASE ( TRIM( variable ) ) CASE ( 'rad_net*' ) IF ( .NOT. ALLOCATED( rad_net_av ) ) THEN ALLOCATE( rad_net_av(nysg:nyng,nxlg:nxrg) ) ENDIF rad_net_av = 0.0_wp CASE ( 'rad_lw_in' ) IF ( .NOT. ALLOCATED( rad_lw_in_av ) ) THEN ALLOCATE( rad_lw_in_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) ENDIF rad_lw_in_av = 0.0_wp CASE ( 'rad_lw_out' ) IF ( .NOT. ALLOCATED( rad_lw_out_av ) ) THEN ALLOCATE( rad_lw_in_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) ENDIF rad_lw_out_av = 0.0_wp CASE ( 'rad_lw_cs_hr' ) IF ( .NOT. ALLOCATED( rad_lw_cs_hr_av ) ) THEN ALLOCATE( rad_lw_cs_hr_av(nzb+1:nzt+1,nysg:nyng,nxlg:nxrg) ) ENDIF rad_lw_cs_hr_av = 0.0_wp CASE ( 'rad_lw_hr' ) IF ( .NOT. ALLOCATED( rad_lw_hr_av ) ) THEN ALLOCATE( rad_lw_hr_av(nzb+1:nzt+1,nysg:nyng,nxlg:nxrg) ) ENDIF rad_lw_hr_av = 0.0_wp CASE ( 'rad_sw_in' ) IF ( .NOT. ALLOCATED( rad_sw_in_av ) ) THEN ALLOCATE( rad_sw_in_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) ENDIF rad_sw_in_av = 0.0_wp CASE ( 'rad_sw_out' ) IF ( .NOT. ALLOCATED( rad_sw_out_av ) ) THEN ALLOCATE( rad_sw_out_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) ENDIF rad_sw_out_av = 0.0_wp CASE ( 'rad_sw_cs_hr' ) IF ( .NOT. ALLOCATED( rad_sw_cs_hr_av ) ) THEN ALLOCATE( rad_sw_cs_hr_av(nzb+1:nzt+1,nysg:nyng,nxlg:nxrg) ) ENDIF rad_sw_cs_hr_av = 0.0_wp CASE ( 'rad_sw_hr' ) IF ( .NOT. ALLOCATED( rad_sw_hr_av ) ) THEN ALLOCATE( rad_sw_hr_av(nzb+1:nzt+1,nysg:nyng,nxlg:nxrg) ) ENDIF rad_sw_hr_av = 0.0_wp CASE DEFAULT CONTINUE END SELECT ELSEIF ( mode == 'sum' ) THEN SELECT CASE ( TRIM( variable ) ) CASE ( 'rad_net*' ) DO i = nxl, nxr DO j = nys, nyn DO m = surf_def_h(0)%start_index(j,i), & surf_def_h(0)%end_index(j,i) rad_net_av(j,i) = rad_net_av(j,i) + surf_def_h(0)%rad_net(m) ENDDO DO m = surf_lsm_h%start_index(j,i), surf_lsm_h%end_index(j,i) rad_net_av(j,i) = rad_net_av(j,i) + surf_lsm_h%rad_net(m) ENDDO DO m = surf_usm_h%start_index(j,i), surf_usm_h%end_index(j,i) rad_net_av(j,i) = rad_net_av(j,i) + surf_usm_h%rad_net(m) ENDDO ENDDO ENDDO CASE ( 'rad_lw_in' ) DO i = nxlg, nxrg DO j = nysg, nyng DO k = nzb, nzt+1 rad_lw_in_av(k,j,i) = rad_lw_in_av(k,j,i) + rad_lw_in(k,j,i) ENDDO ENDDO ENDDO CASE ( 'rad_lw_out' ) DO i = nxlg, nxrg DO j = nysg, nyng DO k = nzb, nzt+1 rad_lw_out_av(k,j,i) = rad_lw_out_av(k,j,i) & + rad_lw_out(k,j,i) ENDDO ENDDO ENDDO CASE ( 'rad_lw_cs_hr' ) DO i = nxlg, nxrg DO j = nysg, nyng DO k = nzb, nzt+1 rad_lw_cs_hr_av(k,j,i) = rad_lw_cs_hr_av(k,j,i) & + rad_lw_cs_hr(k,j,i) ENDDO ENDDO ENDDO CASE ( 'rad_lw_hr' ) DO i = nxlg, nxrg DO j = nysg, nyng DO k = nzb, nzt+1 rad_lw_hr_av(k,j,i) = rad_lw_hr_av(k,j,i) & + rad_lw_hr(k,j,i) ENDDO ENDDO ENDDO CASE ( 'rad_sw_in' ) DO i = nxlg, nxrg DO j = nysg, nyng DO k = nzb, nzt+1 rad_sw_in_av(k,j,i) = rad_sw_in_av(k,j,i) & + rad_sw_in(k,j,i) ENDDO ENDDO ENDDO CASE ( 'rad_sw_out' ) DO i = nxlg, nxrg DO j = nysg, nyng DO k = nzb, nzt+1 rad_sw_out_av(k,j,i) = rad_sw_out_av(k,j,i) & + rad_sw_out(k,j,i) ENDDO ENDDO ENDDO CASE ( 'rad_sw_cs_hr' ) DO i = nxlg, nxrg DO j = nysg, nyng DO k = nzb, nzt+1 rad_sw_cs_hr_av(k,j,i) = rad_sw_cs_hr_av(k,j,i) & + rad_sw_cs_hr(k,j,i) ENDDO ENDDO ENDDO CASE ( 'rad_sw_hr' ) DO i = nxlg, nxrg DO j = nysg, nyng DO k = nzb, nzt+1 rad_sw_hr_av(k,j,i) = rad_sw_hr_av(k,j,i) & + rad_sw_hr(k,j,i) ENDDO ENDDO ENDDO CASE DEFAULT CONTINUE END SELECT ELSEIF ( mode == 'average' ) THEN SELECT CASE ( TRIM( variable ) ) CASE ( 'rad_net*' ) DO i = nxlg, nxrg DO j = nysg, nyng rad_net_av(j,i) = rad_net_av(j,i) / REAL( average_count_3d, & KIND=wp ) ENDDO ENDDO CASE ( 'rad_lw_in' ) DO i = nxlg, nxrg DO j = nysg, nyng DO k = nzb, nzt+1 rad_lw_in_av(k,j,i) = rad_lw_in_av(k,j,i) & / REAL( average_count_3d, KIND=wp ) ENDDO ENDDO ENDDO CASE ( 'rad_lw_out' ) DO i = nxlg, nxrg DO j = nysg, nyng DO k = nzb, nzt+1 rad_lw_out_av(k,j,i) = rad_lw_out_av(k,j,i) & / REAL( average_count_3d, KIND=wp ) ENDDO ENDDO ENDDO CASE ( 'rad_lw_cs_hr' ) DO i = nxlg, nxrg DO j = nysg, nyng DO k = nzb, nzt+1 rad_lw_cs_hr_av(k,j,i) = rad_lw_cs_hr_av(k,j,i) & / REAL( average_count_3d, KIND=wp ) ENDDO ENDDO ENDDO CASE ( 'rad_lw_hr' ) DO i = nxlg, nxrg DO j = nysg, nyng DO k = nzb, nzt+1 rad_lw_hr_av(k,j,i) = rad_lw_hr_av(k,j,i) & / REAL( average_count_3d, KIND=wp ) ENDDO ENDDO ENDDO CASE ( 'rad_sw_in' ) DO i = nxlg, nxrg DO j = nysg, nyng DO k = nzb, nzt+1 rad_sw_in_av(k,j,i) = rad_sw_in_av(k,j,i) & / REAL( average_count_3d, KIND=wp ) ENDDO ENDDO ENDDO CASE ( 'rad_sw_out' ) DO i = nxlg, nxrg DO j = nysg, nyng DO k = nzb, nzt+1 rad_sw_out_av(k,j,i) = rad_sw_out_av(k,j,i) & / REAL( average_count_3d, KIND=wp ) ENDDO ENDDO ENDDO CASE ( 'rad_sw_cs_hr' ) DO i = nxlg, nxrg DO j = nysg, nyng DO k = nzb, nzt+1 rad_sw_cs_hr_av(k,j,i) = rad_sw_cs_hr_av(k,j,i) & / REAL( average_count_3d, KIND=wp ) ENDDO ENDDO ENDDO CASE ( 'rad_sw_hr' ) DO i = nxlg, nxrg DO j = nysg, nyng DO k = nzb, nzt+1 rad_sw_hr_av(k,j,i) = rad_sw_hr_av(k,j,i) & / REAL( average_count_3d, KIND=wp ) ENDDO ENDDO ENDDO END SELECT ENDIF END SUBROUTINE radiation_3d_data_averaging !------------------------------------------------------------------------------! ! ! Description: ! ------------ !> Subroutine defining appropriate grid for netcdf variables. !> It is called out from subroutine netcdf. !------------------------------------------------------------------------------! SUBROUTINE radiation_define_netcdf_grid( var, found, grid_x, grid_y, grid_z ) IMPLICIT NONE CHARACTER (LEN=*), INTENT(IN) :: var !< LOGICAL, INTENT(OUT) :: found !< CHARACTER (LEN=*), INTENT(OUT) :: grid_x !< CHARACTER (LEN=*), INTENT(OUT) :: grid_y !< CHARACTER (LEN=*), INTENT(OUT) :: grid_z !< found = .TRUE. ! !-- Check for the grid SELECT CASE ( TRIM( var ) ) CASE ( 'rad_lw_cs_hr', 'rad_lw_hr', 'rad_sw_cs_hr', 'rad_sw_hr', & 'rad_lw_cs_hr_xy', 'rad_lw_hr_xy', 'rad_sw_cs_hr_xy', & 'rad_sw_hr_xy', 'rad_lw_cs_hr_xz', 'rad_lw_hr_xz', & 'rad_sw_cs_hr_xz', 'rad_sw_hr_xz', 'rad_lw_cs_hr_yz', & 'rad_lw_hr_yz', 'rad_sw_cs_hr_yz', 'rad_sw_hr_yz' ) grid_x = 'x' grid_y = 'y' grid_z = 'zu' CASE ( 'rad_lw_in', 'rad_lw_out', 'rad_sw_in', 'rad_sw_out', & 'rad_lw_in_xy', 'rad_lw_out_xy', 'rad_sw_in_xy','rad_sw_out_xy', & 'rad_lw_in_xz', 'rad_lw_out_xz', 'rad_sw_in_xz','rad_sw_out_xz', & 'rad_lw_in_yz', 'rad_lw_out_yz', 'rad_sw_in_yz','rad_sw_out_yz' ) grid_x = 'x' grid_y = 'y' grid_z = 'zw' CASE DEFAULT found = .FALSE. grid_x = 'none' grid_y = 'none' grid_z = 'none' END SELECT END SUBROUTINE radiation_define_netcdf_grid !------------------------------------------------------------------------------! ! ! Description: ! ------------ !> Subroutine defining 3D output variables !------------------------------------------------------------------------------! SUBROUTINE radiation_data_output_2d( av, variable, found, grid, mode, & local_pf, two_d ) USE indices USE kinds IMPLICIT NONE CHARACTER (LEN=*) :: grid !< CHARACTER (LEN=*) :: mode !< CHARACTER (LEN=*) :: variable !< INTEGER(iwp) :: av !< INTEGER(iwp) :: i !< INTEGER(iwp) :: j !< INTEGER(iwp) :: k !< INTEGER(iwp) :: m !< index of surface element at grid point (j,i) LOGICAL :: found !< LOGICAL :: two_d !< flag parameter that indicates 2D variables (horizontal cross sections) REAL(wp), DIMENSION(nxl:nxr,nys:nyn,nzb:nzt+1) :: local_pf !< found = .TRUE. SELECT CASE ( TRIM( variable ) ) CASE ( 'rad_net*_xy' ) ! 2d-array IF ( av == 0 ) THEN DO i = nxl, nxr DO j = nys, nyn ! !-- Obtain rad_net from its respective surface type !-- Default-type surfaces DO m = surf_def_h(0)%start_index(j,i), & surf_def_h(0)%end_index(j,i) local_pf(i,j,nzb+1) = surf_def_h(0)%rad_net(m) ENDDO ! !-- Natural-type surfaces DO m = surf_lsm_h%start_index(j,i), & surf_lsm_h%end_index(j,i) local_pf(i,j,nzb+1) = surf_lsm_h%rad_net(m) ENDDO ! !-- Urban-type surfaces DO m = surf_usm_h%start_index(j,i), & surf_usm_h%end_index(j,i) local_pf(i,j,nzb+1) = surf_usm_h%rad_net(m) ENDDO ENDDO ENDDO ELSE DO i = nxl, nxr DO j = nys, nyn local_pf(i,j,nzb+1) = rad_net_av(j,i) ENDDO ENDDO ENDIF two_d = .TRUE. grid = 'zu1' CASE ( 'rad_lw_in_xy', 'rad_lw_in_xz', 'rad_lw_in_yz' ) IF ( av == 0 ) THEN DO i = nxl, nxr DO j = nys, nyn DO k = nzb, nzt+1 local_pf(i,j,k) = rad_lw_in(k,j,i) ENDDO ENDDO ENDDO ELSE DO i = nxl, nxr DO j = nys, nyn DO k = nzb, nzt+1 local_pf(i,j,k) = rad_lw_in_av(k,j,i) ENDDO ENDDO ENDDO ENDIF IF ( mode == 'xy' ) grid = 'zu' CASE ( 'rad_lw_out_xy', 'rad_lw_out_xz', 'rad_lw_out_yz' ) IF ( av == 0 ) THEN DO i = nxl, nxr DO j = nys, nyn DO k = nzb, nzt+1 local_pf(i,j,k) = rad_lw_out(k,j,i) ENDDO ENDDO ENDDO ELSE DO i = nxl, nxr DO j = nys, nyn DO k = nzb, nzt+1 local_pf(i,j,k) = rad_lw_out_av(k,j,i) ENDDO ENDDO ENDDO ENDIF IF ( mode == 'xy' ) grid = 'zu' CASE ( 'rad_lw_cs_hr_xy', 'rad_lw_cs_hr_xz', 'rad_lw_cs_hr_yz' ) IF ( av == 0 ) THEN DO i = nxl, nxr DO j = nys, nyn DO k = nzb, nzt+1 local_pf(i,j,k) = rad_lw_cs_hr(k,j,i) ENDDO ENDDO ENDDO ELSE DO i = nxl, nxr DO j = nys, nyn DO k = nzb, nzt+1 local_pf(i,j,k) = rad_lw_cs_hr_av(k,j,i) ENDDO ENDDO ENDDO ENDIF IF ( mode == 'xy' ) grid = 'zw' CASE ( 'rad_lw_hr_xy', 'rad_lw_hr_xz', 'rad_lw_hr_yz' ) IF ( av == 0 ) THEN DO i = nxl, nxr DO j = nys, nyn DO k = nzb, nzt+1 local_pf(i,j,k) = rad_lw_hr(k,j,i) ENDDO ENDDO ENDDO ELSE DO i = nxl, nxr DO j = nys, nyn DO k = nzb, nzt+1 local_pf(i,j,k) = rad_lw_hr_av(k,j,i) ENDDO ENDDO ENDDO ENDIF IF ( mode == 'xy' ) grid = 'zw' CASE ( 'rad_sw_in_xy', 'rad_sw_in_xz', 'rad_sw_in_yz' ) IF ( av == 0 ) THEN DO i = nxl, nxr DO j = nys, nyn DO k = nzb, nzt+1 local_pf(i,j,k) = rad_sw_in(k,j,i) ENDDO ENDDO ENDDO ELSE DO i = nxl, nxr DO j = nys, nyn DO k = nzb, nzt+1 local_pf(i,j,k) = rad_sw_in_av(k,j,i) ENDDO ENDDO ENDDO ENDIF IF ( mode == 'xy' ) grid = 'zu' CASE ( 'rad_sw_out_xy', 'rad_sw_out_xz', 'rad_sw_out_yz' ) IF ( av == 0 ) THEN DO i = nxl, nxr DO j = nys, nyn DO k = nzb, nzt+1 local_pf(i,j,k) = rad_sw_out(k,j,i) ENDDO ENDDO ENDDO ELSE DO i = nxl, nxr DO j = nys, nyn DO k = nzb, nzt+1 local_pf(i,j,k) = rad_sw_out_av(k,j,i) ENDDO ENDDO ENDDO ENDIF IF ( mode == 'xy' ) grid = 'zu' CASE ( 'rad_sw_cs_hr_xy', 'rad_sw_cs_hr_xz', 'rad_sw_cs_hr_yz' ) IF ( av == 0 ) THEN DO i = nxl, nxr DO j = nys, nyn DO k = nzb, nzt+1 local_pf(i,j,k) = rad_sw_cs_hr(k,j,i) ENDDO ENDDO ENDDO ELSE DO i = nxl, nxr DO j = nys, nyn DO k = nzb, nzt+1 local_pf(i,j,k) = rad_sw_cs_hr_av(k,j,i) ENDDO ENDDO ENDDO ENDIF IF ( mode == 'xy' ) grid = 'zw' CASE ( 'rad_sw_hr_xy', 'rad_sw_hr_xz', 'rad_sw_hr_yz' ) IF ( av == 0 ) THEN DO i = nxl, nxr DO j = nys, nyn DO k = nzb, nzt+1 local_pf(i,j,k) = rad_sw_hr(k,j,i) ENDDO ENDDO ENDDO ELSE DO i = nxl, nxr DO j = nys, nyn DO k = nzb, nzt+1 local_pf(i,j,k) = rad_sw_hr_av(k,j,i) ENDDO ENDDO ENDDO ENDIF IF ( mode == 'xy' ) grid = 'zw' CASE DEFAULT found = .FALSE. grid = 'none' END SELECT END SUBROUTINE radiation_data_output_2d !------------------------------------------------------------------------------! ! ! Description: ! ------------ !> Subroutine defining 3D output variables !------------------------------------------------------------------------------! SUBROUTINE radiation_data_output_3d( av, variable, found, local_pf ) USE indices USE kinds IMPLICIT NONE CHARACTER (LEN=*) :: variable !< INTEGER(iwp) :: av !< INTEGER(iwp) :: i !< INTEGER(iwp) :: j !< INTEGER(iwp) :: k !< LOGICAL :: found !< REAL(sp), DIMENSION(nxl:nxr,nys:nyn,nzb:nzt+1) :: local_pf !< found = .TRUE. SELECT CASE ( TRIM( variable ) ) CASE ( 'rad_sw_in' ) IF ( av == 0 ) THEN DO i = nxl, nxr DO j = nys, nyn DO k = nzb, nzt+1 local_pf(i,j,k) = rad_sw_in(k,j,i) ENDDO ENDDO ENDDO ELSE DO i = nxl, nxr DO j = nys, nyn DO k = nzb, nzt+1 local_pf(i,j,k) = rad_sw_in_av(k,j,i) ENDDO ENDDO ENDDO ENDIF CASE ( 'rad_sw_out' ) IF ( av == 0 ) THEN DO i = nxl, nxr DO j = nys, nyn DO k = nzb, nzt+1 local_pf(i,j,k) = rad_sw_out(k,j,i) ENDDO ENDDO ENDDO ELSE DO i = nxl, nxr DO j = nys, nyn DO k = nzb, nzt+1 local_pf(i,j,k) = rad_sw_out_av(k,j,i) ENDDO ENDDO ENDDO ENDIF CASE ( 'rad_sw_cs_hr' ) IF ( av == 0 ) THEN DO i = nxl, nxr DO j = nys, nyn DO k = nzb, nzt+1 local_pf(i,j,k) = rad_sw_cs_hr(k,j,i) ENDDO ENDDO ENDDO ELSE DO i = nxl, nxr DO j = nys, nyn DO k = nzb, nzt+1 local_pf(i,j,k) = rad_sw_cs_hr_av(k,j,i) ENDDO ENDDO ENDDO ENDIF CASE ( 'rad_sw_hr' ) IF ( av == 0 ) THEN DO i = nxl, nxr DO j = nys, nyn DO k = nzb, nzt+1 local_pf(i,j,k) = rad_sw_hr(k,j,i) ENDDO ENDDO ENDDO ELSE DO i = nxl, nxr DO j = nys, nyn DO k = nzb, nzt+1 local_pf(i,j,k) = rad_sw_hr_av(k,j,i) ENDDO ENDDO ENDDO ENDIF CASE ( 'rad_lw_in' ) IF ( av == 0 ) THEN DO i = nxl, nxr DO j = nys, nyn DO k = nzb, nzt+1 local_pf(i,j,k) = rad_lw_in(k,j,i) ENDDO ENDDO ENDDO ELSE DO i = nxl, nxr DO j = nys, nyn DO k = nzb, nzt+1 local_pf(i,j,k) = rad_lw_in_av(k,j,i) ENDDO ENDDO ENDDO ENDIF CASE ( 'rad_lw_out' ) IF ( av == 0 ) THEN DO i = nxl, nxr DO j = nys, nyn DO k = nzb, nzt+1 local_pf(i,j,k) = rad_lw_out(k,j,i) ENDDO ENDDO ENDDO ELSE DO i = nxl, nxr DO j = nys, nyn DO k = nzb, nzt+1 local_pf(i,j,k) = rad_lw_out_av(k,j,i) ENDDO ENDDO ENDDO ENDIF CASE ( 'rad_lw_cs_hr' ) IF ( av == 0 ) THEN DO i = nxl, nxr DO j = nys, nyn DO k = nzb, nzt+1 local_pf(i,j,k) = rad_lw_cs_hr(k,j,i) ENDDO ENDDO ENDDO ELSE DO i = nxl, nxr DO j = nys, nyn DO k = nzb, nzt+1 local_pf(i,j,k) = rad_lw_cs_hr_av(k,j,i) ENDDO ENDDO ENDDO ENDIF CASE ( 'rad_lw_hr' ) IF ( av == 0 ) THEN DO i = nxl, nxr DO j = nys, nyn DO k = nzb, nzt+1 local_pf(i,j,k) = rad_lw_hr(k,j,i) ENDDO ENDDO ENDDO ELSE DO i = nxl, nxr DO j = nys, nyn DO k = nzb, nzt+1 local_pf(i,j,k) = rad_lw_hr_av(k,j,i) ENDDO ENDDO ENDDO ENDIF CASE DEFAULT found = .FALSE. END SELECT END SUBROUTINE radiation_data_output_3d !------------------------------------------------------------------------------! ! ! Description: ! ------------ !> Subroutine defining masked data output !------------------------------------------------------------------------------! SUBROUTINE radiation_data_output_mask( av, variable, found, local_pf ) USE control_parameters USE indices USE kinds IMPLICIT NONE CHARACTER (LEN=*) :: variable !< INTEGER(iwp) :: av !< INTEGER(iwp) :: i !< INTEGER(iwp) :: j !< INTEGER(iwp) :: k !< LOGICAL :: found !< REAL(wp), & DIMENSION(mask_size_l(mid,1),mask_size_l(mid,2),mask_size_l(mid,3)) :: & local_pf !< found = .TRUE. SELECT CASE ( TRIM( variable ) ) CASE ( 'rad_lw_in' ) IF ( av == 0 ) THEN DO i = 1, mask_size_l(mid,1) DO j = 1, mask_size_l(mid,2) DO k = 1, mask_size_l(mid,3) local_pf(i,j,k) = rad_lw_in(mask_k(mid,k), & mask_j(mid,j),mask_i(mid,i)) ENDDO ENDDO ENDDO ELSE DO i = 1, mask_size_l(mid,1) DO j = 1, mask_size_l(mid,2) DO k = 1, mask_size_l(mid,3) local_pf(i,j,k) = rad_lw_in_av(mask_k(mid,k), & mask_j(mid,j),mask_i(mid,i)) ENDDO ENDDO ENDDO ENDIF CASE ( 'rad_lw_out' ) IF ( av == 0 ) THEN DO i = 1, mask_size_l(mid,1) DO j = 1, mask_size_l(mid,2) DO k = 1, mask_size_l(mid,3) local_pf(i,j,k) = rad_lw_out(mask_k(mid,k), & mask_j(mid,j),mask_i(mid,i)) ENDDO ENDDO ENDDO ELSE DO i = 1, mask_size_l(mid,1) DO j = 1, mask_size_l(mid,2) DO k = 1, mask_size_l(mid,3) local_pf(i,j,k) = rad_lw_out_av(mask_k(mid,k), & mask_j(mid,j),mask_i(mid,i)) ENDDO ENDDO ENDDO ENDIF CASE ( 'rad_lw_cs_hr' ) IF ( av == 0 ) THEN DO i = 1, mask_size_l(mid,1) DO j = 1, mask_size_l(mid,2) DO k = 1, mask_size_l(mid,3) local_pf(i,j,k) = rad_lw_cs_hr(mask_k(mid,k), & mask_j(mid,j),mask_i(mid,i)) ENDDO ENDDO ENDDO ELSE DO i = 1, mask_size_l(mid,1) DO j = 1, mask_size_l(mid,2) DO k = 1, mask_size_l(mid,3) local_pf(i,j,k) = rad_lw_cs_hr_av(mask_k(mid,k), & mask_j(mid,j),mask_i(mid,i)) ENDDO ENDDO ENDDO ENDIF CASE ( 'rad_lw_hr' ) IF ( av == 0 ) THEN DO i = 1, mask_size_l(mid,1) DO j = 1, mask_size_l(mid,2) DO k = 1, mask_size_l(mid,3) local_pf(i,j,k) = rad_lw_hr(mask_k(mid,k), & mask_j(mid,j),mask_i(mid,i)) ENDDO ENDDO ENDDO ELSE DO i = 1, mask_size_l(mid,1) DO j = 1, mask_size_l(mid,2) DO k = 1, mask_size_l(mid,3) local_pf(i,j,k) = rad_lw_hr_av(mask_k(mid,k), & mask_j(mid,j),mask_i(mid,i)) ENDDO ENDDO ENDDO ENDIF CASE ( 'rad_sw_in' ) IF ( av == 0 ) THEN DO i = 1, mask_size_l(mid,1) DO j = 1, mask_size_l(mid,2) DO k = 1, mask_size_l(mid,3) local_pf(i,j,k) = rad_sw_in(mask_k(mid,k), & mask_j(mid,j),mask_i(mid,i)) ENDDO ENDDO ENDDO ELSE DO i = 1, mask_size_l(mid,1) DO j = 1, mask_size_l(mid,2) DO k = 1, mask_size_l(mid,3) local_pf(i,j,k) = rad_sw_in_av(mask_k(mid,k), & mask_j(mid,j),mask_i(mid,i)) ENDDO ENDDO ENDDO ENDIF CASE ( 'rad_sw_out' ) IF ( av == 0 ) THEN DO i = 1, mask_size_l(mid,1) DO j = 1, mask_size_l(mid,2) DO k = 1, mask_size_l(mid,3) local_pf(i,j,k) = rad_sw_out(mask_k(mid,k), & mask_j(mid,j),mask_i(mid,i)) ENDDO ENDDO ENDDO ELSE DO i = 1, mask_size_l(mid,1) DO j = 1, mask_size_l(mid,2) DO k = 1, mask_size_l(mid,3) local_pf(i,j,k) = rad_sw_out_av(mask_k(mid,k), & mask_j(mid,j),mask_i(mid,i)) ENDDO ENDDO ENDDO ENDIF CASE ( 'rad_sw_cs_hr' ) IF ( av == 0 ) THEN DO i = 1, mask_size_l(mid,1) DO j = 1, mask_size_l(mid,2) DO k = 1, mask_size_l(mid,3) local_pf(i,j,k) = rad_sw_cs_hr(mask_k(mid,k), & mask_j(mid,j),mask_i(mid,i)) ENDDO ENDDO ENDDO ELSE DO i = 1, mask_size_l(mid,1) DO j = 1, mask_size_l(mid,2) DO k = 1, mask_size_l(mid,3) local_pf(i,j,k) = rad_sw_cs_hr_av(mask_k(mid,k), & mask_j(mid,j),mask_i(mid,i)) ENDDO ENDDO ENDDO ENDIF CASE ( 'rad_sw_hr' ) IF ( av == 0 ) THEN DO i = 1, mask_size_l(mid,1) DO j = 1, mask_size_l(mid,2) DO k = 1, mask_size_l(mid,3) local_pf(i,j,k) = rad_sw_hr(mask_k(mid,k), & mask_j(mid,j),mask_i(mid,i)) ENDDO ENDDO ENDDO ELSE DO i = 1, mask_size_l(mid,1) DO j = 1, mask_size_l(mid,2) DO k = 1, mask_size_l(mid,3) local_pf(i,j,k) = rad_sw_hr_av(mask_k(mid,k), & mask_j(mid,j),mask_i(mid,i)) ENDDO ENDDO ENDDO ENDIF CASE DEFAULT found = .FALSE. END SELECT END SUBROUTINE radiation_data_output_mask !------------------------------------------------------------------------------! ! ! Description: ! ------------ !> Subroutine defines masked output variables !------------------------------------------------------------------------------! SUBROUTINE radiation_last_actions USE control_parameters USE kinds IMPLICIT NONE IF ( write_binary ) THEN IF ( ALLOCATED( rad_net_av ) ) THEN WRITE ( 14 ) 'rad_net_av '; WRITE ( 14 ) rad_net_av ENDIF IF ( ALLOCATED( rad_lw_in ) ) THEN WRITE ( 14 ) 'rad_lw_in '; WRITE ( 14 ) rad_lw_in ENDIF IF ( ALLOCATED( rad_lw_in_av ) ) THEN WRITE ( 14 ) 'rad_lw_in_av '; WRITE ( 14 ) rad_lw_in_av ENDIF IF ( ALLOCATED( rad_lw_out ) ) THEN WRITE ( 14 ) 'rad_lw_out '; WRITE ( 14 ) rad_lw_out ENDIF IF ( ALLOCATED( rad_lw_out_av ) ) THEN WRITE ( 14 ) 'rad_lw_out_av '; WRITE ( 14 ) rad_lw_out_av ENDIF IF ( ALLOCATED( rad_lw_cs_hr ) ) THEN WRITE ( 14 ) 'rad_lw_cs_hr '; WRITE ( 14 ) rad_lw_cs_hr ENDIF IF ( ALLOCATED( rad_lw_cs_hr_av ) ) THEN WRITE ( 14 ) 'rad_lw_cs_hr_av '; WRITE ( 14 ) rad_lw_cs_hr_av ENDIF IF ( ALLOCATED( rad_lw_hr ) ) THEN WRITE ( 14 ) 'rad_lw_hr '; WRITE ( 14 ) rad_lw_hr ENDIF IF ( ALLOCATED( rad_lw_hr_av ) ) THEN WRITE ( 14 ) 'rad_lw_hr_av '; WRITE ( 14 ) rad_lw_hr_av ENDIF IF ( ALLOCATED( rad_sw_in ) ) THEN WRITE ( 14 ) 'rad_sw_in '; WRITE ( 14 ) rad_sw_in ENDIF IF ( ALLOCATED( rad_sw_in_av ) ) THEN WRITE ( 14 ) 'rad_sw_in_av '; WRITE ( 14 ) rad_sw_in_av ENDIF IF ( ALLOCATED( rad_sw_out ) ) THEN WRITE ( 14 ) 'rad_sw_out '; WRITE ( 14 ) rad_sw_out ENDIF IF ( ALLOCATED( rad_sw_out_av ) ) THEN WRITE ( 14 ) 'rad_sw_out_av '; WRITE ( 14 ) rad_sw_out_av ENDIF IF ( ALLOCATED( rad_sw_cs_hr ) ) THEN WRITE ( 14 ) 'rad_sw_cs_hr '; WRITE ( 14 ) rad_sw_cs_hr ENDIF IF ( ALLOCATED( rad_sw_cs_hr_av ) ) THEN WRITE ( 14 ) 'rad_sw_cs_hr_av '; WRITE ( 14 ) rad_sw_cs_hr_av ENDIF IF ( ALLOCATED( rad_sw_hr ) ) THEN WRITE ( 14 ) 'rad_sw_hr '; WRITE ( 14 ) rad_sw_hr ENDIF IF ( ALLOCATED( rad_sw_hr_av ) ) THEN WRITE ( 14 ) 'rad_sw_hr_av '; WRITE ( 14 ) rad_sw_hr_av ENDIF WRITE ( 14 ) '*** end rad *** ' ENDIF END SUBROUTINE radiation_last_actions SUBROUTINE radiation_read_restart_data( i, nxlfa, nxl_on_file, nxrfa, & nxr_on_file, nynfa, nyn_on_file, nysfa,& nys_on_file, offset_xa, offset_ya, & overlap_count, tmp_2d, tmp_3d ) USE control_parameters USE indices USE kinds USE pegrid IMPLICIT NONE CHARACTER (LEN=20) :: field_char !< INTEGER(iwp) :: i !< INTEGER(iwp) :: k !< INTEGER(iwp) :: nxlc !< INTEGER(iwp) :: nxlf !< INTEGER(iwp) :: nxl_on_file !< INTEGER(iwp) :: nxrc !< INTEGER(iwp) :: nxrf !< INTEGER(iwp) :: nxr_on_file !< INTEGER(iwp) :: nync !< INTEGER(iwp) :: nynf !< INTEGER(iwp) :: nyn_on_file !< INTEGER(iwp) :: nysc !< INTEGER(iwp) :: nysf !< INTEGER(iwp) :: nys_on_file !< INTEGER(iwp) :: overlap_count !< INTEGER(iwp), DIMENSION(numprocs_previous_run,1000) :: nxlfa !< INTEGER(iwp), DIMENSION(numprocs_previous_run,1000) :: nxrfa !< INTEGER(iwp), DIMENSION(numprocs_previous_run,1000) :: nynfa !< INTEGER(iwp), DIMENSION(numprocs_previous_run,1000) :: nysfa !< INTEGER(iwp), DIMENSION(numprocs_previous_run,1000) :: offset_xa !< INTEGER(iwp), DIMENSION(numprocs_previous_run,1000) :: offset_ya !< REAL(wp), & DIMENSION(nys_on_file-nbgp:nyn_on_file+nbgp,nxl_on_file-nbgp:nxr_on_file+nbgp) ::& tmp_2d !< REAL(wp), & DIMENSION(nzb:nzt+1,nys_on_file-nbgp:nyn_on_file+nbgp,nxl_on_file-nbgp:nxr_on_file+nbgp) ::& tmp_3d !< REAL(wp), & DIMENSION(0:0,nys_on_file-nbgp:nyn_on_file+nbgp,nxl_on_file-nbgp:nxr_on_file+nbgp) ::& tmp_3d2 !< IF ( initializing_actions == 'read_restart_data' ) THEN READ ( 13 ) field_char DO WHILE ( TRIM( field_char ) /= '*** end rad ***' ) DO k = 1, overlap_count nxlf = nxlfa(i,k) nxlc = nxlfa(i,k) + offset_xa(i,k) nxrf = nxrfa(i,k) nxrc = nxrfa(i,k) + offset_xa(i,k) nysf = nysfa(i,k) nysc = nysfa(i,k) + offset_ya(i,k) nynf = nynfa(i,k) nync = nynfa(i,k) + offset_ya(i,k) SELECT CASE ( TRIM( field_char ) ) CASE ( 'rad_net_av' ) IF ( .NOT. ALLOCATED( rad_net_av ) ) THEN ALLOCATE( rad_net_av(nysg:nyng,nxlg:nxrg) ) ENDIF IF ( k == 1 ) READ ( 13 ) tmp_2d rad_net_av(nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = & tmp_2d(nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp) CASE ( 'rad_lw_in' ) IF ( .NOT. ALLOCATED( rad_lw_in ) ) THEN IF ( radiation_scheme == 'clear-sky' .OR. & radiation_scheme == 'constant') THEN ALLOCATE( rad_lw_in(0:0,nysg:nyng,nxlg:nxrg) ) ELSE ALLOCATE( rad_lw_in(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) ENDIF ENDIF IF ( k == 1 ) THEN IF ( radiation_scheme == 'clear-sky' .OR. & radiation_scheme == 'constant') THEN READ ( 13 ) tmp_3d2 rad_lw_in(0:0,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) =& tmp_3d2(0:0,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp) ELSE READ ( 13 ) tmp_3d rad_lw_in(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) =& tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp) ENDIF ENDIF CASE ( 'rad_lw_in_av' ) IF ( .NOT. ALLOCATED( rad_lw_in_av ) ) THEN IF ( radiation_scheme == 'clear-sky' .OR. & radiation_scheme == 'constant') THEN ALLOCATE( rad_lw_in_av(0:0,nysg:nyng,nxlg:nxrg) ) ELSE ALLOCATE( rad_lw_in_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) ENDIF ENDIF IF ( k == 1 ) THEN IF ( radiation_scheme == 'clear-sky' .OR. & radiation_scheme == 'constant') THEN READ ( 13 ) tmp_3d2 rad_lw_in_av(0:0,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) =& tmp_3d2(0:0,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp) ELSE READ ( 13 ) tmp_3d rad_lw_in_av(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) =& tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp) ENDIF ENDIF CASE ( 'rad_lw_out' ) IF ( .NOT. ALLOCATED( rad_lw_out ) ) THEN IF ( radiation_scheme == 'clear-sky' .OR. & radiation_scheme == 'constant') THEN ALLOCATE( rad_lw_out(0:0,nysg:nyng,nxlg:nxrg) ) ELSE ALLOCATE( rad_lw_out(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) ENDIF ENDIF IF ( k == 1 ) THEN IF ( radiation_scheme == 'clear-sky' .OR. & radiation_scheme == 'constant') THEN READ ( 13 ) tmp_3d2 rad_lw_out(0:0,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) =& tmp_3d2(0:0,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp) ELSE READ ( 13 ) tmp_3d rad_lw_out(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) =& tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp) ENDIF ENDIF CASE ( 'rad_lw_out_av' ) IF ( .NOT. ALLOCATED( rad_lw_out_av ) ) THEN IF ( radiation_scheme == 'clear-sky' .OR. & radiation_scheme == 'constant') THEN ALLOCATE( rad_lw_out_av(0:0,nysg:nyng,nxlg:nxrg) ) ELSE ALLOCATE( rad_lw_out_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) ENDIF ENDIF IF ( k == 1 ) THEN IF ( radiation_scheme == 'clear-sky' .OR. & radiation_scheme == 'constant') THEN READ ( 13 ) tmp_3d2 rad_lw_out_av(0:0,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) =& tmp_3d2(0:0,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp) ELSE READ ( 13 ) tmp_3d rad_lw_out_av(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) =& tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp) ENDIF ENDIF CASE ( 'rad_lw_cs_hr' ) IF ( .NOT. ALLOCATED( rad_lw_cs_hr ) ) THEN ALLOCATE( rad_lw_cs_hr(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) ENDIF IF ( k == 1 ) READ ( 13 ) tmp_3d rad_lw_cs_hr(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = & tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp) CASE ( 'rad_lw_cs_hr_av' ) IF ( .NOT. ALLOCATED( rad_lw_cs_hr_av ) ) THEN ALLOCATE( rad_lw_cs_hr_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) ENDIF IF ( k == 1 ) READ ( 13 ) tmp_3d rad_lw_cs_hr_av(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = & tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp) CASE ( 'rad_lw_hr' ) IF ( .NOT. ALLOCATED( rad_lw_hr ) ) THEN ALLOCATE( rad_lw_hr(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) ENDIF IF ( k == 1 ) READ ( 13 ) tmp_3d rad_lw_hr(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = & tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp) CASE ( 'rad_lw_hr_av' ) IF ( .NOT. ALLOCATED( rad_lw_hr_av ) ) THEN ALLOCATE( rad_lw_hr_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) ENDIF IF ( k == 1 ) READ ( 13 ) tmp_3d rad_lw_hr_av(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = & tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp) CASE ( 'rad_sw_in' ) IF ( .NOT. ALLOCATED( rad_sw_in ) ) THEN IF ( radiation_scheme == 'clear-sky' .OR. & radiation_scheme == 'constant') THEN ALLOCATE( rad_sw_in(0:0,nysg:nyng,nxlg:nxrg) ) ELSE ALLOCATE( rad_sw_in(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) ENDIF ENDIF IF ( k == 1 ) THEN IF ( radiation_scheme == 'clear-sky' .OR. & radiation_scheme == 'constant') THEN READ ( 13 ) tmp_3d2 rad_sw_in(0:0,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) =& tmp_3d2(0:0,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp) ELSE READ ( 13 ) tmp_3d rad_sw_in(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) =& tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp) ENDIF ENDIF CASE ( 'rad_sw_in_av' ) IF ( .NOT. ALLOCATED( rad_sw_in_av ) ) THEN IF ( radiation_scheme == 'clear-sky' .OR. & radiation_scheme == 'constant') THEN ALLOCATE( rad_sw_in_av(0:0,nysg:nyng,nxlg:nxrg) ) ELSE ALLOCATE( rad_sw_in_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) ENDIF ENDIF IF ( k == 1 ) THEN IF ( radiation_scheme == 'clear-sky' .OR. & radiation_scheme == 'constant') THEN READ ( 13 ) tmp_3d2 rad_sw_in_av(0:0,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) =& tmp_3d2(0:0,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp) ELSE READ ( 13 ) tmp_3d rad_sw_in_av(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) =& tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp) ENDIF ENDIF CASE ( 'rad_sw_out' ) IF ( .NOT. ALLOCATED( rad_sw_out ) ) THEN IF ( radiation_scheme == 'clear-sky' .OR. & radiation_scheme == 'constant') THEN ALLOCATE( rad_sw_out(0:0,nysg:nyng,nxlg:nxrg) ) ELSE ALLOCATE( rad_sw_out(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) ENDIF ENDIF IF ( k == 1 ) THEN IF ( radiation_scheme == 'clear-sky' .OR. & radiation_scheme == 'constant') THEN READ ( 13 ) tmp_3d2 rad_sw_out(0:0,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) =& tmp_3d2(0:0,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp) ELSE READ ( 13 ) tmp_3d rad_sw_out(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) =& tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp) ENDIF ENDIF CASE ( 'rad_sw_out_av' ) IF ( .NOT. ALLOCATED( rad_sw_out_av ) ) THEN IF ( radiation_scheme == 'clear-sky' .OR. & radiation_scheme == 'constant') THEN ALLOCATE( rad_sw_out_av(0:0,nysg:nyng,nxlg:nxrg) ) ELSE ALLOCATE( rad_sw_out_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) ENDIF ENDIF IF ( k == 1 ) THEN IF ( radiation_scheme == 'clear-sky' .OR. & radiation_scheme == 'constant') THEN READ ( 13 ) tmp_3d2 rad_sw_out_av(0:0,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) =& tmp_3d2(0:0,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp) ELSE READ ( 13 ) tmp_3d rad_sw_out_av(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) =& tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp) ENDIF ENDIF CASE ( 'rad_sw_cs_hr' ) IF ( .NOT. ALLOCATED( rad_sw_cs_hr ) ) THEN ALLOCATE( rad_sw_cs_hr(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) ENDIF IF ( k == 1 ) READ ( 13 ) tmp_3d rad_sw_cs_hr(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = & tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp) CASE ( 'rad_sw_cs_hr_av' ) IF ( .NOT. ALLOCATED( rad_sw_cs_hr_av ) ) THEN ALLOCATE( rad_sw_cs_hr_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) ENDIF IF ( k == 1 ) READ ( 13 ) tmp_3d rad_sw_cs_hr_av(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = & tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp) CASE ( 'rad_sw_hr' ) IF ( .NOT. ALLOCATED( rad_sw_hr ) ) THEN ALLOCATE( rad_sw_hr(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) ENDIF IF ( k == 1 ) READ ( 13 ) tmp_3d rad_sw_hr(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = & tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp) CASE ( 'rad_sw_hr_av' ) IF ( .NOT. ALLOCATED( rad_sw_hr_av ) ) THEN ALLOCATE( rad_sw_hr_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) ENDIF IF ( k == 1 ) READ ( 13 ) tmp_3d rad_lw_hr_av(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = & tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp) CASE DEFAULT WRITE( message_string, * ) 'unknown variable named "', & TRIM( field_char ), '" found in', & '&data from prior run on PE ', myid CALL message( 'radiation_read_restart_data', 'PA0302', 1, 2, & 0, 6, 0 ) END SELECT ENDDO READ ( 13 ) field_char ENDDO ENDIF END SUBROUTINE radiation_read_restart_data END MODULE radiation_model_mod