Changeset 2920
- Timestamp:
- Mar 22, 2018 11:22:01 AM (6 years ago)
- Location:
- palm/trunk/SOURCE
- Files:
-
- 5 edited
-
init_3d_model.f90 (modified) (4 diffs)
-
plant_canopy_model_mod.f90 (modified) (4 diffs)
-
radiation_model_mod.f90 (modified) (84 diffs)
-
surface_mod.f90 (modified) (2 diffs)
-
urban_surface_mod.f90 (modified) (143 diffs)
Legend:
- Unmodified
- Added
- Removed
-
palm/trunk/SOURCE/init_3d_model.f90
r2906 r2920 25 25 ! ----------------- 26 26 ! $Id$ 27 ! Add call for precalculating apparent solar positions (moh.hefny) 28 ! 29 ! 2906 2018-03-19 08:56:40Z Giersch 27 30 ! The variables read/write_svf_on_init have been removed. Instead ENVIRONMENT 28 31 ! variables read/write_svf have been introduced. Location_message has been … … 494 497 radiation_calc_svf, radiation_write_svf, & 495 498 radiation_interaction, radiation_interactions, & 496 radiation_interaction_init, radiation_read_svf 499 radiation_interaction_init, radiation_read_svf, & 500 radiation_presimulate_solar_pos 497 501 498 502 USE random_function_mod … … 2349 2353 ! 2350 2354 !-- If required, initialize radiation interactions between surfaces 2351 !-- via sky-view factors. This must be done befo e radiation is initialized.2355 !-- via sky-view factors. This must be done before radiation is initialized. 2352 2356 IF ( radiation_interactions ) CALL radiation_interaction_init 2353 2357 … … 2357 2361 CALL radiation_init 2358 2362 CALL location_message( 'finished', .TRUE. ) 2363 2364 ! 2365 !-- Find all discretized apparent solar positions for radiation interaction. 2366 !-- This must be done after radiation_init. 2367 IF ( radiation_interactions ) CALL radiation_presimulate_solar_pos 2359 2368 2360 2369 ! -
palm/trunk/SOURCE/plant_canopy_model_mod.f90
r2892 r2920 25 25 ! ----------------- 26 26 ! $Id$ 27 ! Move usm_lad_rma and prototype_lad to radiation_model (moh.hefny) 28 ! 29 ! 2892 2018-03-14 15:06:29Z suehring 27 30 ! Bugfix, read separate ASCII LAD files for parent and child model. 28 31 ! … … 190 193 191 194 LOGICAL :: calc_beta_lad_profile = .FALSE. !< switch for calc. of lad from beta func. 192 LOGICAL :: usm_lad_rma = .TRUE. !< use MPI RMA to access LAD for raytracing (instead of global array)193 195 194 196 REAL(wp) :: alpha_lad = 9999999.9_wp !< coefficient for lad calculation … … 205 207 REAL(wp) :: lsc = 0.0_wp !< leaf surface concentration 206 208 REAL(wp) :: lsec = 0.0_wp !< leaf scalar exchange coeff. 207 REAL(wp) :: prototype_lad !< prototype leaf area density for computing effective optical depth208 209 209 210 REAL(wp) :: lad_vertical_gradient(10) = 0.0_wp !< lad gradient … … 230 231 !-- Public variables and constants 231 232 PUBLIC pc_heating_rate, canopy_mode, cthf, dt_plant_canopy, lad, lad_s, & 232 pch_index , prototype_lad, usm_lad_rma233 pch_index 233 234 234 235 -
palm/trunk/SOURCE/radiation_model_mod.f90
r2906 r2920 15 15 ! PALM. If not, see <http://www.gnu.org/licenses/>. 16 16 ! 17 ! Copyright 2015-2018 Czech Technical University in Prague 18 ! Copyright 2015-2018 Institute of Computer Science of the 19 ! Czech Academy of Sciences, Prague 17 20 ! Copyright 1997-2018 Leibniz Universitaet Hannover 18 21 !------------------------------------------------------------------------------! … … 25 28 ! ----------------- 26 29 ! $Id$ 30 ! - Bugfix: Initialize pcbl array (=-1) 31 ! moh.hefny: 32 ! - Use precalculated apparent solar positions for direct irradiance 33 ! - Cumulative commit for radiation changes - merged RTM version 2.0: 34 ! - New version of radiation interaction 35 ! - Added new 2D raytracing process using whole vertical column at once (e.g. 36 ! memory efficiency & much less RMA) 37 ! - Removed virtual surfaces 38 ! - Separate processing of direct and diffuse solar radiation, new discreti 39 ! zation by azimuth and elevation angles 40 ! - Diffuse radiation processed cumulatively using sky view factor 41 ! - Enabled limiting of number of view factors between real surfaces, thus 42 ! greatly enhancing scalability 43 ! - Minor bugfixes and enhancements 44 ! - Fixing bugs from moving radiation interaction from urban_surface_mod 45 ! 46 ! 47 ! 2906 2018-03-19 08:56:40Z Giersch 27 48 ! NAMELIST paramter read/write_svf_on_init have been removed, functions 28 49 ! check_open and close_file are used now for opening/closing files related to … … 97 118 ! 98 119 ! 2544 2017-10-13 18:09:32Z maronga 99 ! Moved date and time quantitis to separate module date_and_time_mod 120 ! Moved date and time quantitis to separate module date_and_time_mod 100 121 ! 101 122 ! 2512 2017-10-04 08:26:59Z raasch … … 262 283 latitude, longitude, large_scale_forcing, lsf_surf, & 263 284 message_string, microphysics_morrison, plant_canopy, pt_surface,& 264 rho_surface, surface_pressure, time_since_reference_point 285 rho_surface, surface_pressure, time_since_reference_point, & 286 urban_surface, land_surface, end_time, spinup_time, dt_spinup 265 287 266 288 USE cpulog, & … … 272 294 USE date_and_time_mod, & 273 295 ONLY: calc_date_and_time, d_hours_day, d_seconds_hour, day_of_year, & 274 time_utc296 d_seconds_year, day_of_year_init, time_utc_init, time_utc 275 297 276 298 USE indices, & … … 294 316 295 317 USE plant_canopy_model_mod, & 296 ONLY: pc_heating_rate, lad_s , usm_lad_rma318 ONLY: pc_heating_rate, lad_s 297 319 298 320 USE pegrid … … 380 402 sun_direction = .FALSE., & !< flag parameter indicating whether solar direction shall be calculated 381 403 average_radiation = .FALSE., & !< flag to set the calculation of radiation averaging for the domain 382 atm_surfaces = .FALSE., & !< flag parameter indicating wheather surfaces of atmospheric cells will be considered in calculating SVF 383 radiation_interactions = .TRUE., & !< flag to control if radiation interactions via sky-view factors shall be considered 404 radiation_interactions = .FALSE., & !< flag to control if radiation interactions via sky-view factors shall be considered 384 405 surf_reflections = .TRUE. !< flag to switch the calculation of radiation interaction between surfaces. 385 406 !< When it switched off, only the effect of buildings and trees shadow will … … 581 602 INTEGER(iwp), PARAMETER :: ix = 4 !< position of i-index in surfl and surf 582 603 583 INTEGER(iwp), PARAMETER :: nsurf_type = 21!< number of surf types incl. phys.(land+urban) & (atm.,sky,boundary) surfaces - 1584 585 INTEGER(iwp), PARAMETER :: iup_u = 0 !< 0 - index of urban u bward surface (ground or roof)604 INTEGER(iwp), PARAMETER :: nsurf_type = 16 !< number of surf types incl. phys.(land+urban) & (atm.,sky,boundary) surfaces - 1 605 606 INTEGER(iwp), PARAMETER :: iup_u = 0 !< 0 - index of urban upward surface (ground or roof) 586 607 INTEGER(iwp), PARAMETER :: idown_u = 1 !< 1 - index of urban downward surface (overhanging) 587 608 INTEGER(iwp), PARAMETER :: inorth_u = 2 !< 2 - index of urban northward facing wall … … 590 611 INTEGER(iwp), PARAMETER :: iwest_u = 5 !< 5 - index of urban westward facing wall 591 612 592 INTEGER(iwp), PARAMETER :: iup_l = 6 !< 6 - index of land u bward surface (ground or roof)613 INTEGER(iwp), PARAMETER :: iup_l = 6 !< 6 - index of land upward surface (ground or roof) 593 614 INTEGER(iwp), PARAMETER :: inorth_l = 7 !< 7 - index of land northward facing wall 594 615 INTEGER(iwp), PARAMETER :: isouth_l = 8 !< 8 - index of land southward facing wall … … 603 624 INTEGER(iwp), PARAMETER :: iwest_a = 16 !< 16- index of atm. cell westward facing virtual surface 604 625 605 INTEGER(iwp), PARAMETER :: isky = 17 !< 17 - index of top border of the urban surface layer ("urban sky") 606 INTEGER(iwp), PARAMETER :: inorth_b = 18 !< 18 - index of free north border of the domain (south facing) 607 INTEGER(iwp), PARAMETER :: isouth_b = 19 !< 19 - index of north south border of the domain (north facing) 608 INTEGER(iwp), PARAMETER :: ieast_b = 20 !< 20 - index of east border of the domain (west facing) 609 INTEGER(iwp), PARAMETER :: iwest_b = 21 !< 21 - index of wast border of the domain (east facing) 610 611 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 612 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 613 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 626 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/) !< surface normal direction x indices 627 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/) !< surface normal direction y indices 628 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/) !< surface normal direction z indices 614 629 !< parameter but set in the code 615 630 616 631 617 632 !-- indices and sizes of urban and land surface models 618 INTEGER(iwp) :: nskys !< number of sky surfaces in local processor 619 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 620 INTEGER(iwp) :: endland !< end index of block of land and roof surfaces INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE :: pct !< top layer of the plant canopy 621 INTEGER(iwp) :: nlands !< number of land and roof surfaces in local processor INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE :: pch !< heights of the plant canopy 622 INTEGER(iwp) :: startwall !< start index of block of wall surfaces INTEGER(iwp) :: npcbl !< number of the plant canopy gridboxes in local processor 623 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, 624 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 625 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 626 633 INTEGER(iwp) :: startland !< start index of block of land and roof surfaces 634 INTEGER(iwp) :: endland !< end index of block of land and roof surfaces 635 INTEGER(iwp) :: nlands !< number of land and roof surfaces in local processor 636 INTEGER(iwp) :: startwall !< start index of block of wall surfaces 637 INTEGER(iwp) :: endwall !< end index of block of wall surfaces 638 INTEGER(iwp) :: nwalls !< number of wall surfaces in local processor 627 639 628 640 !-- indices and sizes of urban and land surface models … … 631 643 INTEGER(iwp) :: nsurfl !< number of all surfaces in local processor 632 644 INTEGER(iwp), DIMENSION(:), ALLOCATABLE :: nsurfs !< array of number of all surfaces in individual processors 633 INTEGER(iwp) :: startsky !< start index of block of sky634 INTEGER(iwp) :: endsky !< end index of block of sky635 INTEGER(iwp) :: startenergy !< start index of block of real surfaces (land, walls and roofs)636 INTEGER(iwp) :: endenergy !< end index of block of real surfaces (land, walls and roofs)637 INTEGER(iwp) :: nenergy !< number of real surfaces in local processor638 645 INTEGER(iwp) :: nsurf !< global number of surfaces in index array of surfaces (nsurf = proc nsurfs) 639 INTEGER(iwp) :: startborder !< start index of block of border640 INTEGER(iwp) :: endborder !< end index of block of border641 646 INTEGER(iwp), DIMENSION(:), ALLOCATABLE :: surfstart !< starts of blocks of surfaces for individual processors in array surf 642 647 !< respective block for particular processor is surfstart[iproc]+1 : surfstart[iproc+1] … … 648 653 INTEGER(wp), DIMENSION(:,:), ALLOCATABLE :: pcbl !< k,j,i coordinates of l-th local plant canopy box pcbl[:,l] = [k, j, i] 649 654 REAL(wp), DIMENSION(:), ALLOCATABLE :: pcbinsw !< array of absorbed sw radiation for local plant canopy box 655 REAL(wp), DIMENSION(:), ALLOCATABLE :: pcbinswdir !< array of absorbed direct sw radiation for local plant canopy box 656 REAL(wp), DIMENSION(:), ALLOCATABLE :: pcbinswdif !< array of absorbed diffusion sw radiation for local plant canopy box 650 657 REAL(wp), DIMENSION(:), ALLOCATABLE :: pcbinlw !< array of absorbed lw radiation for local plant canopy box 651 658 … … 653 660 LOGICAL :: split_diffusion_radiation = .TRUE. !< split direct and diffusion dw radiation 654 661 !< (.F. in case the radiation model already does it) 655 LOGICAL :: energy_balance_surf_h = .TRUE. !< flag parameter indicating wheather the energy balance is calculated for horizontal surfaces 656 LOGICAL :: energy_balance_surf_v = .TRUE. !< flag parameter indicating wheather the energy balance is calculated for vertical surfaces 662 LOGICAL :: rma_lad_raytrace = .FALSE. !< use MPI RMA to access LAD for raytracing (instead of global array) 657 663 LOGICAL :: mrt_factors = .FALSE. !< whether to generate MRT factor files during init 658 664 INTEGER(iwp) :: nrefsteps = 0 !< number of reflection steps to perform … … 660 666 INTEGER(iwp), PARAMETER :: svf_code_len = 15 !< length of code for verification of the end of svf file 661 667 CHARACTER(svf_code_len), PARAMETER :: svf_code = '*** end svf ***' !< code for verification of the end of svf file 662 INTEGER(iwp), PARAMETER :: usm_version_len = 10 !< length of identification string of usm version 663 CHARACTER(usm_version_len), PARAMETER :: usm_version = 'USM v. 1.0' !< identification of version of binary svf and restart files 668 INTEGER(iwp), PARAMETER :: rad_version_len = 10 !< length of identification string of rad version 669 CHARACTER(rad_version_len), PARAMETER :: rad_version = 'RAD v. 1.0' !< identification of version of binary svf and restart files 670 INTEGER(iwp) :: raytrace_discrete_elevs = 40 !< number of discretization steps for elevation (nadir to zenith) 671 INTEGER(iwp) :: raytrace_discrete_azims = 80 !< number of discretization steps for azimuth (out of 360 degrees) 672 REAL(wp) :: max_raytracing_dist = -999.0_wp !< maximum distance for raytracing (in metres) 673 REAL(wp) :: min_irrf_value = 1e-6_wp !< minimum potential irradiance factor value for raytracing 674 REAL(wp), DIMENSION(1:30) :: svfnorm_report_thresh = 1e21_wp !< thresholds of SVF normalization values to report 675 INTEGER(iwp) :: svfnorm_report_num !< number of SVF normalization thresholds to report 664 676 665 677 !-- radiation related arrays to be used in radiation_interaction routine … … 697 709 REAL(wp), DIMENSION(:), ALLOCATABLE :: surfins !< array of sw radiation falling to local surface after i-th reflection 698 710 REAL(wp), DIMENSION(:), ALLOCATABLE :: surfinl !< array of lw radiation for local surface after i-th reflection 699 700 !< Inward radiation is also valid for virtual surfaces (radiation leaving domain) 711 712 REAL(wp), DIMENSION(:), ALLOCATABLE :: skyvf !< array of sky view factor for each local surface 713 REAL(wp), DIMENSION(:), ALLOCATABLE :: skyvft !< array of sky view factor including transparency for each local surface 714 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: dsitrans !< dsidir[isvfl,i] = path transmittance of i-th 715 !< direction of direct solar irradiance per target surface 716 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: dsitransc !< dtto per plant canopy box 717 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: dsidir !< dsidir[:,i] = unit vector of i-th 718 !< direction of direct solar irradiance 719 INTEGER(iwp) :: ndsidir !< number of apparent solar directions used 720 INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE :: dsidir_rev !< dsidir_rev[ielev,iazim] = i for dsidir or -1 if not present 721 701 722 REAL(wp), DIMENSION(:), ALLOCATABLE :: surfinsw !< array of sw radiation falling to local surface including radiation from reflections 702 723 REAL(wp), DIMENSION(:), ALLOCATABLE :: surfinlw !< array of lw radiation falling to local surface including radiation from reflections … … 713 734 REAL(wp), DIMENSION(:), ALLOCATABLE :: surfoutlw !< array of total lw radiation outgoing from nonvirtual surfaces surfaces after all reflection 714 735 REAL(wp), DIMENSION(:), ALLOCATABLE :: surfhf !< array of total radiation flux incoming to minus outgoing from local surface 715 REAL(wp), DIMENSION(:), ALLOCATABLE :: rad_net_l !< local copy of rad_net (net radiation at surface)716 736 717 737 !-- block variables needed for calculation of the plant canopy model inside the urban surface model 718 738 INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE :: csfsurf !< csfsurf[:,icsf] = index of target surface and csf grid index for csf[icsf] 719 739 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: csf !< array of plant canopy sink fators + direct irradiation factors (transparency) 720 REAL(wp), DIMENSION(:,:,:), POINTER :: usm_lad !< subset of lad_s within urban surface, transformed to plain Z coordinate 721 REAL(wp), DIMENSION(:), POINTER :: usm_lad_g !< usm_lad globalized (used to avoid MPI RMA calls in raytracing) 740 REAL(wp), DIMENSION(:,:,:), POINTER :: sub_lad !< subset of lad_s within urban surface, transformed to plain Z coordinate 741 REAL(wp), DIMENSION(:), POINTER :: sub_lad_g !< sub_lad globalized (used to avoid MPI RMA calls in raytracing) 742 REAL(wp) :: prototype_lad !< prototype leaf area density for computing effective optical depth 722 743 INTEGER(iwp), DIMENSION(:), ALLOCATABLE :: nzterr, plantt !< temporary global arrays for raytracing 744 INTEGER(iwp) :: plantt_max 723 745 724 746 !-- arrays and variables for calculation of svf and csf … … 736 758 INTEGER(iwp) :: ncsfl !< no. of csf in local processor 737 759 !< needed only during calc_svf but must be here because it is 738 !< shared between subroutines usm_calc_svf and usm_raytrace760 !< shared between subroutines calc_svf and raytrace 739 761 INTEGER(iwp), DIMENSION(:,:,:), ALLOCATABLE :: gridpcbl !< index of local pcb[k,j,i] 740 762 … … 748 770 DIMENSION(:), ALLOCATABLE :: lad_disp !< array of displaycements of lad in local array of proc lad_ip 749 771 #endif 750 REAL(wp), DIMENSION(:), ALLOCATABLE :: lad_s_ray !< array of received lad_s for appropriate gridboxes crossed by ray 772 REAL(wp), DIMENSION(:), ALLOCATABLE :: lad_s_ray !< array of received lad_s for appropriate gridboxes crossed by ray 773 INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE :: rt2_track 774 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: rt2_track_lad 775 REAL(wp), DIMENSION(:), ALLOCATABLE :: rt2_track_dist 776 REAL(wp), DIMENSION(:), ALLOCATABLE :: rt2_dist 777 751 778 752 779 … … 839 866 MODULE PROCEDURE radiation_interaction_init 840 867 END INTERFACE radiation_interaction_init 868 869 INTERFACE radiation_presimulate_solar_pos 870 MODULE PROCEDURE radiation_presimulate_solar_pos 871 END INTERFACE radiation_presimulate_solar_pos 841 872 842 873 INTERFACE radiation_radflux_gridbox … … 872 903 radiation_radflux_gridbox, radiation_calc_svf, radiation_write_svf, & 873 904 radiation_interaction, radiation_interaction_init, & 874 radiation_read_svf 905 radiation_read_svf, radiation_presimulate_solar_pos 875 906 876 907 … … 888 919 zenith, calc_zenith, sun_direction, sun_dir_lat, sun_dir_lon, & 889 920 split_diffusion_radiation, & 890 energy_balance_surf_h, energy_balance_surf_v, &891 921 nrefsteps, mrt_factors, dist_max_svf, nsvfl, svf, & 892 922 svfsurf, surfinsw, surfinlw, surfins, surfinl, surfinswdir, & 893 923 surfinswdif, surfoutsw, surfoutlw, surfinlwdif, rad_sw_in_dir, & 894 924 rad_sw_in_diff, rad_lw_in_diff, surfouts, surfoutl, surfoutsl, & 895 surfoutll, idir, jdir, kdir, id, iz, iy, ix, isky, nenergy, nsurfs, & 896 surfstart, surf, surfl, nsurfl, pcbinsw, pcbinlw, pcbl, npcbl, & 897 startenergy, endenergy, iup_u, inorth_u, isouth_u, ieast_u, iwest_u,& 898 iup_l, inorth_l, isouth_l, ieast_l, iwest_l, startsky, endsky, & 899 startborder, endborder, nsurf_type, nzub, nzut, inorth_b,idown_a, & 900 isouth_b, ieast_b, iwest_b, nzu, pch, nsurf, iup_a, inorth_a, & 901 isouth_a, ieast_a, iwest_a, idsvf, ndsvf, idcsf, ndcsf, kdcsf, pct, & 902 radiation_interactions, startwall, startland, endland, endwall 903 904 925 surfoutll, idir, jdir, kdir, id, iz, iy, ix, nsurfs, surfstart, & 926 surf, surfl, nsurfl, pcbinswdir, pcbinswdif, pcbinsw, pcbinlw, & 927 pcbl, npcbl, iup_u, inorth_u, isouth_u, ieast_u, iwest_u, & 928 iup_l, inorth_l, isouth_l, ieast_l, iwest_l, & 929 nsurf_type, nzub, nzut, nzu, pch, nsurf, & 930 iup_a, idown_a, inorth_a, isouth_a, ieast_a, iwest_a, & 931 idsvf, ndsvf, idcsf, ndcsf, kdcsf, pct, & 932 radiation_interactions, startwall, startland, endland, endwall, & 933 skyvf, skyvft 905 934 906 935 #if defined ( __rrtmg ) … … 1246 1275 ! 1247 1276 !-- Radiation interactions 1248 IF ( urban_surface .AND. .NOT. radiation_interactions ) THEN 1249 message_string = 'radiation_interactions = .T. is required '// & 1250 'when using the urban surface model' 1277 IF ( nrefsteps < 1 .AND. radiation_interactions ) THEN 1278 message_string = 'nrefsteps must be > 0 when using LSM/USM to' // & 1279 'account for surface outgoing SW flux.' // & 1280 'You may set surf_reflections = .FALSE. to ' // & 1281 'diable surface reflections instead.' 1251 1282 CALL message( 'check_parameters', 'PA0999', 1, 2, 0, 6, 0 ) 1252 1283 ENDIF 1284 1285 ! 1286 !-- Incialize svf normalization reporting histogram 1287 svfnorm_report_num = 1 1288 DO WHILE ( svfnorm_report_thresh(svfnorm_report_num) < 1e20_wp & 1289 .AND. svfnorm_report_num <= 30 ) 1290 svfnorm_report_num = svfnorm_report_num + 1 1291 ENDDO 1292 svfnorm_report_num = svfnorm_report_num - 1 1293 1253 1294 1254 1295 … … 1498 1539 IF ( radiation_scheme == 'clear-sky' .OR. & 1499 1540 radiation_scheme == 'constant') THEN 1541 1542 1543 ! 1544 !-- Allocate arrays for incoming/outgoing short/longwave radiation 1545 IF ( .NOT. ALLOCATED ( rad_sw_in ) ) THEN 1546 ALLOCATE ( rad_sw_in(0:0,nysg:nyng,nxlg:nxrg) ) 1547 ENDIF 1548 IF ( .NOT. ALLOCATED ( rad_sw_out ) ) THEN 1549 ALLOCATE ( rad_sw_out(0:0,nysg:nyng,nxlg:nxrg) ) 1550 ENDIF 1551 1552 IF ( .NOT. ALLOCATED ( rad_lw_in ) ) THEN 1553 ALLOCATE ( rad_lw_in(0:0,nysg:nyng,nxlg:nxrg) ) 1554 ENDIF 1555 IF ( .NOT. ALLOCATED ( rad_lw_out ) ) THEN 1556 ALLOCATE ( rad_lw_out(0:0,nysg:nyng,nxlg:nxrg) ) 1557 ENDIF 1558 1500 1559 ! 1501 1560 !-- Allocate average arrays for incoming/outgoing short/longwave radiation … … 1515 1574 ! 1516 1575 !-- Allocate arrays for broadband albedo, and level 1 initialization 1517 !-- via namelist paramter .1518 IF ( .NOT. ALLOCATED(surf_def_h(0)%albedo) ) &1576 !-- via namelist paramter, unless already allocated. 1577 IF ( .NOT. ALLOCATED(surf_def_h(0)%albedo) ) THEN 1519 1578 ALLOCATE( surf_def_h(0)%albedo(0:0,1:surf_def_h(0)%ns) ) 1520 IF ( .NOT. ALLOCATED(surf_lsm_h%albedo) ) & 1579 surf_def_h(0)%albedo = albedo 1580 ENDIF 1581 IF ( .NOT. ALLOCATED(surf_lsm_h%albedo) ) THEN 1521 1582 ALLOCATE( surf_lsm_h%albedo(0:2,1:surf_lsm_h%ns) ) 1522 IF ( .NOT. ALLOCATED(surf_usm_h%albedo) ) & 1583 surf_lsm_h%albedo = albedo 1584 ENDIF 1585 IF ( .NOT. ALLOCATED(surf_usm_h%albedo) ) THEN 1523 1586 ALLOCATE( surf_usm_h%albedo(0:2,1:surf_usm_h%ns) ) 1524 1525 surf_def_h(0)%albedo = albedo 1526 surf_lsm_h%albedo = albedo 1527 surf_usm_h%albedo = albedo 1587 surf_usm_h%albedo = albedo 1588 ENDIF 1589 1528 1590 DO l = 0, 3 1529 IF ( .NOT. ALLOCATED( surf_def_v(l)%albedo ) ) &1591 IF ( .NOT. ALLOCATED( surf_def_v(l)%albedo ) ) THEN 1530 1592 ALLOCATE( surf_def_v(l)%albedo(0:0,1:surf_def_v(l)%ns) ) 1531 IF ( .NOT. ALLOCATED( surf_lsm_v(l)%albedo ) ) & 1593 surf_def_v(l)%albedo = albedo 1594 ENDIF 1595 IF ( .NOT. ALLOCATED( surf_lsm_v(l)%albedo ) ) THEN 1532 1596 ALLOCATE( surf_lsm_v(l)%albedo(0:2,1:surf_lsm_v(l)%ns) ) 1533 IF ( .NOT. ALLOCATED( surf_usm_v(l)%albedo ) ) & 1597 surf_lsm_v(l)%albedo = albedo 1598 ENDIF 1599 IF ( .NOT. ALLOCATED( surf_usm_v(l)%albedo ) ) THEN 1534 1600 ALLOCATE( surf_usm_v(l)%albedo(0:2,1:surf_usm_v(l)%ns) ) 1535 1536 surf_def_v(l)%albedo = albedo 1537 surf_lsm_v(l)%albedo = albedo 1538 surf_usm_v(l)%albedo = albedo 1601 surf_usm_v(l)%albedo = albedo 1602 ENDIF 1539 1603 ENDDO 1540 1604 ! … … 2523 2587 ENDIF 2524 2588 2589 ! 2590 !-- Fill out values in radiation arrays 2591 DO m = 1, surf%ns 2592 i = surf%i(m) 2593 j = surf%j(m) 2594 rad_sw_in(0,j,i) = surf%rad_sw_in(m) 2595 rad_sw_out(0,j,i) = surf%rad_sw_out(m) 2596 rad_lw_in(0,j,i) = surf%rad_lw_in(m) 2597 rad_lw_out(0,j,i) = surf%rad_lw_out(m) 2598 ENDDO 2599 2525 2600 END SUBROUTINE radiation_clearsky_surf 2526 2601 … … 2711 2786 2712 2787 ENDIF 2788 2789 ! 2790 !-- Fill out values in radiation arrays 2791 DO m = 1, surf%ns 2792 i = surf%i(m) 2793 j = surf%j(m) 2794 rad_sw_in(0,j,i) = surf%rad_sw_in(m) 2795 rad_sw_out(0,j,i) = surf%rad_sw_out(m) 2796 rad_lw_in(0,j,i) = surf%rad_lw_in(m) 2797 rad_lw_out(0,j,i) = surf%rad_lw_out(m) 2798 ENDDO 2713 2799 2714 2800 END SUBROUTINE radiation_constant_surf … … 2802 2888 sw_radiation, unscheduled_radiation_calls, & 2803 2889 split_diffusion_radiation, & 2804 energy_balance_surf_h, & 2805 energy_balance_surf_v, & 2806 nrefsteps, & 2807 mrt_factors, & 2890 max_raytracing_dist, min_irrf_value, & 2891 nrefsteps, mrt_factors, rma_lad_raytrace, & 2808 2892 dist_max_svf, & 2809 2893 average_radiation, & 2810 radiation_interactions, atm_surfaces, & 2811 surf_reflections 2894 surf_reflections, svfnorm_report_thresh 2812 2895 2813 2896 line = ' ' … … 2829 2912 !-- Set flag that indicates that the radiation model is switched on 2830 2913 radiation = .TRUE. 2914 2915 !-- Set radiation_interactions flag according to urban_ and land_surface flag 2916 IF ( urban_surface .OR. land_surface ) radiation_interactions = .TRUE. 2831 2917 2832 2918 10 CONTINUE … … 4472 4558 END SUBROUTINE radiation_tendency 4473 4559 4474 4475 4560 !------------------------------------------------------------------------------! 4476 4561 ! Description: 4477 4562 ! ------------ 4478 4563 !> This subroutine calculates interaction of the solar radiation 4479 !> with urban and land surfaces and updates all surface heatfluxes, including 4480 !> the vertual atmospheric cell faces. It calculates also the required parameters 4481 !> for RRTMG lower BC. 4482 !> 4564 !> with urban and land surfaces and updates all surface heatfluxes. 4565 !> It calculates also the required parameters for RRTMG lower BC. 4566 !> 4483 4567 !> For more info. see Resler et al. 2017 4484 !> 4568 !> 4569 !> The new version 2.0 was radically rewriten, the discretization scheme 4570 !> has been changed. This new version significantly improves effectivity 4571 !> of the paralelization and the scalability of the model. 4572 !------------------------------------------------------------------------------! 4573 4574 SUBROUTINE radiation_interaction 4575 4576 IMPLICIT NONE 4577 4578 INTEGER(iwp) :: i, j, k, kk, is, js, d, ku, refstep, m, mm, l, ll 4579 INTEGER(iwp) :: nzubl, nzutl, isurf, isurfsrc, isvf, icsf, ipcgb 4580 INTEGER(iwp) :: isd !< solar direction number 4581 REAL(wp), DIMENSION(3,3) :: mrot !< grid rotation matrix (zyx) 4582 REAL(wp), DIMENSION(3,0:nsurf_type):: vnorm !< face direction normal vectors (zyx) 4583 REAL(wp), DIMENSION(3) :: sunorig !< grid rotated solar direction unit vector (zyx) 4584 REAL(wp), DIMENSION(3) :: sunorig_grid !< grid squashed solar direction unit vector (zyx) 4585 REAL(wp), DIMENSION(0:nsurf_type) :: costheta !< direct irradiance factor of solar angle 4586 REAL(wp), DIMENSION(nzub:nzut) :: pchf_prep !< precalculated factor for canopy temp tendency 4587 REAL(wp), PARAMETER :: alpha = 0._wp !< grid rotation (TODO: add to namelist or remove) 4588 REAL(wp) :: pc_box_area, pc_abs_frac, pc_abs_eff 4589 INTEGER(iwp) :: pc_box_dimshift !< transform for best accuracy 4590 INTEGER(iwp), DIMENSION(0:3) :: reorder = (/ 1, 0, 3, 2 /) 4591 REAL(wp), DIMENSION(0:nsurf_type) :: facearea 4592 REAL(wp) :: pabsswl = 0.0_wp !< total absorbed SW radiation energy in local processor (W) 4593 REAL(wp) :: pabssw = 0.0_wp !< total absorbed SW radiation energy in all processors (W) 4594 REAL(wp) :: pabslwl = 0.0_wp !< total absorbed LW radiation energy in local processor (W) 4595 REAL(wp) :: pabslw = 0.0_wp !< total absorbed LW radiation energy in all processors (W) 4596 REAL(wp) :: pemitlwl = 0.0_wp !< total emitted LW radiation energy in all processors (W) 4597 REAL(wp) :: pemitlw = 0.0_wp !< total emitted LW radiation energy in all processors (W) 4598 REAL(wp) :: pinswl = 0.0_wp !< total received SW radiation energy in local processor (W) 4599 REAL(wp) :: pinsw = 0.0_wp !< total received SW radiation energy in all processor (W) 4600 REAL(wp) :: pinlwl = 0.0_wp !< total received LW radiation energy in local processor (W) 4601 REAL(wp) :: pinlw = 0.0_wp !< total received LW radiation energy in all processor (W) 4602 REAL(wp) :: emiss_sum_surfl !< sum of emissisivity of surfaces in local processor 4603 REAL(wp) :: emiss_sum_surf !< sum of emissisivity of surfaces in all processor 4604 REAL(wp) :: area_surfl !< total area of surfaces in local processor 4605 REAL(wp) :: area_surf !< total area of surfaces in all processor 4606 4607 #if ! defined( __nopointer ) 4608 IF ( plant_canopy ) THEN 4609 pchf_prep(:) = r_d * (hyp(nzub:nzut) / 100000.0_wp)**0.286_wp & 4610 / (cp * hyp(nzub:nzut) * dx*dy*dz) !< equals to 1 / (rho * c_p * Vbox * T) 4611 ENDIF 4612 #endif 4613 sun_direction = .TRUE. 4614 CALL calc_zenith !< required also for diffusion radiation 4615 4616 !-- prepare rotated normal vectors and irradiance factor 4617 vnorm(1,:) = kdir(:) 4618 vnorm(2,:) = jdir(:) 4619 vnorm(3,:) = idir(:) 4620 mrot(1, :) = (/ 1._wp, 0._wp, 0._wp /) 4621 mrot(2, :) = (/ 0._wp, COS(alpha), SIN(alpha) /) 4622 mrot(3, :) = (/ 0._wp, -SIN(alpha), COS(alpha) /) 4623 sunorig = (/ zenith(0), sun_dir_lat, sun_dir_lon /) 4624 sunorig = MATMUL(mrot, sunorig) 4625 DO d = 0, nsurf_type 4626 costheta(d) = DOT_PRODUCT(sunorig, vnorm(:,d)) 4627 ENDDO 4628 4629 IF ( zenith(0) > 0 ) THEN 4630 !-- now we will "squash" the sunorig vector by grid box size in 4631 !-- each dimension, so that this new direction vector will allow us 4632 !-- to traverse the ray path within grid coordinates directly 4633 sunorig_grid = (/ sunorig(1)/dz, sunorig(2)/dy, sunorig(3)/dx /) 4634 !-- sunorig_grid = sunorig_grid / norm2(sunorig_grid) 4635 sunorig_grid = sunorig_grid / SQRT(SUM(sunorig_grid**2)) 4636 4637 IF ( plant_canopy ) THEN 4638 !-- precompute effective box depth with prototype Leaf Area Density 4639 pc_box_dimshift = MAXLOC(ABS(sunorig), 1) - 1 4640 CALL box_absorb(CSHIFT((/dz,dy,dx/), pc_box_dimshift), & 4641 60, prototype_lad, & 4642 CSHIFT(ABS(sunorig), pc_box_dimshift), & 4643 pc_box_area, pc_abs_frac) 4644 pc_box_area = pc_box_area * ABS(sunorig(pc_box_dimshift+1) / sunorig(1)) 4645 pc_abs_eff = LOG(1._wp - pc_abs_frac) / prototype_lad 4646 ENDIF 4647 ENDIF 4648 4649 !-- split diffusion and direct part of the solar downward radiation 4650 !-- comming from radiation model and store it in 2D arrays 4651 !-- rad_sw_in_diff, rad_sw_in_dir and rad_lw_in_diff 4652 IF ( split_diffusion_radiation ) THEN 4653 CALL calc_diffusion_radiation 4654 ELSE 4655 rad_sw_in_diff = 0.0_wp 4656 rad_sw_in_dir(:,:) = rad_sw_in(0,:,:) 4657 rad_lw_in_diff(:,:) = rad_lw_in(0,:,:) 4658 ENDIF 4659 4660 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 4661 !-- First pass: direct + diffuse irradiance + thermal 4662 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 4663 surfinswdir = 0._wp !nsurfl 4664 surfins = 0._wp !nsurfl 4665 surfinl = 0._wp !nsurfl 4666 surfoutsl(:) = 0.0_wp !start-end 4667 surfoutll(:) = 0.0_wp !start-end 4668 4669 !-- Set up thermal radiation from surfaces 4670 !-- emiss_surf is defined only for surfaces for which energy balance is calculated 4671 !-- Workaround: reorder surface data type back on 1D array including all surfaces, 4672 !-- which implies to reorder horizontal and vertical surfaces 4673 ! 4674 !-- Horizontal walls 4675 mm = 1 4676 DO i = nxl, nxr 4677 DO j = nys, nyn 4678 !-- urban 4679 DO m = surf_usm_h%start_index(j,i), surf_usm_h%end_index(j,i) 4680 surfoutll(mm) = SUM ( surf_usm_h%frac(:,m) * & 4681 surf_usm_h%emissivity(:,m) ) & 4682 * sigma_sb & 4683 * surf_usm_h%pt_surface(m)**4 4684 albedo_surf(mm) = SUM ( surf_usm_h%frac(:,m) * & 4685 surf_usm_h%albedo(:,m) ) 4686 emiss_surf(mm) = SUM ( surf_usm_h%frac(:,m) * & 4687 surf_usm_h%emissivity(:,m) ) 4688 mm = mm + 1 4689 ENDDO 4690 !-- land 4691 DO m = surf_lsm_h%start_index(j,i), surf_lsm_h%end_index(j,i) 4692 surfoutll(mm) = SUM ( surf_lsm_h%frac(:,m) * & 4693 surf_lsm_h%emissivity(:,m) ) & 4694 * sigma_sb & 4695 * surf_lsm_h%pt_surface(m)**4 4696 albedo_surf(mm) = SUM ( surf_lsm_h%frac(:,m) * & 4697 surf_lsm_h%albedo(:,m) ) 4698 emiss_surf(mm) = SUM ( surf_lsm_h%frac(:,m) * & 4699 surf_lsm_h%emissivity(:,m) ) 4700 mm = mm + 1 4701 ENDDO 4702 ENDDO 4703 ENDDO 4704 ! 4705 !-- Vertical walls 4706 DO i = nxl, nxr 4707 DO j = nys, nyn 4708 DO ll = 0, 3 4709 l = reorder(ll) 4710 !-- urban 4711 DO m = surf_usm_v(l)%start_index(j,i), & 4712 surf_usm_v(l)%end_index(j,i) 4713 surfoutll(mm) = SUM ( surf_usm_v(l)%frac(:,m) * & 4714 surf_usm_v(l)%emissivity(:,m) ) & 4715 * sigma_sb & 4716 * surf_usm_v(l)%pt_surface(m)**4 4717 albedo_surf(mm) = SUM ( surf_usm_v(l)%frac(:,m) * & 4718 surf_usm_v(l)%albedo(:,m) ) 4719 emiss_surf(mm) = SUM ( surf_usm_v(l)%frac(:,m) * & 4720 surf_usm_v(l)%emissivity(:,m) ) 4721 mm = mm + 1 4722 ENDDO 4723 !-- land 4724 DO m = surf_lsm_v(l)%start_index(j,i), & 4725 surf_lsm_v(l)%end_index(j,i) 4726 surfoutll(mm) = SUM ( surf_lsm_v(l)%frac(:,m) * & 4727 surf_lsm_v(l)%emissivity(:,m) ) & 4728 * sigma_sb & 4729 * surf_lsm_v(l)%pt_surface(m)**4 4730 albedo_surf(mm) = SUM ( surf_lsm_v(l)%frac(:,m) * & 4731 surf_lsm_v(l)%albedo(:,m) ) 4732 emiss_surf(mm) = SUM ( surf_lsm_v(l)%frac(:,m) * & 4733 surf_lsm_v(l)%emissivity(:,m) ) 4734 mm = mm + 1 4735 ENDDO 4736 ENDDO 4737 ENDDO 4738 ENDDO 4739 4740 #if defined( __parallel ) 4741 !-- might be optimized and gather only values relevant for current processor 4742 CALL MPI_AllGatherv(surfoutll, nsurfl, MPI_REAL, & 4743 surfoutl, nsurfs, surfstart, MPI_REAL, comm2d, ierr) !nsurf global 4744 #else 4745 surfoutl(:) = surfoutll(:) !nsurf global 4746 #endif 4747 4748 DO isvf = 1, nsvfl 4749 isurf = svfsurf(1, isvf) 4750 k = surfl(iz, isurf) 4751 j = surfl(iy, isurf) 4752 i = surfl(ix, isurf) 4753 isurfsrc = svfsurf(2, isvf) 4754 4755 !-- for surface-to-surface factors we calculate thermal radiation in 1st pass 4756 surfinl(isurf) = surfinl(isurf) + svf(1,isvf) * surfoutl(isurfsrc) 4757 ENDDO 4758 4759 !-- diffuse radiation using sky view factor, TODO: homogeneous rad_*w_in_diff because now it depends on no. of processors 4760 surfinswdif(:) = rad_sw_in_diff(nyn,nxl) * skyvft(:) 4761 surfinlwdif(:) = rad_lw_in_diff(nyn,nxl) * skyvf(:) 4762 4763 !-- direct radiation 4764 IF ( zenith(0) > 0 ) THEN 4765 !--Identify solar direction vector (discretized number) 1) 4766 !-- 4767 j = FLOOR(ACOS(zenith(0)) / pi * raytrace_discrete_elevs) 4768 i = MODULO(NINT(ATAN2(sun_dir_lon(0), sun_dir_lat(0)) & 4769 / (2._wp*pi) * raytrace_discrete_azims-.5_wp, iwp), & 4770 raytrace_discrete_azims) 4771 isd = dsidir_rev(j, i) 4772 DO isurf = 1, nsurfl 4773 surfinswdir(isurf) = rad_sw_in_dir(nyn,nxl) * costheta(surfl(id, isurf)) * dsitrans(isurf, isd) / zenith(0) 4774 ENDDO 4775 ENDIF 4776 4777 IF ( plant_canopy ) THEN 4778 4779 pcbinswdir(:) = 0._wp 4780 pcbinswdif(:) = 0._wp 4781 pcbinlw(:) = 0._wp !< will stay always 0 since we don't absorb lw anymore 4782 ! 4783 !-- pcsf first pass 4784 DO icsf = 1, ncsfl 4785 ipcgb = csfsurf(1, icsf) 4786 i = pcbl(ix,ipcgb) 4787 j = pcbl(iy,ipcgb) 4788 k = pcbl(iz,ipcgb) 4789 isurfsrc = csfsurf(2, icsf) 4790 4791 IF ( isurfsrc == -1 ) THEN 4792 !-- Diffuse rad from sky. 4793 pcbinswdif(ipcgb) = csf(1,icsf) * csf(2,icsf) * rad_sw_in_diff(j,i) 4794 4795 !--Direct rad 4796 IF ( zenith(0) > 0 ) THEN 4797 !--Estimate directed box absorption 4798 pc_abs_frac = 1._wp - exp(pc_abs_eff * lad_s(k,j,i)) 4799 4800 !--isd has already been established, see 1) 4801 pcbinswdir(ipcgb) = rad_sw_in_dir(j, i) * pc_box_area & 4802 * pc_abs_frac * dsitransc(ipcgb, isd) 4803 ENDIF 4804 4805 EXIT ! only isurfsrc=-1 is processed here 4806 ENDIF 4807 ENDDO 4808 4809 pcbinsw(:) = pcbinswdir(:) + pcbinswdif(:) 4810 ENDIF 4811 surfins = surfinswdir + surfinswdif 4812 surfinl = surfinl + surfinlwdif 4813 surfinsw = surfins 4814 surfinlw = surfinl 4815 surfoutsw = 0.0_wp 4816 surfoutlw = surfoutll 4817 ! surfhf = surfinsw + surfinlw - surfoutsw - surfoutlw 4818 4819 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 4820 !-- Next passes - reflections 4821 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 4822 DO refstep = 1, nrefsteps 4823 4824 surfoutsl = albedo_surf * surfins 4825 !-- for non-transparent surfaces, longwave albedo is 1 - emissivity 4826 surfoutll = (1._wp - emiss_surf) * surfinl 4827 4828 #if defined( __parallel ) 4829 CALL MPI_AllGatherv(surfoutsl, nsurfl, MPI_REAL, & 4830 surfouts, nsurfs, surfstart, MPI_REAL, comm2d, ierr) 4831 CALL MPI_AllGatherv(surfoutll, nsurfl, MPI_REAL, & 4832 surfoutl, nsurfs, surfstart, MPI_REAL, comm2d, ierr) 4833 #else 4834 surfouts = surfoutsl 4835 surfoutl = surfoutll 4836 #endif 4837 4838 !-- reset for next pass input 4839 surfins = 0._wp 4840 surfinl = 0._wp 4841 4842 !-- reflected radiation 4843 DO isvf = 1, nsvfl 4844 isurf = svfsurf(1, isvf) 4845 isurfsrc = svfsurf(2, isvf) 4846 surfins(isurf) = surfins(isurf) + svf(1,isvf) * svf(2,isvf) * surfouts(isurfsrc) 4847 surfinl(isurf) = surfinl(isurf) + svf(1,isvf) * surfoutl(isurfsrc) 4848 ENDDO 4849 4850 !-- radiation absorbed by plant canopy 4851 DO icsf = 1, ncsfl 4852 ipcgb = csfsurf(1, icsf) 4853 isurfsrc = csfsurf(2, icsf) 4854 IF ( isurfsrc == -1 ) CYCLE ! sky->face only in 1st pass, not here 4855 4856 pcbinsw(ipcgb) = pcbinsw(ipcgb) + csf(1,icsf) * csf(2,icsf) * surfouts(isurfsrc) 4857 ENDDO 4858 4859 surfinsw = surfinsw + surfins 4860 surfinlw = surfinlw + surfinl 4861 surfoutsw = surfoutsw + surfoutsl 4862 surfoutlw = surfoutlw + surfoutll 4863 ! surfhf = surfinsw + surfinlw - surfoutsw - surfoutlw 4864 4865 ENDDO 4866 4867 !-- push heat flux absorbed by plant canopy to respective 3D arrays 4868 IF ( plant_canopy ) THEN 4869 pc_heating_rate(:,:,:) = 0._wp 4870 DO ipcgb = 1, npcbl 4871 4872 j = pcbl(iy, ipcgb) 4873 i = pcbl(ix, ipcgb) 4874 k = pcbl(iz, ipcgb) 4875 ! 4876 !-- Following expression equals former kk = k - nzb_s_inner(j,i) 4877 kk = k - get_topography_top_index_ji( j, i, 's' ) !- lad arrays are defined flat 4878 pc_heating_rate(kk, j, i) = (pcbinsw(ipcgb) + pcbinlw(ipcgb)) & 4879 * pchf_prep(k) * pt(k, j, i) !-- = dT/dt 4880 ENDDO 4881 ENDIF 4882 ! 4883 !-- Transfer radiation arrays required for energy balance to the respective data types 4884 DO i = 1, nsurfl 4885 m = surfl(5,i) 4886 ! 4887 !-- (1) Urban surfaces 4888 !-- upward-facing 4889 IF ( surfl(1,i) == iup_u ) THEN 4890 surf_usm_h%rad_sw_in(m) = surfinsw(i) 4891 surf_usm_h%rad_sw_out(m) = surfoutsw(i) 4892 surf_usm_h%rad_lw_in(m) = surfinlw(i) 4893 surf_usm_h%rad_lw_out(m) = surfoutlw(i) 4894 surf_usm_h%rad_net(m) = surfinsw(i) - surfoutsw(i) + & 4895 surfinlw(i) - surfoutlw(i) 4896 ! 4897 !-- northward-facding 4898 ELSEIF ( surfl(1,i) == inorth_u ) THEN 4899 surf_usm_v(0)%rad_sw_in(m) = surfinsw(i) 4900 surf_usm_v(0)%rad_sw_out(m) = surfoutsw(i) 4901 surf_usm_v(0)%rad_lw_in(m) = surfinlw(i) 4902 surf_usm_v(0)%rad_lw_out(m) = surfoutlw(i) 4903 surf_usm_v(0)%rad_net(m) = surfinsw(i) - surfoutsw(i) + & 4904 surfinlw(i) - surfoutlw(i) 4905 ! 4906 !-- southward-facding 4907 ELSEIF ( surfl(1,i) == isouth_u ) THEN 4908 surf_usm_v(1)%rad_sw_in(m) = surfinsw(i) 4909 surf_usm_v(1)%rad_sw_out(m) = surfoutsw(i) 4910 surf_usm_v(1)%rad_lw_in(m) = surfinlw(i) 4911 surf_usm_v(1)%rad_lw_out(m) = surfoutlw(i) 4912 surf_usm_v(1)%rad_net(m) = surfinsw(i) - surfoutsw(i) + & 4913 surfinlw(i) - surfoutlw(i) 4914 ! 4915 !-- eastward-facing 4916 ELSEIF ( surfl(1,i) == ieast_u ) THEN 4917 surf_usm_v(2)%rad_sw_in(m) = surfinsw(i) 4918 surf_usm_v(2)%rad_sw_out(m) = surfoutsw(i) 4919 surf_usm_v(2)%rad_lw_in(m) = surfinlw(i) 4920 surf_usm_v(2)%rad_lw_out(m) = surfoutlw(i) 4921 surf_usm_v(2)%rad_net(m) = surfinsw(i) - surfoutsw(i) + & 4922 surfinlw(i) - surfoutlw(i) 4923 ! 4924 !-- westward-facding 4925 ELSEIF ( surfl(1,i) == iwest_u ) THEN 4926 surf_usm_v(3)%rad_sw_in(m) = surfinsw(i) 4927 surf_usm_v(3)%rad_sw_out(m) = surfoutsw(i) 4928 surf_usm_v(3)%rad_lw_in(m) = surfinlw(i) 4929 surf_usm_v(3)%rad_lw_out(m) = surfoutlw(i) 4930 surf_usm_v(3)%rad_net(m) = surfinsw(i) - surfoutsw(i) + & 4931 surfinlw(i) - surfoutlw(i) 4932 ! 4933 !-- (2) land surfaces 4934 !-- upward-facing 4935 ELSEIF ( surfl(1,i) == iup_l ) THEN 4936 surf_lsm_h%rad_sw_in(m) = surfinsw(i) 4937 surf_lsm_h%rad_sw_out(m) = surfoutsw(i) 4938 surf_lsm_h%rad_lw_in(m) = surfinlw(i) 4939 surf_lsm_h%rad_lw_out(m) = surfoutlw(i) 4940 surf_lsm_h%rad_net(m) = surfinsw(i) - surfoutsw(i) + & 4941 surfinlw(i) - surfoutlw(i) 4942 ! 4943 !-- northward-facding 4944 ELSEIF ( surfl(1,i) == inorth_l ) THEN 4945 surf_lsm_v(0)%rad_sw_in(m) = surfinsw(i) 4946 surf_lsm_v(0)%rad_sw_out(m) = surfoutsw(i) 4947 surf_lsm_v(0)%rad_lw_in(m) = surfinlw(i) 4948 surf_lsm_v(0)%rad_lw_out(m) = surfoutlw(i) 4949 surf_lsm_v(0)%rad_net(m) = surfinsw(i) - surfoutsw(i) + & 4950 surfinlw(i) - surfoutlw(i) 4951 ! 4952 !-- southward-facding 4953 ELSEIF ( surfl(1,i) == isouth_l ) THEN 4954 surf_lsm_v(1)%rad_sw_in(m) = surfinsw(i) 4955 surf_lsm_v(1)%rad_sw_out(m) = surfoutsw(i) 4956 surf_lsm_v(1)%rad_lw_in(m) = surfinlw(i) 4957 surf_lsm_v(1)%rad_lw_out(m) = surfoutlw(i) 4958 surf_lsm_v(1)%rad_net(m) = surfinsw(i) - surfoutsw(i) + & 4959 surfinlw(i) - surfoutlw(i) 4960 ! 4961 !-- eastward-facing 4962 ELSEIF ( surfl(1,i) == ieast_l ) THEN 4963 surf_lsm_v(2)%rad_sw_in(m) = surfinsw(i) 4964 surf_lsm_v(2)%rad_sw_out(m) = surfoutsw(i) 4965 surf_lsm_v(2)%rad_lw_in(m) = surfinlw(i) 4966 surf_lsm_v(2)%rad_lw_out(m) = surfoutlw(i) 4967 surf_lsm_v(2)%rad_net(m) = surfinsw(i) - surfoutsw(i) + & 4968 surfinlw(i) - surfoutlw(i) 4969 ! 4970 !-- westward-facing 4971 ELSEIF ( surfl(1,i) == iwest_l ) THEN 4972 surf_lsm_v(3)%rad_sw_in(m) = surfinsw(i) 4973 surf_lsm_v(3)%rad_sw_out(m) = surfoutsw(i) 4974 surf_lsm_v(3)%rad_lw_in(m) = surfinlw(i) 4975 surf_lsm_v(3)%rad_lw_out(m) = surfoutlw(i) 4976 surf_lsm_v(3)%rad_net(m) = surfinsw(i) - surfoutsw(i) + & 4977 surfinlw(i) - surfoutlw(i) 4978 ENDIF 4979 4980 ENDDO 4981 4982 DO m = 1, surf_usm_h%ns 4983 surf_usm_h%surfhf(m) = surf_usm_h%rad_sw_in(m) + & 4984 surf_usm_h%rad_lw_in(m) - & 4985 surf_usm_h%rad_sw_out(m) - & 4986 surf_usm_h%rad_lw_out(m) 4987 ENDDO 4988 DO m = 1, surf_lsm_h%ns 4989 surf_lsm_h%surfhf(m) = surf_lsm_h%rad_sw_in(m) + & 4990 surf_lsm_h%rad_lw_in(m) - & 4991 surf_lsm_h%rad_sw_out(m) - & 4992 surf_lsm_h%rad_lw_out(m) 4993 ENDDO 4994 4995 DO l = 0, 3 4996 !-- urban 4997 DO m = 1, surf_usm_v(l)%ns 4998 surf_usm_v(l)%surfhf(m) = surf_usm_v(l)%rad_sw_in(m) + & 4999 surf_usm_v(l)%rad_lw_in(m) - & 5000 surf_usm_v(l)%rad_sw_out(m) - & 5001 surf_usm_v(l)%rad_lw_out(m) 5002 ENDDO 5003 !-- land 5004 DO m = 1, surf_lsm_v(l)%ns 5005 surf_lsm_v(l)%surfhf(m) = surf_lsm_v(l)%rad_sw_in(m) + & 5006 surf_lsm_v(l)%rad_lw_in(m) - & 5007 surf_lsm_v(l)%rad_sw_out(m) - & 5008 surf_lsm_v(l)%rad_lw_out(m) 5009 5010 ENDDO 5011 ENDDO 5012 ! 5013 !-- Calculate the average temperature, albedo, and emissivity for urban/land 5014 !-- domain when using average_radiation in the respective radiation model 5015 5016 IF ( average_radiation ) THEN 5017 5018 !-- precalculate face areas for all face directions using normal vector 5019 DO d = 0, nsurf_type 5020 facearea(d) = 1._wp 5021 IF ( idir(d) == 0 ) facearea(d) = facearea(d) * dx 5022 IF ( jdir(d) == 0 ) facearea(d) = facearea(d) * dy 5023 IF ( kdir(d) == 0 ) facearea(d) = facearea(d) * dz 5024 ENDDO 5025 ! 5026 !-- absorbed/received SW & LW and emitted LW energy of all physical 5027 !-- surfaces (land and urban) in local processor 5028 pinswl = 0._wp 5029 pinlwl = 0._wp 5030 pabsswl = 0._wp 5031 pabslwl = 0._wp 5032 pemitlwl = 0._wp 5033 emiss_sum_surfl = 0._wp 5034 area_surfl = 0._wp 5035 DO i = 1, nsurfl 5036 d = surfl(id, i) 5037 !-- received SW & LW 5038 pinswl = pinswl + surfinsw(i) * facearea(d) 5039 pinlwl = pinlwl + surfinlw(i) * facearea(d) 5040 !-- absorbed SW & LW 5041 pabsswl = pabsswl + (1._wp - albedo_surf(i)) * & 5042 surfinsw(i) * facearea(d) 5043 pabslwl = pabslwl + emiss_surf(i) * surfinlw(i) * facearea(d) 5044 !-- emitted LW 5045 pemitlwl = pemitlwl + surfoutlw(i) * facearea(d) 5046 !-- emissivity and area sum 5047 emiss_sum_surfl = emiss_sum_surfl + emiss_surf(i) * facearea(d) 5048 area_surfl = area_surfl + facearea(d) 5049 END DO 5050 ! 5051 !-- add the absorbed SW energy by plant canopy 5052 IF ( plant_canopy ) THEN 5053 pabsswl = pabsswl + SUM(pcbinsw) 5054 pabslwl = pabslwl + SUM(pcbinlw) 5055 ENDIF 5056 ! 5057 !-- gather all rad flux energy in all processors 5058 #if defined( __parallel ) 5059 CALL MPI_ALLREDUCE( pinswl, pinsw, 1, MPI_REAL, MPI_SUM, comm2d, ierr) 5060 CALL MPI_ALLREDUCE( pinlwl, pinlw, 1, MPI_REAL, MPI_SUM, comm2d, ierr) 5061 CALL MPI_ALLREDUCE( pabsswl, pabssw, 1, MPI_REAL, MPI_SUM, comm2d, ierr ) 5062 CALL MPI_ALLREDUCE( pabslwl, pabslw, 1, MPI_REAL, MPI_SUM, comm2d, ierr ) 5063 CALL MPI_ALLREDUCE( pemitlwl, pemitlw, 1, MPI_REAL, MPI_SUM, comm2d, ierr ) 5064 CALL MPI_ALLREDUCE( emiss_sum_surfl, emiss_sum_surf, 1, MPI_REAL, MPI_SUM, comm2d, ierr ) 5065 CALL MPI_ALLREDUCE( area_surfl, area_surf, 1, MPI_REAL, MPI_SUM, comm2d, ierr ) 5066 #else 5067 pinsw = pinswl 5068 pinlw = pinlwl 5069 pabssw = pabsswl 5070 pabslwl = pabslw 5071 pemitlwl = pemitlw 5072 emiss_sum_surf = emiss_sum_surfl 5073 area_surf = area_surfl 5074 #endif 5075 5076 !-- (1) albedo 5077 IF ( pinsw /= 0.0_wp ) albedo_urb = 1._wp - pabssw / pinsw 5078 5079 !-- (2) average emmsivity 5080 IF ( area_surf /= 0.0_wp ) emissivity_urb = emiss_sum_surf / area_surf 5081 5082 !-- (3) temperature 5083 t_rad_urb = ((pemitlw - pabslw + emissivity_urb*pinlw)/(emissivity_urb*sigma_sb*area_surf))**0.25_wp 5084 5085 ENDIF 5086 5087 CONTAINS 5088 5089 !------------------------------------------------------------------------------! 5090 !> Calculates radiation absorbed by box with given size and LAD. 5091 !> 5092 !> Simulates resol**2 rays (by equally spacing a bounding horizontal square 5093 !> conatining all possible rays that would cross the box) and calculates 5094 !> average transparency per ray. Returns fraction of absorbed radiation flux 5095 !> and area for which this fraction is effective. 5096 !------------------------------------------------------------------------------! 5097 PURE SUBROUTINE box_absorb(boxsize, resol, dens, uvec, area, absorb) 5098 IMPLICIT NONE 5099 5100 REAL(wp), DIMENSION(3), INTENT(in) :: & 5101 boxsize, & !< z, y, x size of box in m 5102 uvec !< z, y, x unit vector of incoming flux 5103 INTEGER(iwp), INTENT(in) :: & 5104 resol !< No. of rays in x and y dimensions 5105 REAL(wp), INTENT(in) :: & 5106 dens !< box density (e.g. Leaf Area Density) 5107 REAL(wp), INTENT(out) :: & 5108 area, & !< horizontal area for flux absorbtion 5109 absorb !< fraction of absorbed flux 5110 REAL(wp) :: & 5111 xshift, yshift, & 5112 xmin, xmax, ymin, ymax, & 5113 xorig, yorig, & 5114 dx1, dy1, dz1, dx2, dy2, dz2, & 5115 crdist, & 5116 transp 5117 INTEGER(iwp) :: & 5118 i, j 5119 5120 xshift = uvec(3) / uvec(1) * boxsize(1) 5121 xmin = min(0._wp, -xshift) 5122 xmax = boxsize(3) + max(0._wp, -xshift) 5123 yshift = uvec(2) / uvec(1) * boxsize(1) 5124 ymin = min(0._wp, -yshift) 5125 ymax = boxsize(2) + max(0._wp, -yshift) 5126 5127 transp = 0._wp 5128 DO i = 1, resol 5129 xorig = xmin + (xmax-xmin) * (i-.5_wp) / resol 5130 DO j = 1, resol 5131 yorig = ymin + (ymax-ymin) * (j-.5_wp) / resol 5132 5133 dz1 = 0._wp 5134 dz2 = boxsize(1)/uvec(1) 5135 5136 IF ( uvec(2) > 0._wp ) THEN 5137 dy1 = -yorig / uvec(2) !< crossing with y=0 5138 dy2 = (boxsize(2)-yorig) / uvec(2) !< crossing with y=boxsize(2) 5139 ELSE !uvec(2)==0 5140 dy1 = -huge(1._wp) 5141 dy2 = huge(1._wp) 5142 ENDIF 5143 5144 IF ( uvec(3) > 0._wp ) THEN 5145 dx1 = -xorig / uvec(3) !< crossing with x=0 5146 dx2 = (boxsize(3)-xorig) / uvec(3) !< crossing with x=boxsize(3) 5147 ELSE !uvec(3)==0 5148 dx1 = -huge(1._wp) 5149 dx2 = huge(1._wp) 5150 ENDIF 5151 5152 crdist = max(0._wp, (min(dz2, dy2, dx2) - max(dz1, dy1, dx1))) 5153 transp = transp + exp(-ext_coef * dens * crdist) 5154 ENDDO 5155 ENDDO 5156 transp = transp / resol**2 5157 area = (boxsize(3)+xshift)*(boxsize(2)+yshift) 5158 absorb = 1._wp - transp 5159 5160 END SUBROUTINE box_absorb 5161 5162 !------------------------------------------------------------------------------! 5163 ! Description: 5164 ! ------------ 5165 !> This subroutine splits direct and diffusion dw radiation 5166 !> It sould not be called in case the radiation model already does it 5167 !> It follows <CITATION> 5168 !------------------------------------------------------------------------------! 5169 SUBROUTINE calc_diffusion_radiation 5170 5171 REAL(wp), PARAMETER :: lowest_solarUp = 0.1_wp !< limit the sun elevation to protect stability of the calculation 5172 INTEGER(iwp) :: i, j 5173 REAL(wp) :: year_angle !< angle 5174 REAL(wp) :: etr !< extraterestrial radiation 5175 REAL(wp) :: corrected_solarUp !< corrected solar up radiation 5176 REAL(wp) :: horizontalETR !< horizontal extraterestrial radiation 5177 REAL(wp) :: clearnessIndex !< clearness index 5178 REAL(wp) :: diff_frac !< diffusion fraction of the radiation 5179 5180 5181 !-- Calculate current day and time based on the initial values and simulation time 5182 year_angle = ( (day_of_year_init * 86400) + time_utc_init & 5183 + time_since_reference_point ) * d_seconds_year & 5184 * 2.0_wp * pi 5185 5186 etr = solar_constant * (1.00011_wp + & 5187 0.034221_wp * cos(year_angle) + & 5188 0.001280_wp * sin(year_angle) + & 5189 0.000719_wp * cos(2.0_wp * year_angle) + & 5190 0.000077_wp * sin(2.0_wp * year_angle)) 5191 5192 !-- 5193 !-- Under a very low angle, we keep extraterestrial radiation at 5194 !-- the last small value, therefore the clearness index will be pushed 5195 !-- towards 0 while keeping full continuity. 5196 !-- 5197 IF ( zenith(0) <= lowest_solarUp ) THEN 5198 corrected_solarUp = lowest_solarUp 5199 ELSE 5200 corrected_solarUp = zenith(0) 5201 ENDIF 5202 5203 horizontalETR = etr * corrected_solarUp 5204 5205 DO i = nxl, nxr 5206 DO j = nys, nyn 5207 clearnessIndex = rad_sw_in(0,j,i) / horizontalETR 5208 diff_frac = 1.0_wp / (1.0_wp + exp(-5.0033_wp + 8.6025_wp * clearnessIndex)) 5209 rad_sw_in_diff(j,i) = rad_sw_in(0,j,i) * diff_frac 5210 rad_sw_in_dir(j,i) = rad_sw_in(0,j,i) * (1.0_wp - diff_frac) 5211 rad_lw_in_diff(j,i) = rad_lw_in(0,j,i) 5212 ENDDO 5213 ENDDO 5214 5215 END SUBROUTINE calc_diffusion_radiation 5216 5217 5218 END SUBROUTINE radiation_interaction 5219 5220 !------------------------------------------------------------------------------! 5221 ! Description: 5222 ! ------------ 5223 !> This subroutine initializes structures needed for radiative transfer 5224 !> model. This model calculates transformation processes of the 5225 !> radiation inside urban and land canopy layer. The module includes also 5226 !> the interaction of the radiation with the resolved plant canopy. 5227 !> 5228 !> For more info. see Resler et al. 2017 5229 !> 5230 !> The new version 2.0 was radically rewriten, the discretization scheme 5231 !> has been changed. This new version significantly improves effectivity 5232 !> of the paralelization and the scalability of the model. 5233 !> 4485 5234 !------------------------------------------------------------------------------! 4486 5235 SUBROUTINE radiation_interaction_init 4487 5236 4488 5237 USE netcdf_data_input_mod, & 4489 5238 ONLY: leaf_area_density_f 4490 5239 4491 USE plant_canopy_model_mod, & 4492 ONLY: pch_index, pc_heating_rate, lad_s , prototype_lad, usm_lad_rma4493 5240 USE plant_canopy_model_mod, & 5241 ONLY: pch_index, pc_heating_rate, lad_s 5242 4494 5243 IMPLICIT NONE 4495 5244 … … 4499 5248 INTEGER(iwp) :: nzubl, nzutl, isurf, ipcgb 4500 5249 INTEGER(iwp) :: procid 4501 4502 INTEGER(iwp), DIMENSION(1:4,inorth_b:iwest_b) :: ijdb !< start and end of the local domain border coordinates (set in code) 4503 LOGICAL, DIMENSION(inorth_b:iwest_b) :: isborder !< is PE on the border of the domain in four corresponding directions 4504 4505 ! 4506 !-- Find nzub, nzut, nzu via wall_flag_0 array (nzb_s_inner will be 5250 REAL(wp) :: mrl 5251 5252 5253 !INTEGER(iwp), DIMENSION(1:4,inorth_b:iwest_b) :: ijdb !< start and end of the local domain border coordinates (set in code) 5254 !LOGICAL, DIMENSION(inorth_b:iwest_b) :: isborder !< is PE on the border of the domain in four corresponding directions 5255 5256 ! 5257 !-- Find nzub, nzut, nzu via wall_flag_0 array (nzb_s_inner will be 4507 5258 !-- removed later). The following contruct finds the lowest / largest index 4508 !-- for any upward-facing wall (see bit 12). 5259 !-- for any upward-facing wall (see bit 12). 4509 5260 nzubl = MINVAL( get_topography_top_index( 's' ) ) 4510 5261 nzutl = MAXVAL( get_topography_top_index( 's' ) ) … … 4538 5289 ENDDO 4539 5290 ENDDO 4540 5291 4541 5292 nzutl = MAX( nzutl, MAXVAL( pct ) ) 4542 5293 !-- code of plant canopy model uses parameter pch_index … … 4544 5295 !-- (pch_index, lad_s and other arrays in PCM are defined flat) 4545 5296 pch_index = MERGE( leaf_area_density_f%nz - 1, MAXVAL( pch ), & 4546 leaf_area_density_f%from_file ) 5297 leaf_area_density_f%from_file ) 4547 5298 4548 5299 prototype_lad = MAXVAL( lad_s ) * .9_wp !< better be *1.0 if lad is either 0 or maxval(lad) everywhere … … 4552 5303 !CALL message('usm_init_urban_surface', 'PA0520', 0, 0, -1, 6, 0) 4553 5304 ENDIF 4554 5305 4555 5306 nzutl = MIN( nzutl + nzut_free, nzt ) 4556 5307 … … 4566 5317 nzu = nzut - nzub + 1 4567 5318 ! 5319 !-- check max_raytracing_dist relative to urban surface layer height 5320 mrl = 2.0_wp * nzu * dz 5321 IF ( max_raytracing_dist <= mrl ) THEN 5322 IF ( max_raytracing_dist /= -999.0_wp ) THEN 5323 !-- max_raytracing_dist too low 5324 WRITE(message_string, '(a,f6.1)') 'Max_raytracing_dist too low, ' & 5325 // 'override to value ', mrl 5326 CALL message('radiation_interaction_init', 'PA0521', 0, 0, -1, 6, 0) 5327 ENDIF 5328 max_raytracing_dist = mrl 5329 ENDIF 5330 ! 4568 5331 !-- allocate urban surfaces grid 4569 5332 !-- calc number of surfaces in local proc … … 4579 5342 4580 5343 ! 4581 !-- Number of vertical surfaces in both USM and LSM. Note that all vertical surface elements are 5344 !-- Number of vertical surfaces in both USM and LSM. Note that all vertical surface elements are 4582 5345 !-- already counted in surface_mod. 4583 5346 startwall = nsurfl+1 … … 4587 5350 endwall = nsurfl 4588 5351 nwalls = endwall - startwall + 1 4589 4590 !-- range of energy balance surfaces ! will be treated separately by surf_usm_h and surf_usm_v4591 !-- Do we really need usm_energy_balance_land??!!4592 !-- !!! Attention: if usm_energy_balance_land = false then only vertical surfaces will be considered here4593 nenergy = 04594 IF ( energy_balance_surf_h ) THEN4595 startenergy = startland4596 nenergy = nenergy + nlands4597 ELSE4598 startenergy = startwall4599 ENDIF4600 IF ( energy_balance_surf_v ) THEN4601 endenergy = endwall4602 nenergy = nenergy + nwalls4603 ELSE4604 endenergy = endland4605 ENDIF4606 4607 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!4608 !-- block of virtual surfaces4609 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!4610 !-- calculate sky surfaces ! not used so far!4611 startsky = nsurfl+14612 nsurfl = nsurfl+(nxr-nxl+1)*(nyn-nys+1)4613 endsky = nsurfl4614 nskys = endsky-startsky+14615 4616 !-- border flags4617 #if defined( __parallel )4618 isborder = (/ north_border_pe, south_border_pe, right_border_pe, left_border_pe /)4619 #else4620 isborder = (/.TRUE.,.TRUE.,.TRUE.,.TRUE./)4621 #endif4622 !-- fill array of the limits of the local domain borders4623 ijdb = RESHAPE( (/ nxl,nxr,nyn,nyn,nxl,nxr,nys,nys,nxr,nxr,nys,nyn,nxl,nxl,nys,nyn /), (/4, 4/) )4624 !-- calulation of the free borders of the domain4625 startborder = nsurfl + 14626 DO ids = inorth_b,iwest_b4627 IF ( isborder(ids) ) THEN4628 !-- free border of the domain in direction ids4629 DO i = ijdb(1,ids), ijdb(2,ids)4630 DO j = ijdb(3,ids), ijdb(4,ids)4631 4632 k_topo = get_topography_top_index_ji( j, i, 's' )4633 k_topo2 = get_topography_top_index_ji( j-jdir(ids), i-idir(ids), 's' )4634 4635 4636 k = nzut - MAX( k_topo, k_topo2 )4637 nsurfl = nsurfl + k4638 ENDDO4639 ENDDO4640 ENDIF4641 ENDDO4642 endborder = nsurfl4643 nborder = endborder - startborder + 14644 4645 !-- calulation of the atmospheric virtual surfaces4646 !-- each atmospheric cell has 6 faces4647 IF ( atm_surfaces ) THEN4648 DO i = nxl, nxr4649 DO j = nys, nyn4650 !-- Find topography top index4651 k_topo = get_topography_top_index_ji( j, i, 's' )4652 k = nzut - k_topo4653 nsurfl = nsurfl + 6 * k4654 ENDDO4655 ENDDO4656 !-- exclude the local physical surfaces4657 nsurfl = nsurfl - nlands - nwalls4658 !-- exclude the local virtual surfaces4659 nsurfl = nsurfl - nskys - nborder4660 ENDIF4661 5352 4662 5353 !-- fill gridpcbl and pcbl … … 4664 5355 ALLOCATE( pcbl(iz:ix, 1:npcbl) ) 4665 5356 ALLOCATE( gridpcbl(nzub:nzut,nys:nyn,nxl:nxr) ) 5357 pcbl = -1 4666 5358 gridpcbl(:,:,:) = 0 4667 5359 ipcgb = 0 … … 4679 5371 ENDDO 4680 5372 ENDDO 4681 4682 5373 ALLOCATE( pcbinsw( 1:npcbl ) ) 5374 ALLOCATE( pcbinswdir( 1:npcbl ) ) 5375 ALLOCATE( pcbinswdif( 1:npcbl ) ) 4683 5376 ALLOCATE( pcbinlw( 1:npcbl ) ) 4684 5377 ENDIF 4685 5378 4686 !-- fill surfl 4687 ALLOCATE(surfl(5,nsurfl)) ! is it mecessary to allocate it with (5,nsurfl)? 5379 !-- fill surfl (the ordering of local surfaces given by the following 5380 !-- cycles must not be altered, certain file input routines may depend 5381 !-- on it) 5382 ALLOCATE(surfl(5,nsurfl)) ! is it mecessary to allocate it with (5,nsurfl)? 4688 5383 isurf = 0 4689 5384 4690 5385 !-- add horizontal surface elements (land and urban surfaces) 4691 5386 !-- TODO: add urban overhanging surfaces (idown_u) … … 4705 5400 surfl(:,isurf) = (/iup_l,k,j,i,m/) 4706 5401 ENDDO 4707 5402 4708 5403 ENDDO 4709 5404 ENDDO 4710 5405 4711 5406 !-- add vertical surface elements (land and urban surfaces) 4712 !-- TODO: remove the hard coding of l = 0 to l = idirection 5407 !-- TODO: remove the hard coding of l = 0 to l = idirection 4713 5408 DO i = nxl, nxr 4714 5409 DO j = nys, nyn … … 4771 5466 ENDDO 4772 5467 4773 !-- add sky 4774 DO i = nxl, nxr 4775 DO j = nys, nyn 4776 isurf = isurf + 1 4777 k = nzut 4778 surfl(:,isurf) = (/isky,k,j,i,-1/) 4779 ENDDO 4780 ENDDO 4781 4782 !-- calulation of the free borders of the domain 4783 DO ids = inorth_b,iwest_b 4784 IF ( isborder(ids) ) THEN 4785 !-- free border of the domain in direction ids 4786 DO i = ijdb(1,ids), ijdb(2,ids) 4787 DO j = ijdb(3,ids), ijdb(4,ids) 4788 k_topo = get_topography_top_index_ji( j, i, 's' ) 4789 k_topo2 = get_topography_top_index_ji( j-jdir(ids), i-idir(ids), 's' ) 4790 4791 DO k = MAX(k_topo,k_topo2)+1, nzut 4792 isurf = isurf + 1 4793 surfl(:,isurf) = (/ids,k,j,i,-1/) 4794 ENDDO 4795 ENDDO 4796 ENDDO 4797 ENDIF 4798 ENDDO 4799 4800 !-- adding the atmospheric virtual surfaces 4801 IF ( atm_surfaces ) THEN 4802 !-- TODO: use flags to identfy atmospheric cells and its coresponding surfaces 4803 !-- add horizontal surface 4804 DO i = nxl, nxr 4805 DO j = nys, nyn 4806 k_topo = get_topography_top_index_ji( j, i, 's' ) 4807 4808 !-- add upward surface 4809 DO k = (k_topo+1), nzut-1 4810 isurf = isurf + 1 4811 surfl(:,isurf) = (/iup_a,k+1,j,i,-1/) 4812 ENDDO 4813 4814 !-- add downward surface 4815 DO k = (k_topo+1), nzut-1 4816 isurf = isurf + 1 4817 surfl(:,isurf) = (/idown_a,k,j,i,-1/) 4818 ENDDO 4819 ENDDO 4820 ENDDO 4821 4822 !-- add vertical surfaces 4823 DO i = nxl, nxr 4824 DO j = nys, nyn 4825 k_topo = get_topography_top_index_ji( j, i, 's' ) 4826 !-- north 4827 IF ( j /= ny ) THEN 4828 ids = inorth_a 4829 jr = min(max(j-jdir(ids),0),ny) 4830 ir = min(max(i-idir(ids),0),nx) 4831 k_topo2 = get_topography_top_index_ji( jr, ir, 's' ) 4832 DO k = MAX(k_topo,k_topo2)+1, nzut 4833 isurf = isurf + 1 4834 surfl(:,isurf) = (/inorth_a,k,j,i,-1/) 4835 ENDDO 4836 END IF 4837 !-- south 4838 IF ( j /= 0 ) THEN 4839 ids = isouth_a 4840 jr = min(max(j-jdir(ids),0),ny) 4841 ir = min(max(i-idir(ids),0),nx) 4842 k_topo2 = get_topography_top_index_ji( jr, ir, 's' ) 4843 4844 DO k = MAX(k_topo,k_topo2)+1, nzut 4845 isurf = isurf + 1 4846 surfl(:,isurf) = (/isouth_a,k,j,i,-1/) 4847 ENDDO 4848 END IF 4849 !-- east 4850 IF ( i /= nx ) THEN 4851 ids = ieast_a 4852 jr = min(max(j-jdir(ids),0),ny) 4853 ir = min(max(i-idir(ids),0),nx) 4854 k_topo2 = get_topography_top_index_ji( jr, ir, 's' ) 4855 4856 DO k = MAX(k_topo,k_topo2)+1, nzut 4857 isurf = isurf + 1 4858 surfl(:,isurf) = (/ieast_a,k,j,i,-1/) 4859 ENDDO 4860 END IF 4861 !-- west 4862 IF ( i /= 0 ) THEN 4863 ids = iwest_a 4864 jr = min(max(j-jdir(ids),0),ny) 4865 ir = min(max(i-idir(ids),0),nx) 4866 k_topo2 = get_topography_top_index_ji( jr, ir, 's' ) 4867 4868 DO k = MAX(k_topo,k_topo2)+1, nzut 4869 isurf = isurf + 1 4870 surfl(:,isurf) = (/iwest_a,k,j,i,-1/) 4871 ENDDO 4872 END IF 4873 ENDDO 4874 ENDDO 4875 4876 ENDIF 4877 4878 ! 4879 !-- broadband albedo of the land, roof and wall surface 4880 !-- for domain border and sky set artifically to 1.0 4881 !-- what allows us to calculate heat flux leaving over 4882 !-- side and top borders of the domain 4883 ALLOCATE ( albedo_surf(nsurfl) ) 4884 albedo_surf = 1.0_wp 4885 ! 4886 !-- Also allocate further array for emissivity with identical order of 4887 !-- surface elements as radiation arrays. 4888 !-- MS: Why startenergy:endenergy and albedo surf from 1:nsurfl ? 4889 ALLOCATE ( emiss_surf(startenergy:endenergy) ) 5468 ! 5469 !-- broadband albedo of the land, roof and wall surface 5470 !-- for domain border and sky set artifically to 1.0 5471 !-- what allows us to calculate heat flux leaving over 5472 !-- side and top borders of the domain 5473 ALLOCATE ( albedo_surf(nsurfl) ) 5474 albedo_surf = 1.0_wp 5475 ! 5476 !-- Also allocate further array for emissivity with identical order of 5477 !-- surface elements as radiation arrays. 5478 ALLOCATE ( emiss_surf(nsurfl) ) 4890 5479 4891 5480 … … 4893 5482 !-- global array surf of indices of surfaces and displacement index array surfstart 4894 5483 ALLOCATE(nsurfs(0:numprocs-1)) 4895 5484 4896 5485 #if defined( __parallel ) 4897 5486 CALL MPI_Allgather(nsurfl,1,MPI_INTEGER,nsurfs,1,MPI_INTEGER,comm2d,ierr) … … 4908 5497 nsurf = k 4909 5498 ALLOCATE(surf(5,nsurf)) 4910 5499 4911 5500 #if defined( __parallel ) 4912 CALL MPI_AllGatherv(surfl, nsurfl*5, MPI_INTEGER, surf, nsurfs*5, surfstart*5, MPI_INTEGER, comm2d, ierr) 5501 CALL MPI_AllGatherv(surfl, nsurfl*5, MPI_INTEGER, surf, nsurfs*5, & 5502 surfstart(0:numprocs-1)*5, MPI_INTEGER, comm2d, ierr) 4913 5503 #else 4914 5504 surf = surfl … … 4920 5510 !-- rad_sw_in, rad_lw_in are computed in radiation model, 4921 5511 !-- splitting of direct and diffusion part is done 4922 !-- in usm_calc_diffusion_radiation for now5512 !-- in calc_diffusion_radiation for now 4923 5513 4924 5514 ALLOCATE( rad_sw_in_dir(nysg:nyng,nxlg:nxrg) ) … … 4927 5517 rad_sw_in_dir = 0.0_wp 4928 5518 rad_sw_in_diff = 0.0_wp 4929 rad_lw_in_diff = 0.0_wp 4930 5519 rad_lw_in_diff = 0.0_wp 5520 4931 5521 !-- allocate radiation arrays 4932 5522 ALLOCATE( surfins(nsurfl) ) … … 4937 5527 ALLOCATE( surfinswdif(nsurfl) ) 4938 5528 ALLOCATE( surfinlwdif(nsurfl) ) 4939 ALLOCATE( surfoutsl(startenergy:endenergy) ) 4940 ALLOCATE( surfoutll(startenergy:endenergy) ) 4941 ALLOCATE( surfoutsw(startenergy:endenergy) ) 4942 ALLOCATE( surfoutlw(startenergy:endenergy) ) 4943 ALLOCATE( surfouts(nsurf) ) !TODO: global surfaces without virtual 4944 ALLOCATE( surfoutl(nsurf) ) !TODO: global surfaces without virtual 4945 4946 ! 4947 !-- @Mohamed 5529 ALLOCATE( surfoutsl(nsurfl) ) 5530 ALLOCATE( surfoutll(nsurfl) ) 5531 ALLOCATE( surfoutsw(nsurfl) ) 5532 ALLOCATE( surfoutlw(nsurfl) ) 5533 ALLOCATE( surfouts(nsurf) ) 5534 ALLOCATE( surfoutl(nsurf) ) 5535 ALLOCATE( skyvf(nsurfl) ) 5536 ALLOCATE( skyvft(nsurfl) ) 5537 5538 ! 4948 5539 !-- In case of average_radiation, aggregated surface albedo and emissivity, 4949 !-- also set initial value oft_rad_urb.4950 !-- For the moment set an arbitrary initial value.5540 !-- also set initial value for t_rad_urb. 5541 !-- For now set an arbitrary initial value. 4951 5542 IF ( average_radiation ) THEN 4952 5543 albedo_urb = 0.5_wp 4953 5544 emissivity_urb = 0.5_wp 4954 t_rad_urb = pt_surface 4955 ENDIF 5545 t_rad_urb = pt_surface 5546 ENDIF 4956 5547 4957 5548 END SUBROUTINE radiation_interaction_init 5549 4958 5550 !------------------------------------------------------------------------------! 4959 5551 ! Description: 4960 5552 ! ------------ 4961 !> This subroutine calculates interaction of the solar radiation 4962 !> with urban and land surfaces and updates all surface heatfluxes, including 4963 !> the vertual atmospheric cell faces. It calculates also the required parameters 4964 !> for RRTMG lower BC. 4965 !> 4966 !> For more info. see Resler et al. 2017 4967 !> 5553 !> Calculates shape view factors (SVF), plant sink canopy factors (PCSF), 5554 !> sky-view factors, discretized path for direct solar radiation, MRT factors 5555 !> and other preprocessed data needed for radiation_interaction. 4968 5556 !------------------------------------------------------------------------------! 4969 SUBROUTINE radiation_interaction 4970 4971 4972 USE control_parameters 4973 4974 USE plant_canopy_model_mod, & 4975 ONLY: prototype_lad 5557 SUBROUTINE radiation_calc_svf 4976 5558 4977 5559 IMPLICIT NONE 4978 4979 INTEGER(iwp) :: i, j, k, kk, is, js, d, ku, refstep, m, mm, l, ll4980 INTEGER(iwp) :: ii, jj !< running indices4981 INTEGER(iwp) :: nzubl, nzutl, isurf, isurfsrc, isurf1, isvf, icsf, ipcgb4982 INTEGER(iwp), DIMENSION(4) :: bdycross4983 REAL(wp), DIMENSION(3,3) :: mrot !< grid rotation matrix (xyz)4984 REAL(wp), DIMENSION(3,0:nsurf_type) :: vnorm !< face direction normal vectors (xyz)4985 REAL(wp), DIMENSION(3) :: sunorig !< grid rotated solar direction unit vector (xyz)4986 REAL(wp), DIMENSION(3) :: sunorig_grid !< grid squashed solar direction unit vector (zyx)4987 REAL(wp), DIMENSION(0:nsurf_type) :: costheta !< direct irradiance factor of solar angle4988 REAL(wp), DIMENSION(nzub:nzut) :: pchf_prep !< precalculated factor for canopy temp tendency4989 REAL(wp), PARAMETER :: alpha = 0._wp !< grid rotation (TODO: add to namelist or remove)4990 REAL(wp) :: rx, ry, rz4991 REAL(wp) :: pc_box_area, pc_abs_frac, pc_abs_eff4992 INTEGER(iwp) :: pc_box_dimshift !< transform for best accuracy4993 INTEGER(iwp), DIMENSION(0:3) :: reorder = (/ 1, 0, 3, 2 /)4994 REAL(wp), DIMENSION(0:nsurf_type) :: facearea4995 REAL(wp) :: pabsswl = 0.0_wp !< total absorbed SW radiation energy in local processor (W)4996 REAL(wp) :: pabssw = 0.0_wp !< total absorbed SW radiation energy in all processors (W)4997 REAL(wp) :: pabslwl = 0.0_wp !< total absorbed LW radiation energy in local processor (W)4998 REAL(wp) :: pabslw = 0.0_wp !< total absorbed LW radiation energy in all processors (W)4999 REAL(wp) :: pemitlwl = 0.0_wp !< total emitted LW radiation energy in all processors (W)5000 REAL(wp) :: pemitlw = 0.0_wp !< total emitted LW radiation energy in all processors (W)5001 REAL(wp) :: pinswl = 0.0_wp !< total received SW radiation energy in local processor (W)5002 REAL(wp) :: pinsw = 0.0_wp !< total received SW radiation energy in all processor (W)5003 REAL(wp) :: pinlwl = 0.0_wp !< total received LW radiation energy in local processor (W)5004 REAL(wp) :: pinlw = 0.0_wp !< total received LW radiation energy in all processor (W)5005 REAL(wp) :: emiss_sum_surfl !< sum of emissisivity of surfaces in local processor5006 REAL(wp) :: emiss_sum_surf !< sum of emissisivity of surfaces in all processor5007 REAL(wp) :: area_surfl !< total area of surfaces in local processor5008 REAL(wp) :: area_surf !< total area of surfaces in all processor5009 5560 5010 IF ( plant_canopy ) THEN 5011 pchf_prep(:) = r_d * (hyp(nzub:nzut) / 100000.0_wp)**0.286_wp & 5012 / (cp * hyp(nzub:nzut) * dx*dy*dz) !< equals to 1 / (rho * c_p * Vbox * T) 5013 ENDIF 5014 5015 sun_direction = .TRUE. 5016 CALL calc_zenith !< required also for diffusion radiation 5017 5018 !-- prepare rotated normal vectors and irradiance factor 5019 vnorm(1,:) = idir(:) 5020 vnorm(2,:) = jdir(:) 5021 vnorm(3,:) = kdir(:) 5022 mrot(1, :) = (/ cos(alpha), -sin(alpha), 0._wp /) 5023 mrot(2, :) = (/ sin(alpha), cos(alpha), 0._wp /) 5024 mrot(3, :) = (/ 0._wp, 0._wp, 1._wp /) 5025 sunorig = (/ sun_dir_lon, sun_dir_lat, zenith(0) /) 5026 sunorig = matmul(mrot, sunorig) 5027 DO d = 0, nsurf_type 5028 costheta(d) = dot_product(sunorig, vnorm(:,d)) 5029 ENDDO 5030 5031 IF ( zenith(0) > 0 ) THEN 5032 !-- now we will "squash" the sunorig vector by grid box size in 5033 !-- each dimension, so that this new direction vector will allow us 5034 !-- to traverse the ray path within grid coordinates directly 5035 sunorig_grid = (/ sunorig(3)/dz, sunorig(2)/dy, sunorig(1)/dx /) 5036 !-- sunorig_grid = sunorig_grid / norm2(sunorig_grid) 5037 sunorig_grid = sunorig_grid / SQRT(SUM(sunorig_grid**2)) 5038 5039 IF ( plant_canopy ) THEN 5040 !-- precompute effective box depth with prototype Leaf Area Density 5041 pc_box_dimshift = maxloc(sunorig, 1) - 1 5042 CALL box_absorb(cshift((/dx,dy,dz/), pc_box_dimshift), & 5043 60, prototype_lad, & 5044 cshift(sunorig, pc_box_dimshift), & 5045 pc_box_area, pc_abs_frac) 5046 pc_box_area = pc_box_area * sunorig(pc_box_dimshift+1) / sunorig(3) 5047 pc_abs_eff = log(1._wp - pc_abs_frac) / prototype_lad 5048 ENDIF 5049 ENDIF 5050 5051 !-- split diffusion and direct part of the solar downward radiation 5052 !-- comming from radiation model and store it in 2D arrays 5053 !-- rad_sw_in_diff, rad_sw_in_dir and rad_lw_in_diff 5054 IF ( split_diffusion_radiation ) THEN 5055 CALL calc_diffusion_radiation 5056 ELSE 5057 DO i = nxl, nxr 5058 DO j = nys, nyn 5059 DO m = surf_def_h(0)%start_index(j,i), & 5060 surf_def_h(0)%end_index(j,i) 5061 rad_sw_in_diff(j,i) = 0.0_wp 5062 rad_sw_in_dir(j,i) = surf_def_h(0)%rad_sw_in(m) 5063 rad_lw_in_diff(j,i) = surf_def_h(0)%rad_lw_in(m) 5064 ENDDO 5065 DO m = surf_lsm_h%start_index(j,i), & 5066 surf_lsm_h%end_index(j,i) 5067 rad_sw_in_diff(j,i) = 0.0_wp 5068 rad_sw_in_dir(j,i) = surf_lsm_h%rad_sw_in(m) 5069 rad_lw_in_diff(j,i) = surf_lsm_h%rad_lw_in(m) 5070 ENDDO 5071 DO m = surf_usm_h%start_index(j,i), & 5072 surf_usm_h%end_index(j,i) 5073 rad_sw_in_diff(j,i) = 0.0_wp 5074 rad_sw_in_dir(j,i) = surf_usm_h%rad_sw_in(m) 5075 rad_lw_in_diff(j,i) = surf_usm_h%rad_lw_in(m) 5076 ENDDO 5077 ENDDO 5078 ENDDO 5079 ENDIF 5080 5081 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 5082 !-- First pass: direct + diffuse irradiance 5083 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 5084 surfinswdir = 0._wp !nsurfl 5085 surfinswdif = 0._wp !nsurfl 5086 surfinlwdif = 0._wp !nsurfl 5087 surfins = 0._wp !nsurfl 5088 surfinl = 0._wp !nsurfl 5089 surfoutsl(:) = 0.0_wp !start-end 5090 surfoutll(:) = 0.0_wp !start-end 5091 5092 !-- Set up thermal radiation from surfaces 5093 !-- emiss_surf is defined only for surfaces for which energy balance is calculated 5094 !-- Workaround: reorder surface data type back on 1D array including all surfaces, 5095 !-- which implies to reorder horizontal and vertical surfaces 5096 ! 5097 !-- Horizontal walls 5098 mm = 1 5099 DO i = nxl, nxr 5100 DO j = nys, nyn 5101 !-- urban 5102 DO m = surf_usm_h%start_index(j,i), surf_usm_h%end_index(j,i) 5103 surfoutll(mm) = SUM ( surf_usm_h%frac(:,m) * & 5104 surf_usm_h%emissivity(:,m) ) & 5105 * sigma_sb & 5106 * surf_usm_h%pt_surface(m)**4 5107 albedo_surf(mm) = SUM ( surf_usm_h%frac(:,m) * & 5108 surf_usm_h%albedo(:,m) ) 5109 emiss_surf(mm) = SUM ( surf_usm_h%frac(:,m) * & 5110 surf_usm_h%emissivity(:,m) ) 5111 mm = mm + 1 5112 ENDDO 5113 !-- land 5114 DO m = surf_lsm_h%start_index(j,i), surf_lsm_h%end_index(j,i) 5115 surfoutll(mm) = SUM ( surf_lsm_h%frac(:,m) * & 5116 surf_lsm_h%emissivity(:,m) ) & 5117 * sigma_sb & 5118 * surf_lsm_h%pt_surface(m)**4 5119 albedo_surf(mm) = SUM ( surf_lsm_h%frac(:,m) * & 5120 surf_lsm_h%albedo(:,m) ) 5121 emiss_surf(mm) = SUM ( surf_lsm_h%frac(:,m) * & 5122 surf_lsm_h%emissivity(:,m) ) 5123 mm = mm + 1 5124 ENDDO 5125 ENDDO 5126 ENDDO 5127 ! 5128 !-- Vertical walls 5129 DO i = nxl, nxr 5130 DO j = nys, nyn 5131 DO ll = 0, 3 5132 l = reorder(ll) 5133 !-- urban 5134 DO m = surf_usm_v(l)%start_index(j,i), & 5135 surf_usm_v(l)%end_index(j,i) 5136 surfoutll(mm) = SUM ( surf_usm_v(l)%frac(:,m) * & 5137 surf_usm_v(l)%emissivity(:,m) ) & 5138 * sigma_sb & 5139 * surf_usm_v(l)%pt_surface(m)**4 5140 albedo_surf(mm) = SUM ( surf_usm_v(l)%frac(:,m) * & 5141 surf_usm_v(l)%albedo(:,m) ) 5142 emiss_surf(mm) = SUM ( surf_usm_v(l)%frac(:,m) * & 5143 surf_usm_v(l)%emissivity(:,m) ) 5144 mm = mm + 1 5145 ENDDO 5146 !-- land 5147 DO m = surf_lsm_v(l)%start_index(j,i), & 5148 surf_lsm_v(l)%end_index(j,i) 5149 surfoutll(mm) = SUM ( surf_lsm_v(l)%frac(:,m) * & 5150 surf_lsm_v(l)%emissivity(:,m) ) & 5151 * sigma_sb & 5152 * surf_lsm_v(l)%pt_surface(m)**4 5153 albedo_surf(mm) = SUM ( surf_lsm_v(l)%frac(:,m) * & 5154 surf_lsm_v(l)%albedo(:,m) ) 5155 emiss_surf(mm) = SUM ( surf_lsm_v(l)%frac(:,m) * & 5156 surf_lsm_v(l)%emissivity(:,m) ) 5157 mm = mm + 1 5158 ENDDO 5159 ENDDO 5160 ENDDO 5161 ENDDO 5162 5561 INTEGER(iwp) :: i, j, k, l, d, ip, jp 5562 INTEGER(iwp) :: isvf, ksvf, icsf, kcsf, npcsfl, isvf_surflt, imrtt, imrtf, ipcgb 5563 INTEGER(iwp) :: sd, td, ioln, iproc 5564 INTEGER(iwp) :: iaz, izn !< azimuth, zenith counters 5565 INTEGER(iwp) :: naz, nzn !< azimuth, zenith num of steps 5566 REAL(wp) :: az0, zn0 !< starting azimuth/zenith 5567 REAL(wp) :: azs, zns !< azimuth/zenith cycle step 5568 REAL(wp) :: az1, az2 !< relative azimuth of section borders 5569 REAL(wp) :: azmid !< ray (center) azimuth 5570 REAL(wp) :: horizon !< computed horizon height (tangent of elevation) 5571 REAL(wp) :: azen !< zenith angle 5572 REAL(wp), DIMENSION(:), ALLOCATABLE :: zdirs !< directions in z (tangent of elevation) 5573 REAL(wp), DIMENSION(:), ALLOCATABLE :: zbdry !< zenith angle boundaries 5574 REAL(wp), DIMENSION(:), ALLOCATABLE :: vffrac !< view factor fractions for individual rays 5575 REAL(wp), DIMENSION(:), ALLOCATABLE :: ztransp !< array of transparency in z steps 5576 REAL(wp), DIMENSION(0:nsurf_type) :: facearea 5577 INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE :: nzterrl 5578 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: csflt, pcsflt 5579 INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE :: kcsflt,kpcsflt 5580 INTEGER(iwp), DIMENSION(:), ALLOCATABLE :: icsflt,dcsflt,ipcsflt,dpcsflt 5581 REAL(wp), DIMENSION(3) :: uv 5582 LOGICAL :: visible 5583 REAL(wp), DIMENSION(3) :: sa, ta !< real coordinates z,y,x of source and target 5584 REAL(wp) :: transparency, rirrf, sqdist, svfsum 5585 INTEGER(iwp) :: isurflt, isurfs, isurflt_prev 5586 INTEGER(iwp) :: itx, ity, itz 5587 INTEGER(idp) :: ray_skip_maxdist, ray_skip_minval !< skipped raytracing counts 5588 INTEGER(iwp) :: max_track_len !< maximum 2d track length 5589 CHARACTER(len=7) :: pid_char = '' 5590 INTEGER(iwp) :: win_lad, minfo 5591 REAL(wp), DIMENSION(:,:,:), POINTER :: lad_s_rma !< fortran pointer, but lower bounds are 1 5592 TYPE(c_ptr) :: lad_s_rma_p !< allocated c pointer 5163 5593 #if defined( __parallel ) 5164 !-- might be optimized and gather only values relevant for current processor 5165 5166 CALL MPI_AllGatherv(surfoutll, nenergy, MPI_REAL, & 5167 surfoutl, nsurfs, surfstart, MPI_REAL, comm2d, ierr) !nsurf global 5168 #else 5169 surfoutl(:) = surfoutll(:) !nsurf global 5594 INTEGER(kind=MPI_ADDRESS_KIND) :: size_lad_rma 5170 5595 #endif 5171 5172 isurf1 = -1 !< previous processed surface5173 DO isvf = 1, nsvfl5174 isurf = svfsurf(1, isvf)5175 k = surfl(iz, isurf)5176 j = surfl(iy, isurf)5177 i = surfl(ix, isurf)5178 isurfsrc = svfsurf(2, isvf)5179 IF ( zenith(0) > 0 .AND. isurf /= isurf1 ) THEN5180 !-- locate the virtual surface where the direct solar ray crosses domain boundary5181 !-- (once per target surface)5182 d = surfl(id, isurf)5183 rz = REAL(k, wp) - 0.5_wp * kdir(d)5184 ry = REAL(j, wp) - 0.5_wp * jdir(d)5185 rx = REAL(i, wp) - 0.5_wp * idir(d)5186 5187 CALL find_boundary_face( (/ rz, ry, rx /), sunorig_grid, bdycross)5188 5189 isurf1 = isurf5190 ENDIF5191 5192 IF ( surf(id, isurfsrc) >= isky ) THEN5193 !-- diffuse rad from boundary surfaces. Since it is a simply5194 !-- calculated value, it is not assigned to surfref(s/l),5195 !-- instead it is used directly here5196 !-- we consider the radiation from the radiation model falling on surface5197 !-- as the radiation falling on the top of urban layer into the place of the source surface5198 !-- we consider it as a very reasonable simplification which allow as avoid5199 !-- necessity of other global range arrays and some all to all mpi communication5200 surfinswdif(isurf) = surfinswdif(isurf) + rad_sw_in_diff(j,i) * svf(1,isvf) * svf(2,isvf)5201 !< canopy shading is applied only to shortwave5202 surfinlwdif(isurf) = surfinlwdif(isurf) + rad_lw_in_diff(j,i) * svf(1,isvf)5203 ELSE5204 !-- for surface-to-surface factors we calculate thermal radiation in 1st pass5205 surfinl(isurf) = surfinl(isurf) + svf(1,isvf) * surfoutl(isurfsrc)5206 ENDIF5207 5208 IF ( zenith(0) > 0 .AND. all( surf(1:4,isurfsrc) == bdycross ) ) THEN5209 !-- found svf between model boundary and the face => face isn't shaded5210 surfinswdir(isurf) = rad_sw_in_dir(j,i) &5211 * costheta(surfl(id, isurf)) * svf(2,isvf) / zenith(0)5212 5213 ENDIF5214 ENDDO5215 5216 IF ( plant_canopy ) THEN5217 5218 pcbinsw(:) = 0._wp5219 pcbinlw(:) = 0._wp !< will stay always 0 since we don't absorb lw anymore5220 !5221 !-- pcsf first pass5222 isurf1 = -1 !< previous processed pcgb5223 DO icsf = 1, ncsfl5224 ipcgb = csfsurf(1, icsf)5225 i = pcbl(ix,ipcgb)5226 j = pcbl(iy,ipcgb)5227 k = pcbl(iz,ipcgb)5228 isurfsrc = csfsurf(2, icsf)5229 5230 IF ( zenith(0) > 0 .AND. ipcgb /= isurf1 ) THEN5231 !-- locate the virtual surface where the direct solar ray crosses domain boundary5232 !-- (once per target PC gridbox)5233 rz = REAL(k, wp)5234 ry = REAL(j, wp)5235 rx = REAL(i, wp)5236 CALL find_boundary_face( (/ rz, ry, rx /), &5237 sunorig_grid, bdycross)5238 5239 isurf1 = ipcgb5240 ENDIF5241 5242 IF ( surf(id, isurfsrc) >= isky ) THEN5243 !-- Diffuse rad from boundary surfaces. See comments for svf above.5244 pcbinsw(ipcgb) = pcbinsw(ipcgb) + csf(1,icsf) * csf(2,icsf) * rad_sw_in_diff(j,i)5245 !-- canopy shading is applied only to shortwave, therefore no absorbtion for lw5246 !-- pcbinlw(ipcgb) = pcbinlw(ipcgb) + svf(1,isvf) * rad_lw_in_diff(j,i)5247 !ELSE5248 !-- Thermal radiation in 1st pass5249 !-- pcbinlw(ipcgb) = pcbinlw(ipcgb) + svf(1,isvf) * surfoutl(isurfsrc)5250 ENDIF5251 5252 IF ( zenith(0) > 0 .AND. ALL( surf(1:4,isurfsrc) == bdycross ) ) THEN5253 !-- found svf between model boundary and the pcgb => pcgb isn't shaded5254 pc_abs_frac = 1._wp - EXP(pc_abs_eff * lad_s(k,j,i))5255 pcbinsw(ipcgb) = pcbinsw(ipcgb) &5256 + rad_sw_in_dir(j, i) * pc_box_area * csf(2,icsf) * pc_abs_frac5257 ENDIF5258 ENDDO5259 ENDIF5260 5261 surfins(startenergy:endenergy) = surfinswdir(startenergy:endenergy) + surfinswdif(startenergy:endenergy)5262 surfinl(startenergy:endenergy) = surfinl(startenergy:endenergy) + surfinlwdif(startenergy:endenergy)5263 surfinsw(:) = surfins(:)5264 surfinlw(:) = surfinl(:)5265 surfoutsw(:) = 0.0_wp5266 surfoutlw(:) = surfoutll(:)5267 ! surfhf(startenergy:endenergy) = surfinsw(startenergy:endenergy) + surfinlw(startenergy:endenergy) &5268 ! - surfoutsw(startenergy:endenergy) - surfoutlw(startenergy:endenergy)5269 5270 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!5271 !-- Next passes - reflections5272 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!5273 DO refstep = 1, nrefsteps5274 5275 surfoutsl(startenergy:endenergy) = albedo_surf(startenergy:endenergy) * surfins(startenergy:endenergy)5276 !-- for non-transparent surfaces, longwave albedo is 1 - emissivity5277 surfoutll(startenergy:endenergy) = (1._wp - emiss_surf(startenergy:endenergy)) * surfinl(startenergy:endenergy)5278 5279 #if defined( __parallel )5280 CALL MPI_AllGatherv(surfoutsl, nsurfl, MPI_REAL, &5281 surfouts, nsurfs, surfstart, MPI_REAL, comm2d, ierr)5282 CALL MPI_AllGatherv(surfoutll, nsurfl, MPI_REAL, &5283 surfoutl, nsurfs, surfstart, MPI_REAL, comm2d, ierr)5284 #else5285 surfouts(:) = surfoutsl(:)5286 surfoutl(:) = surfoutll(:)5287 #endif5288 5289 !-- reset for next pass input5290 surfins(:) = 0._wp5291 surfinl(:) = 0._wp5292 5293 !-- reflected radiation5294 DO isvf = 1, nsvfl5295 isurf = svfsurf(1, isvf)5296 isurfsrc = svfsurf(2, isvf)5297 5298 !-- TODO: to remove if, use start+end for isvf5299 IF ( surf(id, isurfsrc) < isky ) THEN5300 surfins(isurf) = surfins(isurf) + svf(1,isvf) * svf(2,isvf) * surfouts(isurfsrc)5301 surfinl(isurf) = surfinl(isurf) + svf(1,isvf) * surfoutl(isurfsrc)5302 ENDIF5303 ENDDO5304 5305 !-- radiation absorbed by plant canopy5306 DO icsf = 1, ncsfl5307 ipcgb = csfsurf(1, icsf)5308 isurfsrc = csfsurf(2, icsf)5309 5310 IF ( surf(id, isurfsrc) < isky ) THEN5311 pcbinsw(ipcgb) = pcbinsw(ipcgb) + csf(1,icsf) * csf(2,icsf) * surfouts(isurfsrc)5312 !-- pcbinlw(ipcgb) = pcbinlw(ipcgb) + csf(1,icsf) * surfoutl(isurfsrc)5313 ENDIF5314 ENDDO5315 5316 surfinsw(:) = surfinsw(:) + surfins(:)5317 surfinlw(:) = surfinlw(:) + surfinl(:)5318 surfoutsw(startenergy:endenergy) = surfoutsw(startenergy:endenergy) + surfoutsl(startenergy:endenergy)5319 surfoutlw(startenergy:endenergy) = surfoutlw(startenergy:endenergy) + surfoutll(startenergy:endenergy)5320 ! surfhf(startenergy:endenergy) = surfinsw(startenergy:endenergy) + surfinlw(startenergy:endenergy) &5321 ! - surfoutsw(startenergy:endenergy) - surfoutlw(startenergy:endenergy)5322 5323 ENDDO5324 5325 !-- push heat flux absorbed by plant canopy to respective 3D arrays5326 IF ( plant_canopy ) THEN5327 pc_heating_rate(:,:,:) = 0._wp5328 DO ipcgb = 1, npcbl5329 j = pcbl(iy, ipcgb)5330 i = pcbl(ix, ipcgb)5331 k = pcbl(iz, ipcgb)5332 !5333 !-- Following expression equals former kk = k - nzb_s_inner(j,i)5334 kk = k - get_topography_top_index_ji( j, i, 's' ) !- lad arrays are defined flat5335 pc_heating_rate(kk, j, i) = (pcbinsw(ipcgb) + pcbinlw(ipcgb)) &5336 * pchf_prep(k) * pt(k, j, i) !-- = dT/dt5337 ENDDO5338 ENDIF5339 !5340 !-- Transfer radiation arrays required for energy balance to the respective data types5341 DO i = startenergy, endenergy5342 m = surfl(5,i)5343 !5344 !-- (1) Urban surfaces5345 !-- upward-facing5346 IF ( surfl(1,i) == iup_u ) THEN5347 surf_usm_h%rad_sw_in(m) = surfinsw(i)5348 surf_usm_h%rad_sw_out(m) = surfoutsw(i)5349 surf_usm_h%rad_lw_in(m) = surfinlw(i)5350 surf_usm_h%rad_lw_out(m) = surfoutlw(i)5351 surf_usm_h%rad_net(m) = surfinsw(i) - surfoutsw(i) + &5352 surfinlw(i) - surfoutlw(i)5353 !5354 !-- northward-facding5355 ELSEIF ( surfl(1,i) == inorth_u ) THEN5356 surf_usm_v(0)%rad_sw_in(m) = surfinsw(i)5357 surf_usm_v(0)%rad_sw_out(m) = surfoutsw(i)5358 surf_usm_v(0)%rad_lw_in(m) = surfinlw(i)5359 surf_usm_v(0)%rad_lw_out(m) = surfoutlw(i)5360 surf_usm_v(0)%rad_net(m) = surfinsw(i) - surfoutsw(i) + &5361 surfinlw(i) - surfoutlw(i)5362 !5363 !-- southward-facding5364 ELSEIF ( surfl(1,i) == isouth_u ) THEN5365 surf_usm_v(1)%rad_sw_in(m) = surfinsw(i)5366 surf_usm_v(1)%rad_sw_out(m) = surfoutsw(i)5367 surf_usm_v(1)%rad_lw_in(m) = surfinlw(i)5368 surf_usm_v(1)%rad_lw_out(m) = surfoutlw(i)5369 surf_usm_v(1)%rad_net(m) = surfinsw(i) - surfoutsw(i) + &5370 surfinlw(i) - surfoutlw(i)5371 !5372 !-- eastward-facing5373 ELSEIF ( surfl(1,i) == ieast_u ) THEN5374 surf_usm_v(2)%rad_sw_in(m) = surfinsw(i)5375 surf_usm_v(2)%rad_sw_out(m) = surfoutsw(i)5376 surf_usm_v(2)%rad_lw_in(m) = surfinlw(i)5377 surf_usm_v(2)%rad_lw_out(m) = surfoutlw(i)5378 surf_usm_v(2)%rad_net(m) = surfinsw(i) - surfoutsw(i) + &5379 surfinlw(i) - surfoutlw(i)5380 !5381 !-- westward-facding5382 ELSEIF ( surfl(1,i) == iwest_u ) THEN5383 surf_usm_v(3)%rad_sw_in(m) = surfinsw(i)5384 surf_usm_v(3)%rad_sw_out(m) = surfoutsw(i)5385 surf_usm_v(3)%rad_lw_in(m) = surfinlw(i)5386 surf_usm_v(3)%rad_lw_out(m) = surfoutlw(i)5387 surf_usm_v(3)%rad_net(m) = surfinsw(i) - surfoutsw(i) + &5388 surfinlw(i) - surfoutlw(i)5389 !5390 !-- (2) land surfaces5391 !-- upward-facing5392 ELSEIF ( surfl(1,i) == iup_l ) THEN5393 surf_lsm_h%rad_sw_in(m) = surfinsw(i)5394 surf_lsm_h%rad_sw_out(m) = surfoutsw(i)5395 surf_lsm_h%rad_lw_in(m) = surfinlw(i)5396 surf_lsm_h%rad_lw_out(m) = surfoutlw(i)5397 surf_lsm_h%rad_net(m) = surfinsw(i) - surfoutsw(i) + &5398 surfinlw(i) - surfoutlw(i)5399 !5400 !-- northward-facding5401 ELSEIF ( surfl(1,i) == inorth_l ) THEN5402 surf_lsm_v(0)%rad_sw_in(m) = surfinsw(i)5403 surf_lsm_v(0)%rad_sw_out(m) = surfoutsw(i)5404 surf_lsm_v(0)%rad_lw_in(m) = surfinlw(i)5405 surf_lsm_v(0)%rad_lw_out(m) = surfoutlw(i)5406 surf_lsm_v(0)%rad_net(m) = surfinsw(i) - surfoutsw(i) + &5407 surfinlw(i) - surfoutlw(i)5408 !5409 !-- southward-facding5410 ELSEIF ( surfl(1,i) == isouth_l ) THEN5411 surf_lsm_v(1)%rad_sw_in(m) = surfinsw(i)5412 surf_lsm_v(1)%rad_sw_out(m) = surfoutsw(i)5413 surf_lsm_v(1)%rad_lw_in(m) = surfinlw(i)5414 surf_lsm_v(1)%rad_lw_out(m) = surfoutlw(i)5415 surf_lsm_v(1)%rad_net(m) = surfinsw(i) - surfoutsw(i) + &5416 surfinlw(i) - surfoutlw(i)5417 !5418 !-- eastward-facing5419 ELSEIF ( surfl(1,i) == ieast_l ) THEN5420 surf_lsm_v(2)%rad_sw_in(m) = surfinsw(i)5421 surf_lsm_v(2)%rad_sw_out(m) = surfoutsw(i)5422 surf_lsm_v(2)%rad_lw_in(m) = surfinlw(i)5423 surf_lsm_v(2)%rad_lw_out(m) = surfoutlw(i)5424 surf_lsm_v(2)%rad_net(m) = surfinsw(i) - surfoutsw(i) + &5425 surfinlw(i) - surfoutlw(i)5426 !5427 !-- westward-facing5428 ELSEIF ( surfl(1,i) == iwest_l ) THEN5429 surf_lsm_v(3)%rad_sw_in(m) = surfinsw(i)5430 surf_lsm_v(3)%rad_sw_out(m) = surfoutsw(i)5431 surf_lsm_v(3)%rad_lw_in(m) = surfinlw(i)5432 surf_lsm_v(3)%rad_lw_out(m) = surfoutlw(i)5433 surf_lsm_v(3)%rad_net(m) = surfinsw(i) - surfoutsw(i) + &5434 surfinlw(i) - surfoutlw(i)5435 ENDIF5436 5437 ENDDO5438 5439 DO m = 1, surf_usm_h%ns5440 surf_usm_h%surfhf(m) = surf_usm_h%rad_sw_in(m) + &5441 surf_usm_h%rad_lw_in(m) - &5442 surf_usm_h%rad_sw_out(m) - &5443 surf_usm_h%rad_lw_out(m)5444 ENDDO5445 DO m = 1, surf_lsm_h%ns5446 surf_lsm_h%surfhf(m) = surf_lsm_h%rad_sw_in(m) + &5447 surf_lsm_h%rad_lw_in(m) - &5448 surf_lsm_h%rad_sw_out(m) - &5449 surf_lsm_h%rad_lw_out(m)5450 ENDDO5451 5452 DO l = 0, 35453 !-- urban5454 DO m = 1, surf_usm_v(l)%ns5455 surf_usm_v(l)%surfhf(m) = surf_usm_v(l)%rad_sw_in(m) + &5456 surf_usm_v(l)%rad_lw_in(m) - &5457 surf_usm_v(l)%rad_sw_out(m) - &5458 surf_usm_v(l)%rad_lw_out(m)5459 ENDDO5460 !-- land5461 DO m = 1, surf_lsm_v(l)%ns5462 surf_lsm_v(l)%surfhf(m) = surf_lsm_v(l)%rad_sw_in(m) + &5463 surf_lsm_v(l)%rad_lw_in(m) - &5464 surf_lsm_v(l)%rad_sw_out(m) - &5465 surf_lsm_v(l)%rad_lw_out(m)5466 5467 ENDDO5468 ENDDO5469 !5470 !-- Calculate the average temperature, albedo, and emissivity for urban/land domain5471 !-- in case of using average_radiation in the respective radiation model5472 IF ( average_radiation ) THEN5473 5474 !--5475 !-- precalculate face areas for different face directions using normal vector5476 !-- TODO: make facearea a globale variable because it is used in more than one subroutine5477 DO d = 0, nsurf_type5478 facearea(d) = 1._wp5479 IF ( idir(d) == 0 ) facearea(d) = facearea(d) * dx5480 IF ( jdir(d) == 0 ) facearea(d) = facearea(d) * dy5481 IF ( kdir(d) == 0 ) facearea(d) = facearea(d) * dz5482 ENDDO5483 !5484 !-- total absorbed SW & LW and emitted LW energy by all physical surfaces (land and urban) in local processor5485 pabsswl = 0._wp5486 pabslwl = 0._wp5487 pemitlwl = 0._wp5488 emiss_sum_surfl = 0._wp5489 area_surfl = 0._wp5490 DO i = startenergy, endenergy5491 d = surfl(id, i)5492 pabsswl = pabsswl + (1._wp - albedo_surf(i)) * surfinsw(i) * facearea(d)5493 pabslwl = pabslwl + emiss_surf(i) * surfinlw(i) * facearea(d)5494 pemitlwl = pemitlwl + surfoutlw(i) * facearea(d)5495 emiss_sum_surfl = emiss_sum_surfl + emiss_surf(i) * facearea(d)5496 area_surfl = area_surfl + facearea(d)5497 END DO5498 !5499 !-- add the absorbed SW energy by plant canopy5500 IF ( plant_canopy ) THEN5501 pabsswl = pabsswl + SUM(pcbinsw)5502 pabslwl = pabslwl + SUM(pcbinlw)5503 ENDIF5504 !5505 !-- gather all absorbed SW energy in all processors5506 #if defined( __parallel )5507 CALL MPI_ALLREDUCE( pabsswl, pabssw, 1, MPI_REAL, MPI_SUM, comm2d, ierr )5508 CALL MPI_ALLREDUCE( pabslwl, pabslw, 1, MPI_REAL, MPI_SUM, comm2d, ierr )5509 CALL MPI_ALLREDUCE( pemitlwl, pemitlw, 1, MPI_REAL, MPI_SUM, comm2d, ierr )5510 CALL MPI_ALLREDUCE( emiss_sum_surfl, emiss_sum_surf, 1, MPI_REAL, MPI_SUM, comm2d, ierr )5511 CALL MPI_ALLREDUCE( area_surfl, area_surf, 1, MPI_REAL, MPI_SUM, comm2d, ierr )5512 #else5513 pabssw = pabsswl5514 pabslwl = pabslw5515 pemitlwl = pemitlw5516 emiss_sum_surf = emiss_sum_surfl5517 area_surf = area_surfl5518 #endif5519 !5520 !-- total received SW energy in local processor !!!!!! cos??!!!!5521 pinswl = 0._wp5522 pinlwl = 0._wp5523 !-- sky5524 DO i = startsky, endsky5525 d = surfl(id, i)5526 ii = surfl(ix, i)5527 jj = surfl(iy, i)5528 pinswl = pinswl + (rad_sw_in_dir(jj,ii) + rad_sw_in_diff(jj,ii)) * facearea(d)5529 pinlwl = pinlwl + rad_lw_in_diff(jj,ii) * facearea(d)5530 ENDDO5531 !-- boundary5532 DO i = startborder, endborder5533 d = surfl(id, i)5534 ii = surfl(ix, i)5535 jj = surfl(iy, i)5536 pinswl = pinswl + (rad_sw_in_dir(jj,ii) + rad_sw_in_diff(jj,ii)) * facearea(d)5537 pinlwl = pinlwl + rad_lw_in_diff(jj,ii) * facearea(d)5538 ENDDO5539 !-- gather all received SW energy in all processors5540 #if defined( __parallel )5541 CALL MPI_ALLREDUCE( pinswl, pinsw, 1, MPI_REAL, MPI_SUM, comm2d, ierr)5542 CALL MPI_ALLREDUCE( pinlwl, pinlw, 1, MPI_REAL, MPI_SUM, comm2d, ierr)5543 #else5544 pinsw = pinswl5545 pinlw = pinlwl5546 #endif5547 !-- (1) albedo5548 IF ( pinsw /= 0.0_wp ) albedo_urb = 1._wp - pabssw / pinsw5549 5550 !-- (2) average emmsivity5551 emissivity_urb = emiss_sum_surf / area_surf5552 5553 !-- (3) temerature5554 t_rad_urb = ((pemitlw - pabslw + emissivity_urb*pinlw)/(emissivity_urb*sigma_sb*area_surf))**0.25_wp5555 5556 ENDIF5557 5558 !-- return surface radiation to horizontal surfaces5559 !-- to rad_sw_in, rad_lw_in and rad_net for outputs5560 !!!!!!!!!!5561 !-- we need the original radiation on urban top layer5562 !-- for calculation of MRT so we can't do adjustment here for now5563 !!!!!!!!!!5564 !!!DO isurf = 1, nsurfl5565 !!! i = surfl(ix,isurf)5566 !!! j = surfl(iy,isurf)5567 !!! k = surfl(iz,isurf)5568 !!! d = surfl(id,isurf)5569 !!! IF ( d==iroof ) THEN5570 !!! rad_sw_in(:,j,i) = surfinsw(isurf)5571 !!! rad_lw_in(:,j,i) = surfinlw(isurf)5572 !!! 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)5573 !!! ENDIF5574 !!!ENDDO5575 5576 CONTAINS5577 5578 !------------------------------------------------------------------------------!5579 ! Description:5580 ! ------------5581 !> This subroutine splits direct and diffusion dw radiation5582 !> It sould not be called in case the radiation model already does it5583 !> It follows <CITATION>5584 !------------------------------------------------------------------------------!5585 SUBROUTINE calc_diffusion_radiation5586 5587 USE date_and_time_mod, &5588 ONLY: day_of_year_init, time_utc_init5589 5590 REAL(wp), PARAMETER :: sol_const = 1367.0_wp !< solar conbstant5591 REAL(wp), PARAMETER :: lowest_solarUp = 0.1_wp !< limit the sun elevation to protect stability of the calculation5592 INTEGER(iwp) :: i, j5593 REAL(wp), PARAMETER :: year_seconds = 86400._wp * 365._wp5594 REAL(wp) :: year_angle !< angle5595 REAL(wp) :: etr !< extraterestrial radiation5596 REAL(wp) :: corrected_solarUp !< corrected solar up radiation5597 REAL(wp) :: horizontalETR !< horizontal extraterestrial radiation5598 REAL(wp) :: clearnessIndex !< clearness index5599 REAL(wp) :: diff_frac !< diffusion fraction of the radiation5600 5601 5602 !-- Calculate current day and time based on the initial values and simulation time5603 year_angle = ((day_of_year_init*86400) &5604 + time_utc_init+time_since_reference_point) &5605 / year_seconds * 2.0_wp * pi5606 5607 etr = sol_const * (1.00011_wp + &5608 0.034221_wp * cos(year_angle) + &5609 0.001280_wp * sin(year_angle) + &5610 0.000719_wp * cos(2.0_wp * year_angle) + &5611 0.000077_wp * sin(2.0_wp * year_angle))5612 5613 !--5614 !-- Under a very low angle, we keep extraterestrial radiation at5615 !-- the last small value, therefore the clearness index will be pushed5616 !-- towards 0 while keeping full continuity.5617 !--5618 IF ( zenith(0) <= lowest_solarUp ) THEN5619 corrected_solarUp = lowest_solarUp5620 ELSE5621 corrected_solarUp = zenith(0)5622 ENDIF5623 5624 horizontalETR = etr * corrected_solarUp5625 5626 DO i = nxl, nxr5627 DO j = nys, nyn5628 5629 DO m = surf_def_h(0)%start_index(j,i), &5630 surf_def_h(0)%end_index(j,i)5631 clearnessIndex = surf_def_h(0)%rad_sw_in(m) / horizontalETR5632 diff_frac = 1.0_wp / &5633 (1.0_wp + exp(-5.0033_wp + 8.6025_wp * clearnessIndex))5634 rad_sw_in_diff(j,i) = surf_def_h(0)%rad_sw_in(m) * diff_frac5635 rad_sw_in_dir(j,i) = surf_def_h(0)%rad_sw_in(m) * &5636 (1.0_wp - diff_frac)5637 rad_lw_in_diff(j,i) = surf_def_h(0)%rad_lw_in(m)5638 ENDDO5639 DO m = surf_lsm_h%start_index(j,i), &5640 surf_lsm_h%end_index(j,i)5641 clearnessIndex = surf_lsm_h%rad_sw_in(m) / horizontalETR5642 diff_frac = 1.0_wp / &5643 (1.0_wp + exp(-5.0033_wp + 8.6025_wp * clearnessIndex))5644 rad_sw_in_diff(j,i) = surf_lsm_h%rad_sw_in(m) * diff_frac5645 rad_sw_in_dir(j,i) = surf_lsm_h%rad_sw_in(m) * &5646 (1.0_wp - diff_frac)5647 rad_lw_in_diff(j,i) = surf_lsm_h%rad_lw_in(m)5648 ENDDO5649 DO m = surf_usm_h%start_index(j,i), &5650 surf_usm_h%end_index(j,i)5651 clearnessIndex = surf_usm_h%rad_sw_in(m) / horizontalETR5652 diff_frac = 1.0_wp / &5653 (1.0_wp + exp(-5.0033_wp + 8.6025_wp * clearnessIndex))5654 rad_sw_in_diff(j,i) = surf_usm_h%rad_sw_in(m) * diff_frac5655 rad_sw_in_dir(j,i) = surf_usm_h%rad_sw_in(m) * &5656 (1.0_wp - diff_frac)5657 rad_lw_in_diff(j,i) = surf_usm_h%rad_lw_in(m)5658 ENDDO5659 ENDDO5660 ENDDO5661 5662 END SUBROUTINE calc_diffusion_radiation5663 5664 !------------------------------------------------------------------------------!5665 !> Finds first model boundary crossed by a ray5666 !------------------------------------------------------------------------------!5667 PURE SUBROUTINE find_boundary_face(origin, uvect, bdycross)5668 5669 IMPLICIT NONE5670 5671 INTEGER(iwp) :: d !<5672 INTEGER(iwp) :: seldim !< found fist crossing index5673 5674 INTEGER(iwp), DIMENSION(3) :: bdyd !< boundary direction5675 INTEGER(iwp), DIMENSION(4), INTENT(out) :: bdycross !< found boundary crossing (d, z, y, x)5676 5677 REAL(wp) :: bdydim !<5678 REAL(wp) :: dist !<5679 5680 REAL(wp), DIMENSION(3) :: crossdist !< crossing distance5681 REAL(wp), DIMENSION(3), INTENT(in) :: origin !< ray origin5682 REAL(wp), DIMENSION(3), INTENT(in) :: uvect !< ray unit vector5683 5684 5685 bdydim = nzut + .5_wp !< top boundary5686 bdyd(1) = isky5687 crossdist(1) = ( bdydim - origin(1) ) / uvect(1) !< subroutine called only when uvect(1)>05688 5689 IF ( uvect(2) == 0._wp ) THEN5690 crossdist(2) = huge(1._wp)5691 ELSE5692 IF ( uvect(2) >= 0._wp ) THEN5693 bdydim = ny + .5_wp !< north global boundary5694 bdyd(2) = inorth_b5695 ELSE5696 bdydim = -.5_wp !< south global boundary5697 bdyd(2) = isouth_b5698 ENDIF5699 crossdist(2) = ( bdydim - origin(2) ) / uvect(2)5700 ENDIF5701 5702 IF ( uvect(3) == 0._wp ) THEN5703 crossdist(3) = huge(1._wp)5704 ELSE5705 IF ( uvect(3) >= 0._wp ) THEN5706 bdydim = nx + .5_wp !< east global boundary5707 bdyd(3) = ieast_b5708 ELSE5709 bdydim = -.5_wp !< west global boundary5710 bdyd(3) = iwest_b5711 ENDIF5712 crossdist(3) = ( bdydim - origin(3) ) / uvect(3)5713 ENDIF5714 5715 seldim = minloc(crossdist, 1)5716 dist = crossdist(seldim)5717 d = bdyd(seldim)5718 5719 bdycross(1) = d5720 bdycross(2:4) = NINT( origin(:) + uvect(:) * dist &5721 + .5_wp * (/ kdir(d), jdir(d), idir(d) /) )5722 5723 END SUBROUTINE find_boundary_face5724 !------------------------------------------------------------------------------!5725 !> Calculates radiation absorbed by box with given size and LAD.5726 !>5727 !> Simulates resol**2 rays (by equally spacing a bounding horizontal square5728 !> conatining all possible rays that would cross the box) and calculates5729 !> average transparency per ray. Returns fraction of absorbed radiation flux5730 !> and area for which this fraction is effective.5731 !------------------------------------------------------------------------------!5732 PURE SUBROUTINE box_absorb(boxsize, resol, dens, uvec, area, absorb)5733 IMPLICIT NONE5734 5735 REAL(wp), DIMENSION(3), INTENT(in) :: &5736 boxsize, & !< z, y, x size of box in m5737 uvec !< z, y, x unit vector of incoming flux5738 INTEGER(iwp), INTENT(in) :: &5739 resol !< No. of rays in x and y dimensions5740 REAL(wp), INTENT(in) :: &5741 dens !< box density (e.g. Leaf Area Density)5742 REAL(wp), INTENT(out) :: &5743 area, & !< horizontal area for flux absorbtion5744 absorb !< fraction of absorbed flux5745 REAL(wp) :: &5746 xshift, yshift, &5747 xmin, xmax, ymin, ymax, &5748 xorig, yorig, &5749 dx1, dy1, dz1, dx2, dy2, dz2, &5750 crdist, &5751 transp5752 INTEGER(iwp) :: &5753 i, j5754 5755 xshift = uvec(3) / uvec(1) * boxsize(1)5756 xmin = min(0._wp, -xshift)5757 xmax = boxsize(3) + max(0._wp, -xshift)5758 yshift = uvec(2) / uvec(1) * boxsize(1)5759 ymin = min(0._wp, -yshift)5760 ymax = boxsize(2) + max(0._wp, -yshift)5761 5762 transp = 0._wp5763 DO i = 1, resol5764 xorig = xmin + (xmax-xmin) * (i-.5_wp) / resol5765 DO j = 1, resol5766 yorig = ymin + (ymax-ymin) * (j-.5_wp) / resol5767 5768 dz1 = 0._wp5769 dz2 = boxsize(1)/uvec(1)5770 5771 IF ( uvec(2) > 0._wp ) THEN5772 dy1 = -yorig / uvec(2) !< crossing with y=05773 dy2 = (boxsize(2)-yorig) / uvec(2) !< crossing with y=boxsize(2)5774 ELSE IF ( uvec(2) < 0._wp ) THEN5775 dy1 = (boxsize(2)-yorig) / uvec(2) !< crossing with y=boxsize(2)5776 dy2 = -yorig / uvec(2) !< crossing with y=05777 ELSE !uvec(2)==05778 dy1 = -huge(1._wp)5779 dy2 = huge(1._wp)5780 ENDIF5781 5782 IF ( uvec(3) > 0._wp ) THEN5783 dx1 = -xorig / uvec(3) !< crossing with x=05784 dx2 = (boxsize(3)-xorig) / uvec(3) !< crossing with x=boxsize(3)5785 ELSE IF ( uvec(3) < 0._wp ) THEN5786 dx1 = (boxsize(3)-xorig) / uvec(3) !< crossing with x=boxsize(3)5787 dx2 = -xorig / uvec(3) !< crossing with x=05788 ELSE !uvec(1)==05789 dx1 = -huge(1._wp)5790 dx2 = huge(1._wp)5791 ENDIF5792 5793 crdist = max(0._wp, (min(dz2, dy2, dx2) - max(dz1, dy1, dx1)))5794 transp = transp + exp(-ext_coef * dens * crdist)5795 ENDDO5796 ENDDO5797 transp = transp / resol**25798 area = (boxsize(3)+xshift)*(boxsize(2)+yshift)5799 absorb = 1._wp - transp5800 5801 END SUBROUTINE box_absorb5802 5803 5804 END SUBROUTINE radiation_interaction5805 5806 5807 !------------------------------------------------------------------------------!5808 ! Description:5809 ! ------------5810 !> Calculates shape view factors SVF and plant sink canopy factors PSCF5811 !> !!!!!DESCRIPTION!!!!!!!!!!5812 !------------------------------------------------------------------------------!5813 SUBROUTINE radiation_calc_svf5814 5815 IMPLICIT NONE5816 5817 INTEGER(iwp) :: i, j, k, l, d, ip, jp5818 INTEGER(iwp) :: isvf, ksvf, icsf, kcsf, npcsfl, isvf_surflt, imrtt, imrtf5819 INTEGER(iwp) :: sd, td, ioln, iproc5820 REAL(wp), DIMENSION(0:nsurf_type) :: facearea5821 INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE :: nzterrl, planthl5822 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: csflt, pcsflt5823 INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE :: kcsflt,kpcsflt5824 INTEGER(iwp), DIMENSION(:), ALLOCATABLE :: icsflt,dcsflt,ipcsflt,dpcsflt5825 REAL(wp), DIMENSION(3) :: uv5826 LOGICAL :: visible5827 REAL(wp), DIMENSION(3) :: sa, ta !< real coordinates z,y,x of source and target5828 REAL(wp) :: transparency, rirrf, sqdist, svfsum5829 INTEGER(iwp) :: isurflt, isurfs, isurflt_prev5830 INTEGER(iwp) :: itx, ity, itz5831 CHARACTER(len=7) :: pid_char = ''5832 INTEGER(iwp) :: win_lad, minfo5833 REAL(wp), DIMENSION(:,:,:), POINTER :: lad_s_rma !< fortran pointer, but lower bounds are 15834 TYPE(c_ptr) :: lad_s_rma_p !< allocated c pointer5835 #if defined( __parallel )5836 INTEGER(kind=MPI_ADDRESS_KIND) :: size_lad_rma5837 #endif5838 REAL(wp), DIMENSION(0:nsurf_type) :: svf_threshold !< threshold to ignore very small svf between far surfaces5839 5840 5596 ! 5597 INTEGER(iwp), DIMENSION(0:svfnorm_report_num) :: svfnorm_counts 5598 CHARACTER(200) :: msg 5599 5841 5600 !-- calculation of the SVF 5842 5601 CALL location_message( ' calculation of SVF and CSF', .TRUE. ) 5843 CALL cpu_log( log_point_s(79), 'radiation_calc_svf', 'start')5844 ! 5602 ! CALL radiation_write_debug_log('Start calculation of SVF and CSF') 5603 5845 5604 !-- precalculate face areas for different face directions using normal vector 5846 5605 DO d = 0, nsurf_type … … 5851 5610 ENDDO 5852 5611 5853 !-- calculate the svf threshold5854 svf_threshold = 0._wp5855 IF ( dist_max_svf > 0._wp ) THEN5856 DO d = 0, nsurf_type5857 sqdist = dist_max_svf * dist_max_svf5858 svf_threshold(d) = 1._wp / (pi * sqdist) * facearea(d)5859 ENDDO5860 ENDIF5861 5862 5612 !-- initialize variables and temporary arrays for calculation of svf and csf 5863 5613 nsvfl = 0 … … 5873 5623 acsf => acsf1 5874 5624 ENDIF 5625 ray_skip_maxdist = 0 5626 ray_skip_minval = 0 5875 5627 5876 5628 !-- initialize temporary terrain and plant canopy height arrays (global 2D array!) … … 5888 5640 ALLOCATE( plantt(0:(nx+1)*(ny+1)-1) ) 5889 5641 maxboxesg = nx + ny + nzu + 1 5642 max_track_len = nx + ny + 1 5890 5643 !-- temporary arrays storing values for csf calculation during raytracing 5891 5644 ALLOCATE( boxes(3, maxboxesg) ) … … 5893 5646 5894 5647 #if defined( __parallel ) 5895 ALLOCATE( planthl(nys:nyn,nxl:nxr) ) 5896 planthl = pch(nys:nyn,nxl:nxr) 5897 5898 CALL MPI_AllGather( planthl, nnx*nny, MPI_INTEGER, & 5648 CALL MPI_AllGather( pct, nnx*nny, MPI_INTEGER, & 5899 5649 plantt, nnx*nny, MPI_INTEGER, comm2d, ierr ) 5900 DEALLOCATE( planthl )5901 5650 5902 5651 !-- temporary arrays storing values for csf calculation during raytracing … … 5904 5653 ALLOCATE( lad_disp(maxboxesg) ) 5905 5654 5906 IF ( usm_lad_rma) THEN5655 IF ( rma_lad_raytrace ) THEN 5907 5656 ALLOCATE( lad_s_ray(maxboxesg) ) 5908 5657 … … 5922 5671 lad_s_rma_p, win_lad, ierr) 5923 5672 CALL c_f_pointer(lad_s_rma_p, lad_s_rma, (/ nzu, nny, nnx /)) 5924 usm_lad(nzub:, nys:, nxl:) => lad_s_rma(:,:,:)5673 sub_lad(nzub:, nys:, nxl:) => lad_s_rma(:,:,:) 5925 5674 ELSE 5926 ALLOCATE( usm_lad(nzub:nzut, nys:nyn, nxl:nxr))5675 ALLOCATE(sub_lad(nzub:nzut, nys:nyn, nxl:nxr)) 5927 5676 ENDIF 5928 5677 #else 5929 5678 plantt = RESHAPE( pct(nys:nyn,nxl:nxr), (/(nx+1)*(ny+1)/) ) 5930 ALLOCATE( usm_lad(nzub:nzut, nys:nyn, nxl:nxr))5679 ALLOCATE(sub_lad(nzub:nzut, nys:nyn, nxl:nxr)) 5931 5680 #endif 5932 usm_lad(:,:,:) = 0._wp 5681 plantt_max = MAXVAL(plantt) 5682 ALLOCATE( rt2_track(2, max_track_len), rt2_track_lad(nzub:plantt_max, max_track_len), & 5683 rt2_track_dist(0:max_track_len), rt2_dist(plantt_max-nzub+2) ) 5684 5685 sub_lad(:,:,:) = 0._wp 5933 5686 DO i = nxl, nxr 5934 5687 DO j = nys, nyn 5935 5688 k = get_topography_top_index_ji( j, i, 's' ) 5936 5689 5937 usm_lad(k:nzut, j, i) = lad_s(0:nzut-k, j, i)5690 sub_lad(k:nzut, j, i) = lad_s(0:nzut-k, j, i) 5938 5691 ENDDO 5939 5692 ENDDO 5940 5693 5941 5694 #if defined( __parallel ) 5942 IF ( usm_lad_rma) THEN5695 IF ( rma_lad_raytrace ) THEN 5943 5696 CALL MPI_Info_free(minfo, ierr) 5944 5697 CALL MPI_Win_lock_all(0, win_lad, ierr) 5945 5698 ELSE 5946 ALLOCATE( usm_lad_g(0:(nx+1)*(ny+1)*nzu-1) )5947 CALL MPI_AllGather( usm_lad, nnx*nny*nzu, MPI_REAL, &5948 usm_lad_g, nnx*nny*nzu, MPI_REAL, comm2d, ierr )5699 ALLOCATE( sub_lad_g(0:(nx+1)*(ny+1)*nzu-1) ) 5700 CALL MPI_AllGather( sub_lad, nnx*nny*nzu, MPI_REAL, & 5701 sub_lad_g, nnx*nny*nzu, MPI_REAL, comm2d, ierr ) 5949 5702 ENDIF 5950 5703 #endif … … 6011 5764 CLOSE(154) 6012 5765 ENDIF !< mrt_factors 6013 5766 5767 !--Directions opposite to face normals are not even calculated, 5768 !--they must be preset to 0 5769 !-- 5770 dsitrans(:,:) = 0._wp 6014 5771 6015 5772 DO isurflt = 1, nsurfl 6016 5773 !-- determine face centers 6017 5774 td = surfl(id, isurflt) 6018 IF ( td >= isky .AND. .NOT. plant_canopy ) CYCLE6019 5775 ta = (/ REAL(surfl(iz, isurflt), wp) - 0.5_wp * kdir(td), & 6020 5776 REAL(surfl(iy, isurflt), wp) - 0.5_wp * jdir(td), & 6021 5777 REAL(surfl(ix, isurflt), wp) - 0.5_wp * idir(td) /) 5778 5779 !--Calculate sky view factor and raytrace DSI paths 5780 skyvf(isurflt) = 0._wp 5781 skyvft(isurflt) = 0._wp 5782 5783 !--Select a proper half-sphere for 2D raytracing 5784 SELECT CASE ( td ) 5785 CASE ( iup_u, iup_l ) 5786 az0 = 0._wp 5787 naz = raytrace_discrete_azims 5788 azs = 2._wp * pi / REAL(naz, wp) 5789 zn0 = 0._wp 5790 nzn = raytrace_discrete_elevs / 2 5791 zns = pi / 2._wp / REAL(nzn, wp) 5792 CASE ( isouth_u, isouth_l ) 5793 az0 = pi / 2._wp 5794 naz = raytrace_discrete_azims / 2 5795 azs = pi / REAL(naz, wp) 5796 zn0 = 0._wp 5797 nzn = raytrace_discrete_elevs 5798 zns = pi / REAL(nzn, wp) 5799 CASE ( inorth_u, inorth_l ) 5800 az0 = - pi / 2._wp 5801 naz = raytrace_discrete_azims / 2 5802 azs = pi / REAL(naz, wp) 5803 zn0 = 0._wp 5804 nzn = raytrace_discrete_elevs 5805 zns = pi / REAL(nzn, wp) 5806 CASE ( iwest_u, iwest_l ) 5807 az0 = pi 5808 naz = raytrace_discrete_azims / 2 5809 azs = pi / REAL(naz, wp) 5810 zn0 = 0._wp 5811 nzn = raytrace_discrete_elevs 5812 zns = pi / REAL(nzn, wp) 5813 CASE ( ieast_u, ieast_l ) 5814 az0 = 0._wp 5815 naz = raytrace_discrete_azims / 2 5816 azs = pi / REAL(naz, wp) 5817 zn0 = 0._wp 5818 nzn = raytrace_discrete_elevs 5819 zns = pi / REAL(nzn, wp) 5820 CASE DEFAULT 5821 WRITE(message_string, *) 'ERROR: the surface type ',td , ' is not supported for calculating SVF' 5822 CALL message( 'radiation_calc_svf', 'PA0XXX', 1, 2, 0, 6, 0 ) 5823 END SELECT 5824 5825 ALLOCATE ( zdirs(1:nzn), zbdry(0:nzn), vffrac(1:nzn), ztransp(1:nzn) ) 5826 zdirs(:) = (/( TAN(pi/2 - (zn0+(REAL(izn,wp)-.5_wp)*zns)), izn=1, nzn )/) 5827 zbdry(:) = (/( zn0+REAL(izn,wp)*zns, izn=0, nzn )/) 5828 IF ( td == iup_u .OR. td == iup_l ) THEN 5829 !-- For horizontal target, vf fractions are constant per azimuth 5830 vffrac(:) = (COS(2 * zbdry(0:nzn-1)) - COS(2 * zbdry(1:nzn))) / 2._wp / REAL(naz, wp) 5831 !--sum of vffrac for all iaz equals 1, verified 5832 ENDIF 5833 5834 !--Calculate sky-view factor and direct solar visibility using 2D raytracing 5835 DO iaz = 1, naz 5836 azmid = az0 + (REAL(iaz, wp) - .5_wp) * azs 5837 IF ( td /= iup_u .AND. td /= iup_l ) THEN 5838 az2 = REAL(iaz, wp) * azs - pi/2._wp 5839 az1 = az2 - azs 5840 !TODO precalculate after 1st line 5841 vffrac(:) = (SIN(az2) - SIN(az1)) & 5842 * (zbdry(1:nzn) - zbdry(0:nzn-1) & 5843 + SIN(zbdry(0:nzn-1))*COS(zbdry(0:nzn-1)) & 5844 - SIN(zbdry(1:nzn))*COS(zbdry(1:nzn))) & 5845 / (2._wp * pi) 5846 !--sum of vffrac for all iaz equals 1, verified 5847 ENDIF 5848 CALL raytrace_2d(ta, (/ COS(azmid), SIN(azmid) /), zdirs, & 5849 surfstart(myid) + isurflt, facearea(td), & 5850 vffrac, .TRUE., .FALSE., win_lad, horizon,& 5851 ztransp) !FIXME unit vect in grid units + zdirs 5852 5853 azen = pi/2 - ATAN(horizon) 5854 IF ( td == iup_u .OR. td == iup_l ) THEN 5855 azen = MIN(azen, pi/2) !only above horizontal direction 5856 skyvf(isurflt) = skyvf(isurflt) + (1._wp - COS(2*azen)) / & 5857 (2._wp * raytrace_discrete_azims) 5858 ELSE 5859 skyvf(isurflt) = skyvf(isurflt) + (SIN(az2) - SIN(az1)) * & 5860 (azen - SIN(azen)*COS(azen)) / (2._wp*pi) 5861 ENDIF 5862 skyvft(isurflt) = skyvft(isurflt) + SUM(ztransp(:) * vffrac(:)) 5863 5864 !--Save direct solar transparency 5865 j = MODULO(NINT(azmid/ & 5866 (2._wp*pi)*raytrace_discrete_azims-.5_wp, iwp), & 5867 raytrace_discrete_azims) 5868 5869 DO k = 1, raytrace_discrete_elevs/2 5870 i = dsidir_rev(k-1, j) 5871 IF ( i /= -1 ) dsitrans(isurflt, i) = ztransp(k) 5872 ENDDO 5873 ENDDO 5874 5875 DEALLOCATE ( zdirs, zbdry, vffrac, ztransp ) 5876 6022 5877 DO isurfs = 1, nsurf 6023 !-- cycle for atmospheric surfaces since they are not source surfaces6024 sd = surf(id, isurfs)6025 IF ( sd > iwest_l .AND. sd < isky ) CYCLE6026 !-- if reflections between target surfaces (urban and land) are neglected (surf_reflection set to6027 !-- FALSE) cycle. This will reduce the number of SVFs and keep SVFs between only ertual surfaces to6028 !-- physical surfaces6029 IF ( .NOT. surf_reflections .AND. sd < isky ) CYCLE6030 !-- cycle if the target and the source surfaces are not facing each other6031 5878 IF ( .NOT. surface_facing(surfl(ix, isurflt), surfl(iy, isurflt), & 6032 5879 surfl(iz, isurflt), surfl(id, isurflt), & … … 6036 5883 ENDIF 6037 5884 5885 sd = surf(id, isurfs) 6038 5886 sa = (/ REAL(surf(iz, isurfs), wp) - 0.5_wp * kdir(sd), & 6039 5887 REAL(surf(iy, isurfs), wp) - 0.5_wp * jdir(sd), & … … 6044 5892 sqdist = SUM(uv(:)**2) 6045 5893 uv = uv / SQRT(sqdist) 5894 5895 !-- reject raytracing above max distance 5896 IF ( SQRT(sqdist) > max_raytracing_dist ) THEN 5897 ray_skip_maxdist = ray_skip_maxdist + 1 5898 CYCLE 5899 ENDIF 6046 5900 6047 5901 !-- irradiance factor (our unshaded shape view factor) = view factor per differential target area * source area … … 6051 5905 * facearea(sd) 6052 5906 6053 !-- skip svf less than svf_threshold 6054 IF ( rirrf < svf_threshold(sd) .AND. sd < isky ) CYCLE 5907 !-- reject raytracing for potentially too small view factor values 5908 IF ( rirrf < min_irrf_value ) THEN 5909 ray_skip_minval = ray_skip_minval + 1 5910 CYCLE 5911 ENDIF 6055 5912 6056 5913 !-- raytrace + process plant canopy sinks within 6057 5914 CALL raytrace(sa, ta, isurfs, rirrf, facearea(td), .TRUE., & 6058 5915 visible, transparency, win_lad) 6059 5916 6060 5917 IF ( .NOT. visible ) CYCLE 6061 IF ( td >= isky ) CYCLE !< we calculated these only for raytracing 6062 !< to find plant canopy sinks, we don't need svf for them 5918 ! rsvf = rirrf * transparency 6063 5919 6064 5920 !-- write to the svf array … … 6080 5936 DEALLOCATE( asvf1 ) 6081 5937 ENDIF 5938 5939 ! WRITE(msg,'(A,3I12)') 'Grow asvf:',nsvfl,nsvfla,k 5940 ! CALL radiation_write_debug_log( msg ) 5941 6082 5942 nsvfla = k 6083 5943 ENDIF … … 6090 5950 ENDDO 6091 5951 5952 !--Raytrace to canopy boxes to fill dsitransc TODO optimize 5953 !-- 5954 dsitransc(:,:) = -999._wp !FIXME 5955 az0 = 0._wp 5956 naz = raytrace_discrete_azims 5957 azs = 2._wp * pi / REAL(naz, wp) 5958 zn0 = 0._wp 5959 nzn = raytrace_discrete_elevs / 2 5960 zns = pi / 2._wp / REAL(nzn, wp) 5961 ALLOCATE ( zdirs(1:nzn), vffrac(1:nzn), ztransp(1:nzn) ) 5962 zdirs(:) = (/( TAN(pi/2 - (zn0+(REAL(izn,wp)-.5_wp)*zns)), izn=1, nzn )/) 5963 vffrac(:) = 0._wp 5964 5965 DO ipcgb = 1, npcbl 5966 ta = (/ REAL(pcbl(iz, ipcgb), wp), & 5967 REAL(pcbl(iy, ipcgb), wp), & 5968 REAL(pcbl(ix, ipcgb), wp) /) 5969 !--Calculate sky-view factor and direct solar visibility using 2D raytracing 5970 DO iaz = 1, naz 5971 azmid = az0 + (REAL(iaz, wp) - .5_wp) * azs 5972 CALL raytrace_2d(ta, (/ COS(azmid), SIN(azmid) /), zdirs, & 5973 -999, -999._wp, vffrac, .FALSE., .TRUE., & 5974 win_lad, horizon, ztransp) !FIXME unit vect in grid units + zdirs 5975 5976 !--Save direct solar transparency 5977 j = MODULO(NINT(azmid/ & 5978 (2._wp*pi)*raytrace_discrete_azims-.5_wp, iwp), & 5979 raytrace_discrete_azims) 5980 DO k = 1, raytrace_discrete_elevs/2 5981 i = dsidir_rev(k-1, j) 5982 IF ( i /= -1 ) dsitransc(ipcgb, i) = ztransp(k) 5983 ENDDO 5984 ENDDO 5985 ENDDO 5986 DEALLOCATE ( zdirs, vffrac, ztransp ) 5987 5988 ! CALL radiation_write_debug_log( 'End of calculation SVF' ) 5989 ! WRITE(msg, *) 'Raytracing skipped for maximum distance of ', & 5990 ! max_raytracing_dist, ' m on ', ray_skip_maxdist, ' pairs.' 5991 ! CALL radiation_write_debug_log( msg ) 5992 ! WRITE(msg, *) 'Raytracing skipped for minimum potential value of ', & 5993 ! min_irrf_value , ' on ', ray_skip_minval, ' pairs.' 5994 ! CALL radiation_write_debug_log( msg ) 5995 6092 5996 CALL location_message( ' waiting for completion of SVF and CSF calculation in all processes', .TRUE. ) 6093 5997 !-- deallocate temporary global arrays … … 6097 6001 !-- finalize mpi_rma communication and deallocate temporary arrays 6098 6002 #if defined( __parallel ) 6099 IF ( usm_lad_rma) THEN6003 IF ( rma_lad_raytrace ) THEN 6100 6004 CALL MPI_Win_flush_all(win_lad, ierr) 6101 6005 !-- unlock MPI window … … 6106 6010 !-- deallocate temporary arrays storing values for csf calculation during raytracing 6107 6011 DEALLOCATE( lad_s_ray ) 6108 !-- usm_lad is the pointer to lad_s_rma in case of usm_lad_rma6012 !-- sub_lad is the pointer to lad_s_rma in case of rma_lad_raytrace 6109 6013 !-- and must not be deallocated here 6110 6014 ELSE 6111 DEALLOCATE( usm_lad)6112 DEALLOCATE( usm_lad_g)6015 DEALLOCATE(sub_lad) 6016 DEALLOCATE(sub_lad_g) 6113 6017 ENDIF 6114 6018 #else 6115 DEALLOCATE( usm_lad)6019 DEALLOCATE(sub_lad) 6116 6020 #endif 6117 6021 DEALLOCATE( boxes ) 6118 6022 DEALLOCATE( crlens ) 6119 6023 DEALLOCATE( plantt ) 6024 DEALLOCATE( rt2_track, rt2_track_lad, rt2_track_dist, rt2_dist ) 6120 6025 ENDIF 6121 6026 6122 6027 CALL location_message( ' calculation of the complete SVF array', .TRUE. ) 6123 6028 6029 ! CALL radiation_write_debug_log( 'Start SVF sort' ) 6124 6030 !-- sort svf ( a version of quicksort ) 6125 6031 CALL quicksort_svf(asvf,1,nsvfl) 6126 6032 6033 !< load svf from the structure array to plain arrays 6034 ! CALL radiation_write_debug_log( 'Load svf from the structure array to plain arrays' ) 6127 6035 ALLOCATE( svf(ndsvf,nsvfl) ) 6128 6036 ALLOCATE( svfsurf(idsvf,nsvfl) ) 6129 6130 !< load svf from the structure array to plain arrays 6037 svfnorm_counts(:) = 0._wp 6131 6038 isurflt_prev = -1 6132 6039 ksvf = 1 … … 6136 6043 IF ( asvf(ksvf)%isurflt /= isurflt_prev ) THEN 6137 6044 IF ( isurflt_prev /= -1 .AND. svfsum /= 0._wp ) THEN 6138 !-- TODO detect and log when normalization differs too much from 1 6139 svf(1, isvf_surflt:isvf-1) = svf(1, isvf_surflt:isvf-1) / svfsum 6045 !< update histogram of logged svf normalization values 6046 i = searchsorted(svfnorm_report_thresh, svfsum / (1._wp-skyvf(isurflt_prev))) 6047 svfnorm_counts(i) = svfnorm_counts(i) + 1 6048 6049 svf(1, isvf_surflt:isvf-1) = svf(1, isvf_surflt:isvf-1) / svfsum * (1._wp-skyvf(isurflt_prev)) 6140 6050 ENDIF 6141 6051 isurflt_prev = asvf(ksvf)%isurflt … … 6154 6064 6155 6065 IF ( isurflt_prev /= -1 .AND. svfsum /= 0._wp ) THEN 6156 !-- TODO detect and log when normalization differs too much from 1 6157 svf(1, isvf_surflt:nsvfl) = svf(1, isvf_surflt:nsvfl) / svfsum 6066 i = searchsorted(svfnorm_report_thresh, svfsum / (1._wp-skyvf(isurflt_prev))) 6067 svfnorm_counts(i) = svfnorm_counts(i) + 1 6068 6069 svf(1, isvf_surflt:nsvfl) = svf(1, isvf_surflt:nsvfl) / svfsum * (1._wp-skyvf(isurflt_prev)) 6158 6070 ENDIF 6071 !TODO we should be able to deallocate skyvf, from now on we only need skyvft 6159 6072 6160 6073 !-- deallocate temporary asvf array … … 6172 6085 6173 6086 CALL location_message( ' calculation of the complete CSF array', .TRUE. ) 6174 6087 ! CALL radiation_write_debug_log( 'Calculation of the complete CSF array' ) 6175 6088 !-- sort and merge csf for the last time, keeping the array size to minimum 6176 6089 CALL merge_and_grow_csf(-1) … … 6243 6156 !-- scatter and gather the number of elements to and from all processor 6244 6157 !-- and calculate displacements 6158 ! CALL radiation_write_debug_log( 'Scatter and gather the number of elements to and from all processor' ) 6245 6159 CALL MPI_AlltoAll(icsflt,1,MPI_INTEGER,ipcsflt,1,MPI_INTEGER,comm2d, ierr) 6246 6160 … … 6251 6165 d = d + ipcsflt(i) 6252 6166 ENDDO 6253 6167 6254 6168 !-- exchange csf fields between processors 6169 ! CALL radiation_write_debug_log( 'Exchange csf fields between processors' ) 6255 6170 ALLOCATE( pcsflt(ndcsf,max(npcsfl,ndcsf)) ) 6256 6171 ALLOCATE( kpcsflt(kdcsf,max(npcsfl,kdcsf)) ) … … 6277 6192 6278 6193 !-- sort csf ( a version of quicksort ) 6194 ! CALL radiation_write_debug_log( 'Sort csf' ) 6279 6195 CALL quicksort_csf2(kpcsflt, pcsflt, 1, npcsfl) 6280 6196 6281 6197 !-- aggregate canopy sink factor records with identical box & source 6282 6198 !-- againg across all values from all processors 6199 ! CALL radiation_write_debug_log( 'Aggregate canopy sink factor records with identical box' ) 6200 6283 6201 IF ( npcsfl > 0 ) THEN 6284 6202 icsf = 1 !< reading index … … 6326 6244 DEALLOCATE( pcsflt ) 6327 6245 DEALLOCATE( kpcsflt ) 6328 IF ( ALLOCATED( gridpcbl ) ) DEALLOCATE( gridpcbl)6246 ! CALL radiation_write_debug_log( 'End of aggregate csf' ) 6329 6247 6330 6248 ENDIF 6331 6249 6250 CALL MPI_BARRIER( comm2d, ierr ) 6251 ! CALL radiation_write_debug_log( 'End of radiation_calc_svf (after mpi_barrier)' ) 6252 6332 6253 RETURN 6333 6254 … … 6336 6257 'plant canopy sink factors / direct irradiance factors.' 6337 6258 CALL message( 'init_urban_surface', 'PA0502', 2, 2, 0, 6, 0 ) 6338 6339 CALL cpu_log( log_point_s(79), 'radiation_calc_svf', 'stop' ) 6340 6341 6259 6342 6260 END SUBROUTINE radiation_calc_svf 6343 6261 6344 6262 6345 6263 !------------------------------------------------------------------------------! 6346 6264 ! Description: … … 6397 6315 !-- Maximum number of gridboxes visited equals to maximum number of boundaries crossed in each dimension plus one. That's also 6398 6316 !-- the maximum number of plant canopy boxes written. We grow the acsf array accordingly using exponential factor. 6399 maxboxes = SUM(ABS(NINT(targ ) - NINT(src))) + 16317 maxboxes = SUM(ABS(NINT(targ, iwp) - NINT(src, iwp))) + 1 6400 6318 IF ( plant_canopy .AND. ncsfl + maxboxes > ncsfla ) THEN 6401 6319 !-- use this code for growing by fixed exponential increments (equivalent to case where ncsfl always increases by 1) … … 6449 6367 IF ( crlen > .001_wp ) THEN 6450 6368 crmid = (lastdist + nextdist) * .5_wp 6451 box = NINT(src(:) + uvect(:) * crmid )6369 box = NINT(src(:) + uvect(:) * crmid, iwp) 6452 6370 6453 6371 !-- calculate index of the grid with global indices (box(2),box(3)) … … 6483 6401 IF ( plant_canopy ) THEN 6484 6402 #if defined( __parallel ) 6485 IF ( usm_lad_rma) THEN6403 IF ( rma_lad_raytrace ) THEN 6486 6404 !-- send requests for lad_s to appropriate processor 6487 CALL cpu_log( log_point_s(77), ' usm_init_rma', 'start' )6405 CALL cpu_log( log_point_s(77), 'rad_init_rma', 'start' ) 6488 6406 DO i = 1, ncsb 6489 6407 CALL MPI_Get(lad_s_ray(i), 1, MPI_REAL, lad_ip(i), lad_disp(i), & … … 6501 6419 CALL message( 'raytrace', 'PA0519', 1, 2, 0, 6, 0 ) 6502 6420 ENDIF 6503 CALL cpu_log( log_point_s(77), ' usm_init_rma', 'stop' )6421 CALL cpu_log( log_point_s(77), 'rad_init_rma', 'stop' ) 6504 6422 6505 6423 ENDIF … … 6509 6427 DO i = 1, ncsb 6510 6428 #if defined( __parallel ) 6511 IF ( usm_lad_rma) THEN6429 IF ( rma_lad_raytrace ) THEN 6512 6430 lad_s_target = lad_s_ray(i) 6513 6431 ELSE 6514 lad_s_target = usm_lad_g(lad_ip(i)*nnx*nny*nzu + lad_disp(i))6432 lad_s_target = sub_lad_g(lad_ip(i)*nnx*nny*nzu + lad_disp(i)) 6515 6433 ENDIF 6516 6434 #else 6517 lad_s_target = usm_lad(boxes(1,i),boxes(2,i),boxes(3,i))6435 lad_s_target = sub_lad(boxes(1,i),boxes(2,i),boxes(3,i)) 6518 6436 #endif 6519 6437 cursink = 1._wp - exp(-ext_coef * lad_s_target * crlens(i)*realdist) … … 6539 6457 6540 6458 END SUBROUTINE raytrace 6541 6542 6459 6460 6543 6461 !------------------------------------------------------------------------------! 6544 6462 ! Description: 6545 6463 ! ------------ 6546 !> Determines whether two faces are oriented towards each other. Since the 6547 !> surfaces follow the gird box surfaces, it checks first whether the two surfaces 6548 !> are directed in the same direction, then it checks if the two surfaces are 6464 !> A new, more efficient version of ray tracing algorithm that processes a whole 6465 !> arc instead of a single ray. 6466 !> 6467 !> In all comments, horizon means tangent of horizon angle, i.e. 6468 !> vertical_delta / horizontal_distance 6469 !------------------------------------------------------------------------------! 6470 SUBROUTINE raytrace_2d(origin, yxdir, zdirs, iorig, aorig, vffrac, & 6471 create_csf, skip_1st_pcb, win_lad, horizon, & 6472 transparency) 6473 IMPLICIT NONE 6474 6475 REAL(wp), DIMENSION(3), INTENT(IN) :: origin !< z,y,x coordinates of ray origin 6476 REAL(wp), DIMENSION(2), INTENT(IN) :: yxdir !< y,x *unit* vector of ray direction (in grid units) 6477 REAL(wp), DIMENSION(:), INTENT(IN) :: zdirs !< list of z directions to raytrace (z/hdist, in grid) 6478 INTEGER(iwp), INTENT(in) :: iorig !< index of origin face for csf 6479 REAL(wp), INTENT(in) :: aorig !< origin face area for csf 6480 REAL(wp), DIMENSION(LBOUND(zdirs, 1):UBOUND(zdirs, 1)), INTENT(in) :: vffrac !< 6481 !< view factor fractions of each ray for csf 6482 LOGICAL, INTENT(in) :: create_csf !< whether to generate new CSFs during raytracing 6483 LOGICAL, INTENT(in) :: skip_1st_pcb !< whether to skip first plant canopy box during raytracing 6484 INTEGER(iwp), INTENT(in) :: win_lad !< leaf area density MPI window 6485 REAL(wp), INTENT(OUT) :: horizon !< highest horizon found after raytracing (z/hdist) 6486 REAL(wp), DIMENSION(LBOUND(zdirs, 1):UBOUND(zdirs, 1)), INTENT(OUT) :: transparency !< 6487 !< transparencies of zdirs paths 6488 !--INTEGER(iwp), DIMENSION(3, LBOUND(zdirs, 1):UBOUND(zdirs, 1)), INTENT(OUT) :: itarget !< 6489 !< (z,y,x) coordinates of target faces for zdirs 6490 INTEGER(iwp) :: i, k, l, d 6491 INTEGER(iwp) :: seldim !< dimension to be incremented 6492 REAL(wp), DIMENSION(2) :: yxorigin !< horizontal copy of origin (y,x) 6493 REAL(wp) :: distance !< euclidean along path 6494 REAL(wp) :: lastdist !< beginning of current crossing 6495 REAL(wp) :: nextdist !< end of current crossing 6496 REAL(wp) :: crmid !< midpoint of crossing 6497 REAL(wp) :: horz_entry !< horizon at entry to column 6498 REAL(wp) :: horz_exit !< horizon at exit from column 6499 REAL(wp) :: bdydim !< boundary for current dimension 6500 REAL(wp), DIMENSION(2) :: crossdist !< distances to boundary for dimensions 6501 REAL(wp), DIMENSION(2) :: dimnextdist !< distance for each dimension increments 6502 INTEGER(iwp), DIMENSION(2) :: column !< grid column being crossed 6503 INTEGER(iwp), DIMENSION(2) :: dimnext !< next dimension increments along path 6504 INTEGER(iwp), DIMENSION(2) :: dimdelta !< dimension direction = +- 1 6505 INTEGER(iwp) :: px, py !< number of processors in x and y dir before 6506 !< the processor in the question 6507 INTEGER(iwp) :: ip !< number of processor where gridbox reside 6508 INTEGER(iwp) :: ig !< 1D index of gridbox in global 2D array 6509 INTEGER(MPI_ADDRESS_KIND) :: wdisp !< RMA window displacement 6510 INTEGER(iwp) :: wcount !< RMA window item count 6511 INTEGER(iwp) :: maxboxes !< max no of CSF created 6512 INTEGER(iwp) :: nly !< maximum plant canopy height 6513 INTEGER(iwp) :: ntrack 6514 REAL(wp) :: zbottom, ztop !< urban surface boundary in real numbers 6515 REAL(wp) :: zorig !< z coordinate of ray column entry 6516 REAL(wp) :: zexit !< z coordinate of ray column exit 6517 REAL(wp) :: qdist !< ratio of real distance to z coord difference 6518 REAL(wp) :: dxxyy !< square of real horizontal distance 6519 REAL(wp) :: curtrans !< transparency of current PC box crossing 6520 INTEGER(iwp) :: zb0 6521 INTEGER(iwp) :: zb1 6522 INTEGER(iwp) :: nz 6523 INTEGER(iwp) :: iz 6524 INTEGER(iwp) :: zsgn 6525 REAL(wp), PARAMETER :: grow_factor = 1.5_wp !< factor of expansion of grow arrays 6526 6527 6528 yxorigin(:) = origin(2:3) 6529 transparency(:) = 1._wp !-- Pre-set the all rays to transparent before reducing 6530 horizon = -HUGE(1._wp) 6531 6532 !--Determine distance to boundary (in 2D xy) 6533 IF ( yxdir(1) > 0._wp ) THEN 6534 bdydim = ny + .5_wp !< north global boundary 6535 crossdist(1) = (bdydim - yxorigin(1)) / yxdir(1) 6536 ELSEIF ( yxdir(1) == 0._wp ) THEN 6537 crossdist(1) = HUGE(1._wp) 6538 ELSE 6539 bdydim = -.5_wp !< south global boundary 6540 crossdist(1) = (bdydim - yxorigin(1)) / yxdir(1) 6541 ENDIF 6542 6543 IF ( yxdir(2) >= 0._wp ) THEN 6544 bdydim = nx + .5_wp !< east global boundary 6545 crossdist(2) = (bdydim - yxorigin(2)) / yxdir(2) 6546 ELSEIF ( yxdir(2) == 0._wp ) THEN 6547 crossdist(2) = HUGE(1._wp) 6548 ELSE 6549 bdydim = -.5_wp !< west global boundary 6550 crossdist(2) = (bdydim - yxorigin(2)) / yxdir(2) 6551 ENDIF 6552 distance = minval(crossdist, 1) 6553 6554 IF ( plant_canopy ) THEN 6555 rt2_track_dist(0) = 0._wp 6556 rt2_track_lad(:,:) = 0._wp 6557 nly = plantt_max - nzub + 1 6558 ENDIF 6559 6560 lastdist = 0._wp 6561 6562 !-- Since all face coordinates have values *.5 and we'd like to use 6563 !-- integers, all these have .5 added 6564 DO d = 1, 2 6565 IF ( yxdir(d) == 0._wp ) THEN 6566 dimnext(d) = HUGE(1_iwp) 6567 dimdelta(d) = HUGE(1_iwp) 6568 dimnextdist(d) = HUGE(1._wp) 6569 ELSE IF ( yxdir(d) > 0._wp ) THEN 6570 dimnext(d) = FLOOR(yxorigin(d) + .5_wp) + 1 6571 dimdelta(d) = 1 6572 dimnextdist(d) = (dimnext(d) - .5_wp - yxorigin(d)) / yxdir(d) 6573 ELSE 6574 dimnext(d) = CEILING(yxorigin(d) + .5_wp) - 1 6575 dimdelta(d) = -1 6576 dimnextdist(d) = (dimnext(d) - .5_wp - yxorigin(d)) / yxdir(d) 6577 ENDIF 6578 ENDDO 6579 6580 ntrack = 0 6581 DO 6582 !-- along what dimension will the next wall crossing be? 6583 seldim = minloc(dimnextdist, 1) 6584 nextdist = dimnextdist(seldim) 6585 IF ( nextdist > distance ) nextdist = distance 6586 6587 IF ( nextdist > lastdist ) THEN 6588 ntrack = ntrack + 1 6589 crmid = (lastdist + nextdist) * .5_wp 6590 column = NINT(yxorigin(:) + yxdir(:) * crmid, iwp) 6591 6592 !-- calculate index of the grid with global indices (column(1),column(2)) 6593 !-- in the array nzterr and plantt and id of the coresponding processor 6594 px = column(2)/nnx 6595 py = column(1)/nny 6596 ip = px*pdims(2)+py 6597 ig = ip*nnx*nny + (column(2)-px*nnx)*nny + column(1)-py*nny 6598 6599 IF ( lastdist == 0._wp ) THEN 6600 horz_entry = -HUGE(1._wp) 6601 ELSE 6602 horz_entry = (nzterr(ig) - origin(1)) / lastdist 6603 ENDIF 6604 horz_exit = (nzterr(ig) - origin(1)) / nextdist 6605 horizon = MAX(horizon, horz_entry, horz_exit) 6606 6607 IF ( plant_canopy ) THEN 6608 rt2_track(:, ntrack) = column(:) 6609 rt2_track_dist(ntrack) = nextdist 6610 ENDIF 6611 ENDIF 6612 6613 IF ( nextdist >= distance ) EXIT 6614 lastdist = nextdist 6615 dimnext(seldim) = dimnext(seldim) + dimdelta(seldim) 6616 dimnextdist(seldim) = (dimnext(seldim) - .5_wp - yxorigin(seldim)) / yxdir(seldim) 6617 ENDDO 6618 6619 IF ( plant_canopy ) THEN 6620 !--Request LAD WHERE applicable 6621 !-- 6622 #if defined( __parallel ) 6623 IF ( rma_lad_raytrace ) THEN 6624 !-- send requests for lad_s to appropriate processor 6625 !CALL cpu_log( log_point_s(77), 'usm_init_rma', 'start' ) 6626 DO i = 1, ntrack 6627 px = rt2_track(2,i)/nnx 6628 py = rt2_track(1,i)/nny 6629 ip = px*pdims(2)+py 6630 ig = ip*nnx*nny + (rt2_track(2,i)-px*nnx)*nny + rt2_track(1,i)-py*nny 6631 IF ( plantt(ig) <= nzterr(ig) ) CYCLE 6632 wdisp = (rt2_track(2,i)-px*nnx)*(nny*nzu) + (rt2_track(1,i)-py*nny)*nzu + nzterr(ig)+1-nzub 6633 wcount = plantt(ig)-nzterr(ig) 6634 ! TODO send request ASAP - even during raytracing 6635 CALL MPI_Get(rt2_track_lad(nzterr(ig)+1:plantt(ig), i), wcount, MPI_REAL, ip, & 6636 wdisp, wcount, MPI_REAL, win_lad, ierr) 6637 IF ( ierr /= 0 ) THEN 6638 WRITE(message_string, *) 'MPI error ', ierr, ' at MPI_Get' 6639 CALL message( 'raytrace_2d', 'PA0526', 1, 2, 0, 6, 0 ) 6640 ENDIF 6641 ENDDO 6642 6643 !-- wait for all pending local requests complete 6644 ! TODO WAIT selectively for each column later when needed 6645 CALL MPI_Win_flush_local_all(win_lad, ierr) 6646 IF ( ierr /= 0 ) THEN 6647 WRITE(message_string, *) 'MPI error ', ierr, ' at MPI_Win_flush_local_all' 6648 CALL message( 'raytrace', 'PA0527', 1, 2, 0, 6, 0 ) 6649 ENDIF 6650 !CALL cpu_log( log_point_s(77), 'usm_init_rma', 'stop' ) 6651 ELSE ! rma_lad_raytrace 6652 DO i = 1, ntrack 6653 px = rt2_track(2,i)/nnx 6654 py = rt2_track(1,i)/nny 6655 ip = px*pdims(2)+py 6656 ig = ip*nnx*nny*nzu + (rt2_track(2,i)-px*nnx)*(nny*nzu) + (rt2_track(1,i)-py*nny)*nzu 6657 rt2_track_lad(nzub:plantt_max, i) = sub_lad_g(ig:ig+nly-1) 6658 ENDDO 6659 ENDIF 6660 #else 6661 DO i = 1, ntrack 6662 rt2_track_lad(nzub:plantt_max, i) = sub_lad(rt2_track(1,i), rt2_track(2,i), nzub:plantt_max) 6663 ENDDO 6664 #endif 6665 6666 !--Skip the PCB around origin if requested 6667 !-- 6668 IF ( skip_1st_pcb ) THEN 6669 rt2_track_lad(NINT(origin(1), iwp), 1) = 0._wp 6670 ENDIF 6671 6672 !--Assert that we have space allocated for CSFs 6673 !-- 6674 maxboxes = (ntrack + MAX(origin(1) - nzub, nzut - origin(1))) * SIZE(zdirs, 1) 6675 IF ( ncsfl + maxboxes > ncsfla ) THEN 6676 !-- use this code for growing by fixed exponential increments (equivalent to case where ncsfl always increases by 1) 6677 !-- k = CEILING(grow_factor ** real(CEILING(log(real(ncsfl + maxboxes, kind=wp)) & 6678 !-- / log(grow_factor)), kind=wp)) 6679 !-- or use this code to simply always keep some extra space after growing 6680 k = CEILING(REAL(ncsfl + maxboxes, kind=wp) * grow_factor) 6681 CALL merge_and_grow_csf(k) 6682 ENDIF 6683 6684 !--Calculate transparencies and store new CSFs 6685 !-- 6686 zbottom = REAL(nzub, wp) - .5_wp 6687 ztop = REAL(plantt_max, wp) + .5_wp 6688 6689 !--Reverse direction of radiation (face->sky), only when create_csf 6690 !-- 6691 IF ( create_csf ) THEN 6692 DO i = 1, ntrack ! for each column 6693 dxxyy = ((dy*yxdir(1))**2 + (dx*yxdir(2))**2) * (rt2_track_dist(i)-rt2_track_dist(i-1))**2 6694 px = rt2_track(2,i)/nnx 6695 py = rt2_track(1,i)/nny 6696 ip = px*pdims(2)+py 6697 6698 DO k = LBOUND(zdirs, 1), UBOUND(zdirs, 1) ! for each ray 6699 IF ( zdirs(k) <= horizon ) THEN 6700 CYCLE 6701 ENDIF 6702 6703 zorig = REAL(origin(1), wp) + zdirs(k) * rt2_track_dist(i-1) 6704 IF ( zorig <= zbottom .OR. zorig >= ztop ) CYCLE 6705 6706 zsgn = INT(SIGN(1._wp, zdirs(k)), iwp) 6707 rt2_dist(1) = 0._wp 6708 IF ( zdirs(k) == 0._wp ) THEN ! ray is exactly horizontal 6709 nz = 2 6710 rt2_dist(nz) = SQRT(dxxyy) 6711 iz = NINT(zorig, iwp) 6712 ELSE 6713 zexit = MIN(MAX(REAL(origin(1), wp) + zdirs(k) * rt2_track_dist(i), zbottom), ztop) 6714 6715 zb0 = FLOOR( zorig * zsgn - .5_wp) + 1 ! because it must be greater than orig 6716 zb1 = CEILING(zexit * zsgn - .5_wp) - 1 ! because it must be smaller than exit 6717 nz = MAX(zb1 - zb0 + 3, 2) 6718 rt2_dist(nz) = SQRT(((zexit-zorig)*dz)**2 + dxxyy) 6719 qdist = rt2_dist(nz) / (zexit-zorig) 6720 rt2_dist(2:nz-1) = (/( ((REAL(l, wp) + .5_wp) * zsgn - zorig) * qdist , l = zb0, zb1 )/) 6721 iz = zb0 * zsgn 6722 ENDIF 6723 6724 DO l = 2, nz 6725 IF ( rt2_track_lad(iz, i) > 0._wp ) THEN 6726 curtrans = exp(-ext_coef * rt2_track_lad(iz, i) * (rt2_dist(l)-rt2_dist(l-1))) 6727 6728 ncsfl = ncsfl + 1 6729 acsf(ncsfl)%ip = ip 6730 acsf(ncsfl)%itx = rt2_track(2,i) 6731 acsf(ncsfl)%ity = rt2_track(1,i) 6732 acsf(ncsfl)%itz = iz 6733 acsf(ncsfl)%isurfs = iorig 6734 acsf(ncsfl)%rsvf = REAL((1._wp - curtrans)*aorig*vffrac(k), wp) ! we postpone multiplication by transparency 6735 acsf(ncsfl)%rtransp = REAL(transparency(k), wp) 6736 6737 transparency(k) = transparency(k) * curtrans 6738 ENDIF 6739 iz = iz + zsgn 6740 ENDDO ! l = 1, nz - 1 6741 ENDDO ! k = LBOUND(zdirs, 1), UBOUND(zdirs, 1) 6742 ENDDO ! i = 1, ntrack 6743 6744 transparency(:) = 1._wp !-- Reset all rays to transparent 6745 ENDIF 6746 6747 !-- Forward direction of radiation (sky->face), always 6748 !-- 6749 DO i = ntrack, 1, -1 ! for each column backwards 6750 dxxyy = ((dy*yxdir(1))**2 + (dx*yxdir(2))**2) * (rt2_track_dist(i)-rt2_track_dist(i-1))**2 6751 px = rt2_track(2,i)/nnx 6752 py = rt2_track(1,i)/nny 6753 ip = px*pdims(2)+py 6754 6755 DO k = LBOUND(zdirs, 1), UBOUND(zdirs, 1) ! for each ray 6756 IF ( zdirs(k) <= horizon ) THEN 6757 transparency(k) = 0._wp 6758 CYCLE 6759 ENDIF 6760 6761 zexit = REAL(origin(1), wp) + zdirs(k) * rt2_track_dist(i-1) 6762 IF ( zexit <= zbottom .OR. zexit >= ztop ) CYCLE 6763 6764 zsgn = -INT(SIGN(1._wp, zdirs(k)), iwp) 6765 rt2_dist(1) = 0._wp 6766 IF ( zdirs(k) == 0._wp ) THEN ! ray is exactly horizontal 6767 nz = 2 6768 rt2_dist(nz) = SQRT(dxxyy) 6769 iz = NINT(zexit, iwp) 6770 ELSE 6771 zorig = MIN(MAX(REAL(origin(1), wp) + zdirs(k) * rt2_track_dist(i), zbottom), ztop) 6772 6773 zb0 = FLOOR( zorig * zsgn - .5_wp) + 1 ! because it must be greater than orig 6774 zb1 = CEILING(zexit * zsgn - .5_wp) - 1 ! because it must be smaller than exit 6775 nz = MAX(zb1 - zb0 + 3, 2) 6776 rt2_dist(nz) = SQRT(((zexit-zorig)*dz)**2 + dxxyy) 6777 qdist = rt2_dist(nz) / (zexit-zorig) 6778 rt2_dist(2:nz-1) = (/( ((REAL(l, wp) + .5_wp) * zsgn - zorig) * qdist , l = zb0, zb1 )/) 6779 iz = zb0 * zsgn 6780 ENDIF 6781 6782 DO l = 2, nz 6783 IF ( rt2_track_lad(iz, i) > 0._wp ) THEN 6784 curtrans = exp(-ext_coef * rt2_track_lad(iz, i) * (rt2_dist(l)-rt2_dist(l-1))) 6785 6786 IF ( create_csf ) THEN 6787 ncsfl = ncsfl + 1 6788 acsf(ncsfl)%ip = ip 6789 acsf(ncsfl)%itx = rt2_track(2,i) 6790 acsf(ncsfl)%ity = rt2_track(1,i) 6791 acsf(ncsfl)%itz = iz 6792 acsf(ncsfl)%isurfs = -1 ! a special ID indicating sky 6793 acsf(ncsfl)%rsvf = REAL((1._wp - curtrans)*aorig*vffrac(k), wp) ! we postpone multiplication by transparency 6794 acsf(ncsfl)%rtransp = REAL(transparency(k), wp) 6795 ENDIF !< create_csf 6796 6797 transparency(k) = transparency(k) * curtrans 6798 ENDIF 6799 iz = iz + zsgn 6800 ENDDO ! l = 1, nz - 1 6801 ENDDO ! k = LBOUND(zdirs, 1), UBOUND(zdirs, 1) 6802 ENDDO ! i = 1, ntrack 6803 6804 ELSE ! not plant_canopy 6805 DO k = UBOUND(zdirs, 1), LBOUND(zdirs, 1), -1 ! TODO make more generic 6806 IF ( zdirs(k) > horizon ) EXIT 6807 transparency(k) = 0._wp 6808 ENDDO 6809 ENDIF 6810 6811 END SUBROUTINE raytrace_2d 6812 6813 6814 !------------------------------------------------------------------------------! 6815 ! 6816 ! Description: 6817 ! ------------ 6818 !> Calculates apparent solar positions for all timesteps and stores discretized 6819 !> positions. 6820 !------------------------------------------------------------------------------! 6821 SUBROUTINE radiation_presimulate_solar_pos 6822 IMPLICIT NONE 6823 6824 INTEGER(iwp) :: it, i, j 6825 REAL(wp) :: tsrp_prev 6826 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: dsidir_tmp !< dsidir_tmp[:,i] = unit vector of i-th 6827 !< appreant solar direction 6828 6829 ALLOCATE ( dsidir_rev(0:raytrace_discrete_elevs/2-1, & 6830 0:raytrace_discrete_azims-1) ) 6831 dsidir_rev(:,:) = -1 6832 ALLOCATE ( dsidir_tmp(3, & 6833 raytrace_discrete_elevs/2*raytrace_discrete_azims) ) 6834 ndsidir = 0 6835 6836 ! 6837 !-- We will artificialy update time_since_reference_point and return to 6838 !-- true value later 6839 tsrp_prev = time_since_reference_point 6840 sun_direction = .TRUE. 6841 6842 ! 6843 !-- Process spinup time if configured 6844 IF ( spinup_time > 0._wp ) THEN 6845 DO it = 0, CEILING(spinup_time / dt_spinup) 6846 time_since_reference_point = -spinup_time + REAL(it, wp) * dt_spinup 6847 CALL simulate_pos 6848 ENDDO 6849 ENDIF 6850 ! 6851 !-- Process simulation time 6852 DO it = 0, CEILING(end_time / dt_radiation) 6853 time_since_reference_point = REAL(it, wp) * dt_radiation 6854 CALL simulate_pos 6855 ENDDO 6856 6857 time_since_reference_point = tsrp_prev 6858 6859 !-- Allocate global vars which depend on ndsidir 6860 ALLOCATE ( dsidir ( 3, ndsidir ) ) 6861 dsidir(:,:) = dsidir_tmp(:, 1:ndsidir) 6862 DEALLOCATE ( dsidir_tmp ) 6863 ALLOCATE ( dsitrans(nsurfl, ndsidir) ) 6864 ALLOCATE ( dsitransc(npcbl, ndsidir) ) 6865 6866 WRITE ( message_string, * ) 'Precalculated', ndsidir, ' solar positions', & 6867 'from', it, ' timesteps.' 6868 CALL message( 'radiation_presimulate_solar_pos', 'UI0013', 0, 0, 0, 6, 0 ) 6869 6870 CONTAINS 6871 6872 !------------------------------------------------------------------------! 6873 ! Description: 6874 ! ------------ 6875 !> Simuates a single position 6876 !------------------------------------------------------------------------! 6877 SUBROUTINE simulate_pos 6878 IMPLICIT NONE 6879 ! 6880 !-- Update apparent solar position based on modified t_s_r_p 6881 CALL calc_zenith 6882 IF ( zenith(0) > 0 ) THEN 6883 !-- 6884 !-- Identify solar direction vector (discretized number) 1) 6885 i = MODULO(NINT(ATAN2(sun_dir_lon(0), sun_dir_lat(0)) & 6886 / (2._wp*pi) * raytrace_discrete_azims-.5_wp, iwp), & 6887 raytrace_discrete_azims) 6888 j = FLOOR(ACOS(zenith(0)) / pi * raytrace_discrete_elevs) 6889 IF ( dsidir_rev(j, i) == -1 ) THEN 6890 ndsidir = ndsidir + 1 6891 dsidir_tmp(:, ndsidir) = & 6892 (/ COS((REAL(j,wp)+.5_wp) * pi / raytrace_discrete_elevs), & 6893 SIN((REAL(j,wp)+.5_wp) * pi / raytrace_discrete_elevs) & 6894 * COS((REAL(i,wp)+.5_wp) * 2_wp*pi / raytrace_discrete_azims), & 6895 SIN((REAL(j,wp)+.5_wp) * pi / raytrace_discrete_elevs) & 6896 * SIN((REAL(i,wp)+.5_wp) * 2_wp*pi / raytrace_discrete_azims) /) 6897 dsidir_rev(j, i) = ndsidir 6898 ENDIF 6899 ENDIF 6900 END SUBROUTINE simulate_pos 6901 6902 END SUBROUTINE radiation_presimulate_solar_pos 6903 6904 6905 6906 !------------------------------------------------------------------------------! 6907 ! Description: 6908 ! ------------ 6909 !> Determines whether two faces are oriented towards each other. Since the 6910 !> surfaces follow the gird box surfaces, it checks first whether the two surfaces 6911 !> are directed in the same direction, then it checks if the two surfaces are 6549 6912 !> located in confronted direction but facing away from each other, e.g. <--| |--> 6550 6913 !------------------------------------------------------------------------------! … … 6558 6921 IF ( (d==iup_u .OR. d==iup_l .OR. d==iup_a ) & 6559 6922 .AND. (d2==iup_u .OR. d2==iup_l) ) RETURN 6560 IF ( (d==isky .OR. d==idown_a) .AND. d2==isky ) RETURN 6561 IF ( (d==isouth_u .OR. d==isouth_l .OR. d==isouth_a .OR. d==inorth_b ) & 6562 .AND. (d2==isouth_u .OR. d2==isouth_l .OR. d2==inorth_b) ) RETURN 6563 IF ( (d==inorth_u .OR. d==inorth_l .OR. d==inorth_a .OR. d==isouth_b ) & 6564 .AND. (d2==inorth_u .OR. d2==inorth_l .OR. d2==isouth_b) ) RETURN 6565 IF ( (d==iwest_u .OR. d==iwest_l .OR. d==iwest_a .OR. d==ieast_b ) & 6566 .AND. (d2==iwest_u .OR. d2==iwest_l .OR. d2==ieast_b ) ) RETURN 6567 IF ( (d==ieast_u .OR. d==ieast_l .OR. d==ieast_a .OR. d==iwest_b ) & 6568 .AND. (d2==ieast_u .OR. d2==ieast_l .OR. d2==iwest_b ) ) RETURN 6923 IF ( (d==isouth_u .OR. d==isouth_l .OR. d==isouth_a ) & 6924 .AND. (d2==isouth_u .OR. d2==isouth_l) ) RETURN 6925 IF ( (d==inorth_u .OR. d==inorth_l .OR. d==inorth_a ) & 6926 .AND. (d2==inorth_u .OR. d2==inorth_l) ) RETURN 6927 IF ( (d==iwest_u .OR. d==iwest_l .OR. d==iwest_a ) & 6928 .AND. (d2==iwest_u .OR. d2==iwest_l ) ) RETURN 6929 IF ( (d==ieast_u .OR. d==ieast_l .OR. d==ieast_a ) & 6930 .AND. (d2==ieast_u .OR. d2==ieast_l ) ) RETURN 6569 6931 6570 6932 !-- second check: are surfaces facing away from each other 6571 6933 SELECT CASE (d) 6572 CASE (iup_u, iup_l, iup_a) 6934 CASE (iup_u, iup_l, iup_a) !< upward facing surfaces 6573 6935 IF ( z2 < z ) RETURN 6574 CASE (i sky, idown_a) !< downward facing surfaces6936 CASE (idown_a) !< downward facing surfaces 6575 6937 IF ( z2 > z ) RETURN 6576 CASE (isouth_u, isouth_l, isouth_a , inorth_b)!< southward facing surfaces6938 CASE (isouth_u, isouth_l, isouth_a) !< southward facing surfaces 6577 6939 IF ( y2 > y ) RETURN 6578 CASE (inorth_u, inorth_l, inorth_a , isouth_b)!< northward facing surfaces6940 CASE (inorth_u, inorth_l, inorth_a) !< northward facing surfaces 6579 6941 IF ( y2 < y ) RETURN 6580 CASE (iwest_u, iwest_l, iwest_a , ieast_b)!< westward facing surfaces6942 CASE (iwest_u, iwest_l, iwest_a) !< westward facing surfaces 6581 6943 IF ( x2 > x ) RETURN 6582 CASE (ieast_u, ieast_l, ieast_a , iwest_b)!< eastward facing surfaces6944 CASE (ieast_u, ieast_l, ieast_a) !< eastward facing surfaces 6583 6945 IF ( x2 < x ) RETURN 6584 6946 END SELECT 6585 6947 6586 6948 SELECT CASE (d2) 6587 CASE (iup_u) !< ground, roof6949 CASE (iup_u) !< ground, roof 6588 6950 IF ( z < z2 ) RETURN 6589 CASE (isky) !< sky 6590 IF ( z > z2 ) RETURN 6591 CASE (isouth_u, isouth_l, inorth_b) !< south facing 6951 CASE (isouth_u, isouth_l) !< south facing 6592 6952 IF ( y > y2 ) RETURN 6593 CASE (inorth_u, inorth_l , isouth_b)!< north facing6953 CASE (inorth_u, inorth_l) !< north facing 6594 6954 IF ( y < y2 ) RETURN 6595 CASE (iwest_u, iwest_l , ieast_b)!< west facing6955 CASE (iwest_u, iwest_l) !< west facing 6596 6956 IF ( x > x2 ) RETURN 6597 CASE (ieast_u, ieast_l , iwest_b)!< east facing6957 CASE (ieast_u, ieast_l) !< east facing 6598 6958 IF ( x < x2 ) RETURN 6599 6959 CASE (-1) … … 6604 6964 6605 6965 END FUNCTION surface_facing 6966 6606 6967 6607 6968 !------------------------------------------------------------------------------! … … 6613 6974 SUBROUTINE radiation_read_svf 6614 6975 6615 IMPLICIT NONE6616 INTEGER(iwp) :: fsvf = 886617 INTEGER(iwp) :: i6618 CHARACTER(usm_version_len) :: usm_version_field6619 CHARACTER(svf_code_len) :: svf_code_field6620 6621 DO i = 0, io_blocks-16622 IF ( i == io_group ) THEN6976 IMPLICIT NONE 6977 INTEGER(iwp) :: fsvf = 88 6978 INTEGER(iwp) :: i 6979 CHARACTER(rad_version_len) :: rad_version_field 6980 CHARACTER(svf_code_len) :: svf_code_field 6981 6982 DO i = 0, io_blocks-1 6983 IF ( i == io_group ) THEN 6623 6984 6624 6985 ! … … 6626 6987 CALL check_open( fsvf ) 6627 6988 6628 6629 !-- read and check version 6630 READ ( fsvf ) usm_version_field 6631 IF ( TRIM(usm_version_field) /= TRIM(usm_version) ) THEN 6632 WRITE( message_string, * ) 'Version of binary SVF file "', & 6633 TRIM(usm_version_field), '" does not match ', & 6634 'the version of model "', TRIM(usm_version), '"' 6635 CALL message( 'radiation_read_svf', 'PA0482', 1, 2, 0, 6, 0 ) 6636 ENDIF 6989 !-- read and check version 6990 READ ( fsvf ) rad_version_field 6991 IF ( TRIM(rad_version_field) /= TRIM(rad_version) ) THEN 6992 WRITE( message_string, * ) 'Version of binary SVF file "', & 6993 TRIM(rad_version_field), '" does not match ', & 6994 'the version of model "', TRIM(rad_version), '"' 6995 CALL message( 'radiation_read_svf', 'PA0482', 1, 2, 0, 6, 0 ) 6996 ENDIF 6637 6997 6638 !-- read nsvfl, ncsfl 6639 READ ( fsvf ) nsvfl, ncsfl 6640 IF ( nsvfl <= 0 .OR. ncsfl < 0 ) THEN 6641 WRITE( message_string, * ) 'Wrong number of SVF or CSF' 6642 CALL message( 'radiation_read_svf', 'PA0483', 1, 2, 0, 6, 0 ) 6643 ELSE 6644 WRITE(message_string,*) ' Number of SVF and CSF to read', nsvfl, ncsfl 6645 CALL location_message( message_string, .TRUE. ) 6646 ENDIF 6998 !-- read nsvfl, ncsfl 6999 READ ( fsvf ) nsvfl, ncsfl, nsurfl 7000 IF ( nsvfl <= 0 .OR. ncsfl < 0 ) THEN 7001 WRITE( message_string, * ) 'Wrong number of SVF or CSF' 7002 CALL message( 'radiation_read_svf', 'PA0483', 1, 2, 0, 6, 0 ) 7003 ELSE 7004 WRITE(message_string,*) ' Number of SVF, CSF, and nsurfl to read '& 7005 , nsvfl, ncsfl, nsurfl 7006 CALL location_message( message_string, .TRUE. ) 7007 ENDIF 6647 7008 6648 ALLOCATE(svf(ndsvf,nsvfl)) 6649 ALLOCATE(svfsurf(idsvf,nsvfl)) 6650 6651 READ(fsvf) svf 6652 READ(fsvf) svfsurf 6653 6654 IF ( plant_canopy ) THEN 6655 ALLOCATE(csf(ndcsf,ncsfl)) 6656 ALLOCATE(csfsurf(idcsf,ncsfl)) 6657 READ(fsvf) csf 6658 READ(fsvf) csfsurf 6659 ENDIF 6660 6661 READ ( fsvf ) svf_code_field 6662 IF ( TRIM(svf_code_field) /= TRIM(svf_code) ) THEN 6663 WRITE( message_string, * ) 'Wrong structure of binary svf file' 6664 CALL message( 'radiation_read_svf', 'PA0484', 1, 2, 0, 6, 0 ) 6665 ENDIF 7009 ALLOCATE(skyvf(nsurfl)) 7010 ALLOCATE(skyvft(nsurfl)) 7011 ALLOCATE(svf(ndsvf,nsvfl)) 7012 ALLOCATE(svfsurf(idsvf,nsvfl)) 7013 READ(fsvf) skyvf 7014 READ(fsvf) skyvft 7015 READ(fsvf) svf 7016 READ(fsvf) svfsurf 7017 IF ( plant_canopy ) THEN 7018 ALLOCATE(csf(ndcsf,ncsfl)) 7019 ALLOCATE(csfsurf(idcsf,ncsfl)) 7020 READ(fsvf) csf 7021 READ(fsvf) csfsurf 7022 ENDIF 7023 READ ( fsvf ) svf_code_field 6666 7024 7025 IF ( TRIM(svf_code_field) /= TRIM(svf_code) ) THEN 7026 WRITE( message_string, * ) 'Wrong structure of binary svf file' 7027 CALL message( 'radiation_read_svf', 'PA0484', 1, 2, 0, 6, 0 ) 7028 ENDIF 6667 7029 ! 6668 7030 !-- Close binary file 6669 7031 CALL close_file( fsvf ) 6670 7032 6671 ENDIF7033 ENDIF 6672 7034 #if defined( __parallel ) 6673 CALL MPI_BARRIER( comm2d, ierr )7035 CALL MPI_BARRIER( comm2d, ierr ) 6674 7036 #endif 6675 ENDDO7037 ENDDO 6676 7038 6677 7039 END SUBROUTINE radiation_read_svf … … 6686 7048 SUBROUTINE radiation_write_svf 6687 7049 6688 6689 IMPLICIT NONE 6690 6691 INTEGER(iwp) :: fsvf = 89 6692 INTEGER(iwp) :: i 6693 6694 6695 DO i = 0, io_blocks-1 6696 IF ( i == io_group ) THEN 6697 7050 IMPLICIT NONE 7051 INTEGER(iwp) :: fsvf = 89 7052 INTEGER(iwp) :: i 7053 7054 DO i = 0, io_blocks-1 7055 IF ( i == io_group ) THEN 6698 7056 ! 6699 7057 !-- Open binary file 6700 7058 CALL check_open( fsvf ) 6701 7059 6702 WRITE ( fsvf ) usm_version 6703 WRITE ( fsvf ) nsvfl, ncsfl 6704 WRITE ( fsvf ) svf 6705 WRITE ( fsvf ) svfsurf 6706 IF ( plant_canopy ) THEN 6707 WRITE ( fsvf ) csf 6708 WRITE ( fsvf ) csfsurf 6709 ENDIF 6710 WRITE ( fsvf ) TRIM(svf_code) 6711 7060 WRITE ( fsvf ) rad_version 7061 WRITE ( fsvf ) nsvfl, ncsfl, nsurfl 7062 WRITE ( fsvf ) skyvf 7063 WRITE ( fsvf ) skyvft 7064 WRITE ( fsvf ) svf 7065 WRITE ( fsvf ) svfsurf 7066 IF ( plant_canopy ) THEN 7067 WRITE ( fsvf ) csf 7068 WRITE ( fsvf ) csfsurf 7069 ENDIF 7070 WRITE ( fsvf ) TRIM(svf_code) 6712 7071 ! 6713 7072 !-- Close binary file … … 6716 7075 ENDIF 6717 7076 #if defined( __parallel ) 6718 CALL MPI_BARRIER( comm2d, ierr )7077 CALL MPI_BARRIER( comm2d, ierr ) 6719 7078 #endif 6720 ENDDO 6721 7079 ENDDO 6722 7080 END SUBROUTINE radiation_write_svf 6723 7081 6724 7082 !------------------------------------------------------------------------------! 7083 ! 7084 ! Description: 7085 ! ------------ 7086 !> Block of auxiliary subroutines: 7087 !> 1. quicksort and corresponding comparison 7088 !> 2. merge_and_grow_csf for implementation of "dynamical growing" 7089 !> array for csf 7090 !------------------------------------------------------------------------------! 7091 PURE FUNCTION svf_lt(svf1,svf2) result (res) 7092 TYPE (t_svf), INTENT(in) :: svf1,svf2 7093 LOGICAL :: res 7094 IF ( svf1%isurflt < svf2%isurflt .OR. & 7095 (svf1%isurflt == svf2%isurflt .AND. svf1%isurfs < svf2%isurfs) ) THEN 7096 res = .TRUE. 7097 ELSE 7098 res = .FALSE. 7099 ENDIF 7100 END FUNCTION svf_lt 7101 7102 7103 !-- quicksort.f -*-f90-*- 7104 !-- Author: t-nissie, adaptation J.Resler 7105 !-- License: GPLv3 7106 !-- Gist: https://gist.github.com/t-nissie/479f0f16966925fa29ea 7107 RECURSIVE SUBROUTINE quicksort_svf(svfl, first, last) 7108 IMPLICIT NONE 7109 TYPE(t_svf), DIMENSION(:), INTENT(INOUT) :: svfl 7110 INTEGER(iwp), INTENT(IN) :: first, last 7111 TYPE(t_svf) :: x, t 7112 INTEGER(iwp) :: i, j 7113 7114 IF ( first>=last ) RETURN 7115 x = svfl( (first+last) / 2 ) 7116 i = first 7117 j = last 7118 DO 7119 DO while ( svf_lt(svfl(i),x) ) 7120 i=i+1 7121 ENDDO 7122 DO while ( svf_lt(x,svfl(j)) ) 7123 j=j-1 7124 ENDDO 7125 IF ( i >= j ) EXIT 7126 t = svfl(i); svfl(i) = svfl(j); svfl(j) = t 7127 i=i+1 7128 j=j-1 7129 ENDDO 7130 IF ( first < i-1 ) CALL quicksort_svf(svfl, first, i-1) 7131 IF ( j+1 < last ) CALL quicksort_svf(svfl, j+1, last) 7132 END SUBROUTINE quicksort_svf 7133 7134 7135 PURE FUNCTION csf_lt(csf1,csf2) result (res) 7136 TYPE (t_csf), INTENT(in) :: csf1,csf2 7137 LOGICAL :: res 7138 IF ( csf1%ip < csf2%ip .OR. & 7139 (csf1%ip == csf2%ip .AND. csf1%itx < csf2%itx) .OR. & 7140 (csf1%ip == csf2%ip .AND. csf1%itx == csf2%itx .AND. csf1%ity < csf2%ity) .OR. & 7141 (csf1%ip == csf2%ip .AND. csf1%itx == csf2%itx .AND. csf1%ity == csf2%ity .AND. & 7142 csf1%itz < csf2%itz) .OR. & 7143 (csf1%ip == csf2%ip .AND. csf1%itx == csf2%itx .AND. csf1%ity == csf2%ity .AND. & 7144 csf1%itz == csf2%itz .AND. csf1%isurfs < csf2%isurfs) ) THEN 7145 res = .TRUE. 7146 ELSE 7147 res = .FALSE. 7148 ENDIF 7149 END FUNCTION csf_lt 7150 7151 7152 !-- quicksort.f -*-f90-*- 7153 !-- Author: t-nissie, adaptation J.Resler 7154 !-- License: GPLv3 7155 !-- Gist: https://gist.github.com/t-nissie/479f0f16966925fa29ea 7156 RECURSIVE SUBROUTINE quicksort_csf(csfl, first, last) 7157 IMPLICIT NONE 7158 TYPE(t_csf), DIMENSION(:), INTENT(INOUT) :: csfl 7159 INTEGER(iwp), INTENT(IN) :: first, last 7160 TYPE(t_csf) :: x, t 7161 INTEGER(iwp) :: i, j 7162 7163 IF ( first>=last ) RETURN 7164 x = csfl( (first+last)/2 ) 7165 i = first 7166 j = last 7167 DO 7168 DO while ( csf_lt(csfl(i),x) ) 7169 i=i+1 7170 ENDDO 7171 DO while ( csf_lt(x,csfl(j)) ) 7172 j=j-1 7173 ENDDO 7174 IF ( i >= j ) EXIT 7175 t = csfl(i); csfl(i) = csfl(j); csfl(j) = t 7176 i=i+1 7177 j=j-1 7178 ENDDO 7179 IF ( first < i-1 ) CALL quicksort_csf(csfl, first, i-1) 7180 IF ( j+1 < last ) CALL quicksort_csf(csfl, j+1, last) 7181 END SUBROUTINE quicksort_csf 7182 7183 7184 SUBROUTINE merge_and_grow_csf(newsize) 7185 INTEGER(iwp), INTENT(in) :: newsize !< new array size after grow, must be >= ncsfl 7186 !< or -1 to shrink to minimum 7187 INTEGER(iwp) :: iread, iwrite 7188 TYPE(t_csf), DIMENSION(:), POINTER :: acsfnew 7189 CHARACTER(100) :: msg 7190 7191 IF ( newsize == -1 ) THEN 7192 !-- merge in-place 7193 acsfnew => acsf 7194 ELSE 7195 !-- allocate new array 7196 IF ( mcsf == 0 ) THEN 7197 ALLOCATE( acsf1(newsize) ) 7198 acsfnew => acsf1 7199 ELSE 7200 ALLOCATE( acsf2(newsize) ) 7201 acsfnew => acsf2 7202 ENDIF 7203 ENDIF 7204 7205 IF ( ncsfl >= 1 ) THEN 7206 !-- sort csf in place (quicksort) 7207 CALL quicksort_csf(acsf,1,ncsfl) 7208 7209 !-- while moving to a new array, aggregate canopy sink factor records with identical box & source 7210 acsfnew(1) = acsf(1) 7211 iwrite = 1 7212 DO iread = 2, ncsfl 7213 !-- here acsf(kcsf) already has values from acsf(icsf) 7214 IF ( acsfnew(iwrite)%itx == acsf(iread)%itx & 7215 .AND. acsfnew(iwrite)%ity == acsf(iread)%ity & 7216 .AND. acsfnew(iwrite)%itz == acsf(iread)%itz & 7217 .AND. acsfnew(iwrite)%isurfs == acsf(iread)%isurfs ) THEN 7218 !-- We could simply take either first or second rtransp, both are valid. As a very simple heuristic about which ray 7219 !-- probably passes nearer the center of the target box, we choose DIF from the entry with greater CSF, since that 7220 !-- might mean that the traced beam passes longer through the canopy box. 7221 IF ( acsfnew(iwrite)%rsvf < acsf(iread)%rsvf ) THEN 7222 acsfnew(iwrite)%rtransp = acsf(iread)%rtransp 7223 ENDIF 7224 acsfnew(iwrite)%rsvf = acsfnew(iwrite)%rsvf + acsf(iread)%rsvf 7225 !-- advance reading index, keep writing index 7226 ELSE 7227 !-- not identical, just advance and copy 7228 iwrite = iwrite + 1 7229 acsfnew(iwrite) = acsf(iread) 7230 ENDIF 7231 ENDDO 7232 ncsfl = iwrite 7233 ENDIF 7234 7235 IF ( newsize == -1 ) THEN 7236 !-- allocate new array and copy shrinked data 7237 IF ( mcsf == 0 ) THEN 7238 ALLOCATE( acsf1(ncsfl) ) 7239 acsf1(1:ncsfl) = acsf2(1:ncsfl) 7240 ELSE 7241 ALLOCATE( acsf2(ncsfl) ) 7242 acsf2(1:ncsfl) = acsf1(1:ncsfl) 7243 ENDIF 7244 ENDIF 7245 7246 !-- deallocate old array 7247 IF ( mcsf == 0 ) THEN 7248 mcsf = 1 7249 acsf => acsf1 7250 DEALLOCATE( acsf2 ) 7251 ELSE 7252 mcsf = 0 7253 acsf => acsf2 7254 DEALLOCATE( acsf1 ) 7255 ENDIF 7256 ncsfla = newsize 7257 7258 ! WRITE(msg,'(A,2I12)') 'Grow acsf2:',ncsfl,ncsfla 7259 ! CALL radiation_write_debug_log( msg ) 7260 7261 END SUBROUTINE merge_and_grow_csf 7262 7263 7264 !-- quicksort.f -*-f90-*- 7265 !-- Author: t-nissie, adaptation J.Resler 7266 !-- License: GPLv3 7267 !-- Gist: https://gist.github.com/t-nissie/479f0f16966925fa29ea 7268 RECURSIVE SUBROUTINE quicksort_csf2(kpcsflt, pcsflt, first, last) 7269 IMPLICIT NONE 7270 INTEGER(iwp), DIMENSION(:,:), INTENT(INOUT) :: kpcsflt 7271 REAL(wp), DIMENSION(:,:), INTENT(INOUT) :: pcsflt 7272 INTEGER(iwp), INTENT(IN) :: first, last 7273 REAL(wp), DIMENSION(ndcsf) :: t2 7274 INTEGER(iwp), DIMENSION(kdcsf) :: x, t1 7275 INTEGER(iwp) :: i, j 7276 7277 IF ( first>=last ) RETURN 7278 x = kpcsflt(:, (first+last)/2 ) 7279 i = first 7280 j = last 7281 DO 7282 DO while ( csf_lt2(kpcsflt(:,i),x) ) 7283 i=i+1 7284 ENDDO 7285 DO while ( csf_lt2(x,kpcsflt(:,j)) ) 7286 j=j-1 7287 ENDDO 7288 IF ( i >= j ) EXIT 7289 t1 = kpcsflt(:,i); kpcsflt(:,i) = kpcsflt(:,j); kpcsflt(:,j) = t1 7290 t2 = pcsflt(:,i); pcsflt(:,i) = pcsflt(:,j); pcsflt(:,j) = t2 7291 i=i+1 7292 j=j-1 7293 ENDDO 7294 IF ( first < i-1 ) CALL quicksort_csf2(kpcsflt, pcsflt, first, i-1) 7295 IF ( j+1 < last ) CALL quicksort_csf2(kpcsflt, pcsflt, j+1, last) 7296 END SUBROUTINE quicksort_csf2 7297 7298 7299 PURE FUNCTION csf_lt2(item1, item2) result(res) 7300 INTEGER(iwp), DIMENSION(kdcsf), INTENT(in) :: item1, item2 7301 LOGICAL :: res 7302 res = ( (item1(3) < item2(3)) & 7303 .OR. (item1(3) == item2(3) .AND. item1(2) < item2(2)) & 7304 .OR. (item1(3) == item2(3) .AND. item1(2) == item2(2) .AND. item1(1) < item2(1)) & 7305 .OR. (item1(3) == item2(3) .AND. item1(2) == item2(2) .AND. item1(1) == item2(1) & 7306 .AND. item1(4) < item2(4)) ) 7307 END FUNCTION csf_lt2 7308 7309 PURE FUNCTION searchsorted(athresh, val) result(ind) 7310 REAL(wp), DIMENSION(:), INTENT(IN) :: athresh 7311 REAL(wp), INTENT(IN) :: val 7312 INTEGER(iwp) :: ind 7313 INTEGER(iwp) :: i 7314 7315 DO i = LBOUND(athresh, 1), UBOUND(athresh, 1) 7316 IF ( val < athresh(i) ) THEN 7317 ind = i - 1 7318 RETURN 7319 ENDIF 7320 ENDDO 7321 ind = UBOUND(athresh, 1) 7322 END FUNCTION searchsorted 6725 7323 6726 7324 !------------------------------------------------------------------------------! … … 6796 7394 swd_gridbox(1) = surfinswdif(l) 6797 7395 6798 CASE (i sky,idown_a) !- gridbox down_facing face7396 CASE (idown_a) !- gridbox down_facing face 6799 7397 sw_gridbox(2) = surfinsw(l) 6800 7398 lw_gridbox(2) = surfinlw(l) 6801 7399 swd_gridbox(2) = surfinswdif(l) 6802 7400 6803 CASE (inorth_u,inorth_l,inorth_a ,isouth_b) !- gridbox north_facing face7401 CASE (inorth_u,inorth_l,inorth_a) !- gridbox north_facing face 6804 7402 sw_gridbox(3) = surfinsw(l) 6805 7403 lw_gridbox(3) = surfinlw(l) 6806 7404 swd_gridbox(3) = surfinswdif(l) 6807 7405 6808 CASE (isouth_u,isouth_l,isouth_a ,inorth_b) !- gridbox south_facing face7406 CASE (isouth_u,isouth_l,isouth_a) !- gridbox south_facing face 6809 7407 sw_gridbox(4) = surfinsw(l) 6810 7408 lw_gridbox(4) = surfinlw(l) 6811 7409 swd_gridbox(4) = surfinswdif(l) 6812 7410 6813 CASE (ieast_u,ieast_l,ieast_a ,iwest_b) !- gridbox east_facing face7411 CASE (ieast_u,ieast_l,ieast_a) !- gridbox east_facing face 6814 7412 sw_gridbox(5) = surfinsw(l) 6815 7413 lw_gridbox(5) = surfinlw(l) 6816 7414 swd_gridbox(5) = surfinswdif(l) 6817 7415 6818 CASE (iwest_u,iwest_l,iwest_a ,ieast_b) !- gridbox west_facing face7416 CASE (iwest_u,iwest_l,iwest_a) !- gridbox west_facing face 6819 7417 sw_gridbox(6) = surfinsw(l) 6820 7418 lw_gridbox(6) = surfinlw(l) … … 6841 7439 6842 7440 END SUBROUTINE radiation_radflux_gridbox 6843 6844 6845 !------------------------------------------------------------------------------!6846 !6847 ! Description:6848 ! ------------6849 !> Block of auxiliary subroutines:6850 !> 1. quicksort and corresponding comparison6851 !> 2. merge_and_grow_csf for implementation of "dynamical growing"6852 !> array for csf6853 !------------------------------------------------------------------------------!6854 PURE FUNCTION svf_lt(svf1,svf2) result (res)6855 TYPE (t_svf), INTENT(in) :: svf1,svf26856 LOGICAL :: res6857 IF ( svf1%isurflt < svf2%isurflt .OR. &6858 (svf1%isurflt == svf2%isurflt .AND. svf1%isurfs < svf2%isurfs) ) THEN6859 res = .TRUE.6860 ELSE6861 res = .FALSE.6862 ENDIF6863 END FUNCTION svf_lt6864 6865 6866 !-- quicksort.f -*-f90-*-6867 !-- Author: t-nissie, adaptation J.Resler6868 !-- License: GPLv36869 !-- Gist: https://gist.github.com/t-nissie/479f0f16966925fa29ea6870 RECURSIVE SUBROUTINE quicksort_svf(svfl, first, last)6871 IMPLICIT NONE6872 TYPE(t_svf), DIMENSION(:), INTENT(INOUT) :: svfl6873 INTEGER(iwp), INTENT(IN) :: first, last6874 TYPE(t_svf) :: x, t6875 INTEGER(iwp) :: i, j6876 6877 IF ( first>=last ) RETURN6878 x = svfl( (first+last) / 2 )6879 i = first6880 j = last6881 DO6882 DO while ( svf_lt(svfl(i),x) )6883 i=i+16884 ENDDO6885 DO while ( svf_lt(x,svfl(j)) )6886 j=j-16887 ENDDO6888 IF ( i >= j ) EXIT6889 t = svfl(i); svfl(i) = svfl(j); svfl(j) = t6890 i=i+16891 j=j-16892 ENDDO6893 IF ( first < i-1 ) CALL quicksort_svf(svfl, first, i-1)6894 IF ( j+1 < last ) CALL quicksort_svf(svfl, j+1, last)6895 END SUBROUTINE quicksort_svf6896 6897 6898 PURE FUNCTION csf_lt(csf1,csf2) result (res)6899 TYPE (t_csf), INTENT(in) :: csf1,csf26900 LOGICAL :: res6901 IF ( csf1%ip < csf2%ip .OR. &6902 (csf1%ip == csf2%ip .AND. csf1%itx < csf2%itx) .OR. &6903 (csf1%ip == csf2%ip .AND. csf1%itx == csf2%itx .AND. csf1%ity < csf2%ity) .OR. &6904 (csf1%ip == csf2%ip .AND. csf1%itx == csf2%itx .AND. csf1%ity == csf2%ity .AND. &6905 csf1%itz < csf2%itz) .OR. &6906 (csf1%ip == csf2%ip .AND. csf1%itx == csf2%itx .AND. csf1%ity == csf2%ity .AND. &6907 csf1%itz == csf2%itz .AND. csf1%isurfs < csf2%isurfs) ) THEN6908 res = .TRUE.6909 ELSE6910 res = .FALSE.6911 ENDIF6912 END FUNCTION csf_lt6913 6914 6915 !-- quicksort.f -*-f90-*-6916 !-- Author: t-nissie, adaptation J.Resler6917 !-- License: GPLv36918 !-- Gist: https://gist.github.com/t-nissie/479f0f16966925fa29ea6919 RECURSIVE SUBROUTINE quicksort_csf(csfl, first, last)6920 IMPLICIT NONE6921 TYPE(t_csf), DIMENSION(:), INTENT(INOUT) :: csfl6922 INTEGER(iwp), INTENT(IN) :: first, last6923 TYPE(t_csf) :: x, t6924 INTEGER(iwp) :: i, j6925 6926 IF ( first>=last ) RETURN6927 x = csfl( (first+last)/2 )6928 i = first6929 j = last6930 DO6931 DO while ( csf_lt(csfl(i),x) )6932 i=i+16933 ENDDO6934 DO while ( csf_lt(x,csfl(j)) )6935 j=j-16936 ENDDO6937 IF ( i >= j ) EXIT6938 t = csfl(i); csfl(i) = csfl(j); csfl(j) = t6939 i=i+16940 j=j-16941 ENDDO6942 IF ( first < i-1 ) CALL quicksort_csf(csfl, first, i-1)6943 IF ( j+1 < last ) CALL quicksort_csf(csfl, j+1, last)6944 END SUBROUTINE quicksort_csf6945 6946 6947 SUBROUTINE merge_and_grow_csf(newsize)6948 INTEGER(iwp), INTENT(in) :: newsize !< new array size after grow, must be >= ncsfl6949 !< or -1 to shrink to minimum6950 INTEGER(iwp) :: iread, iwrite6951 TYPE(t_csf), DIMENSION(:), POINTER :: acsfnew6952 6953 IF ( newsize == -1 ) THEN6954 !-- merge in-place6955 acsfnew => acsf6956 ELSE6957 !-- allocate new array6958 IF ( mcsf == 0 ) THEN6959 ALLOCATE( acsf1(newsize) )6960 acsfnew => acsf16961 ELSE6962 ALLOCATE( acsf2(newsize) )6963 acsfnew => acsf26964 ENDIF6965 ENDIF6966 6967 IF ( ncsfl >= 1 ) THEN6968 !-- sort csf in place (quicksort)6969 CALL quicksort_csf(acsf,1,ncsfl)6970 6971 !-- while moving to a new array, aggregate canopy sink factor records with identical box & source6972 acsfnew(1) = acsf(1)6973 iwrite = 16974 DO iread = 2, ncsfl6975 !-- here acsf(kcsf) already has values from acsf(icsf)6976 IF ( acsfnew(iwrite)%itx == acsf(iread)%itx &6977 .AND. acsfnew(iwrite)%ity == acsf(iread)%ity &6978 .AND. acsfnew(iwrite)%itz == acsf(iread)%itz &6979 .AND. acsfnew(iwrite)%isurfs == acsf(iread)%isurfs ) THEN6980 !-- We could simply take either first or second rtransp, both are valid. As a very simple heuristic about which ray6981 !-- probably passes nearer the center of the target box, we choose DIF from the entry with greater CSF, since that6982 !-- might mean that the traced beam passes longer through the canopy box.6983 IF ( acsfnew(iwrite)%rsvf < acsf(iread)%rsvf ) THEN6984 acsfnew(iwrite)%rtransp = acsf(iread)%rtransp6985 ENDIF6986 acsfnew(iwrite)%rsvf = acsfnew(iwrite)%rsvf + acsf(iread)%rsvf6987 !-- advance reading index, keep writing index6988 ELSE6989 !-- not identical, just advance and copy6990 iwrite = iwrite + 16991 acsfnew(iwrite) = acsf(iread)6992 ENDIF6993 ENDDO6994 ncsfl = iwrite6995 ENDIF6996 6997 IF ( newsize == -1 ) THEN6998 !-- allocate new array and copy shrinked data6999 IF ( mcsf == 0 ) THEN7000 ALLOCATE( acsf1(ncsfl) )7001 acsf1(1:ncsfl) = acsf2(1:ncsfl)7002 ELSE7003 ALLOCATE( acsf2(ncsfl) )7004 acsf2(1:ncsfl) = acsf1(1:ncsfl)7005 ENDIF7006 ENDIF7007 7008 !-- deallocate old array7009 IF ( mcsf == 0 ) THEN7010 mcsf = 17011 acsf => acsf17012 DEALLOCATE( acsf2 )7013 ELSE7014 mcsf = 07015 acsf => acsf27016 DEALLOCATE( acsf1 )7017 ENDIF7018 ncsfla = newsize7019 END SUBROUTINE merge_and_grow_csf7020 7021 7022 !-- quicksort.f -*-f90-*-7023 !-- Author: t-nissie, adaptation J.Resler7024 !-- License: GPLv37025 !-- Gist: https://gist.github.com/t-nissie/479f0f16966925fa29ea7026 RECURSIVE SUBROUTINE quicksort_csf2(kpcsflt, pcsflt, first, last)7027 IMPLICIT NONE7028 INTEGER(iwp), DIMENSION(:,:), INTENT(INOUT) :: kpcsflt7029 REAL(wp), DIMENSION(:,:), INTENT(INOUT) :: pcsflt7030 INTEGER(iwp), INTENT(IN) :: first, last7031 REAL(wp), DIMENSION(ndcsf) :: t27032 INTEGER(iwp), DIMENSION(kdcsf) :: x, t17033 INTEGER(iwp) :: i, j7034 7035 IF ( first>=last ) RETURN7036 x = kpcsflt(:, (first+last)/2 )7037 i = first7038 j = last7039 DO7040 DO while ( csf_lt2(kpcsflt(:,i),x) )7041 i=i+17042 ENDDO7043 DO while ( csf_lt2(x,kpcsflt(:,j)) )7044 j=j-17045 ENDDO7046 IF ( i >= j ) EXIT7047 t1 = kpcsflt(:,i); kpcsflt(:,i) = kpcsflt(:,j); kpcsflt(:,j) = t17048 t2 = pcsflt(:,i); pcsflt(:,i) = pcsflt(:,j); pcsflt(:,j) = t27049 i=i+17050 j=j-17051 ENDDO7052 IF ( first < i-1 ) CALL quicksort_csf2(kpcsflt, pcsflt, first, i-1)7053 IF ( j+1 < last ) CALL quicksort_csf2(kpcsflt, pcsflt, j+1, last)7054 END SUBROUTINE quicksort_csf27055 7056 7057 PURE FUNCTION csf_lt2(item1, item2) result(res)7058 INTEGER(iwp), DIMENSION(kdcsf), INTENT(in) :: item1, item27059 LOGICAL :: res7060 res = ( (item1(3) < item2(3)) &7061 .OR. (item1(3) == item2(3) .AND. item1(2) < item2(2)) &7062 .OR. (item1(3) == item2(3) .AND. item1(2) == item2(2) .AND. item1(1) < item2(1)) &7063 .OR. (item1(3) == item2(3) .AND. item1(2) == item2(2) .AND. item1(1) == item2(1) &7064 .AND. item1(4) < item2(4)) )7065 END FUNCTION csf_lt27066 7441 7067 7442 !------------------------------------------------------------------------------! … … 8055 8430 8056 8431 !------------------------------------------------------------------------------! 8057 !8058 8432 ! Description: 8059 8433 ! ------------ 8060 !> Subroutine writes the respectiverestart data8434 !> Subroutine writes local (subdomain) restart data 8061 8435 !------------------------------------------------------------------------------! 8062 8436 SUBROUTINE radiation_wrd_local … … 8154 8528 END SUBROUTINE radiation_wrd_local 8155 8529 8156 8157 SUBROUTINE radiation_rrd_local( i, k, nxlf, nxlc, nxl_on_file, nxrf, nxrc, & 8530 !------------------------------------------------------------------------------! 8531 ! Description: 8532 ! ------------ 8533 !> Subroutine reads local (subdomain) restart data 8534 !------------------------------------------------------------------------------! 8535 SUBROUTINE radiation_rrd_local( i, k, nxlf, nxlc, nxl_on_file, nxrf, nxrc, & 8158 8536 nxr_on_file, nynf, nync, nyn_on_file, nysf, & 8159 8537 nysc, nys_on_file, tmp_2d, tmp_3d, found ) … … 8198 8576 8199 8577 8200 SELECT CASE ( restart_string(1:length) ) 8201 8202 CASE ( 'rad_net_av' ) 8203 IF ( .NOT. ALLOCATED( rad_net_av ) ) THEN 8204 ALLOCATE( rad_net_av(nysg:nyng,nxlg:nxrg) ) 8205 ENDIF 8206 IF ( k == 1 ) READ ( 13 ) tmp_2d 8207 rad_net_av(nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = & 8208 tmp_2d(nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp) 8209 CASE ( 'rad_lw_in' ) 8210 IF ( .NOT. ALLOCATED( rad_lw_in ) ) THEN 8211 IF ( radiation_scheme == 'clear-sky' .OR. & 8212 radiation_scheme == 'constant') THEN 8213 ALLOCATE( rad_lw_in(0:0,nysg:nyng,nxlg:nxrg) ) 8214 ELSE 8215 ALLOCATE( rad_lw_in(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) 8216 ENDIF 8217 ENDIF 8218 IF ( k == 1 ) THEN 8219 IF ( radiation_scheme == 'clear-sky' .OR. & 8220 radiation_scheme == 'constant') THEN 8221 READ ( 13 ) tmp_3d2 8222 rad_lw_in(0:0,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = & 8223 tmp_3d2(0:0,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp) 8224 ELSE 8225 READ ( 13 ) tmp_3d 8226 rad_lw_in(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = & 8227 tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp) 8228 ENDIF 8229 ENDIF 8230 8231 CASE ( 'rad_lw_in_av' ) 8232 IF ( .NOT. ALLOCATED( rad_lw_in_av ) ) THEN 8233 IF ( radiation_scheme == 'clear-sky' .OR. & 8234 radiation_scheme == 'constant') THEN 8235 ALLOCATE( rad_lw_in_av(0:0,nysg:nyng,nxlg:nxrg) ) 8236 ELSE 8237 ALLOCATE( rad_lw_in_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) 8238 ENDIF 8239 ENDIF 8240 IF ( k == 1 ) THEN 8241 IF ( radiation_scheme == 'clear-sky' .OR. & 8242 radiation_scheme == 'constant') THEN 8243 READ ( 13 ) tmp_3d2 8244 rad_lw_in_av(0:0,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) =& 8245 tmp_3d2(0:0,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp) 8246 ELSE 8247 READ ( 13 ) tmp_3d 8248 rad_lw_in_av(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = & 8249 tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp) 8250 ENDIF 8251 ENDIF 8252 8253 CASE ( 'rad_lw_out' ) 8254 IF ( .NOT. ALLOCATED( rad_lw_out ) ) THEN 8255 IF ( radiation_scheme == 'clear-sky' .OR. & 8256 radiation_scheme == 'constant') THEN 8257 ALLOCATE( rad_lw_out(0:0,nysg:nyng,nxlg:nxrg) ) 8258 ELSE 8259 ALLOCATE( rad_lw_out(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) 8260 ENDIF 8261 ENDIF 8262 IF ( k == 1 ) THEN 8263 IF ( radiation_scheme == 'clear-sky' .OR. & 8264 radiation_scheme == 'constant') THEN 8265 READ ( 13 ) tmp_3d2 8266 rad_lw_out(0:0,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = & 8267 tmp_3d2(0:0,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp) 8268 ELSE 8269 READ ( 13 ) tmp_3d 8270 rad_lw_out(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = & 8271 tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp) 8272 ENDIF 8273 ENDIF 8274 8275 CASE ( 'rad_lw_out_av' ) 8276 IF ( .NOT. ALLOCATED( rad_lw_out_av ) ) THEN 8277 IF ( radiation_scheme == 'clear-sky' .OR. & 8278 radiation_scheme == 'constant') THEN 8279 ALLOCATE( rad_lw_out_av(0:0,nysg:nyng,nxlg:nxrg) ) 8280 ELSE 8281 ALLOCATE( rad_lw_out_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) 8282 ENDIF 8283 ENDIF 8284 IF ( k == 1 ) THEN 8285 IF ( radiation_scheme == 'clear-sky' .OR. & 8286 radiation_scheme == 'constant') THEN 8287 READ ( 13 ) tmp_3d2 8288 rad_lw_out_av(0:0,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) & 8289 = tmp_3d2(0:0,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp) 8290 ELSE 8291 READ ( 13 ) tmp_3d 8292 rad_lw_out_av(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = & 8293 tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp) 8294 ENDIF 8295 ENDIF 8296 8297 CASE ( 'rad_lw_cs_hr' ) 8298 IF ( .NOT. ALLOCATED( rad_lw_cs_hr ) ) THEN 8299 ALLOCATE( rad_lw_cs_hr(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) 8300 ENDIF 8301 IF ( k == 1 ) READ ( 13 ) tmp_3d 8302 rad_lw_cs_hr(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = & 8303 tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp) 8304 8305 CASE ( 'rad_lw_cs_hr_av' ) 8306 IF ( .NOT. ALLOCATED( rad_lw_cs_hr_av ) ) THEN 8307 ALLOCATE( rad_lw_cs_hr_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) 8308 ENDIF 8309 IF ( k == 1 ) READ ( 13 ) tmp_3d 8310 rad_lw_cs_hr_av(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = & 8311 tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp) 8312 8313 CASE ( 'rad_lw_hr' ) 8314 IF ( .NOT. ALLOCATED( rad_lw_hr ) ) THEN 8315 ALLOCATE( rad_lw_hr(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) 8316 ENDIF 8317 IF ( k == 1 ) READ ( 13 ) tmp_3d 8318 rad_lw_hr(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = & 8319 tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp) 8320 8321 CASE ( 'rad_lw_hr_av' ) 8322 IF ( .NOT. ALLOCATED( rad_lw_hr_av ) ) THEN 8323 ALLOCATE( rad_lw_hr_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) 8324 ENDIF 8325 IF ( k == 1 ) READ ( 13 ) tmp_3d 8326 rad_lw_hr_av(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = & 8327 tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp) 8328 8329 CASE ( 'rad_sw_in' ) 8330 IF ( .NOT. ALLOCATED( rad_sw_in ) ) THEN 8331 IF ( radiation_scheme == 'clear-sky' .OR. & 8332 radiation_scheme == 'constant') THEN 8333 ALLOCATE( rad_sw_in(0:0,nysg:nyng,nxlg:nxrg) ) 8334 ELSE 8335 ALLOCATE( rad_sw_in(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) 8336 ENDIF 8337 ENDIF 8338 IF ( k == 1 ) THEN 8339 IF ( radiation_scheme == 'clear-sky' .OR. & 8340 radiation_scheme == 'constant') THEN 8341 READ ( 13 ) tmp_3d2 8342 rad_sw_in(0:0,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = & 8343 tmp_3d2(0:0,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp) 8344 ELSE 8345 READ ( 13 ) tmp_3d 8346 rad_sw_in(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = & 8347 tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp) 8348 ENDIF 8349 ENDIF 8350 8351 CASE ( 'rad_sw_in_av' ) 8352 IF ( .NOT. ALLOCATED( rad_sw_in_av ) ) THEN 8353 IF ( radiation_scheme == 'clear-sky' .OR. & 8354 radiation_scheme == 'constant') THEN 8355 ALLOCATE( rad_sw_in_av(0:0,nysg:nyng,nxlg:nxrg) ) 8356 ELSE 8357 ALLOCATE( rad_sw_in_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) 8358 ENDIF 8359 ENDIF 8360 IF ( k == 1 ) THEN 8361 IF ( radiation_scheme == 'clear-sky' .OR. & 8362 radiation_scheme == 'constant') THEN 8363 READ ( 13 ) tmp_3d2 8364 rad_sw_in_av(0:0,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) =& 8365 tmp_3d2(0:0,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp) 8366 ELSE 8367 READ ( 13 ) tmp_3d 8368 rad_sw_in_av(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = & 8369 tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp) 8370 ENDIF 8371 ENDIF 8372 8373 CASE ( 'rad_sw_out' ) 8374 IF ( .NOT. ALLOCATED( rad_sw_out ) ) THEN 8375 IF ( radiation_scheme == 'clear-sky' .OR. & 8376 radiation_scheme == 'constant') THEN 8377 ALLOCATE( rad_sw_out(0:0,nysg:nyng,nxlg:nxrg) ) 8378 ELSE 8379 ALLOCATE( rad_sw_out(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) 8380 ENDIF 8381 ENDIF 8382 IF ( k == 1 ) THEN 8383 IF ( radiation_scheme == 'clear-sky' .OR. & 8384 radiation_scheme == 'constant') THEN 8385 READ ( 13 ) tmp_3d2 8386 rad_sw_out(0:0,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = & 8387 tmp_3d2(0:0,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp) 8388 ELSE 8389 READ ( 13 ) tmp_3d 8390 rad_sw_out(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = & 8391 tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp) 8392 ENDIF 8393 ENDIF 8394 8395 CASE ( 'rad_sw_out_av' ) 8396 IF ( .NOT. ALLOCATED( rad_sw_out_av ) ) THEN 8397 IF ( radiation_scheme == 'clear-sky' .OR. & 8398 radiation_scheme == 'constant') THEN 8399 ALLOCATE( rad_sw_out_av(0:0,nysg:nyng,nxlg:nxrg) ) 8400 ELSE 8401 ALLOCATE( rad_sw_out_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) 8402 ENDIF 8403 ENDIF 8404 IF ( k == 1 ) THEN 8405 IF ( radiation_scheme == 'clear-sky' .OR. & 8406 radiation_scheme == 'constant') THEN 8407 READ ( 13 ) tmp_3d2 8408 rad_sw_out_av(0:0,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) & 8409 = tmp_3d2(0:0,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp) 8410 ELSE 8411 READ ( 13 ) tmp_3d 8412 rad_sw_out_av(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = & 8413 tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp) 8414 ENDIF 8415 ENDIF 8416 8417 CASE ( 'rad_sw_cs_hr' ) 8418 IF ( .NOT. ALLOCATED( rad_sw_cs_hr ) ) THEN 8419 ALLOCATE( rad_sw_cs_hr(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) 8420 ENDIF 8421 IF ( k == 1 ) READ ( 13 ) tmp_3d 8422 rad_sw_cs_hr(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = & 8423 tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp) 8424 8425 CASE ( 'rad_sw_cs_hr_av' ) 8426 IF ( .NOT. ALLOCATED( rad_sw_cs_hr_av ) ) THEN 8427 ALLOCATE( rad_sw_cs_hr_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) 8428 ENDIF 8429 IF ( k == 1 ) READ ( 13 ) tmp_3d 8430 rad_sw_cs_hr_av(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = & 8431 tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp) 8432 8433 CASE ( 'rad_sw_hr' ) 8434 IF ( .NOT. ALLOCATED( rad_sw_hr ) ) THEN 8435 ALLOCATE( rad_sw_hr(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) 8436 ENDIF 8437 IF ( k == 1 ) READ ( 13 ) tmp_3d 8438 rad_sw_hr(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = & 8439 tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp) 8440 8441 CASE ( 'rad_sw_hr_av' ) 8442 IF ( .NOT. ALLOCATED( rad_sw_hr_av ) ) THEN 8443 ALLOCATE( rad_sw_hr_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) 8444 ENDIF 8445 IF ( k == 1 ) READ ( 13 ) tmp_3d 8446 rad_lw_hr_av(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = & 8447 tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp) 8448 8449 CASE DEFAULT 8450 8451 found = .FALSE. 8452 8453 END SELECT 8454 8578 SELECT CASE ( restart_string(1:length) ) 8579 8580 CASE ( 'rad_net_av' ) 8581 IF ( .NOT. ALLOCATED( rad_net_av ) ) THEN 8582 ALLOCATE( rad_net_av(nysg:nyng,nxlg:nxrg) ) 8583 ENDIF 8584 IF ( k == 1 ) READ ( 13 ) tmp_2d 8585 rad_net_av(nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = & 8586 tmp_2d(nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp) 8587 CASE ( 'rad_lw_in' ) 8588 IF ( .NOT. ALLOCATED( rad_lw_in ) ) THEN 8589 IF ( radiation_scheme == 'clear-sky' .OR. & 8590 radiation_scheme == 'constant') THEN 8591 ALLOCATE( rad_lw_in(0:0,nysg:nyng,nxlg:nxrg) ) 8592 ELSE 8593 ALLOCATE( rad_lw_in(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) 8594 ENDIF 8595 ENDIF 8596 IF ( k == 1 ) THEN 8597 IF ( radiation_scheme == 'clear-sky' .OR. & 8598 radiation_scheme == 'constant') THEN 8599 READ ( 13 ) tmp_3d2 8600 rad_lw_in(0:0,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = & 8601 tmp_3d2(0:0,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp) 8602 ELSE 8603 READ ( 13 ) tmp_3d 8604 rad_lw_in(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = & 8605 tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp) 8606 ENDIF 8607 ENDIF 8608 8609 CASE ( 'rad_lw_in_av' ) 8610 IF ( .NOT. ALLOCATED( rad_lw_in_av ) ) THEN 8611 IF ( radiation_scheme == 'clear-sky' .OR. & 8612 radiation_scheme == 'constant') THEN 8613 ALLOCATE( rad_lw_in_av(0:0,nysg:nyng,nxlg:nxrg) ) 8614 ELSE 8615 ALLOCATE( rad_lw_in_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) 8616 ENDIF 8617 ENDIF 8618 IF ( k == 1 ) THEN 8619 IF ( radiation_scheme == 'clear-sky' .OR. & 8620 radiation_scheme == 'constant') THEN 8621 READ ( 13 ) tmp_3d2 8622 rad_lw_in_av(0:0,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) =& 8623 tmp_3d2(0:0,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp) 8624 ELSE 8625 READ ( 13 ) tmp_3d 8626 rad_lw_in_av(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = & 8627 tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp) 8628 ENDIF 8629 ENDIF 8630 8631 CASE ( 'rad_lw_out' ) 8632 IF ( .NOT. ALLOCATED( rad_lw_out ) ) THEN 8633 IF ( radiation_scheme == 'clear-sky' .OR. & 8634 radiation_scheme == 'constant') THEN 8635 ALLOCATE( rad_lw_out(0:0,nysg:nyng,nxlg:nxrg) ) 8636 ELSE 8637 ALLOCATE( rad_lw_out(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) 8638 ENDIF 8639 ENDIF 8640 IF ( k == 1 ) THEN 8641 IF ( radiation_scheme == 'clear-sky' .OR. & 8642 radiation_scheme == 'constant') THEN 8643 READ ( 13 ) tmp_3d2 8644 rad_lw_out(0:0,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = & 8645 tmp_3d2(0:0,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp) 8646 ELSE 8647 READ ( 13 ) tmp_3d 8648 rad_lw_out(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = & 8649 tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp) 8650 ENDIF 8651 ENDIF 8652 8653 CASE ( 'rad_lw_out_av' ) 8654 IF ( .NOT. ALLOCATED( rad_lw_out_av ) ) THEN 8655 IF ( radiation_scheme == 'clear-sky' .OR. & 8656 radiation_scheme == 'constant') THEN 8657 ALLOCATE( rad_lw_out_av(0:0,nysg:nyng,nxlg:nxrg) ) 8658 ELSE 8659 ALLOCATE( rad_lw_out_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) 8660 ENDIF 8661 ENDIF 8662 IF ( k == 1 ) THEN 8663 IF ( radiation_scheme == 'clear-sky' .OR. & 8664 radiation_scheme == 'constant') THEN 8665 READ ( 13 ) tmp_3d2 8666 rad_lw_out_av(0:0,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) & 8667 = tmp_3d2(0:0,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp) 8668 ELSE 8669 READ ( 13 ) tmp_3d 8670 rad_lw_out_av(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = & 8671 tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp) 8672 ENDIF 8673 ENDIF 8674 8675 CASE ( 'rad_lw_cs_hr' ) 8676 IF ( .NOT. ALLOCATED( rad_lw_cs_hr ) ) THEN 8677 ALLOCATE( rad_lw_cs_hr(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) 8678 ENDIF 8679 IF ( k == 1 ) READ ( 13 ) tmp_3d 8680 rad_lw_cs_hr(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = & 8681 tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp) 8682 8683 CASE ( 'rad_lw_cs_hr_av' ) 8684 IF ( .NOT. ALLOCATED( rad_lw_cs_hr_av ) ) THEN 8685 ALLOCATE( rad_lw_cs_hr_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) 8686 ENDIF 8687 IF ( k == 1 ) READ ( 13 ) tmp_3d 8688 rad_lw_cs_hr_av(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = & 8689 tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp) 8690 8691 CASE ( 'rad_lw_hr' ) 8692 IF ( .NOT. ALLOCATED( rad_lw_hr ) ) THEN 8693 ALLOCATE( rad_lw_hr(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) 8694 ENDIF 8695 IF ( k == 1 ) READ ( 13 ) tmp_3d 8696 rad_lw_hr(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = & 8697 tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp) 8698 8699 CASE ( 'rad_lw_hr_av' ) 8700 IF ( .NOT. ALLOCATED( rad_lw_hr_av ) ) THEN 8701 ALLOCATE( rad_lw_hr_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) 8702 ENDIF 8703 IF ( k == 1 ) READ ( 13 ) tmp_3d 8704 rad_lw_hr_av(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = & 8705 tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp) 8706 8707 CASE ( 'rad_sw_in' ) 8708 IF ( .NOT. ALLOCATED( rad_sw_in ) ) THEN 8709 IF ( radiation_scheme == 'clear-sky' .OR. & 8710 radiation_scheme == 'constant') THEN 8711 ALLOCATE( rad_sw_in(0:0,nysg:nyng,nxlg:nxrg) ) 8712 ELSE 8713 ALLOCATE( rad_sw_in(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) 8714 ENDIF 8715 ENDIF 8716 IF ( k == 1 ) THEN 8717 IF ( radiation_scheme == 'clear-sky' .OR. & 8718 radiation_scheme == 'constant') THEN 8719 READ ( 13 ) tmp_3d2 8720 rad_sw_in(0:0,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = & 8721 tmp_3d2(0:0,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp) 8722 ELSE 8723 READ ( 13 ) tmp_3d 8724 rad_sw_in(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = & 8725 tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp) 8726 ENDIF 8727 ENDIF 8728 8729 CASE ( 'rad_sw_in_av' ) 8730 IF ( .NOT. ALLOCATED( rad_sw_in_av ) ) THEN 8731 IF ( radiation_scheme == 'clear-sky' .OR. & 8732 radiation_scheme == 'constant') THEN 8733 ALLOCATE( rad_sw_in_av(0:0,nysg:nyng,nxlg:nxrg) ) 8734 ELSE 8735 ALLOCATE( rad_sw_in_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) 8736 ENDIF 8737 ENDIF 8738 IF ( k == 1 ) THEN 8739 IF ( radiation_scheme == 'clear-sky' .OR. & 8740 radiation_scheme == 'constant') THEN 8741 READ ( 13 ) tmp_3d2 8742 rad_sw_in_av(0:0,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) =& 8743 tmp_3d2(0:0,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp) 8744 ELSE 8745 READ ( 13 ) tmp_3d 8746 rad_sw_in_av(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = & 8747 tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp) 8748 ENDIF 8749 ENDIF 8750 8751 CASE ( 'rad_sw_out' ) 8752 IF ( .NOT. ALLOCATED( rad_sw_out ) ) THEN 8753 IF ( radiation_scheme == 'clear-sky' .OR. & 8754 radiation_scheme == 'constant') THEN 8755 ALLOCATE( rad_sw_out(0:0,nysg:nyng,nxlg:nxrg) ) 8756 ELSE 8757 ALLOCATE( rad_sw_out(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) 8758 ENDIF 8759 ENDIF 8760 IF ( k == 1 ) THEN 8761 IF ( radiation_scheme == 'clear-sky' .OR. & 8762 radiation_scheme == 'constant') THEN 8763 READ ( 13 ) tmp_3d2 8764 rad_sw_out(0:0,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = & 8765 tmp_3d2(0:0,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp) 8766 ELSE 8767 READ ( 13 ) tmp_3d 8768 rad_sw_out(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = & 8769 tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp) 8770 ENDIF 8771 ENDIF 8772 8773 CASE ( 'rad_sw_out_av' ) 8774 IF ( .NOT. ALLOCATED( rad_sw_out_av ) ) THEN 8775 IF ( radiation_scheme == 'clear-sky' .OR. & 8776 radiation_scheme == 'constant') THEN 8777 ALLOCATE( rad_sw_out_av(0:0,nysg:nyng,nxlg:nxrg) ) 8778 ELSE 8779 ALLOCATE( rad_sw_out_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) 8780 ENDIF 8781 ENDIF 8782 IF ( k == 1 ) THEN 8783 IF ( radiation_scheme == 'clear-sky' .OR. & 8784 radiation_scheme == 'constant') THEN 8785 READ ( 13 ) tmp_3d2 8786 rad_sw_out_av(0:0,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) & 8787 = tmp_3d2(0:0,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp) 8788 ELSE 8789 READ ( 13 ) tmp_3d 8790 rad_sw_out_av(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = & 8791 tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp) 8792 ENDIF 8793 ENDIF 8794 8795 CASE ( 'rad_sw_cs_hr' ) 8796 IF ( .NOT. ALLOCATED( rad_sw_cs_hr ) ) THEN 8797 ALLOCATE( rad_sw_cs_hr(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) 8798 ENDIF 8799 IF ( k == 1 ) READ ( 13 ) tmp_3d 8800 rad_sw_cs_hr(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = & 8801 tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp) 8802 8803 CASE ( 'rad_sw_cs_hr_av' ) 8804 IF ( .NOT. ALLOCATED( rad_sw_cs_hr_av ) ) THEN 8805 ALLOCATE( rad_sw_cs_hr_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) 8806 ENDIF 8807 IF ( k == 1 ) READ ( 13 ) tmp_3d 8808 rad_sw_cs_hr_av(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = & 8809 tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp) 8810 8811 CASE ( 'rad_sw_hr' ) 8812 IF ( .NOT. ALLOCATED( rad_sw_hr ) ) THEN 8813 ALLOCATE( rad_sw_hr(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) 8814 ENDIF 8815 IF ( k == 1 ) READ ( 13 ) tmp_3d 8816 rad_sw_hr(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = & 8817 tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp) 8818 8819 CASE ( 'rad_sw_hr_av' ) 8820 IF ( .NOT. ALLOCATED( rad_sw_hr_av ) ) THEN 8821 ALLOCATE( rad_sw_hr_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) 8822 ENDIF 8823 IF ( k == 1 ) READ ( 13 ) tmp_3d 8824 rad_lw_hr_av(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = & 8825 tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp) 8826 8827 CASE DEFAULT 8828 8829 found = .FALSE. 8830 8831 END SELECT 8455 8832 8456 8833 END SUBROUTINE radiation_rrd_local 8457 8834 8835 !------------------------------------------------------------------------------! 8836 ! Description: 8837 ! ------------ 8838 !> Subroutine writes debug information 8839 !------------------------------------------------------------------------------! 8840 SUBROUTINE radiation_write_debug_log ( message ) 8841 !> it writes debug log with time stamp 8842 CHARACTER(*) :: message 8843 CHARACTER(15) :: dtc 8844 CHARACTER(8) :: date 8845 CHARACTER(10) :: time 8846 CHARACTER(5) :: zone 8847 CALL date_and_time(date, time, zone) 8848 dtc = date(7:8)//','//time(1:2)//':'//time(3:4)//':'//time(5:10) 8849 WRITE(9,'(2A)') dtc, TRIM(message) 8850 FLUSH(9) 8851 END SUBROUTINE radiation_write_debug_log 8458 8852 8459 8853 END MODULE radiation_model_mod -
palm/trunk/SOURCE/surface_mod.f90
r2894 r2920 26 26 ! ----------------- 27 27 ! $Id$ 28 ! Correct comment for surface directions 29 ! 30 ! 2894 2018-03-15 09:17:58Z Giersch 28 31 ! Calculations of the index range of the subdomain on file which overlaps with 29 32 ! the current subdomain are already done in read_restart_data_mod, … … 420 423 421 424 TYPE (surf_type), DIMENSION(0:2), TARGET :: surf_def_h !< horizontal default surfaces (Up, Down, and Top) 422 TYPE (surf_type), DIMENSION(0:3), TARGET :: surf_def_v !< vertical default surfaces (North, South, West, East)425 TYPE (surf_type), DIMENSION(0:3), TARGET :: surf_def_v !< vertical default surfaces (North, South, East, West) 423 426 TYPE (surf_type) , TARGET :: surf_lsm_h !< horizontal natural land surfaces, so far only upward-facing 424 TYPE (surf_type), DIMENSION(0:3), TARGET :: surf_lsm_v !< vertical land surfaces (North, South, West, East)427 TYPE (surf_type), DIMENSION(0:3), TARGET :: surf_lsm_v !< vertical land surfaces (North, South, East, West) 425 428 TYPE (surf_type) , TARGET :: surf_usm_h !< horizontal urban surfaces, so far only upward-facing 426 TYPE (surf_type), DIMENSION(0:3), TARGET :: surf_usm_v !< vertical urban surfaces (North, South, West, East)429 TYPE (surf_type), DIMENSION(0:3), TARGET :: surf_usm_v !< vertical urban surfaces (North, South, East, West) 427 430 428 431 INTEGER(iwp) :: ns_h_on_file(0:2) !< total number of horizontal surfaces with the same facing, required for writing restart data -
palm/trunk/SOURCE/urban_surface_mod.f90
r2906 r2920 16 16 ! 17 17 ! Copyright 2015-2018 Czech Technical University in Prague 18 ! Copyright 2015-2018 Institute of Computer Science of the 19 ! Czech Academy of Sciences, Prague 18 20 ! Copyright 1997-2018 Leibniz Universitaet Hannover 19 21 !------------------------------------------------------------------------------! … … 26 28 ! ----------------- 27 29 ! $Id$ 30 ! Remove unused pcbl, npcbl from ONLY list 31 ! moh.hefny: 32 ! Fixed bugs introduced by new structures and by moving radiation interaction 33 ! into radiation_model_mod.f90. 34 ! Bugfix: usm data output 3D didn't respect directions 35 ! 36 ! 2906 2018-03-19 08:56:40Z Giersch 28 37 ! Local variable ids has to be initialized with a value of -1 in 29 38 ! usm_average_3d_data … … 217 226 !> Further work: 218 227 !> ------------- 219 !> 1. Reduce number of shape view factors by merging factors for distant surfaces 220 !> under shallow angles. Idea: Iteratively select the smallest shape view 221 !> factor by value (among all sources and targets) which has a similarly 222 !> oriented source neighbor (or near enough) SVF and merge them by adding 223 !> value of the smaller SVF to the larger one and deleting the smaller one. 224 !> This will allow for better scaling at higher resolutions. 225 !> 226 !> 2. Remove global arrays surfouts, surfoutl and only keep track of radiosity 228 !> 1. Remove global arrays surfouts, surfoutl and only keep track of radiosity 227 229 !> from surfaces that are visible from local surfaces (i.e. there is a SVF 228 230 !> where target is local). To do that, radiosity will be exchanged after each 229 231 !> reflection step using MPI_Alltoall instead of current MPI_Allgather. 230 232 !> 231 !> 3. Temporarily large values of surface heat flux can be observed, up to233 !> 2. Temporarily large values of surface heat flux can be observed, up to 232 234 !> 1.2 Km/s, which seem to be not realistic. 233 235 !> … … 248 250 #if ! defined( __nopointer ) 249 251 USE arrays_3d, & 250 ONLY: zu, pt, pt_1, pt_2, p, u, v, w, hyp, tend252 ONLY: hyp, zu, pt, pt_1, pt_2, p, u, v, w, hyp, tend 251 253 #endif 252 254 … … 272 274 273 275 USE date_and_time_mod, & 274 ONLY: d_seconds_year, day_of_year_init,time_utc_init276 ONLY: time_utc_init 275 277 276 278 USE grid_variables, & … … 288 290 289 291 USE plant_canopy_model_mod, & 290 ONLY: pc_heating_rate , usm_lad_rma292 ONLY: pc_heating_rate 291 293 292 294 USE radiation_model_mod, & 293 ONLY: albedo_type, radiation , calc_zenith, zenith, &295 ONLY: albedo_type, radiation_interaction, calc_zenith, zenith, & 294 296 rad_sw_in, rad_lw_in, rad_sw_out, rad_lw_out, & 295 297 sigma_sb, solar_constant, sun_direction, sun_dir_lat, & … … 297 299 force_radiation_call, surfinsw, surfinlw, surfinswdir, & 298 300 surfinswdif, surfoutsw, surfoutlw, surfins,nsvfl, svf, svfsurf, & 299 surfinl, surfinlwdif, energy_balance_surf_h, & 300 energy_balance_surf_v, rad_sw_in_dir, rad_sw_in_diff, & 301 surfinl, surfinlwdif, rad_sw_in_dir, rad_sw_in_diff, & 301 302 rad_lw_in_diff, surfouts, surfoutl, surfoutsl, surfoutll, surf, & 302 surfl, nsurfl, nsurfs, surfstart, pcbinsw, pcbinlw, pcbl, npcbl, startenergy, & 303 endenergy, nenergy, iup_u, inorth_u, isouth_u, ieast_u, iwest_u, iup_l, & 304 inorth_l, isouth_l, ieast_l, iwest_l, startsky, endsky,id, & 305 iz, iy, ix, idir, jdir, kdir, startborder, endborder, nsurf_type, nzub, nzut, & 306 isky, inorth_b,idown_a, isouth_b, ieast_b, iwest_b, nzu, pch, nsurf, & 307 iup_a, inorth_a, isouth_a, ieast_a, iwest_a, idsvf, ndsvf, & 308 idcsf, ndcsf, kdcsf, pct, startland, endland, startwall, endwall 303 surfl, nsurfl, nsurfs, surfstart, pcbinsw, pcbinlw, & 304 iup_u, inorth_u, isouth_u, ieast_u, iwest_u, iup_l, & 305 inorth_l, isouth_l, ieast_l, iwest_l, id, & 306 iz, iy, ix, idir, jdir, kdir, nsurf_type, nzub, nzut, & 307 nzu, pch, nsurf, idsvf, ndsvf, & 308 iup_a, idown_a, inorth_a, isouth_a, ieast_a, iwest_a, & 309 idcsf, ndcsf, kdcsf, pct, & 310 startland, endland, startwall, endwall, skyvf, skyvft 309 311 310 312 USE statistics, & … … 322 324 LOGICAL :: force_radiation_call_l = .FALSE. !< flag parameter for unscheduled radiation model calls 323 325 LOGICAL :: indoor_model = .FALSE. !< whether to use the indoor model 324 325 326 LOGICAL :: read_wall_temp_3d = .FALSE. 327 328 326 329 INTEGER(iwp) :: building_type = 1 !< default building type (preleminary setting) 327 330 INTEGER(iwp) :: land_category = 2 !< default category for land surface 328 331 INTEGER(iwp) :: wall_category = 2 !< default category for wall surface over pedestrian zone 329 INTEGER(iwp) :: pedestr ant_category = 2 !< default category for wall surface in pedestrian zone332 INTEGER(iwp) :: pedestrian_category = 2 !< default category for wall surface in pedestrian zone 330 333 INTEGER(iwp) :: roof_category = 2 !< default category for root surface 331 334 REAL(wp) :: roughness_concrete = 0.001_wp !< roughness length of average concrete surface 332 335 ! 333 336 !-- Indices of input attributes for (above) ground floor level … … 380 383 REAL(wp) :: roof_height_limit = 4._wp !< height for distinguish between land surfaces and roofs 381 384 REAL(wp) :: ground_floor_level = 4.0_wp !< default ground floor level 382 REAL(wp) :: ra_horiz_coef = 5.0_wp !< mysterious coefficient for correction of overestimation 383 !< of r_a for horizontal surfaces -> TODO 385 384 386 385 387 CHARACTER(37), DIMENSION(0:6), PARAMETER :: building_type_name = (/ & … … 524 526 !-- anthropogenic heat sources 525 527 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 526 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: aheat !< daily average of anthropogenic heat (W/m2) 527 REAL(wp), DIMENSION(:), ALLOCATABLE :: aheatprof !< diurnal profile of anthropogenic heat 528 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: aheat !< daily average of anthropogenic heat (W/m2) 529 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: aheatprof !< diurnal profiles of anthropogenic heat for particular layers 530 INTEGER(wp) :: naheatlayers = 1 !< number of layers of anthropogenic heat 528 531 529 532 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! … … 547 550 ! REAL(wp), DIMENSION(nzb_wall:nzt_wall) :: zwn_default_green = (/0.33_wp, 0.66_wp, 1.0_wp /) 548 551 549 550 REAL(wp) :: wall_inner_temperature = 296.0_wp !< temperature of the inner wall surface (~23degrees C) (K)551 REAL(wp) :: roof_inner_temperature = 296.0_wp !< temperature of the inner roof surface (~23degrees C) (K)552 REAL(wp) :: soil_inner_temperature = 283.0_wp !< temperature of the deep soil (~10degrees C) (K)553 REAL(wp) :: window_inner_temperature = 296.0_wp !< temperature of the inner window surface (~23degrees C) (K)552 553 REAL(wp) :: wall_inner_temperature = 295.0_wp !< temperature of the inner wall surface (~22 degrees C) (K) 554 REAL(wp) :: roof_inner_temperature = 295.0_wp !< temperature of the inner roof surface (~22 degrees C) (K) 555 REAL(wp) :: soil_inner_temperature = 288.0_wp !< temperature of the deep soil (~15 degrees C) (K) 556 REAL(wp) :: window_inner_temperature = 295.0_wp !< temperature of the inner window surface (~22 degrees C) (K) 554 557 555 558 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! … … 674 677 !-- albedo, emissivity, lambda_surf, roughness, thickness, volumetric heat capacity, thermal conductivity 675 678 INTEGER(iwp) :: n_surface_types !< number of the wall type categories 676 INTEGER(iwp), PARAMETER :: n_surface_params = 8!< number of parameters for each type of the wall679 INTEGER(iwp), PARAMETER :: n_surface_params = 9 !< number of parameters for each type of the wall 677 680 INTEGER(iwp), PARAMETER :: ialbedo = 1 !< albedo of the surface 678 681 INTEGER(iwp), PARAMETER :: iemiss = 2 !< emissivity of the surface 679 INTEGER(iwp), PARAMETER :: ilambdas = 3 !< heat conductivity λS between air and surface ( W mâ2 Kâ1 ) 680 INTEGER(iwp), PARAMETER :: irough = 4 !< roughness relative to concrete 681 INTEGER(iwp), PARAMETER :: icsurf = 5 !< Surface skin layer heat capacity (J mâ2 Kâ1 ) 682 INTEGER(iwp), PARAMETER :: ithick = 6 !< thickness of the surface (wall, roof, land) ( m ) 683 INTEGER(iwp), PARAMETER :: irhoC = 7 !< volumetric heat capacity rho*C of the material ( J mâ3 Kâ1 ) 684 INTEGER(iwp), PARAMETER :: ilambdah = 8 !< thermal conductivity λH of the wall (W mâ1 Kâ1 ) 682 INTEGER(iwp), PARAMETER :: ilambdas = 3 !< heat conductivity lambda S between surface and material ( W m-2 K-1 ) 683 INTEGER(iwp), PARAMETER :: irough = 4 !< roughness length z0 for movements 684 INTEGER(iwp), PARAMETER :: iroughh = 5 !< roughness length z0h for scalars (heat, humidity,...) 685 INTEGER(iwp), PARAMETER :: icsurf = 6 !< Surface skin layer heat capacity (J m-2 K-1 ) 686 INTEGER(iwp), PARAMETER :: ithick = 7 !< thickness of the surface (wall, roof, land) ( m ) 687 INTEGER(iwp), PARAMETER :: irhoC = 8 !< volumetric heat capacity rho*C of the material ( J m-3 K-1 ) 688 INTEGER(iwp), PARAMETER :: ilambdah = 9 !< thermal conductivity lambda H of the wall (W m-1 K-1 ) 685 689 CHARACTER(12), DIMENSION(:), ALLOCATABLE :: surface_type_names !< names of wall types (used only for reports) 686 690 INTEGER(iwp), DIMENSION(:), ALLOCATABLE :: surface_type_codes !< codes of wall types … … 760 764 !-- Public functions 761 765 PUBLIC usm_boundary_condition, usm_check_parameters, usm_init_urban_surface,& 762 usm_rrd_local, 763 usm_surface_energy_balance, usm_material_heat_model, 764 usm_swap_timelevel, usm_check_data_output, usm_average_3d_data, 765 usm_data_output_3d, usm_define_netcdf_grid, usm_parin, 766 usm_rrd_local, & 767 usm_surface_energy_balance, usm_material_heat_model, & 768 usm_swap_timelevel, usm_check_data_output, usm_average_3d_data, & 769 usm_data_output_3d, usm_define_netcdf_grid, usm_parin, & 766 770 usm_wrd_local, usm_allocate_surface 767 771 768 772 !-- Public parameters, constants and initial values 769 PUBLIC usm_anthropogenic_heat, usm_material_model, ra_horiz_coef,&773 PUBLIC usm_anthropogenic_heat, usm_material_model, & 770 774 usm_green_heat_model, usm_temperature_near_surface 771 775 … … 1175 1179 CHARACTER (len=*), INTENT(IN) :: variable 1176 1180 1177 INTEGER(iwp) :: i, j, k, l, m, ids, i wl,istat1181 INTEGER(iwp) :: i, j, k, l, m, ids, idsint, iwl, istat 1178 1182 CHARACTER (len=varnamelength) :: var, surfid 1179 1183 INTEGER(iwp), PARAMETER :: nd = 5 1180 1184 CHARACTER(len=6), DIMENSION(0:nd-1), PARAMETER :: dirname = (/ '_roof ', '_south', '_north', '_west ', '_east ' /) 1185 INTEGER(iwp), DIMENSION(0:nd-1), PARAMETER :: dirint = (/ iup_u, isouth_u, inorth_u, iwest_u, ieast_u /) 1181 1186 1182 1187 !-- find the real name of the variable … … 1188 1193 IF ( var(k-j+1:k) == dirname(i) ) THEN 1189 1194 ids = i 1195 idsint = dirint(ids) 1190 1196 var = var(:k-j) 1191 1197 EXIT … … 1245 1251 CASE ( 'usm_rad_insw' ) 1246 1252 !-- array of sw radiation falling to surface after i-th reflection 1247 IF ( .NOT. ALLOCATED(surf _usm_h%surfinsw_av) ) THEN1248 ALLOCATE( surf _usm_h%surfinsw_av(1:surf_usm_h%ns) )1249 surf _usm_h%surfinsw_av = 0.0_wp1253 IF ( .NOT. ALLOCATED(surfinsw_av) ) THEN 1254 ALLOCATE( surfinsw_av(nsurfl) ) 1255 surfinsw_av = 0.0_wp 1250 1256 ENDIF 1251 DO l = 0, 3 1252 IF ( .NOT. ALLOCATED(surf_usm_v(l)%surfinsw_av) ) THEN 1253 ALLOCATE( surf_usm_v(l)%surfinsw_av(1:surf_usm_v(l)%ns) ) 1254 surf_usm_v(l)%surfinsw_av = 0.0_wp 1255 ENDIF 1256 ENDDO 1257 1257 1258 1258 CASE ( 'usm_rad_inlw' ) 1259 1259 !-- array of lw radiation falling to surface after i-th reflection 1260 IF ( .NOT. ALLOCATED(surf _usm_h%surfinlw_av) ) THEN1261 ALLOCATE( surf _usm_h%surfinlw_av(1:surf_usm_h%ns) )1262 surf _usm_h%surfinlw_av = 0.0_wp1260 IF ( .NOT. ALLOCATED(surfinlw_av) ) THEN 1261 ALLOCATE( surfinlw_av(nsurfl) ) 1262 surfinlw_av = 0.0_wp 1263 1263 ENDIF 1264 DO l = 0, 31265 IF ( .NOT. ALLOCATED(surf_usm_v(l)%surfinlw_av) ) THEN1266 ALLOCATE( surf_usm_v(l)%surfinlw_av(1:surf_usm_v(l)%ns) )1267 surf_usm_v(l)%surfinlw_av = 0.0_wp1268 ENDIF1269 ENDDO1270 1264 1271 1265 CASE ( 'usm_rad_inswdir' ) 1272 1266 !-- array of direct sw radiation falling to surface from sun 1273 1267 IF ( .NOT. ALLOCATED(surfinswdir_av) ) THEN 1274 ALLOCATE( surfinswdir_av( startenergy:endenergy) )1268 ALLOCATE( surfinswdir_av(nsurfl) ) 1275 1269 surfinswdir_av = 0.0_wp 1276 1270 ENDIF … … 1279 1273 !-- array of difusion sw radiation falling to surface from sky and borders of the domain 1280 1274 IF ( .NOT. ALLOCATED(surfinswdif_av) ) THEN 1281 ALLOCATE( surfinswdif_av( startenergy:endenergy) )1275 ALLOCATE( surfinswdif_av(nsurfl) ) 1282 1276 surfinswdif_av = 0.0_wp 1283 1277 ENDIF … … 1286 1280 !-- array of sw radiation falling to surface from reflections 1287 1281 IF ( .NOT. ALLOCATED(surfinswref_av) ) THEN 1288 ALLOCATE( surfinswref_av( startenergy:endenergy) )1282 ALLOCATE( surfinswref_av(nsurfl) ) 1289 1283 surfinswref_av = 0.0_wp 1290 1284 ENDIF … … 1293 1287 !-- array of sw radiation falling to surface after i-th reflection 1294 1288 IF ( .NOT. ALLOCATED(surfinlwdif_av) ) THEN 1295 ALLOCATE( surfinlwdif_av( startenergy:endenergy) )1289 ALLOCATE( surfinlwdif_av(nsurfl) ) 1296 1290 surfinlwdif_av = 0.0_wp 1297 1291 ENDIF … … 1300 1294 !-- array of lw radiation falling to surface from reflections 1301 1295 IF ( .NOT. ALLOCATED(surfinlwref_av) ) THEN 1302 ALLOCATE( surfinlwref_av( startenergy:endenergy) )1296 ALLOCATE( surfinlwref_av(nsurfl) ) 1303 1297 surfinlwref_av = 0.0_wp 1304 1298 ENDIF … … 1307 1301 !-- array of sw radiation emitted from surface after i-th reflection 1308 1302 IF ( .NOT. ALLOCATED(surfoutsw_av) ) THEN 1309 ALLOCATE( surfoutsw_av( startenergy:endenergy) )1303 ALLOCATE( surfoutsw_av(nsurfl) ) 1310 1304 surfoutsw_av = 0.0_wp 1311 1305 ENDIF … … 1314 1308 !-- array of lw radiation emitted from surface after i-th reflection 1315 1309 IF ( .NOT. ALLOCATED(surfoutlw_av) ) THEN 1316 ALLOCATE( surfoutlw_av( startenergy:endenergy) )1310 ALLOCATE( surfoutlw_av(nsurfl) ) 1317 1311 surfoutlw_av = 0.0_wp 1318 1312 ENDIF … … 1320 1314 !-- array of residua of sw radiation absorbed in surface after last reflection 1321 1315 IF ( .NOT. ALLOCATED(surfins_av) ) THEN 1322 ALLOCATE( surfins_av( startenergy:endenergy) )1316 ALLOCATE( surfins_av(nsurfl) ) 1323 1317 surfins_av = 0.0_wp 1324 1318 ENDIF … … 1327 1321 !-- array of residua of lw radiation absorbed in surface after last reflection 1328 1322 IF ( .NOT. ALLOCATED(surfinl_av) ) THEN 1329 ALLOCATE( surfinl_av( startenergy:endenergy) )1323 ALLOCATE( surfinl_av(nsurfl) ) 1330 1324 surfinl_av = 0.0_wp 1331 1325 ENDIF … … 1544 1538 CASE ( 'usm_rad_insw' ) 1545 1539 !-- array of sw radiation falling to surface after i-th reflection 1546 DO l = startenergy, endenergy1547 IF ( surfl(id,l) == ids ) THEN1540 DO l = 1, nsurfl 1541 IF ( surfl(id,l) == idsint ) THEN 1548 1542 surfinsw_av(l) = surfinsw_av(l) + surfinsw(l) 1549 1543 ENDIF … … 1552 1546 CASE ( 'usm_rad_inlw' ) 1553 1547 !-- array of lw radiation falling to surface after i-th reflection 1554 DO l = startenergy, endenergy1555 IF ( surfl(id,l) == ids ) THEN1548 DO l = 1, nsurfl 1549 IF ( surfl(id,l) == idsint ) THEN 1556 1550 surfinlw_av(l) = surfinlw_av(l) + surfinlw(l) 1557 1551 ENDIF … … 1560 1554 CASE ( 'usm_rad_inswdir' ) 1561 1555 !-- array of direct sw radiation falling to surface from sun 1562 DO l = startenergy, endenergy1563 IF ( surfl(id,l) == ids ) THEN1556 DO l = 1, nsurfl 1557 IF ( surfl(id,l) == idsint ) THEN 1564 1558 surfinswdir_av(l) = surfinswdir_av(l) + surfinswdir(l) 1565 1559 ENDIF … … 1568 1562 CASE ( 'usm_rad_inswdif' ) 1569 1563 !-- array of difusion sw radiation falling to surface from sky and borders of the domain 1570 DO l = startenergy, endenergy1571 IF ( surfl(id,l) == ids ) THEN1564 DO l = 1, nsurfl 1565 IF ( surfl(id,l) == idsint ) THEN 1572 1566 surfinswdif_av(l) = surfinswdif_av(l) + surfinswdif(l) 1573 1567 ENDIF … … 1576 1570 CASE ( 'usm_rad_inswref' ) 1577 1571 !-- array of sw radiation falling to surface from reflections 1578 DO l = startenergy, endenergy1579 IF ( surfl(id,l) == ids ) THEN1572 DO l = 1, nsurfl 1573 IF ( surfl(id,l) == idsint ) THEN 1580 1574 surfinswref_av(l) = surfinswref_av(l) + surfinsw(l) - & 1581 1575 surfinswdir(l) - surfinswdif(l) … … 1586 1580 CASE ( 'usm_rad_inlwdif' ) 1587 1581 !-- array of sw radiation falling to surface after i-th reflection 1588 DO l = startenergy, endenergy 1589 IF ( surfl(id,l) == ids ) THEN 1590 surfinswref_av(l) = surfinswref_av(l) + surfinsw(l) - & 1591 surfinswdir(l) - surfinswdif(l) 1582 DO l = 1, nsurfl 1583 IF ( surfl(id,l) == idsint ) THEN 1584 surfinlwdif_av(l) = surfinlwdif_av(l) + surfinlwdif(l) 1592 1585 ENDIF 1593 1586 ENDDO … … 1595 1588 CASE ( 'usm_rad_inlwref' ) 1596 1589 !-- array of lw radiation falling to surface from reflections 1597 DO l = startenergy, endenergy 1598 IF ( surfl(id,l) == ids ) THEN 1599 surfinlwdif_av(l) = surfinlwdif_av(l) + surfinlwdif(l) 1590 DO l = 1, nsurfl 1591 IF ( surfl(id,l) == idsint ) THEN 1592 surfinlwref_av(l) = surfinlwref_av(l) + & 1593 surfinlw(l) - surfinlwdif(l) 1600 1594 ENDIF 1601 1595 ENDDO … … 1603 1597 CASE ( 'usm_rad_outsw' ) 1604 1598 !-- array of sw radiation emitted from surface after i-th reflection 1605 DO l = startenergy, endenergy 1606 IF ( surfl(id,l) == ids ) THEN 1607 surfinlwref_av(l) = surfinlwref_av(l) + & 1608 surfinlw(l) - surfinlwdif(l) 1599 DO l = 1, nsurfl 1600 IF ( surfl(id,l) == idsint ) THEN 1601 surfoutsw_av(l) = surfoutsw_av(l) + surfoutsw(l) 1609 1602 ENDIF 1610 1603 ENDDO … … 1612 1605 CASE ( 'usm_rad_outlw' ) 1613 1606 !-- array of lw radiation emitted from surface after i-th reflection 1614 DO l = startenergy, endenergy1615 IF ( surfl(id,l) == ids ) THEN1616 surfout sw_av(l) = surfoutsw_av(l) + surfoutsw(l)1607 DO l = 1, nsurfl 1608 IF ( surfl(id,l) == idsint ) THEN 1609 surfoutlw_av(l) = surfoutlw_av(l) + surfoutlw(l) 1617 1610 ENDIF 1618 1611 ENDDO … … 1620 1613 CASE ( 'usm_rad_ressw' ) 1621 1614 !-- array of residua of sw radiation absorbed in surface after last reflection 1622 DO l = startenergy, endenergy1623 IF ( surfl(id,l) == ids ) THEN1624 surf outlw_av(l) = surfoutlw_av(l) + surfoutlw(l)1615 DO l = 1, nsurfl 1616 IF ( surfl(id,l) == idsint ) THEN 1617 surfins_av(l) = surfins_av(l) + surfins(l) 1625 1618 ENDIF 1626 1619 ENDDO … … 1628 1621 CASE ( 'usm_rad_reslw' ) 1629 1622 !-- array of residua of lw radiation absorbed in surface after last reflection 1630 DO l = startenergy, endenergy1631 IF ( surfl(id,l) == ids ) THEN1632 surfin s_av(l) = surfins_av(l) + surfins(l)1623 DO l = 1, nsurfl 1624 IF ( surfl(id,l) == idsint ) THEN 1625 surfinl_av(l) = surfinl_av(l) + surfinl(l) 1633 1626 ENDIF 1634 1627 ENDDO … … 1871 1864 CASE ( 'usm_rad_insw' ) 1872 1865 !-- array of sw radiation falling to surface after i-th reflection 1873 DO l = startenergy, endenergy1874 IF ( surfl(id,l) == ids ) THEN1866 DO l = 1, nsurfl 1867 IF ( surfl(id,l) == idsint ) THEN 1875 1868 surfinsw_av(l) = surfinsw_av(l) / REAL( average_count_3d, kind=wp ) 1876 1869 ENDIF … … 1879 1872 CASE ( 'usm_rad_inlw' ) 1880 1873 !-- array of lw radiation falling to surface after i-th reflection 1881 DO l = startenergy, endenergy1882 IF ( surfl(id,l) == ids ) THEN1874 DO l = 1, nsurfl 1875 IF ( surfl(id,l) == idsint ) THEN 1883 1876 surfinlw_av(l) = surfinlw_av(l) / REAL( average_count_3d, kind=wp ) 1884 1877 ENDIF … … 1887 1880 CASE ( 'usm_rad_inswdir' ) 1888 1881 !-- array of direct sw radiation falling to surface from sun 1889 DO l = startenergy, endenergy1890 IF ( surfl(id,l) == ids ) THEN1882 DO l = 1, nsurfl 1883 IF ( surfl(id,l) == idsint ) THEN 1891 1884 surfinswdir_av(l) = surfinswdir_av(l) / REAL( average_count_3d, kind=wp ) 1892 1885 ENDIF … … 1895 1888 CASE ( 'usm_rad_inswdif' ) 1896 1889 !-- array of difusion sw radiation falling to surface from sky and borders of the domain 1897 DO l = startenergy, endenergy1898 IF ( surfl(id,l) == ids ) THEN1890 DO l = 1, nsurfl 1891 IF ( surfl(id,l) == idsint ) THEN 1899 1892 surfinswdif_av(l) = surfinswdif_av(l) / REAL( average_count_3d, kind=wp ) 1900 1893 ENDIF … … 1903 1896 CASE ( 'usm_rad_inswref' ) 1904 1897 !-- array of sw radiation falling to surface from reflections 1905 DO l = startenergy, endenergy1906 IF ( surfl(id,l) == ids ) THEN1898 DO l = 1, nsurfl 1899 IF ( surfl(id,l) == idsint ) THEN 1907 1900 surfinswref_av(l) = surfinswref_av(l) / REAL( average_count_3d, kind=wp ) 1908 1901 ENDIF … … 1911 1904 CASE ( 'usm_rad_inlwdif' ) 1912 1905 !-- array of sw radiation falling to surface after i-th reflection 1913 DO l = startenergy, endenergy1914 IF ( surfl(id,l) == ids ) THEN1906 DO l = 1, nsurfl 1907 IF ( surfl(id,l) == idsint ) THEN 1915 1908 surfinlwdif_av(l) = surfinlwdif_av(l) / REAL( average_count_3d, kind=wp ) 1916 1909 ENDIF … … 1919 1912 CASE ( 'usm_rad_inlwref' ) 1920 1913 !-- array of lw radiation falling to surface from reflections 1921 DO l = startenergy, endenergy1922 IF ( surfl(id,l) == ids ) THEN1914 DO l = 1, nsurfl 1915 IF ( surfl(id,l) == idsint ) THEN 1923 1916 surfinlwref_av(l) = surfinlwref_av(l) / REAL( average_count_3d, kind=wp ) 1924 1917 ENDIF … … 1927 1920 CASE ( 'usm_rad_outsw' ) 1928 1921 !-- array of sw radiation emitted from surface after i-th reflection 1929 DO l = startenergy, endenergy1930 IF ( surfl(id,l) == ids ) THEN1922 DO l = 1, nsurfl 1923 IF ( surfl(id,l) == idsint ) THEN 1931 1924 surfoutsw_av(l) = surfoutsw_av(l) / REAL( average_count_3d, kind=wp ) 1932 1925 ENDIF … … 1935 1928 CASE ( 'usm_rad_outlw' ) 1936 1929 !-- array of lw radiation emitted from surface after i-th reflection 1937 DO l = startenergy, endenergy1938 IF ( surfl(id,l) == ids ) THEN1930 DO l = 1, nsurfl 1931 IF ( surfl(id,l) == idsint ) THEN 1939 1932 surfoutlw_av(l) = surfoutlw_av(l) / REAL( average_count_3d, kind=wp ) 1940 1933 ENDIF … … 1943 1936 CASE ( 'usm_rad_ressw' ) 1944 1937 !-- array of residua of sw radiation absorbed in surface after last reflection 1945 DO l = startenergy, endenergy1946 IF ( surfl(id,l) == ids ) THEN1938 DO l = 1, nsurfl 1939 IF ( surfl(id,l) == idsint ) THEN 1947 1940 surfins_av(l) = surfins_av(l) / REAL( average_count_3d, kind=wp ) 1948 1941 ENDIF … … 1951 1944 CASE ( 'usm_rad_reslw' ) 1952 1945 !-- array of residua of lw radiation absorbed in surface after last reflection 1953 DO l = startenergy, endenergy1954 IF ( surfl(id,l) == ids ) THEN1946 DO l = 1, nsurfl 1947 IF ( surfl(id,l) == idsint ) THEN 1955 1948 surfinl_av(l) = surfinl_av(l) / REAL( average_count_3d, kind=wp ) 1956 1949 ENDIF … … 2245 2238 var(1:10) == 'usm_iwghf_' .OR. var(1:17) == 'usm_iwghf_window_' ) THEN 2246 2239 unit = 'W/m2' 2247 ELSE IF ( var(1:10) == 'usm_t_surf' .OR. var(1:10) == 'usm_t_wall' .OR. &2240 ELSE IF ( var(1:10) == 'usm_t_surf' .OR. var(1:10) == 'usm_t_wall' .OR. & 2248 2241 var(1:12) == 'usm_t_window' .OR. var(1:17) == 'usm_t_surf_window' .OR. & 2249 2242 var(1:16) == 'usm_t_surf_green' .OR. & … … 2253 2246 ELSE IF ( var(1:9) == 'usm_surfz' .OR. var(1:7) == 'usm_svf' .OR. & 2254 2247 var(1:7) == 'usm_dif' .OR. var(1:11) == 'usm_surfcat' .OR. & 2255 var(1:11) == 'usm_surfalb' .OR. var(1:12) == 'usm_surfemis') THEN 2248 var(1:11) == 'usm_surfalb' .OR. var(1:12) == 'usm_surfemis' .OR. & 2249 var(1:9) == 'usm_skyvf' .OR. var(1:9) == 'usm_skyvft' ) THEN 2256 2250 unit = '1' 2257 2251 ELSE … … 2302 2296 CALL message( 'check_parameters', 'PA0592', 1, 2, 0, 6, 0 ) 2303 2297 ENDIF 2298 ! 2299 !-- naheatlayers 2300 IF ( naheatlayers > nzt ) THEN 2301 message_string = 'number of anthropogenic heat layers '// & 2302 '"naheatlayers" can not be larger than'// & 2303 ' number of domain layers "nzt"' 2304 CALL message( 'check_parameters', 'PA0593', 1, 2, 0, 6, 0 ) 2305 ENDIF 2304 2306 2305 2307 END SUBROUTINE usm_check_parameters … … 2331 2333 INTEGER(iwp), PARAMETER :: nd = 5 2332 2334 CHARACTER(len=6), DIMENSION(0:nd-1), PARAMETER :: dirname = (/ '_roof ', '_south', '_north', '_west ', '_east ' /) 2333 INTEGER(iwp), DIMENSION(0:nd-1), PARAMETER :: dirint = (/ iup_u, isouth_u, inorth_u, iwest_u, ieast_u /) 2335 INTEGER(iwp), DIMENSION(0:nd-1), PARAMETER :: dirint = (/ iup_u, isouth_u, inorth_u, iwest_u, ieast_u /) 2336 INTEGER(iwp), DIMENSION(0:nd-1), PARAMETER :: diridx = (/ -1, 1, 0, 3, 2 /) 2337 !< index for surf_*_v: 0:3 = (North, South, East, West) 2334 2338 INTEGER(iwp), DIMENSION(0:nd-1) :: dirstart 2335 2339 INTEGER(iwp), DIMENSION(0:nd-1) :: dirend 2336 INTEGER(iwp) :: ids,i surf,isvf,isurfs,isurflt2340 INTEGER(iwp) :: ids,idsint,idsidx,isurf,isvf,isurfs,isurflt 2337 2341 INTEGER(iwp) :: is,js,ks,i,j,k,iwl,istat, l, m 2338 2342 INTEGER(iwp) :: k_topo !< topography top index … … 2351 2355 IF ( var(k-j+1:k) == dirname(i) ) THEN 2352 2356 ids = i 2357 idsint = dirint(ids) 2358 idsidx = diridx(ids) 2353 2359 var = var(:k-j) 2354 2360 EXIT … … 2400 2406 CASE ( 'usm_surfz' ) 2401 2407 !-- array of lw radiation falling to local surface after i-th reflection 2402 DO m = 1, surf_usm_h%ns 2403 i = surf_usm_h%i(m) 2404 j = surf_usm_h%j(m) 2405 k = surf_usm_h%k(m) 2406 temp_pf(0,j,i) = MAX( temp_pf(0,j,i), REAL( k, kind=wp) ) 2407 ENDDO 2408 DO l = 0, 3 2408 IF ( idsint == iup_u ) THEN 2409 DO m = 1, surf_usm_h%ns 2410 i = surf_usm_h%i(m) 2411 j = surf_usm_h%j(m) 2412 k = surf_usm_h%k(m) 2413 temp_pf(0,j,i) = MAX( temp_pf(0,j,i), REAL( k, kind=wp) ) 2414 ENDDO 2415 ELSE 2416 l = idsidx 2409 2417 DO m = 1, surf_usm_v(l)%ns 2410 2418 i = surf_usm_v(l)%i(m) … … 2413 2421 temp_pf(0,j,i) = MAX( temp_pf(0,j,i), REAL( k, kind=wp) + 1.0_wp ) 2414 2422 ENDDO 2415 END DO2423 ENDIF 2416 2424 2417 2425 CASE ( 'usm_surfcat' ) 2418 2426 !-- surface category 2419 DO m = 1, surf_usm_h%ns 2420 i = surf_usm_h%i(m) 2421 j = surf_usm_h%j(m) 2422 k = surf_usm_h%k(m) 2423 temp_pf(k,j,i) = surf_usm_h%surface_types(m) 2424 ENDDO 2425 DO l = 0, 3 2427 IF ( idsint == iup_u ) THEN 2428 DO m = 1, surf_usm_h%ns 2429 i = surf_usm_h%i(m) 2430 j = surf_usm_h%j(m) 2431 k = surf_usm_h%k(m) 2432 temp_pf(k,j,i) = surf_usm_h%surface_types(m) 2433 ENDDO 2434 ELSE 2435 l = idsidx 2426 2436 DO m = 1, surf_usm_v(l)%ns 2427 2437 i = surf_usm_v(l)%i(m) … … 2430 2440 temp_pf(k,j,i) = surf_usm_v(l)%surface_types(m) 2431 2441 ENDDO 2432 END DO2442 ENDIF 2433 2443 2434 2444 CASE ( 'usm_surfalb' ) 2435 2445 !-- surface albedo, weighted average 2436 DO m = 1, surf_usm_h%ns 2437 i = surf_usm_h%i(m) 2438 j = surf_usm_h%j(m) 2439 k = surf_usm_h%k(m) 2440 temp_pf(k,j,i) = surf_usm_h%frac(0,m) * & 2441 surf_usm_h%albedo(0,m) + & 2442 surf_usm_h%frac(1,m) * & 2443 surf_usm_h%albedo(1,m) + & 2444 surf_usm_h%frac(2,m) * & 2445 surf_usm_h%albedo(2,m) 2446 ENDDO 2447 DO l = 0, 3 2446 IF ( idsint == iup_u ) THEN 2447 DO m = 1, surf_usm_h%ns 2448 i = surf_usm_h%i(m) 2449 j = surf_usm_h%j(m) 2450 k = surf_usm_h%k(m) 2451 temp_pf(k,j,i) = surf_usm_h%frac(0,m) * & 2452 surf_usm_h%albedo(0,m) + & 2453 surf_usm_h%frac(1,m) * & 2454 surf_usm_h%albedo(1,m) + & 2455 surf_usm_h%frac(2,m) * & 2456 surf_usm_h%albedo(2,m) 2457 ENDDO 2458 ELSE 2459 l = idsidx 2448 2460 DO m = 1, surf_usm_v(l)%ns 2449 2461 i = surf_usm_v(l)%i(m) … … 2457 2469 surf_usm_v(l)%albedo(2,m) 2458 2470 ENDDO 2459 END DO2471 ENDIF 2460 2472 2461 2473 CASE ( 'usm_surfemis' ) 2462 2474 !-- surface emissivity, weighted average 2463 DO m = 1, surf_usm_h%ns 2464 i = surf_usm_h%i(m) 2465 j = surf_usm_h%j(m) 2466 k = surf_usm_h%k(m) 2467 temp_pf(k,j,i) = surf_usm_h%frac(0,m) * & 2468 surf_usm_h%emissivity(0,m) + & 2469 surf_usm_h%frac(1,m) * & 2470 surf_usm_h%emissivity(1,m) + & 2471 surf_usm_h%frac(2,m) * & 2472 surf_usm_h%emissivity(2,m) 2473 ENDDO 2474 DO l = 0, 3 2475 IF ( idsint == iup_u ) THEN 2476 DO m = 1, surf_usm_h%ns 2477 i = surf_usm_h%i(m) 2478 j = surf_usm_h%j(m) 2479 k = surf_usm_h%k(m) 2480 temp_pf(k,j,i) = surf_usm_h%frac(0,m) * & 2481 surf_usm_h%emissivity(0,m) + & 2482 surf_usm_h%frac(1,m) * & 2483 surf_usm_h%emissivity(1,m) + & 2484 surf_usm_h%frac(2,m) * & 2485 surf_usm_h%emissivity(2,m) 2486 ENDDO 2487 ELSE 2488 l = idsidx 2475 2489 DO m = 1, surf_usm_v(l)%ns 2476 2490 i = surf_usm_v(l)%i(m) … … 2484 2498 surf_usm_v(l)%emissivity(2,m) 2485 2499 ENDDO 2486 END DO2500 ENDIF 2487 2501 2488 2502 CASE ( 'usm_surfwintrans' ) 2489 2503 !-- transmissivity window tiles 2490 DO m = 1, surf_usm_h%ns 2491 i = surf_usm_h%i(m) 2492 j = surf_usm_h%j(m) 2493 k = surf_usm_h%k(m) 2494 temp_pf(k,j,i) = surf_usm_h%transmissivity(m) 2495 ENDDO 2496 DO l = 0, 3 2504 IF ( idsint == iup_u ) THEN 2505 DO m = 1, surf_usm_h%ns 2506 i = surf_usm_h%i(m) 2507 j = surf_usm_h%j(m) 2508 k = surf_usm_h%k(m) 2509 temp_pf(k,j,i) = surf_usm_h%transmissivity(m) 2510 ENDDO 2511 ELSE 2512 l = idsidx 2497 2513 DO m = 1, surf_usm_v(l)%ns 2498 2514 i = surf_usm_v(l)%i(m) … … 2501 2517 temp_pf(k,j,i) = surf_usm_v(l)%transmissivity(m) 2502 2518 ENDDO 2503 2519 ENDIF 2520 2521 CASE ( 'usm_skyvf' ) 2522 !-- sky view factor 2523 DO isurf = dirstart(ids), dirend(ids) 2524 IF ( surfl(id,isurf) == idsint ) THEN 2525 temp_pf(surfl(iz,isurf),surfl(iy,isurf),surfl(ix,isurf)) = skyvf(isurf) 2526 ENDIF 2527 ENDDO 2528 2529 CASE ( 'usm_skyvft' ) 2530 !-- sky view factor 2531 DO isurf = dirstart(ids), dirend(ids) 2532 IF ( surfl(id,isurf) == ids ) THEN 2533 temp_pf(surfl(iz,isurf),surfl(iy,isurf),surfl(ix,isurf)) = skyvft(isurf) 2534 ENDIF 2504 2535 ENDDO 2505 2536 … … 2518 2549 2519 2550 IF ( surf(ix,isurfs) == is .AND. surf(iy,isurfs) == js .AND. & 2520 surf(iz,isurfs) == ks .AND. surf(id,isurfs) == ids ) THEN2551 surf(iz,isurfs) == ks .AND. surf(id,isurfs) == idsint ) THEN 2521 2552 !-- correct source surface 2522 2553 temp_pf(surfl(iz,isurflt),surfl(iy,isurflt),surfl(ix,isurflt)) = svf(k,isvf) … … 2527 2558 !-- array of complete radiation balance 2528 2559 IF ( av == 0 ) THEN 2529 DO m = 1, surf_usm_h%ns 2530 i = surf_usm_h%i(m) 2531 j = surf_usm_h%j(m) 2532 k = surf_usm_h%k(m) 2533 temp_pf(k,j,i) = surf_usm_h%rad_net_l(m) 2534 ENDDO 2535 DO l = 0, 3 2560 IF ( idsint == iup_u ) THEN 2561 DO m = 1, surf_usm_h%ns 2562 i = surf_usm_h%i(m) 2563 j = surf_usm_h%j(m) 2564 k = surf_usm_h%k(m) 2565 temp_pf(k,j,i) = surf_usm_h%rad_net_l(m) 2566 ENDDO 2567 ELSE 2568 l = idsidx 2536 2569 DO m = 1, surf_usm_v(l)%ns 2537 2570 i = surf_usm_v(l)%i(m) … … 2540 2573 temp_pf(k,j,i) = surf_usm_v(l)%rad_net_l(m) 2541 2574 ENDDO 2542 END DO2575 ENDIF 2543 2576 ELSE 2544 DO m = 1, surf_usm_h%ns 2545 i = surf_usm_h%i(m) 2546 j = surf_usm_h%j(m) 2547 k = surf_usm_h%k(m) 2548 temp_pf(k,j,i) = surf_usm_h%rad_net_av(m) 2549 ENDDO 2550 DO l = 0, 3 2577 IF ( idsint == iup_u ) THEN 2578 DO m = 1, surf_usm_h%ns 2579 i = surf_usm_h%i(m) 2580 j = surf_usm_h%j(m) 2581 k = surf_usm_h%k(m) 2582 temp_pf(k,j,i) = surf_usm_h%rad_net_av(m) 2583 ENDDO 2584 ELSE 2585 l = idsidx 2551 2586 DO m = 1, surf_usm_v(l)%ns 2552 2587 i = surf_usm_v(l)%i(m) … … 2555 2590 temp_pf(k,j,i) = surf_usm_v(l)%rad_net_av(m) 2556 2591 ENDDO 2557 END DO2592 ENDIF 2558 2593 ENDIF 2559 2594 … … 2561 2596 !-- array of sw radiation falling to surface after i-th reflection 2562 2597 DO isurf = dirstart(ids), dirend(ids) 2563 IF ( surfl(id,isurf) == ids ) THEN2598 IF ( surfl(id,isurf) == idsint ) THEN 2564 2599 IF ( av == 0 ) THEN 2565 2600 temp_pf(surfl(iz,isurf),surfl(iy,isurf),surfl(ix,isurf)) = surfinsw(isurf) … … 2573 2608 !-- array of lw radiation falling to surface after i-th reflection 2574 2609 DO isurf = dirstart(ids), dirend(ids) 2575 IF ( surfl(id,isurf) == ids ) THEN2610 IF ( surfl(id,isurf) == idsint ) THEN 2576 2611 IF ( av == 0 ) THEN 2577 2612 temp_pf(surfl(iz,isurf),surfl(iy,isurf),surfl(ix,isurf)) = surfinlw(isurf) … … 2585 2620 !-- array of direct sw radiation falling to surface from sun 2586 2621 DO isurf = dirstart(ids), dirend(ids) 2587 IF ( surfl(id,isurf) == ids ) THEN2622 IF ( surfl(id,isurf) == idsint ) THEN 2588 2623 IF ( av == 0 ) THEN 2589 2624 temp_pf(surfl(iz,isurf),surfl(iy,isurf),surfl(ix,isurf)) = surfinswdir(isurf) … … 2597 2632 !-- array of difusion sw radiation falling to surface from sky and borders of the domain 2598 2633 DO isurf = dirstart(ids), dirend(ids) 2599 IF ( surfl(id,isurf) == ids ) THEN2634 IF ( surfl(id,isurf) == idsint ) THEN 2600 2635 IF ( av == 0 ) THEN 2601 2636 temp_pf(surfl(iz,isurf),surfl(iy,isurf),surfl(ix,isurf)) = surfinswdif(isurf) … … 2609 2644 !-- array of sw radiation falling to surface from reflections 2610 2645 DO isurf = dirstart(ids), dirend(ids) 2611 IF ( surfl(id,isurf) == ids ) THEN2646 IF ( surfl(id,isurf) == idsint ) THEN 2612 2647 IF ( av == 0 ) THEN 2613 2648 temp_pf(surfl(iz,isurf),surfl(iy,isurf),surfl(ix,isurf)) = & … … 2619 2654 ENDDO 2620 2655 2656 CASE ( 'usm_rad_inlwdif' ) 2657 !-- array of difusion lw radiation falling to surface from sky and borders of the domain 2658 DO isurf = dirstart(ids), dirend(ids) 2659 IF ( surfl(id,isurf) == idsint ) THEN 2660 IF ( av == 0 ) THEN 2661 temp_pf(surfl(iz,isurf),surfl(iy,isurf),surfl(ix,isurf)) = surfinlwdif(isurf) 2662 ELSE 2663 temp_pf(surfl(iz,isurf),surfl(iy,isurf),surfl(ix,isurf)) = surfinlwdif_av(isurf) 2664 ENDIF 2665 ENDIF 2666 ENDDO 2667 2621 2668 CASE ( 'usm_rad_inlwref' ) 2622 2669 !-- array of lw radiation falling to surface from reflections 2623 2670 DO isurf = dirstart(ids), dirend(ids) 2624 IF ( surfl(id,isurf) == ids ) THEN2671 IF ( surfl(id,isurf) == idsint ) THEN 2625 2672 IF ( av == 0 ) THEN 2626 2673 temp_pf(surfl(iz,isurf),surfl(iy,isurf),surfl(ix,isurf)) = surfinlw(isurf) - surfinlwdif(isurf) … … 2634 2681 !-- array of sw radiation emitted from surface after i-th reflection 2635 2682 DO isurf = dirstart(ids), dirend(ids) 2636 IF ( surfl(id,isurf) == ids ) THEN2683 IF ( surfl(id,isurf) == idsint ) THEN 2637 2684 IF ( av == 0 ) THEN 2638 2685 temp_pf(surfl(iz,isurf),surfl(iy,isurf),surfl(ix,isurf)) = surfoutsw(isurf) … … 2646 2693 !-- array of lw radiation emitted from surface after i-th reflection 2647 2694 DO isurf = dirstart(ids), dirend(ids) 2648 IF ( surfl(id,isurf) == ids ) THEN2695 IF ( surfl(id,isurf) == idsint ) THEN 2649 2696 IF ( av == 0 ) THEN 2650 2697 temp_pf(surfl(iz,isurf),surfl(iy,isurf),surfl(ix,isurf)) = surfoutlw(isurf) … … 2658 2705 !-- average of array of residua of sw radiation absorbed in surface after last reflection 2659 2706 DO isurf = dirstart(ids), dirend(ids) 2660 IF ( surfl(id,isurf) == ids ) THEN2707 IF ( surfl(id,isurf) == idsint ) THEN 2661 2708 IF ( av == 0 ) THEN 2662 2709 temp_pf(surfl(iz,isurf),surfl(iy,isurf),surfl(ix,isurf)) = surfins(isurf) … … 2670 2717 !-- average of array of residua of lw radiation absorbed in surface after last reflection 2671 2718 DO isurf = dirstart(ids), dirend(ids) 2672 IF ( surfl(id,isurf) == ids ) THEN2719 IF ( surfl(id,isurf) == idsint ) THEN 2673 2720 IF ( av == 0 ) THEN 2674 2721 temp_pf(surfl(iz,isurf),surfl(iy,isurf),surfl(ix,isurf)) = surfinl(isurf) … … 2682 2729 !-- array of heat flux from radiation for surfaces after all reflections 2683 2730 IF ( av == 0 ) THEN 2684 DO m = 1, surf_usm_h%ns 2685 i = surf_usm_h%i(m) 2686 j = surf_usm_h%j(m) 2687 k = surf_usm_h%k(m) 2688 temp_pf(k,j,i) = surf_usm_h%surfhf(m) 2689 ENDDO 2690 DO l = 0, 3 2731 IF ( idsint == iup_u ) THEN 2732 DO m = 1, surf_usm_h%ns 2733 i = surf_usm_h%i(m) 2734 j = surf_usm_h%j(m) 2735 k = surf_usm_h%k(m) 2736 temp_pf(k,j,i) = surf_usm_h%surfhf(m) 2737 ENDDO 2738 ELSE 2739 l = idsidx 2691 2740 DO m = 1, surf_usm_v(l)%ns 2692 2741 i = surf_usm_v(l)%i(m) … … 2695 2744 temp_pf(k,j,i) = surf_usm_v(l)%surfhf(m) 2696 2745 ENDDO 2697 END DO2746 ENDIF 2698 2747 ELSE 2699 DO m = 1, surf_usm_h%ns 2700 i = surf_usm_h%i(m) 2701 j = surf_usm_h%j(m) 2702 k = surf_usm_h%k(m) 2703 temp_pf(k,j,i) = surf_usm_h%surfhf_av(m) 2704 ENDDO 2705 DO l = 0, 3 2748 IF ( idsint == iup_u ) THEN 2749 DO m = 1, surf_usm_h%ns 2750 i = surf_usm_h%i(m) 2751 j = surf_usm_h%j(m) 2752 k = surf_usm_h%k(m) 2753 temp_pf(k,j,i) = surf_usm_h%surfhf_av(m) 2754 ENDDO 2755 ELSE 2756 l = idsidx 2706 2757 DO m = 1, surf_usm_v(l)%ns 2707 2758 i = surf_usm_v(l)%i(m) … … 2710 2761 temp_pf(k,j,i) = surf_usm_v(l)%surfhf_av(m) 2711 2762 ENDDO 2712 END DO2763 ENDIF 2713 2764 ENDIF 2714 2765 … … 2716 2767 !-- array of sensible heat flux from surfaces 2717 2768 IF ( av == 0 ) THEN 2718 DO m = 1, surf_usm_h%ns 2719 i = surf_usm_h%i(m) 2720 j = surf_usm_h%j(m) 2721 k = surf_usm_h%k(m) 2722 temp_pf(k,j,i) = surf_usm_h%wshf_eb(m) 2723 ENDDO 2724 DO l = 0, 3 2769 IF ( idsint == iup_u ) THEN 2770 DO m = 1, surf_usm_h%ns 2771 i = surf_usm_h%i(m) 2772 j = surf_usm_h%j(m) 2773 k = surf_usm_h%k(m) 2774 temp_pf(k,j,i) = surf_usm_h%wshf_eb(m) 2775 ENDDO 2776 ELSE 2777 l = idsidx 2725 2778 DO m = 1, surf_usm_v(l)%ns 2726 2779 i = surf_usm_v(l)%i(m) … … 2729 2782 temp_pf(k,j,i) = surf_usm_v(l)%wshf_eb(m) 2730 2783 ENDDO 2731 END DO2784 ENDIF 2732 2785 ELSE 2733 DO m = 1, surf_usm_h%ns 2734 i = surf_usm_h%i(m) 2735 j = surf_usm_h%j(m) 2736 k = surf_usm_h%k(m) 2737 temp_pf(k,j,i) = surf_usm_h%wshf_eb_av(m) 2738 ENDDO 2739 DO l = 0, 3 2786 IF ( idsint == iup_u ) THEN 2787 DO m = 1, surf_usm_h%ns 2788 i = surf_usm_h%i(m) 2789 j = surf_usm_h%j(m) 2790 k = surf_usm_h%k(m) 2791 temp_pf(k,j,i) = surf_usm_h%wshf_eb_av(m) 2792 ENDDO 2793 ELSE 2794 l = idsidx 2740 2795 DO m = 1, surf_usm_v(l)%ns 2741 2796 i = surf_usm_v(l)%i(m) … … 2744 2799 temp_pf(k,j,i) = surf_usm_v(l)%wshf_eb_av(m) 2745 2800 ENDDO 2746 END DO2801 ENDIF 2747 2802 ENDIF 2748 2803 … … 2751 2806 !-- array of heat flux from ground (land, wall, roof) 2752 2807 IF ( av == 0 ) THEN 2753 DO m = 1, surf_usm_h%ns 2754 i = surf_usm_h%i(m) 2755 j = surf_usm_h%j(m) 2756 k = surf_usm_h%k(m) 2757 temp_pf(k,j,i) = surf_usm_h%wghf_eb(m) 2758 ENDDO 2759 DO l = 0, 3 2808 IF ( idsint == iup_u ) THEN 2809 DO m = 1, surf_usm_h%ns 2810 i = surf_usm_h%i(m) 2811 j = surf_usm_h%j(m) 2812 k = surf_usm_h%k(m) 2813 temp_pf(k,j,i) = surf_usm_h%wghf_eb(m) 2814 ENDDO 2815 ELSE 2816 l = idsidx 2760 2817 DO m = 1, surf_usm_v(l)%ns 2761 2818 i = surf_usm_v(l)%i(m) … … 2764 2821 temp_pf(k,j,i) = surf_usm_v(l)%wghf_eb(m) 2765 2822 ENDDO 2766 END DO2823 ENDIF 2767 2824 ELSE 2768 DO m = 1, surf_usm_h%ns 2769 i = surf_usm_h%i(m) 2770 j = surf_usm_h%j(m) 2771 k = surf_usm_h%k(m) 2772 temp_pf(k,j,i) = surf_usm_h%wghf_eb_av(m) 2773 ENDDO 2774 DO l = 0, 3 2825 IF ( idsint == iup_u ) THEN 2826 DO m = 1, surf_usm_h%ns 2827 i = surf_usm_h%i(m) 2828 j = surf_usm_h%j(m) 2829 k = surf_usm_h%k(m) 2830 temp_pf(k,j,i) = surf_usm_h%wghf_eb_av(m) 2831 ENDDO 2832 ELSE 2833 l = idsidx 2775 2834 DO m = 1, surf_usm_v(l)%ns 2776 2835 i = surf_usm_v(l)%i(m) … … 2779 2838 temp_pf(k,j,i) = surf_usm_v(l)%wghf_eb_av(m) 2780 2839 ENDDO 2781 END DO2840 ENDIF 2782 2841 ENDIF 2783 2842 … … 2786 2845 2787 2846 IF ( av == 0 ) THEN 2788 DO m = 1, surf_usm_h%ns 2789 i = surf_usm_h%i(m) 2790 j = surf_usm_h%j(m) 2791 k = surf_usm_h%k(m) 2792 temp_pf(k,j,i) = surf_usm_h%wghf_eb_window(m) 2793 ENDDO 2794 DO l = 0, 3 2847 IF ( idsint == iup_u ) THEN 2848 DO m = 1, surf_usm_h%ns 2849 i = surf_usm_h%i(m) 2850 j = surf_usm_h%j(m) 2851 k = surf_usm_h%k(m) 2852 temp_pf(k,j,i) = surf_usm_h%wghf_eb_window(m) 2853 ENDDO 2854 ELSE 2855 l = idsidx 2795 2856 DO m = 1, surf_usm_v(l)%ns 2796 2857 i = surf_usm_v(l)%i(m) … … 2799 2860 temp_pf(k,j,i) = surf_usm_v(l)%wghf_eb_window(m) 2800 2861 ENDDO 2801 END DO2862 ENDIF 2802 2863 ELSE 2803 DO m = 1, surf_usm_h%ns 2804 i = surf_usm_h%i(m) 2805 j = surf_usm_h%j(m) 2806 k = surf_usm_h%k(m) 2807 temp_pf(k,j,i) = surf_usm_h%wghf_eb_window_av(m) 2808 ENDDO 2809 DO l = 0, 3 2864 IF ( idsint == iup_u ) THEN 2865 DO m = 1, surf_usm_h%ns 2866 i = surf_usm_h%i(m) 2867 j = surf_usm_h%j(m) 2868 k = surf_usm_h%k(m) 2869 temp_pf(k,j,i) = surf_usm_h%wghf_eb_window_av(m) 2870 ENDDO 2871 ELSE 2872 l = idsidx 2810 2873 DO m = 1, surf_usm_v(l)%ns 2811 2874 i = surf_usm_v(l)%i(m) … … 2814 2877 temp_pf(k,j,i) = surf_usm_v(l)%wghf_eb_window_av(m) 2815 2878 ENDDO 2816 END DO2879 ENDIF 2817 2880 ENDIF 2818 2881 … … 2821 2884 2822 2885 IF ( av == 0 ) THEN 2823 DO m = 1, surf_usm_h%ns 2824 i = surf_usm_h%i(m) 2825 j = surf_usm_h%j(m) 2826 k = surf_usm_h%k(m) 2827 temp_pf(k,j,i) = surf_usm_h%wghf_eb_green(m) 2828 ENDDO 2829 DO l = 0, 3 2886 IF ( idsint == iup_u ) THEN 2887 DO m = 1, surf_usm_h%ns 2888 i = surf_usm_h%i(m) 2889 j = surf_usm_h%j(m) 2890 k = surf_usm_h%k(m) 2891 temp_pf(k,j,i) = surf_usm_h%wghf_eb_green(m) 2892 ENDDO 2893 ELSE 2894 l = idsidx 2830 2895 DO m = 1, surf_usm_v(l)%ns 2831 2896 i = surf_usm_v(l)%i(m) … … 2834 2899 temp_pf(k,j,i) = surf_usm_v(l)%wghf_eb_green(m) 2835 2900 ENDDO 2836 END DO2901 ENDIF 2837 2902 ELSE 2838 DO m = 1, surf_usm_h%ns 2839 i = surf_usm_h%i(m) 2840 j = surf_usm_h%j(m) 2841 k = surf_usm_h%k(m) 2842 temp_pf(k,j,i) = surf_usm_h%wghf_eb_green_av(m) 2843 ENDDO 2844 DO l = 0, 3 2903 IF ( idsint == iup_u ) THEN 2904 DO m = 1, surf_usm_h%ns 2905 i = surf_usm_h%i(m) 2906 j = surf_usm_h%j(m) 2907 k = surf_usm_h%k(m) 2908 temp_pf(k,j,i) = surf_usm_h%wghf_eb_green_av(m) 2909 ENDDO 2910 ELSE 2911 l = idsidx 2845 2912 DO m = 1, surf_usm_v(l)%ns 2846 2913 i = surf_usm_v(l)%i(m) … … 2849 2916 temp_pf(k,j,i) = surf_usm_v(l)%wghf_eb_green_av(m) 2850 2917 ENDDO 2851 END DO2918 ENDIF 2852 2919 ENDIF 2853 2920 … … 2855 2922 !-- array of heat flux from indoor ground (land, wall, roof) 2856 2923 IF ( av == 0 ) THEN 2857 DO m = 1, surf_usm_h%ns 2858 i = surf_usm_h%i(m) 2859 j = surf_usm_h%j(m) 2860 k = surf_usm_h%k(m) 2861 temp_pf(k,j,i) = surf_usm_h%iwghf_eb(m) 2862 ENDDO 2863 DO l = 0, 3 2924 IF ( idsint == iup_u ) THEN 2925 DO m = 1, surf_usm_h%ns 2926 i = surf_usm_h%i(m) 2927 j = surf_usm_h%j(m) 2928 k = surf_usm_h%k(m) 2929 temp_pf(k,j,i) = surf_usm_h%iwghf_eb(m) 2930 ENDDO 2931 ELSE 2932 l = idsidx 2864 2933 DO m = 1, surf_usm_v(l)%ns 2865 2934 i = surf_usm_v(l)%i(m) … … 2868 2937 temp_pf(k,j,i) = surf_usm_v(l)%iwghf_eb(m) 2869 2938 ENDDO 2870 END DO2939 ENDIF 2871 2940 ELSE 2872 DO m = 1, surf_usm_h%ns 2873 i = surf_usm_h%i(m) 2874 j = surf_usm_h%j(m) 2875 k = surf_usm_h%k(m) 2876 temp_pf(k,j,i) = surf_usm_h%iwghf_eb_av(m) 2877 ENDDO 2878 DO l = 0, 3 2941 IF ( idsint == iup_u ) THEN 2942 DO m = 1, surf_usm_h%ns 2943 i = surf_usm_h%i(m) 2944 j = surf_usm_h%j(m) 2945 k = surf_usm_h%k(m) 2946 temp_pf(k,j,i) = surf_usm_h%iwghf_eb_av(m) 2947 ENDDO 2948 ELSE 2949 l = idsidx 2879 2950 DO m = 1, surf_usm_v(l)%ns 2880 2951 i = surf_usm_v(l)%i(m) … … 2883 2954 temp_pf(k,j,i) = surf_usm_v(l)%iwghf_eb_av(m) 2884 2955 ENDDO 2885 END DO2956 ENDIF 2886 2957 ENDIF 2887 2958 … … 2890 2961 2891 2962 IF ( av == 0 ) THEN 2892 DO m = 1, surf_usm_h%ns 2893 i = surf_usm_h%i(m) 2894 j = surf_usm_h%j(m) 2895 k = surf_usm_h%k(m) 2896 temp_pf(k,j,i) = surf_usm_h%iwghf_eb_window(m) 2897 ENDDO 2898 DO l = 0, 3 2963 IF ( idsint == iup_u ) THEN 2964 DO m = 1, surf_usm_h%ns 2965 i = surf_usm_h%i(m) 2966 j = surf_usm_h%j(m) 2967 k = surf_usm_h%k(m) 2968 temp_pf(k,j,i) = surf_usm_h%iwghf_eb_window(m) 2969 ENDDO 2970 ELSE 2971 l = idsidx 2899 2972 DO m = 1, surf_usm_v(l)%ns 2900 2973 i = surf_usm_v(l)%i(m) … … 2903 2976 temp_pf(k,j,i) = surf_usm_v(l)%iwghf_eb_window(m) 2904 2977 ENDDO 2905 END DO2978 ENDIF 2906 2979 ELSE 2907 DO m = 1, surf_usm_h%ns 2908 i = surf_usm_h%i(m) 2909 j = surf_usm_h%j(m) 2910 k = surf_usm_h%k(m) 2911 temp_pf(k,j,i) = surf_usm_h%iwghf_eb_window_av(m) 2912 ENDDO 2913 DO l = 0, 3 2980 IF ( idsint == iup_u ) THEN 2981 DO m = 1, surf_usm_h%ns 2982 i = surf_usm_h%i(m) 2983 j = surf_usm_h%j(m) 2984 k = surf_usm_h%k(m) 2985 temp_pf(k,j,i) = surf_usm_h%iwghf_eb_window_av(m) 2986 ENDDO 2987 ELSE 2988 l = idsidx 2914 2989 DO m = 1, surf_usm_v(l)%ns 2915 2990 i = surf_usm_v(l)%i(m) … … 2918 2993 temp_pf(k,j,i) = surf_usm_v(l)%iwghf_eb_window_av(m) 2919 2994 ENDDO 2920 END DO2995 ENDIF 2921 2996 ENDIF 2922 2997 … … 2924 2999 !-- surface temperature for surfaces 2925 3000 IF ( av == 0 ) THEN 2926 DO m = 1, surf_usm_h%ns 2927 i = surf_usm_h%i(m) 2928 j = surf_usm_h%j(m) 2929 k = surf_usm_h%k(m) 2930 temp_pf(k,j,i) = t_surf_h(m) 2931 ENDDO 2932 DO l = 0, 3 3001 IF ( idsint == iup_u ) THEN 3002 DO m = 1, surf_usm_h%ns 3003 i = surf_usm_h%i(m) 3004 j = surf_usm_h%j(m) 3005 k = surf_usm_h%k(m) 3006 temp_pf(k,j,i) = t_surf_h(m) 3007 ENDDO 3008 ELSE 3009 l = idsidx 2933 3010 DO m = 1, surf_usm_v(l)%ns 2934 3011 i = surf_usm_v(l)%i(m) … … 2937 3014 temp_pf(k,j,i) = t_surf_v(l)%t(m) 2938 3015 ENDDO 2939 END DO3016 ENDIF 2940 3017 ELSE 2941 DO m = 1, surf_usm_h%ns 2942 i = surf_usm_h%i(m) 2943 j = surf_usm_h%j(m) 2944 k = surf_usm_h%k(m) 2945 temp_pf(k,j,i) = surf_usm_h%t_surf_av(m) 2946 ENDDO 2947 DO l = 0, 3 3018 IF ( idsint == iup_u ) THEN 3019 DO m = 1, surf_usm_h%ns 3020 i = surf_usm_h%i(m) 3021 j = surf_usm_h%j(m) 3022 k = surf_usm_h%k(m) 3023 temp_pf(k,j,i) = surf_usm_h%t_surf_av(m) 3024 ENDDO 3025 ELSE 3026 l = idsidx 2948 3027 DO m = 1, surf_usm_v(l)%ns 2949 3028 i = surf_usm_v(l)%i(m) … … 2952 3031 temp_pf(k,j,i) = surf_usm_v(l)%t_surf_av(m) 2953 3032 ENDDO 2954 END DO3033 ENDIF 2955 3034 ENDIF 2956 3035 … … 2959 3038 2960 3039 IF ( av == 0 ) THEN 2961 DO m = 1, surf_usm_h%ns 2962 i = surf_usm_h%i(m) 2963 j = surf_usm_h%j(m) 2964 k = surf_usm_h%k(m) 2965 temp_pf(k,j,i) = t_surf_window_h(m) 2966 ENDDO 2967 DO l = 0, 3 3040 IF ( idsint == iup_u ) THEN 3041 DO m = 1, surf_usm_h%ns 3042 i = surf_usm_h%i(m) 3043 j = surf_usm_h%j(m) 3044 k = surf_usm_h%k(m) 3045 temp_pf(k,j,i) = t_surf_window_h(m) 3046 ENDDO 3047 ELSE 3048 l = idsidx 2968 3049 DO m = 1, surf_usm_v(l)%ns 2969 3050 i = surf_usm_v(l)%i(m) … … 2972 3053 temp_pf(k,j,i) = t_surf_window_v(l)%t(m) 2973 3054 ENDDO 2974 END DO3055 ENDIF 2975 3056 2976 3057 ELSE 2977 DO m = 1, surf_usm_h%ns 2978 i = surf_usm_h%i(m) 2979 j = surf_usm_h%j(m) 2980 k = surf_usm_h%k(m) 2981 temp_pf(k,j,i) = surf_usm_h%t_surf_window_av(m) 2982 ENDDO 2983 DO l = 0, 3 3058 IF ( idsint == iup_u ) THEN 3059 DO m = 1, surf_usm_h%ns 3060 i = surf_usm_h%i(m) 3061 j = surf_usm_h%j(m) 3062 k = surf_usm_h%k(m) 3063 temp_pf(k,j,i) = surf_usm_h%t_surf_window_av(m) 3064 ENDDO 3065 ELSE 3066 l = idsidx 2984 3067 DO m = 1, surf_usm_v(l)%ns 2985 3068 i = surf_usm_v(l)%i(m) … … 2989 3072 ENDDO 2990 3073 2991 END DO3074 ENDIF 2992 3075 2993 3076 ENDIF … … 2997 3080 2998 3081 IF ( av == 0 ) THEN 2999 DO m = 1, surf_usm_h%ns 3000 i = surf_usm_h%i(m) 3001 j = surf_usm_h%j(m) 3002 k = surf_usm_h%k(m) 3003 temp_pf(k,j,i) = t_surf_green_h(m) 3004 ENDDO 3005 DO l = 0, 3 3082 IF ( idsint == iup_u ) THEN 3083 DO m = 1, surf_usm_h%ns 3084 i = surf_usm_h%i(m) 3085 j = surf_usm_h%j(m) 3086 k = surf_usm_h%k(m) 3087 temp_pf(k,j,i) = t_surf_green_h(m) 3088 ENDDO 3089 ELSE 3090 l = idsidx 3006 3091 DO m = 1, surf_usm_v(l)%ns 3007 3092 i = surf_usm_v(l)%i(m) … … 3010 3095 temp_pf(k,j,i) = t_surf_green_v(l)%t(m) 3011 3096 ENDDO 3012 END DO3097 ENDIF 3013 3098 3014 3099 ELSE 3015 DO m = 1, surf_usm_h%ns 3016 i = surf_usm_h%i(m) 3017 j = surf_usm_h%j(m) 3018 k = surf_usm_h%k(m) 3019 temp_pf(k,j,i) = surf_usm_h%t_surf_green_av(m) 3020 ENDDO 3021 DO l = 0, 3 3100 IF ( idsint == iup_u ) THEN 3101 DO m = 1, surf_usm_h%ns 3102 i = surf_usm_h%i(m) 3103 j = surf_usm_h%j(m) 3104 k = surf_usm_h%k(m) 3105 temp_pf(k,j,i) = surf_usm_h%t_surf_green_av(m) 3106 ENDDO 3107 ELSE 3108 l = idsidx 3022 3109 DO m = 1, surf_usm_v(l)%ns 3023 3110 i = surf_usm_v(l)%i(m) … … 3027 3114 ENDDO 3028 3115 3029 END DO3116 ENDIF 3030 3117 3031 3118 ENDIF … … 3035 3122 3036 3123 IF ( av == 0 ) THEN 3037 DO m = 1, surf_usm_h%ns 3038 i = surf_usm_h%i(m) 3039 j = surf_usm_h%j(m) 3040 k = surf_usm_h%k(m) 3041 temp_pf(k,j,i) = t_surf_10cm_h(m) 3042 ENDDO 3043 DO l = 0, 3 3124 IF ( idsint == iup_u ) THEN 3125 DO m = 1, surf_usm_h%ns 3126 i = surf_usm_h%i(m) 3127 j = surf_usm_h%j(m) 3128 k = surf_usm_h%k(m) 3129 temp_pf(k,j,i) = t_surf_10cm_h(m) 3130 ENDDO 3131 ELSE 3132 l = idsidx 3044 3133 DO m = 1, surf_usm_v(l)%ns 3045 3134 i = surf_usm_v(l)%i(m) … … 3048 3137 temp_pf(k,j,i) = t_surf_10cm_v(l)%t(m) 3049 3138 ENDDO 3050 END DO3139 ENDIF 3051 3140 3052 3141 ELSE 3053 DO m = 1, surf_usm_h%ns 3054 i = surf_usm_h%i(m) 3055 j = surf_usm_h%j(m) 3056 k = surf_usm_h%k(m) 3057 temp_pf(k,j,i) = surf_usm_h%t_surf_10cm_av(m) 3058 ENDDO 3059 DO l = 0, 3 3142 IF ( idsint == iup_u ) THEN 3143 DO m = 1, surf_usm_h%ns 3144 i = surf_usm_h%i(m) 3145 j = surf_usm_h%j(m) 3146 k = surf_usm_h%k(m) 3147 temp_pf(k,j,i) = surf_usm_h%t_surf_10cm_av(m) 3148 ENDDO 3149 ELSE 3150 l = idsidx 3060 3151 DO m = 1, surf_usm_v(l)%ns 3061 3152 i = surf_usm_v(l)%i(m) … … 3065 3156 ENDDO 3066 3157 3067 END DO3158 ENDIF 3068 3159 3069 3160 ENDIF … … 3073 3164 !-- wall temperature for iwl layer of walls and land 3074 3165 IF ( av == 0 ) THEN 3075 DO m = 1, surf_usm_h%ns 3076 i = surf_usm_h%i(m) 3077 j = surf_usm_h%j(m) 3078 k = surf_usm_h%k(m) 3079 temp_pf(k,j,i) = t_wall_h(iwl,m) 3080 ENDDO 3081 DO l = 0, 3 3166 IF ( idsint == iup_u ) THEN 3167 DO m = 1, surf_usm_h%ns 3168 i = surf_usm_h%i(m) 3169 j = surf_usm_h%j(m) 3170 k = surf_usm_h%k(m) 3171 temp_pf(k,j,i) = t_wall_h(iwl,m) 3172 ENDDO 3173 ELSE 3174 l = idsidx 3082 3175 DO m = 1, surf_usm_v(l)%ns 3083 3176 i = surf_usm_v(l)%i(m) … … 3086 3179 temp_pf(k,j,i) = t_wall_v(l)%t(iwl,m) 3087 3180 ENDDO 3088 END DO3181 ENDIF 3089 3182 ELSE 3090 DO m = 1, surf_usm_h%ns 3091 i = surf_usm_h%i(m) 3092 j = surf_usm_h%j(m) 3093 k = surf_usm_h%k(m) 3094 temp_pf(k,j,i) = surf_usm_h%t_wall_av(iwl,m) 3095 ENDDO 3096 DO l = 0, 3 3183 IF ( idsint == iup_u ) THEN 3184 DO m = 1, surf_usm_h%ns 3185 i = surf_usm_h%i(m) 3186 j = surf_usm_h%j(m) 3187 k = surf_usm_h%k(m) 3188 temp_pf(k,j,i) = surf_usm_h%t_wall_av(iwl,m) 3189 ENDDO 3190 ELSE 3191 l = idsidx 3097 3192 DO m = 1, surf_usm_v(l)%ns 3098 3193 i = surf_usm_v(l)%i(m) … … 3101 3196 temp_pf(k,j,i) = surf_usm_v(l)%t_wall_av(iwl,m) 3102 3197 ENDDO 3103 END DO3198 ENDIF 3104 3199 ENDIF 3105 3200 … … 3107 3202 !-- window temperature for iwl layer of walls and land 3108 3203 IF ( av == 0 ) THEN 3109 DO m = 1, surf_usm_h%ns 3110 i = surf_usm_h%i(m) 3111 j = surf_usm_h%j(m) 3112 k = surf_usm_h%k(m) 3113 temp_pf(k,j,i) = t_window_h(iwl,m) 3114 ENDDO 3115 DO l = 0, 3 3204 IF ( idsint == iup_u ) THEN 3205 DO m = 1, surf_usm_h%ns 3206 i = surf_usm_h%i(m) 3207 j = surf_usm_h%j(m) 3208 k = surf_usm_h%k(m) 3209 temp_pf(k,j,i) = t_window_h(iwl,m) 3210 ENDDO 3211 ELSE 3212 l = idsidx 3116 3213 DO m = 1, surf_usm_v(l)%ns 3117 3214 i = surf_usm_v(l)%i(m) … … 3120 3217 temp_pf(k,j,i) = t_window_v(l)%t(iwl,m) 3121 3218 ENDDO 3122 END DO3219 ENDIF 3123 3220 ELSE 3124 DO m = 1, surf_usm_h%ns 3125 i = surf_usm_h%i(m) 3126 j = surf_usm_h%j(m) 3127 k = surf_usm_h%k(m) 3128 temp_pf(k,j,i) = surf_usm_h%t_window_av(iwl,m) 3129 ENDDO 3130 DO l = 0, 3 3221 IF ( idsint == iup_u ) THEN 3222 DO m = 1, surf_usm_h%ns 3223 i = surf_usm_h%i(m) 3224 j = surf_usm_h%j(m) 3225 k = surf_usm_h%k(m) 3226 temp_pf(k,j,i) = surf_usm_h%t_window_av(iwl,m) 3227 ENDDO 3228 ELSE 3229 l = idsidx 3131 3230 DO m = 1, surf_usm_v(l)%ns 3132 3231 i = surf_usm_v(l)%i(m) … … 3135 3234 temp_pf(k,j,i) = surf_usm_v(l)%t_window_av(iwl,m) 3136 3235 ENDDO 3137 END DO3236 ENDIF 3138 3237 ENDIF 3139 3238 … … 3141 3240 !-- green temperature for iwl layer of walls and land 3142 3241 IF ( av == 0 ) THEN 3143 DO m = 1, surf_usm_h%ns 3144 i = surf_usm_h%i(m) 3145 j = surf_usm_h%j(m) 3146 k = surf_usm_h%k(m) 3147 temp_pf(k,j,i) = t_green_h(iwl,m) 3148 ENDDO 3149 DO l = 0, 3 3242 IF ( idsint == iup_u ) THEN 3243 DO m = 1, surf_usm_h%ns 3244 i = surf_usm_h%i(m) 3245 j = surf_usm_h%j(m) 3246 k = surf_usm_h%k(m) 3247 temp_pf(k,j,i) = t_green_h(iwl,m) 3248 ENDDO 3249 ELSE 3250 l = idsidx 3150 3251 DO m = 1, surf_usm_v(l)%ns 3151 3252 i = surf_usm_v(l)%i(m) … … 3154 3255 temp_pf(k,j,i) = t_green_v(l)%t(iwl,m) 3155 3256 ENDDO 3156 END DO3257 ENDIF 3157 3258 ELSE 3158 DO m = 1, surf_usm_h%ns 3159 i = surf_usm_h%i(m) 3160 j = surf_usm_h%j(m) 3161 k = surf_usm_h%k(m) 3162 temp_pf(k,j,i) = surf_usm_h%t_green_av(iwl,m) 3163 ENDDO 3164 DO l = 0, 3 3259 IF ( idsint == iup_u ) THEN 3260 DO m = 1, surf_usm_h%ns 3261 i = surf_usm_h%i(m) 3262 j = surf_usm_h%j(m) 3263 k = surf_usm_h%k(m) 3264 temp_pf(k,j,i) = surf_usm_h%t_green_av(iwl,m) 3265 ENDDO 3266 ELSE 3267 l = idsidx 3165 3268 DO m = 1, surf_usm_v(l)%ns 3166 3269 i = surf_usm_v(l)%i(m) … … 3169 3272 temp_pf(k,j,i) = surf_usm_v(l)%t_green_av(iwl,m) 3170 3273 ENDDO 3171 END DO3274 ENDIF 3172 3275 ENDIF 3173 3276 … … 3180 3283 ! 3181 3284 !-- Rearrange dimensions for NetCDF output 3285 !-- FIXME: this may generate FPE overflow upon conversion from DP to SP 3182 3286 DO j = nys, nyn 3183 3287 DO i = nxl, nxr 3184 3288 DO k = nzb_do, nzt_do 3289 ! print*, j,nys,nyn,i,nxl,nxr,k,nzb_do,nzt_do,local_pf(i,j,k),temp_pf(k,j,i) 3185 3290 local_pf(i,j,k) = temp_pf(k,j,i) 3186 3291 ENDDO … … 3228 3333 var(1:7) == 'usm_dif' .OR. var(1:11) == 'usm_surfcat' .OR. & 3229 3334 var(1:11) == 'usm_surfalb' .OR. var(1:12) == 'usm_surfemis' .OR. & 3230 var(1:16) == 'usm_surfwintrans' ) THEN 3335 var(1:16) == 'usm_surfwintrans' .OR. & 3336 var(1:9) == 'usm_skyvf' .OR. var(1:9) == 'usm_skyvft' ) THEN 3231 3337 3232 3338 found = .TRUE. … … 3416 3522 INTEGER(iwp) :: st !< dummy 3417 3523 3418 REAL(wp) :: c, d, tin, twin , exn3524 REAL(wp) :: c, d, tin, twin 3419 3525 REAL(wp) :: ground_floor_level_l !< local height of ground floor level 3420 3526 REAL(wp) :: z_agl !< height above ground 3527 REAL(wp), DIMENSION(nzb:nzt) :: exn !< value of the Exner function in layers 3421 3528 3422 3529 ! … … 4402 4509 CALL usm_read_anthropogenic_heat() 4403 4510 ENDIF 4404 4511 4405 4512 IF ( plant_canopy ) THEN 4406 4513 … … 4419 4526 4420 4527 !-- Calculate initial surface temperature from pt of adjacent gridbox 4421 exn = ( surface_pressure / 1000.0_wp )**0.286_wp 4528 #if ! defined( __nopointer ) 4529 exn(nzb:nzt) = (hyp(nzb:nzt) / 100000.0_wp )**0.286_wp !< Exner function 4530 #endif 4422 4531 4423 4532 ! … … 4430 4539 k = surf_usm_h%k(m) 4431 4540 4432 t_surf_h(m) = pt(k,j,i) * exn 4433 t_surf_window_h(m) = pt(k,j,i) * exn 4434 t_surf_green_h(m) = pt(k,j,i) * exn 4435 surf_usm_h%pt_surface(m) = pt(k,j,i) * exn 4541 t_surf_h(m) = pt(k,j,i) * exn(k) 4542 t_surf_window_h(m) = pt(k,j,i) * exn(k) 4543 t_surf_green_h(m) = pt(k,j,i) * exn(k) 4544 surf_usm_h%pt_surface(m) = pt(k,j,i) * exn(k) 4436 4545 ENDDO 4437 4546 ! … … 4443 4552 k = surf_usm_v(l)%k(m) 4444 4553 4445 t_surf_v(l)%t(m) = pt(k,j,i) * exn 4446 t_surf_window_v(l)%t(m) = pt(k,j,i) * exn 4447 t_surf_green_v(l)%t(m) = pt(k,j,i) * exn 4448 surf_usm_v(l)%pt_surface(m) = pt(k,j,i) * exn 4554 t_surf_v(l)%t(m) = pt(k,j,i) * exn(k) 4555 t_surf_window_v(l)%t(m) = pt(k,j,i) * exn(k) 4556 t_surf_green_v(l)%t(m) = pt(k,j,i) * exn(k) 4557 surf_usm_v(l)%pt_surface(m) = pt(k,j,i) * exn(k) 4449 4558 ENDDO 4450 4559 ENDDO … … 4496 4605 ENDDO 4497 4606 ENDDO 4498 4607 ELSE 4608 !-- If specified, replace constant wall temperatures with fully 3D values from file 4609 IF ( read_wall_temp_3d ) CALL usm_read_wall_temperature() 4610 ! 4499 4611 ENDIF 4500 4612 … … 4519 4631 t_green_h_p = t_green_h 4520 4632 t_green_v_p = t_green_v 4633 4634 !-- Adjust radiative fluxes for urban surface at model start 4635 !CALL radiation_interaction 4636 !-- TODO: interaction should be called once before first output, 4637 !-- that is not yet possible. 4521 4638 4522 4639 CALL cpu_log( log_point_s(78), 'usm_init', 'stop' ) … … 5029 5146 building_type, & 5030 5147 land_category, & 5031 pedestrant_category, & 5032 ra_horiz_coef, & 5148 naheatlayers, & 5149 pedestrian_category, & 5150 roughness_concrete, & 5151 read_wall_temp_3d, & 5033 5152 roof_category, & 5034 5153 urban_surface, & 5035 5154 usm_anthropogenic_heat, & 5036 5155 usm_material_model, & 5037 usm_lad_rma, &5038 5156 wall_category, & 5039 indoor_model 5040 5041 line = ' ' 5157 indoor_model, & 5158 wall_inner_temperature, & 5159 roof_inner_temperature, & 5160 soil_inner_temperature, & 5161 window_inner_temperature 5042 5162 5043 5163 ! … … 5134 5254 SUBROUTINE usm_read_anthropogenic_heat 5135 5255 5136 INTEGER(iwp) :: i,j, ii5256 INTEGER(iwp) :: i,j,k,ii 5137 5257 REAL(wp) :: heat 5138 5258 5139 5259 !-- allocation of array of sources of anthropogenic heat and their diural profile 5140 ALLOCATE( aheat(n ys:nyn,nxl:nxr) )5141 ALLOCATE( aheatprof( 0:24) )5260 ALLOCATE( aheat(naheatlayers,nys:nyn,nxl:nxr) ) 5261 ALLOCATE( aheatprof(naheatlayers,0:24) ) 5142 5262 5143 5263 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! … … 5154 5274 j = 0 5155 5275 DO 5156 READ( 151, *, err=12, end=13 ) i, j, heat5276 READ( 151, *, err=12, end=13 ) i, j, k, heat 5157 5277 IF ( i >= nxl .AND. i <= nxr .AND. j >= nys .AND. j <= nyn ) THEN 5158 !-- write heat into the array 5159 aheat(j,i) = heat 5278 IF ( k <= naheatlayers .AND. k > get_topography_top_index_ji( j, i, 's' ) ) THEN 5279 !-- write heat into the array 5280 aheat(k,j,i) = heat 5281 ENDIF 5160 5282 ENDIF 5161 5283 CYCLE … … 5186 5308 i = 0 5187 5309 DO 5188 READ( 151, *, err=22, end=23 ) i, heat5189 IF ( i >= 0 .AND. i <= 24 ) THEN5310 READ( 151, *, err=22, end=23 ) i, k, heat 5311 IF ( i >= 0 .AND. i <= 24 .AND. k <= naheatlayers ) THEN 5190 5312 !-- write heat into the array 5191 aheatprof( i) = heat5313 aheatprof(k,i) = heat 5192 5314 ENDIF 5193 5315 CYCLE … … 5196 5318 CALL message( 'usm_read_anthropogenic_heat', 'PA0517', 0, 1, 0, 6, 0 ) 5197 5319 ENDDO 5198 aheatprof( 24) = aheatprof(0)5320 aheatprof(:,24) = aheatprof(:,0) 5199 5321 23 CLOSE(151) 5200 5322 CYCLE … … 5212 5334 5213 5335 !------------------------------------------------------------------------------! 5214 !5215 5336 ! Description: 5216 5337 ! ------------ 5217 !> Soubroutine reads t_surf and t_wall data from restart file(s) 5218 !kanani: Renamed this routine according to corresponging routines in PALM 5219 !kanani: Modified the routine to match rrd_global, from where usm_rrd_local 5220 ! shall be called in the future. This part has not been tested yet. (see virtual_flight_mod) 5221 ! Also, I had some trouble with the allocation of t_surf, since this is a pointer. 5222 ! So, I added some directives here. 5338 !> Soubroutine reads t_surf and t_wall data from restart files 5223 5339 !------------------------------------------------------------------------------! 5224 5340 SUBROUTINE usm_rrd_local( i, k, nxlf, nxlc, nxl_on_file, nxrf, nxrc, & … … 6623 6739 surf_usm_h%albedo(:,m) = surface_params(ialbedo,ip) 6624 6740 ENDIF 6741 !-- Albedo type is 0 (custom), others are replaced later 6742 surf_usm_h%albedo_type(:,m) = 0 6625 6743 !-- Transmissivity 6626 6744 IF ( surf_usm_h%transmissivity(m) < 0.0_wp ) THEN … … 6636 6754 surf_usm_h%lambda_surf_green(m) = surface_params(ilambdas,ip) 6637 6755 ! 6638 !-- roughness relative to concrete6756 !-- roughness length for momentum, heat and humidity 6639 6757 surf_usm_h%z0(m) = surface_params(irough,ip) 6640 ! 6758 surf_usm_h%z0h(m) = surface_params(iroughh,ip) 6759 surf_usm_h%z0q(m) = surface_params(iroughh,ip) 6760 ! 6641 6761 !-- Surface skin layer heat capacity (J mâ2 Kâ1 ) 6642 6762 surf_usm_h%c_surface(m) = surface_params(icsurf,ip) … … 6676 6796 j = surf_usm_v(l)%j(m) 6677 6797 kw = surf_usm_v(l)%k(m) 6678 6798 6679 6799 IF ( l == 3 ) THEN ! westward facing 6680 6800 iw = i … … 6699 6819 ENDIF 6700 6820 6701 IF ( kw <= usm_par(ii,jw,iw) ) THEN 6702 !-- pedestrant zone 6821 IF ( iw < 0 .OR. jw < 0 ) THEN 6822 !-- wall on west or south border of the domain - assign default category 6823 IF ( kw <= roof_height_limit ) THEN 6824 surf_usm_v(l)%surface_types(m) = wall_category !< default category for wall surface in wall zone 6825 ELSE 6826 surf_usm_v(l)%surface_types(m) = roof_category !< default category for wall surface in roof zone 6827 END IF 6828 surf_usm_v(l)%albedo(:,m) = -1.0_wp 6829 surf_usm_v(l)%thickness_wall(m) = -1.0_wp 6830 ELSE IF ( kw <= usm_par(ii,jw,iw) ) THEN 6831 !-- pedestrian zone 6703 6832 IF ( usm_par(ii+1,jw,iw) == 0 ) THEN 6704 surf_usm_v(l)%surface_types(m) = pedestr ant_category !< default category for wall surface in pedestrantzone6833 surf_usm_v(l)%surface_types(m) = pedestrian_category !< default category for wall surface in pedestrian zone 6705 6834 surf_usm_v(l)%albedo(:,m) = -1.0_wp 6706 6835 surf_usm_v(l)%thickness_wall(m) = -1.0_wp … … 6751 6880 ENDIF 6752 6881 ELSE 6753 !-- something wrong 6754 CALL message( 'usm_read_urban_surface', 'PA0505', 1, 2, 0, 6, 0 ) 6882 ! 6883 !-- supply the default category 6884 IF ( kw <= roof_height_limit ) THEN 6885 surf_usm_v(l)%surface_types(m) = wall_category !< default category for wall surface in wall zone 6886 ELSE 6887 surf_usm_v(l)%surface_types(m) = roof_category !< default category for wall surface in roof zone 6888 END IF 6889 surf_usm_v(l)%albedo(:,m) = -1.0_wp 6890 surf_usm_v(l)%thickness_wall(m) = -1.0_wp 6755 6891 ENDIF 6756 6757 6892 ! 6758 6893 !-- Find the type position … … 6767 6902 IF ( ip == -99999 ) THEN 6768 6903 !-- wall category not found 6769 WRITE (message_string, "(A,I 5,A,3I5)") 'wall category ', it, &6904 WRITE (message_string, "(A,I7,A,3I5)") 'wall category ', it, & 6770 6905 ' not found for i,j,k=', iw,jw,kw 6771 CALL message( 'usm_read_urban_surface', 'PA0506', 1, 2, 0, 6, 0 )6906 WRITE(9,*) message_string 6772 6907 ENDIF 6773 6908 ! … … 6776 6911 surf_usm_v(l)%albedo(:,m) = surface_params(ialbedo,ip) 6777 6912 ENDIF 6913 !-- Albedo type is 0 (custom), others are replaced later 6914 surf_usm_v(l)%albedo_type(:,m) = 0 6778 6915 !-- Transmissivity of the windows 6779 6916 IF ( surf_usm_v(l)%transmissivity(m) < 0.0_wp ) THEN … … 6784 6921 surf_usm_v(l)%emissivity(:,m) = surface_params(iemiss,ip) 6785 6922 ! 6786 !-- heat conductivity λS between air and wall ( W mâ2 Kâ1 )6923 !-- heat conductivity lambda S between air and wall ( W m-2 K-1 ) 6787 6924 surf_usm_v(l)%lambda_surf(m) = surface_params(ilambdas,ip) 6788 6925 surf_usm_v(l)%lambda_surf_window(m) = surface_params(ilambdas,ip) 6789 6926 surf_usm_v(l)%lambda_surf_green(m) = surface_params(ilambdas,ip) 6790 6927 ! 6791 !-- roughness relative to concrete6928 !-- roughness length 6792 6929 surf_usm_v(l)%z0(m) = surface_params(irough,ip) 6930 surf_usm_v(l)%z0h(m) = surface_params(iroughh,ip) 6931 surf_usm_v(l)%z0q(m) = surface_params(iroughh,ip) 6793 6932 ! 6794 !-- Surface skin layer heat capacity (J m â2 Kâ1 )6933 !-- Surface skin layer heat capacity (J m-2 K-1 ) 6795 6934 surf_usm_v(l)%c_surface(m) = surface_params(icsurf,ip) 6796 6935 surf_usm_v(l)%c_surface_window(m) = surface_params(icsurf,ip) … … 6809 6948 surf_usm_v(l)%thickness_green(m) = surface_params(ithick,ip) 6810 6949 ENDIF 6811 ! 6812 !-- volumetric heat capacity rho*C of the wall ( J m â3 Kâ1 )6950 ! 6951 !-- volumetric heat capacity rho*C of the wall ( J m-3 K-1 ) 6813 6952 surf_usm_v(l)%rho_c_wall(:,m) = surface_params(irhoC,ip) 6814 6953 surf_usm_v(l)%rho_c_window(:,m) = surface_params(irhoC,ip) 6815 6954 surf_usm_v(l)%rho_c_green(:,m) = surface_params(irhoC,ip) 6816 6955 ! 6817 !-- thermal conductivity λH of the wall (W mâ1 Kâ1 )6956 !-- thermal conductivity lambda H of the wall (W m-1 K-1 ) 6818 6957 surf_usm_v(l)%lambda_h(:,m) = surface_params(ilambdah,ip) 6819 6958 surf_usm_v(l)%lambda_h_window(:,m) = surface_params(ilambdah,ip) … … 6848 6987 6849 6988 END SUBROUTINE usm_read_urban_surface_types 6989 6990 6991 !------------------------------------------------------------------------------! 6992 ! Description: 6993 ! ------------ 6994 ! 6995 !> This function advances through the list of local surfaces to find given 6996 !> x, y, d, z coordinates 6997 !------------------------------------------------------------------------------! 6998 PURE FUNCTION advance_surface(isurfl_start, isurfl_stop, x, y, z, d) & 6999 result(isurfl) 7000 7001 INTEGER(iwp), INTENT(in) :: isurfl_start, isurfl_stop 7002 INTEGER(iwp), INTENT(in) :: x, y, z, d 7003 INTEGER(iwp) :: isx, isy, isz, isd 7004 INTEGER(iwp) :: isurfl 7005 7006 DO isurfl = isurfl_start, isurfl_stop 7007 isx = surfl(ix, isurfl) 7008 isy = surfl(iy, isurfl) 7009 isz = surfl(iz, isurfl) 7010 isd = surfl(id, isurfl) 7011 IF ( isx==x .and. isy==y .and. isz==z .and. isd==d ) RETURN 7012 ENDDO 7013 7014 !-- coordinate not found 7015 isurfl = -1 7016 7017 END FUNCTION 7018 7019 7020 !------------------------------------------------------------------------------! 7021 ! Description: 7022 ! ------------ 7023 ! 7024 !> This subroutine reads temperatures of respective material layers in walls, 7025 !> roofs and ground from input files. Data in the input file must be in 7026 !> standard order, i.e. horizontal surfaces first ordered by x, y and then 7027 !> vertical surfaces ordered by x, y, direction, z 7028 !------------------------------------------------------------------------------! 7029 SUBROUTINE usm_read_wall_temperature 7030 7031 INTEGER(iwp) :: i, j, k, d, ii, iline 7032 INTEGER(iwp) :: isurfl 7033 REAL(wp) :: rtsurf 7034 REAL(wp), DIMENSION(nzb_wall:nzt_wall+1) :: rtwall 7035 7036 7037 7038 7039 DO ii = 0, io_blocks-1 7040 IF ( ii == io_group ) THEN 7041 7042 !-- open wall temperature file 7043 OPEN( 152, file='WALL_TEMPERATURE'//coupling_char, action='read', & 7044 status='old', form='formatted', err=15 ) 7045 7046 isurfl = 0 7047 iline = 1 7048 DO 7049 rtwall = -9999.0_wp !< for incomplete lines 7050 READ( 152, *, err=13, end=14 ) i, j, k, d, rtsurf, rtwall 7051 7052 IF ( nxl <= i .and. i <= nxr .and. & 7053 nys <= j .and. j <= nyn) THEN !< local processor 7054 !-- identify surface id 7055 isurfl = advance_surface(isurfl+1, nsurfl, i, j, k, d) 7056 IF ( isurfl == -1 ) THEN 7057 WRITE(message_string, '(a,4i5,a,i5,a)') 'Coordinates (xyzd) ', i, j, k, d, & 7058 ' on line ', iline, & 7059 ' in file WALL_TEMPERATURE are either not present or out of standard order of surfaces.' 7060 CALL message( 'usm_read_wall_temperature', 'PA0521', 1, 2, 0, 6, 0 ) 7061 ENDIF 7062 7063 !-- assign temperatures 7064 IF ( d == 0 ) THEN 7065 t_surf_h(isurfl) = rtsurf 7066 t_wall_h(:,isurfl) = rtwall(:) 7067 ELSE 7068 t_surf_v(d-1)%t(isurfl) = rtsurf 7069 t_wall_v(d-1)%t(:,isurfl) = rtwall(:) 7070 ENDIF 7071 ENDIF 7072 7073 iline = iline + 1 7074 CYCLE 7075 13 WRITE(message_string, '(a,i5,a)') 'Error reading line ', iline, & 7076 ' in file WALL_TEMPERATURE.' 7077 CALL message( 'usm_read_wall_temperature', 'PA0522', 1, 2, 0, 6, 0 ) 7078 ENDDO 7079 14 CLOSE(152) 7080 CYCLE 7081 15 message_string = 'file WALL_TEMPERATURE'//TRIM(coupling_char)//' does not exist' 7082 CALL message( 'usm_read_wall_temperature', 'PA0523', 1, 2, 0, 6, 0 ) 7083 ENDIF 7084 #if defined( __parallel ) && ! defined ( __check ) 7085 CALL MPI_BARRIER( comm2d, ierr ) 7086 #endif 7087 ENDDO 7088 7089 CALL location_message( ' wall layer temperatures read', .TRUE. ) 7090 7091 END SUBROUTINE usm_read_wall_temperature 7092 6850 7093 6851 7094 … … 6945 7188 IF ( surf_usm_h%r_a_window(m) < 1.0_wp ) & 6946 7189 surf_usm_h%r_a_window(m) = 1.0_wp 6947 6948 6949 !-- the parameterization is developed originally for larger scales6950 !-- (compare with remark in TUF-3D)6951 !-- our first experiences show that the parameterization underestimates6952 !-- r_a in meter resolution.6953 !-- A temporary solution would be multiplication by magic constant :-(.6954 !-- For the moment this is comment out.6955 surf_usm_h%r_a(m) = surf_usm_h%r_a(m) !* ra_horiz_coef6956 surf_usm_h%r_a_window(m) = surf_usm_h%r_a_window(m) !* ra_horiz_coef6957 surf_usm_h%r_a_green(m) = surf_usm_h%r_a_green(m) !* ra_horiz_coef6958 7190 6959 7191 !-- factor for shf_eb … … 7070 7302 !-- calculate fluxes 7071 7303 !-- rad_net_l is never used! 7072 surf_usm_h%rad_net_l(m) = surf_usm_h%frac(0,m) * & 7073 ( surf_usm_h%rad_net_l(m) + & 7074 3.0_wp * sigma_sb * & 7075 t_surf_h(m)**4 - 4.0_wp * sigma_sb * & 7076 t_surf_h(m)**3 * t_surf_h_p(m) ) & 7077 + surf_usm_h%frac(2,m) * & 7078 ( surf_usm_h%rad_net_l(m) + & 7079 3.0_wp * sigma_sb * & 7080 t_surf_window_h(m)**4 - 4.0_wp * sigma_sb * & 7081 t_surf_window_h(m)**3 * t_surf_window_h_p(m) ) & 7082 + surf_usm_h%frac(1,m) * & 7083 ( surf_usm_h%rad_net_l(m) + & 7084 3.0_wp * sigma_sb * & 7085 t_surf_green_h(m)**4 - 4.0_wp * sigma_sb * & 7086 t_surf_green_h(m)**3 * t_surf_green_h_p(m) ) 7304 surf_usm_h%rad_net_l(m) = surf_usm_h%rad_net_l(m) + & 7305 surf_usm_h%frac(0,m) * & 7306 sigma_sb * surf_usm_h%emissivity(0,m) * & 7307 ( t_surf_h_p(m)**4 - t_surf_h(m)**4 ) & 7308 + surf_usm_h%frac(2,m) * & 7309 sigma_sb * surf_usm_h%emissivity(2,m) * & 7310 ( t_surf_window_h_p(m)**4 - t_surf_window_h(m)**4 ) & 7311 + surf_usm_h%frac(1,m) * & 7312 sigma_sb * surf_usm_h%emissivity(1,m) * & 7313 ( t_surf_green_h_p(m)**4 - t_surf_green_h(m)**4 ) 7314 7087 7315 surf_usm_h%wghf_eb(m) = lambda_surface * & 7088 7316 ( t_surf_h_p(m) - t_wall_h(nzb_wall,m) ) … … 7269 7497 7270 7498 !-- calculate fluxes 7271 !-- rad_net_l is never used!7499 !-- prognostic rad_net_l is used just for output! 7272 7500 surf_usm_v(l)%rad_net_l(m) = surf_usm_v(l)%frac(0,m) * & 7273 7501 ( surf_usm_v(l)%rad_net_l(m) + & … … 7322 7550 dtime = mod(simulated_time + time_utc_init, 24.0_wp*3600.0_wp) 7323 7551 dhour = INT(dtime/3600.0_wp) 7324 !-- linear interpolation of coeficient 7325 acoef = (REAL(dhour+1,wp)-dtime/3600.0_wp)*aheatprof(dhour) + (dtime/3600.0_wp-REAL(dhour,wp))*aheatprof(dhour+1) 7326 7327 DO m = 1, surf_usm_h%ns 7328 ! 7552 DO m = 1, naheatlayers 7329 7553 !-- Get indices of respective grid point 7330 7554 i = surf_usm_h%i(m) 7331 7555 j = surf_usm_h%j(m) 7332 7556 k = surf_usm_h%k(m) 7333 7334 IF ( aheat(j,i) > 0.0_wp) THEN7335 !-- TODO the increase of pt in box i,j,nzb_s_inner(j,i)+1in time dt_3d7557 IF ( k > get_topography_top_index_ji( j, i, 's' ) .AND. & 7558 k <= naheatlayers ) THEN 7559 !-- increase of pt in box i,j,k in time dt_3d 7336 7560 !-- given to anthropogenic heat aheat*acoef (W*m-2) 7337 !-- k = nzb_s_inner(j,i)+1 7338 !-- pt(k,j,i) = pt(k,j,i) + aheat(j,i)*acoef*dt_3d/(exn(k)*rho_cp*dz) 7339 !-- Instead of this, we can adjust shf in case AH only at surface 7340 surf_usm_h%shf(m) = surf_usm_h%shf(m) + & 7341 aheat(j,i) * acoef * ddx * ddy / cp 7561 !-- linear interpolation of coeficient 7562 acoef = (REAL(dhour+1,wp)-dtime/3600.0_wp)*aheatprof(k,dhour) + & 7563 (dtime/3600.0_wp-REAL(dhour,wp))*aheatprof(k,dhour+1) 7564 IF ( aheat(k,j,i) > 0.0_wp ) THEN 7565 pt(k,j,i) = pt(k,j,i) + aheat(k,j,i)*acoef*dt_3d/(exn(k)*rho_cp*dz) 7566 ENDIF 7342 7567 ENDIF 7343 7568 ENDDO … … 7437 7662 7438 7663 !------------------------------------------------------------------------------! 7439 !7440 7664 ! Description: 7441 7665 ! ------------ 7442 !> Subroutine writes t_surf and t_wall data into restart files. It is necessary 7443 !> to write start_index and end_index several times 7444 !kanani: Renamed this routine according to corresponging routines in PALM 7445 !kanani: Modified the routine to match wrd_global, from where usm_wrd_local 7446 ! shall be called in the future. This part has not been tested yet. (see virtual_flight_mod) 7447 ! Also, I had some trouble with the allocation of t_surf, since this is a pointer. 7448 ! So, I added some directives here. 7666 !> Subroutine writes t_surf and t_wall data into restart files 7449 7667 !------------------------------------------------------------------------------! 7450 7668 SUBROUTINE usm_wrd_local
Note: See TracChangeset
for help on using the changeset viewer.
