diff --git a/main/CoLM.F90 b/main/CoLM.F90 index fe9831fb..dd8608d2 100644 --- a/main/CoLM.F90 +++ b/main/CoLM.F90 @@ -504,7 +504,7 @@ PROGRAM CoLM time_used = (end_time - start_time) / c_per_sec IF (time_used >= 3600) THEN write(*,101) time_used/3600, mod(time_used,3600)/60, mod(time_used,60) - elseif (time_used >= 60) THEN + ELSEIF (time_used >= 60) THEN write(*,102) time_used/60, mod(time_used,60) ELSE write(*,103) time_used diff --git a/main/LULCC/MOD_Lulcc_Driver.F90 b/main/LULCC/MOD_Lulcc_Driver.F90 index 81136202..d4b86df8 100644 --- a/main/LULCC/MOD_Lulcc_Driver.F90 +++ b/main/LULCC/MOD_Lulcc_Driver.F90 @@ -20,8 +20,8 @@ MODULE MOD_Lulcc_Driver - SUBROUTINE LulccDriver (casename,dir_landdata,dir_restart,& - idate,greenwich) + SUBROUTINE LulccDriver (casename,dir_landdata,dir_restart,& + idate,greenwich) ! ====================================================================== ! !PURPOSE: @@ -54,61 +54,61 @@ SUBROUTINE LulccDriver (casename,dir_landdata,dir_restart,& logical, intent(in) :: greenwich !true: greenwich time, false: local time integer, intent(inout) :: idate(3) !year, julian day, seconds of the starting time - ! allocate Lulcc memory - CALL allocate_LulccTimeInvariants - CALL allocate_LulccTimeVariables + ! allocate Lulcc memory + CALL allocate_LulccTimeInvariants + CALL allocate_LulccTimeVariables - ! SAVE variables - CALL SAVE_LulccTimeInvariants - CALL SAVE_LulccTimeVariables + ! SAVE variables + CALL SAVE_LulccTimeInvariants + CALL SAVE_LulccTimeVariables - ! ============================================================= - ! cold start for Lulcc - ! ============================================================= + ! ============================================================= + ! cold start for Lulcc + ! ============================================================= - IF (p_is_master) THEN - print *, ">>> LULCC: initializing..." - ENDIF + IF (p_is_master) THEN + print *, ">>> LULCC: initializing..." + ENDIF - CALL LulccInitialize (casename,dir_landdata,dir_restart,& - idate,greenwich) + CALL LulccInitialize (casename,dir_landdata,dir_restart,& + idate,greenwich) - ! ============================================================= - ! simple method for variable recovery - ! ============================================================= + ! ============================================================= + ! simple method for variable recovery + ! ============================================================= - IF (DEF_LULCC_SCHEME == 1) THEN - IF (p_is_master) THEN - print *, ">>> LULCC: simple method for variable recovery..." + IF (DEF_LULCC_SCHEME == 1) THEN + IF (p_is_master) THEN + print *, ">>> LULCC: simple method for variable recovery..." + ENDIF + CALL REST_LulccTimeVariables ENDIF - CALL REST_LulccTimeVariables - ENDIF - ! ============================================================= - ! conserved method for variable revocery - ! ============================================================= + ! ============================================================= + ! conserved method for variable revocery + ! ============================================================= - IF (DEF_LULCC_SCHEME == 2) THEN - IF (p_is_master) THEN - print *, ">>> LULCC: Mass&Energy conserve for variable recovery..." + IF (DEF_LULCC_SCHEME == 2) THEN + IF (p_is_master) THEN + print *, ">>> LULCC: Mass&Energy conserve for variable recovery..." + ENDIF + CALL allocate_LulccTransferTrace() + CALL REST_LulccTimeVariables + CALL MAKE_LulccTransferTrace(idate(1)) + CALL LulccMassEnergyConserve() ENDIF - CALL allocate_LulccTransferTrace() - CALL REST_LulccTimeVariables - CALL MAKE_LulccTransferTrace(idate(1)) - CALL LulccMassEnergyConserve() - ENDIF - ! deallocate Lulcc memory - CALL deallocate_LulccTimeInvariants() - CALL deallocate_LulccTimeVariables() - IF (DEF_LULCC_SCHEME == 2) THEN - CALL deallocate_LulccTransferTrace() - ENDIF + ! deallocate Lulcc memory + CALL deallocate_LulccTimeInvariants() + CALL deallocate_LulccTimeVariables() + IF (DEF_LULCC_SCHEME == 2) THEN + CALL deallocate_LulccTransferTrace() + ENDIF - END SUBROUTINE LulccDriver + END SUBROUTINE LulccDriver END MODULE MOD_Lulcc_Driver #endif diff --git a/main/LULCC/MOD_Lulcc_Initialize.F90 b/main/LULCC/MOD_Lulcc_Initialize.F90 index 4bbcb978..8f7f31e6 100644 --- a/main/LULCC/MOD_Lulcc_Initialize.F90 +++ b/main/LULCC/MOD_Lulcc_Initialize.F90 @@ -11,11 +11,11 @@ MODULE MOD_Lulcc_Initialize PUBLIC :: LulccInitialize !----------------------------------------------------------------------- - CONTAINS +CONTAINS !----------------------------------------------------------------------- - SUBROUTINE LulccInitialize (casename,dir_landdata,dir_restart,& - idate,greenwich) + SUBROUTINE LulccInitialize (casename,dir_landdata,dir_restart,& + idate,greenwich) ! ====================================================================== ! @@ -65,89 +65,89 @@ SUBROUTINE LulccInitialize (casename,dir_landdata,dir_restart,& integer :: year, jday ! ---------------------------------------------------------------------- - ! initial time of model run - ! ............................ - CALL adj2begin(idate) + ! initial time of model run + ! ............................ + CALL adj2begin(idate) - year = idate(1) - jday = idate(2) + year = idate(1) + jday = idate(2) - CALL Init_GlobalVars - CAll Init_LC_Const - CAll Init_PFT_Const + CALL Init_GlobalVars + CAll Init_LC_Const + CAll Init_PFT_Const - ! deallocate pixelset and mesh data of previous year - CALL mesh_free_mem - CALL landelm%forc_free_mem - CALL landpatch%forc_free_mem + ! deallocate pixelset and mesh data of previous year + CALL mesh_free_mem + CALL landelm%forc_free_mem + CALL landpatch%forc_free_mem #if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) - CALL landpft%forc_free_mem + CALL landpft%forc_free_mem #endif #ifdef URBAN_MODEL - CALL landurban%forc_free_mem + CALL landurban%forc_free_mem #endif - ! load pixelset and mesh data of next year - ! CALL pixel%load_from_file (dir_landdata) - ! CALL gblock%load_from_file (dir_landdata) - CALL mesh_load_from_file (dir_landdata, year) - CALL pixelset_load_from_file (dir_landdata, 'landelm' , landelm , numelm , year) + ! load pixelset and mesh data of next year + ! CALL pixel%load_from_file (dir_landdata) + ! CALL gblock%load_from_file (dir_landdata) + CALL mesh_load_from_file (dir_landdata, year) + CALL pixelset_load_from_file (dir_landdata, 'landelm' , landelm , numelm , year) - ! load CATCHMENT of next year + ! load CATCHMENT of next year #ifdef CATCHMENT - CALL pixelset_load_from_file (dir_landdata, 'landhru' , landhru , numhru , year) + CALL pixelset_load_from_file (dir_landdata, 'landhru' , landhru , numhru , year) #endif - ! load landpatch data of next year - CALL pixelset_load_from_file (dir_landdata, 'landpatch', landpatch, numpatch, year) + ! load landpatch data of next year + CALL pixelset_load_from_file (dir_landdata, 'landpatch', landpatch, numpatch, year) - ! load pft data of PFT/PC of next year + ! load pft data of PFT/PC of next year #if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) - CALL pixelset_load_from_file (dir_landdata, 'landpft' , landpft , numpft , year) - CALL map_patch_to_pft + CALL pixelset_load_from_file (dir_landdata, 'landpft' , landpft , numpft , year) + CALL map_patch_to_pft #endif - ! load urban data of next year + ! load urban data of next year #ifdef URBAN_MODEL - CALL pixelset_load_from_file (dir_landdata, 'landurban', landurban, numurban, year) - CALL map_patch_to_urban + CALL pixelset_load_from_file (dir_landdata, 'landurban', landurban, numurban, year) + CALL map_patch_to_urban #endif - ! initialize for data associated with land element + ! initialize for data associated with land element #if (defined UNSTRUCTURED || defined CATCHMENT) - CALL elm_vector_init () + CALL elm_vector_init () #ifdef CATCHMENT - CALL hru_vector_init () + CALL hru_vector_init () #endif #endif - ! build element subfraction of next year which it's needed in the MOD_Lulcc_TransferTrace - IF (p_is_worker) THEN - CALL elm_patch%build (landelm, landpatch, use_frac = .true.) - ENDIF + ! build element subfraction of next year which it's needed in the MOD_Lulcc_TransferTrace + IF (p_is_worker) THEN + CALL elm_patch%build (landelm, landpatch, use_frac = .true.) + ENDIF - ! initialize for SrfdataDiag, it is needed in the MOD_Lulcc_TransferTrace for outputing transfer_matrix + ! initialize for SrfdataDiag, it is needed in the MOD_Lulcc_TransferTrace for outputing transfer_matrix #ifdef SrfdataDiag #ifdef GRIDBASED - CALL init_gridbased_mesh_grid () - CALL gdiag%define_by_copy (gridmesh) + CALL init_gridbased_mesh_grid () + CALL gdiag%define_by_copy (gridmesh) #else - CALL gdiag%define_by_ndims(3600,1800) + CALL gdiag%define_by_ndims(3600,1800) #endif - CALL srfdata_diag_init (dir_landdata) + CALL srfdata_diag_init (dir_landdata) #endif - ! -------------------------------------------------------------------- - ! Deallocates memory for CoLM 1d [numpatch] variables - ! -------------------------------------------------------------------- - CALL deallocate_TimeInvariants - CALL deallocate_TimeVariables + ! -------------------------------------------------------------------- + ! Deallocates memory for CoLM 1d [numpatch] variables + ! -------------------------------------------------------------------- + CALL deallocate_TimeInvariants + CALL deallocate_TimeVariables - ! initialize all state variables of next year - CALL initialize (casename,dir_landdata,dir_restart,& - idate,year,greenwich,lulcc_call=.true.) + ! initialize all state variables of next year + CALL initialize (casename,dir_landdata,dir_restart,& + idate,year,greenwich,lulcc_call=.true.) - END SUBROUTINE LulccInitialize + END SUBROUTINE LulccInitialize END MODULE MOD_Lulcc_Initialize #endif diff --git a/main/LULCC/MOD_Lulcc_MassEnergyConserve.F90 b/main/LULCC/MOD_Lulcc_MassEnergyConserve.F90 index 92e76d05..e0cf7be5 100644 --- a/main/LULCC/MOD_Lulcc_MassEnergyConserve.F90 +++ b/main/LULCC/MOD_Lulcc_MassEnergyConserve.F90 @@ -19,7 +19,7 @@ MODULE MOD_Lulcc_MassEnergyConserve !----------------------------------------------------------------------- - SUBROUTINE LulccMassEnergyConserve + SUBROUTINE LulccMassEnergyConserve ! ====================================================================== ! ! Created by Wanyi Lin and Hua Yuan, 07/2023 @@ -106,828 +106,828 @@ SUBROUTINE LulccMassEnergyConserve ! real(r8) :: deltim = 1800. !time step (senconds) TODO: be intent in logical :: FROM_SOIL - IF (p_is_worker) THEN - - ! allocate with numelm - allocate(grid_patch_s (numelm )) - allocate(grid_patch_e (numelm )) - allocate(grid_patch_s_(numelm_)) - allocate(grid_patch_e_(numelm_)) - - grid_patch_e (:) = -1 - grid_patch_s (:) = -1 - grid_patch_e_(:) = -1 - grid_patch_s_(:) = -1 - - ! loop for numelm of next year, patches at the beginning and end of - ! the element were recorded landpatch%eindex is arranged in order, - ! and the not land element is skipped so, if element is missing, the - ! recorder is -1. - DO i=1, numelm - ! how many patches in ith element in this worker - numpxl = count(landpatch%eindex==landelm%eindex(i)) - - IF (allocated(locpxl)) deallocate(locpxl) - allocate(locpxl(numpxl)) - - ! get all patches' index that eindex is equal the i element - locpxl = pack([(ipxl, ipxl=1, numpatch)], landpatch%eindex==landelm%eindex(i)) - ! the min index is the start of patch's index - grid_patch_s(i) = minval(locpxl) - ! the max index is the end of patch's index - grid_patch_e(i) = maxval(locpxl) - ENDDO + IF (p_is_worker) THEN + + ! allocate with numelm + allocate(grid_patch_s (numelm )) + allocate(grid_patch_e (numelm )) + allocate(grid_patch_s_(numelm_)) + allocate(grid_patch_e_(numelm_)) + + grid_patch_e (:) = -1 + grid_patch_s (:) = -1 + grid_patch_e_(:) = -1 + grid_patch_s_(:) = -1 + + ! loop for numelm of next year, patches at the beginning and end of + ! the element were recorded landpatch%eindex is arranged in order, + ! and the not land element is skipped so, if element is missing, the + ! recorder is -1. + DO i=1, numelm + ! how many patches in ith element in this worker + numpxl = count(landpatch%eindex==landelm%eindex(i)) + + IF (allocated(locpxl)) deallocate(locpxl) + allocate(locpxl(numpxl)) + + ! get all patches' index that eindex is equal the i element + locpxl = pack([(ipxl, ipxl=1, numpatch)], landpatch%eindex==landelm%eindex(i)) + ! the min index is the start of patch's index + grid_patch_s(i) = minval(locpxl) + ! the max index is the end of patch's index + grid_patch_e(i) = maxval(locpxl) + ENDDO - ! same as above, loop for numelm of previous year - ! patches at the beginning and end of the element were recorded - DO i=1, numelm_ - numpxl = count(landpatch_%eindex==landelm_%eindex(i)) + ! same as above, loop for numelm of previous year + ! patches at the beginning and end of the element were recorded + DO i=1, numelm_ + numpxl = count(landpatch_%eindex==landelm_%eindex(i)) - IF (allocated(locpxl)) deallocate(locpxl) - allocate(locpxl(numpxl)) + IF (allocated(locpxl)) deallocate(locpxl) + allocate(locpxl(numpxl)) - locpxl = pack([(ipxl, ipxl=1, numpatch_)], landpatch_%eindex==landelm_%eindex(i)) + locpxl = pack([(ipxl, ipxl=1, numpatch_)], landpatch_%eindex==landelm_%eindex(i)) - grid_patch_s_(i) = minval(locpxl) - grid_patch_e_(i) = maxval(locpxl) - ENDDO + grid_patch_s_(i) = minval(locpxl) + grid_patch_e_(i) = maxval(locpxl) + ENDDO - DO i=1, numelm - DO j=1,numelm_ - IF (landelm%eindex(i) == landelm_%eindex(j)) THEN - np = grid_patch_s (i) - np_= grid_patch_s_(j) + DO i=1, numelm + DO j=1,numelm_ + IF (landelm%eindex(i) == landelm_%eindex(j)) THEN + np = grid_patch_s (i) + np_= grid_patch_s_(j) - IF (np.le.0) CYCLE + IF (np.le.0) CYCLE - DO WHILE (np.le.grid_patch_e(i)) + DO WHILE (np.le.grid_patch_e(i)) IF (patchtype(np) .ne. 3) THEN !not a glacier patch IF (DEF_USE_PFT .or. DEF_FAST_PC) THEN - lccpct_np(:) = 0 - lccpct_np(1) = sum(lccpct_patches(np,1:), mask=patchtypes(:)==0) - lccpct_np(URBAN ) = lccpct_patches(np,URBAN ) - lccpct_np(WETLAND) = lccpct_patches(np,WETLAND) - lccpct_np(WATERBODY) = lccpct_patches(np,WATERBODY) + lccpct_np(:) = 0 + lccpct_np(1) = sum(lccpct_patches(np,1:), mask=patchtypes(:)==0) + lccpct_np(URBAN ) = lccpct_patches(np,URBAN ) + lccpct_np(WETLAND) = lccpct_patches(np,WETLAND) + lccpct_np(WATERBODY) = lccpct_patches(np,WATERBODY) ELSE - lccpct_np(:) = lccpct_patches(np,1:nlc) + lccpct_np(:) = lccpct_patches(np,1:nlc) ENDIF - num = count(lccpct_np .gt. 0) - sum_lccpct_np = sum(lccpct_np) - allocate ( frnp_ ( num)) - allocate ( cvsoil_(maxsnl+1:nl_soil,num)) + num = count(lccpct_np .gt. 0) + sum_lccpct_np = sum(lccpct_np) + allocate ( frnp_ ( num)) + allocate ( cvsoil_(maxsnl+1:nl_soil,num)) - ! Source patch type which differs from np's type exists - IF ( (sum_lccpct_np - lccpct_np(patchclass(np))) .gt. 0 ) THEN + ! Source patch type which differs from np's type exists + IF ( (sum_lccpct_np - lccpct_np(patchclass(np))) .gt. 0 ) THEN - ! Get the index of source patches, and stored as frnp_ - k = 0 - DO ilc = 1, nlc + ! Get the index of source patches, and stored as frnp_ + k = 0 + DO ilc = 1, nlc - IF (lccpct_np(ilc) .gt. 0) THEN - k = k + 1 - inp_ = np_ + IF (lccpct_np(ilc) .gt. 0) THEN + k = k + 1 + inp_ = np_ - DO WHILE (inp_ .le. grid_patch_e_(j)) + DO WHILE (inp_ .le. grid_patch_e_(j)) - ! Get the index of source patch that has the same LC, and stored as selfnp_ - IF (patchclass_(inp_) .eq. patchclass(np)) THEN - selfnp_ = inp_ - ENDIF - - IF (patchclass_(inp_) .eq. ilc) THEN - frnp_(k) = inp_ - EXIT - ENDIF - inp_ = inp_ + 1 - ENDDO - - ELSE - CYCLE - ENDIF - ENDDO - - ! Initialize - wliq_soisno (:,np) = 0 !liquid water in layers [kg/m2] - wice_soisno (:,np) = 0 !ice lens in layers [kg/m2] - t_soisno (:,np) = 0 !soil + snow layer temperature [K] - z_sno (:,np) = 0 !node depth [m] - dz_sno (:,np) = 0 !interface depth [m] - t_grnd (np) = 0 !ground surface temperature [K] - tleaf (np) = 0 !leaf temperature [K] - ldew (np) = 0 !depth of water on foliage [mm] - ldew_rain (np) = 0 !depth of rain on foliage [mm] - ldew_snow (np) = 0 !depth of snow on foliage [mm] - sag (np) = 0 !non dimensional snow age [-] - scv (np) = 0 !snow cover, water equivalent [mm] - snowdp (np) = 0 !snow depth [meter] - fsno (np) = 0 !fraction of snow cover on ground - sigf (np) = 0 !fraction of veg cover, excluding snow-covered veg [-] - zwt (np) = 0 !the depth to water table [m] - wa (np) = 0 !water storage in aquifer [mm] - wdsrf (np) = 0 !depth of surface water [mm] - smp (:,np) = 0 !soil matrix potential [mm] - hk (:,np) = 0 !hydraulic conductivity [mm h2o/s] - - IF(DEF_USE_PLANTHYDRAULICS)THEN - vegwp (:,np) = 0 !vegetation water potential [mm] - gs0sun (np) = 0 !working copy of sunlit stomata conductance - gs0sha (np) = 0 !working copy of shalit stomata conductance - ENDIF + ! Get the index of source patch that has the same LC, and stored as selfnp_ + IF (patchclass_(inp_) .eq. patchclass(np)) THEN + selfnp_ = inp_ + ENDIF - IF(DEF_USE_OZONESTRESS)THEN - lai_old (np) = 0 !lai in last time step - ENDIF + IF (patchclass_(inp_) .eq. ilc) THEN + frnp_(k) = inp_ + EXIT + ENDIF + inp_ = inp_ + 1 + ENDDO - snw_rds (:,np) = 0 !effective grain radius (col,lyr) [microns, m-6] - mss_bcpho (:,np) = 0 !mass of hydrophobic BC in snow (col,lyr) [kg] - mss_bcphi (:,np) = 0 !mass of hydrophillic BC in snow (col,lyr) [kg] - mss_ocpho (:,np) = 0 !mass of hydrophobic OC in snow (col,lyr) [kg] - mss_ocphi (:,np) = 0 !mass of hydrophillic OC in snow (col,lyr) [kg] - mss_dst1 (:,np) = 0 !mass of dust species 1 in snow (col,lyr) [kg] - mss_dst2 (:,np) = 0 !mass of dust species 2 in snow (col,lyr) [kg] - mss_dst3 (:,np) = 0 !mass of dust species 3 in snow (col,lyr) [kg] - mss_dst4 (:,np) = 0 !mass of dust species 4 in snow (col,lyr) [kg] - ssno_lyr(:,:,:,np) = 0 !snow layer absorption [-] - - trad (np) = 0 !radiative temperature of surface [K] - tref (np) = 0 !2 m height air temperature [kelvin] - qref (np) = 0 !2 m height air specific humidity - rst (np) = 0 !canopy stomatal resistance (s/m) - emis (np) = 0 !averaged bulk surface emissivity - z0m (np) = 0 !effective roughness [m] - zol (np) = 0 !dimensionless height (z/L) used in Monin-Obukhov theory - rib (np) = 0 !bulk Richardson number in surface layer - ustar (np) = 0 !u* in similarity theory [m/s] - qstar (np) = 0 !q* in similarity theory [kg/kg] - tstar (np) = 0 !t* in similarity theory [K] - fm (np) = 0 !integral of profile function for momentum - fh (np) = 0 !integral of profile function for heat - fq (np) = 0 !integral of profile function for moisture - - - ! ============================================================= - ! 1) Mass and Energy conserve adjustment (except for dz_sno). - ! ============================================================= - - ! Calculate the weight of temperature adjustment - c_water = cpliq * denh2o ! J/(m3 K) = 4188 [J/(kg K)]*1000(kg/m3) - c_ice = cpice * denice ! J/(m3 K) = 2117.27[J/(kg K)]*917 (kg/m3) - cvsoil_(:,:) = 0 - wgt(maxsnl+1:nl_soil) = 0 - - DO k = 1, num - - ! Soil ground and wetland heat capacity - DO l = 1, nl_soil - vf_water = wliq_soisno_(l,frnp_(k))/(dz_soi(l)*denh2o) - vf_ice = wice_soisno_(l,frnp_(k))/(dz_soi(l)*denice) - hcap = csol_(l,frnp_(k)) + vf_water*c_water + vf_ice*c_ice - cvsoil_(l,k) = hcap*dz_soi(l) + ELSE + CYCLE + ENDIF ENDDO - ! no snow layer exist - IF( dz_sno_(0,frnp_(k))<1.e-6 .and. scv_(frnp_(k))>0.) THEN - cvsoil_(1,k) = cvsoil_(1,k) + cpice*scv_(frnp_(k)) - ENDIF + ! Initialize + wliq_soisno (:,np) = 0 !liquid water in layers [kg/m2] + wice_soisno (:,np) = 0 !ice lens in layers [kg/m2] + t_soisno (:,np) = 0 !soil + snow layer temperature [K] + z_sno (:,np) = 0 !node depth [m] + dz_sno (:,np) = 0 !interface depth [m] + t_grnd (np) = 0 !ground surface temperature [K] + tleaf (np) = 0 !leaf temperature [K] + ldew (np) = 0 !depth of water on foliage [mm] + ldew_rain (np) = 0 !depth of rain on foliage [mm] + ldew_snow (np) = 0 !depth of snow on foliage [mm] + sag (np) = 0 !non dimensional snow age [-] + scv (np) = 0 !snow cover, water equivalent [mm] + snowdp (np) = 0 !snow depth [meter] + fsno (np) = 0 !fraction of snow cover on ground + sigf (np) = 0 !fraction of veg cover, excluding snow-covered veg [-] + zwt (np) = 0 !the depth to water table [m] + wa (np) = 0 !water storage in aquifer [mm] + wdsrf (np) = 0 !depth of surface water [mm] + smp (:,np) = 0 !soil matrix potential [mm] + hk (:,np) = 0 !hydraulic conductivity [mm h2o/s] - ! Snow heat capacity - IF( z_sno_(0,frnp_(k)) < 0 ) THEN - cvsoil_(:0,k) = cpliq*wliq_soisno_(:0,frnp_(k)) + cpice*wice_soisno_(:0,frnp_(k)) + IF(DEF_USE_PLANTHYDRAULICS)THEN + vegwp (:,np) = 0 !vegetation water potential [mm] + gs0sun (np) = 0 !working copy of sunlit stomata conductance + gs0sha (np) = 0 !working copy of shalit stomata conductance ENDIF - wgt(maxsnl+1:nl_soil) = wgt(maxsnl+1:nl_soil) & - + cvsoil_(maxsnl+1:nl_soil,k) * lccpct_np(patchclass_(frnp_(k))) - ENDDO - - ! Get the maximum lccpct for snow layers assignment - inp_ = frnp_(1) - k = 2 - DO WHILE (k .le. num) - IF ( lccpct_np(patchclass_(frnp_(k))) .gt. lccpct_np(patchclass_(inp_)) ) THEN - inp_ = frnp_(k) - ENDIF - k = k + 1 - ENDDO - - ! check if snow layer exist in patch inp_ - nsl = count(z_sno_(:,inp_) .lt. 0) - nsl_max = count(wgt(:0) .gt. 0) - denh2o_np(maxsnl+1:0) = 0 - denice_np(maxsnl+1:0) = 0 - - IF (nsl > 0) THEN - ! move wgt above nsl to nsl - IF ( nsl_max > nsl) THEN - DO l = nsl+1, nsl_max - wgt(-nsl+1) = wgt(-nsl+1) + wgt(-l+1) - ENDDO + IF(DEF_USE_OZONESTRESS)THEN + lai_old (np) = 0 !lai in last time step ENDIF + snw_rds (:,np) = 0 !effective grain radius (col,lyr) [microns, m-6] + mss_bcpho (:,np) = 0 !mass of hydrophobic BC in snow (col,lyr) [kg] + mss_bcphi (:,np) = 0 !mass of hydrophillic BC in snow (col,lyr) [kg] + mss_ocpho (:,np) = 0 !mass of hydrophobic OC in snow (col,lyr) [kg] + mss_ocphi (:,np) = 0 !mass of hydrophillic OC in snow (col,lyr) [kg] + mss_dst1 (:,np) = 0 !mass of dust species 1 in snow (col,lyr) [kg] + mss_dst2 (:,np) = 0 !mass of dust species 2 in snow (col,lyr) [kg] + mss_dst3 (:,np) = 0 !mass of dust species 3 in snow (col,lyr) [kg] + mss_dst4 (:,np) = 0 !mass of dust species 4 in snow (col,lyr) [kg] + ssno_lyr(:,:,:,np) = 0 !snow layer absorption [-] + + trad (np) = 0 !radiative temperature of surface [K] + tref (np) = 0 !2 m height air temperature [kelvin] + qref (np) = 0 !2 m height air specific humidity + rst (np) = 0 !canopy stomatal resistance (s/m) + emis (np) = 0 !averaged bulk surface emissivity + z0m (np) = 0 !effective roughness [m] + zol (np) = 0 !dimensionless height (z/L) used in Monin-Obukhov theory + rib (np) = 0 !bulk Richardson number in surface layer + ustar (np) = 0 !u* in similarity theory [m/s] + qstar (np) = 0 !q* in similarity theory [kg/kg] + tstar (np) = 0 !t* in similarity theory [K] + fm (np) = 0 !integral of profile function for momentum + fh (np) = 0 !integral of profile function for heat + fq (np) = 0 !integral of profile function for moisture + + + ! ============================================================= + ! 1) Mass and Energy conserve adjustment (except for dz_sno). + ! ============================================================= + + ! Calculate the weight of temperature adjustment + c_water = cpliq * denh2o ! J/(m3 K) = 4188 [J/(kg K)]*1000(kg/m3) + c_ice = cpice * denice ! J/(m3 K) = 2117.27[J/(kg K)]*917 (kg/m3) + cvsoil_(:,:) = 0 + wgt(maxsnl+1:nl_soil) = 0 + DO k = 1, num - t_soisno (-nsl+1:0,np) = t_soisno (-nsl+1:0,np) & - + t_soisno_(-nsl+1:0,frnp_(k))*cvsoil_(-nsl+1:0,k)*lccpct_np(patchclass_(frnp_(k)))/wgt(-nsl+1:0) - wliq_soisno (-nsl+1:0,np) = wliq_soisno (-nsl+1:0,np) & - + wliq_soisno_(-nsl+1:0,frnp_(k))*lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np - wice_soisno (-nsl+1:0,np) = wice_soisno (-nsl+1:0,np) & - + wice_soisno_(-nsl+1:0,frnp_(k))*lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np - - l = 1 - DO WHILE ( (l .le. nsl) .and. (dz_sno_(-l+1,frnp_(k)) .gt. 0) ) - denh2o_np (-l+1) = denh2o_np(-l+1) & - + wliq_soisno_(-l+1,frnp_(k))/dz_sno_(-l+1,frnp_(k))*lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np - denice_np (-l+1) = denice_np(-l+1) & - + wice_soisno_(-l+1,frnp_(k))/dz_sno_(-l+1,frnp_(k))*lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np - l = l + 1 - IF (l .gt. -maxsnl) EXIT + ! Soil ground and wetland heat capacity + DO l = 1, nl_soil + vf_water = wliq_soisno_(l,frnp_(k))/(dz_soi(l)*denh2o) + vf_ice = wice_soisno_(l,frnp_(k))/(dz_soi(l)*denice) + hcap = csol_(l,frnp_(k)) + vf_water*c_water + vf_ice*c_ice + cvsoil_(l,k) = hcap*dz_soi(l) ENDDO - ! if source patch has more snow layer than the main patch - IF (nsl .lt. -maxsnl) THEN - l = nsl+1 - DO WHILE ( (l .le. -maxsnl) .and. (dz_sno_(-l+1,frnp_(k)) .gt. 0) ) + ! no snow layer exist + IF( dz_sno_(0,frnp_(k))<1.e-6 .and. scv_(frnp_(k))>0.) THEN + cvsoil_(1,k) = cvsoil_(1,k) + cpice*scv_(frnp_(k)) + ENDIF - wliq_soisno(-nsl+1,np) = wliq_soisno (-nsl+1,np) & - + wliq_soisno_(-l+1,frnp_(k))*lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np - wice_soisno(-nsl+1,np) = wice_soisno (-nsl+1,np) & - + wice_soisno_(-l+1,frnp_(k))*lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np + ! Snow heat capacity + IF( z_sno_(0,frnp_(k)) < 0 ) THEN + cvsoil_(:0,k) = cpliq*wliq_soisno_(:0,frnp_(k)) + cpice*wice_soisno_(:0,frnp_(k)) + ENDIF - t_soisno (-nsl+1,np) = t_soisno (-nsl+1,np) & - + t_soisno_(-l+1,frnp_(k))*cvsoil_(-l+1,k)*lccpct_np(patchclass_(frnp_(k)))/wgt(-nsl+1) + wgt(maxsnl+1:nl_soil) = wgt(maxsnl+1:nl_soil) & + + cvsoil_(maxsnl+1:nl_soil,k) * lccpct_np(patchclass_(frnp_(k))) + ENDDO - denh2o_np (-nsl+1) = denh2o_np(-nsl+1) & - + wliq_soisno_(-l+1,frnp_(k))/dz_sno_(-l+1,frnp_(k))*lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np - denice_np (-nsl+1) = denice_np(-nsl+1) & - + wice_soisno_(-l+1,frnp_(k))/dz_sno_(-l+1,frnp_(k))*lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np - l = l + 1 - IF (l .gt. -maxsnl) EXIT - ENDDO + ! Get the maximum lccpct for snow layers assignment + inp_ = frnp_(1) + k = 2 + DO WHILE (k .le. num) + IF ( lccpct_np(patchclass_(frnp_(k))) .gt. lccpct_np(patchclass_(inp_)) ) THEN + inp_ = frnp_(k) ENDIF + k = k + 1 ENDDO - ! snow layer node and depth calculation according to new mass and density - zi_sno(0) = 0._r8 - DO l = 0, -nsl+1, -1 - - IF (denice_np(l)>0 .and. denh2o_np(l)>0) THEN - dz_sno (l,np) = wice_soisno(l,np)/denice_np(l) + wliq_soisno(l,np)/denh2o_np(l) - - ELSEIF (denice_np(l)==0 .and. denh2o_np(l)>0) THEN - dz_sno (l,np) = wliq_soisno(l,np)/denh2o_np(l) - ! print*, 'denice=0! np=',np,'igbp=',patchclass(np),'nsl=',nsl,'frnp_=',frnp_ - ! DO k = 1,num - ! print*,'frnp_=',frnp_(k),'wice=',wice_soisno(:0,frnp_(k)) - ! ENDDO - - ELSEIF (denh2o_np(l)==0 .and. denice_np(l)>0) THEN - dz_sno (l,np) = wice_soisno(l,np)/denice_np(l) - ! print*, 'denh2o=0! np=',np,'igbp=',patchclass(np),'nsl=',nsl,'frnp_=',frnp_ - ! DO k = 1,num - ! print*,'frnp_=',frnp_(k),'wliq=',wliq_soisno(:0,frnp_(k)) - ! ENDDO - - ELSE - print*, 'denh2o and denice == 0! np=',np,'igbp=',patchclass(np),'nsl=',nsl,'frnp_=',frnp_ - DO k = 1,num - print*,'frnp_=',frnp_(k),'wliq=',wliq_soisno(:0,frnp_(k)) - print*,'frnp_=',frnp_(k),'wice=',wice_soisno(:0,frnp_(k)) + ! check if snow layer exist in patch inp_ + nsl = count(z_sno_(:,inp_) .lt. 0) + nsl_max = count(wgt(:0) .gt. 0) + denh2o_np(maxsnl+1:0) = 0 + denice_np(maxsnl+1:0) = 0 + + IF (nsl > 0) THEN + ! move wgt above nsl to nsl + IF ( nsl_max > nsl) THEN + DO l = nsl+1, nsl_max + wgt(-nsl+1) = wgt(-nsl+1) + wgt(-l+1) ENDDO - CALL CoLM_stop() ENDIF - z_sno (l,np) = zi_sno(l) - 0.5_r8*dz_sno(l,np) - IF (l-1 .lt. maxsnl+1) EXIT - zi_sno (l-1) = zi_sno(l) - dz_sno(l,np) - - ENDDO + DO k = 1, num - ELSE - ! no snow layer exist in the main patch, add a layer - ! move wgt above soil to layer 0 - IF ( nsl_max > nsl) THEN - DO l = nsl+1, nsl_max - wgt(0) = wgt(0) + wgt(-l+1) - ENDDO - ENDIF + t_soisno (-nsl+1:0,np) = t_soisno (-nsl+1:0,np) & + + t_soisno_(-nsl+1:0,frnp_(k))*cvsoil_(-nsl+1:0,k)*lccpct_np(patchclass_(frnp_(k)))/wgt(-nsl+1:0) + wliq_soisno (-nsl+1:0,np) = wliq_soisno (-nsl+1:0,np) & + + wliq_soisno_(-nsl+1:0,frnp_(k))*lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np + wice_soisno (-nsl+1:0,np) = wice_soisno (-nsl+1:0,np) & + + wice_soisno_(-nsl+1:0,frnp_(k))*lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np - l = 0 - DO WHILE (wgt(l) .gt. 0) - DO k = 1, num + l = 1 + DO WHILE ( (l .le. nsl) .and. (dz_sno_(-l+1,frnp_(k)) .gt. 0) ) + denh2o_np (-l+1) = denh2o_np(-l+1) & + + wliq_soisno_(-l+1,frnp_(k))/dz_sno_(-l+1,frnp_(k))*lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np + denice_np (-l+1) = denice_np(-l+1) & + + wice_soisno_(-l+1,frnp_(k))/dz_sno_(-l+1,frnp_(k))*lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np + l = l + 1 + IF (l .gt. -maxsnl) EXIT + ENDDO - wliq_soisno(0,np) = wliq_soisno(0,np) & - + wliq_soisno_(l,frnp_(k))*lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np - wice_soisno(0,np) = wice_soisno(0,np) & - + wice_soisno_(l,frnp_(k))*lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np - t_soisno (0,np) = t_soisno (0,np) & - + t_soisno_(l,frnp_(k))*cvsoil_(l,k)*lccpct_np(patchclass_(frnp_(k)))/wgt(0) - - IF (dz_sno_(l,frnp_(k)) .gt. 0) THEN - denh2o_np(0) = denh2o_np(0) & - + wliq_soisno_(l,frnp_(k))/dz_sno_(l,frnp_(k))*lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np - denice_np(0) = denice_np(0) & - + wice_soisno_(l,frnp_(k))/dz_sno_(l,frnp_(k))*lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np + ! if source patch has more snow layer than the main patch + IF (nsl .lt. -maxsnl) THEN + l = nsl+1 + DO WHILE ( (l .le. -maxsnl) .and. (dz_sno_(-l+1,frnp_(k)) .gt. 0) ) + + wliq_soisno(-nsl+1,np) = wliq_soisno (-nsl+1,np) & + + wliq_soisno_(-l+1,frnp_(k))*lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np + wice_soisno(-nsl+1,np) = wice_soisno (-nsl+1,np) & + + wice_soisno_(-l+1,frnp_(k))*lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np + + t_soisno (-nsl+1,np) = t_soisno (-nsl+1,np) & + + t_soisno_(-l+1,frnp_(k))*cvsoil_(-l+1,k)*lccpct_np(patchclass_(frnp_(k)))/wgt(-nsl+1) + + denh2o_np (-nsl+1) = denh2o_np(-nsl+1) & + + wliq_soisno_(-l+1,frnp_(k))/dz_sno_(-l+1,frnp_(k))*lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np + denice_np (-nsl+1) = denice_np(-nsl+1) & + + wice_soisno_(-l+1,frnp_(k))/dz_sno_(-l+1,frnp_(k))*lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np + l = l + 1 + IF (l .gt. -maxsnl) EXIT + ENDDO ENDIF ENDDO - l = l-1 - IF (l .lt. maxsnl+1) EXIT - ENDDO + ! snow layer node and depth calculation according to new mass and density + zi_sno(0) = 0._r8 + DO l = 0, -nsl+1, -1 + + IF (denice_np(l)>0 .and. denh2o_np(l)>0) THEN + dz_sno (l,np) = wice_soisno(l,np)/denice_np(l) + wliq_soisno(l,np)/denh2o_np(l) + + ELSEIF (denice_np(l)==0 .and. denh2o_np(l)>0) THEN + dz_sno (l,np) = wliq_soisno(l,np)/denh2o_np(l) + ! print*, 'denice=0! np=',np,'igbp=',patchclass(np),'nsl=',nsl,'frnp_=',frnp_ + ! DO k = 1,num + ! print*,'frnp_=',frnp_(k),'wice=',wice_soisno(:0,frnp_(k)) + ! ENDDO + + ELSEIF (denh2o_np(l)==0 .and. denice_np(l)>0) THEN + dz_sno (l,np) = wice_soisno(l,np)/denice_np(l) + ! print*, 'denh2o=0! np=',np,'igbp=',patchclass(np),'nsl=',nsl,'frnp_=',frnp_ + ! DO k = 1,num + ! print*,'frnp_=',frnp_(k),'wliq=',wliq_soisno(:0,frnp_(k)) + ! ENDDO + + ELSE + print*, 'denh2o and denice == 0! np=',np,'igbp=',patchclass(np),'nsl=',nsl,'frnp_=',frnp_ + DO k = 1,num + print*,'frnp_=',frnp_(k),'wliq=',wliq_soisno(:0,frnp_(k)) + print*,'frnp_=',frnp_(k),'wice=',wice_soisno(:0,frnp_(k)) + ENDDO + CALL CoLM_stop() + ENDIF - IF (wgt(0) .gt. 0) THEN + z_sno (l,np) = zi_sno(l) - 0.5_r8*dz_sno(l,np) + IF (l-1 .lt. maxsnl+1) EXIT + zi_sno (l-1) = zi_sno(l) - dz_sno(l,np) - ! snow layer node and depth calculation according to new mass and density - IF (denh2o_np(0)>0 .and. denh2o_np(0)>0) THEN - dz_sno (0,np) = wice_soisno(0,np)/denice_np(0) + wliq_soisno(0,np)/denh2o_np(0) - ELSEIF (denice_np(0)==0 .and. denh2o_np(0)>0) THEN - dz_sno (0,np) = wliq_soisno(0,np)/denh2o_np(0) - ! print*, 'denice=0! stop! np=',np,'igbp=',patchclass(np),'nsl=',nsl,'frnp_=',frnp_ - ! DO k = 1,num - ! print*,'frnp_=',frnp_(k),'wice=',wice_soisno(:0,frnp_(k)) - ! ENDDO - ELSEIF (denice_np(0)>0 .and. denh2o_np(0)==0) THEN - dz_sno (0,np) = wice_soisno(0,np)/denice_np(0) - ! print*, 'denh2o=0! stop! np=',np,'igbp=',patchclass(np),'nsl=',nsl,'frnp_=',frnp_ - ! DO k = 1,num - ! print*,'frnp_=',frnp_(k),'wliq=',wliq_soisno(:0,frnp_(k)) - ! ENDDO - ELSE - print*, 'denh2o and denice == 0! np=',np,'igbp=',patchclass(np),'nsl=',nsl,'frnp_=',frnp_ - DO k = 1,num - print*,'frnp_=',frnp_(k),'wliq=',wliq_soisno(:0,frnp_(k)) - print*,'frnp_=',frnp_(k),'wice=',wice_soisno(:0,frnp_(k)) + ENDDO + + ELSE + ! no snow layer exist in the main patch, add a layer + ! move wgt above soil to layer 0 + IF ( nsl_max > nsl) THEN + DO l = nsl+1, nsl_max + wgt(0) = wgt(0) + wgt(-l+1) ENDDO - CALL CoLM_stop() ENDIF - zi_sno (0) = 0._r8 - z_sno (0,np) = zi_sno(0) - 0.5_r8*dz_sno(0,np) - ENDIF + l = 0 + DO WHILE (wgt(l) .gt. 0) + DO k = 1, num + + wliq_soisno(0,np) = wliq_soisno(0,np) & + + wliq_soisno_(l,frnp_(k))*lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np + wice_soisno(0,np) = wice_soisno(0,np) & + + wice_soisno_(l,frnp_(k))*lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np + t_soisno (0,np) = t_soisno (0,np) & + + t_soisno_(l,frnp_(k))*cvsoil_(l,k)*lccpct_np(patchclass_(frnp_(k)))/wgt(0) + + IF (dz_sno_(l,frnp_(k)) .gt. 0) THEN + denh2o_np(0) = denh2o_np(0) & + + wliq_soisno_(l,frnp_(k))/dz_sno_(l,frnp_(k))*lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np + denice_np(0) = denice_np(0) & + + wice_soisno_(l,frnp_(k))/dz_sno_(l,frnp_(k))*lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np + ENDIF + ENDDO - ENDIF + l = l-1 + IF (l .lt. maxsnl+1) EXIT + ENDDO + IF (wgt(0) .gt. 0) THEN + + ! snow layer node and depth calculation according to new mass and density + IF (denh2o_np(0)>0 .and. denh2o_np(0)>0) THEN + dz_sno (0,np) = wice_soisno(0,np)/denice_np(0) + wliq_soisno(0,np)/denh2o_np(0) + ELSEIF (denice_np(0)==0 .and. denh2o_np(0)>0) THEN + dz_sno (0,np) = wliq_soisno(0,np)/denh2o_np(0) + ! print*, 'denice=0! stop! np=',np,'igbp=',patchclass(np),'nsl=',nsl,'frnp_=',frnp_ + ! DO k = 1,num + ! print*,'frnp_=',frnp_(k),'wice=',wice_soisno(:0,frnp_(k)) + ! ENDDO + ELSEIF (denice_np(0)>0 .and. denh2o_np(0)==0) THEN + dz_sno (0,np) = wice_soisno(0,np)/denice_np(0) + ! print*, 'denh2o=0! stop! np=',np,'igbp=',patchclass(np),'nsl=',nsl,'frnp_=',frnp_ + ! DO k = 1,num + ! print*,'frnp_=',frnp_(k),'wliq=',wliq_soisno(:0,frnp_(k)) + ! ENDDO + ELSE + print*, 'denh2o and denice == 0! np=',np,'igbp=',patchclass(np),'nsl=',nsl,'frnp_=',frnp_ + DO k = 1,num + print*,'frnp_=',frnp_(k),'wliq=',wliq_soisno(:0,frnp_(k)) + print*,'frnp_=',frnp_(k),'wice=',wice_soisno(:0,frnp_(k)) + ENDDO + CALL CoLM_stop() + ENDIF - ! Variable adjustment - DO k = 1, num - - wliq_soisno (1:nl_soil,np) = wliq_soisno (1:nl_soil,np) & - + wliq_soisno_(1:nl_soil,frnp_(k))*lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np - wice_soisno (1:nl_soil,np) = wice_soisno (1:nl_soil,np) & - + wice_soisno_(1:nl_soil,frnp_(k))*lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np - t_soisno (1:nl_soil,np) = t_soisno (1:nl_soil,np) & - + t_soisno_(1:nl_soil,frnp_(k))*cvsoil_(1:nl_soil,k)*lccpct_np(patchclass_(frnp_(k)))/wgt(1:nl_soil) - - tleaf (np) = tleaf (np) + tleaf_ (frnp_(k))*lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np - ldew (np) = ldew (np) + ldew_ (frnp_(k))*lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np - ldew_rain (np) = ldew_rain (np) + ldew_rain_ (frnp_(k))*lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np - ldew_snow (np) = ldew_snow (np) + ldew_snow_ (frnp_(k))*lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np - sag (np) = sag (np) + sag_ (frnp_(k))*lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np - - ! TODO: use MOD_SnowFraction.F90 to calculate sigf later - DONE - ! sigf (np) = sigf (np) + sigf_ (frnp_(k))*lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np - wa (np) = wa (np) + wa_ (frnp_(k))*lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np - wdsrf (np) = wdsrf (np) + wdsrf_ (frnp_(k))*lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np - - snw_rds (:,np) = snw_rds (:,np) + snw_rds_ (:,frnp_(k))*lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np - mss_bcpho (:,np) = mss_bcpho (:,np) + mss_bcpho_ (:,frnp_(k))*lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np - mss_bcphi (:,np) = mss_bcphi (:,np) + mss_bcphi_ (:,frnp_(k))*lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np - mss_ocpho (:,np) = mss_ocpho (:,np) + mss_ocpho_ (:,frnp_(k))*lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np - mss_ocphi (:,np) = mss_ocphi (:,np) + mss_ocphi_ (:,frnp_(k))*lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np - mss_dst1 (:,np) = mss_dst1 (:,np) + mss_dst1_ (:,frnp_(k))*lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np - mss_dst2 (:,np) = mss_dst2 (:,np) + mss_dst2_ (:,frnp_(k))*lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np - mss_dst3 (:,np) = mss_dst3 (:,np) + mss_dst3_ (:,frnp_(k))*lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np - mss_dst4 (:,np) = mss_dst4 (:,np) + mss_dst4_ (:,frnp_(k))*lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np - ssno_lyr (:,:,:,np) = ssno_lyr (:,:,:,np) + ssno_lyr_ (:,:,:,frnp_(k))*lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np - - ! TODO:or use same type assignment - smp (:,np) = smp (:,np) + smp_ (:,frnp_(k))*lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np - hk (:,np) = hk (:,np) + hk_ (:,frnp_(k))*lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np + zi_sno (0) = 0._r8 + z_sno (0,np) = zi_sno(0) - 0.5_r8*dz_sno(0,np) + ENDIF - IF(DEF_USE_PLANTHYDRAULICS)THEN - vegwp (:,np) = vegwp (:,np) + vegwp_ (:,frnp_(k))*lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np - gs0sun (np) = gs0sun (np) + gs0sun_ (frnp_(k))*lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np - gs0sha (np) = gs0sha (np) + gs0sha_ (frnp_(k))*lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np ENDIF - !TODO@Wanyi: check the related namelist, DEF_USE_OZONESTRESS or some other? - ! - checked. Line 1109 of MOD_Vars_TimeVariables.F90 - IF(DEF_USE_OZONESTRESS)THEN - lai_old (np) = lai_old (np) + lai_old_ (frnp_(k))*lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np - ENDIF - trad (np) = trad (np) + trad_ (frnp_(k))*lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np - tref (np) = tref (np) + tref_ (frnp_(k))*lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np - qref (np) = qref (np) + qref_ (frnp_(k))*lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np - rst (np) = rst (np) + rst_ (frnp_(k))*lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np - emis (np) = emis (np) + emis_ (frnp_(k))*lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np - z0m (np) = z0m (np) + z0m_ (frnp_(k))*lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np - zol (np) = zol (np) + zol_ (frnp_(k))*lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np - rib (np) = rib (np) + rib_ (frnp_(k))*lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np - ustar (np) = ustar (np) + ustar_ (frnp_(k))*lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np - qstar (np) = qstar (np) + qstar_ (frnp_(k))*lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np - tstar (np) = tstar (np) + tstar_ (frnp_(k))*lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np - fm (np) = fm (np) + fm_ (frnp_(k))*lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np - fh (np) = fh (np) + fh_ (frnp_(k))*lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np - fq (np) = fq (np) + fq_ (frnp_(k))*lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np - ENDDO - - ! water balance check - wbef = 0 - wpre = 0 - DO k = 1, num - wbef = wbef + ldew_(frnp_(k))*lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np - wbef = wbef + scv_ (frnp_(k))*lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np - wbef = wbef + wa_ (frnp_(k))*lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np - wbef = wbef + sum(wliq_soisno_(maxsnl+1:nl_soil,frnp_(k)))*lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np - wbef = wbef + sum(wice_soisno_(maxsnl+1:nl_soil,frnp_(k)))*lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np - ENDDO - - wpre = ldew(np) + scv(np) + wa(np) + sum(wliq_soisno(maxsnl+1:nl_soil,np)) + sum(wice_soisno(maxsnl+1:nl_soil,np)) - IF (wpre-wbef > 1.e-6) THEN - print*,'np=',np,'total err=',wpre-wbef - ENDIF + ! Variable adjustment + DO k = 1, num - wbef = 0 - wpre = 0 - DO k = 1, num - wbef = wbef + sum(wliq_soisno_(maxsnl+1:nl_soil,frnp_(k)))*lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np - wbef = wbef + sum(wice_soisno_(maxsnl+1:nl_soil,frnp_(k)))*lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np - ENDDO + wliq_soisno (1:nl_soil,np) = wliq_soisno (1:nl_soil,np) & + + wliq_soisno_(1:nl_soil,frnp_(k))*lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np + wice_soisno (1:nl_soil,np) = wice_soisno (1:nl_soil,np) & + + wice_soisno_(1:nl_soil,frnp_(k))*lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np + t_soisno (1:nl_soil,np) = t_soisno (1:nl_soil,np) & + + t_soisno_(1:nl_soil,frnp_(k))*cvsoil_(1:nl_soil,k)*lccpct_np(patchclass_(frnp_(k)))/wgt(1:nl_soil) + + tleaf (np) = tleaf (np) + tleaf_ (frnp_(k))*lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np + ldew (np) = ldew (np) + ldew_ (frnp_(k))*lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np + ldew_rain (np) = ldew_rain (np) + ldew_rain_ (frnp_(k))*lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np + ldew_snow (np) = ldew_snow (np) + ldew_snow_ (frnp_(k))*lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np + sag (np) = sag (np) + sag_ (frnp_(k))*lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np + + ! TODO: use MOD_SnowFraction.F90 to calculate sigf later - DONE + ! sigf (np) = sigf (np) + sigf_ (frnp_(k))*lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np + wa (np) = wa (np) + wa_ (frnp_(k))*lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np + wdsrf (np) = wdsrf (np) + wdsrf_ (frnp_(k))*lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np + + snw_rds (:,np) = snw_rds (:,np) + snw_rds_ (:,frnp_(k))*lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np + mss_bcpho (:,np) = mss_bcpho (:,np) + mss_bcpho_ (:,frnp_(k))*lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np + mss_bcphi (:,np) = mss_bcphi (:,np) + mss_bcphi_ (:,frnp_(k))*lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np + mss_ocpho (:,np) = mss_ocpho (:,np) + mss_ocpho_ (:,frnp_(k))*lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np + mss_ocphi (:,np) = mss_ocphi (:,np) + mss_ocphi_ (:,frnp_(k))*lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np + mss_dst1 (:,np) = mss_dst1 (:,np) + mss_dst1_ (:,frnp_(k))*lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np + mss_dst2 (:,np) = mss_dst2 (:,np) + mss_dst2_ (:,frnp_(k))*lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np + mss_dst3 (:,np) = mss_dst3 (:,np) + mss_dst3_ (:,frnp_(k))*lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np + mss_dst4 (:,np) = mss_dst4 (:,np) + mss_dst4_ (:,frnp_(k))*lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np + ssno_lyr (:,:,:,np) = ssno_lyr (:,:,:,np) + ssno_lyr_ (:,:,:,frnp_(k))*lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np + + ! TODO:or use same type assignment + smp (:,np) = smp (:,np) + smp_ (:,frnp_(k))*lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np + hk (:,np) = hk (:,np) + hk_ (:,frnp_(k))*lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np + + IF(DEF_USE_PLANTHYDRAULICS)THEN + vegwp (:,np) = vegwp (:,np) + vegwp_ (:,frnp_(k))*lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np + gs0sun (np) = gs0sun (np) + gs0sun_ (frnp_(k))*lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np + gs0sha (np) = gs0sha (np) + gs0sha_ (frnp_(k))*lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np + ENDIF - wpre = sum(wliq_soisno(maxsnl+1:nl_soil,np)) + sum(wice_soisno(maxsnl+1:nl_soil,np)) - IF (wpre-wbef > 1.e-6) THEN - print*,'np=',np,'wice+wliq err=',wpre-wbef - ENDIF + !TODO@Wanyi: check the related namelist, DEF_USE_OZONESTRESS or some other? + ! - checked. Line 1109 of MOD_Vars_TimeVariables.F90 + IF(DEF_USE_OZONESTRESS)THEN + lai_old (np) = lai_old (np) + lai_old_ (frnp_(k))*lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np + ENDIF + trad (np) = trad (np) + trad_ (frnp_(k))*lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np + tref (np) = tref (np) + tref_ (frnp_(k))*lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np + qref (np) = qref (np) + qref_ (frnp_(k))*lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np + rst (np) = rst (np) + rst_ (frnp_(k))*lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np + emis (np) = emis (np) + emis_ (frnp_(k))*lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np + z0m (np) = z0m (np) + z0m_ (frnp_(k))*lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np + zol (np) = zol (np) + zol_ (frnp_(k))*lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np + rib (np) = rib (np) + rib_ (frnp_(k))*lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np + ustar (np) = ustar (np) + ustar_ (frnp_(k))*lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np + qstar (np) = qstar (np) + qstar_ (frnp_(k))*lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np + tstar (np) = tstar (np) + tstar_ (frnp_(k))*lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np + fm (np) = fm (np) + fm_ (frnp_(k))*lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np + fh (np) = fh (np) + fh_ (frnp_(k))*lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np + fq (np) = fq (np) + fq_ (frnp_(k))*lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np + ENDDO - ! ============================================================= - ! 2) adjusted based on code of physical process. - ! ============================================================= + ! water balance check + wbef = 0 + wpre = 0 + DO k = 1, num + wbef = wbef + ldew_(frnp_(k))*lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np + wbef = wbef + scv_ (frnp_(k))*lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np + wbef = wbef + wa_ (frnp_(k))*lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np + wbef = wbef + sum(wliq_soisno_(maxsnl+1:nl_soil,frnp_(k)))*lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np + wbef = wbef + sum(wice_soisno_(maxsnl+1:nl_soil,frnp_(k)))*lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np + ENDDO - DO l = maxsnl+1, 0 - IF ( z_sno(l,np) .lt. 0 ) THEN - scv(np) = scv(np) + wice_soisno(l,np) + wliq_soisno(l,np) - snowdp(np) = snowdp(np) + dz_sno(l,np) + wpre = ldew(np) + scv(np) + wa(np) + sum(wliq_soisno(maxsnl+1:nl_soil,np)) + sum(wice_soisno(maxsnl+1:nl_soil,np)) + IF (wpre-wbef > 1.e-6) THEN + print*,'np=',np,'total err=',wpre-wbef ENDIF - ENDDO - ! ! Use restart value from the same type of source patch or remain initialized - ! IF (lccpct_np(patchclass(np)) .gt. 0) THEN - ! tleaf (np) = tleaf_ (selfnp_) - ! lake_icefrac(:,np) = lake_icefrac_(:,selfnp_) - ! t_lake (:,np) = t_lake_ (:,selfnp_) - ! ENDIF + wbef = 0 + wpre = 0 + DO k = 1, num + wbef = wbef + sum(wliq_soisno_(maxsnl+1:nl_soil,frnp_(k)))*lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np + wbef = wbef + sum(wice_soisno_(maxsnl+1:nl_soil,frnp_(k)))*lccpct_np(patchclass_(frnp_(k)))/sum_lccpct_np + ENDDO - ! Fraction of soil covered by snow - zlnd = 0.01 !Roughness length for soil [m] - ! fsno(np) = 0.0 - ! IF (snowdp(np) > 0.) THEN - ! fmelt = (scv(np)/snowdp(np)/100.) ** m - ! fsno(np) = tanh(snowdp(np)/(2.5 * zlnd * fmelt)) - ! ENDIF + wpre = sum(wliq_soisno(maxsnl+1:nl_soil,np)) + sum(wice_soisno(maxsnl+1:nl_soil,np)) + IF (wpre-wbef > 1.e-6) THEN + print*,'np=',np,'wice+wliq err=',wpre-wbef + ENDIF - ! Sigf, fsno - CALL snowfraction (tlai(np),tsai(np),z0m(np),zlnd,scv(np),snowdp(np),wt,sigf(np),fsno(np)) - sai(np) = tsai(np) * sigf(np) - ! ! In case lai+sai come into existence this year, set sigf to 1; Update: won't happen if CALL snowfraction - ! IF ( (lai(np) + sai(np)).gt.0 .and. sigf(np).eq.0 ) THEN - ! sigf(np) = 1 - ! ENDIF + ! ============================================================= + ! 2) adjusted based on code of physical process. + ! ============================================================= - ! Set Groud temperature - IF ( sum( z_sno(:,np) ) .eq. 0 ) THEN - t_grnd(np) = t_soisno(1,np) - ELSE - DO k = maxsnl+1, 0 - IF ( z_sno(k,np) .lt. 0 ) THEN - t_grnd(np) = t_soisno(k,np) - EXIT + DO l = maxsnl+1, 0 + IF ( z_sno(l,np) .lt. 0 ) THEN + scv(np) = scv(np) + wice_soisno(l,np) + wliq_soisno(l,np) + snowdp(np) = snowdp(np) + dz_sno(l,np) ENDIF ENDDO - ENDIF - ! Get the lowest zwt from source patches and assign to np suggested by Shupeng Zhang - zwt(np) = zwt_(frnp_(1)) - k = 2 - DO WHILE (k .le. num) - IF ( zwt_(frnp_(k)) .lt. zwt(np) ) zwt(np) = zwt_(frnp_(k)) - k = k + 1 - ENDDO - - ! ELSE - ! ! Patch area stay unchanged or decrease, use restart value or remain initialized - ! ! TODO: CALL REST - DONE - ! inp_ = np_ - ! DO WHILE (inp_ .le. grid_patch_e_(j)) - ! IF (patchclass_(inp_) .eq. patchclass(np)) THEN - ! selfnp_ = inp_ - ! frnp_(1) = inp_ - ! wliq_soisno (:,np) = wliq_soisno_ (:,inp_) - ! wice_soisno (:,np) = wice_soisno_ (:,inp_) - ! t_soisno (:,np) = t_soisno_ (:,inp_) - ! z_sno (:,np) = z_sno_ (:,inp_) - ! dz_sno (:,np) = dz_sno_ (:,inp_) - ! t_grnd (np) = t_grnd_ (inp_) - ! tleaf (np) = tleaf_ (inp_) - ! ldew (np) = ldew_ (inp_) - ! sag (np) = sag_ (inp_) - ! scv (np) = scv_ (inp_) - ! snowdp (np) = snowdp_ (inp_) - ! fsno (np) = fsno_ (inp_) - ! sigf (np) = sigf_ (inp_) - ! ! In case lai+sai come into existence this year, set sigf to 1 - ! IF ( (lai(np) + sai(np)).gt.0 .and. sigf(np).eq.0 ) THEN - ! sigf(np) = 1 - ! ENDIF - ! zwt (np) = zwt_ (inp_) - ! wa (np) = wa_ (inp_) - ! EXIT - ! ENDIF - ! - ! inp_ = inp_ + 1 - ! ENDDO - - ENDIF + ! ! Use restart value from the same type of source patch or remain initialized + ! IF (lccpct_np(patchclass(np)) .gt. 0) THEN + ! tleaf (np) = tleaf_ (selfnp_) + ! lake_icefrac(:,np) = lake_icefrac_(:,selfnp_) + ! t_lake (:,np) = t_lake_ (:,selfnp_) + ! ENDIF + + ! Fraction of soil covered by snow + zlnd = 0.01 !Roughness length for soil [m] + ! fsno(np) = 0.0 + ! IF (snowdp(np) > 0.) THEN + ! fmelt = (scv(np)/snowdp(np)/100.) ** m + ! fsno(np) = tanh(snowdp(np)/(2.5 * zlnd * fmelt)) + ! ENDIF + + ! Sigf, fsno + CALL snowfraction (tlai(np),tsai(np),z0m(np),zlnd,scv(np),snowdp(np),wt,sigf(np),fsno(np)) + sai(np) = tsai(np) * sigf(np) + + ! ! In case lai+sai come into existence this year, set sigf to 1; Update: won't happen if CALL snowfraction + ! IF ( (lai(np) + sai(np)).gt.0 .and. sigf(np).eq.0 ) THEN + ! sigf(np) = 1 + ! ENDIF + + ! Set Groud temperature + IF ( sum( z_sno(:,np) ) .eq. 0 ) THEN + t_grnd(np) = t_soisno(1,np) + ELSE + DO k = maxsnl+1, 0 + IF ( z_sno(k,np) .lt. 0 ) THEN + t_grnd(np) = t_soisno(k,np) + EXIT + ENDIF + ENDDO + ENDIF + + ! Get the lowest zwt from source patches and assign to np suggested by Shupeng Zhang + zwt(np) = zwt_(frnp_(1)) + k = 2 + DO WHILE (k .le. num) + IF ( zwt_(frnp_(k)) .lt. zwt(np) ) zwt(np) = zwt_(frnp_(k)) + k = k + 1 + ENDDO + + ! ELSE + ! ! Patch area stay unchanged or decrease, use restart value or remain initialized + ! ! TODO: CALL REST - DONE + ! inp_ = np_ + ! DO WHILE (inp_ .le. grid_patch_e_(j)) + ! IF (patchclass_(inp_) .eq. patchclass(np)) THEN + ! selfnp_ = inp_ + ! frnp_(1) = inp_ + ! wliq_soisno (:,np) = wliq_soisno_ (:,inp_) + ! wice_soisno (:,np) = wice_soisno_ (:,inp_) + ! t_soisno (:,np) = t_soisno_ (:,inp_) + ! z_sno (:,np) = z_sno_ (:,inp_) + ! dz_sno (:,np) = dz_sno_ (:,inp_) + ! t_grnd (np) = t_grnd_ (inp_) + ! tleaf (np) = tleaf_ (inp_) + ! ldew (np) = ldew_ (inp_) + ! sag (np) = sag_ (inp_) + ! scv (np) = scv_ (inp_) + ! snowdp (np) = snowdp_ (inp_) + ! fsno (np) = fsno_ (inp_) + ! sigf (np) = sigf_ (inp_) + ! ! In case lai+sai come into existence this year, set sigf to 1 + ! IF ( (lai(np) + sai(np)).gt.0 .and. sigf(np).eq.0 ) THEN + ! sigf(np) = 1 + ! ENDIF + ! zwt (np) = zwt_ (inp_) + ! wa (np) = wa_ (inp_) + ! EXIT + ! ENDIF + ! + ! inp_ = inp_ + 1 + ! ENDDO + + ENDIF ! ELSEIF (patchtype(np)==3) THEN !glacier patch -! ! Used restart value for GLACIERS patches if patchclass exists last year, or remain initialized -! ! TODO: CALL REST - DONE -! inp_ = np_ -! DO WHILE (inp_ .le. grid_patch_e_(j)) -! IF (patchclass_(inp_) .eq. patchclass(np)) THEN -! wliq_soisno (:,np) = wliq_soisno_ (:,inp_) -! wice_soisno (:,np) = wice_soisno_ (:,inp_) -! t_soisno (:,np) = t_soisno_ (:,inp_) -! z_sno (:,np) = z_sno_ (:,inp_) -! dz_sno (:,np) = dz_sno_ (:,inp_) -! t_grnd (np) = t_grnd_ (inp_) -! tleaf (np) = tleaf_ (inp_) -! ldew (np) = ldew_ (inp_) -! sag (np) = sag_ (inp_) -! scv (np) = scv_ (inp_) -! snowdp (np) = snowdp_ (inp_) -! fsno (np) = fsno_ (inp_) -! sigf (np) = sigf_ (inp_) -! zwt (np) = zwt_ (inp_) -! wa (np) = wa_ (inp_) -! EXIT -! ENDIF -! inp_ = inp_ + 1 -! ENDDO +! ! Used restart value for GLACIERS patches if patchclass exists last year, or remain initialized +! ! TODO: CALL REST - DONE +! inp_ = np_ +! DO WHILE (inp_ .le. grid_patch_e_(j)) +! IF (patchclass_(inp_) .eq. patchclass(np)) THEN +! wliq_soisno (:,np) = wliq_soisno_ (:,inp_) +! wice_soisno (:,np) = wice_soisno_ (:,inp_) +! t_soisno (:,np) = t_soisno_ (:,inp_) +! z_sno (:,np) = z_sno_ (:,inp_) +! dz_sno (:,np) = dz_sno_ (:,inp_) +! t_grnd (np) = t_grnd_ (inp_) +! tleaf (np) = tleaf_ (inp_) +! ldew (np) = ldew_ (inp_) +! sag (np) = sag_ (inp_) +! scv (np) = scv_ (inp_) +! snowdp (np) = snowdp_ (inp_) +! fsno (np) = fsno_ (inp_) +! sigf (np) = sigf_ (inp_) +! zwt (np) = zwt_ (inp_) +! wa (np) = wa_ (inp_) +! EXIT +! ENDIF +! inp_ = inp_ + 1 +! ENDDO ENDIF #if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) - IF (patchtype(np)==0) THEN - ps = patch_pft_s(np) - pe = patch_pft_e(np) - ! ps_ = patch_pft_s_(selfnp_) - ! pe_ = patch_pft_e_(selfnp_) - ! if totally come from other types,ldew set to zero since ldew_p(:)=0 - ldew(np) = sum( ldew_p(ps:pe)*pftfrac(ps:pe) ) - - ! z0m_p was same-type assigned, then here we update sigf_p, sigf, fsno - CALL snowfraction_pftwrap (np,zlnd,scv(np),snowdp(np),wt,sigf(np),fsno(np)) - - sai_p(ps:pe) = tsai_p(ps:pe) * sigf_p(ps:pe) - sai(np) = sum(sai_p(ps:pe)*pftfrac(ps:pe)) - ENDIF - - ! ! TODO: CALL REST - DONE - ! IF (patchtype(np)==0 .and. lccpct_np(patchclass(np)) .gt. 0) THEN - ! ! Used restart value of the same pftclass for pft-specific variables - ! ! Note: For ip-specific variables, remain initialized value for new soil patch or pftclass - ! ip = ps - ! ip_= ps_ - ! - ! IF (ip.le.0 .or. ip_.le.0) THEN - ! print *, "Error in LuLccMassEnergyConserve LULC_IGBP_PFT|LULC_IGBP_PC!" - ! STOP - ! ENDIF - ! - ! DO WHILE (ip.le.pe .and. ip_.le.pe_) - ! ! if a PFT is missing, CYCLE - ! IF (pftclass(ip) > pftclass_(ip_)) THEN - ! ip_= ip_+ 1 - ! CYCLE - ! ENDIF - ! - ! ! if a PFT is added, CYCLE - ! IF (pftclass(ip) < pftclass_(ip_)) THEN - ! ip = ip + 1 - ! CYCLE - ! ENDIF - ! - ! ! for the same PFT, set PFT value - ! tleaf_p (ip) = tleaf_p_ (ip_) - ! ldew_p (ip) = ldew_p_ (ip_) - ! ! use MOD_SnowFraction.F90 later - ! sigf_p (ip) = sigf_p_ (ip_) - ! IF ( (lai_p(ip) + sai_p(ip)).gt.0 .and. sigf_p(ip).eq.0 ) THEN - ! sigf_p(ip) = 1 - ! ENDIF - ! - ! ip = ip + 1 - ! ip_= ip_+ 1 - ! ENDDO - ! ldew(np) = sum( ldew_p(ps:pe)*pftfrac(ps:pe) ) - ! ENDIF + IF (patchtype(np)==0) THEN + ps = patch_pft_s(np) + pe = patch_pft_e(np) + ! ps_ = patch_pft_s_(selfnp_) + ! pe_ = patch_pft_e_(selfnp_) + ! if totally come from other types,ldew set to zero since ldew_p(:)=0 + ldew(np) = sum( ldew_p(ps:pe)*pftfrac(ps:pe) ) + + ! z0m_p was same-type assigned, then here we update sigf_p, sigf, fsno + CALL snowfraction_pftwrap (np,zlnd,scv(np),snowdp(np),wt,sigf(np),fsno(np)) + + sai_p(ps:pe) = tsai_p(ps:pe) * sigf_p(ps:pe) + sai(np) = sum(sai_p(ps:pe)*pftfrac(ps:pe)) + ENDIF + + ! ! TODO: CALL REST - DONE + ! IF (patchtype(np)==0 .and. lccpct_np(patchclass(np)) .gt. 0) THEN + ! ! Used restart value of the same pftclass for pft-specific variables + ! ! Note: For ip-specific variables, remain initialized value for new soil patch or pftclass + ! ip = ps + ! ip_= ps_ + ! + ! IF (ip.le.0 .or. ip_.le.0) THEN + ! print *, "Error in LuLccMassEnergyConserve LULC_IGBP_PFT|LULC_IGBP_PC!" + ! STOP + ! ENDIF + ! + ! DO WHILE (ip.le.pe .and. ip_.le.pe_) + ! ! if a PFT is missing, CYCLE + ! IF (pftclass(ip) > pftclass_(ip_)) THEN + ! ip_= ip_+ 1 + ! CYCLE + ! ENDIF + ! + ! ! if a PFT is added, CYCLE + ! IF (pftclass(ip) < pftclass_(ip_)) THEN + ! ip = ip + 1 + ! CYCLE + ! ENDIF + ! + ! ! for the same PFT, set PFT value + ! tleaf_p (ip) = tleaf_p_ (ip_) + ! ldew_p (ip) = ldew_p_ (ip_) + ! ! use MOD_SnowFraction.F90 later + ! sigf_p (ip) = sigf_p_ (ip_) + ! IF ( (lai_p(ip) + sai_p(ip)).gt.0 .and. sigf_p(ip).eq.0 ) THEN + ! sigf_p(ip) = 1 + ! ENDIF + ! + ! ip = ip + 1 + ! ip_= ip_+ 1 + ! ENDDO + ! ldew(np) = sum( ldew_p(ps:pe)*pftfrac(ps:pe) ) + ! ENDIF #endif #ifdef URBAN_MODEL - IF (patchclass(np)==URBAN) THEN + IF (patchclass(np)==URBAN) THEN - ! If there isn't any urban patch in last year's grid,initialized value was remained. - ! Though the first source soil patch would be used for pervious ground related variables. - u = patch2urban (np) - nurb = count( patchclass_(grid_patch_s_(j):grid_patch_e_(j)) == URBAN ) + ! If there isn't any urban patch in last year's grid,initialized value was remained. + ! Though the first source soil patch would be used for pervious ground related variables. + u = patch2urban (np) + nurb = count( patchclass_(grid_patch_s_(j):grid_patch_e_(j)) == URBAN ) - ! Get the index of urban patches in last year's grid, and index of urban patch with the same urbclass - IF (nurb > 0) THEN + ! Get the index of urban patches in last year's grid, and index of urban patch with the same urbclass + IF (nurb > 0) THEN - allocate(gu_(nurb)) ! index of urban patches in last year's grid - selfu_ = -1 ! index of urban patch with the same urbclass in last year's grid - inp_ = np_ ! for loop to record the index of urban patch - iu = 0 + allocate(gu_(nurb)) ! index of urban patches in last year's grid + selfu_ = -1 ! index of urban patch with the same urbclass in last year's grid + inp_ = np_ ! for loop to record the index of urban patch + iu = 0 - DO WHILE (inp_ .le. grid_patch_e_(j)) - IF (patchclass_(inp_) == URBAN) THEN - iu = iu + 1 - gu_(iu) = patch2urban_(inp_) - IF (landurban%settyp(u) == urbclass_(gu_(iu))) THEN - selfu_ = gu_(iu) + DO WHILE (inp_ .le. grid_patch_e_(j)) + IF (patchclass_(inp_) == URBAN) THEN + iu = iu + 1 + gu_(iu) = patch2urban_(inp_) + IF (landurban%settyp(u) == urbclass_(gu_(iu))) THEN + selfu_ = gu_(iu) + ENDIF ENDIF - ENDIF - inp_ = inp_ + 1 - ENDDO - ENDIF + inp_ = inp_ + 1 + ENDDO + ENDIF - ! Index of the same urbclass or the nearest class would be used for new year's assignment - IF (selfu_ > 0) THEN - u_ = selfu_ - - ELSE IF (nurb > 0) THEN - duclass = abs ( landurban%settyp(u) - urbclass_(gu_(1)) ) - u_ = gu_(1) - iu = 2 - DO WHILE (iu .le. nurb) - IF (duclass .gt. abs( landurban%settyp(u) - urbclass_(gu_(iu)) )) THEN - u_ = gu_(iu) - duclass = abs( landurban%settyp(u) - urbclass_(u_) ) - ENDIF - iu = iu + 1 - ENDDO - ENDIF + ! Index of the same urbclass or the nearest class would be used for new year's assignment + IF (selfu_ > 0) THEN + u_ = selfu_ + + ELSE IF (nurb > 0) THEN + duclass = abs ( landurban%settyp(u) - urbclass_(gu_(1)) ) + u_ = gu_(1) + iu = 2 + DO WHILE (iu .le. nurb) + IF (duclass .gt. abs( landurban%settyp(u) - urbclass_(gu_(iu)) )) THEN + u_ = gu_(iu) + duclass = abs( landurban%settyp(u) - urbclass_(u_) ) + ENDIF + iu = iu + 1 + ENDDO + ENDIF - IF (u.le.0 .or. u_.le.0) THEN - print *, "Error in LuLccMassEnergyConserve URBAN_MODEL!" - STOP - ENDIF + IF (u.le.0 .or. u_.le.0) THEN + print *, "Error in LuLccMassEnergyConserve URBAN_MODEL!" + STOP + ENDIF - fwsun (u) = fwsun_ (u_) - dfwsun (u) = dfwsun_ (u_) - - sroof (:,:,u) = sroof_ (:,:,u_) - swsun (:,:,u) = swsun_ (:,:,u_) - swsha (:,:,u) = swsha_ (:,:,u_) - sgimp (:,:,u) = sgimp_ (:,:,u_) - sgper (:,:,u) = sgper_ (:,:,u_) - slake (:,:,u) = slake_ (:,:,u_) - - z_sno_roof (:,u) = z_sno_roof_ (:,u_) - z_sno_gimp (:,u) = z_sno_gimp_ (:,u_) - z_sno_gper (:,u) = z_sno_gper_ (:,u_) - z_sno_lake (:,u) = z_sno_lake_ (:,u_) - - dz_sno_roof (:,u) = dz_sno_roof_ (:,u_) - dz_sno_gimp (:,u) = dz_sno_gimp_ (:,u_) - dz_sno_gper (:,u) = dz_sno_gper_ (:,u_) - dz_sno_lake (:,u) = dz_sno_lake_ (:,u_) - - lwsun (u) = lwsun_ (u_) - lwsha (u) = lwsha_ (u_) - lgimp (u) = lgimp_ (u_) - lgper (u) = lgper_ (u_) - lveg (u) = lveg_ (u_) - - t_roofsno (:,u) = t_roofsno_ (:,u_) - t_wallsun (:,u) = t_wallsun_ (:,u_) - t_wallsha (:,u) = t_wallsha_ (:,u_) - t_gimpsno (:,u) = t_gimpsno_ (:,u_) - t_gpersno (:,u) = t_gpersno_ (:,u_) - t_lakesno (:,u) = t_lakesno_ (:,u_) - - troof_inner (u) = troof_inner_ (u_) - twsun_inner (u) = twsun_inner_ (u_) - twsha_inner (u) = twsha_inner_ (u_) - - wliq_roofsno (:,u) = wliq_roofsno_ (:,u_) - wice_roofsno (:,u) = wice_roofsno_ (:,u_) - wliq_gimpsno (:,u) = wliq_gimpsno_ (:,u_) - wice_gimpsno (:,u) = wice_gimpsno_ (:,u_) - wliq_gpersno (:,u) = wliq_gpersno_ (:,u_) - wice_gpersno (:,u) = wice_gpersno_ (:,u_) - wliq_lakesno (:,u) = wliq_lakesno_ (:,u_) - wice_lakesno (:,u) = wice_lakesno_ (:,u_) - - sag_roof (u) = sag_roof_ (u_) - sag_gimp (u) = sag_gimp_ (u_) - sag_gper (u) = sag_gper_ (u_) - sag_lake (u) = sag_lake_ (u_) - scv_roof (u) = scv_roof_ (u_) - scv_gimp (u) = scv_gimp_ (u_) - scv_gper (u) = scv_gper_ (u_) - scv_lake (u) = scv_lake_ (u_) - fsno_roof (u) = fsno_roof_ (u_) - fsno_gimp (u) = fsno_gimp_ (u_) - fsno_gper (u) = fsno_gper_ (u_) - fsno_lake (u) = fsno_lake_ (u_) - snowdp_roof (u) = snowdp_roof_ (u_) - snowdp_gimp (u) = snowdp_gimp_ (u_) - snowdp_gper (u) = snowdp_gper_ (u_) - snowdp_lake (u) = snowdp_lake_ (u_) - - Fhac (u) = Fhac_ (u_) - Fwst (u) = Fwst_ (u_) - Fach (u) = Fach_ (u_) - Fahe (u) = Fahe_ (u_) - Fhah (u) = Fhah_ (u_) - vehc (u) = vehc_ (u_) - meta (u) = meta_ (u_) - t_room (u) = t_room_ (u_) - t_roof (u) = t_roof_ (u_) - t_wall (u) = t_wall_ (u_) - tafu (u) = tafu_ (u_) - urb_green (u) = urb_green_ (u_) - - ! used soil patch value for variable on pervious ground - FROM_SOIL = .false. - IF (selfu_ < 0) THEN - DO k = 1, num - IF (patchtype_(frnp_(k)) == 0) THEN - FROM_SOIL = .true. - ENDIF - ENDDO - ENDIF + fwsun (u) = fwsun_ (u_) + dfwsun (u) = dfwsun_ (u_) + + sroof (:,:,u) = sroof_ (:,:,u_) + swsun (:,:,u) = swsun_ (:,:,u_) + swsha (:,:,u) = swsha_ (:,:,u_) + sgimp (:,:,u) = sgimp_ (:,:,u_) + sgper (:,:,u) = sgper_ (:,:,u_) + slake (:,:,u) = slake_ (:,:,u_) + + z_sno_roof (:,u) = z_sno_roof_ (:,u_) + z_sno_gimp (:,u) = z_sno_gimp_ (:,u_) + z_sno_gper (:,u) = z_sno_gper_ (:,u_) + z_sno_lake (:,u) = z_sno_lake_ (:,u_) + + dz_sno_roof (:,u) = dz_sno_roof_ (:,u_) + dz_sno_gimp (:,u) = dz_sno_gimp_ (:,u_) + dz_sno_gper (:,u) = dz_sno_gper_ (:,u_) + dz_sno_lake (:,u) = dz_sno_lake_ (:,u_) + + lwsun (u) = lwsun_ (u_) + lwsha (u) = lwsha_ (u_) + lgimp (u) = lgimp_ (u_) + lgper (u) = lgper_ (u_) + lveg (u) = lveg_ (u_) + + t_roofsno (:,u) = t_roofsno_ (:,u_) + t_wallsun (:,u) = t_wallsun_ (:,u_) + t_wallsha (:,u) = t_wallsha_ (:,u_) + t_gimpsno (:,u) = t_gimpsno_ (:,u_) + t_gpersno (:,u) = t_gpersno_ (:,u_) + t_lakesno (:,u) = t_lakesno_ (:,u_) + + troof_inner (u) = troof_inner_ (u_) + twsun_inner (u) = twsun_inner_ (u_) + twsha_inner (u) = twsha_inner_ (u_) + + wliq_roofsno (:,u) = wliq_roofsno_ (:,u_) + wice_roofsno (:,u) = wice_roofsno_ (:,u_) + wliq_gimpsno (:,u) = wliq_gimpsno_ (:,u_) + wice_gimpsno (:,u) = wice_gimpsno_ (:,u_) + wliq_gpersno (:,u) = wliq_gpersno_ (:,u_) + wice_gpersno (:,u) = wice_gpersno_ (:,u_) + wliq_lakesno (:,u) = wliq_lakesno_ (:,u_) + wice_lakesno (:,u) = wice_lakesno_ (:,u_) + + sag_roof (u) = sag_roof_ (u_) + sag_gimp (u) = sag_gimp_ (u_) + sag_gper (u) = sag_gper_ (u_) + sag_lake (u) = sag_lake_ (u_) + scv_roof (u) = scv_roof_ (u_) + scv_gimp (u) = scv_gimp_ (u_) + scv_gper (u) = scv_gper_ (u_) + scv_lake (u) = scv_lake_ (u_) + fsno_roof (u) = fsno_roof_ (u_) + fsno_gimp (u) = fsno_gimp_ (u_) + fsno_gper (u) = fsno_gper_ (u_) + fsno_lake (u) = fsno_lake_ (u_) + snowdp_roof (u) = snowdp_roof_ (u_) + snowdp_gimp (u) = snowdp_gimp_ (u_) + snowdp_gper (u) = snowdp_gper_ (u_) + snowdp_lake (u) = snowdp_lake_ (u_) + + Fhac (u) = Fhac_ (u_) + Fwst (u) = Fwst_ (u_) + Fach (u) = Fach_ (u_) + Fahe (u) = Fahe_ (u_) + Fhah (u) = Fhah_ (u_) + vehc (u) = vehc_ (u_) + meta (u) = meta_ (u_) + t_room (u) = t_room_ (u_) + t_roof (u) = t_roof_ (u_) + t_wall (u) = t_wall_ (u_) + tafu (u) = tafu_ (u_) + urb_green (u) = urb_green_ (u_) + + ! used soil patch value for variable on pervious ground + FROM_SOIL = .false. + IF (selfu_ < 0) THEN + DO k = 1, num + IF (patchtype_(frnp_(k)) == 0) THEN + FROM_SOIL = .true. + ENDIF + ENDDO + ENDIF - ! Use the first source soil patch temporarily - IF (FROM_SOIL) THEN - z_sno_gper (:,u) = z_sno_ (:,frnp_(1)) - sag_gper (u) = sag_ (frnp_(1)) - scv_gper (u) = scv_ (frnp_(1)) - fsno_gper (u) = fsno_ (frnp_(1)) - snowdp_gper (u) = snowdp_ (frnp_(1)) - ENDIF + ! Use the first source soil patch temporarily + IF (FROM_SOIL) THEN + z_sno_gper (:,u) = z_sno_ (:,frnp_(1)) + sag_gper (u) = sag_ (frnp_(1)) + scv_gper (u) = scv_ (frnp_(1)) + fsno_gper (u) = fsno_ (frnp_(1)) + snowdp_gper (u) = snowdp_ (frnp_(1)) + ENDIF - !TODO: need to recalculate wliq_soisno, wice_soisno and scv value - DONE - wliq_soisno(: ,np) = 0. - wliq_soisno(:1,np) = wliq_roofsno(:1,u )*froof(u) - wliq_soisno(: ,np) = wliq_soisno (: ,np)+wliq_gpersno(: ,u)*(1-froof(u))*fgper(u) - wliq_soisno(:1,np) = wliq_soisno (:1,np)+wliq_gimpsno(:1,u)*(1-froof(u))*(1-fgper(u)) + !TODO: need to recalculate wliq_soisno, wice_soisno and scv value - DONE + wliq_soisno(: ,np) = 0. + wliq_soisno(:1,np) = wliq_roofsno(:1,u )*froof(u) + wliq_soisno(: ,np) = wliq_soisno (: ,np)+wliq_gpersno(: ,u)*(1-froof(u))*fgper(u) + wliq_soisno(:1,np) = wliq_soisno (:1,np)+wliq_gimpsno(:1,u)*(1-froof(u))*(1-fgper(u)) - wice_soisno(: ,np) = 0. - wice_soisno(:1,np) = wice_roofsno(:1,u )*froof(u) - wice_soisno(: ,np) = wice_soisno (: ,np)+wice_gpersno(: ,u)*(1-froof(u))*fgper(u) - wice_soisno(:1,np) = wice_soisno (:1,np)+wice_gimpsno(:1,u)*(1-froof(u))*(1-fgper(u)) + wice_soisno(: ,np) = 0. + wice_soisno(:1,np) = wice_roofsno(:1,u )*froof(u) + wice_soisno(: ,np) = wice_soisno (: ,np)+wice_gpersno(: ,u)*(1-froof(u))*fgper(u) + wice_soisno(:1,np) = wice_soisno (:1,np)+wice_gimpsno(:1,u)*(1-froof(u))*(1-fgper(u)) - scv(np) = scv_roof(u)*froof(u) + scv_gper(u)*(1-froof(u))*fgper(u) + scv_gimp(u)*(1-froof(u))*(1-fgper(u)) + scv(np) = scv_roof(u)*froof(u) + scv_gper(u)*(1-froof(u))*fgper(u) + scv_gimp(u)*(1-froof(u))*(1-fgper(u)) - ENDIF + ENDIF #endif - ! CALL albland (np, patchtype(np),deltim,& - ! soil_s_v_alb(np),soil_d_v_alb(np),soil_s_n_alb(np),soil_d_n_alb(np),& - ! chil(patchclass(np)),rho(1:,1:,patchclass(np)),tau(1:,1:,patchclass(np)),fveg(np),green(np),lai(np),sai(np),coszen(np),& - ! wt,fsno(np),scv(np),scvold(np),sag(np),ssw,pg_snow(np),forc_t(np),t_grnd(np),t_soisno_(maxsnl+1:,np),& - ! dz_soisno_(maxsnl+1:,np),snl,wliq_soisno(maxsnl+1:,np),wice_soisno(maxsnl+1:,np),snw_rds(maxsnl+1:0,np),snofrz,& - ! mss_bcpho(maxsnl+1:0,np),mss_bcphi(maxsnl+1:0,np),mss_ocpho(maxsnl+1:0,np),mss_ocphi(maxsnl+1:0,np),& - ! mss_dst1(maxsnl+1:0,np),mss_dst2(maxsnl+1:0,np),mss_dst3(maxsnl+1:0,np),mss_dst4(maxsnl+1:0,np),& - ! alb(1:,1:,np),ssun(1:,1:,np),ssha(1:,1:,np),ssno(:,:,:,np),thermk(np),extkb(np),extkd(np)) - - - IF (allocated(frnp_ )) deallocate(frnp_ ) - IF (allocated(gu_ )) deallocate(gu_ ) - IF (allocated(cvsoil_)) deallocate(cvsoil_) - np = np + 1 - ENDDO - ENDIF + ! CALL albland (np, patchtype(np),deltim,& + ! soil_s_v_alb(np),soil_d_v_alb(np),soil_s_n_alb(np),soil_d_n_alb(np),& + ! chil(patchclass(np)),rho(1:,1:,patchclass(np)),tau(1:,1:,patchclass(np)),fveg(np),green(np),lai(np),sai(np),coszen(np),& + ! wt,fsno(np),scv(np),scvold(np),sag(np),ssw,pg_snow(np),forc_t(np),t_grnd(np),t_soisno_(maxsnl+1:,np),& + ! dz_soisno_(maxsnl+1:,np),snl,wliq_soisno(maxsnl+1:,np),wice_soisno(maxsnl+1:,np),snw_rds(maxsnl+1:0,np),snofrz,& + ! mss_bcpho(maxsnl+1:0,np),mss_bcphi(maxsnl+1:0,np),mss_ocpho(maxsnl+1:0,np),mss_ocphi(maxsnl+1:0,np),& + ! mss_dst1(maxsnl+1:0,np),mss_dst2(maxsnl+1:0,np),mss_dst3(maxsnl+1:0,np),mss_dst4(maxsnl+1:0,np),& + ! alb(1:,1:,np),ssun(1:,1:,np),ssha(1:,1:,np),ssno(:,:,:,np),thermk(np),extkb(np),extkd(np)) + + + IF (allocated(frnp_ )) deallocate(frnp_ ) + IF (allocated(gu_ )) deallocate(gu_ ) + IF (allocated(cvsoil_)) deallocate(cvsoil_) + np = np + 1 + ENDDO + ENDIF + ENDDO ENDDO - ENDDO - ENDIF - - IF (p_is_worker) THEN - IF (allocated(grid_patch_s )) deallocate(grid_patch_s ) - IF (allocated(grid_patch_e )) deallocate(grid_patch_e ) - IF (allocated(grid_patch_s_)) deallocate(grid_patch_s_) - IF (allocated(grid_patch_e_)) deallocate(grid_patch_e_) - IF (allocated(locpxl )) deallocate(locpxl ) - ENDIF - - END SUBROUTINE LulccMassEnergyConserve + ENDIF + + IF (p_is_worker) THEN + IF (allocated(grid_patch_s )) deallocate(grid_patch_s ) + IF (allocated(grid_patch_e )) deallocate(grid_patch_e ) + IF (allocated(grid_patch_s_)) deallocate(grid_patch_s_) + IF (allocated(grid_patch_e_)) deallocate(grid_patch_e_) + IF (allocated(locpxl )) deallocate(locpxl ) + ENDIF + + END SUBROUTINE LulccMassEnergyConserve END MODULE MOD_Lulcc_MassEnergyConserve #endif diff --git a/main/LULCC/MOD_Lulcc_TransferTrace.F90 b/main/LULCC/MOD_Lulcc_TransferTrace.F90 index 482f6ee0..2792ed20 100644 --- a/main/LULCC/MOD_Lulcc_TransferTrace.F90 +++ b/main/LULCC/MOD_Lulcc_TransferTrace.F90 @@ -41,14 +41,14 @@ SUBROUTINE allocate_LulccTransferTrace ! Allocates memory for Lulcc time invariant variables ! -------------------------------------------------------------------- - USE MOD_Precision - USE MOD_Vars_Global - USE MOD_LandPatch - USE MOD_SPMD_Task + USE MOD_Precision + USE MOD_Vars_Global + USE MOD_LandPatch + USE MOD_SPMD_Task - IMPLICIT NONE + IMPLICIT NONE - integer :: nlc = N_land_classification + integer :: nlc = N_land_classification IF (p_is_worker) THEN allocate (lccpct_patches (numpatch, 0:nlc)) @@ -62,48 +62,48 @@ END SUBROUTINE allocate_LulccTransferTrace SUBROUTINE MAKE_LulccTransferTrace (lc_year) - USE MOD_Precision - USE MOD_Namelist - USE MOD_SPMD_Task - USE MOD_Grid - USE MOD_LandPatch - USE MOD_NetCDFVector - USE MOD_NetCDFBlock - USE MOD_AggregationRequestData - USE MOD_Mesh - USE MOD_MeshFilter - USE MOD_LandElm - USE MOD_DataType - USE MOD_Block - USE MOD_Pixel - USE MOD_5x5DataReadin - USE MOD_RegionClip - USE MOD_Utils + USE MOD_Precision + USE MOD_Namelist + USE MOD_SPMD_Task + USE MOD_Grid + USE MOD_LandPatch + USE MOD_NetCDFVector + USE MOD_NetCDFBlock + USE MOD_AggregationRequestData + USE MOD_Mesh + USE MOD_MeshFilter + USE MOD_LandElm + USE MOD_DataType + USE MOD_Block + USE MOD_Pixel + USE MOD_5x5DataReadin + USE MOD_RegionClip + USE MOD_Utils #ifdef SrfdataDiag - USE MOD_SrfdataDiag + USE MOD_SrfdataDiag #endif #ifdef RangeCheck - USE MOD_RangeCheck + USE MOD_RangeCheck #endif - IMPLICIT NONE - - integer, intent(in) :: lc_year + IMPLICIT NONE - ! local variables: - ! --------------------------------------------------------------- - character(len=256) :: dir_5x5, suffix, lastyr, thisyr, dir_landdata, lndname - integer :: i,ipatch,ipxl,ipxstt,ipxend,numpxl,ilc - integer, allocatable, dimension(:) :: locpxl - type (block_data_int32_2d) :: lcdatafr !land cover data of last year - integer, allocatable, dimension(:) :: lcdatafr_one(:), lcfrbuff(:) - real(r8),allocatable, dimension(:) :: area_one(:) , areabuff(:) - real(r8) :: sum_areabuff, gridarea - integer, allocatable, dimension(:) :: grid_patch_s, grid_patch_e + integer, intent(in) :: lc_year + + ! local variables: + ! --------------------------------------------------------------- + character(len=256) :: dir_5x5, suffix, lastyr, thisyr, dir_landdata, lndname + integer :: i,ipatch,ipxl,ipxstt,ipxend,numpxl,ilc + integer, allocatable, dimension(:) :: locpxl + type (block_data_int32_2d) :: lcdatafr !land cover data of last year + integer, allocatable, dimension(:) :: lcdatafr_one(:), lcfrbuff(:) + real(r8),allocatable, dimension(:) :: area_one(:) , areabuff(:) + real(r8) :: sum_areabuff, gridarea + integer, allocatable, dimension(:) :: grid_patch_s, grid_patch_e ! for surface data diag #ifdef SrfdataDiag - integer :: ityp - integer, allocatable, dimension(:) :: typindex + integer :: ityp + integer, allocatable, dimension(:) :: typindex allocate( typindex(N_land_classification+1) ) #endif @@ -232,10 +232,10 @@ END SUBROUTINE MAKE_LulccTransferTrace SUBROUTINE deallocate_LulccTransferTrace - ! -------------------------------------------------- - ! Deallocates memory for Lulcc time invariant variables - ! -------------------------------------------------- - USE MOD_SPMD_Task + ! -------------------------------------------------- + ! Deallocates memory for Lulcc time invariant variables + ! -------------------------------------------------- + USE MOD_SPMD_Task IF (p_is_worker) THEN IF (allocated(lccpct_patches)) deallocate (lccpct_patches) diff --git a/main/LULCC/MOD_Lulcc_Vars_TimeInvariants.F90 b/main/LULCC/MOD_Lulcc_Vars_TimeInvariants.F90 index 6c418d72..0e04f3fa 100644 --- a/main/LULCC/MOD_Lulcc_Vars_TimeInvariants.F90 +++ b/main/LULCC/MOD_Lulcc_Vars_TimeInvariants.F90 @@ -11,187 +11,187 @@ MODULE MOD_Lulcc_Vars_TimeInvariants ! ! ====================================================================== - USE MOD_Precision - USE MOD_Vars_Global - USE MOD_PixelSet + USE MOD_Precision + USE MOD_Vars_Global + USE MOD_PixelSet - IMPLICIT NONE - SAVE + IMPLICIT NONE + SAVE !----------------------------------------------------------------------- - ! for patch time invariant information - type(pixelset_type) :: landpatch_ - type(pixelset_type) :: landelm_ - integer :: numpatch_ - integer :: numelm_ - integer :: numpft_ - integer :: numpc_ - integer :: numurban_ - integer, allocatable :: patchclass_ (:) !index of land cover type - integer, allocatable :: patchtype_ (:) !land patch type - real(r8), allocatable:: csol_ (:,:) !heat capacity of soil solids [J/(m3 K)] - - ! for LULC_IGBP_PFT and LULC_IGBP_PC - integer, allocatable :: pftclass_ (:) !PFT type - integer, allocatable :: patch_pft_s_ (:) !start PFT index of a patch - integer, allocatable :: patch_pft_e_ (:) !end PFT index of a patch - - ! for Urban model - integer, allocatable :: urbclass_ (:) !urban type - integer, allocatable :: patch2urban_ (:) !projection from patch to Urban + ! for patch time invariant information + type(pixelset_type) :: landpatch_ + type(pixelset_type) :: landelm_ + integer :: numpatch_ + integer :: numelm_ + integer :: numpft_ + integer :: numpc_ + integer :: numurban_ + integer, allocatable :: patchclass_ (:) !index of land cover type + integer, allocatable :: patchtype_ (:) !land patch type + real(r8), allocatable:: csol_ (:,:) !heat capacity of soil solids [J/(m3 K)] + + ! for LULC_IGBP_PFT and LULC_IGBP_PC + integer, allocatable :: pftclass_ (:) !PFT type + integer, allocatable :: patch_pft_s_ (:) !start PFT index of a patch + integer, allocatable :: patch_pft_e_ (:) !end PFT index of a patch + + ! for Urban model + integer, allocatable :: urbclass_ (:) !urban type + integer, allocatable :: patch2urban_ (:) !projection from patch to Urban ! PUBLIC MEMBER FUNCTIONS: - PUBLIC :: allocate_LulccTimeInvariants - PUBLIC :: deallocate_LulccTimeInvariants - PUBLIC :: SAVE_LulccTimeInvariants + PUBLIC :: allocate_LulccTimeInvariants + PUBLIC :: deallocate_LulccTimeInvariants + PUBLIC :: SAVE_LulccTimeInvariants ! PRIVATE MEMBER FUNCTIONS: !----------------------------------------------------------------------- - CONTAINS +CONTAINS !----------------------------------------------------------------------- - SUBROUTINE allocate_LulccTimeInvariants - ! -------------------------------------------------------------------- - ! Allocates memory for Lulcc time invariant variables - ! -------------------------------------------------------------------- + SUBROUTINE allocate_LulccTimeInvariants + ! -------------------------------------------------------------------- + ! Allocates memory for Lulcc time invariant variables + ! -------------------------------------------------------------------- - USE MOD_SPMD_Task - USE MOD_Precision - USE MOD_Vars_Global - USE MOD_LandPatch - USE MOD_Mesh + USE MOD_SPMD_Task + USE MOD_Precision + USE MOD_Vars_Global + USE MOD_LandPatch + USE MOD_Mesh #if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) - USE MOD_LandPFT + USE MOD_LandPFT #endif #ifdef URBAN_MODEL - USE MOD_LandUrban + USE MOD_LandUrban #endif - IMPLICIT NONE + IMPLICIT NONE - IF (p_is_worker) THEN - IF (numpatch > 0) THEN - allocate (landpatch_%eindex (numpatch)) - allocate (landpatch_%ipxstt (numpatch)) - allocate (landpatch_%ipxend (numpatch)) - allocate (landpatch_%settyp (numpatch)) - allocate (landpatch_%ielm (numpatch)) - allocate (landpatch_%xblkgrp (numpatch)) - allocate (landpatch_%yblkgrp (numpatch)) + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + allocate (landpatch_%eindex (numpatch)) + allocate (landpatch_%ipxstt (numpatch)) + allocate (landpatch_%ipxend (numpatch)) + allocate (landpatch_%settyp (numpatch)) + allocate (landpatch_%ielm (numpatch)) + allocate (landpatch_%xblkgrp (numpatch)) + allocate (landpatch_%yblkgrp (numpatch)) - allocate (landelm_%eindex (numelm)) - allocate (landelm_%ipxstt (numelm)) - allocate (landelm_%ipxend (numelm)) - allocate (landelm_%settyp (numelm)) + allocate (landelm_%eindex (numelm)) + allocate (landelm_%ipxstt (numelm)) + allocate (landelm_%ipxend (numelm)) + allocate (landelm_%settyp (numelm)) - allocate (patchclass_ (numpatch)) - allocate (patchtype_ (numpatch)) - allocate (csol_ (nl_soil,numpatch)) + allocate (patchclass_ (numpatch)) + allocate (patchtype_ (numpatch)) + allocate (csol_ (nl_soil,numpatch)) #if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) - IF (numpft > 0) THEN - allocate (pftclass_ (numpft)) - allocate (patch_pft_s_ (numpatch)) - allocate (patch_pft_e_ (numpatch)) - ENDIF + IF (numpft > 0) THEN + allocate (pftclass_ (numpft)) + allocate (patch_pft_s_ (numpatch)) + allocate (patch_pft_e_ (numpatch)) + ENDIF #endif #ifdef URBAN_MODEL - IF (numurban > 0) THEN - allocate (urbclass_ (numurban)) - allocate (patch2urban_ (numpatch)) - ENDIF + IF (numurban > 0) THEN + allocate (urbclass_ (numurban)) + allocate (patch2urban_ (numpatch)) + ENDIF #endif - ENDIF - ENDIF - END SUBROUTINE allocate_LulccTimeInvariants + ENDIF + ENDIF + END SUBROUTINE allocate_LulccTimeInvariants - SUBROUTINE SAVE_LulccTimeInvariants + SUBROUTINE SAVE_LulccTimeInvariants - USE MOD_Precision - USE MOD_Vars_Global - USE MOD_SPMD_Task - USE MOD_Pixelset - USE MOD_Vars_TimeInvariants - USE MOD_Landpatch - USE MOD_Landelm - USE MOD_Mesh + USE MOD_Precision + USE MOD_Vars_Global + USE MOD_SPMD_Task + USE MOD_Pixelset + USE MOD_Vars_TimeInvariants + USE MOD_Landpatch + USE MOD_Landelm + USE MOD_Mesh #if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) - USE MOD_Vars_PFTimeInvariants - USE MOD_LandPFT + USE MOD_Vars_PFTimeInvariants + USE MOD_LandPFT #endif #ifdef URBAN_MODEL - USE MOD_LandUrban + USE MOD_LandUrban #endif - IMPLICIT NONE + IMPLICIT NONE - IF (p_is_worker) THEN - IF (numpatch > 0) THEN - CALL copy_pixelset(landpatch, landpatch_) - CALL copy_pixelset(landelm , landelm_ ) - numpatch_ = numpatch - numelm_ = numelm - patchclass_ (:) = patchclass (:) - patchtype_ (:) = patchtype (:) - csol_ (:,:) = csol (:,:) + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + CALL copy_pixelset(landpatch, landpatch_) + CALL copy_pixelset(landelm , landelm_ ) + numpatch_ = numpatch + numelm_ = numelm + patchclass_ (:) = patchclass (:) + patchtype_ (:) = patchtype (:) + csol_ (:,:) = csol (:,:) #if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) - IF (numpft > 0) THEN - numpft_ = numpft - pftclass_ (:) = pftclass (:) - patch_pft_s_ (:) = patch_pft_s (:) - patch_pft_e_ (:) = patch_pft_e (:) - ENDIF + IF (numpft > 0) THEN + numpft_ = numpft + pftclass_ (:) = pftclass (:) + patch_pft_s_ (:) = patch_pft_s (:) + patch_pft_e_ (:) = patch_pft_e (:) + ENDIF #endif #ifdef URBAN_MODEL - IF (numurban > 0) THEN - numurban_ = numurban - urbclass_ (:) = landurban%settyp (:) - patch2urban_ (:) = patch2urban (:) - ENDIF + IF (numurban > 0) THEN + numurban_ = numurban + urbclass_ (:) = landurban%settyp (:) + patch2urban_ (:) = patch2urban (:) + ENDIF #endif - ENDIF - ENDIF - END SUBROUTINE SAVE_LulccTimeInvariants + ENDIF + ENDIF + END SUBROUTINE SAVE_LulccTimeInvariants - SUBROUTINE deallocate_LulccTimeInvariants - USE MOD_SPMD_Task - USE MOD_PixelSet + SUBROUTINE deallocate_LulccTimeInvariants + USE MOD_SPMD_Task + USE MOD_PixelSet ! -------------------------------------------------- ! Deallocates memory for Lulcc time invariant variables ! -------------------------------------------------- - IF (p_is_worker) THEN - IF (numpatch_ > 0) THEN - CALL landpatch_%forc_free_mem - CALL landelm_%forc_free_mem - deallocate (patchclass_ ) - deallocate (patchtype_ ) - deallocate (csol_ ) + IF (p_is_worker) THEN + IF (numpatch_ > 0) THEN + CALL landpatch_%forc_free_mem + CALL landelm_%forc_free_mem + deallocate (patchclass_ ) + deallocate (patchtype_ ) + deallocate (csol_ ) #if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) - IF (numpft_ > 0) THEN - deallocate (pftclass_ ) - deallocate (patch_pft_s_ ) - deallocate (patch_pft_e_ ) - ENDIF + IF (numpft_ > 0) THEN + deallocate (pftclass_ ) + deallocate (patch_pft_s_ ) + deallocate (patch_pft_e_ ) + ENDIF #endif #ifdef URBAN_MODEL - IF (numurban_ > 0) THEN - deallocate (urbclass_ ) - deallocate (patch2urban_ ) - ENDIF + IF (numurban_ > 0) THEN + deallocate (urbclass_ ) + deallocate (patch2urban_ ) + ENDIF #endif - ENDIF - ENDIF + ENDIF + ENDIF - END SUBROUTINE deallocate_LulccTimeInvariants + END SUBROUTINE deallocate_LulccTimeInvariants END MODULE MOD_Lulcc_Vars_TimeInvariants ! ---------- EOP ------------ diff --git a/main/LULCC/MOD_Lulcc_Vars_TimeVariables.F90 b/main/LULCC/MOD_Lulcc_Vars_TimeVariables.F90 index 1942c89a..8adc37b7 100644 --- a/main/LULCC/MOD_Lulcc_Vars_TimeVariables.F90 +++ b/main/LULCC/MOD_Lulcc_Vars_TimeVariables.F90 @@ -15,1175 +15,1176 @@ MODULE MOD_Lulcc_Vars_TimeVariables ! ! ====================================================================== - USE MOD_Precision - USE MOD_Vars_Global - IMPLICIT NONE - SAVE + USE MOD_Precision + USE MOD_Vars_Global + IMPLICIT NONE + SAVE ! ---------------------------------------------------------------------- ! Time-varying state variables which reaquired by restart run - !TODO: need to check with MOD_Vars_TimeVariables.F90 whether - ! there are any variables missing. - DONE - real(r8), allocatable :: z_sno_ (:,:) !node depth [m] - real(r8), allocatable :: dz_sno_ (:,:) !interface depth [m] - real(r8), allocatable :: t_soisno_ (:,:) !soil temperature [K] - real(r8), allocatable :: wliq_soisno_ (:,:) !liquid water in layers [kg/m2] - real(r8), allocatable :: wice_soisno_ (:,:) !ice lens in layers [kg/m2] - real(r8), allocatable :: smp_ (:,:) !soil matrix potential [mm] - real(r8), allocatable :: hk_ (:,:) !hydraulic conductivity [mm h2o/s] - real(r8), allocatable :: t_grnd_ (:) !ground surface temperature [K] - - real(r8), allocatable :: tleaf_ (:) !leaf temperature [K] - real(r8), allocatable :: ldew_ (:) !depth of water on foliage [mm] - real(r8), allocatable :: ldew_rain_ (:) !depth of rain on foliage [mm] - real(r8), allocatable :: ldew_snow_ (:) !depth of rain on foliage [mm] - real(r8), allocatable :: sag_ (:) !non dimensional snow age [-] - real(r8), allocatable :: scv_ (:) !snow cover, water equivalent [mm] - real(r8), allocatable :: snowdp_ (:) !snow depth [meter] - real(r8), allocatable :: fsno_ (:) !fraction of snow cover on ground - real(r8), allocatable :: sigf_ (:) !fraction of veg cover, excluding snow-covered veg [-] - real(r8), allocatable :: zwt_ (:) !the depth to water table [m] - real(r8), allocatable :: wa_ (:) !water storage in aquifer [mm] - real(r8), allocatable :: wdsrf_ (:) !depth of surface water [mm] - real(r8), allocatable :: rss_ (:) !soil surface resistance [s/m] - - real(r8), allocatable :: t_lake_ (:,:) !lake layer teperature [K] - real(r8), allocatable :: lake_icefrac_(:,:) !lake mass fraction of lake layer that is frozen - real(r8), allocatable :: savedtke1_ (:) !top level eddy conductivity (W/m K) - - !Plant Hydraulic variables - real(r8), allocatable :: vegwp_ (:,:) !vegetation water potential [mm] - real(r8), allocatable :: gs0sun_ (:) !working copy of sunlit stomata conductance - real(r8), allocatable :: gs0sha_ (:) !working copy of shalit stomata conductance - !END plant hydraulic variables - - !Ozone stress variables - real(r8), allocatable :: lai_old_ (:) !lai in last time step - real(r8), allocatable :: o3uptakesun_ (:) !Ozone does, sunlit leaf (mmol O3/m^2) - real(r8), allocatable :: o3uptakesha_ (:) !Ozone does, shaded leaf (mmol O3/m^2) - !End ozone stress variables - - real(r8), allocatable :: snw_rds_ (:,:) !effective grain radius (col,lyr) [microns, m-6] - real(r8), allocatable :: mss_bcpho_ (:,:) !mass of hydrophobic BC in snow (col,lyr) [kg] - real(r8), allocatable :: mss_bcphi_ (:,:) !mass of hydrophillic BC in snow (col,lyr) [kg] - real(r8), allocatable :: mss_ocpho_ (:,:) !mass of hydrophobic OC in snow (col,lyr) [kg] - real(r8), allocatable :: mss_ocphi_ (:,:) !mass of hydrophillic OC in snow (col,lyr) [kg] - real(r8), allocatable :: mss_dst1_ (:,:) !mass of dust species 1 in snow (col,lyr) [kg] - real(r8), allocatable :: mss_dst2_ (:,:) !mass of dust species 2 in snow (col,lyr) [kg] - real(r8), allocatable :: mss_dst3_ (:,:) !mass of dust species 3 in snow (col,lyr) [kg] - real(r8), allocatable :: mss_dst4_ (:,:) !mass of dust species 4 in snow (col,lyr) [kg] - real(r8), allocatable :: ssno_lyr_(:,:,:,:) !snow layer absorption [-] - - ! Additional variables required by reginal model (such as WRF ) RSM) - real(r8), allocatable :: trad_ (:) !radiative temperature of surface [K] - real(r8), allocatable :: tref_ (:) !2 m height air temperature [kelvin] - real(r8), allocatable :: qref_ (:) !2 m height air specific humidity - real(r8), allocatable :: rst_ (:) !canopy stomatal resistance (s/m) - real(r8), allocatable :: emis_ (:) !averaged bulk surface emissivity - real(r8), allocatable :: z0m_ (:) !effective roughness [m] - real(r8), allocatable :: displa_ (:) !zero displacement height [m] - real(r8), allocatable :: zol_ (:) !dimensionless height (z/L) used in Monin-Obukhov theory - real(r8), allocatable :: rib_ (:) !bulk Richardson number in surface layer - real(r8), allocatable :: ustar_ (:) !u* in similarity theory [m/s] - real(r8), allocatable :: qstar_ (:) !q* in similarity theory [kg/kg] - real(r8), allocatable :: tstar_ (:) !t* in similarity theory [K] - real(r8), allocatable :: fm_ (:) !integral of profile function for momentum - real(r8), allocatable :: fh_ (:) !integral of profile function for heat - real(r8), allocatable :: fq_ (:) !integral of profile function for moisture - - real(r8), allocatable :: sum_irrig_ (:) !total irrigation amount [kg/m2] - real(r8), allocatable :: sum_irrig_count_ (:) !total irrigation counts [-] - - ! for LULC_IGBP_PFT and LULC_IGBP_PC - real(r8), allocatable :: tleaf_p_ (:) !shaded leaf temperature [K] - real(r8), allocatable :: ldew_rain_p_ (:) !depth of rain on foliage [mm] - real(r8), allocatable :: ldew_snow_p_ (:) !depth of snow on foliage [mm] - real(r8), allocatable :: ldew_p_ (:) !depth of water on foliage [mm] - real(r8), allocatable :: sigf_p_ (:) !fraction of veg cover, excluding snow-covered veg [-] - - !TODO@yuan: to check the below for PC whether they are needed - real(r8), allocatable :: tref_p_ (:) !2 m height air temperature [kelvin] - real(r8), allocatable :: qref_p_ (:) !2 m height air specific humidity - real(r8), allocatable :: rst_p_ (:) !canopy stomatal resistance (s/m) - real(r8), allocatable :: z0m_p_ (:) !effective roughness [m] - - ! Plant Hydraulic variables - real(r8), allocatable :: vegwp_p_ (:,:) !vegetation water potential [mm] - real(r8), allocatable :: gs0sun_p_ (:) !working copy of sunlit stomata conductance - real(r8), allocatable :: gs0sha_p_ (:) !working copy of shalit stomata conductance - ! end plant hydraulic variables - - ! Ozone Stress Variables - real(r8), allocatable :: lai_old_p_ (:) !lai in last time step - real(r8), allocatable :: o3uptakesun_p_ (:) !Ozone does, sunlit leaf (mmol O3/m^2) - real(r8), allocatable :: o3uptakesha_p_ (:) !Ozone does, shaded leaf (mmol O3/m^2) - ! End Ozone Stress Variables - - ! for URBAN_MODEL - real(r8), allocatable :: fwsun_ (:) !sunlit fraction of walls [-] - real(r8), allocatable :: dfwsun_ (:) !change of sunlit fraction of walls [-] - - ! shortwave absorption - real(r8), allocatable :: sroof_ (:,:,:) !roof aborption [-] - real(r8), allocatable :: swsun_ (:,:,:) !sunlit wall absorption [-] - real(r8), allocatable :: swsha_ (:,:,:) !shaded wall absorption [-] - real(r8), allocatable :: sgimp_ (:,:,:) !impervious absorptioin [-] - real(r8), allocatable :: sgper_ (:,:,:) !pervious absorptioin [-] - real(r8), allocatable :: slake_ (:,:,:) !urban lake absorptioin [-] - - ! net longwave radiation for last time temperature change - real(r8), allocatable :: lwsun_ (:) !net longwave of sunlit wall [W/m2] - real(r8), allocatable :: lwsha_ (:) !net longwave of shaded wall [W/m2] - real(r8), allocatable :: lgimp_ (:) !net longwave of impervious [W/m2] - real(r8), allocatable :: lgper_ (:) !net longwave of pervious [W/m2] - real(r8), allocatable :: lveg_ (:) !net longwave of vegetation [W/m2] - - real(r8), allocatable :: z_sno_roof_ (:,:) !node depth of roof [m] - real(r8), allocatable :: z_sno_gimp_ (:,:) !node depth of impervious [m] - real(r8), allocatable :: z_sno_gper_ (:,:) !node depth pervious [m] - real(r8), allocatable :: z_sno_lake_ (:,:) !node depth lake [m] - - real(r8), allocatable :: dz_sno_roof_ (:,:) !interface depth of roof [m] - real(r8), allocatable :: dz_sno_gimp_ (:,:) !interface depth of impervious [m] - real(r8), allocatable :: dz_sno_gper_ (:,:) !interface depth pervious [m] - real(r8), allocatable :: dz_sno_lake_ (:,:) !interface depth lake [m] - - real(r8), allocatable :: troof_inner_ (:) !temperature of roof [K] - real(r8), allocatable :: twsun_inner_ (:) !temperature of sunlit wall [K] - real(r8), allocatable :: twsha_inner_ (:) !temperature of shaded wall [K] - - real(r8), allocatable :: t_roofsno_ (:,:) !temperature of roof [K] - real(r8), allocatable :: t_wallsun_ (:,:) !temperature of sunlit wall [K] - real(r8), allocatable :: t_wallsha_ (:,:) !temperature of shaded wall [K] - real(r8), allocatable :: t_gimpsno_ (:,:) !temperature of impervious [K] - real(r8), allocatable :: t_gpersno_ (:,:) !temperature of pervious [K] - real(r8), allocatable :: t_lakesno_ (:,:) !temperature of pervious [K] - - real(r8), allocatable :: wliq_roofsno_(:,:) !liquid water in layers [kg/m2] - real(r8), allocatable :: wliq_gimpsno_(:,:) !liquid water in layers [kg/m2] - real(r8), allocatable :: wliq_gpersno_(:,:) !liquid water in layers [kg/m2] - real(r8), allocatable :: wliq_lakesno_(:,:) !liquid water in layers [kg/m2] - real(r8), allocatable :: wice_roofsno_(:,:) !ice lens in layers [kg/m2] - real(r8), allocatable :: wice_gimpsno_(:,:) !ice lens in layers [kg/m2] - real(r8), allocatable :: wice_gpersno_(:,:) !ice lens in layers [kg/m2] - real(r8), allocatable :: wice_lakesno_(:,:) !ice lens in layers [kg/m2] - - real(r8), allocatable :: sag_roof_ (:) !roof snow age [-] - real(r8), allocatable :: sag_gimp_ (:) !impervious ground snow age [-] - real(r8), allocatable :: sag_gper_ (:) !pervious ground snow age [-] - real(r8), allocatable :: sag_lake_ (:) !urban lake snow age [-] - - real(r8), allocatable :: scv_roof_ (:) !roof snow cover [-] - real(r8), allocatable :: scv_gimp_ (:) !impervious ground snow cover [-] - real(r8), allocatable :: scv_gper_ (:) !pervious ground snow cover [-] - real(r8), allocatable :: scv_lake_ (:) !urban lake snow cover [-] - - real(r8), allocatable :: fsno_roof_ (:) !roof snow fraction [-] - real(r8), allocatable :: fsno_gimp_ (:) !impervious ground snow fraction [-] - real(r8), allocatable :: fsno_gper_ (:) !pervious ground snow fraction [-] - real(r8), allocatable :: fsno_lake_ (:) !urban lake snow fraction [-] - - real(r8), allocatable :: snowdp_roof_ (:) !roof snow depth [m] - real(r8), allocatable :: snowdp_gimp_ (:) !impervious ground snow depth [m] - real(r8), allocatable :: snowdp_gper_ (:) !pervious ground snow depth [m] - real(r8), allocatable :: snowdp_lake_ (:) !urban lake snow depth [m] - - !TODO: condsider renaming the below variables - real(r8), allocatable :: Fhac_ (:) !sensible flux from heat or cool AC [W/m2] - real(r8), allocatable :: Fwst_ (:) !waste heat flux from heat or cool AC [W/m2] - real(r8), allocatable :: Fach_ (:) !flux from inner and outter air exchange [W/m2] - real(r8), allocatable :: Fahe_ (:) !flux from metabolism and vehicle [W/m2] - real(r8), allocatable :: Fhah_ (:) !sensible heat flux from heating [W/m2] - real(r8), allocatable :: vehc_ (:) !flux from vehicle [W/m2] - real(r8), allocatable :: meta_ (:) !flux from metabolism [W/m2] - - real(r8), allocatable :: t_room_ (:) !temperature of inner building [K] - real(r8), allocatable :: t_roof_ (:) !temperature of roof [K] - real(r8), allocatable :: t_wall_ (:) !temperature of wall [K] - real(r8), allocatable :: tafu_ (:) !temperature of outer building [K] - - real(r8), allocatable :: urb_green_ (:) !fractional of green leaf in urban patch [-] + !TODO: need to check with MOD_Vars_TimeVariables.F90 whether + ! there are any variables missing. - DONE + real(r8), allocatable :: z_sno_ (:,:) !node depth [m] + real(r8), allocatable :: dz_sno_ (:,:) !interface depth [m] + real(r8), allocatable :: t_soisno_ (:,:) !soil temperature [K] + real(r8), allocatable :: wliq_soisno_ (:,:) !liquid water in layers [kg/m2] + real(r8), allocatable :: wice_soisno_ (:,:) !ice lens in layers [kg/m2] + real(r8), allocatable :: smp_ (:,:) !soil matrix potential [mm] + real(r8), allocatable :: hk_ (:,:) !hydraulic conductivity [mm h2o/s] + real(r8), allocatable :: t_grnd_ (:) !ground surface temperature [K] + + real(r8), allocatable :: tleaf_ (:) !leaf temperature [K] + real(r8), allocatable :: ldew_ (:) !depth of water on foliage [mm] + real(r8), allocatable :: ldew_rain_ (:) !depth of rain on foliage [mm] + real(r8), allocatable :: ldew_snow_ (:) !depth of rain on foliage [mm] + real(r8), allocatable :: sag_ (:) !non dimensional snow age [-] + real(r8), allocatable :: scv_ (:) !snow cover, water equivalent [mm] + real(r8), allocatable :: snowdp_ (:) !snow depth [meter] + real(r8), allocatable :: fsno_ (:) !fraction of snow cover on ground + real(r8), allocatable :: sigf_ (:) !fraction of veg cover, excluding snow-covered veg [-] + real(r8), allocatable :: zwt_ (:) !the depth to water table [m] + real(r8), allocatable :: wa_ (:) !water storage in aquifer [mm] + real(r8), allocatable :: wdsrf_ (:) !depth of surface water [mm] + real(r8), allocatable :: rss_ (:) !soil surface resistance [s/m] + + real(r8), allocatable :: t_lake_ (:,:) !lake layer teperature [K] + real(r8), allocatable :: lake_icefrac_(:,:) !lake mass fraction of lake layer that is frozen + real(r8), allocatable :: savedtke1_ (:) !top level eddy conductivity (W/m K) + + !Plant Hydraulic variables + real(r8), allocatable :: vegwp_ (:,:) !vegetation water potential [mm] + real(r8), allocatable :: gs0sun_ (:) !working copy of sunlit stomata conductance + real(r8), allocatable :: gs0sha_ (:) !working copy of shalit stomata conductance + !END plant hydraulic variables + + !Ozone stress variables + real(r8), allocatable :: lai_old_ (:) !lai in last time step + real(r8), allocatable :: o3uptakesun_ (:) !Ozone does, sunlit leaf (mmol O3/m^2) + real(r8), allocatable :: o3uptakesha_ (:) !Ozone does, shaded leaf (mmol O3/m^2) + !End ozone stress variables + + real(r8), allocatable :: snw_rds_ (:,:) !effective grain radius (col,lyr) [microns, m-6] + real(r8), allocatable :: mss_bcpho_ (:,:) !mass of hydrophobic BC in snow (col,lyr) [kg] + real(r8), allocatable :: mss_bcphi_ (:,:) !mass of hydrophillic BC in snow (col,lyr) [kg] + real(r8), allocatable :: mss_ocpho_ (:,:) !mass of hydrophobic OC in snow (col,lyr) [kg] + real(r8), allocatable :: mss_ocphi_ (:,:) !mass of hydrophillic OC in snow (col,lyr) [kg] + real(r8), allocatable :: mss_dst1_ (:,:) !mass of dust species 1 in snow (col,lyr) [kg] + real(r8), allocatable :: mss_dst2_ (:,:) !mass of dust species 2 in snow (col,lyr) [kg] + real(r8), allocatable :: mss_dst3_ (:,:) !mass of dust species 3 in snow (col,lyr) [kg] + real(r8), allocatable :: mss_dst4_ (:,:) !mass of dust species 4 in snow (col,lyr) [kg] + real(r8), allocatable :: ssno_lyr_(:,:,:,:) !snow layer absorption [-] + + ! Additional variables required by reginal model (such as WRF ) RSM) + real(r8), allocatable :: trad_ (:) !radiative temperature of surface [K] + real(r8), allocatable :: tref_ (:) !2 m height air temperature [kelvin] + real(r8), allocatable :: qref_ (:) !2 m height air specific humidity + real(r8), allocatable :: rst_ (:) !canopy stomatal resistance (s/m) + real(r8), allocatable :: emis_ (:) !averaged bulk surface emissivity + real(r8), allocatable :: z0m_ (:) !effective roughness [m] + real(r8), allocatable :: displa_ (:) !zero displacement height [m] + real(r8), allocatable :: zol_ (:) !dimensionless height (z/L) used in Monin-Obukhov theory + real(r8), allocatable :: rib_ (:) !bulk Richardson number in surface layer + real(r8), allocatable :: ustar_ (:) !u* in similarity theory [m/s] + real(r8), allocatable :: qstar_ (:) !q* in similarity theory [kg/kg] + real(r8), allocatable :: tstar_ (:) !t* in similarity theory [K] + real(r8), allocatable :: fm_ (:) !integral of profile function for momentum + real(r8), allocatable :: fh_ (:) !integral of profile function for heat + real(r8), allocatable :: fq_ (:) !integral of profile function for moisture + + real(r8), allocatable :: sum_irrig_ (:) !total irrigation amount [kg/m2] + real(r8), allocatable :: sum_irrig_count_ (:) !total irrigation counts [-] + + ! for LULC_IGBP_PFT and LULC_IGBP_PC + real(r8), allocatable :: tleaf_p_ (:) !shaded leaf temperature [K] + real(r8), allocatable :: ldew_rain_p_ (:) !depth of rain on foliage [mm] + real(r8), allocatable :: ldew_snow_p_ (:) !depth of snow on foliage [mm] + real(r8), allocatable :: ldew_p_ (:) !depth of water on foliage [mm] + real(r8), allocatable :: sigf_p_ (:) !fraction of veg cover, excluding snow-covered veg [-] + + !TODO@yuan: to check the below for PC whether they are needed + real(r8), allocatable :: tref_p_ (:) !2 m height air temperature [kelvin] + real(r8), allocatable :: qref_p_ (:) !2 m height air specific humidity + real(r8), allocatable :: rst_p_ (:) !canopy stomatal resistance (s/m) + real(r8), allocatable :: z0m_p_ (:) !effective roughness [m] + + ! Plant Hydraulic variables + real(r8), allocatable :: vegwp_p_ (:,:) !vegetation water potential [mm] + real(r8), allocatable :: gs0sun_p_ (:) !working copy of sunlit stomata conductance + real(r8), allocatable :: gs0sha_p_ (:) !working copy of shalit stomata conductance + ! end plant hydraulic variables + + ! Ozone Stress Variables + real(r8), allocatable :: lai_old_p_ (:) !lai in last time step + real(r8), allocatable :: o3uptakesun_p_ (:) !Ozone does, sunlit leaf (mmol O3/m^2) + real(r8), allocatable :: o3uptakesha_p_ (:) !Ozone does, shaded leaf (mmol O3/m^2) + ! End Ozone Stress Variables + + ! for URBAN_MODEL + real(r8), allocatable :: fwsun_ (:) !sunlit fraction of walls [-] + real(r8), allocatable :: dfwsun_ (:) !change of sunlit fraction of walls [-] + + ! shortwave absorption + real(r8), allocatable :: sroof_ (:,:,:) !roof aborption [-] + real(r8), allocatable :: swsun_ (:,:,:) !sunlit wall absorption [-] + real(r8), allocatable :: swsha_ (:,:,:) !shaded wall absorption [-] + real(r8), allocatable :: sgimp_ (:,:,:) !impervious absorptioin [-] + real(r8), allocatable :: sgper_ (:,:,:) !pervious absorptioin [-] + real(r8), allocatable :: slake_ (:,:,:) !urban lake absorptioin [-] + + ! net longwave radiation for last time temperature change + real(r8), allocatable :: lwsun_ (:) !net longwave of sunlit wall [W/m2] + real(r8), allocatable :: lwsha_ (:) !net longwave of shaded wall [W/m2] + real(r8), allocatable :: lgimp_ (:) !net longwave of impervious [W/m2] + real(r8), allocatable :: lgper_ (:) !net longwave of pervious [W/m2] + real(r8), allocatable :: lveg_ (:) !net longwave of vegetation [W/m2] + + real(r8), allocatable :: z_sno_roof_ (:,:) !node depth of roof [m] + real(r8), allocatable :: z_sno_gimp_ (:,:) !node depth of impervious [m] + real(r8), allocatable :: z_sno_gper_ (:,:) !node depth pervious [m] + real(r8), allocatable :: z_sno_lake_ (:,:) !node depth lake [m] + + real(r8), allocatable :: dz_sno_roof_ (:,:) !interface depth of roof [m] + real(r8), allocatable :: dz_sno_gimp_ (:,:) !interface depth of impervious [m] + real(r8), allocatable :: dz_sno_gper_ (:,:) !interface depth pervious [m] + real(r8), allocatable :: dz_sno_lake_ (:,:) !interface depth lake [m] + + real(r8), allocatable :: troof_inner_ (:) !temperature of roof [K] + real(r8), allocatable :: twsun_inner_ (:) !temperature of sunlit wall [K] + real(r8), allocatable :: twsha_inner_ (:) !temperature of shaded wall [K] + + real(r8), allocatable :: t_roofsno_ (:,:) !temperature of roof [K] + real(r8), allocatable :: t_wallsun_ (:,:) !temperature of sunlit wall [K] + real(r8), allocatable :: t_wallsha_ (:,:) !temperature of shaded wall [K] + real(r8), allocatable :: t_gimpsno_ (:,:) !temperature of impervious [K] + real(r8), allocatable :: t_gpersno_ (:,:) !temperature of pervious [K] + real(r8), allocatable :: t_lakesno_ (:,:) !temperature of pervious [K] + + real(r8), allocatable :: wliq_roofsno_(:,:) !liquid water in layers [kg/m2] + real(r8), allocatable :: wliq_gimpsno_(:,:) !liquid water in layers [kg/m2] + real(r8), allocatable :: wliq_gpersno_(:,:) !liquid water in layers [kg/m2] + real(r8), allocatable :: wliq_lakesno_(:,:) !liquid water in layers [kg/m2] + real(r8), allocatable :: wice_roofsno_(:,:) !ice lens in layers [kg/m2] + real(r8), allocatable :: wice_gimpsno_(:,:) !ice lens in layers [kg/m2] + real(r8), allocatable :: wice_gpersno_(:,:) !ice lens in layers [kg/m2] + real(r8), allocatable :: wice_lakesno_(:,:) !ice lens in layers [kg/m2] + + real(r8), allocatable :: sag_roof_ (:) !roof snow age [-] + real(r8), allocatable :: sag_gimp_ (:) !impervious ground snow age [-] + real(r8), allocatable :: sag_gper_ (:) !pervious ground snow age [-] + real(r8), allocatable :: sag_lake_ (:) !urban lake snow age [-] + + real(r8), allocatable :: scv_roof_ (:) !roof snow cover [-] + real(r8), allocatable :: scv_gimp_ (:) !impervious ground snow cover [-] + real(r8), allocatable :: scv_gper_ (:) !pervious ground snow cover [-] + real(r8), allocatable :: scv_lake_ (:) !urban lake snow cover [-] + + real(r8), allocatable :: fsno_roof_ (:) !roof snow fraction [-] + real(r8), allocatable :: fsno_gimp_ (:) !impervious ground snow fraction [-] + real(r8), allocatable :: fsno_gper_ (:) !pervious ground snow fraction [-] + real(r8), allocatable :: fsno_lake_ (:) !urban lake snow fraction [-] + + real(r8), allocatable :: snowdp_roof_ (:) !roof snow depth [m] + real(r8), allocatable :: snowdp_gimp_ (:) !impervious ground snow depth [m] + real(r8), allocatable :: snowdp_gper_ (:) !pervious ground snow depth [m] + real(r8), allocatable :: snowdp_lake_ (:) !urban lake snow depth [m] + + !TODO: condsider renaming the below variables + real(r8), allocatable :: Fhac_ (:) !sensible flux from heat or cool AC [W/m2] + real(r8), allocatable :: Fwst_ (:) !waste heat flux from heat or cool AC [W/m2] + real(r8), allocatable :: Fach_ (:) !flux from inner and outter air exchange [W/m2] + real(r8), allocatable :: Fahe_ (:) !flux from metabolism and vehicle [W/m2] + real(r8), allocatable :: Fhah_ (:) !sensible heat flux from heating [W/m2] + real(r8), allocatable :: vehc_ (:) !flux from vehicle [W/m2] + real(r8), allocatable :: meta_ (:) !flux from metabolism [W/m2] + + real(r8), allocatable :: t_room_ (:) !temperature of inner building [K] + real(r8), allocatable :: t_roof_ (:) !temperature of roof [K] + real(r8), allocatable :: t_wall_ (:) !temperature of wall [K] + real(r8), allocatable :: tafu_ (:) !temperature of outer building [K] + + real(r8), allocatable :: urb_green_ (:) !fractional of green leaf in urban patch [-] ! PUBLIC MEMBER FUNCTIONS: - PUBLIC :: allocate_LulccTimeVariables - PUBLIC :: deallocate_LulccTimeVariables - PUBLIC :: SAVE_LulccTimeVariables - PUBLIC :: REST_LulccTimeVariables + PUBLIC :: allocate_LulccTimeVariables + PUBLIC :: deallocate_LulccTimeVariables + PUBLIC :: SAVE_LulccTimeVariables + PUBLIC :: REST_LulccTimeVariables ! PRIVATE MEMBER FUNCTIONS: !----------------------------------------------------------------------- - CONTAINS +CONTAINS !----------------------------------------------------------------------- - SUBROUTINE allocate_LulccTimeVariables - ! -------------------------------------------------------------------- - ! Allocates memory for Lulcc time variant variables - ! -------------------------------------------------------------------- + SUBROUTINE allocate_LulccTimeVariables + ! -------------------------------------------------------------------- + ! Allocates memory for Lulcc time variant variables + ! -------------------------------------------------------------------- - USE MOD_SPMD_Task - USE MOD_Precision - USE MOD_Vars_Global - USE MOD_LandPatch + USE MOD_SPMD_Task + USE MOD_Precision + USE MOD_Vars_Global + USE MOD_LandPatch #if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) - USE MOD_Vars_PFTimeVariables - USE MOD_LandPFT + USE MOD_Vars_PFTimeVariables + USE MOD_LandPFT #endif #ifdef URBAN_MODEL - USE MOD_Urban_Vars_TimeVariables - USE MOD_LandUrban + USE MOD_Urban_Vars_TimeVariables + USE MOD_LandUrban #endif - IMPLICIT NONE - - IF (p_is_worker) THEN - IF (numpatch > 0) THEN - allocate (z_sno_ (maxsnl+1:0,numpatch)) - allocate (dz_sno_ (maxsnl+1:0,numpatch)) - allocate (t_soisno_ (maxsnl+1:nl_soil,numpatch)) - allocate (wliq_soisno_ (maxsnl+1:nl_soil,numpatch)) - allocate (wice_soisno_ (maxsnl+1:nl_soil,numpatch)) - allocate (smp_ (1:nl_soil,numpatch)) - allocate (hk_ (1:nl_soil,numpatch)) - allocate (t_grnd_ (numpatch)) - allocate (tleaf_ (numpatch)) - allocate (ldew_ (numpatch)) - allocate (ldew_rain_ (numpatch)) - allocate (ldew_snow_ (numpatch)) - allocate (sag_ (numpatch)) - allocate (scv_ (numpatch)) - allocate (snowdp_ (numpatch)) - allocate (fsno_ (numpatch)) - allocate (sigf_ (numpatch)) - allocate (zwt_ (numpatch)) - allocate (wa_ (numpatch)) - allocate (wdsrf_ (numpatch)) - allocate (rss_ (numpatch)) - - allocate (t_lake_ (nl_lake,numpatch)) - allocate (lake_icefrac_ (nl_lake,numpatch)) - allocate (savedtke1_ (numpatch)) - - !Plant Hydraulic variables - allocate (vegwp_ (1:nvegwcs,numpatch)) - allocate (gs0sun_ (numpatch)) - allocate (gs0sha_ (numpatch)) - !END plant hydraulic variables - - !Ozone Stress variables - allocate (lai_old_ (numpatch)) - allocate (o3uptakesun_ (numpatch)) - allocate (o3uptakesha_ (numpatch)) - !End ozone stress variables - - allocate (snw_rds_ (maxsnl+1:0,numpatch)) - allocate (mss_bcpho_ (maxsnl+1:0,numpatch)) - allocate (mss_bcphi_ (maxsnl+1:0,numpatch)) - allocate (mss_ocpho_ (maxsnl+1:0,numpatch)) - allocate (mss_ocphi_ (maxsnl+1:0,numpatch)) - allocate (mss_dst1_ (maxsnl+1:0,numpatch)) - allocate (mss_dst2_ (maxsnl+1:0,numpatch)) - allocate (mss_dst3_ (maxsnl+1:0,numpatch)) - allocate (mss_dst4_ (maxsnl+1:0,numpatch)) - allocate (ssno_lyr_ (2,2,maxsnl+1:1,numpatch)) - - allocate (trad_ (numpatch)) - allocate (tref_ (numpatch)) - allocate (qref_ (numpatch)) - allocate (rst_ (numpatch)) - allocate (emis_ (numpatch)) - allocate (z0m_ (numpatch)) - allocate (zol_ (numpatch)) - allocate (rib_ (numpatch)) - allocate (ustar_ (numpatch)) - allocate (qstar_ (numpatch)) - allocate (tstar_ (numpatch)) - allocate (fm_ (numpatch)) - allocate (fh_ (numpatch)) - allocate (fq_ (numpatch)) - - allocate (sum_irrig_ (numpatch)) - allocate (sum_irrig_count_ (numpatch)) - ENDIF + IMPLICIT NONE + + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + allocate (z_sno_ (maxsnl+1:0,numpatch)) + allocate (dz_sno_ (maxsnl+1:0,numpatch)) + allocate (t_soisno_ (maxsnl+1:nl_soil,numpatch)) + allocate (wliq_soisno_ (maxsnl+1:nl_soil,numpatch)) + allocate (wice_soisno_ (maxsnl+1:nl_soil,numpatch)) + allocate (smp_ (1:nl_soil,numpatch)) + allocate (hk_ (1:nl_soil,numpatch)) + allocate (t_grnd_ (numpatch)) + allocate (tleaf_ (numpatch)) + allocate (ldew_ (numpatch)) + allocate (ldew_rain_ (numpatch)) + allocate (ldew_snow_ (numpatch)) + allocate (sag_ (numpatch)) + allocate (scv_ (numpatch)) + allocate (snowdp_ (numpatch)) + allocate (fsno_ (numpatch)) + allocate (sigf_ (numpatch)) + allocate (zwt_ (numpatch)) + allocate (wa_ (numpatch)) + allocate (wdsrf_ (numpatch)) + allocate (rss_ (numpatch)) + + allocate (t_lake_ (nl_lake,numpatch)) + allocate (lake_icefrac_ (nl_lake,numpatch)) + allocate (savedtke1_ (numpatch)) + + !Plant Hydraulic variables + allocate (vegwp_ (1:nvegwcs,numpatch)) + allocate (gs0sun_ (numpatch)) + allocate (gs0sha_ (numpatch)) + !END plant hydraulic variables + + !Ozone Stress variables + allocate (lai_old_ (numpatch)) + allocate (o3uptakesun_ (numpatch)) + allocate (o3uptakesha_ (numpatch)) + !End ozone stress variables + + allocate (snw_rds_ (maxsnl+1:0,numpatch)) + allocate (mss_bcpho_ (maxsnl+1:0,numpatch)) + allocate (mss_bcphi_ (maxsnl+1:0,numpatch)) + allocate (mss_ocpho_ (maxsnl+1:0,numpatch)) + allocate (mss_ocphi_ (maxsnl+1:0,numpatch)) + allocate (mss_dst1_ (maxsnl+1:0,numpatch)) + allocate (mss_dst2_ (maxsnl+1:0,numpatch)) + allocate (mss_dst3_ (maxsnl+1:0,numpatch)) + allocate (mss_dst4_ (maxsnl+1:0,numpatch)) + allocate (ssno_lyr_ (2,2,maxsnl+1:1,numpatch)) + + allocate (trad_ (numpatch)) + allocate (tref_ (numpatch)) + allocate (qref_ (numpatch)) + allocate (rst_ (numpatch)) + allocate (emis_ (numpatch)) + allocate (z0m_ (numpatch)) + allocate (zol_ (numpatch)) + allocate (rib_ (numpatch)) + allocate (ustar_ (numpatch)) + allocate (qstar_ (numpatch)) + allocate (tstar_ (numpatch)) + allocate (fm_ (numpatch)) + allocate (fh_ (numpatch)) + allocate (fq_ (numpatch)) + + allocate (sum_irrig_ (numpatch)) + allocate (sum_irrig_count_ (numpatch)) + ENDIF #if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) - IF (numpft > 0) THEN - allocate (tleaf_p_ (numpft)) - allocate (ldew_p_ (numpft)) - allocate (ldew_rain_p_ (numpft)) - allocate (ldew_snow_p_ (numpft)) - allocate (sigf_p_ (numpft)) - allocate (tref_p_ (numpft)) - allocate (qref_p_ (numpft)) - allocate (rst_p_ (numpft)) - allocate (z0m_p_ (numpft)) - - ! Plant Hydraulic variables - allocate (vegwp_p_ (1:nvegwcs,numpft)) - allocate (gs0sun_p_ (numpft)) - allocate (gs0sha_p_ (numpft)) - ! end plant hydraulic variables - - ! Allocate Ozone Stress Variables - allocate (lai_old_p_ (numpft)) - allocate (o3uptakesun_p_ (numpft)) - allocate (o3uptakesha_p_ (numpft)) - ! End allocate Ozone Stress Variables - ENDIF + IF (numpft > 0) THEN + allocate (tleaf_p_ (numpft)) + allocate (ldew_p_ (numpft)) + allocate (ldew_rain_p_ (numpft)) + allocate (ldew_snow_p_ (numpft)) + allocate (sigf_p_ (numpft)) + allocate (tref_p_ (numpft)) + allocate (qref_p_ (numpft)) + allocate (rst_p_ (numpft)) + allocate (z0m_p_ (numpft)) + + ! Plant Hydraulic variables + allocate (vegwp_p_ (1:nvegwcs,numpft)) + allocate (gs0sun_p_ (numpft)) + allocate (gs0sha_p_ (numpft)) + ! end plant hydraulic variables + + ! Allocate Ozone Stress Variables + allocate (lai_old_p_ (numpft)) + allocate (o3uptakesun_p_ (numpft)) + allocate (o3uptakesha_p_ (numpft)) + ! End allocate Ozone Stress Variables + ENDIF #endif #ifdef URBAN_MODEL - IF (numurban > 0) THEN - allocate (fwsun_ (numurban)) - allocate (dfwsun_ (numurban)) - - allocate (sroof_ (2,2,numurban)) - allocate (swsun_ (2,2,numurban)) - allocate (swsha_ (2,2,numurban)) - allocate (sgimp_ (2,2,numurban)) - allocate (sgper_ (2,2,numurban)) - allocate (slake_ (2,2,numurban)) - - allocate (lwsun_ (numurban)) - allocate (lwsha_ (numurban)) - allocate (lgimp_ (numurban)) - allocate (lgper_ (numurban)) - allocate (lveg_ (numurban)) - - allocate (z_sno_roof_ (maxsnl+1:0,numurban)) - allocate (z_sno_gimp_ (maxsnl+1:0,numurban)) - allocate (z_sno_gper_ (maxsnl+1:0,numurban)) - allocate (z_sno_lake_ (maxsnl+1:0,numurban)) - - allocate (dz_sno_roof_ (maxsnl+1:0,numurban)) - allocate (dz_sno_gimp_ (maxsnl+1:0,numurban)) - allocate (dz_sno_gper_ (maxsnl+1:0,numurban)) - allocate (dz_sno_lake_ (maxsnl+1:0,numurban)) - - allocate (t_roofsno_ (maxsnl+1:nl_roof,numurban)) - allocate (t_wallsun_ (maxsnl+1:nl_wall,numurban)) - allocate (t_wallsha_ (maxsnl+1:nl_wall,numurban)) - allocate (t_gimpsno_ (maxsnl+1:nl_soil,numurban)) - allocate (t_gpersno_ (maxsnl+1:nl_soil,numurban)) - allocate (t_lakesno_ (maxsnl+1:nl_soil,numurban)) - - allocate (troof_inner_ (numurban)) - allocate (twsun_inner_ (numurban)) - allocate (twsha_inner_ (numurban)) - - allocate (wliq_roofsno_(maxsnl+1:nl_roof,numurban)) - allocate (wice_roofsno_(maxsnl+1:nl_roof,numurban)) - allocate (wliq_gimpsno_(maxsnl+1:nl_soil,numurban)) - allocate (wice_gimpsno_(maxsnl+1:nl_soil,numurban)) - allocate (wliq_gpersno_(maxsnl+1:nl_soil,numurban)) - allocate (wice_gpersno_(maxsnl+1:nl_soil,numurban)) - allocate (wliq_lakesno_(maxsnl+1:nl_soil,numurban)) - allocate (wice_lakesno_(maxsnl+1:nl_soil,numurban)) - - allocate (sag_roof_ (numurban)) - allocate (sag_gimp_ (numurban)) - allocate (sag_gper_ (numurban)) - allocate (sag_lake_ (numurban)) - allocate (scv_roof_ (numurban)) - allocate (scv_gimp_ (numurban)) - allocate (scv_gper_ (numurban)) - allocate (scv_lake_ (numurban)) - allocate (fsno_roof_ (numurban)) - allocate (fsno_gimp_ (numurban)) - allocate (fsno_gper_ (numurban)) - allocate (fsno_lake_ (numurban)) - allocate (snowdp_roof_ (numurban)) - allocate (snowdp_gimp_ (numurban)) - allocate (snowdp_gper_ (numurban)) - allocate (snowdp_lake_ (numurban)) - - allocate (Fhac_ (numurban)) - allocate (Fwst_ (numurban)) - allocate (Fach_ (numurban)) - allocate (Fahe_ (numurban)) - allocate (Fhah_ (numurban)) - allocate (vehc_ (numurban)) - allocate (meta_ (numurban)) - allocate (t_room_ (numurban)) - allocate (t_roof_ (numurban)) - allocate (t_wall_ (numurban)) - allocate (tafu_ (numurban)) - allocate (urb_green_ (numurban)) - ENDIF + IF (numurban > 0) THEN + allocate (fwsun_ (numurban)) + allocate (dfwsun_ (numurban)) + + allocate (sroof_ (2,2,numurban)) + allocate (swsun_ (2,2,numurban)) + allocate (swsha_ (2,2,numurban)) + allocate (sgimp_ (2,2,numurban)) + allocate (sgper_ (2,2,numurban)) + allocate (slake_ (2,2,numurban)) + + allocate (lwsun_ (numurban)) + allocate (lwsha_ (numurban)) + allocate (lgimp_ (numurban)) + allocate (lgper_ (numurban)) + allocate (lveg_ (numurban)) + + allocate (z_sno_roof_ (maxsnl+1:0,numurban)) + allocate (z_sno_gimp_ (maxsnl+1:0,numurban)) + allocate (z_sno_gper_ (maxsnl+1:0,numurban)) + allocate (z_sno_lake_ (maxsnl+1:0,numurban)) + + allocate (dz_sno_roof_ (maxsnl+1:0,numurban)) + allocate (dz_sno_gimp_ (maxsnl+1:0,numurban)) + allocate (dz_sno_gper_ (maxsnl+1:0,numurban)) + allocate (dz_sno_lake_ (maxsnl+1:0,numurban)) + + allocate (t_roofsno_ (maxsnl+1:nl_roof,numurban)) + allocate (t_wallsun_ (maxsnl+1:nl_wall,numurban)) + allocate (t_wallsha_ (maxsnl+1:nl_wall,numurban)) + allocate (t_gimpsno_ (maxsnl+1:nl_soil,numurban)) + allocate (t_gpersno_ (maxsnl+1:nl_soil,numurban)) + allocate (t_lakesno_ (maxsnl+1:nl_soil,numurban)) + + allocate (troof_inner_ (numurban)) + allocate (twsun_inner_ (numurban)) + allocate (twsha_inner_ (numurban)) + + allocate (wliq_roofsno_(maxsnl+1:nl_roof,numurban)) + allocate (wice_roofsno_(maxsnl+1:nl_roof,numurban)) + allocate (wliq_gimpsno_(maxsnl+1:nl_soil,numurban)) + allocate (wice_gimpsno_(maxsnl+1:nl_soil,numurban)) + allocate (wliq_gpersno_(maxsnl+1:nl_soil,numurban)) + allocate (wice_gpersno_(maxsnl+1:nl_soil,numurban)) + allocate (wliq_lakesno_(maxsnl+1:nl_soil,numurban)) + allocate (wice_lakesno_(maxsnl+1:nl_soil,numurban)) + + allocate (sag_roof_ (numurban)) + allocate (sag_gimp_ (numurban)) + allocate (sag_gper_ (numurban)) + allocate (sag_lake_ (numurban)) + allocate (scv_roof_ (numurban)) + allocate (scv_gimp_ (numurban)) + allocate (scv_gper_ (numurban)) + allocate (scv_lake_ (numurban)) + allocate (fsno_roof_ (numurban)) + allocate (fsno_gimp_ (numurban)) + allocate (fsno_gper_ (numurban)) + allocate (fsno_lake_ (numurban)) + allocate (snowdp_roof_ (numurban)) + allocate (snowdp_gimp_ (numurban)) + allocate (snowdp_gper_ (numurban)) + allocate (snowdp_lake_ (numurban)) + + allocate (Fhac_ (numurban)) + allocate (Fwst_ (numurban)) + allocate (Fach_ (numurban)) + allocate (Fahe_ (numurban)) + allocate (Fhah_ (numurban)) + allocate (vehc_ (numurban)) + allocate (meta_ (numurban)) + allocate (t_room_ (numurban)) + allocate (t_roof_ (numurban)) + allocate (t_wall_ (numurban)) + allocate (tafu_ (numurban)) + allocate (urb_green_ (numurban)) + ENDIF #endif - ENDIF - END SUBROUTINE allocate_LulccTimeVariables + ENDIF + END SUBROUTINE allocate_LulccTimeVariables - SUBROUTINE SAVE_LulccTimeVariables + SUBROUTINE SAVE_LulccTimeVariables - USE MOD_Precision - USE MOD_SPMD_Task - USE MOD_Vars_Global - USE MOD_Vars_TimeVariables + USE MOD_Precision + USE MOD_SPMD_Task + USE MOD_Vars_Global + USE MOD_Vars_TimeVariables #if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) - USE MOD_Vars_PFTimeVariables + USE MOD_Vars_PFTimeVariables #endif #ifdef URBAN_MODEL - USE MOD_Urban_Vars_TimeVariables + USE MOD_Urban_Vars_TimeVariables #endif - IMPLICIT NONE - - IF (p_is_worker) THEN - z_sno_ = z_sno - dz_sno_ = dz_sno - t_soisno_ = t_soisno - wliq_soisno_ = wliq_soisno - wice_soisno_ = wice_soisno - smp_ = smp - hk_ = hk - t_grnd_ = t_grnd - tleaf_ = tleaf - ldew_ = ldew - ldew_rain_ = ldew_rain - ldew_snow_ = ldew_snow - sag_ = sag - scv_ = scv - snowdp_ = snowdp - fsno_ = fsno - sigf_ = sigf - zwt_ = zwt - wa_ = wa - wdsrf_ = wdsrf - rss_ = rss - - t_lake_ = t_lake - lake_icefrac_ = lake_icefrac - savedtke1_ = savedtke1 + IMPLICIT NONE + + IF (p_is_worker) THEN + z_sno_ = z_sno + dz_sno_ = dz_sno + t_soisno_ = t_soisno + wliq_soisno_ = wliq_soisno + wice_soisno_ = wice_soisno + smp_ = smp + hk_ = hk + t_grnd_ = t_grnd + tleaf_ = tleaf + ldew_ = ldew + ldew_rain_ = ldew_rain + ldew_snow_ = ldew_snow + sag_ = sag + scv_ = scv + snowdp_ = snowdp + fsno_ = fsno + sigf_ = sigf + zwt_ = zwt + wa_ = wa + wdsrf_ = wdsrf + rss_ = rss + + t_lake_ = t_lake + lake_icefrac_ = lake_icefrac + savedtke1_ = savedtke1 IF(DEF_USE_PLANTHYDRAULICS)THEN - vegwp_ = vegwp - gs0sun_ = gs0sun - gs0sha_ = gs0sha + vegwp_ = vegwp + gs0sun_ = gs0sun + gs0sha_ = gs0sha ENDIF IF(DEF_USE_OZONESTRESS)THEN - lai_old_ = lai_old - o3uptakesun_ = o3uptakesun - o3uptakesha_ = o3uptakesha + lai_old_ = lai_old + o3uptakesun_ = o3uptakesun + o3uptakesha_ = o3uptakesha ENDIF - snw_rds_ = snw_rds - mss_bcpho_ = mss_bcpho - mss_bcphi_ = mss_bcphi - mss_ocpho_ = mss_ocpho - mss_ocphi_ = mss_ocphi - mss_dst1_ = mss_dst1 - mss_dst2_ = mss_dst2 - mss_dst3_ = mss_dst3 - mss_dst4_ = mss_dst4 - ssno_lyr_ = ssno_lyr - - trad_ = trad - tref_ = tref - qref_ = qref - rst_ = rst - emis_ = emis - z0m_ = z0m - displa_ = displa - zol_ = zol - rib_ = rib - ustar_ = ustar - qstar_ = qstar - tstar_ = tstar - fm_ = fm - fh_ = fh - fq_ = fq + snw_rds_ = snw_rds + mss_bcpho_ = mss_bcpho + mss_bcphi_ = mss_bcphi + mss_ocpho_ = mss_ocpho + mss_ocphi_ = mss_ocphi + mss_dst1_ = mss_dst1 + mss_dst2_ = mss_dst2 + mss_dst3_ = mss_dst3 + mss_dst4_ = mss_dst4 + ssno_lyr_ = ssno_lyr + + trad_ = trad + tref_ = tref + qref_ = qref + rst_ = rst + emis_ = emis + z0m_ = z0m + displa_ = displa + zol_ = zol + rib_ = rib + ustar_ = ustar + qstar_ = qstar + tstar_ = tstar + fm_ = fm + fh_ = fh + fq_ = fq IF (DEF_USE_IRRIGATION) THEN - sum_irrig_ = sum_irrig - sum_irrig_count_ = sum_irrig_count + sum_irrig_ = sum_irrig + sum_irrig_count_ = sum_irrig_count ENDIF #if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) - tleaf_p_ = tleaf_p - ldew_p_ = ldew_p - ldew_rain_p_ = ldew_rain_p - ldew_snow_p_ = ldew_snow_p - sigf_p_ = sigf_p - - tref_p_ = tref_p - qref_p_ = qref_p - rst_p_ = rst_p - z0m_p_ = z0m_p + tleaf_p_ = tleaf_p + ldew_p_ = ldew_p + ldew_rain_p_ = ldew_rain_p + ldew_snow_p_ = ldew_snow_p + sigf_p_ = sigf_p + + tref_p_ = tref_p + qref_p_ = qref_p + rst_p_ = rst_p + z0m_p_ = z0m_p IF(DEF_USE_PLANTHYDRAULICS)THEN - ! Plant Hydraulic variables - vegwp_p_ = vegwp_p - gs0sun_p_ = gs0sun_p - gs0sha_p_ = gs0sha_p - ! end plant hydraulic variables + ! Plant Hydraulic variables + vegwp_p_ = vegwp_p + gs0sun_p_ = gs0sun_p + gs0sha_p_ = gs0sha_p + ! end plant hydraulic variables ENDIF IF(DEF_USE_OZONESTRESS)THEN - ! Ozone Stress Variables - lai_old_p_ = lai_old_p - o3uptakesun_p_ = o3uptakesun_p - o3uptakesha_p_ = o3uptakesha_p - ! End allocate Ozone Stress Variables + ! Ozone Stress Variables + lai_old_p_ = lai_old_p + o3uptakesun_p_ = o3uptakesun_p + o3uptakesha_p_ = o3uptakesha_p + ! End allocate Ozone Stress Variables ENDIF #endif #ifdef URBAN_MODEL - fwsun_ = fwsun - dfwsun_ = dfwsun - - sroof_ = sroof - swsun_ = swsun - swsha_ = swsha - sgimp_ = sgimp - sgper_ = sgper - slake_ = slake - - lwsun_ = lwsun - lwsha_ = lwsha - lgimp_ = lgimp - lgper_ = lgper - lveg_ = lveg - - z_sno_roof_ = z_sno_roof - z_sno_gimp_ = z_sno_gimp - z_sno_gper_ = z_sno_gper - z_sno_lake_ = z_sno_lake - - dz_sno_roof_ = dz_sno_roof - dz_sno_gimp_ = dz_sno_gimp - dz_sno_gper_ = dz_sno_gper - dz_sno_lake_ = dz_sno_lake - - t_roofsno_ = t_roofsno - t_wallsun_ = t_wallsun - t_wallsha_ = t_wallsha - t_gimpsno_ = t_gimpsno - t_gpersno_ = t_gpersno - t_lakesno_ = t_lakesno - - troof_inner_ = troof_inner - twsun_inner_ = twsun_inner - twsha_inner_ = twsha_inner - - wliq_roofsno_ = wliq_roofsno - wice_roofsno_ = wice_roofsno - wliq_gimpsno_ = wliq_gimpsno - wice_gimpsno_ = wice_gimpsno - wliq_gpersno_ = wliq_gpersno - wice_gpersno_ = wice_gpersno - wliq_lakesno_ = wliq_lakesno - wice_lakesno_ = wice_lakesno - - sag_roof_ = sag_roof - sag_gimp_ = sag_gimp - sag_gper_ = sag_gper - sag_lake_ = sag_lake - scv_roof_ = scv_roof - scv_gimp_ = scv_gimp - scv_gper_ = scv_gper - scv_lake_ = scv_lake - fsno_roof_ = fsno_roof - fsno_gimp_ = fsno_gimp - fsno_gper_ = fsno_gper - fsno_lake_ = fsno_lake - snowdp_roof_ = snowdp_roof - snowdp_gimp_ = snowdp_gimp - snowdp_gper_ = snowdp_gper - snowdp_lake_ = snowdp_lake - - Fhac_ = Fhac - Fwst_ = Fwst - Fach_ = Fach - Fahe_ = Fahe - Fhah_ = Fhah - vehc_ = vehc - meta_ = meta - t_room_ = t_room - t_roof_ = t_roof - t_wall_ = t_wall - tafu_ = tafu - urb_green_ = urb_green + fwsun_ = fwsun + dfwsun_ = dfwsun + + sroof_ = sroof + swsun_ = swsun + swsha_ = swsha + sgimp_ = sgimp + sgper_ = sgper + slake_ = slake + + lwsun_ = lwsun + lwsha_ = lwsha + lgimp_ = lgimp + lgper_ = lgper + lveg_ = lveg + + z_sno_roof_ = z_sno_roof + z_sno_gimp_ = z_sno_gimp + z_sno_gper_ = z_sno_gper + z_sno_lake_ = z_sno_lake + + dz_sno_roof_ = dz_sno_roof + dz_sno_gimp_ = dz_sno_gimp + dz_sno_gper_ = dz_sno_gper + dz_sno_lake_ = dz_sno_lake + + t_roofsno_ = t_roofsno + t_wallsun_ = t_wallsun + t_wallsha_ = t_wallsha + t_gimpsno_ = t_gimpsno + t_gpersno_ = t_gpersno + t_lakesno_ = t_lakesno + + troof_inner_ = troof_inner + twsun_inner_ = twsun_inner + twsha_inner_ = twsha_inner + + wliq_roofsno_ = wliq_roofsno + wice_roofsno_ = wice_roofsno + wliq_gimpsno_ = wliq_gimpsno + wice_gimpsno_ = wice_gimpsno + wliq_gpersno_ = wliq_gpersno + wice_gpersno_ = wice_gpersno + wliq_lakesno_ = wliq_lakesno + wice_lakesno_ = wice_lakesno + + sag_roof_ = sag_roof + sag_gimp_ = sag_gimp + sag_gper_ = sag_gper + sag_lake_ = sag_lake + scv_roof_ = scv_roof + scv_gimp_ = scv_gimp + scv_gper_ = scv_gper + scv_lake_ = scv_lake + fsno_roof_ = fsno_roof + fsno_gimp_ = fsno_gimp + fsno_gper_ = fsno_gper + fsno_lake_ = fsno_lake + snowdp_roof_ = snowdp_roof + snowdp_gimp_ = snowdp_gimp + snowdp_gper_ = snowdp_gper + snowdp_lake_ = snowdp_lake + + Fhac_ = Fhac + Fwst_ = Fwst + Fach_ = Fach + Fahe_ = Fahe + Fhah_ = Fhah + vehc_ = vehc + meta_ = meta + t_room_ = t_room + t_roof_ = t_roof + t_wall_ = t_wall + tafu_ = tafu + urb_green_ = urb_green #endif - ENDIF + ENDIF - END SUBROUTINE SAVE_LulccTimeVariables + END SUBROUTINE SAVE_LulccTimeVariables - SUBROUTINE REST_LulccTimeVariables + SUBROUTINE REST_LulccTimeVariables - USE MOD_SPMD_Task - USE MOD_Precision - USE MOD_Vars_Global - USE MOD_LandPatch - USE MOD_LandElm - USE MOD_Mesh - USE MOD_Vars_TimeInvariants - USE MOD_Vars_TimeVariables - USE MOD_Lulcc_Vars_TimeInvariants + USE MOD_SPMD_Task + USE MOD_Precision + USE MOD_Vars_Global + USE MOD_LandPatch + USE MOD_LandElm + USE MOD_Mesh + USE MOD_Vars_TimeInvariants + USE MOD_Vars_TimeVariables + USE MOD_Lulcc_Vars_TimeInvariants #if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) - USE MOD_Vars_PFTimeInvariants - USE MOD_Vars_PFTimeVariables - USE MOD_LandPFT + USE MOD_Vars_PFTimeInvariants + USE MOD_Vars_PFTimeVariables + USE MOD_LandPFT #endif #ifdef URBAN_MODEL - USE MOD_Urban_Vars_TimeVariables - USE MOD_LandUrban + USE MOD_Urban_Vars_TimeVariables + USE MOD_LandUrban #endif - IMPLICIT NONE - - real(r8), allocatable, dimension(:) :: grid_patch_s , grid_patch_e - real(r8), allocatable, dimension(:) :: grid_patch_s_, grid_patch_e_ - integer , allocatable, dimension(:) :: locpxl - integer i, j, np, np_, ip, ip_, pc, pc_, u, u_ - integer ps, ps_, pe, pe_ - integer numpxl, ipxl - - IF (p_is_worker) THEN - ! allocate with numelm - allocate(grid_patch_s (numelm )) - allocate(grid_patch_e (numelm )) - allocate(grid_patch_s_(numelm_)) - allocate(grid_patch_e_(numelm_)) - - grid_patch_e (:) = -1. - grid_patch_s (:) = -1. - grid_patch_e_(:) = -1. - grid_patch_s_(:) = -1. - - ! loop for numelm of next year, patches at the beginning and end of - ! the element were recorded landpatch%eindex is arranged in order, - ! and the not land element is skipped so, if element is missing, the - ! recorder is -1. - DO i=1, numelm - ! how many patches in ith element in this worker - numpxl = count(landpatch%eindex==landelm%eindex(i)) - - IF (allocated(locpxl)) deallocate(locpxl) - allocate(locpxl(numpxl)) - - ! get all patches' index that eindex is equal the i element - locpxl = pack([(ipxl, ipxl=1, numpatch)], & - landpatch%eindex==landelm%eindex(i)) - ! the min index is the start of patch's index - grid_patch_s(i) = minval(locpxl) - ! the max index is the end of patch's index - grid_patch_e(i) = maxval(locpxl) - ENDDO - - ! same as above, loop for numelm of previous year - ! patches at the beginning and end of the element were recorded - DO i=1, numelm_ - numpxl = count(landpatch_%eindex==landelm_%eindex(i)) - - IF (allocated(locpxl)) deallocate(locpxl) - allocate(locpxl(numpxl)) - - locpxl = pack([(ipxl, ipxl=1, numpatch_)], & - landpatch_%eindex==landelm_%eindex(i)) - - grid_patch_s_(i) = minval(locpxl) - grid_patch_e_(i) = maxval(locpxl) - ENDDO - - ! loop for element - ! print*, 'minelm is', minelm, 'maxelm is', maxelm - DO i=1, numelm - DO j=1,numelm_ - IF (landelm%eindex(i) == landelm_%eindex(j)) THEN - np = grid_patch_s (i) - np_= grid_patch_s_(j) - - IF (np.le.0 .or. np_.le.0) CYCLE - - ! if element is still present, loop for patches in same element - DO WHILE (np.le.grid_patch_e(i) .and. np_.le.grid_patch_e_(j)) - - ! if a patch is missing, CYCLE - IF (patchclass(np) > patchclass_(np_)) THEN - np_= np_+ 1 - CYCLE - ENDIF - - ! if a patch is added, CYCLE - IF (patchclass(np) < patchclass_(np_)) THEN - np = np + 1 - CYCLE - ENDIF + IMPLICIT NONE + + real(r8), allocatable, dimension(:) :: grid_patch_s , grid_patch_e + real(r8), allocatable, dimension(:) :: grid_patch_s_, grid_patch_e_ + integer , allocatable, dimension(:) :: locpxl + integer i, j, np, np_, ip, ip_, pc, pc_, u, u_ + integer ps, ps_, pe, pe_ + integer numpxl, ipxl + + IF (p_is_worker) THEN + ! allocate with numelm + allocate(grid_patch_s (numelm )) + allocate(grid_patch_e (numelm )) + allocate(grid_patch_s_(numelm_)) + allocate(grid_patch_e_(numelm_)) + + grid_patch_e (:) = -1. + grid_patch_s (:) = -1. + grid_patch_e_(:) = -1. + grid_patch_s_(:) = -1. + + ! loop for numelm of next year, patches at the beginning and end of + ! the element were recorded landpatch%eindex is arranged in order, + ! and the not land element is skipped so, IF element is missing, the + ! recorder is -1. + DO i=1, numelm + ! how many patches in ith element in this worker + numpxl = count(landpatch%eindex==landelm%eindex(i)) + + IF (allocated(locpxl)) deallocate(locpxl) + allocate(locpxl(numpxl)) + + ! get all patches' index that eindex is equal the i element + locpxl = pack([(ipxl, ipxl=1, numpatch)], & + landpatch%eindex==landelm%eindex(i)) + ! the min index is the start of patch's index + grid_patch_s(i) = minval(locpxl) + ! the max index is the end of patch's index + grid_patch_e(i) = maxval(locpxl) + ENDDO + + ! same as above, loop for numelm of previous year + ! patches at the beginning and end of the element were recorded + DO i=1, numelm_ + numpxl = count(landpatch_%eindex==landelm_%eindex(i)) + + IF (allocated(locpxl)) deallocate(locpxl) + allocate(locpxl(numpxl)) + + locpxl = pack([(ipxl, ipxl=1, numpatch_)], & + landpatch_%eindex==landelm_%eindex(i)) + + grid_patch_s_(i) = minval(locpxl) + grid_patch_e_(i) = maxval(locpxl) + ENDDO + + ! loop for element + ! print*, 'minelm is', minelm, 'maxelm is', maxelm + DO i=1, numelm + DO j=1,numelm_ + IF (landelm%eindex(i) == landelm_%eindex(j)) THEN + np = grid_patch_s (i) + np_= grid_patch_s_(j) + + IF (np.le.0 .or. np_.le.0) CYCLE + + ! IF element is still present, loop for patches in same element + DO WHILE (np.le.grid_patch_e(i) .and. np_.le.grid_patch_e_(j)) + + ! IF a patch is missing, CYCLE + IF (patchclass(np) > patchclass_(np_)) THEN + np_= np_+ 1 + CYCLE + ENDIF + + ! IF a patch is added, CYCLE + IF (patchclass(np) < patchclass_(np_)) THEN + np = np + 1 + CYCLE + ENDIF #ifdef URBAN_MODEL - u = patch2urban (np ) - u_= patch2urban_(np_) - - ! vars assignment needs same urb class for urban patch - IF (patchclass(np) == URBAN) THEN - ! if a Urban type is missing, CYCLE - IF (landurban%settyp(u) > urbclass_(u_)) THEN - np_= np_+ 1 - CYCLE - ENDIF - - ! if a urban type is added, CYCLE - IF (landurban%settyp(u) < urbclass_(u_)) THEN - np = np + 1 - CYCLE - ENDIF - ENDIF + u = patch2urban (np ) + u_= patch2urban_(np_) + + ! vars assignment needs same urb class for urban patch + IF (patchclass(np) == URBAN) THEN + ! IF a Urban type is missing, CYCLE + IF (landurban%settyp(u) > urbclass_(u_)) THEN + np_= np_+ 1 + CYCLE + ENDIF + + ! IF a urban type is added, CYCLE + IF (landurban%settyp(u) < urbclass_(u_)) THEN + np = np + 1 + CYCLE + ENDIF + ENDIF #endif - ! otherwise, set patch value - ! only for the same patch type - z_sno (:,np) = z_sno_ (:,np_) - dz_sno (:,np) = dz_sno_ (:,np_) - t_soisno (:,np) = t_soisno_ (:,np_) - wliq_soisno (:,np) = wliq_soisno_ (:,np_) - wice_soisno (:,np) = wice_soisno_ (:,np_) - scv (np) = scv_ (np_) - smp (:,np) = smp_ (:,np_) - hk (:,np) = hk_ (:,np_) - t_grnd (np) = t_grnd_ (np_) - tleaf (np) = tleaf_ (np_) - ldew (np) = ldew_ (np_) - ldew_rain (np) = ldew_rain_ (np_) - ldew_snow (np) = ldew_snow_ (np_) - sag (np) = sag_ (np_) - snowdp (np) = snowdp_ (np_) - fsno (np) = fsno_ (np_) - sigf (np) = sigf_ (np_) - ! In case lai+sai come into existence this year, set sigf to 1 - IF ( (sigf(np) .eq. 0) .and. ((lai(np) + sai(np)) .gt. 0) ) THEN - sigf(np) = 1 - ENDIF - zwt (np) = zwt_ (np_) - wa (np) = wa_ (np_) - wdsrf (np) = wdsrf_ (np_) - rss (np) = rss_ (np_) - - t_lake (:,np) = t_lake_ (:,np_) - lake_icefrac(:,np) = lake_icefrac_(:,np_) - savedtke1 (np) = savedtke1_ (np_) + ! otherwise, set patch value + ! only for the same patch type + z_sno (:,np) = z_sno_ (:,np_) + dz_sno (:,np) = dz_sno_ (:,np_) + t_soisno (:,np) = t_soisno_ (:,np_) + wliq_soisno (:,np) = wliq_soisno_ (:,np_) + wice_soisno (:,np) = wice_soisno_ (:,np_) + scv (np) = scv_ (np_) + smp (:,np) = smp_ (:,np_) + hk (:,np) = hk_ (:,np_) + t_grnd (np) = t_grnd_ (np_) + tleaf (np) = tleaf_ (np_) + ldew (np) = ldew_ (np_) + ldew_rain (np) = ldew_rain_ (np_) + ldew_snow (np) = ldew_snow_ (np_) + sag (np) = sag_ (np_) + snowdp (np) = snowdp_ (np_) + fsno (np) = fsno_ (np_) + sigf (np) = sigf_ (np_) + ! In case lai+sai come into existence this year, set sigf to 1 + IF ( (sigf(np) .eq. 0) .and. ((lai(np) + sai(np)) .gt. 0) ) THEN + sigf(np) = 1 + ENDIF + zwt (np) = zwt_ (np_) + wa (np) = wa_ (np_) + wdsrf (np) = wdsrf_ (np_) + rss (np) = rss_ (np_) + + t_lake (:,np) = t_lake_ (:,np_) + lake_icefrac(:,np) = lake_icefrac_(:,np_) + savedtke1 (np) = savedtke1_ (np_) IF(DEF_USE_PLANTHYDRAULICS)THEN - !Plant Hydraulic variables - vegwp (:,np) = vegwp_ (:,np_) - gs0sun (np) = gs0sun_ (np_) - gs0sha (np) = gs0sha_ (np_) - !END plant hydraulic variables + !Plant Hydraulic variables + vegwp (:,np) = vegwp_ (:,np_) + gs0sun (np) = gs0sun_ (np_) + gs0sha (np) = gs0sha_ (np_) + !END plant hydraulic variables ENDIF IF(DEF_USE_OZONESTRESS)THEN - !Ozone Stress variables - lai_old (np) = lai_old_ (np_) - o3uptakesun (np) = o3uptakesun_ (np_) - o3uptakesha (np) = o3uptakesha_ (np_) - !End ozone stress variables + !Ozone Stress variables + lai_old (np) = lai_old_ (np_) + o3uptakesun (np) = o3uptakesun_ (np_) + o3uptakesha (np) = o3uptakesha_ (np_) + !End ozone stress variables ENDIF - snw_rds (:,np) = snw_rds_ (:,np_) - mss_bcpho (:,np) = mss_bcpho_ (:,np_) - mss_bcphi (:,np) = mss_bcphi_ (:,np_) - mss_ocpho (:,np) = mss_ocpho_ (:,np_) - mss_ocphi (:,np) = mss_ocphi_ (:,np_) - mss_dst1 (:,np) = mss_dst1_ (:,np_) - mss_dst2 (:,np) = mss_dst2_ (:,np_) - mss_dst3 (:,np) = mss_dst3_ (:,np_) - mss_dst4 (:,np) = mss_dst4_ (:,np_) - ssno_lyr(2,2,:,np) = ssno_lyr_(2,2,:,np_) - - trad (np) = trad_ (np_) - tref (np) = tref_ (np_) - qref (np) = qref_ (np_) - rst (np) = rst_ (np_) - emis (np) = emis_ (np_) - z0m (np) = z0m_ (np_) - zol (np) = zol_ (np_) - rib (np) = rib_ (np_) - ustar (np) = ustar_ (np_) - qstar (np) = qstar_ (np_) - tstar (np) = tstar_ (np_) - fm (np) = fm_ (np_) - fh (np) = fh_ (np_) - fq (np) = fq_ (np_) + snw_rds (:,np) = snw_rds_ (:,np_) + mss_bcpho (:,np) = mss_bcpho_ (:,np_) + mss_bcphi (:,np) = mss_bcphi_ (:,np_) + mss_ocpho (:,np) = mss_ocpho_ (:,np_) + mss_ocphi (:,np) = mss_ocphi_ (:,np_) + mss_dst1 (:,np) = mss_dst1_ (:,np_) + mss_dst2 (:,np) = mss_dst2_ (:,np_) + mss_dst3 (:,np) = mss_dst3_ (:,np_) + mss_dst4 (:,np) = mss_dst4_ (:,np_) + ssno_lyr(2,2,:,np) = ssno_lyr_(2,2,:,np_) + + trad (np) = trad_ (np_) + tref (np) = tref_ (np_) + qref (np) = qref_ (np_) + rst (np) = rst_ (np_) + emis (np) = emis_ (np_) + z0m (np) = z0m_ (np_) + zol (np) = zol_ (np_) + rib (np) = rib_ (np_) + ustar (np) = ustar_ (np_) + qstar (np) = qstar_ (np_) + tstar (np) = tstar_ (np_) + fm (np) = fm_ (np_) + fh (np) = fh_ (np_) + fq (np) = fq_ (np_) IF(DEF_USE_IRRIGATION)THEN - sum_irrig (np) = sum_irrig_ (np_) - sum_irrig_count (np) = sum_irrig_count_ (np_) + sum_irrig (np) = sum_irrig_ (np_) + sum_irrig_count (np) = sum_irrig_count_ (np_) ENDIF #if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) IF (patchtype(np)==0 .and. patchtype_(np_)==0) THEN - ip = patch_pft_s (np ) - ip_= patch_pft_s_(np_) - - IF (ip.le.0 .or. ip_.le.0) THEN - print *, "Error in REST_LulccTimeVariables LULC_IGBP_PFT|LULC_IGBP_PC!" - CALL CoLM_stop () - ENDIF - - DO WHILE (ip.le.patch_pft_e(np) .and. ip_.le.patch_pft_e_(np_)) - - ! if a PFT is missing, CYCLE - IF (pftclass(ip) > pftclass_(ip_)) THEN - ip_= ip_+ 1 - CYCLE - ENDIF - - ! if a PFT is added, CYCLE - IF (pftclass(ip) < pftclass_(ip_)) THEN - ip = ip + 1 - CYCLE - ENDIF - - ! for the same PFT, set PFT value - tleaf_p (ip) = tleaf_p_ (ip_) - ldew_p (ip) = ldew_p_ (ip_) - ldew_rain_p(ip) = ldew_rain_p_(ip_) - ldew_snow_p(ip) = ldew_snow_p_(ip_) - sigf_p (ip) = sigf_p_ (ip_) - - tref_p (ip) = tref_p_ (ip_) - qref_p (ip) = qref_p_ (ip_) - rst_p (ip) = rst_p_ (ip_) - z0m_p (ip) = z0m_p_ (ip_) + ip = patch_pft_s (np ) + ip_= patch_pft_s_(np_) + + IF (ip.le.0 .or. ip_.le.0) THEN + print *, "Error in REST_LulccTimeVariables LULC_IGBP_PFT|LULC_IGBP_PC!" + CALL CoLM_stop () + ENDIF + + DO WHILE (ip.le.patch_pft_e(np) .and. ip_.le.patch_pft_e_(np_)) + + ! IF a PFT is missing, CYCLE + IF (pftclass(ip) > pftclass_(ip_)) THEN + ip_= ip_+ 1 + CYCLE + ENDIF + + ! IF a PFT is added, CYCLE + IF (pftclass(ip) < pftclass_(ip_)) THEN + ip = ip + 1 + CYCLE + ENDIF + + ! for the same PFT, set PFT value + tleaf_p (ip) = tleaf_p_ (ip_) + ldew_p (ip) = ldew_p_ (ip_) + ldew_rain_p(ip) = ldew_rain_p_(ip_) + ldew_snow_p(ip) = ldew_snow_p_(ip_) + sigf_p (ip) = sigf_p_ (ip_) + + tref_p (ip) = tref_p_ (ip_) + qref_p (ip) = qref_p_ (ip_) + rst_p (ip) = rst_p_ (ip_) + z0m_p (ip) = z0m_p_ (ip_) IF(DEF_USE_PLANTHYDRAULICS)THEN - ! Plant Hydraulic variables - vegwp_p (:,ip) = vegwp_p_ (:,ip_) - gs0sun_p (ip) = gs0sun_p_ (ip_) - gs0sha_p (ip) = gs0sha_p_ (ip_) - ! end plant hydraulic variables + ! Plant Hydraulic variables + vegwp_p (:,ip) = vegwp_p_ (:,ip_) + gs0sun_p (ip) = gs0sun_p_ (ip_) + gs0sha_p (ip) = gs0sha_p_ (ip_) + ! end plant hydraulic variables ENDIF IF(DEF_USE_OZONESTRESS)THEN - ! Ozone Stress Variables - lai_old_p (ip) = lai_old_p_ (ip_) - o3uptakesun_p (ip) = o3uptakesun_p_ (ip_) - o3uptakesha_p (ip) = o3uptakesha_p_ (ip_) - ! End allocate Ozone Stress Variables + ! Ozone Stress Variables + lai_old_p (ip) = lai_old_p_ (ip_) + o3uptakesun_p (ip) = o3uptakesun_p_ (ip_) + o3uptakesha_p (ip) = o3uptakesha_p_ (ip_) + ! End allocate Ozone Stress Variables ENDIF - ip = ip + 1 - ip_= ip_+ 1 - ENDDO - ps = patch_pft_s(np) - pe = patch_pft_e(np) - ldew(np) = sum( ldew_p(ps:pe)*pftfrac(ps:pe) ) + ip = ip + 1 + ip_= ip_+ 1 + ENDDO + ps = patch_pft_s(np) + pe = patch_pft_e(np) + ldew(np) = sum( ldew_p(ps:pe)*pftfrac(ps:pe) ) ENDIF #endif #ifdef URBAN_MODEL IF (patchclass(np)==URBAN .and. patchclass_(np_)==URBAN) THEN - ! u = patch2urban (np ) - ! u_= patch2urban_(np_) - - IF (u.le.0 .or. u_.le.0) THEN - print *, "Error in REST_LulccTimeVariables URBAN_MODEL!" - CALL CoLM_stop () - ENDIF - - ! ! if a Urban type is missing, CYCLE - ! IF (landurban%settyp(u) > urbclass_(u_)) THEN - ! np_= np_+ 1 - ! CYCLE - ! ENDIF - - ! ! if a urban type is added, CYCLE - ! IF (landurban%settyp(u) < urbclass_(u_)) THEN - ! np = np + 1 - ! CYCLE - ! ENDIF - - ! otherwise, set urban value - ! include added urban and the same urban type - fwsun (u) = fwsun_ (u_) - dfwsun (u) = dfwsun_ (u_) - - sroof (:,:,u) = sroof_ (:,:,u_) - swsun (:,:,u) = swsun_ (:,:,u_) - swsha (:,:,u) = swsha_ (:,:,u_) - sgimp (:,:,u) = sgimp_ (:,:,u_) - sgper (:,:,u) = sgper_ (:,:,u_) - slake (:,:,u) = slake_ (:,:,u_) - - lwsun (u) = lwsun_ (u_) - lwsha (u) = lwsha_ (u_) - lgimp (u) = lgimp_ (u_) - lgper (u) = lgper_ (u_) - lveg (u) = lveg_ (u_) - - z_sno_roof (:,u) = z_sno_roof_ (:,u_) - z_sno_gimp (:,u) = z_sno_gimp_ (:,u_) - z_sno_gper (:,u) = z_sno_gper_ (:,u_) - z_sno_lake (:,u) = z_sno_lake_ (:,u_) - - dz_sno_roof (:,u) = dz_sno_roof_ (:,u_) - dz_sno_gimp (:,u) = dz_sno_gimp_ (:,u_) - dz_sno_gper (:,u) = dz_sno_gper_ (:,u_) - dz_sno_lake (:,u) = dz_sno_lake_ (:,u_) - - t_roofsno (:,u) = t_roofsno_ (:,u_) - t_wallsun (:,u) = t_wallsun_ (:,u_) - t_wallsha (:,u) = t_wallsha_ (:,u_) - t_gimpsno (:,u) = t_gimpsno_ (:,u_) - t_gpersno (:,u) = t_gpersno_ (:,u_) - t_lakesno (:,u) = t_lakesno_ (:,u_) - - troof_inner (u) = troof_inner_ (u_) - twsun_inner (u) = twsun_inner_ (u_) - twsha_inner (u) = twsha_inner_ (u_) - - wliq_roofsno (:,u) = wliq_roofsno_ (:,u_) - wice_roofsno (:,u) = wice_roofsno_ (:,u_) - wliq_gimpsno (:,u) = wliq_gimpsno_ (:,u_) - wice_gimpsno (:,u) = wice_gimpsno_ (:,u_) - wliq_gpersno (:,u) = wliq_gpersno_ (:,u_) - wice_gpersno (:,u) = wice_gpersno_ (:,u_) - wliq_lakesno (:,u) = wliq_lakesno_ (:,u_) - wice_lakesno (:,u) = wice_lakesno_ (:,u_) - - sag_roof (u) = sag_roof_ (u_) - sag_gimp (u) = sag_gimp_ (u_) - sag_gper (u) = sag_gper_ (u_) - sag_lake (u) = sag_lake_ (u_) - scv_roof (u) = scv_roof_ (u_) - scv_gimp (u) = scv_gimp_ (u_) - scv_gper (u) = scv_gper_ (u_) - scv_lake (u) = scv_lake_ (u_) - fsno_roof (u) = fsno_roof_ (u_) - fsno_gimp (u) = fsno_gimp_ (u_) - fsno_gper (u) = fsno_gper_ (u_) - fsno_lake (u) = fsno_lake_ (u_) - snowdp_roof (u) = snowdp_roof_ (u_) - snowdp_gimp (u) = snowdp_gimp_ (u_) - snowdp_gper (u) = snowdp_gper_ (u_) - snowdp_lake (u) = snowdp_lake_ (u_) - - Fhac (u) = Fhac_ (u_) - Fwst (u) = Fwst_ (u_) - Fach (u) = Fach_ (u_) - Fahe (u) = Fahe_ (u_) - Fhah (u) = Fhah_ (u_) - vehc (u) = vehc_ (u_) - meta (u) = meta_ (u_) - t_room (u) = t_room_ (u_) - t_roof (u) = t_roof_ (u_) - t_wall (u) = t_wall_ (u_) - tafu (u) = tafu_ (u_) - urb_green (u) = urb_green_ (u_) - - wliq_soisno(: ,np) = 0. - wliq_soisno(:1,np) = wliq_roofsno(:1,u )*froof(u) - wliq_soisno(: ,np) = wliq_soisno (: ,np)+wliq_gpersno(: ,u)*(1-froof(u))*fgper(u) - wliq_soisno(:1,np) = wliq_soisno (:1,np)+wliq_gimpsno(:1,u)*(1-froof(u))*(1-fgper(u)) - - wice_soisno(: ,np) = 0. - wice_soisno(:1,np) = wice_roofsno(:1,u )*froof(u) - wice_soisno(: ,np) = wice_soisno (: ,np)+wice_gpersno(: ,u)*(1-froof(u))*fgper(u) - wice_soisno(:1,np) = wice_soisno (:1,np)+wice_gimpsno(:1,u)*(1-froof(u))*(1-fgper(u)) - - scv(np) = scv_roof(u)*froof(u) + scv_gper(u)*(1-froof(u))*fgper(u) + scv_gimp(u)*(1-froof(u))*(1-fgper(u)) + ! u = patch2urban (np ) + ! u_= patch2urban_(np_) + + IF (u.le.0 .or. u_.le.0) THEN + print *, "Error in REST_LulccTimeVariables URBAN_MODEL!" + CALL CoLM_stop () + ENDIF + + ! ! IF a Urban type is missing, CYCLE + ! IF (landurban%settyp(u) > urbclass_(u_)) THEN + ! np_= np_+ 1 + ! CYCLE + ! ENDIF + + ! ! IF a urban type is added, CYCLE + ! IF (landurban%settyp(u) < urbclass_(u_)) THEN + ! np = np + 1 + ! CYCLE + ! ENDIF + + ! otherwise, set urban value + ! include added urban and the same urban type + fwsun (u) = fwsun_ (u_) + dfwsun (u) = dfwsun_ (u_) + + sroof (:,:,u) = sroof_ (:,:,u_) + swsun (:,:,u) = swsun_ (:,:,u_) + swsha (:,:,u) = swsha_ (:,:,u_) + sgimp (:,:,u) = sgimp_ (:,:,u_) + sgper (:,:,u) = sgper_ (:,:,u_) + slake (:,:,u) = slake_ (:,:,u_) + + lwsun (u) = lwsun_ (u_) + lwsha (u) = lwsha_ (u_) + lgimp (u) = lgimp_ (u_) + lgper (u) = lgper_ (u_) + lveg (u) = lveg_ (u_) + + z_sno_roof (:,u) = z_sno_roof_ (:,u_) + z_sno_gimp (:,u) = z_sno_gimp_ (:,u_) + z_sno_gper (:,u) = z_sno_gper_ (:,u_) + z_sno_lake (:,u) = z_sno_lake_ (:,u_) + + dz_sno_roof (:,u) = dz_sno_roof_ (:,u_) + dz_sno_gimp (:,u) = dz_sno_gimp_ (:,u_) + dz_sno_gper (:,u) = dz_sno_gper_ (:,u_) + dz_sno_lake (:,u) = dz_sno_lake_ (:,u_) + + t_roofsno (:,u) = t_roofsno_ (:,u_) + t_wallsun (:,u) = t_wallsun_ (:,u_) + t_wallsha (:,u) = t_wallsha_ (:,u_) + t_gimpsno (:,u) = t_gimpsno_ (:,u_) + t_gpersno (:,u) = t_gpersno_ (:,u_) + t_lakesno (:,u) = t_lakesno_ (:,u_) + + troof_inner (u) = troof_inner_ (u_) + twsun_inner (u) = twsun_inner_ (u_) + twsha_inner (u) = twsha_inner_ (u_) + + wliq_roofsno (:,u) = wliq_roofsno_ (:,u_) + wice_roofsno (:,u) = wice_roofsno_ (:,u_) + wliq_gimpsno (:,u) = wliq_gimpsno_ (:,u_) + wice_gimpsno (:,u) = wice_gimpsno_ (:,u_) + wliq_gpersno (:,u) = wliq_gpersno_ (:,u_) + wice_gpersno (:,u) = wice_gpersno_ (:,u_) + wliq_lakesno (:,u) = wliq_lakesno_ (:,u_) + wice_lakesno (:,u) = wice_lakesno_ (:,u_) + + sag_roof (u) = sag_roof_ (u_) + sag_gimp (u) = sag_gimp_ (u_) + sag_gper (u) = sag_gper_ (u_) + sag_lake (u) = sag_lake_ (u_) + scv_roof (u) = scv_roof_ (u_) + scv_gimp (u) = scv_gimp_ (u_) + scv_gper (u) = scv_gper_ (u_) + scv_lake (u) = scv_lake_ (u_) + fsno_roof (u) = fsno_roof_ (u_) + fsno_gimp (u) = fsno_gimp_ (u_) + fsno_gper (u) = fsno_gper_ (u_) + fsno_lake (u) = fsno_lake_ (u_) + snowdp_roof (u) = snowdp_roof_ (u_) + snowdp_gimp (u) = snowdp_gimp_ (u_) + snowdp_gper (u) = snowdp_gper_ (u_) + snowdp_lake (u) = snowdp_lake_ (u_) + + Fhac (u) = Fhac_ (u_) + Fwst (u) = Fwst_ (u_) + Fach (u) = Fach_ (u_) + Fahe (u) = Fahe_ (u_) + Fhah (u) = Fhah_ (u_) + vehc (u) = vehc_ (u_) + meta (u) = meta_ (u_) + t_room (u) = t_room_ (u_) + t_roof (u) = t_roof_ (u_) + t_wall (u) = t_wall_ (u_) + tafu (u) = tafu_ (u_) + urb_green (u) = urb_green_ (u_) + + wliq_soisno(: ,np) = 0. + wliq_soisno(:1,np) = wliq_roofsno(:1,u )*froof(u) + wliq_soisno(: ,np) = wliq_soisno (: ,np)+wliq_gpersno(: ,u)*(1-froof(u))*fgper(u) + wliq_soisno(:1,np) = wliq_soisno (:1,np)+wliq_gimpsno(:1,u)*(1-froof(u))*(1-fgper(u)) + + wice_soisno(: ,np) = 0. + wice_soisno(:1,np) = wice_roofsno(:1,u )*froof(u) + wice_soisno(: ,np) = wice_soisno (: ,np)+wice_gpersno(: ,u)*(1-froof(u))*fgper(u) + wice_soisno(:1,np) = wice_soisno (:1,np)+wice_gimpsno(:1,u)*(1-froof(u))*(1-fgper(u)) + + scv(np) = scv_roof(u)*froof(u) + scv_gper(u)*(1-froof(u))*fgper(u) + scv_gimp(u)*(1-froof(u))*(1-fgper(u)) ENDIF #endif - np = np + 1 - np_= np_+ 1 - ENDDO - ENDIF - ENDDO - ENDDO - ENDIF - - IF (p_is_worker) THEN - IF (allocated(grid_patch_s )) deallocate(grid_patch_s ) - IF (allocated(grid_patch_e )) deallocate(grid_patch_e ) - IF (allocated(grid_patch_s_)) deallocate(grid_patch_s_) - IF (allocated(grid_patch_e_)) deallocate(grid_patch_e_) - IF (allocated(locpxl )) deallocate(locpxl ) - ENDIF - END SUBROUTINE REST_LulccTimeVariables - - - SUBROUTINE deallocate_LulccTimeVariables - USE MOD_SPMD_Task - USE MOD_Lulcc_Vars_TimeInvariants, only: numpatch_, numpft_, numpc_, numurban_ + np = np + 1 + np_= np_+ 1 + ENDDO + ENDIF + ENDDO + ENDDO + ENDIF + + IF (p_is_worker) THEN + IF (allocated(grid_patch_s )) deallocate(grid_patch_s ) + IF (allocated(grid_patch_e )) deallocate(grid_patch_e ) + IF (allocated(grid_patch_s_)) deallocate(grid_patch_s_) + IF (allocated(grid_patch_e_)) deallocate(grid_patch_e_) + IF (allocated(locpxl )) deallocate(locpxl ) + ENDIF + END SUBROUTINE REST_LulccTimeVariables + + + SUBROUTINE deallocate_LulccTimeVariables + + USE MOD_SPMD_Task + USE MOD_Lulcc_Vars_TimeInvariants, only: numpatch_, numpft_, numpc_, numurban_ ! -------------------------------------------------- ! Deallocates memory for Lulcc time variant variables ! -------------------------------------------------- - IF (p_is_worker) THEN - IF (numpatch_ > 0) THEN - deallocate (z_sno_ ) - deallocate (dz_sno_ ) - deallocate (t_soisno_ ) - deallocate (wliq_soisno_ ) - deallocate (wice_soisno_ ) - deallocate (smp_ ) - deallocate (hk_ ) - deallocate (t_grnd_ ) - deallocate (tleaf_ ) - deallocate (ldew_ ) - deallocate (ldew_rain_ ) - deallocate (ldew_snow_ ) - deallocate (sag_ ) - deallocate (scv_ ) - deallocate (snowdp_ ) - deallocate (fsno_ ) - deallocate (sigf_ ) - deallocate (zwt_ ) - deallocate (wa_ ) - deallocate (wdsrf_ ) - deallocate (rss_ ) - - deallocate (t_lake_ ) - deallocate (lake_icefrac_ ) - deallocate (savedtke1_ ) - - !Plant Hydraulic variables - deallocate (vegwp_ ) - deallocate (gs0sun_ ) - deallocate (gs0sha_ ) - !END plant hydraulic variables - - !Ozone Stress variables - deallocate (lai_old_ ) - deallocate (o3uptakesun_ ) - deallocate (o3uptakesha_ ) - !End ozone stress variables - - deallocate (snw_rds_ ) - deallocate (mss_bcpho_ ) - deallocate (mss_bcphi_ ) - deallocate (mss_ocpho_ ) - deallocate (mss_ocphi_ ) - deallocate (mss_dst1_ ) - deallocate (mss_dst2_ ) - deallocate (mss_dst3_ ) - deallocate (mss_dst4_ ) - deallocate (ssno_lyr_ ) - - deallocate (trad_ ) - deallocate (tref_ ) - deallocate (qref_ ) - deallocate (rst_ ) - deallocate (emis_ ) - deallocate (z0m_ ) - deallocate (zol_ ) - deallocate (rib_ ) - deallocate (ustar_ ) - deallocate (qstar_ ) - deallocate (tstar_ ) - deallocate (fm_ ) - deallocate (fh_ ) - deallocate (fq_ ) - - deallocate (sum_irrig_ ) - deallocate (sum_irrig_count_) - - ENDIF + IF (p_is_worker) THEN + IF (numpatch_ > 0) THEN + deallocate (z_sno_ ) + deallocate (dz_sno_ ) + deallocate (t_soisno_ ) + deallocate (wliq_soisno_ ) + deallocate (wice_soisno_ ) + deallocate (smp_ ) + deallocate (hk_ ) + deallocate (t_grnd_ ) + deallocate (tleaf_ ) + deallocate (ldew_ ) + deallocate (ldew_rain_ ) + deallocate (ldew_snow_ ) + deallocate (sag_ ) + deallocate (scv_ ) + deallocate (snowdp_ ) + deallocate (fsno_ ) + deallocate (sigf_ ) + deallocate (zwt_ ) + deallocate (wa_ ) + deallocate (wdsrf_ ) + deallocate (rss_ ) + + deallocate (t_lake_ ) + deallocate (lake_icefrac_ ) + deallocate (savedtke1_ ) + + !Plant Hydraulic variables + deallocate (vegwp_ ) + deallocate (gs0sun_ ) + deallocate (gs0sha_ ) + !END plant hydraulic variables + + !Ozone Stress variables + deallocate (lai_old_ ) + deallocate (o3uptakesun_ ) + deallocate (o3uptakesha_ ) + !End ozone stress variables + + deallocate (snw_rds_ ) + deallocate (mss_bcpho_ ) + deallocate (mss_bcphi_ ) + deallocate (mss_ocpho_ ) + deallocate (mss_ocphi_ ) + deallocate (mss_dst1_ ) + deallocate (mss_dst2_ ) + deallocate (mss_dst3_ ) + deallocate (mss_dst4_ ) + deallocate (ssno_lyr_ ) + + deallocate (trad_ ) + deallocate (tref_ ) + deallocate (qref_ ) + deallocate (rst_ ) + deallocate (emis_ ) + deallocate (z0m_ ) + deallocate (zol_ ) + deallocate (rib_ ) + deallocate (ustar_ ) + deallocate (qstar_ ) + deallocate (tstar_ ) + deallocate (fm_ ) + deallocate (fh_ ) + deallocate (fq_ ) + + deallocate (sum_irrig_ ) + deallocate (sum_irrig_count_) + + ENDIF #if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) - IF (numpft_ > 0) THEN - deallocate (tleaf_p_ ) - deallocate (ldew_p_ ) - deallocate (ldew_rain_p_ ) - deallocate (ldew_snow_p_ ) - deallocate (sigf_p_ ) - deallocate (tref_p_ ) - deallocate (qref_p_ ) - deallocate (rst_p_ ) - deallocate (z0m_p_ ) - - ! Plant Hydraulic variables - deallocate (vegwp_p_ ) - deallocate (gs0sun_p_ ) - deallocate (gs0sha_p_ ) - ! end plant hydraulic variables - - ! Allocate Ozone Stress Variables - deallocate (lai_old_p_ ) - deallocate (o3uptakesun_p_) - deallocate (o3uptakesha_p_) - ! End allocate Ozone Stress Variables - ENDIF + IF (numpft_ > 0) THEN + deallocate (tleaf_p_ ) + deallocate (ldew_p_ ) + deallocate (ldew_rain_p_ ) + deallocate (ldew_snow_p_ ) + deallocate (sigf_p_ ) + deallocate (tref_p_ ) + deallocate (qref_p_ ) + deallocate (rst_p_ ) + deallocate (z0m_p_ ) + + ! Plant Hydraulic variables + deallocate (vegwp_p_ ) + deallocate (gs0sun_p_ ) + deallocate (gs0sha_p_ ) + ! end plant hydraulic variables + + ! Allocate Ozone Stress Variables + deallocate (lai_old_p_ ) + deallocate (o3uptakesun_p_) + deallocate (o3uptakesha_p_) + ! End allocate Ozone Stress Variables + ENDIF #endif #ifdef URBAN_MODEL - IF (numurban_ > 0) THEN - deallocate (fwsun_ ) - deallocate (dfwsun_ ) - - deallocate (sroof_ ) - deallocate (swsun_ ) - deallocate (swsha_ ) - deallocate (sgimp_ ) - deallocate (sgper_ ) - deallocate (slake_ ) - - deallocate (lwsun_ ) - deallocate (lwsha_ ) - deallocate (lgimp_ ) - deallocate (lgper_ ) - deallocate (lveg_ ) - - deallocate (z_sno_roof_ ) - deallocate (z_sno_gimp_ ) - deallocate (z_sno_gper_ ) - deallocate (z_sno_lake_ ) - - deallocate (dz_sno_roof_ ) - deallocate (dz_sno_gimp_ ) - deallocate (dz_sno_gper_ ) - deallocate (dz_sno_lake_ ) - - deallocate (t_roofsno_ ) - deallocate (t_wallsun_ ) - deallocate (t_wallsha_ ) - deallocate (t_gimpsno_ ) - deallocate (t_gpersno_ ) - deallocate (t_lakesno_ ) - - deallocate (troof_inner_ ) - deallocate (twsun_inner_ ) - deallocate (twsha_inner_ ) - - deallocate (wliq_roofsno_ ) - deallocate (wice_roofsno_ ) - deallocate (wliq_gimpsno_ ) - deallocate (wice_gimpsno_ ) - deallocate (wliq_gpersno_ ) - deallocate (wice_gpersno_ ) - deallocate (wliq_lakesno_ ) - deallocate (wice_lakesno_ ) - - deallocate (sag_roof_ ) - deallocate (sag_gimp_ ) - deallocate (sag_gper_ ) - deallocate (sag_lake_ ) - deallocate (scv_roof_ ) - deallocate (scv_gimp_ ) - deallocate (scv_gper_ ) - deallocate (scv_lake_ ) - deallocate (fsno_roof_ ) - deallocate (fsno_gimp_ ) - deallocate (fsno_gper_ ) - deallocate (fsno_lake_ ) - deallocate (snowdp_roof_ ) - deallocate (snowdp_gimp_ ) - deallocate (snowdp_gper_ ) - deallocate (snowdp_lake_ ) - - deallocate (Fhac_ ) - deallocate (Fwst_ ) - deallocate (Fach_ ) - deallocate (Fahe_ ) - deallocate (Fhah_ ) - deallocate (vehc_ ) - deallocate (meta_ ) - deallocate (t_room_ ) - deallocate (t_roof_ ) - deallocate (t_wall_ ) - deallocate (tafu_ ) - deallocate (urb_green_ ) - ENDIF + IF (numurban_ > 0) THEN + deallocate (fwsun_ ) + deallocate (dfwsun_ ) + + deallocate (sroof_ ) + deallocate (swsun_ ) + deallocate (swsha_ ) + deallocate (sgimp_ ) + deallocate (sgper_ ) + deallocate (slake_ ) + + deallocate (lwsun_ ) + deallocate (lwsha_ ) + deallocate (lgimp_ ) + deallocate (lgper_ ) + deallocate (lveg_ ) + + deallocate (z_sno_roof_ ) + deallocate (z_sno_gimp_ ) + deallocate (z_sno_gper_ ) + deallocate (z_sno_lake_ ) + + deallocate (dz_sno_roof_ ) + deallocate (dz_sno_gimp_ ) + deallocate (dz_sno_gper_ ) + deallocate (dz_sno_lake_ ) + + deallocate (t_roofsno_ ) + deallocate (t_wallsun_ ) + deallocate (t_wallsha_ ) + deallocate (t_gimpsno_ ) + deallocate (t_gpersno_ ) + deallocate (t_lakesno_ ) + + deallocate (troof_inner_ ) + deallocate (twsun_inner_ ) + deallocate (twsha_inner_ ) + + deallocate (wliq_roofsno_ ) + deallocate (wice_roofsno_ ) + deallocate (wliq_gimpsno_ ) + deallocate (wice_gimpsno_ ) + deallocate (wliq_gpersno_ ) + deallocate (wice_gpersno_ ) + deallocate (wliq_lakesno_ ) + deallocate (wice_lakesno_ ) + + deallocate (sag_roof_ ) + deallocate (sag_gimp_ ) + deallocate (sag_gper_ ) + deallocate (sag_lake_ ) + deallocate (scv_roof_ ) + deallocate (scv_gimp_ ) + deallocate (scv_gper_ ) + deallocate (scv_lake_ ) + deallocate (fsno_roof_ ) + deallocate (fsno_gimp_ ) + deallocate (fsno_gper_ ) + deallocate (fsno_lake_ ) + deallocate (snowdp_roof_ ) + deallocate (snowdp_gimp_ ) + deallocate (snowdp_gper_ ) + deallocate (snowdp_lake_ ) + + deallocate (Fhac_ ) + deallocate (Fwst_ ) + deallocate (Fach_ ) + deallocate (Fahe_ ) + deallocate (Fhah_ ) + deallocate (vehc_ ) + deallocate (meta_ ) + deallocate (t_room_ ) + deallocate (t_roof_ ) + deallocate (t_wall_ ) + deallocate (tafu_ ) + deallocate (urb_green_ ) + ENDIF #endif - ENDIF + ENDIF - END SUBROUTINE deallocate_LulccTimeVariables + END SUBROUTINE deallocate_LulccTimeVariables END MODULE MOD_Lulcc_Vars_TimeVariables ! ---------- EOP ------------ diff --git a/main/URBAN/MOD_Urban_Albedo.F90 b/main/URBAN/MOD_Urban_Albedo.F90 index 9272b21c..408d2b0a 100644 --- a/main/URBAN/MOD_Urban_Albedo.F90 +++ b/main/URBAN/MOD_Urban_Albedo.F90 @@ -12,26 +12,26 @@ MODULE MOD_Urban_Albedo ! ! !----------------------------------------------------------------------- - USE MOD_Precision - IMPLICIT NONE - SAVE + USE MOD_Precision + IMPLICIT NONE + SAVE ! PUBLIC MEMBER FUNCTIONS: - PUBLIC :: alburban + PUBLIC :: alburban !----------------------------------------------------------------------- - CONTAINS +CONTAINS !----------------------------------------------------------------------- - SUBROUTINE alburban (ipatch,froof,fgper,flake,hwr,hroof,& - alb_roof,alb_wall,alb_gimp,alb_gper,& - rho,tau,fveg,hveg,lai,sai,coszen,fwsun,tlake,& - fsno_roof,fsno_gimp,fsno_gper,fsno_lake,& - scv_roof,scv_gimp,scv_gper,scv_lake,& - sag_roof,sag_gimp,sag_gper,sag_lake,& - dfwsun,extkd,alb,ssun,ssha,sroof,swsun,swsha,sgimp,sgper,slake) + SUBROUTINE alburban (ipatch,froof,fgper,flake,hwr,hroof,& + alb_roof,alb_wall,alb_gimp,alb_gper,& + rho,tau,fveg,hveg,lai,sai,coszen,fwsun,tlake,& + fsno_roof,fsno_gimp,fsno_gper,fsno_lake,& + scv_roof,scv_gimp,scv_gper,scv_lake,& + sag_roof,sag_gimp,sag_gper,sag_lake,& + dfwsun,extkd,alb,ssun,ssha,sroof,swsun,swsha,sgimp,sgper,slake) !======================================================================= ! Calculates fragmented albedos (direct and diffuse) in @@ -49,31 +49,31 @@ SUBROUTINE alburban (ipatch,froof,fgper,flake,hwr,hroof,& ! !======================================================================= - USE MOD_Precision - USE MOD_Const_Physical, only: tfrz - USE MOD_Urban_Shortwave + USE MOD_Precision + USE MOD_Const_Physical, only: tfrz + USE MOD_Urban_Shortwave - IMPLICIT NONE + IMPLICIT NONE !------------------------- Dummy Arguments ----------------------------- ! ground cover index - INTEGER, intent(in) :: & + integer, intent(in) :: & ipatch ! patch index - REAL(r8), intent(in) :: & + real(r8), intent(in) :: & froof, &! roof fraction fgper, &! impervious ground weight fraction flake, &! lake fraction hwr, &! average building height to their distance hroof ! average building height - REAL(r8), intent(in) :: & + real(r8), intent(in) :: & alb_roof(2,2), &! roof albedo (iband,direct/diffuse) alb_wall(2,2), &! wall albedo (iband,direct/diffuse) alb_gimp(2,2), &! impervious albedo (iband,direct/diffuse) alb_gper(2,2) ! pervious albedo (iband,direct/diffuse) - REAL(r8), intent(in) :: & + real(r8), intent(in) :: & rho(2,2), &! leaf reflectance (iw=iband, il=life and dead) tau(2,2), &! leaf transmittance (iw=iband, il=life and dead) fveg, &! fractional vegetation cover [-] @@ -98,7 +98,7 @@ SUBROUTINE alburban (ipatch,froof,fgper,flake,hwr,hroof,& sag_gper, &! non dimensional snow age [-] sag_lake ! non dimensional snow age [-] - REAL(r8), intent(out) :: & + real(r8), intent(out) :: & dfwsun, &! change of fwsun extkd, &! diffuse and scattered diffuse PAR extinction coefficient alb(2,2), &! averaged albedo [-] @@ -112,7 +112,7 @@ SUBROUTINE alburban (ipatch,froof,fgper,flake,hwr,hroof,& slake(2,2) ! lake absorption for solar radiation, !-------------------------- Local variables ---------------------------- - REAL(r8) :: &! + real(r8) :: &! age, &! factor to reduce visible snow alb due to snow age [-] albg0, &! temporary varaiable [-] alb_s_inc, &! decrease in soil albedo due to wetness [-] @@ -132,7 +132,7 @@ SUBROUTINE alburban (ipatch,froof,fgper,flake,hwr,hroof,& snal0, &! alb for visible,incident on new snow (zen ang<60) [-] snal1 ! alb for NIR, incident on new snow (zen angle<60) [-] - REAL(r8) :: &! + real(r8) :: &! erho(2), &! effective reflection of leaf+stem etau(2), &! effective transmittance of leaf+stem albsno(2,2), &! snow albedo [-] @@ -338,7 +338,7 @@ SUBROUTINE alburban (ipatch,froof,fgper,flake,hwr,hroof,& alb(:,:) = (1.-flake)*alb(:,:) + flake*alblake(:,:) - END SUBROUTINE alburban + END SUBROUTINE alburban END MODULE MOD_Urban_Albedo ! --------- EOP ---------- diff --git a/main/URBAN/MOD_Urban_BEM.F90 b/main/URBAN/MOD_Urban_BEM.F90 index 3639d0f8..1d4c7ef7 100644 --- a/main/URBAN/MOD_Urban_BEM.F90 +++ b/main/URBAN/MOD_Urban_BEM.F90 @@ -2,31 +2,31 @@ MODULE MOD_Urban_BEM - USE MOD_Precision - USE MOD_Vars_Global - USE MOD_Const_Physical - USE MOD_Urban_Shortwave, only: MatrixInverse + USE MOD_Precision + USE MOD_Vars_Global + USE MOD_Const_Physical + USE MOD_Urban_Shortwave, only: MatrixInverse - IMPLICIT NONE - SAVE - PRIVATE + IMPLICIT NONE + SAVE + PRIVATE - ! A simple building energy model to calculate room temperature - PUBLIC :: SimpleBEM + ! A simple building energy model to calculate room temperature + PUBLIC :: SimpleBEM CONTAINS - !----------------------------------------------------------------------------------- - SUBROUTINE SimpleBEM ( deltim, rhoair, fcover, H, troom_max, troom_min, & - troof_nl_bef, twsun_nl_bef, twsha_nl_bef, & - troof_nl, twsun_nl, twsha_nl, & - tkdz_roof, tkdz_wsun, tkdz_wsha, taf, & - troom, troof_inner, twsun_inner, twsha_inner, & - Fhac, Fwst, Fach, Fhah) + !----------------------------------------------------------------------------------- + SUBROUTINE SimpleBEM ( deltim, rhoair, fcover, H, troom_max, troom_min, & + troof_nl_bef, twsun_nl_bef, twsha_nl_bef, & + troof_nl, twsun_nl, twsha_nl, & + tkdz_roof, tkdz_wsun, tkdz_wsha, taf, & + troom, troof_inner, twsun_inner, twsha_inner, & + Fhac, Fwst, Fach, Fhah) - IMPLICIT NONE + IMPLICIT NONE - REAL(r8), intent(in) :: & + real(r8), intent(in) :: & deltim, &! seconds in a time step [second] rhoair, &! density air [kg/m3] fcover(0:2), &! fractional cover of roof, wall @@ -44,20 +44,20 @@ SUBROUTINE SimpleBEM ( deltim, rhoair, fcover, H, troom_max, troom_min, & tkdz_wsha, &! temporal var for heat transfer of shaded wall taf ! temperature of urban air - REAL(r8), intent(inout) :: & + real(r8), intent(inout) :: & troom, &! temperature of inner building troof_inner, &! temperature of inner roof twsun_inner, &! temperature of inner sunlit wall twsha_inner ! temperature of inner shaded wall - REAL(r8), intent(out) :: & + real(r8), intent(out) :: & Fhah, &! flux from heating Fhac, &! flux from heat or cool AC Fwst, &! waste heat from cool or heat Fach ! flux from air exchange - ! local variables - REAL(r8) :: & + ! local variables + real(r8) :: & ACH, &! air exchange coefficience hcv_roof, &! convective exchange ceofficience for roof<->room hcv_wall, &! convective exchange ceofficience for wall<->room @@ -65,150 +65,150 @@ SUBROUTINE SimpleBEM ( deltim, rhoair, fcover, H, troom_max, troom_min, & waste_cool, &! waste heat for AC cooling waste_heat ! waste heat for AC heating - REAL(r8) :: & + real(r8) :: & f_wsun, &! weight factor for sunlit wall f_wsha ! weight factor for shaded wall - REAL(r8) :: & + real(r8) :: & A(4,4), &! Heat transfer matrix Ainv(4,4), &! Inverse of Heat transfer matrix B(4), &! B for Ax=B X(4) ! x for Ax=B - REAL(r8) :: & + real(r8) :: & troom_pro, &! projected room temperature troom_bef, &! temperature of inner building troof_inner_bef, &! temperature of inner roof twsun_inner_bef, &! temperature of inner sunlit wall twsha_inner_bef ! temperature of inner shaded wall - LOGICAL :: cooling, heating - - ! Option for continuous AC - LOGICAL, parameter :: Constant_AC = .true. - - !=================================================================================== - ! - ! o Solve the following equations - ! o variables: troom, troof_inner, twsun_inner, twsha_innter - ! - ! Hc_roof = Fn_roof .................................(1) - ! Hc_wsun = Fn_wsun .................................(2) - ! Hc_wsha = Fn_wsha .................................(3) - ! - ! Troom' - Troom - ! H*rhoair*cpair*-------------- = - ! dt - ! ACH - ! ------*H*rhoair*cpair*(Taf-Troom') + Hc_roof + Hc_wsun + Hc_wsha - ! 3600 - ! .................................(4) - !=================================================================================== - - ACH = 0.3 !air exchange coefficience - hcv_roof = 4.040 !convective exchange ceofficience for roof<->room (W m-2 K-1) - hcv_wall = 3.076 !convective exchange ceofficience for wall<->room (W m-2 K-1) - waste_cool = 0.6 !waste heat for AC cooling - waste_heat = 0.2 !waste heat for AC heating - cooling = .false. !cooling case - heating = .false. !heating case - - f_wsun = fcover(1)/fcover(0) !weight factor for sunlit wall - f_wsha = fcover(2)/fcover(0) !weight factor for shaded wall - - ! initialization - Fhac = 0.; Fwst = 0.; Fach = 0.; - - ! Ax = B - ! set values for heat transfer matrix - ! 1: roof, 2: sunlit wall, 3: shaded wall, 4: room - A(:,:) = 0. - A(1,:) = (/0.5*hcv_roof+0.5*tkdz_roof, 0., 0., -0.5*hcv_roof/) - A(2,:) = (/0., 0.5*hcv_wall+0.5*tkdz_wsun, 0., -0.5*hcv_wall/) - A(3,:) = (/0., 0., 0.5*hcv_wall+0.5*tkdz_wsha, -0.5*hcv_wall/) - - A(4,:) = (/-0.5*hcv_roof, -0.5*hcv_wall*f_wsun, -0.5*hcv_wall*f_wsha, & - 0.5*hcv_roof + 0.5*hcv_wall*f_wsun + 0.5*hcv_wall*f_wsha +& - H*rhoair*cpair/deltim + (ACH/3600.)*H*rhoair*cpair /) - - B(1) = -0.5*hcv_roof*(troof_inner-troom) + 0.5*tkdz_roof*(troof_nl_bef-troof_inner) + 0.5*tkdz_roof*troof_nl - B(2) = -0.5*hcv_wall*(twsun_inner-troom) + 0.5*tkdz_wsun*(twsun_nl_bef-twsun_inner) + 0.5*tkdz_wsun*twsun_nl - B(3) = -0.5*hcv_wall*(twsha_inner-troom) + 0.5*tkdz_wsha*(twsha_nl_bef-twsha_inner) + 0.5*tkdz_wsha*twsha_nl - - B(4) = H*rhoair*cpair*troom/deltim + (ACH/3600.)*H*rhoair*cpair*taf & - + 0.5*hcv_roof*(troof_inner-troom) & - + 0.5*hcv_wall*(twsun_inner-troom)*f_wsun & - + 0.5*hcv_wall*(twsha_inner-troom)*f_wsha - - ! Inverse of matrix A - Ainv = MatrixInverse(A) - - ! Matrix computing to revole multiple reflections - X = matmul(Ainv, B) - - troof_inner_bef = troof_inner - twsun_inner_bef = twsun_inner - twsha_inner_bef = twsha_inner - troom_bef = troom - - troof_inner = X(1) - twsun_inner = X(2) - twsha_inner = X(3) - troom = X(4) - troom_pro = X(4) - - Fach = (ACH/3600.)*H*rhoair*cpair*(troom - taf) - - IF (troom > troom_max) THEN !cooling case - Fhac = H*rhoair*cpair*(troom-troom_max)/deltim - troom = troom_max - Fwst = Fhac*waste_cool - ENDIF - - IF (troom < troom_min) THEN !heating case - Fhac = H*rhoair*cpair*(troom-troom_min)/deltim - troom = troom_min - Fwst = abs(Fhac)*waste_heat - ! nagative value, set it to 0. - Fhac = 0. - ENDIF - - ! for constant cooling or heating - IF ((troom_pro>troom_max .or. troom_pro troom_max) THEN !cooling case - troom = troom_max - waste_coef = waste_cool - cooling = .true. - ENDIF - - IF (troom_pro < troom_min) THEN !heating case - troom = troom_min - waste_coef = waste_heat - heating = .true. - ENDIF - - Fach = (ACH/3600.)*H*rhoair*cpair*(troom - taf) - - troof_inner = (B(1)-A(1,4)*troom)/A(1,1) - twsun_inner = (B(2)-A(2,4)*troom)/A(2,2) - twsha_inner = (B(3)-A(3,4)*troom)/A(3,3) - - Fhac = 0.5*hcv_roof*(troof_inner_bef-troom_bef) + 0.5*hcv_roof*(troof_inner-troom) - Fhac = 0.5*hcv_wall*(twsun_inner_bef-troom_bef)*f_wsun + 0.5*hcv_wall*(twsun_inner-troom)*f_wsun + Fhac - Fhac = 0.5*hcv_wall*(twsha_inner_bef-troom_bef)*f_wsha + 0.5*hcv_wall*(twsha_inner-troom)*f_wsha + Fhac - Fhah = Fhac - Fhac = abs(Fhac) + abs(Fach) - Fwst = Fhac*waste_coef - IF ( heating ) Fhac = 0. - - ENDIF - - Fhah = Fhah*fcover(0) - Fach = Fach*fcover(0) - Fwst = Fwst*fcover(0) - Fhac = Fhac*fcover(0) - - END SUBROUTINE SimpleBEM + logical :: cooling, heating + + ! Option for continuous AC + logical, parameter :: Constant_AC = .true. + + !=================================================================================== + ! + ! o Solve the following equations + ! o variables: troom, troof_inner, twsun_inner, twsha_innter + ! + ! Hc_roof = Fn_roof .................................(1) + ! Hc_wsun = Fn_wsun .................................(2) + ! Hc_wsha = Fn_wsha .................................(3) + ! + ! Troom' - Troom + ! H*rhoair*cpair*-------------- = + ! dt + ! ACH + ! ------*H*rhoair*cpair*(Taf-Troom') + Hc_roof + Hc_wsun + Hc_wsha + ! 3600 + ! .................................(4) + !=================================================================================== + + ACH = 0.3 !air exchange coefficience + hcv_roof = 4.040 !convective exchange ceofficience for roof<->room (W m-2 K-1) + hcv_wall = 3.076 !convective exchange ceofficience for wall<->room (W m-2 K-1) + waste_cool = 0.6 !waste heat for AC cooling + waste_heat = 0.2 !waste heat for AC heating + cooling = .false. !cooling case + heating = .false. !heating case + + f_wsun = fcover(1)/fcover(0) !weight factor for sunlit wall + f_wsha = fcover(2)/fcover(0) !weight factor for shaded wall + + ! initialization + Fhac = 0.; Fwst = 0.; Fach = 0.; + + ! Ax = B + ! set values for heat transfer matrix + ! 1: roof, 2: sunlit wall, 3: shaded wall, 4: room + A(:,:) = 0. + A(1,:) = (/0.5*hcv_roof+0.5*tkdz_roof, 0., 0., -0.5*hcv_roof/) + A(2,:) = (/0., 0.5*hcv_wall+0.5*tkdz_wsun, 0., -0.5*hcv_wall/) + A(3,:) = (/0., 0., 0.5*hcv_wall+0.5*tkdz_wsha, -0.5*hcv_wall/) + + A(4,:) = (/-0.5*hcv_roof, -0.5*hcv_wall*f_wsun, -0.5*hcv_wall*f_wsha, & + 0.5*hcv_roof + 0.5*hcv_wall*f_wsun + 0.5*hcv_wall*f_wsha +& + H*rhoair*cpair/deltim + (ACH/3600.)*H*rhoair*cpair /) + + B(1) = -0.5*hcv_roof*(troof_inner-troom) + 0.5*tkdz_roof*(troof_nl_bef-troof_inner) + 0.5*tkdz_roof*troof_nl + B(2) = -0.5*hcv_wall*(twsun_inner-troom) + 0.5*tkdz_wsun*(twsun_nl_bef-twsun_inner) + 0.5*tkdz_wsun*twsun_nl + B(3) = -0.5*hcv_wall*(twsha_inner-troom) + 0.5*tkdz_wsha*(twsha_nl_bef-twsha_inner) + 0.5*tkdz_wsha*twsha_nl + + B(4) = H*rhoair*cpair*troom/deltim + (ACH/3600.)*H*rhoair*cpair*taf & + + 0.5*hcv_roof*(troof_inner-troom) & + + 0.5*hcv_wall*(twsun_inner-troom)*f_wsun & + + 0.5*hcv_wall*(twsha_inner-troom)*f_wsha + + ! Inverse of matrix A + Ainv = MatrixInverse(A) + + ! Matrix computing to revole multiple reflections + X = matmul(Ainv, B) + + troof_inner_bef = troof_inner + twsun_inner_bef = twsun_inner + twsha_inner_bef = twsha_inner + troom_bef = troom + + troof_inner = X(1) + twsun_inner = X(2) + twsha_inner = X(3) + troom = X(4) + troom_pro = X(4) + + Fach = (ACH/3600.)*H*rhoair*cpair*(troom - taf) + + IF (troom > troom_max) THEN !cooling case + Fhac = H*rhoair*cpair*(troom-troom_max)/deltim + troom = troom_max + Fwst = Fhac*waste_cool + ENDIF + + IF (troom < troom_min) THEN !heating case + Fhac = H*rhoair*cpair*(troom-troom_min)/deltim + troom = troom_min + Fwst = abs(Fhac)*waste_heat + ! nagative value, set it to 0. + Fhac = 0. + ENDIF + + ! for constant cooling or heating + IF ((troom_pro>troom_max .or. troom_pro troom_max) THEN !cooling case + troom = troom_max + waste_coef = waste_cool + cooling = .true. + ENDIF + + IF (troom_pro < troom_min) THEN !heating case + troom = troom_min + waste_coef = waste_heat + heating = .true. + ENDIF + + Fach = (ACH/3600.)*H*rhoair*cpair*(troom - taf) + + troof_inner = (B(1)-A(1,4)*troom)/A(1,1) + twsun_inner = (B(2)-A(2,4)*troom)/A(2,2) + twsha_inner = (B(3)-A(3,4)*troom)/A(3,3) + + Fhac = 0.5*hcv_roof*(troof_inner_bef-troom_bef) + 0.5*hcv_roof*(troof_inner-troom) + Fhac = 0.5*hcv_wall*(twsun_inner_bef-troom_bef)*f_wsun + 0.5*hcv_wall*(twsun_inner-troom)*f_wsun + Fhac + Fhac = 0.5*hcv_wall*(twsha_inner_bef-troom_bef)*f_wsha + 0.5*hcv_wall*(twsha_inner-troom)*f_wsha + Fhac + Fhah = Fhac + Fhac = abs(Fhac) + abs(Fach) + Fwst = Fhac*waste_coef + IF ( heating ) Fhac = 0. + + ENDIF + + Fhah = Fhah*fcover(0) + Fach = Fach*fcover(0) + Fwst = Fwst*fcover(0) + Fhac = Fhac*fcover(0) + + END SUBROUTINE SimpleBEM END MODULE MOD_Urban_BEM diff --git a/main/URBAN/MOD_Urban_Const_LCZ.F90 b/main/URBAN/MOD_Urban_Const_LCZ.F90 index 5b464f61..2144c291 100644 --- a/main/URBAN/MOD_Urban_Const_LCZ.F90 +++ b/main/URBAN/MOD_Urban_Const_LCZ.F90 @@ -1,114 +1,114 @@ #include MODULE MOD_Urban_Const_LCZ - ! ----------------------------------------------------------------------- - ! !DESCRIPTION: - ! look-up-table for LCZ morphology and thermal parameters - ! !NOTE!!!!!!!!!!!!!!! - ! Each city may have different values for the parameters in this table. - ! The default values may not suit any specific city. - ! Users could adjust these values based on the city they are working with. - ! - ! Created by Wenzong Dong, Jun, 2022 - !----------------------------------------------------------------------- - ! REFERENCES: - ! 1) Stewart, I. D., Oke, T. R., & Krayenhoff, E. S. (2014). Evaluation of - ! the 'local climate zone' scheme using temperature observations and model - ! simulations. International Journal of Climatology, 34(4), 1062–1080. - ! https://doi.org/10.1002/joc.3746 2) The URBPARM_LCZ.TBL of WRF, - ! https://github.com/wrf-model/WRF/ - ! - ! ----------------------------------------------------------------------- - ! !USE +! ----------------------------------------------------------------------- +! !DESCRIPTION: +! look-up-table for LCZ morphology and thermal parameters +! !NOTE!!!!!!!!!!!!!!! +! Each city may have different values for the parameters in this table. +! The default values may not suit any specific city. +! Users could adjust these values based on the city they are working with. +! +! Created by Wenzong Dong, Jun, 2022 +!----------------------------------------------------------------------- +! REFERENCES: +! 1) Stewart, I. D., Oke, T. R., & Krayenhoff, E. S. (2014). Evaluation of +! the 'local climate zone' scheme using temperature observations and model +! simulations. International Journal of Climatology, 34(4), 1062–1080. +! https://doi.org/10.1002/joc.3746 2) The URBPARM_LCZ.TBL of WRF, +! https://github.com/wrf-model/WRF/ +! +! ----------------------------------------------------------------------- +! !USE USE MOD_Precision IMPLICIT NONE SAVE ! roof fraction [-] - REAL(r8), parameter, dimension(10) :: wtroof_lcz & + real(r8), parameter, dimension(10) :: wtroof_lcz & = (/0.5 , 0.5 , 0.55, 0.3 , 0.3, 0.3, 0.8 , 0.4 , 0.15, 0.25/) ! pervious fraction [-] - REAL(r8), parameter, dimension(10) :: wtperroad_lcz & + real(r8), parameter, dimension(10) :: wtperroad_lcz & = (/0.05, 0.1 , 0.15, 0.35, 0.3, 0.4, 0.15, 0.15, 0.7 , 0.45/) ! height of roof [m] - REAL(r8), parameter, dimension(10) :: htroof_lcz & + real(r8), parameter, dimension(10) :: htroof_lcz & = (/45., 15. , 5. , 40., 15., 5. , 3. , 7. , 5. , 8.5 /) ! H/W [-] - REAL(r8), parameter, dimension(10) :: canyonhwr_lcz & + real(r8), parameter, dimension(10) :: canyonhwr_lcz & = (/2.5, 1.25, 1.25, 1. , 0.5, 0.5, 1.5, 0.2, 0.15, 0.35/) ! thickness of roof [m] - REAL(r8), parameter, dimension(10) :: thickroof_lcz & + real(r8), parameter, dimension(10) :: thickroof_lcz & = (/0.3 , 0.3 , 0.2 , 0.3 , 0.25, 0.15, 0.05, 0.12, 0.15, 0.05/) ! thickness of wall [m] - REAL(r8), parameter, dimension(10) :: thickwall_lcz & + real(r8), parameter, dimension(10) :: thickwall_lcz & = (/0.3 , 0.25, 0.2 , 0.2 , 0.2 , 0.2 , 0.1 , 0.2 , 0.2 , 0.05/) ! thickness of impervious road [m] - REAL(r8), parameter, dimension(10) :: thickroad_lcz & + real(r8), parameter, dimension(10) :: thickroad_lcz & = (/0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25/) ! albeodo of roof [-] - REAL(r8), parameter, dimension(10) :: albroof_lcz & + real(r8), parameter, dimension(10) :: albroof_lcz & = (/0.13, 0.18, 0.15, 0.13, 0.13, 0.13, 0.15, 0.18, 0.13, 0.1 /) ! albeodo of wall [-] - REAL(r8), parameter, dimension(10) :: albwall_lcz & + real(r8), parameter, dimension(10) :: albwall_lcz & = (/0.25, 0.2 , 0.2 , 0.25, 0.25, 0.25, 0.2 , 0.25, 0.25, 0.2 /) ! albeodo of impervious road [-] - REAL(r8), parameter, dimension(10) :: albimproad_lcz & + real(r8), parameter, dimension(10) :: albimproad_lcz & = (/0.15, 0.15, 0.18, 0.20, 0.20, 0.21, 0.24, 0.17, 0.23, 0.21/) ! albeodo of pervious road [-] - REAL(r8), parameter, dimension(10) :: albperroad_lcz & + real(r8), parameter, dimension(10) :: albperroad_lcz & = (/0.08, 0.08, 0.08, 0.08, 0.08, 0.08, 0.08, 0.08, 0.08, 0.08/) ! emissivity of roof [-] - REAL(r8), parameter, dimension(10) :: emroof_lcz & + real(r8), parameter, dimension(10) :: emroof_lcz & = (/0.91, 0.91, 0.91, 0.91, 0.91, 0.91, 0.28, 0.91, 0.91, 0.91/) ! emissivity of wall [-] - REAL(r8), parameter, dimension(10) :: emwall_lcz & + real(r8), parameter, dimension(10) :: emwall_lcz & = (/0.90, 0.90, 0.90, 0.90, 0.90, 0.90, 0.90, 0.90, 0.90, 0.90/) ! emissivity of road [-] - REAL(r8), parameter, dimension(10) :: emimproad_lcz & + real(r8), parameter, dimension(10) :: emimproad_lcz & = (/0.95, 0.95, 0.95, 0.95, 0.95, 0.95, 0.92, 0.95, 0.95, 0.95/) ! emissivity of impervious road [-] - REAL(r8), parameter, dimension(10) :: emperroad_lcz & + real(r8), parameter, dimension(10) :: emperroad_lcz & = (/0.95, 0.95, 0.95, 0.95, 0.95, 0.95, 0.95, 0.95, 0.95, 0.95/) ! volumetric heat capacity of roof [J/m3*K] - REAL(r8), parameter, dimension(10) :: cvroof_lcz & + real(r8), parameter, dimension(10) :: cvroof_lcz & = (/1.8E6 , 1.8E6 , 1.44E6, 1.8E6 , 1.8E6 , 1.44E6, 2.0E6 , 1.8E6 , 1.44E6, 2.0E6 /) ! volumetric heat capacity of wall [J/m3*K] - REAL(r8), parameter, dimension(10) :: cvwall_lcz & + real(r8), parameter, dimension(10) :: cvwall_lcz & = (/1.8E6 , 2.67E6, 2.05E6, 2.0E6 , 2.0E6 , 2.05E6, 0.72E6, 1.8E6 , 2.56E6, 1.69E6/) ! volumetric heat capacity of impervious road [J/m3*K] - REAL(r8), parameter, dimension(10) :: cvimproad_lcz & + real(r8), parameter, dimension(10) :: cvimproad_lcz & = (/1.75E6, 1.68E6, 1.63E6, 1.54E6, 1.50E6, 1.47E6, 1.67E6, 1.38E6, 1.37E6, 1.49E6/) ! thermal conductivity of roof [W/m*K] - REAL(r8), parameter, dimension(10) :: tkroof_lcz & + real(r8), parameter, dimension(10) :: tkroof_lcz & = (/1.25, 1.25, 1.00, 1.25, 1.25, 1.00, 2.0 , 1.25, 1.00, 2.00/) ! thermal conductivity of wall [W/m*K] - REAL(r8), parameter, dimension(10) :: tkwall_lcz & + real(r8), parameter, dimension(10) :: tkwall_lcz & = (/1.09, 1.5 , 1.25, 1.45, 1.45, 1.25, 0.5 , 1.25, 1.00, 1.33/) ! thermal conductivity of impervious road [W/m*K] - REAL(r8), parameter, dimension(10) :: tkimproad_lcz & + real(r8), parameter, dimension(10) :: tkimproad_lcz & = (/0.77, 0.73, 0.69, 0.64, 0.62, 0.60, 0.72, 0.51, 0.55, 0.61/) !TODO:AHE coding diff --git a/main/URBAN/MOD_Urban_Flux.F90 b/main/URBAN/MOD_Urban_Flux.F90 index f132f79c..1231901e 100644 --- a/main/URBAN/MOD_Urban_Flux.F90 +++ b/main/URBAN/MOD_Urban_Flux.F90 @@ -3,75 +3,75 @@ MODULE MOD_Urban_Flux !----------------------------------------------------------------------- - USE MOD_Precision - USE MOD_Vars_Global - USE MOD_Qsadv, only: qsadv - IMPLICIT NONE - SAVE + USE MOD_Precision + USE MOD_Vars_Global + USE MOD_Qsadv, only: qsadv + IMPLICIT NONE + SAVE ! PUBLIC MEMBER FUNCTIONS: - PUBLIC :: UrbanOnlyFlux - PUBLIC :: UrbanVegFlux - PUBLIC :: dewfraction + PUBLIC :: UrbanOnlyFlux + PUBLIC :: UrbanVegFlux + PUBLIC :: dewfraction ! Exponential extinction factor (alpha) options: ! 1. Masson, 2000; Oleson et al., 2008 ! 2. Swaid, 1993; Kusaka, 2001; Lee and Park, 2008 ! 3. Macdonald, 2000 - INTEGER, parameter :: alpha_opt = 3 - -!----------------------------------------------------------------------- - - CONTAINS - -!----------------------------------------------------------------------- - - SUBROUTINE UrbanOnlyFlux ( & - ! Model running information - ipatch ,deltim ,lbr ,lbi ,& - ! Forcing - hu ,ht ,hq ,us ,& - vs ,thm ,th ,thv ,& - qm ,psrf ,rhoair ,Fhac ,& - Fwst ,Fach ,vehc ,meta ,& - ! Urban parameters - hroof ,hwr ,nurb ,fcover ,& - ! Status of surface - z0h_g ,obug ,ustarg ,zlnd ,& - zsno ,fsno_roof ,fsno_gimp ,fsno_gper ,& - wliq_roofsno,wliq_gimpsno,wice_roofsno,wice_gimpsno,& - htvp_roof ,htvp_gimp ,htvp_gper ,troof ,& - twsun ,twsha ,tgimp ,tgper ,& - qroof ,qgimp ,qgper ,dqroofdT ,& - dqgimpdT ,dqgperdT ,rsr ,& - ! Output - taux ,tauy ,fsenroof ,fsenwsun ,& - fsenwsha ,fsengimp ,fsengper ,fevproof ,& - fevpgimp ,fevpgper ,croofs ,cwalls ,& - cgrnds ,croofl ,cgimpl ,cgperl ,& - croof ,cgimp ,cgper ,tref ,& - qref ,z0m ,zol ,rib ,& - ustar ,qstar ,tstar ,fm ,& - fh ,fq ,tafu ) + integer, parameter :: alpha_opt = 3 + +!----------------------------------------------------------------------- + +CONTAINS + +!----------------------------------------------------------------------- + + SUBROUTINE UrbanOnlyFlux ( & + ! Model running information + ipatch ,deltim ,lbr ,lbi ,& + ! Forcing + hu ,ht ,hq ,us ,& + vs ,thm ,th ,thv ,& + qm ,psrf ,rhoair ,Fhac ,& + Fwst ,Fach ,vehc ,meta ,& + ! Urban parameters + hroof ,hwr ,nurb ,fcover ,& + ! Status of surface + z0h_g ,obug ,ustarg ,zlnd ,& + zsno ,fsno_roof ,fsno_gimp ,fsno_gper ,& + wliq_roofsno,wliq_gimpsno,wice_roofsno,wice_gimpsno,& + htvp_roof ,htvp_gimp ,htvp_gper ,troof ,& + twsun ,twsha ,tgimp ,tgper ,& + qroof ,qgimp ,qgper ,dqroofdT ,& + dqgimpdT ,dqgperdT ,rsr ,& + ! Output + taux ,tauy ,fsenroof ,fsenwsun ,& + fsenwsha ,fsengimp ,fsengper ,fevproof ,& + fevpgimp ,fevpgper ,croofs ,cwalls ,& + cgrnds ,croofl ,cgimpl ,cgperl ,& + croof ,cgimp ,cgper ,tref ,& + qref ,z0m ,zol ,rib ,& + ustar ,qstar ,tstar ,fm ,& + fh ,fq ,tafu ) !======================================================================= - USE MOD_Precision - USE MOD_Const_Physical, only: cpair,vonkar,grav - USE MOD_FrictionVelocity - USE MOD_CanopyLayerProfile - IMPLICIT NONE + USE MOD_Precision + USE MOD_Const_Physical, only: cpair,vonkar,grav + USE MOD_FrictionVelocity + USE MOD_CanopyLayerProfile + IMPLICIT NONE !----------------------- Dummy argument -------------------------------- - INTEGER, intent(in) :: & + integer, intent(in) :: & ipatch, &! patch index [-] lbr, &! lower bound of array lbi ! lower bound of array - REAL(r8), intent(in) :: & + real(r8), intent(in) :: & deltim ! seconds in a time step [second] - ! atmospherical variables and observational height - REAL(r8), intent(in) :: & + ! atmospherical variables and observational height + real(r8), intent(in) :: & hu, &! observational height of wind [m] ht, &! observational height of temperature [m] hq, &! observational height of humidity [m] @@ -84,22 +84,22 @@ SUBROUTINE UrbanOnlyFlux ( & psrf, &! atmosphere pressure at the surface [pa] [not used] rhoair ! density air [kg/m3] - REAL(r8), intent(in) :: & + real(r8), intent(in) :: & vehc, &! flux from vehicle meta, &! flux from metabolic Fhac, &! flux from heat or cool AC Fwst, &! waste heat from cool or heat Fach ! flux from air exchange - INTEGER, intent(in) :: & + integer, intent(in) :: & nurb ! number of aboveground urban components [-] - REAL(r8), intent(in) :: & + real(r8), intent(in) :: & hroof, &! average building height [m] hwr, &! average building height to their distance [-] fcover(0:4)! coverage of aboveground urban components [-] - REAL(r8), intent(in) :: & + real(r8), intent(in) :: & rsr, &! bare soil resistance for evaporation z0h_g, &! roughness length for bare ground, sensible heat [m] obug, &! monin-obukhov length for bare ground (m) @@ -130,8 +130,8 @@ SUBROUTINE UrbanOnlyFlux ( & dqgimpdT, &! d(qgimp)/dT dqgperdT ! d(qgper)/dT - ! Output - REAL(r8), intent(out) :: & + ! Output + real(r8), intent(out) :: & taux, &! wind stress: E-W [kg/m/s**2] tauy, &! wind stress: N-S [kg/m/s**2] fsenroof, &! sensible heat flux from roof [W/m2] @@ -168,12 +168,12 @@ SUBROUTINE UrbanOnlyFlux ( & tafu ! effective urban air temperature (2nd layer, walls) !------------------------ LOCAL VARIABLES ------------------------------ - INTEGER :: & + integer :: & niters, &! maximum number of iterations for surface temperature iter, &! iteration index nmozsgn ! number of times moz changes sign - REAL(r8) :: & + real(r8) :: & beta, &! coefficient of conective velocity [-] dth, &! diff of virtual temp. between ref. height and surface dqh, &! diff of humidity between ref. height and surface @@ -198,17 +198,17 @@ SUBROUTINE UrbanOnlyFlux ( & z0hg, &! roughness length over ground, sensible heat [m] z0qg ! roughness length over ground, latent heat [m] - REAL(r8) evplwet, evplwet_dtl, elwmax, elwdif + real(r8) evplwet, evplwet_dtl, elwmax, elwdif !----------------------- defination for 3d run ------------------------ ! - INTEGER, parameter :: nlay = 3 ! potential layer number + integer, parameter :: nlay = 3 ! potential layer number - INTEGER :: & + integer :: & clev, &! current layer index numlay ! available layer number - REAL(r8) :: & + real(r8) :: & huu, &! observational height of wind [m] htu, &! observational height of temperature [m] hqu, &! observational height of humidity [m] @@ -226,7 +226,7 @@ SUBROUTINE UrbanOnlyFlux ( & tg, &! ground temperature qg ! ground specific humidity - REAL(r8) :: & + real(r8) :: & fg, &! ground fractional cover fgimp, &! weight of impervious ground fgper, &! weight of pervious ground @@ -238,7 +238,7 @@ SUBROUTINE UrbanOnlyFlux ( & delta, &! 0 or 1 alpha ! exponential extinction factor for u/k decline within urban - REAL(r8), dimension(0:nurb) :: & + real(r8), dimension(0:nurb) :: & tu, &! termperature array fc, &! fractional cover array canlev, &! urban canopy layer lookup table @@ -253,7 +253,7 @@ SUBROUTINE UrbanOnlyFlux ( & qsatl, &! leaf specific humidity [kg/kg] qsatldT ! derivative of "qsatl" on "tlef" - REAL(r8), dimension(nlay) :: & + real(r8), dimension(nlay) :: & fah, &! weight for thermal resistance to upper layer faw, &! weight for moisture resistance to upper layer fgh, &! weight for thermal resistance to lower layer @@ -277,655 +277,655 @@ SUBROUTINE UrbanOnlyFlux ( & wtll, &! sum of normalized heat conductance for air and leaf wtlql ! sum of normalized heat conductance for air and leaf - REAL(r8) :: & + real(r8) :: & ra2m, &! aerodynamic resistance between 2m and bottom layer [s/m] rd2m ! aerodynamic resistance between bottom layer and ground [s/m] - ! temporal - INTEGER i - REAL(r8) h_vec, l_vec, tmpw3, cgw_per, cgw_imp - REAL(r8) bee, tmpw1, tmpw2, fact, facq - REAL(r8) fwet_roof, fwet_roof_, fwet_gimp, fwet_gimp_ - REAL(r8) fwetfac + ! temporal + integer i + real(r8) h_vec, l_vec, tmpw3, cgw_per, cgw_imp + real(r8) bee, tmpw1, tmpw2, fact, facq + real(r8) fwet_roof, fwet_roof_, fwet_gimp, fwet_gimp_ + real(r8) fwetfac !-----------------------End Variable List------------------------------- ! initialization - tu(0) = troof; tu(1) = twsun; tu(2) = twsha + tu(0) = troof; tu(1) = twsun; tu(2) = twsha - fc(:) = fcover(0:nurb) - fg = 1 - fcover(0) - fgimp = fcover(3)/fg - fgper = fcover(4)/fg - hlr = hwr*(1-sqrt(fcover(0)))/sqrt(fcover(0)) - canlev = (/3, 2, 2/) - numlay = 2 + fc(:) = fcover(0:nurb) + fg = 1 - fcover(0) + fgimp = fcover(3)/fg + fgper = fcover(4)/fg + hlr = hwr*(1-sqrt(fcover(0)))/sqrt(fcover(0)) + canlev = (/3, 2, 2/) + numlay = 2 !----------------------------------------------------------------------- ! initial roughness length for z0mg, z0hg, z0qg ! Roughness of the city ground only (excluding buildings and vegetation) - !NOTE: change to original - !z0mg = (1.-fsno)*zlnd + fsno*zsno - IF (fsno_gper > 0) THEN - z0mg = zsno - ELSE - z0mg = zlnd - ENDIF - z0hg = z0mg - z0qg = z0mg + !NOTE: change to original + !z0mg = (1.-fsno)*zlnd + fsno*zsno + IF (fsno_gper > 0) THEN + z0mg = zsno + ELSE + z0mg = zlnd + ENDIF + z0hg = z0mg + z0qg = z0mg !----------------------------------------------------------------------- ! initial saturated vapor pressure and humidity and their derivation ! 0: roof, 1: sunlit wall, 2: shaded wall !----------------------------------------------------------------------- - qsatl(0) = qroof - qsatldT(0) = dqroofdT - DO i = 1, nurb - CALL qsadv(tu(i),psrf,ei(i),deiDT(i),qsatl(i),qsatldT(i)) - ENDDO + qsatl(0) = qroof + qsatldT(0) = dqroofdT + DO i = 1, nurb + CALL qsadv(tu(i),psrf,ei(i),deiDT(i),qsatl(i),qsatldT(i)) + ENDDO !----------------------------------------------------------------------- ! set weight !----------------------------------------------------------------------- - ! set weighting factor - fah(1) = 1.; fah(2) = 1.; fah(3) = 1. - faw(1) = 1.; faw(2) = 1.; faw(3) = 1. - fgh(1) = 1.; fgh(2) = fg; fgh(3) = 1. - fgw(1) = 1.; fgw(2) = fg; fgw(3) = 1. - - ! weighted tg - tg = tgimp*fgimp + tgper*fgper - - ! wet fraction for roof and impervious ground - !------------------------------------------- - ! roof - IF (lbr < 1) THEN - fwet_roof_ = fsno_roof !for snow layer exist - ELSE - ! surface wet fraction. assuming max ponding = 1 kg/m2 - fwet_roof_ = (max(0., wliq_roofsno+wice_roofsno))**(2/3.) - fwet_roof_ = min(1., fwet_roof_) - ENDIF - - ! impervious ground - IF (lbi < 1) THEN - fwet_gimp_ = fsno_gimp !for snow layer exist - ELSE - ! surface wet fraction. assuming max ponding = 1 kg/m2 - fwet_gimp_ = (max(0., wliq_gimpsno+wice_gimpsno))**(2/3.) - fwet_gimp_ = min(1., fwet_gimp_) - ENDIF - - ! dew case - IF (qm > qroof) THEN - fwet_roof = 1. - ELSE - fwet_roof = fwet_roof_ - ENDIF - - ! ! dew case - IF (qm > qgimp) THEN - fwet_gimp = 1. - ELSE - fwet_gimp = fwet_gimp_ - ENDIF - - ! weighted qg - ! NOTE: IF fwet_gimp=1, same as previous - fwetfac = fgimp*fwet_gimp + fgper - qg = (qgimp*fgimp*fwet_gimp + qgper*fgper) / fwetfac - - fgw(2) = fg*fwetfac + ! set weighting factor + fah(1) = 1.; fah(2) = 1.; fah(3) = 1. + faw(1) = 1.; faw(2) = 1.; faw(3) = 1. + fgh(1) = 1.; fgh(2) = fg; fgh(3) = 1. + fgw(1) = 1.; fgw(2) = fg; fgw(3) = 1. + + ! weighted tg + tg = tgimp*fgimp + tgper*fgper + + ! wet fraction for roof and impervious ground + !------------------------------------------- + ! roof + IF (lbr < 1) THEN + fwet_roof_ = fsno_roof !for snow layer exist + ELSE + ! surface wet fraction. assuming max ponding = 1 kg/m2 + fwet_roof_ = (max(0., wliq_roofsno+wice_roofsno))**(2/3.) + fwet_roof_ = min(1., fwet_roof_) + ENDIF + + ! impervious ground + IF (lbi < 1) THEN + fwet_gimp_ = fsno_gimp !for snow layer exist + ELSE + ! surface wet fraction. assuming max ponding = 1 kg/m2 + fwet_gimp_ = (max(0., wliq_gimpsno+wice_gimpsno))**(2/3.) + fwet_gimp_ = min(1., fwet_gimp_) + ENDIF + + ! dew case + IF (qm > qroof) THEN + fwet_roof = 1. + ELSE + fwet_roof = fwet_roof_ + ENDIF + + ! ! dew case + IF (qm > qgimp) THEN + fwet_gimp = 1. + ELSE + fwet_gimp = fwet_gimp_ + ENDIF + + ! weighted qg + ! NOTE: IF fwet_gimp=1, same as previous + fwetfac = fgimp*fwet_gimp + fgper + qg = (qgimp*fgimp*fwet_gimp + qgper*fgper) / fwetfac + + fgw(2) = fg*fwetfac !----------------------------------------------------------------------- ! initial for fluxes profile !----------------------------------------------------------------------- - nmozsgn = 0 !number of times moz changes sign - obuold = 0. !monin-obukhov length from previous iteration - zii = 1000. !m (pbl height) - beta = 1. !- (in computing W_*) + nmozsgn = 0 !number of times moz changes sign + obuold = 0. !monin-obukhov length from previous iteration + zii = 1000. !m (pbl height) + beta = 1. !- (in computing W_*) !----------------------------------------------------------------------- ! scaling factor bee !----------------------------------------------------------------------- !NOTE: bee value, the default is 1 - bee = 1. + bee = 1. !----------------------------------------------------------------------- ! calculate z0m and displa !----------------------------------------------------------------------- - ! Macdonald et al., 1998, Eq. (23), A=4.43 - displau = hroof * (1 + 4.43**(-fcover(0))*(fcover(0) - 1)) - fai = 4/PI*hlr*fcover(0) - z0mu = (hroof - displau) * & - exp( -(0.5*1.2/vonkar/vonkar*(1-displau/hroof)*fai)**(-0.5) ) + ! Macdonald et al., 1998, Eq. (23), A=4.43 + displau = hroof * (1 + 4.43**(-fcover(0))*(fcover(0) - 1)) + fai = 4/PI*hlr*fcover(0) + z0mu = (hroof - displau) * & + exp( -(0.5*1.2/vonkar/vonkar*(1-displau/hroof)*fai)**(-0.5) ) - ! to compare z0 of urban and only the surface - ! maximum assumption - IF (z0mu < z0mg) z0mu = z0mg + ! to compare z0 of urban and only the surface + ! maximum assumption + IF (z0mu < z0mg) z0mu = z0mg - ! roughness length and displacement height for sensible - ! and latent heat transfer - z0m = z0mu + ! roughness length and displacement height for sensible + ! and latent heat transfer + z0m = z0mu - displa = displau - displau = max(hroof/2., displau) + displa = displau + displau = max(hroof/2., displau) !----------------------------------------------------------------------- ! calculate layer decay coefficient !----------------------------------------------------------------------- - !NOTE: the below is for vegetation, may not suitable for urban - ! Raupach, 1992 - !sqrtdragc = min( (0.003+0.3*fai)**0.5, 0.3 ) + !NOTE: the below is for vegetation, may not suitable for urban + ! Raupach, 1992 + !sqrtdragc = min( (0.003+0.3*fai)**0.5, 0.3 ) - ! Kondo, 1971 - !alpha = hroof/(hroof-displa)/(vonkar/sqrtdragc) + ! Kondo, 1971 + !alpha = hroof/(hroof-displa)/(vonkar/sqrtdragc) - ! Masson, 2000; Oleson et al., 2008 - IF (alpha_opt == 1) alpha = 0.5*hwr + ! Masson, 2000; Oleson et al., 2008 + IF (alpha_opt == 1) alpha = 0.5*hwr - ! Swaid, 1993; Kusaka, 2001; Lee and Park, 2008 - IF (alpha_opt == 2) alpha = 0.772*hwr + ! Swaid, 1993; Kusaka, 2001; Lee and Park, 2008 + IF (alpha_opt == 2) alpha = 0.772*hwr - ! Macdonald, 2000 - IF (alpha_opt == 3) alpha = 9.6*fai + ! Macdonald, 2000 + IF (alpha_opt == 3) alpha = 9.6*fai !----------------------------------------------------------------------- ! first guess for taf and qaf for each layer ! a large differece from previous schemes !----------------------------------------------------------------------- - IF (numlay .eq. 2) THEN - taf(3) = (tg + 2.*thm)/3. - qaf(3) = (qg + 2.*qm )/3. - taf(2) = (2.*tg + thm)/3. - qaf(2) = (2.*qg + qm )/3. - ENDIF + IF (numlay .eq. 2) THEN + taf(3) = (tg + 2.*thm)/3. + qaf(3) = (qg + 2.*qm )/3. + taf(2) = (2.*tg + thm)/3. + qaf(2) = (2.*qg + qm )/3. + ENDIF ! initialization and input values for Monin-Obukhov - ! have been set before - z0h = z0m; z0q = z0m - ur = max(0.1, sqrt(us*us+vs*vs)) !limit set to 0.1 - dth = thm - taf(2) - dqh = qm - qaf(2) - dthv = dth*(1.+0.61*qm) + 0.61*th*dqh + ! have been set before + z0h = z0m; z0q = z0m + ur = max(0.1, sqrt(us*us+vs*vs)) !limit set to 0.1 + dth = thm - taf(2) + dqh = qm - qaf(2) + dthv = dth*(1.+0.61*qm) + 0.61*th*dqh - ! to ensure the obs height >= hroof+10. - huu = max(hroof+10., hu) - htu = max(hroof+10., ht) - hqu = max(hroof+10., hq) + ! to ensure the obs height >= hroof+10. + huu = max(hroof+10., hu) + htu = max(hroof+10., ht) + hqu = max(hroof+10., hq) - zldis = huu - displa + zldis = huu - displa - IF (zldis <= 0.0) THEN - write(6,*) 'the obs height of u less than the zero displacement heght' - CALL abort - ENDIF + IF (zldis <= 0.0) THEN + write(6,*) 'the obs height of u less than the zero displacement heght' + CALL abort + ENDIF - CALL moninobukini(ur,th,thm,thv,dth,dqh,dthv,zldis,z0m,um,obu) + CALL moninobukini(ur,th,thm,thv,dth,dqh,dthv,zldis,z0m,um,obu) - niters=6 + niters=6 ! ====================================================================== -! BEGIN stability iteration +! BEGIN stability iteration ! ====================================================================== - ITERATION : DO iter = 1, niters !begin stability iteration + ITERATION : DO iter = 1, niters !begin stability iteration !----------------------------------------------------------------------- ! Aerodynamical resistances !----------------------------------------------------------------------- ! Evaluate stability-dependent variables using moz from prior iteration - !NOTE: displat=hroof, z0mt=0, are set for roof - ! fmtop is calculated at the same height of fht, fqt - CALL moninobukm(huu,htu,hqu,displa,z0m,z0h,z0q,obu,um, & - hroof,0.,ustar,fh2m,fq2m,hroof,fmtop,fm,fh,fq,fht,fqt,phih) + !NOTE: displat=hroof, z0mt=0, are set for roof + ! fmtop is calculated at the same height of fht, fqt + CALL moninobukm(huu,htu,hqu,displa,z0m,z0h,z0q,obu,um, & + hroof,0.,ustar,fh2m,fq2m,hroof,fmtop,fm,fh,fq,fht,fqt,phih) ! Aerodynamic resistance - ! 09/16/2017: - ! note that for ram, it is the resistance from Href to z0mv+displa - ! however, for rah and raw is only from Href to canopy effective - ! exchange height. - ! for Urban: from Href to roof height - ! so rah/raw is not comparable with that of 1D case - ram = 1./(ustar*ustar/um) + ! 09/16/2017: + ! note that for ram, it is the resistance from Href to z0mv+displa + ! however, for rah and raw is only from Href to canopy effective + ! exchange height. + ! for Urban: from Href to roof height + ! so rah/raw is not comparable with that of 1D case + ram = 1./(ustar*ustar/um) - ! 05/02/2016: calculate resistance from the top layer (effective exchange - ! height) to reference height - ! for Urban: from roof height to reference height - rah = 1./(vonkar/(fh-fht)*ustar) - raw = 1./(vonkar/(fq-fqt)*ustar) + ! 05/02/2016: calculate resistance from the top layer (effective exchange + ! height) to reference height + ! for Urban: from roof height to reference height + rah = 1./(vonkar/(fh-fht)*ustar) + raw = 1./(vonkar/(fq-fqt)*ustar) - ! update roughness length for sensible/latent heat - z0hg = z0mg/exp(0.13 * (ustar*z0mg/1.5e-5)**0.45) - z0qg = z0hg + ! update roughness length for sensible/latent heat + z0hg = z0mg/exp(0.13 * (ustar*z0mg/1.5e-5)**0.45) + z0qg = z0hg - z0h = max(z0hg, z0h) - z0q = max(z0qg, z0q) + z0h = max(z0hg, z0h) + z0q = max(z0qg, z0q) !----------------------------------------------------------------------- ! new method to calculate rd and ueffect ! the kernel part of 3d model !----------------------------------------------------------------------- - ! initialization - rd(:) = 0. - rd_(:) = 0. - ueff_lay(:) = 0. - ueff_lay_(:) = 0. + ! initialization + rd(:) = 0. + rd_(:) = 0. + ueff_lay(:) = 0. + ueff_lay_(:) = 0. - ! calculate canopy top wind speed (utop) and exchange coefficient (ktop) - ! need to update each time as obu changed after each iteration - utop = ustar/vonkar * fmtop - ktop = vonkar * (hroof-displa) * ustar / phih + ! calculate canopy top wind speed (utop) and exchange coefficient (ktop) + ! need to update each time as obu changed after each iteration + utop = ustar/vonkar * fmtop + ktop = vonkar * (hroof-displa) * ustar / phih - ueff_lay(3) = utop + ueff_lay(3) = utop - !REAL(r8) FUNCTION kintegral(ktop, fc, bee, alpha, z0mg, & - ! displah, htop, hbot, obu, ustar, ztop, zbot) - !rd(3) = kintegral(ktop, 1., bee, alpha, z0mg, displa/hroof, & - ! hroof, 0., obug, ustarg, hroof, displa+z0m) + !real(r8) FUNCTION kintegral(ktop, fc, bee, alpha, z0mg, & + ! displah, htop, hbot, obu, ustar, ztop, zbot) + !rd(3) = kintegral(ktop, 1., bee, alpha, z0mg, displa/hroof, & + ! hroof, 0., obug, ustarg, hroof, displa+z0m) - !REAL(r8) FUNCTION frd(ktop, htop, hbot, & - ! ztop, zbot, displah, z0h, obu, ustar, & - ! z0mg, alpha, bee, fc) - rd(3) = frd(ktop, hroof, 0., hroof, displau+z0mu, displa/hroof, z0h_g, & - obug, ustarg, z0mg, alpha, bee, 1.) + !real(r8) FUNCTION frd(ktop, htop, hbot, & + ! ztop, zbot, displah, z0h, obu, ustar, & + ! z0mg, alpha, bee, fc) + rd(3) = frd(ktop, hroof, 0., hroof, displau+z0mu, displa/hroof, z0h_g, & + obug, ustarg, z0mg, alpha, bee, 1.) - !REAL(r8) FUNCTION uintegralz(utop, fc, bee, alpha, z0mg, htop, hbot, ztop, zbot) - !ueff_lay(2) = uintegralz(utop, 1., bee, alpha, z0mg, hroof, 0., hroof, z0mg) + !real(r8) FUNCTION uintegralz(utop, fc, bee, alpha, z0mg, htop, hbot, ztop, zbot) + !ueff_lay(2) = uintegralz(utop, 1., bee, alpha, z0mg, hroof, 0., hroof, z0mg) - !REAL(r8) FUNCTION ueffectz(utop, htop, hbot, ztop, zbot, z0mg, alpha, bee, fc) - ueff_lay(2) = ueffectz(utop, hroof, 0., hroof, z0mg, z0mg, alpha, bee, 1.) + !real(r8) FUNCTION ueffectz(utop, htop, hbot, ztop, zbot, z0mg, alpha, bee, fc) + ueff_lay(2) = ueffectz(utop, hroof, 0., hroof, z0mg, z0mg, alpha, bee, 1.) - !rd(2) = kintegral(ktop, 1., bee, alpha, z0mg, displa/hroof, & - ! hroof, 0., obug, ustarg, displau+z0mu, z0qg) - rd(2) = frd(ktop, hroof, 0., displau+z0mu, z0qg, displa/hroof, z0h_g, & - obug, ustarg, z0mg, alpha, bee, 1.) + !rd(2) = kintegral(ktop, 1., bee, alpha, z0mg, displa/hroof, & + ! hroof, 0., obug, ustarg, displau+z0mu, z0qg) + rd(2) = frd(ktop, hroof, 0., displau+z0mu, z0qg, displa/hroof, z0h_g, & + obug, ustarg, z0mg, alpha, bee, 1.) - !print *, "------------------------" - !print *, "rd :", rd - !print *, "rd_:", rd_ + !print *, "------------------------" + !print *, "rd :", rd + !print *, "rd_:", rd_ - ! calculate ra2m, rd2m - ra2m = frd(ktop, hroof, 0., displau+z0mu, 2., displa/hroof, z0h_g, & - obug, ustarg, z0mg, alpha, bee, 1.) + ! calculate ra2m, rd2m + ra2m = frd(ktop, hroof, 0., displau+z0mu, 2., displa/hroof, z0h_g, & + obug, ustarg, z0mg, alpha, bee, 1.) - rd2m = frd(ktop, hroof, 0., 2., z0qg, displa/hroof, z0h_g, & - obug, ustarg, z0mg, alpha, bee, 1.) + rd2m = frd(ktop, hroof, 0., 2., z0qg, displa/hroof, z0h_g, & + obug, ustarg, z0mg, alpha, bee, 1.) - ! Masson, 2000: Account for different canyon orientations - ! 2/PI is a factor derived from 0-360deg integration - IF (alpha_opt == 1) THEN - ueff_lay(2) = 2/PI*ueff_lay(2) - rd(:) = PI/2*rd(:) - ENDIF + ! Masson, 2000: Account for different canyon orientations + ! 2/PI is a factor derived from 0-360deg integration + IF (alpha_opt == 1) THEN + ueff_lay(2) = 2/PI*ueff_lay(2) + rd(:) = PI/2*rd(:) + ENDIF !----------------------------------------------------------------------- ! Bulk boundary layer resistance of leaves !----------------------------------------------------------------------- - rb(:) = 0. + rb(:) = 0. - DO i = 0, nurb - clev = canlev(i) - rb(i) = rhoair * cpair / ( 11.8 + 4.2*ueff_lay(clev) ) - ENDDO + DO i = 0, nurb + clev = canlev(i) + rb(i) = rhoair * cpair / ( 11.8 + 4.2*ueff_lay(clev) ) + ENDDO !----------------------------------------------------------------------- ! dimensional and non-dimensional sensible and latent heat conductances ! for canopy and soil flux calculations. !----------------------------------------------------------------------- - !NOTE: 0: roof, 1: sunlit wall, 2: shaded wall, - ! 3: impervious road, 4: pervious road, 5: vegetation - cfh(:) = 0. - cfw(:) = 0. - - DO i = 0, nurb - cfh(i) = 1 / rb(i) - - IF (i == 0) THEN !roof - ! account for fwet - cfw(i) = fwet_roof / rb(i) - ELSE - cfw(i) = 1 / rb(i) - ENDIF - ENDDO - - ! For simplicity, there is no water exchange on the wall - cfw(1:2) = 0. - - ! initialization - cah(:) = 0. - caw(:) = 0. - cgh(:) = 0. - cgw(:) = 0. - - ! conductance for each layer - DO i = 3, 2, -1 - IF (i == 3) THEN - cah(i) = 1. / rah - caw(i) = 1. / raw - ELSE - cah(i) = 1. / rd(i+1) - caw(i) = 1. / rd(i+1) - ENDIF - - cgh(i) = 1. / rd(i) - cgw(i) = 1. / rd(i) - ENDDO - - ! claculate wtshi, wtsqi - wtshi(:) = cah(:)*fah(:) + cgh(:)*fgh(:) - wtsqi(:) = caw(:)*faw(:) + cgw(:)*fgw(:) - - DO i = 0, nurb - clev = canlev(i) - wtshi(clev) = wtshi(clev) + fc(i)*cfh(i) - wtsqi(clev) = wtsqi(clev) + fc(i)*cfw(i) - ENDDO - - DO i = 3, 2, -1 - wtshi(i) = 1./wtshi(i) - wtsqi(i) = 1./wtsqi(i) - ENDDO - - wta0(:) = cah(:) * wtshi(:) * fah(:) - wtg0(:) = cgh(:) * wtshi(:) * fgh(:) - - wtaq0(:) = caw(:) * wtsqi(:) * faw(:) - wtgq0(:) = cgw(:) * wtsqi(:) * fgw(:) - - ! calculate wtl0, wtll, wtlq0, wtlql - wtll(:) = 0. - wtlql(:) = 0. - - DO i = 0, nurb - clev = canlev(i) - - wtl0(i) = cfh(i) * wtshi(clev) * fc(i) - wtll(clev) = wtll(clev) + wtl0(i)*tu(i) - - wtlq0(i) = cfw(i) * wtsqi(clev) * fc(i) - wtlql(clev) = wtlql(clev) + wtlq0(i)*qsatl(i) - ENDDO - - IF (numlay .eq. 2) THEN - - ! - Equations: - ! taf(3) = (1/rah*thm + 1/rd(3)*taf(2) + 1/rb(0)*troof*fc(0) + AHE/(rho*cp))/(1/rah + 1/rd(3) + 1/rb(0)*fc(0)) - ! taf(2) = (1/rd(3)*taf(3) + 1/rd(2)*tg*fg + 1/rb(1)*twsun*fc(1) + 1/rb(2)*twsha*fc(2) + AHE/(rho*cp))/ & - ! (1/rd(3) + 1/rd(2)*fg + 1/rb(1)*fc(1) + 1/rb(2)*fc(2)) - ! Also written as: - ! taf(3) = (cah(3)*thm + cah(2)*taf(2) + cfh(0)*troof*fc(0))/(cah(3) + cah(2) + cfh(0)*fc(0)) - ! taf(2) = (cah(2)*taf(3) + cgh(2)*tg*fg + cfh(1)*twsun*fc(1) + cfh(2)*twsha*fc(2) + AHE/(rho*cp))/ & - ! (cah(2) + cgh(2)*fg + cfh(1)*fc(1) + cfh(2)*fc(2)) - - ! - Equations: - ! qaf(3) = (1/raw*qm + 1/rd(3)*qaf(2) + 1/rb(0)*qroof*fc(0))/(1/raw + 1/rd(3) + 1/rb(0)*fc(0)) - ! qaf(2) = (1/rd(3)*qaf(3) + 1/(rd(2)+rsr)*qper*fgper*fg + fwetimp/rd(2)*qimp*fgimp*fg + AHE/rho)/ & - ! (1/rd(3) + 1/(rd(2)+rsr)*fgper*fg + fwetimp/rd(2)*fgimp*fg) - ! Also written as: - ! qaf(3) = (caw(3)*qm + caw(2)*qaf(2) + cfw(0)*qroof*fc(0))/(caw(3) + caw(2) + cfw(0)*fc(0)) - ! qaf(2) = (caw(2)*qaf(3) + cgwper*qper*fgper*fg + cgwimp*qimp*fgimp*fg + AHE/rho)/ & - ! (caw(2) + cgwper*fgper*fg + cgwimp*fgimp*fg) - - ! 06/20/2021, yuan: account for Anthropogenic heat - ! 92% heat release as SH, Pigeon et al., 2007 - - h_vec = vehc - tmpw1 = cah(2)*((cah(3)*thm + cfh(0)*tu(0)*fc(0) + 1/(4*hlr+1)*(Fhac+Fwst)/(rhoair*cpair))/& - (cah(3) + cah(2) + cfh(0)*fc(0))) - tmpw2 = (4*hlr/(4*hlr+1)*(Fhac+Fwst)+Fach)/(rhoair*cpair) + (h_vec+meta)/(rhoair*cpair) - tmpw3 = cgh(2)*fg*tg + cfh(1)*tu(1)*fc(1) + cfh(2)*tu(2)*fc(2) - fact = 1. - (cah(2)*cah(2)/(cah(3) + cah(2) + cfh(0)*fc(0))/& - (cah(2) + cgh(2)*fg + cfh(1)*fc(1) + cfh(2)*fc(2))) - taf(2) = (tmpw1 + tmpw2 + tmpw3) / & - (cah(2) + cgh(2)*fg + cfh(1)*fc(1) + cfh(2)*fc(2)) / & - fact - - IF (qgper < qaf(2)) THEN - ! dew case. no soil resistance - cgw_per= cgw(2) - ELSE - cgw_per= 1/(1/cgw(2)+rsr) - ENDIF - - cgw_imp= fwet_gimp*cgw(2) - - - ! account for soil resistance, qgper and qgimp are calculated separately - l_vec = 0 - tmpw1 = caw(2)*((caw(3)*qm + cfw(0)*qsatl(0)*fc(0))/& - (caw(3) + caw(2) + cfw(0)*fc(0))) - tmpw2 = l_vec/(rhoair) - tmpw3 = cgw_per*qgper*fgper*fg + cgw_imp*qgimp*fgimp*fg - facq = 1. - (caw(2)*caw(2)/& - (caw(3) + caw(2) + cfw(0)*fc(0))/& - (caw(2) + cgw_per*fgper*fg + cgw_imp*fgimp*fg)) - qaf(2) = (tmpw1 + tmpw2 + tmpw3)/& - (caw(2) + cgw_per*fgper*fg + cgw_imp*fgimp*fg)/& - facq - - tmpw1 = 1/(4*hlr+1)*(Fhac+Fwst)/(rhoair*cpair) - taf(3) = (cah(3)*thm + cah(2)*taf(2) + cfh(0)*tu(0)*fc(0) + tmpw1)/& - (cah(3) + cah(2) + cfh(0)*fc(0)) - qaf(3) = (caw(3)*qm + caw(2)*qaf(2) + cfw(0)*qsatl(0)*fc(0))/& - (caw(3) + caw(2) + cfw(0)*fc(0)) - ENDIF - - !------------------------------------------------ - ! update fwet for roof and impervious ground - ! to check whether dew happens - IF (qaf(3) > qroof) THEN - fwet_roof = 1. !dew case - ELSE - fwet_roof = fwet_roof_ - ENDIF - - ! to check whether dew happens - IF (qaf(2) > qgimp) THEN - fwet_gimp = 1. !dew case - ELSE - fwet_gimp = fwet_gimp_ - ENDIF - - ! weighted qg - ! NOTE: IF fwet_gimp=1, same as previous - fwetfac = fgimp*fwet_gimp + fgper - qg = (qgimp*fgimp*fwet_gimp + qgper*fgper) / fwetfac - - fgw(2) = fg*fwetfac + !NOTE: 0: roof, 1: sunlit wall, 2: shaded wall, + ! 3: impervious road, 4: pervious road, 5: vegetation + cfh(:) = 0. + cfw(:) = 0. + + DO i = 0, nurb + cfh(i) = 1 / rb(i) + + IF (i == 0) THEN !roof + ! account for fwet + cfw(i) = fwet_roof / rb(i) + ELSE + cfw(i) = 1 / rb(i) + ENDIF + ENDDO + + ! For simplicity, there is no water exchange on the wall + cfw(1:2) = 0. + + ! initialization + cah(:) = 0. + caw(:) = 0. + cgh(:) = 0. + cgw(:) = 0. + + ! conductance for each layer + DO i = 3, 2, -1 + IF (i == 3) THEN + cah(i) = 1. / rah + caw(i) = 1. / raw + ELSE + cah(i) = 1. / rd(i+1) + caw(i) = 1. / rd(i+1) + ENDIF + + cgh(i) = 1. / rd(i) + cgw(i) = 1. / rd(i) + ENDDO + + ! claculate wtshi, wtsqi + wtshi(:) = cah(:)*fah(:) + cgh(:)*fgh(:) + wtsqi(:) = caw(:)*faw(:) + cgw(:)*fgw(:) + + DO i = 0, nurb + clev = canlev(i) + wtshi(clev) = wtshi(clev) + fc(i)*cfh(i) + wtsqi(clev) = wtsqi(clev) + fc(i)*cfw(i) + ENDDO + + DO i = 3, 2, -1 + wtshi(i) = 1./wtshi(i) + wtsqi(i) = 1./wtsqi(i) + ENDDO + + wta0(:) = cah(:) * wtshi(:) * fah(:) + wtg0(:) = cgh(:) * wtshi(:) * fgh(:) + + wtaq0(:) = caw(:) * wtsqi(:) * faw(:) + wtgq0(:) = cgw(:) * wtsqi(:) * fgw(:) + + ! calculate wtl0, wtll, wtlq0, wtlql + wtll(:) = 0. + wtlql(:) = 0. + + DO i = 0, nurb + clev = canlev(i) + + wtl0(i) = cfh(i) * wtshi(clev) * fc(i) + wtll(clev) = wtll(clev) + wtl0(i)*tu(i) + + wtlq0(i) = cfw(i) * wtsqi(clev) * fc(i) + wtlql(clev) = wtlql(clev) + wtlq0(i)*qsatl(i) + ENDDO + + IF (numlay .eq. 2) THEN + + ! - Equations: + ! taf(3) = (1/rah*thm + 1/rd(3)*taf(2) + 1/rb(0)*troof*fc(0) + AHE/(rho*cp))/(1/rah + 1/rd(3) + 1/rb(0)*fc(0)) + ! taf(2) = (1/rd(3)*taf(3) + 1/rd(2)*tg*fg + 1/rb(1)*twsun*fc(1) + 1/rb(2)*twsha*fc(2) + AHE/(rho*cp))/ & + ! (1/rd(3) + 1/rd(2)*fg + 1/rb(1)*fc(1) + 1/rb(2)*fc(2)) + ! Also written as: + ! taf(3) = (cah(3)*thm + cah(2)*taf(2) + cfh(0)*troof*fc(0))/(cah(3) + cah(2) + cfh(0)*fc(0)) + ! taf(2) = (cah(2)*taf(3) + cgh(2)*tg*fg + cfh(1)*twsun*fc(1) + cfh(2)*twsha*fc(2) + AHE/(rho*cp))/ & + ! (cah(2) + cgh(2)*fg + cfh(1)*fc(1) + cfh(2)*fc(2)) + + ! - Equations: + ! qaf(3) = (1/raw*qm + 1/rd(3)*qaf(2) + 1/rb(0)*qroof*fc(0))/(1/raw + 1/rd(3) + 1/rb(0)*fc(0)) + ! qaf(2) = (1/rd(3)*qaf(3) + 1/(rd(2)+rsr)*qper*fgper*fg + fwetimp/rd(2)*qimp*fgimp*fg + AHE/rho)/ & + ! (1/rd(3) + 1/(rd(2)+rsr)*fgper*fg + fwetimp/rd(2)*fgimp*fg) + ! Also written as: + ! qaf(3) = (caw(3)*qm + caw(2)*qaf(2) + cfw(0)*qroof*fc(0))/(caw(3) + caw(2) + cfw(0)*fc(0)) + ! qaf(2) = (caw(2)*qaf(3) + cgwper*qper*fgper*fg + cgwimp*qimp*fgimp*fg + AHE/rho)/ & + ! (caw(2) + cgwper*fgper*fg + cgwimp*fgimp*fg) + + ! 06/20/2021, yuan: account for Anthropogenic heat + ! 92% heat release as SH, Pigeon et al., 2007 + + h_vec = vehc + tmpw1 = cah(2)*((cah(3)*thm + cfh(0)*tu(0)*fc(0) + 1/(4*hlr+1)*(Fhac+Fwst)/(rhoair*cpair))/& + (cah(3) + cah(2) + cfh(0)*fc(0))) + tmpw2 = (4*hlr/(4*hlr+1)*(Fhac+Fwst)+Fach)/(rhoair*cpair) + (h_vec+meta)/(rhoair*cpair) + tmpw3 = cgh(2)*fg*tg + cfh(1)*tu(1)*fc(1) + cfh(2)*tu(2)*fc(2) + fact = 1. - (cah(2)*cah(2)/(cah(3) + cah(2) + cfh(0)*fc(0))/& + (cah(2) + cgh(2)*fg + cfh(1)*fc(1) + cfh(2)*fc(2))) + taf(2) = (tmpw1 + tmpw2 + tmpw3) / & + (cah(2) + cgh(2)*fg + cfh(1)*fc(1) + cfh(2)*fc(2)) / & + fact + + IF (qgper < qaf(2)) THEN + ! dew case. no soil resistance + cgw_per= cgw(2) + ELSE + cgw_per= 1/(1/cgw(2)+rsr) + ENDIF + + cgw_imp= fwet_gimp*cgw(2) + + + ! account for soil resistance, qgper and qgimp are calculated separately + l_vec = 0 + tmpw1 = caw(2)*((caw(3)*qm + cfw(0)*qsatl(0)*fc(0))/& + (caw(3) + caw(2) + cfw(0)*fc(0))) + tmpw2 = l_vec/(rhoair) + tmpw3 = cgw_per*qgper*fgper*fg + cgw_imp*qgimp*fgimp*fg + facq = 1. - (caw(2)*caw(2)/& + (caw(3) + caw(2) + cfw(0)*fc(0))/& + (caw(2) + cgw_per*fgper*fg + cgw_imp*fgimp*fg)) + qaf(2) = (tmpw1 + tmpw2 + tmpw3)/& + (caw(2) + cgw_per*fgper*fg + cgw_imp*fgimp*fg)/& + facq + + tmpw1 = 1/(4*hlr+1)*(Fhac+Fwst)/(rhoair*cpair) + taf(3) = (cah(3)*thm + cah(2)*taf(2) + cfh(0)*tu(0)*fc(0) + tmpw1)/& + (cah(3) + cah(2) + cfh(0)*fc(0)) + qaf(3) = (caw(3)*qm + caw(2)*qaf(2) + cfw(0)*qsatl(0)*fc(0))/& + (caw(3) + caw(2) + cfw(0)*fc(0)) + ENDIF + + !------------------------------------------------ + ! update fwet for roof and impervious ground + ! to check whether dew happens + IF (qaf(3) > qroof) THEN + fwet_roof = 1. !dew case + ELSE + fwet_roof = fwet_roof_ + ENDIF + + ! to check whether dew happens + IF (qaf(2) > qgimp) THEN + fwet_gimp = 1. !dew case + ELSE + fwet_gimp = fwet_gimp_ + ENDIF + + ! weighted qg + ! NOTE: IF fwet_gimp=1, same as previous + fwetfac = fgimp*fwet_gimp + fgper + qg = (qgimp*fgimp*fwet_gimp + qgper*fgper) / fwetfac + + fgw(2) = fg*fwetfac !----------------------------------------------------------------------- ! Update monin-obukhov length and wind speed including the stability effect !----------------------------------------------------------------------- - ! USE the top layer taf and qaf - !TODO: need more check - dth = thm - taf(2) - dqh = qm - qaf(2) + ! USE the top layer taf and qaf + !TODO: need more check + dth = thm - taf(2) + dqh = qm - qaf(2) - tstar = vonkar/(fh)*dth - qstar = vonkar/(fq)*dqh + tstar = vonkar/(fh)*dth + qstar = vonkar/(fq)*dqh - thvstar = tstar*(1.+0.61*qm)+0.61*th*qstar - zeta = zldis*vonkar*grav*thvstar / (ustar**2*thv) - IF (zeta .ge. 0.) THEN !stable - zeta = min(2.,max(zeta,1.e-6)) - ELSE !unstable - zeta = max(-100.,min(zeta,-1.e-6)) - ENDIF - obu = zldis/zeta + thvstar = tstar*(1.+0.61*qm)+0.61*th*qstar + zeta = zldis*vonkar*grav*thvstar / (ustar**2*thv) + IF (zeta .ge. 0.) THEN !stable + zeta = min(2.,max(zeta,1.e-6)) + ELSE !unstable + zeta = max(-100.,min(zeta,-1.e-6)) + ENDIF + obu = zldis/zeta - IF (zeta .ge. 0.) THEN - um = max(ur,.1) - ELSE - wc = (-grav*ustar*thvstar*zii/thv)**(1./3.) - wc2 = beta*beta*(wc*wc) - um = sqrt(ur*ur+wc2) - ENDIF + IF (zeta .ge. 0.) THEN + um = max(ur,.1) + ELSE + wc = (-grav*ustar*thvstar*zii/thv)**(1./3.) + wc2 = beta*beta*(wc*wc) + um = sqrt(ur*ur+wc2) + ENDIF - IF (obuold*obu .lt. 0.) nmozsgn = nmozsgn+1 - IF (nmozsgn >= 4) EXIT + IF (obuold*obu .lt. 0.) nmozsgn = nmozsgn+1 + IF (nmozsgn >= 4) EXIT - obuold = obu + obuold = obu - ENDDO ITERATION !end stability iteration + ENDDO ITERATION !end stability iteration ! ====================================================================== -! END stability iteration +! END stability iteration ! ====================================================================== - zol = zeta - rib = min(5.,zol*ustar**2/(vonkar**2/fh*um**2)) + zol = zeta + rib = min(5.,zol*ustar**2/(vonkar**2/fh*um**2)) - ! sensible heat fluxes - fsenroof = rhoair*cpair*cfh(0)*(troof-taf(3)) - fsenwsun = rhoair*cpair*cfh(1)*(twsun-taf(2)) - fsenwsha = rhoair*cpair*cfh(2)*(twsha-taf(2)) + ! sensible heat fluxes + fsenroof = rhoair*cpair*cfh(0)*(troof-taf(3)) + fsenwsun = rhoair*cpair*cfh(1)*(twsun-taf(2)) + fsenwsha = rhoair*cpair*cfh(2)*(twsha-taf(2)) - ! latent heat fluxes - fevproof = rhoair*cfw(0)*(qsatl(0)-qaf(3)) - fevproof = fevproof*fwet_roof + ! latent heat fluxes + fevproof = rhoair*cfw(0)*(qsatl(0)-qaf(3)) + fevproof = fevproof*fwet_roof - ! fact = 1. - wta0(2)*wtg0(3) - ! facq = 1. - wtaq0(2)*wtgq0(3) - ! deduce: croofs = rhoair*cpair*cfh(0)*(1.-wtg0(3)*wta0(2)*wtl0(0)/fact-wtl0(0)) - croofs = rhoair*cpair*cfh(0)*(1.-wtl0(0)/fact) - cwalls = rhoair*cpair*cfh(1)*(1.-wtl0(1)/fact) - ! deduce: croofl = rhoair*cfw(0)*(1.-wtgq0(3)*wtaq0(2)*wtlq0(0)/facq-wtlq0(0))*qsatldT(0) - croofl = rhoair*cfw(0)*(1.-wtlq0(0)/facq)*qsatldT(0) - croofl = croofl*fwet_roof + ! fact = 1. - wta0(2)*wtg0(3) + ! facq = 1. - wtaq0(2)*wtgq0(3) + ! deduce: croofs = rhoair*cpair*cfh(0)*(1.-wtg0(3)*wta0(2)*wtl0(0)/fact-wtl0(0)) + croofs = rhoair*cpair*cfh(0)*(1.-wtl0(0)/fact) + cwalls = rhoair*cpair*cfh(1)*(1.-wtl0(1)/fact) + ! deduce: croofl = rhoair*cfw(0)*(1.-wtgq0(3)*wtaq0(2)*wtlq0(0)/facq-wtlq0(0))*qsatldT(0) + croofl = rhoair*cfw(0)*(1.-wtlq0(0)/facq)*qsatldT(0) + croofl = croofl*fwet_roof - croof = croofs + croofl*htvp_roof + croof = croofs + croofl*htvp_roof #if(defined CoLMDEBUG) #endif - tafu = taf(2) + tafu = taf(2) !----------------------------------------------------------------------- ! wind stresses !----------------------------------------------------------------------- - taux = - rhoair*us/ram - tauy = - rhoair*vs/ram + taux = - rhoair*us/ram + tauy = - rhoair*vs/ram !----------------------------------------------------------------------- ! fluxes from urban ground to canopy space !----------------------------------------------------------------------- - fsengper = cpair*rhoair*cgh(2)*(tgper-taf(2)) - fsengimp = cpair*rhoair*cgh(2)*(tgimp-taf(2)) + fsengper = cpair*rhoair*cgh(2)*(tgper-taf(2)) + fsengimp = cpair*rhoair*cgh(2)*(tgimp-taf(2)) - fevpgper = rhoair*cgw_per*(qgper-qaf(2)) - fevpgimp = rhoair*cgw_imp*(qgimp-qaf(2)) - fevpgimp = fevpgimp*fwet_gimp + fevpgper = rhoair*cgw_per*(qgper-qaf(2)) + fevpgimp = rhoair*cgw_imp*(qgimp-qaf(2)) + fevpgimp = fevpgimp*fwet_gimp !----------------------------------------------------------------------- ! Derivative of soil energy flux with respect to soil temperature (cgrnd) !----------------------------------------------------------------------- - cgrnds = cpair*rhoair*cgh(2)*(1.-wtg0(2)/fact) - ! cgperl = rhoair*cgw(2)*(1.-wtgq0(2)/facq)*dqgperdT - ! cgimpl = rhoair*cgw(2)*(1.-wtgq0(2)/facq)*dqgimpdT + cgrnds = cpair*rhoair*cgh(2)*(1.-wtg0(2)/fact) + ! cgperl = rhoair*cgw(2)*(1.-wtgq0(2)/facq)*dqgperdT + ! cgimpl = rhoair*cgw(2)*(1.-wtgq0(2)/facq)*dqgimpdT - cgperl = rhoair*cgw_per*(dqgperdT & - - (dqgperdT*cgw_per*fgper*fg+dqgimpdT*cgw_imp*fgimp*fg) & - /(caw(2) + cgw_per*fgper*fg + cgw_imp*fgimp*fg) & - /facq) - cgimpl = rhoair*cgw_imp*(dqgimpdT & - - (dqgperdT*cgw_per*fgper*fg+dqgimpdT*cgw_imp*fgimp*fg) & - /(caw(2) + cgw_per*fgper*fg + cgw_imp*fgimp*fg) & - /facq) - cgimpl = cgimpl*fwet_gimp + cgperl = rhoair*cgw_per*(dqgperdT & + - (dqgperdT*cgw_per*fgper*fg+dqgimpdT*cgw_imp*fgimp*fg) & + /(caw(2) + cgw_per*fgper*fg + cgw_imp*fgimp*fg) & + /facq) + cgimpl = rhoair*cgw_imp*(dqgimpdT & + - (dqgperdT*cgw_per*fgper*fg+dqgimpdT*cgw_imp*fgimp*fg) & + /(caw(2) + cgw_per*fgper*fg + cgw_imp*fgimp*fg) & + /facq) + cgimpl = cgimpl*fwet_gimp - cgimp = cgrnds + cgimpl*htvp_gimp - cgper = cgrnds + cgperl*htvp_gper + cgimp = cgrnds + cgimpl*htvp_gimp + cgper = cgrnds + cgperl*htvp_gper !----------------------------------------------------------------------- ! 2 m height air temperature above apparent sink height !----------------------------------------------------------------------- - !tref = thm + vonkar/(fh-fht)*dth * (fh2m/vonkar - fh/vonkar) - !qref = qm + vonkar/(fq-fqt)*dqh * (fq2m/vonkar - fq/vonkar) - - END SUBROUTINE UrbanOnlyFlux - - - SUBROUTINE UrbanVegFlux ( & - ! Model running information - ipatch ,deltim ,lbr ,lbi ,& - ! Forcing - hu ,ht ,hq ,us ,& - vs ,thm ,th ,thv ,& - qm ,psrf ,rhoair ,frl ,& - po2m ,pco2m ,par ,sabv ,& - rstfac ,Fhac ,Fwst ,Fach ,& - vehc ,meta ,& - ! Urban and vegetation parameters - hroof ,hwr ,nurb ,fcover ,& - ewall ,egimp ,egper ,ev ,& - htop ,hbot ,lai ,sai ,& - sqrtdi ,effcon ,vmax25 ,slti ,& - hlti ,shti ,hhti ,trda ,& - trdm ,trop ,g1 ,g0 ,& - gradm ,binter ,extkn ,extkd ,& - dewmx ,etrc ,& - ! Status of surface - z0h_g ,obug ,ustarg ,zlnd ,& - zsno ,fsno_roof ,fsno_gimp ,fsno_gper ,& - wliq_roofsno,wliq_gimpsno,wice_roofsno,wice_gimpsno,& - htvp_roof ,htvp_gimp ,htvp_gper ,troof ,& - twsun ,twsha ,tgimp ,tgper ,& - qroof ,qgimp ,qgper ,dqroofdT ,& - dqgimpdT ,dqgperdT ,sigf ,tl ,& - ldew ,rsr ,& - ! Longwave information - Ainv ,B ,B1 ,dBdT ,& - SkyVF ,VegVF ,& - ! Output - taux ,tauy ,fsenroof ,fsenwsun ,& - fsenwsha ,fsengimp ,fsengper ,fevproof ,& - fevpgimp ,fevpgper ,croofs ,cwalls ,& - cgrnds ,croofl ,cgimpl ,cgperl ,& - croof ,cgimp ,cgper ,fsenl ,& - fevpl ,etr ,rst ,assim ,& - respc ,lwsun ,lwsha ,lgimp ,& - lgper ,lveg ,lout ,tref ,& - qref ,z0m ,zol ,rib ,& - ustar ,qstar ,tstar ,fm ,& - fh ,fq ,tafu ) + !tref = thm + vonkar/(fh-fht)*dth * (fh2m/vonkar - fh/vonkar) + !qref = qm + vonkar/(fq-fqt)*dqh * (fq2m/vonkar - fq/vonkar) + + END SUBROUTINE UrbanOnlyFlux + + + SUBROUTINE UrbanVegFlux ( & + ! Model running information + ipatch ,deltim ,lbr ,lbi ,& + ! Forcing + hu ,ht ,hq ,us ,& + vs ,thm ,th ,thv ,& + qm ,psrf ,rhoair ,frl ,& + po2m ,pco2m ,par ,sabv ,& + rstfac ,Fhac ,Fwst ,Fach ,& + vehc ,meta ,& + ! Urban and vegetation parameters + hroof ,hwr ,nurb ,fcover ,& + ewall ,egimp ,egper ,ev ,& + htop ,hbot ,lai ,sai ,& + sqrtdi ,effcon ,vmax25 ,slti ,& + hlti ,shti ,hhti ,trda ,& + trdm ,trop ,g1 ,g0 ,& + gradm ,binter ,extkn ,extkd ,& + dewmx ,etrc ,& + ! Status of surface + z0h_g ,obug ,ustarg ,zlnd ,& + zsno ,fsno_roof ,fsno_gimp ,fsno_gper ,& + wliq_roofsno,wliq_gimpsno,wice_roofsno,wice_gimpsno,& + htvp_roof ,htvp_gimp ,htvp_gper ,troof ,& + twsun ,twsha ,tgimp ,tgper ,& + qroof ,qgimp ,qgper ,dqroofdT ,& + dqgimpdT ,dqgperdT ,sigf ,tl ,& + ldew ,rsr ,& + ! Longwave information + Ainv ,B ,B1 ,dBdT ,& + SkyVF ,VegVF ,& + ! Output + taux ,tauy ,fsenroof ,fsenwsun ,& + fsenwsha ,fsengimp ,fsengper ,fevproof ,& + fevpgimp ,fevpgper ,croofs ,cwalls ,& + cgrnds ,croofl ,cgimpl ,cgperl ,& + croof ,cgimp ,cgper ,fsenl ,& + fevpl ,etr ,rst ,assim ,& + respc ,lwsun ,lwsha ,lgimp ,& + lgper ,lveg ,lout ,tref ,& + qref ,z0m ,zol ,rib ,& + ustar ,qstar ,tstar ,fm ,& + fh ,fq ,tafu ) !======================================================================= - USE MOD_Precision - USE MOD_Const_Physical, only: vonkar,grav,hvap,cpair,stefnc - USE MOD_FrictionVelocity - USE MOD_CanopyLayerProfile - USE MOD_AssimStomataConductance - IMPLICIT NONE + USE MOD_Precision + USE MOD_Const_Physical, only: vonkar,grav,hvap,cpair,stefnc + USE MOD_FrictionVelocity + USE MOD_CanopyLayerProfile + USE MOD_AssimStomataConductance + IMPLICIT NONE !-----------------------Arguments--------------------------------------- - INTEGER, intent(in) :: & + integer, intent(in) :: & ipatch, &! patch index [-] lbr, &! lower bound of array lbi ! lower bound of array - REAL(r8), intent(in) :: & + real(r8), intent(in) :: & deltim ! seconds in a time step [second] - ! Forcing - REAL(r8), intent(in) :: & + ! Forcing + real(r8), intent(in) :: & hu, &! observational height of wind [m] ht, &! observational height of temperature [m] hq, &! observational height of humidity [m] @@ -952,22 +952,22 @@ SUBROUTINE UrbanVegFlux ( & Fwst, &! waste heat from cool or heat Fach ! flux from air exchange - ! Urban and vegetation parameters - INTEGER, intent(in) :: & + ! Urban and vegetation parameters + integer, intent(in) :: & nurb ! number of aboveground urban components [-] - REAL(r8), intent(in) :: & + real(r8), intent(in) :: & hroof, &! average building height [m] hwr, &! average building height to their distance [-] fcover(0:5)! coverage of aboveground urban components [-] - REAL(r8), intent(in) :: & + real(r8), intent(in) :: & ewall, &! emissivity of walls egimp, &! emissivity of impervious road egper, &! emissivity of pervious road ev ! emissivity of vegetation - REAL(r8), intent(in) :: & + real(r8), intent(in) :: & htop, &! PFT crown top height [m] hbot, &! PFT crown bottom height [m] lai, &! adjusted leaf area index for seasonal variation [-] @@ -994,8 +994,8 @@ SUBROUTINE UrbanVegFlux ( & dewmx, &! maximum dew etrc ! maximum possible transpiration rate (mm/s) - ! Status of surface - REAL(r8), intent(in) :: & + ! Status of surface + real(r8), intent(in) :: & rsr, &! bare soil resistance for evaporation z0h_g, &! roughness length for bare ground, sensible heat [m] obug, &! monin-obukhov length for bare ground (m) @@ -1027,18 +1027,18 @@ SUBROUTINE UrbanVegFlux ( & dqgperdT, &! d(qgper)/dT sigf ! - REAL(r8), intent(inout) :: & + real(r8), intent(inout) :: & tl, &! leaf temperature [K] ldew ! depth of water on foliage [mm] - REAL(r8), intent(in) :: Ainv(5,5) !Inverse of Radiation transfer matrix - REAL(r8), intent(in) :: SkyVF (5) !View factor to sky - REAL(r8), intent(in) :: VegVF (5) !View factor to veg - REAL(r8), intent(inout) :: B (5) !Vectors of incident radition on each surface - REAL(r8), intent(inout) :: B1 (5) !Vectors of incident radition on each surface - REAL(r8), intent(inout) :: dBdT (5) !Vectors of incident radition on each surface + real(r8), intent(in) :: Ainv(5,5) !Inverse of Radiation transfer matrix + real(r8), intent(in) :: SkyVF (5) !View factor to sky + real(r8), intent(in) :: VegVF (5) !View factor to veg + real(r8), intent(inout) :: B (5) !Vectors of incident radition on each surface + real(r8), intent(inout) :: B1 (5) !Vectors of incident radition on each surface + real(r8), intent(inout) :: dBdT (5) !Vectors of incident radition on each surface - REAL(r8), intent(out) :: & + real(r8), intent(out) :: & taux, &! wind stress: E-W [kg/m/s**2] tauy, &! wind stress: N-S [kg/m/s**2] fsenroof, &! sensible heat flux from roof [W/m2] @@ -1063,7 +1063,7 @@ SUBROUTINE UrbanVegFlux ( & tref, &! 2 m height air temperature [kelvin] qref ! 2 m height air humidity - REAL(r8), intent(out) :: & + real(r8), intent(out) :: & fsenl, &! sensible heat from leaves [W/m2] fevpl, &! evaporation+transpiration from leaves [mm/s] etr, &! transpiration rate [mm/s] @@ -1071,7 +1071,7 @@ SUBROUTINE UrbanVegFlux ( & assim, &! rate of assimilation respc ! rate of respiration - REAL(r8), intent(inout) :: & + real(r8), intent(inout) :: & lwsun, &! net longwave radiation of sunlit wall lwsha, &! net longwave radiation of shaded wall lgimp, &! net longwave radiation of impervious road @@ -1079,7 +1079,7 @@ SUBROUTINE UrbanVegFlux ( & lveg, &! net longwave radiation of vegetation lout ! out-going longwave radiation - REAL(r8), intent(inout) :: & + real(r8), intent(inout) :: & z0m, &! effective roughness [m] zol, &! dimensionless height (z/L) used in Monin-Obukhov theory rib, &! bulk Richardson number in surface layer @@ -1093,15 +1093,15 @@ SUBROUTINE UrbanVegFlux ( & !-----------------------Local Variables--------------------------------- ! assign iteration parameters - INTEGER, parameter :: itmax = 40 !maximum number of iteration - INTEGER, parameter :: itmin = 6 !minimum number of iteration - REAL(r8),parameter :: delmax = 3.0 !maximum change in leaf temperature [K] - REAL(r8),parameter :: dtmin = 0.01 !max limit for temperature convergence [K] - REAL(r8),parameter :: dlemin = 0.1 !max limit for energy flux convergence [w/m2] + integer, parameter :: itmax = 40 !maximum number of iteration + integer, parameter :: itmin = 6 !minimum number of iteration + real(r8),parameter :: delmax = 3.0 !maximum change in leaf temperature [K] + real(r8),parameter :: dtmin = 0.01 !max limit for temperature convergence [K] + real(r8),parameter :: dlemin = 0.1 !max limit for energy flux convergence [w/m2] - REAL(r8) dtl(0:itmax+1) !difference of tl between two iterative step + real(r8) dtl(0:itmax+1) !difference of tl between two iterative step - REAL(r8) :: & + real(r8) :: & zldis, &! reference height "minus" zero displacement heght [m] zii, &! convective boundary layer height [m] z0mv, &! roughness length of vegetation only, momentum [m] @@ -1148,23 +1148,23 @@ SUBROUTINE UrbanVegFlux ( & gdh2o, &! conductance between canopy and ground tprcor ! tf*psur*100./1.013e5 - INTEGER it, nmozsgn + integer it, nmozsgn - REAL(r8) evplwet, evplwet_dtl, etr_dtl, elwmax, elwdif - REAL(r8) irab, dirab_dtl, fsenl_dtl, fevpl_dtl - REAL(r8) z0mg, z0hg, z0qg, cint(3) - REAL(r8) fevpl_bef, fevpl_noadj, dtl_noadj, erre + real(r8) evplwet, evplwet_dtl, etr_dtl, elwmax, elwdif + real(r8) irab, dirab_dtl, fsenl_dtl, fevpl_dtl + real(r8) z0mg, z0hg, z0qg, cint(3) + real(r8) fevpl_bef, fevpl_noadj, dtl_noadj, erre !----------------------- defination for 3d run ------------------------ ! - INTEGER, parameter :: nlay = 3 - INTEGER, parameter :: uvec(5) = (/0,0,0,0,1/) !unit vector + integer, parameter :: nlay = 3 + integer, parameter :: uvec(5) = (/0,0,0,0,1/) !unit vector - INTEGER :: & + integer :: & clev, &! current layer index botlay, &! botom layer index numlay ! available layer number - REAL(r8) :: & + real(r8) :: & huu, &! observational height of wind [m] htu, &! observational height of temperature [m] hqu, &! observational height of humidity [m] @@ -1183,7 +1183,7 @@ SUBROUTINE UrbanVegFlux ( & tg, &! ground temperature qg ! ground specific humidity - REAL(r8) :: & + real(r8) :: & fg, &! ground fractional cover fgimp, &! weight of impervious ground fgper, &! weight of pervious ground @@ -1198,14 +1198,14 @@ SUBROUTINE UrbanVegFlux ( & alpha, &! exponential extinction factor for u/k decline within urban alphav ! exponential extinction factor for u/k decline within trees - REAL(r8) :: & + real(r8) :: & lwsun_bef,&! change of lw for the last time lwsha_bef,&! change of lw for the last time lgimp_bef,&! change of lw for the last time lgper_bef,&! change of lw for the last time lveg_bef ! change of lw for the last time - REAL(r8), dimension(0:nurb) :: & + real(r8), dimension(0:nurb) :: & tu, &! termperature array fc, &! fractional cover array canlev, &! urban canopy layer lookup table @@ -1220,7 +1220,7 @@ SUBROUTINE UrbanVegFlux ( & qsatl, &! leaf specific humidity [kg/kg] qsatldT ! derivative of "qsatl" on "tlef" - REAL(r8), dimension(nlay) :: & + real(r8), dimension(nlay) :: & fah, &! weight for thermal resistance to upper layer faw, &! weight for moisture resistance to upper layer fgh, &! weight for thermal resistance to lower layer @@ -1244,710 +1244,710 @@ SUBROUTINE UrbanVegFlux ( & wtll, &! sum of normalized heat conductance for air and leaf wtlql ! sum of normalized heat conductance for air and leaf - REAL(r8) :: & + real(r8) :: & ra2m, &! aerodynamic resistance between 2m and bottom layer [s/m] rd2m ! aerodynamic resistance between bottom layer and ground [s/m] - ! temporal - INTEGER i - REAL(r8) bee, cf, tmpw1, tmpw2, tmpw3, tmpw4, fact, facq, taftmp - REAL(r8) B_5, B1_5, dBdT_5, X(5), dX(5) - REAL(r8) fwet_roof, fwet_roof_, fwet_gimp, fwet_gimp_ - REAL(r8) fwetfac, lambda - REAL(r8) cgw_imp, cgw_per - REAL(r8) h_vec, l_vec + ! temporal + integer i + real(r8) bee, cf, tmpw1, tmpw2, tmpw3, tmpw4, fact, facq, taftmp + real(r8) B_5, B1_5, dBdT_5, X(5), dX(5) + real(r8) fwet_roof, fwet_roof_, fwet_gimp, fwet_gimp_ + real(r8) fwetfac, lambda + real(r8) cgw_imp, cgw_per + real(r8) h_vec, l_vec - ! for interface - REAL(r8) o3coefv,o3coefg,assim_RuBP, assim_Rubisco, ci, vpd, gammas + ! for interface + real(r8) o3coefv,o3coefg,assim_RuBP, assim_Rubisco, ci, vpd, gammas !-----------------------End Variable List------------------------------- ! initialization of errors and iteration parameters - it = 1 !counter for leaf temperature iteration - del = 0.0 !change in leaf temperature from previous iteration - dele = 0.0 !latent head flux from leaf for previous iteration + it = 1 !counter for leaf temperature iteration + del = 0.0 !change in leaf temperature from previous iteration + dele = 0.0 !latent head flux from leaf for previous iteration - dtl = 0. - fevpl_bef = 0. + dtl = 0. + fevpl_bef = 0. ! initial values for z0hg, z0qg - !TODO: change to original - !z0mg = (1.-fsno)*zlnd + fsno*zsno - IF (fsno_gper > 0) THEN - z0mg = zsno - ELSE - z0mg = zlnd - ENDIF - z0hg = z0mg - z0qg = z0mg + !TODO: change to original + !z0mg = (1.-fsno)*zlnd + fsno*zsno + IF (fsno_gper > 0) THEN + z0mg = zsno + ELSE + z0mg = zlnd + ENDIF + z0hg = z0mg + z0qg = z0mg !----------------------------------------------------------------------- ! scaling-up coefficients from leaf to canopy !----------------------------------------------------------------------- - cint(1) = (1.-exp(-0.110*lai))/0.110 - cint(2) = (1.-exp(-extkd*lai))/extkd - cint(3) = lai + cint(1) = (1.-exp(-0.110*lai))/0.110 + cint(2) = (1.-exp(-extkd*lai))/extkd + cint(3) = lai !----------------------------------------------------------------------- ! initial saturated vapor pressure and humidity and their derivation !----------------------------------------------------------------------- - !clai = 4.2 * 1000. * 0.2 - clai = 0.0 - lsai = lai + sai + !clai = 4.2 * 1000. * 0.2 + clai = 0.0 + lsai = lai + sai - ! index 0:roof, 1:sunlit wall, 2:shaded wall, 3: vegetation - tu(0) = troof; tu(1) = twsun; tu(2) = twsha; tu(3) = tl + ! index 0:roof, 1:sunlit wall, 2:shaded wall, 3: vegetation + tu(0) = troof; tu(1) = twsun; tu(2) = twsha; tu(3) = tl - fg = 1 - fcover(0) - fc(:) = fcover(0:nurb) - fc(3) = fcover(5) - fgimp = fcover(3)/fg - fgper = fcover(4)/fg - hlr = hwr*(1-sqrt(fcover(0)))/sqrt(fcover(0)) - canlev = (/3, 2, 2, 1/) + fg = 1 - fcover(0) + fc(:) = fcover(0:nurb) + fc(3) = fcover(5) + fgimp = fcover(3)/fg + fgper = fcover(4)/fg + hlr = hwr*(1-sqrt(fcover(0)))/sqrt(fcover(0)) + canlev = (/3, 2, 2, 1/) - B_5 = B(5) - B1_5 = B1(5) - dBdT_5 = dBdT(5) + B_5 = B(5) + B1_5 = B1(5) + dBdT_5 = dBdT(5) - CALL dewfraction (sigf,lai,sai,dewmx,ldew,fwet) + CALL dewfraction (sigf,lai,sai,dewmx,ldew,fwet) - qsatl(0) = qroof - qsatldT(0) = dqroofDT - DO i = 1, nurb - CALL qsadv(tu(i),psrf,ei(i),deiDT(i),qsatl(i),qsatldT(i)) - ENDDO + qsatl(0) = qroof + qsatldT(0) = dqroofDT + DO i = 1, nurb + CALL qsadv(tu(i),psrf,ei(i),deiDT(i),qsatl(i),qsatldT(i)) + ENDDO - ! Save the longwave for the last time - lwsun_bef = lwsun - lwsha_bef = lwsha - lgimp_bef = lgimp - lgper_bef = lgper - lveg_bef = lveg + ! Save the longwave for the last time + lwsun_bef = lwsun + lwsha_bef = lwsha + lgimp_bef = lgimp + lgper_bef = lgper + lveg_bef = lveg !----------------------------------------------------------------------- ! Calculate the weighted qg, tg !----------------------------------------------------------------------- - ! set weghting factor - fah(1) = 1.; fah(2) = 1.; fah(3) = 1. - faw(1) = 1.; faw(2) = 1.; faw(3) = 1. - fgh(1) = 1.; fgh(2) = 1.; fgh(3) = 1. - fgw(1) = 1.; fgw(2) = 1.; fgw(3) = 1. - - ! weighted tg and qg - tg = tgimp*fgimp + tgper*fgper - - ! wet fraction for roof and impervious ground - !------------------------------------------- - ! roof - IF (lbr < 1) THEN - fwet_roof_ = fsno_roof !for snow layer exist - ELSE - ! surface wet fraction. assuming max ponding = 1 kg/m2 - fwet_roof_ = (max(0., wliq_roofsno+wice_roofsno))**(2/3.) - fwet_roof_ = min(1., fwet_roof_) - ENDIF - - ! impervious ground - IF (lbi < 1) THEN - fwet_gimp_ = fsno_gimp !for snow layer exist - ELSE - ! surface wet fraction. assuming max ponding = 1 kg/m2 - fwet_gimp_ = (max(0., wliq_gimpsno+wice_gimpsno))**(2/3.) - fwet_gimp_ = min(1., fwet_gimp_) - ENDIF - - ! dew case - IF (qm > qroof) THEN - fwet_roof = 1. - ELSE - fwet_roof = fwet_roof_ - ENDIF - - ! dew case - IF (qm > qgimp) THEN - fwet_gimp = 1. - ELSE - fwet_gimp = fwet_gimp_ - ENDIF - - ! weighted qg - ! NOTE: IF fwet_gimp=1, same as previous - fwetfac = fgimp*fwet_gimp + fgper - qg = (qgimp*fgimp*fwet_gimp + qgper*fgper) / fwetfac - - fgw(2) = fg*fwetfac + ! set weghting factor + fah(1) = 1.; fah(2) = 1.; fah(3) = 1. + faw(1) = 1.; faw(2) = 1.; faw(3) = 1. + fgh(1) = 1.; fgh(2) = 1.; fgh(3) = 1. + fgw(1) = 1.; fgw(2) = 1.; fgw(3) = 1. + + ! weighted tg and qg + tg = tgimp*fgimp + tgper*fgper + + ! wet fraction for roof and impervious ground + !------------------------------------------- + ! roof + IF (lbr < 1) THEN + fwet_roof_ = fsno_roof !for snow layer exist + ELSE + ! surface wet fraction. assuming max ponding = 1 kg/m2 + fwet_roof_ = (max(0., wliq_roofsno+wice_roofsno))**(2/3.) + fwet_roof_ = min(1., fwet_roof_) + ENDIF + + ! impervious ground + IF (lbi < 1) THEN + fwet_gimp_ = fsno_gimp !for snow layer exist + ELSE + ! surface wet fraction. assuming max ponding = 1 kg/m2 + fwet_gimp_ = (max(0., wliq_gimpsno+wice_gimpsno))**(2/3.) + fwet_gimp_ = min(1., fwet_gimp_) + ENDIF + + ! dew case + IF (qm > qroof) THEN + fwet_roof = 1. + ELSE + fwet_roof = fwet_roof_ + ENDIF + + ! dew case + IF (qm > qgimp) THEN + fwet_gimp = 1. + ELSE + fwet_gimp = fwet_gimp_ + ENDIF + + ! weighted qg + ! NOTE: IF fwet_gimp=1, same as previous + fwetfac = fgimp*fwet_gimp + fgper + qg = (qgimp*fgimp*fwet_gimp + qgper*fgper) / fwetfac + + fgw(2) = fg*fwetfac !----------------------------------------------------------------------- ! initial for fluxes profile !----------------------------------------------------------------------- - nmozsgn = 0 !number of times moz changes sign - obuold = 0. !monin-obukhov length from previous iteration - zii = 1000. !m (pbl height) - beta = 1. !- (in computing W_*) + nmozsgn = 0 !number of times moz changes sign + obuold = 0. !monin-obukhov length from previous iteration + zii = 1000. !m (pbl height) + beta = 1. !- (in computing W_*) !----------------------------------------------------------------------- ! scaling factor bee !----------------------------------------------------------------------- !NOTE: bee value, the default is 1 - bee = 1. + bee = 1. !----------------------------------------------------------------------- ! calculate z0m and displa for layers !----------------------------------------------------------------------- - ! Calculate z0 and displa for vegetation only and the whole area - CALL cal_z0_displa(lsai, htop, 1., z0mv, displav) - CALL cal_z0_displa(lsai, htop, fc(3), z0mv_lay, displav_lay) - - ! For building only below - ! Macdonald et al., 1998, Eq. (23), A=4.43 - lambda = fcover(0) - displau = hroof * (1 + 4.43**(-lambda)*(lambda - 1)) - fai = 4/PI*hlr*fcover(0) - z0mu = (hroof - displau) * & - exp( -(0.5*1.2/vonkar/vonkar*(1-displau/hroof)*fai)**(-0.5) ) - - ! account for vegetation - faiv = fc(3)*(1. - exp(-0.5*lsai)) - lambda = fcover(0) + faiv*htop/hroof - displa = hroof * (1 + 4.43**(-lambda)*(lambda - 1)) - displa = min(0.95*hroof, displa) - z0m = (hroof - displa) * & - exp( -(0.5*1.2/vonkar/vonkar*(1-displa/hroof)*(fai+faiv*htop/hroof))**(-0.5) ) - - ! to compare z0 of urban and only the surface - ! maximum assumption - ! 11/26/2021, yuan: remove the below - !IF (z0mu < z0mv_lay) z0mu = z0mv_lay - !IF (displau < displav_lay) displau = displav_lay - IF (z0m < z0mg) z0m = z0mg - IF (displa >= hroof-z0mg) displa = hroof-z0mg - - ! minimum building displa limit - displau = max(hroof/2., displau) - - ! Layer setting - ! NOTE: right now only for 2 layers - !IF (z0mv+displav > z0mu+displau) THEN - numlay = 2; botlay = 2; canlev(3) = 2 - fgh(2) = fg; fgw(2) = fg; - !ELSE - ! numlay = 3; botlay = 1 - ! fgh(1) = fg; fgw(1) = fg; - !ENDIF + ! Calculate z0 and displa for vegetation only and the whole area + CALL cal_z0_displa(lsai, htop, 1., z0mv, displav) + CALL cal_z0_displa(lsai, htop, fc(3), z0mv_lay, displav_lay) + + ! For building only below + ! Macdonald et al., 1998, Eq. (23), A=4.43 + lambda = fcover(0) + displau = hroof * (1 + 4.43**(-lambda)*(lambda - 1)) + fai = 4/PI*hlr*fcover(0) + z0mu = (hroof - displau) * & + exp( -(0.5*1.2/vonkar/vonkar*(1-displau/hroof)*fai)**(-0.5) ) + + ! account for vegetation + faiv = fc(3)*(1. - exp(-0.5*lsai)) + lambda = fcover(0) + faiv*htop/hroof + displa = hroof * (1 + 4.43**(-lambda)*(lambda - 1)) + displa = min(0.95*hroof, displa) + z0m = (hroof - displa) * & + exp( -(0.5*1.2/vonkar/vonkar*(1-displa/hroof)*(fai+faiv*htop/hroof))**(-0.5) ) + + ! to compare z0 of urban and only the surface + ! maximum assumption + ! 11/26/2021, yuan: remove the below + !IF (z0mu < z0mv_lay) z0mu = z0mv_lay + !IF (displau < displav_lay) displau = displav_lay + IF (z0m < z0mg) z0m = z0mg + IF (displa >= hroof-z0mg) displa = hroof-z0mg + + ! minimum building displa limit + displau = max(hroof/2., displau) + + ! Layer setting + ! NOTE: right now only for 2 layers + !IF (z0mv+displav > z0mu+displau) THEN + numlay = 2; botlay = 2; canlev(3) = 2 + fgh(2) = fg; fgw(2) = fg; + !ELSE + ! numlay = 3; botlay = 1 + ! fgh(1) = fg; fgw(1) = fg; + !ENDIF !----------------------------------------------------------------------- ! calculate layer decay coefficient !----------------------------------------------------------------------- - ! Raupach, 1992 - sqrtdragc = min( (0.003+0.3*faiv)**0.5, 0.3 ) + ! Raupach, 1992 + sqrtdragc = min( (0.003+0.3*faiv)**0.5, 0.3 ) - ! Kondo, 1971 - alphav = htop/(htop-displav_lay)/(vonkar/sqrtdragc) - alphav = alphav*htop/hroof + ! Kondo, 1971 + alphav = htop/(htop-displav_lay)/(vonkar/sqrtdragc) + alphav = alphav*htop/hroof - ! Masson, 2000; Oleson et al., 2008 plus tree (+) - IF (alpha_opt == 1) alpha = 0.5*hwr + alphav + ! Masson, 2000; Oleson et al., 2008 plus tree (+) + IF (alpha_opt == 1) alpha = 0.5*hwr + alphav - ! Swaid, 1993; Kusaka, 2001; Lee and Park, 2008. plus tree (+) - IF (alpha_opt == 2) alpha = 0.772*hwr + alphav + ! Swaid, 1993; Kusaka, 2001; Lee and Park, 2008. plus tree (+) + IF (alpha_opt == 2) alpha = 0.772*hwr + alphav - ! Macdonald, 2000 plus tree (+) - IF (alpha_opt == 3) alpha = 9.6*fai + alphav + ! Macdonald, 2000 plus tree (+) + IF (alpha_opt == 3) alpha = 9.6*fai + alphav !----------------------------------------------------------------------- ! first guess for taf and qaf for each layer ! a large differece from previous schemes !----------------------------------------------------------------------- - taf(:) = 0. - qaf(:) = 0. + taf(:) = 0. + qaf(:) = 0. - IF (numlay .eq. 2) THEN - taf(3) = (tg + 2.*thm)/3. - qaf(3) = (qg + 2.*qm )/3. - taf(2) = (2.*tg + thm)/3. - qaf(2) = (2.*qg + qm )/3. - ENDIF + IF (numlay .eq. 2) THEN + taf(3) = (tg + 2.*thm)/3. + qaf(3) = (qg + 2.*qm )/3. + taf(2) = (2.*tg + thm)/3. + qaf(2) = (2.*qg + qm )/3. + ENDIF - IF (numlay .eq. 3) THEN - taf(3) = (tg + 3.*thm)/4. - qaf(3) = (qg + 3.*qm )/4. - taf(2) = (tg + thm )/2. - qaf(2) = (qg + qm )/2. - taf(1) = (3.*tg + thm)/4. - qaf(1) = (3.*qg + qm )/4. - ENDIF + IF (numlay .eq. 3) THEN + taf(3) = (tg + 3.*thm)/4. + qaf(3) = (qg + 3.*qm )/4. + taf(2) = (tg + thm )/2. + qaf(2) = (qg + qm )/2. + taf(1) = (3.*tg + thm)/4. + qaf(1) = (3.*qg + qm )/4. + ENDIF !----------------------------------------------------------------------- ! some environment variables ! how to calculate rsoil and what is its usage? !----------------------------------------------------------------------- - pco2a = pco2m - tprcor = 44.6*273.16*psrf/1.013e5 - rsoil = 0. !respiration (mol m-2 s-1) - !rsoil = 1.22e-6*exp(308.56*(1./56.02-1./(tg-227.13))) - !rsoil = rstfac * 0.23 * 15. * 2.**((tg-273.16-10.)/10.) * 1.e-6 - !rsoil = 5.22 * 1.e-6 - rsoil = 0.22 * 1.e-6 + pco2a = pco2m + tprcor = 44.6*273.16*psrf/1.013e5 + rsoil = 0. !respiration (mol m-2 s-1) + !rsoil = 1.22e-6*exp(308.56*(1./56.02-1./(tg-227.13))) + !rsoil = rstfac * 0.23 * 15. * 2.**((tg-273.16-10.)/10.) * 1.e-6 + !rsoil = 5.22 * 1.e-6 + rsoil = 0.22 * 1.e-6 ! initialization and input values for Monin-Obukhov - ! have been set before - z0h = z0m; z0q = z0m - ur = max(0.1, sqrt(us*us+vs*vs)) !limit set to 0.1 - dth = thm - taf(2) - dqh = qm - qaf(2) - dthv = dth*(1.+0.61*qm) + 0.61*th*dqh + ! have been set before + z0h = z0m; z0q = z0m + ur = max(0.1, sqrt(us*us+vs*vs)) !limit set to 0.1 + dth = thm - taf(2) + dqh = qm - qaf(2) + dthv = dth*(1.+0.61*qm) + 0.61*th*dqh - ! To ensure the obs height >= hroof+10. - huu = max(hroof+10., hu) - htu = max(hroof+10., ht) - hqu = max(hroof+10., hq) + ! To ensure the obs height >= hroof+10. + huu = max(hroof+10., hu) + htu = max(hroof+10., ht) + hqu = max(hroof+10., hq) - zldis = huu - displa + zldis = huu - displa - IF (zldis <= 0.0) THEN - write(6,*) 'the obs height of u less than the zero displacement heght' - CALL abort - ENDIF + IF (zldis <= 0.0) THEN + write(6,*) 'the obs height of u less than the zero displacement heght' + CALL abort + ENDIF - CALL moninobukini(ur,th,thm,thv,dth,dqh,dthv,zldis,z0m,um,obu) + CALL moninobukini(ur,th,thm,thv,dth,dqh,dthv,zldis,z0m,um,obu) ! ====================================================================== -! BEGIN stability iteration +! BEGIN stability iteration ! ====================================================================== - DO WHILE (it .le. itmax) + DO WHILE (it .le. itmax) - tlbef = tl + tlbef = tl - del2 = del - dele2 = dele + del2 = del + dele2 = dele !----------------------------------------------------------------------- ! Aerodynamical resistances !----------------------------------------------------------------------- ! Evaluate stability-dependent variables using moz from prior iteration - CALL moninobukm(huu,htu,hqu,displa,z0m,z0h,z0q,obu,um, & - hroof,0.,ustar,fh2m,fq2m,hroof,fmtop,fm,fh,fq,fht,fqt,phih) + CALL moninobukm(huu,htu,hqu,displa,z0m,z0h,z0q,obu,um, & + hroof,0.,ustar,fh2m,fq2m,hroof,fmtop,fm,fh,fq,fht,fqt,phih) ! Aerodynamic resistance - ! 09/16/2017: - ! note that for ram, it is the resistance from Href to z0m+displa - ! however, for rah and raw is only from Href to canopy effective - ! exchange height. - ! so rah/raw is not comparable with that of 1D case - ram = 1./(ustar*ustar/um) - - ! 05/02/2016: calculate resistance from the top layer (effective exchange - ! height) to reference height - ! for urban, from roof height to reference height - rah = 1./(vonkar/(fh-fht)*ustar) - raw = 1./(vonkar/(fq-fqt)*ustar) + ! 09/16/2017: + ! note that for ram, it is the resistance from Href to z0m+displa + ! however, for rah and raw is only from Href to canopy effective + ! exchange height. + ! so rah/raw is not comparable with that of 1D case + ram = 1./(ustar*ustar/um) + + ! 05/02/2016: calculate resistance from the top layer (effective exchange + ! height) to reference height + ! for urban, from roof height to reference height + rah = 1./(vonkar/(fh-fht)*ustar) + raw = 1./(vonkar/(fq-fqt)*ustar) ! update roughness length for sensible/latent heat - z0hg = z0mg/exp(0.13 * (ustar*z0mg/1.5e-5)**0.45) - z0qg = z0hg + z0hg = z0mg/exp(0.13 * (ustar*z0mg/1.5e-5)**0.45) + z0qg = z0hg - z0h = max(z0hg, z0h) - z0q = max(z0qg, z0q) + z0h = max(z0hg, z0h) + z0q = max(z0qg, z0q) !----------------------------------------------------------------------- ! new method to calculate rd and ueffect ! the kernel part of 3d model !----------------------------------------------------------------------- - ! initialization - rd(:) = 0. - rd_(:) = 0. - ueff_lay(:) = 0. - ueff_lay_(:) = 0. - - ! calculate canopy top wind speed (utop) and exchange coefficient (ktop) - ! need to update each time as obu changed after each iteration - ! print*, ustar, fmtop - utop = ustar/vonkar * fmtop - ktop = vonkar * (hroof-displa) * ustar / phih - - ueff_lay(3) = utop - ueff_lay_(3) = utop - - ! REAL(r8) FUNCTION kintegral(ktop, fc, bee, alpha, z0mg, & - ! displah, htop, hbot, obu, ustar, ztop, zbot) - !rd_(3) = kintegral(ktop, 1., bee, alpha, z0mg, displa/hroof, & - ! hroof, 0., obug, ustarg, hroof, displau+z0mu) - - ! REAL(r8) FUNCTION frd(ktop, htop, hbot, & - ! ztop, zbot, displah, z0h, obu, ustar, & - ! z0mg, alpha, bee, fc) - rd(3) = frd(ktop, hroof, 0., hroof, displau+z0mu, displa/hroof, z0h_g, & - obug, ustarg, z0mg, alpha, bee, 1.) - - ! REAL(r8) FUNCTION uintegralz(utop, fc, bee, alpha, z0mg, htop, hbot, ztop, zbot) - !ueff_lay(2) = uintegralz(utop, 1., bee, alpha, z0mg, hroof, 0., hroof, z0mg) - - ! REAL(r8) FUNCTION ueffectz(utop, htop, hbot, & - ! ztop, zbot, z0mg, alpha, bee, fc) - ueff_lay(2) = ueffectz(utop, hroof, 0., hroof, z0mg, z0mg, alpha, bee, 1.) - - IF (numlay == 3) THEN - ! REAL(r8) FUNCTION kintegral(ktop, fc, bee, alpha, z0mg, & - ! displah, htop, hbot, obu, ustar, ztop, zbot) - !rd(2) = kintegral(ktop, 1., bee, alpha, z0mg, displa/hroof, & - ! hroof, 0., obug, ustarg, displau+z0mu, displav+z0mv) - rd(2) = frd(ktop, hroof, 0., displau+z0mu, displav+z0mv, displa/hroof, z0h_g, & - obug, ustarg, z0mg, alpha, bee, 1.) - - !rd(1) = kintegral(ktop, 1., bee, alpha, z0mg, displa/hroof, & - ! hroof, 0., obug, ustarg, displav+z0mv, z0qg) - rd(1) = frd(ktop, hroof, 0., displav+z0mv, z0qg, displa/hroof, z0h_g, & - obug, ustarg, z0mg, alpha, bee, 1.) - - ! calculate ra2m, rd2m - ra2m = frd(ktop, hroof, 0., displav+z0mv, 2., displa/hroof, z0h_g, & - obug, ustarg, z0mg, alpha, bee, 1.) - - rd2m = frd(ktop, hroof, 0., 2., z0qg, displa/hroof, z0h_g, & - obug, ustarg, z0mg, alpha, bee, 1.) - ELSE - !rd_(2) = kintegral(ktop, 1., bee, alpha, z0mg, displa/hroof, & - ! hroof, 0., obug, ustarg, displau+z0mu, z0qg) - rd(2) = frd(ktop, hroof, 0., displau+z0mu, z0qg, displa/hroof, z0h_g, & - obug, ustarg, z0mg, alpha, bee, 1.) - - ! calculate ra2m, rd2m - ra2m = frd(ktop, hroof, 0., displau+z0mu, 2., displa/hroof, z0h_g, & - obug, ustarg, z0mg, alpha, bee, 1.) - - rd2m = frd(ktop, hroof, 0., 2., z0qg, displa/hroof, z0h_g, & - obug, ustarg, z0mg, alpha, bee, 1.) - ENDIF - - !ueff_lay(2) = uintegralz(utop, 1., bee, alpha, z0mg, hroof, 0., hroof, z0mg) - !print *, "htop/hbot:", htop, hbot !fordebug - !ueff_veg = uintegralz(utop, 1., bee, alpha, z0mg, hroof, 0., htop, hbot) - - !ueff_lay_(2) = ueffectz(utop, hroof, 0., hroof, z0mg, z0mg, alpha, bee, 1.) - ueff_veg = ueffectz(utop, hroof, 0., htop, hbot, z0mg, alpha, bee, 1.) - - ! Masson, 2000: Account for different canyon orientations - ! 2/PI is a factor derived from 0-360deg integration - IF (alpha_opt == 1) THEN - ueff_lay(2) = 2/PI*ueff_lay(2) - ueff_veg = 2/PI*ueff_veg - rd(:) = PI/2*rd(:) - ENDIF - - ! ueff_lay(3) = ueff_lay(2) - - !print *, "ueff_lay :", ueff_lay - !print *, "ueff_lay_:", ueff_lay_ - !print *, "------------------------" - !print *, "rd :", rd - !print *, "rd_:", rd_ + ! initialization + rd(:) = 0. + rd_(:) = 0. + ueff_lay(:) = 0. + ueff_lay_(:) = 0. + + ! calculate canopy top wind speed (utop) and exchange coefficient (ktop) + ! need to update each time as obu changed after each iteration + ! print*, ustar, fmtop + utop = ustar/vonkar * fmtop + ktop = vonkar * (hroof-displa) * ustar / phih + + ueff_lay(3) = utop + ueff_lay_(3) = utop + + ! real(r8) FUNCTION kintegral(ktop, fc, bee, alpha, z0mg, & + ! displah, htop, hbot, obu, ustar, ztop, zbot) + !rd_(3) = kintegral(ktop, 1., bee, alpha, z0mg, displa/hroof, & + ! hroof, 0., obug, ustarg, hroof, displau+z0mu) + + ! real(r8) FUNCTION frd(ktop, htop, hbot, & + ! ztop, zbot, displah, z0h, obu, ustar, & + ! z0mg, alpha, bee, fc) + rd(3) = frd(ktop, hroof, 0., hroof, displau+z0mu, displa/hroof, z0h_g, & + obug, ustarg, z0mg, alpha, bee, 1.) + + ! real(r8) FUNCTION uintegralz(utop, fc, bee, alpha, z0mg, htop, hbot, ztop, zbot) + !ueff_lay(2) = uintegralz(utop, 1., bee, alpha, z0mg, hroof, 0., hroof, z0mg) + + ! real(r8) FUNCTION ueffectz(utop, htop, hbot, & + ! ztop, zbot, z0mg, alpha, bee, fc) + ueff_lay(2) = ueffectz(utop, hroof, 0., hroof, z0mg, z0mg, alpha, bee, 1.) + + IF (numlay == 3) THEN + ! real(r8) FUNCTION kintegral(ktop, fc, bee, alpha, z0mg, & + ! displah, htop, hbot, obu, ustar, ztop, zbot) + !rd(2) = kintegral(ktop, 1., bee, alpha, z0mg, displa/hroof, & + ! hroof, 0., obug, ustarg, displau+z0mu, displav+z0mv) + rd(2) = frd(ktop, hroof, 0., displau+z0mu, displav+z0mv, displa/hroof, z0h_g, & + obug, ustarg, z0mg, alpha, bee, 1.) + + !rd(1) = kintegral(ktop, 1., bee, alpha, z0mg, displa/hroof, & + ! hroof, 0., obug, ustarg, displav+z0mv, z0qg) + rd(1) = frd(ktop, hroof, 0., displav+z0mv, z0qg, displa/hroof, z0h_g, & + obug, ustarg, z0mg, alpha, bee, 1.) + + ! calculate ra2m, rd2m + ra2m = frd(ktop, hroof, 0., displav+z0mv, 2., displa/hroof, z0h_g, & + obug, ustarg, z0mg, alpha, bee, 1.) + + rd2m = frd(ktop, hroof, 0., 2., z0qg, displa/hroof, z0h_g, & + obug, ustarg, z0mg, alpha, bee, 1.) + ELSE + !rd_(2) = kintegral(ktop, 1., bee, alpha, z0mg, displa/hroof, & + ! hroof, 0., obug, ustarg, displau+z0mu, z0qg) + rd(2) = frd(ktop, hroof, 0., displau+z0mu, z0qg, displa/hroof, z0h_g, & + obug, ustarg, z0mg, alpha, bee, 1.) + + ! calculate ra2m, rd2m + ra2m = frd(ktop, hroof, 0., displau+z0mu, 2., displa/hroof, z0h_g, & + obug, ustarg, z0mg, alpha, bee, 1.) + + rd2m = frd(ktop, hroof, 0., 2., z0qg, displa/hroof, z0h_g, & + obug, ustarg, z0mg, alpha, bee, 1.) + ENDIF + + !ueff_lay(2) = uintegralz(utop, 1., bee, alpha, z0mg, hroof, 0., hroof, z0mg) + !print *, "htop/hbot:", htop, hbot !fordebug + !ueff_veg = uintegralz(utop, 1., bee, alpha, z0mg, hroof, 0., htop, hbot) + + !ueff_lay_(2) = ueffectz(utop, hroof, 0., hroof, z0mg, z0mg, alpha, bee, 1.) + ueff_veg = ueffectz(utop, hroof, 0., htop, hbot, z0mg, alpha, bee, 1.) + + ! Masson, 2000: Account for different canyon orientations + ! 2/PI is a factor derived from 0-360deg integration + IF (alpha_opt == 1) THEN + ueff_lay(2) = 2/PI*ueff_lay(2) + ueff_veg = 2/PI*ueff_veg + rd(:) = PI/2*rd(:) + ENDIF + + ! ueff_lay(3) = ueff_lay(2) + + !print *, "ueff_lay :", ueff_lay + !print *, "ueff_lay_:", ueff_lay_ + !print *, "------------------------" + !print *, "rd :", rd + !print *, "rd_:", rd_ !----------------------------------------------------------------------- ! Bulk boundary layer resistance of leaves !----------------------------------------------------------------------- - rb(:) = 0. + rb(:) = 0. - DO i = 0, nurb + DO i = 0, nurb - IF (i == 3) THEN - cf = 0.01*sqrtdi*sqrt(ueff_veg) - rb(i) = 1./cf - cycle - ENDIF + IF (i == 3) THEN + cf = 0.01*sqrtdi*sqrt(ueff_veg) + rb(i) = 1./cf + CYCLE + ENDIF - clev = canlev(i) - rb(i) = rhoair * cpair / ( 11.8 + 4.2*ueff_lay(clev) ) + clev = canlev(i) + rb(i) = rhoair * cpair / ( 11.8 + 4.2*ueff_lay(clev) ) - ! Cole & Sturrock (1977) Building and Environment, 12, 207–214. - ! rb(i) = rhoair * cpair / ( 5.8 + 4.1*ueff_lay(clev) ) - !IF (ueff_lay(clev) > 5.) THEN - ! rb(i) = rhoair * cpair / (7.51*ueff_lay(clev)**0.78) - !ELSE - ! rb(i) = rhoair * cpair / (5.8 + 4.1*ueff_lay(clev)) - !ENDIF - !rb(i) = rhoair * cpair / (cpair*vonkar*vonkar*ueff_lay(clev)/(log(0.1*hroof/)*(2.3+log(0.1*hroof/)))) - ENDDO + ! Cole & Sturrock (1977) Building and Environment, 12, 207–214. + ! rb(i) = rhoair * cpair / ( 5.8 + 4.1*ueff_lay(clev) ) + !IF (ueff_lay(clev) > 5.) THEN + ! rb(i) = rhoair * cpair / (7.51*ueff_lay(clev)**0.78) + !ELSE + ! rb(i) = rhoair * cpair / (5.8 + 4.1*ueff_lay(clev)) + !ENDIF + !rb(i) = rhoair * cpair / (cpair*vonkar*vonkar*ueff_lay(clev)/(log(0.1*hroof/)*(2.3+log(0.1*hroof/)))) + ENDDO !----------------------------------------------------------------------- ! stomatal resistances !----------------------------------------------------------------------- - IF (lai > 0.) THEN + IF (lai > 0.) THEN - ! only for vegetation - ! rb(3) = rb(3) + ! only for vegetation + ! rb(3) = rb(3) - clev = canlev(3) - eah = qaf(clev) * psrf / ( 0.622 + 0.378 * qaf(clev) ) !pa + clev = canlev(3) + eah = qaf(clev) * psrf / ( 0.622 + 0.378 * qaf(clev) ) !pa !----------------------------------------------------------------------- ! note: calculate resistance for leaves !----------------------------------------------------------------------- - CALL stomata (vmax25,effcon ,slti ,hlti ,& - shti ,hhti ,trda ,trdm ,trop ,& - g1 ,g0 ,gradm ,binter ,thm ,& - psrf ,po2m ,pco2m ,pco2a ,eah ,& - ei(3) ,tu(3) ,par ,& - o3coefv ,o3coefg ,& - rb(3)/lai,raw ,rstfac ,cint(:),& - assim ,respc ,rs & - ) - ELSE - rs = 2.e4; assim = 0.; respc = 0. - ENDIF + CALL stomata (vmax25,effcon ,slti ,hlti ,& + shti ,hhti ,trda ,trdm ,trop ,& + g1 ,g0 ,gradm ,binter ,thm ,& + psrf ,po2m ,pco2m ,pco2a ,eah ,& + ei(3) ,tu(3) ,par ,& + o3coefv ,o3coefg ,& + rb(3)/lai,raw ,rstfac ,cint(:),& + assim ,respc ,rs & + ) + ELSE + rs = 2.e4; assim = 0.; respc = 0. + ENDIF ! above stomatal resistances are for the canopy, the stomatal rsistances ! and the "rb" in the following calculations are the average for single leaf. thus, - rs = rs * lai + rs = rs * lai !----------------------------------------------------------------------- ! dimensional and non-dimensional sensible and latent heat conductances ! for canopy and soil flux calculations. !----------------------------------------------------------------------- - cfh(:) = 0. - cfw(:) = 0. - - DO i = 0, nurb - - IF (i == 3) THEN - - clev = canlev(i) - delta = 0.0 - IF (qsatl(i)-qaf(clev) .gt. 0.) delta = 1.0 - - ! calculate sensible heat conductance - cfh(i) = lsai / rb(i) - - ! for building walls, cfw=0., no water transfer - ! for canopy, keep the same but for one leaf - ! calculate latent heat conductance - cfw(i) = (1.-delta*(1.-fwet))*lsai/rb(i) + & - (1.-fwet)*delta* ( lai/(rb(i)+rs) ) - ELSE - cfh(i) = 1 / rb(i) - - IF (i == 0) THEN !roof - ! account for fwet - cfw(i) = fwet_roof / rb(i) - ELSE - cfw(i) = 1 / rb(i) - ENDIF - ENDIF - ENDDO - - ! For simplicity, there is no water exchange on the wall - cfw(1:2) = 0. - - ! initialization - cah(:) = 0. - caw(:) = 0. - cgh(:) = 0. - cgw(:) = 0. - - ! conductance for each layer - DO i = 3, botlay, -1 - IF (i == 3) THEN - cah(i) = 1. / rah - caw(i) = 1. / raw - ! ELSE IF (i == 2) THEN - ! cah(i) = 1e6 - ! caw(i) = 1e6 - ELSE - cah(i) = 1. / rd(i+1) - caw(i) = 1. / rd(i+1) - ENDIF - - ! IF (i == 3) THEN - ! cgh(i) = 1e6 - ! cgw(i) = 1e6 - ! ELSE - cgh(i) = 1. / rd(i) - cgw(i) = 1. / rd(i) - ! ENDIF - ENDDO - - ! claculate wtshi, wtsqi - wtshi(:) = cah(:)*fah(:) + cgh(:)*fgh(:) - wtsqi(:) = caw(:)*faw(:) + cgw(:)*fgw(:) - - DO i = 0, nurb - clev = canlev(i) - wtshi(clev) = wtshi(clev) + fc(i)*cfh(i) - wtsqi(clev) = wtsqi(clev) + fc(i)*cfw(i) - ENDDO - - DO i = 3, 3-numlay+1, -1 - wtshi(i) = 1./wtshi(i) - wtsqi(i) = 1./wtsqi(i) - ENDDO - - wta0(:) = cah(:) * wtshi(:) * fah(:) - wtg0(:) = cgh(:) * wtshi(:) * fgh(:) - - wtaq0(:) = caw(:) * wtsqi(:) * faw(:) - wtgq0(:) = cgw(:) * wtsqi(:) * fgw(:) - - ! calculate wtl0, wtll, wtlq0, wtlql - wtll(:) = 0. - wtlql(:) = 0. - - DO i = 0, nurb - clev = canlev(i) - - wtl0(i) = cfh(i) * wtshi(clev) * fc(i) - wtll(clev) = wtll(clev) + wtl0(i)*tu(i) - - wtlq0(i) = cfw(i) * wtsqi(clev) * fc(i) - wtlql(clev) = wtlql(clev) + wtlq0(i)*qsatl(i) - ENDDO - - ! to solve taf(:) and qaf(:) - - IF (numlay .eq. 2) THEN - - ! - Equations: - ! taf(3) = (1/rah*thm + 1/rd(3)*taf(2) + 1/rb(0)*troof*fc(0) + AHE/(rho*cp))/(1/rah + 1/rd(3) + 1/rb(0)*fc(0)) - ! taf(2) = (1/rd(3)*taf(3) + 1/rd(2)*tg*fg + 1/rb(1)*twsun*fc(1) + 1/rb(2)*twsha*fc(2) + lsai/rb(3)*tl*fc(3) + AHE/(rho*cp))/ & - ! (1/rd(3) + 1/rd(2)*fg + 1/rb(1)*fc(1) + 1/rb(2)*fc(2) + lsai/rb(3)*fc(3)) - ! Also written as: - ! taf(3) = (cah(3)*thm + cah(2)*taf(2) + cfh(0)*troof*fc(0))/(cah(3) + cah(2) + cfh(0)*fc(0)) - ! taf(2) = (cah(2)*taf(3) + cgh(2)*tg*fg + cfh(1)*twsun*fc(1) + cfh(2)*twsha*fc(2) + cfh(3)*tl*fc(3) + AHE/(rho*cp))/ & - ! (cah(2) + cgh(2)*fg + cfh(1)*fc(1) + cfh(2)*fc(2) + cfh(3)*fc(3)) - ! - Equations: - ! qaf(3) = (1/raw*qm + 1/rd(3)*qaf(2) + 1/rb(0)*qroof*fc(0))/(1/raw + 1/rd(3) + 1/rb(0)*fc(0)) - ! qaf(2) = (1/rd(3)*qaf(3) + 1/(rd(2)+rsr)*qper*fgper*fg + fwetimp/rd(2)*qimp*fgimp*fg + lsai/(rb(3)+rs)*ql*fc(3) + AHE/rho)/ & - ! (1/rd(3) + 1/(rd(2)+rsr)*fgper*fg + fwetimp/rd(2)*fgimp*fg + lsai/(rb(3)+rs)*fc(3)) - ! Also written as: - ! qaf(3) = (caw(3)*qm + caw(2)*qaf(2) + cfw(0)*qroof*fc(0))/(caw(3) + caw(2) + cfw(0)*fc(0)) - ! qaf(2) = (caw(2)*qaf(3) + cgwper*qper*fgper*fg + cgwimp*qimp*fgimp*fg + cfw(3)*ql*fc(3) + AHE/rho)/ & - ! (caw(2) + cgwper*fgper*fg + cgwimp*fgimp*fg + cfw(3)*fc(3)) - - ! 06/20/2021, yuan: account for Anthropogenic heat - ! 92% heat release as SH, Pigeon et al., 2007 - - h_vec = vehc! - tmpw1 = cah(2)*((cah(3)*thm + cfh(0)*tu(0)*fc(0) + 1/(4*hlr+1)*(Fhac+Fwst)/(rhoair*cpair))/& - (cah(3) + cah(2) + cfh(0)*fc(0))) - tmpw2 = (4*hlr/(4*hlr+1)*(Fhac+Fwst)+Fach)/(rhoair*cpair) + (h_vec+meta)/(rhoair*cpair) - tmpw3 = cgh(2)*fg*tg + cfh(1)*tu(1)*fc(1) + cfh(2)*tu(2)*fc(2) + cfh(3)*tu(3)*fc(3) - fact = 1. - (cah(2)*cah(2)/(cah(3) + cah(2) + cfh(0)*fc(0))/& - (cah(2) + cgh(2)*fg + cfh(1)*fc(1) + cfh(2)*fc(2) + cfh(3)*fc(3))) - taf(2) = (tmpw1 + tmpw2 + tmpw3) / & - (cah(2) + cgh(2)*fg + cfh(1)*fc(1) + cfh(2)*fc(2) + cfh(3)*fc(3)) / & - fact - - IF (qgper < qaf(2)) THEN - ! dew case. no soil resistance - cgw_per= cgw(2) - ELSE - cgw_per= 1/(1/cgw(2)+rsr) - ENDIF - - cgw_imp= fwet_gimp*cgw(2) - - ! account for soil resistance, qgper and qgimp are calculated separately - l_vec = 0 - tmpw1 = caw(2)*((caw(3)*qm + cfw(0)*qsatl(0)*fc(0))/& - (caw(3) + caw(2) + cfw(0)*fc(0))) - tmpw2 = l_vec/(rhoair) - tmpw3 = cgw_per*qgper*fgper*fg + cgw_imp*qgimp*fgimp*fg + cfw(3)*qsatl(3)*fc(3) - facq = 1. - (caw(2)*caw(2)/& - (caw(3) + caw(2) + cfw(0)*fc(0))/& - (caw(2) + cgw_per*fgper*fg + cgw_imp*fgimp*fg + cfw(3)*fc(3))) - qaf(2) = (tmpw1 + tmpw2 + tmpw3)/& - (caw(2) + cgw_per*fgper*fg + cgw_imp*fgimp*fg + cfw(3)*fc(3))/& - facq - - tmpw1 = 1/(4*hlr+1)*(Fhac+Fwst)/(rhoair*cpair) - taf(3) = (cah(3)*thm + cah(2)*taf(2) + cfh(0)*tu(0)*fc(0) + tmpw1)/& - (cah(3) + cah(2) + cfh(0)*fc(0)) - qaf(3) = (caw(3)*qm + caw(2)*qaf(2) + cfw(0)*qsatl(0)*fc(0))/& - (caw(3) + caw(2) + cfw(0)*fc(0)) - ENDIF - - IF (numlay .eq. 3) THEN - - ! - Equations: - ! taf(3) = (thm/rah+1/rd(3)*taf(2)+AHE2/rho/cpair+1/rb(0)*troof*fc(0))/& - ! (1/rah+1/rd(3)+1/rb(0)*fc(0)) - ! taf(2) = (1/rd(3)*taf(3)+1/rd(2)*taf1+1/rb(1)*twsun*fc(1)+1/rb(2)*twsha*fc(2)+AHE1/rho/cpair)/& - ! (1/rd(3)+1/rd(2)+1/rb(1)*fc(1)+1/rb(2)*fc(2)) - ! taf(1) = (1/rd(2)*taf(2)+1/rd(1)*tg*fg+1/rb(3)*tl*fc(3)+Hveh/rhoair/cpair)/& - ! (1/rd(2)+1/rd(1)*fg+1/rb(3)*fc(3)) - ! - Equations: - ! qaf(3) = (1/raw*qm+1/rd(3)*qaf(2)+1/rb(0)*qroof*fc(0))/& - ! (1/raw+1/rd(3)+1/rb(0)*fc(0)) - ! qaf(2) = (1/rd(3)*qaf(3)+1/rd(2)*qaf(1))/& - ! (1/rd(3) + 1/rd(2)) - ! qaf(1) = (1/rd(2)*qaf(2)+1/(rd(1)+rsr)*qgper*fgper*fg+1/rd(1)*qimp*fgimp*fg+1/(rb(3)+rs)*ql*fc(3)+h_veh/rho))/& - ! (1/rd(2)+1/(rd(1)+rsr)*fgper*fg+1/rd(1)*fgimp*fg+1/(rb(3)+rs)*fc(3)) - - tmpw1 = cah(1)*(cgh(1)*tg*fg + cfh(3)*tu(3)*fc(3) + (vehc+meta)/rhoair/cpair)/& - (cah(1) + cgh(1)*fg + cfh(3)*fc(3)) - tmpw2 = cah(2)*(cah(3)*thm + cfh(0)*tu(0)*fc(0) + 1/(4*hlr+1)*(Fhac+Fwst)/(rhoair*cpair))/& - (cah(3) + cah(2) + cfh(0)*fc(0)) - tmpw3 = cah(1)*cah(1)/& - (cah(1) + cgh(1)*fg + cfh(3)*fc(3))/& - (cah(1) + cah(2) + cfh(1)*fc(1) + cfh(2)*fc(2)) - tmpw4 = cah(2)*cah(2)/& - (cah(3) + cah(2) + cfh(0)*fc(0))/& - (cah(1) + cah(2) + cfh(1)*fc(1) + cfh(2)*fc(2)) - fact = 1. - tmpw3 - tmpw4 - - taf(2) = (tmpw1 + tmpw2 + cfh(1)*tu(1)*fc(1) + cfh(2)*tu(2)*fc(2) + (4*hlr/(4*hlr+1)*(Fhac+Fwst)+Fach)/(rhoair*cpair))/& - (cah(1) + cah(2) + cfh(1)*fc(1) + cfh(2)*fc(2))/& - fact - - taf(1) = (cah(1)*taf(2) + cgh(1)*tg*fg + cfh(3)*tu(3)*fc(3) + (vehc+meta)/rhoair/cpair)/& - (cah(1) + cgh(1)*fg + cfh(3)*fc(3)) - tmpw1 = 1/(4*hlr+1)*(Fhac+Fwst)/(rhoair*cpair) - taf(3) = (cah(3)*thm + cah(2)*taf(2) + cfh(0)*tu(0)*fc(0) + tmpw1)/& - (cah(3) + cah(2) + cfh(0)*fc(0)) - - IF (qgper < qaf(1)) THEN - ! dew case. no soil resistance - cgw_per= cgw(1) - ELSE - cgw_per= 1/(1/cgw(1)+rsr) - ENDIF - - cgw_imp= fwet_gimp*cgw(1) - - l_vec = 0 - tmpw1 = caw(1)*(cgw_per*qgper*fgper*fg + cgw_imp*qgimp*fgimp*fg + cfw(3)*qsatl(3)*fc(3) + l_vec/(rhoair))/& - (caw(1) + cgw_per*fgper*fg + cgw_imp*fgimp*fg + cfw(3)*fc(3)) - tmpw2 = caw(2)*(caw(3)*qm + cfw(0)*qsatl(0)*fc(0))/& - (caw(3) + caw(2) + cfw(0)*fc(0)) - tmpw3 = caw(1)*caw(1)/& - (caw(1) + cgw_per*fgper*fg + cgw_imp*fgimp*fg + cfw(3)*fc(3))/& - (caw(2) + caw(1)) - tmpw4 = caw(2)*caw(2)/& - (caw(3) + caw(2) + cfw(0)*fc(0))/& - (caw(2) + caw(1)) - facq = 1. - tmpw3 - tmpw4 - - qaf(2) = (tmpw1 + tmpw2)/& - (caw(2) + caw(1))/& - facq - - tmpw1 = l_vec/(rhoair) - qaf(1) = (caw(1)*qaf(2) + qgper*cgw_per*fgper*fg + qgimp*cgw_imp*fgimp*fg + cfw(3)*qsatl(3)*fc(3) + tmpw1)/& - (caw(1) + cgw_per*fgper*fg + cgw_imp*fgimp*fg + cfw(3)*fc(3)) - qaf(3) = (caw(3)*qm + caw(2)*qaf(2) + cfw(0)*qsatl(0)*fc(0))/& - (caw(3) + caw(2) + cfw(0)*fc(0)) - ENDIF + cfh(:) = 0. + cfw(:) = 0. + + DO i = 0, nurb + + IF (i == 3) THEN + + clev = canlev(i) + delta = 0.0 + IF (qsatl(i)-qaf(clev) .gt. 0.) delta = 1.0 + + ! calculate sensible heat conductance + cfh(i) = lsai / rb(i) + + ! for building walls, cfw=0., no water transfer + ! for canopy, keep the same but for one leaf + ! calculate latent heat conductance + cfw(i) = (1.-delta*(1.-fwet))*lsai/rb(i) + & + (1.-fwet)*delta* ( lai/(rb(i)+rs) ) + ELSE + cfh(i) = 1 / rb(i) + + IF (i == 0) THEN !roof + ! account for fwet + cfw(i) = fwet_roof / rb(i) + ELSE + cfw(i) = 1 / rb(i) + ENDIF + ENDIF + ENDDO + + ! For simplicity, there is no water exchange on the wall + cfw(1:2) = 0. + + ! initialization + cah(:) = 0. + caw(:) = 0. + cgh(:) = 0. + cgw(:) = 0. + + ! conductance for each layer + DO i = 3, botlay, -1 + IF (i == 3) THEN + cah(i) = 1. / rah + caw(i) = 1. / raw + ! ELSE IF (i == 2) THEN + ! cah(i) = 1e6 + ! caw(i) = 1e6 + ELSE + cah(i) = 1. / rd(i+1) + caw(i) = 1. / rd(i+1) + ENDIF + + ! IF (i == 3) THEN + ! cgh(i) = 1e6 + ! cgw(i) = 1e6 + ! ELSE + cgh(i) = 1. / rd(i) + cgw(i) = 1. / rd(i) + ! ENDIF + ENDDO + + ! claculate wtshi, wtsqi + wtshi(:) = cah(:)*fah(:) + cgh(:)*fgh(:) + wtsqi(:) = caw(:)*faw(:) + cgw(:)*fgw(:) + + DO i = 0, nurb + clev = canlev(i) + wtshi(clev) = wtshi(clev) + fc(i)*cfh(i) + wtsqi(clev) = wtsqi(clev) + fc(i)*cfw(i) + ENDDO + + DO i = 3, 3-numlay+1, -1 + wtshi(i) = 1./wtshi(i) + wtsqi(i) = 1./wtsqi(i) + ENDDO + + wta0(:) = cah(:) * wtshi(:) * fah(:) + wtg0(:) = cgh(:) * wtshi(:) * fgh(:) + + wtaq0(:) = caw(:) * wtsqi(:) * faw(:) + wtgq0(:) = cgw(:) * wtsqi(:) * fgw(:) + + ! calculate wtl0, wtll, wtlq0, wtlql + wtll(:) = 0. + wtlql(:) = 0. + + DO i = 0, nurb + clev = canlev(i) + + wtl0(i) = cfh(i) * wtshi(clev) * fc(i) + wtll(clev) = wtll(clev) + wtl0(i)*tu(i) + + wtlq0(i) = cfw(i) * wtsqi(clev) * fc(i) + wtlql(clev) = wtlql(clev) + wtlq0(i)*qsatl(i) + ENDDO + + ! to solve taf(:) and qaf(:) + + IF (numlay .eq. 2) THEN + + ! - Equations: + ! taf(3) = (1/rah*thm + 1/rd(3)*taf(2) + 1/rb(0)*troof*fc(0) + AHE/(rho*cp))/(1/rah + 1/rd(3) + 1/rb(0)*fc(0)) + ! taf(2) = (1/rd(3)*taf(3) + 1/rd(2)*tg*fg + 1/rb(1)*twsun*fc(1) + 1/rb(2)*twsha*fc(2) + lsai/rb(3)*tl*fc(3) + AHE/(rho*cp))/ & + ! (1/rd(3) + 1/rd(2)*fg + 1/rb(1)*fc(1) + 1/rb(2)*fc(2) + lsai/rb(3)*fc(3)) + ! Also written as: + ! taf(3) = (cah(3)*thm + cah(2)*taf(2) + cfh(0)*troof*fc(0))/(cah(3) + cah(2) + cfh(0)*fc(0)) + ! taf(2) = (cah(2)*taf(3) + cgh(2)*tg*fg + cfh(1)*twsun*fc(1) + cfh(2)*twsha*fc(2) + cfh(3)*tl*fc(3) + AHE/(rho*cp))/ & + ! (cah(2) + cgh(2)*fg + cfh(1)*fc(1) + cfh(2)*fc(2) + cfh(3)*fc(3)) + ! - Equations: + ! qaf(3) = (1/raw*qm + 1/rd(3)*qaf(2) + 1/rb(0)*qroof*fc(0))/(1/raw + 1/rd(3) + 1/rb(0)*fc(0)) + ! qaf(2) = (1/rd(3)*qaf(3) + 1/(rd(2)+rsr)*qper*fgper*fg + fwetimp/rd(2)*qimp*fgimp*fg + lsai/(rb(3)+rs)*ql*fc(3) + AHE/rho)/ & + ! (1/rd(3) + 1/(rd(2)+rsr)*fgper*fg + fwetimp/rd(2)*fgimp*fg + lsai/(rb(3)+rs)*fc(3)) + ! Also written as: + ! qaf(3) = (caw(3)*qm + caw(2)*qaf(2) + cfw(0)*qroof*fc(0))/(caw(3) + caw(2) + cfw(0)*fc(0)) + ! qaf(2) = (caw(2)*qaf(3) + cgwper*qper*fgper*fg + cgwimp*qimp*fgimp*fg + cfw(3)*ql*fc(3) + AHE/rho)/ & + ! (caw(2) + cgwper*fgper*fg + cgwimp*fgimp*fg + cfw(3)*fc(3)) + + ! 06/20/2021, yuan: account for Anthropogenic heat + ! 92% heat release as SH, Pigeon et al., 2007 + + h_vec = vehc! + tmpw1 = cah(2)*((cah(3)*thm + cfh(0)*tu(0)*fc(0) + 1/(4*hlr+1)*(Fhac+Fwst)/(rhoair*cpair))/& + (cah(3) + cah(2) + cfh(0)*fc(0))) + tmpw2 = (4*hlr/(4*hlr+1)*(Fhac+Fwst)+Fach)/(rhoair*cpair) + (h_vec+meta)/(rhoair*cpair) + tmpw3 = cgh(2)*fg*tg + cfh(1)*tu(1)*fc(1) + cfh(2)*tu(2)*fc(2) + cfh(3)*tu(3)*fc(3) + fact = 1. - (cah(2)*cah(2)/(cah(3) + cah(2) + cfh(0)*fc(0))/& + (cah(2) + cgh(2)*fg + cfh(1)*fc(1) + cfh(2)*fc(2) + cfh(3)*fc(3))) + taf(2) = (tmpw1 + tmpw2 + tmpw3) / & + (cah(2) + cgh(2)*fg + cfh(1)*fc(1) + cfh(2)*fc(2) + cfh(3)*fc(3)) / & + fact + + IF (qgper < qaf(2)) THEN + ! dew case. no soil resistance + cgw_per= cgw(2) + ELSE + cgw_per= 1/(1/cgw(2)+rsr) + ENDIF + + cgw_imp= fwet_gimp*cgw(2) + + ! account for soil resistance, qgper and qgimp are calculated separately + l_vec = 0 + tmpw1 = caw(2)*((caw(3)*qm + cfw(0)*qsatl(0)*fc(0))/& + (caw(3) + caw(2) + cfw(0)*fc(0))) + tmpw2 = l_vec/(rhoair) + tmpw3 = cgw_per*qgper*fgper*fg + cgw_imp*qgimp*fgimp*fg + cfw(3)*qsatl(3)*fc(3) + facq = 1. - (caw(2)*caw(2)/& + (caw(3) + caw(2) + cfw(0)*fc(0))/& + (caw(2) + cgw_per*fgper*fg + cgw_imp*fgimp*fg + cfw(3)*fc(3))) + qaf(2) = (tmpw1 + tmpw2 + tmpw3)/& + (caw(2) + cgw_per*fgper*fg + cgw_imp*fgimp*fg + cfw(3)*fc(3))/& + facq + + tmpw1 = 1/(4*hlr+1)*(Fhac+Fwst)/(rhoair*cpair) + taf(3) = (cah(3)*thm + cah(2)*taf(2) + cfh(0)*tu(0)*fc(0) + tmpw1)/& + (cah(3) + cah(2) + cfh(0)*fc(0)) + qaf(3) = (caw(3)*qm + caw(2)*qaf(2) + cfw(0)*qsatl(0)*fc(0))/& + (caw(3) + caw(2) + cfw(0)*fc(0)) + ENDIF + + IF (numlay .eq. 3) THEN + + ! - Equations: + ! taf(3) = (thm/rah+1/rd(3)*taf(2)+AHE2/rho/cpair+1/rb(0)*troof*fc(0))/& + ! (1/rah+1/rd(3)+1/rb(0)*fc(0)) + ! taf(2) = (1/rd(3)*taf(3)+1/rd(2)*taf1+1/rb(1)*twsun*fc(1)+1/rb(2)*twsha*fc(2)+AHE1/rho/cpair)/& + ! (1/rd(3)+1/rd(2)+1/rb(1)*fc(1)+1/rb(2)*fc(2)) + ! taf(1) = (1/rd(2)*taf(2)+1/rd(1)*tg*fg+1/rb(3)*tl*fc(3)+Hveh/rhoair/cpair)/& + ! (1/rd(2)+1/rd(1)*fg+1/rb(3)*fc(3)) + ! - Equations: + ! qaf(3) = (1/raw*qm+1/rd(3)*qaf(2)+1/rb(0)*qroof*fc(0))/& + ! (1/raw+1/rd(3)+1/rb(0)*fc(0)) + ! qaf(2) = (1/rd(3)*qaf(3)+1/rd(2)*qaf(1))/& + ! (1/rd(3) + 1/rd(2)) + ! qaf(1) = (1/rd(2)*qaf(2)+1/(rd(1)+rsr)*qgper*fgper*fg+1/rd(1)*qimp*fgimp*fg+1/(rb(3)+rs)*ql*fc(3)+h_veh/rho))/& + ! (1/rd(2)+1/(rd(1)+rsr)*fgper*fg+1/rd(1)*fgimp*fg+1/(rb(3)+rs)*fc(3)) + + tmpw1 = cah(1)*(cgh(1)*tg*fg + cfh(3)*tu(3)*fc(3) + (vehc+meta)/rhoair/cpair)/& + (cah(1) + cgh(1)*fg + cfh(3)*fc(3)) + tmpw2 = cah(2)*(cah(3)*thm + cfh(0)*tu(0)*fc(0) + 1/(4*hlr+1)*(Fhac+Fwst)/(rhoair*cpair))/& + (cah(3) + cah(2) + cfh(0)*fc(0)) + tmpw3 = cah(1)*cah(1)/& + (cah(1) + cgh(1)*fg + cfh(3)*fc(3))/& + (cah(1) + cah(2) + cfh(1)*fc(1) + cfh(2)*fc(2)) + tmpw4 = cah(2)*cah(2)/& + (cah(3) + cah(2) + cfh(0)*fc(0))/& + (cah(1) + cah(2) + cfh(1)*fc(1) + cfh(2)*fc(2)) + fact = 1. - tmpw3 - tmpw4 + + taf(2) = (tmpw1 + tmpw2 + cfh(1)*tu(1)*fc(1) + cfh(2)*tu(2)*fc(2) + (4*hlr/(4*hlr+1)*(Fhac+Fwst)+Fach)/(rhoair*cpair))/& + (cah(1) + cah(2) + cfh(1)*fc(1) + cfh(2)*fc(2))/& + fact + + taf(1) = (cah(1)*taf(2) + cgh(1)*tg*fg + cfh(3)*tu(3)*fc(3) + (vehc+meta)/rhoair/cpair)/& + (cah(1) + cgh(1)*fg + cfh(3)*fc(3)) + tmpw1 = 1/(4*hlr+1)*(Fhac+Fwst)/(rhoair*cpair) + taf(3) = (cah(3)*thm + cah(2)*taf(2) + cfh(0)*tu(0)*fc(0) + tmpw1)/& + (cah(3) + cah(2) + cfh(0)*fc(0)) + + IF (qgper < qaf(1)) THEN + ! dew case. no soil resistance + cgw_per= cgw(1) + ELSE + cgw_per= 1/(1/cgw(1)+rsr) + ENDIF + + cgw_imp= fwet_gimp*cgw(1) + + l_vec = 0 + tmpw1 = caw(1)*(cgw_per*qgper*fgper*fg + cgw_imp*qgimp*fgimp*fg + cfw(3)*qsatl(3)*fc(3) + l_vec/(rhoair))/& + (caw(1) + cgw_per*fgper*fg + cgw_imp*fgimp*fg + cfw(3)*fc(3)) + tmpw2 = caw(2)*(caw(3)*qm + cfw(0)*qsatl(0)*fc(0))/& + (caw(3) + caw(2) + cfw(0)*fc(0)) + tmpw3 = caw(1)*caw(1)/& + (caw(1) + cgw_per*fgper*fg + cgw_imp*fgimp*fg + cfw(3)*fc(3))/& + (caw(2) + caw(1)) + tmpw4 = caw(2)*caw(2)/& + (caw(3) + caw(2) + cfw(0)*fc(0))/& + (caw(2) + caw(1)) + facq = 1. - tmpw3 - tmpw4 + + qaf(2) = (tmpw1 + tmpw2)/& + (caw(2) + caw(1))/& + facq + + tmpw1 = l_vec/(rhoair) + qaf(1) = (caw(1)*qaf(2) + qgper*cgw_per*fgper*fg + qgimp*cgw_imp*fgimp*fg + cfw(3)*qsatl(3)*fc(3) + tmpw1)/& + (caw(1) + cgw_per*fgper*fg + cgw_imp*fgimp*fg + cfw(3)*fc(3)) + qaf(3) = (caw(3)*qm + caw(2)*qaf(2) + cfw(0)*qsatl(0)*fc(0))/& + (caw(3) + caw(2) + cfw(0)*fc(0)) + ENDIF !----------------------------------------------------------------------- ! IR radiation, sensible and latent heat fluxes and their derivatives @@ -1955,526 +1955,526 @@ SUBROUTINE UrbanVegFlux ( & ! the partial derivatives of areodynamical resistance are ignored ! which cannot be determined analtically - !NOTE: ONLY for vegetation - i = 3 + !NOTE: ONLY for vegetation + i = 3 ! sensible heat fluxes and their derivatives - fsenl = rhoair * cpair * cfh(i) * (tl - taf(botlay)) + fsenl = rhoair * cpair * cfh(i) * (tl - taf(botlay)) - ! 09/24/2017: why fact/facq here? bugs? YES - ! 09/25/2017: re-written, check it clearfully - ! 11/25/2021: re-written, double check - IF (botlay == 2) THEN - fsenl_dtl = rhoair * cpair * cfh(i) * (1.-wtl0(i)/fact) - ELSE - fsenl_dtl = rhoair * cpair * cfh(i) * (1.-wta0(1)*wtg0(2)*wtl0(i)/fact-wtl0(i)) - ENDIF + ! 09/24/2017: why fact/facq here? bugs? YES + ! 09/25/2017: re-written, check it clearfully + ! 11/25/2021: re-written, double check + IF (botlay == 2) THEN + fsenl_dtl = rhoair * cpair * cfh(i) * (1.-wtl0(i)/fact) + ELSE + fsenl_dtl = rhoair * cpair * cfh(i) * (1.-wta0(1)*wtg0(2)*wtl0(i)/fact-wtl0(i)) + ENDIF ! latent heat fluxes and their derivatives - etr = rhoair * (1.-fwet) * delta * lai/(rb(i)+rs) & - * (qsatl(i) - qaf(botlay)) - - IF (botlay == 2) THEN - etr_dtl = rhoair * (1.-fwet) * delta * lai/(rb(i)+rs) & - * (1.-wtlq0(i)/facq)*qsatldT(i) - ELSE - etr_dtl = rhoair * (1.-fwet) * delta * lai/(rb(i)+rs) & - * (1.-wtaq0(1)*wtgq0(2)*wtlq0(i)/facq-wtlq0(i))*qsatldT(i) - ENDIF - - IF (etr.ge.etrc) THEN - etr = etrc - etr_dtl = 0. - ENDIF - - evplwet = rhoair * (1.-delta*(1.-fwet)) * lsai/rb(i) & - * (qsatl(i) - qaf(botlay)) - - IF (botlay == 2) THEN - evplwet_dtl = rhoair * (1.-delta*(1.-fwet)) * lsai/rb(i) & - * (1.-wtlq0(i)/facq)*qsatldT(i) - ELSE - evplwet_dtl = rhoair * (1.-delta*(1.-fwet)) * lsai/rb(i) & - * (1.-wtaq0(1)*wtgq0(2)*wtlq0(i)/facq-wtlq0(i))*qsatldT(i) - ENDIF - - IF (evplwet.ge.ldew/deltim) THEN - evplwet = ldew/deltim - evplwet_dtl = 0. - ENDIF - - fevpl = etr + evplwet - fevpl_dtl = etr_dtl + evplwet_dtl - - erre = 0. - fevpl_noadj = fevpl - IF ( fevpl*fevpl_bef < 0. ) THEN - erre = -0.9*fevpl - fevpl = 0.1*fevpl - ENDIF + etr = rhoair * (1.-fwet) * delta * lai/(rb(i)+rs) & + * (qsatl(i) - qaf(botlay)) + + IF (botlay == 2) THEN + etr_dtl = rhoair * (1.-fwet) * delta * lai/(rb(i)+rs) & + * (1.-wtlq0(i)/facq)*qsatldT(i) + ELSE + etr_dtl = rhoair * (1.-fwet) * delta * lai/(rb(i)+rs) & + * (1.-wtaq0(1)*wtgq0(2)*wtlq0(i)/facq-wtlq0(i))*qsatldT(i) + ENDIF + + IF (etr.ge.etrc) THEN + etr = etrc + etr_dtl = 0. + ENDIF + + evplwet = rhoair * (1.-delta*(1.-fwet)) * lsai/rb(i) & + * (qsatl(i) - qaf(botlay)) + + IF (botlay == 2) THEN + evplwet_dtl = rhoair * (1.-delta*(1.-fwet)) * lsai/rb(i) & + * (1.-wtlq0(i)/facq)*qsatldT(i) + ELSE + evplwet_dtl = rhoair * (1.-delta*(1.-fwet)) * lsai/rb(i) & + * (1.-wtaq0(1)*wtgq0(2)*wtlq0(i)/facq-wtlq0(i))*qsatldT(i) + ENDIF + + IF (evplwet.ge.ldew/deltim) THEN + evplwet = ldew/deltim + evplwet_dtl = 0. + ENDIF + + fevpl = etr + evplwet + fevpl_dtl = etr_dtl + evplwet_dtl + + erre = 0. + fevpl_noadj = fevpl + IF ( fevpl*fevpl_bef < 0. ) THEN + erre = -0.9*fevpl + fevpl = 0.1*fevpl + ENDIF !----------------------------------------------------------------------- ! difference of temperatures by quasi-newton-raphson method for the non-linear system equations !----------------------------------------------------------------------- - ! calculate irab, dirab_dtl - B(5) = B_5*tl**4 - B1(5) = B1_5*tl**4 - dBdT(5) = dBdT_5*tl**3 - X = matmul(Ainv, B) - ! first 5 items of dBdT is 0, dBdT*(0,0,0,0,0,1) - dX = matmul(Ainv, dBdT*uvec) + ! calculate irab, dirab_dtl + B(5) = B_5*tl**4 + B1(5) = B1_5*tl**4 + dBdT(5) = dBdT_5*tl**3 + X = matmul(Ainv, B) + ! first 5 items of dBdT is 0, dBdT*(0,0,0,0,0,1) + dX = matmul(Ainv, dBdT*uvec) - ! calculate longwave for vegetation - irab = ( (sum(X(1:4)*VegVF(1:4)) + frl*VegVF(5))*ev - B1(5))/fcover(5)*fg - dirab_dtl = ( sum(dX(1:4)*VegVF(1:4))*ev - dBdT(5) )/fcover(5)*fg + ! calculate longwave for vegetation + irab = ( (sum(X(1:4)*VegVF(1:4)) + frl*VegVF(5))*ev - B1(5))/fcover(5)*fg + dirab_dtl = ( sum(dX(1:4)*VegVF(1:4))*ev - dBdT(5) )/fcover(5)*fg - ! solve for leaf temperature - dtl(it) = (sabv + irab - fsenl - hvap*fevpl) & - / (lsai*clai/deltim - dirab_dtl + fsenl_dtl + hvap*fevpl_dtl) - dtl_noadj = dtl(it) + ! solve for leaf temperature + dtl(it) = (sabv + irab - fsenl - hvap*fevpl) & + / (lsai*clai/deltim - dirab_dtl + fsenl_dtl + hvap*fevpl_dtl) + dtl_noadj = dtl(it) - ! check magnitude of change in leaf temperature limit to maximum allowed value + ! check magnitude of change in leaf temperature limit to maximum allowed value - IF (it .le. itmax) THEN + IF (it .le. itmax) THEN - ! put brakes on large temperature excursions - IF (abs(dtl(it)).gt.delmax) THEN - dtl(it) = delmax*dtl(it)/abs(dtl(it)) - ENDIF + ! put brakes on large temperature excursions + IF (abs(dtl(it)).gt.delmax) THEN + dtl(it) = delmax*dtl(it)/abs(dtl(it)) + ENDIF - IF ((it.ge.2) .and. (dtl(it-1)*dtl(it).le.0.)) THEN - dtl(it) = 0.5*(dtl(it-1) + dtl(it)) - ENDIF + IF ((it.ge.2) .and. (dtl(it-1)*dtl(it).le.0.)) THEN + dtl(it) = 0.5*(dtl(it-1) + dtl(it)) + ENDIF - ENDIF + ENDIF - tl = tlbef + dtl(it) - tu(3) = tl + tl = tlbef + dtl(it) + tu(3) = tl !----------------------------------------------------------------------- ! square roots differences of temperatures and fluxes for use as the condition of convergences !----------------------------------------------------------------------- - del = sqrt( dtl(it)*dtl(it) ) - dele = dtl(it) * dtl(it) * & - ( dirab_dtl**2 + fsenl_dtl**2 + hvap*fevpl_dtl**2 ) - dele = sqrt(dele) + del = sqrt( dtl(it)*dtl(it) ) + dele = dtl(it) * dtl(it) * & + ( dirab_dtl**2 + fsenl_dtl**2 + hvap*fevpl_dtl**2 ) + dele = sqrt(dele) !----------------------------------------------------------------------- ! saturated vapor pressures and canopy air temperature, canopy air humidity !----------------------------------------------------------------------- ! Recalculate leaf saturated vapor pressure (ei_)for updated leaf temperature ! and adjust specific humidity (qsatl_) proportionately - CALL qsadv(tu(i),psrf,ei(i),deiDT(i),qsatl(i),qsatldT(i)) + CALL qsadv(tu(i),psrf,ei(i),deiDT(i),qsatl(i),qsatldT(i)) ! update vegetation/ground surface temperature, canopy air temperature, ! canopy air humidity - ! calculate wtll, wtlql - wtll(:) = 0. - wtlql(:) = 0. - - DO i = 0, nurb - clev = canlev(i) - wtll(clev) = wtll(clev) + wtl0(i)*tu(i) - wtlql(clev) = wtlql(clev) + wtlq0(i)*qsatl(i) - ENDDO - - IF (numlay .eq. 2) THEN - - ! - Equations: - ! taf(3) = (1/rah*thm + 1/rd(3)*taf(2) + 1/rb(0)*troof*fc(0) + AHE/(rho*cp))/(1/rah + 1/rd(3) + 1/rb(0)*fc(0)) - ! taf(2) = (1/rd(3)*taf(3) + 1/rd(2)*tg*fg + 1/rb(1)*twsun*fc(1) + 1/rb(2)*twsha*fc(2) + lsai/rb(3)*tl*fc(3) + AHE/(rho*cp))/ & - ! (1/rd(3) + 1/rd(2)*fg + 1/rb(1)*fc(1) + 1/rb(2)*fc(2) + lsai/rb(3)*fc(3)) - ! Also written as: - ! taf(3) = (cah(3)*thm + cah(2)*taf(2) + cfh(0)*troof*fc(0))/(cah(3) + cah(2) + cfh(0)*fc(0)) - ! taf(2) = (cah(2)*taf(3) + cgh(2)*tg*fg + cfh(1)*twsun*fc(1) + cfh(2)*twsha*fc(2) + cfh(3)*tl*fc(3) + AHE/(rho*cp))/ & - ! (cah(2) + cgh(2)*fg + cfh(1)*fc(1) + cfh(2)*fc(2) + cfh(3)*fc(3)) - ! - Equations: - ! qaf(3) = (1/raw*qm + 1/rd(3)*qaf(2) + 1/rb(0)*qroof*fc(0))/(1/raw + 1/rd(3) + 1/rb(0)*fc(0)) - ! qaf(2) = (1/rd(3)*qaf(3) + 1/(rd(2)+rsr)*qper*fgper*fg + fwetimp/rd(2)*qimp*fgimp*fg + lsai/(rb(3)+rs)*ql*fc(3) + AHE/rho)/ & - ! (1/rd(3) + 1/(rd(2)+rsr)*fgper*fg + fwetimp/rd(2)*fgimp*fg + lsai/(rb(3)+rs)*fc(3)) - ! Also written as: - ! qaf(3) = (caw(3)*qm + caw(2)*qaf(2) + cfw(0)*qroof*fc(0))/(caw(3) + caw(2) + cfw(0)*fc(0)) - ! qaf(2) = (caw(2)*qaf(3) + cgwper*qper*fgper*fg + cgwimp*qimp*fgimp*fg + cfw(3)*ql*fc(3) + AHE/rho)/ & - ! (caw(2) + cgwper*fgper*fg + cgwimp*fgimp*fg + cfw(3)*fc(3)) - - ! 06/20/2021, yuan: account for AH - ! 92% heat release as SH, Pigeon et al., 2007 - - h_vec = vehc - tmpw1 = cah(2)*((cah(3)*thm + cfh(0)*tu(0)*fc(0) + 1/(4*hlr+1)*(Fhac+Fwst)/(rhoair*cpair))/& - (cah(3) + cah(2) + cfh(0)*fc(0))) - tmpw2 = (4*hlr/(4*hlr+1)*(Fhac+Fwst)+Fach)/(rhoair*cpair) + (h_vec+meta)/(rhoair*cpair) - tmpw3 = cgh(2)*fg*tg + cfh(1)*tu(1)*fc(1) + cfh(2)*tu(2)*fc(2) + cfh(3)*tu(3)*fc(3) - fact = 1. - (cah(2)*cah(2)/(cah(3) + cah(2) + cfh(0)*fc(0))/& - (cah(2) + cgh(2)*fg + cfh(1)*fc(1) + cfh(2)*fc(2) + cfh(3)*fc(3))) - taf(2) = (tmpw1 + tmpw2 + tmpw3) / & - (cah(2) + cgh(2)*fg + cfh(1)*fc(1) + cfh(2)*fc(2) + cfh(3)*fc(3)) / & - fact - - IF (qgper < qaf(2)) THEN - ! dew case. no soil resistance - cgw_per= cgw(2) - ELSE - cgw_per= 1/(1/cgw(2)+rsr) - ENDIF - - cgw_imp= fwet_gimp*cgw(2) - - ! account for soil resistance, qgper and qgimp are calculated separately - l_vec = 0 - tmpw1 = caw(2)*((caw(3)*qm + cfw(0)*qsatl(0)*fc(0))/& - (caw(3) + caw(2) + cfw(0)*fc(0))) - tmpw2 = l_vec/(rhoair) - tmpw3 = cgw_per*qgper*fgper*fg + cgw_imp*qgimp*fgimp*fg + cfw(3)*qsatl(3)*fc(3) - facq = 1. - (caw(2)*caw(2)/& - (caw(3) + caw(2) + cfw(0)*fc(0))/& - (caw(2) + cgw_per*fgper*fg + cgw_imp*fgimp*fg + cfw(3)*fc(3))) - qaf(2) = (tmpw1 + tmpw2 + tmpw3)/& - (caw(2) + cgw_per*fgper*fg + cgw_imp*fgimp*fg + cfw(3)*fc(3))/& - facq - - tmpw1 = 1/(4*hlr+1)*(Fhac+Fwst)/(rhoair*cpair) - taf(3) = (cah(3)*thm + cah(2)*taf(2) + cfh(0)*tu(0)*fc(0) + tmpw1)/& - (cah(3) + cah(2) + cfh(0)*fc(0)) - qaf(3) = (caw(3)*qm + caw(2)*qaf(2) + cfw(0)*qsatl(0)*fc(0))/& - (caw(3) + caw(2) + cfw(0)*fc(0)) - ENDIF - - IF (numlay .eq. 3) THEN - - ! - Equations: - ! taf(3) = (thm/rah+1/rd(3)*taf(2)+AHE2/rho/cpair+1/rb(0)*troof*fc(0))/& - ! (1/rah+1/rd(3)+1/rb(0)*fc(0)) - ! taf(2) = (1/rd(3)*taf(3)+1/rd(2)*taf1+1/rb(1)*twsun*fc(1)+1/rb(2)*twsha*fc(2)+AHE1/rho/cpair)/& - ! (1/rd(3)+1/rd(2)+1/rb(1)*fc(1)+1/rb(2)*fc(2)) - ! taf(1) = (1/rd(2)*taf(2)+1/rd(1)*tg*fg+1/rb(3)*tl*fc(3)+Hveh/rhoair/cpair)/& - ! (1/rd(2)+1/rd(1)*fg+1/rb(3)*fc(3)) - ! - Equations: - ! qaf(3) = (1/raw*qm+1/rd(3)*qaf(2)+1/rb(0)*qroof*fc(0))/& - ! (1/raw+1/rd(3)+1/rb(0)*fc(0)) - ! qaf(2) = (1/rd(3)*qaf(3)+1/rd(2)*qaf(1))/& - ! (1/rd(3) + 1/rd(2)) - ! qaf(1) = (1/rd(2)*qaf(2)+1/(rd(1)+rsr)*qgper*fgper*fg+1/rd(1)*qimp*fgimp*fg+1/(rb(3)+rs)*ql*fc(3)+h_veh/rho))/& - ! (1/rd(2)+1/(rd(1)+rsr)*fgper*fg+1/rd(1)*fgimp*fg+1/(rb(3)+rs)*fc(3)) - - tmpw1 = cah(1)*(cgh(1)*tg*fg + cfh(3)*tu(3)*fc(3) + (vehc+meta)/rhoair/cpair)/& - (cah(1) + cgh(1)*fg + cfh(3)*fc(3)) - tmpw2 = cah(2)*(cah(3)*thm + cfh(0)*tu(0)*fc(0) + 1/(4*hlr+1)*(Fhac+Fwst)/(rhoair*cpair))/& - (cah(3) + cah(2) + cfh(0)*fc(0)) - tmpw3 = cah(1)*cah(1)/& - (cah(1) + cgh(1)*fg + cfh(3)*fc(3))/& - (cah(1) + cah(2) + cfh(1)*fc(1) + cfh(2)*fc(2)) - tmpw4 = cah(2)*cah(2)/& - (cah(3) + cah(2) + cfh(0)*fc(0))/& - (cah(1) + cah(2) + cfh(1)*fc(1) + cfh(2)*fc(2)) - fact = 1. - tmpw3 - tmpw4 - - taf(2) = (tmpw1 + tmpw2 + cfh(1)*tu(1)*fc(1) + cfh(2)*tu(2)*fc(2) + (4*hlr/(4*hlr+1)*(Fhac+Fwst)+Fach)/(rhoair*cpair))/& - (cah(1) + cah(2) + cfh(1)*fc(1) + cfh(2)*fc(2))/& - fact - - taf(1) = (cah(1)*taf(2) + cgh(1)*tg*fg + cfh(3)*tu(3)*fc(3) + (vehc+meta)/rhoair/cpair)/& - (cah(1) + cgh(1)*fg + cfh(3)*fc(3)) - tmpw1 = 1/(4*hlr+1)*(Fhac+Fwst)/(rhoair*cpair) - taf(3) = (cah(3)*thm + cah(2)*taf(2) + cfh(0)*tu(0)*fc(0) + tmpw1)/& - (cah(3) + cah(2) + cfh(0)*fc(0)) - - IF (qgper < qaf(1)) THEN - ! dew case. no soil resistance - cgw_per= cgw(1) - ELSE - cgw_per= 1/(1/cgw(1)+rsr) - ENDIF - - cgw_imp= fwet_gimp*cgw(1) - - l_vec = 0!vehc*0.08 - tmpw1 = caw(1)*(cgw_per*qgper*fgper*fg + cgw_imp*qgimp*fgimp*fg + cfw(3)*qsatl(3)*fc(3) + l_vec/(rhoair))/& - (caw(1) + cgw_per*fgper*fg + cgw_imp*fgimp*fg + cfw(3)*fc(3)) - tmpw2 = caw(2)*(caw(3)*qm + cfw(0)*qsatl(0)*fc(0))/& - (caw(3) + caw(2) + cfw(0)*fc(0)) - tmpw3 = caw(1)*caw(1)/& - (caw(1) + cgw_per*fgper*fg + cgw_imp*fgimp*fg + cfw(3)*fc(3))/& - (caw(2) + caw(1)) - tmpw4 = caw(2)*caw(2)/& - (caw(3) + caw(2) + cfw(0)*fc(0))/& - (caw(2) + caw(1)) - facq = 1. - tmpw3 - tmpw4 - - qaf(2) = (tmpw1 + tmpw2)/& - (caw(2) + caw(1))/& - facq - - tmpw1 = l_vec/(rhoair) - qaf(1) = (caw(1)*qaf(2) + qgper*cgw_per*fgper*fg + qgimp*cgw_imp*fgimp*fg + cfw(3)*qsatl(3)*fc(3) + tmpw1)/& - (caw(1) + cgw_per*fgper*fg + cgw_imp*fgimp*fg + cfw(3)*fc(3)) - qaf(3) = (caw(3)*qm + caw(2)*qaf(2) + cfw(0)*qsatl(0)*fc(0))/& - (caw(3) + caw(2) + cfw(0)*fc(0)) - - ENDIF - - !------------------------------------------------ - ! account for fwet for roof and impervious ground - IF (qaf(3) > qroof) THEN - fwet_roof = 1. !dew case - ELSE - fwet_roof = fwet_roof_ - ENDIF - - IF (qaf(botlay) > qgimp) THEN - fwet_gimp = 1. !dew case - ELSE - fwet_gimp = fwet_gimp_ - ENDIF - - ! weighted qg - ! NOTE: IF fwet_gimp=1, same as previous - fwetfac = fgimp*fwet_gimp + fgper - qg = (qgimp*fgimp*fwet_gimp + qgper*fgper) / fwetfac - - fgw(2) = fg*fwetfac + ! calculate wtll, wtlql + wtll(:) = 0. + wtlql(:) = 0. + + DO i = 0, nurb + clev = canlev(i) + wtll(clev) = wtll(clev) + wtl0(i)*tu(i) + wtlql(clev) = wtlql(clev) + wtlq0(i)*qsatl(i) + ENDDO + + IF (numlay .eq. 2) THEN + + ! - Equations: + ! taf(3) = (1/rah*thm + 1/rd(3)*taf(2) + 1/rb(0)*troof*fc(0) + AHE/(rho*cp))/(1/rah + 1/rd(3) + 1/rb(0)*fc(0)) + ! taf(2) = (1/rd(3)*taf(3) + 1/rd(2)*tg*fg + 1/rb(1)*twsun*fc(1) + 1/rb(2)*twsha*fc(2) + lsai/rb(3)*tl*fc(3) + AHE/(rho*cp))/ & + ! (1/rd(3) + 1/rd(2)*fg + 1/rb(1)*fc(1) + 1/rb(2)*fc(2) + lsai/rb(3)*fc(3)) + ! Also written as: + ! taf(3) = (cah(3)*thm + cah(2)*taf(2) + cfh(0)*troof*fc(0))/(cah(3) + cah(2) + cfh(0)*fc(0)) + ! taf(2) = (cah(2)*taf(3) + cgh(2)*tg*fg + cfh(1)*twsun*fc(1) + cfh(2)*twsha*fc(2) + cfh(3)*tl*fc(3) + AHE/(rho*cp))/ & + ! (cah(2) + cgh(2)*fg + cfh(1)*fc(1) + cfh(2)*fc(2) + cfh(3)*fc(3)) + ! - Equations: + ! qaf(3) = (1/raw*qm + 1/rd(3)*qaf(2) + 1/rb(0)*qroof*fc(0))/(1/raw + 1/rd(3) + 1/rb(0)*fc(0)) + ! qaf(2) = (1/rd(3)*qaf(3) + 1/(rd(2)+rsr)*qper*fgper*fg + fwetimp/rd(2)*qimp*fgimp*fg + lsai/(rb(3)+rs)*ql*fc(3) + AHE/rho)/ & + ! (1/rd(3) + 1/(rd(2)+rsr)*fgper*fg + fwetimp/rd(2)*fgimp*fg + lsai/(rb(3)+rs)*fc(3)) + ! Also written as: + ! qaf(3) = (caw(3)*qm + caw(2)*qaf(2) + cfw(0)*qroof*fc(0))/(caw(3) + caw(2) + cfw(0)*fc(0)) + ! qaf(2) = (caw(2)*qaf(3) + cgwper*qper*fgper*fg + cgwimp*qimp*fgimp*fg + cfw(3)*ql*fc(3) + AHE/rho)/ & + ! (caw(2) + cgwper*fgper*fg + cgwimp*fgimp*fg + cfw(3)*fc(3)) + + ! 06/20/2021, yuan: account for AH + ! 92% heat release as SH, Pigeon et al., 2007 + + h_vec = vehc + tmpw1 = cah(2)*((cah(3)*thm + cfh(0)*tu(0)*fc(0) + 1/(4*hlr+1)*(Fhac+Fwst)/(rhoair*cpair))/& + (cah(3) + cah(2) + cfh(0)*fc(0))) + tmpw2 = (4*hlr/(4*hlr+1)*(Fhac+Fwst)+Fach)/(rhoair*cpair) + (h_vec+meta)/(rhoair*cpair) + tmpw3 = cgh(2)*fg*tg + cfh(1)*tu(1)*fc(1) + cfh(2)*tu(2)*fc(2) + cfh(3)*tu(3)*fc(3) + fact = 1. - (cah(2)*cah(2)/(cah(3) + cah(2) + cfh(0)*fc(0))/& + (cah(2) + cgh(2)*fg + cfh(1)*fc(1) + cfh(2)*fc(2) + cfh(3)*fc(3))) + taf(2) = (tmpw1 + tmpw2 + tmpw3) / & + (cah(2) + cgh(2)*fg + cfh(1)*fc(1) + cfh(2)*fc(2) + cfh(3)*fc(3)) / & + fact + + IF (qgper < qaf(2)) THEN + ! dew case. no soil resistance + cgw_per= cgw(2) + ELSE + cgw_per= 1/(1/cgw(2)+rsr) + ENDIF + + cgw_imp= fwet_gimp*cgw(2) + + ! account for soil resistance, qgper and qgimp are calculated separately + l_vec = 0 + tmpw1 = caw(2)*((caw(3)*qm + cfw(0)*qsatl(0)*fc(0))/& + (caw(3) + caw(2) + cfw(0)*fc(0))) + tmpw2 = l_vec/(rhoair) + tmpw3 = cgw_per*qgper*fgper*fg + cgw_imp*qgimp*fgimp*fg + cfw(3)*qsatl(3)*fc(3) + facq = 1. - (caw(2)*caw(2)/& + (caw(3) + caw(2) + cfw(0)*fc(0))/& + (caw(2) + cgw_per*fgper*fg + cgw_imp*fgimp*fg + cfw(3)*fc(3))) + qaf(2) = (tmpw1 + tmpw2 + tmpw3)/& + (caw(2) + cgw_per*fgper*fg + cgw_imp*fgimp*fg + cfw(3)*fc(3))/& + facq + + tmpw1 = 1/(4*hlr+1)*(Fhac+Fwst)/(rhoair*cpair) + taf(3) = (cah(3)*thm + cah(2)*taf(2) + cfh(0)*tu(0)*fc(0) + tmpw1)/& + (cah(3) + cah(2) + cfh(0)*fc(0)) + qaf(3) = (caw(3)*qm + caw(2)*qaf(2) + cfw(0)*qsatl(0)*fc(0))/& + (caw(3) + caw(2) + cfw(0)*fc(0)) + ENDIF + + IF (numlay .eq. 3) THEN + + ! - Equations: + ! taf(3) = (thm/rah+1/rd(3)*taf(2)+AHE2/rho/cpair+1/rb(0)*troof*fc(0))/& + ! (1/rah+1/rd(3)+1/rb(0)*fc(0)) + ! taf(2) = (1/rd(3)*taf(3)+1/rd(2)*taf1+1/rb(1)*twsun*fc(1)+1/rb(2)*twsha*fc(2)+AHE1/rho/cpair)/& + ! (1/rd(3)+1/rd(2)+1/rb(1)*fc(1)+1/rb(2)*fc(2)) + ! taf(1) = (1/rd(2)*taf(2)+1/rd(1)*tg*fg+1/rb(3)*tl*fc(3)+Hveh/rhoair/cpair)/& + ! (1/rd(2)+1/rd(1)*fg+1/rb(3)*fc(3)) + ! - Equations: + ! qaf(3) = (1/raw*qm+1/rd(3)*qaf(2)+1/rb(0)*qroof*fc(0))/& + ! (1/raw+1/rd(3)+1/rb(0)*fc(0)) + ! qaf(2) = (1/rd(3)*qaf(3)+1/rd(2)*qaf(1))/& + ! (1/rd(3) + 1/rd(2)) + ! qaf(1) = (1/rd(2)*qaf(2)+1/(rd(1)+rsr)*qgper*fgper*fg+1/rd(1)*qimp*fgimp*fg+1/(rb(3)+rs)*ql*fc(3)+h_veh/rho))/& + ! (1/rd(2)+1/(rd(1)+rsr)*fgper*fg+1/rd(1)*fgimp*fg+1/(rb(3)+rs)*fc(3)) + + tmpw1 = cah(1)*(cgh(1)*tg*fg + cfh(3)*tu(3)*fc(3) + (vehc+meta)/rhoair/cpair)/& + (cah(1) + cgh(1)*fg + cfh(3)*fc(3)) + tmpw2 = cah(2)*(cah(3)*thm + cfh(0)*tu(0)*fc(0) + 1/(4*hlr+1)*(Fhac+Fwst)/(rhoair*cpair))/& + (cah(3) + cah(2) + cfh(0)*fc(0)) + tmpw3 = cah(1)*cah(1)/& + (cah(1) + cgh(1)*fg + cfh(3)*fc(3))/& + (cah(1) + cah(2) + cfh(1)*fc(1) + cfh(2)*fc(2)) + tmpw4 = cah(2)*cah(2)/& + (cah(3) + cah(2) + cfh(0)*fc(0))/& + (cah(1) + cah(2) + cfh(1)*fc(1) + cfh(2)*fc(2)) + fact = 1. - tmpw3 - tmpw4 + + taf(2) = (tmpw1 + tmpw2 + cfh(1)*tu(1)*fc(1) + cfh(2)*tu(2)*fc(2) + (4*hlr/(4*hlr+1)*(Fhac+Fwst)+Fach)/(rhoair*cpair))/& + (cah(1) + cah(2) + cfh(1)*fc(1) + cfh(2)*fc(2))/& + fact + + taf(1) = (cah(1)*taf(2) + cgh(1)*tg*fg + cfh(3)*tu(3)*fc(3) + (vehc+meta)/rhoair/cpair)/& + (cah(1) + cgh(1)*fg + cfh(3)*fc(3)) + tmpw1 = 1/(4*hlr+1)*(Fhac+Fwst)/(rhoair*cpair) + taf(3) = (cah(3)*thm + cah(2)*taf(2) + cfh(0)*tu(0)*fc(0) + tmpw1)/& + (cah(3) + cah(2) + cfh(0)*fc(0)) + + IF (qgper < qaf(1)) THEN + ! dew case. no soil resistance + cgw_per= cgw(1) + ELSE + cgw_per= 1/(1/cgw(1)+rsr) + ENDIF + + cgw_imp= fwet_gimp*cgw(1) + + l_vec = 0!vehc*0.08 + tmpw1 = caw(1)*(cgw_per*qgper*fgper*fg + cgw_imp*qgimp*fgimp*fg + cfw(3)*qsatl(3)*fc(3) + l_vec/(rhoair))/& + (caw(1) + cgw_per*fgper*fg + cgw_imp*fgimp*fg + cfw(3)*fc(3)) + tmpw2 = caw(2)*(caw(3)*qm + cfw(0)*qsatl(0)*fc(0))/& + (caw(3) + caw(2) + cfw(0)*fc(0)) + tmpw3 = caw(1)*caw(1)/& + (caw(1) + cgw_per*fgper*fg + cgw_imp*fgimp*fg + cfw(3)*fc(3))/& + (caw(2) + caw(1)) + tmpw4 = caw(2)*caw(2)/& + (caw(3) + caw(2) + cfw(0)*fc(0))/& + (caw(2) + caw(1)) + facq = 1. - tmpw3 - tmpw4 + + qaf(2) = (tmpw1 + tmpw2)/& + (caw(2) + caw(1))/& + facq + + tmpw1 = l_vec/(rhoair) + qaf(1) = (caw(1)*qaf(2) + qgper*cgw_per*fgper*fg + qgimp*cgw_imp*fgimp*fg + cfw(3)*qsatl(3)*fc(3) + tmpw1)/& + (caw(1) + cgw_per*fgper*fg + cgw_imp*fgimp*fg + cfw(3)*fc(3)) + qaf(3) = (caw(3)*qm + caw(2)*qaf(2) + cfw(0)*qsatl(0)*fc(0))/& + (caw(3) + caw(2) + cfw(0)*fc(0)) + + ENDIF + + !------------------------------------------------ + ! account for fwet for roof and impervious ground + IF (qaf(3) > qroof) THEN + fwet_roof = 1. !dew case + ELSE + fwet_roof = fwet_roof_ + ENDIF + + IF (qaf(botlay) > qgimp) THEN + fwet_gimp = 1. !dew case + ELSE + fwet_gimp = fwet_gimp_ + ENDIF + + ! weighted qg + ! NOTE: IF fwet_gimp=1, same as previous + fwetfac = fgimp*fwet_gimp + fgper + qg = (qgimp*fgimp*fwet_gimp + qgper*fgper) / fwetfac + + fgw(2) = fg*fwetfac ! update co2 partial pressure within canopy air - ! 05/02/2016: may have some problem with gdh2o, however, - ! this variable seems never used here. Different height - ! level vegetation should have different gdh2o, i.e., - ! different rd(layer) values. - gah2o = 1.0/raw * tprcor/thm !mol m-2 s-1 - gdh2o = 1.0/rd(botlay) * tprcor/thm !mol m-2 s-1 + ! 05/02/2016: may have some problem with gdh2o, however, + ! this variable seems never used here. Different height + ! level vegetation should have different gdh2o, i.e., + ! different rd(layer) values. + gah2o = 1.0/raw * tprcor/thm !mol m-2 s-1 + gdh2o = 1.0/rd(botlay) * tprcor/thm !mol m-2 s-1 - pco2a = pco2m - 1.37*psrf/max(0.446,gah2o) * & - (assim - respc - rsoil) + pco2a = pco2m - 1.37*psrf/max(0.446,gah2o) * & + (assim - respc - rsoil) !----------------------------------------------------------------------- ! Update monin-obukhov length and wind speed including the stability effect !----------------------------------------------------------------------- - ! USE the top layer taf and qaf - !TODO: need more check - dth = thm - taf(2) - dqh = qm - qaf(2) + ! USE the top layer taf and qaf + !TODO: need more check + dth = thm - taf(2) + dqh = qm - qaf(2) - tstar = vonkar/(fh)*dth - qstar = vonkar/(fq)*dqh + tstar = vonkar/(fh)*dth + qstar = vonkar/(fq)*dqh - thvstar = tstar*(1.+0.61*qm)+0.61*th*qstar - zeta = zldis*vonkar*grav*thvstar / (ustar**2*thv) - IF (zeta .ge. 0.) THEN !stable - zeta = min(2.,max(zeta,1.e-6)) - ELSE !unstable - zeta = max(-100.,min(zeta,-1.e-6)) - ENDIF - obu = zldis/zeta + thvstar = tstar*(1.+0.61*qm)+0.61*th*qstar + zeta = zldis*vonkar*grav*thvstar / (ustar**2*thv) + IF (zeta .ge. 0.) THEN !stable + zeta = min(2.,max(zeta,1.e-6)) + ELSE !unstable + zeta = max(-100.,min(zeta,-1.e-6)) + ENDIF + obu = zldis/zeta - IF (zeta .ge. 0.) THEN - um = max(ur,.1) - ELSE - wc = (-grav*ustar*thvstar*zii/thv)**(1./3.) - wc2 = beta*beta*(wc*wc) - um = sqrt(ur*ur+wc2) - ENDIF + IF (zeta .ge. 0.) THEN + um = max(ur,.1) + ELSE + wc = (-grav*ustar*thvstar*zii/thv)**(1./3.) + wc2 = beta*beta*(wc*wc) + um = sqrt(ur*ur+wc2) + ENDIF - IF (obuold*obu .lt. 0.) nmozsgn = nmozsgn+1 - IF (nmozsgn .ge. 4) obu = zldis/(-0.01) - obuold = obu + IF (obuold*obu .lt. 0.) nmozsgn = nmozsgn+1 + IF (nmozsgn .ge. 4) obu = zldis/(-0.01) + obuold = obu !----------------------------------------------------------------------- ! Test for convergence !----------------------------------------------------------------------- - it = it+1 + it = it+1 - IF (it .gt. itmin) THEN - fevpl_bef = fevpl - det = max(del,del2) - dee = max(dele,dele2) - IF (det .lt. dtmin .and. dee .lt. dlemin) EXIT - ENDIF + IF (it .gt. itmin) THEN + fevpl_bef = fevpl + det = max(del,del2) + dee = max(dele,dele2) + IF (det .lt. dtmin .and. dee .lt. dlemin) EXIT + ENDIF - ENDDO + ENDDO ! ====================================================================== ! END stability iteration ! ====================================================================== - zol = zeta - rib = min(5.,zol*ustar**2/(vonkar**2/fh*um**2)) + zol = zeta + rib = min(5.,zol*ustar**2/(vonkar**2/fh*um**2)) ! canopy fluxes and total assimilation amd respiration - IF (lai .gt. 0.001) THEN - rst = rs/lai - ELSE - rs = 2.0e4 - assim = 0. - respc = 0. - rst = 2.0e4 - ENDIF - respc = respc + rsoil + IF (lai .gt. 0.001) THEN + rst = rs/lai + ELSE + rs = 2.0e4 + assim = 0. + respc = 0. + rst = 2.0e4 + ENDIF + respc = respc + rsoil ! canopy fluxes and total assimilation amd respiration - fsenl = fsenl + fsenl_dtl*dtl(it-1) & - ! add the imbalanced energy below due to T adjustment to sensibel heat - + (dtl_noadj-dtl(it-1)) * (lsai*clai/deltim - dirab_dtl & - + fsenl_dtl + hvap*fevpl_dtl) & - ! add the imbalanced energy below due to q adjustment to sensibel heat - + hvap*erre + fsenl = fsenl + fsenl_dtl*dtl(it-1) & + ! add the imbalanced energy below due to T adjustment to sensibel heat + + (dtl_noadj-dtl(it-1)) * (lsai*clai/deltim - dirab_dtl & + + fsenl_dtl + hvap*fevpl_dtl) & + ! add the imbalanced energy below due to q adjustment to sensibel heat + + hvap*erre - etr = etr + etr_dtl*dtl(it-1) - evplwet = evplwet + evplwet_dtl*dtl(it-1) - fevpl = fevpl_noadj - fevpl = fevpl + fevpl_dtl*dtl(it-1) + etr = etr + etr_dtl*dtl(it-1) + evplwet = evplwet + evplwet_dtl*dtl(it-1) + fevpl = fevpl_noadj + fevpl = fevpl + fevpl_dtl*dtl(it-1) - elwmax = ldew/deltim + elwmax = ldew/deltim - elwdif = max(0., evplwet-elwmax) - evplwet = min(evplwet, elwmax) + elwdif = max(0., evplwet-elwmax) + evplwet = min(evplwet, elwmax) - fevpl = fevpl - elwdif - fsenl = fsenl + hvap*elwdif + fevpl = fevpl - elwdif + fsenl = fsenl + hvap*elwdif !----------------------------------------------------------------------- ! Update dew accumulation (kg/m2) !----------------------------------------------------------------------- - ldew = max(0., ldew-evplwet*deltim) + ldew = max(0., ldew-evplwet*deltim) !----------------------------------------------------------------------- ! balance check !----------------------------------------------------------------------- - err = sabv + irab + dirab_dtl*dtl(it-1) & - - fsenl - hvap*fevpl + err = sabv + irab + dirab_dtl*dtl(it-1) & + - fsenl - hvap*fevpl #if(defined CLMDEBUG) - IF (abs(err) .gt. .2) & - write(6,*) 'energy imbalance in UrbanVegFlux.F90', & - i,it-1,err,sabv,irab,fsenl,hvap*fevpl + IF (abs(err) .gt. .2) & + write(6,*) 'energy imbalance in UrbanVegFlux.F90', & + i,it-1,err,sabv,irab,fsenl,hvap*fevpl #endif - ! calculate longwave absorption - lwsun = ( ewall*X(1) - B1(1) ) / (1-ewall) - lwsha = ( ewall*X(2) - B1(2) ) / (1-ewall) - lgimp = ( egimp*X(3) - B1(3) ) / (1-egimp) - lgper = ( egper*X(4) - B1(4) ) / (1-egper) - lveg = ( (sum(X(1:4)*VegVF(1:4)) + frl*VegVF(5))*ev - B1(5) ) - lout = sum( X * SkyVF ) + ! calculate longwave absorption + lwsun = ( ewall*X(1) - B1(1) ) / (1-ewall) + lwsha = ( ewall*X(2) - B1(2) ) / (1-ewall) + lgimp = ( egimp*X(3) - B1(3) ) / (1-egimp) + lgper = ( egper*X(4) - B1(4) ) / (1-egper) + lveg = ( (sum(X(1:4)*VegVF(1:4)) + frl*VegVF(5))*ev - B1(5) ) + lout = sum( X * SkyVF ) - ! longwave absorption due to leaf temperature change - lwsun = lwsun + ( ewall*dX(1) ) / (1-ewall) * dtl(it-1) - lwsha = lwsha + ( ewall*dX(2) ) / (1-ewall) * dtl(it-1) - lgimp = lgimp + ( egimp*dX(3) ) / (1-egimp) * dtl(it-1) - lgper = lgper + ( egper*dX(4) ) / (1-egper) * dtl(it-1) - lveg = lveg + ( sum(dX(1:4)*VegVF(1:4))*ev - dBdT(5) ) * dtl(it-1) - lout = lout + sum( dX * SkyVF * dtl(it-1) ) + ! longwave absorption due to leaf temperature change + lwsun = lwsun + ( ewall*dX(1) ) / (1-ewall) * dtl(it-1) + lwsha = lwsha + ( ewall*dX(2) ) / (1-ewall) * dtl(it-1) + lgimp = lgimp + ( egimp*dX(3) ) / (1-egimp) * dtl(it-1) + lgper = lgper + ( egper*dX(4) ) / (1-egper) * dtl(it-1) + lveg = lveg + ( sum(dX(1:4)*VegVF(1:4))*ev - dBdT(5) ) * dtl(it-1) + lout = lout + sum( dX * SkyVF * dtl(it-1) ) - ! Energy balance check - err = lwsun + lwsha + lgimp + lgper + lveg + lout + ! Energy balance check + err = lwsun + lwsha + lgimp + lgper + lveg + lout - IF (abs(err-frl) > 1e-6) THEN - print *, "Longwave - Energy Balance Check error!", err-frl - ENDIF + IF (abs(err-frl) > 1e-6) THEN + print *, "Longwave - Energy Balance Check error!", err-frl + ENDIF - ! convert to per unit area - IF (fcover(1) > 0.) lwsun = lwsun / fcover(1) * fg !/ (4*fwsun*HL*fb/fg) - IF (fcover(2) > 0.) lwsha = lwsha / fcover(2) * fg !/ (4*fwsha*HL*fb/fg) - IF (fcover(3) > 0.) lgimp = lgimp / fcover(3) * fg !/ fgimp - IF (fcover(4) > 0.) lgper = lgper / fcover(4) * fg !/ fgper - IF (fcover(5) > 0.) lveg = lveg / fcover(5) * fg !/ fv/fg + ! convert to per unit area + IF (fcover(1) > 0.) lwsun = lwsun / fcover(1) * fg !/ (4*fwsun*HL*fb/fg) + IF (fcover(2) > 0.) lwsha = lwsha / fcover(2) * fg !/ (4*fwsha*HL*fb/fg) + IF (fcover(3) > 0.) lgimp = lgimp / fcover(3) * fg !/ fgimp + IF (fcover(4) > 0.) lgper = lgper / fcover(4) * fg !/ fgper + IF (fcover(5) > 0.) lveg = lveg / fcover(5) * fg !/ fv/fg - ! add previous longwave - lwsun = lwsun + lwsun_bef - lwsha = lwsha + lwsha_bef - lgimp = lgimp + lgimp_bef - lgper = lgper + lgper_bef - lveg = lveg + lveg_bef + ! add previous longwave + lwsun = lwsun + lwsun_bef + lwsha = lwsha + lwsha_bef + lgimp = lgimp + lgimp_bef + lgper = lgper + lgper_bef + lveg = lveg + lveg_bef - tafu = taf(2) + tafu = taf(2) !----------------------------------------------------------------------- ! wind stresses !----------------------------------------------------------------------- - taux = - rhoair*us/ram - tauy = - rhoair*vs/ram + taux = - rhoair*us/ram + tauy = - rhoair*vs/ram !----------------------------------------------------------------------- ! fluxes from roof, walls to canopy space !----------------------------------------------------------------------- - ! sensible heat fluxes - fsenroof = rhoair*cpair*cfh(0)*(troof-taf(3)) - fsenwsun = rhoair*cpair*cfh(1)*(twsun-taf(2)) - fsenwsha = rhoair*cpair*cfh(2)*(twsha-taf(2)) + ! sensible heat fluxes + fsenroof = rhoair*cpair*cfh(0)*(troof-taf(3)) + fsenwsun = rhoair*cpair*cfh(1)*(twsun-taf(2)) + fsenwsha = rhoair*cpair*cfh(2)*(twsha-taf(2)) - ! latent heat fluxes - fevproof = rhoair*cfw(0)*(qsatl(0)-qaf(3)) - fevproof = fevproof*fwet_roof + ! latent heat fluxes + fevproof = rhoair*cfw(0)*(qsatl(0)-qaf(3)) + fevproof = fevproof*fwet_roof - croofs = rhoair*cpair*cfh(0)*(1.-wtg0(3)*wta0(2)*wtl0(0)/fact-wtl0(0)) - cwalls = rhoair*cpair*cfh(1)*(1.-wtl0(1)/fact) - croofl = rhoair*cfw(0)*(1.-wtgq0(3)*wtaq0(2)*wtlq0(0)/facq-wtlq0(0))*qsatldT(0) - croofl = croofl*fwet_roof + croofs = rhoair*cpair*cfh(0)*(1.-wtg0(3)*wta0(2)*wtl0(0)/fact-wtl0(0)) + cwalls = rhoair*cpair*cfh(1)*(1.-wtl0(1)/fact) + croofl = rhoair*cfw(0)*(1.-wtgq0(3)*wtaq0(2)*wtlq0(0)/facq-wtlq0(0))*qsatldT(0) + croofl = croofl*fwet_roof - croof = croofs + croofl*htvp_roof + croof = croofs + croofl*htvp_roof !----------------------------------------------------------------------- ! fluxes from urban ground to canopy space !----------------------------------------------------------------------- - fsengimp = cpair*rhoair*cgh(botlay)*(tgimp-taf(botlay)) - fsengper = cpair*rhoair*cgh(botlay)*(tgper-taf(botlay)) + fsengimp = cpair*rhoair*cgh(botlay)*(tgimp-taf(botlay)) + fsengper = cpair*rhoair*cgh(botlay)*(tgper-taf(botlay)) - fevpgimp = rhoair*cgw_imp*(qgimp-qaf(botlay)) - fevpgper = rhoair*cgw_per*(qgper-qaf(botlay)) + fevpgimp = rhoair*cgw_imp*(qgimp-qaf(botlay)) + fevpgper = rhoair*cgw_per*(qgper-qaf(botlay)) - fevpgimp = fevpgimp*fwet_gimp + fevpgimp = fevpgimp*fwet_gimp !----------------------------------------------------------------------- ! Derivative of soil energy flux with respect to soil temperature !----------------------------------------------------------------------- - IF (botlay == 2) THEN - cgrnds = cpair*rhoair*cgh(2)*(1.-wtg0(2)/fact) - ! cgperl = rhoair*cgw(2)*(1.-wtgq0(2)/facq)*dqgperdT - ! cgimpl = rhoair*cgw(2)*(1.-wtgq0(2)/facq)*dqgimpdT - cgperl = rhoair*cgw_per*(dqgperdT & - - (dqgperdT*cgw_per*fgper*fg+dqgimpdT*cgw_imp*fgimp*fg) & - /(caw(2) + cgw_per*fgper*fg + cgw_imp*fgimp*fg + cfw(3)*fc(3)) & - /facq) - cgimpl = rhoair*cgw_imp*(dqgimpdT & - - (dqgperdT*cgw_per*fgper*fg+dqgimpdT*cgw_imp*fgimp*fg) & - /(caw(2) + cgw_per*fgper*fg + cgw_imp*fgimp*fg + cfw(3)*fc(3)) & - /facq) - cgimpl = cgimpl*fwet_gimp - ELSE !botlay == 1 - cgrnds = cpair*rhoair*cgh(1)*(1.-wta0(1)*wtg0(2)*wtg0(1)/fact-wtg0(1)) - cgperl = rhoair*cgw_per*(1.-wtaq0(1)*wtgq0(2)*wtgq0(1)/facq-wtgq0(1))*dqgperdT - cgimpl = rhoair*cgw_imp*(1.-wtaq0(1)*wtgq0(2)*wtgq0(1)/facq-wtgq0(1))*dqgimpdT - cgimpl = cgimpl*fwet_gimp - ENDIF - - cgimp = cgrnds + cgimpl*htvp_gimp - cgper = cgrnds + cgperl*htvp_gper + IF (botlay == 2) THEN + cgrnds = cpair*rhoair*cgh(2)*(1.-wtg0(2)/fact) + ! cgperl = rhoair*cgw(2)*(1.-wtgq0(2)/facq)*dqgperdT + ! cgimpl = rhoair*cgw(2)*(1.-wtgq0(2)/facq)*dqgimpdT + cgperl = rhoair*cgw_per*(dqgperdT & + - (dqgperdT*cgw_per*fgper*fg+dqgimpdT*cgw_imp*fgimp*fg) & + /(caw(2) + cgw_per*fgper*fg + cgw_imp*fgimp*fg + cfw(3)*fc(3)) & + /facq) + cgimpl = rhoair*cgw_imp*(dqgimpdT & + - (dqgperdT*cgw_per*fgper*fg+dqgimpdT*cgw_imp*fgimp*fg) & + /(caw(2) + cgw_per*fgper*fg + cgw_imp*fgimp*fg + cfw(3)*fc(3)) & + /facq) + cgimpl = cgimpl*fwet_gimp + ELSE !botlay == 1 + cgrnds = cpair*rhoair*cgh(1)*(1.-wta0(1)*wtg0(2)*wtg0(1)/fact-wtg0(1)) + cgperl = rhoair*cgw_per*(1.-wtaq0(1)*wtgq0(2)*wtgq0(1)/facq-wtgq0(1))*dqgperdT + cgimpl = rhoair*cgw_imp*(1.-wtaq0(1)*wtgq0(2)*wtgq0(1)/facq-wtgq0(1))*dqgimpdT + cgimpl = cgimpl*fwet_gimp + ENDIF + + cgimp = cgrnds + cgimpl*htvp_gimp + cgper = cgrnds + cgperl*htvp_gper !----------------------------------------------------------------------- ! 2 m height air temperature above apparent sink height !----------------------------------------------------------------------- - !tref = thm + vonkar/(fh)*dth * (fh2m/vonkar - fh/vonkar) - !qref = qm + vonkar/(fq)*dqh * (fq2m/vonkar - fq/vonkar) + !tref = thm + vonkar/(fh)*dth * (fh2m/vonkar - fh/vonkar) + !qref = qm + vonkar/(fq)*dqh * (fq2m/vonkar - fq/vonkar) END SUBROUTINE UrbanVegFlux !---------------------------------------------------------------------- - SUBROUTINE dewfraction (sigf,lai,sai,dewmx,ldew,fwet) + SUBROUTINE dewfraction (sigf,lai,sai,dewmx,ldew,fwet) !======================================================================= ! Original author: Yongjiu Dai, September 15, 1999 @@ -2484,42 +2484,42 @@ SUBROUTINE dewfraction (sigf,lai,sai,dewmx,ldew,fwet) ! !======================================================================= - USE MOD_Precision - IMPLICIT NONE + USE MOD_Precision + IMPLICIT NONE - REAL(r8), intent(in) :: sigf ! fraction of veg cover, excluding snow-covered veg [-] - REAL(r8), intent(in) :: lai ! leaf area index [-] - REAL(r8), intent(in) :: sai ! stem area index [-] - REAL(r8), intent(in) :: dewmx ! maximum allowed dew [0.1 mm] - REAL(r8), intent(in) :: ldew ! depth of water on foliage [kg/m2/s] + real(r8), intent(in) :: sigf ! fraction of veg cover, excluding snow-covered veg [-] + real(r8), intent(in) :: lai ! leaf area index [-] + real(r8), intent(in) :: sai ! stem area index [-] + real(r8), intent(in) :: dewmx ! maximum allowed dew [0.1 mm] + real(r8), intent(in) :: ldew ! depth of water on foliage [kg/m2/s] - REAL(r8), intent(out) :: fwet ! fraction of foliage covered by water [-] + real(r8), intent(out) :: fwet ! fraction of foliage covered by water [-] - REAL(r8) lsai ! lai + sai - REAL(r8) dewmxi ! inverse of maximum allowed dew [1/mm] - REAL(r8) vegt ! sigf*lsai + real(r8) lsai ! lai + sai + real(r8) dewmxi ! inverse of maximum allowed dew [1/mm] + real(r8) vegt ! sigf*lsai ! !----------------------------------------------------------------------- ! Fwet is the fraction of all vegetation surfaces which are wet ! including stem area which contribute to evaporation - lsai = lai + sai - dewmxi = 1.0/dewmx - ! why * sigf? may have bugs - ! 06/17/2018: - ! for ONLY one PFT, there may be no problem - ! but for multiple PFTs, bugs exist!!! - ! convert the whole area ldew to sigf ldew - vegt = lsai - - fwet = 0 - IF (ldew > 0.) THEN - fwet = ((dewmxi/vegt)*ldew)**.666666666666 + lsai = lai + sai + dewmxi = 1.0/dewmx + ! why * sigf? may have bugs + ! 06/17/2018: + ! for ONLY one PFT, there may be no problem + ! but for multiple PFTs, bugs exist!!! + ! convert the whole area ldew to sigf ldew + vegt = lsai + + fwet = 0 + IF (ldew > 0.) THEN + fwet = ((dewmxi/vegt)*ldew)**.666666666666 ! Check for maximum limit of fwet - fwet = min(fwet,1.0) + fwet = min(fwet,1.0) - ENDIF + ENDIF - END SUBROUTINE dewfraction + END SUBROUTINE dewfraction END MODULE MOD_Urban_Flux diff --git a/main/URBAN/MOD_Urban_GroundFlux.F90 b/main/URBAN/MOD_Urban_GroundFlux.F90 index 95630421..aa821836 100644 --- a/main/URBAN/MOD_Urban_GroundFlux.F90 +++ b/main/URBAN/MOD_Urban_GroundFlux.F90 @@ -2,19 +2,19 @@ MODULE MOD_Urban_GroundFlux - USE MOD_Precision - IMPLICIT NONE - SAVE + USE MOD_Precision + IMPLICIT NONE + SAVE - PUBLIC :: UrbanGroundFlux + PUBLIC :: UrbanGroundFlux CONTAINS - SUBROUTINE UrbanGroundFlux (hu, ht, hq, us, vs, tm, qm, rhoair, psrf, & - ur, thm, th, thv, zlnd, zsno, fsno_gimp, & - lbi, wliq_gimpsno,wice_gimpsno, & - fcover, tgimp, tgper, qgimp, qgper, tref, qref, & - z0m, z0hg, zol, ustar, qstar, tstar, fm, fh, fq) + SUBROUTINE UrbanGroundFlux (hu, ht, hq, us, vs, tm, qm, rhoair, psrf, & + ur, thm, th, thv, zlnd, zsno, fsno_gimp, & + lbi, wliq_gimpsno,wice_gimpsno, & + fcover, tgimp, tgper, qgimp, qgper, tref, qref, & + z0m, z0hg, zol, ustar, qstar, tstar, fm, fh, fq) !======================================================================= ! this is the main subroutine to execute the calculation @@ -22,15 +22,15 @@ SUBROUTINE UrbanGroundFlux (hu, ht, hq, us, vs, tm, qm, rhoair, psrf, & ! !======================================================================= - USE MOD_Precision - USE MOD_Const_Physical, only: cpair,vonkar,grav - USE MOD_FrictionVelocity - IMPLICIT NONE + USE MOD_Precision + USE MOD_Const_Physical, only: cpair,vonkar,grav + USE MOD_FrictionVelocity + IMPLICIT NONE !----------------------- Dummy argument -------------------------------- - INTEGER , intent(in) :: & + integer , intent(in) :: & lbi - REAL(r8), intent(in) :: & + real(r8), intent(in) :: & ! atmospherical variables and observational height hu, &! observational height of wind [m] ht, &! observational height of temperature [m] @@ -60,11 +60,11 @@ SUBROUTINE UrbanGroundFlux (hu, ht, hq, us, vs, tm, qm, rhoair, psrf, & qgimp, &! ground impervious specific humidity [kg/kg] qgper ! ground pervious specific humidity [kg/kg] - REAL(r8), intent(out) :: & + real(r8), intent(out) :: & tref, &! 2 m height air temperature [kelvin] qref ! 2 m height air humidity - REAL(r8), intent(out) :: & + real(r8), intent(out) :: & z0m, &! effective roughness [m] z0hg, &! roughness length over ground, sensible heat [m] zol, &! dimensionless height (z/L) used in Monin-Obukhov theory @@ -76,11 +76,11 @@ SUBROUTINE UrbanGroundFlux (hu, ht, hq, us, vs, tm, qm, rhoair, psrf, & fq ! integral of profile function for moisture !------------------------ LOCAL VARIABLES ------------------------------ - INTEGER niters, &! maximum number of iterations for surface temperature + integer niters, &! maximum number of iterations for surface temperature iter, &! iteration index nmozsgn ! number of times moz changes sign - REAL(r8) :: & + real(r8) :: & beta, &! coefficient of conective velocity [-] displax, &! zero-displacement height [m] tg, &! ground surface temperature [K] @@ -106,7 +106,7 @@ SUBROUTINE UrbanGroundFlux (hu, ht, hq, us, vs, tm, qm, rhoair, psrf, & z0mg, &! roughness length over ground, momentum [m] z0qg ! roughness length over ground, latent heat [m] - REAL(r8) fwet_gimp, fwetfac + real(r8) fwet_gimp, fwetfac !----------------------- Dummy argument -------------------------------- ! initial roughness length @@ -200,7 +200,7 @@ SUBROUTINE UrbanGroundFlux (hu, ht, hq, us, vs, tm, qm, rhoair, psrf, & ENDIF IF (obuold*obu < 0.) nmozsgn = nmozsgn+1 - IF (nmozsgn >= 4) exit + IF (nmozsgn >= 4) EXIT obuold = obu @@ -215,6 +215,6 @@ SUBROUTINE UrbanGroundFlux (hu, ht, hq, us, vs, tm, qm, rhoair, psrf, & tref = thm + vonkar/fh*dth * (fh2m/vonkar - fh/vonkar) qref = qm + vonkar/fq*dqh * (fq2m/vonkar - fq/vonkar) - END SUBROUTINE UrbanGroundFlux + END SUBROUTINE UrbanGroundFlux END MODULE MOD_Urban_GroundFlux diff --git a/main/URBAN/MOD_Urban_Hydrology.F90 b/main/URBAN/MOD_Urban_Hydrology.F90 index c7224b35..56fd3b7e 100644 --- a/main/URBAN/MOD_Urban_Hydrology.F90 +++ b/main/URBAN/MOD_Urban_Hydrology.F90 @@ -2,15 +2,15 @@ MODULE MOD_Urban_Hydrology - USE MOD_Precision - IMPLICIT NONE - SAVE + USE MOD_Precision + IMPLICIT NONE + SAVE - PUBLIC :: UrbanHydrology + PUBLIC :: UrbanHydrology CONTAINS - SUBROUTINE UrbanHydrology ( & + SUBROUTINE UrbanHydrology ( & ! model running information ipatch ,patchtype ,lbr ,lbi ,& lbp ,lbl ,snll ,deltim ,& @@ -55,16 +55,16 @@ SUBROUTINE UrbanHydrology ( & ! !======================================================================= - USE MOD_Precision - USE MOD_Vars_Global - USE MOD_Const_Physical, only: denice, denh2o, tfrz - USE MOD_SoilSnowHydrology - USE MOD_Lake + USE MOD_Precision + USE MOD_Vars_Global + USE MOD_Const_Physical, only: denice, denh2o, tfrz + USE MOD_SoilSnowHydrology + USE MOD_Lake - IMPLICIT NONE + IMPLICIT NONE !-----------------------Argument---------------------------------------- - INTEGER, intent(in) :: & + integer, intent(in) :: & ipatch ,&! patch index patchtype ,&! land patch type (0=soil, 1=urban or built-up, 2=wetland, ! 3=land ice, 4=land water bodies, 99=ocean @@ -73,10 +73,10 @@ SUBROUTINE UrbanHydrology ( & lbp ,&! lower bound of array lbl ! lower bound of array - INTEGER, intent(inout) :: & + integer, intent(inout) :: & snll ! number of snow layers - REAL(r8), intent(in) :: & + real(r8), intent(in) :: & deltim ,&! time step (s) pg_rain ,&! rainfall after removal of interception (mm h2o/s) pg_snow ,&! snowfall after removal of interception (mm h2o/s) @@ -90,7 +90,7 @@ SUBROUTINE UrbanHydrology ( & wtfact ,&! fraction of model area with high water table pondmx ,&! ponding depth (mm) ssi ,&! irreducible water saturation of snow - wimp ,&! water impremeable if porosity less than wimp + wimp ,&! water impremeable IF porosity less than wimp smpmin ,&! restriction for min of soil poten. (mm) bsw (1:nl_soil),&! Clapp-Hornberger "B" @@ -121,22 +121,22 @@ SUBROUTINE UrbanHydrology ( & sm_gper ,&! snow melt (mm h2o/s) w_old ! liquid water mass of the column at the previous time step (mm) - REAL(r8), intent(inout) :: rootflux(1:nl_soil) + real(r8), intent(inout) :: rootflux(1:nl_soil) #if(defined CaMa_Flood) - real(r8), INTENT(inout) :: flddepth ! inundation water depth [mm] - real(r8), INTENT(in) :: fldfrc ! inundation water depth [0-1] - real(r8), INTENT(out) :: qinfl_fld ! grid averaged inundation water input from top (mm/s) + real(r8), intent(inout) :: flddepth ! inundation water depth [mm] + real(r8), intent(in) :: fldfrc ! inundation water depth [0-1] + real(r8), intent(out) :: qinfl_fld ! grid averaged inundation water input from top (mm/s) #endif - real(r8), intent(in) :: forc_us - real(r8), intent(in) :: forc_vs + real(r8), intent(in) :: forc_us + real(r8), intent(in) :: forc_vs ! SNICAR model variables ! Aerosol Fluxes (Jan. 07, 2023) - real(r8), intent(in) :: forc_aer (14) ! aerosol deposition from atmosphere model (grd,aer) [kg m-1 s-1] + real(r8), intent(in) :: forc_aer (14) ! aerosol deposition from atmosphere model (grd,aer) [kg m-1 s-1] - real(r8), INTENT(inout) :: & + real(r8), intent(inout) :: & mss_bcpho (lbp:0) ,&! mass of hydrophobic BC in snow (col,lyr) [kg] mss_bcphi (lbp:0) ,&! mass of hydrophillic BC in snow (col,lyr) [kg] mss_ocpho (lbp:0) ,&! mass of hydrophobic OC in snow (col,lyr) [kg] @@ -148,10 +148,10 @@ SUBROUTINE UrbanHydrology ( & ! Aerosol Fluxes (Jan. 07, 2023) ! END SNICAR model variables - INTEGER, intent(in) :: & + integer, intent(in) :: & imelt_lake(maxsnl+1:nl_soil) ! lake flag for melting or freezing snow and soil layer [-] - REAL(r8), intent(inout) :: & + real(r8), intent(inout) :: & lake_icefrac( 1:nl_lake) ,&! lake ice fraction fioldl (maxsnl+1:nl_soil) ,&! fraction of ice relative to the total water content [-] dz_lake ( 1:nl_lake) ,&! lake layer depth [m] @@ -184,20 +184,20 @@ SUBROUTINE UrbanHydrology ( & zwt ,&! the depth from ground (soil) surface to water table [m] wa ! water storage in aquifer [mm] - REAL(r8), intent(out) :: & + real(r8), intent(out) :: & rsur ,&! surface runoff (mm h2o/s) rnof ,&! total runoff (mm h2o/s) qinfl ,&! infiltration rate (mm h2o/s) qcharge ! groundwater recharge (positive to aquifer) [mm/s] - REAL(r8), intent(out) :: & + real(r8), intent(out) :: & smp(1:nl_soil) ,&! soil matrix potential [mm] hk (1:nl_soil) ,&! hydraulic conductivity [mm h2o/m] errw_rsub ! the possible subsurface runoff deficit after PHS is included ! !-----------------------Local Variables------------------------------ ! - REAL(r8) :: & + real(r8) :: & fg ,&! ground fractional cover [-] gwat ,&! net water input from top (mm/s) rnof_roof ,&! total runoff (mm h2o/s) @@ -211,7 +211,7 @@ SUBROUTINE UrbanHydrology ( & dfseng ,&! change of lake sensible heat [W/m2] dfgrnd ! change of lake ground heat flux [W/m2] - REAL(r8) :: a, aa, xs1 + real(r8) :: a, aa, xs1 fg = 1 - froof dfseng = 0. @@ -366,7 +366,7 @@ SUBROUTINE UrbanHydrology ( & rnof = rnof_roof*froof + rnof_gimp*fg*(1-fgper) + rnof_gper*fg*fgper !rnof = rnof*(1.-flake) + rnof_lake*flake - END SUBROUTINE UrbanHydrology + END SUBROUTINE UrbanHydrology END MODULE MOD_Urban_Hydrology ! ---------- EOP ------------ diff --git a/main/URBAN/MOD_Urban_ImperviousTemperature.F90 b/main/URBAN/MOD_Urban_ImperviousTemperature.F90 index fb09b295..0375a18b 100644 --- a/main/URBAN/MOD_Urban_ImperviousTemperature.F90 +++ b/main/URBAN/MOD_Urban_ImperviousTemperature.F90 @@ -2,22 +2,22 @@ MODULE MOD_Urban_ImperviousTemperature - USE MOD_Precision - IMPLICIT NONE - SAVE + USE MOD_Precision + IMPLICIT NONE + SAVE - PUBLIC :: UrbanImperviousTem + PUBLIC :: UrbanImperviousTem CONTAINS - SUBROUTINE UrbanImperviousTem (patchtype,lb,deltim, & - capr,cnfac,csol,k_solids,porsl,psi0,dkdry,dksatu,dksatf,& - vf_quartz,vf_gravels,vf_om,vf_sand,wf_gravels,wf_sand,& - BA_alpha, BA_beta,& - cv_gimp,tk_gimp,dz_gimpsno,z_gimpsno,zi_gimpsno,& - t_gimpsno,wice_gimpsno,wliq_gimpsno,scv_gimp,snowdp_gimp,& - lgimp,clgimp,sabgimp,fsengimp,fevpgimp,cgimp,htvp,& - imelt,sm,xmf,fact) + SUBROUTINE UrbanImperviousTem (patchtype,lb,deltim, & + capr,cnfac,csol,k_solids,porsl,psi0,dkdry,dksatu,dksatf,& + vf_quartz,vf_gravels,vf_om,vf_sand,wf_gravels,wf_sand,& + BA_alpha, BA_beta,& + cv_gimp,tk_gimp,dz_gimpsno,z_gimpsno,zi_gimpsno,& + t_gimpsno,wice_gimpsno,wliq_gimpsno,scv_gimp,snowdp_gimp,& + lgimp,clgimp,sabgimp,fsengimp,fevpgimp,cgimp,htvp,& + imelt,sm,xmf,fact) !======================================================================= ! Snow and impervious road temperatures @@ -41,94 +41,94 @@ SUBROUTINE UrbanImperviousTem (patchtype,lb,deltim, & ! Original author : Yongjiu Dai, 09/15/1999; 08/30/2002; 05/2020 !======================================================================= - USE MOD_Precision - USE MOD_Vars_Global - USE MOD_Const_Physical - USE MOD_SoilThermalParameters - USE MOD_PhaseChange, only: meltf_urban - USE MOD_Utils, only: tridia - - IMPLICIT NONE - - integer, intent(in) :: lb !lower bound of array - integer, intent(in) :: patchtype !land patch type (0=soil,1=urban or built-up,2=wetland, - !3=land ice, 4=deep lake, 5=shallow lake) - real(r8), intent(in) :: deltim !seconds in a time step [second] - real(r8), intent(in) :: capr !tuning factor to turn first layer T into surface T - real(r8), intent(in) :: cnfac !Crank Nicholson factor between 0 and 1 - - real(r8), intent(in) :: csol (1:nl_soil) !heat capacity of soil solids [J/(m3 K)] - real(r8), intent(in) :: k_solids (1:nl_soil) !thermal conductivity of minerals soil [W/m-K] - real(r8), intent(in) :: porsl (1:nl_soil) !soil porosity [-] - real(r8), intent(in) :: psi0 (1:nl_soil) !soil water suction, negative potential [mm] - - real(r8), intent(in) :: dkdry (1:nl_soil) !thermal conductivity of dry soil [W/m-K] - real(r8), intent(in) :: dksatu (1:nl_soil) !thermal conductivity of saturated soil [W/m-K] - real(r8), intent(in) :: dksatf (1:nl_soil) !thermal conductivity of saturated frozen soil [W/m-K] - - real(r8), intent(in) :: vf_quartz (1:nl_soil) !volumetric fraction of quartz within mineral soil - real(r8), intent(in) :: vf_gravels(1:nl_soil) !volumetric fraction of gravels - real(r8), intent(in) :: vf_om (1:nl_soil) !volumetric fraction of organic matter - real(r8), intent(in) :: vf_sand (1:nl_soil) !volumetric fraction of sand - real(r8), intent(in) :: wf_gravels(1:nl_soil) !gravimetric fraction of gravels - real(r8), intent(in) :: wf_sand (1:nl_soil) !gravimetric fraction of sand - - real(r8), intent(in) :: BA_alpha (1:nl_soil) !alpha in Balland and Arp(2005) thermal conductivity scheme - real(r8), intent(in) :: BA_beta (1:nl_soil) !beta in Balland and Arp(2005) thermal conductivity scheme - - real(r8), intent(in) :: cv_gimp (1:nl_soil) !heat capacity of urban impervious [J/m3/K] - real(r8), intent(in) :: tk_gimp (1:nl_soil) !thermal conductivity of urban impervious [W/m/K] - - real(r8), intent(in) :: dz_gimpsno(lb :nl_soil) !layer thickiness [m] - real(r8), intent(in) :: z_gimpsno (lb :nl_soil) !node depth [m] - real(r8), intent(in) :: zi_gimpsno(lb-1:nl_soil) !interface depth [m] - - real(r8), intent(in) :: sabgimp !solar radiation absorbed by ground [W/m2] - real(r8), intent(in) :: lgimp !atmospheric infrared (longwave) radiation [W/m2] - real(r8), intent(in) :: clgimp !deriv. of longwave wrt to soil temp [w/m2/k] - real(r8), intent(in) :: fsengimp !sensible heat flux from ground [W/m2] - real(r8), intent(in) :: fevpgimp !evaporation heat flux from ground [mm/s] - real(r8), intent(in) :: cgimp !deriv. of soil energy flux wrt to soil temp [w/m2/k] - real(r8), intent(in) :: htvp !latent heat of vapor of water (or sublimation) [j/kg] - - real(r8), intent(inout) :: t_gimpsno (lb:nl_soil) !soil temperature [K] - real(r8), intent(inout) :: wice_gimpsno(lb:nl_soil) !ice lens [kg/m2] - real(r8), intent(inout) :: wliq_gimpsno(lb:nl_soil) !liqui water [kg/m2] - real(r8), intent(inout) :: scv_gimp !snow cover, water equivalent [mm, kg/m2] - real(r8), intent(inout) :: snowdp_gimp !snow depth [m] - - real(r8), intent(out) :: sm !rate of snowmelt [kg/(m2 s)] - real(r8), intent(out) :: xmf !total latent heat of phase change of ground water - real(r8), intent(out) :: fact (lb:nl_soil) !used in computing tridiagonal matrix - integer, intent(out) :: imelt(lb:nl_soil) !flag for melting or freezing [-] + USE MOD_Precision + USE MOD_Vars_Global + USE MOD_Const_Physical + USE MOD_SoilThermalParameters + USE MOD_PhaseChange, only: meltf_urban + USE MOD_Utils, only: tridia + + IMPLICIT NONE + + integer, intent(in) :: lb !lower bound of array + integer, intent(in) :: patchtype !land patch type (0=soil,1=urban or built-up,2=wetland, + !3=land ice, 4=deep lake, 5=shallow lake) + real(r8), intent(in) :: deltim !seconds in a time step [second] + real(r8), intent(in) :: capr !tuning factor to turn first layer T into surface T + real(r8), intent(in) :: cnfac !Crank Nicholson factor between 0 and 1 + + real(r8), intent(in) :: csol (1:nl_soil) !heat capacity of soil solids [J/(m3 K)] + real(r8), intent(in) :: k_solids (1:nl_soil) !thermal conductivity of minerals soil [W/m-K] + real(r8), intent(in) :: porsl (1:nl_soil) !soil porosity [-] + real(r8), intent(in) :: psi0 (1:nl_soil) !soil water suction, negative potential [mm] + + real(r8), intent(in) :: dkdry (1:nl_soil) !thermal conductivity of dry soil [W/m-K] + real(r8), intent(in) :: dksatu (1:nl_soil) !thermal conductivity of saturated soil [W/m-K] + real(r8), intent(in) :: dksatf (1:nl_soil) !thermal conductivity of saturated frozen soil [W/m-K] + + real(r8), intent(in) :: vf_quartz (1:nl_soil) !volumetric fraction of quartz within mineral soil + real(r8), intent(in) :: vf_gravels(1:nl_soil) !volumetric fraction of gravels + real(r8), intent(in) :: vf_om (1:nl_soil) !volumetric fraction of organic matter + real(r8), intent(in) :: vf_sand (1:nl_soil) !volumetric fraction of sand + real(r8), intent(in) :: wf_gravels(1:nl_soil) !gravimetric fraction of gravels + real(r8), intent(in) :: wf_sand (1:nl_soil) !gravimetric fraction of sand + + real(r8), intent(in) :: BA_alpha (1:nl_soil) !alpha in Balland and Arp(2005) thermal conductivity scheme + real(r8), intent(in) :: BA_beta (1:nl_soil) !beta in Balland and Arp(2005) thermal conductivity scheme + + real(r8), intent(in) :: cv_gimp (1:nl_soil) !heat capacity of urban impervious [J/m3/K] + real(r8), intent(in) :: tk_gimp (1:nl_soil) !thermal conductivity of urban impervious [W/m/K] + + real(r8), intent(in) :: dz_gimpsno(lb :nl_soil) !layer thickiness [m] + real(r8), intent(in) :: z_gimpsno (lb :nl_soil) !node depth [m] + real(r8), intent(in) :: zi_gimpsno(lb-1:nl_soil) !interface depth [m] + + real(r8), intent(in) :: sabgimp !solar radiation absorbed by ground [W/m2] + real(r8), intent(in) :: lgimp !atmospheric infrared (longwave) radiation [W/m2] + real(r8), intent(in) :: clgimp !deriv. of longwave wrt to soil temp [w/m2/k] + real(r8), intent(in) :: fsengimp !sensible heat flux from ground [W/m2] + real(r8), intent(in) :: fevpgimp !evaporation heat flux from ground [mm/s] + real(r8), intent(in) :: cgimp !deriv. of soil energy flux wrt to soil temp [w/m2/k] + real(r8), intent(in) :: htvp !latent heat of vapor of water (or sublimation) [j/kg] + + real(r8), intent(inout) :: t_gimpsno (lb:nl_soil) !soil temperature [K] + real(r8), intent(inout) :: wice_gimpsno(lb:nl_soil) !ice lens [kg/m2] + real(r8), intent(inout) :: wliq_gimpsno(lb:nl_soil) !liqui water [kg/m2] + real(r8), intent(inout) :: scv_gimp !snow cover, water equivalent [mm, kg/m2] + real(r8), intent(inout) :: snowdp_gimp !snow depth [m] + + real(r8), intent(out) :: sm !rate of snowmelt [kg/(m2 s)] + real(r8), intent(out) :: xmf !total latent heat of phase change of ground water + real(r8), intent(out) :: fact (lb:nl_soil) !used in computing tridiagonal matrix + integer, intent(out) :: imelt(lb:nl_soil) !flag for melting or freezing [-] !------------------------ local variables ------------------------------ - real(r8) cv (lb:nl_soil) !heat capacity [J/(m2 K)] - real(r8) tk (lb:nl_soil) !thermal conductivity [W/(m K)] + real(r8) cv (lb:nl_soil) !heat capacity [J/(m2 K)] + real(r8) tk (lb:nl_soil) !thermal conductivity [W/(m K)] - real(r8) hcap(1:nl_soil) !J/(m3 K) - real(r8) thk(lb:nl_soil) !W/(m K) - real(r8) rhosnow !partitial density of water (ice + liquid) + real(r8) hcap(1:nl_soil) !J/(m3 K) + real(r8) thk(lb:nl_soil) !W/(m K) + real(r8) rhosnow !partitial density of water (ice + liquid) - real(r8) at (lb:nl_soil) !"a" vector for tridiagonal matrix - real(r8) bt (lb:nl_soil) !"b" vector for tridiagonal matrix - real(r8) ct (lb:nl_soil) !"c" vector for tridiagonal matrix - real(r8) rt (lb:nl_soil) !"r" vector for tridiagonal solution + real(r8) at (lb:nl_soil) !"a" vector for tridiagonal matrix + real(r8) bt (lb:nl_soil) !"b" vector for tridiagonal matrix + real(r8) ct (lb:nl_soil) !"c" vector for tridiagonal matrix + real(r8) rt (lb:nl_soil) !"r" vector for tridiagonal solution - real(r8) fn (lb:nl_soil) !heat diffusion through the layer interface [W/m2] - real(r8) fn1(lb:nl_soil) !heat diffusion through the layer interface [W/m2] - real(r8) dzm !used in computing tridiagonal matrix - real(r8) dzp !used in computing tridiagonal matrix + real(r8) fn (lb:nl_soil) !heat diffusion through the layer interface [W/m2] + real(r8) fn1(lb:nl_soil) !heat diffusion through the layer interface [W/m2] + real(r8) dzm !used in computing tridiagonal matrix + real(r8) dzp !used in computing tridiagonal matrix - real(r8) t_gimpsno_bef(lb:nl_soil) !soil/snow temperature before update - real(r8) hs !net energy flux into the surface (w/m2) - real(r8) dhsdt !d(hs)/dT - real(r8) brr(lb:nl_soil) !temporay set + real(r8) t_gimpsno_bef(lb:nl_soil) !soil/snow temperature before update + real(r8) hs !net energy flux into the surface (w/m2) + real(r8) dhsdt !d(hs)/dT + real(r8) brr(lb:nl_soil) !temporay set - real(r8) vf_water(1:nl_soil) !volumetric fraction liquid water within soil - real(r8) vf_ice (1:nl_soil) !volumetric fraction ice len within soil + real(r8) vf_water(1:nl_soil) !volumetric fraction liquid water within soil + real(r8) vf_ice (1:nl_soil) !volumetric fraction ice len within soil - integer i,j + integer i,j wice_gimpsno(2:) = 0.0 !ice lens [kg/m2] wliq_gimpsno(2:) = 0.0 !liquid water [kg/m2] @@ -274,7 +274,7 @@ SUBROUTINE UrbanImperviousTem (patchtype,lb,deltim, & t_gimpsno_bef(lb:1),t_gimpsno(lb:1),wliq_gimpsno(lb:1),wice_gimpsno(lb:1),imelt(lb:1), & scv_gimp,snowdp_gimp,sm,xmf) - END SUBROUTINE UrbanImperviousTem + END SUBROUTINE UrbanImperviousTem END MODULE MOD_Urban_ImperviousTemperature ! ---------- EOP ------------ diff --git a/main/URBAN/MOD_Urban_LAIReadin.F90 b/main/URBAN/MOD_Urban_LAIReadin.F90 index a2bb2e88..eac44d1b 100644 --- a/main/URBAN/MOD_Urban_LAIReadin.F90 +++ b/main/URBAN/MOD_Urban_LAIReadin.F90 @@ -3,43 +3,43 @@ #ifdef URBAN_MODEL MODULE MOD_Urban_LAIReadin - USE MOD_Precision - IMPLICIT NONE - SAVE + USE MOD_Precision + IMPLICIT NONE + SAVE - PUBLIC :: UrbanLAI_readin + PUBLIC :: UrbanLAI_readin CONTAINS - SUBROUTINE UrbanLAI_readin (year, time, dir_landdata) + SUBROUTINE UrbanLAI_readin (year, time, dir_landdata) ! =========================================================== ! Read in urban LAI, SAI and urban tree cover data ! =========================================================== - USE MOD_Precision - USE MOD_Namelist - USE MOD_SPMD_Task - USE MOD_LandUrban - USE MOD_Vars_Global - USE MOD_Const_LC - USE MOD_Vars_TimeVariables - USE MOD_Vars_TimeInvariants - USE MOD_Urban_Vars_TimeInvariants - USE MOD_NetCDFVector + USE MOD_Precision + USE MOD_Namelist + USE MOD_SPMD_Task + USE MOD_LandUrban + USE MOD_Vars_Global + USE MOD_Const_LC + USE MOD_Vars_TimeVariables + USE MOD_Vars_TimeInvariants + USE MOD_Urban_Vars_TimeInvariants + USE MOD_NetCDFVector #ifdef SinglePoint - USE MOD_SingleSrfdata + USE MOD_SingleSrfdata #endif - IMPLICIT NONE + IMPLICIT NONE - INTEGER, intent(in) :: year - INTEGER, intent(in) :: time - CHARACTER(LEN=256), intent(in) :: dir_landdata + integer, intent(in) :: year + integer, intent(in) :: time + character(LEN=256), intent(in) :: dir_landdata - CHARACTER(LEN=256) :: lndname - CHARACTER(len=256) :: cyear, ctime - INTEGER :: u, npatch, iyear + character(LEN=256) :: lndname + character(len=256) :: cyear, ctime + integer :: u, npatch, iyear ! READ in Leaf area index and stem area index write(ctime,'(i2.2)') time @@ -51,10 +51,10 @@ SUBROUTINE UrbanLAI_readin (year, time, dir_landdata) urb_sai(:) = SITE_SAI_monthly(time,iyear) #else lndname = trim(dir_landdata)//'/urban/'//trim(cyear)//'/LAI/urban_LAI_'//trim(ctime)//'.nc' - call ncio_read_vector (lndname, 'TREE_LAI', landurban, urb_lai) + CALL ncio_read_vector (lndname, 'TREE_LAI', landurban, urb_lai) lndname = trim(dir_landdata)//'/urban/'//trim(cyear)//'/LAI/urban_SAI_'//trim(ctime)//'.nc' - call ncio_read_vector (lndname, 'TREE_SAI', landurban, urb_sai) + CALL ncio_read_vector (lndname, 'TREE_SAI', landurban, urb_sai) #endif ! loop for urban atch to assign fraction of green leaf IF (p_is_worker) THEN @@ -67,7 +67,7 @@ SUBROUTINE UrbanLAI_readin (year, time, dir_landdata) ENDDO ENDIF - END SUBROUTINE UrbanLAI_readin + END SUBROUTINE UrbanLAI_readin END MODULE MOD_Urban_LAIReadin #endif diff --git a/main/URBAN/MOD_Urban_LUCY.F90 b/main/URBAN/MOD_Urban_LUCY.F90 index e999a489..a74b56e3 100644 --- a/main/URBAN/MOD_Urban_LUCY.F90 +++ b/main/URBAN/MOD_Urban_LUCY.F90 @@ -1,54 +1,54 @@ #include MODULE MOD_Urban_LUCY - ! ----------------------------------------------------------------------- - ! !DESCRIPTION: - ! Anthropogenic model to calculate anthropogenic heat flux for the rest - ! - ! ORIGINAL: - ! Wenzong Dong, May, 2022 - ! - ! ----------------------------------------------------------------------- - ! !USE - USE MOD_Precision - USE MOD_TimeManager - USE MOD_Namelist - USE MOD_Vars_Global - USE MOD_Const_Physical - USE MOD_TimeManager - IMPLICIT NONE - SAVE - PUBLIC :: LUCY +! ----------------------------------------------------------------------- +! !DESCRIPTION: +! Anthropogenic model to calculate anthropogenic heat flux for the rest +! +! ORIGINAL: +! Wenzong Dong, May, 2022 +! +! ----------------------------------------------------------------------- +! !USE + USE MOD_Precision + USE MOD_TimeManager + USE MOD_Namelist + USE MOD_Vars_Global + USE MOD_Const_Physical + USE MOD_TimeManager + IMPLICIT NONE + SAVE + PUBLIC :: LUCY CONTAINS - ! ----------------------------------------------------------------------- - SUBROUTINE LUCY( idate , deltim , patchlonr, fix_holiday, & - week_holiday, hum_prof, wdh_prof , weh_prof , pop_den, & - vehicle , Fahe , vehc , meta ) - - ! !DESCRIPTION: - ! Anthropogenic heat fluxes other than building heat were calculated - ! - ! REFERENCES: - ! 1) Grimmond, C. S. B. (1992). The suburban energy balance: Methodological considerations and results - ! for a mid-latitude west coast city under winter and spring conditions. International Journal of Climatology, - ! 12(5), 481–497. https://doi.org/10.1002/joc.3370120506 - ! 2) Allen, L., Lindberg, F., & Grimmond, C. S. B. (2011). Global to city scale urban anthropogenic - ! heat flux: Model and variability. International Journal of Climatology, 31(13), - ! 1990–2005. https://doi.org/10.1002/joc.2210 - ! - ! ----------------------------------------------------------------------- + ! ----------------------------------------------------------------------- + SUBROUTINE LUCY( idate , deltim , patchlonr, fix_holiday, & + week_holiday, hum_prof, wdh_prof , weh_prof , pop_den, & + vehicle , Fahe , vehc , meta ) + + ! !DESCRIPTION: + ! Anthropogenic heat fluxes other than building heat were calculated + ! + ! REFERENCES: + ! 1) Grimmond, C. S. B. (1992). The suburban energy balance: Methodological considerations and results + ! for a mid-latitude west coast city under winter and spring conditions. International Journal of Climatology, + ! 12(5), 481–497. https://doi.org/10.1002/joc.3370120506 + ! 2) Allen, L., Lindberg, F., & Grimmond, C. S. B. (2011). Global to city scale urban anthropogenic + ! heat flux: Model and variability. International Journal of Climatology, 31(13), + ! 1990–2005. https://doi.org/10.1002/joc.2210 + ! + ! ----------------------------------------------------------------------- IMPLICIT NONE - INTEGER , intent(in) :: & + integer , intent(in) :: & idate(3) ! calendar (year, julian day, seconds) - REAL(r8), intent(in) :: & + real(r8), intent(in) :: & fix_holiday(365), &! Fixed public holidays, holiday(0) or workday(1) week_holiday(7) ! week holidays - REAL(r8), intent(in) :: & + real(r8), intent(in) :: & deltim , &! seconds in a time step [second] patchlonr , &! longitude of patch [radian] hum_prof(24), &! Diurnal metabolic heat profile [W/person] @@ -57,18 +57,18 @@ SUBROUTINE LUCY( idate , deltim , patchlonr, fix_holiday, & pop_den , &! population density [person per square kilometer] vehicle(3) ! vehicle numbers per thousand people - REAL(r8) :: & + real(r8) :: & vehc_prof(24,2), & carscell, &! cars numbers per thousand people frescell, &! freights numbers per thousand people mbkscell ! motobikes numbers per thousand people - REAL(r8), intent(out) :: & + real(r8), intent(out) :: & Fahe, &! flux from metabolic and vehicle vehc, &! flux from vehicle meta ! flux from metabolic - REAL(r8) :: & + real(r8) :: & londeg , &! longitude of path [degree] car_sp , &! distance traveled [km] traf_frac, &! vehicle heat profile of hour [-] @@ -79,8 +79,8 @@ SUBROUTINE LUCY( idate , deltim , patchlonr, fix_holiday, & ! local vars - REAL(r8):: ldate(3) ! local time (year, julian day, seconds) - INTEGER :: & + real(r8):: ldate(3) ! local time (year, julian day, seconds) + integer :: & iweek , &! day of week ihour , &! hour of day day , &! day of mmonth @@ -90,88 +90,87 @@ SUBROUTINE LUCY( idate , deltim , patchlonr, fix_holiday, & EF , &! emission factor of freight [J/m] EM ! emission factor of motorbike [J/m] - ! initializition - meta = 0. - vehc = 0. - Fahe = 0. - - ! set vehicle distance traveled - car_sp = 50 - - ! emission factor Sailor and Lu (2004), - ! all vehicle are set to same value - EC = 3975 - EM = 3975 - EF = 3975 - - IF (DEF_simulation_time%greenwich) THEN - ! convert GMT time to local time - londeg = patchlonr*180/PI - CALL gmt2local(idate, londeg, ldate) - ENDIF - - vehc_prof(:,1) = wdh_prof - vehc_prof(:,2) = weh_prof - - CALL julian2monthday(int(ldate(1)), int(ldate(2)), month, day) - CALL timeweek(int(ldate(1)), month, day, iweek) - - ihour = CEILING(ldate(3)*1./3600) - - IF (day==366) day=365 - IF (fix_holiday(day)==0 .or. week_holiday(iweek)==0) THEN - day_inx = 1 - ELSE - day_inx = 2 - ENDIF - - ! set traffic flow to be used of this time step - traf_frac = vehc_prof(ihour,day_inx) - ! set heat release per people of this time step - meta_prof = hum_prof (ihour) - - carscell = vehicle(1) - mbkscell = vehicle(2) - frescell = vehicle(3) - - ! heat release of metabolism [W/m2] - meta = pop_den*meta_prof/1e6 - ! heat release of cars [W/m2] - IF (carscell > 0) THEN - carflx = carscell*pop_den/1000 - carflx = carflx*traf_frac & - *EC*(car_sp*1000)/1e6 - carflx = carflx/3600 - ELSE - carflx = 0. - ENDIF - - ! heat release of motorbikes [W/m2] - IF (mbkscell > 0) THEN - motflx = mbkscell*pop_den/1000 - motflx = motflx*traf_frac & - *EM*(car_sp*1000)/1e6 - motflx = motflx/3600 - ELSE - motflx = 0. - ENDIF - - ! heat release of freight [W/m2] - IF (frescell > 0)THEN - freflx = frescell*pop_den/1000 - freflx = freflx*traf_frac & - *EF*(car_sp*1000)/1e6 - freflx = freflx/3600 - ELSE - freflx = 0. - ENDIF - - ! total vehicle heat flux - vehc = carflx + motflx + freflx - ! total anthropogenic heat flux exclude building part - Fahe = meta + vehc - - END Subroutine LUCY - - !TODO-done: write the below to timemanager.F90 @Wenzong + ! initializition + meta = 0. + vehc = 0. + Fahe = 0. + + ! set vehicle distance traveled + car_sp = 50 + + ! emission factor Sailor and Lu (2004), + ! all vehicle are set to same value + EC = 3975 + EM = 3975 + EF = 3975 + + IF (DEF_simulation_time%greenwich) THEN + ! convert GMT time to local time + londeg = patchlonr*180/PI + CALL gmt2local(idate, londeg, ldate) + ENDIF + + vehc_prof(:,1) = wdh_prof + vehc_prof(:,2) = weh_prof + + CALL julian2monthday(int(ldate(1)), int(ldate(2)), month, day) + CALL timeweek(int(ldate(1)), month, day, iweek) + + ihour = CEILING(ldate(3)*1./3600) + + IF (day==366) day=365 + IF (fix_holiday(day)==0 .or. week_holiday(iweek)==0) THEN + day_inx = 1 + ELSE + day_inx = 2 + ENDIF + + ! set traffic flow to be used of this time step + traf_frac = vehc_prof(ihour,day_inx) + ! set heat release per people of this time step + meta_prof = hum_prof (ihour) + + carscell = vehicle(1) + mbkscell = vehicle(2) + frescell = vehicle(3) + + ! heat release of metabolism [W/m2] + meta = pop_den*meta_prof/1e6 + ! heat release of cars [W/m2] + IF (carscell > 0) THEN + carflx = carscell*pop_den/1000 + carflx = carflx*traf_frac & + *EC*(car_sp*1000)/1e6 + carflx = carflx/3600 + ELSE + carflx = 0. + ENDIF + + ! heat release of motorbikes [W/m2] + IF (mbkscell > 0) THEN + motflx = mbkscell*pop_den/1000 + motflx = motflx*traf_frac & + *EM*(car_sp*1000)/1e6 + motflx = motflx/3600 + ELSE + motflx = 0. + ENDIF + + ! heat release of freight [W/m2] + IF (frescell > 0)THEN + freflx = frescell*pop_den/1000 + freflx = freflx*traf_frac & + *EF*(car_sp*1000)/1e6 + freflx = freflx/3600 + ELSE + freflx = 0. + ENDIF + + ! total vehicle heat flux + vehc = carflx + motflx + freflx + ! total anthropogenic heat flux exclude building part + Fahe = meta + vehc + + END Subroutine LUCY + END MODULE MOD_Urban_LUCY diff --git a/main/URBAN/MOD_Urban_Longwave.F90 b/main/URBAN/MOD_Urban_Longwave.F90 index 12459999..c32eaa8b 100644 --- a/main/URBAN/MOD_Urban_Longwave.F90 +++ b/main/URBAN/MOD_Urban_Longwave.F90 @@ -2,32 +2,32 @@ MODULE MOD_Urban_Longwave - USE MOD_Precision - USE MOD_Vars_Global - USE MOD_Const_Physical, only: stefnc - USE MOD_Urban_Shortwave, only: MatrixInverse - USE MOD_Urban_Shortwave, only: ShadowWall_dir - USE MOD_Urban_Shortwave, only: ShadowWall_dif - USE MOD_Urban_Shortwave, only: ShadowTree - USE MOD_3DCanopyRadiation, only: tee, phi - - IMPLICIT NONE - SAVE - PRIVATE - - PUBLIC :: UrbanOnlyLongwave !Urban Longwave radiation transfer - PUBLIC :: UrbanVegLongwave !Urban Longwave radiation transfer with trees + USE MOD_Precision + USE MOD_Vars_Global + USE MOD_Const_Physical, only: stefnc + USE MOD_Urban_Shortwave, only: MatrixInverse + USE MOD_Urban_Shortwave, only: ShadowWall_dir + USE MOD_Urban_Shortwave, only: ShadowWall_dif + USE MOD_Urban_Shortwave, only: ShadowTree + USE MOD_3DCanopyRadiation, only: tee, phi + + IMPLICIT NONE + SAVE + PRIVATE + + PUBLIC :: UrbanOnlyLongwave !Urban Longwave radiation transfer + PUBLIC :: UrbanVegLongwave !Urban Longwave radiation transfer with trees CONTAINS - !------------------------------------------------- - SUBROUTINE UrbanOnlyLongwave (theta, HW, fb, fgper, H, LW, & - twsun, twsha, tgimp, tgper, ewall, egimp, egper, & - Ainv, B, B1, dBdT, SkyVF, fcover) + !------------------------------------------------- + SUBROUTINE UrbanOnlyLongwave (theta, HW, fb, fgper, H, LW, & + twsun, twsha, tgimp, tgper, ewall, egimp, egper, & + Ainv, B, B1, dBdT, SkyVF, fcover) - IMPLICIT NONE + IMPLICIT NONE - REAL(r8), intent(in) :: & + real(r8), intent(in) :: & theta, &! Sun zenith angle [radian] HW, &! Ratio of building height to ground width [-] fb, &! Fraction of building area [-] @@ -44,7 +44,7 @@ SUBROUTINE UrbanOnlyLongwave (theta, HW, fb, fgper, H, LW, & egimp, &! Emissivity of ground [-] egper ! Emissivity of ground [-] - REAL(r8), intent(out) :: & + real(r8), intent(out) :: & Ainv(4,4), &! Inverse of Radiation transfer matrix B(4), &! Vectors of incident radition on each surface B1(4), &! Vectors of incident radition on each surface @@ -52,9 +52,9 @@ SUBROUTINE UrbanOnlyLongwave (theta, HW, fb, fgper, H, LW, & SkyVF(4), &! Viewall factor to sky fcover(0:4) ! View factor to sky - ! Local variables - !------------------------------------------------- - REAL(r8) :: & + ! Local variables + !------------------------------------------------- + real(r8) :: & W, &! Urban ground average width [m] L, &! Urban building average length [m] HL, &! Ratio of H to L, H/L [-] @@ -78,145 +78,145 @@ SUBROUTINE UrbanOnlyLongwave (theta, HW, fb, fgper, H, LW, & Igimp, &! Incident radiation on impervious ground [W/m2] Igper ! Incident radiation on pervious ground [W/m2] - REAL(r8) :: A(4,4) !Radiation transfer matrix - - ! Temporal - REAL(r8) :: tmp, eb - - ! Claculate urban structure parameters - !------------------------------------------------- - W = H/HW - L = W*sqrt(fb)/(1-sqrt(fb)) - HL = H/L !NOTE: Same as HL = HW*(1-sqrt(fb))/sqrt(fb) - fg = 1. - fb - fgimp = 1. - fgper - - ! Calculate view factors - !------------------------------------------------- - - ! View factor from sky to wall(sunlit+shaded) and ground - Fsw = ShadowWall_dif(fb/fg, HL) - Fsg = 1 - Fsw - - ! View factor from ground to walls and sky - Fgw = Fsw - Fgs = Fsg - - ! View factor from wall to wall, sky and ground - ! Fws*4*H*L/L/L = Fws*4H/L*fb = Fsw*fg - ! Fws*4HL*fb = Fsw*fg - ! Fws = Fsw*fg/(4HL*fb) - ! Adjusted as below: - Fws = Fsw*fg/fb/(4*HL) - Fwg = Fsw*fg/fb/(4*HL) - Fww = 1 - Fws - Fwg - - ! Calculate sunlit wall fraction - !------------------------------------------------- - - ! Building shadow on the ground - Sw = ShadowWall_dir(fb/fg, HL, theta) - - ! Sunlit/shaded wall fraction - fwsun = 0.5 * (Sw*fg + fb) / (4/PI*fb*HL*tan(theta) + fb) - fwsha = 1. - fwsun - - ! Calculate radiation transfer matrix - ! AX = B - ! o A: radiation transfer matrix - ! o B: incident radiation on each surface - ! o X: radiation emit from each surface - !------------------------------------------------- - A(1,:) = (/1-Fww*fwsun*(1-ewall), -Fww*fwsun*(1-ewall), -Fgw*fwsun*(1-ewall), -Fgw*fwsun*(1-ewall)/) - A(2,:) = (/ -Fww*fwsha*(1-ewall), 1-Fww*fwsha*(1-ewall), -Fgw*fwsha*(1-ewall), -Fgw*fwsha*(1-ewall)/) - A(3,:) = (/ -Fwg*fgimp*(1-egimp), -Fwg*fgimp*(1-egimp), 1._r8, 0._r8/) - A(4,:) = (/ -Fwg*fgper*(1-egper), -Fwg*fgper*(1-egper), 0._r8, 1._r8/) - - ! Inverse of matrix A - Ainv = MatrixInverse(A) - - ! Incident LW radiation on sunlit/shaded wall and - ! impervious/pervious ground - Iwsun = LW*Fsw*fwsun - Iwsha = LW*Fsw*fwsha - Ig = LW*Fsg - Igimp = Ig*fgimp - Igper = Ig*fgper - - ! Vector of initial LW radiatioin on each surface - !NOTE: for 3D, absorption per unit area: 4*HL*fb/fg - ! for canyon: absorption per unit area: 2*HW - B(1) = Iwsun*(1.-ewall) + 4*fwsun*HL*fb/fg*stefnc*ewall*twsun**4 - B(2) = Iwsha*(1.-ewall) + 4*fwsha*HL*fb/fg*stefnc*ewall*twsha**4 - !B(1) = Iwsun*(1.-ewall) + 2*fwsun*HW*stefnc*ewall*twsun**4 - !B(2) = Iwsha*(1.-ewall) + 2*fwsha*HW*stefnc*ewall*twsha**4 - B(3) = Igimp*(1.-egimp) + fgimp*stefnc*egimp*tgimp**4 - B(4) = Igper*(1.-egper) + fgper*stefnc*egper*tgper**4 - - B1(1) = 4*fwsun*HL*fb/fg*stefnc*ewall*twsun**4 - B1(2) = 4*fwsha*HL*fb/fg*stefnc*ewall*twsha**4 - !B1(1) = 2*fwsun*HW*stefnc*ewall*twsun**4 - !B1(2) = 2*fwsha*HW*stefnc*ewall*twsha**4 - B1(3) = fgimp*stefnc*egimp*tgimp**4 - B1(4) = fgper*stefnc*egper*tgper**4 - - dBdT(1) = 16*fwsun*HL*fb/fg*stefnc*ewall*twsun**3 - dBdT(2) = 16*fwsha*HL*fb/fg*stefnc*ewall*twsha**3 - !dBdT(1) = 2*fwsun*HW*stefnc*ewall*twsun**3 - !dBdT(2) = 2*fwsha*HW*stefnc*ewall*twsha**3 - dBdT(3) = 4*fgimp*stefnc*egimp*tgimp**3 - dBdT(4) = 4*fgper*stefnc*egper*tgper**3 - - SkyVF(1:2) = Fws - SkyVF(3:4) = Fgs - - fcover(0) = fb - fcover(1) = 4*fwsun*HL*fb - fcover(2) = 4*fwsha*HL*fb - fcover(3) = fg*fgimp - fcover(4) = fg*fgper - - !NOTE: the below codes put into the THERMAL.F90 - ! Equation solve - ! X = matmul(Ainv, B) - - ! LW radiation absorption by each surface (per m^2) - !lwsun = ( ewall*X(1) - B1(1) ) / (1-ewall) !/ (4*fwsun*HL*fb/fg) - !lwsha = ( ewall*X(2) - B1(2) ) / (1-ewall) !/ (4*fwsha*HL*fb/fg) - !lgimp = ( egimp*X(3) - B1(3) ) / (1-egimp) !/ fgimp - !lgper = ( egper*X(4) - B1(4) ) / (1-egper) !/ fgper - - ! Out-going LW of urban canopy - !lout = X(1)*Fws + X(2)*Fws + X(3)*Fgs + X(4)*Fgs - !lout = sum( X * SkyVF ) - - ! Energy balance check - !eb = lwsun + lwsha + lgimp + lgper + lout - - !IF (abs(eb-LW) > 1e-6) THEN - ! print *, "Longwave - Energy Balance Check error!", eb-LW - !ENDIF - - !NOTE: put it outside, after temperature change of roof, wall and ground - ! absorption change due to temperature change, as restart variables. - !dX = matmul(Ainv, dBdT*dT) - !lwsun = ( ewall*dX(1) - dBdT(1)*dT(1) ) / (1-ewall) !/ (4*fwsun*HL*fb/fg) - !lwsha = ( ewall*dX(2) - dBdT(2)*dT(2) ) / (1-ewall) !/ (4*fwsha*HL*fb/fg) - !lgimp = ( egimp*dX(3) - dBdT(3)*dT(3) ) / (1-egimp) !/ fgimp - !lgper = ( egper*dX(4) - dBdT(4)*dT(4) ) / (1-egper) !/ fgper - - !lout = lout + sum( dX * SkyVF ) - - END SUBROUTINE UrbanOnlyLongwave - - !------------------------------------------------- - SUBROUTINE UrbanVegLongwave (theta, HW, fb, fgper, H, LW, & - twsun, twsha, tgimp, tgper, ewall, egimp, egper, lai, sai, fv, hv, & - ev, Ainv, B, B1, dBdT, SkyVF, VegVF, fcover) - - IMPLICIT NONE - - REAL(r8), intent(in) :: & + real(r8) :: A(4,4) !Radiation transfer matrix + + ! Temporal + real(r8) :: tmp, eb + + ! Claculate urban structure parameters + !------------------------------------------------- + W = H/HW + L = W*sqrt(fb)/(1-sqrt(fb)) + HL = H/L !NOTE: Same as HL = HW*(1-sqrt(fb))/sqrt(fb) + fg = 1. - fb + fgimp = 1. - fgper + + ! Calculate view factors + !------------------------------------------------- + + ! View factor from sky to wall(sunlit+shaded) and ground + Fsw = ShadowWall_dif(fb/fg, HL) + Fsg = 1 - Fsw + + ! View factor from ground to walls and sky + Fgw = Fsw + Fgs = Fsg + + ! View factor from wall to wall, sky and ground + ! Fws*4*H*L/L/L = Fws*4H/L*fb = Fsw*fg + ! Fws*4HL*fb = Fsw*fg + ! Fws = Fsw*fg/(4HL*fb) + ! Adjusted as below: + Fws = Fsw*fg/fb/(4*HL) + Fwg = Fsw*fg/fb/(4*HL) + Fww = 1 - Fws - Fwg + + ! Calculate sunlit wall fraction + !------------------------------------------------- + + ! Building shadow on the ground + Sw = ShadowWall_dir(fb/fg, HL, theta) + + ! Sunlit/shaded wall fraction + fwsun = 0.5 * (Sw*fg + fb) / (4/PI*fb*HL*tan(theta) + fb) + fwsha = 1. - fwsun + + ! Calculate radiation transfer matrix + ! AX = B + ! o A: radiation transfer matrix + ! o B: incident radiation on each surface + ! o X: radiation emit from each surface + !------------------------------------------------- + A(1,:) = (/1-Fww*fwsun*(1-ewall), -Fww*fwsun*(1-ewall), -Fgw*fwsun*(1-ewall), -Fgw*fwsun*(1-ewall)/) + A(2,:) = (/ -Fww*fwsha*(1-ewall), 1-Fww*fwsha*(1-ewall), -Fgw*fwsha*(1-ewall), -Fgw*fwsha*(1-ewall)/) + A(3,:) = (/ -Fwg*fgimp*(1-egimp), -Fwg*fgimp*(1-egimp), 1._r8, 0._r8/) + A(4,:) = (/ -Fwg*fgper*(1-egper), -Fwg*fgper*(1-egper), 0._r8, 1._r8/) + + ! Inverse of matrix A + Ainv = MatrixInverse(A) + + ! Incident LW radiation on sunlit/shaded wall and + ! impervious/pervious ground + Iwsun = LW*Fsw*fwsun + Iwsha = LW*Fsw*fwsha + Ig = LW*Fsg + Igimp = Ig*fgimp + Igper = Ig*fgper + + ! Vector of initial LW radiatioin on each surface + !NOTE: for 3D, absorption per unit area: 4*HL*fb/fg + ! for canyon: absorption per unit area: 2*HW + B(1) = Iwsun*(1.-ewall) + 4*fwsun*HL*fb/fg*stefnc*ewall*twsun**4 + B(2) = Iwsha*(1.-ewall) + 4*fwsha*HL*fb/fg*stefnc*ewall*twsha**4 + !B(1) = Iwsun*(1.-ewall) + 2*fwsun*HW*stefnc*ewall*twsun**4 + !B(2) = Iwsha*(1.-ewall) + 2*fwsha*HW*stefnc*ewall*twsha**4 + B(3) = Igimp*(1.-egimp) + fgimp*stefnc*egimp*tgimp**4 + B(4) = Igper*(1.-egper) + fgper*stefnc*egper*tgper**4 + + B1(1) = 4*fwsun*HL*fb/fg*stefnc*ewall*twsun**4 + B1(2) = 4*fwsha*HL*fb/fg*stefnc*ewall*twsha**4 + !B1(1) = 2*fwsun*HW*stefnc*ewall*twsun**4 + !B1(2) = 2*fwsha*HW*stefnc*ewall*twsha**4 + B1(3) = fgimp*stefnc*egimp*tgimp**4 + B1(4) = fgper*stefnc*egper*tgper**4 + + dBdT(1) = 16*fwsun*HL*fb/fg*stefnc*ewall*twsun**3 + dBdT(2) = 16*fwsha*HL*fb/fg*stefnc*ewall*twsha**3 + !dBdT(1) = 2*fwsun*HW*stefnc*ewall*twsun**3 + !dBdT(2) = 2*fwsha*HW*stefnc*ewall*twsha**3 + dBdT(3) = 4*fgimp*stefnc*egimp*tgimp**3 + dBdT(4) = 4*fgper*stefnc*egper*tgper**3 + + SkyVF(1:2) = Fws + SkyVF(3:4) = Fgs + + fcover(0) = fb + fcover(1) = 4*fwsun*HL*fb + fcover(2) = 4*fwsha*HL*fb + fcover(3) = fg*fgimp + fcover(4) = fg*fgper + + !NOTE: the below codes put into the THERMAL.F90 + ! Equation solve + ! X = matmul(Ainv, B) + + ! LW radiation absorption by each surface (per m^2) + !lwsun = ( ewall*X(1) - B1(1) ) / (1-ewall) !/ (4*fwsun*HL*fb/fg) + !lwsha = ( ewall*X(2) - B1(2) ) / (1-ewall) !/ (4*fwsha*HL*fb/fg) + !lgimp = ( egimp*X(3) - B1(3) ) / (1-egimp) !/ fgimp + !lgper = ( egper*X(4) - B1(4) ) / (1-egper) !/ fgper + + ! Out-going LW of urban canopy + !lout = X(1)*Fws + X(2)*Fws + X(3)*Fgs + X(4)*Fgs + !lout = sum( X * SkyVF ) + + ! Energy balance check + !eb = lwsun + lwsha + lgimp + lgper + lout + + !IF (abs(eb-LW) > 1e-6) THEN + ! print *, "Longwave - Energy Balance Check error!", eb-LW + !ENDIF + + !NOTE: put it outside, after temperature change of roof, wall and ground + ! absorption change due to temperature change, as restart variables. + !dX = matmul(Ainv, dBdT*dT) + !lwsun = ( ewall*dX(1) - dBdT(1)*dT(1) ) / (1-ewall) !/ (4*fwsun*HL*fb/fg) + !lwsha = ( ewall*dX(2) - dBdT(2)*dT(2) ) / (1-ewall) !/ (4*fwsha*HL*fb/fg) + !lgimp = ( egimp*dX(3) - dBdT(3)*dT(3) ) / (1-egimp) !/ fgimp + !lgper = ( egper*dX(4) - dBdT(4)*dT(4) ) / (1-egper) !/ fgper + + !lout = lout + sum( dX * SkyVF ) + + END SUBROUTINE UrbanOnlyLongwave + + !------------------------------------------------- + SUBROUTINE UrbanVegLongwave (theta, HW, fb, fgper, H, LW, & + twsun, twsha, tgimp, tgper, ewall, egimp, egper, lai, sai, fv, hv, & + ev, Ainv, B, B1, dBdT, SkyVF, VegVF, fcover) + + IMPLICIT NONE + + real(r8), intent(in) :: & theta, &! Sun zenith angle [radian] HW, &! Ratio of building height to ground width [-] fb, &! Fraction of building area [-] @@ -237,7 +237,7 @@ SUBROUTINE UrbanVegLongwave (theta, HW, fb, fgper, H, LW, & fv, &! Fraction of tree cover [-] hv ! Crown central height [m] - REAL(r8), intent(out) :: & + real(r8), intent(out) :: & ev, &! emissivity of vegetation Ainv(5,5), &! Inverse of Radiation transfer matrix B(5), &! Vectors of incident radition on each surface @@ -247,11 +247,11 @@ SUBROUTINE UrbanVegLongwave (theta, HW, fb, fgper, H, LW, & VegVF(5), &! View factor to sky fcover(0:5) ! View factor to sky - ! Local variables - !------------------------------------------------- - REAL(r16),parameter:: DD1=1.0_r16 !quad accuracy REAL number + ! Local variables + !------------------------------------------------- + real(r16),parameter:: DD1=1.0_r16 !quad accuracy real number - REAL(r8) :: & + real(r8) :: & W, &! Urban ground average width [m] L, &! Urban building average length [m] HL, &! Ratio of H to L, H/L [-] @@ -304,299 +304,299 @@ SUBROUTINE UrbanVegLongwave (theta, HW, fb, fgper, H, LW, & Igper, &! Incident radiation on pervious ground [W/m2] Iv ! Incident radiation on trees [W/m2] - ! Radiation transfer matrix and vectors - !------------------------------------------------- - REAL(r8) :: A(5,5) !Radiation transfer matrix + ! Radiation transfer matrix and vectors + !------------------------------------------------- + real(r8) :: A(5,5) !Radiation transfer matrix - ! Temporal - REAL(r8) :: tmp, eb, fac1, fac2, lsai + ! Temporal + real(r8) :: tmp, eb, fac1, fac2, lsai - ! Claculate urban structure parameters - !------------------------------------------------- - W = H/HW - L = W*sqrt(fb)/(1-sqrt(fb)) - HL = H/L !NOTE: Same as HL = HW*(1-sqrt(fb))/sqrt(fb) - fg = 1. - fb + ! Claculate urban structure parameters + !------------------------------------------------- + W = H/HW + L = W*sqrt(fb)/(1-sqrt(fb)) + HL = H/L !NOTE: Same as HL = HW*(1-sqrt(fb))/sqrt(fb) + fg = 1. - fb - fgimp = 1. - fgper - - ! Calculate transmittion and albedo of tree - !------------------------------------------------- - lsai = (lai+sai)*fv/cos(PI/3)/ShadowTree(fv, PI/3) - Td = tee(DD1*3/8.*lsai) - ev = 1 - Td + fgimp = 1. - fgper + + ! Calculate transmittion and albedo of tree + !------------------------------------------------- + lsai = (lai+sai)*fv/cos(PI/3)/ShadowTree(fv, PI/3) + Td = tee(DD1*3/8.*lsai) + ev = 1 - Td - ! Calculate view factors - !------------------------------------------------- - - ! View factor from sky to wall(sunlit+shaded) and ground - Fsw = ShadowWall_dif(fb/fg, HL) - Fsg = 1 - Fsw - - ! View factor from ground to walls and sky - Fgw = Fsw - Fgs = Fsg - - ! View factor from wall to wall, sky and ground - ! Fws*4*H*L*L/L = Fws*4H/L*fb = Fsw*fg - ! Fws*4HL*fb = Fsw*fg - ! Fws = Fsw*fg/(4HL*fb) - Fws = Fsw*fg/fb/(4*HL) - Fwg = Fsw*fg/fb/(4*HL) - Fww = 1 - Fws - Fwg + ! Calculate view factors + !------------------------------------------------- + + ! View factor from sky to wall(sunlit+shaded) and ground + Fsw = ShadowWall_dif(fb/fg, HL) + Fsg = 1 - Fsw + + ! View factor from ground to walls and sky + Fgw = Fsw + Fgs = Fsg + + ! View factor from wall to wall, sky and ground + ! Fws*4*H*L*L/L = Fws*4H/L*fb = Fsw*fg + ! Fws*4HL*fb = Fsw*fg + ! Fws = Fsw*fg/(4HL*fb) + Fws = Fsw*fg/fb/(4*HL) + Fwg = Fsw*fg/fb/(4*HL) + Fww = 1 - Fws - Fwg - ! View factor from tree to walls, ground and sky - !------------------------------------------------- + ! View factor from tree to walls, ground and sky + !------------------------------------------------- - Sw = ShadowWall_dif(fb/fg, HL) - Sw_ = ShadowWall_dif(fb/fg, (H-hv)/L) - - !NOTE: fg*(fv/fg - fv/fg * Sw_) - fv_ = fv - fv*Sw_ - Sv = ShadowTree(fv_, PI/3) + Sw = ShadowWall_dif(fb/fg, HL) + Sw_ = ShadowWall_dif(fb/fg, (H-hv)/L) + + !NOTE: fg*(fv/fg - fv/fg * Sw_) + fv_ = fv - fv*Sw_ + Sv = ShadowTree(fv_, PI/3) - ! Overlapped shadow between tree and building - ! (to groud only) - Swv = (Sw-Sw_) * Sv - - ! convert Sv to ground ratio - Sv = min(1., Sv/fg) + ! Overlapped shadow between tree and building + ! (to groud only) + Swv = (Sw-Sw_) * Sv + + ! convert Sv to ground ratio + Sv = min(1., Sv/fg) - ! robust check - IF (Sw+Sv-Swv > 1) THEN - Swv = Sw+Sv-1 - ENDIF + ! robust check + IF (Sw+Sv-Swv > 1) THEN + Swv = Sw+Sv-1 + ENDIF - ! Calibrated building ground shadow - Fsv = Sv - Fsvw = Swv - Fsvg = Fsv - Fsvw - - ! View factor from veg to sky and walls above canopy - Fvs = 0.5*(1-Sw_) - Fvw = 0.5*Sw_ - - Sw_ = ShadowWall_dif(fb/fg, hv/L) - fv_ = fv - fv*Sw_ - Sv = ShadowTree(fv_, PI/3) - - ! Overlapped shadow between tree and building - ! (to groud only) - Swv = (Sw-Sw_) * Sv - - ! convert Sv to ground ratio - Sv = min(1., Sv/fg) - - ! robust check - IF (Sw+Sv-Swv > 1) THEN - Swv = Sw+Sv-1 - ENDIF - - ! Calibrated building ground shadow - Fgv = Sv - Fgvw = Swv - Fgvs = Fgv - Fgvw - - ! View factor from veg to sky and walls below+above canopy - Fvg = 0.5*(1-Sw_) - Fvw = 0.5*Sw_ + Fvw - - Fvw = 1 - Fvs - Fvg - - !Fvs = Fsv*fg/min(4*fv,2*fg) - !Fvg = Fgv*fg/min(4*fv,2*fg) - !Fvw = 1 - Fvs - Fvg - - ! Canopy mode: - Fwv = max(fv,0.5*(Fsv+Fgv))*2*fg*Fvw/(4*HL*fb) - Fwv = min(0.8, Fwv) - - fac1 = 1.*hv/H - fac2 = 1.*(H-hv)/H - Fwvw = Fwv/(1 + Fws*fac1/Fww + Fwg*fac2/Fww) - Fwvs = Fws*fac1/Fww*Fwvw - Fwvg = Fwg*fac2/Fww*Fwvw - - ! set upper limit - Fwvw = min(Fww, Fwvw) - Fwvs = min(Fws, Fwvs) - Fwvg = min(Fwg, Fwvg) - - Fwv = Fwvw + Fwvs + Fwvg - - ! View factors with trees - !--------------------------------------------------------- - Fsw_ = Fsw - Fsvw + Fsvw*Td - Fsg_ = Fsg - Fsvg + Fsvg*Td - Fgw_ = Fgw - Fgvw + Fgvw*Td - Fgs_ = Fgs - Fgvs + Fgvs*Td - Fwg_ = Fwg - Fwvg + Fwvg*Td - Fww_ = Fww - Fwvw + Fwvw*Td - Fws_ = Fws - Fwvs + Fwvs*Td - - ! Calculate wall sunlit fraction - !------------------------------------------------- - - ! Builing wall shadow - Sw = ShadowWall_dir(fb/fg, HL, theta) - - Sw_ = Sw; fv_ = fv; - - Sw_ = ShadowWall_dir(fb/fg, (H-hv)/L, theta) - fv_ = fv - fv*Sw_ - - ! Tree shadow (to all area) - Sv = ShadowTree(fv_, theta) - - ! Overlapped shadow between tree and building - ! (to groud only) - Swv = (Sw-Sw_) * Sv - - ! convert Sv to ground ratio - Sv = min(1., Sv/fg) - - ! robust check - IF (Sw+Sv-Swv > 1) THEN - Swv = Sw+Sv-1 - ENDIF - - ! Calibrated building ground shadow - Sw = Sw - Swv - - ! Sunlit/shaded wall fraction - fwsun = 0.5 * (Sw*fg+fb) / (4/PI*fb*HL*tan(theta) + fb) - fwsha = 1. - fwsun - - ! Calculate radiation transfer matrix - ! AX = B - !------------------------------------------------- - A(1,:) = (/1-Fww_*fwsun*(1-ewall), -Fww_*fwsun*(1-ewall), -Fgw_*fwsun*(1-ewall), & - -Fgw_*fwsun*(1-ewall), -Fvw *fwsun*(1-ewall)/) - A(2,:) = (/ -Fww_*fwsha*(1-ewall), 1-Fww_*fwsha*(1-ewall), -Fgw_*fwsha*(1-ewall), & - -Fgw_*fwsha*(1-ewall), -Fvw *fwsha*(1-ewall)/) - A(3,:) = (/ -Fwg_*fgimp*(1-egimp), -Fwg_*fgimp*(1-egimp), 1._r8, & - 0._r8, -Fvg *fgimp*(1-egimp)/) - A(4,:) = (/ -Fwg_*fgper*(1-egper), -Fwg_*fgper*(1-egper), 0._r8, & - 1._r8, -Fvg *fgper*(1-egper)/) - A(5,:) = (/ 0._r8, 0._r8, 0._r8, & - 0._r8, 1._r8/) - - ! Inverse of matrix A - Ainv = MatrixInverse(A) - - ! Incident LW radiation on sunlit/shaded wall and - ! impervious/pervious ground - Iwsun = LW*Fsw_*fwsun - Iwsha = LW*Fsw_*fwsha - Ig = LW*Fsg_ - Igimp = Ig*fgimp - Igper = Ig*fgper - Iv = LW*Fsv - - ! Vector of initial LW radiatioin on each surface - !NOTE: for 3D, absorption per unit area: 4*HL*fb/fg - ! for canyon: absorption per unit area: 2*HW - B(1) = Iwsun*(1.-ewall) + 4*fwsun*HL*fb/fg*stefnc*ewall*twsun**4 - B(2) = Iwsha*(1.-ewall) + 4*fwsha*HL*fb/fg*stefnc*ewall*twsha**4 - B(3) = Igimp*(1.-egimp) + fgimp*stefnc*egimp*tgimp**4 - B(4) = Igper*(1.-egper) + fgper*stefnc*egper*tgper**4 - ! leaf temperature iteration in urban flux calculation - ! see MOD_Urban_Flux.F90 - ! B(5) = 4*fv/fg*stefnc*ev*tl**4 !NOTE: 4*fv/fg or 2*fv/fg - !4*fv/fg. equivalent to 2fc - B(5) = max(2*fv/fg,Fsv+Fgv)*stefnc*ev - - B1(1) = 4*fwsun*HL*fb/fg*stefnc*ewall*twsun**4 - B1(2) = 4*fwsha*HL*fb/fg*stefnc*ewall*twsha**4 - B1(3) = fgimp*stefnc*egimp*tgimp**4 - B1(4) = fgper*stefnc*egper*tgper**4 - ! leaf temperature iteration in urban flux calculation - ! B1(5) = 4*fv/fg*stefnc*ev*tl**4 - B1(5) = max(2*fv/fg,Fsv+Fgv)*stefnc*ev - - dBdT(1) = 16*fwsun*HL*fb/fg*stefnc*ewall*twsun**3 - dBdT(2) = 16*fwsha*HL*fb/fg*stefnc*ewall*twsha**3 - dBdT(3) = 4*fgimp*stefnc*egimp*tgimp**3 - dBdT(4) = 4*fgper*stefnc*egper*tgper**3 - ! leaf temperature iteration in urban flux calculation - ! dBdT(5) = 16*fv/fg*stefnc*ev*tl**3 - dBdT(5) = 4*max(2*fv/fg,Fsv+Fgv)*stefnc*ev - - SkyVF(1:2) = Fws_ - SkyVF(3:4) = Fgs_ - SkyVF(5) = Fvs - - VegVF(1:2) = Fwv - VegVF(3:4) = Fgv - VegVF(5) = Fsv - - fcover(0) = fb - fcover(1) = 4*fwsun*HL*fb - fcover(2) = 4*fwsha*HL*fb - fcover(3) = fg*fgimp - fcover(4) = fg*fgper - fcover(5) = fv - - !NOTE: the below codes are put in the leaf temperature iteration process - ! after each iteration, update the below iterms - !B(5) = 4*fv/fg*stefnc*ev*tl**4 - !B1(5) = 4*fv/fg*stefnc*ev*tl**4 - !dBdT(5) = 16*fv/fg*stefnc*ev*tl**3 - ! Equation solve - !X = matmul(Ainv, B) - - ! LW radiation absorption by each surface (per m^2) - !lwsun = ( ewall*X(1) - B1(1) ) / (1-ewall) !/ (4*fwsun*HL*fb/fg) - !lwsha = ( ewall*X(2) - B1(2) ) / (1-ewall) !/ (4*fwsha*HL*fb/fg) - !lgimp = ( egimp*X(3) - B1(3) ) / (1-egimp) !/ fgimp - !lgper = ( egper*X(4) - B1(4) ) / (1-egper) !/ fgper - - !NOTE: before leaf temperature iteration - !lv = ((X(1)*Fwv + X(2)*Fwv + X(3)*Fgv + X(4)*Fgv + LW*Fsv)*ev - B1(5))!/(fv/fg) - - ! Out-going LW of urban canopy - !SkyVF(1:2) = Fws_; SkyVF(3:4) = Fgs_; SkyVF(5) = Fvs - !lout = X(1)*Fws_ + X(2)*Fws_ + X(3)*Fgs_ + X(4)*Fgs_ + X(5)*Fvs - !lout = sum( X * SkyVF ) - - ! Energy balance check - !eb = lwsun + lwsha + lgimp + lgper + lv + lout - - !IF (abs(eb-LW) > 1e-6) THEN - ! print *, "Longwave tree - Energy Balance Check error!", eb-LW - !ENDIF - - ! Radiation difference due to the last temperature change of the leaf - ! dBdT: the first 4 iterms is 0 - !dX = matmul(Ainv, dBdT) - ! Finally solve the first 4 items, the leaf has been solved - !lwsun = lwsun + ( ewall*dX(1) ) / (1-ewall) * dtl!/ (4*fwsun*HL*fb/fg) - !lwsha = lwsha + ( ewall*dX(2) ) / (1-ewall) * dtl!/ (4*fwsha*HL*fb/fg) - !lgimp = lwimp + ( egimp*dX(3) ) / (1-egimp) * dtl!/ fgimp - !lgper = lgper + ( egper*dX(4) ) / (1-egper) * dtl!/ fgper - - ! update after each temperature iteration - !lv = lv + ((dX(1)*Fwv + dX(2)*Fwv + dX(3)*Fgv + dX(4)*Fgv)*ev - dBdT(5))*dtl!/(fv/fg) - !dlvdt = (dX(1)*Fwv + dX(2)*Fwv + dX(3)*Fgv + dX(4)*Fgv)*ev - dBdT(5) - - !SkyVF(1:2) = Fws_; SkyVF(3:4) = Fgs_; SkyVF(5) = Fvs - !lout = lout + sum( dX * SkyVF * dtl ) - - ! put it outside - ! absorption change due to temperature change, as restart variables. - ! now the leaf temperature does not change, the last iterm of dBdT is 0. - !dX = matmul(Ainv, dBdT*dT) - - !lwsun = ( ewall*dX(1) - dBdT(1)*dT(1) ) / (1-ewall) !/ (4*fwsun*HL*fb/fg) - !lwsha = ( ewall*dX(2) - dBdT(2)*dT(2) ) / (1-ewall) !/ (4*fwsha*HL*fb/fg) - !lgimp = ( egimp*dX(3) - dBdT(3)*dT(3) ) / (1-egimp) !/ fgimp - !lgper = ( esnow*dX(4) - dBdT(4)*dT(4) ) / (1-esnow) !/ fgper - !lv = ((dX(1)*Fwv + dX(2)*Fwv + dX(3)*Fgv + dX(4)*Fgv + dX(5)*Fgv)*ev)!/(fv/fg) - - !lout = X(1)*Fws_ + X(2)*Fws_ + X(3)*Fgs_ + X(4)*Fgs_ + X(5)*Fvs - !SkyVF(1:2) = Fws_; SkyVF(3:4) = Fgs_; SkyVF(5) = Fvs - !lout = lout + sum( dX * SkyVF ) - - END SUBROUTINE UrbanVegLongwave + ! Calibrated building ground shadow + Fsv = Sv + Fsvw = Swv + Fsvg = Fsv - Fsvw + + ! View factor from veg to sky and walls above canopy + Fvs = 0.5*(1-Sw_) + Fvw = 0.5*Sw_ + + Sw_ = ShadowWall_dif(fb/fg, hv/L) + fv_ = fv - fv*Sw_ + Sv = ShadowTree(fv_, PI/3) + + ! Overlapped shadow between tree and building + ! (to groud only) + Swv = (Sw-Sw_) * Sv + + ! convert Sv to ground ratio + Sv = min(1., Sv/fg) + + ! robust check + IF (Sw+Sv-Swv > 1) THEN + Swv = Sw+Sv-1 + ENDIF + + ! Calibrated building ground shadow + Fgv = Sv + Fgvw = Swv + Fgvs = Fgv - Fgvw + + ! View factor from veg to sky and walls below+above canopy + Fvg = 0.5*(1-Sw_) + Fvw = 0.5*Sw_ + Fvw + + Fvw = 1 - Fvs - Fvg + + !Fvs = Fsv*fg/min(4*fv,2*fg) + !Fvg = Fgv*fg/min(4*fv,2*fg) + !Fvw = 1 - Fvs - Fvg + + ! Canopy mode: + Fwv = max(fv,0.5*(Fsv+Fgv))*2*fg*Fvw/(4*HL*fb) + Fwv = min(0.8, Fwv) + + fac1 = 1.*hv/H + fac2 = 1.*(H-hv)/H + Fwvw = Fwv/(1 + Fws*fac1/Fww + Fwg*fac2/Fww) + Fwvs = Fws*fac1/Fww*Fwvw + Fwvg = Fwg*fac2/Fww*Fwvw + + ! set upper limit + Fwvw = min(Fww, Fwvw) + Fwvs = min(Fws, Fwvs) + Fwvg = min(Fwg, Fwvg) + + Fwv = Fwvw + Fwvs + Fwvg + + ! View factors with trees + !--------------------------------------------------------- + Fsw_ = Fsw - Fsvw + Fsvw*Td + Fsg_ = Fsg - Fsvg + Fsvg*Td + Fgw_ = Fgw - Fgvw + Fgvw*Td + Fgs_ = Fgs - Fgvs + Fgvs*Td + Fwg_ = Fwg - Fwvg + Fwvg*Td + Fww_ = Fww - Fwvw + Fwvw*Td + Fws_ = Fws - Fwvs + Fwvs*Td + + ! Calculate wall sunlit fraction + !------------------------------------------------- + + ! Builing wall shadow + Sw = ShadowWall_dir(fb/fg, HL, theta) + + Sw_ = Sw; fv_ = fv; + + Sw_ = ShadowWall_dir(fb/fg, (H-hv)/L, theta) + fv_ = fv - fv*Sw_ + + ! Tree shadow (to all area) + Sv = ShadowTree(fv_, theta) + + ! Overlapped shadow between tree and building + ! (to groud only) + Swv = (Sw-Sw_) * Sv + + ! convert Sv to ground ratio + Sv = min(1., Sv/fg) + + ! robust check + IF (Sw+Sv-Swv > 1) THEN + Swv = Sw+Sv-1 + ENDIF + + ! Calibrated building ground shadow + Sw = Sw - Swv + + ! Sunlit/shaded wall fraction + fwsun = 0.5 * (Sw*fg+fb) / (4/PI*fb*HL*tan(theta) + fb) + fwsha = 1. - fwsun + + ! Calculate radiation transfer matrix + ! AX = B + !------------------------------------------------- + A(1,:) = (/1-Fww_*fwsun*(1-ewall), -Fww_*fwsun*(1-ewall), -Fgw_*fwsun*(1-ewall), & + -Fgw_*fwsun*(1-ewall), -Fvw *fwsun*(1-ewall)/) + A(2,:) = (/ -Fww_*fwsha*(1-ewall), 1-Fww_*fwsha*(1-ewall), -Fgw_*fwsha*(1-ewall), & + -Fgw_*fwsha*(1-ewall), -Fvw *fwsha*(1-ewall)/) + A(3,:) = (/ -Fwg_*fgimp*(1-egimp), -Fwg_*fgimp*(1-egimp), 1._r8, & + 0._r8, -Fvg *fgimp*(1-egimp)/) + A(4,:) = (/ -Fwg_*fgper*(1-egper), -Fwg_*fgper*(1-egper), 0._r8, & + 1._r8, -Fvg *fgper*(1-egper)/) + A(5,:) = (/ 0._r8, 0._r8, 0._r8, & + 0._r8, 1._r8/) + + ! Inverse of matrix A + Ainv = MatrixInverse(A) + + ! Incident LW radiation on sunlit/shaded wall and + ! impervious/pervious ground + Iwsun = LW*Fsw_*fwsun + Iwsha = LW*Fsw_*fwsha + Ig = LW*Fsg_ + Igimp = Ig*fgimp + Igper = Ig*fgper + Iv = LW*Fsv + + ! Vector of initial LW radiatioin on each surface + !NOTE: for 3D, absorption per unit area: 4*HL*fb/fg + ! for canyon: absorption per unit area: 2*HW + B(1) = Iwsun*(1.-ewall) + 4*fwsun*HL*fb/fg*stefnc*ewall*twsun**4 + B(2) = Iwsha*(1.-ewall) + 4*fwsha*HL*fb/fg*stefnc*ewall*twsha**4 + B(3) = Igimp*(1.-egimp) + fgimp*stefnc*egimp*tgimp**4 + B(4) = Igper*(1.-egper) + fgper*stefnc*egper*tgper**4 + ! leaf temperature iteration in urban flux calculation + ! see MOD_Urban_Flux.F90 + ! B(5) = 4*fv/fg*stefnc*ev*tl**4 !NOTE: 4*fv/fg or 2*fv/fg + !4*fv/fg. equivalent to 2fc + B(5) = max(2*fv/fg,Fsv+Fgv)*stefnc*ev + + B1(1) = 4*fwsun*HL*fb/fg*stefnc*ewall*twsun**4 + B1(2) = 4*fwsha*HL*fb/fg*stefnc*ewall*twsha**4 + B1(3) = fgimp*stefnc*egimp*tgimp**4 + B1(4) = fgper*stefnc*egper*tgper**4 + ! leaf temperature iteration in urban flux calculation + ! B1(5) = 4*fv/fg*stefnc*ev*tl**4 + B1(5) = max(2*fv/fg,Fsv+Fgv)*stefnc*ev + + dBdT(1) = 16*fwsun*HL*fb/fg*stefnc*ewall*twsun**3 + dBdT(2) = 16*fwsha*HL*fb/fg*stefnc*ewall*twsha**3 + dBdT(3) = 4*fgimp*stefnc*egimp*tgimp**3 + dBdT(4) = 4*fgper*stefnc*egper*tgper**3 + ! leaf temperature iteration in urban flux calculation + ! dBdT(5) = 16*fv/fg*stefnc*ev*tl**3 + dBdT(5) = 4*max(2*fv/fg,Fsv+Fgv)*stefnc*ev + + SkyVF(1:2) = Fws_ + SkyVF(3:4) = Fgs_ + SkyVF(5) = Fvs + + VegVF(1:2) = Fwv + VegVF(3:4) = Fgv + VegVF(5) = Fsv + + fcover(0) = fb + fcover(1) = 4*fwsun*HL*fb + fcover(2) = 4*fwsha*HL*fb + fcover(3) = fg*fgimp + fcover(4) = fg*fgper + fcover(5) = fv + + !NOTE: the below codes are put in the leaf temperature iteration process + ! after each iteration, update the below iterms + !B(5) = 4*fv/fg*stefnc*ev*tl**4 + !B1(5) = 4*fv/fg*stefnc*ev*tl**4 + !dBdT(5) = 16*fv/fg*stefnc*ev*tl**3 + ! Equation solve + !X = matmul(Ainv, B) + + ! LW radiation absorption by each surface (per m^2) + !lwsun = ( ewall*X(1) - B1(1) ) / (1-ewall) !/ (4*fwsun*HL*fb/fg) + !lwsha = ( ewall*X(2) - B1(2) ) / (1-ewall) !/ (4*fwsha*HL*fb/fg) + !lgimp = ( egimp*X(3) - B1(3) ) / (1-egimp) !/ fgimp + !lgper = ( egper*X(4) - B1(4) ) / (1-egper) !/ fgper + + !NOTE: before leaf temperature iteration + !lv = ((X(1)*Fwv + X(2)*Fwv + X(3)*Fgv + X(4)*Fgv + LW*Fsv)*ev - B1(5))!/(fv/fg) + + ! Out-going LW of urban canopy + !SkyVF(1:2) = Fws_; SkyVF(3:4) = Fgs_; SkyVF(5) = Fvs + !lout = X(1)*Fws_ + X(2)*Fws_ + X(3)*Fgs_ + X(4)*Fgs_ + X(5)*Fvs + !lout = sum( X * SkyVF ) + + ! Energy balance check + !eb = lwsun + lwsha + lgimp + lgper + lv + lout + + !IF (abs(eb-LW) > 1e-6) THEN + ! print *, "Longwave tree - Energy Balance Check error!", eb-LW + !ENDIF + + ! Radiation difference due to the last temperature change of the leaf + ! dBdT: the first 4 iterms is 0 + !dX = matmul(Ainv, dBdT) + ! Finally solve the first 4 items, the leaf has been solved + !lwsun = lwsun + ( ewall*dX(1) ) / (1-ewall) * dtl!/ (4*fwsun*HL*fb/fg) + !lwsha = lwsha + ( ewall*dX(2) ) / (1-ewall) * dtl!/ (4*fwsha*HL*fb/fg) + !lgimp = lwimp + ( egimp*dX(3) ) / (1-egimp) * dtl!/ fgimp + !lgper = lgper + ( egper*dX(4) ) / (1-egper) * dtl!/ fgper + + ! update after each temperature iteration + !lv = lv + ((dX(1)*Fwv + dX(2)*Fwv + dX(3)*Fgv + dX(4)*Fgv)*ev - dBdT(5))*dtl!/(fv/fg) + !dlvdt = (dX(1)*Fwv + dX(2)*Fwv + dX(3)*Fgv + dX(4)*Fgv)*ev - dBdT(5) + + !SkyVF(1:2) = Fws_; SkyVF(3:4) = Fgs_; SkyVF(5) = Fvs + !lout = lout + sum( dX * SkyVF * dtl ) + + ! put it outside + ! absorption change due to temperature change, as restart variables. + ! now the leaf temperature does not change, the last iterm of dBdT is 0. + !dX = matmul(Ainv, dBdT*dT) + + !lwsun = ( ewall*dX(1) - dBdT(1)*dT(1) ) / (1-ewall) !/ (4*fwsun*HL*fb/fg) + !lwsha = ( ewall*dX(2) - dBdT(2)*dT(2) ) / (1-ewall) !/ (4*fwsha*HL*fb/fg) + !lgimp = ( egimp*dX(3) - dBdT(3)*dT(3) ) / (1-egimp) !/ fgimp + !lgper = ( esnow*dX(4) - dBdT(4)*dT(4) ) / (1-esnow) !/ fgper + !lv = ((dX(1)*Fwv + dX(2)*Fwv + dX(3)*Fgv + dX(4)*Fgv + dX(5)*Fgv)*ev)!/(fv/fg) + + !lout = X(1)*Fws_ + X(2)*Fws_ + X(3)*Fgs_ + X(4)*Fgs_ + X(5)*Fvs + !SkyVF(1:2) = Fws_; SkyVF(3:4) = Fgs_; SkyVF(5) = Fvs + !lout = lout + sum( dX * SkyVF ) + + END SUBROUTINE UrbanVegLongwave END MODULE MOD_Urban_Longwave diff --git a/main/URBAN/MOD_Urban_NetSolar.F90 b/main/URBAN/MOD_Urban_NetSolar.F90 index 035d08a7..18dd303b 100644 --- a/main/URBAN/MOD_Urban_NetSolar.F90 +++ b/main/URBAN/MOD_Urban_NetSolar.F90 @@ -2,50 +2,50 @@ MODULE MOD_Urban_NetSolar - USE MOD_Precision - IMPLICIT NONE - SAVE + USE MOD_Precision + IMPLICIT NONE + SAVE - PUBLIC :: netsolar_urban + PUBLIC :: netsolar_urban CONTAINS - SUBROUTINE netsolar_urban (ipatch,idate,dlon,deltim,& - forc_sols,forc_soll,forc_solsd,forc_solld,lai,sai,rho,tau,& - alb,ssun,ssha,sroof,swsun,swsha,sgimp,sgper,slake,& - sr,sabv,par,sabroof,sabwsun,sabwsha,sabgimp,sabgper,sablake,& - solvd,solvi,solnd,solni,srvd,srvi,srnd,srni,& - solvdln,solviln,solndln,solniln,srvdln,srviln,srndln,srniln) + SUBROUTINE netsolar_urban (ipatch,idate,dlon,deltim,& + forc_sols,forc_soll,forc_solsd,forc_solld,lai,sai,rho,tau,& + alb,ssun,ssha,sroof,swsun,swsha,sgimp,sgper,slake,& + sr,sabv,par,sabroof,sabwsun,sabwsha,sabgimp,sabgper,sablake,& + solvd,solvi,solnd,solni,srvd,srvi,srnd,srni,& + solvdln,solviln,solndln,solniln,srvdln,srviln,srndln,srniln) !======================================================================= ! Net solar absorbed by urban surface !======================================================================= - USE MOD_Precision - USE MOD_Vars_Global - USE MOD_TimeManager, only: isgreenwich - IMPLICIT NONE + USE MOD_Precision + USE MOD_Vars_Global + USE MOD_TimeManager, only: isgreenwich + IMPLICIT NONE ! Dummy argument - INTEGER, intent(in) :: ipatch ! patch index - INTEGER, intent(in) :: idate(3) ! model time + integer, intent(in) :: ipatch ! patch index + integer, intent(in) :: idate(3) ! model time - REAL(r8), intent(in) :: dlon ! logitude in radians - REAL(r8), intent(in) :: deltim ! seconds in a time step [second] + real(r8), intent(in) :: dlon ! logitude in radians + real(r8), intent(in) :: deltim ! seconds in a time step [second] - REAL(r8), intent(in) :: & + real(r8), intent(in) :: & forc_sols, &! atm vis direct beam solar rad onto srf [W/m2] forc_soll, &! atm nir direct beam solar rad onto srf [W/m2] forc_solsd, &! atm vis diffuse solar rad onto srf [W/m2] forc_solld ! atm nir diffuse solar rad onto srf [W/m2] - REAL(r8), intent(in) :: & + real(r8), intent(in) :: & lai, &! leaf area index sai, &! stem area index rho(2,2), &! leaf reflectance (iw=iband, il=life and dead) tau(2,2) ! leaf transmittance (iw=iband, il=life and dead) - REAL(r8), dimension(1:2,1:2), intent(in) :: & + real(r8), dimension(1:2,1:2), intent(in) :: & alb, &! averaged albedo [-] ssun, &! sunlit canopy absorption for solar radiation ssha, &! shaded canopy absorption for solar radiation @@ -57,7 +57,7 @@ SUBROUTINE netsolar_urban (ipatch,idate,dlon,deltim,& slake ! lake absorption for solar radiation - REAL(r8), intent(out) :: & + real(r8), intent(out) :: & sr, &! total reflected solar radiation (W/m2) par, &! PAR absorbed by sunlit vegetation [W/m2] sabv, &! solar absorbed by sunlit vegetation [W/m2] @@ -85,91 +85,91 @@ SUBROUTINE netsolar_urban (ipatch,idate,dlon,deltim,& srniln ! reflected diffuse beam nir solar radiation at local noon(W/m2) ! ----------------local variables --------------------------------- - INTEGER :: local_secs - REAL(r8) :: radpsec + integer :: local_secs + real(r8) :: radpsec - sabroof = 0. - sabwsun = 0. - sabwsha = 0. - sabgimp = 0. - sabgper = 0. - sablake = 0. - sabv = 0. - par = 0. + sabroof = 0. + sabwsun = 0. + sabwsha = 0. + sabgimp = 0. + sabgper = 0. + sablake = 0. + sabv = 0. + par = 0. - IF (forc_sols+forc_soll+forc_solsd+forc_solld > 0.) THEN + IF (forc_sols+forc_soll+forc_solsd+forc_solld > 0.) THEN - sabroof = forc_sols *sroof(1,1) + forc_soll *sroof(2,1) & - + forc_solsd*sroof(1,2) + forc_solld*sroof(2,2) + sabroof = forc_sols *sroof(1,1) + forc_soll *sroof(2,1) & + + forc_solsd*sroof(1,2) + forc_solld*sroof(2,2) - sabwsun = forc_sols *swsun(1,1) + forc_soll *swsun(2,1) & - + forc_solsd*swsun(1,2) + forc_solld*swsun(2,2) + sabwsun = forc_sols *swsun(1,1) + forc_soll *swsun(2,1) & + + forc_solsd*swsun(1,2) + forc_solld*swsun(2,2) - sabwsha = forc_sols *swsha(1,1) + forc_soll *swsha(2,1) & - + forc_solsd*swsha(1,2) + forc_solld*swsha(2,2) + sabwsha = forc_sols *swsha(1,1) + forc_soll *swsha(2,1) & + + forc_solsd*swsha(1,2) + forc_solld*swsha(2,2) - sabgimp = forc_sols *sgimp(1,1) + forc_soll *sgimp(2,1) & - + forc_solsd*sgimp(1,2) + forc_solld*sgimp(2,2) + sabgimp = forc_sols *sgimp(1,1) + forc_soll *sgimp(2,1) & + + forc_solsd*sgimp(1,2) + forc_solld*sgimp(2,2) - sabgper = forc_sols *sgper(1,1) + forc_soll *sgper(2,1) & - + forc_solsd*sgper(1,2) + forc_solld*sgper(2,2) + sabgper = forc_sols *sgper(1,1) + forc_soll *sgper(2,1) & + + forc_solsd*sgper(1,2) + forc_solld*sgper(2,2) - sabv = forc_sols *ssun (1,1) + forc_soll *ssun (2,1) & - + forc_solsd*ssun (1,2) + forc_solld*ssun (2,2) + sabv = forc_sols *ssun (1,1) + forc_soll *ssun (2,1) & + + forc_solsd*ssun (1,2) + forc_solld*ssun (2,2) - par = forc_sols *ssun (1,1) + forc_solsd*ssun (1,2) + par = forc_sols *ssun (1,1) + forc_solsd*ssun (1,2) - ! LAI PAR - !TODO: to distinguish lai and sai - !par = par * lai*(1.-rho(1,1)-tau(1,1)) / & - ! ( lai*(1.-rho(1,1)-tau(1,1)) + & - ! sai*(1.-rho(1,2)-tau(1,2)) ) + ! LAI PAR + !TODO: to distinguish lai and sai + !par = par * lai*(1.-rho(1,1)-tau(1,1)) / & + ! ( lai*(1.-rho(1,1)-tau(1,1)) + & + ! sai*(1.-rho(1,2)-tau(1,2)) ) - ! for lake - sablake = forc_sols *slake(1,1) + forc_soll *slake(2,1) & - + forc_solsd*slake(1,2) + forc_solld*slake(2,2) + ! for lake + sablake = forc_sols *slake(1,1) + forc_soll *slake(2,1) & + + forc_solsd*slake(1,2) + forc_solld*slake(2,2) - ENDIF + ENDIF - solvd = forc_sols - solvi = forc_solsd - solnd = forc_soll - solni = forc_solld - srvd = solvd*alb(1,1) - srvi = solvi*alb(1,2) - srnd = solnd*alb(2,1) - srni = solni*alb(2,2) - sr = srvd + srvi + srnd + srni + solvd = forc_sols + solvi = forc_solsd + solnd = forc_soll + solni = forc_solld + srvd = solvd*alb(1,1) + srvi = solvi*alb(1,2) + srnd = solnd*alb(2,1) + srni = solni*alb(2,2) + sr = srvd + srvi + srnd + srni ! calculate the local secs - radpsec = pi/12./3600. - IF ( isgreenwich ) THEN - local_secs = idate(3) + nint((dlon/radpsec)/deltim)*deltim - local_secs = mod(local_secs,86400) - ELSE - local_secs = idate(3) - ENDIF - - IF (local_secs == 86400/2) THEN - solvdln = forc_sols - solviln = forc_solsd - solndln = forc_soll - solniln = forc_solld - srvdln = solvdln*alb(1,1) - srviln = solviln*alb(1,2) - srndln = solndln*alb(2,1) - srniln = solniln*alb(2,2) - ELSE - solvdln = spval - solviln = spval - solndln = spval - solniln = spval - srvdln = spval - srviln = spval - srndln = spval - srniln = spval - ENDIF - - END SUBROUTINE netsolar_urban + radpsec = pi/12./3600. + IF ( isgreenwich ) THEN + local_secs = idate(3) + nint((dlon/radpsec)/deltim)*deltim + local_secs = mod(local_secs,86400) + ELSE + local_secs = idate(3) + ENDIF + + IF (local_secs == 86400/2) THEN + solvdln = forc_sols + solviln = forc_solsd + solndln = forc_soll + solniln = forc_solld + srvdln = solvdln*alb(1,1) + srviln = solviln*alb(1,2) + srndln = solndln*alb(2,1) + srniln = solniln*alb(2,2) + ELSE + solvdln = spval + solviln = spval + solndln = spval + solniln = spval + srvdln = spval + srviln = spval + srndln = spval + srniln = spval + ENDIF + + END SUBROUTINE netsolar_urban END MODULE MOD_Urban_NetSolar diff --git a/main/URBAN/MOD_Urban_PerviousTemperature.F90 b/main/URBAN/MOD_Urban_PerviousTemperature.F90 index 123bb44e..b2467b41 100644 --- a/main/URBAN/MOD_Urban_PerviousTemperature.F90 +++ b/main/URBAN/MOD_Urban_PerviousTemperature.F90 @@ -2,29 +2,29 @@ MODULE MOD_Urban_PerviousTemperature - USE MOD_Precision - IMPLICIT NONE - SAVE + USE MOD_Precision + IMPLICIT NONE + SAVE - PUBLIC :: UrbanPerviousTem + PUBLIC :: UrbanPerviousTem CONTAINS - SUBROUTINE UrbanPerviousTem (patchtype,lb,deltim, & - capr,cnfac,csol,k_solids,porsl,psi0,dkdry,dksatu,dksatf,& - vf_quartz,vf_gravels,vf_om,vf_sand,wf_gravels,wf_sand,& - BA_alpha, BA_beta,& + SUBROUTINE UrbanPerviousTem (patchtype,lb,deltim, & + capr,cnfac,csol,k_solids,porsl,psi0,dkdry,dksatu,dksatf,& + vf_quartz,vf_gravels,vf_om,vf_sand,wf_gravels,wf_sand,& + BA_alpha, BA_beta,& #ifdef Campbell_SOIL_MODEL - bsw,& + bsw,& #endif #ifdef vanGenuchten_Mualem_SOIL_MODEL - theta_r,alpha_vgm,n_vgm,L_vgm,& - sc_vgm,fc_vgm,& + theta_r,alpha_vgm,n_vgm,L_vgm,& + sc_vgm,fc_vgm,& #endif - dz_gpersno,z_gpersno,zi_gpersno,& - t_gpersno,wice_gpersno,wliq_gpersno,scv_gper,snowdp_gper,& - lgper,clgper,sabgper,fsengper,fevpgper,cgper,htvp,& - imelt,sm,xmf,fact) + dz_gpersno,z_gpersno,zi_gpersno,& + t_gpersno,wice_gpersno,wliq_gpersno,scv_gper,snowdp_gper,& + lgper,clgper,sabgper,fsengper,fevpgper,cgper,htvp,& + imelt,sm,xmf,fact) !======================================================================= ! Snow and pervious road temperatures @@ -48,103 +48,103 @@ SUBROUTINE UrbanPerviousTem (patchtype,lb,deltim, & ! Original author : Yongjiu Dai, 09/15/1999; 08/30/2002; 05/2020 !======================================================================= - USE MOD_Precision - USE MOD_Vars_Global - USE MOD_Const_Physical - USE MOD_SoilThermalParameters - USE MOD_Utils, only: tridia - USE MOD_PhaseChange, only: meltf - - IMPLICIT NONE - - integer, intent(in) :: lb !lower bound of array - integer, intent(in) :: patchtype !land patch type (0=soil,1=urban or built-up,2=wetland, - !3=land ice, 4=deep lake, 5=shallow lake) - real(r8), intent(in) :: deltim !seconds in a time step [second] - real(r8), intent(in) :: capr !tuning factor to turn first layer T into surface T - real(r8), intent(in) :: cnfac !Crank Nicholson factor between 0 and 1 - - real(r8), intent(in) :: csol (1:nl_soil) !heat capacity of soil solids [J/(m3 K)] - real(r8), intent(in) :: k_solids (1:nl_soil) !thermal conductivity of minerals soil [W/m-K] - real(r8), intent(in) :: porsl (1:nl_soil) !soil porosity [-] - real(r8), intent(in) :: psi0 (1:nl_soil) !soil water suction, negative potential [mm] - - real(r8), intent(in) :: dkdry (1:nl_soil) !thermal conductivity of dry soil [W/m-K] - real(r8), intent(in) :: dksatu (1:nl_soil) !thermal conductivity of saturated soil [W/m-K] - real(r8), intent(in) :: dksatf (1:nl_soil) !thermal conductivity of saturated frozen soil [W/m-K] - - real(r8), intent(in) :: vf_quartz (1:nl_soil) !volumetric fraction of quartz within mineral soil - real(r8), intent(in) :: vf_gravels(1:nl_soil) !volumetric fraction of gravels - real(r8), intent(in) :: vf_om (1:nl_soil) !volumetric fraction of organic matter - real(r8), intent(in) :: vf_sand (1:nl_soil) !volumetric fraction of sand - real(r8), intent(in) :: wf_gravels(1:nl_soil) !gravimetric fraction of gravels - real(r8), intent(in) :: wf_sand (1:nl_soil) !gravimetric fraction of sand - - real(r8), intent(in) :: BA_alpha (1:nl_soil) !alpha in Balland and Arp(2005) thermal conductivity scheme - real(r8), intent(in) :: BA_beta (1:nl_soil) !beta in Balland and Arp(2005) thermal conductivity scheme + USE MOD_Precision + USE MOD_Vars_Global + USE MOD_Const_Physical + USE MOD_SoilThermalParameters + USE MOD_Utils, only: tridia + USE MOD_PhaseChange, only: meltf + + IMPLICIT NONE + + integer, intent(in) :: lb !lower bound of array + integer, intent(in) :: patchtype !land patch type (0=soil,1=urban or built-up,2=wetland, + !3=land ice, 4=deep lake, 5=shallow lake) + real(r8), intent(in) :: deltim !seconds in a time step [second] + real(r8), intent(in) :: capr !tuning factor to turn first layer T into surface T + real(r8), intent(in) :: cnfac !Crank Nicholson factor between 0 and 1 + + real(r8), intent(in) :: csol (1:nl_soil) !heat capacity of soil solids [J/(m3 K)] + real(r8), intent(in) :: k_solids (1:nl_soil) !thermal conductivity of minerals soil [W/m-K] + real(r8), intent(in) :: porsl (1:nl_soil) !soil porosity [-] + real(r8), intent(in) :: psi0 (1:nl_soil) !soil water suction, negative potential [mm] + + real(r8), intent(in) :: dkdry (1:nl_soil) !thermal conductivity of dry soil [W/m-K] + real(r8), intent(in) :: dksatu (1:nl_soil) !thermal conductivity of saturated soil [W/m-K] + real(r8), intent(in) :: dksatf (1:nl_soil) !thermal conductivity of saturated frozen soil [W/m-K] + + real(r8), intent(in) :: vf_quartz (1:nl_soil) !volumetric fraction of quartz within mineral soil + real(r8), intent(in) :: vf_gravels(1:nl_soil) !volumetric fraction of gravels + real(r8), intent(in) :: vf_om (1:nl_soil) !volumetric fraction of organic matter + real(r8), intent(in) :: vf_sand (1:nl_soil) !volumetric fraction of sand + real(r8), intent(in) :: wf_gravels(1:nl_soil) !gravimetric fraction of gravels + real(r8), intent(in) :: wf_sand (1:nl_soil) !gravimetric fraction of sand + + real(r8), intent(in) :: BA_alpha (1:nl_soil) !alpha in Balland and Arp(2005) thermal conductivity scheme + real(r8), intent(in) :: BA_beta (1:nl_soil) !beta in Balland and Arp(2005) thermal conductivity scheme #ifdef Campbell_SOIL_MODEL - real(r8), intent(in) :: bsw (1:nl_soil) !clapp and hornbereger "b" parameter [-] + real(r8), intent(in) :: bsw (1:nl_soil) !clapp and hornbereger "b" parameter [-] #endif #ifdef vanGenuchten_Mualem_SOIL_MODEL - real(r8), intent(in) :: theta_r (1:nl_soil),& !soil parameter for vanGenuchten scheme - alpha_vgm (1:nl_soil),& !soil parameter for vanGenuchten scheme - n_vgm (1:nl_soil),& !soil parameter for vanGenuchten scheme - L_vgm (1:nl_soil),& !soil parameter for vanGenuchten scheme - sc_vgm (1:nl_soil),& !soil parameter for vanGenuchten scheme - fc_vgm (1:nl_soil) !soil parameter for vanGenuchten scheme + real(r8), intent(in) :: theta_r (1:nl_soil),& !soil parameter for vanGenuchten scheme + alpha_vgm (1:nl_soil),& !soil parameter for vanGenuchten scheme + n_vgm (1:nl_soil),& !soil parameter for vanGenuchten scheme + L_vgm (1:nl_soil),& !soil parameter for vanGenuchten scheme + sc_vgm (1:nl_soil),& !soil parameter for vanGenuchten scheme + fc_vgm (1:nl_soil) !soil parameter for vanGenuchten scheme #endif - real(r8), intent(in) :: dz_gpersno(lb :nl_soil) !layer thickiness [m] - real(r8), intent(in) :: z_gpersno (lb :nl_soil) !node depth [m] - real(r8), intent(in) :: zi_gpersno(lb-1:nl_soil) !interface depth [m] - - real(r8), intent(in) :: sabgper !solar radiation absorbed by ground [W/m2] - real(r8), intent(in) :: lgper !atmospheric infrared (longwave) radiation [W/m2] - real(r8), intent(in) :: clgper !deriv. of longwave wrt to soil temp [w/m2/k] - real(r8), intent(in) :: fsengper !sensible heat flux from ground [W/m2] - real(r8), intent(in) :: fevpgper !evaporation heat flux from ground [mm/s] - real(r8), intent(in) :: cgper !deriv. of soil energy flux wrt to soil temp [w/m2/k] - real(r8), intent(in) :: htvp !latent heat of vapor of water (or sublimation) [j/kg] - - real(r8), intent(inout) :: t_gpersno (lb:nl_soil) !soil temperature [K] - real(r8), intent(inout) :: wice_gpersno(lb:nl_soil) !ice lens [kg/m2] - real(r8), intent(inout) :: wliq_gpersno(lb:nl_soil) !liqui water [kg/m2] - real(r8), intent(inout) :: scv_gper !snow cover, water equivalent [mm, kg/m2] - real(r8), intent(inout) :: snowdp_gper !snow depth [m] - - real(r8), intent(out) :: sm !rate of snowmelt [kg/(m2 s)] - real(r8), intent(out) :: xmf !total latent heat of phase change of ground water - real(r8), intent(out) :: fact (lb:nl_soil) !used in computing tridiagonal matrix - integer, intent(out) :: imelt(lb:nl_soil) !flag for melting or freezing [-] + real(r8), intent(in) :: dz_gpersno(lb :nl_soil) !layer thickiness [m] + real(r8), intent(in) :: z_gpersno (lb :nl_soil) !node depth [m] + real(r8), intent(in) :: zi_gpersno(lb-1:nl_soil) !interface depth [m] + + real(r8), intent(in) :: sabgper !solar radiation absorbed by ground [W/m2] + real(r8), intent(in) :: lgper !atmospheric infrared (longwave) radiation [W/m2] + real(r8), intent(in) :: clgper !deriv. of longwave wrt to soil temp [w/m2/k] + real(r8), intent(in) :: fsengper !sensible heat flux from ground [W/m2] + real(r8), intent(in) :: fevpgper !evaporation heat flux from ground [mm/s] + real(r8), intent(in) :: cgper !deriv. of soil energy flux wrt to soil temp [w/m2/k] + real(r8), intent(in) :: htvp !latent heat of vapor of water (or sublimation) [j/kg] + + real(r8), intent(inout) :: t_gpersno (lb:nl_soil) !soil temperature [K] + real(r8), intent(inout) :: wice_gpersno(lb:nl_soil) !ice lens [kg/m2] + real(r8), intent(inout) :: wliq_gpersno(lb:nl_soil) !liqui water [kg/m2] + real(r8), intent(inout) :: scv_gper !snow cover, water equivalent [mm, kg/m2] + real(r8), intent(inout) :: snowdp_gper !snow depth [m] + + real(r8), intent(out) :: sm !rate of snowmelt [kg/(m2 s)] + real(r8), intent(out) :: xmf !total latent heat of phase change of ground water + real(r8), intent(out) :: fact (lb:nl_soil) !used in computing tridiagonal matrix + integer, intent(out) :: imelt(lb:nl_soil) !flag for melting or freezing [-] !------------------------ local variables ------------------------------ - real(r8) cv(lb:nl_soil) !heat capacity [J/(m2 K)] - real(r8) tk(lb:nl_soil) !thermal conductivity [W/(m K)] + real(r8) cv(lb:nl_soil) !heat capacity [J/(m2 K)] + real(r8) tk(lb:nl_soil) !thermal conductivity [W/(m K)] - real(r8) hcap(1:nl_soil) !J/(m3 K) - real(r8) thk(lb:nl_soil) !W/(m K) - real(r8) rhosnow !partitial density of water (ice + liquid) + real(r8) hcap(1:nl_soil) !J/(m3 K) + real(r8) thk(lb:nl_soil) !W/(m K) + real(r8) rhosnow !partitial density of water (ice + liquid) - real(r8) at(lb:nl_soil) !"a" vector for tridiagonal matrix - real(r8) bt(lb:nl_soil) !"b" vector for tridiagonal matrix - real(r8) ct(lb:nl_soil) !"c" vector for tridiagonal matrix - real(r8) rt(lb:nl_soil) !"r" vector for tridiagonal solution + real(r8) at(lb:nl_soil) !"a" vector for tridiagonal matrix + real(r8) bt(lb:nl_soil) !"b" vector for tridiagonal matrix + real(r8) ct(lb:nl_soil) !"c" vector for tridiagonal matrix + real(r8) rt(lb:nl_soil) !"r" vector for tridiagonal solution - real(r8) fn (lb:nl_soil) !heat diffusion through the layer interface [W/m2] - real(r8) fn1(lb:nl_soil) !heat diffusion through the layer interface [W/m2] - real(r8) dzm !used in computing tridiagonal matrix - real(r8) dzp !used in computing tridiagonal matrix + real(r8) fn (lb:nl_soil) !heat diffusion through the layer interface [W/m2] + real(r8) fn1(lb:nl_soil) !heat diffusion through the layer interface [W/m2] + real(r8) dzm !used in computing tridiagonal matrix + real(r8) dzp !used in computing tridiagonal matrix - real(r8) t_gpersno_bef(lb:nl_soil) !soil/snow temperature before update - real(r8) hs !net energy flux into the surface (w/m2) - real(r8) dhsdt !d(hs)/dT - real(r8) brr(lb:nl_soil) !temporay set + real(r8) t_gpersno_bef(lb:nl_soil) !soil/snow temperature before update + real(r8) hs !net energy flux into the surface (w/m2) + real(r8) dhsdt !d(hs)/dT + real(r8) brr(lb:nl_soil) !temporay set - real(r8) vf_water(1:nl_soil) !volumetric fraction liquid water within soil - real(r8) vf_ice(1:nl_soil) !volumetric fraction ice len within soil + real(r8) vf_water(1:nl_soil) !volumetric fraction liquid water within soil + real(r8) vf_ice(1:nl_soil) !volumetric fraction ice len within soil - integer i,j + integer i,j !======================================================================= ! soil ground and wetland heat capacity @@ -287,7 +287,7 @@ SUBROUTINE UrbanPerviousTem (patchtype,lb,deltim, & #endif dz_soi(1:nl_soil)) - END SUBROUTINE UrbanPerviousTem + END SUBROUTINE UrbanPerviousTem END MODULE MOD_Urban_PerviousTemperature ! ---------- EOP ------------ diff --git a/main/URBAN/MOD_Urban_RoofFlux.F90 b/main/URBAN/MOD_Urban_RoofFlux.F90 index 8bc02559..b998dccf 100644 --- a/main/URBAN/MOD_Urban_RoofFlux.F90 +++ b/main/URBAN/MOD_Urban_RoofFlux.F90 @@ -2,20 +2,20 @@ MODULE MOD_Urban_RoofFlux - USE MOD_Precision - IMPLICIT NONE - SAVE + USE MOD_Precision + IMPLICIT NONE + SAVE - PUBLIC :: UrbanRoofFlux + PUBLIC :: UrbanRoofFlux CONTAINS - SUBROUTINE UrbanRoofFlux (hu, ht, hq, us, vs, tm, qm, rhoair, psrf, & - ur, thm, th, thv, zsno, fsno_roof, hroof, htvp_roof, & - lbr, wliq_roofsno, wice_roofsno, troof, qroof, dqroofdT, & - croofs, croofl, croof, fsenroof, fevproof, & - z0m, z0hg, zol, ustar, qstar, tstar, fm, fh, fq) + SUBROUTINE UrbanRoofFlux (hu, ht, hq, us, vs, tm, qm, rhoair, psrf, & + ur, thm, th, thv, zsno, fsno_roof, hroof, htvp_roof, & + lbr, wliq_roofsno, wice_roofsno, troof, qroof, dqroofdT, & + croofs, croofl, croof, fsenroof, fevproof, & + z0m, z0hg, zol, ustar, qstar, tstar, fm, fh, fq) !======================================================================= ! this is the main subroutine to execute the calculation @@ -23,16 +23,16 @@ SUBROUTINE UrbanRoofFlux (hu, ht, hq, us, vs, tm, qm, rhoair, psrf, & ! !======================================================================= - USE MOD_Precision - USE MOD_Const_Physical, only: cpair,vonkar,grav - USE MOD_FrictionVelocity - IMPLICIT NONE + USE MOD_Precision + USE MOD_Const_Physical, only: cpair,vonkar,grav + USE MOD_FrictionVelocity + IMPLICIT NONE !----------------------- Dummy argument -------------------------------- - INTEGER, intent(in) :: & + integer, intent(in) :: & lbr ! lower bound of array - REAL(r8), intent(in) :: & + real(r8), intent(in) :: & ! atmospherical variables and observational height hu, &! observational height of wind [m] ht, &! observational height of temperature [m] @@ -61,16 +61,16 @@ SUBROUTINE UrbanRoofFlux (hu, ht, hq, us, vs, tm, qm, rhoair, psrf, & dqroofdT, &! d(qroof)/dT htvp_roof ! latent heat of vapor of water (or sublimation) [j/kg] - REAL(r8), intent(out) :: & + real(r8), intent(out) :: & croofs, &! deriv of roof sensible heat flux wrt soil temp [w/m**2/k] croofl, &! deriv of roof latent heat flux wrt soil temp [w/m**2/k] croof ! deriv of roof total heat flux wrt soil temp [w/m**2/k] - REAL(r8), intent(out) :: & + real(r8), intent(out) :: & fsenroof, &! sensible heat flux from roof [W/m2] fevproof ! evaperation heat flux from roof [W/m2] - REAL(r8), intent(out) :: & + real(r8), intent(out) :: & z0m, &! effective roughness [m] z0hg, &! roughness length over ground, sensible heat [m] zol, &! dimensionless height (z/L) used in Monin-Obukhov theory @@ -82,11 +82,11 @@ SUBROUTINE UrbanRoofFlux (hu, ht, hq, us, vs, tm, qm, rhoair, psrf, & fq ! integral of profile function for moisture !------------------------ LOCAL VARIABLES ------------------------------ - INTEGER niters, &! maximum number of iterations for surface temperature + integer niters,&! maximum number of iterations for surface temperature iter, &! iteration index nmozsgn ! number of times moz changes sign - REAL(r8) :: & + real(r8) :: & beta, &! coefficient of conective velocity [-] displax, &! zero-displacement height [m] tg, &! ground surface temperature [K] @@ -116,7 +116,7 @@ SUBROUTINE UrbanRoofFlux (hu, ht, hq, us, vs, tm, qm, rhoair, psrf, & z0mg, &! roughness length over ground, momentum [m] z0qg ! roughness length over ground, latent heat [m] - REAL(r8) fwet_roof + real(r8) fwet_roof !----------------------- Dummy argument -------------------------------- ! initial roughness length @@ -200,7 +200,7 @@ SUBROUTINE UrbanRoofFlux (hu, ht, hq, us, vs, tm, qm, rhoair, psrf, & ENDIF IF (obuold*obu < 0.) nmozsgn = nmozsgn+1 - IF (nmozsgn >= 4) exit + IF (nmozsgn >= 4) EXIT obuold = obu @@ -228,6 +228,6 @@ SUBROUTINE UrbanRoofFlux (hu, ht, hq, us, vs, tm, qm, rhoair, psrf, & fsenroof = -raih*dth fevproof = -raiw*dqh*fwet_roof - END SUBROUTINE UrbanRoofFlux + END SUBROUTINE UrbanRoofFlux END MODULE MOD_Urban_RoofFlux diff --git a/main/URBAN/MOD_Urban_RoofTemperature.F90 b/main/URBAN/MOD_Urban_RoofTemperature.F90 index 40094ed0..7a14c107 100644 --- a/main/URBAN/MOD_Urban_RoofTemperature.F90 +++ b/main/URBAN/MOD_Urban_RoofTemperature.F90 @@ -2,20 +2,20 @@ MODULE MOD_Urban_RoofTemperature - USE MOD_Precision - IMPLICIT NONE - SAVE + USE MOD_Precision + IMPLICIT NONE + SAVE - PUBLIC :: UrbanRoofTem + PUBLIC :: UrbanRoofTem CONTAINS - SUBROUTINE UrbanRoofTem (lb,deltim,capr,cnfac,& - cv_roof,tk_roof,dz_roofsno,z_roofsno,zi_roofsno,& - t_roofsno,wice_roofsno,wliq_roofsno,scv_roof,snowdp_roof,& - troof_inner,lroof,clroof,sabroof,fsenroof,fevproof,croof,htvp,& - imelt_roof,sm_roof,xmf_roof,fact,tkdz_roof) + SUBROUTINE UrbanRoofTem (lb,deltim,capr,cnfac,& + cv_roof,tk_roof,dz_roofsno,z_roofsno,zi_roofsno,& + t_roofsno,wice_roofsno,wliq_roofsno,scv_roof,snowdp_roof,& + troof_inner,lroof,clroof,sabroof,fsenroof,fevproof,croof,htvp,& + imelt_roof,sm_roof,xmf_roof,fact,tkdz_roof) !======================================================================= ! Snow and roof temperatures @@ -42,69 +42,69 @@ SUBROUTINE UrbanRoofTem (lb,deltim,capr,cnfac,& ! Original author : Yongjiu Dai, 05/2020 !======================================================================= - USE MOD_Precision - USE MOD_Vars_Global - USE MOD_Const_Physical - USE MOD_Utils, only: tridia - USE MOD_PhaseChange, only: meltf_urban - - IMPLICIT NONE - - INTEGER , intent(in) :: lb !lower bound of array - REAL(r8), intent(in) :: deltim !seconds in a time step [second] - REAL(r8), intent(in) :: capr !tuning factor to turn first layer T into surface T - REAL(r8), intent(in) :: cnfac !Crank Nicholson factor between 0 and 1 - - REAL(r8), intent(in) :: cv_roof(1:nl_roof) !heat capacity of urban roof [J/m3/K] - REAL(r8), intent(in) :: tk_roof(1:nl_roof) !thermal conductivity of urban roof [W/m/K] - - REAL(r8), intent(in) :: dz_roofsno(lb:nl_roof) !layer thickiness [m] - REAL(r8), intent(in) :: z_roofsno (lb:nl_roof) !node depth [m] - REAL(r8), intent(in) :: zi_roofsno(lb-1:nl_roof) !interface depth [m] - - REAL(r8), intent(in) :: troof_inner !temperature at the roof inner surface [K] - REAL(r8), intent(in) :: lroof !atmospheric infrared (longwave) radiation [W/m2] - REAL(r8), intent(in) :: clroof !atmospheric infrared (longwave) radiation [W/m2] - REAL(r8), intent(in) :: sabroof !solar radiation absorbed by roof [W/m2] - REAL(r8), intent(in) :: fsenroof !sensible heat flux from roof [W/m2] - REAL(r8), intent(in) :: fevproof !evaporation heat flux from roof [mm/s] - REAL(r8), intent(in) :: croof !deriv. of roof energy flux wrt to roof temp [w/m2/k] - REAL(r8), intent(in) :: htvp !latent heat of vapor of water (or sublimation) [j/kg] - - REAL(r8), intent(inout) :: t_roofsno (lb:nl_roof) !roof layers' temperature [K] - REAL(r8), intent(inout) :: wice_roofsno(lb:nl_roof) !ice lens [kg/m2] - REAL(r8), intent(inout) :: wliq_roofsno(lb:nl_roof) !liqui water [kg/m2] - REAL(r8), intent(inout) :: scv_roof !snow cover, water equivalent [mm, kg/m2] - REAL(r8), intent(inout) :: snowdp_roof !snow depth [m] - - REAL(r8), intent(out) :: sm_roof !rate of snowmelt [kg/(m2 s)] - REAL(r8), intent(out) :: xmf_roof !total latent heat of phase change of roof residual water - REAL(r8), intent(out) :: fact(lb:nl_roof) !used in computing tridiagonal matrix - REAL(r8), intent(out) :: tkdz_roof !heat diffusion with inner room space - INTEGER , intent(out) :: imelt_roof(lb:nl_roof) !flag for melting or freezing [-] + USE MOD_Precision + USE MOD_Vars_Global + USE MOD_Const_Physical + USE MOD_Utils, only: tridia + USE MOD_PhaseChange, only: meltf_urban + + IMPLICIT NONE + + integer , intent(in) :: lb !lower bound of array + real(r8), intent(in) :: deltim !seconds in a time step [second] + real(r8), intent(in) :: capr !tuning factor to turn first layer T into surface T + real(r8), intent(in) :: cnfac !Crank Nicholson factor between 0 and 1 + + real(r8), intent(in) :: cv_roof(1:nl_roof) !heat capacity of urban roof [J/m3/K] + real(r8), intent(in) :: tk_roof(1:nl_roof) !thermal conductivity of urban roof [W/m/K] + + real(r8), intent(in) :: dz_roofsno(lb:nl_roof) !layer thickiness [m] + real(r8), intent(in) :: z_roofsno (lb:nl_roof) !node depth [m] + real(r8), intent(in) :: zi_roofsno(lb-1:nl_roof) !interface depth [m] + + real(r8), intent(in) :: troof_inner !temperature at the roof inner surface [K] + real(r8), intent(in) :: lroof !atmospheric infrared (longwave) radiation [W/m2] + real(r8), intent(in) :: clroof !atmospheric infrared (longwave) radiation [W/m2] + real(r8), intent(in) :: sabroof !solar radiation absorbed by roof [W/m2] + real(r8), intent(in) :: fsenroof !sensible heat flux from roof [W/m2] + real(r8), intent(in) :: fevproof !evaporation heat flux from roof [mm/s] + real(r8), intent(in) :: croof !deriv. of roof energy flux wrt to roof temp [w/m2/k] + real(r8), intent(in) :: htvp !latent heat of vapor of water (or sublimation) [j/kg] + + real(r8), intent(inout) :: t_roofsno (lb:nl_roof) !roof layers' temperature [K] + real(r8), intent(inout) :: wice_roofsno(lb:nl_roof) !ice lens [kg/m2] + real(r8), intent(inout) :: wliq_roofsno(lb:nl_roof) !liqui water [kg/m2] + real(r8), intent(inout) :: scv_roof !snow cover, water equivalent [mm, kg/m2] + real(r8), intent(inout) :: snowdp_roof !snow depth [m] + + real(r8), intent(out) :: sm_roof !rate of snowmelt [kg/(m2 s)] + real(r8), intent(out) :: xmf_roof !total latent heat of phase change of roof residual water + real(r8), intent(out) :: fact(lb:nl_roof) !used in computing tridiagonal matrix + real(r8), intent(out) :: tkdz_roof !heat diffusion with inner room space + integer , intent(out) :: imelt_roof(lb:nl_roof) !flag for melting or freezing [-] !------------------------ local variables ------------------------------ - REAL(r8) cv (lb:nl_roof) !heat capacity [J/(m2 K)] - REAL(r8) thk(lb:nl_roof) !thermal conductivity of layer - REAL(r8) tk (lb:nl_roof) !thermal conductivity [W/(m K)] + real(r8) cv (lb:nl_roof) !heat capacity [J/(m2 K)] + real(r8) thk(lb:nl_roof) !thermal conductivity of layer + real(r8) tk (lb:nl_roof) !thermal conductivity [W/(m K)] - REAL(r8) at (lb:nl_roof) !"a" vector for tridiagonal matrix - REAL(r8) bt (lb:nl_roof) !"b" vector for tridiagonal matrix - REAL(r8) ct (lb:nl_roof) !"c" vector for tridiagonal matrix - REAL(r8) rt (lb:nl_roof) !"r" vector for tridiagonal solution + real(r8) at (lb:nl_roof) !"a" vector for tridiagonal matrix + real(r8) bt (lb:nl_roof) !"b" vector for tridiagonal matrix + real(r8) ct (lb:nl_roof) !"c" vector for tridiagonal matrix + real(r8) rt (lb:nl_roof) !"r" vector for tridiagonal solution - REAL(r8) fn (lb:nl_roof) !heat diffusion through the layer interface [W/m2] - REAL(r8) fn1(lb:nl_roof) !heat diffusion through the layer interface [W/m2] - REAL(r8) dzm !used in computing tridiagonal matrix - REAL(r8) dzp !used in computing tridiagonal matrix + real(r8) fn (lb:nl_roof) !heat diffusion through the layer interface [W/m2] + real(r8) fn1(lb:nl_roof) !heat diffusion through the layer interface [W/m2] + real(r8) dzm !used in computing tridiagonal matrix + real(r8) dzp !used in computing tridiagonal matrix - REAL(r8) t_roofsno_bef(lb:nl_roof) !roof/snow temperature before update - REAL(r8) hs !net energy flux into the surface (w/m2) - REAL(r8) dhsdt !d(hs)/dT - REAL(r8) brr(lb:nl_roof) !temporay set - REAL(r8) bw !snow density [kg/m3] + real(r8) t_roofsno_bef(lb:nl_roof) !roof/snow temperature before update + real(r8) hs !net energy flux into the surface (w/m2) + real(r8) dhsdt !d(hs)/dT + real(r8) brr(lb:nl_roof) !temporay set + real(r8) bw !snow density [kg/m3] - INTEGER i,j + integer i,j !======================================================================= @@ -227,7 +227,7 @@ SUBROUTINE UrbanRoofTem (lb,deltim,capr,cnfac,& t_roofsno_bef(lb:1),t_roofsno(lb:1),wliq_roofsno(lb:1),wice_roofsno(lb:1),imelt_roof(lb:1), & scv_roof,snowdp_roof,sm_roof,xmf_roof) - END SUBROUTINE UrbanRoofTem + END SUBROUTINE UrbanRoofTem END MODULE MOD_Urban_RoofTemperature ! ---------- EOP ------------ diff --git a/main/URBAN/MOD_Urban_Shortwave.F90 b/main/URBAN/MOD_Urban_Shortwave.F90 index c10fc455..8df64082 100644 --- a/main/URBAN/MOD_Urban_Shortwave.F90 +++ b/main/URBAN/MOD_Urban_Shortwave.F90 @@ -2,46 +2,46 @@ MODULE MOD_Urban_Shortwave - USE MOD_Precision - USE MOD_LandUrban - USE MOD_Vars_Global - USE MOD_3DCanopyRadiation, only: tee, phi - USE MOD_SPMD_Task + USE MOD_Precision + USE MOD_LandUrban + USE MOD_Vars_Global + USE MOD_3DCanopyRadiation, only: tee, phi + USE MOD_SPMD_Task - IMPLICIT NONE - SAVE - PRIVATE + IMPLICIT NONE + SAVE + PRIVATE - PUBLIC :: UrbanOnlyShortwave !Radiation transfer for shortwave radiation without trees - PUBLIC :: UrbanVegShortwave !Radiation transfer for shortwave radiation with trees + PUBLIC :: UrbanOnlyShortwave !Radiation transfer for shortwave radiation without trees + PUBLIC :: UrbanVegShortwave !Radiation transfer for shortwave radiation with trees - PUBLIC :: MatrixInverse !Inverse of radiation transfer matrix for multiple reflections - PUBLIC :: ShadowWall_dir !Shadow of wall for direct radiation - PUBLIC :: ShadowWall_dif !Shadow of wall for diffuse radiation - PUBLIC :: ShadowTree !Shadow of trees + PUBLIC :: MatrixInverse !Inverse of radiation transfer matrix for multiple reflections + PUBLIC :: ShadowWall_dir !Shadow of wall for direct radiation + PUBLIC :: ShadowWall_dif !Shadow of wall for diffuse radiation + PUBLIC :: ShadowTree !Shadow of trees CONTAINS - !------------------------------------------------- - SUBROUTINE UrbanOnlyShortwave ( theta, HW, fb, fgper, H, & - aroof, awall, agimp, agper, fwsun, sroof, swsun, swsha, sgimp, sgper, albu) + !------------------------------------------------- + SUBROUTINE UrbanOnlyShortwave ( theta, HW, fb, fgper, H, & + aroof, awall, agimp, agper, fwsun, sroof, swsun, swsha, sgimp, sgper, albu) - IMPLICIT NONE + IMPLICIT NONE - REAL(r8), intent(in) :: & + real(r8), intent(in) :: & theta, &! Sun zenith angle [radian] HW, &! Ratio of building height to ground width [-] fb, &! Fraction of building area [-] fgper, &! Fraction of impervious ground [-] H ! Building average height [m] - REAL(r8), intent(in) :: & + real(r8), intent(in) :: & aroof, &! albedo of roof [-] awall, &! albedo of walls [-] agimp, &! albedo of impervious road [-] agper ! albedo of pervious road [-] - REAL(r8), intent(out) :: & + real(r8), intent(out) :: & fwsun, &! Fraction of sunlit wall [-] sroof(2), &! Urban building roof absorption [-] swsun(2), &! Urban sunlit wall absorption [-] @@ -50,9 +50,9 @@ SUBROUTINE UrbanOnlyShortwave ( theta, HW, fb, fgper, H, & sgper(2), &! Urban pervious gournd absorption [-] albu(2) ! Urban overall albedo [-] - ! Local variables - !------------------------------------------------- - REAL(r8) :: & + ! Local variables + !------------------------------------------------- + real(r8) :: & W, &! Urban ground average width [m] L, &! Urban building average length [m] HL, &! Ratio of H to L, H/L [-] @@ -80,171 +80,171 @@ SUBROUTINE UrbanOnlyShortwave ( theta, HW, fb, fgper, H, & B(4), &! Vectors of incident radition on each surface X(4) ! Radiation emit from each surface in balance condition - ! Temporal - REAL(r8) :: fac1, fac2, eb - - ! Claculate urban structure parameters - !------------------------------------------------- - W = H/HW - L = W*sqrt(fb)/(1-sqrt(fb)) - HL = H/L !NOTE: Same as: HL = HW*(1-sqrt(fb))/sqrt(fb) - fg = 1. - fb - - fgimp = 1. - fgper - - ! Calculate view factors - !------------------------------------------------- - - ! View factor from sky to wall(sunlit+shaded) and ground - Fsw = ShadowWall_dif(fb/fg, HL) - Fsg = 1 - Fsw - - ! View factor from ground to walls and sky - Fgw = Fsw - Fgs = Fsg - - ! View factor from wall to wall, sky and ground - ! Fws*4*H*L/L/L = Fws*4H/L*fb = Fsw*fg - ! Fws*4HL*fb = Fsw*fg - ! Fws = Fsw*fg/(4HL*fb) - ! Adjusted as below: - Fws = Fsw*fg/fb/(2*HL)*0.75 - Fwg = Fsw*fg/fb/(2*HL)*0.25 - Fww = 1 - Fws - Fwg - - ! Calculate sunlit wall fraction - !------------------------------------------------- - - ! Building wall shadow on the ground - Sw = ShadowWall_dir(fb/fg, HL, theta) - - ! Sunlit/shaded wall fraction - fwsun = 0.5 * (Sw*fg + fb) / (4/PI*fb*HL*tan(theta) + fb) - fwsha = 1. - fwsun - - ! Calculate radiation transfer matrix - ! AX = B - ! o A: radiation transfer matrix - ! o B: incident radiation on each surface - ! o X: radiation emit from each surface - !------------------------------------------------- - A(1,:) = (/1-Fww*fwsun*awall, -Fww*fwsun*awall, -Fgw*fwsun*awall, -Fgw*fwsun*awall/) - A(2,:) = (/ -Fww*fwsha*awall, 1-Fww*fwsha*awall, -Fgw*fwsha*awall, -Fgw*fwsha*awall/) - A(3,:) = (/ -Fwg*fgimp*agimp, -Fwg*fgimp*agimp, 1._r8, 0._r8/) - A(4,:) = (/ -Fwg*fgper*agper, -Fwg*fgper*agper, 0._r8, 1._r8/) - - ! Inverse of matrix A - Ainv = MatrixInverse(A) - - ! Radiation transfer for incident direct case - !------------------------------------------------- - - ! Incident radiation on sunlit/shaded wall and - ! impervious/pervious ground - Ewsun = Sw - Ewsha = 0. - Eg = 1.-Ewsun - Egimp = Eg*fgimp - Egper = Eg*fgper - - ! Vector of first scattering radiatioin on each surface - B(:) = (/Ewsun*awall, Ewsha*awall, Egimp*agimp, Egper*agper/) - - ! Matrix computing to revole multiple reflections - X = matmul(Ainv, B) - - !------------------------------------------------- - ! SAVE results for output - !------------------------------------------------- - - ! Radiation absorption by each surface - !NOTE: for 3D, absorption per unit area: 4*HL*fb/fg - ! for canyon: absorption per unit area: 2*HW - swsun(1) = X(1)/awall*(1-awall)!/(4*fwsun*HL*fb/fg) - swsha(1) = X(2)/awall*(1-awall)!/(4*fwsha*HL*fb/fg) - sgimp(1) = X(3)/agimp*(1-agimp)!/fgimp - sgper(1) = X(4)/agper*(1-agper)!/fgper - - ! albedo of urban canopy - albu(1) = X(1)*Fws + X(2)*Fws + X(3)*Fgs + X(4)*Fgs - - ! Energy balance check - eb = swsun(1) + swsha(1) + sgimp(1) + sgper(1) + albu(1) - IF (abs(eb-1) > 1e-6) THEN - print *, "Direct - Energy Balance Check error!", eb-1 - ENDIF - - ! Radiation transfer for incident diffuse case - !------------------------------------------------- - - ! Incident radiation on sunlit/shaded wall and - ! impervious/pervious ground - Ewsun = Fsw*fwsun - Ewsha = Fsw*fwsha - Eg = Fsg - Egimp = Eg*fgimp - Egper = Eg*fgper - - ! Vector of first scattering radiatioin on each surface - B(:) = (/Ewsun*awall, Ewsha*awall, Egimp*agimp, Egper*agper/) - - ! Equation solve - X = matmul(Ainv, B) - - ! Radiation absorption by each surface - !NOTE: for 3D, absorption per unit area: 4*HL*fb/fg - ! for canyon: absorption per unit area: 2*HW - swsun(2) = X(1)/awall*(1-awall)!/(4*fwsun*HL*fb/fg) - swsha(2) = X(2)/awall*(1-awall)!/(4*fwsha*HL*fb/fg) - sgimp(2) = X(3)/agimp*(1-agimp)!/fgimp - sgper(2) = X(4)/agper*(1-agper)!/fgper - - !albedo of urban canopy - albu(2) = X(1)*Fws + X(2)*Fws + X(3)*Fgs + X(4)*Fgs - - ! energy balance check - eb = swsun(2) + swsha(2) + sgimp(2) + sgper(2) + albu(2) - IF (abs(eb-1) > 1e-6) THEN - print *, "Diffuse - Energy Balance Check error!", eb-1 - ENDIF - - ! convert to per unit area absorption - IF (fb > 0.) THEN - swsun = swsun/(4*fwsun*HL*fb)*fg - swsha = swsha/(4*fwsha*HL*fb)*fg - ENDIF - IF (fgimp > 0.) sgimp = sgimp/fgimp - IF (fgper > 0.) sgper = sgper/fgper - - ! roof absorption - sroof = 1. - aroof - - ! albedo accout for both roof and urban's wall and ground - albu = aroof*fb + albu*fg - - END SUBROUTINE UrbanOnlyShortwave - - !------------------------------------------------- - SUBROUTINE UrbanVegShortwave ( theta, HW, fb, fgper, H, & - aroof, awall, agimp, agper, lai, sai, fv, hv, rho, tau, & - fwsun, sroof, swsun, swsha, sgimp, sgper, sveg, albu ) - - IMPLICIT NONE - - REAL(r8), intent(in) :: & + ! Temporal + real(r8) :: fac1, fac2, eb + + ! Claculate urban structure parameters + !------------------------------------------------- + W = H/HW + L = W*sqrt(fb)/(1-sqrt(fb)) + HL = H/L !NOTE: Same as: HL = HW*(1-sqrt(fb))/sqrt(fb) + fg = 1. - fb + + fgimp = 1. - fgper + + ! Calculate view factors + !------------------------------------------------- + + ! View factor from sky to wall(sunlit+shaded) and ground + Fsw = ShadowWall_dif(fb/fg, HL) + Fsg = 1 - Fsw + + ! View factor from ground to walls and sky + Fgw = Fsw + Fgs = Fsg + + ! View factor from wall to wall, sky and ground + ! Fws*4*H*L/L/L = Fws*4H/L*fb = Fsw*fg + ! Fws*4HL*fb = Fsw*fg + ! Fws = Fsw*fg/(4HL*fb) + ! Adjusted as below: + Fws = Fsw*fg/fb/(2*HL)*0.75 + Fwg = Fsw*fg/fb/(2*HL)*0.25 + Fww = 1 - Fws - Fwg + + ! Calculate sunlit wall fraction + !------------------------------------------------- + + ! Building wall shadow on the ground + Sw = ShadowWall_dir(fb/fg, HL, theta) + + ! Sunlit/shaded wall fraction + fwsun = 0.5 * (Sw*fg + fb) / (4/PI*fb*HL*tan(theta) + fb) + fwsha = 1. - fwsun + + ! Calculate radiation transfer matrix + ! AX = B + ! o A: radiation transfer matrix + ! o B: incident radiation on each surface + ! o X: radiation emit from each surface + !------------------------------------------------- + A(1,:) = (/1-Fww*fwsun*awall, -Fww*fwsun*awall, -Fgw*fwsun*awall, -Fgw*fwsun*awall/) + A(2,:) = (/ -Fww*fwsha*awall, 1-Fww*fwsha*awall, -Fgw*fwsha*awall, -Fgw*fwsha*awall/) + A(3,:) = (/ -Fwg*fgimp*agimp, -Fwg*fgimp*agimp, 1._r8, 0._r8/) + A(4,:) = (/ -Fwg*fgper*agper, -Fwg*fgper*agper, 0._r8, 1._r8/) + + ! Inverse of matrix A + Ainv = MatrixInverse(A) + + ! Radiation transfer for incident direct case + !------------------------------------------------- + + ! Incident radiation on sunlit/shaded wall and + ! impervious/pervious ground + Ewsun = Sw + Ewsha = 0. + Eg = 1.-Ewsun + Egimp = Eg*fgimp + Egper = Eg*fgper + + ! Vector of first scattering radiatioin on each surface + B(:) = (/Ewsun*awall, Ewsha*awall, Egimp*agimp, Egper*agper/) + + ! Matrix computing to revole multiple reflections + X = matmul(Ainv, B) + + !------------------------------------------------- + ! SAVE results for output + !------------------------------------------------- + + ! Radiation absorption by each surface + !NOTE: for 3D, absorption per unit area: 4*HL*fb/fg + ! for canyon: absorption per unit area: 2*HW + swsun(1) = X(1)/awall*(1-awall)!/(4*fwsun*HL*fb/fg) + swsha(1) = X(2)/awall*(1-awall)!/(4*fwsha*HL*fb/fg) + sgimp(1) = X(3)/agimp*(1-agimp)!/fgimp + sgper(1) = X(4)/agper*(1-agper)!/fgper + + ! albedo of urban canopy + albu(1) = X(1)*Fws + X(2)*Fws + X(3)*Fgs + X(4)*Fgs + + ! Energy balance check + eb = swsun(1) + swsha(1) + sgimp(1) + sgper(1) + albu(1) + IF (abs(eb-1) > 1e-6) THEN + print *, "Direct - Energy Balance Check error!", eb-1 + ENDIF + + ! Radiation transfer for incident diffuse case + !------------------------------------------------- + + ! Incident radiation on sunlit/shaded wall and + ! impervious/pervious ground + Ewsun = Fsw*fwsun + Ewsha = Fsw*fwsha + Eg = Fsg + Egimp = Eg*fgimp + Egper = Eg*fgper + + ! Vector of first scattering radiatioin on each surface + B(:) = (/Ewsun*awall, Ewsha*awall, Egimp*agimp, Egper*agper/) + + ! Equation solve + X = matmul(Ainv, B) + + ! Radiation absorption by each surface + !NOTE: for 3D, absorption per unit area: 4*HL*fb/fg + ! for canyon: absorption per unit area: 2*HW + swsun(2) = X(1)/awall*(1-awall)!/(4*fwsun*HL*fb/fg) + swsha(2) = X(2)/awall*(1-awall)!/(4*fwsha*HL*fb/fg) + sgimp(2) = X(3)/agimp*(1-agimp)!/fgimp + sgper(2) = X(4)/agper*(1-agper)!/fgper + + !albedo of urban canopy + albu(2) = X(1)*Fws + X(2)*Fws + X(3)*Fgs + X(4)*Fgs + + ! energy balance check + eb = swsun(2) + swsha(2) + sgimp(2) + sgper(2) + albu(2) + IF (abs(eb-1) > 1e-6) THEN + print *, "Diffuse - Energy Balance Check error!", eb-1 + ENDIF + + ! convert to per unit area absorption + IF (fb > 0.) THEN + swsun = swsun/(4*fwsun*HL*fb)*fg + swsha = swsha/(4*fwsha*HL*fb)*fg + ENDIF + IF (fgimp > 0.) sgimp = sgimp/fgimp + IF (fgper > 0.) sgper = sgper/fgper + + ! roof absorption + sroof = 1. - aroof + + ! albedo accout for both roof and urban's wall and ground + albu = aroof*fb + albu*fg + + END SUBROUTINE UrbanOnlyShortwave + + !------------------------------------------------- + SUBROUTINE UrbanVegShortwave ( theta, HW, fb, fgper, H, & + aroof, awall, agimp, agper, lai, sai, fv, hv, rho, tau, & + fwsun, sroof, swsun, swsha, sgimp, sgper, sveg, albu ) + + IMPLICIT NONE + + real(r8), intent(in) :: & theta, &! Sun zenith angle [radian] HW, &! Ratio of building height to ground width [-] fb, &! Fraction of building area [-] fgper, &! Fraction of impervious ground [-] H ! Building average height [m] - REAL(r8), intent(in) :: & + real(r8), intent(in) :: & aroof, &! albedo of roof [-] awall, &! albedo of walls [-] agimp, &! albedo of impervious road [-] agper ! albedo of pervious road [-] - REAL(r8), intent(in) :: & + real(r8), intent(in) :: & lai, &! leaf area index sai, &! stem area index fv, &! Fraction of tree cover [-] @@ -252,7 +252,7 @@ SUBROUTINE UrbanVegShortwave ( theta, HW, fb, fgper, H, & rho, &! effective rho (lai + sai) tau ! effective tau (lai + sai) - REAL(r8), intent(out) :: & + real(r8), intent(out) :: & fwsun, &! Fraction of sunlit wall [-] sroof(2), &! Urban building roof absorption [-] swsun(2), &! Urban sunlit wall absorption [-] @@ -262,11 +262,11 @@ SUBROUTINE UrbanVegShortwave ( theta, HW, fb, fgper, H, & sveg(2), &! Urban building tree absorption [-] albu(2) ! Urban overall albedo [-] - ! Local variables - !------------------------------------------------- - REAL(r16),parameter:: DD1=1.0_r16 !quad accuracy REAL number + ! Local variables + !------------------------------------------------- + real(r16),parameter:: DD1=1.0_r16 !quad accuracy real number - REAL(r8) :: & + real(r8) :: & W, &! Urban ground average width L, &! Urban building average length HL, &! Ratio of H to L, H/L [-] @@ -319,375 +319,376 @@ SUBROUTINE UrbanVegShortwave ( theta, HW, fb, fgper, H, & Egper, &! Incident radiation on pervious ground [-] Ev ! Incident radiation on trees [-] - ! Radiation transfer matrix and vectors - !------------------------------------------------- - REAL(r8) :: A(5,5) !Radiation transfer matrix - REAL(r8) :: Ainv(5,5) !Inverse of Radiation transfer matrix - REAL(r8) :: B(5) !Vectors of incident radition on each surface - REAL(r8) :: X(5) !Radiation emit from each surface in balance condition - - ! Temporal - REAL(r8) :: fac1, fac2, eb, sumw, ws, wg, ww - - REAL(r8) :: phi_tot !albedo of a single tree - REAL(r8) :: phi_dif !Temporal - REAL(r8) :: pa2 !Temporal - REAL(r8) :: lsai !lai+sai - - ! Claculate urban structure parameters - !------------------------------------------------- - W = H/HW - L = W*sqrt(fb)/(1-sqrt(fb)) - HL = H/L !NOTE: Same as: HL = HW*(1-sqrt(fb))/sqrt(fb) - fg = 1. - fb - - fgimp = 1. - fgper - - ! Calculate transmittion and albedo of tree - !------------------------------------------------- - lsai = (lai+sai)*fv/cos(PI/3)/ShadowTree(fv, PI/3) - Td = tee(DD1*3/8.*lsai) - CALL phi(.true., 3/8.*lsai, tau+rho, tau, rho, phi_tot, phi_dif, pa2) - av = phi_tot - - ! Calculate view factors - !------------------------------------------------- - - ! View factor from sky to wall(sunlit+shaded) and ground - Fsw = ShadowWall_dif(fb/fg, HL) - Fsg = 1 - Fsw - - ! View factor from ground to walls and sky - Fgw = Fsw - Fgs = Fsg - - ! View factor from wall to wall, sky and ground - ! Fws*4*H*L*L/L = Fws*4H/L*fb = Fsw*fg - ! Fws*4HL*fb = Fsw*fg - ! Fws = Fsw*fg/(4HL*fb) - ! adjusted as below: - Fws = Fsw*fg/fb/(2*HL)*0.75 - Fwg = Fsw*fg/fb/(2*HL)*0.25 - Fww = 1 - Fws - Fwg - - ! View factor from tree to walls, ground and sky - !------------------------------------------------- - - Sw = ShadowWall_dif(fb/fg, HL) - Sw_ = ShadowWall_dif(fb/fg, (H-hv)/L) - - !NOTE: fg*(fv/fg - fv/fg * Sw_) - fv_ = fv - fv*Sw_ - Sv = ShadowTree(fv_, PI/3) - - ! Overlapped shadow between tree and building - ! (to groud only) - Svw = Sv * (Sw-Sw_) - - ! convert Sv to ground ratio - Sv = min(1., Sv/fg) - - ! robust check - IF (Sv+Sw-Svw > 1) THEN - Svw = Sv+Sw-1 - ENDIF - - ! Calibrated building ground shadow - Fsv = Sv - Fsvw = Svw - Fsvg = Fsv - Fsvw - - ! View factor from veg to sky and walls above canopy - Fvs = 0.5*(1-Sw_) - Fvw = 0.5*Sw_ - - Sw_ = ShadowWall_dif(fb/fg, hv/L) - fv_ = fv - fv*Sw_ - Sv = ShadowTree(fv_, PI/3) - - ! Overlapped shadow between tree and building - ! (to groud only) - Svw = Sv * (Sw-Sw_) - - ! convert Sv to ground ratio - Sv = min(1., Sv/fg) - - ! robust check - IF (Sv+Sw-Svw > 1) THEN - Svw = Sv+Sw-1 - ENDIF - - ! Calibrated building ground shadow - Fgv = Sv - Fgvw = Svw - Fgvs = Fgv - Fgvw - - ! View factor from veg to sky and walls below+above canopy - Fvg = 0.5*(1-Sw_) - Fvw = 0.5*Sw_ + Fvw - - Fvw = 1 - Fvs - Fvg - - !Fvs = Fsv*fg/min(4*fv,2*fg) - !Fvg = Fgv*fg/min(4*fv,2*fg) - !Fvw = 1 - Fvs - Fvg - - !ws = (phi_tot - phi_dif)/2 - !wg = (phi_tot + phi_dif)/2 - !ww = (phi_tot + phi_dif)/2 - !sumw = Fvs*ws + Fvg*wg + Fvw*ww - !Fvs = Fvs*ws/sumw - !Fvg = Fvg*wg/sumw - !Fvw = Fvw*ww/sumw - - ! Canopy mode: - Fwv = max(fv,0.5*(Fsv+Fgv))*2*fg*Fvw/(4*HL*fb) - Fwv = min(0.8, Fwv) - - fac1 = 1.*hv/H - fac2 = 1.*(H-hv)/H - Fwvw = Fwv/(1 + Fws*fac1/Fww + Fwg*fac2/Fww) - Fwvs = Fws*fac1/Fww*Fwvw - Fwvg = Fwg*fac2/Fww*Fwvw - - ! set upper limit - Fwvw = min(Fww, Fwvw) - Fwvs = min(Fws, Fwvs) - Fwvg = min(Fwg, Fwvg) - - Fwv = Fwvw + Fwvs + Fwvg - - ! View factors with trees - !--------------------------------------------------------- - Fsw_ = Fsw - Fsvw + Fsvw*Td - Fsg_ = Fsg - Fsvg + Fsvg*Td - Fgw_ = Fgw - Fgvw + Fgvw*Td - Fgs_ = Fgs - Fgvs + Fgvs*Td - Fwg_ = Fwg - Fwvg + Fwvg*Td - Fww_ = Fww - Fwvw + Fwvw*Td - Fws_ = Fws - Fwvs + Fwvs*Td - - ! Calculate sunlit wall fraction - !------------------------------------------------- - - ! Builing wall shadow - Sw = ShadowWall_dir(fb/fg, HL, theta) - - Sw_ = Sw; fv_ = fv; - - Sw_ = ShadowWall_dir(fb/fg, (H-hv)/L, theta) - fv_ = fv - fv*Sw_ - - ! Tree shadow (to all area) - Sv = ShadowTree(fv_, theta) - - ! Overlapped shadow between tree and building - ! (to groud only) - Svw = (Sw-Sw_) * Sv - - ! convert Sv to ground ratio - Sv = min(1., Sv/fg) - - ! robust check - IF (Sv+Sw-Svw > 1) THEN - Svw = Sv+Sw-1 - ENDIF - - ! Calibrated building ground shadow - Sw = Sw - Svw - - ! Sunlit/shaded wall fraction - fwsun = 0.5 * (Sw*fg + fb) / (4/PI*fb*HL*tan(theta) + fb) - fwsha = 1. - fwsun - - ! Calculate radiation transfer matrix - ! AX = B - !------------------------------------------------- - A(1,:) = (/1-Fww_*fwsun*awall, -Fww_*fwsun*awall, -Fgw_*fwsun*awall, -Fgw_*fwsun*awall, -Fvw*fwsun*awall/) - A(2,:) = (/ -Fww_*fwsha*awall, 1-Fww_*fwsha*awall, -Fgw_*fwsha*awall, -Fgw_*fwsha*awall, -Fvw*fwsha*awall/) - A(3,:) = (/ -Fwg_*fgimp*agimp, -Fwg_*fgimp*agimp, 1._r8, 0._r8, -Fvg*fgimp*agimp/) - A(4,:) = (/ -Fwg_*fgper*agper, -Fwg_*fgper*agper, 0._r8, 1._r8, -Fvg*fgper*agper/) - A(5,:) = (/ -Fwv*av , -Fwv*av , -Fgv*av , -Fgv*av , 1._r8/) - - ! Inverse of matrix A - Ainv = MatrixInverse(A) - - ! Radiation transfer for incident direct case - !------------------------------------------------- - - ! Incident radiation on sunlit/shaded wall and - ! impervious/pervious ground - Ewsun = Sw - Ewsha = Svw*Td - Eg = 1-Sw-Sv+(Sv-Svw)*Td - Egimp = Eg*fgimp - Egper = Eg*fgper - Ev = Sv - - ! Vector of first scattering radiatioin on each surface - B(:) = (/Ewsun*awall, Ewsha*awall, Egimp*agimp, Egper*agper, Ev*av/) - - ! Matrix computing to revole multiple reflections - X = matmul(Ainv, B) - - !------------------------------------------------- - ! SAVE results for output - !------------------------------------------------- - - ! Radiation absorption by each surface - !NOTE: for 3D, absorption per unit area: 4*HL*fb/fg - ! for canyon: absorption per unit area: 2*HW - swsun(1) = X(1)/awall*(1-awall)!/(4*fwsun*HL*fb/fg) - swsha(1) = X(2)/awall*(1-awall)!/(4*fwsha*HL*fb/fg) - sgimp(1) = X(3)/agimp*(1-agimp)!/fgimp - sgper(1) = X(4)/agper*(1-agper)!/fgper - sveg (1) = X(5)/av *(1-av-Td)!/(fv/fg) + ! Radiation transfer matrix and vectors + !------------------------------------------------- + real(r8) :: A(5,5) !Radiation transfer matrix + real(r8) :: Ainv(5,5) !Inverse of Radiation transfer matrix + real(r8) :: B(5) !Vectors of incident radition on each surface + real(r8) :: X(5) !Radiation emit from each surface in balance condition + + ! Temporal + real(r8) :: fac1, fac2, eb, sumw, ws, wg, ww + + real(r8) :: phi_tot !albedo of a single tree + real(r8) :: phi_dif !Temporal + real(r8) :: pa2 !Temporal + real(r8) :: lsai !lai+sai + + ! Claculate urban structure parameters + !------------------------------------------------- + W = H/HW + L = W*sqrt(fb)/(1-sqrt(fb)) + HL = H/L !NOTE: Same as: HL = HW*(1-sqrt(fb))/sqrt(fb) + fg = 1. - fb + + fgimp = 1. - fgper + + ! Calculate transmittion and albedo of tree + !------------------------------------------------- + lsai = (lai+sai)*fv/cos(PI/3)/ShadowTree(fv, PI/3) + Td = tee(DD1*3/8.*lsai) + CALL phi(.true., 3/8.*lsai, tau+rho, tau, rho, phi_tot, phi_dif, pa2) + av = phi_tot + + ! Calculate view factors + !------------------------------------------------- + + ! View factor from sky to wall(sunlit+shaded) and ground + Fsw = ShadowWall_dif(fb/fg, HL) + Fsg = 1 - Fsw + + ! View factor from ground to walls and sky + Fgw = Fsw + Fgs = Fsg + + ! View factor from wall to wall, sky and ground + ! Fws*4*H*L*L/L = Fws*4H/L*fb = Fsw*fg + ! Fws*4HL*fb = Fsw*fg + ! Fws = Fsw*fg/(4HL*fb) + ! adjusted as below: + Fws = Fsw*fg/fb/(2*HL)*0.75 + Fwg = Fsw*fg/fb/(2*HL)*0.25 + Fww = 1 - Fws - Fwg + + ! View factor from tree to walls, ground and sky + !------------------------------------------------- + + Sw = ShadowWall_dif(fb/fg, HL) + Sw_ = ShadowWall_dif(fb/fg, (H-hv)/L) + + !NOTE: fg*(fv/fg - fv/fg * Sw_) + fv_ = fv - fv*Sw_ + Sv = ShadowTree(fv_, PI/3) + + ! Overlapped shadow between tree and building + ! (to groud only) + Svw = Sv * (Sw-Sw_) + + ! convert Sv to ground ratio + Sv = min(1., Sv/fg) + + ! robust check + IF (Sv+Sw-Svw > 1) THEN + Svw = Sv+Sw-1 + ENDIF + + ! Calibrated building ground shadow + Fsv = Sv + Fsvw = Svw + Fsvg = Fsv - Fsvw + + ! View factor from veg to sky and walls above canopy + Fvs = 0.5*(1-Sw_) + Fvw = 0.5*Sw_ + + Sw_ = ShadowWall_dif(fb/fg, hv/L) + fv_ = fv - fv*Sw_ + Sv = ShadowTree(fv_, PI/3) + + ! Overlapped shadow between tree and building + ! (to groud only) + Svw = Sv * (Sw-Sw_) + + ! convert Sv to ground ratio + Sv = min(1., Sv/fg) + + ! robust check + IF (Sv+Sw-Svw > 1) THEN + Svw = Sv+Sw-1 + ENDIF + + ! Calibrated building ground shadow + Fgv = Sv + Fgvw = Svw + Fgvs = Fgv - Fgvw + + ! View factor from veg to sky and walls below+above canopy + Fvg = 0.5*(1-Sw_) + Fvw = 0.5*Sw_ + Fvw + + Fvw = 1 - Fvs - Fvg + + !Fvs = Fsv*fg/min(4*fv,2*fg) + !Fvg = Fgv*fg/min(4*fv,2*fg) + !Fvw = 1 - Fvs - Fvg + + !ws = (phi_tot - phi_dif)/2 + !wg = (phi_tot + phi_dif)/2 + !ww = (phi_tot + phi_dif)/2 + !sumw = Fvs*ws + Fvg*wg + Fvw*ww + !Fvs = Fvs*ws/sumw + !Fvg = Fvg*wg/sumw + !Fvw = Fvw*ww/sumw + + ! Canopy mode: + Fwv = max(fv,0.5*(Fsv+Fgv))*2*fg*Fvw/(4*HL*fb) + Fwv = min(0.8, Fwv) + + fac1 = 1.*hv/H + fac2 = 1.*(H-hv)/H + Fwvw = Fwv/(1 + Fws*fac1/Fww + Fwg*fac2/Fww) + Fwvs = Fws*fac1/Fww*Fwvw + Fwvg = Fwg*fac2/Fww*Fwvw + + ! set upper limit + Fwvw = min(Fww, Fwvw) + Fwvs = min(Fws, Fwvs) + Fwvg = min(Fwg, Fwvg) + + Fwv = Fwvw + Fwvs + Fwvg + + ! View factors with trees + !--------------------------------------------------------- + Fsw_ = Fsw - Fsvw + Fsvw*Td + Fsg_ = Fsg - Fsvg + Fsvg*Td + Fgw_ = Fgw - Fgvw + Fgvw*Td + Fgs_ = Fgs - Fgvs + Fgvs*Td + Fwg_ = Fwg - Fwvg + Fwvg*Td + Fww_ = Fww - Fwvw + Fwvw*Td + Fws_ = Fws - Fwvs + Fwvs*Td + + ! Calculate sunlit wall fraction + !------------------------------------------------- + + ! Builing wall shadow + Sw = ShadowWall_dir(fb/fg, HL, theta) + + Sw_ = Sw; fv_ = fv; + + Sw_ = ShadowWall_dir(fb/fg, (H-hv)/L, theta) + fv_ = fv - fv*Sw_ + + ! Tree shadow (to all area) + Sv = ShadowTree(fv_, theta) + + ! Overlapped shadow between tree and building + ! (to groud only) + Svw = (Sw-Sw_) * Sv + + ! convert Sv to ground ratio + Sv = min(1., Sv/fg) + + ! robust check + IF (Sv+Sw-Svw > 1) THEN + Svw = Sv+Sw-1 + ENDIF + + ! Calibrated building ground shadow + Sw = Sw - Svw + + ! Sunlit/shaded wall fraction + fwsun = 0.5 * (Sw*fg + fb) / (4/PI*fb*HL*tan(theta) + fb) + fwsha = 1. - fwsun + + ! Calculate radiation transfer matrix + ! AX = B + !------------------------------------------------- + A(1,:) = (/1-Fww_*fwsun*awall, -Fww_*fwsun*awall, -Fgw_*fwsun*awall, -Fgw_*fwsun*awall, -Fvw*fwsun*awall/) + A(2,:) = (/ -Fww_*fwsha*awall, 1-Fww_*fwsha*awall, -Fgw_*fwsha*awall, -Fgw_*fwsha*awall, -Fvw*fwsha*awall/) + A(3,:) = (/ -Fwg_*fgimp*agimp, -Fwg_*fgimp*agimp, 1._r8, 0._r8, -Fvg*fgimp*agimp/) + A(4,:) = (/ -Fwg_*fgper*agper, -Fwg_*fgper*agper, 0._r8, 1._r8, -Fvg*fgper*agper/) + A(5,:) = (/ -Fwv*av , -Fwv*av , -Fgv*av , -Fgv*av , 1._r8/) + + ! Inverse of matrix A + Ainv = MatrixInverse(A) + + ! Radiation transfer for incident direct case + !------------------------------------------------- + + ! Incident radiation on sunlit/shaded wall and + ! impervious/pervious ground + Ewsun = Sw + Ewsha = Svw*Td + Eg = 1-Sw-Sv+(Sv-Svw)*Td + Egimp = Eg*fgimp + Egper = Eg*fgper + Ev = Sv + + ! Vector of first scattering radiatioin on each surface + B(:) = (/Ewsun*awall, Ewsha*awall, Egimp*agimp, Egper*agper, Ev*av/) + + ! Matrix computing to revole multiple reflections + X = matmul(Ainv, B) + + !------------------------------------------------- + ! SAVE results for output + !------------------------------------------------- + + ! Radiation absorption by each surface + !NOTE: for 3D, absorption per unit area: 4*HL*fb/fg + ! for canyon: absorption per unit area: 2*HW + swsun(1) = X(1)/awall*(1-awall)!/(4*fwsun*HL*fb/fg) + swsha(1) = X(2)/awall*(1-awall)!/(4*fwsha*HL*fb/fg) + sgimp(1) = X(3)/agimp*(1-agimp)!/fgimp + sgper(1) = X(4)/agper*(1-agper)!/fgper + sveg (1) = X(5)/av *(1-av-Td)!/(fv/fg) - ! albedo of urban canopy - albu(1) = X(1)*Fws_ + X(2)*Fws_ + X(3)*Fgs_ + X(4)*Fgs_ + X(5)*Fvs + ! albedo of urban canopy + albu(1) = X(1)*Fws_ + X(2)*Fws_ + X(3)*Fgs_ + X(4)*Fgs_ + X(5)*Fvs - ! Energy balance check - eb = swsun(1) + swsha(1) + sgimp(1) + sgper(1) + sveg(1) + albu(1) - IF (abs(eb-1) > 1e-6) THEN - print *, "Direct tree - Energy Balance Check error!", eb-1 - ENDIF + ! Energy balance check + eb = swsun(1) + swsha(1) + sgimp(1) + sgper(1) + sveg(1) + albu(1) + IF (abs(eb-1) > 1e-6) THEN + print *, "Direct tree - Energy Balance Check error!", eb-1 + ENDIF - ! Radiation transfer for incident diffuse case - !------------------------------------------------- + ! Radiation transfer for incident diffuse case + !------------------------------------------------- - ! Incident radiation on sunlit/shaded wall and - ! impervious/pervious ground - Ewsun = Fsw_*fwsun - Ewsha = Fsw_*fwsha - Eg = Fsg_ - Egimp = Eg*fgimp - Egper = Eg*fgper - Ev = Fsv + ! Incident radiation on sunlit/shaded wall and + ! impervious/pervious ground + Ewsun = Fsw_*fwsun + Ewsha = Fsw_*fwsha + Eg = Fsg_ + Egimp = Eg*fgimp + Egper = Eg*fgper + Ev = Fsv - ! Vector of first scattering radiatioin on each surface - B(:) = (/Ewsun*awall, Ewsha*awall, Egimp*agimp, Egper*agper, Ev*av/) + ! Vector of first scattering radiatioin on each surface + B(:) = (/Ewsun*awall, Ewsha*awall, Egimp*agimp, Egper*agper, Ev*av/) - ! Equation solve - X = matmul(Ainv, B) + ! Equation solve + X = matmul(Ainv, B) - ! Radiation absorption by each surface - !NOTE: for 3D, absorption per unit area: 4*HL*fb/fg - ! for canyon: aborption per unit area: 2*HW - swsun(2) = X(1)/awall*(1-awall)!/(4*fwsun*HL*fb/fg) - swsha(2) = X(2)/awall*(1-awall)!/(4*fwsha*HL*fb/fg) - sgimp(2) = X(3)/agimp*(1-agimp)!/fgimp - sgper(2) = X(4)/agper*(1-agper)!/fgper - sveg (2) = X(5)/ av*(1-av-Td)!/(fv/fg) + ! Radiation absorption by each surface + !NOTE: for 3D, absorption per unit area: 4*HL*fb/fg + ! for canyon: aborption per unit area: 2*HW + swsun(2) = X(1)/awall*(1-awall)!/(4*fwsun*HL*fb/fg) + swsha(2) = X(2)/awall*(1-awall)!/(4*fwsha*HL*fb/fg) + sgimp(2) = X(3)/agimp*(1-agimp)!/fgimp + sgper(2) = X(4)/agper*(1-agper)!/fgper + sveg (2) = X(5)/ av*(1-av-Td)!/(fv/fg) - ! albedo of urban canopy - albu(2) = X(1)*Fws_ + X(2)*Fws_ + X(3)*Fgs_ + X(4)*Fgs_ + X(5)*Fvs + ! albedo of urban canopy + albu(2) = X(1)*Fws_ + X(2)*Fws_ + X(3)*Fgs_ + X(4)*Fgs_ + X(5)*Fvs - ! Energy balance check - eb = swsun(2) + swsha(2) + sgimp(2) + sgper(2) + sveg(2) + albu(2) - IF (abs(eb-1) > 1e-6) THEN - print *, "Diffuse tree - Energy Balance Check error!", eb-1 - ENDIF + ! Energy balance check + eb = swsun(2) + swsha(2) + sgimp(2) + sgper(2) + sveg(2) + albu(2) + IF (abs(eb-1) > 1e-6) THEN + print *, "Diffuse tree - Energy Balance Check error!", eb-1 + ENDIF - ! convert to per unit area absorption - IF (fb > 0.) THEN - swsun = swsun/(4*fwsun*HL*fb)*fg - swsha = swsha/(4*fwsha*HL*fb)*fg - ENDIF - IF (fgimp > 0.) sgimp = sgimp/fgimp - IF (fgper > 0.) sgper = sgper/fgper - IF ( fv > 0.) sveg = sveg/fv*fg - - ! roof absorption - sroof = 1. - aroof + ! convert to per unit area absorption + IF (fb > 0.) THEN + swsun = swsun/(4*fwsun*HL*fb)*fg + swsha = swsha/(4*fwsha*HL*fb)*fg + ENDIF + IF (fgimp > 0.) sgimp = sgimp/fgimp + IF (fgper > 0.) sgper = sgper/fgper + IF ( fv > 0.) sveg = sveg/fv*fg - ! albedo accout for both roof and urban's wall and ground - albu = aroof*fb + albu*fg + ! roof absorption + sroof = 1. - aroof - END SUBROUTINE UrbanVegShortwave + ! albedo accout for both roof and urban's wall and ground + albu = aroof*fb + albu*fg - !------------------------------------------------- - ! claculate shadow of wall for incident direct radiation - FUNCTION ShadowWall_dir(f, HL, theta) result(Sw) + END SUBROUTINE UrbanVegShortwave - IMPLICIT NONE + !------------------------------------------------- + ! claculate shadow of wall for incident direct radiation + FUNCTION ShadowWall_dir(f, HL, theta) result(Sw) - REAL(r8), intent(IN) :: f - REAL(r8), intent(IN) :: HL - REAL(r8), intent(IN) :: theta + IMPLICIT NONE - REAL(r8) :: Sw + real(r8), intent(in) :: f + real(r8), intent(in) :: HL + real(r8), intent(in) :: theta - Sw = 1 - exp( -4/PI*f*HL*tan(theta) ) + real(r8) :: Sw - END FUNCTION ShadowWall_dir + Sw = 1 - exp( -4/PI*f*HL*tan(theta) ) - !------------------------------------------------- - ! claculate shadow of wall for incident diffuse radiation - FUNCTION ShadowWall_dif(f, HL) result(Sw) + END FUNCTION ShadowWall_dir - IMPLICIT NONE + !------------------------------------------------- + ! claculate shadow of wall for incident diffuse radiation + FUNCTION ShadowWall_dif(f, HL) result(Sw) - REAL(r8), intent(IN) :: f - REAL(r8), intent(IN) :: HL + IMPLICIT NONE - REAL(r8) :: Sw + real(r8), intent(in) :: f + real(r8), intent(in) :: HL - Sw = 1 - exp( -4/PI*f*HL*tan( (53-sqrt(f*HL*100))/180*PI ) ) + real(r8) :: Sw - END FUNCTION ShadowWall_dif + Sw = 1 - exp( -4/PI*f*HL*tan( (53-sqrt(f*HL*100))/180*PI ) ) - !------------------------------------------------- - ! claculate shadow of tree - FUNCTION ShadowTree(f, theta) result(Sv) + END FUNCTION ShadowWall_dif - IMPLICIT NONE + !------------------------------------------------- + ! claculate shadow of tree + FUNCTION ShadowTree(f, theta) result(Sv) - REAL(r8), intent(IN) :: f - REAL(r8), intent(IN) :: theta + IMPLICIT NONE - REAL(r8) :: mu - REAL(r8) :: Sv + real(r8), intent(in) :: f + real(r8), intent(in) :: theta - mu = cos(theta) - Sv = max( f, (1.-exp(-f/mu))/(1.-f*exp(-1./mu)) ) + real(r8) :: mu + real(r8) :: Sv - END FUNCTION ShadowTree + mu = cos(theta) + Sv = max( f, (1.-exp(-f/mu))/(1.-f*exp(-1./mu)) ) + END FUNCTION ShadowTree - !------------------------------------------------- - ! Returns the inverse of a matrix calculated by finding the LU - ! decomposition. Depends on LAPACK. - FUNCTION MatrixInverse(A) result(Ainv) - IMPLICIT NONE + !------------------------------------------------- + ! Returns the inverse of a matrix calculated by finding the LU + ! decomposition. Depends on LAPACK. + FUNCTION MatrixInverse(A) result(Ainv) - REAL(r8), dimension(:,:), intent(in) :: A - REAL(r8), dimension(size(A,1),size(A,2)) :: Ainv - REAL(r8), dimension(size(A,1)) :: work !work array for LAPACK - INTEGER, dimension(size(A,1)) :: ipiv !pivot indices - INTEGER :: n, info + IMPLICIT NONE - ! External procedures defined in LAPACK - external DGETRF - external DGETRI + real(r8), dimension(:,:), intent(in) :: A + real(r8), dimension(size(A,1),size(A,2)) :: Ainv + real(r8), dimension(size(A,1)) :: work !work array for LAPACK + integer, dimension(size(A,1)) :: ipiv !pivot indices + integer :: n, info - ! Store A in Ainv to prevent it from being overwritten by LAPACK - Ainv = A - n = size(A,1) + ! External procedures defined in LAPACK + external DGETRF + external DGETRI - ! DGETRF computes an LU factorization of a general M-by-N matrix A - ! using partial pivoting with row interchanges. - CALL DGETRF(n, n, Ainv, n, ipiv, info) - IF (info /= 0) THEN - CALL CoLM_stop('Matrix is numerically singular!') - ENDIF + ! Store A in Ainv to prevent it from being overwritten by LAPACK + Ainv = A + n = size(A,1) - ! DGETRI computes the inverse of a matrix using the LU factorization - ! computed by DGETRF. - CALL DGETRI(n, Ainv, n, ipiv, work, n, info) - IF (info /= 0) THEN - CALL CoLM_stop('Matrix inversion failed!') - ENDIF - END FUNCTION MatrixInverse + ! DGETRF computes an LU factorization of a general M-by-N matrix A + ! using partial pivoting with row interchanges. + CALL DGETRF(n, n, Ainv, n, ipiv, info) + IF (info /= 0) THEN + CALL CoLM_stop('Matrix is numerically singular!') + ENDIF + + ! DGETRI computes the inverse of a matrix using the LU factorization + ! computed by DGETRF. + CALL DGETRI(n, Ainv, n, ipiv, work, n, info) + IF (info /= 0) THEN + CALL CoLM_stop('Matrix inversion failed!') + ENDIF + + END FUNCTION MatrixInverse END MODULE MOD_Urban_Shortwave diff --git a/main/URBAN/MOD_Urban_Thermal.F90 b/main/URBAN/MOD_Urban_Thermal.F90 index a95d9f50..3cfe0976 100644 --- a/main/URBAN/MOD_Urban_Thermal.F90 +++ b/main/URBAN/MOD_Urban_Thermal.F90 @@ -2,17 +2,17 @@ MODULE MOD_Urban_Thermal - USE MOD_Precision - IMPLICIT NONE - SAVE - PRIVATE + USE MOD_Precision + IMPLICIT NONE + SAVE + PRIVATE - PUBLIC :: UrbanTHERMAL + PUBLIC :: UrbanTHERMAL CONTAINS - SUBROUTINE UrbanTHERMAL ( & + SUBROUTINE UrbanTHERMAL ( & ! model running information ipatch ,patchtype ,lbr ,lbi ,& @@ -103,30 +103,30 @@ SUBROUTINE UrbanTHERMAL ( & ! !======================================================================= - USE MOD_Precision - USE MOD_Vars_Global - USE MOD_Const_Physical, only: denh2o,roverg,hvap,hsub,rgas,cpair,& - stefnc,denice,tfrz,vonkar,grav - USE MOD_Urban_Shortwave - USE MOD_Urban_Longwave - USE MOD_Urban_GroundFlux - USE MOD_Urban_Flux - USE MOD_Urban_RoofTemperature - USE MOD_Urban_WallTemperature - USE MOD_Urban_PerviousTemperature - USE MOD_Urban_ImperviousTemperature - USE MOD_Lake - USE MOD_Urban_BEM - USE MOD_Urban_LUCY, only: LUCY - USE MOD_Eroot, only: eroot + USE MOD_Precision + USE MOD_Vars_Global + USE MOD_Const_Physical, only: denh2o,roverg,hvap,hsub,rgas,cpair,& + stefnc,denice,tfrz,vonkar,grav + USE MOD_Urban_Shortwave + USE MOD_Urban_Longwave + USE MOD_Urban_GroundFlux + USE MOD_Urban_Flux + USE MOD_Urban_RoofTemperature + USE MOD_Urban_WallTemperature + USE MOD_Urban_PerviousTemperature + USE MOD_Urban_ImperviousTemperature + USE MOD_Lake + USE MOD_Urban_BEM + USE MOD_Urban_LUCY, only: LUCY + USE MOD_Eroot, only: eroot #ifdef vanGenuchten_Mualem_SOIL_MODEL - USE MOD_Hydro_SoilFunction, only : soil_psi_from_vliq + USE MOD_Hydro_SoilFunction, only : soil_psi_from_vliq #endif - IMPLICIT NONE + IMPLICIT NONE !---------------------Argument------------------------------------------ - INTEGER, intent(in) :: & + integer, intent(in) :: & idate(3) ,& ipatch ,&! patch index patchtype ,&! land patch type (0=soil, 1=urban or built-up, 2=wetland, @@ -136,11 +136,11 @@ SUBROUTINE UrbanTHERMAL ( & lbp ,&! lower bound of array lbl ! lower bound of array - REAL(r8), intent(in) :: & + real(r8), intent(in) :: & deltim ,&! seconds in a time step [second] patchlatr ! latitude in radians - REAL(r8), intent(in) :: & + real(r8), intent(in) :: & patchlonr , &! longitude of patch [radian] fix_holiday(365), &! Fixed public holidays, holiday(0) or workday(1) week_holiday(7) , &! week holidays @@ -150,7 +150,7 @@ SUBROUTINE UrbanTHERMAL ( & pop_den , &! population density vehicle(3) ! vehicle numbers per thousand people - REAL(r8), intent(in) :: & + real(r8), intent(in) :: & ! atmospherical variables and observational height forc_hgt_u ,&! observational height of wind [m] forc_hgt_t ,&! observational height of temperature [m] @@ -178,7 +178,7 @@ SUBROUTINE UrbanTHERMAL ( & sabgper ,&! absorbed shortwave radiation by ground snow [W/m2] sablake ! absorbed shortwave radiation by lake [W/m2] - REAL(r8), intent(in) :: & + real(r8), intent(in) :: & froof ,&! roof fractional cover [-] flake ,&! urban lake fractional cover [-] hroof ,&! average building height [m] @@ -270,7 +270,7 @@ SUBROUTINE UrbanTHERMAL ( & binter ,&! conductance-photosynthesis intercept extkn ! coefficient of leaf nitrogen allocation - REAL(r8), intent(in) :: & + real(r8), intent(in) :: & fsno_roof ,&! fraction of ground covered by snow fsno_gimp ,&! fraction of ground covered by snow fsno_gper ,&! fraction of ground covered by snow @@ -283,9 +283,9 @@ SUBROUTINE UrbanTHERMAL ( & sigf ,&! fraction of veg cover, excluding snow-covered veg [-] extkd ! diffuse and scattered diffuse PAR extinction coefficient - real(r8), INTENT(in) :: hpbl ! atmospheric boundary layer height [m] + real(r8), intent(in) :: hpbl ! atmospheric boundary layer height [m] - REAL(r8), intent(inout) :: & + real(r8), intent(inout) :: & fwsun ,&! fraction of sunlit wall [-] lwsun ,&! net longwave radiation of sunlit wall lwsha ,&! net longwave radiation of shaded wall @@ -336,7 +336,7 @@ SUBROUTINE UrbanTHERMAL ( & meta ! flux from metabolic ! Output - REAL(r8), intent(out) :: & + real(r8), intent(out) :: & taux ,&! wind stress: E-W [kg/m/s**2] tauy ,&! wind stress: N-S [kg/m/s**2] fsena ,&! sensible heat from canopy height to atmosphere [W/m2] @@ -382,13 +382,13 @@ SUBROUTINE UrbanTHERMAL ( & qfros_gper ,&! surface dew added to snow pack (mm h2o /s) [+] qfros_lake ! surface dew added to snow pack (mm h2o /s) [+] - INTEGER, intent(out) :: & + integer, intent(out) :: & imelt_roof(lbr:nl_roof) ,&! flag for melting or freezing [-] imelt_gimp(lbi:nl_soil) ,&! flag for melting or freezing [-] imelt_gper(lbp:nl_soil) ,&! flag for melting or freezing [-] imelt_lake(maxsnl+1:nl_soil) ! flag for melting or freezing [-] - REAL(r8), intent(out) :: & + real(r8), intent(out) :: & sm_roof ,&! rate of snowmelt [kg/(m2 s)] sm_gimp ,&! rate of snowmelt [kg/(m2 s)] sm_gper ,&! rate of snowmelt [kg/(m2 s)] @@ -417,17 +417,17 @@ SUBROUTINE UrbanTHERMAL ( & fq ! integral of profile function for moisture ! SNICAR model variables - REAL(r8), intent(in) :: sabg_lyr(lbp:1) !snow layer aborption - REAL(r8), intent(out) :: snofrz (lbp:0) !snow freezing rate (col,lyr) [kg m-2 s-1] + real(r8), intent(in) :: sabg_lyr(lbp:1) !snow layer aborption + real(r8), intent(out) :: snofrz (lbp:0) !snow freezing rate (col,lyr) [kg m-2 s-1] ! END SNICAR model variables !---------------------Local Variables----------------------------------- - INTEGER :: nurb ! number of aboveground urban components [-] + integer :: nurb ! number of aboveground urban components [-] - LOGICAL :: doveg ! run model with vegetation + logical :: doveg ! run model with vegetation - REAL(r8) :: & + real(r8) :: & fg ,&! ground fraction ( impervious + soil + snow ) fsenroof ,&! sensible heat flux from roof [W/m2] fsenwsun ,&! sensible heat flux from sunlit wall [W/m2] @@ -519,7 +519,7 @@ SUBROUTINE UrbanTHERMAL ( & wx ,&! patitial volume of ice and water of surface layer xmf ! total latent heat of phase change of ground water - REAL(r8) :: & + real(r8) :: & taux_lake ,&! wind stress: E-W [kg/m/s**2] tauy_lake ,&! wind stress: N-S [kg/m/s**2] fsena_lake ,&! sensible heat from canopy height to atmosphere [W/m2] @@ -544,20 +544,20 @@ SUBROUTINE UrbanTHERMAL ( & fh_lake ,&! integral of profile function for heat fq_lake ! integral of profile function for moisture - REAL(r8) :: z0m_g,z0h_g,zol_g,obu_g,ustar_g,qstar_g,tstar_g - REAL(r8) :: fm10m,fm_g,fh_g,fq_g,fh2m,fq2m,um,obu,eb - - ! defination for urban related - REAL(r8), allocatable :: Ainv(:,:) !Inverse of Radiation transfer matrix - REAL(r8), allocatable :: X(:) !solution - REAL(r8), allocatable :: dX(:) !solution - REAL(r8), allocatable :: B(:) !Vectors of incident radition on each surface - REAL(r8), allocatable :: B1(:) !Vectors of incident radition on each surface - REAL(r8), allocatable :: dBdT(:) !Vectors of incident radition on each surface - REAL(r8), allocatable :: dT(:) !Vectors of incident radition on each surface - REAL(r8), allocatable :: SkyVF(:) !View factor to sky - REAL(r8), allocatable :: VegVF(:) !View factor to vegetation - REAL(r8), allocatable :: fcover(:) !fractional cover of roof, wall, ground and veg + real(r8) :: z0m_g,z0h_g,zol_g,obu_g,ustar_g,qstar_g,tstar_g + real(r8) :: fm10m,fm_g,fh_g,fq_g,fh2m,fq2m,um,obu,eb + + ! defination for urban related + real(r8), allocatable :: Ainv(:,:) !Inverse of Radiation transfer matrix + real(r8), allocatable :: X(:) !solution + real(r8), allocatable :: dX(:) !solution + real(r8), allocatable :: B(:) !Vectors of incident radition on each surface + real(r8), allocatable :: B1(:) !Vectors of incident radition on each surface + real(r8), allocatable :: dBdT(:) !Vectors of incident radition on each surface + real(r8), allocatable :: dT(:) !Vectors of incident radition on each surface + real(r8), allocatable :: SkyVF(:) !View factor to sky + real(r8), allocatable :: VegVF(:) !View factor to vegetation + real(r8), allocatable :: fcover(:) !fractional cover of roof, wall, ground and veg !======================================================================= ! [1] Initial set and propositional variables @@ -1045,7 +1045,7 @@ SUBROUTINE UrbanTHERMAL ( & fevpgper = fevpgper + dT(4)*cgperl ! calculation of evaporative potential; flux in kg m-2 s-1. -! egidif holds the excess energy if all water is evaporated +! egidif holds the excess energy IF all water is evaporated ! during the timestep. this energy is later added to the sensible heat flux. ! --- for pervious ground --- @@ -1355,7 +1355,7 @@ SUBROUTINE UrbanTHERMAL ( & deallocate ( fcover ) - END SUBROUTINE UrbanTHERMAL + END SUBROUTINE UrbanTHERMAL END MODULE MOD_Urban_Thermal ! ---------- EOP ------------ diff --git a/main/URBAN/MOD_Urban_Vars_1DFluxes.F90 b/main/URBAN/MOD_Urban_Vars_1DFluxes.F90 index bd465eef..bdea1f42 100644 --- a/main/URBAN/MOD_Urban_Vars_1DFluxes.F90 +++ b/main/URBAN/MOD_Urban_Vars_1DFluxes.F90 @@ -7,35 +7,35 @@ MODULE MOD_Urban_Vars_1DFluxes ! Created by Hua Yuan, 12/2020 ! ------------------------------- - USE MOD_Precision - IMPLICIT NONE - SAVE + USE MOD_Precision + IMPLICIT NONE + SAVE ! ----------------------------------------------------------------- ! Fluxes ! ----------------------------------------------------------------- - !REAL(r8), allocatable :: sabroof (:) !solar absorption of roof [W/m2] - !REAL(r8), allocatable :: sabwsun (:) !solar absorption of sunlit wall [W/m2] - !REAL(r8), allocatable :: sabwsha (:) !solar absorption of shaded wall [W/m2] - !REAL(r8), allocatable :: sabgimp (:) !solar absorption of impervious [W/m2] - !REAL(r8), allocatable :: sabgper (:) !solar absorption of pervious [W/m2] - - REAL(r8), allocatable :: fsen_roof (:) !sensible heat flux from roof [W/m2] - REAL(r8), allocatable :: fsen_wsun (:) !sensible heat flux from sunlit wall [W/m2] - REAL(r8), allocatable :: fsen_wsha (:) !sensible heat flux from shaded wall [W/m2] - REAL(r8), allocatable :: fsen_gimp (:) !sensible heat flux from impervious road [W/m2] - REAL(r8), allocatable :: fsen_gper (:) !sensible heat flux from pervious road [W/m2] - REAL(r8), allocatable :: fsen_urbl (:) !sensible heat flux from urban vegetation [W/m2] - - REAL(r8), allocatable :: lfevp_roof (:) !latent heat flux from roof [W/m2] - REAL(r8), allocatable :: lfevp_gimp (:) !latent heat flux from impervious road [W/m2] - REAL(r8), allocatable :: lfevp_gper (:) !latent heat flux from pervious road [W/m2] - REAL(r8), allocatable :: lfevp_urbl (:) !latent heat flux from urban vegetation [W/m2] + !real(r8), allocatable :: sabroof (:) !solar absorption of roof [W/m2] + !real(r8), allocatable :: sabwsun (:) !solar absorption of sunlit wall [W/m2] + !real(r8), allocatable :: sabwsha (:) !solar absorption of shaded wall [W/m2] + !real(r8), allocatable :: sabgimp (:) !solar absorption of impervious [W/m2] + !real(r8), allocatable :: sabgper (:) !solar absorption of pervious [W/m2] + + real(r8), allocatable :: fsen_roof (:) !sensible heat flux from roof [W/m2] + real(r8), allocatable :: fsen_wsun (:) !sensible heat flux from sunlit wall [W/m2] + real(r8), allocatable :: fsen_wsha (:) !sensible heat flux from shaded wall [W/m2] + real(r8), allocatable :: fsen_gimp (:) !sensible heat flux from impervious road [W/m2] + real(r8), allocatable :: fsen_gper (:) !sensible heat flux from pervious road [W/m2] + real(r8), allocatable :: fsen_urbl (:) !sensible heat flux from urban vegetation [W/m2] + + real(r8), allocatable :: lfevp_roof (:) !latent heat flux from roof [W/m2] + real(r8), allocatable :: lfevp_gimp (:) !latent heat flux from impervious road [W/m2] + real(r8), allocatable :: lfevp_gper (:) !latent heat flux from pervious road [W/m2] + real(r8), allocatable :: lfevp_urbl (:) !latent heat flux from urban vegetation [W/m2] ! PUBLIC MEMBER FUNCTIONS: - PUBLIC :: allocate_1D_UrbanFluxes - PUBLIC :: deallocate_1D_UrbanFluxes - PUBLIC :: set_1D_UrbanFluxes + PUBLIC :: allocate_1D_UrbanFluxes + PUBLIC :: deallocate_1D_UrbanFluxes + PUBLIC :: set_1D_UrbanFluxes ! PRIVATE MEMBER FUNCTIONS: @@ -45,46 +45,46 @@ MODULE MOD_Urban_Vars_1DFluxes !----------------------------------------------------------------------- - SUBROUTINE allocate_1D_UrbanFluxes - ! -------------------------------------------------------------------- - ! Allocates memory for CLM 1d [numurban] variables - ! -------------------------------------------------------------------- - - USE MOD_Precision - USE MOD_SPMD_Task - USE MOD_LandUrban - USE MOD_Vars_Global, only : spval - IMPLICIT NONE - - IF (p_is_worker) THEN - IF (numurban > 0) THEN - !allocate (sabroof (numurban)) - !allocate (sabwsun (numurban)) - !allocate (sabwsha (numurban)) - !allocate (sabgimp (numurban)) - !allocate (sabgper (numurban)) - allocate (fsen_roof (numurban)) ; fsen_roof (:) = spval - allocate (fsen_wsun (numurban)) ; fsen_wsun (:) = spval - allocate (fsen_wsha (numurban)) ; fsen_wsha (:) = spval - allocate (fsen_gimp (numurban)) ; fsen_gimp (:) = spval - allocate (fsen_gper (numurban)) ; fsen_gper (:) = spval - allocate (fsen_urbl (numurban)) ; fsen_urbl (:) = spval - - allocate (lfevp_roof (numurban)) ; lfevp_roof (:) = spval - allocate (lfevp_gimp (numurban)) ; lfevp_gimp (:) = spval - allocate (lfevp_gper (numurban)) ; lfevp_gper (:) = spval - allocate (lfevp_urbl (numurban)) ; lfevp_urbl (:) = spval - ENDIF - ENDIF + SUBROUTINE allocate_1D_UrbanFluxes + ! -------------------------------------------------------------------- + ! Allocates memory for CLM 1d [numurban] variables + ! -------------------------------------------------------------------- - END SUBROUTINE allocate_1D_UrbanFluxes + USE MOD_Precision + USE MOD_SPMD_Task + USE MOD_LandUrban + USE MOD_Vars_Global, only : spval + IMPLICIT NONE - SUBROUTINE deallocate_1D_UrbanFluxes - ! -------------------------------------------------------------------- - ! deallocates memory for CLM 1d [numurban] variables - ! -------------------------------------------------------------------- - USE MOD_SPMD_Task - USE MOD_LandUrban + IF (p_is_worker) THEN + IF (numurban > 0) THEN + !allocate (sabroof (numurban)) + !allocate (sabwsun (numurban)) + !allocate (sabwsha (numurban)) + !allocate (sabgimp (numurban)) + !allocate (sabgper (numurban)) + allocate (fsen_roof (numurban)) ; fsen_roof (:) = spval + allocate (fsen_wsun (numurban)) ; fsen_wsun (:) = spval + allocate (fsen_wsha (numurban)) ; fsen_wsha (:) = spval + allocate (fsen_gimp (numurban)) ; fsen_gimp (:) = spval + allocate (fsen_gper (numurban)) ; fsen_gper (:) = spval + allocate (fsen_urbl (numurban)) ; fsen_urbl (:) = spval + + allocate (lfevp_roof (numurban)) ; lfevp_roof (:) = spval + allocate (lfevp_gimp (numurban)) ; lfevp_gimp (:) = spval + allocate (lfevp_gper (numurban)) ; lfevp_gper (:) = spval + allocate (lfevp_urbl (numurban)) ; lfevp_urbl (:) = spval + ENDIF + ENDIF + + END SUBROUTINE allocate_1D_UrbanFluxes + + SUBROUTINE deallocate_1D_UrbanFluxes + ! -------------------------------------------------------------------- + ! deallocates memory for CLM 1d [numurban] variables + ! -------------------------------------------------------------------- + USE MOD_SPMD_Task + USE MOD_LandUrban IF (p_is_worker) THEN IF (numurban > 0) THEN @@ -109,42 +109,42 @@ SUBROUTINE deallocate_1D_UrbanFluxes ENDIF ENDIF - END SUBROUTINE deallocate_1D_UrbanFluxes - - SUBROUTINE set_1D_UrbanFluxes(Values, Nan) - ! -------------------------------------------------------------------- - ! Allocates memory for CLM 1d [numurban] variables - ! -------------------------------------------------------------------- - - USE MOD_Precision - USE MOD_SPMD_Task - USE MOD_LandUrban - IMPLICIT NONE - REAL(r8),INTENT(in) :: Values - REAL(r8),INTENT(in) :: Nan - - IF (p_is_worker) THEN - IF (numurban > 0) THEN - !sabroof (:) = Values - !sabwsun (:) = Values - !sabwsha (:) = Values - !sabgimp (:) = Values - !sabgper (:) = Values - fsen_roof (:) = Values - fsen_wsun (:) = Values - fsen_wsha (:) = Values - fsen_gimp (:) = Values - fsen_gper (:) = Values - fsen_urbl (:) = Values - - lfevp_roof (:) = Values - lfevp_gimp (:) = Values - lfevp_gper (:) = Values - lfevp_urbl (:) = Values - ENDIF - ENDIF + END SUBROUTINE deallocate_1D_UrbanFluxes + + SUBROUTINE set_1D_UrbanFluxes(Values, Nan) + ! -------------------------------------------------------------------- + ! Allocates memory for CLM 1d [numurban] variables + ! -------------------------------------------------------------------- + + USE MOD_Precision + USE MOD_SPMD_Task + USE MOD_LandUrban + IMPLICIT NONE + real(r8),intent(in) :: Values + real(r8),intent(in) :: Nan - END SUBROUTINE set_1D_UrbanFluxes + IF (p_is_worker) THEN + IF (numurban > 0) THEN + !sabroof (:) = Values + !sabwsun (:) = Values + !sabwsha (:) = Values + !sabgimp (:) = Values + !sabgper (:) = Values + fsen_roof (:) = Values + fsen_wsun (:) = Values + fsen_wsha (:) = Values + fsen_gimp (:) = Values + fsen_gper (:) = Values + fsen_urbl (:) = Values + + lfevp_roof (:) = Values + lfevp_gimp (:) = Values + lfevp_gper (:) = Values + lfevp_urbl (:) = Values + ENDIF + ENDIF + + END SUBROUTINE set_1D_UrbanFluxes END MODULE MOD_Urban_Vars_1DFluxes #endif diff --git a/main/URBAN/MOD_Urban_Vars_TimeInvariants.F90 b/main/URBAN/MOD_Urban_Vars_TimeInvariants.F90 index aa37b842..6312fa9e 100644 --- a/main/URBAN/MOD_Urban_Vars_TimeInvariants.F90 +++ b/main/URBAN/MOD_Urban_Vars_TimeInvariants.F90 @@ -11,59 +11,59 @@ MODULE MOD_Urban_Vars_TimeInvariants IMPLICIT NONE SAVE - !INTEGER , allocatable :: urbclass (:) !urban TYPE - !INTEGER , allocatable :: patch2urb (:) !projection from patch to Urban - !INTEGER , allocatable :: urb2patch (:) !projection from Urban to patch - - REAL(r8), allocatable :: pop_den (:) !pop density - REAL(r8), allocatable :: vehicle (:,:) !vehicle numbers per thousand people - REAL(r8), allocatable :: week_holiday(:,:) !week holidays - REAL(r8), allocatable :: weh_prof (:,:) !Diurnal traffic flow profile of weekend - REAL(r8), allocatable :: wdh_prof (:,:) !Diurnal traffic flow profile of weekday - REAL(r8), allocatable :: hum_prof (:,:) !Diurnal metabolic heat profile - REAL(r8), allocatable :: fix_holiday (:,:) !Fixed public holidays, holiday (0) or workday(1) + !integer , allocatable :: urbclass (:) !urban type + !integer , allocatable :: patch2urb (:) !projection from patch to Urban + !integer , allocatable :: urb2patch (:) !projection from Urban to patch + + real(r8), allocatable :: pop_den (:) !pop density + real(r8), allocatable :: vehicle (:,:) !vehicle numbers per thousand people + real(r8), allocatable :: week_holiday(:,:) !week holidays + real(r8), allocatable :: weh_prof (:,:) !Diurnal traffic flow profile of weekend + real(r8), allocatable :: wdh_prof (:,:) !Diurnal traffic flow profile of weekday + real(r8), allocatable :: hum_prof (:,:) !Diurnal metabolic heat profile + real(r8), allocatable :: fix_holiday (:,:) !Fixed public holidays, holiday (0) or workday(1) ! Vegetations - REAL(r8), allocatable :: fveg_urb (:) !tree coverage of urban patch [-] - REAL(r8), allocatable :: htop_urb (:) !tree crown top height of urban patch [m] - REAL(r8), allocatable :: hbot_urb (:) !tree crown bottom height of urban patch [m] + real(r8), allocatable :: fveg_urb (:) !tree coverage of urban patch [-] + real(r8), allocatable :: htop_urb (:) !tree crown top height of urban patch [m] + real(r8), allocatable :: hbot_urb (:) !tree crown bottom height of urban patch [m] ! Urban morphology - REAL(r8), allocatable :: froof (:) !roof fractional cover [-] - REAL(r8), allocatable :: fgper (:) !impervious fraction to ground area [-] - REAL(r8), allocatable :: flake (:) !lake fraction to ground area [-] - REAL(r8), allocatable :: hroof (:) !average building height [m] - REAL(r8), allocatable :: hwr (:) !average building height to their distance [-] + real(r8), allocatable :: froof (:) !roof fractional cover [-] + real(r8), allocatable :: fgper (:) !impervious fraction to ground area [-] + real(r8), allocatable :: flake (:) !lake fraction to ground area [-] + real(r8), allocatable :: hroof (:) !average building height [m] + real(r8), allocatable :: hwr (:) !average building height to their distance [-] - REAL(r8), allocatable :: z_roof (:,:) !depth of each roof layer [m] - REAL(r8), allocatable :: z_wall (:,:) !depth of each wall layer [m] - REAL(r8), allocatable :: dz_roof (:,:) !thickness of each roof layer [m] - REAL(r8), allocatable :: dz_wall (:,:) !thickness of each wall layer [m] + real(r8), allocatable :: z_roof (:,:) !depth of each roof layer [m] + real(r8), allocatable :: z_wall (:,:) !depth of each wall layer [m] + real(r8), allocatable :: dz_roof (:,:) !thickness of each roof layer [m] + real(r8), allocatable :: dz_wall (:,:) !thickness of each wall layer [m] ! albedo - REAL(r8), allocatable :: alb_roof(:,:,:) !albedo of roof [-] - REAL(r8), allocatable :: alb_wall(:,:,:) !albedo of walls [-] - REAL(r8), allocatable :: alb_gimp(:,:,:) !albedo of impervious [-] - REAL(r8), allocatable :: alb_gper(:,:,:) !albedo of pervious [-] + real(r8), allocatable :: alb_roof(:,:,:) !albedo of roof [-] + real(r8), allocatable :: alb_wall(:,:,:) !albedo of walls [-] + real(r8), allocatable :: alb_gimp(:,:,:) !albedo of impervious [-] + real(r8), allocatable :: alb_gper(:,:,:) !albedo of pervious [-] ! emissivity - REAL(r8), allocatable :: em_roof (:) !emissivity of roof [-] - REAL(r8), allocatable :: em_wall (:) !emissivity of walls [-] - REAL(r8), allocatable :: em_gimp (:) !emissivity of impervious [-] - REAL(r8), allocatable :: em_gper (:) !emissivity of pervious [-] + real(r8), allocatable :: em_roof (:) !emissivity of roof [-] + real(r8), allocatable :: em_wall (:) !emissivity of walls [-] + real(r8), allocatable :: em_gimp (:) !emissivity of impervious [-] + real(r8), allocatable :: em_gper (:) !emissivity of pervious [-] ! thermal pars of roof, wall, impervious - REAL(r8), allocatable :: cv_roof (:,:) !heat capacity of roof [J/(m2 K)] - REAL(r8), allocatable :: cv_wall (:,:) !heat capacity of wall [J/(m2 K)] - REAL(r8), allocatable :: cv_gimp (:,:) !heat capacity of impervious [J/(m2 K)] + real(r8), allocatable :: cv_roof (:,:) !heat capacity of roof [J/(m2 K)] + real(r8), allocatable :: cv_wall (:,:) !heat capacity of wall [J/(m2 K)] + real(r8), allocatable :: cv_gimp (:,:) !heat capacity of impervious [J/(m2 K)] - REAL(r8), allocatable :: tk_roof (:,:) !thermal conductivity of roof [W/m-K] - REAL(r8), allocatable :: tk_wall (:,:) !thermal conductivity of wall [W/m-K] - REAL(r8), allocatable :: tk_gimp (:,:) !thermal conductivity of impervious [W/m-K] + real(r8), allocatable :: tk_roof (:,:) !thermal conductivity of roof [W/m-K] + real(r8), allocatable :: tk_wall (:,:) !thermal conductivity of wall [W/m-K] + real(r8), allocatable :: tk_gimp (:,:) !thermal conductivity of impervious [W/m-K] ! room maximum and minimum temperature - REAL(r8), allocatable :: t_roommax (:) !maximum temperature of inner room [K] - REAL(r8), allocatable :: t_roommin (:) !minimum temperature of inner room [K] + real(r8), allocatable :: t_roommax (:) !maximum temperature of inner room [K] + real(r8), allocatable :: t_roommin (:) !minimum temperature of inner room [K] ! PUBLIC MEMBER FUNCTIONS: PUBLIC :: allocate_UrbanTimeInvariants @@ -83,11 +83,11 @@ SUBROUTINE allocate_UrbanTimeInvariants () ! ------------------------------------------------------ ! Allocates memory for CLM 1d [numurban] variants ! ------------------------------------------------------ - USE MOD_Precision - USE MOD_SPMD_Task - USE MOD_LandUrban - USE MOD_Vars_Global - IMPLICIT NONE + USE MOD_Precision + USE MOD_SPMD_Task + USE MOD_LandUrban + USE MOD_Vars_Global + IMPLICIT NONE IF (p_is_worker) THEN IF (numurban > 0) THEN @@ -139,147 +139,148 @@ END SUBROUTINE allocate_UrbanTimeInvariants SUBROUTINE READ_UrbanTimeInvariants (file_restart) - USE MOD_NetCDFVector - USE MOD_LandUrban - - IMPLICIT NONE - - INTEGER, parameter :: ns = 2 - INTEGER, parameter :: nr = 2 - INTEGER, parameter :: ulev = 10 - character(LEN=*), intent(in) :: file_restart - - ! vegetation - CALL ncio_read_vector (file_restart, 'PCT_Tree' , landurban, fveg_urb ) - CALL ncio_read_vector (file_restart, 'URBAN_TREE_TOP', landurban, htop_urb ) - CALL ncio_read_vector (file_restart, 'URBAN_TREE_BOT', landurban, hbot_urb ) - CALL ncio_read_vector (file_restart, 'PCT_Water' , landurban, flake ) - - ! LUCY paras !TODO: variable name can be optimized - CALL ncio_read_vector (file_restart, 'POP_DEN' , landurban, pop_den ) - CALL ncio_read_vector (file_restart, 'VEHC_NUM' , 3 , landurban, vehicle ) - CALL ncio_read_vector (file_restart, 'week_holiday', 7 , landurban, week_holiday) - CALL ncio_read_vector (file_restart, 'weekendhour' , 24 , landurban, weh_prof ) - CALL ncio_read_vector (file_restart, 'weekdayhour' , 24 , landurban, wdh_prof ) - CALL ncio_read_vector (file_restart, 'metabolism' , 24 , landurban, hum_prof ) - CALL ncio_read_vector (file_restart, 'holiday' , 365, landurban, fix_holiday ) - - ! morphological paras - CALL ncio_read_vector (file_restart, 'WT_ROOF' , landurban, froof ) - CALL ncio_read_vector (file_restart, 'HT_ROOF' , landurban, hroof ) - CALL ncio_read_vector (file_restart, 'CANYON_HWR' , landurban, hwr ) - CALL ncio_read_vector (file_restart, 'WTROAD_PERV' , landurban, fgper ) - CALL ncio_read_vector (file_restart, 'EM_ROOF' , landurban, em_roof ) - CALL ncio_read_vector (file_restart, 'EM_WALL' , landurban, em_wall ) - CALL ncio_read_vector (file_restart, 'EM_IMPROAD' , landurban, em_gimp ) - CALL ncio_read_vector (file_restart, 'EM_PERROAD' , landurban, em_gper ) - CALL ncio_read_vector (file_restart, 'T_BUILDING_MIN', landurban, t_roommin) - CALL ncio_read_vector (file_restart, 'T_BUILDING_MAX', landurban, t_roommax) - - CALL ncio_read_vector (file_restart, 'ROOF_DEPTH_L' , ulev, landurban, z_roof ) - CALL ncio_read_vector (file_restart, 'ROOF_THICK_L' , ulev, landurban, dz_roof ) - CALL ncio_read_vector (file_restart, 'WALL_DEPTH_L' , ulev, landurban, z_wall ) - CALL ncio_read_vector (file_restart, 'WALL_THICK_L' , ulev, landurban, dz_wall ) - - ! thermal paras - CALL ncio_read_vector (file_restart, 'CV_ROOF' , ulev, landurban, cv_roof) - CALL ncio_read_vector (file_restart, 'CV_WALL' , ulev, landurban, cv_wall) - CALL ncio_read_vector (file_restart, 'TK_ROOF' , ulev, landurban, tk_roof) - CALL ncio_read_vector (file_restart, 'TK_WALL' , ulev, landurban, tk_wall) - CALL ncio_read_vector (file_restart, 'TK_IMPROAD', ulev, landurban, tk_gimp) - CALL ncio_read_vector (file_restart, 'CV_IMPROAD', ulev, landurban, cv_gimp) - - CALL ncio_read_vector (file_restart, 'ALB_ROOF' , ns, nr, landurban, alb_roof ) - CALL ncio_read_vector (file_restart, 'ALB_WALL' , ns, nr, landurban, alb_wall ) - CALL ncio_read_vector (file_restart, 'ALB_IMPROAD', ns, nr, landurban, alb_gimp ) - CALL ncio_read_vector (file_restart, 'ALB_PERROAD', ns, nr, landurban, alb_gper ) + USE MOD_NetCDFVector + USE MOD_LandUrban + + IMPLICIT NONE + + integer, parameter :: ns = 2 + integer, parameter :: nr = 2 + integer, parameter :: ulev = 10 + character(LEN=*), intent(in) :: file_restart + + ! vegetation + CALL ncio_read_vector (file_restart, 'PCT_Tree' , landurban, fveg_urb ) + CALL ncio_read_vector (file_restart, 'URBAN_TREE_TOP', landurban, htop_urb ) + CALL ncio_read_vector (file_restart, 'URBAN_TREE_BOT', landurban, hbot_urb ) + CALL ncio_read_vector (file_restart, 'PCT_Water' , landurban, flake ) + + ! LUCY paras !TODO: variable name can be optimized + CALL ncio_read_vector (file_restart, 'POP_DEN' , landurban, pop_den ) + CALL ncio_read_vector (file_restart, 'VEHC_NUM' , 3 , landurban, vehicle ) + CALL ncio_read_vector (file_restart, 'week_holiday', 7 , landurban, week_holiday) + CALL ncio_read_vector (file_restart, 'weekendhour' , 24 , landurban, weh_prof ) + CALL ncio_read_vector (file_restart, 'weekdayhour' , 24 , landurban, wdh_prof ) + CALL ncio_read_vector (file_restart, 'metabolism' , 24 , landurban, hum_prof ) + CALL ncio_read_vector (file_restart, 'holiday' , 365, landurban, fix_holiday ) + + ! morphological paras + CALL ncio_read_vector (file_restart, 'WT_ROOF' , landurban, froof ) + CALL ncio_read_vector (file_restart, 'HT_ROOF' , landurban, hroof ) + CALL ncio_read_vector (file_restart, 'CANYON_HWR' , landurban, hwr ) + CALL ncio_read_vector (file_restart, 'WTROAD_PERV' , landurban, fgper ) + CALL ncio_read_vector (file_restart, 'EM_ROOF' , landurban, em_roof ) + CALL ncio_read_vector (file_restart, 'EM_WALL' , landurban, em_wall ) + CALL ncio_read_vector (file_restart, 'EM_IMPROAD' , landurban, em_gimp ) + CALL ncio_read_vector (file_restart, 'EM_PERROAD' , landurban, em_gper ) + CALL ncio_read_vector (file_restart, 'T_BUILDING_MIN', landurban, t_roommin) + CALL ncio_read_vector (file_restart, 'T_BUILDING_MAX', landurban, t_roommax) + + CALL ncio_read_vector (file_restart, 'ROOF_DEPTH_L' , ulev, landurban, z_roof ) + CALL ncio_read_vector (file_restart, 'ROOF_THICK_L' , ulev, landurban, dz_roof ) + CALL ncio_read_vector (file_restart, 'WALL_DEPTH_L' , ulev, landurban, z_wall ) + CALL ncio_read_vector (file_restart, 'WALL_THICK_L' , ulev, landurban, dz_wall ) + + ! thermal paras + CALL ncio_read_vector (file_restart, 'CV_ROOF' , ulev, landurban, cv_roof) + CALL ncio_read_vector (file_restart, 'CV_WALL' , ulev, landurban, cv_wall) + CALL ncio_read_vector (file_restart, 'TK_ROOF' , ulev, landurban, tk_roof) + CALL ncio_read_vector (file_restart, 'TK_WALL' , ulev, landurban, tk_wall) + CALL ncio_read_vector (file_restart, 'TK_IMPROAD', ulev, landurban, tk_gimp) + CALL ncio_read_vector (file_restart, 'CV_IMPROAD', ulev, landurban, cv_gimp) + + CALL ncio_read_vector (file_restart, 'ALB_ROOF' , ns, nr, landurban, alb_roof ) + CALL ncio_read_vector (file_restart, 'ALB_WALL' , ns, nr, landurban, alb_wall ) + CALL ncio_read_vector (file_restart, 'ALB_IMPROAD', ns, nr, landurban, alb_gimp ) + CALL ncio_read_vector (file_restart, 'ALB_PERROAD', ns, nr, landurban, alb_gper ) END SUBROUTINE READ_UrbanTimeInvariants SUBROUTINE WRITE_UrbanTimeInvariants (file_restart) - use MOD_NetCDFVector - use MOD_LandUrban - USE MOD_Namelist - USE MOD_Vars_Global - - IMPLICIT NONE - - INTEGER, parameter :: ns = 2 - INTEGER, parameter :: nr = 2 - INTEGER, parameter :: ulev = 10 - INTEGER, parameter :: ityp = 3 - INTEGER, parameter :: ihour = 24 - INTEGER, parameter :: iweek = 7 - INTEGER, parameter :: iday = 365 - ! Local variables - character(len=*), intent(in) :: file_restart - integer :: compress - - compress = DEF_REST_COMPRESS_LEVEL - - call ncio_create_file_vector (file_restart, landurban) - CALL ncio_define_dimension_vector (file_restart, landurban, 'urban') - - CALL ncio_define_dimension_vector (file_restart, landurban, 'urban') - CALL ncio_define_dimension_vector (file_restart, landurban, 'numsolar', nr ) - CALL ncio_define_dimension_vector (file_restart, landurban, 'numrad' , ns ) - CALL ncio_define_dimension_vector (file_restart, landurban, 'ulev' , ulev) - CALL ncio_define_dimension_vector (file_restart, landurban, 'ityp' , 3 ) - CALL ncio_define_dimension_vector (file_restart, landurban, 'iweek' , 7 ) - CALL ncio_define_dimension_vector (file_restart, landurban, 'ihour' , 24 ) - CALL ncio_define_dimension_vector (file_restart, landurban, 'iday' , 365 ) - - ! vegetation - CALL ncio_write_vector (file_restart, 'PCT_Tree' , 'urban', landurban, fveg_urb, DEF_REST_COMPRESS_LEVEL) - CALL ncio_write_vector (file_restart, 'URBAN_TREE_TOP', 'urban', landurban, htop_urb, DEF_REST_COMPRESS_LEVEL) - CALL ncio_write_vector (file_restart, 'URBAN_TREE_BOT', 'urban', landurban, hbot_urb, DEF_REST_COMPRESS_LEVEL) - CALL ncio_write_vector (file_restart, 'PCT_Water' , 'urban', landurban, flake , DEF_REST_COMPRESS_LEVEL) - - ! LUCY paras - CALL ncio_write_vector (file_restart, 'POP_DEN' , 'urban', landurban, pop_den , DEF_REST_COMPRESS_LEVEL) - CALL ncio_write_vector (file_restart, 'VEHC_NUM' , 'ityp' , ityp , 'urban', landurban, vehicle , DEF_REST_COMPRESS_LEVEL) - CALL ncio_write_vector (file_restart, 'week_holiday', 'iweek', iweek, 'urban', landurban, week_holiday, DEF_REST_COMPRESS_LEVEL) - CALL ncio_write_vector (file_restart, 'weekendhour' , 'ihour', ihour, 'urban', landurban, weh_prof , DEF_REST_COMPRESS_LEVEL) - CALL ncio_write_vector (file_restart, 'weekdayhour' , 'ihour', ihour, 'urban', landurban, wdh_prof , DEF_REST_COMPRESS_LEVEL) - CALL ncio_write_vector (file_restart, 'metabolism' , 'ihour', ihour, 'urban', landurban, hum_prof , DEF_REST_COMPRESS_LEVEL) - CALL ncio_write_vector (file_restart, 'holiday' , 'iday' , iday , 'urban', landurban, fix_holiday , DEF_REST_COMPRESS_LEVEL) - - ! morphological paras - CALL ncio_write_vector (file_restart, 'WT_ROOF' , 'urban', landurban, froof , DEF_REST_COMPRESS_LEVEL) - CALL ncio_write_vector (file_restart, 'HT_ROOF' , 'urban', landurban, hroof , DEF_REST_COMPRESS_LEVEL) - CALL ncio_write_vector (file_restart, 'CANYON_HWR' , 'urban', landurban, hwr , DEF_REST_COMPRESS_LEVEL) - CALL ncio_write_vector (file_restart, 'WTROAD_PERV' , 'urban', landurban, fgper , DEF_REST_COMPRESS_LEVEL) - CALL ncio_write_vector (file_restart, 'EM_ROOF' , 'urban', landurban, em_roof , DEF_REST_COMPRESS_LEVEL) - CALL ncio_write_vector (file_restart, 'EM_WALL' , 'urban', landurban, em_wall , DEF_REST_COMPRESS_LEVEL) - CALL ncio_write_vector (file_restart, 'EM_IMPROAD' , 'urban', landurban, em_gimp , DEF_REST_COMPRESS_LEVEL) - CALL ncio_write_vector (file_restart, 'EM_PERROAD' , 'urban', landurban, em_gper , DEF_REST_COMPRESS_LEVEL) - CALL ncio_write_vector (file_restart, 'T_BUILDING_MIN', 'urban', landurban, t_roommin, DEF_REST_COMPRESS_LEVEL) - CALL ncio_write_vector (file_restart, 'T_BUILDING_MAX', 'urban', landurban, t_roommax, DEF_REST_COMPRESS_LEVEL) - - CALL ncio_write_vector (file_restart, 'ROOF_DEPTH_L', 'ulev', ulev, 'urban', landurban, z_roof , DEF_REST_COMPRESS_LEVEL) - CALL ncio_write_vector (file_restart, 'ROOF_THICK_L', 'ulev', ulev, 'urban', landurban, dz_roof, DEF_REST_COMPRESS_LEVEL) - CALL ncio_write_vector (file_restart, 'WALL_DEPTH_L', 'ulev', ulev, 'urban', landurban, z_wall , DEF_REST_COMPRESS_LEVEL) - CALL ncio_write_vector (file_restart, 'WALL_THICK_L', 'ulev', ulev, 'urban', landurban, dz_wall, DEF_REST_COMPRESS_LEVEL) - ! thermal paras - CALL ncio_write_vector (file_restart, 'CV_ROOF' , 'ulev', ulev, 'urban', landurban, cv_roof, DEF_REST_COMPRESS_LEVEL) - CALL ncio_write_vector (file_restart, 'CV_WALL' , 'ulev', ulev, 'urban', landurban, cv_wall, DEF_REST_COMPRESS_LEVEL) - CALL ncio_write_vector (file_restart, 'TK_ROOF' , 'ulev', ulev, 'urban', landurban, tk_roof, DEF_REST_COMPRESS_LEVEL) - CALL ncio_write_vector (file_restart, 'TK_WALL' , 'ulev', ulev, 'urban', landurban, tk_wall, DEF_REST_COMPRESS_LEVEL) - CALL ncio_write_vector (file_restart, 'TK_IMPROAD', 'ulev', ulev, 'urban', landurban, tk_gimp, DEF_REST_COMPRESS_LEVEL) - CALL ncio_write_vector (file_restart, 'CV_IMPROAD', 'ulev', ulev, 'urban', landurban, cv_gimp, DEF_REST_COMPRESS_LEVEL) - - CALL ncio_write_vector (file_restart, 'ALB_ROOF' , 'numsolar', ns, 'numrad', nr, 'urban', landurban, alb_roof, DEF_REST_COMPRESS_LEVEL) - CALL ncio_write_vector (file_restart, 'ALB_WALL' , 'numsolar', ns, 'numrad', nr, 'urban', landurban, alb_wall, DEF_REST_COMPRESS_LEVEL) - CALL ncio_write_vector (file_restart, 'ALB_IMPROAD', 'numsolar', ns, 'numrad', nr, 'urban', landurban, alb_gimp, DEF_REST_COMPRESS_LEVEL) - CALL ncio_write_vector (file_restart, 'ALB_PERROAD', 'numsolar', ns, 'numrad', nr, 'urban', landurban, alb_gper, DEF_REST_COMPRESS_LEVEL) + USE MOD_NetCDFVector + USE MOD_LandUrban + USE MOD_Namelist + USE MOD_Vars_Global + + IMPLICIT NONE + + integer, parameter :: ns = 2 + integer, parameter :: nr = 2 + integer, parameter :: ulev = 10 + integer, parameter :: ityp = 3 + integer, parameter :: ihour = 24 + integer, parameter :: iweek = 7 + integer, parameter :: iday = 365 + ! Local variables + character(len=*), intent(in) :: file_restart + integer :: compress + + compress = DEF_REST_COMPRESS_LEVEL + + CALL ncio_create_file_vector (file_restart, landurban) + CALL ncio_define_dimension_vector (file_restart, landurban, 'urban') + + CALL ncio_define_dimension_vector (file_restart, landurban, 'urban') + CALL ncio_define_dimension_vector (file_restart, landurban, 'numsolar', nr ) + CALL ncio_define_dimension_vector (file_restart, landurban, 'numrad' , ns ) + CALL ncio_define_dimension_vector (file_restart, landurban, 'ulev' , ulev) + CALL ncio_define_dimension_vector (file_restart, landurban, 'ityp' , 3 ) + CALL ncio_define_dimension_vector (file_restart, landurban, 'iweek' , 7 ) + CALL ncio_define_dimension_vector (file_restart, landurban, 'ihour' , 24 ) + CALL ncio_define_dimension_vector (file_restart, landurban, 'iday' , 365 ) + + ! vegetation + CALL ncio_write_vector (file_restart, 'PCT_Tree' , 'urban', landurban, fveg_urb, DEF_REST_COMPRESS_LEVEL) + CALL ncio_write_vector (file_restart, 'URBAN_TREE_TOP', 'urban', landurban, htop_urb, DEF_REST_COMPRESS_LEVEL) + CALL ncio_write_vector (file_restart, 'URBAN_TREE_BOT', 'urban', landurban, hbot_urb, DEF_REST_COMPRESS_LEVEL) + CALL ncio_write_vector (file_restart, 'PCT_Water' , 'urban', landurban, flake , DEF_REST_COMPRESS_LEVEL) + + ! LUCY paras + CALL ncio_write_vector (file_restart, 'POP_DEN' , 'urban', landurban, pop_den , DEF_REST_COMPRESS_LEVEL) + CALL ncio_write_vector (file_restart, 'VEHC_NUM' , 'ityp' , ityp , 'urban', landurban, vehicle , DEF_REST_COMPRESS_LEVEL) + CALL ncio_write_vector (file_restart, 'week_holiday', 'iweek', iweek, 'urban', landurban, week_holiday, DEF_REST_COMPRESS_LEVEL) + CALL ncio_write_vector (file_restart, 'weekendhour' , 'ihour', ihour, 'urban', landurban, weh_prof , DEF_REST_COMPRESS_LEVEL) + CALL ncio_write_vector (file_restart, 'weekdayhour' , 'ihour', ihour, 'urban', landurban, wdh_prof , DEF_REST_COMPRESS_LEVEL) + CALL ncio_write_vector (file_restart, 'metabolism' , 'ihour', ihour, 'urban', landurban, hum_prof , DEF_REST_COMPRESS_LEVEL) + CALL ncio_write_vector (file_restart, 'holiday' , 'iday' , iday , 'urban', landurban, fix_holiday , DEF_REST_COMPRESS_LEVEL) + + ! morphological paras + CALL ncio_write_vector (file_restart, 'WT_ROOF' , 'urban', landurban, froof , DEF_REST_COMPRESS_LEVEL) + CALL ncio_write_vector (file_restart, 'HT_ROOF' , 'urban', landurban, hroof , DEF_REST_COMPRESS_LEVEL) + CALL ncio_write_vector (file_restart, 'CANYON_HWR' , 'urban', landurban, hwr , DEF_REST_COMPRESS_LEVEL) + CALL ncio_write_vector (file_restart, 'WTROAD_PERV' , 'urban', landurban, fgper , DEF_REST_COMPRESS_LEVEL) + CALL ncio_write_vector (file_restart, 'EM_ROOF' , 'urban', landurban, em_roof , DEF_REST_COMPRESS_LEVEL) + CALL ncio_write_vector (file_restart, 'EM_WALL' , 'urban', landurban, em_wall , DEF_REST_COMPRESS_LEVEL) + CALL ncio_write_vector (file_restart, 'EM_IMPROAD' , 'urban', landurban, em_gimp , DEF_REST_COMPRESS_LEVEL) + CALL ncio_write_vector (file_restart, 'EM_PERROAD' , 'urban', landurban, em_gper , DEF_REST_COMPRESS_LEVEL) + CALL ncio_write_vector (file_restart, 'T_BUILDING_MIN', 'urban', landurban, t_roommin, DEF_REST_COMPRESS_LEVEL) + CALL ncio_write_vector (file_restart, 'T_BUILDING_MAX', 'urban', landurban, t_roommax, DEF_REST_COMPRESS_LEVEL) + + CALL ncio_write_vector (file_restart, 'ROOF_DEPTH_L', 'ulev', ulev, 'urban', landurban, z_roof , DEF_REST_COMPRESS_LEVEL) + CALL ncio_write_vector (file_restart, 'ROOF_THICK_L', 'ulev', ulev, 'urban', landurban, dz_roof, DEF_REST_COMPRESS_LEVEL) + CALL ncio_write_vector (file_restart, 'WALL_DEPTH_L', 'ulev', ulev, 'urban', landurban, z_wall , DEF_REST_COMPRESS_LEVEL) + CALL ncio_write_vector (file_restart, 'WALL_THICK_L', 'ulev', ulev, 'urban', landurban, dz_wall, DEF_REST_COMPRESS_LEVEL) + ! thermal paras + CALL ncio_write_vector (file_restart, 'CV_ROOF' , 'ulev', ulev, 'urban', landurban, cv_roof, DEF_REST_COMPRESS_LEVEL) + CALL ncio_write_vector (file_restart, 'CV_WALL' , 'ulev', ulev, 'urban', landurban, cv_wall, DEF_REST_COMPRESS_LEVEL) + CALL ncio_write_vector (file_restart, 'TK_ROOF' , 'ulev', ulev, 'urban', landurban, tk_roof, DEF_REST_COMPRESS_LEVEL) + CALL ncio_write_vector (file_restart, 'TK_WALL' , 'ulev', ulev, 'urban', landurban, tk_wall, DEF_REST_COMPRESS_LEVEL) + CALL ncio_write_vector (file_restart, 'TK_IMPROAD', 'ulev', ulev, 'urban', landurban, tk_gimp, DEF_REST_COMPRESS_LEVEL) + CALL ncio_write_vector (file_restart, 'CV_IMPROAD', 'ulev', ulev, 'urban', landurban, cv_gimp, DEF_REST_COMPRESS_LEVEL) + + CALL ncio_write_vector (file_restart, 'ALB_ROOF' , 'numsolar', ns, 'numrad', nr, 'urban', landurban, alb_roof, DEF_REST_COMPRESS_LEVEL) + CALL ncio_write_vector (file_restart, 'ALB_WALL' , 'numsolar', ns, 'numrad', nr, 'urban', landurban, alb_wall, DEF_REST_COMPRESS_LEVEL) + CALL ncio_write_vector (file_restart, 'ALB_IMPROAD', 'numsolar', ns, 'numrad', nr, 'urban', landurban, alb_gimp, DEF_REST_COMPRESS_LEVEL) + CALL ncio_write_vector (file_restart, 'ALB_PERROAD', 'numsolar', ns, 'numrad', nr, 'urban', landurban, alb_gper, DEF_REST_COMPRESS_LEVEL) END SUBROUTINE WRITE_UrbanTimeInvariants SUBROUTINE deallocate_UrbanTimeInvariants - USE MOD_SPMD_Task - USE MOD_LandUrban + USE MOD_SPMD_Task + USE MOD_LandUrban + ! deallocate (urbclass ) IF (p_is_worker) THEN diff --git a/main/URBAN/MOD_Urban_Vars_TimeVariables.F90 b/main/URBAN/MOD_Urban_Vars_TimeVariables.F90 index b0847909..e1901e8e 100644 --- a/main/URBAN/MOD_Urban_Vars_TimeVariables.F90 +++ b/main/URBAN/MOD_Urban_Vars_TimeVariables.F90 @@ -13,91 +13,91 @@ MODULE MOD_Urban_Vars_TimeVariables ! ----------------------------------------------------------------- ! Time-varying state variables which reaquired by restart run - REAL(r8), allocatable :: fwsun (:) !sunlit fraction of walls [-] - REAL(r8), allocatable :: dfwsun (:) !change of sunlit fraction of walls [-] + real(r8), allocatable :: fwsun (:) !sunlit fraction of walls [-] + real(r8), allocatable :: dfwsun (:) !change of sunlit fraction of walls [-] ! shortwave absorption - REAL(r8), allocatable :: sroof (:,:,:) !roof aborption [-] - REAL(r8), allocatable :: swsun (:,:,:) !sunlit wall absorption [-] - REAL(r8), allocatable :: swsha (:,:,:) !shaded wall absorption [-] - REAL(r8), allocatable :: sgimp (:,:,:) !impervious absorptioin [-] - REAL(r8), allocatable :: sgper (:,:,:) !pervious absorptioin [-] - REAL(r8), allocatable :: slake (:,:,:) !urban lake absorptioin [-] + real(r8), allocatable :: sroof (:,:,:) !roof aborption [-] + real(r8), allocatable :: swsun (:,:,:) !sunlit wall absorption [-] + real(r8), allocatable :: swsha (:,:,:) !shaded wall absorption [-] + real(r8), allocatable :: sgimp (:,:,:) !impervious absorptioin [-] + real(r8), allocatable :: sgper (:,:,:) !pervious absorptioin [-] + real(r8), allocatable :: slake (:,:,:) !urban lake absorptioin [-] ! net longwave radiation for last time temperature change - REAL(r8), allocatable :: lwsun (:) !net longwave of sunlit wall [W/m2] - REAL(r8), allocatable :: lwsha (:) !net longwave of shaded wall [W/m2] - REAL(r8), allocatable :: lgimp (:) !net longwave of impervious [W/m2] - REAL(r8), allocatable :: lgper (:) !net longwave of pervious [W/m2] - REAL(r8), allocatable :: lveg (:) !net longwave of vegetation [W/m2] - - REAL(r8), allocatable :: z_sno_roof (:,:) !node depth of roof [m] - REAL(r8), allocatable :: z_sno_gimp (:,:) !node depth of impervious [m] - REAL(r8), allocatable :: z_sno_gper (:,:) !node depth pervious [m] - REAL(r8), allocatable :: z_sno_lake (:,:) !node depth lake [m] - - REAL(r8), allocatable :: dz_sno_roof (:,:) !interface depth of roof [m] - REAL(r8), allocatable :: dz_sno_gimp (:,:) !interface depth of impervious [m] - REAL(r8), allocatable :: dz_sno_gper (:,:) !interface depth pervious [m] - REAL(r8), allocatable :: dz_sno_lake (:,:) !interface depth lake [m] - - REAL(r8), allocatable :: troof_inner (:) !temperature of roof [K] - REAL(r8), allocatable :: twsun_inner (:) !temperature of sunlit wall [K] - REAL(r8), allocatable :: twsha_inner (:) !temperature of shaded wall [K] - - REAL(r8), allocatable :: t_roofsno (:,:) !temperature of roof [K] - REAL(r8), allocatable :: t_wallsun (:,:) !temperature of sunlit wall [K] - REAL(r8), allocatable :: t_wallsha (:,:) !temperature of shaded wall [K] - REAL(r8), allocatable :: t_gimpsno (:,:) !temperature of impervious [K] - REAL(r8), allocatable :: t_gpersno (:,:) !temperature of pervious [K] - REAL(r8), allocatable :: t_lakesno (:,:) !temperature of pervious [K] - - REAL(r8), allocatable :: wliq_roofsno (:,:) !liquid water in layers [kg/m2] - REAL(r8), allocatable :: wliq_gimpsno (:,:) !liquid water in layers [kg/m2] - REAL(r8), allocatable :: wliq_gpersno (:,:) !liquid water in layers [kg/m2] - REAL(r8), allocatable :: wliq_lakesno (:,:) !liquid water in layers [kg/m2] - REAL(r8), allocatable :: wice_roofsno (:,:) !ice lens in layers [kg/m2] - REAL(r8), allocatable :: wice_gimpsno (:,:) !ice lens in layers [kg/m2] - REAL(r8), allocatable :: wice_gpersno (:,:) !ice lens in layers [kg/m2] - REAL(r8), allocatable :: wice_lakesno (:,:) !ice lens in layers [kg/m2] - - REAL(r8), allocatable :: sag_roof (:) !roof snow age [-] - REAL(r8), allocatable :: sag_gimp (:) !impervious ground snow age [-] - REAL(r8), allocatable :: sag_gper (:) !pervious ground snow age [-] - REAL(r8), allocatable :: sag_lake (:) !urban lake snow age [-] - - REAL(r8), allocatable :: scv_roof (:) !roof snow mass [kg/m2] - REAL(r8), allocatable :: scv_gimp (:) !impervious ground snow mass [kg/m2] - REAL(r8), allocatable :: scv_gper (:) !pervious ground snow mass [kg/m2] - REAL(r8), allocatable :: scv_lake (:) !urban lake snow mass [kg/m2] - - REAL(r8), allocatable :: fsno_roof (:) !roof snow fraction [-] - REAL(r8), allocatable :: fsno_gimp (:) !impervious ground snow fraction [-] - REAL(r8), allocatable :: fsno_gper (:) !pervious ground snow fraction [-] - REAL(r8), allocatable :: fsno_lake (:) !urban lake snow fraction [-] - - REAL(r8), allocatable :: snowdp_roof (:) !roof snow depth [m] - REAL(r8), allocatable :: snowdp_gimp (:) !impervious ground snow depth [m] - REAL(r8), allocatable :: snowdp_gper (:) !pervious ground snow depth [m] - REAL(r8), allocatable :: snowdp_lake (:) !urban lake snow depth [m] + real(r8), allocatable :: lwsun (:) !net longwave of sunlit wall [W/m2] + real(r8), allocatable :: lwsha (:) !net longwave of shaded wall [W/m2] + real(r8), allocatable :: lgimp (:) !net longwave of impervious [W/m2] + real(r8), allocatable :: lgper (:) !net longwave of pervious [W/m2] + real(r8), allocatable :: lveg (:) !net longwave of vegetation [W/m2] + + real(r8), allocatable :: z_sno_roof (:,:) !node depth of roof [m] + real(r8), allocatable :: z_sno_gimp (:,:) !node depth of impervious [m] + real(r8), allocatable :: z_sno_gper (:,:) !node depth pervious [m] + real(r8), allocatable :: z_sno_lake (:,:) !node depth lake [m] + + real(r8), allocatable :: dz_sno_roof (:,:) !interface depth of roof [m] + real(r8), allocatable :: dz_sno_gimp (:,:) !interface depth of impervious [m] + real(r8), allocatable :: dz_sno_gper (:,:) !interface depth pervious [m] + real(r8), allocatable :: dz_sno_lake (:,:) !interface depth lake [m] + + real(r8), allocatable :: troof_inner (:) !temperature of roof [K] + real(r8), allocatable :: twsun_inner (:) !temperature of sunlit wall [K] + real(r8), allocatable :: twsha_inner (:) !temperature of shaded wall [K] + + real(r8), allocatable :: t_roofsno (:,:) !temperature of roof [K] + real(r8), allocatable :: t_wallsun (:,:) !temperature of sunlit wall [K] + real(r8), allocatable :: t_wallsha (:,:) !temperature of shaded wall [K] + real(r8), allocatable :: t_gimpsno (:,:) !temperature of impervious [K] + real(r8), allocatable :: t_gpersno (:,:) !temperature of pervious [K] + real(r8), allocatable :: t_lakesno (:,:) !temperature of pervious [K] + + real(r8), allocatable :: wliq_roofsno (:,:) !liquid water in layers [kg/m2] + real(r8), allocatable :: wliq_gimpsno (:,:) !liquid water in layers [kg/m2] + real(r8), allocatable :: wliq_gpersno (:,:) !liquid water in layers [kg/m2] + real(r8), allocatable :: wliq_lakesno (:,:) !liquid water in layers [kg/m2] + real(r8), allocatable :: wice_roofsno (:,:) !ice lens in layers [kg/m2] + real(r8), allocatable :: wice_gimpsno (:,:) !ice lens in layers [kg/m2] + real(r8), allocatable :: wice_gpersno (:,:) !ice lens in layers [kg/m2] + real(r8), allocatable :: wice_lakesno (:,:) !ice lens in layers [kg/m2] + + real(r8), allocatable :: sag_roof (:) !roof snow age [-] + real(r8), allocatable :: sag_gimp (:) !impervious ground snow age [-] + real(r8), allocatable :: sag_gper (:) !pervious ground snow age [-] + real(r8), allocatable :: sag_lake (:) !urban lake snow age [-] + + real(r8), allocatable :: scv_roof (:) !roof snow mass [kg/m2] + real(r8), allocatable :: scv_gimp (:) !impervious ground snow mass [kg/m2] + real(r8), allocatable :: scv_gper (:) !pervious ground snow mass [kg/m2] + real(r8), allocatable :: scv_lake (:) !urban lake snow mass [kg/m2] + + real(r8), allocatable :: fsno_roof (:) !roof snow fraction [-] + real(r8), allocatable :: fsno_gimp (:) !impervious ground snow fraction [-] + real(r8), allocatable :: fsno_gper (:) !pervious ground snow fraction [-] + real(r8), allocatable :: fsno_lake (:) !urban lake snow fraction [-] + + real(r8), allocatable :: snowdp_roof (:) !roof snow depth [m] + real(r8), allocatable :: snowdp_gimp (:) !impervious ground snow depth [m] + real(r8), allocatable :: snowdp_gper (:) !pervious ground snow depth [m] + real(r8), allocatable :: snowdp_lake (:) !urban lake snow depth [m] !TODO: rename the below variables - REAL(r8), allocatable :: Fhac (:) !sensible flux from heat or cool AC [W/m2] - REAL(r8), allocatable :: Fwst (:) !waste heat flux from heat or cool AC [W/m2] - REAL(r8), allocatable :: Fach (:) !flux from inner and outter air exchange [W/m2] - REAL(r8), allocatable :: Fahe (:) !flux from metabolism and vehicle [W/m2] - REAL(r8), allocatable :: Fhah (:) !sensible heat flux from heating [W/m2] - REAL(r8), allocatable :: vehc (:) !flux from vehicle [W/m2] - REAL(r8), allocatable :: meta (:) !flux from metabolism [W/m2] + real(r8), allocatable :: Fhac (:) !sensible flux from heat or cool AC [W/m2] + real(r8), allocatable :: Fwst (:) !waste heat flux from heat or cool AC [W/m2] + real(r8), allocatable :: Fach (:) !flux from inner and outter air exchange [W/m2] + real(r8), allocatable :: Fahe (:) !flux from metabolism and vehicle [W/m2] + real(r8), allocatable :: Fhah (:) !sensible heat flux from heating [W/m2] + real(r8), allocatable :: vehc (:) !flux from vehicle [W/m2] + real(r8), allocatable :: meta (:) !flux from metabolism [W/m2] - REAL(r8), allocatable :: t_room (:) !temperature of inner building [K] - REAL(r8), allocatable :: t_roof (:) !temperature of roof [K] - REAL(r8), allocatable :: t_wall (:) !temperature of wall [K] - REAL(r8), allocatable :: tafu (:) !temperature of outer building [K] + real(r8), allocatable :: t_room (:) !temperature of inner building [K] + real(r8), allocatable :: t_roof (:) !temperature of roof [K] + real(r8), allocatable :: t_wall (:) !temperature of wall [K] + real(r8), allocatable :: tafu (:) !temperature of outer building [K] - REAL(r8), allocatable :: urb_green (:) !fractional of green leaf in urban patch [-] - REAL(r8), allocatable :: urb_lai (:) !urban tree LAI [m2/m2] - REAL(r8), allocatable :: urb_sai (:) !urban tree SAI [m2/m2] + real(r8), allocatable :: urb_green (:) !fractional of green leaf in urban patch [-] + real(r8), allocatable :: urb_lai (:) !urban tree LAI [m2/m2] + real(r8), allocatable :: urb_sai (:) !urban tree SAI [m2/m2] ! PUBLIC MEMBER FUNCTIONS: @@ -118,11 +118,11 @@ SUBROUTINE allocate_UrbanTimeVariables () ! ------------------------------------------------------ ! Allocates memory for CLM 1d [numurban] variables ! ------------------------------------------------------ - USE MOD_Precision - USE MOD_SPMD_Task - USE MOD_LandUrban - USE MOD_Vars_Global - IMPLICIT NONE + USE MOD_Precision + USE MOD_SPMD_Task + USE MOD_LandUrban + USE MOD_Vars_Global + IMPLICIT NONE IF (p_is_worker) THEN IF (numurban > 0) THEN @@ -211,109 +211,109 @@ END SUBROUTINE allocate_UrbanTimeVariables SUBROUTINE READ_UrbanTimeVariables (file_restart) - USE MOD_NetCDFVector - USE MOD_LandUrban - USE MOD_Vars_Global - - IMPLICIT NONE - - character(LEN=*), intent(in) :: file_restart - - call ncio_read_vector (file_restart, 'fwsun' , landurban, fwsun ) ! - call ncio_read_vector (file_restart, 'dfwsun', landurban, dfwsun) ! - - call ncio_read_vector (file_restart, 'sroof', 2, 2, landurban, sroof) ! - call ncio_read_vector (file_restart, 'swsun', 2, 2, landurban, swsun) ! - call ncio_read_vector (file_restart, 'swsha', 2, 2, landurban, swsha) ! - call ncio_read_vector (file_restart, 'sgimp', 2, 2, landurban, sgimp) ! - call ncio_read_vector (file_restart, 'sgper', 2, 2, landurban, sgper) ! - call ncio_read_vector (file_restart, 'slake', 2, 2, landurban, slake) ! - - call ncio_read_vector (file_restart, 'lwsun', landurban, lwsun) ! - call ncio_read_vector (file_restart, 'lwsha', landurban, lwsha) ! - call ncio_read_vector (file_restart, 'lgimp', landurban, lgimp) ! - call ncio_read_vector (file_restart, 'lgper', landurban, lgper) ! - call ncio_read_vector (file_restart, 'lveg' , landurban, lveg ) ! - - call ncio_read_vector (file_restart, 'z_sno_roof' , -maxsnl, landurban, z_sno_roof ) ! - call ncio_read_vector (file_restart, 'z_sno_gimp' , -maxsnl, landurban, z_sno_gimp ) ! - call ncio_read_vector (file_restart, 'z_sno_gper' , -maxsnl, landurban, z_sno_gper ) ! - call ncio_read_vector (file_restart, 'z_sno_lake' , -maxsnl, landurban, z_sno_lake ) ! - - call ncio_read_vector (file_restart, 'dz_sno_roof', -maxsnl, landurban, dz_sno_roof) ! - call ncio_read_vector (file_restart, 'dz_sno_gimp', -maxsnl, landurban, dz_sno_gimp) ! - call ncio_read_vector (file_restart, 'dz_sno_gper', -maxsnl, landurban, dz_sno_gper) ! - call ncio_read_vector (file_restart, 'dz_sno_lake', -maxsnl, landurban, dz_sno_lake) ! - - call ncio_read_vector (file_restart, 'troof_inner', landurban, troof_inner) ! - call ncio_read_vector (file_restart, 'twsun_inner', landurban, twsun_inner) ! - call ncio_read_vector (file_restart, 'twsha_inner', landurban, twsha_inner) ! - - call ncio_read_vector (file_restart, 't_roofsno', nl_roof-maxsnl, landurban, t_roofsno) ! - call ncio_read_vector (file_restart, 't_wallsun', nl_wall-maxsnl, landurban, t_wallsun) ! - call ncio_read_vector (file_restart, 't_wallsha', nl_wall-maxsnl, landurban, t_wallsha) ! - call ncio_read_vector (file_restart, 't_gimpsno', nl_soil-maxsnl, landurban, t_gimpsno) ! - call ncio_read_vector (file_restart, 't_gpersno', nl_soil-maxsnl, landurban, t_gpersno) ! - call ncio_read_vector (file_restart, 't_lakesno', nl_soil-maxsnl, landurban, t_lakesno) ! - - call ncio_read_vector (file_restart, 'wliq_roofsno', nl_roof-maxsnl, landurban, wliq_roofsno) ! - call ncio_read_vector (file_restart, 'wliq_gimpsno', nl_soil-maxsnl, landurban, wliq_gimpsno) ! - call ncio_read_vector (file_restart, 'wliq_gpersno', nl_soil-maxsnl, landurban, wliq_gpersno) ! - call ncio_read_vector (file_restart, 'wliq_lakesno', nl_soil-maxsnl, landurban, wliq_lakesno) ! - call ncio_read_vector (file_restart, 'wice_roofsno', nl_roof-maxsnl, landurban, wice_roofsno) ! - call ncio_read_vector (file_restart, 'wice_gimpsno', nl_soil-maxsnl, landurban, wice_gimpsno) ! - call ncio_read_vector (file_restart, 'wice_gpersno', nl_soil-maxsnl, landurban, wice_gpersno) ! - call ncio_read_vector (file_restart, 'wice_lakesno', nl_soil-maxsnl, landurban, wice_lakesno) ! - - call ncio_read_vector (file_restart, 'sag_roof' , landurban, sag_roof ) ! - call ncio_read_vector (file_restart, 'sag_gimp' , landurban, sag_gimp ) ! - call ncio_read_vector (file_restart, 'sag_gper' , landurban, sag_gper ) ! - call ncio_read_vector (file_restart, 'sag_lake' , landurban, sag_lake ) ! - call ncio_read_vector (file_restart, 'scv_roof' , landurban, scv_roof ) ! - call ncio_read_vector (file_restart, 'scv_gimp' , landurban, scv_gimp ) ! - call ncio_read_vector (file_restart, 'scv_gper' , landurban, scv_gper ) ! - call ncio_read_vector (file_restart, 'scv_lake' , landurban, scv_lake ) ! - call ncio_read_vector (file_restart, 'fsno_roof' , landurban, fsno_roof ) ! - call ncio_read_vector (file_restart, 'fsno_gimp' , landurban, fsno_gimp ) ! - call ncio_read_vector (file_restart, 'fsno_gper' , landurban, fsno_gper ) ! - call ncio_read_vector (file_restart, 'fsno_lake' , landurban, fsno_lake ) ! - call ncio_read_vector (file_restart, 'snowdp_roof', landurban, snowdp_roof) ! - call ncio_read_vector (file_restart, 'snowdp_gimp', landurban, snowdp_gimp) ! - call ncio_read_vector (file_restart, 'snowdp_gper', landurban, snowdp_gper) ! - call ncio_read_vector (file_restart, 'snowdp_lake', landurban, snowdp_lake) ! - call ncio_read_vector (file_restart, 'Fhac' , landurban, Fhac ) ! - call ncio_read_vector (file_restart, 'Fwst' , landurban, Fwst ) ! - call ncio_read_vector (file_restart, 'Fach' , landurban, Fach ) ! - call ncio_read_vector (file_restart, 'Fahe' , landurban, Fahe ) ! - call ncio_read_vector (file_restart, 'Fhah' , landurban, Fhah ) ! - call ncio_read_vector (file_restart, 'vehc' , landurban, vehc ) ! - call ncio_read_vector (file_restart, 'meta' , landurban, meta ) ! - call ncio_read_vector (file_restart, 't_room ' , landurban, t_room ) ! - call ncio_read_vector (file_restart, 't_roof' , landurban, t_roof ) ! - call ncio_read_vector (file_restart, 't_wall' , landurban, t_wall ) ! - call ncio_read_vector (file_restart, 'tafu' , landurban, tafu ) ! - call ncio_read_vector (file_restart, 'urb_green' , landurban, urb_green ) ! - call ncio_read_vector (file_restart, 'tree_lai' , landurban, urb_lai ) ! - call ncio_read_vector (file_restart, 'tree_sai' , landurban, urb_sai ) ! + USE MOD_NetCDFVector + USE MOD_LandUrban + USE MOD_Vars_Global + + IMPLICIT NONE + + character(LEN=*), intent(in) :: file_restart + + CALL ncio_read_vector (file_restart, 'fwsun' , landurban, fwsun ) ! + CALL ncio_read_vector (file_restart, 'dfwsun', landurban, dfwsun) ! + + CALL ncio_read_vector (file_restart, 'sroof', 2, 2, landurban, sroof) ! + CALL ncio_read_vector (file_restart, 'swsun', 2, 2, landurban, swsun) ! + CALL ncio_read_vector (file_restart, 'swsha', 2, 2, landurban, swsha) ! + CALL ncio_read_vector (file_restart, 'sgimp', 2, 2, landurban, sgimp) ! + CALL ncio_read_vector (file_restart, 'sgper', 2, 2, landurban, sgper) ! + CALL ncio_read_vector (file_restart, 'slake', 2, 2, landurban, slake) ! + + CALL ncio_read_vector (file_restart, 'lwsun', landurban, lwsun) ! + CALL ncio_read_vector (file_restart, 'lwsha', landurban, lwsha) ! + CALL ncio_read_vector (file_restart, 'lgimp', landurban, lgimp) ! + CALL ncio_read_vector (file_restart, 'lgper', landurban, lgper) ! + CALL ncio_read_vector (file_restart, 'lveg' , landurban, lveg ) ! + + CALL ncio_read_vector (file_restart, 'z_sno_roof' , -maxsnl, landurban, z_sno_roof ) ! + CALL ncio_read_vector (file_restart, 'z_sno_gimp' , -maxsnl, landurban, z_sno_gimp ) ! + CALL ncio_read_vector (file_restart, 'z_sno_gper' , -maxsnl, landurban, z_sno_gper ) ! + CALL ncio_read_vector (file_restart, 'z_sno_lake' , -maxsnl, landurban, z_sno_lake ) ! + + CALL ncio_read_vector (file_restart, 'dz_sno_roof', -maxsnl, landurban, dz_sno_roof) ! + CALL ncio_read_vector (file_restart, 'dz_sno_gimp', -maxsnl, landurban, dz_sno_gimp) ! + CALL ncio_read_vector (file_restart, 'dz_sno_gper', -maxsnl, landurban, dz_sno_gper) ! + CALL ncio_read_vector (file_restart, 'dz_sno_lake', -maxsnl, landurban, dz_sno_lake) ! + + CALL ncio_read_vector (file_restart, 'troof_inner', landurban, troof_inner) ! + CALL ncio_read_vector (file_restart, 'twsun_inner', landurban, twsun_inner) ! + CALL ncio_read_vector (file_restart, 'twsha_inner', landurban, twsha_inner) ! + + CALL ncio_read_vector (file_restart, 't_roofsno', nl_roof-maxsnl, landurban, t_roofsno) ! + CALL ncio_read_vector (file_restart, 't_wallsun', nl_wall-maxsnl, landurban, t_wallsun) ! + CALL ncio_read_vector (file_restart, 't_wallsha', nl_wall-maxsnl, landurban, t_wallsha) ! + CALL ncio_read_vector (file_restart, 't_gimpsno', nl_soil-maxsnl, landurban, t_gimpsno) ! + CALL ncio_read_vector (file_restart, 't_gpersno', nl_soil-maxsnl, landurban, t_gpersno) ! + CALL ncio_read_vector (file_restart, 't_lakesno', nl_soil-maxsnl, landurban, t_lakesno) ! + + CALL ncio_read_vector (file_restart, 'wliq_roofsno', nl_roof-maxsnl, landurban, wliq_roofsno) ! + CALL ncio_read_vector (file_restart, 'wliq_gimpsno', nl_soil-maxsnl, landurban, wliq_gimpsno) ! + CALL ncio_read_vector (file_restart, 'wliq_gpersno', nl_soil-maxsnl, landurban, wliq_gpersno) ! + CALL ncio_read_vector (file_restart, 'wliq_lakesno', nl_soil-maxsnl, landurban, wliq_lakesno) ! + CALL ncio_read_vector (file_restart, 'wice_roofsno', nl_roof-maxsnl, landurban, wice_roofsno) ! + CALL ncio_read_vector (file_restart, 'wice_gimpsno', nl_soil-maxsnl, landurban, wice_gimpsno) ! + CALL ncio_read_vector (file_restart, 'wice_gpersno', nl_soil-maxsnl, landurban, wice_gpersno) ! + CALL ncio_read_vector (file_restart, 'wice_lakesno', nl_soil-maxsnl, landurban, wice_lakesno) ! + + CALL ncio_read_vector (file_restart, 'sag_roof' , landurban, sag_roof ) ! + CALL ncio_read_vector (file_restart, 'sag_gimp' , landurban, sag_gimp ) ! + CALL ncio_read_vector (file_restart, 'sag_gper' , landurban, sag_gper ) ! + CALL ncio_read_vector (file_restart, 'sag_lake' , landurban, sag_lake ) ! + CALL ncio_read_vector (file_restart, 'scv_roof' , landurban, scv_roof ) ! + CALL ncio_read_vector (file_restart, 'scv_gimp' , landurban, scv_gimp ) ! + CALL ncio_read_vector (file_restart, 'scv_gper' , landurban, scv_gper ) ! + CALL ncio_read_vector (file_restart, 'scv_lake' , landurban, scv_lake ) ! + CALL ncio_read_vector (file_restart, 'fsno_roof' , landurban, fsno_roof ) ! + CALL ncio_read_vector (file_restart, 'fsno_gimp' , landurban, fsno_gimp ) ! + CALL ncio_read_vector (file_restart, 'fsno_gper' , landurban, fsno_gper ) ! + CALL ncio_read_vector (file_restart, 'fsno_lake' , landurban, fsno_lake ) ! + CALL ncio_read_vector (file_restart, 'snowdp_roof', landurban, snowdp_roof) ! + CALL ncio_read_vector (file_restart, 'snowdp_gimp', landurban, snowdp_gimp) ! + CALL ncio_read_vector (file_restart, 'snowdp_gper', landurban, snowdp_gper) ! + CALL ncio_read_vector (file_restart, 'snowdp_lake', landurban, snowdp_lake) ! + CALL ncio_read_vector (file_restart, 'Fhac' , landurban, Fhac ) ! + CALL ncio_read_vector (file_restart, 'Fwst' , landurban, Fwst ) ! + CALL ncio_read_vector (file_restart, 'Fach' , landurban, Fach ) ! + CALL ncio_read_vector (file_restart, 'Fahe' , landurban, Fahe ) ! + CALL ncio_read_vector (file_restart, 'Fhah' , landurban, Fhah ) ! + CALL ncio_read_vector (file_restart, 'vehc' , landurban, vehc ) ! + CALL ncio_read_vector (file_restart, 'meta' , landurban, meta ) ! + CALL ncio_read_vector (file_restart, 't_room ' , landurban, t_room ) ! + CALL ncio_read_vector (file_restart, 't_roof' , landurban, t_roof ) ! + CALL ncio_read_vector (file_restart, 't_wall' , landurban, t_wall ) ! + CALL ncio_read_vector (file_restart, 'tafu' , landurban, tafu ) ! + CALL ncio_read_vector (file_restart, 'urb_green' , landurban, urb_green ) ! + CALL ncio_read_vector (file_restart, 'tree_lai' , landurban, urb_lai ) ! + CALL ncio_read_vector (file_restart, 'tree_sai' , landurban, urb_sai ) ! END SUBROUTINE READ_UrbanTimeVariables SUBROUTINE WRITE_UrbanTimeVariables (file_restart) - USE MOD_Namelist, only : DEF_REST_COMPRESS_LEVEL - USE MOD_LandUrban - USE MOD_NetCDFVector - USE MOD_Vars_Global - IMPLICIT NONE + USE MOD_Namelist, only : DEF_REST_COMPRESS_LEVEL + USE MOD_LandUrban + USE MOD_NetCDFVector + USE MOD_Vars_Global + IMPLICIT NONE - character(LEN=*), intent(in) :: file_restart + character(LEN=*), intent(in) :: file_restart - ! Local variables - integer :: compress + ! Local variables + integer :: compress compress = DEF_REST_COMPRESS_LEVEL - call ncio_create_file_vector (file_restart, landurban) + CALL ncio_create_file_vector (file_restart, landurban) CALL ncio_define_dimension_vector (file_restart, landurban, 'urban') CALL ncio_define_dimension_vector (file_restart, landurban, 'snow' , -maxsnl ) @@ -327,89 +327,89 @@ SUBROUTINE WRITE_UrbanTimeVariables (file_restart) CALL ncio_define_dimension_vector (file_restart, landurban, 'band', 2) CALL ncio_define_dimension_vector (file_restart, landurban, 'rtyp', 2) - call ncio_write_vector (file_restart, 'fwsun' , 'urban', landurban, fwsun , compress) ! - call ncio_write_vector (file_restart, 'dfwsun', 'urban', landurban, dfwsun, compress) ! - - call ncio_write_vector (file_restart, 'sroof', 'band', 2, 'rtyp', 2, 'urban', landurban, sroof, compress) ! - call ncio_write_vector (file_restart, 'swsun', 'band', 2, 'rtyp', 2, 'urban', landurban, swsun, compress) ! - call ncio_write_vector (file_restart, 'swsha', 'band', 2, 'rtyp', 2, 'urban', landurban, swsha, compress) ! - call ncio_write_vector (file_restart, 'sgimp', 'band', 2, 'rtyp', 2, 'urban', landurban, sgimp, compress) ! - call ncio_write_vector (file_restart, 'sgper', 'band', 2, 'rtyp', 2, 'urban', landurban, sgper, compress) ! - call ncio_write_vector (file_restart, 'slake', 'band', 2, 'rtyp', 2, 'urban', landurban, slake, compress) ! - - call ncio_write_vector (file_restart, 'lwsun', 'urban', landurban, lwsun, compress) ! - call ncio_write_vector (file_restart, 'lwsha', 'urban', landurban, lwsha, compress) ! - call ncio_write_vector (file_restart, 'lgimp', 'urban', landurban, lgimp, compress) ! - call ncio_write_vector (file_restart, 'lgper', 'urban', landurban, lgper, compress) ! - call ncio_write_vector (file_restart, 'lveg' , 'urban', landurban, lveg , compress) ! - - call ncio_write_vector (file_restart, 'z_sno_roof' , 'snow', -maxsnl, 'urban', landurban, z_sno_roof , compress) ! - call ncio_write_vector (file_restart, 'z_sno_gimp' , 'snow', -maxsnl, 'urban', landurban, z_sno_gimp , compress) ! - call ncio_write_vector (file_restart, 'z_sno_gper' , 'snow', -maxsnl, 'urban', landurban, z_sno_gper , compress) ! - call ncio_write_vector (file_restart, 'z_sno_lake' , 'snow', -maxsnl, 'urban', landurban, z_sno_lake , compress) ! - - call ncio_write_vector (file_restart, 'dz_sno_roof', 'snow', -maxsnl, 'urban', landurban, dz_sno_roof, compress) ! - call ncio_write_vector (file_restart, 'dz_sno_gimp', 'snow', -maxsnl, 'urban', landurban, dz_sno_gimp, compress) ! - call ncio_write_vector (file_restart, 'dz_sno_gper', 'snow', -maxsnl, 'urban', landurban, dz_sno_gper, compress) ! - call ncio_write_vector (file_restart, 'dz_sno_lake', 'snow', -maxsnl, 'urban', landurban, dz_sno_lake, compress) ! - - call ncio_write_vector (file_restart, 'troof_inner', 'urban', landurban, troof_inner, compress) ! - call ncio_write_vector (file_restart, 'twsun_inner', 'urban', landurban, twsun_inner, compress) ! - call ncio_write_vector (file_restart, 'twsha_inner', 'urban', landurban, twsha_inner, compress) ! - - call ncio_write_vector (file_restart, 't_roofsno', 'roofsnow', nl_roof-maxsnl, 'urban', landurban, t_roofsno, compress) ! - call ncio_write_vector (file_restart, 't_wallsun', 'wallsnow', nl_wall-maxsnl, 'urban', landurban, t_wallsun, compress) ! - call ncio_write_vector (file_restart, 't_wallsha', 'wallsnow', nl_wall-maxsnl, 'urban', landurban, t_wallsha, compress) ! - call ncio_write_vector (file_restart, 't_gimpsno', 'soilsnow', nl_soil-maxsnl, 'urban', landurban, t_gimpsno, compress) ! - call ncio_write_vector (file_restart, 't_gpersno', 'soilsnow', nl_soil-maxsnl, 'urban', landurban, t_gpersno, compress) ! - call ncio_write_vector (file_restart, 't_lakesno', 'soilsnow', nl_soil-maxsnl, 'urban', landurban, t_lakesno, compress) ! - - call ncio_write_vector (file_restart, 'wliq_roofsno', 'roofsnow', nl_roof-maxsnl, 'urban', landurban, wliq_roofsno, compress) ! - call ncio_write_vector (file_restart, 'wliq_gimpsno', 'soilsnow', nl_soil-maxsnl, 'urban', landurban, wliq_gimpsno, compress) ! - call ncio_write_vector (file_restart, 'wliq_gpersno', 'soilsnow', nl_soil-maxsnl, 'urban', landurban, wliq_gpersno, compress) ! - call ncio_write_vector (file_restart, 'wliq_lakesno', 'soilsnow', nl_soil-maxsnl, 'urban', landurban, wliq_lakesno, compress) ! - call ncio_write_vector (file_restart, 'wice_roofsno', 'roofsnow', nl_roof-maxsnl, 'urban', landurban, wice_roofsno, compress) ! - call ncio_write_vector (file_restart, 'wice_gimpsno', 'soilsnow', nl_soil-maxsnl, 'urban', landurban, wice_gimpsno, compress) ! - call ncio_write_vector (file_restart, 'wice_gpersno', 'soilsnow', nl_soil-maxsnl, 'urban', landurban, wice_gpersno, compress) ! - call ncio_write_vector (file_restart, 'wice_lakesno', 'soilsnow', nl_soil-maxsnl, 'urban', landurban, wice_lakesno, compress) ! - - call ncio_write_vector (file_restart, 'sag_roof' , 'urban', landurban, sag_roof , compress) ! - call ncio_write_vector (file_restart, 'sag_gimp' , 'urban', landurban, sag_gimp , compress) ! - call ncio_write_vector (file_restart, 'sag_gper' , 'urban', landurban, sag_gper , compress) ! - call ncio_write_vector (file_restart, 'sag_lake' , 'urban', landurban, sag_lake , compress) ! - call ncio_write_vector (file_restart, 'scv_roof' , 'urban', landurban, scv_roof , compress) ! - call ncio_write_vector (file_restart, 'scv_gimp' , 'urban', landurban, scv_gimp , compress) ! - call ncio_write_vector (file_restart, 'scv_gper' , 'urban', landurban, scv_gper , compress) ! - call ncio_write_vector (file_restart, 'scv_lake' , 'urban', landurban, scv_lake , compress) ! - call ncio_write_vector (file_restart, 'fsno_roof' , 'urban', landurban, fsno_roof , compress) ! - call ncio_write_vector (file_restart, 'fsno_gimp' , 'urban', landurban, fsno_gimp , compress) ! - call ncio_write_vector (file_restart, 'fsno_gper' , 'urban', landurban, fsno_gper , compress) ! - call ncio_write_vector (file_restart, 'fsno_lake' , 'urban', landurban, fsno_lake , compress) ! - call ncio_write_vector (file_restart, 'snowdp_roof', 'urban', landurban, snowdp_roof, compress) ! - call ncio_write_vector (file_restart, 'snowdp_gimp', 'urban', landurban, snowdp_gimp, compress) ! - call ncio_write_vector (file_restart, 'snowdp_gper', 'urban', landurban, snowdp_gper, compress) ! - call ncio_write_vector (file_restart, 'snowdp_lake', 'urban', landurban, snowdp_lake, compress) ! - call ncio_write_vector (file_restart, 't_room' , 'urban', landurban, t_room , compress) ! - call ncio_write_vector (file_restart, 't_roof' , 'urban', landurban, t_roof , compress) ! - call ncio_write_vector (file_restart, 't_wall' , 'urban', landurban, t_wall , compress) ! - call ncio_write_vector (file_restart, 'tafu' , 'urban', landurban, tafu , compress) ! - call ncio_write_vector (file_restart, 'Fhac' , 'urban', landurban, Fhac , compress) ! - call ncio_write_vector (file_restart, 'Fwst' , 'urban', landurban, Fwst , compress) ! - call ncio_write_vector (file_restart, 'Fach' , 'urban', landurban, Fach , compress) ! - call ncio_write_vector (file_restart, 'Fahe' , 'urban', landurban, Fahe , compress) ! - call ncio_write_vector (file_restart, 'Fhah' , 'urban', landurban, Fhah , compress) ! - call ncio_write_vector (file_restart, 'vehc' , 'urban', landurban, vehc , compress) ! - call ncio_write_vector (file_restart, 'meta' , 'urban', landurban, meta , compress) ! - call ncio_write_vector (file_restart, 'tree_lai' , 'urban', landurban, urb_lai , compress) ! - call ncio_write_vector (file_restart, 'tree_sai' , 'urban', landurban, urb_sai , compress) ! - call ncio_write_vector (file_restart, 'urb_green' , 'urban', landurban, urb_green , compress) ! + CALL ncio_write_vector (file_restart, 'fwsun' , 'urban', landurban, fwsun , compress) ! + CALL ncio_write_vector (file_restart, 'dfwsun', 'urban', landurban, dfwsun, compress) ! + + CALL ncio_write_vector (file_restart, 'sroof', 'band', 2, 'rtyp', 2, 'urban', landurban, sroof, compress) ! + CALL ncio_write_vector (file_restart, 'swsun', 'band', 2, 'rtyp', 2, 'urban', landurban, swsun, compress) ! + CALL ncio_write_vector (file_restart, 'swsha', 'band', 2, 'rtyp', 2, 'urban', landurban, swsha, compress) ! + CALL ncio_write_vector (file_restart, 'sgimp', 'band', 2, 'rtyp', 2, 'urban', landurban, sgimp, compress) ! + CALL ncio_write_vector (file_restart, 'sgper', 'band', 2, 'rtyp', 2, 'urban', landurban, sgper, compress) ! + CALL ncio_write_vector (file_restart, 'slake', 'band', 2, 'rtyp', 2, 'urban', landurban, slake, compress) ! + + CALL ncio_write_vector (file_restart, 'lwsun', 'urban', landurban, lwsun, compress) ! + CALL ncio_write_vector (file_restart, 'lwsha', 'urban', landurban, lwsha, compress) ! + CALL ncio_write_vector (file_restart, 'lgimp', 'urban', landurban, lgimp, compress) ! + CALL ncio_write_vector (file_restart, 'lgper', 'urban', landurban, lgper, compress) ! + CALL ncio_write_vector (file_restart, 'lveg' , 'urban', landurban, lveg , compress) ! + + CALL ncio_write_vector (file_restart, 'z_sno_roof' , 'snow', -maxsnl, 'urban', landurban, z_sno_roof , compress) ! + CALL ncio_write_vector (file_restart, 'z_sno_gimp' , 'snow', -maxsnl, 'urban', landurban, z_sno_gimp , compress) ! + CALL ncio_write_vector (file_restart, 'z_sno_gper' , 'snow', -maxsnl, 'urban', landurban, z_sno_gper , compress) ! + CALL ncio_write_vector (file_restart, 'z_sno_lake' , 'snow', -maxsnl, 'urban', landurban, z_sno_lake , compress) ! + + CALL ncio_write_vector (file_restart, 'dz_sno_roof', 'snow', -maxsnl, 'urban', landurban, dz_sno_roof, compress) ! + CALL ncio_write_vector (file_restart, 'dz_sno_gimp', 'snow', -maxsnl, 'urban', landurban, dz_sno_gimp, compress) ! + CALL ncio_write_vector (file_restart, 'dz_sno_gper', 'snow', -maxsnl, 'urban', landurban, dz_sno_gper, compress) ! + CALL ncio_write_vector (file_restart, 'dz_sno_lake', 'snow', -maxsnl, 'urban', landurban, dz_sno_lake, compress) ! + + CALL ncio_write_vector (file_restart, 'troof_inner', 'urban', landurban, troof_inner, compress) ! + CALL ncio_write_vector (file_restart, 'twsun_inner', 'urban', landurban, twsun_inner, compress) ! + CALL ncio_write_vector (file_restart, 'twsha_inner', 'urban', landurban, twsha_inner, compress) ! + + CALL ncio_write_vector (file_restart, 't_roofsno', 'roofsnow', nl_roof-maxsnl, 'urban', landurban, t_roofsno, compress) ! + CALL ncio_write_vector (file_restart, 't_wallsun', 'wallsnow', nl_wall-maxsnl, 'urban', landurban, t_wallsun, compress) ! + CALL ncio_write_vector (file_restart, 't_wallsha', 'wallsnow', nl_wall-maxsnl, 'urban', landurban, t_wallsha, compress) ! + CALL ncio_write_vector (file_restart, 't_gimpsno', 'soilsnow', nl_soil-maxsnl, 'urban', landurban, t_gimpsno, compress) ! + CALL ncio_write_vector (file_restart, 't_gpersno', 'soilsnow', nl_soil-maxsnl, 'urban', landurban, t_gpersno, compress) ! + CALL ncio_write_vector (file_restart, 't_lakesno', 'soilsnow', nl_soil-maxsnl, 'urban', landurban, t_lakesno, compress) ! + + CALL ncio_write_vector (file_restart, 'wliq_roofsno', 'roofsnow', nl_roof-maxsnl, 'urban', landurban, wliq_roofsno, compress) ! + CALL ncio_write_vector (file_restart, 'wliq_gimpsno', 'soilsnow', nl_soil-maxsnl, 'urban', landurban, wliq_gimpsno, compress) ! + CALL ncio_write_vector (file_restart, 'wliq_gpersno', 'soilsnow', nl_soil-maxsnl, 'urban', landurban, wliq_gpersno, compress) ! + CALL ncio_write_vector (file_restart, 'wliq_lakesno', 'soilsnow', nl_soil-maxsnl, 'urban', landurban, wliq_lakesno, compress) ! + CALL ncio_write_vector (file_restart, 'wice_roofsno', 'roofsnow', nl_roof-maxsnl, 'urban', landurban, wice_roofsno, compress) ! + CALL ncio_write_vector (file_restart, 'wice_gimpsno', 'soilsnow', nl_soil-maxsnl, 'urban', landurban, wice_gimpsno, compress) ! + CALL ncio_write_vector (file_restart, 'wice_gpersno', 'soilsnow', nl_soil-maxsnl, 'urban', landurban, wice_gpersno, compress) ! + CALL ncio_write_vector (file_restart, 'wice_lakesno', 'soilsnow', nl_soil-maxsnl, 'urban', landurban, wice_lakesno, compress) ! + + CALL ncio_write_vector (file_restart, 'sag_roof' , 'urban', landurban, sag_roof , compress) ! + CALL ncio_write_vector (file_restart, 'sag_gimp' , 'urban', landurban, sag_gimp , compress) ! + CALL ncio_write_vector (file_restart, 'sag_gper' , 'urban', landurban, sag_gper , compress) ! + CALL ncio_write_vector (file_restart, 'sag_lake' , 'urban', landurban, sag_lake , compress) ! + CALL ncio_write_vector (file_restart, 'scv_roof' , 'urban', landurban, scv_roof , compress) ! + CALL ncio_write_vector (file_restart, 'scv_gimp' , 'urban', landurban, scv_gimp , compress) ! + CALL ncio_write_vector (file_restart, 'scv_gper' , 'urban', landurban, scv_gper , compress) ! + CALL ncio_write_vector (file_restart, 'scv_lake' , 'urban', landurban, scv_lake , compress) ! + CALL ncio_write_vector (file_restart, 'fsno_roof' , 'urban', landurban, fsno_roof , compress) ! + CALL ncio_write_vector (file_restart, 'fsno_gimp' , 'urban', landurban, fsno_gimp , compress) ! + CALL ncio_write_vector (file_restart, 'fsno_gper' , 'urban', landurban, fsno_gper , compress) ! + CALL ncio_write_vector (file_restart, 'fsno_lake' , 'urban', landurban, fsno_lake , compress) ! + CALL ncio_write_vector (file_restart, 'snowdp_roof', 'urban', landurban, snowdp_roof, compress) ! + CALL ncio_write_vector (file_restart, 'snowdp_gimp', 'urban', landurban, snowdp_gimp, compress) ! + CALL ncio_write_vector (file_restart, 'snowdp_gper', 'urban', landurban, snowdp_gper, compress) ! + CALL ncio_write_vector (file_restart, 'snowdp_lake', 'urban', landurban, snowdp_lake, compress) ! + CALL ncio_write_vector (file_restart, 't_room' , 'urban', landurban, t_room , compress) ! + CALL ncio_write_vector (file_restart, 't_roof' , 'urban', landurban, t_roof , compress) ! + CALL ncio_write_vector (file_restart, 't_wall' , 'urban', landurban, t_wall , compress) ! + CALL ncio_write_vector (file_restart, 'tafu' , 'urban', landurban, tafu , compress) ! + CALL ncio_write_vector (file_restart, 'Fhac' , 'urban', landurban, Fhac , compress) ! + CALL ncio_write_vector (file_restart, 'Fwst' , 'urban', landurban, Fwst , compress) ! + CALL ncio_write_vector (file_restart, 'Fach' , 'urban', landurban, Fach , compress) ! + CALL ncio_write_vector (file_restart, 'Fahe' , 'urban', landurban, Fahe , compress) ! + CALL ncio_write_vector (file_restart, 'Fhah' , 'urban', landurban, Fhah , compress) ! + CALL ncio_write_vector (file_restart, 'vehc' , 'urban', landurban, vehc , compress) ! + CALL ncio_write_vector (file_restart, 'meta' , 'urban', landurban, meta , compress) ! + CALL ncio_write_vector (file_restart, 'tree_lai' , 'urban', landurban, urb_lai , compress) ! + CALL ncio_write_vector (file_restart, 'tree_sai' , 'urban', landurban, urb_sai , compress) ! + CALL ncio_write_vector (file_restart, 'urb_green' , 'urban', landurban, urb_green , compress) ! END SUBROUTINE WRITE_UrbanTimeVariables SUBROUTINE deallocate_UrbanTimeVariables - USE MOD_SPMD_Task - USE MOD_LandUrban + USE MOD_SPMD_Task + USE MOD_LandUrban IF (p_is_worker) THEN IF (numurban > 0) THEN diff --git a/main/URBAN/MOD_Urban_WallTemperature.F90 b/main/URBAN/MOD_Urban_WallTemperature.F90 index c1ad7a17..3fe5fdc1 100644 --- a/main/URBAN/MOD_Urban_WallTemperature.F90 +++ b/main/URBAN/MOD_Urban_WallTemperature.F90 @@ -2,18 +2,18 @@ MODULE MOD_Urban_WallTemperature - USE MOD_Precision - IMPLICIT NONE - SAVE + USE MOD_Precision + IMPLICIT NONE + SAVE - PUBLIC :: UrbanWallTem + PUBLIC :: UrbanWallTem CONTAINS - SUBROUTINE UrbanWallTem (deltim,capr,cnfac,& - cv_wall,tk_wall,t_wall,dz_wall,z_wall,zi_wall,& - twall_inner,lwall,clwall,sabwall,fsenwall,cwalls,tkdz_wall) + SUBROUTINE UrbanWallTem (deltim,capr,cnfac,& + cv_wall,tk_wall,t_wall,dz_wall,z_wall,zi_wall,& + twall_inner,lwall,clwall,sabwall,fsenwall,cwalls,tkdz_wall) !======================================================================= ! Wall temperatures @@ -35,58 +35,58 @@ SUBROUTINE UrbanWallTem (deltim,capr,cnfac,& ! Original author : Yongjiu Dai, 05/2020 !======================================================================= - USE MOD_Precision - USE MOD_Vars_Global - USE MOD_Const_Physical - USE MOD_Utils, only: tridia + USE MOD_Precision + USE MOD_Vars_Global + USE MOD_Const_Physical + USE MOD_Utils, only: tridia - IMPLICIT NONE + IMPLICIT NONE - REAL(r8), intent(in) :: deltim !seconds in a time step [second] - REAL(r8), intent(in) :: capr !tuning factor to turn first layer T into surface T - REAL(r8), intent(in) :: cnfac !Crank Nicholson factor between 0 and 1 + real(r8), intent(in) :: deltim !seconds in a time step [second] + real(r8), intent(in) :: capr !tuning factor to turn first layer T into surface T + real(r8), intent(in) :: cnfac !Crank Nicholson factor between 0 and 1 - REAL(r8), intent(in) :: cv_wall(1:nl_wall) !heat capacity of urban wall [J/m3/K] - REAL(r8), intent(in) :: tk_wall(1:nl_wall) !thermal conductivity of urban wall [W/m/K] + real(r8), intent(in) :: cv_wall(1:nl_wall) !heat capacity of urban wall [J/m3/K] + real(r8), intent(in) :: tk_wall(1:nl_wall) !thermal conductivity of urban wall [W/m/K] - REAL(r8), intent(in) :: dz_wall(1:nl_wall) !layer thickiness [m] - REAL(r8), intent(in) :: z_wall (1:nl_wall) !node depth [m] - REAL(r8), intent(in) :: zi_wall(0:nl_wall) !interface depth [m] + real(r8), intent(in) :: dz_wall(1:nl_wall) !layer thickiness [m] + real(r8), intent(in) :: z_wall (1:nl_wall) !node depth [m] + real(r8), intent(in) :: zi_wall(0:nl_wall) !interface depth [m] - REAL(r8), intent(in) :: twall_inner !temperature at the wall inner surface [K] - REAL(r8), intent(in) :: lwall !atmospheric infrared (longwave) radiation [W/m2] - REAL(r8), intent(in) :: clwall !atmospheric infrared (longwave) radiation [W/m2] - REAL(r8), intent(in) :: sabwall !solar radiation absorbed by wall [W/m2] - REAL(r8), intent(in) :: fsenwall !sensible heat flux from wall [W/m2] - REAL(r8), intent(in) :: cwalls !deriv. of wall energy flux wrt to wall temp [w/m2/k] + real(r8), intent(in) :: twall_inner !temperature at the wall inner surface [K] + real(r8), intent(in) :: lwall !atmospheric infrared (longwave) radiation [W/m2] + real(r8), intent(in) :: clwall !atmospheric infrared (longwave) radiation [W/m2] + real(r8), intent(in) :: sabwall !solar radiation absorbed by wall [W/m2] + real(r8), intent(in) :: fsenwall !sensible heat flux from wall [W/m2] + real(r8), intent(in) :: cwalls !deriv. of wall energy flux wrt to wall temp [w/m2/k] - REAL(r8), intent(inout) :: t_wall(1:nl_wall) !wall layers' temperature [K] - REAL(r8), intent(inout) :: tkdz_wall !inner wall heat flux [w/m2/k] + real(r8), intent(inout) :: t_wall(1:nl_wall) !wall layers' temperature [K] + real(r8), intent(inout) :: tkdz_wall !inner wall heat flux [w/m2/k] !------------------------ local variables ------------------------------ - REAL(r8) wice_wall(1:nl_wall) !ice lens [kg/m2] - REAL(r8) wliq_wall(1:nl_wall) !liqui water [kg/m2] + real(r8) wice_wall(1:nl_wall) !ice lens [kg/m2] + real(r8) wliq_wall(1:nl_wall) !liqui water [kg/m2] - REAL(r8) cv (1:nl_wall) !heat capacity [J/(m2 K)] - REAL(r8) thk(1:nl_wall) !thermal conductivity of layer - REAL(r8) tk (1:nl_wall) !thermal conductivity [W/(m K)] + real(r8) cv (1:nl_wall) !heat capacity [J/(m2 K)] + real(r8) thk(1:nl_wall) !thermal conductivity of layer + real(r8) tk (1:nl_wall) !thermal conductivity [W/(m K)] - REAL(r8) at (1:nl_wall) !"a" vector for tridiagonal matrix - REAL(r8) bt (1:nl_wall) !"b" vector for tridiagonal matrix - REAL(r8) ct (1:nl_wall) !"c" vector for tridiagonal matrix - REAL(r8) rt (1:nl_wall) !"r" vector for tridiagonal solution + real(r8) at (1:nl_wall) !"a" vector for tridiagonal matrix + real(r8) bt (1:nl_wall) !"b" vector for tridiagonal matrix + real(r8) ct (1:nl_wall) !"c" vector for tridiagonal matrix + real(r8) rt (1:nl_wall) !"r" vector for tridiagonal solution - REAL(r8) fn (1:nl_wall) !heat diffusion through the layer interface [W/m2] - REAL(r8) fn1(1:nl_wall) !heat diffusion through the layer interface [W/m2] - REAL(r8) fact(1:nl_wall) !used in computing tridiagonal matrix - REAL(r8) dzm !used in computing tridiagonal matrix - REAL(r8) dzp !used in computing tridiagonal matrix + real(r8) fn (1:nl_wall) !heat diffusion through the layer interface [W/m2] + real(r8) fn1(1:nl_wall) !heat diffusion through the layer interface [W/m2] + real(r8) fact(1:nl_wall) !used in computing tridiagonal matrix + real(r8) dzm !used in computing tridiagonal matrix + real(r8) dzp !used in computing tridiagonal matrix - REAL(r8) t_wall_bef(1:nl_wall) !wall/snow temperature before update - REAL(r8) hs !net energy flux into the surface (w/m2) - REAL(r8) dhsdt !d(hs)/dT + real(r8) t_wall_bef(1:nl_wall) !wall/snow temperature before update + real(r8) hs !net energy flux into the surface (w/m2) + real(r8) dhsdt !d(hs)/dT - INTEGER i,j + integer i,j !======================================================================= @@ -157,7 +157,7 @@ SUBROUTINE UrbanWallTem (deltim,capr,cnfac,& j = nl_wall fn1(j) = tk(j)*(twall_inner - cnfac*t_wall(j))/(zi_wall(j)-z_wall(j)) - END SUBROUTINE UrbanWallTem + END SUBROUTINE UrbanWallTem END MODULE MOD_Urban_WallTemperature ! ---------- EOP ------------ diff --git a/main/URBAN/Urban_CoLMMAIN.F90 b/main/URBAN/Urban_CoLMMAIN.F90 index 360d42b7..b23376c9 100644 --- a/main/URBAN/Urban_CoLMMAIN.F90 +++ b/main/URBAN/Urban_CoLMMAIN.F90 @@ -143,24 +143,24 @@ SUBROUTINE UrbanCoLMMAIN ( & IMPLICIT NONE ! ------------------------ Dummy Argument ------------------------------ - INTEGER, intent(in) :: & + integer, intent(in) :: & ipatch ,&! maximum number of snow layers idate(3) ,&! next time-step /year/julian day/second in a day/ patchclass ,&! land cover type of USGS classification or others patchtype ! land patch type (0=soil, 1=urban and built-up, ! 2=wetland, 3=land ice, 4=land water bodies, 99 = ocean) - REAL(r8),intent(in) :: & + real(r8),intent(in) :: & deltim ,&! seconds in a time step [second] patchlonr ,&! logitude in radians patchlatr ! latitude in radians - REAL(r8),intent(inout) :: & + real(r8),intent(inout) :: & coszen ! cosine of solar zenith angle ! Parameters ! ---------------------- - REAL(r8), intent(in) :: & + real(r8), intent(in) :: & fix_holiday(365), &! Fixed public holidays, holiday(0) or workday(1) week_holiday(7) , &! week holidays hum_prof(24) , &! Diurnal metabolic heat profile @@ -169,7 +169,7 @@ SUBROUTINE UrbanCoLMMAIN ( & pop_den , &! population density vehicle(3) ! vehicle numbers per thousand people - REAL(r8), intent(in) :: & + real(r8), intent(in) :: & froof ,&! roof fractional cover [-] fgper ,&! impervious fraction to ground area [-] flake ,&! lake fraction to ground area [-] @@ -180,7 +180,7 @@ SUBROUTINE UrbanCoLMMAIN ( & em_gimp ,&! emissivity of impervious [-] em_gper ! emissivity of pervious [-] - REAL(r8), intent(in) :: & + real(r8), intent(in) :: & cv_roof(1:nl_roof) ,&! heat capacity of roof [J/(m2 K)] cv_wall(1:nl_wall) ,&! heat capacity of wall [J/(m2 K)] cv_gimp(1:nl_soil) ,&! heat capacity of impervious [J/(m2 K)] @@ -188,7 +188,7 @@ SUBROUTINE UrbanCoLMMAIN ( & tk_wall(1:nl_wall) ,&! thermal conductivity of wall [W/m-K] tk_gimp(1:nl_soil) ! thermal conductivity of impervious [W/m-K] - REAL(r8), intent(in) :: & + real(r8), intent(in) :: & ! soil physical parameters and lake info vf_quartz (nl_soil),&! volumetric fraction of quartz within mineral soil vf_gravels(nl_soil),&! volumetric fraction of gravels @@ -253,18 +253,18 @@ SUBROUTINE UrbanCoLMMAIN ( & capr ,&! tuning factor to turn first layer T into surface T cnfac ,&! Crank Nicholson factor between 0 and 1 ssi ,&! irreducible water saturation of snow - wimp ,&! water impremeable if porosity less than wimp + wimp ,&! water impremeable IF porosity less than wimp pondmx ,&! ponding depth (mm) smpmax ,&! wilting point potential in mm smpmin ,&! restriction for min of soil poten. (mm) trsmx0 ,&! max transpiration for moist soil+100% veg. [mm/s] tcrit ! critical temp. to determine rain or snow - real(r8), INTENT(in) :: hpbl ! atmospheric boundary layer height [m] + real(r8), intent(in) :: hpbl ! atmospheric boundary layer height [m] ! Forcing ! ---------------------- - REAL(r8), intent(in) :: & + real(r8), intent(in) :: & forc_pco2m ,&! partial pressure of CO2 at observational height [pa] forc_po2m ,&! partial pressure of O2 at observational height [pa] forc_us ,&! wind speed in eastward direction [m/s] @@ -286,15 +286,15 @@ SUBROUTINE UrbanCoLMMAIN ( & forc_rhoair ! density air [kg/m3] #if(defined CaMa_Flood) - REAL(r8), intent(in) :: fldfrc !inundation fraction--> allow re-evaporation and infiltrition![0-1] - REAL(r8), intent(inout) :: flddepth !inundation depth--> allow re-evaporation and infiltrition![mm] - REAL(r8), intent(out) :: fevpg_fld !effective evaporation from inundation [mm/s] - REAL(r8), intent(out) :: qinfl_fld !effective re-infiltration from inundation [mm/s] + real(r8), intent(in) :: fldfrc !inundation fraction--> allow re-evaporation and infiltrition![0-1] + real(r8), intent(inout) :: flddepth !inundation depth--> allow re-evaporation and infiltrition![mm] + real(r8), intent(out) :: fevpg_fld !effective evaporation from inundation [mm/s] + real(r8), intent(out) :: qinfl_fld !effective re-infiltration from inundation [mm/s] #endif ! Variables required for restart run ! ---------------------------------------------------------------------- - REAL(r8), intent(inout) :: & + real(r8), intent(inout) :: & t_wallsun ( 1:nl_wall) ,&! sunlit wall layer temperature [K] t_wallsha ( 1:nl_wall) ,&! shaded wall layer temperature [K] t_soisno (maxsnl+1:nl_soil) ,&! soil + snow layer temperature [K] @@ -417,7 +417,7 @@ SUBROUTINE UrbanCoLMMAIN ( & slake(2,2) ! shaded canopy absorption for solar radiation ! additional diagnostic variables for output - REAL(r8), intent(out) :: & + real(r8), intent(out) :: & laisun ,&! sunlit leaf area index laisha ,&! shaded leaf area index rstfac ,&! factor of soil water stress @@ -427,7 +427,7 @@ SUBROUTINE UrbanCoLMMAIN ( & ! Fluxes ! ---------------------------------------------------------------------- - REAL(r8), intent(out) :: & + real(r8), intent(out) :: & taux ,&! wind stress: E-W [kg/m/s**2] tauy ,&! wind stress: N-S [kg/m/s**2] fsena ,&! sensible heat from canopy height to atmosphere [W/m2] @@ -508,7 +508,7 @@ SUBROUTINE UrbanCoLMMAIN ( & fq ! integral of profile function for moisture ! ----------------------- Local Variables ----------------------------- - REAL(r8) :: & + real(r8) :: & calday ,&! Julian cal day (1.xx to 365.xx) endwb ,&! water mass at the end of time step errore ,&! energy balnce errore (Wm-2) @@ -578,7 +578,7 @@ SUBROUTINE UrbanCoLMMAIN ( & zi_gpersno(maxsnl :nl_soil) ,&! interface level below a "z" level [m] zi_lakesno(maxsnl :nl_soil) ! interface level below a "z" level [m] - REAL(r8) :: & + real(r8) :: & prc_rain ,&! convective rainfall [kg/(m2 s)] prc_snow ,&! convective snowfall [kg/(m2 s)] prl_rain ,&! large scale rainfall [kg/(m2 s)] @@ -597,16 +597,16 @@ SUBROUTINE UrbanCoLMMAIN ( & fveg_gper ,&! fraction of fveg/fgper fveg_gimp ! fraction of fveg/fgimp - REAL(r8) :: & + real(r8) :: & errw_rsub ! the possible subsurface runoff deficit after PHS is included - REAL(r8) :: & + real(r8) :: & ei, &! vapor pressure on leaf surface [pa] deidT, &! derivative of "ei" on "tl" [pa/K] qsatl, &! leaf specific humidity [kg/kg] qsatldT ! derivative of "qsatl" on "tlef" - INTEGER :: & + integer :: & snlr ,&! number of snow layers snli ,&! number of snow layers snlp ,&! number of snow layers @@ -620,13 +620,13 @@ SUBROUTINE UrbanCoLMMAIN ( & lbp ,&! lower bound of arrays lbl ,&! lower bound of arrays lbsn ,&! lower bound of arrays - j ! do looping index + j ! DO looping index ! For SNICAR snow model !---------------------------------------------------------------------- - REAL(r8) forc_aer ( 14 ) !aerosol deposition from atmosphere model (grd,aer) [kg m-1 s-1] - REAL(r8) snofrz (maxsnl+1:0) !snow freezing rate (col,lyr) [kg m-2 s-1] - REAL(r8) sabg_lyr (maxsnl+1:1) !snow layer absorption [W/m-2] + real(r8) forc_aer ( 14 ) !aerosol deposition from atmosphere model (grd,aer) [kg m-1 s-1] + real(r8) snofrz (maxsnl+1:0) !snow freezing rate (col,lyr) [kg m-2 s-1] + real(r8) sabg_lyr (maxsnl+1:1) !snow layer absorption [W/m-2] theta = acos(max(coszen,0.001)) forc_aer(:) = 0. !aerosol deposition from atmosphere model (grd,aer) [kg m-1 s-1] @@ -1167,12 +1167,12 @@ SUBROUTINE UrbanCoLMMAIN ( & #if(defined CoLMDEBUG) IF(abs(errorw)>1.e-3) THEN write(6,*) 'Warning: water balance violation', errorw, ipatch, patchclass - !stop + !STOP ENDIF - if(abs(errw_rsub*deltim)>1.e-3) then + IF(abs(errw_rsub*deltim)>1.e-3) THEN write(6,*) 'Subsurface runoff deficit due to PHS', errw_rsub*deltim - end if + ENDIF #endif !======================================================================