Changeset 2696 for palm/trunk/SOURCE/radiation_model_mod.f90
- Timestamp:
- Dec 14, 2017 5:12:51 PM (6 years ago)
- Location:
- palm/trunk
- Files:
-
- 3 edited
Legend:
- Unmodified
- Added
- Removed
-
palm/trunk
-
palm/trunk/SOURCE
-
palm/trunk/SOURCE/radiation_model_mod.f90
r2604 r2696 1 1 !> @file radiation_model_mod.f90 2 2 !------------------------------------------------------------------------------! 3 ! This file is part of PALM.3 ! This file is part of the PALM model system. 4 4 ! 5 5 ! PALM is free software: you can redistribute it and/or modify it under the … … 25 25 ! ----------------- 26 26 ! $Id$ 27 ! - Improved reading/writing of SVF from/to file (BM) 28 ! - Bugfixes concerning RRTMG as well as average_radiation options (M. Salim) 29 ! - Revised initialization of surface albedo and some minor bugfixes (MS) 30 ! - Update net radiation after running radiation interaction routine (MS) 31 ! - Revisions from M Salim included 32 ! - Adjustment to topography and surface structure (MS) 33 ! - Initialization of albedo and surface emissivity via input file (MS) 34 ! - albedo_pars extended (MS) 35 ! 36 ! 2604 2017-11-06 13:29:00Z schwenkel 27 37 ! bugfix for calculation of effective radius using morrison microphysics 28 38 ! … … 179 189 !> @todo Output of other rrtm arrays (such as volume mixing ratios) 180 190 !> @todo Adapt for use with topography 191 !> @todo Optimize radiation_tendency routines 181 192 !> 182 193 !> @note Many variables have a leading dummy dimension (0:0) in order to … … 188 199 ONLY: dzw, hyp, nc, pt, q, ql, zu, zw 189 200 201 USE calc_mean_profile_mod, & 202 ONLY: calc_mean_profile 203 190 204 USE cloud_parameters, & 191 ONLY: cp, l_d_cp, r ho_l205 ONLY: cp, l_d_cp, r_d, rho_l 192 206 193 207 USE constants, & … … 195 209 196 210 USE control_parameters, & 197 ONLY: cloud_droplets, cloud_physics, g, initializing_actions, & 211 ONLY: cloud_droplets, cloud_physics, coupling_char, dz, g, & 212 initializing_actions, io_blocks, io_group, & 198 213 latitude, longitude, large_scale_forcing, lsf_surf, & 199 microphysics_morrison, pt_surface, rho_surface, & 200 surface_pressure, time_since_reference_point 214 message_string, microphysics_morrison, pt_surface, & 215 rho_surface, surface_pressure, time_since_reference_point 216 217 USE cpulog, & 218 ONLY: cpu_log, log_point, log_point_s 219 220 USE grid_variables, & 221 ONLY: ddx, ddy, dx, dy 201 222 202 223 USE date_and_time_mod, & … … 205 226 206 227 USE indices, & 207 ONLY: nxl, nxlg, nxr, nxrg, nyn, nyng, nys, nysg, nzb, nzt 228 ONLY: nnx, nny, nx, nxl, nxlg, nxr, nxrg, ny, nyn, nyng, nys, nysg, & 229 nzb, nzt 230 231 USE, INTRINSIC :: iso_c_binding 208 232 209 233 USE kinds … … 216 240 #endif 217 241 242 USE netcdf_data_input_mod, & 243 ONLY: albedo_type_f, albedo_pars_f, building_type_f, pavement_type_f, & 244 vegetation_type_f, water_type_f 245 246 USE plant_canopy_model_mod, & 247 ONLY: plant_canopy, pc_heating_rate, lad_s, usm_lad_rma 248 249 USE pegrid 250 218 251 #if defined ( __rrtmg ) 219 252 USE parrrsw, & … … 235 268 ONLY: rrtmg_sw 236 269 #endif 270 USE statistics, & 271 ONLY: hom 272 237 273 USE surface_mod, & 238 ONLY: get_topography_top_index 274 ONLY: get_topography_top_index, surf_def_h, surf_def_v, surf_lsm_h, & 275 surf_lsm_v, surf_type, surf_usm_h, surf_usm_v 239 276 240 277 IMPLICIT NONE … … 281 318 /) 282 319 283 284 320 INTEGER(iwp) :: albedo_type = 9999999, & !< Albedo surface type 285 321 dots_rad = 0 !< starting index for timeseries output … … 291 327 radiation = .FALSE., & !< flag parameter indicating whether the radiation model is used 292 328 sun_up = .TRUE., & !< flag parameter indicating whether the sun is up or down 293 sw_radiation = .TRUE., & !< flag parameter indicing whether shortwave radiation shall be calculated 294 sun_direction = .FALSE. !< flag parameter indicing whether solar direction shall be calculated 329 sw_radiation = .TRUE., & !< flag parameter indicating whether shortwave radiation shall be calculated 330 sun_direction = .FALSE., & !< flag parameter indicating whether solar direction shall be calculated 331 average_radiation = .TRUE., & !< flag to set the calculation of radiation averaging for the domain 332 atm_surfaces = .FALSE., & !< flag parameter indicating wheather surfaces of atmospheric cells will be considered in calculating SVF 333 radiation_interactions = .TRUE., & !< flag to control if radiation interactions via sky-view factors shall be considered 334 surf_reflections = .TRUE. !< flag to switch the calculation of radiation interaction between surfaces. 335 !< When it switched off, only the effect of buildings and trees shadow will 336 !< will be considered. However fewer SVFs are expected. 295 337 296 338 … … 320 362 sun_dir_lon !< solar directional vector in longitudes 321 363 322 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: & 323 alpha, & !< surface broadband albedo (used for clear-sky scheme) 324 emis, & !< surface broadband emissivity 325 rad_lw_out_change_0, & !< change in LW out due to change in surface temperature 326 rad_net, & !< net radiation at the surface 327 rad_net_av !< average of rad_net 328 364 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: rad_net_av !< average of rad_net 329 365 ! 330 366 !-- Land surface albedos for solar zenith angle of 60° after Briegleb (1992) … … 420 456 t_snd !< actual temperature from sounding data (hPa) 421 457 422 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: aldif, & !< longwave diffuse albedo solar angle of 60° 423 aldir, & !< longwave direct albedo solar angle of 60° 424 asdif, & !< shortwave diffuse albedo solar angle of 60° 425 asdir, & !< shortwave direct albedo solar angle of 60° 426 rrtm_ccl4vmr, & !< CCL4 volume mixing ratio (g/mol) 458 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: rrtm_ccl4vmr, & !< CCL4 volume mixing ratio (g/mol) 427 459 rrtm_cfc11vmr, & !< CFC11 volume mixing ratio (g/mol) 428 460 rrtm_cfc12vmr, & !< CFC12 volume mixing ratio (g/mol) … … 433 465 rrtm_cliqwp, & !< in-cloud liquid water path (g/m²) 434 466 rrtm_co2vmr, & !< CO2 volume mixing ratio (g/mol) 435 rrtm_emis, & !< surface emissivity (0-1) 467 rrtm_emis, & !< surface emissivity (0-1) 436 468 rrtm_h2ovmr, & !< H2O volume mixing ratio 437 469 rrtm_n2ovmr, & !< N2O volume mixing ratio … … 459 491 rrtm_swhrc !< RRTM output of incoming shortwave clear sky radiation heating rate (K/d) 460 492 493 494 REAL(wp), DIMENSION(1) :: rrtm_aldif, & !< surface albedo for longwave diffuse radiation 495 rrtm_aldir, & !< surface albedo for longwave direct radiation 496 rrtm_asdif, & !< surface albedo for shortwave diffuse radiation 497 rrtm_asdir !< surface albedo for shortwave direct radiation 498 461 499 ! 462 500 !-- Definition of arrays that are currently not used for calling RRTMG (due to setting of flag parameters) … … 465 503 rad_sw_cs_in, & !< incoming clear sky shortwave radiation (W/m2) (not used) 466 504 rad_sw_cs_out, & !< outgoing clear sky shortwave radiation (W/m2) (not used) 467 rrtm_aldif, & !< surface albedo for longwave diffuse radiation468 rrtm_aldir, & !< surface albedo for longwave direct radiation469 rrtm_asdif, & !< surface albedo for shortwave diffuse radiation470 rrtm_asdir, & !< surface albedo for shortwave direct radiation471 505 rrtm_lw_tauaer, & !< lw aerosol optical depth 472 506 rrtm_lw_taucld, & !< lw in-cloud optical depth … … 481 515 482 516 #endif 517 ! 518 !-- Parameters of urban and land surface models 519 INTEGER(iwp) :: nzu !< number of layers of urban surface (will be calculated) 520 INTEGER(iwp) :: nzub,nzut !< bottom and top layer of urban surface (will be calculated) 521 !-- parameters of urban and land surface models 522 INTEGER(iwp), PARAMETER :: nzut_free = 3 !< number of free layers above top of of topography 523 INTEGER(iwp), PARAMETER :: ndsvf = 2 !< number of dimensions of real values in SVF 524 INTEGER(iwp), PARAMETER :: idsvf = 2 !< number of dimensions of integer values in SVF 525 INTEGER(iwp), PARAMETER :: ndcsf = 2 !< number of dimensions of real values in CSF 526 INTEGER(iwp), PARAMETER :: idcsf = 2 !< number of dimensions of integer values in CSF 527 INTEGER(iwp), PARAMETER :: kdcsf = 4 !< number of dimensions of integer values in CSF calculation array 528 INTEGER(iwp), PARAMETER :: id = 1 !< position of d-index in surfl and surf 529 INTEGER(iwp), PARAMETER :: iz = 2 !< position of k-index in surfl and surf 530 INTEGER(iwp), PARAMETER :: iy = 3 !< position of j-index in surfl and surf 531 INTEGER(iwp), PARAMETER :: ix = 4 !< position of i-index in surfl and surf 532 533 INTEGER(iwp), PARAMETER :: nsurf_type = 21 !< number of surf types incl. phys.(land+urban) & (atm.,sky,boundary) surfaces - 1 534 535 INTEGER(iwp), PARAMETER :: iup_u = 0 !< 0 - index of urban ubward surface (ground or roof) 536 INTEGER(iwp), PARAMETER :: idown_u = 1 !< 1 - index of urban downward surface (overhanging) 537 INTEGER(iwp), PARAMETER :: inorth_u = 2 !< 2 - index of urban northward facing wall 538 INTEGER(iwp), PARAMETER :: isouth_u = 3 !< 3 - index of urban southward facing wall 539 INTEGER(iwp), PARAMETER :: ieast_u = 4 !< 4 - index of urban eastward facing wall 540 INTEGER(iwp), PARAMETER :: iwest_u = 5 !< 5 - index of urban westward facing wall 541 542 INTEGER(iwp), PARAMETER :: iup_l = 6 !< 6 - index of land ubward surface (ground or roof) 543 INTEGER(iwp), PARAMETER :: inorth_l = 7 !< 7 - index of land northward facing wall 544 INTEGER(iwp), PARAMETER :: isouth_l = 8 !< 8 - index of land southward facing wall 545 INTEGER(iwp), PARAMETER :: ieast_l = 9 !< 9 - index of land eastward facing wall 546 INTEGER(iwp), PARAMETER :: iwest_l = 10 !< 10- index of land westward facing wall 547 548 INTEGER(iwp), PARAMETER :: iup_a = 11 !< 11- index of atm. cell ubward virtual surface 549 INTEGER(iwp), PARAMETER :: idown_a = 12 !< 12- index of atm. cell downward virtual surface 550 INTEGER(iwp), PARAMETER :: inorth_a = 13 !< 13- index of atm. cell northward facing virtual surface 551 INTEGER(iwp), PARAMETER :: isouth_a = 14 !< 14- index of atm. cell southward facing virtual surface 552 INTEGER(iwp), PARAMETER :: ieast_a = 15 !< 15- index of atm. cell eastward facing virtual surface 553 INTEGER(iwp), PARAMETER :: iwest_a = 16 !< 16- index of atm. cell westward facing virtual surface 554 555 INTEGER(iwp), PARAMETER :: isky = 17 !< 17 - index of top border of the urban surface layer ("urban sky") 556 INTEGER(iwp), PARAMETER :: inorth_b = 18 !< 18 - index of free north border of the domain (south facing) 557 INTEGER(iwp), PARAMETER :: isouth_b = 19 !< 19 - index of north south border of the domain (north facing) 558 INTEGER(iwp), PARAMETER :: ieast_b = 20 !< 20 - index of east border of the domain (west facing) 559 INTEGER(iwp), PARAMETER :: iwest_b = 21 !< 21 - index of wast border of the domain (east facing) 560 561 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 562 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 563 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 564 !< parameter but set in the code 565 566 567 !-- indices and sizes of urban and land surface models 568 INTEGER(iwp) :: nskys !< number of sky surfaces in local processor 569 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 570 INTEGER(iwp) :: endland !< end index of block of land and roof surfaces INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE :: pct !< top layer of the plant canopy 571 INTEGER(iwp) :: nlands !< number of land and roof surfaces in local processor INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE :: pch !< heights of the plant canopy 572 INTEGER(iwp) :: startwall !< start index of block of wall surfaces INTEGER(iwp) :: npcbl !< number of the plant canopy gridboxes in local processor 573 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, 574 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 575 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 576 577 578 !-- indices and sizes of urban and land surface models 579 INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE :: surfl !< coordinates of i-th local surface in local grid - surfl[:,k] = [d, z, y, x] 580 INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE :: surf !< coordinates of i-th surface in grid - surf[:,k] = [d, z, y, x] 581 INTEGER(iwp) :: nsurfl !< number of all surfaces in local processor 582 INTEGER(iwp), DIMENSION(:), ALLOCATABLE :: nsurfs !< array of number of all surfaces in individual processors 583 INTEGER(iwp) :: startsky !< start index of block of sky 584 INTEGER(iwp) :: endsky !< end index of block of sky 585 INTEGER(iwp) :: startenergy !< start index of block of real surfaces (land, walls and roofs) 586 INTEGER(iwp) :: endenergy !< end index of block of real surfaces (land, walls and roofs) 587 INTEGER(iwp) :: nenergy !< number of real surfaces in local processor 588 INTEGER(iwp) :: nsurf !< global number of surfaces in index array of surfaces (nsurf = proc nsurfs) 589 INTEGER(iwp) :: startborder !< start index of block of border 590 INTEGER(iwp) :: endborder !< end index of block of border 591 INTEGER(iwp), DIMENSION(:), ALLOCATABLE :: surfstart !< starts of blocks of surfaces for individual processors in array surf 592 !< respective block for particular processor is surfstart[iproc]+1 : surfstart[iproc+1] 593 594 !-- block variables needed for calculation of the plant canopy model inside the urban surface model 595 INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE :: pct !< top layer of the plant canopy 596 INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE :: pch !< heights of the plant canopy 597 INTEGER(iwp) :: npcbl !< number of the plant canopy gridboxes in local processor 598 INTEGER(wp), DIMENSION(:,:), ALLOCATABLE :: pcbl !< k,j,i coordinates of l-th local plant canopy box pcbl[:,l] = [k, j, i] 599 REAL(wp), DIMENSION(:), ALLOCATABLE :: pcbinsw !< array of absorbed sw radiation for local plant canopy box 600 REAL(wp), DIMENSION(:), ALLOCATABLE :: pcbinlw !< array of absorbed lw radiation for local plant canopy box 601 602 !-- configuration parameters (they can be setup in PALM config) 603 LOGICAL :: split_diffusion_radiation = .TRUE. !< split direct and diffusion dw radiation 604 !< (.F. in case the radiation model already does it) 605 LOGICAL :: energy_balance_surf_h = .TRUE. !< flag parameter indicating wheather the energy balance is calculated for horizontal surfaces 606 LOGICAL :: energy_balance_surf_v = .TRUE. !< flag parameter indicating wheather the energy balance is calculated for vertical surfaces 607 LOGICAL :: read_svf_on_init = .FALSE. !< flag parameter indicating wheather SVFs will be read from a file at initialization 608 LOGICAL :: write_svf_on_init = .FALSE. !< flag parameter indicating wheather SVFs will be written out to a file 609 LOGICAL :: mrt_factors = .FALSE. !< whether to generate MRT factor files during init 610 INTEGER(iwp) :: nrefsteps = 0 !< number of reflection steps to perform 611 REAL(wp), PARAMETER :: ext_coef = 0.6_wp !< extinction coefficient (a.k.a. alpha) 612 INTEGER(iwp), PARAMETER :: svf_code_len = 15 !< length of code for verification of the end of svf file 613 CHARACTER(svf_code_len), PARAMETER :: svf_code = '*** end svf ***' !< code for verification of the end of svf file 614 INTEGER(iwp), PARAMETER :: usm_version_len = 10 !< length of identification string of usm version 615 CHARACTER(usm_version_len), PARAMETER :: usm_version = 'USM v. 1.0' !< identification of version of binary svf and restart files 616 617 !-- radiation related arrays to be used in radiation_interaction routine 618 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: rad_sw_in_dir !< direct sw radiation 619 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: rad_sw_in_diff !< diffusion sw radiation 620 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: rad_lw_in_diff !< diffusion lw radiation 621 622 !-- parameters required for RRTMG lower boundary condition 623 REAL(wp) :: albedo_urb !< albedo value retuned to RRTMG boundary cond. 624 REAL(wp) :: emissivity_urb !< emissivity value retuned to RRTMG boundary cond. 625 REAL(wp) :: t_rad_urb !< temperature value retuned to RRTMG boundary cond. 626 627 !-- type for calculation of svf 628 TYPE t_svf 629 INTEGER(iwp) :: isurflt !< 630 INTEGER(iwp) :: isurfs !< 631 REAL(wp) :: rsvf !< 632 REAL(wp) :: rtransp !< 633 END TYPE 634 635 !-- type for calculation of csf 636 TYPE t_csf 637 INTEGER(iwp) :: ip !< 638 INTEGER(iwp) :: itx !< 639 INTEGER(iwp) :: ity !< 640 INTEGER(iwp) :: itz !< 641 INTEGER(iwp) :: isurfs !< 642 REAL(wp) :: rsvf !< 643 REAL(wp) :: rtransp !< 644 END TYPE 645 646 !-- arrays storing the values of USM 647 INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE :: svfsurf !< svfsurf[:,isvf] = index of source and target surface for svf[isvf] 648 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: svf !< array of shape view factors+direct irradiation factors for local surfaces 649 REAL(wp), DIMENSION(:), ALLOCATABLE :: surfins !< array of sw radiation falling to local surface after i-th reflection 650 REAL(wp), DIMENSION(:), ALLOCATABLE :: surfinl !< array of lw radiation for local surface after i-th reflection 651 652 !< Inward radiation is also valid for virtual surfaces (radiation leaving domain) 653 REAL(wp), DIMENSION(:), ALLOCATABLE :: surfinsw !< array of sw radiation falling to local surface including radiation from reflections 654 REAL(wp), DIMENSION(:), ALLOCATABLE :: surfinlw !< array of lw radiation falling to local surface including radiation from reflections 655 REAL(wp), DIMENSION(:), ALLOCATABLE :: surfinswdir !< array of direct sw radiation falling to local surface 656 REAL(wp), DIMENSION(:), ALLOCATABLE :: surfinswdif !< array of diffuse sw radiation from sky and model boundary falling to local surface 657 REAL(wp), DIMENSION(:), ALLOCATABLE :: surfinlwdif !< array of diffuse lw radiation from sky and model boundary falling to local surface 658 659 !< Outward radiation is only valid for nonvirtual surfaces 660 REAL(wp), DIMENSION(:), ALLOCATABLE :: surfoutsl !< array of reflected sw radiation for local surface in i-th reflection 661 REAL(wp), DIMENSION(:), ALLOCATABLE :: surfoutll !< array of reflected + emitted lw radiation for local surface in i-th reflection 662 REAL(wp), DIMENSION(:), ALLOCATABLE :: surfouts !< array of reflected sw radiation for all surfaces in i-th reflection 663 REAL(wp), DIMENSION(:), ALLOCATABLE :: surfoutl !< array of reflected + emitted lw radiation for all surfaces in i-th reflection 664 REAL(wp), DIMENSION(:), ALLOCATABLE :: surfoutsw !< array of total sw radiation outgoing from nonvirtual surfaces surfaces after all reflection 665 REAL(wp), DIMENSION(:), ALLOCATABLE :: surfoutlw !< array of total lw radiation outgoing from nonvirtual surfaces surfaces after all reflection 666 REAL(wp), DIMENSION(:), ALLOCATABLE :: surfhf !< array of total radiation flux incoming to minus outgoing from local surface 667 REAL(wp), DIMENSION(:), ALLOCATABLE :: rad_net_l !< local copy of rad_net (net radiation at surface) 668 669 !-- block variables needed for calculation of the plant canopy model inside the urban surface model 670 INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE :: csfsurf !< csfsurf[:,icsf] = index of target surface and csf grid index for csf[icsf] 671 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: csf !< array of plant canopy sink fators + direct irradiation factors (transparency) 672 REAL(wp), DIMENSION(:,:,:), POINTER :: usm_lad !< subset of lad_s within urban surface, transformed to plain Z coordinate 673 REAL(wp), DIMENSION(:), POINTER :: usm_lad_g !< usm_lad globalized (used to avoid MPI RMA calls in raytracing) 674 INTEGER(iwp), DIMENSION(:), ALLOCATABLE :: nzterr, plantt !< temporary global arrays for raytracing 675 676 !-- arrays and variables for calculation of svf and csf 677 TYPE(t_svf), DIMENSION(:), POINTER :: asvf !< pointer to growing svc array 678 TYPE(t_csf), DIMENSION(:), POINTER :: acsf !< pointer to growing csf array 679 TYPE(t_svf), DIMENSION(:), ALLOCATABLE, TARGET :: asvf1, asvf2 !< realizations of svf array 680 TYPE(t_csf), DIMENSION(:), ALLOCATABLE, TARGET :: acsf1, acsf2 !< realizations of csf array 681 INTEGER(iwp) :: nsvfla !< dimmension of array allocated for storage of svf in local processor 682 INTEGER(iwp) :: ncsfla !< dimmension of array allocated for storage of csf in local processor 683 INTEGER(iwp) :: msvf, mcsf !< mod for swapping the growing array 684 INTEGER(iwp), PARAMETER :: gasize = 10000 !< initial size of growing arrays 685 REAL(wp) :: dist_max_svf = -9999.0 !< maximum distance to calculate the minimum svf to be considered. It is 686 !< used to avoid very small SVFs resulting from too far surfaces with mutual visibility 687 INTEGER(iwp) :: nsvfl !< number of svf for local processor 688 INTEGER(iwp) :: ncsfl !< no. of csf in local processor 689 !< needed only during calc_svf but must be here because it is 690 !< shared between subroutines usm_calc_svf and usm_raytrace 691 INTEGER(iwp), DIMENSION(:,:,:), ALLOCATABLE :: gridpcbl !< index of local pcb[k,j,i] 692 693 !-- temporary arrays for calculation of csf in raytracing 694 INTEGER(iwp) :: maxboxesg !< max number of boxes ray can cross in the domain 695 INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE :: boxes !< coordinates of gridboxes being crossed by ray 696 REAL(wp), DIMENSION(:), ALLOCATABLE :: crlens !< array of crossing lengths of ray for particular grid boxes 697 INTEGER(iwp), DIMENSION(:), ALLOCATABLE :: lad_ip !< array of numbers of process where lad is stored 698 #if defined( __parallel ) 699 INTEGER(kind=MPI_ADDRESS_KIND), & 700 DIMENSION(:), ALLOCATABLE :: lad_disp !< array of displaycements of lad in local array of proc lad_ip 701 #endif 702 REAL(wp), DIMENSION(:), ALLOCATABLE :: lad_s_ray !< array of received lad_s for appropriate gridboxes crossed by ray 703 704 705 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 706 !-- Energy balance variables 707 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 708 !-- parameters of the land, roof and wall surfaces 709 REAL(wp), DIMENSION(:), ALLOCATABLE :: albedo_surf !< albedo of the surface 710 REAL(wp), DIMENSION(:), ALLOCATABLE :: emiss_surf !< emissivity of the wall surface 711 483 712 484 713 INTERFACE radiation_check_data_output … … 555 784 END INTERFACE radiation_last_actions 556 785 786 INTERFACE radiation_interaction 787 MODULE PROCEDURE radiation_interaction 788 END INTERFACE radiation_interaction 789 790 INTERFACE radiation_interaction_init 791 MODULE PROCEDURE radiation_interaction_init 792 END INTERFACE radiation_interaction_init 793 794 INTERFACE radiation_radflux_gridbox 795 MODULE PROCEDURE radiation_radflux_gridbox 796 END INTERFACE radiation_radflux_gridbox 797 798 INTERFACE radiation_calc_svf 799 MODULE PROCEDURE radiation_calc_svf 800 END INTERFACE radiation_calc_svf 801 802 INTERFACE radiation_write_svf 803 MODULE PROCEDURE radiation_write_svf 804 END INTERFACE radiation_write_svf 805 806 INTERFACE radiation_read_svf 807 MODULE PROCEDURE radiation_read_svf 808 END INTERFACE radiation_read_svf 809 810 557 811 SAVE 558 812 … … 567 821 radiation_data_output_2d, radiation_data_output_3d, & 568 822 radiation_define_netcdf_grid, radiation_last_actions, & 569 radiation_read_restart_data, radiation_data_output_mask 823 radiation_read_restart_data, radiation_data_output_mask, & 824 radiation_radflux_gridbox, radiation_calc_svf, radiation_write_svf, & 825 radiation_interaction, radiation_interaction_init, & 826 radiation_read_svf 827 828 570 829 571 830 ! 572 831 !-- Public variables and constants / NEEDS SORTING 573 PUBLIC albedo, albedo_type, decl_1, decl_2, decl_3, dots_rad, dt_radiation, emissivity, force_radiation_call,& 574 lat, lon, rad_net, rad_net_av, radiation, radiation_scheme, rad_lw_in, & 575 rad_lw_in_av, rad_lw_out, rad_lw_out_av, rad_lw_out_change_0, & 832 PUBLIC albedo, albedo_type, decl_1, decl_2, decl_3, dots_rad, dt_radiation,& 833 emissivity, force_radiation_call, & 834 lat, lon, rad_net_av, radiation, radiation_scheme, rad_lw_in, & 835 rad_lw_in_av, rad_lw_out, rad_lw_out_av, & 576 836 rad_lw_cs_hr, rad_lw_cs_hr_av, rad_lw_hr, rad_lw_hr_av, rad_sw_in, & 577 837 rad_sw_in_av, rad_sw_out, rad_sw_out_av, rad_sw_cs_hr, & 578 rad_sw_cs_hr_av, rad_sw_hr, rad_sw_hr_av, sigma_sb, & 579 skip_time_do_radiation, solar_constant, time_radiation, & 580 unscheduled_radiation_calls, zenith, calc_zenith, sun_direction, & 581 sun_dir_lat, sun_dir_lon 838 rad_sw_cs_hr_av, rad_sw_hr, rad_sw_hr_av, sigma_sb, solar_constant, & 839 skip_time_do_radiation, time_radiation, unscheduled_radiation_calls,& 840 zenith, calc_zenith, sun_direction, sun_dir_lat, sun_dir_lon, & 841 split_diffusion_radiation, & 842 energy_balance_surf_h, energy_balance_surf_v, write_svf_on_init, & 843 read_svf_on_init, nrefsteps, mrt_factors, dist_max_svf, nsvfl, svf, & 844 svfsurf, surfinsw, surfinlw, surfins, surfinl, surfinswdir, & 845 surfinswdif, surfoutsw, surfoutlw, surfinlwdif, rad_sw_in_dir, & 846 rad_sw_in_diff, rad_lw_in_diff, surfouts, surfoutl, surfoutsl, & 847 surfoutll, idir, jdir, kdir, id, iz, iy, ix, isky, nenergy, nsurfs, & 848 surfstart, surf, surfl, nsurfl, pcbinsw, pcbinlw, pcbl, npcbl, & 849 startenergy, endenergy, iup_u, inorth_u, isouth_u, ieast_u, iwest_u,& 850 iup_l, inorth_l, isouth_l, ieast_l, iwest_l, startsky, endsky, & 851 startborder, endborder, nsurf_type, nzub, nzut, inorth_b,idown_a, & 852 isouth_b, ieast_b, iwest_b, nzu, pch, nsurf, iup_a, inorth_a, & 853 isouth_a, ieast_a, iwest_a, idsvf, ndsvf, idcsf, ndcsf, kdcsf, pct, & 854 radiation_interactions, startwall, startland, endland, endwall 855 582 856 583 857 … … 605 879 CALL radiation_constant 606 880 607 CASE ( 'clear-sky' ) 881 CASE ( 'clear-sky' ) 608 882 CALL radiation_clearsky 609 883 … … 648 922 ENDIF 649 923 unit = 'K/h' 650 651 CASE ( 'rad_lw_in', 'rad_lw_out', 'rad_sw_in', 'rad_sw_out' )652 IF ( .NOT. radiation .OR. radiation_scheme /= 'rrtmg' ) THEN653 message_string = '"output of "' // TRIM( var ) // '" requi' // &654 'res radiation = .TRUE. and ' // &655 'radiation_scheme = "rrtmg"'656 CALL message( 'check_parameters', 'PA0406', 1, 2, 0, 6, 0 )657 ENDIF658 unit = 'W/m2'659 924 660 925 CASE ( 'rad_net*', 'rrtm_aldif*', 'rrtm_aldir*', 'rrtm_asdif*', & … … 878 1143 USE control_parameters, & 879 1144 ONLY: message_string, topography, urban_surface 880 1145 1146 USE netcdf_data_input_mod, & 1147 ONLY: input_pids_static 881 1148 882 1149 IMPLICIT NONE … … 904 1171 905 1172 ENDIF 906 907 IF ( albedo_type == 0 .AND. albedo == 9999999.9_wp .AND. & 908 radiation_scheme == 'clear-sky') THEN 909 message_string = 'radiation_scheme = "clear-sky" in combination' // & 910 'with albedo_type = 0 requires setting of albedo'// & 911 ' /= 9999999.9' 912 CALL message( 'check_parameters', 'PA0410', 1, 2, 0, 6, 0 ) 1173 ! 1174 !-- Checks performed only if data is given via namelist only. 1175 IF ( .NOT. input_pids_static ) THEN 1176 IF ( albedo_type == 0 .AND. albedo == 9999999.9_wp .AND. & 1177 radiation_scheme == 'clear-sky') THEN 1178 message_string = 'radiation_scheme = "clear-sky" in combination' //& 1179 'with albedo_type = 0 requires setting of albedo'//& 1180 ' /= 9999999.9' 1181 CALL message( 'check_parameters', 'PA0410', 1, 2, 0, 6, 0 ) 1182 ENDIF 1183 1184 IF ( albedo_type == 0 .AND. radiation_scheme == 'rrtmg' .AND. & 1185 ( albedo_lw_dif == 9999999.9_wp .OR. albedo_lw_dir == 9999999.9_wp& 1186 .OR. albedo_sw_dif == 9999999.9_wp .OR. albedo_sw_dir == 9999999.9_wp& 1187 ) ) THEN 1188 message_string = 'radiation_scheme = "rrtmg" in combination' // & 1189 'with albedo_type = 0 requires setting of ' // & 1190 'albedo_lw_dif /= 9999999.9' // & 1191 'albedo_lw_dir /= 9999999.9' // & 1192 'albedo_sw_dif /= 9999999.9 and' // & 1193 'albedo_sw_dir /= 9999999.9' 1194 CALL message( 'check_parameters', 'PA0411', 1, 2, 0, 6, 0 ) 1195 ENDIF 913 1196 ENDIF 914 1197 915 IF ( albedo_type == 0 .AND. radiation_scheme == 'rrtmg' .AND. & 916 ( albedo_lw_dif == 9999999.9_wp .OR. albedo_lw_dir == 9999999.9_wp& 917 .OR. albedo_sw_dif == 9999999.9_wp .OR. albedo_sw_dir == 9999999.9_wp& 918 ) ) THEN 919 message_string = 'radiation_scheme = "rrtmg" in combination' // & 920 'with albedo_type = 0 requires setting of ' // & 921 'albedo_lw_dif /= 9999999.9' // & 922 'albedo_lw_dir /= 9999999.9' // & 923 'albedo_sw_dif /= 9999999.9 and' // & 924 'albedo_sw_dir /= 9999999.9' 925 CALL message( 'check_parameters', 'PA0411', 1, 2, 0, 6, 0 ) 1198 ! 1199 !-- Radiation interactions 1200 IF ( urban_surface .AND. .NOT. radiation_interactions ) THEN 1201 message_string = 'radiation_interactions = .T. is required '// & 1202 'when using the urban surface model' 1203 CALL message( 'check_parameters', 'PA0999', 1, 2, 0, 6, 0 ) 926 1204 ENDIF 927 1205 928 !929 !-- The following paramter check is temporarily extended by the urban_surface930 !-- flag, until a better solution comes up to omit this check in case of931 !-- urban surface model is used.932 IF ( topography /= 'flat' .AND. .NOT. urban_surface ) THEN933 message_string = 'radiation scheme cannot be used ' // &934 'in combination with topography /= "flat"'935 CALL message( 'check_parameters', 'PA0414', 1, 2, 0, 6, 0 )936 ENDIF937 1206 938 1207 END SUBROUTINE radiation_check_parameters … … 948 1217 IMPLICIT NONE 949 1218 950 ! 951 !-- Allocate array for storing emissivity 952 IF ( .NOT. ALLOCATED ( emis ) ) THEN 953 ALLOCATE ( emis(nysg:nyng,nxlg:nxrg) ) 954 emis = emissivity 1219 INTEGER(iwp) :: i !< running index x-direction 1220 INTEGER(iwp) :: ind_type !< index of natural land-surface type with respect to albedo array 1221 INTEGER(iwp) :: ioff !< offset in x between surface element reference grid point in atmosphere and actual surface 1222 INTEGER(iwp) :: j !< running index y-direction 1223 INTEGER(iwp) :: joff !< offset in y between surface element reference grid point in atmosphere and actual surface 1224 INTEGER(iwp) :: l !< running index for orientation of vertical surfaces 1225 INTEGER(iwp) :: m !< running index for surface elements 1226 1227 ! 1228 !-- Allocate array for storing the surface net radiation 1229 IF ( .NOT. ALLOCATED ( surf_def_h(0)%rad_net ) .AND. & 1230 surf_def_h(0)%ns > 0 ) THEN 1231 ALLOCATE( surf_def_h(0)%rad_net(1:surf_def_h(0)%ns) ) 1232 surf_def_h(0)%rad_net = 0.0_wp 955 1233 ENDIF 956 957 ! 958 !-- Allocate array for storing the surface net radiation 959 IF ( .NOT. ALLOCATED ( rad_net ) ) THEN 960 ALLOCATE ( rad_net(nysg:nyng,nxlg:nxrg) ) 961 rad_net = 0.0_wp 1234 IF ( .NOT. ALLOCATED ( surf_lsm_h%rad_net ) .AND. & 1235 surf_lsm_h%ns > 0 ) THEN 1236 ALLOCATE( surf_lsm_h%rad_net(1:surf_lsm_h%ns) ) 1237 surf_lsm_h%rad_net = 0.0_wp 962 1238 ENDIF 963 964 ! 965 !-- Allocate array for storing the surface net radiation 966 IF ( .NOT. ALLOCATED ( rad_lw_out_change_0 ) ) THEN 967 ALLOCATE ( rad_lw_out_change_0(nysg:nyng,nxlg:nxrg) ) 968 rad_lw_out_change_0 = 0.0_wp 1239 IF ( .NOT. ALLOCATED ( surf_usm_h%rad_net ) .AND. & 1240 surf_usm_h%ns > 0 ) THEN 1241 ALLOCATE( surf_usm_h%rad_net(1:surf_usm_h%ns) ) 1242 surf_usm_h%rad_net = 0.0_wp 969 1243 ENDIF 1244 DO l = 0, 3 1245 IF ( .NOT. ALLOCATED ( surf_def_v(l)%rad_net ) .AND. & 1246 surf_def_v(l)%ns > 0 ) THEN 1247 ALLOCATE( surf_def_v(l)%rad_net(1:surf_def_v(l)%ns) ) 1248 surf_def_v(l)%rad_net = 0.0_wp 1249 ENDIF 1250 IF ( .NOT. ALLOCATED ( surf_lsm_v(l)%rad_net ) .AND. & 1251 surf_lsm_v(l)%ns > 0 ) THEN 1252 ALLOCATE( surf_lsm_v(l)%rad_net(1:surf_lsm_v(l)%ns) ) 1253 surf_lsm_v(l)%rad_net = 0.0_wp 1254 ENDIF 1255 IF ( .NOT. ALLOCATED ( surf_usm_v(l)%rad_net ) .AND. & 1256 surf_usm_v(l)%ns > 0 ) THEN 1257 ALLOCATE( surf_usm_v(l)%rad_net(1:surf_usm_v(l)%ns) ) 1258 surf_usm_v(l)%rad_net = 0.0_wp 1259 ENDIF 1260 ENDDO 1261 1262 1263 ! 1264 !-- Allocate array for storing the surface longwave (out) radiation change 1265 IF ( .NOT. ALLOCATED ( surf_def_h(0)%rad_lw_out_change_0 ) .AND. & 1266 surf_def_h(0)%ns > 0 ) THEN 1267 ALLOCATE( surf_def_h(0)%rad_lw_out_change_0(1:surf_def_h(0)%ns) ) 1268 surf_def_h(0)%rad_lw_out_change_0 = 0.0_wp 1269 ENDIF 1270 IF ( .NOT. ALLOCATED ( surf_lsm_h%rad_lw_out_change_0 ) .AND. & 1271 surf_lsm_h%ns > 0 ) THEN 1272 ALLOCATE( surf_lsm_h%rad_lw_out_change_0(1:surf_lsm_h%ns) ) 1273 surf_lsm_h%rad_lw_out_change_0 = 0.0_wp 1274 ENDIF 1275 IF ( .NOT. ALLOCATED ( surf_usm_h%rad_lw_out_change_0 ) .AND. & 1276 surf_usm_h%ns > 0 ) THEN 1277 ALLOCATE( surf_usm_h%rad_lw_out_change_0(1:surf_usm_h%ns) ) 1278 surf_usm_h%rad_lw_out_change_0 = 0.0_wp 1279 ENDIF 1280 DO l = 0, 3 1281 IF ( .NOT. ALLOCATED ( surf_def_v(l)%rad_lw_out_change_0 ) .AND. & 1282 surf_def_v(l)%ns > 0 ) THEN 1283 ALLOCATE( surf_def_v(l)%rad_lw_out_change_0(1:surf_def_v(l)%ns) ) 1284 surf_def_v(l)%rad_lw_out_change_0 = 0.0_wp 1285 ENDIF 1286 IF ( .NOT. ALLOCATED ( surf_lsm_v(l)%rad_lw_out_change_0 ) .AND. & 1287 surf_lsm_v(l)%ns > 0 ) THEN 1288 ALLOCATE( surf_lsm_v(l)%rad_lw_out_change_0(1:surf_lsm_v(l)%ns) ) 1289 surf_lsm_v(l)%rad_lw_out_change_0 = 0.0_wp 1290 ENDIF 1291 IF ( .NOT. ALLOCATED ( surf_usm_v(l)%rad_lw_out_change_0 ) .AND. & 1292 surf_usm_v(l)%ns > 0 ) THEN 1293 ALLOCATE( surf_usm_v(l)%rad_lw_out_change_0(1:surf_usm_v(l)%ns) ) 1294 surf_usm_v(l)%rad_lw_out_change_0 = 0.0_wp 1295 ENDIF 1296 ENDDO 1297 1298 ! 1299 !-- Allocate surface arrays for incoming/outgoing short/longwave radiation 1300 IF ( .NOT. ALLOCATED ( surf_def_h(0)%rad_sw_in ) .AND. & 1301 surf_def_h(0)%ns > 0 ) THEN 1302 ALLOCATE( surf_def_h(0)%rad_sw_in(1:surf_def_h(0)%ns) ) 1303 ALLOCATE( surf_def_h(0)%rad_sw_out(1:surf_def_h(0)%ns) ) 1304 ALLOCATE( surf_def_h(0)%rad_lw_in(1:surf_def_h(0)%ns) ) 1305 ALLOCATE( surf_def_h(0)%rad_lw_out(1:surf_def_h(0)%ns) ) 1306 surf_def_h(0)%rad_sw_in = 0.0_wp 1307 surf_def_h(0)%rad_sw_out = 0.0_wp 1308 surf_def_h(0)%rad_lw_in = 0.0_wp 1309 surf_def_h(0)%rad_lw_out = 0.0_wp 1310 ENDIF 1311 IF ( .NOT. ALLOCATED ( surf_lsm_h%rad_sw_in ) .AND. & 1312 surf_lsm_h%ns > 0 ) THEN 1313 ALLOCATE( surf_lsm_h%rad_sw_in(1:surf_lsm_h%ns) ) 1314 ALLOCATE( surf_lsm_h%rad_sw_out(1:surf_lsm_h%ns) ) 1315 ALLOCATE( surf_lsm_h%rad_lw_in(1:surf_lsm_h%ns) ) 1316 ALLOCATE( surf_lsm_h%rad_lw_out(1:surf_lsm_h%ns) ) 1317 surf_lsm_h%rad_sw_in = 0.0_wp 1318 surf_lsm_h%rad_sw_out = 0.0_wp 1319 surf_lsm_h%rad_lw_in = 0.0_wp 1320 surf_lsm_h%rad_lw_out = 0.0_wp 1321 ENDIF 1322 IF ( .NOT. ALLOCATED ( surf_usm_h%rad_sw_in ) .AND. & 1323 surf_usm_h%ns > 0 ) THEN 1324 ALLOCATE( surf_usm_h%rad_sw_in(1:surf_usm_h%ns) ) 1325 ALLOCATE( surf_usm_h%rad_sw_out(1:surf_usm_h%ns) ) 1326 ALLOCATE( surf_usm_h%rad_lw_in(1:surf_usm_h%ns) ) 1327 ALLOCATE( surf_usm_h%rad_lw_out(1:surf_usm_h%ns) ) 1328 surf_usm_h%rad_sw_in = 0.0_wp 1329 surf_usm_h%rad_sw_out = 0.0_wp 1330 surf_usm_h%rad_lw_in = 0.0_wp 1331 surf_usm_h%rad_lw_out = 0.0_wp 1332 ENDIF 1333 DO l = 0, 3 1334 IF ( .NOT. ALLOCATED ( surf_def_v(l)%rad_sw_in ) .AND. & 1335 surf_def_v(l)%ns > 0 ) THEN 1336 ALLOCATE( surf_def_v(l)%rad_sw_in(1:surf_def_v(l)%ns) ) 1337 ALLOCATE( surf_def_v(l)%rad_sw_out(1:surf_def_v(l)%ns) ) 1338 ALLOCATE( surf_def_v(l)%rad_lw_in(1:surf_def_v(l)%ns) ) 1339 ALLOCATE( surf_def_v(l)%rad_lw_out(1:surf_def_v(l)%ns) ) 1340 surf_def_v(l)%rad_sw_in = 0.0_wp 1341 surf_def_v(l)%rad_sw_out = 0.0_wp 1342 surf_def_v(l)%rad_lw_in = 0.0_wp 1343 surf_def_v(l)%rad_lw_out = 0.0_wp 1344 ENDIF 1345 IF ( .NOT. ALLOCATED ( surf_lsm_v(l)%rad_sw_in ) .AND. & 1346 surf_lsm_v(l)%ns > 0 ) THEN 1347 ALLOCATE( surf_lsm_v(l)%rad_sw_in(1:surf_lsm_v(l)%ns) ) 1348 ALLOCATE( surf_lsm_v(l)%rad_sw_out(1:surf_lsm_v(l)%ns) ) 1349 ALLOCATE( surf_lsm_v(l)%rad_lw_in(1:surf_lsm_v(l)%ns) ) 1350 ALLOCATE( surf_lsm_v(l)%rad_lw_out(1:surf_lsm_v(l)%ns) ) 1351 surf_lsm_v(l)%rad_sw_in = 0.0_wp 1352 surf_lsm_v(l)%rad_sw_out = 0.0_wp 1353 surf_lsm_v(l)%rad_lw_in = 0.0_wp 1354 surf_lsm_v(l)%rad_lw_out = 0.0_wp 1355 ENDIF 1356 IF ( .NOT. ALLOCATED ( surf_usm_v(l)%rad_sw_in ) .AND. & 1357 surf_usm_v(l)%ns > 0 ) THEN 1358 ALLOCATE( surf_usm_v(l)%rad_sw_in(1:surf_usm_v(l)%ns) ) 1359 ALLOCATE( surf_usm_v(l)%rad_sw_out(1:surf_usm_v(l)%ns) ) 1360 ALLOCATE( surf_usm_v(l)%rad_lw_in(1:surf_usm_v(l)%ns) ) 1361 ALLOCATE( surf_usm_v(l)%rad_lw_out(1:surf_usm_v(l)%ns) ) 1362 surf_usm_v(l)%rad_sw_in = 0.0_wp 1363 surf_usm_v(l)%rad_sw_out = 0.0_wp 1364 surf_usm_v(l)%rad_lw_in = 0.0_wp 1365 surf_usm_v(l)%rad_lw_out = 0.0_wp 1366 ENDIF 1367 ENDDO 1368 ! 1369 !-- If necessary, allocate surface attribute albedo_type. 1370 !-- Only for default-surfaces, In case urban- or land-surface scheme is 1371 !-- utilized, this has been already allocated. For default surfaces, 1372 !-- no tile approach between different surface fractions is considered, 1373 !-- so first dimension is allocated with zero. 1374 !-- Initialize them with namelist parameter. 1375 ALLOCATE ( surf_def_h(0)%albedo_type(0:0,1:surf_def_h(0)%ns) ) 1376 surf_def_h(0)%albedo_type = albedo_type 1377 1378 DO l = 0, 3 1379 ALLOCATE ( surf_def_v(l)%albedo_type(0:0,1:surf_def_v(l)%ns) ) 1380 surf_def_v(l)%albedo_type = albedo_type 1381 ENDDO 1382 ! 1383 !-- If available, overwrite albedo_type by values read from file. 1384 !-- Again, only required for default-type surfaces. 1385 IF ( albedo_type_f%from_file ) THEN 1386 DO i = nxl, nxr 1387 DO j = nys, nyn 1388 IF ( albedo_type_f%var(j,i) /= albedo_type_f%fill ) THEN 1389 1390 DO m = surf_def_h(0)%start_index(j,i), & 1391 surf_def_h(0)%end_index(j,i) 1392 surf_def_h(0)%albedo_type(0,m) = albedo_type_f%var(j,i) 1393 ENDDO 1394 DO l = 0, 3 1395 ioff = surf_def_v(l)%ioff 1396 joff = surf_def_v(l)%joff 1397 DO m = surf_def_v(l)%start_index(j,i), & 1398 surf_def_v(l)%end_index(j,i) 1399 surf_def_v(l)%albedo_type(0,m) = & 1400 albedo_type_f%var(j+joff,i+ioff) 1401 ENDDO 1402 ENDDO 1403 ENDIF 1404 ENDDO 1405 ENDDO 1406 ENDIF 1407 1408 ! 1409 !-- If necessary, allocate surface attribute emissivity. 1410 !-- Only for default-type surfaces. In case urband- or 1411 !-- land-surface scheme is utilized, this has been already allocated. 1412 !-- Initialize them with namelist parameter. 1413 ALLOCATE ( surf_def_h(0)%emissivity(0:0,1:surf_def_h(0)%ns) ) 1414 surf_def_h(0)%emissivity = emissivity 1415 1416 DO l = 0, 3 1417 ALLOCATE ( surf_def_v(l)%emissivity(0:0,1:surf_def_v(l)%ns) ) 1418 ENDDO 970 1419 971 1420 ! 972 1421 !-- Fix net radiation in case of radiation_scheme = 'constant' 973 1422 IF ( radiation_scheme == 'constant' ) THEN 974 rad_net = net_radiation 1423 IF ( ALLOCATED( surf_def_h(0)%rad_net ) ) & 1424 surf_def_h(0)%rad_net = net_radiation 1425 IF ( ALLOCATED( surf_lsm_h%rad_net ) ) & 1426 surf_lsm_h%rad_net = net_radiation 1427 IF ( ALLOCATED( surf_usm_h%rad_net ) ) & 1428 surf_usm_h%rad_net = net_radiation 1429 ! 1430 !-- Todo: weight with inclination angle 1431 DO l = 0, 3 1432 IF ( ALLOCATED( surf_def_v(l)%rad_net ) ) & 1433 surf_def_v(l)%rad_net = net_radiation 1434 IF ( ALLOCATED( surf_lsm_v(l)%rad_net ) ) & 1435 surf_lsm_v(l)%rad_net = net_radiation 1436 IF ( ALLOCATED( surf_usm_v(l)%rad_net ) ) & 1437 surf_usm_v(l)%rad_net = net_radiation 1438 ENDDO 975 1439 ! radiation = .FALSE. 976 1440 ! … … 986 1450 IF ( radiation_scheme == 'clear-sky' .OR. & 987 1451 radiation_scheme == 'constant') THEN 988 989 ALLOCATE ( alpha(nysg:nyng,nxlg:nxrg) ) 990 991 IF ( .NOT. ALLOCATED ( rad_sw_in ) ) THEN 992 ALLOCATE ( rad_sw_in(0:0,nysg:nyng,nxlg:nxrg) ) 993 ENDIF 994 IF ( .NOT. ALLOCATED ( rad_sw_out ) ) THEN 995 ALLOCATE ( rad_sw_out(0:0,nysg:nyng,nxlg:nxrg) ) 996 ENDIF 997 1452 ! 1453 !-- Allocate average arrays for incoming/outgoing short/longwave radiation 998 1454 IF ( .NOT. ALLOCATED ( rad_sw_in_av ) ) THEN 999 1455 ALLOCATE ( rad_sw_in_av(0:0,nysg:nyng,nxlg:nxrg) ) … … 1003 1459 ENDIF 1004 1460 1005 IF ( .NOT. ALLOCATED ( rad_lw_in ) ) THEN1006 ALLOCATE ( rad_lw_in(0:0,nysg:nyng,nxlg:nxrg) )1007 ENDIF1008 IF ( .NOT. ALLOCATED ( rad_lw_out ) ) THEN1009 ALLOCATE ( rad_lw_out(0:0,nysg:nyng,nxlg:nxrg) )1010 ENDIF1011 1012 1461 IF ( .NOT. ALLOCATED ( rad_lw_in_av ) ) THEN 1013 1462 ALLOCATE ( rad_lw_in_av(0:0,nysg:nyng,nxlg:nxrg) ) … … 1016 1465 ALLOCATE ( rad_lw_out_av(0:0,nysg:nyng,nxlg:nxrg) ) 1017 1466 ENDIF 1018 1019 rad_sw_in = 0.0_wp 1020 rad_sw_out = 0.0_wp 1021 rad_lw_in = 0.0_wp 1022 rad_lw_out = 0.0_wp 1023 1024 ! 1025 !-- Overwrite albedo if manually set in parameter file 1026 IF ( albedo_type /= 0 .AND. albedo_type /= 9999999 .AND. albedo == 9999999.9_wp ) THEN 1027 albedo = albedo_pars(2,albedo_type) 1028 ENDIF 1029 ! 1030 !-- Write albedo to 2d array alpha to allow surface heterogeneities 1031 alpha = albedo 1032 1467 ! 1468 !-- Allocate arrays for broadband albedo, and level 1 initialization 1469 !-- via namelist paramter. 1470 IF ( .NOT. ALLOCATED(surf_def_h(0)%albedo) ) & 1471 ALLOCATE( surf_def_h(0)%albedo(0:0,1:surf_def_h(0)%ns) ) 1472 IF ( .NOT. ALLOCATED(surf_lsm_h%albedo) ) & 1473 ALLOCATE( surf_lsm_h%albedo(0:2,1:surf_lsm_h%ns) ) 1474 IF ( .NOT. ALLOCATED(surf_usm_h%albedo) ) & 1475 ALLOCATE( surf_usm_h%albedo(0:2,1:surf_usm_h%ns) ) 1476 1477 surf_def_h(0)%albedo = albedo 1478 surf_lsm_h%albedo = albedo 1479 surf_usm_h%albedo = albedo 1480 DO l = 0, 3 1481 IF ( .NOT. ALLOCATED( surf_def_v(l)%albedo ) ) & 1482 ALLOCATE( surf_def_v(l)%albedo(0:0,1:surf_def_v(l)%ns) ) 1483 IF ( .NOT. ALLOCATED( surf_lsm_v(l)%albedo ) ) & 1484 ALLOCATE( surf_lsm_v(l)%albedo(0:2,1:surf_lsm_v(l)%ns) ) 1485 IF ( .NOT. ALLOCATED( surf_usm_v(l)%albedo ) ) & 1486 ALLOCATE( surf_usm_v(l)%albedo(0:2,1:surf_usm_v(l)%ns) ) 1487 1488 surf_def_v(l)%albedo = albedo 1489 surf_lsm_v(l)%albedo = albedo 1490 surf_usm_v(l)%albedo = albedo 1491 ENDDO 1492 ! 1493 !-- Level 2 initialization of broadband albedo via given albedo_type. 1494 !-- Only if albedo_type is non-zero 1495 DO m = 1, surf_def_h(0)%ns 1496 IF ( surf_def_h(0)%albedo_type(0,m) /= 0 ) & 1497 surf_def_h(0)%albedo(0,m) = & 1498 albedo_pars(2,surf_def_h(0)%albedo_type(0,m)) 1499 ENDDO 1500 DO m = 1, surf_lsm_h%ns 1501 IF ( surf_lsm_h%albedo_type(0,m) /= 0 ) & 1502 surf_lsm_h%albedo(0,m) = & 1503 albedo_pars(2,surf_lsm_h%albedo_type(0,m)) 1504 IF ( surf_lsm_h%albedo_type(1,m) /= 0 ) & 1505 surf_lsm_h%albedo(1,m) = & 1506 albedo_pars(2,surf_lsm_h%albedo_type(1,m)) 1507 IF ( surf_lsm_h%albedo_type(2,m) /= 0 ) & 1508 surf_lsm_h%albedo(2,m) = & 1509 albedo_pars(2,surf_lsm_h%albedo_type(2,m)) 1510 ENDDO 1511 DO m = 1, surf_usm_h%ns 1512 IF ( surf_usm_h%albedo_type(0,m) /= 0 ) & 1513 surf_usm_h%albedo(0,m) = & 1514 albedo_pars(2,surf_usm_h%albedo_type(0,m)) 1515 IF ( surf_usm_h%albedo_type(1,m) /= 0 ) & 1516 surf_usm_h%albedo(1,m) = & 1517 albedo_pars(2,surf_usm_h%albedo_type(1,m)) 1518 IF ( surf_usm_h%albedo_type(2,m) /= 0 ) & 1519 surf_usm_h%albedo(2,m) = & 1520 albedo_pars(2,surf_usm_h%albedo_type(2,m)) 1521 ENDDO 1522 1523 DO l = 0, 3 1524 DO m = 1, surf_def_v(l)%ns 1525 IF ( surf_def_v(l)%albedo_type(0,m) /= 0 ) & 1526 surf_def_v(l)%albedo(0,m) = & 1527 albedo_pars(2,surf_def_v(l)%albedo_type(0,m)) 1528 ENDDO 1529 DO m = 1, surf_lsm_v(l)%ns 1530 IF ( surf_lsm_v(l)%albedo_type(0,m) /= 0 ) & 1531 surf_lsm_v(l)%albedo(0,m) = & 1532 albedo_pars(2,surf_lsm_v(l)%albedo_type(0,m)) 1533 IF ( surf_lsm_v(l)%albedo_type(1,m) /= 0 ) & 1534 surf_lsm_v(l)%albedo(1,m) = & 1535 albedo_pars(2,surf_lsm_v(l)%albedo_type(1,m)) 1536 IF ( surf_lsm_v(l)%albedo_type(2,m) /= 0 ) & 1537 surf_lsm_v(l)%albedo(2,m) = & 1538 albedo_pars(2,surf_lsm_v(l)%albedo_type(2,m)) 1539 ENDDO 1540 DO m = 1, surf_usm_v(l)%ns 1541 IF ( surf_usm_v(l)%albedo_type(0,m) /= 0 ) & 1542 surf_usm_v(l)%albedo(0,m) = & 1543 albedo_pars(2,surf_usm_v(l)%albedo_type(0,m)) 1544 IF ( surf_usm_v(l)%albedo_type(1,m) /= 0 ) & 1545 surf_usm_v(l)%albedo(1,m) = & 1546 albedo_pars(2,surf_usm_v(l)%albedo_type(1,m)) 1547 IF ( surf_usm_v(l)%albedo_type(2,m) /= 0 ) & 1548 surf_usm_v(l)%albedo(2,m) = & 1549 albedo_pars(2,surf_usm_v(l)%albedo_type(2,m)) 1550 ENDDO 1551 ENDDO 1552 1553 ! 1554 !-- Level 3 initialization at grid points where albedo type is zero. 1555 !-- This case, albedo is taken from file. In case of constant radiation 1556 !-- or clear sky, only broadband albedo is given. 1557 IF ( albedo_pars_f%from_file ) THEN 1558 ! 1559 !-- Horizontal surfaces 1560 DO m = 1, surf_def_h(0)%ns 1561 i = surf_def_h(0)%i(m) 1562 j = surf_def_h(0)%j(m) 1563 IF ( albedo_pars_f%pars_xy(0,j,i) /= albedo_pars_f%fill .AND. & 1564 surf_def_h(0)%albedo_type(0,m) == 0 ) THEN 1565 surf_def_h(0)%albedo(0,m) = albedo_pars_f%pars_xy(0,j,i) 1566 ENDIF 1567 ENDDO 1568 DO m = 1, surf_lsm_h%ns 1569 i = surf_lsm_h%i(m) 1570 j = surf_lsm_h%j(m) 1571 IF ( albedo_pars_f%pars_xy(0,j,i) /= albedo_pars_f%fill ) THEN 1572 IF ( surf_lsm_h%albedo_type(0,m) == 0 ) & 1573 surf_lsm_h%albedo(0,m) = albedo_pars_f%pars_xy(0,j,i) 1574 IF ( surf_lsm_h%albedo_type(1,m) == 0 ) & 1575 surf_lsm_h%albedo(1,m) = albedo_pars_f%pars_xy(0,j,i) 1576 IF ( surf_lsm_h%albedo_type(2,m) == 0 ) & 1577 surf_lsm_h%albedo(2,m) = albedo_pars_f%pars_xy(0,j,i) 1578 ENDIF 1579 ENDDO 1580 DO m = 1, surf_usm_h%ns 1581 i = surf_usm_h%i(m) 1582 j = surf_usm_h%j(m) 1583 IF ( albedo_pars_f%pars_xy(0,j,i) /= albedo_pars_f%fill ) THEN 1584 IF ( surf_usm_h%albedo_type(0,m) == 0 ) & 1585 surf_usm_h%albedo(0,m) = albedo_pars_f%pars_xy(0,j,i) 1586 IF ( surf_usm_h%albedo_type(1,m) == 0 ) & 1587 surf_usm_h%albedo(1,m) = albedo_pars_f%pars_xy(0,j,i) 1588 IF ( surf_usm_h%albedo_type(2,m) == 0 ) & 1589 surf_usm_h%albedo(2,m) = albedo_pars_f%pars_xy(0,j,i) 1590 ENDIF 1591 ENDDO 1592 ! 1593 !-- Vertical surfaces 1594 DO l = 0, 3 1595 1596 ioff = surf_def_v(l)%ioff 1597 joff = surf_def_v(l)%joff 1598 DO m = 1, surf_def_v(l)%ns 1599 i = surf_def_v(l)%i(m) + ioff 1600 j = surf_def_v(l)%j(m) + joff 1601 IF ( albedo_pars_f%pars_xy(0,j,i) /= albedo_pars_f%fill .AND. & 1602 surf_def_v(l)%albedo_type(0,m) == 0 ) THEN 1603 surf_def_v(l)%albedo(0,m) = albedo_pars_f%pars_xy(0,j,i) 1604 ENDIF 1605 ENDDO 1606 1607 ioff = surf_lsm_v(l)%ioff 1608 joff = surf_lsm_v(l)%joff 1609 DO m = 1, surf_lsm_v(l)%ns 1610 i = surf_lsm_v(l)%i(m) + ioff 1611 j = surf_lsm_v(l)%j(m) + joff 1612 IF ( albedo_pars_f%pars_xy(0,j,i) /= albedo_pars_f%fill ) THEN 1613 IF ( surf_lsm_v(l)%albedo_type(0,m) == 0 ) & 1614 surf_lsm_v(l)%albedo(1,m) = albedo_pars_f%pars_xy(0,j,i) 1615 IF ( surf_lsm_v(l)%albedo_type(1,m) == 0 ) & 1616 surf_lsm_v(l)%albedo(1,m) = albedo_pars_f%pars_xy(0,j,i) 1617 IF ( surf_lsm_v(l)%albedo_type(2,m) == 0 ) & 1618 surf_lsm_v(l)%albedo(2,m) = albedo_pars_f%pars_xy(0,j,i) 1619 ENDIF 1620 ENDDO 1621 1622 ioff = surf_usm_v(l)%ioff 1623 joff = surf_usm_v(l)%joff 1624 DO m = 1, surf_usm_h%ns 1625 i = surf_usm_h%i(m) + joff 1626 j = surf_usm_h%j(m) + joff 1627 IF ( albedo_pars_f%pars_xy(0,j,i) /= albedo_pars_f%fill ) THEN 1628 IF ( surf_usm_v(l)%albedo_type(0,m) == 0 ) & 1629 surf_usm_v(l)%albedo(1,m) = albedo_pars_f%pars_xy(0,j,i) 1630 IF ( surf_usm_v(l)%albedo_type(1,m) == 0 ) & 1631 surf_usm_v(l)%albedo(1,m) = albedo_pars_f%pars_xy(0,j,i) 1632 IF ( surf_usm_v(l)%albedo_type(2,m) == 0 ) & 1633 surf_lsm_v(l)%albedo(2,m) = albedo_pars_f%pars_xy(0,j,i) 1634 ENDIF 1635 ENDDO 1636 ENDDO 1637 1638 ENDIF 1033 1639 ! 1034 1640 !-- Initialization actions for RRTMG … … 1036 1642 #if defined ( __rrtmg ) 1037 1643 ! 1038 !-- Allocate albedos 1039 ALLOCATE ( rrtm_aldif(0:0,nysg:nyng,nxlg:nxrg) ) 1040 ALLOCATE ( rrtm_aldir(0:0,nysg:nyng,nxlg:nxrg) ) 1041 ALLOCATE ( rrtm_asdif(0:0,nysg:nyng,nxlg:nxrg) ) 1042 ALLOCATE ( rrtm_asdir(0:0,nysg:nyng,nxlg:nxrg) ) 1043 ALLOCATE ( aldif(nysg:nyng,nxlg:nxrg) ) 1044 ALLOCATE ( aldir(nysg:nyng,nxlg:nxrg) ) 1045 ALLOCATE ( asdif(nysg:nyng,nxlg:nxrg) ) 1046 ALLOCATE ( asdir(nysg:nyng,nxlg:nxrg) ) 1047 1048 IF ( albedo_type /= 0 ) THEN 1049 IF ( albedo_sw_dif == 9999999.9_wp ) THEN 1050 albedo_sw_dif = albedo_pars(0,albedo_type) 1051 albedo_sw_dir = albedo_sw_dif 1644 !-- Allocate albedos for short/longwave radiation, horizontal surfaces. 1645 ALLOCATE ( surf_def_h(0)%aldif(1:surf_def_h(0)%ns) ) 1646 ALLOCATE ( surf_def_h(0)%aldir(1:surf_def_h(0)%ns) ) 1647 ALLOCATE ( surf_def_h(0)%asdif(1:surf_def_h(0)%ns) ) 1648 ALLOCATE ( surf_def_h(0)%asdir(1:surf_def_h(0)%ns) ) 1649 ALLOCATE ( surf_def_h(0)%rrtm_aldif(1:surf_def_h(0)%ns) ) 1650 ALLOCATE ( surf_def_h(0)%rrtm_aldir(1:surf_def_h(0)%ns) ) 1651 ALLOCATE ( surf_def_h(0)%rrtm_asdif(1:surf_def_h(0)%ns) ) 1652 ALLOCATE ( surf_def_h(0)%rrtm_asdir(1:surf_def_h(0)%ns) ) 1653 1654 ALLOCATE ( surf_lsm_h%aldif(1:surf_lsm_h%ns) ) 1655 ALLOCATE ( surf_lsm_h%aldir(1:surf_lsm_h%ns) ) 1656 ALLOCATE ( surf_lsm_h%asdif(1:surf_lsm_h%ns) ) 1657 ALLOCATE ( surf_lsm_h%asdir(1:surf_lsm_h%ns) ) 1658 ALLOCATE ( surf_lsm_h%rrtm_aldif(1:surf_lsm_h%ns) ) 1659 ALLOCATE ( surf_lsm_h%rrtm_aldir(1:surf_lsm_h%ns) ) 1660 ALLOCATE ( surf_lsm_h%rrtm_asdif(1:surf_lsm_h%ns) ) 1661 ALLOCATE ( surf_lsm_h%rrtm_asdir(1:surf_lsm_h%ns) ) 1662 1663 ALLOCATE ( surf_usm_h%aldif(1:surf_usm_h%ns) ) 1664 ALLOCATE ( surf_usm_h%aldir(1:surf_usm_h%ns) ) 1665 ALLOCATE ( surf_usm_h%asdif(1:surf_usm_h%ns) ) 1666 ALLOCATE ( surf_usm_h%asdir(1:surf_usm_h%ns) ) 1667 ALLOCATE ( surf_usm_h%rrtm_aldif(1:surf_usm_h%ns) ) 1668 ALLOCATE ( surf_usm_h%rrtm_aldir(1:surf_usm_h%ns) ) 1669 ALLOCATE ( surf_usm_h%rrtm_asdif(1:surf_usm_h%ns) ) 1670 ALLOCATE ( surf_usm_h%rrtm_asdir(1:surf_usm_h%ns) ) 1671 1672 ! 1673 !-- Allocate broadband albedo (temporary for the current radiation 1674 !-- implementations) 1675 IF ( .NOT. ALLOCATED(surf_def_h(0)%albedo) ) & 1676 ALLOCATE( surf_def_h(0)%albedo(0:0,1:surf_def_h(0)%ns) ) 1677 IF ( .NOT. ALLOCATED(surf_lsm_h%albedo) ) & 1678 ALLOCATE( surf_lsm_h%albedo(0:2,1:surf_lsm_h%ns) ) 1679 IF ( .NOT. ALLOCATED(surf_usm_h%albedo) ) & 1680 ALLOCATE( surf_usm_h%albedo(0:2,1:surf_usm_h%ns) ) 1681 1682 ! 1683 !-- Allocate albedos for short/longwave radiation, vertical surfaces 1684 DO l = 0, 3 1685 ALLOCATE ( surf_def_v(l)%aldif(1:surf_def_v(l)%ns) ) 1686 ALLOCATE ( surf_def_v(l)%aldir(1:surf_def_v(l)%ns) ) 1687 ALLOCATE ( surf_def_v(l)%asdif(1:surf_def_v(l)%ns) ) 1688 ALLOCATE ( surf_def_v(l)%asdir(1:surf_def_v(l)%ns) ) 1689 1690 ALLOCATE ( surf_def_v(l)%rrtm_aldif(1:surf_def_v(l)%ns) ) 1691 ALLOCATE ( surf_def_v(l)%rrtm_aldir(1:surf_def_v(l)%ns) ) 1692 ALLOCATE ( surf_def_v(l)%rrtm_asdif(1:surf_def_v(l)%ns) ) 1693 ALLOCATE ( surf_def_v(l)%rrtm_asdir(1:surf_def_v(l)%ns) ) 1694 1695 ALLOCATE ( surf_lsm_v(l)%aldif(1:surf_lsm_v(l)%ns) ) 1696 ALLOCATE ( surf_lsm_v(l)%aldir(1:surf_lsm_v(l)%ns) ) 1697 ALLOCATE ( surf_lsm_v(l)%asdif(1:surf_lsm_v(l)%ns) ) 1698 ALLOCATE ( surf_lsm_v(l)%asdir(1:surf_lsm_v(l)%ns) ) 1699 1700 ALLOCATE ( surf_lsm_v(l)%rrtm_aldif(1:surf_lsm_v(l)%ns) ) 1701 ALLOCATE ( surf_lsm_v(l)%rrtm_aldir(1:surf_lsm_v(l)%ns) ) 1702 ALLOCATE ( surf_lsm_v(l)%rrtm_asdif(1:surf_lsm_v(l)%ns) ) 1703 ALLOCATE ( surf_lsm_v(l)%rrtm_asdir(1:surf_lsm_v(l)%ns) ) 1704 1705 ALLOCATE ( surf_usm_v(l)%aldif(1:surf_usm_v(l)%ns) ) 1706 ALLOCATE ( surf_usm_v(l)%aldir(1:surf_usm_v(l)%ns) ) 1707 ALLOCATE ( surf_usm_v(l)%asdif(1:surf_usm_v(l)%ns) ) 1708 ALLOCATE ( surf_usm_v(l)%asdir(1:surf_usm_v(l)%ns) ) 1709 1710 ALLOCATE ( surf_usm_v(l)%rrtm_aldif(1:surf_usm_v(l)%ns) ) 1711 ALLOCATE ( surf_usm_v(l)%rrtm_aldir(1:surf_usm_v(l)%ns) ) 1712 ALLOCATE ( surf_usm_v(l)%rrtm_asdif(1:surf_usm_v(l)%ns) ) 1713 ALLOCATE ( surf_usm_v(l)%rrtm_asdir(1:surf_usm_v(l)%ns) ) 1714 ! 1715 !-- Allocate broadband albedo (temporary for the current radiation 1716 !-- implementations) 1717 IF ( .NOT. ALLOCATED( surf_def_v(l)%albedo ) ) & 1718 ALLOCATE( surf_def_v(l)%albedo(0,1:surf_def_v(l)%ns) ) 1719 IF ( .NOT. ALLOCATED( surf_lsm_v(l)%albedo ) ) & 1720 ALLOCATE( surf_lsm_v(l)%albedo(0:2,1:surf_lsm_v(l)%ns) ) 1721 IF ( .NOT. ALLOCATED( surf_usm_v(l)%albedo ) ) & 1722 ALLOCATE( surf_usm_v(l)%albedo(0:2,1:surf_usm_v(l)%ns) ) 1723 1724 ENDDO 1725 ! 1726 !-- Level 1 initialization of spectral albedos via namelist 1727 !-- paramters 1728 IF ( surf_def_h(0)%ns > 0 ) THEN 1729 surf_def_h(0)%aldif = albedo_lw_dif 1730 surf_def_h(0)%aldir = albedo_lw_dir 1731 surf_def_h(0)%asdif = albedo_sw_dif 1732 surf_def_h(0)%asdir = albedo_sw_dir 1733 surf_def_h(0)%albedo = albedo_sw_dif 1734 ENDIF 1735 IF ( surf_lsm_h%ns > 0 ) THEN 1736 surf_lsm_h%aldif = albedo_lw_dif 1737 surf_lsm_h%aldir = albedo_lw_dir 1738 surf_lsm_h%asdif = albedo_sw_dif 1739 surf_lsm_h%asdir = albedo_sw_dir 1740 surf_lsm_h%albedo = albedo_sw_dif 1741 ENDIF 1742 IF ( surf_usm_h%ns > 0 ) THEN 1743 surf_usm_h%aldif = albedo_lw_dif 1744 surf_usm_h%aldir = albedo_lw_dir 1745 surf_usm_h%asdif = albedo_sw_dif 1746 surf_usm_h%asdir = albedo_sw_dir 1747 surf_usm_h%albedo = albedo_sw_dif 1748 ENDIF 1749 1750 DO l = 0, 3 1751 IF ( surf_def_v(l)%ns > 0 ) THEN 1752 surf_def_v(l)%aldif = albedo_lw_dif 1753 surf_def_v(l)%aldir = albedo_lw_dir 1754 surf_def_v(l)%asdif = albedo_sw_dif 1755 surf_def_v(l)%asdir = albedo_sw_dir 1756 surf_def_v(l)%albedo = albedo_sw_dif 1052 1757 ENDIF 1053 IF ( albedo_lw_dif == 9999999.9_wp ) THEN 1054 albedo_lw_dif = albedo_pars(1,albedo_type) 1055 albedo_lw_dir = albedo_lw_dif 1758 1759 IF ( surf_lsm_v(l)%ns > 0 ) THEN 1760 surf_lsm_v(l)%aldif = albedo_lw_dif 1761 surf_lsm_v(l)%aldir = albedo_lw_dir 1762 surf_lsm_v(l)%asdif = albedo_sw_dif 1763 surf_lsm_v(l)%asdir = albedo_sw_dir 1764 surf_lsm_v(l)%albedo = albedo_sw_dif 1056 1765 ENDIF 1766 1767 IF ( surf_usm_v(l)%ns > 0 ) THEN 1768 surf_usm_v(l)%aldif = albedo_lw_dif 1769 surf_usm_v(l)%aldir = albedo_lw_dir 1770 surf_usm_v(l)%asdif = albedo_sw_dif 1771 surf_usm_v(l)%asdir = albedo_sw_dir 1772 surf_usm_v(l)%albedo = albedo_sw_dif 1773 ENDIF 1774 ENDDO 1775 1776 ! 1777 !-- Level 2 initialization of spectral albedos via albedo_type. 1778 !-- Only diffusive albedos (why?) 1779 DO m = 1, surf_def_h(0)%ns 1780 IF ( surf_def_h(0)%albedo_type(0,m) /= 0 ) THEN 1781 surf_def_h(0)%aldif(m) = & 1782 albedo_pars(0,surf_def_h(0)%albedo_type(0,m)) 1783 surf_def_h(0)%asdif(m) = & 1784 albedo_pars(1,surf_def_h(0)%albedo_type(0,m)) 1785 surf_def_h(0)%aldir(m) = & 1786 albedo_pars(0,surf_def_h(0)%albedo_type(0,m)) 1787 surf_def_h(0)%asdir(m) = & 1788 albedo_pars(1,surf_def_h(0)%albedo_type(0,m)) 1789 surf_def_h(0)%albedo(0,m) = & 1790 albedo_pars(2,surf_def_h(0)%albedo_type(0,m)) 1791 ENDIF 1792 ENDDO 1793 DO m = 1, surf_lsm_h%ns 1794 ! 1795 !-- Determine surface type 1796 IF ( surf_lsm_h%vegetation_surface(m) ) ind_type = 0 1797 IF ( surf_lsm_h%pavement_surface(m) ) ind_type = 1 1798 IF ( surf_lsm_h%water_surface(m) ) ind_type = 2 1799 1800 IF ( surf_lsm_h%albedo_type(ind_type,m) /= 0 ) THEN 1801 surf_lsm_h%aldif(m) = & 1802 albedo_pars(0,surf_lsm_h%albedo_type(ind_type,m)) 1803 surf_lsm_h%asdif(m) = & 1804 albedo_pars(1,surf_lsm_h%albedo_type(ind_type,m)) 1805 surf_lsm_h%aldir(m) = & 1806 albedo_pars(0,surf_lsm_h%albedo_type(ind_type,m)) 1807 surf_lsm_h%asdir(m) = & 1808 albedo_pars(1,surf_lsm_h%albedo_type(ind_type,m)) 1809 surf_lsm_h%albedo(:,m) = & 1810 albedo_pars(2,surf_lsm_h%albedo_type(ind_type,m)) 1811 ENDIF 1812 1813 ENDDO 1814 1815 DO m = 1, surf_usm_h%ns 1816 ! 1817 !-- Initialize spectral albedos for urban-type surfaces. Please note, 1818 !-- for urban surfaces a tile approach is applied, so that the 1819 !-- resulting albedo should be calculated via the weighted average of 1820 !-- respective surface fractions. However, for the moment the albedo 1821 !-- is set to the wall-surface value. 1822 IF ( surf_usm_h%albedo_type(0,m) /= 0 ) THEN 1823 surf_usm_h%aldif(m) = & 1824 albedo_pars(0,surf_usm_h%albedo_type(0,m)) 1825 surf_usm_h%asdif(m) = & 1826 albedo_pars(1,surf_usm_h%albedo_type(0,m)) 1827 surf_usm_h%aldir(m) = & 1828 albedo_pars(0,surf_usm_h%albedo_type(0,m)) 1829 surf_usm_h%asdir(m) = & 1830 albedo_pars(1,surf_usm_h%albedo_type(0,m)) 1831 surf_usm_h%albedo(:,m) = & 1832 albedo_pars(2,surf_usm_h%albedo_type(0,m)) 1833 ENDIF 1834 ENDDO 1835 1836 DO l = 0, 3 1837 DO m = 1, surf_def_v(l)%ns 1838 IF ( surf_def_v(l)%albedo_type(0,m) /= 0 ) THEN 1839 surf_def_v(l)%aldif(m) = & 1840 albedo_pars(0,surf_def_v(l)%albedo_type(0,m)) 1841 surf_def_v(l)%asdif(m) = & 1842 albedo_pars(1,surf_def_v(l)%albedo_type(0,m)) 1843 surf_def_v(l)%aldir(m) = & 1844 albedo_pars(0,surf_def_v(l)%albedo_type(0,m)) 1845 surf_def_v(l)%asdir(m) = & 1846 albedo_pars(1,surf_def_v(l)%albedo_type(0,m)) 1847 surf_def_v(l)%albedo(:,m) = & 1848 albedo_pars(2,surf_def_v(l)%albedo_type(0,m)) 1849 ENDIF 1850 ENDDO 1851 DO m = 1, surf_lsm_v(l)%ns 1852 IF ( surf_lsm_v(l)%vegetation_surface(m) ) ind_type = 0 1853 IF ( surf_lsm_v(l)%pavement_surface(m) ) ind_type = 1 1854 IF ( surf_lsm_v(l)%water_surface(m) ) ind_type = 2 1855 1856 IF ( surf_lsm_v(l)%albedo_type(0,m) /= 0 ) THEN 1857 surf_lsm_v(l)%aldif(m) = & 1858 albedo_pars(0,surf_lsm_v(l)%albedo_type(ind_type,m)) 1859 surf_lsm_v(l)%asdif(m) = & 1860 albedo_pars(1,surf_lsm_v(l)%albedo_type(ind_type,m)) 1861 surf_lsm_v(l)%aldir(m) = & 1862 albedo_pars(0,surf_lsm_v(l)%albedo_type(ind_type,m)) 1863 surf_lsm_v(l)%asdir(m) = & 1864 albedo_pars(1,surf_lsm_v(l)%albedo_type(ind_type,m)) 1865 surf_lsm_v(l)%albedo(:,m) = & 1866 albedo_pars(2,surf_lsm_v(l)%albedo_type(ind_type,m)) 1867 ENDIF 1868 ENDDO 1869 1870 DO m = 1, surf_usm_v(l)%ns 1871 ! 1872 !-- Initialize spectral albedos for urban-type surfaces. Please note, 1873 !-- for urban surfaces a tile approach is applied, so that the 1874 !-- resulting albedo should be calculated via the weighted average of 1875 !-- respective surface fractions. However, for the moment the albedo 1876 !-- is set to the wall-surface value. 1877 IF ( surf_usm_v(l)%albedo_type(0,m) /= 0 ) THEN 1878 surf_usm_v(l)%aldif(m) = & 1879 albedo_pars(0,surf_usm_v(l)%albedo_type(0,m)) 1880 surf_usm_v(l)%asdif(m) = & 1881 albedo_pars(1,surf_usm_v(l)%albedo_type(0,m)) 1882 surf_usm_v(l)%aldir(m) = & 1883 albedo_pars(0,surf_usm_v(l)%albedo_type(0,m)) 1884 surf_usm_v(l)%asdir(m) = & 1885 albedo_pars(1,surf_usm_v(l)%albedo_type(0,m)) 1886 surf_usm_v(l)%albedo(:,m) = & 1887 albedo_pars(2,surf_usm_v(l)%albedo_type(0,m)) 1888 ENDIF 1889 ENDDO 1890 ENDDO 1891 ! 1892 !-- Level 3 initialization at grid points where albedo type is zero. 1893 !-- This case, spectral albedos are taken from file if available 1894 IF ( albedo_pars_f%from_file ) THEN 1895 ! 1896 !-- Horizontal 1897 DO m = 1, surf_def_h(0)%ns 1898 i = surf_def_h(0)%i(m) 1899 j = surf_def_h(0)%j(m) 1900 IF ( surf_def_h(0)%albedo_type(0,m) == 0 ) THEN 1901 1902 IF ( albedo_pars_f%pars_xy(1,j,i) /= albedo_pars_f%fill ) & 1903 surf_def_h(0)%albedo(0,m) = albedo_pars_f%pars_xy(1,j,i) 1904 IF ( albedo_pars_f%pars_xy(1,j,i) /= albedo_pars_f%fill ) & 1905 surf_def_h(0)%aldir(m) = albedo_pars_f%pars_xy(1,j,i) 1906 IF ( albedo_pars_f%pars_xy(2,j,i) /= albedo_pars_f%fill ) & 1907 surf_def_h(0)%aldif(m) = albedo_pars_f%pars_xy(2,j,i) 1908 IF ( albedo_pars_f%pars_xy(3,j,i) /= albedo_pars_f%fill ) & 1909 surf_def_h(0)%asdir(m) = albedo_pars_f%pars_xy(3,j,i) 1910 IF ( albedo_pars_f%pars_xy(4,j,i) /= albedo_pars_f%fill ) & 1911 surf_def_h(0)%asdif(m) = albedo_pars_f%pars_xy(4,j,i) 1912 ENDIF 1913 ENDDO 1914 1915 DO m = 1, surf_lsm_h%ns 1916 i = surf_lsm_h%i(m) 1917 j = surf_lsm_h%j(m) 1918 1919 IF ( surf_lsm_h%vegetation_surface(m) ) ind_type = 0 1920 IF ( surf_lsm_h%pavement_surface(m) ) ind_type = 1 1921 IF ( surf_lsm_h%water_surface(m) ) ind_type = 2 1922 1923 IF ( surf_lsm_h%albedo_type(ind_type,m) == 0 ) THEN 1924 IF ( albedo_pars_f%pars_xy(1,j,i) /= albedo_pars_f%fill ) & 1925 surf_lsm_h%albedo(ind_type,m) = albedo_pars_f%pars_xy(1,j,i) 1926 IF ( albedo_pars_f%pars_xy(1,j,i) /= albedo_pars_f%fill ) & 1927 surf_lsm_h%aldir(m) = albedo_pars_f%pars_xy(1,j,i) 1928 IF ( albedo_pars_f%pars_xy(2,j,i) /= albedo_pars_f%fill ) & 1929 surf_lsm_h%aldif(m) = albedo_pars_f%pars_xy(2,j,i) 1930 IF ( albedo_pars_f%pars_xy(3,j,i) /= albedo_pars_f%fill ) & 1931 surf_lsm_h%asdir(m) = albedo_pars_f%pars_xy(3,j,i) 1932 IF ( albedo_pars_f%pars_xy(4,j,i) /= albedo_pars_f%fill ) & 1933 surf_lsm_h%asdif(m) = albedo_pars_f%pars_xy(4,j,i) 1934 ENDIF 1935 ENDDO 1936 1937 DO m = 1, surf_usm_h%ns 1938 i = surf_usm_h%i(m) 1939 j = surf_usm_h%j(m) 1940 ! 1941 !-- At the moment, consider only wall surfaces (index 0) 1942 IF ( surf_usm_h%albedo_type(0,m) == 0 ) THEN 1943 IF ( albedo_pars_f%pars_xy(1,j,i) /= albedo_pars_f%fill ) & 1944 surf_usm_h%albedo(:,m) = albedo_pars_f%pars_xy(1,j,i) 1945 IF ( albedo_pars_f%pars_xy(1,j,i) /= albedo_pars_f%fill ) & 1946 surf_usm_h%aldir(m) = albedo_pars_f%pars_xy(1,j,i) 1947 IF ( albedo_pars_f%pars_xy(2,j,i) /= albedo_pars_f%fill ) & 1948 surf_usm_h%aldif(m) = albedo_pars_f%pars_xy(2,j,i) 1949 IF ( albedo_pars_f%pars_xy(3,j,i) /= albedo_pars_f%fill ) & 1950 surf_usm_h%asdir(m) = albedo_pars_f%pars_xy(3,j,i) 1951 IF ( albedo_pars_f%pars_xy(4,j,i) /= albedo_pars_f%fill ) & 1952 surf_usm_h%asdif(m) = albedo_pars_f%pars_xy(4,j,i) 1953 ENDIF 1954 ENDDO 1955 ! 1956 !-- Vertical 1957 DO l = 0, 3 1958 ioff = surf_def_v(l)%ioff 1959 joff = surf_def_v(l)%joff 1960 1961 DO m = 1, surf_def_v(l)%ns 1962 i = surf_def_v(l)%i(m) 1963 j = surf_def_v(l)%j(m) 1964 IF ( surf_def_v(l)%albedo_type(0,m) == 0 ) THEN 1965 1966 IF ( albedo_pars_f%pars_xy(1,j+joff,i+ioff) /= & 1967 albedo_pars_f%fill ) & 1968 surf_def_v(l)%albedo(0,m) = & 1969 albedo_pars_f%pars_xy(1,j+joff,i+ioff) 1970 IF ( albedo_pars_f%pars_xy(1,j+joff,i+ioff) /= & 1971 albedo_pars_f%fill ) & 1972 surf_def_v(l)%aldir(m) = & 1973 albedo_pars_f%pars_xy(1,j+joff,i+ioff) 1974 IF ( albedo_pars_f%pars_xy(2,j+joff,i+ioff) /= & 1975 albedo_pars_f%fill ) & 1976 surf_def_v(l)%aldif(m) = & 1977 albedo_pars_f%pars_xy(2,j+joff,i+ioff) 1978 IF ( albedo_pars_f%pars_xy(3,j+joff,i+ioff) /= & 1979 albedo_pars_f%fill ) & 1980 surf_def_v(l)%asdir(m) = & 1981 albedo_pars_f%pars_xy(3,j+joff,i+ioff) 1982 IF ( albedo_pars_f%pars_xy(4,j+joff,i+ioff) /= & 1983 albedo_pars_f%fill ) & 1984 surf_def_v(l)%asdif(m) = & 1985 albedo_pars_f%pars_xy(4,j+joff,i+ioff) 1986 ENDIF 1987 ENDDO 1988 1989 ioff = surf_lsm_v(l)%ioff 1990 joff = surf_lsm_v(l)%joff 1991 DO m = 1, surf_lsm_v(l)%ns 1992 i = surf_lsm_v(l)%i(m) 1993 j = surf_lsm_v(l)%j(m) 1994 1995 IF ( surf_lsm_v(l)%vegetation_surface(m) ) ind_type = 0 1996 IF ( surf_lsm_v(l)%pavement_surface(m) ) ind_type = 1 1997 IF ( surf_lsm_v(l)%water_surface(m) ) ind_type = 2 1998 1999 IF ( surf_lsm_v(l)%albedo_type(ind_type,m) == 0 ) THEN 2000 IF ( albedo_pars_f%pars_xy(1,j+joff,i+ioff) /= & 2001 albedo_pars_f%fill ) & 2002 surf_lsm_v(l)%albedo(:,m) = & 2003 albedo_pars_f%pars_xy(1,j+joff,i+ioff) 2004 IF ( albedo_pars_f%pars_xy(1,j+joff,i+ioff) /= & 2005 albedo_pars_f%fill ) & 2006 surf_lsm_v(l)%aldir(m) = & 2007 albedo_pars_f%pars_xy(1,j+joff,i+ioff) 2008 IF ( albedo_pars_f%pars_xy(2,j+joff,i+ioff) /= & 2009 albedo_pars_f%fill ) & 2010 surf_lsm_v(l)%aldif(m) = & 2011 albedo_pars_f%pars_xy(2,j+joff,i+ioff) 2012 IF ( albedo_pars_f%pars_xy(3,j+joff,i+ioff) /= & 2013 albedo_pars_f%fill ) & 2014 surf_lsm_v(l)%asdir(m) = & 2015 albedo_pars_f%pars_xy(3,j+joff,i+ioff) 2016 IF ( albedo_pars_f%pars_xy(4,j+joff,i+ioff) /= & 2017 albedo_pars_f%fill ) & 2018 surf_lsm_v(l)%asdif(m) = & 2019 albedo_pars_f%pars_xy(4,j+joff,i+ioff) 2020 ENDIF 2021 ENDDO 2022 2023 ioff = surf_usm_v(l)%ioff 2024 joff = surf_usm_v(l)%joff 2025 DO m = 1, surf_usm_v(l)%ns 2026 i = surf_usm_v(l)%i(m) 2027 j = surf_usm_v(l)%j(m) 2028 2029 !-- At the moment, consider only wall surfaces (index 0) 2030 IF ( surf_usm_v(l)%albedo_type(0,m) == 0 ) THEN 2031 IF ( albedo_pars_f%pars_xy(1,j+joff,i+ioff) /= & 2032 albedo_pars_f%fill ) & 2033 surf_usm_v(l)%albedo(:,m) = & 2034 albedo_pars_f%pars_xy(1,j+joff,i+ioff) 2035 IF ( albedo_pars_f%pars_xy(1,j+joff,i+ioff) /= & 2036 albedo_pars_f%fill ) & 2037 surf_usm_v(l)%aldir(m) = & 2038 albedo_pars_f%pars_xy(1,j+joff,i+ioff) 2039 IF ( albedo_pars_f%pars_xy(2,j+joff,i+ioff) /= & 2040 albedo_pars_f%fill ) & 2041 surf_usm_v(l)%aldif(m) = & 2042 albedo_pars_f%pars_xy(2,j+joff,i+ioff) 2043 IF ( albedo_pars_f%pars_xy(3,j+joff,i+ioff) /= & 2044 albedo_pars_f%fill ) & 2045 surf_usm_v(l)%asdir(m) = & 2046 albedo_pars_f%pars_xy(3,j+joff,i+ioff) 2047 IF ( albedo_pars_f%pars_xy(4,j+joff,i+ioff) /= & 2048 albedo_pars_f%fill ) & 2049 surf_usm_v(l)%asdif(m) = & 2050 albedo_pars_f%pars_xy(4,j+joff,i+ioff) 2051 ENDIF 2052 ENDDO 2053 ENDDO 2054 1057 2055 ENDIF 1058 2056 1059 aldif(:,:) = albedo_lw_dif1060 aldir(:,:) = albedo_lw_dir1061 asdif(:,:) = albedo_sw_dif1062 asdir(:,:) = albedo_sw_dir1063 2057 ! 1064 2058 !-- Calculate initial values of current (cosine of) the zenith angle and … … 1066 2060 CALL calc_zenith 1067 2061 ! 1068 !-- Calculate initial surface albedo 2062 !-- Calculate initial surface albedo for different surfaces 1069 2063 IF ( .NOT. constant_albedo ) THEN 1070 CALL calc_albedo 2064 ! 2065 !-- Horizontally aligned default, natural and urban surfaces 2066 CALL calc_albedo( surf_def_h(0) ) 2067 CALL calc_albedo( surf_lsm_h ) 2068 CALL calc_albedo( surf_usm_h ) 2069 ! 2070 !-- Vertically aligned default, natural and urban surfaces 2071 DO l = 0, 3 2072 CALL calc_albedo( surf_def_v(l) ) 2073 CALL calc_albedo( surf_lsm_v(l) ) 2074 CALL calc_albedo( surf_usm_v(l) ) 2075 ENDDO 1071 2076 ELSE 1072 rrtm_aldif(0,:,:) = aldif(:,:) 1073 rrtm_aldir(0,:,:) = aldir(:,:) 1074 rrtm_asdif(0,:,:) = asdif(:,:) 1075 rrtm_asdir(0,:,:) = asdir(:,:) 2077 ! 2078 !-- Initialize sun-inclination independent spectral albedos 2079 !-- Horizontal surfaces 2080 IF ( surf_def_h(0)%ns > 0 ) THEN 2081 surf_def_h(0)%rrtm_aldir = surf_def_h(0)%aldir 2082 surf_def_h(0)%rrtm_asdir = surf_def_h(0)%asdir 2083 surf_def_h(0)%rrtm_aldif = surf_def_h(0)%aldif 2084 surf_def_h(0)%rrtm_asdif = surf_def_h(0)%asdif 2085 ENDIF 2086 IF ( surf_lsm_h%ns > 0 ) THEN 2087 surf_lsm_h%rrtm_aldir = surf_lsm_h%aldir 2088 surf_lsm_h%rrtm_asdir = surf_lsm_h%asdir 2089 surf_lsm_h%rrtm_aldif = surf_lsm_h%aldif 2090 surf_lsm_h%rrtm_asdif = surf_lsm_h%asdif 2091 ENDIF 2092 IF ( surf_usm_h%ns > 0 ) THEN 2093 surf_usm_h%rrtm_aldir = surf_usm_h%aldir 2094 surf_usm_h%rrtm_asdir = surf_usm_h%asdir 2095 surf_usm_h%rrtm_aldif = surf_usm_h%aldif 2096 surf_usm_h%rrtm_asdif = surf_usm_h%asdif 2097 ENDIF 2098 ! 2099 !-- Vertical surfaces 2100 DO l = 0, 3 2101 IF ( surf_def_h(0)%ns > 0 ) THEN 2102 surf_def_v(l)%rrtm_aldir = surf_def_v(l)%aldir 2103 surf_def_v(l)%rrtm_asdir = surf_def_v(l)%asdir 2104 surf_def_v(l)%rrtm_aldif = surf_def_v(l)%aldif 2105 surf_def_v(l)%rrtm_asdif = surf_def_v(l)%asdif 2106 ENDIF 2107 IF ( surf_lsm_v(l)%ns > 0 ) THEN 2108 surf_lsm_v(l)%rrtm_aldir = surf_lsm_v(l)%aldir 2109 surf_lsm_v(l)%rrtm_asdir = surf_lsm_v(l)%asdir 2110 surf_lsm_v(l)%rrtm_aldif = surf_lsm_v(l)%aldif 2111 surf_lsm_v(l)%rrtm_asdif = surf_lsm_v(l)%asdif 2112 ENDIF 2113 IF ( surf_usm_v(l)%ns > 0 ) THEN 2114 surf_usm_v(l)%rrtm_aldir = surf_usm_v(l)%aldir 2115 surf_usm_v(l)%rrtm_asdir = surf_usm_v(l)%asdir 2116 surf_usm_v(l)%rrtm_aldif = surf_usm_v(l)%aldif 2117 surf_usm_v(l)%rrtm_asdif = surf_usm_v(l)%asdif 2118 ENDIF 2119 ENDDO 2120 1076 2121 ENDIF 1077 1078 !1079 !-- Allocate surface emissivity1080 ALLOCATE ( rrtm_emis(0:0,1:nbndlw+1) )1081 rrtm_emis = emissivity1082 2122 1083 2123 ! … … 1170 2210 1171 2211 ! 1172 !-- Allocate dummy array for storing surface temperature 2212 !-- Allocate 1-element array for surface temperature 2213 !-- (RRTMG anticipates an array as passed argument). 1173 2214 ALLOCATE ( rrtm_tsfc(1) ) 2215 ! 2216 !-- Allocate surface emissivity. 2217 !-- Values will be given directly before calling rrtm_lw. 2218 ALLOCATE ( rrtm_emis(0:0,1:nbndlw+1) ) 1174 2219 1175 2220 ! … … 1234 2279 IMPLICIT NONE 1235 2280 1236 INTEGER(iwp) :: i, j, k !< loop indices 1237 REAL(wp) :: exn, & !< Exner functions at surface 1238 exn1, & !< Exner functions at first grid level 1239 pt1 !< potential temperature at first grid level 2281 INTEGER(iwp) :: l !< running index for surface orientation 2282 2283 REAL(wp) :: exn !< Exner functions at surface 2284 REAL(wp) :: exn1 !< Exner functions at first grid level or at urban layer top 2285 REAL(wp) :: pt1 !< potential temperature at first grid level or mean value at urban layer top 2286 REAL(wp) :: pt1_l !< potential temperature at first grid level or mean value at urban layer top at local subdomain 2287 REAL(wp) :: ql1 !< liquid water mixing ratio at first grid level or mean value at urban layer top 2288 REAL(wp) :: ql1_l !< liquid water mixing ratio at first grid level or mean value at urban layer top at local subdomain 2289 2290 TYPE(surf_type), POINTER :: surf !< pointer on respective surface type, used to generalize routine 1240 2291 1241 2292 ! … … 1246 2297 !-- Calculate sky transmissivity 1247 2298 sky_trans = 0.6_wp + 0.2_wp * zenith(0) 1248 1249 ! 1250 !-- Calculate value of the Exner function 2299 ! 2300 !-- Calculate value of the Exner function at model surface 1251 2301 exn = (surface_pressure / 1000.0_wp )**0.286_wp 1252 2302 ! 1253 !-- Calculate radiation fluxes and net radiation (rad_net) for each grid 1254 !-- point 1255 DO i = nxlg, nxrg 1256 DO j = nysg, nyng 1257 ! 1258 !-- Obtain vertical index of topography top 1259 k = get_topography_top_index( j, i, 's' ) 1260 1261 exn1 = (hyp(k+1) / 100000.0_wp )**0.286_wp 1262 1263 rad_sw_in(0,j,i) = solar_constant * sky_trans * zenith(0) 1264 rad_sw_out(0,j,i) = alpha(j,i) * rad_sw_in(0,j,i) 1265 rad_lw_out(0,j,i) = emis(j,i) * sigma_sb * (pt(k,j,i) * exn)**4 1266 1267 IF ( cloud_physics .OR. cloud_droplets ) THEN 1268 pt1 = pt(k+1,j,i) + l_d_cp / exn1 * ql(k+1,j,i) 1269 rad_lw_in(0,j,i) = 0.8_wp * sigma_sb * (pt1 * exn1)**4 2303 !-- In case averaged radiation is used, calculate mean temperature and 2304 !-- liquid water mixing ratio at the urban-layer top. 2305 IF ( average_radiation ) THEN 2306 pt1 = 0.0_wp 2307 IF ( cloud_physics ) ql1 = 0.0_wp 2308 2309 pt1_l = SUM( pt(nzut,nys:nyn,nxl:nxr) ) 2310 IF ( cloud_physics ) ql1_l = SUM( ql(nzut,nys:nyn,nxl:nxr) ) 2311 2312 #if defined( __parallel ) 2313 IF ( collective_wait ) CALL MPI_BARRIER( comm2d, ierr ) 2314 CALL MPI_ALLREDUCE( pt1_l, pt1, 1, MPI_REAL, MPI_SUM, comm2d, ierr ) 2315 IF ( cloud_physics ) & 2316 CALL MPI_ALLREDUCE( ql1_l, ql1, 1, MPI_REAL, MPI_SUM, comm2d, ierr ) 2317 #else 2318 pt1 = pt1_l 2319 IF ( cloud_physics ) ql1 = ql1_l 2320 #endif 2321 IF ( cloud_physics ) pt1 = pt1 + l_d_cp / exn1 * ql1 2322 ! 2323 !-- Finally, divide by number of grid points 2324 pt1 = pt1 / REAL( ( nx + 1 ) * ( ny + 1 ), KIND=wp ) 2325 ENDIF 2326 ! 2327 !-- Call clear-sky calculation for each surface orientation. 2328 !-- First, horizontal surfaces 2329 surf => surf_def_h(0) 2330 CALL radiation_clearsky_surf 2331 surf => surf_lsm_h 2332 CALL radiation_clearsky_surf 2333 surf => surf_usm_h 2334 CALL radiation_clearsky_surf 2335 ! 2336 !-- Vertical surfaces 2337 DO l = 0, 3 2338 surf => surf_def_v(l) 2339 CALL radiation_clearsky_surf 2340 surf => surf_lsm_v(l) 2341 CALL radiation_clearsky_surf 2342 surf => surf_usm_v(l) 2343 CALL radiation_clearsky_surf 2344 ENDDO 2345 2346 CONTAINS 2347 2348 SUBROUTINE radiation_clearsky_surf 2349 2350 IMPLICIT NONE 2351 2352 INTEGER(iwp) :: i !< index x-direction 2353 INTEGER(iwp) :: ioff !< offset between surface element and adjacent grid point along x 2354 INTEGER(iwp) :: j !< index y-direction 2355 INTEGER(iwp) :: joff !< offset between surface element and adjacent grid point along y 2356 INTEGER(iwp) :: k !< index z-direction 2357 INTEGER(iwp) :: koff !< offset between surface element and adjacent grid point along z 2358 INTEGER(iwp) :: m !< running index for surface elements 2359 2360 IF ( surf%ns < 1 ) RETURN 2361 2362 ! 2363 !-- Calculate radiation fluxes and net radiation (rad_net) assuming 2364 !-- homogeneous urban radiation conditions. 2365 IF ( average_radiation ) THEN 2366 2367 k = nzut 2368 ! 2369 !-- MS: Why k+1 ? 2370 !-- MS: @Mohamed: emissivity belongs now to surface type with 3 different values for each 2371 !-- surface element (due to tile approach). 2372 exn1 = ( hyp(k+1) / 100000.0_wp )**0.286_wp 2373 2374 surf%rad_sw_in = solar_constant * sky_trans * zenith(0) 2375 surf%rad_sw_out = albedo_urb * surf%rad_sw_in 2376 2377 surf%rad_lw_in = 0.8_wp * sigma_sb * (pt1 * exn1)**4 2378 2379 surf%rad_lw_out = emissivity_urb * sigma_sb * (t_rad_urb)**4 & 2380 + (1.0_wp - emissivity_urb) * surf%rad_lw_in 2381 2382 surf%rad_net = surf%rad_sw_in - surf%rad_sw_out & 2383 + surf%rad_lw_in - surf%rad_lw_out 2384 2385 surf%rad_lw_out_change_0 = 3.0_wp * emissivity_urb * sigma_sb & 2386 * (t_rad_urb)**3 2387 2388 ! 2389 !-- Calculate radiation fluxes and net radiation (rad_net) for each surface 2390 !-- element. 1270 2391 ELSE 1271 rad_lw_in(0,j,i) = 0.8_wp * sigma_sb * (pt(k+1,j,i) * exn1)**4 2392 ! 2393 !-- Determine index offset between surface element and adjacent 2394 !-- atmospheric grid point (depends on surface orientation). 2395 ioff = surf%ioff 2396 joff = surf%joff 2397 koff = surf%koff 2398 2399 DO m = 1, surf%ns 2400 i = surf%i(m) 2401 j = surf%j(m) 2402 k = surf%k(m) 2403 2404 exn1 = (hyp(k) / 100000.0_wp )**0.286_wp 2405 2406 surf%rad_sw_in(m) = solar_constant * sky_trans * zenith(0) 2407 ! 2408 !-- Weighted average according to surface fraction. 2409 !-- In case no surface fraction is given ( default-type ) 2410 !-- no weighted averaging is performed ( only one surface type per 2411 !-- surface element ). 2412 IF ( ALLOCATED( surf%frac ) ) THEN 2413 2414 surf%rad_sw_out(m) = ( surf%frac(0,m) * surf%albedo(0,m) & 2415 + surf%frac(1,m) * surf%albedo(1,m) & 2416 + surf%frac(2,m) * surf%albedo(2,m) ) & 2417 * surf%rad_sw_in(m) 2418 2419 surf%rad_lw_out(m) = ( surf%frac(0,m) * surf%emissivity(0,m)& 2420 + surf%frac(1,m) * surf%emissivity(1,m)& 2421 + surf%frac(2,m) * surf%emissivity(2,m)& 2422 ) & 2423 * sigma_sb & 2424 * ( pt(k+koff,j+joff,i+ioff) * exn )**4 2425 2426 2427 surf%rad_lw_out_change_0(m) = & 2428 ( surf%frac(0,m) * surf%emissivity(0,m) & 2429 + surf%frac(1,m) * surf%emissivity(1,m) & 2430 + surf%frac(2,m) * surf%emissivity(2,m) & 2431 ) * 3.0_wp * sigma_sb & 2432 * ( pt(k+koff,j+joff,i+ioff) * exn )** 3 2433 2434 ELSE 2435 2436 surf%rad_sw_out(m) = surf%albedo(0,m) * surf%rad_sw_in(m) 2437 2438 surf%rad_lw_out(m) = surf%emissivity(0,m) & 2439 * sigma_sb & 2440 * ( pt(k+koff,j+joff,i+ioff) * exn )**4 2441 2442 2443 surf%rad_lw_out_change_0(m) = surf%emissivity(0,m) & 2444 * 3.0_wp * sigma_sb & 2445 * ( pt(k+koff,j+joff,i+ioff) * exn )** 3 2446 2447 ENDIF 2448 2449 IF ( cloud_physics ) THEN 2450 pt1 = pt(k,j,i) + l_d_cp / exn1 * ql(k,j,i) 2451 surf%rad_lw_in(m) = 0.8_wp * sigma_sb * (pt1 * exn1)**4 2452 ELSE 2453 surf%rad_lw_in(m) = 0.8_wp * sigma_sb * (pt(k,j,i) * exn1)**4 2454 ENDIF 2455 2456 surf%rad_net(m) = surf%rad_sw_in(m) - surf%rad_sw_out(m) & 2457 + surf%rad_lw_in(m) - surf%rad_lw_out(m) 2458 2459 ENDDO 2460 1272 2461 ENDIF 1273 2462 1274 rad_net(j,i) = rad_sw_in(0,j,i) - rad_sw_out(0,j,i) & 1275 + rad_lw_in(0,j,i) - rad_lw_out(0,j,i) 1276 1277 1278 rad_lw_out_change_0(j,i) = 3.0_wp * sigma_sb * emis(j,i) & 1279 * (pt(k,j,i) * exn) ** 3 1280 1281 ENDDO 1282 ENDDO 2463 END SUBROUTINE radiation_clearsky_surf 1283 2464 1284 2465 END SUBROUTINE radiation_clearsky … … 1295 2476 IMPLICIT NONE 1296 2477 1297 INTEGER(iwp) :: i, j, k !< loop indices 1298 REAL(wp) :: exn, & !< Exner functions at surface 1299 exn1, & !< Exner functions at first grid level 1300 pt1 !< potential temperature at first grid level 2478 INTEGER(iwp) :: l !< running index for surface orientation 2479 2480 REAL(wp) :: exn !< Exner functions at surface 2481 REAL(wp) :: exn1 !< Exner functions at first grid level 2482 REAL(wp) :: pt1 !< potential temperature at first grid level or mean value at urban layer top 2483 REAL(wp) :: pt1_l !< potential temperature at first grid level or mean value at urban layer top at local subdomain 2484 REAL(wp) :: ql1 !< liquid water mixing ratio at first grid level or mean value at urban layer top 2485 REAL(wp) :: ql1_l !< liquid water mixing ratio at first grid level or mean value at urban layer top at local subdomain 2486 2487 TYPE(surf_type), POINTER :: surf !< pointer on respective surface type, used to generalize routine 1301 2488 1302 2489 ! … … 1304 2491 exn = (surface_pressure / 1000.0_wp )**0.286_wp 1305 2492 ! 1306 !-- Prescribe net radiation and estimate the remaining radiative fluxes 1307 DO i = nxlg, nxrg 1308 DO j = nysg, nyng 1309 ! 1310 !-- Obtain vertical index of topography top. So far it is identical to 1311 !-- nzb. 1312 k = get_topography_top_index( j, i, 's' ) 1313 1314 rad_net(j,i) = net_radiation 1315 1316 exn1 = (hyp(k+1) / 100000.0_wp )**0.286_wp 1317 1318 IF ( cloud_physics .OR. cloud_droplets ) THEN 1319 pt1 = pt(k+1,j,i) + l_d_cp / exn1 * ql(k+1,j,i) 1320 rad_lw_in(0,j,i) = 0.8_wp * sigma_sb * (pt1 * exn1)**4 2493 !-- In case averaged radiation is used, calculate mean temperature and 2494 !-- liquid water mixing ratio at the urban-layer top. 2495 IF ( average_radiation ) THEN 2496 pt1 = 0.0_wp 2497 IF ( cloud_physics ) ql1 = 0.0_wp 2498 2499 pt1_l = SUM( pt(nzut,nys:nyn,nxl:nxr) ) 2500 IF ( cloud_physics ) ql1_l = SUM( ql(nzut,nys:nyn,nxl:nxr) ) 2501 2502 #if defined( __parallel ) 2503 IF ( collective_wait ) CALL MPI_BARRIER( comm2d, ierr ) 2504 CALL MPI_ALLREDUCE( pt1_l, pt1, 1, MPI_REAL, MPI_SUM, comm2d, ierr ) 2505 IF ( cloud_physics ) & 2506 CALL MPI_ALLREDUCE( ql1_l, ql1, 1, MPI_REAL, MPI_SUM, comm2d, ierr ) 2507 #else 2508 pt1 = pt1_l 2509 IF ( cloud_physics ) ql1 = ql1_l 2510 #endif 2511 IF ( cloud_physics ) pt1 = pt1 + l_d_cp / exn1 * ql1 2512 ! 2513 !-- Finally, divide by number of grid points 2514 pt1 = pt1 / REAL( ( nx + 1 ) * ( ny + 1 ), KIND=wp ) 2515 ENDIF 2516 2517 ! 2518 !-- First, horizontal surfaces 2519 surf => surf_def_h(0) 2520 CALL radiation_constant_surf 2521 surf => surf_lsm_h 2522 CALL radiation_constant_surf 2523 surf => surf_usm_h 2524 CALL radiation_constant_surf 2525 ! 2526 !-- Vertical surfaces 2527 DO l = 0, 3 2528 surf => surf_def_v(l) 2529 CALL radiation_constant_surf 2530 surf => surf_lsm_v(l) 2531 CALL radiation_constant_surf 2532 surf => surf_usm_v(l) 2533 CALL radiation_constant_surf 2534 ENDDO 2535 2536 CONTAINS 2537 2538 SUBROUTINE radiation_constant_surf 2539 2540 IMPLICIT NONE 2541 2542 INTEGER(iwp) :: i !< index x-direction 2543 INTEGER(iwp) :: ioff !< offset between surface element and adjacent grid point along x 2544 INTEGER(iwp) :: j !< index y-direction 2545 INTEGER(iwp) :: joff !< offset between surface element and adjacent grid point along y 2546 INTEGER(iwp) :: k !< index z-direction 2547 INTEGER(iwp) :: koff !< offset between surface element and adjacent grid point along z 2548 INTEGER(iwp) :: m !< running index for surface elements 2549 2550 IF ( surf%ns < 1 ) RETURN 2551 2552 !-- Calculate homogenoeus urban radiation fluxes 2553 IF ( average_radiation ) THEN 2554 2555 ! set height above canopy 2556 k = nzut 2557 2558 surf%rad_net = net_radiation 2559 ! MS: Wyh k + 1 ? 2560 exn1 = (hyp(k+1) / 100000.0_wp )**0.286_wp 2561 2562 surf%rad_lw_in = 0.8_wp * sigma_sb * (pt1 * exn1)**4 2563 2564 surf%rad_lw_out = emissivity_urb * sigma_sb * (t_rad_urb)**4 & 2565 + ( 10.0_wp - emissivity_urb ) & ! shouldn't be this a bulk value -- emissivity_urb? 2566 * surf%rad_lw_in 2567 2568 surf%rad_lw_out_change_0 = 3.0_wp * emissivity_urb * sigma_sb & 2569 * t_rad_urb**3 2570 2571 surf%rad_sw_in = ( surf%rad_net - surf%rad_lw_in & 2572 + surf%rad_lw_out ) & 2573 / ( 1.0_wp - albedo_urb ) 2574 2575 surf%rad_sw_out = albedo_urb * surf%rad_sw_in 2576 2577 ! 2578 !-- Calculate radiation fluxes for each surface element 1321 2579 ELSE 1322 rad_lw_in(0,j,i) = 0.8_wp * sigma_sb * (pt(k+1,j,i) * exn1)**4 2580 ! 2581 !-- Determine index offset between surface element and adjacent 2582 !-- atmospheric grid point 2583 ioff = surf%ioff 2584 joff = surf%joff 2585 koff = surf%koff 2586 2587 ! 2588 !-- Prescribe net radiation and estimate the remaining radiative fluxes 2589 DO m = 1, surf%ns 2590 i = surf%i(m) 2591 j = surf%j(m) 2592 k = surf%k(m) 2593 2594 surf%rad_net(m) = net_radiation 2595 2596 exn1 = (hyp(k) / 100000.0_wp )**0.286_wp 2597 2598 IF ( cloud_physics ) THEN 2599 pt1 = pt(k,j,i) + l_d_cp / exn1 * ql(k,j,i) 2600 surf%rad_lw_in(m) = 0.8_wp * sigma_sb * (pt1 * exn1)**4 2601 ELSE 2602 surf%rad_lw_in(m) = 0.8_wp * sigma_sb * & 2603 ( pt(k,j,i) * exn1 )**4 2604 ENDIF 2605 2606 ! 2607 !-- Weighted average according to surface fraction. 2608 !-- In case no surface fraction is given ( default-type ) 2609 !-- no weighted averaging is performed ( only one surface type per 2610 !-- surface element ). 2611 IF ( ALLOCATED( surf%frac ) ) THEN 2612 2613 surf%rad_lw_out(m) = ( surf%frac(0,m) * surf%emissivity(0,m)& 2614 + surf%frac(1,m) * surf%emissivity(1,m)& 2615 + surf%frac(2,m) * surf%emissivity(2,m)& 2616 ) & 2617 * sigma_sb & 2618 * ( pt(k+koff,j+joff,i+ioff) * exn )**4 2619 2620 surf%rad_sw_in(m) = ( surf%rad_net(m) - surf%rad_lw_in(m) & 2621 + surf%rad_lw_out(m) ) & 2622 / ( 1.0_wp - & 2623 ( surf%frac(0,m) * surf%albedo(0,m) +& 2624 surf%frac(1,m) * surf%albedo(1,m) +& 2625 surf%frac(1,m) * surf%albedo(1,m) )& 2626 ) 2627 2628 surf%rad_sw_out(m) = ( surf%frac(0,m) * surf%albedo(0,m) & 2629 + surf%frac(1,m) * surf%albedo(1,m) & 2630 + surf%frac(2,m) * surf%albedo(2,m) ) & 2631 * surf%rad_sw_in(m) 2632 2633 ELSE 2634 surf%rad_lw_out(m) = surf%emissivity(0,m) & 2635 * sigma_sb & 2636 * ( pt(k+koff,j+joff,i+ioff) * exn )**4 2637 2638 surf%rad_sw_in(m) = ( surf%rad_net(m) - surf%rad_lw_in(m) & 2639 + surf%rad_lw_out(m) ) & 2640 / ( 1.0_wp - & 2641 ( surf%frac(0,m) * surf%albedo(0,m) )& 2642 ) 2643 2644 surf%rad_sw_out(m) = ( surf%frac(0,m) * surf%albedo(0,m) ) & 2645 * surf%rad_sw_in(m) 2646 ENDIF 2647 2648 ENDDO 2649 1323 2650 ENDIF 1324 2651 1325 rad_lw_out(0,j,i) = emis(j,i) * sigma_sb * (pt(k,j,i) * exn)**4 1326 1327 rad_sw_in(0,j,i) = ( rad_net(j,i) - rad_lw_in(0,j,i) & 1328 + rad_lw_out(0,j,i) ) & 1329 / ( 1.0_wp - alpha(j,i) ) 1330 1331 rad_sw_out(0,j,i) = alpha(j,i) * rad_sw_in(0,j,i) 1332 1333 ENDDO 1334 ENDDO 2652 END SUBROUTINE radiation_constant_surf 2653 1335 2654 1336 2655 END SUBROUTINE radiation_constant … … 1364 2683 ENDIF 1365 2684 1366 IF ( albedo_type == 0 ) THEN 1367 WRITE( io, 7 ) albedo 1368 ELSE 1369 WRITE( io, 8 ) TRIM( albedo_type_name(albedo_type) ) 2685 IF ( albedo_type_f%from_file .OR. vegetation_type_f%from_file .OR. & 2686 pavement_type_f%from_file .OR. water_type_f%from_file .OR. & 2687 building_type_f%from_file ) THEN 2688 WRITE( io, 13 ) 2689 ELSE 2690 IF ( albedo_type == 0 ) THEN 2691 WRITE( io, 7 ) albedo 2692 ELSE 2693 WRITE( io, 8 ) TRIM( albedo_type_name(albedo_type) ) 2694 ENDIF 1370 2695 ENDIF 1371 2696 IF ( constant_albedo ) THEN … … 1389 2714 11 FORMAT (/' --> Shortwave radiation is disabled.') 1390 2715 12 FORMAT (' Timestep: dt_radiation = ', F6.2, ' s') 2716 13 FORMAT (/' Albedo is set individually for each xy-location, according ' & 2717 'to given surface type.') 1391 2718 1392 2719 … … 1411 2738 lw_radiation, net_radiation, & 1412 2739 radiation_scheme, skip_time_do_radiation, & 1413 sw_radiation, unscheduled_radiation_calls 2740 sw_radiation, unscheduled_radiation_calls, & 2741 split_diffusion_radiation, & 2742 energy_balance_surf_h, & 2743 energy_balance_surf_v, & 2744 read_svf_on_init, & 2745 nrefsteps, & 2746 write_svf_on_init, & 2747 mrt_factors, & 2748 dist_max_svf, & 2749 average_radiation, & 2750 radiation_interactions, atm_surfaces, & 2751 surf_reflections 1414 2752 1415 2753 line = ' ' … … 1456 2794 #if defined ( __rrtmg ) 1457 2795 1458 INTEGER(iwp) :: i, j, k, n !< loop indices 2796 INTEGER(iwp) :: i, j, k, l, m, n !< loop indices 2797 INTEGER(iwp) :: k_topo !< topography top index 1459 2798 1460 2799 REAL(wp) :: nc_rad, & !< number concentration of cloud droplets … … 1462 2801 s_r3 !< weighted sum over all droplets with r^3 1463 2802 2803 REAL(wp), DIMENSION(0:nzt+1) :: pt_av, q_av, ql_av 2804 ! 2805 !-- Just dummy arguments 2806 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: rrtm_lw_taucld_dum, & 2807 rrtm_lw_tauaer_dum, & 2808 rrtm_sw_taucld_dum, & 2809 rrtm_sw_ssacld_dum, & 2810 rrtm_sw_asmcld_dum, & 2811 rrtm_sw_fsfcld_dum, & 2812 rrtm_sw_tauaer_dum, & 2813 rrtm_sw_ssaaer_dum, & 2814 rrtm_sw_asmaer_dum, & 2815 rrtm_sw_ecaer_dum 2816 1464 2817 ! 1465 2818 !-- Calculate current (cosine of) zenith angle and whether the sun is up 1466 2819 CALL calc_zenith 1467 2820 ! 1468 !-- Calculate surface albedo 2821 !-- Calculate surface albedo. In case average radiation is applied, 2822 !-- this is not required. 1469 2823 IF ( .NOT. constant_albedo ) THEN 1470 CALL calc_albedo 2824 ! 2825 !-- Horizontally aligned default, natural and urban surfaces 2826 CALL calc_albedo( surf_def_h(0) ) 2827 CALL calc_albedo( surf_lsm_h ) 2828 CALL calc_albedo( surf_usm_h ) 2829 ! 2830 !-- Vertically aligned default, natural and urban surfaces 2831 DO l = 0, 3 2832 CALL calc_albedo( surf_def_v(l) ) 2833 CALL calc_albedo( surf_lsm_v(l) ) 2834 CALL calc_albedo( surf_usm_v(l) ) 2835 ENDDO 1471 2836 ENDIF 1472 2837 … … 1482 2847 CALL read_trace_gas_data 1483 2848 ENDIF 1484 ! 1485 !-- Loop over all grid points 1486 DO i = nxl, nxr 1487 DO j = nys, nyn 1488 1489 ! 1490 !-- Prepare profiles of temperature and H2O volume mixing ratio 1491 rrtm_tlev(0,nzb+1) = pt(nzb,j,i) * ( surface_pressure & 1492 / 1000.0_wp )**0.286_wp 1493 1494 1495 IF ( cloud_physics ) THEN 1496 DO k = nzb+1, nzt+1 1497 rrtm_tlay(0,k) = pt(k,j,i) * ( (hyp(k) ) / 100000.0_wp & 1498 )**0.286_wp + l_d_cp * ql(k,j,i) 1499 rrtm_h2ovmr(0,k) = mol_mass_air_d_wv * (q(k,j,i) - ql(k,j,i)) 1500 ENDDO 1501 ELSEIF ( cloud_droplets ) THEN 1502 DO k = nzb+1, nzt+1 1503 rrtm_tlay(0,k) = pt(k,j,i) * ( (hyp(k) ) / 100000.0_wp & 1504 )**0.286_wp + l_d_cp * ql(k,j,i) 1505 rrtm_h2ovmr(0,k) = mol_mass_air_d_wv * q(k,j,i) 1506 ENDDO 1507 ELSE 1508 DO k = nzb+1, nzt+1 1509 rrtm_tlay(0,k) = pt(k,j,i) * ( (hyp(k) ) / 100000.0_wp & 1510 )**0.286_wp 1511 rrtm_h2ovmr(0,k) = 0.0_wp 1512 ENDDO 2849 2850 2851 IF ( average_radiation ) THEN 2852 2853 rrtm_asdir(1) = albedo_urb 2854 rrtm_asdif(1) = albedo_urb 2855 rrtm_aldir(1) = albedo_urb 2856 rrtm_aldif(1) = albedo_urb 2857 2858 rrtm_emis = emissivity_urb 2859 ! 2860 !-- Calculate mean pt profile. Actually, only one height level is required. 2861 CALL calc_mean_profile( pt, 4 ) 2862 pt_av = hom(:, 1, 4, 0) 2863 2864 ! 2865 !-- Prepare profiles of temperature and H2O volume mixing ratio 2866 rrtm_tlev(0,nzb+1) = t_rad_urb 2867 2868 IF ( cloud_physics ) THEN 2869 CALL calc_mean_profile( q, 41 ) 2870 ! average q is now in hom(:, 1, 41, 0) 2871 q_av = hom(:, 1, 41, 0) 2872 CALL calc_mean_profile( ql, 54 ) 2873 ! average ql is now in hom(:, 1, 54, 0) 2874 ql_av = hom(:, 1, 54, 0) 2875 2876 DO k = nzb+1, nzt+1 2877 rrtm_tlay(0,k) = pt_av(k) * ( (hyp(k) ) / 100000._wp & 2878 )**.286_wp + l_d_cp * ql_av(k) 2879 rrtm_h2ovmr(0,k) = mol_mass_air_d_wv * (q_av(k) - ql_av(k)) 2880 ENDDO 2881 ELSE 2882 DO k = nzb+1, nzt+1 2883 rrtm_tlay(0,k) = pt_av(k) * ( (hyp(k) ) / 100000._wp & 2884 )**.286_wp 2885 rrtm_h2ovmr(0,k) = 0._wp 2886 ENDDO 2887 ENDIF 2888 2889 ! 2890 !-- Avoid temperature/humidity jumps at the top of the LES domain by 2891 !-- linear interpolation from nzt+2 to nzt+7 2892 DO k = nzt+2, nzt+7 2893 rrtm_tlay(0,k) = rrtm_tlay(0,nzt+1) & 2894 + ( rrtm_tlay(0,nzt+8) - rrtm_tlay(0,nzt+1) ) & 2895 / ( rrtm_play(0,nzt+8) - rrtm_play(0,nzt+1) ) & 2896 * ( rrtm_play(0,k) - rrtm_play(0,nzt+1) ) 2897 2898 rrtm_h2ovmr(0,k) = rrtm_h2ovmr(0,nzt+1) & 2899 + ( rrtm_h2ovmr(0,nzt+8) - rrtm_h2ovmr(0,nzt+1) )& 2900 / ( rrtm_play(0,nzt+8) - rrtm_play(0,nzt+1) )& 2901 * ( rrtm_play(0,k) - rrtm_play(0,nzt+1) ) 2902 2903 ENDDO 2904 2905 !-- Linear interpolate to zw grid 2906 DO k = nzb+2, nzt+8 2907 rrtm_tlev(0,k) = rrtm_tlay(0,k-1) + (rrtm_tlay(0,k) - & 2908 rrtm_tlay(0,k-1)) & 2909 / ( rrtm_play(0,k) - rrtm_play(0,k-1) ) & 2910 * ( rrtm_plev(0,k) - rrtm_play(0,k-1) ) 2911 ENDDO 2912 2913 2914 ! 2915 !-- Calculate liquid water path and cloud fraction for each column. 2916 !-- Note that LWP is required in g/m² instead of kg/kg m. 2917 rrtm_cldfr = 0.0_wp 2918 rrtm_reliq = 0.0_wp 2919 rrtm_cliqwp = 0.0_wp 2920 rrtm_icld = 0 2921 2922 IF ( cloud_physics ) THEN 2923 DO k = nzb+1, nzt+1 2924 rrtm_cliqwp(0,k) = ql_av(k) * 1000._wp * & 2925 (rrtm_plev(0,k) - rrtm_plev(0,k+1)) & 2926 * 100._wp / g 2927 2928 IF ( rrtm_cliqwp(0,k) > 0._wp ) THEN 2929 rrtm_cldfr(0,k) = 1._wp 2930 IF ( rrtm_icld == 0 ) rrtm_icld = 1 2931 2932 ! 2933 !-- Calculate cloud droplet effective radius 2934 IF ( cloud_physics ) THEN 2935 rrtm_reliq(0,k) = 1.0E6_wp * ( 3._wp * ql_av(k) & 2936 * rho_surface & 2937 / ( 4._wp * pi * nc_const * rho_l )& 2938 )**.33333333333333_wp & 2939 * EXP( LOG( sigma_gc )**2 ) 2940 2941 ENDIF 2942 2943 ! 2944 !-- Limit effective radius 2945 IF ( rrtm_reliq(0,k) > 0.0_wp ) THEN 2946 rrtm_reliq(0,k) = MAX(rrtm_reliq(0,k),2.5_wp) 2947 rrtm_reliq(0,k) = MIN(rrtm_reliq(0,k),60.0_wp) 2948 ENDIF 2949 ENDIF 2950 ENDDO 2951 ENDIF 2952 2953 ! 2954 !-- Set surface temperature 2955 rrtm_tsfc = t_rad_urb 2956 2957 IF ( lw_radiation ) THEN 2958 CALL rrtmg_lw( 1, nzt_rad , rrtm_icld , rrtm_idrv ,& 2959 rrtm_play , rrtm_plev , rrtm_tlay , rrtm_tlev ,& 2960 rrtm_tsfc , rrtm_h2ovmr , rrtm_o3vmr , rrtm_co2vmr ,& 2961 rrtm_ch4vmr , rrtm_n2ovmr , rrtm_o2vmr , rrtm_cfc11vmr ,& 2962 rrtm_cfc12vmr , rrtm_cfc22vmr, rrtm_ccl4vmr , rrtm_emis ,& 2963 rrtm_inflglw , rrtm_iceflglw, rrtm_liqflglw, rrtm_cldfr ,& 2964 rrtm_lw_taucld , rrtm_cicewp , rrtm_cliqwp , rrtm_reice ,& 2965 rrtm_reliq , rrtm_lw_tauaer, & 2966 rrtm_lwuflx , rrtm_lwdflx , rrtm_lwhr , & 2967 rrtm_lwuflxc , rrtm_lwdflxc , rrtm_lwhrc , & 2968 rrtm_lwuflx_dt , rrtm_lwuflxc_dt ) 2969 2970 ! 2971 !-- Save fluxes 2972 DO k = nzb, nzt+1 2973 rad_lw_in(k,:,:) = rrtm_lwdflx(0,k) 2974 rad_lw_out(k,:,:) = rrtm_lwuflx(0,k) 2975 ENDDO 2976 2977 ! 2978 !-- Save heating rates (convert from K/d to K/h) 2979 DO k = nzb+1, nzt+1 2980 rad_lw_hr(k,:,:) = rrtm_lwhr(0,k) * d_hours_day 2981 rad_lw_cs_hr(k,:,:) = rrtm_lwhrc(0,k) * d_hours_day 2982 ENDDO 2983 2984 ! 2985 !-- Save surface radiative fluxes and change in LW heating rate 2986 !-- onto respective surface elements 2987 !-- Horizontal surfaces 2988 IF ( surf_def_h(0)%ns > 0 ) THEN 2989 surf_def_h(0)%rad_lw_in = rrtm_lwdflx(0,nzb) 2990 surf_def_h(0)%rad_lw_out = rrtm_lwuflx(0,nzb) 2991 surf_def_h(0)%rad_lw_out_change_0 = rrtm_lwuflx_dt(0,nzb) 1513 2992 ENDIF 1514 1515 ! 1516 !-- Avoid temperature/humidity jumps at the top of the LES domain by 1517 !-- linear interpolation from nzt+2 to nzt+7 1518 DO k = nzt+2, nzt+7 1519 rrtm_tlay(0,k) = rrtm_tlay(0,nzt+1) & 1520 + ( rrtm_tlay(0,nzt+8) - rrtm_tlay(0,nzt+1) ) & 1521 / ( rrtm_play(0,nzt+8) - rrtm_play(0,nzt+1) ) & 1522 * ( rrtm_play(0,k) - rrtm_play(0,nzt+1) ) 1523 1524 rrtm_h2ovmr(0,k) = rrtm_h2ovmr(0,nzt+1) & 2993 IF ( surf_lsm_h%ns > 0 ) THEN 2994 surf_lsm_h%rad_lw_in = rrtm_lwdflx(0,nzb) 2995 surf_lsm_h%rad_lw_out = rrtm_lwuflx(0,nzb) 2996 surf_lsm_h%rad_lw_out_change_0 = rrtm_lwuflx_dt(0,nzb) 2997 ENDIF 2998 IF ( surf_usm_h%ns > 0 ) THEN 2999 surf_usm_h%rad_lw_in = rrtm_lwdflx(0,nzb) 3000 surf_usm_h%rad_lw_out = rrtm_lwuflx(0,nzb) 3001 surf_usm_h%rad_lw_out_change_0 = rrtm_lwuflx_dt(0,nzb) 3002 ENDIF 3003 ! 3004 !-- Vertical surfaces. 3005 DO l = 0, 3 3006 IF ( surf_def_v(l)%ns > 0 ) THEN 3007 surf_def_v(l)%rad_lw_in = rrtm_lwdflx(0,nzb) 3008 surf_def_v(l)%rad_lw_out = rrtm_lwuflx(0,nzb) 3009 surf_def_v(l)%rad_lw_out_change_0 = rrtm_lwuflx_dt(0,nzb) 3010 ENDIF 3011 IF ( surf_lsm_v(l)%ns > 0 ) THEN 3012 surf_lsm_v(l)%rad_lw_in = rrtm_lwdflx(0,nzb) 3013 surf_lsm_v(l)%rad_lw_out = rrtm_lwuflx(0,nzb) 3014 surf_lsm_v(l)%rad_lw_out_change_0 = rrtm_lwuflx_dt(0,nzb) 3015 ENDIF 3016 IF ( surf_usm_v(l)%ns > 0 ) THEN 3017 surf_usm_v(l)%rad_lw_in = rrtm_lwdflx(0,nzb) 3018 surf_usm_v(l)%rad_lw_out = rrtm_lwuflx(0,nzb) 3019 surf_usm_v(l)%rad_lw_out_change_0 = rrtm_lwuflx_dt(0,nzb) 3020 ENDIF 3021 ENDDO 3022 3023 ENDIF 3024 3025 IF ( sw_radiation .AND. sun_up ) THEN 3026 CALL rrtmg_sw( 1, nzt_rad , rrtm_icld , rrtm_iaer ,& 3027 rrtm_play , rrtm_plev , rrtm_tlay , rrtm_tlev ,& 3028 rrtm_tsfc , rrtm_h2ovmr , rrtm_o3vmr , rrtm_co2vmr ,& 3029 rrtm_ch4vmr , rrtm_n2ovmr , rrtm_o2vmr , rrtm_asdir ,& 3030 rrtm_asdif , rrtm_aldir , rrtm_aldif , zenith, & 3031 0.0_wp , day_of_year , solar_constant, rrtm_inflgsw,& 3032 rrtm_iceflgsw , rrtm_liqflgsw, rrtm_cldfr , rrtm_sw_taucld ,& 3033 rrtm_sw_ssacld , rrtm_sw_asmcld, rrtm_sw_fsfcld, rrtm_cicewp ,& 3034 rrtm_cliqwp , rrtm_reice , rrtm_reliq , rrtm_sw_tauaer ,& 3035 rrtm_sw_ssaaer , rrtm_sw_asmaer , rrtm_sw_ecaer , & 3036 rrtm_swuflx , rrtm_swdflx , rrtm_swhr , & 3037 rrtm_swuflxc , rrtm_swdflxc , rrtm_swhrc ) 3038 3039 ! 3040 !-- Save fluxes 3041 DO k = nzb, nzt+1 3042 rad_sw_in(k,:,:) = rrtm_swdflx(0,k) 3043 rad_sw_out(k,:,:) = rrtm_swuflx(0,k) 3044 ENDDO 3045 3046 ! 3047 !-- Save heating rates (convert from K/d to K/s) 3048 DO k = nzb+1, nzt+1 3049 rad_sw_hr(k,:,:) = rrtm_swhr(0,k) * d_hours_day 3050 rad_sw_cs_hr(k,:,:) = rrtm_swhrc(0,k) * d_hours_day 3051 ENDDO 3052 3053 ! 3054 !-- Save surface radiative fluxes onto respective surface elements 3055 !-- Horizontal surfaces 3056 IF ( surf_def_h(0)%ns > 0 ) THEN 3057 surf_def_h(0)%rad_lw_in = rrtm_swdflx(0,nzb) 3058 surf_def_h(0)%rad_lw_out = rrtm_swuflx(0,nzb) 3059 ENDIF 3060 IF ( surf_lsm_h%ns > 0 ) THEN 3061 surf_lsm_h%rad_sw_in = rrtm_swdflx(0,nzb) 3062 surf_lsm_h%rad_sw_out = rrtm_swuflx(0,nzb) 3063 ENDIF 3064 IF ( surf_usm_h%ns > 0 ) THEN 3065 surf_usm_h%rad_sw_in = rrtm_swdflx(0,nzb) 3066 surf_usm_h%rad_sw_out = rrtm_swuflx(0,nzb) 3067 ENDIF 3068 ! 3069 !-- Vertical surfaces. Fluxes are obtain at respective vertical 3070 !-- level of the surface element 3071 DO l = 0, 3 3072 IF ( surf_def_v(l)%ns > 0 ) THEN 3073 surf_def_v(l)%rad_sw_in = rrtm_swdflx(0,nzb) 3074 surf_def_v(l)%rad_sw_out = rrtm_swuflx(0,nzb) 3075 ENDIF 3076 IF ( surf_lsm_v(l)%ns > 0 ) THEN 3077 surf_lsm_v(l)%rad_sw_in = rrtm_swdflx(0,nzb) 3078 surf_lsm_v(l)%rad_sw_out = rrtm_swuflx(0,nzb) 3079 ENDIF 3080 IF ( surf_usm_v(l)%ns > 0 ) THEN 3081 surf_usm_v(l)%rad_sw_in = rrtm_swdflx(0,nzb) 3082 surf_usm_v(l)%rad_sw_out = rrtm_swuflx(0,nzb) 3083 ENDIF 3084 ENDDO 3085 3086 ENDIF 3087 ! 3088 !-- RRTMG is called for each (j,i) grid point separately, starting at the 3089 !-- highest topography level 3090 ELSE 3091 ! 3092 !-- Loop over all grid points 3093 DO i = nxl, nxr 3094 DO j = nys, nyn 3095 3096 ! 3097 !-- Prepare profiles of temperature and H2O volume mixing ratio 3098 rrtm_tlev(0,nzb+1) = pt(nzb,j,i) * ( surface_pressure & 3099 / 1000.0_wp )**0.286_wp 3100 3101 3102 IF ( cloud_physics ) THEN 3103 DO k = nzb+1, nzt+1 3104 rrtm_tlay(0,k) = pt(k,j,i) * ( (hyp(k) ) / 100000.0_wp & 3105 )**0.286_wp + l_d_cp * ql(k,j,i) 3106 rrtm_h2ovmr(0,k) = mol_mass_air_d_wv * (q(k,j,i) - ql(k,j,i)) 3107 ENDDO 3108 ELSE 3109 DO k = nzb+1, nzt+1 3110 rrtm_tlay(0,k) = pt(k,j,i) * ( (hyp(k) ) / 100000.0_wp & 3111 )**0.286_wp 3112 rrtm_h2ovmr(0,k) = 0.0_wp 3113 ENDDO 3114 ENDIF 3115 3116 ! 3117 !-- Avoid temperature/humidity jumps at the top of the LES domain by 3118 !-- linear interpolation from nzt+2 to nzt+7 3119 DO k = nzt+2, nzt+7 3120 rrtm_tlay(0,k) = rrtm_tlay(0,nzt+1) & 3121 + ( rrtm_tlay(0,nzt+8) - rrtm_tlay(0,nzt+1) ) & 3122 / ( rrtm_play(0,nzt+8) - rrtm_play(0,nzt+1) ) & 3123 * ( rrtm_play(0,k) - rrtm_play(0,nzt+1) ) 3124 3125 rrtm_h2ovmr(0,k) = rrtm_h2ovmr(0,nzt+1) & 1525 3126 + ( rrtm_h2ovmr(0,nzt+8) - rrtm_h2ovmr(0,nzt+1) )& 1526 3127 / ( rrtm_play(0,nzt+8) - rrtm_play(0,nzt+1) )& 1527 * ( rrtm_play(0,k) - rrtm_play(0,nzt+1) ) 3128 * ( rrtm_play(0,k) - rrtm_play(0,nzt+1) ) 3129 3130 ENDDO 3131 3132 !-- Linear interpolate to zw grid 3133 DO k = nzb+2, nzt+8 3134 rrtm_tlev(0,k) = rrtm_tlay(0,k-1) + (rrtm_tlay(0,k) - & 3135 rrtm_tlay(0,k-1)) & 3136 / ( rrtm_play(0,k) - rrtm_play(0,k-1) ) & 3137 * ( rrtm_plev(0,k) - rrtm_play(0,k-1) ) 3138 ENDDO 3139 3140 3141 ! 3142 !-- Calculate liquid water path and cloud fraction for each column. 3143 !-- Note that LWP is required in g/m² instead of kg/kg m. 3144 rrtm_cldfr = 0.0_wp 3145 rrtm_reliq = 0.0_wp 3146 rrtm_cliqwp = 0.0_wp 3147 rrtm_icld = 0 3148 3149 IF ( cloud_physics .OR. cloud_droplets ) THEN 3150 DO k = nzb+1, nzt+1 3151 rrtm_cliqwp(0,k) = ql(k,j,i) * 1000.0_wp * & 3152 (rrtm_plev(0,k) - rrtm_plev(0,k+1)) & 3153 * 100.0_wp / g 3154 3155 IF ( rrtm_cliqwp(0,k) > 0.0_wp ) THEN 3156 rrtm_cldfr(0,k) = 1.0_wp 3157 IF ( rrtm_icld == 0 ) rrtm_icld = 1 3158 3159 ! 3160 !-- Calculate cloud droplet effective radius 3161 IF ( cloud_physics ) THEN 3162 ! 3163 !-- Calculete effective droplet radius. In case of using 3164 !-- cloud_scheme = 'morrison' and a non reasonable number 3165 !-- of cloud droplets the inital aerosol number 3166 !-- concentration is considered. 3167 IF ( microphysics_morrison ) THEN 3168 IF ( nc(k,j,i) > 1.0E-20_wp ) THEN 3169 nc_rad = nc(k,j,i) 3170 ELSE 3171 nc_rad = na_init 3172 ENDIF 3173 ELSE 3174 nc_rad = nc_const 3175 ENDIF 3176 3177 rrtm_reliq(0,k) = 1.0E6_wp * ( 3.0_wp * ql(k,j,i) & 3178 * rho_surface & 3179 / ( 4.0_wp * pi * nc_rad * rho_l ) & 3180 )**0.33333333333333_wp & 3181 * EXP( LOG( sigma_gc )**2 ) 3182 3183 ELSEIF ( cloud_droplets ) THEN 3184 number_of_particles = prt_count(k,j,i) 3185 3186 IF (number_of_particles <= 0) CYCLE 3187 particles => grid_particles(k,j,i)%particles(1:number_of_particles) 3188 s_r2 = 0.0_wp 3189 s_r3 = 0.0_wp 3190 3191 DO n = 1, number_of_particles 3192 IF ( particles(n)%particle_mask ) THEN 3193 s_r2 = s_r2 + particles(n)%radius**2 * & 3194 particles(n)%weight_factor 3195 s_r3 = s_r3 + particles(n)%radius**3 * & 3196 particles(n)%weight_factor 3197 ENDIF 3198 ENDDO 3199 3200 IF ( s_r2 > 0.0_wp ) rrtm_reliq(0,k) = s_r3 / s_r2 3201 3202 ENDIF 3203 3204 ! 3205 !-- Limit effective radius 3206 IF ( rrtm_reliq(0,k) > 0.0_wp ) THEN 3207 rrtm_reliq(0,k) = MAX(rrtm_reliq(0,k),2.5_wp) 3208 rrtm_reliq(0,k) = MIN(rrtm_reliq(0,k),60.0_wp) 3209 ENDIF 3210 ENDIF 3211 ENDDO 3212 ENDIF 3213 3214 ! 3215 !-- Write surface emissivity and surface temperature at current 3216 !-- surface element on RRTMG-shaped array. 3217 !-- Please note, as RRTMG is a single column model, surface attributes 3218 !-- are only obtained from horizontally aligned surfaces (for 3219 !-- simplicity). Taking surface attributes from horizontal and 3220 !-- vertical walls would lead to multiple solutions. 3221 !-- Moreover, for natural- and urban-type surfaces, several surface 3222 !-- classes can exist at a surface element next to each other. 3223 !-- To obtain bulk parameters, apply a weighted average for these 3224 !-- surfaces. 3225 DO m = surf_def_h(0)%start_index(j,i), surf_def_h(0)%end_index(j,i) 3226 rrtm_emis = surf_def_h(0)%emissivity(0,m) 3227 rrtm_tsfc = pt(surf_def_h(0)%k(m)+surf_def_h(0)%koff,j,i) * & 3228 (surface_pressure / 1000.0_wp )**0.286_wp 3229 ENDDO 3230 DO m = surf_lsm_h%start_index(j,i), surf_lsm_h%end_index(j,i) 3231 rrtm_emis = surf_lsm_h%frac(0,m) * surf_lsm_h%emissivity(0,m) +& 3232 surf_lsm_h%frac(1,m) * surf_lsm_h%emissivity(1,m) +& 3233 surf_lsm_h%frac(2,m) * surf_lsm_h%emissivity(2,m) 3234 rrtm_tsfc = pt(surf_lsm_h%k(m)+surf_lsm_h%koff,j,i) * & 3235 (surface_pressure / 1000.0_wp )**0.286_wp 3236 ENDDO 3237 DO m = surf_usm_h%start_index(j,i), surf_usm_h%end_index(j,i) 3238 rrtm_emis = surf_usm_h%frac(0,m) * surf_usm_h%emissivity(0,m) +& 3239 surf_usm_h%frac(1,m) * surf_usm_h%emissivity(1,m) +& 3240 surf_usm_h%frac(2,m) * surf_usm_h%emissivity(2,m) 3241 rrtm_tsfc = pt(surf_usm_h%k(m)+surf_usm_h%koff,j,i) * & 3242 (surface_pressure / 1000.0_wp )**0.286_wp 3243 ENDDO 3244 ! 3245 !-- Obtain topography top index (lower bound of RRTMG) 3246 k_topo = get_topography_top_index( j, i, 's' ) 3247 3248 IF ( lw_radiation ) THEN 3249 ! 3250 !-- Due to technical reasons, copy optical depth to dummy arguments 3251 !-- which are allocated on the exact size as the rrtmg_lw is called. 3252 !-- As one dimesion is allocated with zero size, compiler complains 3253 !-- that rank of the array does not match that of the 3254 !-- assumed-shaped arguments in the RRTMG library. In order to 3255 !-- avoid this, write to dummy arguments and give pass the entire 3256 !-- dummy array. Seems to be the only existing work-around. 3257 ALLOCATE( rrtm_lw_taucld_dum(1:nbndlw+1,0:0,k_topo+1:nzt_rad+1) ) 3258 ALLOCATE( rrtm_lw_tauaer_dum(0:0,k_topo+1:nzt_rad+1,1:nbndlw+1) ) 3259 3260 rrtm_lw_taucld_dum = & 3261 rrtm_lw_taucld(1:nbndlw+1,0:0,k_topo+1:nzt_rad+1) 3262 rrtm_lw_tauaer_dum = & 3263 rrtm_lw_tauaer(0:0,k_topo+1:nzt_rad+1,1:nbndlw+1) 3264 3265 CALL rrtmg_lw( 1, & 3266 nzt_rad-k_topo, & 3267 rrtm_icld, & 3268 rrtm_idrv, & 3269 rrtm_play(:,k_topo+1:nzt_rad+1), & 3270 rrtm_plev(:,k_topo+1:nzt_rad+2), & 3271 rrtm_tlay(:,k_topo+1:nzt_rad+1), & 3272 rrtm_tlev(:,k_topo+1:nzt_rad+2), & 3273 rrtm_tsfc, & 3274 rrtm_h2ovmr(:,k_topo+1:nzt_rad+1), & 3275 rrtm_o3vmr(:,k_topo+1:nzt_rad+1), & 3276 rrtm_co2vmr(:,k_topo+1:nzt_rad+1), & 3277 rrtm_ch4vmr(:,k_topo+1:nzt_rad+1), & 3278 rrtm_n2ovmr(:,k_topo+1:nzt_rad+1), & 3279 rrtm_o2vmr(:,k_topo+1:nzt_rad+1), & 3280 rrtm_cfc11vmr(:,k_topo+1:nzt_rad+1), & 3281 rrtm_cfc12vmr(:,k_topo+1:nzt_rad+1), & 3282 rrtm_cfc22vmr(:,k_topo+1:nzt_rad+1), & 3283 rrtm_ccl4vmr(:,k_topo+1:nzt_rad+1), & 3284 rrtm_emis, & 3285 rrtm_inflglw, & 3286 rrtm_iceflglw, & 3287 rrtm_liqflglw, & 3288 rrtm_cldfr(:,k_topo+1:nzt_rad+1), & 3289 rrtm_lw_taucld_dum, & 3290 rrtm_cicewp(:,k_topo+1:nzt_rad+1), & 3291 rrtm_cliqwp(:,k_topo+1:nzt_rad+1), & 3292 rrtm_reice(:,k_topo+1:nzt_rad+1), & 3293 rrtm_reliq(:,k_topo+1:nzt_rad+1), & 3294 rrtm_lw_tauaer_dum, & 3295 rrtm_lwuflx(:,k_topo:nzt_rad+1), & 3296 rrtm_lwdflx(:,k_topo:nzt_rad+1), & 3297 rrtm_lwhr(:,k_topo+1:nzt_rad+1), & 3298 rrtm_lwuflxc(:,k_topo:nzt_rad+1), & 3299 rrtm_lwdflxc(:,k_topo:nzt_rad+1), & 3300 rrtm_lwhrc(:,k_topo+1:nzt_rad+1), & 3301 rrtm_lwuflx_dt(:,k_topo:nzt_rad+1), & 3302 rrtm_lwuflxc_dt(:,k_topo:nzt_rad+1) ) 3303 3304 DEALLOCATE ( rrtm_lw_taucld_dum ) 3305 DEALLOCATE ( rrtm_lw_tauaer_dum ) 3306 ! 3307 !-- Save fluxes 3308 DO k = k_topo, nzt+1 3309 rad_lw_in(k,j,i) = rrtm_lwdflx(0,k) 3310 rad_lw_out(k,j,i) = rrtm_lwuflx(0,k) 3311 ENDDO 3312 3313 ! 3314 !-- Save heating rates (convert from K/d to K/h) 3315 DO k = k_topo+1, nzt+1 3316 rad_lw_hr(k,j,i) = rrtm_lwhr(0,k) * d_hours_day 3317 rad_lw_cs_hr(k,j,i) = rrtm_lwhrc(0,k) * d_hours_day 3318 ENDDO 3319 3320 ! 3321 !-- Save surface radiative fluxes and change in LW heating rate 3322 !-- onto respective surface elements 3323 !-- Horizontal surfaces 3324 DO m = surf_def_h(0)%start_index(j,i), & 3325 surf_def_h(0)%end_index(j,i) 3326 surf_def_h(0)%rad_lw_in(m) = rrtm_lwdflx(0,k_topo) 3327 surf_def_h(0)%rad_lw_out(m) = rrtm_lwuflx(0,k_topo) 3328 surf_def_h(0)%rad_lw_out_change_0(m) = rrtm_lwuflx_dt(0,k_topo) 3329 ENDDO 3330 DO m = surf_lsm_h%start_index(j,i), & 3331 surf_lsm_h%end_index(j,i) 3332 surf_lsm_h%rad_lw_in(m) = rrtm_lwdflx(0,k_topo) 3333 surf_lsm_h%rad_lw_out(m) = rrtm_lwuflx(0,k_topo) 3334 surf_lsm_h%rad_lw_out_change_0(m) = rrtm_lwuflx_dt(0,k_topo) 3335 ENDDO 3336 DO m = surf_usm_h%start_index(j,i), & 3337 surf_usm_h%end_index(j,i) 3338 surf_usm_h%rad_lw_in(m) = rrtm_lwdflx(0,k_topo) 3339 surf_usm_h%rad_lw_out(m) = rrtm_lwuflx(0,k_topo) 3340 surf_usm_h%rad_lw_out_change_0(m) = rrtm_lwuflx_dt(0,k_topo) 3341 ENDDO 3342 ! 3343 !-- Vertical surfaces. Fluxes are obtain at vertical level of the 3344 !-- respective surface element 3345 DO l = 0, 3 3346 DO m = surf_def_v(l)%start_index(j,i), & 3347 surf_def_v(l)%end_index(j,i) 3348 k = surf_def_v(l)%k(m) 3349 surf_def_v(l)%rad_lw_in(m) = rrtm_lwdflx(0,k) 3350 surf_def_v(l)%rad_lw_out(m) = rrtm_lwuflx(0,k) 3351 surf_def_v(l)%rad_lw_out_change_0(m) = rrtm_lwuflx_dt(0,k) 3352 ENDDO 3353 DO m = surf_lsm_v(l)%start_index(j,i), & 3354 surf_lsm_v(l)%end_index(j,i) 3355 k = surf_lsm_v(l)%k(m) 3356 surf_lsm_v(l)%rad_lw_in(m) = rrtm_lwdflx(0,k) 3357 surf_lsm_v(l)%rad_lw_out(m) = rrtm_lwuflx(0,k) 3358 surf_lsm_v(l)%rad_lw_out_change_0(m) = rrtm_lwuflx_dt(0,k) 3359 ENDDO 3360 DO m = surf_usm_v(l)%start_index(j,i), & 3361 surf_usm_v(l)%end_index(j,i) 3362 k = surf_usm_v(l)%k(m) 3363 surf_usm_v(l)%rad_lw_in(m) = rrtm_lwdflx(0,k) 3364 surf_usm_v(l)%rad_lw_out(m) = rrtm_lwuflx(0,k) 3365 surf_usm_v(l)%rad_lw_out_change_0(m) = rrtm_lwuflx_dt(0,k) 3366 ENDDO 3367 ENDDO 3368 3369 ENDIF 3370 3371 IF ( sw_radiation .AND. sun_up ) THEN 3372 ! 3373 !-- Get albedo for direct/diffusive long/shortwave radiation at 3374 !-- current (y,x)-location from surface variables. 3375 !-- Only obtain it from horizontal surfaces, as RRTMG is a single 3376 !-- column model 3377 !-- (Please note, only one loop will entered, controlled by 3378 !-- start-end index.) 3379 DO m = surf_def_h(0)%start_index(j,i), & 3380 surf_def_h(0)%end_index(j,i) 3381 rrtm_asdir(1) = surf_def_h(0)%rrtm_asdir(m) 3382 rrtm_asdif(1) = surf_def_h(0)%rrtm_asdif(m) 3383 rrtm_aldir(1) = surf_def_h(0)%rrtm_aldir(m) 3384 rrtm_aldif(1) = surf_def_h(0)%rrtm_aldif(m) 3385 ENDDO 3386 DO m = surf_lsm_h%start_index(j,i), & 3387 surf_lsm_h%end_index(j,i) 3388 rrtm_asdir(1) = surf_lsm_h%rrtm_asdir(m) 3389 rrtm_asdif(1) = surf_lsm_h%rrtm_asdif(m) 3390 rrtm_aldir(1) = surf_lsm_h%rrtm_aldir(m) 3391 rrtm_aldif(1) = surf_lsm_h%rrtm_aldif(m) 3392 ENDDO 3393 DO m = surf_usm_h%start_index(j,i), & 3394 surf_usm_h%end_index(j,i) 3395 rrtm_asdir(1) = surf_usm_h%rrtm_asdir(m) 3396 rrtm_asdif(1) = surf_usm_h%rrtm_asdif(m) 3397 rrtm_aldir(1) = surf_usm_h%rrtm_aldir(m) 3398 rrtm_aldif(1) = surf_usm_h%rrtm_aldif(m) 3399 ENDDO 3400 ! 3401 !-- Due to technical reasons, copy optical depths and other 3402 !-- to dummy arguments which are allocated on the exact size as the 3403 !-- rrtmg_sw is called. 3404 !-- As one dimesion is allocated with zero size, compiler complains 3405 !-- that rank of the array does not match that of the 3406 !-- assumed-shaped arguments in the RRTMG library. In order to 3407 !-- avoid this, write to dummy arguments and give pass the entire 3408 !-- dummy array. Seems to be the only existing work-around. 3409 ALLOCATE( rrtm_sw_taucld_dum(1:nbndsw+1,0:0,k_topo+1:nzt_rad+1) ) 3410 ALLOCATE( rrtm_sw_ssacld_dum(1:nbndsw+1,0:0,k_topo+1:nzt_rad+1) ) 3411 ALLOCATE( rrtm_sw_asmcld_dum(1:nbndsw+1,0:0,k_topo+1:nzt_rad+1) ) 3412 ALLOCATE( rrtm_sw_fsfcld_dum(1:nbndsw+1,0:0,k_topo+1:nzt_rad+1) ) 3413 ALLOCATE( rrtm_sw_tauaer_dum(0:0,k_topo+1:nzt_rad+1,1:nbndsw+1) ) 3414 ALLOCATE( rrtm_sw_ssaaer_dum(0:0,k_topo+1:nzt_rad+1,1:nbndsw+1) ) 3415 ALLOCATE( rrtm_sw_asmaer_dum(0:0,k_topo+1:nzt_rad+1,1:nbndsw+1) ) 3416 ALLOCATE( rrtm_sw_ecaer_dum(0:0,k_topo+1:nzt_rad+1,1:naerec+1) ) 3417 3418 rrtm_sw_taucld_dum = rrtm_sw_taucld(1:nbndsw+1,0:0,k_topo+1:nzt_rad+1) 3419 rrtm_sw_ssacld_dum = rrtm_sw_ssacld(1:nbndsw+1,0:0,k_topo+1:nzt_rad+1) 3420 rrtm_sw_asmcld_dum = rrtm_sw_asmcld(1:nbndsw+1,0:0,k_topo+1:nzt_rad+1) 3421 rrtm_sw_fsfcld_dum = rrtm_sw_fsfcld(1:nbndsw+1,0:0,k_topo+1:nzt_rad+1) 3422 rrtm_sw_tauaer_dum = rrtm_sw_tauaer(0:0,k_topo+1:nzt_rad+1,1:nbndsw+1) 3423 rrtm_sw_ssaaer_dum = rrtm_sw_ssaaer(0:0,k_topo+1:nzt_rad+1,1:nbndsw+1) 3424 rrtm_sw_asmaer_dum = rrtm_sw_asmaer(0:0,k_topo+1:nzt_rad+1,1:nbndsw+1) 3425 rrtm_sw_ecaer_dum = rrtm_sw_ecaer(0:0,k_topo+1:nzt_rad+1,1:naerec+1) 3426 3427 CALL rrtmg_sw( 1, & 3428 nzt_rad-k_topo, & 3429 rrtm_icld, & 3430 rrtm_iaer, & 3431 rrtm_play(:,k_topo+1:nzt_rad+1), & 3432 rrtm_plev(:,k_topo+1:nzt_rad+2), & 3433 rrtm_tlay(:,k_topo+1:nzt_rad+1), & 3434 rrtm_tlev(:,k_topo+1:nzt_rad+2), & 3435 rrtm_tsfc, & 3436 rrtm_h2ovmr(:,k_topo+1:nzt_rad+1), & 3437 rrtm_o3vmr(:,k_topo+1:nzt_rad+1), & 3438 rrtm_co2vmr(:,k_topo+1:nzt_rad+1), & 3439 rrtm_ch4vmr(:,k_topo+1:nzt_rad+1), & 3440 rrtm_n2ovmr(:,k_topo+1:nzt_rad+1), & 3441 rrtm_o2vmr(:,k_topo+1:nzt_rad+1), & 3442 rrtm_asdir, & 3443 rrtm_asdif, & 3444 rrtm_aldir, & 3445 rrtm_aldif, & 3446 zenith, & 3447 0.0_wp, & 3448 day_of_year, & 3449 solar_constant, & 3450 rrtm_inflgsw, & 3451 rrtm_iceflgsw, & 3452 rrtm_liqflgsw, & 3453 rrtm_cldfr(:,k_topo+1:nzt_rad+1), & 3454 rrtm_sw_taucld_dum, & 3455 rrtm_sw_ssacld_dum, & 3456 rrtm_sw_asmcld_dum, & 3457 rrtm_sw_fsfcld_dum, & 3458 rrtm_cicewp(:,k_topo+1:nzt_rad+1), & 3459 rrtm_cliqwp(:,k_topo+1:nzt_rad+1), & 3460 rrtm_reice(:,k_topo+1:nzt_rad+1), & 3461 rrtm_reliq(:,k_topo+1:nzt_rad+1), & 3462 rrtm_sw_tauaer_dum, & 3463 rrtm_sw_ssaaer_dum, & 3464 rrtm_sw_asmaer_dum, & 3465 rrtm_sw_ecaer_dum, & 3466 rrtm_swuflx(:,k_topo:nzt_rad+1), & 3467 rrtm_swdflx(:,k_topo:nzt_rad+1), & 3468 rrtm_swhr(:,k_topo+1:nzt_rad+1), & 3469 rrtm_swuflxc(:,k_topo:nzt_rad+1), & 3470 rrtm_swdflxc(:,k_topo:nzt_rad+1), & 3471 rrtm_swhrc(:,k_topo+1:nzt_rad+1) ) 3472 3473 DEALLOCATE( rrtm_sw_taucld_dum ) 3474 DEALLOCATE( rrtm_sw_ssacld_dum ) 3475 DEALLOCATE( rrtm_sw_asmcld_dum ) 3476 DEALLOCATE( rrtm_sw_fsfcld_dum ) 3477 DEALLOCATE( rrtm_sw_tauaer_dum ) 3478 DEALLOCATE( rrtm_sw_ssaaer_dum ) 3479 DEALLOCATE( rrtm_sw_asmaer_dum ) 3480 DEALLOCATE( rrtm_sw_ecaer_dum ) 3481 ! 3482 !-- Save fluxes 3483 DO k = nzb, nzt+1 3484 rad_sw_in(k,j,i) = rrtm_swdflx(0,k) 3485 rad_sw_out(k,j,i) = rrtm_swuflx(0,k) 3486 ENDDO 3487 ! 3488 !-- Save heating rates (convert from K/d to K/s) 3489 DO k = nzb+1, nzt+1 3490 rad_sw_hr(k,j,i) = rrtm_swhr(0,k) * d_hours_day 3491 rad_sw_cs_hr(k,j,i) = rrtm_swhrc(0,k) * d_hours_day 3492 ENDDO 3493 3494 ! 3495 !-- Save surface radiative fluxes onto respective surface elements 3496 !-- Horizontal surfaces 3497 DO m = surf_def_h(0)%start_index(j,i), & 3498 surf_def_h(0)%end_index(j,i) 3499 surf_def_h(0)%rad_sw_in(m) = rrtm_swdflx(0,k_topo) 3500 surf_def_h(0)%rad_sw_out(m) = rrtm_swuflx(0,k_topo) 3501 ENDDO 3502 DO m = surf_lsm_h%start_index(j,i), & 3503 surf_lsm_h%end_index(j,i) 3504 surf_lsm_h%rad_sw_in(m) = rrtm_swdflx(0,k_topo) 3505 surf_lsm_h%rad_sw_out(m) = rrtm_swuflx(0,k_topo) 3506 ENDDO 3507 DO m = surf_usm_h%start_index(j,i), & 3508 surf_usm_h%end_index(j,i) 3509 surf_usm_h%rad_sw_in(m) = rrtm_swdflx(0,k_topo) 3510 surf_usm_h%rad_sw_out(m) = rrtm_swuflx(0,k_topo) 3511 ENDDO 3512 ! 3513 !-- Vertical surfaces. Fluxes are obtain at respective vertical 3514 !-- level of the surface element 3515 DO l = 0, 3 3516 DO m = surf_def_v(l)%start_index(j,i), & 3517 surf_def_v(l)%end_index(j,i) 3518 k = surf_def_v(l)%k(m) 3519 surf_def_v(l)%rad_sw_in(m) = rrtm_swdflx(0,k) 3520 surf_def_v(l)%rad_sw_out(m) = rrtm_swuflx(0,k) 3521 ENDDO 3522 DO m = surf_lsm_v(l)%start_index(j,i), & 3523 surf_lsm_v(l)%end_index(j,i) 3524 k = surf_lsm_v(l)%k(m) 3525 surf_lsm_v(l)%rad_sw_in(m) = rrtm_swdflx(0,k) 3526 surf_lsm_v(l)%rad_sw_out(m) = rrtm_swuflx(0,k) 3527 ENDDO 3528 DO m = surf_usm_v(l)%start_index(j,i), & 3529 surf_usm_v(l)%end_index(j,i) 3530 k = surf_usm_v(l)%k(m) 3531 surf_usm_v(l)%rad_sw_in(m) = rrtm_swdflx(0,k) 3532 surf_usm_v(l)%rad_sw_out(m) = rrtm_swuflx(0,k) 3533 ENDDO 3534 ENDDO 3535 3536 ENDIF 1528 3537 1529 3538 ENDDO 1530 1531 !-- Linear interpolate to zw grid 1532 DO k = nzb+2, nzt+8 1533 rrtm_tlev(0,k) = rrtm_tlay(0,k-1) + (rrtm_tlay(0,k) - & 1534 rrtm_tlay(0,k-1)) & 1535 / ( rrtm_play(0,k) - rrtm_play(0,k-1) ) & 1536 * ( rrtm_plev(0,k) - rrtm_play(0,k-1) ) 1537 ENDDO 1538 1539 1540 ! 1541 !-- Calculate liquid water path and cloud fraction for each column. 1542 !-- Note that LWP is required in g/m² instead of kg/kg m. 1543 rrtm_cldfr = 0.0_wp 1544 rrtm_reliq = 0.0_wp 1545 rrtm_cliqwp = 0.0_wp 1546 rrtm_icld = 0 1547 1548 IF ( cloud_physics .OR. cloud_droplets ) THEN 1549 DO k = nzb+1, nzt+1 1550 rrtm_cliqwp(0,k) = ql(k,j,i) * 1000.0_wp * & 1551 (rrtm_plev(0,k) - rrtm_plev(0,k+1)) & 1552 * 100.0_wp / g 1553 1554 IF ( rrtm_cliqwp(0,k) > 0.0_wp ) THEN 1555 rrtm_cldfr(0,k) = 1.0_wp 1556 IF ( rrtm_icld == 0 ) rrtm_icld = 1 1557 1558 ! 1559 !-- Calculate cloud droplet effective radius 1560 IF ( cloud_physics ) THEN 1561 ! 1562 !-- Calculete effective droplet radius. In case of using 1563 !-- cloud_scheme = 'morrison' and a non reasonable number 1564 !-- of cloud droplets the inital aerosol number 1565 !-- concentration is considered. 1566 IF ( microphysics_morrison ) THEN 1567 IF ( nc(k,j,i) > 1.0E-20_wp ) THEN 1568 nc_rad = nc(k,j,i) 1569 ELSE 1570 nc_rad = na_init 1571 ENDIF 1572 ELSE 1573 nc_rad = nc_const 1574 ENDIF 1575 1576 rrtm_reliq(0,k) = 1.0E6_wp * ( 3.0_wp * ql(k,j,i) & 1577 * rho_surface & 1578 / ( 4.0_wp * pi * nc_rad * rho_l )& 1579 )**0.33333333333333_wp & 1580 * EXP( LOG( sigma_gc )**2 ) 1581 1582 ELSEIF ( cloud_droplets ) THEN 1583 number_of_particles = prt_count(k,j,i) 1584 1585 IF (number_of_particles <= 0) CYCLE 1586 particles => grid_particles(k,j,i)%particles(1:number_of_particles) 1587 s_r2 = 0.0_wp 1588 s_r3 = 0.0_wp 1589 1590 DO n = 1, number_of_particles 1591 IF ( particles(n)%particle_mask ) THEN 1592 s_r2 = s_r2 + particles(n)%radius**2 * & 1593 particles(n)%weight_factor 1594 s_r3 = s_r3 + particles(n)%radius**3 * & 1595 particles(n)%weight_factor 1596 ENDIF 1597 ENDDO 1598 1599 IF ( s_r2 > 0.0_wp ) rrtm_reliq(0,k) = s_r3 / s_r2 1600 1601 ENDIF 1602 1603 ! 1604 !-- Limit effective radius 1605 IF ( rrtm_reliq(0,k) > 0.0_wp ) THEN 1606 rrtm_reliq(0,k) = MAX(rrtm_reliq(0,k),2.5_wp) 1607 rrtm_reliq(0,k) = MIN(rrtm_reliq(0,k),60.0_wp) 1608 ENDIF 1609 ENDIF 1610 ENDDO 1611 ENDIF 1612 1613 ! 1614 !-- Set surface temperature 1615 rrtm_tsfc = pt(nzb,j,i) * (surface_pressure / 1000.0_wp )**0.286_wp 1616 1617 ! 1618 !-- Set surface emissivity 1619 rrtm_emis = emis(j,i) 1620 1621 IF ( lw_radiation ) THEN 1622 CALL rrtmg_lw( 1, nzt_rad , rrtm_icld , rrtm_idrv ,& 1623 rrtm_play , rrtm_plev , rrtm_tlay , rrtm_tlev ,& 1624 rrtm_tsfc , rrtm_h2ovmr , rrtm_o3vmr , rrtm_co2vmr ,& 1625 rrtm_ch4vmr , rrtm_n2ovmr , rrtm_o2vmr , rrtm_cfc11vmr ,& 1626 rrtm_cfc12vmr , rrtm_cfc22vmr, rrtm_ccl4vmr , rrtm_emis ,& 1627 rrtm_inflglw , rrtm_iceflglw, rrtm_liqflglw, rrtm_cldfr ,& 1628 rrtm_lw_taucld , rrtm_cicewp , rrtm_cliqwp , rrtm_reice ,& 1629 rrtm_reliq , rrtm_lw_tauaer, & 1630 rrtm_lwuflx , rrtm_lwdflx , rrtm_lwhr , & 1631 rrtm_lwuflxc , rrtm_lwdflxc , rrtm_lwhrc , & 1632 rrtm_lwuflx_dt , rrtm_lwuflxc_dt ) 1633 1634 ! 1635 !-- Save fluxes 1636 DO k = nzb, nzt+1 1637 rad_lw_in(k,j,i) = rrtm_lwdflx(0,k) 1638 rad_lw_out(k,j,i) = rrtm_lwuflx(0,k) 1639 ENDDO 1640 1641 ! 1642 !-- Save heating rates (convert from K/d to K/h) 1643 DO k = nzb+1, nzt+1 1644 rad_lw_hr(k,j,i) = rrtm_lwhr(0,k) * d_hours_day 1645 rad_lw_cs_hr(k,j,i) = rrtm_lwhrc(0,k) * d_hours_day 1646 ENDDO 1647 1648 ! 1649 !-- Save change in LW heating rate 1650 rad_lw_out_change_0(j,i) = rrtm_lwuflx_dt(0,nzb) 1651 1652 ENDIF 1653 1654 IF ( sw_radiation .AND. sun_up ) THEN 1655 CALL rrtmg_sw( 1, nzt_rad , rrtm_icld , rrtm_iaer ,& 1656 rrtm_play , rrtm_plev , rrtm_tlay , rrtm_tlev ,& 1657 rrtm_tsfc , rrtm_h2ovmr , rrtm_o3vmr , rrtm_co2vmr ,& 1658 rrtm_ch4vmr , rrtm_n2ovmr , rrtm_o2vmr , rrtm_asdir(:,j,i),& 1659 rrtm_asdif(:,j,i), rrtm_aldir(:,j,i), rrtm_aldif(:,j,i), zenith,& 1660 0.0_wp , day_of_year , solar_constant, rrtm_inflgsw,& 1661 rrtm_iceflgsw , rrtm_liqflgsw, rrtm_cldfr , rrtm_sw_taucld ,& 1662 rrtm_sw_ssacld , rrtm_sw_asmcld, rrtm_sw_fsfcld, rrtm_cicewp ,& 1663 rrtm_cliqwp , rrtm_reice , rrtm_reliq , rrtm_sw_tauaer ,& 1664 rrtm_sw_ssaaer , rrtm_sw_asmaer , rrtm_sw_ecaer , & 1665 rrtm_swuflx , rrtm_swdflx , rrtm_swhr , & 1666 rrtm_swuflxc , rrtm_swdflxc , rrtm_swhrc ) 1667 1668 ! 1669 !-- Save fluxes 1670 DO k = nzb, nzt+1 1671 rad_sw_in(k,j,i) = rrtm_swdflx(0,k) 1672 rad_sw_out(k,j,i) = rrtm_swuflx(0,k) 1673 ENDDO 1674 1675 ! 1676 !-- Save heating rates (convert from K/d to K/s) 1677 DO k = nzb+1, nzt+1 1678 rad_sw_hr(k,j,i) = rrtm_swhr(0,k) * d_hours_day 1679 rad_sw_cs_hr(k,j,i) = rrtm_swhrc(0,k) * d_hours_day 1680 ENDDO 1681 1682 ENDIF 1683 1684 ! 1685 !-- Calculate surface net radiation 1686 rad_net(j,i) = rad_sw_in(nzb,j,i) - rad_sw_out(nzb,j,i) & 1687 + rad_lw_in(nzb,j,i) - rad_lw_out(nzb,j,i) 1688 3539 ENDDO 3540 3541 ENDIF 3542 ! 3543 !-- Finally, calculate surface net radiation for surface elements. 3544 !-- First, for horizontal surfaces 3545 DO m = 1, surf_def_h(0)%ns 3546 surf_def_h(0)%rad_net(m) = surf_def_h(0)%rad_sw_in(m) & 3547 - surf_def_h(0)%rad_sw_out(m) & 3548 + surf_def_h(0)%rad_lw_in(m) & 3549 - surf_def_h(0)%rad_lw_out(m) 3550 ENDDO 3551 DO m = 1, surf_lsm_h%ns 3552 surf_lsm_h%rad_net(m) = surf_lsm_h%rad_sw_in(m) & 3553 - surf_lsm_h%rad_sw_out(m) & 3554 + surf_lsm_h%rad_lw_in(m) & 3555 - surf_lsm_h%rad_lw_out(m) 3556 ENDDO 3557 DO m = 1, surf_usm_h%ns 3558 surf_usm_h%rad_net(m) = surf_usm_h%rad_sw_in(m) & 3559 - surf_usm_h%rad_sw_out(m) & 3560 + surf_usm_h%rad_lw_in(m) & 3561 - surf_usm_h%rad_lw_out(m) 3562 ENDDO 3563 ! 3564 !-- Vertical surfaces. 3565 !-- Todo: weight with azimuth and zenith angle according to their orientation! 3566 DO l = 0, 3 3567 DO m = 1, surf_def_v(l)%ns 3568 surf_def_v(l)%rad_net(m) = surf_def_v(l)%rad_sw_in(m) & 3569 - surf_def_v(l)%rad_sw_out(m) & 3570 + surf_def_v(l)%rad_lw_in(m) & 3571 - surf_def_v(l)%rad_lw_out(m) 3572 ENDDO 3573 DO m = 1, surf_lsm_v(l)%ns 3574 surf_lsm_v(l)%rad_net(m) = surf_lsm_v(l)%rad_sw_in(m) & 3575 - surf_lsm_v(l)%rad_sw_out(m) & 3576 + surf_lsm_v(l)%rad_lw_in(m) & 3577 - surf_lsm_v(l)%rad_lw_out(m) 3578 ENDDO 3579 DO m = 1, surf_usm_v(l)%ns 3580 surf_usm_v(l)%rad_net(m) = surf_usm_v(l)%rad_sw_in(m) & 3581 - surf_usm_v(l)%rad_sw_out(m) & 3582 + surf_usm_v(l)%rad_lw_in(m) & 3583 - surf_usm_v(l)%rad_lw_out(m) 1689 3584 ENDDO 1690 3585 ENDDO 3586 1691 3587 1692 3588 CALL exchange_horiz( rad_lw_in, nbgp ) … … 1700 3596 CALL exchange_horiz( rad_sw_cs_hr, nbgp ) 1701 3597 1702 CALL exchange_horiz_2d( rad_net )1703 CALL exchange_horiz_2d( rad_lw_out_change_0 )1704 3598 #endif 1705 3599 … … 1765 3659 !> Briegleb et al. (1986) 1766 3660 !------------------------------------------------------------------------------! 1767 SUBROUTINE calc_albedo 3661 SUBROUTINE calc_albedo( surf ) 1768 3662 1769 3663 IMPLICIT NONE 1770 3664 1771 IF ( sun_up ) THEN 1772 ! 1773 !-- Ocean 1774 IF ( albedo_type == 1 ) THEN 1775 rrtm_aldir(0,:,:) = 0.026_wp / ( zenith(0)**1.7_wp + 0.065_wp ) & 3665 INTEGER(iwp) :: m !< running index surface elements 3666 3667 TYPE(surf_type) :: surf !< treated surfaces 3668 3669 IF ( sun_up .AND. .NOT. average_radiation) THEN 3670 3671 DO m = 1, surf%ns 3672 ! 3673 !-- Ocean 3674 IF ( surf%albedo_type(0,m) == 1 ) THEN 3675 surf%rrtm_aldir(m) = 0.026_wp / & 3676 ( zenith(0)**1.7_wp + 0.065_wp ) & 1776 3677 + 0.15_wp * ( zenith(0) - 0.1_wp ) & 1777 3678 * ( zenith(0) - 0.5_wp ) & 1778 3679 * ( zenith(0) - 1.0_wp ) 1779 rrtm_asdir(0,:,:) = rrtm_aldir(0,:,:)1780 ! 1781 !-- Snow1782 ELSEIF ( albedo_type== 16 ) THEN1783 IF ( zenith(0) < 0.5_wp ) THEN1784 rrtm_aldir(0,:,:) = 0.5_wp * (1.0_wp - aldif)&3680 surf%rrtm_asdir(m) = surf%rrtm_aldir(m) 3681 ! 3682 !-- Snow 3683 ELSEIF ( surf%albedo_type(0,m) == 16 ) THEN 3684 IF ( zenith(0) < 0.5_wp ) THEN 3685 surf%rrtm_aldir(m) = 0.5_wp * (1.0_wp - surf%aldif(m)) & 1785 3686 * ( 3.0_wp / (1.0_wp + 4.0_wp & 1786 3687 * zenith(0))) - 1.0_wp 1787 rrtm_asdir(0,:,:) = 0.5_wp * (1.0_wp - asdif)&3688 surf%rrtm_asdir(m) = 0.5_wp * (1.0_wp - surf%asdif(m)) & 1788 3689 * ( 3.0_wp / (1.0_wp + 4.0_wp & 1789 3690 * zenith(0))) - 1.0_wp 1790 3691 1791 rrtm_aldir(0,:,:) = MIN(0.98_wp, rrtm_aldir(0,:,:)) 1792 rrtm_asdir(0,:,:) = MIN(0.98_wp, rrtm_asdir(0,:,:)) 3692 surf%rrtm_aldir(m) = MIN(0.98_wp, surf%rrtm_aldir(m)) 3693 surf%rrtm_asdir(m) = MIN(0.98_wp, surf%rrtm_asdir(m)) 3694 ELSE 3695 surf%rrtm_aldir(m) = surf%aldif(m) 3696 surf%rrtm_asdir(m) = surf%asdif(m) 3697 ENDIF 3698 ! 3699 !-- Sea ice 3700 ELSEIF ( surf%albedo_type(0,m) == 15 ) THEN 3701 surf%rrtm_aldir(m) = surf%aldif(m) 3702 surf%rrtm_asdir(m) = surf%asdif(m) 3703 3704 ! 3705 !-- Asphalt 3706 ELSEIF ( surf%albedo_type(0,m) == 17 ) THEN 3707 surf%rrtm_aldir(m) = surf%aldif(m) 3708 surf%rrtm_asdir(m) = surf%asdif(m) 3709 3710 3711 ! 3712 !-- Bare soil 3713 ELSEIF ( surf%albedo_type(0,m) == 18 ) THEN 3714 surf%rrtm_aldir(m) = surf%aldif(m) 3715 surf%rrtm_asdir(m) = surf%asdif(m) 3716 3717 ! 3718 !-- Land surfaces 1793 3719 ELSE 1794 rrtm_aldir(0,:,:) = aldif 1795 rrtm_asdir(0,:,:) = asdif 3720 SELECT CASE ( surf%albedo_type(0,m) ) 3721 3722 ! 3723 !-- Surface types with strong zenith dependence 3724 CASE ( 1, 2, 3, 4, 11, 12, 13 ) 3725 surf%rrtm_aldir(m) = surf%aldif(m) * 1.4_wp / & 3726 (1.0_wp + 0.8_wp * zenith(0)) 3727 surf%rrtm_asdir(m) = surf%asdif(m) * 1.4_wp / & 3728 (1.0_wp + 0.8_wp * zenith(0)) 3729 ! 3730 !-- Surface types with weak zenith dependence 3731 CASE ( 5, 6, 7, 8, 9, 10, 14 ) 3732 surf%rrtm_aldir(m) = surf%aldif(m) * 1.1_wp / & 3733 (1.0_wp + 0.2_wp * zenith(0)) 3734 surf%rrtm_asdir(m) = surf%asdif(m) * 1.1_wp / & 3735 (1.0_wp + 0.2_wp * zenith(0)) 3736 3737 CASE DEFAULT 3738 3739 END SELECT 1796 3740 ENDIF 1797 3741 ! 1798 !-- Sea ice 1799 ELSEIF ( albedo_type == 15 ) THEN 1800 rrtm_aldir(0,:,:) = aldif 1801 rrtm_asdir(0,:,:) = asdif 1802 1803 ! 1804 !-- Bare soil 1805 ELSEIF ( albedo_type == 17 ) THEN 1806 rrtm_aldir(0,:,:) = aldif 1807 rrtm_asdir(0,:,:) = asdif 1808 1809 ! 1810 !-- For impermeable surfaces, use values from the lookup table 1811 ELSEIF ( albedo_type > 17 ) THEN 1812 rrtm_aldir(0,:,:) = aldif 1813 rrtm_asdir(0,:,:) = asdif 1814 ! 1815 !-- Land surfaces 1816 ELSE 1817 SELECT CASE ( albedo_type ) 1818 1819 ! 1820 !-- Surface types with strong zenith dependence 1821 CASE ( 1, 2, 3, 4, 11, 12, 13 ) 1822 rrtm_aldir(0,:,:) = aldif * 1.4_wp / & 1823 (1.0_wp + 0.8_wp * zenith(0)) 1824 rrtm_asdir(0,:,:) = asdif * 1.4_wp / & 1825 (1.0_wp + 0.8_wp * zenith(0)) 1826 ! 1827 !-- Surface types with weak zenith dependence 1828 CASE ( 5, 6, 7, 8, 9, 10, 14 ) 1829 rrtm_aldir(0,:,:) = aldif * 1.1_wp / & 1830 (1.0_wp + 0.2_wp * zenith(0)) 1831 rrtm_asdir(0,:,:) = asdif * 1.1_wp / & 1832 (1.0_wp + 0.2_wp * zenith(0)) 1833 1834 CASE DEFAULT 1835 1836 END SELECT 1837 ENDIF 1838 ! 1839 !-- Diffusive albedo is taken from Table 2 1840 rrtm_aldif(0,:,:) = aldif 1841 rrtm_asdif(0,:,:) = asdif 1842 3742 !-- Diffusive albedo is taken from Table 2 3743 surf%rrtm_aldif(m) = surf%aldif(m) 3744 surf%rrtm_asdif(m) = surf%asdif(m) 3745 ENDDO 3746 ! 3747 !-- Set albedo in case of average radiation 3748 ELSEIF ( sun_up .AND. average_radiation ) THEN 3749 surf%rrtm_asdir = albedo_urb 3750 surf%rrtm_asdif = albedo_urb 3751 surf%rrtm_aldir = albedo_urb 3752 surf%rrtm_aldif = albedo_urb 3753 ! 3754 !-- Darkness 1843 3755 ELSE 1844 1845 rrtm_aldir(0,:,:) = 0.0_wp 1846 rrtm_asdir(0,:,:) = 0.0_wp 1847 rrtm_aldif(0,:,:) = 0.0_wp 1848 rrtm_asdif(0,:,:) = 0.0_wp 3756 surf%rrtm_aldir = 0.0_wp 3757 surf%rrtm_asdir = 0.0_wp 3758 surf%rrtm_aldif = 0.0_wp 3759 surf%rrtm_asdif = 0.0_wp 1849 3760 ENDIF 3761 1850 3762 END SUBROUTINE calc_albedo 1851 3763 … … 2478 4390 END SUBROUTINE radiation_tendency 2479 4391 4392 4393 !------------------------------------------------------------------------------! 4394 ! Description: 4395 ! ------------ 4396 !> This subroutine calculates interaction of the solar radiation 4397 !> with urban and land surfaces and updates all surface heatfluxes, including 4398 !> the vertual atmospheric cell faces. It calculates also the required parameters 4399 !> for RRTMG lower BC. 4400 !> 4401 !> For more info. see Resler et al. 2017 4402 !> 4403 !------------------------------------------------------------------------------! 4404 SUBROUTINE radiation_interaction_init 4405 4406 USE netcdf_data_input_mod, & 4407 ONLY: leaf_area_density_f 4408 4409 USE plant_canopy_model_mod, & 4410 ONLY: plant_canopy, pch_index, & 4411 pc_heating_rate, lad_s, prototype_lad, usm_lad_rma 4412 4413 USE surface_mod, & 4414 ONLY: get_topography_top_index, surf_lsm_h, surf_lsm_v, surf_usm_h,& 4415 surf_usm_v 4416 4417 IMPLICIT NONE 4418 4419 INTEGER(iwp) :: i, j, k, d, l, ir, jr, ids, m 4420 INTEGER(iwp) :: k_topo !< vertical index indicating topography top for given (j,i) 4421 INTEGER(iwp) :: k_topo2 !< vertical index indicating topography top for given (j,i) 4422 INTEGER(iwp) :: nzubl, nzutl, isurf, ipcgb 4423 INTEGER(iwp) :: procid 4424 4425 INTEGER(iwp), DIMENSION(1:4,inorth_b:iwest_b) :: ijdb !< start and end of the local domain border coordinates (set in code) 4426 LOGICAL, DIMENSION(inorth_b:iwest_b) :: isborder !< is PE on the border of the domain in four corresponding directions 4427 4428 ! 4429 !-- Find nzub, nzut, nzu via wall_flag_0 array (nzb_s_inner will be 4430 !-- removed later). The following contruct finds the lowest / largest index 4431 !-- for any upward-facing wall (see bit 12). 4432 nzubl = MINVAL( get_topography_top_index( 's' ) ) 4433 nzutl = MAXVAL( get_topography_top_index( 's' ) ) 4434 4435 nzubl = MAX( nzubl, nzb ) 4436 4437 IF ( plant_canopy ) THEN 4438 !-- allocate needed arrays 4439 ALLOCATE( pct(nys:nyn,nxl:nxr) ) 4440 ALLOCATE( pch(nys:nyn,nxl:nxr) ) 4441 4442 !-- calculate plant canopy height 4443 npcbl = 0 4444 pct = 0 4445 pch = 0 4446 DO i = nxl, nxr 4447 DO j = nys, nyn 4448 ! 4449 !-- Find topography top index 4450 k_topo = get_topography_top_index( j, i, 's' ) 4451 4452 DO k = nzt+1, 0, -1 4453 IF ( lad_s(k,j,i) /= 0.0_wp ) THEN 4454 !-- we are at the top of the pcs 4455 pct(j,i) = k + k_topo 4456 pch(j,i) = k 4457 npcbl = npcbl + pch(j,i) 4458 EXIT 4459 ENDIF 4460 ENDDO 4461 ENDDO 4462 ENDDO 4463 4464 nzutl = MAX( nzutl, MAXVAL( pct ) ) 4465 !-- code of plant canopy model uses parameter pch_index 4466 !-- we need to setup it here to right value 4467 !-- (pch_index, lad_s and other arrays in PCM are defined flat) 4468 pch_index = MERGE( leaf_area_density_f%nz - 1, MAXVAL( pch ), & 4469 leaf_area_density_f%from_file ) 4470 4471 prototype_lad = MAXVAL( lad_s ) * .9_wp !< better be *1.0 if lad is either 0 or maxval(lad) everywhere 4472 IF ( prototype_lad <= 0._wp ) prototype_lad = .3_wp 4473 !WRITE(message_string, '(a,f6.3)') 'Precomputing effective box optical ' & 4474 ! // 'depth using prototype leaf area density = ', prototype_lad 4475 !CALL message('usm_init_urban_surface', 'PA0520', 0, 0, -1, 6, 0) 4476 ENDIF 4477 4478 nzutl = MIN( nzutl + nzut_free, nzt ) 4479 4480 #if defined( __parallel ) 4481 CALL MPI_AllReduce(nzubl, nzub, 1, MPI_INTEGER, MPI_MIN, comm2d, ierr ) 4482 CALL MPI_AllReduce(nzutl, nzut, 1, MPI_INTEGER, MPI_MAX, comm2d, ierr ) 4483 #else 4484 nzub = nzubl 4485 nzut = nzutl 4486 #endif 4487 ! 4488 !-- global number of urban layers 4489 nzu = nzut - nzub + 1 4490 ! 4491 !-- allocate urban surfaces grid 4492 !-- calc number of surfaces in local proc 4493 CALL location_message( ' calculation of indices for surfaces', .TRUE. ) 4494 nsurfl = 0 4495 ! 4496 !-- Number of horizontal surfaces including land- and roof surfaces in both USM and LSM. Note that 4497 !-- All horizontal surface elements are already counted in surface_mod. 4498 startland = 1 4499 nsurfl = surf_usm_h%ns + surf_lsm_h%ns 4500 endland = nsurfl 4501 nlands = endland - startland + 1 4502 4503 ! 4504 !-- Number of vertical surfaces in both USM and LSM. Note that all vertical surface elements are 4505 !-- already counted in surface_mod. 4506 startwall = nsurfl+1 4507 DO i = 0,3 4508 nsurfl = nsurfl + surf_usm_v(i)%ns + surf_lsm_v(i)%ns 4509 ENDDO 4510 endwall = nsurfl 4511 nwalls = endwall - startwall + 1 4512 4513 !-- range of energy balance surfaces ! will be treated separately by surf_usm_h and surf_usm_v 4514 !-- Do we really need usm_energy_balance_land??!! 4515 !-- !!! Attention: if usm_energy_balance_land = false then only vertical surfaces will be considered here 4516 nenergy = 0 4517 IF ( energy_balance_surf_h ) THEN 4518 startenergy = startland 4519 nenergy = nenergy + nlands 4520 ELSE 4521 startenergy = startwall 4522 ENDIF 4523 IF ( energy_balance_surf_v ) THEN 4524 endenergy = endwall 4525 nenergy = nenergy + nwalls 4526 ELSE 4527 endenergy = endland 4528 ENDIF 4529 4530 !!!!!!!!!!!!!!!!!!!!!!!!!!!!! 4531 !-- block of virtual surfaces 4532 !!!!!!!!!!!!!!!!!!!!!!!!!!!!! 4533 !-- calculate sky surfaces ! not used so far! 4534 startsky = nsurfl+1 4535 nsurfl = nsurfl+(nxr-nxl+1)*(nyn-nys+1) 4536 endsky = nsurfl 4537 nskys = endsky-startsky+1 4538 4539 !-- border flags 4540 #if defined( __parallel ) 4541 isborder = (/ north_border_pe, south_border_pe, right_border_pe, left_border_pe /) 4542 #else 4543 isborder = (/.TRUE.,.TRUE.,.TRUE.,.TRUE./) 4544 #endif 4545 !-- fill array of the limits of the local domain borders 4546 ijdb = RESHAPE( (/ nxl,nxr,nyn,nyn,nxl,nxr,nys,nys,nxr,nxr,nys,nyn,nxl,nxl,nys,nyn /), (/4, 4/) ) 4547 !-- calulation of the free borders of the domain 4548 startborder = nsurfl + 1 4549 DO ids = inorth_b,iwest_b 4550 IF ( isborder(ids) ) THEN 4551 !-- free border of the domain in direction ids 4552 DO i = ijdb(1,ids), ijdb(2,ids) 4553 DO j = ijdb(3,ids), ijdb(4,ids) 4554 4555 k_topo = get_topography_top_index( j, i, 's' ) 4556 k_topo2 = get_topography_top_index( j-jdir(ids), i-idir(ids), 's' ) 4557 4558 4559 k = nzut - MAX( k_topo, k_topo2 ) 4560 nsurfl = nsurfl + k 4561 ENDDO 4562 ENDDO 4563 ENDIF 4564 ENDDO 4565 endborder = nsurfl 4566 nborder = endborder - startborder + 1 4567 4568 !-- calulation of the atmospheric virtual surfaces 4569 !-- each atmospheric cell has 6 faces 4570 IF ( atm_surfaces ) THEN 4571 DO i = nxl, nxr 4572 DO j = nys, nyn 4573 !-- Find topography top index 4574 k_topo = get_topography_top_index( j, i, 's' ) 4575 k = nzut - k_topo 4576 nsurfl = nsurfl + 6 * k 4577 ENDDO 4578 ENDDO 4579 !-- exclude the local physical surfaces 4580 nsurfl = nsurfl - nlands - nwalls 4581 !-- exclude the local virtual surfaces 4582 nsurfl = nsurfl - nskys - nborder 4583 ENDIF 4584 4585 !-- fill gridpcbl and pcbl 4586 IF ( plant_canopy ) THEN 4587 ALLOCATE( pcbl(iz:ix, 1:npcbl) ) 4588 ALLOCATE( gridpcbl(nzub:nzut,nys:nyn,nxl:nxr) ) 4589 gridpcbl(:,:,:) = 0 4590 ipcgb = 0 4591 DO i = nxl, nxr 4592 DO j = nys, nyn 4593 ! 4594 !-- Find topography top index 4595 k_topo = get_topography_top_index( j, i, 's' ) 4596 4597 DO k = k_topo + 1, pct(j,i) 4598 ipcgb = ipcgb + 1 4599 gridpcbl(k,j,i) = ipcgb 4600 pcbl(:,ipcgb) = (/ k, j, i /) 4601 ENDDO 4602 ENDDO 4603 ENDDO 4604 4605 ALLOCATE( pcbinsw( 1:npcbl ) ) 4606 ALLOCATE( pcbinlw( 1:npcbl ) ) 4607 ENDIF 4608 4609 !-- fill surfl 4610 ALLOCATE(surfl(5,nsurfl)) ! is it mecessary to allocate it with (5,nsurfl)? 4611 isurf = 0 4612 4613 !-- add horizontal surface elements (land and urban surfaces) 4614 !-- TODO: add urban overhanging surfaces (idown_u) 4615 DO i = nxl, nxr 4616 DO j = nys, nyn 4617 DO m = surf_usm_h%start_index(j,i), surf_usm_h%end_index(j,i) 4618 k = surf_usm_h%k(m) 4619 4620 isurf = isurf + 1 4621 surfl(:,isurf) = (/iup_u,k,j,i,m/) 4622 ENDDO 4623 4624 DO m = surf_lsm_h%start_index(j,i), surf_lsm_h%end_index(j,i) 4625 k = surf_lsm_h%k(m) 4626 4627 isurf = isurf + 1 4628 surfl(:,isurf) = (/iup_l,k,j,i,m/) 4629 ENDDO 4630 4631 ENDDO 4632 ENDDO 4633 4634 !-- add vertical surface elements (land and urban surfaces) 4635 !-- TODO: remove the hard coding of l = 0 to l = idirection 4636 DO i = nxl, nxr 4637 DO j = nys, nyn 4638 l = 0 4639 DO m = surf_usm_v(l)%start_index(j,i), surf_usm_v(l)%end_index(j,i) 4640 k = surf_usm_v(l)%k(m) 4641 4642 isurf = isurf + 1 4643 surfl(:,isurf) = (/inorth_u,k,j,i,m/) 4644 ENDDO 4645 DO m = surf_lsm_v(l)%start_index(j,i), surf_lsm_v(l)%end_index(j,i) 4646 k = surf_lsm_v(l)%k(m) 4647 4648 isurf = isurf + 1 4649 surfl(:,isurf) = (/inorth_l,k,j,i,m/) 4650 ENDDO 4651 4652 l = 1 4653 DO m = surf_usm_v(l)%start_index(j,i), surf_usm_v(l)%end_index(j,i) 4654 k = surf_usm_v(l)%k(m) 4655 4656 isurf = isurf + 1 4657 surfl(:,isurf) = (/isouth_u,k,j,i,m/) 4658 ENDDO 4659 DO m = surf_lsm_v(l)%start_index(j,i), surf_lsm_v(l)%end_index(j,i) 4660 k = surf_lsm_v(l)%k(m) 4661 4662 isurf = isurf + 1 4663 surfl(:,isurf) = (/isouth_l,k,j,i,m/) 4664 ENDDO 4665 4666 l = 2 4667 DO m = surf_usm_v(l)%start_index(j,i), surf_usm_v(l)%end_index(j,i) 4668 k = surf_usm_v(l)%k(m) 4669 4670 isurf = isurf + 1 4671 surfl(:,isurf) = (/ieast_u,k,j,i,m/) 4672 ENDDO 4673 DO m = surf_lsm_v(l)%start_index(j,i), surf_lsm_v(l)%end_index(j,i) 4674 k = surf_lsm_v(l)%k(m) 4675 4676 isurf = isurf + 1 4677 surfl(:,isurf) = (/ieast_l,k,j,i,m/) 4678 ENDDO 4679 4680 l = 3 4681 DO m = surf_usm_v(l)%start_index(j,i), surf_usm_v(l)%end_index(j,i) 4682 k = surf_usm_v(l)%k(m) 4683 4684 isurf = isurf + 1 4685 surfl(:,isurf) = (/iwest_u,k,j,i,m/) 4686 ENDDO 4687 DO m = surf_lsm_v(l)%start_index(j,i), surf_lsm_v(l)%end_index(j,i) 4688 k = surf_lsm_v(l)%k(m) 4689 4690 isurf = isurf + 1 4691 surfl(:,isurf) = (/iwest_l,k,j,i,m/) 4692 ENDDO 4693 ENDDO 4694 ENDDO 4695 4696 !-- add sky 4697 DO i = nxl, nxr 4698 DO j = nys, nyn 4699 isurf = isurf + 1 4700 k = nzut 4701 surfl(:,isurf) = (/isky,k,j,i,-1/) 4702 ENDDO 4703 ENDDO 4704 4705 !-- calulation of the free borders of the domain 4706 DO ids = inorth_b,iwest_b 4707 IF ( isborder(ids) ) THEN 4708 !-- free border of the domain in direction ids 4709 DO i = ijdb(1,ids), ijdb(2,ids) 4710 DO j = ijdb(3,ids), ijdb(4,ids) 4711 k_topo = get_topography_top_index( j, i, 's' ) 4712 k_topo2 = get_topography_top_index( j-jdir(ids), i-idir(ids), 's' ) 4713 4714 DO k = MAX(k_topo,k_topo2)+1, nzut 4715 isurf = isurf + 1 4716 surfl(:,isurf) = (/ids,k,j,i,-1/) 4717 ENDDO 4718 ENDDO 4719 ENDDO 4720 ENDIF 4721 ENDDO 4722 4723 !-- adding the atmospheric virtual surfaces 4724 IF ( atm_surfaces ) THEN 4725 !-- TODO: use flags to identfy atmospheric cells and its coresponding surfaces 4726 !-- add horizontal surface 4727 DO i = nxl, nxr 4728 DO j = nys, nyn 4729 k_topo = get_topography_top_index( j, i, 's' ) 4730 4731 !-- add upward surface 4732 DO k = (k_topo+1), nzut-1 4733 isurf = isurf + 1 4734 surfl(:,isurf) = (/iup_a,k+1,j,i,-1/) 4735 ENDDO 4736 4737 !-- add downward surface 4738 DO k = (k_topo+1), nzut-1 4739 isurf = isurf + 1 4740 surfl(:,isurf) = (/idown_a,k,j,i,-1/) 4741 ENDDO 4742 ENDDO 4743 ENDDO 4744 4745 !-- add vertical surfaces 4746 DO i = nxl, nxr 4747 DO j = nys, nyn 4748 k_topo = get_topography_top_index( j, i, 's' ) 4749 !-- north 4750 IF ( j /= ny ) THEN 4751 ids = inorth_a 4752 jr = min(max(j-jdir(ids),0),ny) 4753 ir = min(max(i-idir(ids),0),nx) 4754 k_topo2 = get_topography_top_index( jr, ir, 's' ) 4755 DO k = MAX(k_topo,k_topo2)+1, nzut 4756 isurf = isurf + 1 4757 surfl(:,isurf) = (/inorth_a,k,j,i,-1/) 4758 ENDDO 4759 END IF 4760 !-- south 4761 IF ( j /= 0 ) THEN 4762 ids = isouth_a 4763 jr = min(max(j-jdir(ids),0),ny) 4764 ir = min(max(i-idir(ids),0),nx) 4765 k_topo2 = get_topography_top_index( jr, ir, 's' ) 4766 4767 DO k = MAX(k_topo,k_topo2)+1, nzut 4768 isurf = isurf + 1 4769 surfl(:,isurf) = (/isouth_a,k,j,i,-1/) 4770 ENDDO 4771 END IF 4772 !-- east 4773 IF ( i /= nx ) THEN 4774 ids = ieast_a 4775 jr = min(max(j-jdir(ids),0),ny) 4776 ir = min(max(i-idir(ids),0),nx) 4777 k_topo2 = get_topography_top_index( jr, ir, 's' ) 4778 4779 DO k = MAX(k_topo,k_topo2)+1, nzut 4780 isurf = isurf + 1 4781 surfl(:,isurf) = (/ieast_a,k,j,i,-1/) 4782 ENDDO 4783 END IF 4784 !-- west 4785 IF ( i /= 0 ) THEN 4786 ids = iwest_a 4787 jr = min(max(j-jdir(ids),0),ny) 4788 ir = min(max(i-idir(ids),0),nx) 4789 k_topo2 = get_topography_top_index( jr, ir, 's' ) 4790 4791 DO k = MAX(k_topo,k_topo2)+1, nzut 4792 isurf = isurf + 1 4793 surfl(:,isurf) = (/iwest_a,k,j,i,-1/) 4794 ENDDO 4795 END IF 4796 ENDDO 4797 ENDDO 4798 4799 ENDIF 4800 4801 ! 4802 !-- broadband albedo of the land, roof and wall surface 4803 !-- for domain border and sky set artifically to 1.0 4804 !-- what allows us to calculate heat flux leaving over 4805 !-- side and top borders of the domain 4806 ALLOCATE ( albedo_surf(nsurfl) ) 4807 albedo_surf = 1.0_wp 4808 ! 4809 !-- Also allocate further array for emissivity with identical order of 4810 !-- surface elements as radiation arrays. 4811 !-- MS: Why startenergy:endenergy and albedo surf from 1:nsurfl ? 4812 ALLOCATE ( emiss_surf(startenergy:endenergy) ) 4813 4814 4815 ! 4816 !-- global array surf of indices of surfaces and displacement index array surfstart 4817 ALLOCATE(nsurfs(0:numprocs-1)) 4818 4819 #if defined( __parallel ) 4820 CALL MPI_Allgather(nsurfl,1,MPI_INTEGER,nsurfs,1,MPI_INTEGER,comm2d,ierr) 4821 #else 4822 nsurfs(0) = nsurfl 4823 #endif 4824 ALLOCATE(surfstart(0:numprocs)) 4825 k = 0 4826 DO i=0,numprocs-1 4827 surfstart(i) = k 4828 k = k+nsurfs(i) 4829 ENDDO 4830 surfstart(numprocs) = k 4831 nsurf = k 4832 ALLOCATE(surf(5,nsurf)) 4833 4834 #if defined( __parallel ) 4835 CALL MPI_AllGatherv(surfl, nsurfl*5, MPI_INTEGER, surf, nsurfs*5, surfstart*5, MPI_INTEGER, comm2d, ierr) 4836 #else 4837 surf = surfl 4838 #endif 4839 4840 !-- 4841 !-- allocation of the arrays for direct and diffusion radiation 4842 CALL location_message( ' allocation of radiation arrays', .TRUE. ) 4843 !-- rad_sw_in, rad_lw_in are computed in radiation model, 4844 !-- splitting of direct and diffusion part is done 4845 !-- in usm_calc_diffusion_radiation for now 4846 4847 ALLOCATE( rad_sw_in_dir(nysg:nyng,nxlg:nxrg) ) 4848 ALLOCATE( rad_sw_in_diff(nysg:nyng,nxlg:nxrg) ) 4849 ALLOCATE( rad_lw_in_diff(nysg:nyng,nxlg:nxrg) ) 4850 rad_sw_in_dir = 0.0_wp 4851 rad_sw_in_diff = 0.0_wp 4852 rad_lw_in_diff = 0.0_wp 4853 4854 !-- allocate radiation arrays 4855 ALLOCATE( surfins(nsurfl) ) 4856 ALLOCATE( surfinl(nsurfl) ) 4857 ALLOCATE( surfinsw(nsurfl) ) 4858 ALLOCATE( surfinlw(nsurfl) ) 4859 ALLOCATE( surfinswdir(nsurfl) ) 4860 ALLOCATE( surfinswdif(nsurfl) ) 4861 ALLOCATE( surfinlwdif(nsurfl) ) 4862 ALLOCATE( surfoutsl(startenergy:endenergy) ) 4863 ALLOCATE( surfoutll(startenergy:endenergy) ) 4864 ALLOCATE( surfoutsw(startenergy:endenergy) ) 4865 ALLOCATE( surfoutlw(startenergy:endenergy) ) 4866 ALLOCATE( surfouts(nsurf) ) !TODO: global surfaces without virtual 4867 ALLOCATE( surfoutl(nsurf) ) !TODO: global surfaces without virtual 4868 4869 ! 4870 !-- @Mohamed 4871 !-- In case of average_radiation, aggregated surface albedo and emissivity, 4872 !-- also set initial value of t_rad_urb. 4873 !-- For the moment set an arbitrary initial value. 4874 IF ( average_radiation ) THEN 4875 albedo_urb = 0.5_wp 4876 emissivity_urb = 0.5_wp 4877 t_rad_urb = pt_surface 4878 ENDIF 4879 4880 END SUBROUTINE radiation_interaction_init 4881 !------------------------------------------------------------------------------! 4882 ! Description: 4883 ! ------------ 4884 !> This subroutine calculates interaction of the solar radiation 4885 !> with urban and land surfaces and updates all surface heatfluxes, including 4886 !> the vertual atmospheric cell faces. It calculates also the required parameters 4887 !> for RRTMG lower BC. 4888 !> 4889 !> For more info. see Resler et al. 2017 4890 !> 4891 !------------------------------------------------------------------------------! 4892 SUBROUTINE radiation_interaction 4893 4894 4895 USE control_parameters 4896 4897 USE plant_canopy_model_mod, & 4898 ONLY: prototype_lad 4899 4900 IMPLICIT NONE 4901 4902 INTEGER(iwp) :: i, j, k, kk, is, js, d, ku, refstep, m, mm, l, ll 4903 INTEGER(iwp) :: ii, jj !< running indices 4904 INTEGER(iwp) :: nzubl, nzutl, isurf, isurfsrc, isurf1, isvf, icsf, ipcgb 4905 INTEGER(iwp), DIMENSION(4) :: bdycross 4906 REAL(wp), DIMENSION(3,3) :: mrot !< grid rotation matrix (xyz) 4907 REAL(wp), DIMENSION(3,0:nsurf_type) :: vnorm !< face direction normal vectors (xyz) 4908 REAL(wp), DIMENSION(3) :: sunorig !< grid rotated solar direction unit vector (xyz) 4909 REAL(wp), DIMENSION(3) :: sunorig_grid !< grid squashed solar direction unit vector (zyx) 4910 REAL(wp), DIMENSION(0:nsurf_type) :: costheta !< direct irradiance factor of solar angle 4911 REAL(wp), DIMENSION(nzub:nzut) :: pchf_prep !< precalculated factor for canopy temp tendency 4912 REAL(wp), PARAMETER :: alpha = 0._wp !< grid rotation (TODO: add to namelist or remove) 4913 REAL(wp) :: rx, ry, rz 4914 REAL(wp) :: pc_box_area, pc_abs_frac, pc_abs_eff 4915 INTEGER(iwp) :: pc_box_dimshift !< transform for best accuracy 4916 INTEGER(iwp), DIMENSION(0:3) :: reorder = (/ 1, 0, 3, 2 /) 4917 REAL(wp), DIMENSION(0:nsurf_type) :: facearea 4918 REAL(wp) :: pabsswl = 0.0_wp !< total absorbed SW radiation energy in local processor (W) 4919 REAL(wp) :: pabssw = 0.0_wp !< total absorbed SW radiation energy in all processors (W) 4920 REAL(wp) :: pabslwl = 0.0_wp !< total absorbed LW radiation energy in local processor (W) 4921 REAL(wp) :: pabslw = 0.0_wp !< total absorbed LW radiation energy in all processors (W) 4922 REAL(wp) :: pemitlwl = 0.0_wp !< total emitted LW radiation energy in all processors (W) 4923 REAL(wp) :: pemitlw = 0.0_wp !< total emitted LW radiation energy in all processors (W) 4924 REAL(wp) :: pinswl = 0.0_wp !< total received SW radiation energy in local processor (W) 4925 REAL(wp) :: pinsw = 0.0_wp !< total received SW radiation energy in all processor (W) 4926 REAL(wp) :: pinlwl = 0.0_wp !< total received LW radiation energy in local processor (W) 4927 REAL(wp) :: pinlw = 0.0_wp !< total received LW radiation energy in all processor (W) 4928 REAL(wp) :: emiss_sum_surfl !< sum of emissisivity of surfaces in local processor 4929 REAL(wp) :: emiss_sum_surf !< sum of emissisivity of surfaces in all processor 4930 REAL(wp) :: area_surfl !< total area of surfaces in local processor 4931 REAL(wp) :: area_surf !< total area of surfaces in all processor 4932 4933 IF ( plant_canopy ) THEN 4934 pchf_prep(:) = r_d * (hyp(nzub:nzut) / 100000.0_wp)**0.286_wp & 4935 / (cp * hyp(nzub:nzut) * dx*dy*dz) !< equals to 1 / (rho * c_p * Vbox * T) 4936 ENDIF 4937 4938 sun_direction = .TRUE. 4939 CALL calc_zenith !< required also for diffusion radiation 4940 4941 !-- prepare rotated normal vectors and irradiance factor 4942 vnorm(1,:) = idir(:) 4943 vnorm(2,:) = jdir(:) 4944 vnorm(3,:) = kdir(:) 4945 mrot(1, :) = (/ cos(alpha), -sin(alpha), 0._wp /) 4946 mrot(2, :) = (/ sin(alpha), cos(alpha), 0._wp /) 4947 mrot(3, :) = (/ 0._wp, 0._wp, 1._wp /) 4948 sunorig = (/ sun_dir_lon, sun_dir_lat, zenith(0) /) 4949 sunorig = matmul(mrot, sunorig) 4950 DO d = 0, nsurf_type 4951 costheta(d) = dot_product(sunorig, vnorm(:,d)) 4952 ENDDO 4953 4954 IF ( zenith(0) > 0 ) THEN 4955 !-- now we will "squash" the sunorig vector by grid box size in 4956 !-- each dimension, so that this new direction vector will allow us 4957 !-- to traverse the ray path within grid coordinates directly 4958 sunorig_grid = (/ sunorig(3)/dz, sunorig(2)/dy, sunorig(1)/dx /) 4959 !-- sunorig_grid = sunorig_grid / norm2(sunorig_grid) 4960 sunorig_grid = sunorig_grid / SQRT(SUM(sunorig_grid**2)) 4961 4962 IF ( plant_canopy ) THEN 4963 !-- precompute effective box depth with prototype Leaf Area Density 4964 pc_box_dimshift = maxloc(sunorig, 1) - 1 4965 CALL box_absorb(cshift((/dx,dy,dz/), pc_box_dimshift), & 4966 60, prototype_lad, & 4967 cshift(sunorig, pc_box_dimshift), & 4968 pc_box_area, pc_abs_frac) 4969 pc_box_area = pc_box_area * sunorig(pc_box_dimshift+1) / sunorig(3) 4970 pc_abs_eff = log(1._wp - pc_abs_frac) / prototype_lad 4971 ENDIF 4972 ENDIF 4973 4974 !-- split diffusion and direct part of the solar downward radiation 4975 !-- comming from radiation model and store it in 2D arrays 4976 !-- rad_sw_in_diff, rad_sw_in_dir and rad_lw_in_diff 4977 IF ( split_diffusion_radiation ) THEN 4978 CALL calc_diffusion_radiation 4979 ELSE 4980 DO i = nxl, nxr 4981 DO j = nys, nyn 4982 DO m = surf_def_h(0)%start_index(j,i), & 4983 surf_def_h(0)%end_index(j,i) 4984 rad_sw_in_diff(j,i) = 0.0_wp 4985 rad_sw_in_dir(j,i) = surf_def_h(0)%rad_sw_in(m) 4986 rad_lw_in_diff(j,i) = surf_def_h(0)%rad_lw_in(m) 4987 ENDDO 4988 DO m = surf_lsm_h%start_index(j,i), & 4989 surf_lsm_h%end_index(j,i) 4990 rad_sw_in_diff(j,i) = 0.0_wp 4991 rad_sw_in_dir(j,i) = surf_lsm_h%rad_sw_in(m) 4992 rad_lw_in_diff(j,i) = surf_lsm_h%rad_lw_in(m) 4993 ENDDO 4994 DO m = surf_usm_h%start_index(j,i), & 4995 surf_usm_h%end_index(j,i) 4996 rad_sw_in_diff(j,i) = 0.0_wp 4997 rad_sw_in_dir(j,i) = surf_usm_h%rad_sw_in(m) 4998 rad_lw_in_diff(j,i) = surf_usm_h%rad_lw_in(m) 4999 ENDDO 5000 ENDDO 5001 ENDDO 5002 ENDIF 5003 5004 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 5005 !-- First pass: direct + diffuse irradiance 5006 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 5007 surfinswdir = 0._wp !nsurfl 5008 surfinswdif = 0._wp !nsurfl 5009 surfinlwdif = 0._wp !nsurfl 5010 surfins = 0._wp !nsurfl 5011 surfinl = 0._wp !nsurfl 5012 surfoutsl(:) = 0.0_wp !start-end 5013 surfoutll(:) = 0.0_wp !start-end 5014 5015 !-- Set up thermal radiation from surfaces 5016 !-- emiss_surf is defined only for surfaces for which energy balance is calculated 5017 !-- Workaround: reorder surface data type back on 1D array including all surfaces, 5018 !-- which implies to reorder horizontal and vertical surfaces 5019 ! 5020 !-- Horizontal walls 5021 mm = 1 5022 DO i = nxl, nxr 5023 DO j = nys, nyn 5024 !-- urban 5025 DO m = surf_usm_h%start_index(j,i), surf_usm_h%end_index(j,i) 5026 surfoutll(mm) = SUM ( surf_usm_h%frac(:,m) * & 5027 surf_usm_h%emissivity(:,m) ) & 5028 * sigma_sb & 5029 * surf_usm_h%pt_surface(m)**4 5030 albedo_surf(mm) = SUM ( surf_usm_h%frac(:,m) * & 5031 surf_usm_h%albedo(:,m) ) 5032 emiss_surf(mm) = SUM ( surf_usm_h%frac(:,m) * & 5033 surf_usm_h%emissivity(:,m) ) 5034 mm = mm + 1 5035 ENDDO 5036 !-- land 5037 DO m = surf_lsm_h%start_index(j,i), surf_lsm_h%end_index(j,i) 5038 surfoutll(mm) = SUM ( surf_lsm_h%frac(:,m) * & 5039 surf_lsm_h%emissivity(:,m) ) & 5040 * sigma_sb & 5041 * surf_lsm_h%pt_surface(m)**4 5042 albedo_surf(mm) = SUM ( surf_lsm_h%frac(:,m) * & 5043 surf_lsm_h%albedo(:,m) ) 5044 emiss_surf(mm) = SUM ( surf_lsm_h%frac(:,m) * & 5045 surf_lsm_h%emissivity(:,m) ) 5046 mm = mm + 1 5047 ENDDO 5048 ENDDO 5049 ENDDO 5050 ! 5051 !-- Vertical walls 5052 DO i = nxl, nxr 5053 DO j = nys, nyn 5054 DO ll = 0, 3 5055 l = reorder(ll) 5056 !-- urban 5057 DO m = surf_usm_v(l)%start_index(j,i), & 5058 surf_usm_v(l)%end_index(j,i) 5059 surfoutll(mm) = SUM ( surf_usm_v(l)%frac(:,m) * & 5060 surf_usm_v(l)%emissivity(:,m) ) & 5061 * sigma_sb & 5062 * surf_usm_v(l)%pt_surface(m)**4 5063 albedo_surf(mm) = SUM ( surf_usm_v(l)%frac(:,m) * & 5064 surf_usm_v(l)%albedo(:,m) ) 5065 emiss_surf(mm) = SUM ( surf_usm_v(l)%frac(:,m) * & 5066 surf_usm_v(l)%emissivity(:,m) ) 5067 mm = mm + 1 5068 ENDDO 5069 !-- land 5070 DO m = surf_lsm_v(l)%start_index(j,i), & 5071 surf_lsm_v(l)%end_index(j,i) 5072 surfoutll(mm) = SUM ( surf_lsm_v(l)%frac(:,m) * & 5073 surf_lsm_v(l)%emissivity(:,m) ) & 5074 * sigma_sb & 5075 * surf_lsm_v(l)%pt_surface(m)**4 5076 albedo_surf(mm) = SUM ( surf_lsm_v(l)%frac(:,m) * & 5077 surf_lsm_v(l)%albedo(:,m) ) 5078 emiss_surf(mm) = SUM ( surf_lsm_v(l)%frac(:,m) * & 5079 surf_lsm_v(l)%emissivity(:,m) ) 5080 mm = mm + 1 5081 ENDDO 5082 ENDDO 5083 ENDDO 5084 ENDDO 5085 5086 #if defined( __parallel ) 5087 !-- might be optimized and gather only values relevant for current processor 5088 5089 CALL MPI_AllGatherv(surfoutll, nenergy, MPI_REAL, & 5090 surfoutl, nsurfs, surfstart, MPI_REAL, comm2d, ierr) !nsurf global 5091 #else 5092 surfoutl(:) = surfoutll(:) !nsurf global 5093 #endif 5094 5095 isurf1 = -1 !< previous processed surface 5096 DO isvf = 1, nsvfl 5097 isurf = svfsurf(1, isvf) 5098 k = surfl(iz, isurf) 5099 j = surfl(iy, isurf) 5100 i = surfl(ix, isurf) 5101 isurfsrc = svfsurf(2, isvf) 5102 IF ( zenith(0) > 0 .AND. isurf /= isurf1 ) THEN 5103 !-- locate the virtual surface where the direct solar ray crosses domain boundary 5104 !-- (once per target surface) 5105 d = surfl(id, isurf) 5106 rz = REAL(k, wp) - 0.5_wp * kdir(d) 5107 ry = REAL(j, wp) - 0.5_wp * jdir(d) 5108 rx = REAL(i, wp) - 0.5_wp * idir(d) 5109 5110 CALL find_boundary_face( (/ rz, ry, rx /), sunorig_grid, bdycross) 5111 5112 isurf1 = isurf 5113 ENDIF 5114 5115 IF ( surf(id, isurfsrc) >= isky ) THEN 5116 !-- diffuse rad from boundary surfaces. Since it is a simply 5117 !-- calculated value, it is not assigned to surfref(s/l), 5118 !-- instead it is used directly here 5119 !-- we consider the radiation from the radiation model falling on surface 5120 !-- as the radiation falling on the top of urban layer into the place of the source surface 5121 !-- we consider it as a very reasonable simplification which allow as avoid 5122 !-- necessity of other global range arrays and some all to all mpi communication 5123 surfinswdif(isurf) = surfinswdif(isurf) + rad_sw_in_diff(j,i) * svf(1,isvf) * svf(2,isvf) 5124 !< canopy shading is applied only to shortwave 5125 surfinlwdif(isurf) = surfinlwdif(isurf) + rad_lw_in_diff(j,i) * svf(1,isvf) 5126 ELSE 5127 !-- for surface-to-surface factors we calculate thermal radiation in 1st pass 5128 surfinl(isurf) = surfinl(isurf) + svf(1,isvf) * surfoutl(isurfsrc) 5129 ENDIF 5130 5131 IF ( zenith(0) > 0 .AND. all( surf(1:4,isurfsrc) == bdycross ) ) THEN 5132 !-- found svf between model boundary and the face => face isn't shaded 5133 surfinswdir(isurf) = rad_sw_in_dir(j,i) & 5134 * costheta(surfl(id, isurf)) * svf(2,isvf) / zenith(0) 5135 5136 ENDIF 5137 ENDDO 5138 5139 IF ( plant_canopy ) THEN 5140 5141 pcbinsw(:) = 0._wp 5142 pcbinlw(:) = 0._wp !< will stay always 0 since we don't absorb lw anymore 5143 ! 5144 !-- pcsf first pass 5145 isurf1 = -1 !< previous processed pcgb 5146 DO icsf = 1, ncsfl 5147 ipcgb = csfsurf(1, icsf) 5148 i = pcbl(ix,ipcgb) 5149 j = pcbl(iy,ipcgb) 5150 k = pcbl(iz,ipcgb) 5151 isurfsrc = csfsurf(2, icsf) 5152 5153 IF ( zenith(0) > 0 .AND. ipcgb /= isurf1 ) THEN 5154 !-- locate the virtual surface where the direct solar ray crosses domain boundary 5155 !-- (once per target PC gridbox) 5156 rz = REAL(k, wp) 5157 ry = REAL(j, wp) 5158 rx = REAL(i, wp) 5159 CALL find_boundary_face( (/ rz, ry, rx /), & 5160 sunorig_grid, bdycross) 5161 5162 isurf1 = ipcgb 5163 ENDIF 5164 5165 IF ( surf(id, isurfsrc) >= isky ) THEN 5166 !-- Diffuse rad from boundary surfaces. See comments for svf above. 5167 pcbinsw(ipcgb) = pcbinsw(ipcgb) + csf(1,icsf) * csf(2,icsf) * rad_sw_in_diff(j,i) 5168 !-- canopy shading is applied only to shortwave, therefore no absorbtion for lw 5169 !-- pcbinlw(ipcgb) = pcbinlw(ipcgb) + svf(1,isvf) * rad_lw_in_diff(j,i) 5170 !ELSE 5171 !-- Thermal radiation in 1st pass 5172 !-- pcbinlw(ipcgb) = pcbinlw(ipcgb) + svf(1,isvf) * surfoutl(isurfsrc) 5173 ENDIF 5174 5175 IF ( zenith(0) > 0 .AND. ALL( surf(1:4,isurfsrc) == bdycross ) ) THEN 5176 !-- found svf between model boundary and the pcgb => pcgb isn't shaded 5177 pc_abs_frac = 1._wp - EXP(pc_abs_eff * lad_s(k,j,i)) 5178 pcbinsw(ipcgb) = pcbinsw(ipcgb) & 5179 + rad_sw_in_dir(j, i) * pc_box_area * csf(2,icsf) * pc_abs_frac 5180 ENDIF 5181 ENDDO 5182 ENDIF 5183 5184 surfins(startenergy:endenergy) = surfinswdir(startenergy:endenergy) + surfinswdif(startenergy:endenergy) 5185 surfinl(startenergy:endenergy) = surfinl(startenergy:endenergy) + surfinlwdif(startenergy:endenergy) 5186 surfinsw(:) = surfins(:) 5187 surfinlw(:) = surfinl(:) 5188 surfoutsw(:) = 0.0_wp 5189 surfoutlw(:) = surfoutll(:) 5190 ! surfhf(startenergy:endenergy) = surfinsw(startenergy:endenergy) + surfinlw(startenergy:endenergy) & 5191 ! - surfoutsw(startenergy:endenergy) - surfoutlw(startenergy:endenergy) 5192 5193 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 5194 !-- Next passes - reflections 5195 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 5196 DO refstep = 1, nrefsteps 5197 5198 surfoutsl(startenergy:endenergy) = albedo_surf(startenergy:endenergy) * surfins(startenergy:endenergy) 5199 !-- for non-transparent surfaces, longwave albedo is 1 - emissivity 5200 surfoutll(startenergy:endenergy) = (1._wp - emiss_surf(startenergy:endenergy)) * surfinl(startenergy:endenergy) 5201 5202 #if defined( __parallel ) 5203 CALL MPI_AllGatherv(surfoutsl, nsurfl, MPI_REAL, & 5204 surfouts, nsurfs, surfstart, MPI_REAL, comm2d, ierr) 5205 CALL MPI_AllGatherv(surfoutll, nsurfl, MPI_REAL, & 5206 surfoutl, nsurfs, surfstart, MPI_REAL, comm2d, ierr) 5207 #else 5208 surfouts(:) = surfoutsl(:) 5209 surfoutl(:) = surfoutll(:) 5210 #endif 5211 5212 !-- reset for next pass input 5213 surfins(:) = 0._wp 5214 surfinl(:) = 0._wp 5215 5216 !-- reflected radiation 5217 DO isvf = 1, nsvfl 5218 isurf = svfsurf(1, isvf) 5219 isurfsrc = svfsurf(2, isvf) 5220 5221 !-- TODO: to remove if, use start+end for isvf 5222 IF ( surf(id, isurfsrc) < isky ) THEN 5223 surfins(isurf) = surfins(isurf) + svf(1,isvf) * svf(2,isvf) * surfouts(isurfsrc) 5224 surfinl(isurf) = surfinl(isurf) + svf(1,isvf) * surfoutl(isurfsrc) 5225 ENDIF 5226 ENDDO 5227 5228 !-- radiation absorbed by plant canopy 5229 DO icsf = 1, ncsfl 5230 ipcgb = csfsurf(1, icsf) 5231 isurfsrc = csfsurf(2, icsf) 5232 5233 IF ( surf(id, isurfsrc) < isky ) THEN 5234 pcbinsw(ipcgb) = pcbinsw(ipcgb) + csf(1,icsf) * csf(2,icsf) * surfouts(isurfsrc) 5235 !-- pcbinlw(ipcgb) = pcbinlw(ipcgb) + csf(1,icsf) * surfoutl(isurfsrc) 5236 ENDIF 5237 ENDDO 5238 5239 surfinsw(:) = surfinsw(:) + surfins(:) 5240 surfinlw(:) = surfinlw(:) + surfinl(:) 5241 surfoutsw(startenergy:endenergy) = surfoutsw(startenergy:endenergy) + surfoutsl(startenergy:endenergy) 5242 surfoutlw(startenergy:endenergy) = surfoutlw(startenergy:endenergy) + surfoutll(startenergy:endenergy) 5243 ! surfhf(startenergy:endenergy) = surfinsw(startenergy:endenergy) + surfinlw(startenergy:endenergy) & 5244 ! - surfoutsw(startenergy:endenergy) - surfoutlw(startenergy:endenergy) 5245 5246 ENDDO 5247 5248 !-- push heat flux absorbed by plant canopy to respective 3D arrays 5249 IF ( plant_canopy ) THEN 5250 pc_heating_rate(:,:,:) = 0._wp 5251 DO ipcgb = 1, npcbl 5252 j = pcbl(iy, ipcgb) 5253 i = pcbl(ix, ipcgb) 5254 k = pcbl(iz, ipcgb) 5255 ! 5256 !-- Following expression equals former kk = k - nzb_s_inner(j,i) 5257 kk = k - get_topography_top_index( j, i, 's' ) !- lad arrays are defined flat 5258 pc_heating_rate(kk, j, i) = (pcbinsw(ipcgb) + pcbinlw(ipcgb)) & 5259 * pchf_prep(k) * pt(k, j, i) !-- = dT/dt 5260 ENDDO 5261 ENDIF 5262 ! 5263 !-- Transfer radiation arrays required for energy balance to the respective data types 5264 DO i = startenergy, endenergy 5265 m = surfl(5,i) 5266 ! 5267 !-- (1) Urban surfaces 5268 !-- upward-facing 5269 IF ( surfl(1,i) == iup_u ) THEN 5270 surf_usm_h%rad_sw_in(m) = surfinsw(i) 5271 surf_usm_h%rad_sw_out(m) = surfoutsw(i) 5272 surf_usm_h%rad_lw_in(m) = surfinlw(i) 5273 surf_usm_h%rad_lw_out(m) = surfoutlw(i) 5274 surf_usm_h%rad_net(m) = surfinsw(i) - surfoutsw(i) + & 5275 surfinlw(i) - surfoutlw(i) 5276 ! 5277 !-- northward-facding 5278 ELSEIF ( surfl(1,i) == inorth_u ) THEN 5279 surf_usm_v(0)%rad_sw_in(m) = surfinsw(i) 5280 surf_usm_v(0)%rad_sw_out(m) = surfoutsw(i) 5281 surf_usm_v(0)%rad_lw_in(m) = surfinlw(i) 5282 surf_usm_v(0)%rad_lw_out(m) = surfoutlw(i) 5283 surf_usm_v(0)%rad_net(m) = surfinsw(i) - surfoutsw(i) + & 5284 surfinlw(i) - surfoutlw(i) 5285 ! 5286 !-- southward-facding 5287 ELSEIF ( surfl(1,i) == isouth_u ) THEN 5288 surf_usm_v(1)%rad_sw_in(m) = surfinsw(i) 5289 surf_usm_v(1)%rad_sw_out(m) = surfoutsw(i) 5290 surf_usm_v(1)%rad_lw_in(m) = surfinlw(i) 5291 surf_usm_v(1)%rad_lw_out(m) = surfoutlw(i) 5292 surf_usm_v(1)%rad_net(m) = surfinsw(i) - surfoutsw(i) + & 5293 surfinlw(i) - surfoutlw(i) 5294 ! 5295 !-- eastward-facing 5296 ELSEIF ( surfl(1,i) == ieast_u ) THEN 5297 surf_usm_v(2)%rad_sw_in(m) = surfinsw(i) 5298 surf_usm_v(2)%rad_sw_out(m) = surfoutsw(i) 5299 surf_usm_v(2)%rad_lw_in(m) = surfinlw(i) 5300 surf_usm_v(2)%rad_lw_out(m) = surfoutlw(i) 5301 surf_usm_v(2)%rad_net(m) = surfinsw(i) - surfoutsw(i) + & 5302 surfinlw(i) - surfoutlw(i) 5303 ! 5304 !-- westward-facding 5305 ELSEIF ( surfl(1,i) == iwest_u ) THEN 5306 surf_usm_v(3)%rad_sw_in(m) = surfinsw(i) 5307 surf_usm_v(3)%rad_sw_out(m) = surfoutsw(i) 5308 surf_usm_v(3)%rad_lw_in(m) = surfinlw(i) 5309 surf_usm_v(3)%rad_lw_out(m) = surfoutlw(i) 5310 surf_usm_v(3)%rad_net(m) = surfinsw(i) - surfoutsw(i) + & 5311 surfinlw(i) - surfoutlw(i) 5312 ! 5313 !-- (2) land surfaces 5314 !-- upward-facing 5315 ELSEIF ( surfl(1,i) == iup_l ) THEN 5316 surf_lsm_h%rad_sw_in(m) = surfinsw(i) 5317 surf_lsm_h%rad_sw_out(m) = surfoutsw(i) 5318 surf_lsm_h%rad_lw_in(m) = surfinlw(i) 5319 surf_lsm_h%rad_lw_out(m) = surfoutlw(i) 5320 surf_lsm_h%rad_net(m) = surfinsw(i) - surfoutsw(i) + & 5321 surfinlw(i) - surfoutlw(i) 5322 ! 5323 !-- northward-facding 5324 ELSEIF ( surfl(1,i) == inorth_l ) THEN 5325 surf_lsm_v(0)%rad_sw_in(m) = surfinsw(i) 5326 surf_lsm_v(0)%rad_sw_out(m) = surfoutsw(i) 5327 surf_lsm_v(0)%rad_lw_in(m) = surfinlw(i) 5328 surf_lsm_v(0)%rad_lw_out(m) = surfoutlw(i) 5329 surf_lsm_v(0)%rad_net(m) = surfinsw(i) - surfoutsw(i) + & 5330 surfinlw(i) - surfoutlw(i) 5331 ! 5332 !-- southward-facding 5333 ELSEIF ( surfl(1,i) == isouth_l ) THEN 5334 surf_lsm_v(1)%rad_sw_in(m) = surfinsw(i) 5335 surf_lsm_v(1)%rad_sw_out(m) = surfoutsw(i) 5336 surf_lsm_v(1)%rad_lw_in(m) = surfinlw(i) 5337 surf_lsm_v(1)%rad_lw_out(m) = surfoutlw(i) 5338 surf_lsm_v(1)%rad_net(m) = surfinsw(i) - surfoutsw(i) + & 5339 surfinlw(i) - surfoutlw(i) 5340 ! 5341 !-- eastward-facing 5342 ELSEIF ( surfl(1,i) == ieast_l ) THEN 5343 surf_lsm_v(2)%rad_sw_in(m) = surfinsw(i) 5344 surf_lsm_v(2)%rad_sw_out(m) = surfoutsw(i) 5345 surf_lsm_v(2)%rad_lw_in(m) = surfinlw(i) 5346 surf_lsm_v(2)%rad_lw_out(m) = surfoutlw(i) 5347 surf_lsm_v(2)%rad_net(m) = surfinsw(i) - surfoutsw(i) + & 5348 surfinlw(i) - surfoutlw(i) 5349 ! 5350 !-- westward-facding 5351 ELSEIF ( surfl(1,i) == iwest_l ) THEN 5352 surf_lsm_v(3)%rad_sw_in(m) = surfinsw(i) 5353 surf_lsm_v(3)%rad_sw_out(m) = surfoutsw(i) 5354 surf_lsm_v(3)%rad_lw_in(m) = surfinlw(i) 5355 surf_lsm_v(3)%rad_lw_out(m) = surfoutlw(i) 5356 surf_lsm_v(3)%rad_net(m) = surfinsw(i) - surfoutsw(i) + & 5357 surfinlw(i) - surfoutlw(i) 5358 ENDIF 5359 5360 ENDDO 5361 5362 DO m = 1, surf_usm_h%ns 5363 surf_usm_h%surfhf(m) = surf_usm_h%rad_sw_in(m) + & 5364 surf_usm_h%rad_lw_in(m) - & 5365 surf_usm_h%rad_sw_out(m) - & 5366 surf_usm_h%rad_lw_out(m) 5367 ENDDO 5368 DO m = 1, surf_lsm_h%ns 5369 surf_lsm_h%surfhf(m) = surf_lsm_h%rad_sw_in(m) + & 5370 surf_lsm_h%rad_lw_in(m) - & 5371 surf_lsm_h%rad_sw_out(m) - & 5372 surf_lsm_h%rad_lw_out(m) 5373 ENDDO 5374 5375 DO l = 0, 3 5376 !-- urban 5377 DO m = 1, surf_usm_v(l)%ns 5378 surf_usm_v(l)%surfhf(m) = surf_usm_v(l)%rad_sw_in(m) + & 5379 surf_usm_v(l)%rad_lw_in(m) - & 5380 surf_usm_v(l)%rad_sw_out(m) - & 5381 surf_usm_v(l)%rad_lw_out(m) 5382 ENDDO 5383 !-- land 5384 DO m = 1, surf_lsm_v(l)%ns 5385 surf_lsm_v(l)%surfhf(m) = surf_lsm_v(l)%rad_sw_in(m) + & 5386 surf_lsm_v(l)%rad_lw_in(m) - & 5387 surf_lsm_v(l)%rad_sw_out(m) - & 5388 surf_lsm_v(l)%rad_lw_out(m) 5389 5390 ENDDO 5391 ENDDO 5392 ! 5393 !-- Calculate the average temperature, albedo, and emissivity for urban/land domain 5394 !-- in case of using average_radiation in the respective radiation model 5395 IF ( average_radiation ) THEN 5396 5397 !-- 5398 !-- precalculate face areas for different face directions using normal vector 5399 !-- TODO: make facearea a globale variable because it is used in more than one subroutine 5400 DO d = 0, nsurf_type 5401 facearea(d) = 1._wp 5402 IF ( idir(d) == 0 ) facearea(d) = facearea(d) * dx 5403 IF ( jdir(d) == 0 ) facearea(d) = facearea(d) * dy 5404 IF ( kdir(d) == 0 ) facearea(d) = facearea(d) * dz 5405 ENDDO 5406 ! 5407 !-- total absorbed SW & LW and emitted LW energy by all physical surfaces (land and urban) in local processor 5408 pabsswl = 0._wp 5409 pabslwl = 0._wp 5410 pemitlwl = 0._wp 5411 emiss_sum_surfl = 0._wp 5412 area_surfl = 0._wp 5413 DO i = startenergy, endenergy 5414 d = surfl(id, i) 5415 pabsswl = pabsswl + (1._wp - albedo_surf(i)) * surfinsw(i) * facearea(d) 5416 pabslwl = pabslwl + emiss_surf(i) * surfinlw(i) * facearea(d) 5417 pemitlwl = pemitlwl + surfoutlw(i) * facearea(d) 5418 emiss_sum_surfl = emiss_sum_surfl + emiss_surf(i) * facearea(d) 5419 area_surfl = area_surfl + facearea(d) 5420 END DO 5421 ! 5422 !-- add the absorbed SW energy by plant canopy 5423 IF ( plant_canopy ) THEN 5424 pabsswl = pabsswl + SUM(pcbinsw) 5425 pabslwl = pabslwl + SUM(pcbinlw) 5426 ENDIF 5427 ! 5428 !-- gather all absorbed SW energy in all processors 5429 #if defined( __parallel ) 5430 CALL MPI_ALLREDUCE( pabsswl, pabssw, 1, MPI_REAL, MPI_SUM, comm2d, ierr ) 5431 CALL MPI_ALLREDUCE( pabslwl, pabslw, 1, MPI_REAL, MPI_SUM, comm2d, ierr ) 5432 CALL MPI_ALLREDUCE( pemitlwl, pemitlw, 1, MPI_REAL, MPI_SUM, comm2d, ierr ) 5433 CALL MPI_ALLREDUCE( emiss_sum_surfl, emiss_sum_surf, 1, MPI_REAL, MPI_SUM, comm2d, ierr ) 5434 CALL MPI_ALLREDUCE( area_surfl, area_surf, 1, MPI_REAL, MPI_SUM, comm2d, ierr ) 5435 #else 5436 pabssw = pabsswl 5437 pabslwl = pabslw 5438 pemitlwl = pemitlw 5439 emiss_sum_surf = emiss_sum_surfl 5440 area_surf = area_surfl 5441 #endif 5442 ! 5443 !-- total received SW energy in local processor !!!!!! cos??!!!! 5444 pinswl = 0._wp 5445 pinlwl = 0._wp 5446 !-- sky 5447 DO i = startsky, endsky 5448 d = surfl(id, i) 5449 ii = surfl(ix, i) 5450 jj = surfl(iy, i) 5451 pinswl = pinswl + (rad_sw_in_dir(jj,ii) + rad_sw_in_diff(jj,ii)) * facearea(d) 5452 pinlwl = pinlwl + rad_lw_in_diff(jj,ii) * facearea(d) 5453 ENDDO 5454 !-- boundary 5455 DO i = startborder, endborder 5456 d = surfl(id, i) 5457 ii = surfl(ix, i) 5458 jj = surfl(iy, i) 5459 pinswl = pinswl + (rad_sw_in_dir(jj,ii) + rad_sw_in_diff(jj,ii)) * facearea(d) 5460 pinlwl = pinlwl + rad_lw_in_diff(jj,ii) * facearea(d) 5461 ENDDO 5462 !-- gather all received SW energy in all processors 5463 #if defined( __parallel ) 5464 CALL MPI_ALLREDUCE( pinswl, pinsw, 1, MPI_REAL, MPI_SUM, comm2d, ierr) 5465 CALL MPI_ALLREDUCE( pinlwl, pinlw, 1, MPI_REAL, MPI_SUM, comm2d, ierr) 5466 #else 5467 pinsw = pinswl 5468 pinlw = pinlwl 5469 #endif 5470 !-- (1) albedo 5471 IF ( pinsw /= 0.0_wp ) albedo_urb = 1._wp - pabssw / pinsw 5472 5473 !-- (2) average emmsivity 5474 emissivity_urb = emiss_sum_surf / area_surf 5475 5476 !-- (3) temerature 5477 t_rad_urb = ((pemitlw - pabslw + emissivity_urb*pinlw)/(emissivity_urb*sigma_sb*area_surf))**0.25_wp 5478 5479 ENDIF 5480 5481 !-- return surface radiation to horizontal surfaces 5482 !-- to rad_sw_in, rad_lw_in and rad_net for outputs 5483 !!!!!!!!!! 5484 !-- we need the original radiation on urban top layer 5485 !-- for calculation of MRT so we can't do adjustment here for now 5486 !!!!!!!!!! 5487 !!!DO isurf = 1, nsurfl 5488 !!! i = surfl(ix,isurf) 5489 !!! j = surfl(iy,isurf) 5490 !!! k = surfl(iz,isurf) 5491 !!! d = surfl(id,isurf) 5492 !!! IF ( d==iroof ) THEN 5493 !!! rad_sw_in(:,j,i) = surfinsw(isurf) 5494 !!! rad_lw_in(:,j,i) = surfinlw(isurf) 5495 !!! 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) 5496 !!! ENDIF 5497 !!!ENDDO 5498 5499 CONTAINS 5500 5501 !------------------------------------------------------------------------------! 5502 ! Description: 5503 ! ------------ 5504 !> This subroutine splits direct and diffusion dw radiation 5505 !> It sould not be called in case the radiation model already does it 5506 !> It follows <CITATION> 5507 !------------------------------------------------------------------------------! 5508 SUBROUTINE calc_diffusion_radiation 5509 5510 USE date_and_time_mod, & 5511 ONLY: day_of_year_init, time_utc_init 5512 5513 REAL(wp), PARAMETER :: sol_const = 1367.0_wp !< solar conbstant 5514 REAL(wp), PARAMETER :: lowest_solarUp = 0.1_wp !< limit the sun elevation to protect stability of the calculation 5515 INTEGER(iwp) :: i, j 5516 REAL(wp), PARAMETER :: year_seconds = 86400._wp * 365._wp 5517 REAL(wp) :: year_angle !< angle 5518 REAL(wp) :: etr !< extraterestrial radiation 5519 REAL(wp) :: corrected_solarUp !< corrected solar up radiation 5520 REAL(wp) :: horizontalETR !< horizontal extraterestrial radiation 5521 REAL(wp) :: clearnessIndex !< clearness index 5522 REAL(wp) :: diff_frac !< diffusion fraction of the radiation 5523 5524 5525 !-- Calculate current day and time based on the initial values and simulation time 5526 year_angle = ((day_of_year_init*86400) & 5527 + time_utc_init+time_since_reference_point) & 5528 / year_seconds * 2.0_wp * pi 5529 5530 etr = sol_const * (1.00011_wp + & 5531 0.034221_wp * cos(year_angle) + & 5532 0.001280_wp * sin(year_angle) + & 5533 0.000719_wp * cos(2.0_wp * year_angle) + & 5534 0.000077_wp * sin(2.0_wp * year_angle)) 5535 5536 !-- 5537 !-- Under a very low angle, we keep extraterestrial radiation at 5538 !-- the last small value, therefore the clearness index will be pushed 5539 !-- towards 0 while keeping full continuity. 5540 !-- 5541 IF ( zenith(0) <= lowest_solarUp ) THEN 5542 corrected_solarUp = lowest_solarUp 5543 ELSE 5544 corrected_solarUp = zenith(0) 5545 ENDIF 5546 5547 horizontalETR = etr * corrected_solarUp 5548 5549 DO i = nxl, nxr 5550 DO j = nys, nyn 5551 5552 DO m = surf_def_h(0)%start_index(j,i), & 5553 surf_def_h(0)%end_index(j,i) 5554 clearnessIndex = surf_def_h(0)%rad_sw_in(m) / horizontalETR 5555 diff_frac = 1.0_wp / & 5556 (1.0_wp + exp(-5.0033_wp + 8.6025_wp * clearnessIndex)) 5557 rad_sw_in_diff(j,i) = surf_def_h(0)%rad_sw_in(m) * diff_frac 5558 rad_sw_in_dir(j,i) = surf_def_h(0)%rad_sw_in(m) * & 5559 (1.0_wp - diff_frac) 5560 rad_lw_in_diff(j,i) = surf_def_h(0)%rad_lw_in(m) 5561 ENDDO 5562 DO m = surf_lsm_h%start_index(j,i), & 5563 surf_lsm_h%end_index(j,i) 5564 clearnessIndex = surf_lsm_h%rad_sw_in(m) / horizontalETR 5565 diff_frac = 1.0_wp / & 5566 (1.0_wp + exp(-5.0033_wp + 8.6025_wp * clearnessIndex)) 5567 rad_sw_in_diff(j,i) = surf_lsm_h%rad_sw_in(m) * diff_frac 5568 rad_sw_in_dir(j,i) = surf_lsm_h%rad_sw_in(m) * & 5569 (1.0_wp - diff_frac) 5570 rad_lw_in_diff(j,i) = surf_lsm_h%rad_lw_in(m) 5571 ENDDO 5572 DO m = surf_usm_h%start_index(j,i), & 5573 surf_usm_h%end_index(j,i) 5574 clearnessIndex = surf_usm_h%rad_sw_in(m) / horizontalETR 5575 diff_frac = 1.0_wp / & 5576 (1.0_wp + exp(-5.0033_wp + 8.6025_wp * clearnessIndex)) 5577 rad_sw_in_diff(j,i) = surf_usm_h%rad_sw_in(m) * diff_frac 5578 rad_sw_in_dir(j,i) = surf_usm_h%rad_sw_in(m) * & 5579 (1.0_wp - diff_frac) 5580 rad_lw_in_diff(j,i) = surf_usm_h%rad_lw_in(m) 5581 ENDDO 5582 ENDDO 5583 ENDDO 5584 5585 END SUBROUTINE calc_diffusion_radiation 5586 5587 !------------------------------------------------------------------------------! 5588 !> Finds first model boundary crossed by a ray 5589 !------------------------------------------------------------------------------! 5590 PURE SUBROUTINE find_boundary_face(origin, uvect, bdycross) 5591 5592 IMPLICIT NONE 5593 5594 INTEGER(iwp) :: d !< 5595 INTEGER(iwp) :: seldim !< found fist crossing index 5596 5597 INTEGER(iwp), DIMENSION(3) :: bdyd !< boundary direction 5598 INTEGER(iwp), DIMENSION(4), INTENT(out) :: bdycross !< found boundary crossing (d, z, y, x) 5599 5600 REAL(wp) :: bdydim !< 5601 REAL(wp) :: dist !< 5602 5603 REAL(wp), DIMENSION(3) :: crossdist !< crossing distance 5604 REAL(wp), DIMENSION(3), INTENT(in) :: origin !< ray origin 5605 REAL(wp), DIMENSION(3), INTENT(in) :: uvect !< ray unit vector 5606 5607 5608 bdydim = nzut + .5_wp !< top boundary 5609 bdyd(1) = isky 5610 crossdist(1) = ( bdydim - origin(1) ) / uvect(1) !< subroutine called only when uvect(1)>0 5611 5612 IF ( uvect(2) == 0._wp ) THEN 5613 crossdist(2) = huge(1._wp) 5614 ELSE 5615 IF ( uvect(2) >= 0._wp ) THEN 5616 bdydim = ny + .5_wp !< north global boundary 5617 bdyd(2) = inorth_b 5618 ELSE 5619 bdydim = -.5_wp !< south global boundary 5620 bdyd(2) = isouth_b 5621 ENDIF 5622 crossdist(2) = ( bdydim - origin(2) ) / uvect(2) 5623 ENDIF 5624 5625 IF ( uvect(3) == 0._wp ) THEN 5626 crossdist(3) = huge(1._wp) 5627 ELSE 5628 IF ( uvect(3) >= 0._wp ) THEN 5629 bdydim = nx + .5_wp !< east global boundary 5630 bdyd(3) = ieast_b 5631 ELSE 5632 bdydim = -.5_wp !< west global boundary 5633 bdyd(3) = iwest_b 5634 ENDIF 5635 crossdist(3) = ( bdydim - origin(3) ) / uvect(3) 5636 ENDIF 5637 5638 seldim = minloc(crossdist, 1) 5639 dist = crossdist(seldim) 5640 d = bdyd(seldim) 5641 5642 bdycross(1) = d 5643 bdycross(2:4) = NINT( origin(:) + uvect(:) * dist & 5644 + .5_wp * (/ kdir(d), jdir(d), idir(d) /) ) 5645 5646 END SUBROUTINE find_boundary_face 5647 !------------------------------------------------------------------------------! 5648 !> Calculates radiation absorbed by box with given size and LAD. 5649 !> 5650 !> Simulates resol**2 rays (by equally spacing a bounding horizontal square 5651 !> conatining all possible rays that would cross the box) and calculates 5652 !> average transparency per ray. Returns fraction of absorbed radiation flux 5653 !> and area for which this fraction is effective. 5654 !------------------------------------------------------------------------------! 5655 PURE SUBROUTINE box_absorb(boxsize, resol, dens, uvec, area, absorb) 5656 IMPLICIT NONE 5657 5658 REAL(wp), DIMENSION(3), INTENT(in) :: & 5659 boxsize, & !< z, y, x size of box in m 5660 uvec !< z, y, x unit vector of incoming flux 5661 INTEGER(iwp), INTENT(in) :: & 5662 resol !< No. of rays in x and y dimensions 5663 REAL(wp), INTENT(in) :: & 5664 dens !< box density (e.g. Leaf Area Density) 5665 REAL(wp), INTENT(out) :: & 5666 area, & !< horizontal area for flux absorbtion 5667 absorb !< fraction of absorbed flux 5668 REAL(wp) :: & 5669 xshift, yshift, & 5670 xmin, xmax, ymin, ymax, & 5671 xorig, yorig, & 5672 dx1, dy1, dz1, dx2, dy2, dz2, & 5673 crdist, & 5674 transp 5675 INTEGER(iwp) :: & 5676 i, j 5677 5678 xshift = uvec(3) / uvec(1) * boxsize(1) 5679 xmin = min(0._wp, -xshift) 5680 xmax = boxsize(3) + max(0._wp, -xshift) 5681 yshift = uvec(2) / uvec(1) * boxsize(1) 5682 ymin = min(0._wp, -yshift) 5683 ymax = boxsize(2) + max(0._wp, -yshift) 5684 5685 transp = 0._wp 5686 DO i = 1, resol 5687 xorig = xmin + (xmax-xmin) * (i-.5_wp) / resol 5688 DO j = 1, resol 5689 yorig = ymin + (ymax-ymin) * (j-.5_wp) / resol 5690 5691 dz1 = 0._wp 5692 dz2 = boxsize(1)/uvec(1) 5693 5694 IF ( uvec(2) > 0._wp ) THEN 5695 dy1 = -yorig / uvec(2) !< crossing with y=0 5696 dy2 = (boxsize(2)-yorig) / uvec(2) !< crossing with y=boxsize(2) 5697 ELSE IF ( uvec(2) < 0._wp ) THEN 5698 dy1 = (boxsize(2)-yorig) / uvec(2) !< crossing with y=boxsize(2) 5699 dy2 = -yorig / uvec(2) !< crossing with y=0 5700 ELSE !uvec(2)==0 5701 dy1 = -huge(1._wp) 5702 dy2 = huge(1._wp) 5703 ENDIF 5704 5705 IF ( uvec(3) > 0._wp ) THEN 5706 dx1 = -xorig / uvec(3) !< crossing with x=0 5707 dx2 = (boxsize(3)-xorig) / uvec(3) !< crossing with x=boxsize(3) 5708 ELSE IF ( uvec(3) < 0._wp ) THEN 5709 dx1 = (boxsize(3)-xorig) / uvec(3) !< crossing with x=boxsize(3) 5710 dx2 = -xorig / uvec(3) !< crossing with x=0 5711 ELSE !uvec(1)==0 5712 dx1 = -huge(1._wp) 5713 dx2 = huge(1._wp) 5714 ENDIF 5715 5716 crdist = max(0._wp, (min(dz2, dy2, dx2) - max(dz1, dy1, dx1))) 5717 transp = transp + exp(-ext_coef * dens * crdist) 5718 ENDDO 5719 ENDDO 5720 transp = transp / resol**2 5721 area = (boxsize(3)+xshift)*(boxsize(2)+yshift) 5722 absorb = 1._wp - transp 5723 5724 END SUBROUTINE box_absorb 5725 5726 5727 END SUBROUTINE radiation_interaction 5728 5729 5730 !------------------------------------------------------------------------------! 5731 ! Description: 5732 ! ------------ 5733 !> Calculates shape view factors SVF and plant sink canopy factors PSCF 5734 !> !!!!!DESCRIPTION!!!!!!!!!! 5735 !------------------------------------------------------------------------------! 5736 SUBROUTINE radiation_calc_svf 5737 5738 IMPLICIT NONE 5739 5740 INTEGER(iwp) :: i, j, k, l, d, ip, jp 5741 INTEGER(iwp) :: isvf, ksvf, icsf, kcsf, npcsfl, isvf_surflt, imrtt, imrtf 5742 INTEGER(iwp) :: sd, td, ioln, iproc 5743 REAL(wp), DIMENSION(0:nsurf_type) :: facearea 5744 INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE :: nzterrl, planthl 5745 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: csflt, pcsflt 5746 INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE :: kcsflt,kpcsflt 5747 INTEGER(iwp), DIMENSION(:), ALLOCATABLE :: icsflt,dcsflt,ipcsflt,dpcsflt 5748 REAL(wp), DIMENSION(3) :: uv 5749 LOGICAL :: visible 5750 REAL(wp), DIMENSION(3) :: sa, ta !< real coordinates z,y,x of source and target 5751 REAL(wp) :: transparency, rirrf, sqdist, svfsum 5752 INTEGER(iwp) :: isurflt, isurfs, isurflt_prev 5753 INTEGER(iwp) :: itx, ity, itz 5754 CHARACTER(len=7) :: pid_char = '' 5755 INTEGER(iwp) :: win_lad, minfo 5756 REAL(wp), DIMENSION(:,:,:), POINTER :: lad_s_rma !< fortran pointer, but lower bounds are 1 5757 TYPE(c_ptr) :: lad_s_rma_p !< allocated c pointer 5758 #if defined( __parallel ) 5759 INTEGER(kind=MPI_ADDRESS_KIND) :: size_lad_rma 5760 #endif 5761 REAL(wp), DIMENSION(0:nsurf_type) :: svf_threshold !< threshold to ignore very small svf between far surfaces 5762 5763 ! 5764 !-- calculation of the SVF 5765 CALL location_message( ' calculation of SVF and CSF', .TRUE. ) 5766 CALL cpu_log( log_point_s(79), 'radiation_calc_svf', 'start' ) 5767 ! 5768 !-- precalculate face areas for different face directions using normal vector 5769 DO d = 0, nsurf_type 5770 facearea(d) = 1._wp 5771 IF ( idir(d) == 0 ) facearea(d) = facearea(d) * dx 5772 IF ( jdir(d) == 0 ) facearea(d) = facearea(d) * dy 5773 IF ( kdir(d) == 0 ) facearea(d) = facearea(d) * dz 5774 ENDDO 5775 5776 !-- calculate the svf threshold 5777 svf_threshold = 0._wp 5778 IF ( dist_max_svf > 0._wp ) THEN 5779 DO d = 0, nsurf_type 5780 sqdist = dist_max_svf * dist_max_svf 5781 svf_threshold(d) = 1._wp / (pi * sqdist) * facearea(d) 5782 ENDDO 5783 ENDIF 5784 5785 !-- initialize variables and temporary arrays for calculation of svf and csf 5786 nsvfl = 0 5787 ncsfl = 0 5788 nsvfla = gasize 5789 msvf = 1 5790 ALLOCATE( asvf1(nsvfla) ) 5791 asvf => asvf1 5792 IF ( plant_canopy ) THEN 5793 ncsfla = gasize 5794 mcsf = 1 5795 ALLOCATE( acsf1(ncsfla) ) 5796 acsf => acsf1 5797 ENDIF 5798 5799 !-- initialize temporary terrain and plant canopy height arrays (global 2D array!) 5800 ALLOCATE( nzterr(0:(nx+1)*(ny+1)-1) ) 5801 #if defined( __parallel ) 5802 ALLOCATE( nzterrl(nys:nyn,nxl:nxr) ) 5803 nzterrl = get_topography_top_index( 's' ) 5804 CALL MPI_AllGather( nzterrl, nnx*nny, MPI_INTEGER, & 5805 nzterr, nnx*nny, MPI_INTEGER, comm2d, ierr ) 5806 DEALLOCATE(nzterrl) 5807 #else 5808 nzterr = RESHAPE( get_topography_top_index( 's' ), (/(nx+1)*(ny+1)/) ) 5809 #endif 5810 IF ( plant_canopy ) THEN 5811 ALLOCATE( plantt(0:(nx+1)*(ny+1)-1) ) 5812 maxboxesg = nx + ny + nzu + 1 5813 !-- temporary arrays storing values for csf calculation during raytracing 5814 ALLOCATE( boxes(3, maxboxesg) ) 5815 ALLOCATE( crlens(maxboxesg) ) 5816 5817 #if defined( __parallel ) 5818 ALLOCATE( planthl(nys:nyn,nxl:nxr) ) 5819 planthl = pch(nys:nyn,nxl:nxr) 5820 5821 CALL MPI_AllGather( planthl, nnx*nny, MPI_INTEGER, & 5822 plantt, nnx*nny, MPI_INTEGER, comm2d, ierr ) 5823 DEALLOCATE( planthl ) 5824 5825 !-- temporary arrays storing values for csf calculation during raytracing 5826 ALLOCATE( lad_ip(maxboxesg) ) 5827 ALLOCATE( lad_disp(maxboxesg) ) 5828 5829 IF ( usm_lad_rma ) THEN 5830 ALLOCATE( lad_s_ray(maxboxesg) ) 5831 5832 ! set conditions for RMA communication 5833 CALL MPI_Info_create(minfo, ierr) 5834 CALL MPI_Info_set(minfo, 'accumulate_ordering', '', ierr) 5835 CALL MPI_Info_set(minfo, 'accumulate_ops', 'same_op', ierr) 5836 CALL MPI_Info_set(minfo, 'same_size', 'true', ierr) 5837 CALL MPI_Info_set(minfo, 'same_disp_unit', 'true', ierr) 5838 5839 !-- Allocate and initialize the MPI RMA window 5840 !-- must be in accordance with allocation of lad_s in plant_canopy_model 5841 !-- optimization of memory should be done 5842 !-- Argument X of function c_sizeof(X) needs arbitrary REAL(wp) value, set to 1.0_wp for now 5843 size_lad_rma = c_sizeof(1.0_wp)*nnx*nny*nzu 5844 CALL MPI_Win_allocate(size_lad_rma, c_sizeof(1.0_wp), minfo, comm2d, & 5845 lad_s_rma_p, win_lad, ierr) 5846 CALL c_f_pointer(lad_s_rma_p, lad_s_rma, (/ nzu, nny, nnx /)) 5847 usm_lad(nzub:, nys:, nxl:) => lad_s_rma(:,:,:) 5848 ELSE 5849 ALLOCATE(usm_lad(nzub:nzut, nys:nyn, nxl:nxr)) 5850 ENDIF 5851 #else 5852 plantt = RESHAPE( pct(nys:nyn,nxl:nxr), (/(nx+1)*(ny+1)/) ) 5853 ALLOCATE(usm_lad(nzub:nzut, nys:nyn, nxl:nxr)) 5854 #endif 5855 usm_lad(:,:,:) = 0._wp 5856 DO i = nxl, nxr 5857 DO j = nys, nyn 5858 k = get_topography_top_index( j, i, 's' ) 5859 5860 usm_lad(k:nzut, j, i) = lad_s(0:nzut-k, j, i) 5861 ENDDO 5862 ENDDO 5863 5864 #if defined( __parallel ) 5865 IF ( usm_lad_rma ) THEN 5866 CALL MPI_Info_free(minfo, ierr) 5867 CALL MPI_Win_lock_all(0, win_lad, ierr) 5868 ELSE 5869 ALLOCATE( usm_lad_g(0:(nx+1)*(ny+1)*nzu-1) ) 5870 CALL MPI_AllGather( usm_lad, nnx*nny*nzu, MPI_REAL, & 5871 usm_lad_g, nnx*nny*nzu, MPI_REAL, comm2d, ierr ) 5872 ENDIF 5873 #endif 5874 ENDIF 5875 5876 IF ( mrt_factors ) THEN 5877 OPEN(153, file='MRT_TARGETS', access='SEQUENTIAL', & 5878 action='READ', status='OLD', form='FORMATTED', err=524) 5879 OPEN(154, file='MRT_FACTORS'//myid_char, access='DIRECT', recl=(5*4+2*8), & 5880 action='WRITE', status='REPLACE', form='UNFORMATTED', err=525) 5881 imrtf = 1 5882 DO 5883 READ(153, *, end=526, err=524) imrtt, i, j, k 5884 IF ( i < nxl .OR. i > nxr & 5885 .OR. j < nys .OR. j > nyn ) CYCLE 5886 ta = (/ REAL(k), REAL(j), REAL(i) /) 5887 5888 DO isurfs = 1, nsurf 5889 IF ( .NOT. surface_facing(i, j, k, -1, & 5890 surf(ix, isurfs), surf(iy, isurfs), & 5891 surf(iz, isurfs), surf(id, isurfs)) ) THEN 5892 CYCLE 5893 ENDIF 5894 5895 sd = surf(id, isurfs) 5896 sa = (/ REAL(surf(iz, isurfs), wp) - 0.5_wp * kdir(sd), & 5897 REAL(surf(iy, isurfs), wp) - 0.5_wp * jdir(sd), & 5898 REAL(surf(ix, isurfs), wp) - 0.5_wp * idir(sd) /) 5899 5900 !-- unit vector source -> target 5901 uv = (/ (ta(1)-sa(1))*dz, (ta(2)-sa(2))*dy, (ta(3)-sa(3))*dx /) 5902 sqdist = SUM(uv(:)**2) 5903 uv = uv / SQRT(sqdist) 5904 5905 !-- irradiance factor - see svf. Here we consider that target face is always normal, 5906 !-- i.e. the second dot product equals 1 5907 rirrf = dot_product((/ kdir(sd), jdir(sd), idir(sd) /), uv) & 5908 / (pi * sqdist) * facearea(sd) 5909 5910 !-- raytrace while not creating any canopy sink factors 5911 CALL raytrace(sa, ta, isurfs, rirrf, 1._wp, .FALSE., & 5912 visible, transparency, win_lad) 5913 IF ( .NOT. visible ) CYCLE 5914 5915 !rsvf = rirrf * transparency 5916 WRITE(154, rec=imrtf, err=525) INT(imrtt, kind=4), & 5917 INT(surf(id, isurfs), kind=4), & 5918 INT(surf(iz, isurfs), kind=4), & 5919 INT(surf(iy, isurfs), kind=4), & 5920 INT(surf(ix, isurfs), kind=4), & 5921 REAL(rirrf, kind=8), REAL(transparency, kind=8) 5922 imrtf = imrtf + 1 5923 5924 ENDDO !< isurfs 5925 ENDDO !< MRT_TARGETS record 5926 5927 524 message_string = 'error reading file MRT_TARGETS' 5928 CALL message( 'radiation_calc_svf', 'PA0524', 1, 2, 0, 6, 0 ) 5929 5930 525 message_string = 'error writing file MRT_FACTORS'//myid_char 5931 CALL message( 'radiation_calc_svf', 'PA0525', 1, 2, 0, 6, 0 ) 5932 5933 526 CLOSE(153) 5934 CLOSE(154) 5935 ENDIF !< mrt_factors 5936 5937 5938 DO isurflt = 1, nsurfl 5939 !-- determine face centers 5940 td = surfl(id, isurflt) 5941 IF ( td >= isky .AND. .NOT. plant_canopy ) CYCLE 5942 ta = (/ REAL(surfl(iz, isurflt), wp) - 0.5_wp * kdir(td), & 5943 REAL(surfl(iy, isurflt), wp) - 0.5_wp * jdir(td), & 5944 REAL(surfl(ix, isurflt), wp) - 0.5_wp * idir(td) /) 5945 DO isurfs = 1, nsurf 5946 !-- cycle for atmospheric surfaces since they are not source surfaces 5947 sd = surf(id, isurfs) 5948 IF ( sd > iwest_l .AND. sd < isky ) CYCLE 5949 !-- if reflections between target surfaces (urban and land) are neglected (surf_reflection set to 5950 !-- FALSE) cycle. This will reduce the number of SVFs and keep SVFs between only ertual surfaces to 5951 !-- physical surfaces 5952 IF ( .NOT. surf_reflections .AND. sd < isky ) CYCLE 5953 !-- cycle if the target and the source surfaces are not facing each other 5954 IF ( .NOT. surface_facing(surfl(ix, isurflt), surfl(iy, isurflt), & 5955 surfl(iz, isurflt), surfl(id, isurflt), & 5956 surf(ix, isurfs), surf(iy, isurfs), & 5957 surf(iz, isurfs), surf(id, isurfs)) ) THEN 5958 CYCLE 5959 ENDIF 5960 5961 sa = (/ REAL(surf(iz, isurfs), wp) - 0.5_wp * kdir(sd), & 5962 REAL(surf(iy, isurfs), wp) - 0.5_wp * jdir(sd), & 5963 REAL(surf(ix, isurfs), wp) - 0.5_wp * idir(sd) /) 5964 5965 !-- unit vector source -> target 5966 uv = (/ (ta(1)-sa(1))*dz, (ta(2)-sa(2))*dy, (ta(3)-sa(3))*dx /) 5967 sqdist = SUM(uv(:)**2) 5968 uv = uv / SQRT(sqdist) 5969 5970 !-- irradiance factor (our unshaded shape view factor) = view factor per differential target area * source area 5971 rirrf = dot_product((/ kdir(sd), jdir(sd), idir(sd) /), uv) & ! cosine of source normal and direction 5972 * dot_product((/ kdir(td), jdir(td), idir(td) /), -uv) & ! cosine of target normal and reverse direction 5973 / (pi * sqdist) & ! square of distance between centers 5974 * facearea(sd) 5975 5976 !-- skip svf less than svf_threshold 5977 IF ( rirrf < svf_threshold(sd) .AND. sd < isky ) CYCLE 5978 5979 !-- raytrace + process plant canopy sinks within 5980 CALL raytrace(sa, ta, isurfs, rirrf, facearea(td), .TRUE., & 5981 visible, transparency, win_lad) 5982 5983 IF ( .NOT. visible ) CYCLE 5984 IF ( td >= isky ) CYCLE !< we calculated these only for raytracing 5985 !< to find plant canopy sinks, we don't need svf for them 5986 5987 !-- write to the svf array 5988 nsvfl = nsvfl + 1 5989 !-- check dimmension of asvf array and enlarge it if needed 5990 IF ( nsvfla < nsvfl ) THEN 5991 k = nsvfla * 2 5992 IF ( msvf == 0 ) THEN 5993 msvf = 1 5994 ALLOCATE( asvf1(k) ) 5995 asvf => asvf1 5996 asvf1(1:nsvfla) = asvf2 5997 DEALLOCATE( asvf2 ) 5998 ELSE 5999 msvf = 0 6000 ALLOCATE( asvf2(k) ) 6001 asvf => asvf2 6002 asvf2(1:nsvfla) = asvf1 6003 DEALLOCATE( asvf1 ) 6004 ENDIF 6005 nsvfla = k 6006 ENDIF 6007 !-- write svf values into the array 6008 asvf(nsvfl)%isurflt = isurflt 6009 asvf(nsvfl)%isurfs = isurfs 6010 asvf(nsvfl)%rsvf = rirrf !we postopne multiplication by transparency 6011 asvf(nsvfl)%rtransp = transparency !a.k.a. Direct Irradiance Factor 6012 ENDDO 6013 ENDDO 6014 6015 CALL location_message( ' waiting for completion of SVF and CSF calculation in all processes', .TRUE. ) 6016 !-- deallocate temporary global arrays 6017 DEALLOCATE(nzterr) 6018 6019 IF ( plant_canopy ) THEN 6020 !-- finalize mpi_rma communication and deallocate temporary arrays 6021 #if defined( __parallel ) 6022 IF ( usm_lad_rma ) THEN 6023 CALL MPI_Win_flush_all(win_lad, ierr) 6024 !-- unlock MPI window 6025 CALL MPI_Win_unlock_all(win_lad, ierr) 6026 !-- free MPI window 6027 CALL MPI_Win_free(win_lad, ierr) 6028 6029 !-- deallocate temporary arrays storing values for csf calculation during raytracing 6030 DEALLOCATE( lad_s_ray ) 6031 !-- usm_lad is the pointer to lad_s_rma in case of usm_lad_rma 6032 !-- and must not be deallocated here 6033 ELSE 6034 DEALLOCATE(usm_lad) 6035 DEALLOCATE(usm_lad_g) 6036 ENDIF 6037 #else 6038 DEALLOCATE(usm_lad) 6039 #endif 6040 DEALLOCATE( boxes ) 6041 DEALLOCATE( crlens ) 6042 DEALLOCATE( plantt ) 6043 ENDIF 6044 6045 CALL location_message( ' calculation of the complete SVF array', .TRUE. ) 6046 6047 !-- sort svf ( a version of quicksort ) 6048 CALL quicksort_svf(asvf,1,nsvfl) 6049 6050 ALLOCATE( svf(ndsvf,nsvfl) ) 6051 ALLOCATE( svfsurf(idsvf,nsvfl) ) 6052 6053 !< load svf from the structure array to plain arrays 6054 isurflt_prev = -1 6055 ksvf = 1 6056 svfsum = 0._wp 6057 DO isvf = 1, nsvfl 6058 !-- normalize svf per target face 6059 IF ( asvf(ksvf)%isurflt /= isurflt_prev ) THEN 6060 IF ( isurflt_prev /= -1 .AND. svfsum /= 0._wp ) THEN 6061 !-- TODO detect and log when normalization differs too much from 1 6062 svf(1, isvf_surflt:isvf-1) = svf(1, isvf_surflt:isvf-1) / svfsum 6063 ENDIF 6064 isurflt_prev = asvf(ksvf)%isurflt 6065 isvf_surflt = isvf 6066 svfsum = asvf(ksvf)%rsvf !?? / asvf(ksvf)%rtransp 6067 ELSE 6068 svfsum = svfsum + asvf(ksvf)%rsvf !?? / asvf(ksvf)%rtransp 6069 ENDIF 6070 6071 svf(:, isvf) = (/ asvf(ksvf)%rsvf, asvf(ksvf)%rtransp /) 6072 svfsurf(:, isvf) = (/ asvf(ksvf)%isurflt, asvf(ksvf)%isurfs /) 6073 6074 !-- next element 6075 ksvf = ksvf + 1 6076 ENDDO 6077 6078 IF ( isurflt_prev /= -1 .AND. svfsum /= 0._wp ) THEN 6079 !-- TODO detect and log when normalization differs too much from 1 6080 svf(1, isvf_surflt:nsvfl) = svf(1, isvf_surflt:nsvfl) / svfsum 6081 ENDIF 6082 6083 !-- deallocate temporary asvf array 6084 !-- DEALLOCATE(asvf) - ifort has a problem with deallocation of allocatable target 6085 !-- via pointing pointer - we need to test original targets 6086 IF ( ALLOCATED(asvf1) ) THEN 6087 DEALLOCATE(asvf1) 6088 ENDIF 6089 IF ( ALLOCATED(asvf2) ) THEN 6090 DEALLOCATE(asvf2) 6091 ENDIF 6092 6093 npcsfl = 0 6094 IF ( plant_canopy ) THEN 6095 6096 CALL location_message( ' calculation of the complete CSF array', .TRUE. ) 6097 6098 !-- sort and merge csf for the last time, keeping the array size to minimum 6099 CALL merge_and_grow_csf(-1) 6100 6101 !-- aggregate csb among processors 6102 !-- allocate necessary arrays 6103 ALLOCATE( csflt(ndcsf,max(ncsfl,ndcsf)) ) 6104 ALLOCATE( kcsflt(kdcsf,max(ncsfl,kdcsf)) ) 6105 ALLOCATE( icsflt(0:numprocs-1) ) 6106 ALLOCATE( dcsflt(0:numprocs-1) ) 6107 ALLOCATE( ipcsflt(0:numprocs-1) ) 6108 ALLOCATE( dpcsflt(0:numprocs-1) ) 6109 6110 !-- fill out arrays of csf values and 6111 !-- arrays of number of elements and displacements 6112 !-- for particular precessors 6113 icsflt = 0 6114 dcsflt = 0 6115 ip = -1 6116 j = -1 6117 d = 0 6118 DO kcsf = 1, ncsfl 6119 j = j+1 6120 IF ( acsf(kcsf)%ip /= ip ) THEN 6121 !-- new block of the processor 6122 !-- number of elements of previous block 6123 IF ( ip>=0) icsflt(ip) = j 6124 d = d+j 6125 !-- blank blocks 6126 DO jp = ip+1, acsf(kcsf)%ip-1 6127 !-- number of elements is zero, displacement is equal to previous 6128 icsflt(jp) = 0 6129 dcsflt(jp) = d 6130 ENDDO 6131 !-- the actual block 6132 ip = acsf(kcsf)%ip 6133 dcsflt(ip) = d 6134 j = 0 6135 ENDIF 6136 !-- fill out real values of rsvf, rtransp 6137 csflt(1,kcsf) = acsf(kcsf)%rsvf 6138 csflt(2,kcsf) = acsf(kcsf)%rtransp 6139 !-- fill out integer values of itz,ity,itx,isurfs 6140 kcsflt(1,kcsf) = acsf(kcsf)%itz 6141 kcsflt(2,kcsf) = acsf(kcsf)%ity 6142 kcsflt(3,kcsf) = acsf(kcsf)%itx 6143 kcsflt(4,kcsf) = acsf(kcsf)%isurfs 6144 ENDDO 6145 !-- last blank blocks at the end of array 6146 j = j+1 6147 IF ( ip>=0 ) icsflt(ip) = j 6148 d = d+j 6149 DO jp = ip+1, numprocs-1 6150 !-- number of elements is zero, displacement is equal to previous 6151 icsflt(jp) = 0 6152 dcsflt(jp) = d 6153 ENDDO 6154 6155 !-- deallocate temporary acsf array 6156 !-- DEALLOCATE(acsf) - ifort has a problem with deallocation of allocatable target 6157 !-- via pointing pointer - we need to test original targets 6158 IF ( ALLOCATED(acsf1) ) THEN 6159 DEALLOCATE(acsf1) 6160 ENDIF 6161 IF ( ALLOCATED(acsf2) ) THEN 6162 DEALLOCATE(acsf2) 6163 ENDIF 6164 6165 #if defined( __parallel ) 6166 !-- scatter and gather the number of elements to and from all processor 6167 !-- and calculate displacements 6168 CALL MPI_AlltoAll(icsflt,1,MPI_INTEGER,ipcsflt,1,MPI_INTEGER,comm2d, ierr) 6169 6170 npcsfl = SUM(ipcsflt) 6171 d = 0 6172 DO i = 0, numprocs-1 6173 dpcsflt(i) = d 6174 d = d + ipcsflt(i) 6175 ENDDO 6176 6177 !-- exchange csf fields between processors 6178 ALLOCATE( pcsflt(ndcsf,max(npcsfl,ndcsf)) ) 6179 ALLOCATE( kpcsflt(kdcsf,max(npcsfl,kdcsf)) ) 6180 CALL MPI_AlltoAllv(csflt, ndcsf*icsflt, ndcsf*dcsflt, MPI_REAL, & 6181 pcsflt, ndcsf*ipcsflt, ndcsf*dpcsflt, MPI_REAL, comm2d, ierr) 6182 CALL MPI_AlltoAllv(kcsflt, kdcsf*icsflt, kdcsf*dcsflt, MPI_INTEGER, & 6183 kpcsflt, kdcsf*ipcsflt, kdcsf*dpcsflt, MPI_INTEGER, comm2d, ierr) 6184 6185 #else 6186 npcsfl = ncsfl 6187 ALLOCATE( pcsflt(ndcsf,max(npcsfl,ndcsf)) ) 6188 ALLOCATE( kpcsflt(kdcsf,max(npcsfl,kdcsf)) ) 6189 pcsflt = csflt 6190 kpcsflt = kcsflt 6191 #endif 6192 6193 !-- deallocate temporary arrays 6194 DEALLOCATE( csflt ) 6195 DEALLOCATE( kcsflt ) 6196 DEALLOCATE( icsflt ) 6197 DEALLOCATE( dcsflt ) 6198 DEALLOCATE( ipcsflt ) 6199 DEALLOCATE( dpcsflt ) 6200 6201 !-- sort csf ( a version of quicksort ) 6202 CALL quicksort_csf2(kpcsflt, pcsflt, 1, npcsfl) 6203 6204 !-- aggregate canopy sink factor records with identical box & source 6205 !-- againg across all values from all processors 6206 IF ( npcsfl > 0 ) THEN 6207 icsf = 1 !< reading index 6208 kcsf = 1 !< writing index 6209 DO while (icsf < npcsfl) 6210 !-- here kpcsf(kcsf) already has values from kpcsf(icsf) 6211 IF ( kpcsflt(3,icsf) == kpcsflt(3,icsf+1) .AND. & 6212 kpcsflt(2,icsf) == kpcsflt(2,icsf+1) .AND. & 6213 kpcsflt(1,icsf) == kpcsflt(1,icsf+1) .AND. & 6214 kpcsflt(4,icsf) == kpcsflt(4,icsf+1) ) THEN 6215 !-- We could simply take either first or second rtransp, both are valid. As a very simple heuristic about which ray 6216 !-- probably passes nearer the center of the target box, we choose DIF from the entry with greater CSF, since that 6217 !-- might mean that the traced beam passes longer through the canopy box. 6218 IF ( pcsflt(1,kcsf) < pcsflt(1,icsf+1) ) THEN 6219 pcsflt(2,kcsf) = pcsflt(2,icsf+1) 6220 ENDIF 6221 pcsflt(1,kcsf) = pcsflt(1,kcsf) + pcsflt(1,icsf+1) 6222 6223 !-- advance reading index, keep writing index 6224 icsf = icsf + 1 6225 ELSE 6226 !-- not identical, just advance and copy 6227 icsf = icsf + 1 6228 kcsf = kcsf + 1 6229 kpcsflt(:,kcsf) = kpcsflt(:,icsf) 6230 pcsflt(:,kcsf) = pcsflt(:,icsf) 6231 ENDIF 6232 ENDDO 6233 !-- last written item is now also the last item in valid part of array 6234 npcsfl = kcsf 6235 ENDIF 6236 6237 ncsfl = npcsfl 6238 IF ( ncsfl > 0 ) THEN 6239 ALLOCATE( csf(ndcsf,ncsfl) ) 6240 ALLOCATE( csfsurf(idcsf,ncsfl) ) 6241 DO icsf = 1, ncsfl 6242 csf(:,icsf) = pcsflt(:,icsf) 6243 csfsurf(1,icsf) = gridpcbl(kpcsflt(1,icsf),kpcsflt(2,icsf),kpcsflt(3,icsf)) 6244 csfsurf(2,icsf) = kpcsflt(4,icsf) 6245 ENDDO 6246 ENDIF 6247 6248 !-- deallocation of temporary arrays 6249 DEALLOCATE( pcsflt ) 6250 DEALLOCATE( kpcsflt ) 6251 IF ( ALLOCATED( gridpcbl ) ) DEALLOCATE( gridpcbl ) 6252 6253 ENDIF 6254 6255 RETURN 6256 6257 301 WRITE( message_string, * ) & 6258 'I/O error when processing shape view factors / ', & 6259 'plant canopy sink factors / direct irradiance factors.' 6260 CALL message( 'init_urban_surface', 'PA0502', 2, 2, 0, 6, 0 ) 6261 6262 CALL cpu_log( log_point_s(79), 'radiation_calc_svf', 'stop' ) 6263 6264 6265 END SUBROUTINE radiation_calc_svf 6266 6267 6268 !------------------------------------------------------------------------------! 6269 ! Description: 6270 ! ------------ 6271 !> Raytracing for detecting obstacles and calculating compound canopy sink 6272 !> factors. (A simple obstacle detection would only need to process faces in 6273 !> 3 dimensions without any ordering.) 6274 !> Assumtions: 6275 !> ----------- 6276 !> 1. The ray always originates from a face midpoint (only one coordinate equals 6277 !> *.5, i.e. wall) and doesn't travel parallel to the surface (that would mean 6278 !> shape factor=0). Therefore, the ray may never travel exactly along a face 6279 !> or an edge. 6280 !> 2. From grid bottom to urban surface top the grid has to be *equidistant* 6281 !> within each of the dimensions, including vertical (but the resolution 6282 !> doesn't need to be the same in all three dimensions). 6283 !------------------------------------------------------------------------------! 6284 SUBROUTINE raytrace(src, targ, isrc, rirrf, atarg, create_csf, visible, transparency, win_lad) 6285 IMPLICIT NONE 6286 6287 REAL(wp), DIMENSION(3), INTENT(in) :: src, targ !< real coordinates z,y,x 6288 INTEGER(iwp), INTENT(in) :: isrc !< index of source face for csf 6289 REAL(wp), INTENT(in) :: rirrf !< irradiance factor for csf 6290 REAL(wp), INTENT(in) :: atarg !< target surface area for csf 6291 LOGICAL, INTENT(in) :: create_csf !< whether to generate new CSFs during raytracing 6292 LOGICAL, INTENT(out) :: visible 6293 REAL(wp), INTENT(out) :: transparency !< along whole path 6294 INTEGER(iwp), INTENT(in) :: win_lad 6295 INTEGER(iwp) :: i, j, k, d 6296 INTEGER(iwp) :: seldim !< dimension to be incremented 6297 INTEGER(iwp) :: ncsb !< no of written plant canopy sinkboxes 6298 INTEGER(iwp) :: maxboxes !< max no of gridboxes visited 6299 REAL(wp) :: distance !< euclidean along path 6300 REAL(wp) :: crlen !< length of gridbox crossing 6301 REAL(wp) :: lastdist !< beginning of current crossing 6302 REAL(wp) :: nextdist !< end of current crossing 6303 REAL(wp) :: realdist !< distance in meters per unit distance 6304 REAL(wp) :: crmid !< midpoint of crossing 6305 REAL(wp) :: cursink !< sink factor for current canopy box 6306 REAL(wp), DIMENSION(3) :: delta !< path vector 6307 REAL(wp), DIMENSION(3) :: uvect !< unit vector 6308 REAL(wp), DIMENSION(3) :: dimnextdist !< distance for each dimension increments 6309 INTEGER(iwp), DIMENSION(3) :: box !< gridbox being crossed 6310 INTEGER(iwp), DIMENSION(3) :: dimnext !< next dimension increments along path 6311 INTEGER(iwp), DIMENSION(3) :: dimdelta !< dimension direction = +- 1 6312 INTEGER(iwp) :: px, py !< number of processors in x and y dir before 6313 !< the processor in the question 6314 INTEGER(iwp) :: ip !< number of processor where gridbox reside 6315 INTEGER(iwp) :: ig !< 1D index of gridbox in global 2D array 6316 REAL(wp) :: lad_s_target !< recieved lad_s of particular grid box 6317 REAL(wp), PARAMETER :: grow_factor = 1.5_wp !< factor of expansion of grow arrays 6318 6319 ! 6320 !-- Maximum number of gridboxes visited equals to maximum number of boundaries crossed in each dimension plus one. That's also 6321 !-- the maximum number of plant canopy boxes written. We grow the acsf array accordingly using exponential factor. 6322 maxboxes = SUM(ABS(NINT(targ) - NINT(src))) + 1 6323 IF ( plant_canopy .AND. ncsfl + maxboxes > ncsfla ) THEN 6324 !-- use this code for growing by fixed exponential increments (equivalent to case where ncsfl always increases by 1) 6325 !-- k = CEILING(grow_factor ** real(CEILING(log(real(ncsfl + maxboxes, kind=wp)) & 6326 !-- / log(grow_factor)), kind=wp)) 6327 !-- or use this code to simply always keep some extra space after growing 6328 k = CEILING(REAL(ncsfl + maxboxes, kind=wp) * grow_factor) 6329 6330 CALL merge_and_grow_csf(k) 6331 ENDIF 6332 6333 transparency = 1._wp 6334 ncsb = 0 6335 6336 delta(:) = targ(:) - src(:) 6337 distance = SQRT(SUM(delta(:)**2)) 6338 IF ( distance == 0._wp ) THEN 6339 visible = .TRUE. 6340 RETURN 6341 ENDIF 6342 uvect(:) = delta(:) / distance 6343 realdist = SQRT(SUM( (uvect(:)*(/dz,dy,dx/))**2 )) 6344 6345 lastdist = 0._wp 6346 6347 !-- Since all face coordinates have values *.5 and we'd like to use 6348 !-- integers, all these have .5 added 6349 DO d = 1, 3 6350 IF ( uvect(d) == 0._wp ) THEN 6351 dimnext(d) = 999999999 6352 dimdelta(d) = 999999999 6353 dimnextdist(d) = 1.0E20_wp 6354 ELSE IF ( uvect(d) > 0._wp ) THEN 6355 dimnext(d) = CEILING(src(d) + .5_wp) 6356 dimdelta(d) = 1 6357 dimnextdist(d) = (dimnext(d) - .5_wp - src(d)) / uvect(d) 6358 ELSE 6359 dimnext(d) = FLOOR(src(d) + .5_wp) 6360 dimdelta(d) = -1 6361 dimnextdist(d) = (dimnext(d) - .5_wp - src(d)) / uvect(d) 6362 ENDIF 6363 ENDDO 6364 6365 DO 6366 !-- along what dimension will the next wall crossing be? 6367 seldim = minloc(dimnextdist, 1) 6368 nextdist = dimnextdist(seldim) 6369 IF ( nextdist > distance ) nextdist = distance 6370 6371 crlen = nextdist - lastdist 6372 IF ( crlen > .001_wp ) THEN 6373 crmid = (lastdist + nextdist) * .5_wp 6374 box = NINT(src(:) + uvect(:) * crmid) 6375 6376 !-- calculate index of the grid with global indices (box(2),box(3)) 6377 !-- in the array nzterr and plantt and id of the coresponding processor 6378 px = box(3)/nnx 6379 py = box(2)/nny 6380 ip = px*pdims(2)+py 6381 ig = ip*nnx*nny + (box(3)-px*nnx)*nny + box(2)-py*nny 6382 IF ( box(1) <= nzterr(ig) ) THEN 6383 visible = .FALSE. 6384 RETURN 6385 ENDIF 6386 6387 IF ( plant_canopy ) THEN 6388 IF ( box(1) <= plantt(ig) ) THEN 6389 ncsb = ncsb + 1 6390 boxes(:,ncsb) = box 6391 crlens(ncsb) = crlen 6392 #if defined( __parallel ) 6393 lad_ip(ncsb) = ip 6394 lad_disp(ncsb) = (box(3)-px*nnx)*(nny*nzu) + (box(2)-py*nny)*nzu + box(1)-nzub 6395 #endif 6396 ENDIF 6397 ENDIF 6398 ENDIF 6399 6400 IF ( nextdist >= distance ) EXIT 6401 lastdist = nextdist 6402 dimnext(seldim) = dimnext(seldim) + dimdelta(seldim) 6403 dimnextdist(seldim) = (dimnext(seldim) - .5_wp - src(seldim)) / uvect(seldim) 6404 ENDDO 6405 6406 IF ( plant_canopy ) THEN 6407 #if defined( __parallel ) 6408 IF ( usm_lad_rma ) THEN 6409 !-- send requests for lad_s to appropriate processor 6410 CALL cpu_log( log_point_s(77), 'usm_init_rma', 'start' ) 6411 DO i = 1, ncsb 6412 CALL MPI_Get(lad_s_ray(i), 1, MPI_REAL, lad_ip(i), lad_disp(i), & 6413 1, MPI_REAL, win_lad, ierr) 6414 IF ( ierr /= 0 ) THEN 6415 WRITE(message_string, *) 'MPI error ', ierr, ' at MPI_Get' 6416 CALL message( 'raytrace', 'PA0519', 1, 2, 0, 6, 0 ) 6417 ENDIF 6418 ENDDO 6419 6420 !-- wait for all pending local requests complete 6421 CALL MPI_Win_flush_local_all(win_lad, ierr) 6422 IF ( ierr /= 0 ) THEN 6423 WRITE(message_string, *) 'MPI error ', ierr, ' at MPI_Win_flush_local_all' 6424 CALL message( 'raytrace', 'PA0519', 1, 2, 0, 6, 0 ) 6425 ENDIF 6426 CALL cpu_log( log_point_s(77), 'usm_init_rma', 'stop' ) 6427 6428 ENDIF 6429 #endif 6430 6431 !-- calculate csf and transparency 6432 DO i = 1, ncsb 6433 #if defined( __parallel ) 6434 IF ( usm_lad_rma ) THEN 6435 lad_s_target = lad_s_ray(i) 6436 ELSE 6437 lad_s_target = usm_lad_g(lad_ip(i)*nnx*nny*nzu + lad_disp(i)) 6438 ENDIF 6439 #else 6440 lad_s_target = usm_lad(boxes(1,i),boxes(2,i),boxes(3,i)) 6441 #endif 6442 cursink = 1._wp - exp(-ext_coef * lad_s_target * crlens(i)*realdist) 6443 6444 IF ( create_csf ) THEN 6445 !-- write svf values into the array 6446 ncsfl = ncsfl + 1 6447 acsf(ncsfl)%ip = lad_ip(i) 6448 acsf(ncsfl)%itx = boxes(3,i) 6449 acsf(ncsfl)%ity = boxes(2,i) 6450 acsf(ncsfl)%itz = boxes(1,i) 6451 acsf(ncsfl)%isurfs = isrc 6452 acsf(ncsfl)%rsvf = REAL(cursink*rirrf*atarg, wp) !-- we postpone multiplication by transparency 6453 acsf(ncsfl)%rtransp = REAL(transparency, wp) 6454 ENDIF !< create_csf 6455 6456 transparency = transparency * (1._wp - cursink) 6457 6458 ENDDO 6459 ENDIF 6460 6461 visible = .TRUE. 6462 6463 END SUBROUTINE raytrace 6464 6465 6466 !------------------------------------------------------------------------------! 6467 ! Description: 6468 ! ------------ 6469 !> Determines whether two faces are oriented towards each other. Since the 6470 !> surfaces follow the gird box surfaces, it checks first whether the two surfaces 6471 !> are directed in the same direction, then it checks if the two surfaces are 6472 !> located in confronted direction but facing away from each other, e.g. <--| |--> 6473 !------------------------------------------------------------------------------! 6474 PURE LOGICAL FUNCTION surface_facing(x, y, z, d, x2, y2, z2, d2) 6475 IMPLICIT NONE 6476 INTEGER(iwp), INTENT(in) :: x, y, z, d, x2, y2, z2, d2 6477 6478 surface_facing = .FALSE. 6479 6480 !-- first check: are the two surfaces directed in the same direction 6481 IF ( (d==iup_u .OR. d==iup_l .OR. d==iup_a ) & 6482 .AND. (d2==iup_u .OR. d2==iup_l) ) RETURN 6483 IF ( (d==isky .OR. d==idown_a) .AND. d2==isky ) RETURN 6484 IF ( (d==isouth_u .OR. d==isouth_l .OR. d==isouth_a .OR. d==inorth_b ) & 6485 .AND. (d2==isouth_u .OR. d2==isouth_l .OR. d2==inorth_b) ) RETURN 6486 IF ( (d==inorth_u .OR. d==inorth_l .OR. d==inorth_a .OR. d==isouth_b ) & 6487 .AND. (d2==inorth_u .OR. d2==inorth_l .OR. d2==isouth_b) ) RETURN 6488 IF ( (d==iwest_u .OR. d==iwest_l .OR. d==iwest_a .OR. d==ieast_b ) & 6489 .AND. (d2==iwest_u .OR. d2==iwest_l .OR. d2==ieast_b ) ) RETURN 6490 IF ( (d==ieast_u .OR. d==ieast_l .OR. d==ieast_a .OR. d==iwest_b ) & 6491 .AND. (d2==ieast_u .OR. d2==ieast_l .OR. d2==iwest_b ) ) RETURN 6492 6493 !-- second check: are surfaces facing away from each other 6494 SELECT CASE (d) 6495 CASE (iup_u, iup_l, iup_a) !< upward facing surfaces 6496 IF ( z2 < z ) RETURN 6497 CASE (isky, idown_a) !< downward facing surfaces 6498 IF ( z2 > z ) RETURN 6499 CASE (isouth_u, isouth_l, isouth_a, inorth_b) !< southward facing surfaces 6500 IF ( y2 > y ) RETURN 6501 CASE (inorth_u, inorth_l, inorth_a, isouth_b) !< northward facing surfaces 6502 IF ( y2 < y ) RETURN 6503 CASE (iwest_u, iwest_l, iwest_a, ieast_b) !< westward facing surfaces 6504 IF ( x2 > x ) RETURN 6505 CASE (ieast_u, ieast_l, ieast_a, iwest_b) !< eastward facing surfaces 6506 IF ( x2 < x ) RETURN 6507 END SELECT 6508 6509 SELECT CASE (d2) 6510 CASE (iup_u) !< ground, roof 6511 IF ( z < z2 ) RETURN 6512 CASE (isky) !< sky 6513 IF ( z > z2 ) RETURN 6514 CASE (isouth_u, isouth_l, inorth_b) !< south facing 6515 IF ( y > y2 ) RETURN 6516 CASE (inorth_u, inorth_l, isouth_b) !< north facing 6517 IF ( y < y2 ) RETURN 6518 CASE (iwest_u, iwest_l, ieast_b) !< west facing 6519 IF ( x > x2 ) RETURN 6520 CASE (ieast_u, ieast_l, iwest_b) !< east facing 6521 IF ( x < x2 ) RETURN 6522 CASE (-1) 6523 CONTINUE 6524 END SELECT 6525 6526 surface_facing = .TRUE. 6527 6528 END FUNCTION surface_facing 6529 6530 !------------------------------------------------------------------------------! 6531 ! 6532 ! Description: 6533 ! ------------ 6534 !> Soubroutine reads svf and svfsurf data from saved file 6535 !------------------------------------------------------------------------------! 6536 SUBROUTINE radiation_read_svf 6537 6538 IMPLICIT NONE 6539 INTEGER(iwp) :: fsvf = 89 6540 INTEGER(iwp) :: i 6541 CHARACTER(usm_version_len) :: usm_version_field 6542 CHARACTER(svf_code_len) :: svf_code_field 6543 6544 DO i = 0, io_blocks-1 6545 IF ( i == io_group ) THEN 6546 OPEN ( fsvf, FILE='SVFIN'//TRIM(coupling_char)//'/'//myid_char,& 6547 form='unformatted', status='old' ) 6548 6549 !-- read and check version 6550 READ ( fsvf ) usm_version_field 6551 IF ( TRIM(usm_version_field) /= TRIM(usm_version) ) THEN 6552 WRITE( message_string, * ) 'Version of binary SVF file "', & 6553 TRIM(usm_version_field), '" does not match ', & 6554 'the version of model "', TRIM(usm_version), '"' 6555 CALL message( 'radiation_read_svf', 'UI0012', 1, 2, 0, 6, 0 ) 6556 ENDIF 6557 6558 !-- read nsvfl, ncsfl 6559 READ ( fsvf ) nsvfl, ncsfl 6560 IF ( nsvfl <= 0 .OR. ncsfl < 0 ) THEN 6561 WRITE( message_string, * ) 'Wrong number of SVF or CSF' 6562 CALL message( 'radiation_read_svf', 'UI0012', 1, 2, 0, 6, 0 ) 6563 ELSE 6564 WRITE(message_string,*) ' Number of SVF and CSF to read', nsvfl, ncsfl 6565 CALL location_message( message_string, .TRUE. ) 6566 ENDIF 6567 6568 ALLOCATE(svf(ndsvf,nsvfl)) 6569 ALLOCATE(svfsurf(idsvf,nsvfl)) 6570 READ(fsvf) svf 6571 READ(fsvf) svfsurf 6572 IF ( plant_canopy ) THEN 6573 ALLOCATE(csf(ndcsf,ncsfl)) 6574 ALLOCATE(csfsurf(idcsf,ncsfl)) 6575 READ(fsvf) csf 6576 READ(fsvf) csfsurf 6577 ENDIF 6578 READ ( fsvf ) svf_code_field 6579 6580 IF ( TRIM(svf_code_field) /= TRIM(svf_code) ) THEN 6581 WRITE( message_string, * ) 'Wrong structure of binary svf file' 6582 CALL message( 'radiation_read_svf', 'UI0012', 1, 2, 0, 6, 0 ) 6583 ENDIF 6584 6585 CLOSE (fsvf) 6586 6587 ENDIF 6588 #if defined( __parallel ) 6589 CALL MPI_BARRIER( comm2d, ierr ) 6590 #endif 6591 ENDDO 6592 6593 END SUBROUTINE radiation_read_svf 6594 6595 6596 !------------------------------------------------------------------------------! 6597 ! 6598 ! Description: 6599 ! ------------ 6600 !> Subroutine stores svf, svfsurf, csf and csfsurf data to a file. 6601 !------------------------------------------------------------------------------! 6602 SUBROUTINE radiation_write_svf 6603 6604 IMPLICIT NONE 6605 INTEGER(iwp) :: fsvf = 89 6606 INTEGER(iwp) :: i 6607 6608 DO i = 0, io_blocks-1 6609 IF ( i == io_group ) THEN 6610 OPEN ( fsvf, FILE='SVFOUT'//TRIM( coupling_char )//'/'//myid_char, & 6611 form='unformatted', status='new' ) 6612 6613 WRITE ( fsvf ) usm_version 6614 WRITE ( fsvf ) nsvfl, ncsfl 6615 WRITE ( fsvf ) svf 6616 WRITE ( fsvf ) svfsurf 6617 IF ( plant_canopy ) THEN 6618 WRITE ( fsvf ) csf 6619 WRITE ( fsvf ) csfsurf 6620 ENDIF 6621 WRITE ( fsvf ) TRIM(svf_code) 6622 6623 CLOSE (fsvf) 6624 #if defined( __parallel ) 6625 CALL MPI_BARRIER( comm2d, ierr ) 6626 #endif 6627 ENDIF 6628 ENDDO 6629 6630 END SUBROUTINE radiation_write_svf 6631 6632 6633 6634 !------------------------------------------------------------------------------! 6635 ! Description: 6636 ! ------------ 6637 ! 6638 !> radiation_radflux_gridbox subroutine gives the sw and lw radiation fluxes at the 6639 !> faces of a gridbox defined at i,j,k and located in the urban layer. 6640 !> The total sw and the diffuse sw radiation as well as the lw radiation fluxes at 6641 !> the gridbox 6 faces are stored in sw_gridbox, swd_gridbox, and lw_gridbox arrays, 6642 !> respectively, in the following order: 6643 !> up_face, down_face, north_face, south_face, east_face, west_face 6644 !> 6645 !> The subroutine reports also how successful was the search process via the parameter 6646 !> i_feedback as follow: 6647 !> - i_feedback = 1 : successful 6648 !> - i_feedback = -1 : unsuccessful; the requisted point is outside the urban domain 6649 !> - i_feedback = 0 : uncomplete; some gridbox faces fluxes are missing 6650 !> 6651 !> 6652 !> It is called outside from usm_urban_surface_mod whenever the radiation fluxes 6653 !> are needed. 6654 !> 6655 !> TODO: 6656 !> - Compare performance when using some combination of the Fortran intrinsic 6657 !> functions, e.g. MINLOC, MAXLOC, ALL, ANY and COUNT functions, which search 6658 !> surfl array for elements meeting user-specified criterion, i.e. i,j,k 6659 !> - Report non-found or incomplete radiation fluxes arrays , if any, at the 6660 !> gridbox faces in an error message form 6661 !> 6662 !------------------------------------------------------------------------------! 6663 SUBROUTINE radiation_radflux_gridbox(i,j,k,sw_gridbox,swd_gridbox,lw_gridbox,i_feedback) 6664 6665 IMPLICIT NONE 6666 6667 INTEGER(iwp), INTENT(in) :: i,j,k !< gridbox indices at which fluxes are required 6668 INTEGER(iwp) :: ii,jj,kk,d !< surface indices and type 6669 INTEGER(iwp) :: l !< surface id 6670 REAL(wp) , DIMENSION(1:6), INTENT(out) :: sw_gridbox,lw_gridbox !< total sw and lw radiation fluxes of 6 faces of a gridbox, w/m2 6671 REAL(wp) , DIMENSION(1:6), INTENT(out) :: swd_gridbox !< diffuse sw radiation from sky and model boundary of 6 faces of a gridbox, w/m2 6672 INTEGER(iwp), INTENT(out) :: i_feedback !< feedback to report how the search was successful 6673 6674 6675 !-- initialize variables 6676 i_feedback = -999999 6677 sw_gridbox = -999999.9_wp 6678 lw_gridbox = -999999.9_wp 6679 swd_gridbox = -999999.9_wp 6680 6681 !-- check the requisted grid indices 6682 IF ( k < nzb .OR. k > nzut .OR. & 6683 j < nysg .OR. j > nyng .OR. & 6684 i < nxlg .OR. i > nxrg & 6685 ) THEN 6686 i_feedback = -1 6687 RETURN 6688 ENDIF 6689 6690 !-- search for the required grid and formulate the fluxes at the 6 gridbox faces 6691 DO l = 1, nsurfl 6692 ii = surfl(ix,l) 6693 jj = surfl(iy,l) 6694 kk = surfl(iz,l) 6695 6696 IF ( ii == i .AND. jj == j .AND. kk == k ) THEN 6697 d = surfl(id,l) 6698 6699 SELECT CASE ( d ) 6700 6701 CASE (iup_u,iup_l,iup_a) !- gridbox up_facing face 6702 sw_gridbox(1) = surfinsw(l) 6703 lw_gridbox(1) = surfinlw(l) 6704 swd_gridbox(1) = surfinswdif(l) 6705 6706 CASE (isky,idown_a) !- gridbox down_facing face 6707 sw_gridbox(2) = surfinsw(l) 6708 lw_gridbox(2) = surfinlw(l) 6709 swd_gridbox(2) = surfinswdif(l) 6710 6711 CASE (inorth_u,inorth_l,inorth_a,isouth_b) !- gridbox north_facing face 6712 sw_gridbox(3) = surfinsw(l) 6713 lw_gridbox(3) = surfinlw(l) 6714 swd_gridbox(3) = surfinswdif(l) 6715 6716 CASE (isouth_u,isouth_l,isouth_a,inorth_b) !- gridbox south_facing face 6717 sw_gridbox(4) = surfinsw(l) 6718 lw_gridbox(4) = surfinlw(l) 6719 swd_gridbox(4) = surfinswdif(l) 6720 6721 CASE (ieast_u,ieast_l,ieast_a,iwest_b) !- gridbox east_facing face 6722 sw_gridbox(5) = surfinsw(l) 6723 lw_gridbox(5) = surfinlw(l) 6724 swd_gridbox(5) = surfinswdif(l) 6725 6726 CASE (iwest_u,iwest_l,iwest_a,ieast_b) !- gridbox west_facing face 6727 sw_gridbox(6) = surfinsw(l) 6728 lw_gridbox(6) = surfinlw(l) 6729 swd_gridbox(6) = surfinswdif(l) 6730 6731 END SELECT 6732 6733 ENDIF 6734 6735 IF ( ALL( sw_gridbox(:) /= -999999.9_wp ) ) EXIT 6736 ENDDO 6737 6738 !-- check the completeness of the fluxes at all gidbox faces 6739 !-- TODO: report non-found or incomplete rad fluxes arrays in an error message form 6740 IF ( ANY( sw_gridbox(:) <= -999999.9_wp ) .OR. & 6741 ANY( swd_gridbox(:) <= -999999.9_wp ) .OR. & 6742 ANY( lw_gridbox(:) <= -999999.9_wp ) ) THEN 6743 i_feedback = 0 6744 ELSE 6745 i_feedback = 1 6746 ENDIF 6747 6748 RETURN 6749 6750 END SUBROUTINE radiation_radflux_gridbox 6751 6752 6753 !------------------------------------------------------------------------------! 6754 ! 6755 ! Description: 6756 ! ------------ 6757 !> Block of auxiliary subroutines: 6758 !> 1. quicksort and corresponding comparison 6759 !> 2. merge_and_grow_csf for implementation of "dynamical growing" 6760 !> array for csf 6761 !------------------------------------------------------------------------------! 6762 PURE FUNCTION svf_lt(svf1,svf2) result (res) 6763 TYPE (t_svf), INTENT(in) :: svf1,svf2 6764 LOGICAL :: res 6765 IF ( svf1%isurflt < svf2%isurflt .OR. & 6766 (svf1%isurflt == svf2%isurflt .AND. svf1%isurfs < svf2%isurfs) ) THEN 6767 res = .TRUE. 6768 ELSE 6769 res = .FALSE. 6770 ENDIF 6771 END FUNCTION svf_lt 6772 6773 6774 !-- quicksort.f -*-f90-*- 6775 !-- Author: t-nissie, adaptation J.Resler 6776 !-- License: GPLv3 6777 !-- Gist: https://gist.github.com/t-nissie/479f0f16966925fa29ea 6778 RECURSIVE SUBROUTINE quicksort_svf(svfl, first, last) 6779 IMPLICIT NONE 6780 TYPE(t_svf), DIMENSION(:), INTENT(INOUT) :: svfl 6781 INTEGER(iwp), INTENT(IN) :: first, last 6782 TYPE(t_svf) :: x, t 6783 INTEGER(iwp) :: i, j 6784 6785 IF ( first>=last ) RETURN 6786 x = svfl( (first+last) / 2 ) 6787 i = first 6788 j = last 6789 DO 6790 DO while ( svf_lt(svfl(i),x) ) 6791 i=i+1 6792 ENDDO 6793 DO while ( svf_lt(x,svfl(j)) ) 6794 j=j-1 6795 ENDDO 6796 IF ( i >= j ) EXIT 6797 t = svfl(i); svfl(i) = svfl(j); svfl(j) = t 6798 i=i+1 6799 j=j-1 6800 ENDDO 6801 IF ( first < i-1 ) CALL quicksort_svf(svfl, first, i-1) 6802 IF ( j+1 < last ) CALL quicksort_svf(svfl, j+1, last) 6803 END SUBROUTINE quicksort_svf 6804 6805 6806 PURE FUNCTION csf_lt(csf1,csf2) result (res) 6807 TYPE (t_csf), INTENT(in) :: csf1,csf2 6808 LOGICAL :: res 6809 IF ( csf1%ip < csf2%ip .OR. & 6810 (csf1%ip == csf2%ip .AND. csf1%itx < csf2%itx) .OR. & 6811 (csf1%ip == csf2%ip .AND. csf1%itx == csf2%itx .AND. csf1%ity < csf2%ity) .OR. & 6812 (csf1%ip == csf2%ip .AND. csf1%itx == csf2%itx .AND. csf1%ity == csf2%ity .AND. & 6813 csf1%itz < csf2%itz) .OR. & 6814 (csf1%ip == csf2%ip .AND. csf1%itx == csf2%itx .AND. csf1%ity == csf2%ity .AND. & 6815 csf1%itz == csf2%itz .AND. csf1%isurfs < csf2%isurfs) ) THEN 6816 res = .TRUE. 6817 ELSE 6818 res = .FALSE. 6819 ENDIF 6820 END FUNCTION csf_lt 6821 6822 6823 !-- quicksort.f -*-f90-*- 6824 !-- Author: t-nissie, adaptation J.Resler 6825 !-- License: GPLv3 6826 !-- Gist: https://gist.github.com/t-nissie/479f0f16966925fa29ea 6827 RECURSIVE SUBROUTINE quicksort_csf(csfl, first, last) 6828 IMPLICIT NONE 6829 TYPE(t_csf), DIMENSION(:), INTENT(INOUT) :: csfl 6830 INTEGER(iwp), INTENT(IN) :: first, last 6831 TYPE(t_csf) :: x, t 6832 INTEGER(iwp) :: i, j 6833 6834 IF ( first>=last ) RETURN 6835 x = csfl( (first+last)/2 ) 6836 i = first 6837 j = last 6838 DO 6839 DO while ( csf_lt(csfl(i),x) ) 6840 i=i+1 6841 ENDDO 6842 DO while ( csf_lt(x,csfl(j)) ) 6843 j=j-1 6844 ENDDO 6845 IF ( i >= j ) EXIT 6846 t = csfl(i); csfl(i) = csfl(j); csfl(j) = t 6847 i=i+1 6848 j=j-1 6849 ENDDO 6850 IF ( first < i-1 ) CALL quicksort_csf(csfl, first, i-1) 6851 IF ( j+1 < last ) CALL quicksort_csf(csfl, j+1, last) 6852 END SUBROUTINE quicksort_csf 6853 6854 6855 SUBROUTINE merge_and_grow_csf(newsize) 6856 INTEGER(iwp), INTENT(in) :: newsize !< new array size after grow, must be >= ncsfl 6857 !< or -1 to shrink to minimum 6858 INTEGER(iwp) :: iread, iwrite 6859 TYPE(t_csf), DIMENSION(:), POINTER :: acsfnew 6860 6861 IF ( newsize == -1 ) THEN 6862 !-- merge in-place 6863 acsfnew => acsf 6864 ELSE 6865 !-- allocate new array 6866 IF ( mcsf == 0 ) THEN 6867 ALLOCATE( acsf1(newsize) ) 6868 acsfnew => acsf1 6869 ELSE 6870 ALLOCATE( acsf2(newsize) ) 6871 acsfnew => acsf2 6872 ENDIF 6873 ENDIF 6874 6875 IF ( ncsfl >= 1 ) THEN 6876 !-- sort csf in place (quicksort) 6877 CALL quicksort_csf(acsf,1,ncsfl) 6878 6879 !-- while moving to a new array, aggregate canopy sink factor records with identical box & source 6880 acsfnew(1) = acsf(1) 6881 iwrite = 1 6882 DO iread = 2, ncsfl 6883 !-- here acsf(kcsf) already has values from acsf(icsf) 6884 IF ( acsfnew(iwrite)%itx == acsf(iread)%itx & 6885 .AND. acsfnew(iwrite)%ity == acsf(iread)%ity & 6886 .AND. acsfnew(iwrite)%itz == acsf(iread)%itz & 6887 .AND. acsfnew(iwrite)%isurfs == acsf(iread)%isurfs ) THEN 6888 !-- We could simply take either first or second rtransp, both are valid. As a very simple heuristic about which ray 6889 !-- probably passes nearer the center of the target box, we choose DIF from the entry with greater CSF, since that 6890 !-- might mean that the traced beam passes longer through the canopy box. 6891 IF ( acsfnew(iwrite)%rsvf < acsf(iread)%rsvf ) THEN 6892 acsfnew(iwrite)%rtransp = acsf(iread)%rtransp 6893 ENDIF 6894 acsfnew(iwrite)%rsvf = acsfnew(iwrite)%rsvf + acsf(iread)%rsvf 6895 !-- advance reading index, keep writing index 6896 ELSE 6897 !-- not identical, just advance and copy 6898 iwrite = iwrite + 1 6899 acsfnew(iwrite) = acsf(iread) 6900 ENDIF 6901 ENDDO 6902 ncsfl = iwrite 6903 ENDIF 6904 6905 IF ( newsize == -1 ) THEN 6906 !-- allocate new array and copy shrinked data 6907 IF ( mcsf == 0 ) THEN 6908 ALLOCATE( acsf1(ncsfl) ) 6909 acsf1(1:ncsfl) = acsf2(1:ncsfl) 6910 ELSE 6911 ALLOCATE( acsf2(ncsfl) ) 6912 acsf2(1:ncsfl) = acsf1(1:ncsfl) 6913 ENDIF 6914 ENDIF 6915 6916 !-- deallocate old array 6917 IF ( mcsf == 0 ) THEN 6918 mcsf = 1 6919 acsf => acsf1 6920 DEALLOCATE( acsf2 ) 6921 ELSE 6922 mcsf = 0 6923 acsf => acsf2 6924 DEALLOCATE( acsf1 ) 6925 ENDIF 6926 ncsfla = newsize 6927 END SUBROUTINE merge_and_grow_csf 6928 6929 6930 !-- quicksort.f -*-f90-*- 6931 !-- Author: t-nissie, adaptation J.Resler 6932 !-- License: GPLv3 6933 !-- Gist: https://gist.github.com/t-nissie/479f0f16966925fa29ea 6934 RECURSIVE SUBROUTINE quicksort_csf2(kpcsflt, pcsflt, first, last) 6935 IMPLICIT NONE 6936 INTEGER(iwp), DIMENSION(:,:), INTENT(INOUT) :: kpcsflt 6937 REAL(wp), DIMENSION(:,:), INTENT(INOUT) :: pcsflt 6938 INTEGER(iwp), INTENT(IN) :: first, last 6939 REAL(wp), DIMENSION(ndcsf) :: t2 6940 INTEGER(iwp), DIMENSION(kdcsf) :: x, t1 6941 INTEGER(iwp) :: i, j 6942 6943 IF ( first>=last ) RETURN 6944 x = kpcsflt(:, (first+last)/2 ) 6945 i = first 6946 j = last 6947 DO 6948 DO while ( csf_lt2(kpcsflt(:,i),x) ) 6949 i=i+1 6950 ENDDO 6951 DO while ( csf_lt2(x,kpcsflt(:,j)) ) 6952 j=j-1 6953 ENDDO 6954 IF ( i >= j ) EXIT 6955 t1 = kpcsflt(:,i); kpcsflt(:,i) = kpcsflt(:,j); kpcsflt(:,j) = t1 6956 t2 = pcsflt(:,i); pcsflt(:,i) = pcsflt(:,j); pcsflt(:,j) = t2 6957 i=i+1 6958 j=j-1 6959 ENDDO 6960 IF ( first < i-1 ) CALL quicksort_csf2(kpcsflt, pcsflt, first, i-1) 6961 IF ( j+1 < last ) CALL quicksort_csf2(kpcsflt, pcsflt, j+1, last) 6962 END SUBROUTINE quicksort_csf2 6963 6964 6965 PURE FUNCTION csf_lt2(item1, item2) result(res) 6966 INTEGER(iwp), DIMENSION(kdcsf), INTENT(in) :: item1, item2 6967 LOGICAL :: res 6968 res = ( (item1(3) < item2(3)) & 6969 .OR. (item1(3) == item2(3) .AND. item1(2) < item2(2)) & 6970 .OR. (item1(3) == item2(3) .AND. item1(2) == item2(2) .AND. item1(1) < item2(1)) & 6971 .OR. (item1(3) == item2(3) .AND. item1(2) == item2(2) .AND. item1(1) == item2(1) & 6972 .AND. item1(4) < item2(4)) ) 6973 END FUNCTION csf_lt2 6974 2480 6975 !------------------------------------------------------------------------------! 2481 6976 ! … … 2501 6996 INTEGER(iwp) :: j !< 2502 6997 INTEGER(iwp) :: k !< 6998 INTEGER(iwp) :: m !< index of current surface element 2503 6999 2504 7000 IF ( mode == 'allocate' ) THEN … … 2570 7066 2571 7067 CASE ( 'rad_net*' ) 2572 DO i = nxlg, nxrg 2573 DO j = nysg, nyng 2574 rad_net_av(j,i) = rad_net_av(j,i) + rad_net(j,i) 7068 DO i = nxl, nxr 7069 DO j = nys, nyn 7070 DO m = surf_def_h(0)%start_index(j,i), & 7071 surf_def_h(0)%end_index(j,i) 7072 rad_net_av(j,i) = rad_net_av(j,i) + surf_def_h(0)%rad_net(m) 7073 ENDDO 7074 DO m = surf_lsm_h%start_index(j,i), surf_lsm_h%end_index(j,i) 7075 rad_net_av(j,i) = rad_net_av(j,i) + surf_lsm_h%rad_net(m) 7076 ENDDO 7077 DO m = surf_usm_h%start_index(j,i), surf_usm_h%end_index(j,i) 7078 rad_net_av(j,i) = rad_net_av(j,i) + surf_usm_h%rad_net(m) 7079 ENDDO 2575 7080 ENDDO 2576 7081 ENDDO … … 2835 7340 INTEGER(iwp) :: j !< 2836 7341 INTEGER(iwp) :: k !< 7342 INTEGER(iwp) :: m !< index of surface element at grid point (j,i) 2837 7343 2838 7344 LOGICAL :: found !< … … 2849 7355 DO i = nxl, nxr 2850 7356 DO j = nys, nyn 2851 local_pf(i,j,nzb+1) = rad_net(j,i) 7357 ! 7358 !-- Obtain rad_net from its respective surface type 7359 !-- Default-type surfaces 7360 DO m = surf_def_h(0)%start_index(j,i), & 7361 surf_def_h(0)%end_index(j,i) 7362 local_pf(i,j,nzb+1) = surf_def_h(0)%rad_net(m) 7363 ENDDO 7364 ! 7365 !-- Natural-type surfaces 7366 DO m = surf_lsm_h%start_index(j,i), & 7367 surf_lsm_h%end_index(j,i) 7368 local_pf(i,j,nzb+1) = surf_lsm_h%rad_net(m) 7369 ENDDO 7370 ! 7371 !-- Urban-type surfaces 7372 DO m = surf_usm_h%start_index(j,i), & 7373 surf_usm_h%end_index(j,i) 7374 local_pf(i,j,nzb+1) = surf_usm_h%rad_net(m) 7375 ENDDO 2852 7376 ENDDO 2853 7377 ENDDO … … 3454 7978 3455 7979 IF ( write_binary ) THEN 3456 IF ( ALLOCATED( rad_net ) ) THEN3457 WRITE ( 14 ) 'rad_net '; WRITE ( 14 ) rad_net3458 ENDIF3459 7980 IF ( ALLOCATED( rad_net_av ) ) THEN 3460 7981 WRITE ( 14 ) 'rad_net_av '; WRITE ( 14 ) rad_net_av … … 3472 7993 WRITE ( 14 ) 'rad_lw_out_av '; WRITE ( 14 ) rad_lw_out_av 3473 7994 ENDIF 3474 IF ( ALLOCATED( rad_lw_out_change_0 ) ) THEN3475 WRITE ( 14 ) 'rad_lw_out_change_0 '3476 WRITE ( 14 ) rad_lw_out_change_03477 ENDIF3478 7995 IF ( ALLOCATED( rad_lw_cs_hr ) ) THEN 3479 7996 WRITE ( 14 ) 'rad_lw_cs_hr '; WRITE ( 14 ) rad_lw_cs_hr … … 3594 8111 SELECT CASE ( TRIM( field_char ) ) 3595 8112 3596 CASE ( 'rad_net' )3597 IF ( .NOT. ALLOCATED( rad_net ) ) THEN3598 ALLOCATE( rad_net(nysg:nyng,nxlg:nxrg) )3599 ENDIF3600 IF ( k == 1 ) READ ( 13 ) tmp_2d3601 rad_net(nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = &3602 tmp_2d(nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)3603 3604 8113 CASE ( 'rad_net_av' ) 3605 8114 IF ( .NOT. ALLOCATED( rad_net_av ) ) THEN … … 3697 8206 ENDIF 3698 8207 3699 CASE ( 'rad_lw_out_change_0' )3700 IF ( .NOT. ALLOCATED( rad_lw_out_change_0 ) ) THEN3701 ALLOCATE( rad_lw_out_change_0(nysg:nyng,nxlg:nxrg) )3702 ENDIF3703 IF ( k == 1 ) READ ( 13 ) tmp_2d3704 rad_lw_out_change_0(nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp)&3705 = tmp_2d(nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)3706 3707 8208 CASE ( 'rad_lw_cs_hr' ) 3708 8209 IF ( .NOT. ALLOCATED( rad_lw_cs_hr ) ) THEN
Note: See TracChangeset
for help on using the changeset viewer.
