From 7d758e101b99f24727ba22d9297ea060e9c0040a Mon Sep 17 00:00:00 2001 From: Hua Yuan Date: Wed, 20 Dec 2023 12:57:42 +0800 Subject: [PATCH 1/4] A small fix for cv(1) setting for roof temperature and format adjust. -fix(MOD_Urban_RoofTemperature.F90): fix for first layer cv(1) setting when there is snow with no snow layer exist. -adj(MOD_Urban_Hydrology.F90 and MOD_Urban_*.Temperature.F90): code format adjust. --- main/URBAN/MOD_Urban_Hydrology.F90 | 100 +++++++++--------- .../URBAN/MOD_Urban_ImperviousTemperature.F90 | 10 +- main/URBAN/MOD_Urban_PerviousTemperature.F90 | 20 ++-- main/URBAN/MOD_Urban_RoofTemperature.F90 | 80 +++++++------- main/URBAN/MOD_Urban_WallTemperature.F90 | 50 ++++----- 5 files changed, 128 insertions(+), 132 deletions(-) diff --git a/main/URBAN/MOD_Urban_Hydrology.F90 b/main/URBAN/MOD_Urban_Hydrology.F90 index 2e84daab..33a5f173 100644 --- a/main/URBAN/MOD_Urban_Hydrology.F90 +++ b/main/URBAN/MOD_Urban_Hydrology.F90 @@ -124,9 +124,9 @@ SUBROUTINE UrbanHydrology ( & 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 @@ -134,47 +134,47 @@ SUBROUTINE UrbanHydrology ( & ! 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) :: & - 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] - mss_ocphi (lbp:0), &! mass of hydrophillic OC in snow (col,lyr) [kg] - mss_dst1 (lbp:0), &! mass of dust species 1 in snow (col,lyr) [kg] - mss_dst2 (lbp:0), &! mass of dust species 2 in snow (col,lyr) [kg] - mss_dst3 (lbp:0), &! mass of dust species 3 in snow (col,lyr) [kg] - mss_dst4 (lbp:0) ! mass of dust species 4 in snow (col,lyr) [kg] + 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] + mss_ocphi (lbp:0) ,&! mass of hydrophillic OC in snow (col,lyr) [kg] + mss_dst1 (lbp:0) ,&! mass of dust species 1 in snow (col,lyr) [kg] + mss_dst2 (lbp:0) ,&! mass of dust species 2 in snow (col,lyr) [kg] + mss_dst3 (lbp:0) ,&! mass of dust species 3 in snow (col,lyr) [kg] + mss_dst4 (lbp:0) ! mass of dust species 4 in snow (col,lyr) [kg] ! Aerosol Fluxes (Jan. 07, 2023) ! END SNICAR model variables INTEGER, intent(in) :: & - imelt_lake(maxsnl+1:nl_soil)! lake flag for melting or freezing snow and soil layer [-] + imelt_lake(maxsnl+1:nl_soil) ! lake flag for melting or freezing snow and soil layer [-] 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] - z_gpersno (lbp:nl_soil) ,&! layer depth (m) - dz_roofsno (lbr:nl_roof) ,&! layer thickness (m) - dz_gimpsno (lbi:nl_soil) ,&! layer thickness (m) - dz_gpersno (lbp:nl_soil) ,&! layer thickness (m) - zi_gpersno(lbp-1:nl_soil) ,&! interface level below a "z" level (m) - t_lake ( 1:nl_lake) ,&! lake temperature [K] - t_gpersno (lbp:nl_soil) ,&! soil/snow skin temperature (K) - wliq_roofsno(lbr:nl_roof) ,&! liquid water (kg/m2) - wliq_gimpsno(lbi:nl_soil) ,&! liquid water (kg/m2) - wliq_gpersno(lbp:nl_soil) ,&! liquid water (kg/m2) - wice_roofsno(lbr:nl_roof) ,&! ice lens (kg/m2) - wice_gimpsno(lbi:nl_soil) ,&! ice lens (kg/m2) - wice_gpersno(lbp:nl_soil) ,&! ice lens (kg/m2) - - zi_lakesno (maxsnl :nl_soil) ,&! interface level below a "z" level (m) - t_lakesno (maxsnl+1:nl_soil) ,&! soil/snow skin temperature (K) - z_lakesno (maxsnl+1:nl_soil) ,&! layer depth (m) - dz_lakesno (maxsnl+1:nl_soil) ,&! layer thickness (m) - wliq_lakesno(maxsnl+1:nl_soil) ,&! liquid water (kg/m2) - wice_lakesno(maxsnl+1:nl_soil) ,&! ice lens (kg/m2) + 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] + z_gpersno (lbp:nl_soil) ,&! layer depth (m) + dz_roofsno (lbr:nl_roof) ,&! layer thickness (m) + dz_gimpsno (lbi:nl_soil) ,&! layer thickness (m) + dz_gpersno (lbp:nl_soil) ,&! layer thickness (m) + zi_gpersno(lbp-1:nl_soil) ,&! interface level below a "z" level (m) + t_lake ( 1:nl_lake) ,&! lake temperature [K] + t_gpersno (lbp:nl_soil) ,&! soil/snow skin temperature (K) + wliq_roofsno(lbr:nl_roof) ,&! liquid water (kg/m2) + wliq_gimpsno(lbi:nl_soil) ,&! liquid water (kg/m2) + wliq_gpersno(lbp:nl_soil) ,&! liquid water (kg/m2) + wice_roofsno(lbr:nl_roof) ,&! ice lens (kg/m2) + wice_gimpsno(lbi:nl_soil) ,&! ice lens (kg/m2) + wice_gpersno(lbp:nl_soil) ,&! ice lens (kg/m2) + + zi_lakesno (maxsnl :nl_soil),&! interface level below a "z" level (m) + t_lakesno (maxsnl+1:nl_soil),&! soil/snow skin temperature (K) + z_lakesno (maxsnl+1:nl_soil),&! layer depth (m) + dz_lakesno (maxsnl+1:nl_soil),&! layer thickness (m) + wliq_lakesno(maxsnl+1:nl_soil),&! liquid water (kg/m2) + wice_lakesno(maxsnl+1:nl_soil),&! ice lens (kg/m2) sm_lake ,&! snow melt (mm h2o/s) scv_lake ,&! lake snow mass (kg/m2) @@ -221,23 +221,23 @@ SUBROUTINE UrbanHydrology ( & ! [1] for pervious road, the same as soil !======================================================================= rootflux(:) = rootr(:)*etr - CALL WATER_2014 (ipatch,patchtype, lbp ,nl_soil ,deltim ,& - z_gpersno ,dz_gpersno ,zi_gpersno ,& - bsw ,porsl ,psi0 ,hksati,rootr,rootflux,& - t_gpersno ,wliq_gpersno,wice_gpersno,smp,hk,pgper_rain,sm_gper,& - etr ,qseva_gper ,qsdew_gper ,qsubl_gper,qfros_gper,& + CALL WATER_2014 (ipatch,patchtype,lbp ,nl_soil ,deltim ,& + z_gpersno ,dz_gpersno ,zi_gpersno ,bsw ,porsl ,& + psi0 ,hksati ,rootr ,rootflux ,t_gpersno ,& + wliq_gpersno,wice_gpersno,smp ,hk ,pgper_rain ,& + sm_gper ,etr ,qseva_gper ,qsdew_gper ,qsubl_gper ,& + qfros_gper ,& !NOTE: temporal input, as urban mode doesn't support split soil&snow ! set all the same for soil and snow surface, ! and fsno=0. (no physical meaning here) - qseva_gper ,qsdew_gper ,qsubl_gper,qfros_gper,& - qseva_gper ,qsdew_gper ,qsubl_gper,qfros_gper,& + qseva_gper ,qsdew_gper ,qsubl_gper ,qfros_gper ,& + qseva_gper ,qsdew_gper ,qsubl_gper ,qfros_gper ,& 0. ,& ! fsno, not active - rsur_gper ,& - rnof_gper ,qinfl ,wtfact ,pondmx ,& - ssi ,wimp ,smpmin ,zwt ,wa ,& - qcharge ,errw_rsub & + rsur_gper ,rnof_gper ,qinfl ,wtfact ,& + pondmx ,ssi ,wimp ,smpmin ,& + zwt ,wa ,qcharge ,errw_rsub & #if(defined CaMa_Flood) - ,flddepth ,fldfrc ,qinfl_fld & + ,flddepth ,fldfrc ,qinfl_fld ,& #endif ! SNICAR model variables ,forc_aer ,& @@ -326,13 +326,13 @@ SUBROUTINE UrbanHydrology ( & ! --------------------------- z_lakesno ,dz_lakesno ,zi_lakesno ,t_lakesno ,& wice_lakesno ,wliq_lakesno ,t_lake ,lake_icefrac ,& - gwat , & + gwat ,& dfseng ,dfgrnd ,snll ,scv_lake ,& snowdp_lake ,sm_lake ,forc_us ,forc_vs & ! SNICAR model variables ,forc_aer ,& mss_bcpho ,mss_bcphi ,mss_ocpho ,mss_ocphi ,& - mss_dst1 , mss_dst2 ,mss_dst3 ,mss_dst4 ,& + mss_dst1 ,mss_dst2 ,mss_dst3 ,mss_dst4 ,& ! END SNICAR model variables urban_call=.true.) diff --git a/main/URBAN/MOD_Urban_ImperviousTemperature.F90 b/main/URBAN/MOD_Urban_ImperviousTemperature.F90 index 26923bde..fb09b295 100644 --- a/main/URBAN/MOD_Urban_ImperviousTemperature.F90 +++ b/main/URBAN/MOD_Urban_ImperviousTemperature.F90 @@ -20,14 +20,14 @@ SUBROUTINE UrbanImperviousTem (patchtype,lb,deltim, & imelt,sm,xmf,fact) !======================================================================= -! Snow and road temperatures +! Snow and impervious road temperatures ! o The volumetric heat capacity is calculated as a linear combination ! in terms of the volumetric fraction of the constituent phases. ! o The thermal conductivity of road soil is computed from ! the algorithm of Johansen (as reported by Farouki 1981), impervious and perivious from ! LOOK-UP table and of snow is from the formulation used in SNTHERM (Jordan 1991). ! o Boundary conditions: -! F = Rnet - Hg - LEg (top), F= 0 (base of the soil column). +! F = Rnet - Hg - LEg (top), F = 0 (base of the soil column). ! o Soil / snow temperature is predicted from heat conduction ! in 10 soil layers and up to 5 snow layers. ! The thermal conductivities at the interfaces between two neighbor layers @@ -36,7 +36,7 @@ SUBROUTINE UrbanImperviousTem (patchtype,lb,deltim, & ! interface to the node j+1. The equation is solved using the Crank-Nicholson ! method and resulted in a tridiagonal system equation. ! -! Phase change (see meltf.F90) +! Phase change (see MOD_PhaseChange.F90) ! ! Original author : Yongjiu Dai, 09/15/1999; 08/30/2002; 05/2020 !======================================================================= @@ -137,7 +137,7 @@ SUBROUTINE UrbanImperviousTem (patchtype,lb,deltim, & ! soil ground and wetland heat capacity DO i = 1, nl_soil vf_water(i) = wliq_gimpsno(i)/(dz_gimpsno(i)*denh2o) - vf_ice(i) = wice_gimpsno(i)/(dz_gimpsno(i)*denice) + vf_ice(i) = wice_gimpsno(i)/(dz_gimpsno(i)*denice) CALL soil_hcap_cond(vf_gravels(i),vf_om(i),vf_sand(i),porsl(i),& wf_gravels(i),wf_sand(i),k_solids(i),& csol(i),dkdry(i),dksatu(i),dksatf(i),& @@ -197,7 +197,7 @@ SUBROUTINE UrbanImperviousTem (patchtype,lb,deltim, & WHERE (tk_gimp > 0.) tk(1:) = tk_gimp(1:) WHERE (cv_gimp > 0.) cv(1:) = cv_gimp(1:)*dz_gimpsno(1:) - ! snow exist for the first soil layer + ! snow exist when there is no snow layer IF (lb == 1 .and. scv_gimp > 0.0) THEN cv(1) = cv(1) + cpice*scv_gimp ENDIF diff --git a/main/URBAN/MOD_Urban_PerviousTemperature.F90 b/main/URBAN/MOD_Urban_PerviousTemperature.F90 index 9760534f..123bb44e 100644 --- a/main/URBAN/MOD_Urban_PerviousTemperature.F90 +++ b/main/URBAN/MOD_Urban_PerviousTemperature.F90 @@ -27,14 +27,14 @@ SUBROUTINE UrbanPerviousTem (patchtype,lb,deltim, & imelt,sm,xmf,fact) !======================================================================= -! Snow and road temperatures +! Snow and pervious road temperatures ! o The volumetric heat capacity is calculated as a linear combination ! in terms of the volumetric fraction of the constituent phases. ! o The thermal conductivity of road soil is computed from ! the algorithm of Johansen (as reported by Farouki 1981), impervious and perivious from ! LOOK-UP table and of snow is from the formulation used in SNTHERM (Jordan 1991). ! o Boundary conditions: -! F = Rnet - Hg - LEg (top), F= 0 (base of the soil column). +! F = Rnet - Hg - LEg (top), F = 0 (base of the soil column). ! o Soil / snow temperature is predicted from heat conduction ! in 10 soil layers and up to 5 snow layers. ! The thermal conductivities at the interfaces between two neighbor layers @@ -43,7 +43,7 @@ SUBROUTINE UrbanPerviousTem (patchtype,lb,deltim, & ! interface to the node j+1. The equation is solved using the Crank-Nicholson ! method and resulted in a tridiagonal system equation. ! -! Phase change (see meltf.F90) +! Phase change (see MOD_PhaseChange.F90) ! ! Original author : Yongjiu Dai, 09/15/1999; 08/30/2002; 05/2020 !======================================================================= @@ -87,12 +87,12 @@ SUBROUTINE UrbanPerviousTem (patchtype,lb,deltim, & 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), & - alpha_vgm (1:nl_soil), & - n_vgm (1:nl_soil), & - L_vgm (1:nl_soil), & - sc_vgm (1:nl_soil), & - fc_vgm (1:nl_soil) + 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] @@ -150,7 +150,7 @@ SUBROUTINE UrbanPerviousTem (patchtype,lb,deltim, & ! soil ground and wetland heat capacity DO i = 1, nl_soil vf_water(i) = wliq_gpersno(i)/(dz_gpersno(i)*denh2o) - vf_ice(i) = wice_gpersno(i)/(dz_gpersno(i)*denice) + vf_ice(i) = wice_gpersno(i)/(dz_gpersno(i)*denice) CALL soil_hcap_cond(vf_gravels(i),vf_om(i),vf_sand(i),porsl(i),& wf_gravels(i),wf_sand(i),k_solids(i),& csol(i),dkdry(i),dksatu(i),dksatf(i),& diff --git a/main/URBAN/MOD_Urban_RoofTemperature.F90 b/main/URBAN/MOD_Urban_RoofTemperature.F90 index 142c41f6..40094ed0 100644 --- a/main/URBAN/MOD_Urban_RoofTemperature.F90 +++ b/main/URBAN/MOD_Urban_RoofTemperature.F90 @@ -37,7 +37,7 @@ SUBROUTINE UrbanRoofTem (lb,deltim,capr,cnfac,& ! interface to the node j+1. The equation is solved using the Crank-Nicholson ! method and resulted in a tridiagonal system equation. ! -! Phase change (see meltf.F90) +! Phase change (see MOD_PhaseChange.F90) ! ! Original author : Yongjiu Dai, 05/2020 !======================================================================= @@ -50,26 +50,26 @@ SUBROUTINE UrbanRoofTem (lb,deltim,capr,cnfac,& 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 + 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) :: 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) :: 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(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] @@ -84,25 +84,25 @@ SUBROUTINE UrbanRoofTem (lb,deltim,capr,cnfac,& 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) 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 @@ -119,13 +119,15 @@ SUBROUTINE UrbanRoofTem (lb,deltim,capr,cnfac,& ENDIF cv(1:) = cv_roof(1:)*dz_roofsno(1:) + + ! snow exist when there is no snow layer IF (lb == 1 .and. scv_roof > 0.0) THEN cv(1) = cv(1) + cpice*scv_roof - ELSE - !ponding water - cv(1) = cv(1) + cpliq*wliq_roofsno(1) + cpice*wice_roofsno(1) ENDIF + ! ponding water or ice exist + cv(1) = cv(1) + cpliq*wliq_roofsno(1) + cpice*wice_roofsno(1) + ! thermal conductivity ! Thermal conductivity of snow, which from Yen (1980) IF (lb <= 0) THEN @@ -151,12 +153,6 @@ SUBROUTINE UrbanRoofTem (lb,deltim,capr,cnfac,& ENDDO tk(nl_roof) = thk(nl_roof) -!??? -! ! update thermal conductivity of the ponding water -! zh2osfc=1.0e-3*(0.5*h2osfc(c)) !convert to [m] from [mm] -! tk(1)= tkwat*thk(1)*(z(1)+zh2osfc) & -! /(tkwat*z(1)+thk(1)*zh2osfc) - ! net ground heat flux into the roof surface and its temperature derivative hs = sabroof + lroof - (fsenroof+fevproof*htvp) dhsdT = - croof + clroof diff --git a/main/URBAN/MOD_Urban_WallTemperature.F90 b/main/URBAN/MOD_Urban_WallTemperature.F90 index c4aa283e..c1ad7a17 100644 --- a/main/URBAN/MOD_Urban_WallTemperature.F90 +++ b/main/URBAN/MOD_Urban_WallTemperature.F90 @@ -42,9 +42,9 @@ SUBROUTINE UrbanWallTem (deltim,capr,cnfac,& 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] @@ -53,38 +53,38 @@ SUBROUTINE UrbanWallTem (deltim,capr,cnfac,& 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] !------------------------ 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) hs !net energy flux into the surface (w/m2) + REAL(r8) dhsdt !d(hs)/dT INTEGER i,j From 4b144145727f6f8573f0bf41a941f3f86dfb380f Mon Sep 17 00:00:00 2001 From: Hua Yuan Date: Wed, 24 Jan 2024 10:27:31 +0800 Subject: [PATCH 2/4] Make code indent and keywords case adjustment. -mod(main/*.F90): unify the code indent and keywords case. --- main/CoLM.F90 | 18 +- main/CoLMDRIVER.F90 | 533 +-- main/CoLMMAIN.F90 | 542 ++-- main/MOD_3DCanopyRadiation.F90 | 1457 ++++----- main/MOD_Aerosol.F90 | 746 ++--- main/MOD_Albedo.F90 | 1458 +++++---- main/MOD_AssimStomataConductance.F90 | 391 ++- main/MOD_CanopyLayerProfile.F90 | 1350 ++++---- main/MOD_Const_LC.F90 | 4 +- main/MOD_Const_PFT.F90 | 240 +- main/MOD_Const_Physical.F90 | 36 +- main/MOD_CropReadin.F90 | 149 +- main/MOD_Eroot.F90 | 110 +- main/MOD_FireData.F90 | 102 +- main/MOD_Forcing.F90 | 1272 ++++---- main/MOD_FrictionVelocity.F90 | 855 +++-- main/MOD_Glacier.F90 | 658 ++-- main/MOD_GroundFluxes.F90 | 224 +- main/MOD_GroundTemperature.F90 | 390 +-- main/MOD_Hist.F90 | 1880 +++++------ main/MOD_Irrigation.F90 | 674 ++-- main/MOD_LAIEmpirical.F90 | 40 +- main/MOD_LAIReadin.F90 | 106 +- main/MOD_LeafTemperature.F90 | 1194 +++---- main/MOD_LeafTemperaturePC.F90 | 2221 +++++++------ main/MOD_LightningData.F90 | 60 +- main/MOD_MonthlyinSituCO2MaunaLoa.F90 | 36 +- main/MOD_NdepData.F90 | 152 +- main/MOD_NewSnow.F90 | 152 +- main/MOD_NitrifData.F90 | 124 +- main/MOD_OrbCoszen.F90 | 39 +- main/MOD_Ozone.F90 | 492 +-- main/MOD_PhaseChange.F90 | 1114 +++---- main/MOD_PlantHydraulic.F90 | 1817 +++++------ main/MOD_Qsadv.F90 | 104 +- main/MOD_RainSnowTemp.F90 | 374 +-- main/MOD_SimpleOcean.F90 | 427 ++- main/MOD_SnowFraction.F90 | 152 +- main/MOD_SnowLayersCombineDivide.F90 | 891 +++-- main/MOD_SnowSnicar.F90 | 4290 ++++++++++++------------- main/MOD_SoilSurfaceResistance.F90 | 330 +- main/MOD_Thermal.F90 | 274 +- main/MOD_Vars_1DAccFluxes.F90 | 1070 +++--- main/MOD_Vars_1DFluxes.F90 | 269 +- main/MOD_Vars_1DForcing.F90 | 356 +- main/MOD_Vars_1DPFTFluxes.F90 | 256 +- main/MOD_Vars_2DForcing.F90 | 64 +- main/MOD_Vars_Global.F90 | 6 +- main/MOD_Vars_TimeInvariants.F90 | 1140 +++---- main/MOD_Vars_TimeVariables.F90 | 1760 +++++----- main/MOD_WetBulb.F90 | 46 +- mksrfdata/Aggregation_LAI.F90 | 6 +- 52 files changed, 16212 insertions(+), 16239 deletions(-) diff --git a/main/CoLM.F90 b/main/CoLM.F90 index 621bbf43..fe2618ae 100644 --- a/main/CoLM.F90 +++ b/main/CoLM.F90 @@ -1,18 +1,6 @@ #include PROGRAM CoLM - ! ====================================================================== - ! Reference: - ! [1] Dai et al., 2003: The Common Land Model (CoLM). - ! Bull. of Amer. Meter. Soc., 84: 1013-1023 - ! [2] Dai et al., 2004: A two-big-leaf model for canopy temperature, - ! photosynthesis and stomatal conductance. J. Climate, 17: 2281-2299. - ! [3] Dai et al., 2014: The Terrestrial Modeling System (TMS). - ! [4] Dai Yamazaki, 2014: The global river model CaMa-Flood (version 3.6.2) - ! - ! Created by Yongjiu Dai, Februay 2004 - ! Revised by Yongjiu Dai and Hua Yuan, April 2014 - ! ====================================================================== USE MOD_Precision USE MOD_SPMD_Task @@ -414,7 +402,7 @@ PROGRAM CoLM #endif #if(defined CaMa_Flood) - call colm_CaMa_drv(idate(3)) ! run CaMa-Flood + CALL colm_CaMa_drv(idate(3)) ! run CaMa-Flood #endif #ifdef DataAssimilation @@ -480,7 +468,7 @@ PROGRAM CoLM ELSE ! Update every 8 days (time interval of the MODIS LAI data) Julian_8day = int(calendarday(jdate)-1)/8*8 + 1 - if ((itstamp < etstamp) .and. (Julian_8day /= Julian_8day_p)) then + IF ((itstamp < etstamp) .and. (Julian_8day /= Julian_8day_p)) THEN CALL LAI_readin (jdate(1), Julian_8day, dir_landdata) ! 06/2023, yuan: or depend on DEF_LAI_CHANGE_YEARLY nanemlist !CALL LAI_readin (lai_year, Julian_8day, dir_landdata) @@ -496,7 +484,7 @@ PROGRAM CoLM #endif #if(defined CaMa_Flood) IF (p_is_master) THEN - call colm_cama_write_restart (jdate, lc_year, casename, dir_restart) + CALL colm_cama_write_restart (jdate, lc_year, casename, dir_restart) ENDIF #endif ENDIF diff --git a/main/CoLMDRIVER.F90 b/main/CoLMDRIVER.F90 index 5caf8689..8625629c 100644 --- a/main/CoLMDRIVER.F90 +++ b/main/CoLMDRIVER.F90 @@ -11,38 +11,39 @@ SUBROUTINE CoLMDRIVER (idate,deltim,dolai,doalb,dosst,oro) ! !======================================================================= - USE MOD_Precision - USE MOD_Const_Physical, only: tfrz, rgas, vonkar - USE MOD_Const_LC - USE MOD_Vars_Global - USE MOD_Vars_TimeInvariants - USE MOD_Vars_TimeVariables - USE MOD_Vars_1DForcing - USE MOD_Vars_1DFluxes - USE MOD_LandPatch, only: numpatch - USE MOD_LandUrban, only: patch2urban - USE MOD_Namelist, only: DEF_forcing, DEF_URBAN_RUN - USE MOD_Forcing, only: forcmask - USE omp_lib + USE MOD_Precision + USE MOD_Const_Physical, only: tfrz, rgas, vonkar + USE MOD_Const_LC + USE MOD_Vars_Global + USE MOD_Vars_TimeInvariants + USE MOD_Vars_TimeVariables + USE MOD_Vars_1DForcing + USE MOD_Vars_1DFluxes + USE MOD_LandPatch, only: numpatch + USE MOD_LandUrban, only: patch2urban + USE MOD_Namelist, only: DEF_forcing, DEF_URBAN_RUN + USE MOD_Forcing, only: forcmask + USE omp_lib #ifdef CaMa_Flood ! get flood variables: inundation depth[mm], inundation fraction [0-1], ! inundation evaporation [mm/s], inundation re-infiltration[mm/s] - USE MOD_CaMa_Vars, only : flddepth_cama,fldfrc_cama,fevpg_fld,finfg_fld + USE MOD_CaMa_Vars, only : flddepth_cama,fldfrc_cama,fevpg_fld,finfg_fld #endif - IMPLICIT NONE - integer, intent(in) :: idate(3) ! model calendar for next time step (year, julian day, seconds) - real(r8), intent(in) :: deltim ! seconds in a time-step + IMPLICIT NONE - logical, intent(in) :: dolai ! true if time for time-varying vegetation paramter - logical, intent(in) :: doalb ! true if time for surface albedo calculation - logical, intent(in) :: dosst ! true if time for update sst/ice/snow + integer, intent(in) :: idate(3) ! model calendar for next time step (year, julian day, seconds) + real(r8), intent(in) :: deltim ! seconds in a time-step - real(r8), intent(inout) :: oro(numpatch) ! ocean(0)/seaice(2)/ flag + logical, intent(in) :: dolai ! true if time for time-varying vegetation paramter + logical, intent(in) :: doalb ! true if time for surface albedo calculation + logical, intent(in) :: dosst ! true if time for update sst/ice/snow - real(r8) :: deltim_phy - integer :: steps_in_one_deltim - integer :: i, m, u, k + real(r8), intent(inout) :: oro(numpatch) ! ocean(0)/seaice(2)/ flag + + real(r8) :: deltim_phy + integer :: steps_in_one_deltim + integer :: i, m, u, k ! ====================================================================== @@ -52,277 +53,277 @@ SUBROUTINE CoLMDRIVER (idate,deltim,dolai,doalb,dosst,oro) !$OMP SCHEDULE(STATIC, 1) #endif - DO i = 1, numpatch + DO i = 1, numpatch - ! Apply forcing mask - IF (DEF_forcing%has_missing_value) THEN - IF (.not. forcmask(i)) CYCLE - ENDIF + ! Apply forcing mask + IF (DEF_forcing%has_missing_value) THEN + IF (.not. forcmask(i)) CYCLE + ENDIF - ! Apply patch mask - IF (.not. patchmask(i)) CYCLE + ! Apply patch mask + IF (.not. patchmask(i)) CYCLE - m = patchclass(i) + m = patchclass(i) - steps_in_one_deltim = 1 - ! deltim need to be within 1800s for waterbody with snow in order to avoid large - ! temperature fluctuations due to rapid snow heat conductance - IF(m == WATERBODY .and. snowdp(i) > 0.0) steps_in_one_deltim = ceiling(deltim/1800.) - deltim_phy = deltim/steps_in_one_deltim + steps_in_one_deltim = 1 + ! deltim need to be within 1800s for waterbody with snow in order to avoid large + ! temperature fluctuations due to rapid snow heat conductance + IF(m == WATERBODY .and. snowdp(i) > 0.0) steps_in_one_deltim = ceiling(deltim/1800.) + deltim_phy = deltim/steps_in_one_deltim - ! For non urban patch or slab urban - IF (.not.DEF_URBAN_RUN .or. m.ne.URBAN) THEN + ! For non urban patch or slab urban + IF (.not.DEF_URBAN_RUN .or. m.ne.URBAN) THEN - DO k = 1, steps_in_one_deltim - ! ***** Call CoLM main program ***** - ! - CALL CoLMMAIN (i,idate, coszen(i), deltim_phy, & - patchlonr(i), patchlatr(i), patchclass(i), patchtype(i), & - doalb, dolai, dosst, oro(i), & + DO k = 1, steps_in_one_deltim + ! ***** Call CoLM main program ***** + ! + CALL CoLMMAIN (i,idate, coszen(i), deltim_phy, & + patchlonr(i), patchlatr(i), patchclass(i), patchtype(i), & + doalb, dolai, dosst, oro(i), & - ! SOIL INFORMATION AND LAKE DEPTH - soil_s_v_alb(i), soil_d_v_alb(i), soil_s_n_alb(i), soil_d_n_alb(i), & - vf_quartz(1:,i), vf_gravels(1:,i),vf_om(1:,i), vf_sand(1:,i), & - wf_gravels(1:,i),wf_sand(1:,i), porsl(1:,i), psi0(1:,i), & - bsw(1:,i), & + ! SOIL INFORMATION AND LAKE DEPTH + soil_s_v_alb(i), soil_d_v_alb(i), soil_s_n_alb(i), soil_d_n_alb(i), & + vf_quartz(1:,i), vf_gravels(1:,i),vf_om(1:,i), vf_sand(1:,i), & + wf_gravels(1:,i),wf_sand(1:,i), porsl(1:,i), psi0(1:,i), & + bsw(1:,i), & #ifdef vanGenuchten_Mualem_SOIL_MODEL - theta_r(1:,i), alpha_vgm(1:,i), n_vgm(1:,i), L_vgm(1:,i), & - sc_vgm (1:,i), fc_vgm (1:,i), & + theta_r(1:,i), alpha_vgm(1:,i), n_vgm(1:,i), L_vgm(1:,i), & + sc_vgm (1:,i), fc_vgm (1:,i), & #endif - hksati(1:,i), csol(1:,i), k_solids(1:,i), dksatu(1:,i), & - dksatf(1:,i), dkdry(1:,i), & - BA_alpha(1:,i), BA_beta(1:,i), & - rootfr(1:,m), lakedepth(i), dz_lake(1:,i), & + hksati(1:,i), csol(1:,i), k_solids(1:,i), dksatu(1:,i), & + dksatf(1:,i), dkdry(1:,i), & + BA_alpha(1:,i), BA_beta(1:,i), & + rootfr(1:,m), lakedepth(i), dz_lake(1:,i), & #if(defined CaMa_Flood) - ! flood variables [mm, m2/m2, mm/s, mm/s] - flddepth_cama(i),fldfrc_cama(i),fevpg_fld(i), finfg_fld(i), & + ! flood variables [mm, m2/m2, mm/s, mm/s] + flddepth_cama(i),fldfrc_cama(i),fevpg_fld(i), finfg_fld(i), & #endif - ! VEGETATION INFORMATION - htop(i), hbot(i), sqrtdi(m), & - effcon(m), vmax25(m), & - kmax_sun(m), kmax_sha(m), kmax_xyl(m), kmax_root(m), & - psi50_sun(m), psi50_sha(m), psi50_xyl(m), psi50_root(m), & - ck(m), & - slti(m), hlti(m), & - shti(m), hhti(m), trda(m), trdm(m), & - trop(m), g1(m), g0(m),gradm(m), binter(m), & - extkn(m), chil(m), rho(1:,1:,m), tau(1:,1:,m), & - - ! ATMOSPHERIC FORCING - forc_pco2m(i), forc_po2m(i), forc_us(i), forc_vs(i), & - forc_t(i), forc_q(i), forc_prc(i), forc_prl(i), & - forc_rain(i), forc_snow(i), forc_psrf(i), forc_pbot(i), & - forc_sols(i), forc_soll(i), forc_solsd(i), forc_solld(i), & - forc_frl(i), forc_hgt_u(i), forc_hgt_t(i), forc_hgt_q(i), & - forc_rhoair(i), & - ! CBL height forcing - forc_hpbl(i), & - ! Aerosol deposition - forc_aerdep(:,i), & - - ! LAND SURFACE VARIABLES REQUIRED FOR RESTART - z_sno(maxsnl+1:,i), dz_sno(maxsnl+1:,i), & - t_soisno(maxsnl+1:,i), wliq_soisno(maxsnl+1:,i), & - wice_soisno(maxsnl+1:,i), smp(1:,i), hk(1:,i), & - t_grnd(i), tleaf(i), ldew(i),ldew_rain(i),ldew_snow(i),& - sag(i), scv(i), snowdp(i), fveg(i), & - fsno(i), sigf(i), green(i), lai(i), & - sai(i), alb(1:,1:,i), ssun(1:,1:,i), ssha(1:,1:,i), & - ssoi(:,:,i), ssno(:,:,i), thermk(i), extkb(i), & - extkd(i), vegwp(1:,i), gs0sun(i), gs0sha(i), & - ! Ozone Stress Variables - lai_old(i), o3uptakesun(i), o3uptakesha(i) ,forc_ozone(i), & - ! End ozone stress variables - zwt(i), wdsrf(i), wa(i), wetwat(i), & - t_lake(1:,i), lake_icefrac(1:,i), savedtke1(i), & - - ! SNICAR snow model related - snw_rds(:,i), ssno_lyr(:,:,:,i), & - mss_bcpho(:,i), mss_bcphi(:,i), mss_ocpho(:,i), mss_ocphi(:,i), & - mss_dst1(:,i), mss_dst2(:,i), mss_dst3(:,i), mss_dst4(:,i), & - - ! additional diagnostic variables for output - laisun(i), laisha(i), rootr(1:,i),rootflux(1:,i),rss(i),& - rstfacsun_out(i),rstfacsha_out(i),gssun_out(i), gssha_out(i), & - assimsun_out(i), etrsun_out(i), assimsha_out(i), etrsha_out(i), & - h2osoi(1:,i), wat(i), & - - ! FLUXES - taux(i), tauy(i), fsena(i), fevpa(i), & - lfevpa(i), fsenl(i), fevpl(i), etr(i), & - fseng(i), fevpg(i), olrg(i), fgrnd(i), & - trad(i), tref(i), qref(i), rsur(i), & - rnof(i), qintr(i), qinfl(i), qdrip(i), & - rst(i), assim(i), respc(i), sabvsun(i), & - sabvsha(i), sabg(i), sr(i), solvd(i), & - solvi(i), solnd(i), solni(i), srvd(i), & - srvi(i), srnd(i), srni(i), solvdln(i), & - solviln(i), solndln(i), solniln(i), srvdln(i), & - srviln(i), srndln(i), srniln(i), qcharge(i), & - xerr(i), zerr(i), & - - ! TUNABLE modle constants - zlnd, zsno, csoilc, dewmx, & - wtfact, capr, cnfac, ssi, & - wimp, pondmx, smpmax, smpmin, & - trsmx0, tcrit, & - - ! additional variables required by coupling with WRF model - emis(i), z0m(i), zol(i), rib(i), & - ustar(i), qstar(i), tstar(i), & - fm(i), fh(i), fq(i) ) - - END DO - ENDIF + ! VEGETATION INFORMATION + htop(i), hbot(i), sqrtdi(m), & + effcon(m), vmax25(m), & + kmax_sun(m), kmax_sha(m), kmax_xyl(m), kmax_root(m), & + psi50_sun(m), psi50_sha(m), psi50_xyl(m), psi50_root(m), & + ck(m), & + slti(m), hlti(m), & + shti(m), hhti(m), trda(m), trdm(m), & + trop(m), g1(m), g0(m),gradm(m), binter(m), & + extkn(m), chil(m), rho(1:,1:,m), tau(1:,1:,m), & + + ! ATMOSPHERIC FORCING + forc_pco2m(i), forc_po2m(i), forc_us(i), forc_vs(i), & + forc_t(i), forc_q(i), forc_prc(i), forc_prl(i), & + forc_rain(i), forc_snow(i), forc_psrf(i), forc_pbot(i), & + forc_sols(i), forc_soll(i), forc_solsd(i), forc_solld(i), & + forc_frl(i), forc_hgt_u(i), forc_hgt_t(i), forc_hgt_q(i), & + forc_rhoair(i), & + ! CBL height forcing + forc_hpbl(i), & + ! Aerosol deposition + forc_aerdep(:,i), & + + ! LAND SURFACE VARIABLES REQUIRED FOR RESTART + z_sno(maxsnl+1:,i), dz_sno(maxsnl+1:,i), & + t_soisno(maxsnl+1:,i), wliq_soisno(maxsnl+1:,i), & + wice_soisno(maxsnl+1:,i), smp(1:,i), hk(1:,i), & + t_grnd(i), tleaf(i), ldew(i),ldew_rain(i),ldew_snow(i),& + sag(i), scv(i), snowdp(i), fveg(i), & + fsno(i), sigf(i), green(i), lai(i), & + sai(i), alb(1:,1:,i), ssun(1:,1:,i), ssha(1:,1:,i), & + ssoi(:,:,i), ssno(:,:,i), thermk(i), extkb(i), & + extkd(i), vegwp(1:,i), gs0sun(i), gs0sha(i), & + ! Ozone Stress Variables + lai_old(i), o3uptakesun(i), o3uptakesha(i) ,forc_ozone(i), & + ! End ozone stress variables + zwt(i), wdsrf(i), wa(i), wetwat(i), & + t_lake(1:,i), lake_icefrac(1:,i), savedtke1(i), & + + ! SNICAR snow model related + snw_rds(:,i), ssno_lyr(:,:,:,i), & + mss_bcpho(:,i), mss_bcphi(:,i), mss_ocpho(:,i), mss_ocphi(:,i), & + mss_dst1(:,i), mss_dst2(:,i), mss_dst3(:,i), mss_dst4(:,i), & + + ! additional diagnostic variables for output + laisun(i), laisha(i), rootr(1:,i),rootflux(1:,i),rss(i),& + rstfacsun_out(i),rstfacsha_out(i),gssun_out(i), gssha_out(i), & + assimsun_out(i), etrsun_out(i), assimsha_out(i), etrsha_out(i), & + h2osoi(1:,i), wat(i), & + + ! FLUXES + taux(i), tauy(i), fsena(i), fevpa(i), & + lfevpa(i), fsenl(i), fevpl(i), etr(i), & + fseng(i), fevpg(i), olrg(i), fgrnd(i), & + trad(i), tref(i), qref(i), rsur(i), & + rnof(i), qintr(i), qinfl(i), qdrip(i), & + rst(i), assim(i), respc(i), sabvsun(i), & + sabvsha(i), sabg(i), sr(i), solvd(i), & + solvi(i), solnd(i), solni(i), srvd(i), & + srvi(i), srnd(i), srni(i), solvdln(i), & + solviln(i), solndln(i), solniln(i), srvdln(i), & + srviln(i), srndln(i), srniln(i), qcharge(i), & + xerr(i), zerr(i), & + + ! TUNABLE modle constants + zlnd, zsno, csoilc, dewmx, & + wtfact, capr, cnfac, ssi, & + wimp, pondmx, smpmax, smpmin, & + trsmx0, tcrit, & + + ! additional variables required by coupling with WRF model + emis(i), z0m(i), zol(i), rib(i), & + ustar(i), qstar(i), tstar(i), & + fm(i), fh(i), fq(i) ) + + ENDDO + ENDIF #if(defined BGC) - IF(patchtype(i) .eq. 0)THEN + IF(patchtype(i) .eq. 0)THEN - ! ***** Call CoLM BGC model ***** - ! - CALL bgc_driver (i,idate(1:3),deltim, patchlatr(i)*180/PI,patchlonr(i)*180/PI) - END IF + ! ***** Call CoLM BGC model ***** + ! + CALL bgc_driver (i,idate(1:3),deltim, patchlatr(i)*180/PI,patchlonr(i)*180/PI) + ENDIF #endif #ifdef URBAN_MODEL - ! For urban model and urban patches - IF (DEF_URBAN_RUN .and. m.eq.URBAN) THEN - - u = patch2urban(i) - !print *, "patch:", i, "urban:", u !fortest only - - ! ***** Call CoLM urban model ***** - ! - CALL UrbanCoLMMAIN ( & - ! MODEL RUNNING PARAMETERS - i ,idate ,coszen(i) ,deltim ,& - patchlonr(i) ,patchlatr(i) ,patchclass(i) ,patchtype(i) ,& - - ! URBAN PARAMETERS - froof(u) ,flake(u) ,hroof(u) ,hwr(u) ,& - fgper(u) ,em_roof(u) ,em_wall(u) ,em_gimp(u) ,& - em_gper(u) ,cv_roof(:,u) ,cv_wall(:,u) ,cv_gimp(:,u) ,& - tk_roof(:,u) ,tk_wall(:,u) ,tk_gimp(:,u) ,z_roof(:,u) ,& - z_wall(:,u) ,dz_roof(:,u) ,dz_wall(:,u) ,& - lakedepth(i) ,dz_lake(1:,i) ,& - - ! LUCY INPUT PARAMETERS - fix_holiday(:,u),week_holiday(:,u),hum_prof(:,u) ,pop_den(u) ,& - vehicle(:,u) ,weh_prof(:,u) ,wdh_prof(:,u) ,& - - ! SOIL INFORMATION AND LAKE DEPTH - vf_quartz(1:,i) ,vf_gravels(1:,i),vf_om(1:,i) ,vf_sand(1:,i) ,& - wf_gravels(1:,i),wf_sand(1:,i) ,porsl(1:,i) ,psi0(1:,i) ,& - bsw(1:,i) ,& + ! For urban model and urban patches + IF (DEF_URBAN_RUN .and. m.eq.URBAN) THEN + + u = patch2urban(i) + !print *, "patch:", i, "urban:", u !fortest only + + ! ***** Call CoLM urban model ***** + ! + CALL UrbanCoLMMAIN ( & + ! MODEL RUNNING PARAMETERS + i ,idate ,coszen(i) ,deltim ,& + patchlonr(i) ,patchlatr(i) ,patchclass(i) ,patchtype(i) ,& + + ! URBAN PARAMETERS + froof(u) ,flake(u) ,hroof(u) ,hwr(u) ,& + fgper(u) ,em_roof(u) ,em_wall(u) ,em_gimp(u) ,& + em_gper(u) ,cv_roof(:,u) ,cv_wall(:,u) ,cv_gimp(:,u) ,& + tk_roof(:,u) ,tk_wall(:,u) ,tk_gimp(:,u) ,z_roof(:,u) ,& + z_wall(:,u) ,dz_roof(:,u) ,dz_wall(:,u) ,& + lakedepth(i) ,dz_lake(1:,i) ,& + + ! LUCY INPUT PARAMETERS + fix_holiday(:,u),week_holiday(:,u),hum_prof(:,u) ,pop_den(u) ,& + vehicle(:,u) ,weh_prof(:,u) ,wdh_prof(:,u) ,& + + ! SOIL INFORMATION AND LAKE DEPTH + vf_quartz(1:,i) ,vf_gravels(1:,i),vf_om(1:,i) ,vf_sand(1:,i) ,& + wf_gravels(1:,i),wf_sand(1:,i) ,porsl(1:,i) ,psi0(1:,i) ,& + bsw(1:,i) ,& #ifdef vanGenuchten_Mualem_SOIL_MODEL - theta_r(1:,i) ,alpha_vgm(1:,i) ,n_vgm(1:,i) ,L_vgm(1:,i) ,& - sc_vgm (1:,i) ,fc_vgm (1:,i) ,& + theta_r(1:,i) ,alpha_vgm(1:,i) ,n_vgm(1:,i) ,L_vgm(1:,i) ,& + sc_vgm (1:,i) ,fc_vgm (1:,i) ,& #endif - hksati(1:,i) ,csol(1:,i) ,k_solids(1:,i), dksatu(1:,i) ,& - dksatf(1:,i) ,dkdry(1:,i) ,& - BA_alpha(1:,i) ,BA_beta(1:,i) ,& - alb_roof(:,:,u) ,alb_wall(:,:,u) ,alb_gimp(:,:,u) ,alb_gper(:,:,u) ,& - - ! VEGETATION INFORMATION - htop(i) ,hbot(i) ,sqrtdi(m) ,chil(m) ,& - effcon(m) ,vmax25(m) ,slti(m) ,hlti(m) ,& - shti(m) ,hhti(m) ,trda(m) ,trdm(m) ,& - trop(m) ,g1(m) ,g0(m),gradm(m) ,binter(m) ,& - extkn(m) ,rho(1:,1:,m) ,tau(1:,1:,m) ,rootfr(1:,m) ,& - - ! ATMOSPHERIC FORCING - forc_pco2m(i) ,forc_po2m(i) ,forc_us(i) ,forc_vs(i) ,& - forc_t(i) ,forc_q(i) ,forc_prc(i) ,forc_prl(i) ,& - forc_rain(i) ,forc_snow(i) ,forc_psrf(i) ,forc_pbot(i) ,& - forc_sols(i) ,forc_soll(i) ,forc_solsd(i) ,forc_solld(i) ,& - forc_frl(i) ,forc_hgt_u(i) ,forc_hgt_t(i) ,forc_hgt_q(i) ,& - forc_rhoair(i) ,Fhac(u) ,Fwst(u) ,Fach(u) ,& - Fahe(u) ,Fhah(u) ,vehc(u) ,meta(u) ,& - - ! LAND SURFACE VARIABLES REQUIRED FOR RESTART - z_sno_roof (maxsnl+1:,u) ,z_sno_gimp (maxsnl+1:,u) ,& - z_sno_gper (maxsnl+1:,u) ,z_sno_lake (maxsnl+1:,u) ,& - dz_sno_roof (maxsnl+1:,u) ,dz_sno_gimp (maxsnl+1:,u) ,& - dz_sno_gper (maxsnl+1:,u) ,dz_sno_lake (maxsnl+1:,u) ,& - t_roofsno (maxsnl+1:,u) ,t_gimpsno (maxsnl+1:,u) ,& - t_gpersno (maxsnl+1:,u) ,t_lakesno (maxsnl+1:,u) ,& - wliq_roofsno(maxsnl+1:,u) ,wliq_gimpsno(maxsnl+1:,u) ,& - wliq_gpersno(maxsnl+1:,u) ,wliq_lakesno(maxsnl+1:,u) ,& - wice_roofsno(maxsnl+1:,u) ,wice_gimpsno(maxsnl+1:,u) ,& - wice_gpersno(maxsnl+1:,u) ,wice_lakesno(maxsnl+1:,u) ,& - z_sno (maxsnl+1:,i) ,dz_sno (maxsnl+1:,i) ,& - wliq_soisno (maxsnl+1:,i) ,wice_soisno (maxsnl+1:,i) ,& - t_soisno (maxsnl+1:,i) ,& - smp (1:,i) ,hk (1:,i) ,& - t_wallsun (1:,u) ,t_wallsha (1:,u) ,& - - lai(i) ,sai(i) ,fveg(i) ,sigf(i) ,& - green(i) ,tleaf(i) ,ldew(i) ,t_grnd(i) ,& - - sag_roof(u) ,sag_gimp(u) ,sag_gper(u) ,sag_lake(u) ,& - scv_roof(u) ,scv_gimp(u) ,scv_gper(u) ,scv_lake(u) ,& - snowdp_roof(u) ,snowdp_gimp(u) ,snowdp_gper(u) ,snowdp_lake(u) ,& - fsno_roof(u) ,fsno_gimp(u) ,fsno_gper(u) ,fsno_lake(u) ,& - sag(i) ,scv(i) ,snowdp(i) ,fsno(i) ,& - extkd(i) ,alb(1:,1:,i) ,ssun(1:,1:,i) ,ssha(1:,1:,i) ,& - sroof(1:,1:,u) ,swsun(1:,1:,u) ,swsha(1:,1:,u) ,sgimp(1:,1:,u) ,& - sgper(1:,1:,u) ,slake(1:,1:,u) ,lwsun(u) ,lwsha(u) ,& - lgimp(u) ,lgper(u) ,lveg(u) ,fwsun(u) ,& - dfwsun(u) ,t_room(u) ,troof_inner(u) ,twsun_inner(u) ,& - twsha_inner(u) ,t_roommax(u) ,t_roommin(u) ,tafu(u) ,& - - zwt(i) ,wa(i) ,& - t_lake(1:,i) ,lake_icefrac(1:,i), savedtke1(i) ,& - - ! SNICAR snow model related - snw_rds(:,i) ,ssno_lyr(:,:,:,i),& - mss_bcpho(:,i) ,mss_bcphi(:,i) ,mss_ocpho(:,i) ,mss_ocphi(:,i) ,& - mss_dst1(:,i) ,mss_dst2(:,i) ,mss_dst3(:,i) ,mss_dst4(:,i) ,& + hksati(1:,i) ,csol(1:,i) ,k_solids(1:,i), dksatu(1:,i) ,& + dksatf(1:,i) ,dkdry(1:,i) ,& + BA_alpha(1:,i) ,BA_beta(1:,i) ,& + alb_roof(:,:,u) ,alb_wall(:,:,u) ,alb_gimp(:,:,u) ,alb_gper(:,:,u) ,& + + ! VEGETATION INFORMATION + htop(i) ,hbot(i) ,sqrtdi(m) ,chil(m) ,& + effcon(m) ,vmax25(m) ,slti(m) ,hlti(m) ,& + shti(m) ,hhti(m) ,trda(m) ,trdm(m) ,& + trop(m) ,g1(m) ,g0(m),gradm(m) ,binter(m) ,& + extkn(m) ,rho(1:,1:,m) ,tau(1:,1:,m) ,rootfr(1:,m) ,& + + ! ATMOSPHERIC FORCING + forc_pco2m(i) ,forc_po2m(i) ,forc_us(i) ,forc_vs(i) ,& + forc_t(i) ,forc_q(i) ,forc_prc(i) ,forc_prl(i) ,& + forc_rain(i) ,forc_snow(i) ,forc_psrf(i) ,forc_pbot(i) ,& + forc_sols(i) ,forc_soll(i) ,forc_solsd(i) ,forc_solld(i) ,& + forc_frl(i) ,forc_hgt_u(i) ,forc_hgt_t(i) ,forc_hgt_q(i) ,& + forc_rhoair(i) ,Fhac(u) ,Fwst(u) ,Fach(u) ,& + Fahe(u) ,Fhah(u) ,vehc(u) ,meta(u) ,& + + ! LAND SURFACE VARIABLES REQUIRED FOR RESTART + z_sno_roof (maxsnl+1:,u) ,z_sno_gimp (maxsnl+1:,u) ,& + z_sno_gper (maxsnl+1:,u) ,z_sno_lake (maxsnl+1:,u) ,& + dz_sno_roof (maxsnl+1:,u) ,dz_sno_gimp (maxsnl+1:,u) ,& + dz_sno_gper (maxsnl+1:,u) ,dz_sno_lake (maxsnl+1:,u) ,& + t_roofsno (maxsnl+1:,u) ,t_gimpsno (maxsnl+1:,u) ,& + t_gpersno (maxsnl+1:,u) ,t_lakesno (maxsnl+1:,u) ,& + wliq_roofsno(maxsnl+1:,u) ,wliq_gimpsno(maxsnl+1:,u) ,& + wliq_gpersno(maxsnl+1:,u) ,wliq_lakesno(maxsnl+1:,u) ,& + wice_roofsno(maxsnl+1:,u) ,wice_gimpsno(maxsnl+1:,u) ,& + wice_gpersno(maxsnl+1:,u) ,wice_lakesno(maxsnl+1:,u) ,& + z_sno (maxsnl+1:,i) ,dz_sno (maxsnl+1:,i) ,& + wliq_soisno (maxsnl+1:,i) ,wice_soisno (maxsnl+1:,i) ,& + t_soisno (maxsnl+1:,i) ,& + smp (1:,i) ,hk (1:,i) ,& + t_wallsun (1:,u) ,t_wallsha (1:,u) ,& + + lai(i) ,sai(i) ,fveg(i) ,sigf(i) ,& + green(i) ,tleaf(i) ,ldew(i) ,t_grnd(i) ,& + + sag_roof(u) ,sag_gimp(u) ,sag_gper(u) ,sag_lake(u) ,& + scv_roof(u) ,scv_gimp(u) ,scv_gper(u) ,scv_lake(u) ,& + snowdp_roof(u) ,snowdp_gimp(u) ,snowdp_gper(u) ,snowdp_lake(u) ,& + fsno_roof(u) ,fsno_gimp(u) ,fsno_gper(u) ,fsno_lake(u) ,& + sag(i) ,scv(i) ,snowdp(i) ,fsno(i) ,& + extkd(i) ,alb(1:,1:,i) ,ssun(1:,1:,i) ,ssha(1:,1:,i) ,& + sroof(1:,1:,u) ,swsun(1:,1:,u) ,swsha(1:,1:,u) ,sgimp(1:,1:,u) ,& + sgper(1:,1:,u) ,slake(1:,1:,u) ,lwsun(u) ,lwsha(u) ,& + lgimp(u) ,lgper(u) ,lveg(u) ,fwsun(u) ,& + dfwsun(u) ,t_room(u) ,troof_inner(u) ,twsun_inner(u) ,& + twsha_inner(u) ,t_roommax(u) ,t_roommin(u) ,tafu(u) ,& + + zwt(i) ,wa(i) ,& + t_lake(1:,i) ,lake_icefrac(1:,i), savedtke1(i) ,& + + ! SNICAR snow model related + snw_rds(:,i) ,ssno_lyr(:,:,:,i),& + mss_bcpho(:,i) ,mss_bcphi(:,i) ,mss_ocpho(:,i) ,mss_ocphi(:,i) ,& + mss_dst1(:,i) ,mss_dst2(:,i) ,mss_dst3(:,i) ,mss_dst4(:,i) ,& #if(defined CaMa_Flood) - ! flood variables [mm, m2/m2, mm/s, mm/s] - flddepth_cama(i),fldfrc_cama(i) ,fevpg_fld(i) ,finfg_fld(i) ,& + ! flood variables [mm, m2/m2, mm/s, mm/s] + flddepth_cama(i),fldfrc_cama(i) ,fevpg_fld(i) ,finfg_fld(i) ,& #endif - ! additional diagnostic variables for output - laisun(i) ,laisha(i) ,rss(i) ,& - rstfacsun_out(i),h2osoi(1:,i) ,wat(i) ,& - - ! FLUXES - taux(i) ,tauy(i) ,fsena(i) ,fevpa(i) ,& - lfevpa(i) ,fsenl(i) ,fevpl(i) ,etr(i) ,& - fseng(i) ,fevpg(i) ,olrg(i) ,fgrnd(i) ,& - fsen_roof(u) ,fsen_wsun(u) ,fsen_wsha(u) ,fsen_gimp(u) ,& - fsen_gper(u) ,fsen_urbl(u) ,t_roof(u) ,t_wall(u) ,& - lfevp_roof(u) ,lfevp_gimp(u) ,lfevp_gper(u) ,lfevp_urbl(u) ,& - trad(i) ,tref(i) ,&!tmax(i) ,tmin(i) ,& - qref(i) ,rsur(i) ,rnof(i) ,qintr(i) ,& - qinfl(i) ,qdrip(i) ,rst(i) ,assim(i) ,& - respc(i) ,sabvsun(i) ,sabvsha(i) ,sabg(i) ,& - sr(i) ,solvd(i) ,solvi(i) ,solnd(i) ,& - solni(i) ,srvd(i) ,srvi(i) ,srnd(i) ,& - srni(i) ,solvdln(i) ,solviln(i) ,solndln(i) ,& - solniln(i) ,srvdln(i) ,srviln(i) ,srndln(i) ,& - srniln(i) ,qcharge(i) ,xerr(i) ,zerr(i) ,& - - ! TUNABLE modle constants - zlnd ,zsno ,csoilc ,dewmx ,& - wtfact ,capr ,cnfac ,ssi ,& - wimp ,pondmx ,smpmax ,smpmin ,& - trsmx0 ,tcrit ,& - - ! additional variables required by coupling with WRF model - emis(i) ,z0m(i) ,zol(i) ,rib(i) ,& - ustar(i) ,qstar(i) ,tstar(i) ,fm(i) ,& - fh(i) ,fq(i) ,forc_hpbl(i) ) - ENDIF + ! additional diagnostic variables for output + laisun(i) ,laisha(i) ,rss(i) ,& + rstfacsun_out(i),h2osoi(1:,i) ,wat(i) ,& + + ! FLUXES + taux(i) ,tauy(i) ,fsena(i) ,fevpa(i) ,& + lfevpa(i) ,fsenl(i) ,fevpl(i) ,etr(i) ,& + fseng(i) ,fevpg(i) ,olrg(i) ,fgrnd(i) ,& + fsen_roof(u) ,fsen_wsun(u) ,fsen_wsha(u) ,fsen_gimp(u) ,& + fsen_gper(u) ,fsen_urbl(u) ,t_roof(u) ,t_wall(u) ,& + lfevp_roof(u) ,lfevp_gimp(u) ,lfevp_gper(u) ,lfevp_urbl(u) ,& + trad(i) ,tref(i) ,&!tmax(i) ,tmin(i) ,& + qref(i) ,rsur(i) ,rnof(i) ,qintr(i) ,& + qinfl(i) ,qdrip(i) ,rst(i) ,assim(i) ,& + respc(i) ,sabvsun(i) ,sabvsha(i) ,sabg(i) ,& + sr(i) ,solvd(i) ,solvi(i) ,solnd(i) ,& + solni(i) ,srvd(i) ,srvi(i) ,srnd(i) ,& + srni(i) ,solvdln(i) ,solviln(i) ,solndln(i) ,& + solniln(i) ,srvdln(i) ,srviln(i) ,srndln(i) ,& + srniln(i) ,qcharge(i) ,xerr(i) ,zerr(i) ,& + + ! TUNABLE modle constants + zlnd ,zsno ,csoilc ,dewmx ,& + wtfact ,capr ,cnfac ,ssi ,& + wimp ,pondmx ,smpmax ,smpmin ,& + trsmx0 ,tcrit ,& + + ! additional variables required by coupling with WRF model + emis(i) ,z0m(i) ,zol(i) ,rib(i) ,& + ustar(i) ,qstar(i) ,tstar(i) ,fm(i) ,& + fh(i) ,fq(i) ,forc_hpbl(i) ) + ENDIF #endif - ENDDO + ENDDO #ifdef OPENMP !$OMP END PARALLEL DO #endif diff --git a/main/CoLMMAIN.F90 b/main/CoLMMAIN.F90 index a8c65617..35913b6c 100644 --- a/main/CoLMMAIN.F90 +++ b/main/CoLMMAIN.F90 @@ -31,11 +31,10 @@ SUBROUTINE CoLMMAIN ( & effcon, vmax25, & kmax_sun, kmax_sha, kmax_xyl, kmax_root, & psi50_sun, psi50_sha, psi50_xyl, psi50_root, & - ck, & - slti, hlti, & - shti, hhti, trda, trdm, & - trop, g1, g0, gradm, & - binter, extkn, chil, rho, tau,& + ck, slti, hlti, shti, & + hhti, trda, trdm, trop, & + g1, g0, gradm, binter, & + extkn, chil, rho, tau, & ! atmospheric forcing forc_pco2m, forc_po2m, forc_us, forc_vs, & @@ -134,32 +133,32 @@ SUBROUTINE CoLMMAIN ( & ! !======================================================================= - USE MOD_Precision - USE MOD_Vars_Global - USE MOD_Const_Physical, only: tfrz, denh2o, denice, cpliq, cpice - USE MOD_Vars_TimeVariables, only: tlai, tsai, irrig_rate + USE MOD_Precision + USE MOD_Vars_Global + USE MOD_Const_Physical, only: tfrz, denh2o, denice, cpliq, cpice + USE MOD_Vars_TimeVariables, only: tlai, tsai, irrig_rate #if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) - USE MOD_LandPFT, only : patch_pft_s, patch_pft_e - USE MOD_Vars_PFTimeInvariants - USE MOD_Vars_PFTimeVariables + USE MOD_LandPFT, only : patch_pft_s, patch_pft_e + USE MOD_Vars_PFTimeInvariants + USE MOD_Vars_PFTimeVariables #endif - USE MOD_RainSnowTemp - USE MOD_NetSolar - USE MOD_OrbCoszen - USE MOD_NewSnow - USE MOD_Thermal - USE MOD_SoilSnowHydrology - USE MOD_SnowFraction - USE MOD_SnowLayersCombineDivide - USE MOD_Glacier - USE MOD_Lake - USE MOD_SimpleOcean - USE MOD_Albedo - USE MOD_LAIEmpirical - USE MOD_TimeManager - USE MOD_Namelist, only: DEF_Interception_scheme, DEF_USE_VariablySaturatedFlow, & - DEF_USE_PLANTHYDRAULICS, DEF_USE_IRRIGATION - USE MOD_LeafInterception + USE MOD_RainSnowTemp + USE MOD_NetSolar + USE MOD_OrbCoszen + USE MOD_NewSnow + USE MOD_Thermal + USE MOD_SoilSnowHydrology + USE MOD_SnowFraction + USE MOD_SnowLayersCombineDivide + USE MOD_Glacier + USE MOD_Lake + USE MOD_SimpleOcean + USE MOD_Albedo + USE MOD_LAIEmpirical + USE MOD_TimeManager + USE MOD_Namelist, only: DEF_Interception_scheme, DEF_USE_VariablySaturatedFlow, & + DEF_USE_PLANTHYDRAULICS, DEF_USE_IRRIGATION + USE MOD_LeafInterception #if(defined CaMa_Flood) ! get flood depth [mm], flood fraction[0-1], flood evaporation [mm/s], flood inflow [mm/s] USE MOD_CaMa_colmCaMa, only: get_fldevp @@ -167,28 +166,28 @@ SUBROUTINE CoLMMAIN ( & #endif USE MOD_SPMD_Task - IMPLICIT NONE + IMPLICIT NONE ! ------------------------ Dummy Argument ------------------------------ - real(r8),intent(in) :: deltim !seconds in a time step [second] - logical, intent(in) :: doalb !true if time for surface albedo calculation - logical, intent(in) :: dolai !true if time for leaf area index calculation - logical, intent(in) :: dosst !true to update sst/ice/snow before calculation + real(r8),intent(in) :: deltim !seconds in a time step [second] + logical, intent(in) :: doalb !true if time for surface albedo calculation + logical, intent(in) :: dolai !true if time for leaf area index calculation + logical, intent(in) :: dosst !true to update sst/ice/snow before calculation - integer, intent(in) :: & + integer, intent(in) :: & ipatch ! patch index - real(r8), intent(in) :: & + real(r8), intent(in) :: & patchlonr ,&! logitude in radians patchlatr ! latitude in radians - integer, intent(in) :: & + integer, intent(in) :: & patchclass ,&! land patch class 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) ! Parameters ! ---------------------- - real(r8), intent(in) :: & + real(r8), intent(in) :: & lakedepth ,&! lake depth (m) dz_lake(nl_lake) ,&! lake layer thickness (m) @@ -274,7 +273,7 @@ SUBROUTINE CoLMMAIN ( & ! 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] @@ -305,11 +304,11 @@ SUBROUTINE CoLMMAIN ( & #endif ! Variables required for restart run ! ---------------------------------------------------------------------- - integer, intent(in) :: & + integer, intent(in) :: & idate(3) ! next time-step /year/julian day/second in a day/ - real(r8), intent(inout) :: oro ! ocean(0)/seaice(2)/ flag - real(r8), intent(inout) :: & + real(r8), intent(inout) :: oro ! ocean(0)/seaice(2)/ flag + real(r8), intent(inout) :: & z_sno (maxsnl+1:0) ,&! layer depth (m) dz_sno (maxsnl+1:0) ,&! layer thickness (m) t_soisno (maxsnl+1:nl_soil) ,&! soil + snow layer temperature [K] @@ -373,7 +372,7 @@ SUBROUTINE CoLMMAIN ( & ! additional diagnostic variables for output - real(r8), intent(out) :: & + real(r8), intent(out) :: & laisun ,&! sunlit leaf area index laisha ,&! shaded leaf area index rstfacsun_out ,&! factor of soil water stress @@ -386,14 +385,14 @@ SUBROUTINE CoLMMAIN ( & rootflux(nl_soil),&! water exchange between soil and root in different layers. Posiitive: soil->root [?] h2osoi(nl_soil) ! volumetric soil water in layers [m3/m3] - real(r8), intent(out) :: & + real(r8), intent(out) :: & assimsun_out,& etrsun_out ,& assimsha_out,& etrsha_out ! 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] @@ -507,46 +506,46 @@ SUBROUTINE CoLMMAIN ( & qintr_snow ,&! snowfall interception (mm h2o/s) errw_rsub ! the possible subsurface runoff deficit after PHS is included - integer snl ,&! number of snow layers + integer snl ,&! number of snow layers imelt(maxsnl+1:nl_soil), &! flag for: melting=1, freezing=2, Nothing happended=0 lb , lbsn, &! lower bound of arrays j ! do looping index - ! For SNICAR snow model - !---------------------------------------------------------------------- - integer snl_bef !number of snow layers - 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) t_soisno_ (maxsnl+1:1) !soil + snow layer temperature [K] - real(r8) dz_soisno_ (maxsnl+1:1) !layer thickness (m) - real(r8) sabg_snow_lyr(maxsnl+1:1) !snow layer absorption [W/m-2] + ! For SNICAR snow model + !---------------------------------------------------------------------- + integer snl_bef !number of snow layers + 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) t_soisno_ (maxsnl+1:1) !soil + snow layer temperature [K] + real(r8) dz_soisno_ (maxsnl+1:1) !layer thickness (m) + real(r8) sabg_snow_lyr(maxsnl+1:1) !snow layer absorption [W/m-2] - !---------------------------------------------------------------------- + !---------------------------------------------------------------------- - real(r8) :: a, aa, gwat - real(r8) :: wextra, t_rain, t_snow - integer ps, pe, pc + real(r8) :: a, aa, gwat + real(r8) :: wextra, t_rain, t_snow + integer ps, pe, pc !====================================================================== #if(defined CaMa_Flood) - !add variables for flood evaporation [mm/s] and re-infiltration [mm/s] calculation. - real(r8) :: kk - real(r8) :: taux_fld ! wind stress: E-W [kg/m/s**2] - real(r8) :: tauy_fld ! wind stress: N-S [kg/m/s**2] - real(r8) :: fsena_fld ! sensible heat from agcm reference height to atmosphere [W/m2] - real(r8) :: fevpa_fld ! evaporation from agcm reference height to atmosphere [mm/s] - real(r8) :: fseng_fld ! sensible heat flux from ground [W/m2] - real(r8) :: tref_fld ! 2 m height air temperature [kelvin] - real(r8) :: qref_fld ! 2 m height air humidity - real(r8) :: z0m_fld ! effective roughness [m] - real(r8) :: zol_fld ! dimensionless height (z/L) used in Monin-Obukhov theory - real(r8) :: rib_fld ! bulk Richardson number in surface layer - real(r8) :: ustar_fld ! friction velocity [m/s] - real(r8) :: tstar_fld ! temperature scaling parameter - real(r8) :: qstar_fld ! moisture scaling parameter - real(r8) :: fm_fld ! integral of profile function for momentum - real(r8) :: fh_fld ! integral of profile function for heat - real(r8) :: fq_fld ! integral of profile function for moisture + !add variables for flood evaporation [mm/s] and re-infiltration [mm/s] calculation. + real(r8) :: kk + real(r8) :: taux_fld ! wind stress: E-W [kg/m/s**2] + real(r8) :: tauy_fld ! wind stress: N-S [kg/m/s**2] + real(r8) :: fsena_fld ! sensible heat from agcm reference height to atmosphere [W/m2] + real(r8) :: fevpa_fld ! evaporation from agcm reference height to atmosphere [mm/s] + real(r8) :: fseng_fld ! sensible heat flux from ground [W/m2] + real(r8) :: tref_fld ! 2 m height air temperature [kelvin] + real(r8) :: qref_fld ! 2 m height air humidity + real(r8) :: z0m_fld ! effective roughness [m] + real(r8) :: zol_fld ! dimensionless height (z/L) used in Monin-Obukhov theory + real(r8) :: rib_fld ! bulk Richardson number in surface layer + real(r8) :: ustar_fld ! friction velocity [m/s] + real(r8) :: tstar_fld ! temperature scaling parameter + real(r8) :: qstar_fld ! moisture scaling parameter + real(r8) :: fm_fld ! integral of profile function for momentum + real(r8) :: fh_fld ! integral of profile function for heat + real(r8) :: fq_fld ! integral of profile function for moisture #endif ! 09/2022, yuan: move from CoLMDRIVER to avoid using stack memory @@ -633,7 +632,8 @@ SUBROUTINE CoLMMAIN ( & !---------------------------------------------------------------------- ! [2] Canopy interception and precipitation onto ground surface !---------------------------------------------------------------------- -qflx_irrig_sprinkler = 0._r8 + qflx_irrig_sprinkler = 0._r8 + IF (patchtype == 0) THEN #if(defined LULC_USGS || defined LULC_IGBP) @@ -741,12 +741,12 @@ SUBROUTINE CoLMMAIN ( & CALL WATER_2014 (ipatch,patchtype ,lb ,nl_soil ,& deltim ,z_soisno(lb:) ,dz_soisno(lb:) ,zi_soisno(lb-1:) ,& bsw ,porsl ,psi0 ,hksati ,& - rootr,rootflux ,t_soisno(lb:) ,wliq_soisno(lb:) ,wice_soisno(lb:) ,smp,hk,& - pg_rain ,sm ,etr ,& - qseva ,qsdew ,qsubl ,qfros ,& - qseva_soil ,qsdew_soil ,qsubl_soil ,qfros_soil ,& - qseva_snow ,qsdew_snow ,qsubl_snow ,qfros_snow ,& - fsno ,rsur ,& + rootr ,rootflux ,t_soisno(lb:) ,wliq_soisno(lb:) ,& + wice_soisno(lb:) ,smp ,hk ,pg_rain ,& + sm ,etr ,qseva ,qsdew ,& + qsubl ,qfros ,qseva_soil ,qsdew_soil ,& + qsubl_soil ,qfros_soil ,qseva_snow ,qsdew_snow ,& + qsubl_snow ,qfros_snow ,fsno ,rsur ,& rnof ,qinfl ,wtfact ,pondmx ,& ssi ,wimp ,smpmin ,zwt ,& wa ,qcharge ,errw_rsub & @@ -772,15 +772,14 @@ SUBROUTINE CoLMMAIN ( & theta_r ,alpha_vgm ,n_vgm ,L_vgm ,& sc_vgm ,fc_vgm ,& #endif - porsl ,psi0 ,hksati ,& - rootr,rootflux ,t_soisno(lb:) ,wliq_soisno(lb:) ,wice_soisno(lb:) ,smp,hk,& - pg_rain ,sm ,etr ,qseva ,& - qsdew ,qsubl ,qfros ,& - qseva_soil ,qsdew_soil ,qsubl_soil ,qfros_soil ,& - qseva_snow ,qsdew_snow ,qsubl_snow ,qfros_snow ,& - fsno ,rsur ,& - rnof ,qinfl ,wtfact ,ssi ,& - pondmx, & + porsl ,psi0 ,hksati ,rootr ,& + rootflux ,t_soisno(lb:) ,wliq_soisno(lb:) ,wice_soisno(lb:) ,& + smp ,hk ,pg_rain ,sm ,& + etr ,qseva ,qsdew ,qsubl ,& + qfros ,qseva_soil ,qsdew_soil ,qsubl_soil ,& + qfros_soil ,qseva_snow ,qsdew_snow ,qsubl_snow ,& + qfros_snow ,fsno ,rsur ,rnof ,& + qinfl ,wtfact ,ssi ,pondmx ,& wimp ,zwt ,wdsrf ,wa ,& wetwat ,qcharge ,errw_rsub & #if(defined CaMa_Flood) @@ -870,11 +869,11 @@ SUBROUTINE CoLMMAIN ( & ENDIF ENDIF #if(defined CaMa_Flood) - IF (LWINFILT) THEN - IF (patchtype == 0) THEN - endwb=endwb - qinfl_fld*deltim - ENDIF - ENDIF + IF (LWINFILT) THEN + IF (patchtype == 0) THEN + endwb=endwb - qinfl_fld*deltim + ENDIF + ENDIF #endif #ifndef LATERAL_FLOW @@ -1216,7 +1215,7 @@ SUBROUTINE CoLMMAIN ( & IF (wdsrf + wa < 0) THEN wa = wa + wdsrf wdsrf = 0 - else + ELSE wdsrf = wa + wdsrf wa = 0 ENDIF @@ -1272,9 +1271,9 @@ SUBROUTINE CoLMMAIN ( & !====================================================================== ! simple ocean-sea ice model - tssea = t_grnd - tssub (1:7) = t_soisno (1:7) - CALL SOCEAN (dosst,deltim,oro,forc_hgt_u,forc_hgt_t,forc_hgt_q,& + tssea = t_grnd + tssub (1:7) = t_soisno (1:7) + CALL SOCEAN (dosst,deltim,oro,forc_hgt_u,forc_hgt_t,forc_hgt_q,& forc_us,forc_vs,forc_t,forc_t,forc_rhoair,forc_psrf,& sabg,forc_frl,tssea,tssub(1:7),scv,& taux,tauy,fsena,fevpa,lfevpa,fseng,fevpg,tref,qref,& @@ -1297,45 +1296,44 @@ SUBROUTINE CoLMMAIN ( & xerr = 0.0 !====================================================================== - ENDIF + #if(defined CaMa_Flood) -IF (LWEVAP) THEN - IF ((flddepth .gt. 1.e-6).and.(fldfrc .gt. 0.05).and.patchtype == 0)THEN - CALL get_fldevp (forc_hgt_u,forc_hgt_t,forc_hgt_q,& - forc_us,forc_vs,forc_t,forc_q,forc_rhoair,forc_psrf,t_grnd,& - forc_hpbl, & - taux_fld,tauy_fld,fseng_fld,fevpg_fld,tref_fld,qref_fld,& - z0m_fld,zol_fld,rib_fld,ustar_fld,qstar_fld,tstar_fld,fm_fld,fh_fld,fq_fld) - IF (fevpg_fld<0.0) fevpg_fld=0.0d0 - IF ((flddepth-deltim*fevpg_fld .gt. 0.0) .and. (fevpg_fld.gt.0.0)) THEN - flddepth=flddepth-deltim*fevpg_fld - !taux= taux_fld*fldfrc+(1.0-fldfrc)*taux - !tauy= tauy_fld*fldfrc+(1.0-fldfrc)*tauy - fseng= fseng_fld*fldfrc+(1.0-fldfrc)*fseng - fevpg= fevpg_fld*fldfrc+(1.0-fldfrc)*fevpg - fevpg_fld=fevpg_fld*fldfrc - !tref=tref_fld*fldfrc+(1.0-fldfrc)*tref! 2 m height air temperature [kelvin] - !qref=qref_fld*fldfrc+(1.0-fldfrc)*qref! 2 m height air humidity - !z0m=z0m_fld*fldfrc+(1.0-fldfrc)*z0m! effective roughness [m] - !zol=zol_fld*fldfrc+(1.0-fldfrc)*zol! dimensionless height (z/L) used in Monin-Obukhov theory - !rib=rib_fld*fldfrc+(1.0-fldfrc)*rib! bulk Richardson number in surface layer - !ustar=ustar_fld*fldfrc+(1.0-fldfrc)*ustar! friction velocity [m/s] - !tstar=tstar_fld*fldfrc+(1.0-fldfrc)*tstar! temperature scaling parameter - !qstar=qstar_fld*fldfrc+(1.0-fldfrc)*qstar! moisture scaling parameter - !fm=fm_fld*fldfrc+(1.0-fldfrc)*fm! integral of profile function for momentum - !fh=fh_fld*fldfrc+(1.0-fldfrc)*fh! integral of profile function for heat - !fq=fq_fld*fldfrc+(1.0-fldfrc)*fq!, &! integral of profile function for moisture + IF (LWEVAP) THEN + IF ((flddepth .gt. 1.e-6).and.(fldfrc .gt. 0.05).and.patchtype == 0)THEN + CALL get_fldevp (forc_hgt_u,forc_hgt_t,forc_hgt_q,& + forc_us,forc_vs,forc_t,forc_q,forc_rhoair,forc_psrf,t_grnd,& + forc_hpbl, & + taux_fld,tauy_fld,fseng_fld,fevpg_fld,tref_fld,qref_fld,& + z0m_fld,zol_fld,rib_fld,ustar_fld,qstar_fld,tstar_fld,fm_fld,fh_fld,fq_fld) + IF (fevpg_fld<0.0) fevpg_fld=0.0d0 + IF ((flddepth-deltim*fevpg_fld .gt. 0.0) .and. (fevpg_fld.gt.0.0)) THEN + flddepth=flddepth-deltim*fevpg_fld + !taux= taux_fld*fldfrc+(1.0-fldfrc)*taux + !tauy= tauy_fld*fldfrc+(1.0-fldfrc)*tauy + fseng= fseng_fld*fldfrc+(1.0-fldfrc)*fseng + fevpg= fevpg_fld*fldfrc+(1.0-fldfrc)*fevpg + fevpg_fld=fevpg_fld*fldfrc + !tref=tref_fld*fldfrc+(1.0-fldfrc)*tref! 2 m height air temperature [kelvin] + !qref=qref_fld*fldfrc+(1.0-fldfrc)*qref! 2 m height air humidity + !z0m=z0m_fld*fldfrc+(1.0-fldfrc)*z0m! effective roughness [m] + !zol=zol_fld*fldfrc+(1.0-fldfrc)*zol! dimensionless height (z/L) used in Monin-Obukhov theory + !rib=rib_fld*fldfrc+(1.0-fldfrc)*rib! bulk Richardson number in surface layer + !ustar=ustar_fld*fldfrc+(1.0-fldfrc)*ustar! friction velocity [m/s] + !tstar=tstar_fld*fldfrc+(1.0-fldfrc)*tstar! temperature scaling parameter + !qstar=qstar_fld*fldfrc+(1.0-fldfrc)*qstar! moisture scaling parameter + !fm=fm_fld*fldfrc+(1.0-fldfrc)*fm! integral of profile function for momentum + !fh=fh_fld*fldfrc+(1.0-fldfrc)*fh! integral of profile function for heat + !fq=fq_fld*fldfrc+(1.0-fldfrc)*fq!, &! integral of profile function for moisture + ELSE + fevpg_fld=0.0d0 + ENDIF + ELSE + fevpg_fld=0.0d0 + ENDIF ELSE fevpg_fld=0.0d0 ENDIF - ELSE - fevpg_fld=0.0d0 - ENDIF -ELSE - fevpg_fld=0.0d0 -ENDIF - #endif @@ -1347,16 +1345,16 @@ SUBROUTINE CoLMMAIN ( & ! 4) albedos !====================================================================== - ! cosine of solar zenith angle - calday = calendarday(idate) - coszen = orb_coszen(calday,patchlonr,patchlatr) + ! cosine of solar zenith angle + calday = calendarday(idate) + coszen = orb_coszen(calday,patchlonr,patchlatr) - IF (patchtype <= 5) THEN !LAND +IF (patchtype <= 5) THEN !LAND #if(defined DYN_PHENOLOGY) - ! need to update lai and sai, fveg, green, they are done once in a day only - IF (dolai) THEN - CALL LAI_empirical(patchclass,nl_soil,rootfr,t_soisno(1:),lai,sai,fveg,green) - ENDIF + ! need to update lai and sai, fveg, green, they are done once in a day only + IF (dolai) THEN + CALL LAI_empirical(patchclass,nl_soil,rootfr,t_soisno(1:),lai,sai,fveg,green) + ENDIF #endif ! only for soil patches @@ -1364,39 +1362,39 @@ SUBROUTINE CoLMMAIN ( & IF (patchtype == 0) THEN #if(defined LULC_USGS || defined LULC_IGBP) - CALL snowfraction (tlai(ipatch),tsai(ipatch),z0m,zlnd,scv,snowdp,wt,sigf,fsno) - lai = tlai(ipatch) - sai = tsai(ipatch) * sigf + CALL snowfraction (tlai(ipatch),tsai(ipatch),z0m,zlnd,scv,snowdp,wt,sigf,fsno) + lai = tlai(ipatch) + sai = tsai(ipatch) * sigf #endif #if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) - ps = patch_pft_s(ipatch) - pe = patch_pft_e(ipatch) - CALL snowfraction_pftwrap (ipatch,zlnd,scv,snowdp,wt,sigf,fsno) - if(DEF_USE_LAIFEEDBACK)then - lai = sum(lai_p(ps:pe)*pftfrac(ps:pe)) - else - lai_p(ps:pe) = tlai_p(ps:pe) - lai = tlai(ipatch) - endif - sai_p(ps:pe) = tsai_p(ps:pe) * sigf_p(ps:pe) - sai = sum(sai_p(ps:pe)*pftfrac(ps:pe)) + ps = patch_pft_s(ipatch) + pe = patch_pft_e(ipatch) + CALL snowfraction_pftwrap (ipatch,zlnd,scv,snowdp,wt,sigf,fsno) + IF(DEF_USE_LAIFEEDBACK)THEN + lai = sum(lai_p(ps:pe)*pftfrac(ps:pe)) + ELSE + lai_p(ps:pe) = tlai_p(ps:pe) + lai = tlai(ipatch) + ENDIF + sai_p(ps:pe) = tsai_p(ps:pe) * sigf_p(ps:pe) + sai = sum(sai_p(ps:pe)*pftfrac(ps:pe)) #endif ELSE - CALL snowfraction (tlai(ipatch),tsai(ipatch),z0m,zlnd,scv,snowdp,wt,sigf,fsno) - lai = tlai(ipatch) - sai = tsai(ipatch) * sigf + CALL snowfraction (tlai(ipatch),tsai(ipatch),z0m,zlnd,scv,snowdp,wt,sigf,fsno) + lai = tlai(ipatch) + sai = tsai(ipatch) * sigf ENDIF - ! 05/02/2023, Dai: move to MOD_Albedo.F90 - ! update the snow age - !IF (snl == 0) sag=0. - !CALL snowage (deltim,t_grnd,scv,scvold,sag) + ! 05/02/2023, Dai: move to MOD_Albedo.F90 + ! update the snow age + !IF (snl == 0) sag=0. + !CALL snowage (deltim,t_grnd,scv,scvold,sag) - ! water volumetric content of soil surface layer [m3/m3] - ssw = min(1.,1.e-3*wliq_soisno(1)/dz_soisno(1)) - IF (patchtype >= 3) ssw = 1.0 + ! water volumetric content of soil surface layer [m3/m3] + ssw = min(1.,1.e-3*wliq_soisno(1)/dz_soisno(1)) + IF (patchtype >= 3) ssw = 1.0 ! ============================================================================ ! Calculate column-integrated aerosol masses, and @@ -1405,124 +1403,124 @@ SUBROUTINE CoLMMAIN ( & ! NEEDS TO BE AFTER SnowFiler is rebuilt, otherwise there ! can be zero snow layers but an active column in filter) - !NOTE: put the below inside MOD_Albedo.F90 -! CALL AerosolMasses( snl ,do_capsnow ,& -! wice_soisno(:0),wliq_soisno(:0),snwcp_ice ,snw_rds ,& + !NOTE: put the below inside MOD_Albedo.F90 +! CALL AerosolMasses( snl ,do_capsnow ,& +! wice_soisno(:0),wliq_soisno(:0),snwcp_ice ,snw_rds ,& ! -! mss_bcpho ,mss_bcphi ,mss_ocpho ,mss_ocphi ,& -! mss_dst1 ,mss_dst2 ,mss_dst3 ,mss_dst4 ,& +! mss_bcpho ,mss_bcphi ,mss_ocpho ,mss_ocphi ,& +! mss_dst1 ,mss_dst2 ,mss_dst3 ,mss_dst4 ,& ! -! mss_cnc_bcphi ,mss_cnc_bcpho ,mss_cnc_ocphi ,mss_cnc_ocpho ,& -! mss_cnc_dst1 ,mss_cnc_dst2 ,mss_cnc_dst3 ,mss_cnc_dst4 ) +! mss_cnc_bcphi ,mss_cnc_bcpho ,mss_cnc_ocphi ,mss_cnc_ocpho ,& +! mss_cnc_dst1 ,mss_cnc_dst2 ,mss_cnc_dst3 ,mss_cnc_dst4 ) ! ============================================================================ ! Snow aging routine based on Flanner and Zender (2006), Linking snowpack ! microphysics and albedo evolution, JGR, and Brun (1989), Investigation of ! wet-snow metamorphism in respect of liquid-water content, Ann. Glaciol. - dz_soisno_(:1) = dz_soisno(:1) - t_soisno_ (:1) = t_soisno (:1) + dz_soisno_(:1) = dz_soisno(:1) + t_soisno_ (:1) = t_soisno (:1) - IF (patchtype == 4) THEN - dz_soisno_(1) = dz_lake(1) - t_soisno_ (1) = t_lake (1) - ENDIF + IF (patchtype == 4) THEN + dz_soisno_(1) = dz_lake(1) + t_soisno_ (1) = t_lake (1) + ENDIF - !NOTE: put the below inside MOD_Albedo.F90 -! CALL SnowAge_grain( deltim ,snl ,dz_soisno_(:1) ,& -! pg_snow ,snwcp_ice ,snofrz ,& + !NOTE: put the below inside MOD_Albedo.F90 +! CALL SnowAge_grain( deltim ,snl ,dz_soisno_(:1) ,& +! pg_snow ,snwcp_ice ,snofrz ,& ! -! do_capsnow ,fsno ,scv ,& -! wliq_soisno (:0),wice_soisno(:0),& -! t_soisno_ (:1),t_grnd ,& -! snw_rds ) +! do_capsnow ,fsno ,scv ,& +! wliq_soisno (:0),wice_soisno(:0),& +! t_soisno_ (:1),t_grnd ,& +! snw_rds ) ! ============================================================================ - ! albedos - ! we supposed CALL it every time-step, because - ! other vegeation related parameters are needed to create - IF (doalb) THEN - CALL albland (ipatch, patchtype,deltim,& - soil_s_v_alb,soil_d_v_alb,soil_s_n_alb,soil_d_n_alb,& - chil,rho,tau,fveg,green,lai,sai,coszen,& - wt,fsno,scv,scvold,sag,ssw,pg_snow,forc_t,t_grnd,t_soisno_,dz_soisno_,& - snl,wliq_soisno,wice_soisno,snw_rds,snofrz,& - mss_bcpho,mss_bcphi,mss_ocpho,mss_ocphi,& - mss_dst1,mss_dst2,mss_dst3,mss_dst4,& - alb,ssun,ssha,ssoi,ssno,ssno_lyr,thermk,extkb,extkd) - ENDIF - ELSE !OCEAN - sag = 0.0 - IF(doalb)THEN - CALL albocean (oro,scv,coszen,alb) - ENDIF - ENDIF - - ! zero-filling set for glacier/ice-sheet/land water bodies/ocean components - IF (patchtype > 2) THEN - lai = 0.0 - sai = 0.0 - laisun = 0.0 - laisha = 0.0 - green = 0.0 - fveg = 0.0 - sigf = 0.0 - - ssun(:,:) = 0.0 - ssha(:,:) = 0.0 - thermk = 0.0 - extkb = 0.0 - extkd = 0.0 - - tleaf = forc_t - ldew_rain = 0.0 - ldew_snow = 0.0 - ldew = 0.0 - fsenl = 0.0 - fevpl = 0.0 - etr = 0.0 - assim = 0.0 - respc = 0.0 - - zerr = 0. - - qinfl = 0. - qdrip = forc_rain + forc_snow - qintr = 0. - h2osoi = 0. - rstfacsun_out = 0. - rstfacsha_out = 0. - gssun_out = 0. - gssha_out = 0. - assimsun_out = 0. - etrsun_out = 0. - assimsha_out = 0. - etrsha_out = 0. - rootr = 0. - rootflux = 0. - zwt = 0. - - IF (.not. DEF_USE_VariablySaturatedFlow) THEN - wa = 4800. - ENDIF - - qcharge = 0. - IF (DEF_USE_PLANTHYDRAULICS)THEN - vegwp = -2.5e4 - ENDIF - ENDIF - - h2osoi = wliq_soisno(1:)/(dz_soisno(1:)*denh2o) + wice_soisno(1:)/(dz_soisno(1:)*denice) - - IF (DEF_USE_VariablySaturatedFlow) THEN - wat = sum(wice_soisno(1:)+wliq_soisno(1:))+ldew+scv+wetwat - ELSE - wat = sum(wice_soisno(1:)+wliq_soisno(1:))+ldew+scv + wa - ENDIF - - ! 09/2022, yuan: move from CoLMDRIVER to avoid using stack memory - z_sno (maxsnl+1:0) = z_soisno (maxsnl+1:0) - dz_sno(maxsnl+1:0) = dz_soisno(maxsnl+1:0) + ! albedos + ! we supposed CALL it every time-step, because + ! other vegeation related parameters are needed to create + IF (doalb) THEN + CALL albland (ipatch, patchtype,deltim,& + soil_s_v_alb,soil_d_v_alb,soil_s_n_alb,soil_d_n_alb,& + chil,rho,tau,fveg,green,lai,sai,coszen,& + wt,fsno,scv,scvold,sag,ssw,pg_snow,forc_t,t_grnd,t_soisno_,dz_soisno_,& + snl,wliq_soisno,wice_soisno,snw_rds,snofrz,& + mss_bcpho,mss_bcphi,mss_ocpho,mss_ocphi,& + mss_dst1,mss_dst2,mss_dst3,mss_dst4,& + alb,ssun,ssha,ssoi,ssno,ssno_lyr,thermk,extkb,extkd) + ENDIF +ELSE !OCEAN + sag = 0.0 + IF(doalb)THEN + CALL albocean (oro,scv,coszen,alb) + ENDIF +ENDIF + + ! zero-filling set for glacier/ice-sheet/land water bodies/ocean components + IF (patchtype > 2) THEN + lai = 0.0 + sai = 0.0 + laisun = 0.0 + laisha = 0.0 + green = 0.0 + fveg = 0.0 + sigf = 0.0 + + ssun(:,:) = 0.0 + ssha(:,:) = 0.0 + thermk = 0.0 + extkb = 0.0 + extkd = 0.0 + + tleaf = forc_t + ldew_rain = 0.0 + ldew_snow = 0.0 + ldew = 0.0 + fsenl = 0.0 + fevpl = 0.0 + etr = 0.0 + assim = 0.0 + respc = 0.0 + + zerr = 0. + + qinfl = 0. + qdrip = forc_rain + forc_snow + qintr = 0. + h2osoi = 0. + rstfacsun_out = 0. + rstfacsha_out = 0. + gssun_out = 0. + gssha_out = 0. + assimsun_out = 0. + etrsun_out = 0. + assimsha_out = 0. + etrsha_out = 0. + rootr = 0. + rootflux = 0. + zwt = 0. + + IF (.not. DEF_USE_VariablySaturatedFlow) THEN + wa = 4800. + ENDIF + + qcharge = 0. + IF (DEF_USE_PLANTHYDRAULICS)THEN + vegwp = -2.5e4 + ENDIF + ENDIF + + h2osoi = wliq_soisno(1:)/(dz_soisno(1:)*denh2o) + wice_soisno(1:)/(dz_soisno(1:)*denice) + + IF (DEF_USE_VariablySaturatedFlow) THEN + wat = sum(wice_soisno(1:)+wliq_soisno(1:))+ldew+scv+wetwat + ELSE + wat = sum(wice_soisno(1:)+wliq_soisno(1:))+ldew+scv + wa + ENDIF + + ! 09/2022, yuan: move from CoLMDRIVER to avoid using stack memory + z_sno (maxsnl+1:0) = z_soisno (maxsnl+1:0) + dz_sno(maxsnl+1:0) = dz_soisno(maxsnl+1:0) END SUBROUTINE CoLMMAIN ! ---------- EOP ------------ diff --git a/main/MOD_3DCanopyRadiation.F90 b/main/MOD_3DCanopyRadiation.F90 index e4f552a9..c39a7b07 100644 --- a/main/MOD_3DCanopyRadiation.F90 +++ b/main/MOD_3DCanopyRadiation.F90 @@ -24,7 +24,7 @@ MODULE MOD_3DCanopyRadiation #ifdef LULC_IGBP_PC !----------------------------------------------------------------------- - SUBROUTINE ThreeDCanopy_wrap (ipatch, czen, albg, albv, tran, ssun, ssha) + SUBROUTINE ThreeDCanopy_wrap (ipatch, czen, albg, albv, tran, ssun, ssha) ! ! !DESCRIPTION: @@ -72,154 +72,154 @@ SUBROUTINE ThreeDCanopy_wrap (ipatch, czen, albg, albv, tran, ssun, ssha) real(r8), allocatable :: fsun_id(:), fsun_ii(:), psun(:) real(r8), allocatable :: phi1(:), phi2(:), gdir(:) - ! get patch PFT index - ps = patch_pft_s(ipatch) - pe = patch_pft_e(ipatch) - - ! allocate memory for defined variables - allocate (albd (ps:pe, 2) ) - allocate (albi (ps:pe, 2) ) - allocate (fabd (ps:pe, 2) ) - allocate (fabi (ps:pe, 2) ) - allocate (fadd (ps:pe, 2) ) - allocate (ftdd (ps:pe, 2) ) - allocate (ftid (ps:pe, 2) ) - allocate (ftii (ps:pe, 2) ) - allocate (rho (ps:pe, 2) ) - allocate (tau (ps:pe, 2) ) - allocate (csiz (ps:pe) ) - allocate (chgt (ps:pe) ) - allocate (chil (ps:pe) ) - allocate (lsai (ps:pe) ) - allocate (canlay (ps:pe) ) - allocate (fsun_id(ps:pe) ) - allocate (fsun_ii(ps:pe) ) - allocate (psun (ps:pe) ) - allocate (phi1 (ps:pe) ) - allocate (phi2 (ps:pe) ) - allocate (gdir (ps:pe) ) - - ! initialization - albd=1.; albi=1.; fabd=0.; fabi=0.; - ftdd=1.; ftid=0.; ftii=1.; fadd=0.; - csiz(:) = (htop_p(ps:pe) - hbot_p(ps:pe)) / 2 - chgt(:) = (htop_p(ps:pe) + hbot_p(ps:pe)) / 2 - lsai(:) = lai_p(ps:pe) + sai_p(ps:pe) - - ! calculate weighted plant optical properties - ! loop for each PFT - rho = 0. - tau = 0. - DO i = ps, pe - - p = pftclass(i) - canlay(i) = canlay_p(p) - chil(i) = chil_p(p) - - IF (lsai(i) > 0.) THEN - rho(i,:) = rho_p(:,1,p)*lai_p(i)/lsai(i) & - + rho_p(:,2,p)*sai_p(i)/lsai(i) - tau(i,:) = tau_p(:,1,p)*lai_p(i)/lsai(i) & - + tau_p(:,2,p)*sai_p(i)/lsai(i) - ENDIF - ENDDO - - ! CALL 3D canopy radiation transfer model - CALL ThreeDCanopy(ps, pe, canlay, pftfrac(ps:pe), csiz, chgt, chil, czen, & - lsai, rho, tau, albg(:,1), albg(:,2), albd, albi, & - fabd, fabi, ftdd, ftid, ftii, fadd, psun, & - thermk_p(ps:pe), fshade_p(ps:pe) ) - - ! calculate extkb_p, extkd_p - ! applied for 1D case - extkd_p(ps:pe) = 0.719 !used for scaling-up coefficients from leaf to canopy - - ! 11/07/2018: calculate gee FUNCTION consider LAD - DO i = ps, pe - p = pftclass(i) - phi1(i) = 0.5 - 0.633 * chil_p(p) - 0.33 * chil_p(p) * chil_p(p) - phi2(i) = 0.877 * ( 1. - 2. * phi1(i) ) - ENDDO - - ! 11/07/2018: calculate gee FUNCTION consider LAD - gdir = phi1 + phi2*czen - extkb_p(ps:pe) = gdir/czen - - fsun_id(:) = 0. - fsun_ii(:) = 0. - - DO p = ps, pe - IF (lsai(p) > 0.) THEN - fsun_id(p) = (1._r8 - exp(-2._r8*extkb_p(p)*lsai(p))) / & - (1._r8 - exp(-extkb_p(p)*lsai(p))) / 2.0_r8 * psun(p) - - fsun_ii(p) = (1._r8 - exp(-extkb_p(p)*lsai(p)-0.5/0.5_r8*lsai(p))) / & - (extkb_p(p)+0.5/0.5_r8) / & - (1._r8 - exp(-0.5/0.5_r8*lsai(p))) * & - (0.5/0.5_r8) * psun(p) - ENDIF - ENDDO - - ! calculate albv, ssun, ssha - ! NOTE: CoLM (1/2,): vis/nir; (,1/2): dir/dif - albv(1,1) = albd(ps,1); albv(1,2) = albi(ps,1) - albv(2,1) = albd(ps,2); albv(2,2) = albi(ps,2) - - ! ssun(band, dir/dif, pft), fabd/fadd(pft, band) - ssun_p(1,1,ps:pe) = fadd(:,1) + (fabd(:,1)-fadd(:,1))*fsun_id - ssun_p(2,1,ps:pe) = fadd(:,2) + (fabd(:,2)-fadd(:,2))*fsun_id - ssha_p(1,1,ps:pe) = (fabd(:,1)-fadd(:,1)) * (1.-fsun_id) - ssha_p(2,1,ps:pe) = (fabd(:,2)-fadd(:,2)) * (1.-fsun_id) - ssun_p(1,2,ps:pe) = fabi(:,1) * fsun_ii - ssun_p(2,2,ps:pe) = fabi(:,2) * fsun_ii - ssha_p(1,2,ps:pe) = fabi(:,1) * (1.-fsun_ii) - ssha_p(2,2,ps:pe) = fabi(:,2) * (1.-fsun_ii) - - ssun(1,1) = sum( ssun_p(1,1,ps:pe) * pftfrac(ps:pe) ) - ssun(2,1) = sum( ssun_p(2,1,ps:pe) * pftfrac(ps:pe) ) - ssun(1,2) = sum( ssun_p(1,2,ps:pe) * pftfrac(ps:pe) ) - ssun(2,2) = sum( ssun_p(2,2,ps:pe) * pftfrac(ps:pe) ) - - ssha(1,1) = sum( ssha_p(1,1,ps:pe) * pftfrac(ps:pe) ) - ssha(2,1) = sum( ssha_p(2,1,ps:pe) * pftfrac(ps:pe) ) - ssha(1,2) = sum( ssha_p(1,2,ps:pe) * pftfrac(ps:pe) ) - ssha(2,2) = sum( ssha_p(2,2,ps:pe) * pftfrac(ps:pe) ) - - tran(1,1) = ftid(ps,1) - tran(2,1) = ftid(ps,2) - tran(1,3) = ftdd(ps,1) - tran(2,3) = ftdd(ps,2) - tran(1,2) = ftii(ps,1) - tran(2,2) = ftii(ps,2) - - ! deallocate memory for defined variables - deallocate (albd ) - deallocate (albi ) - deallocate (fabd ) - deallocate (fabi ) - deallocate (fadd ) - deallocate (ftdd ) - deallocate (ftid ) - deallocate (ftii ) - deallocate (rho ) - deallocate (tau ) - deallocate (csiz ) - deallocate (chgt ) - deallocate (chil ) - deallocate (lsai ) - deallocate (canlay ) - deallocate (fsun_id ) - deallocate (fsun_ii ) - deallocate (psun ) - deallocate (phi1 ) - deallocate (phi2 ) - deallocate (gdir ) - - END SUBROUTINE ThreeDCanopy_wrap + ! get patch PFT index + ps = patch_pft_s(ipatch) + pe = patch_pft_e(ipatch) + + ! allocate memory for defined variables + allocate (albd (ps:pe, 2) ) + allocate (albi (ps:pe, 2) ) + allocate (fabd (ps:pe, 2) ) + allocate (fabi (ps:pe, 2) ) + allocate (fadd (ps:pe, 2) ) + allocate (ftdd (ps:pe, 2) ) + allocate (ftid (ps:pe, 2) ) + allocate (ftii (ps:pe, 2) ) + allocate (rho (ps:pe, 2) ) + allocate (tau (ps:pe, 2) ) + allocate (csiz (ps:pe) ) + allocate (chgt (ps:pe) ) + allocate (chil (ps:pe) ) + allocate (lsai (ps:pe) ) + allocate (canlay (ps:pe) ) + allocate (fsun_id(ps:pe) ) + allocate (fsun_ii(ps:pe) ) + allocate (psun (ps:pe) ) + allocate (phi1 (ps:pe) ) + allocate (phi2 (ps:pe) ) + allocate (gdir (ps:pe) ) + + ! initialization + albd=1.; albi=1.; fabd=0.; fabi=0.; + ftdd=1.; ftid=0.; ftii=1.; fadd=0.; + csiz(:) = (htop_p(ps:pe) - hbot_p(ps:pe)) / 2 + chgt(:) = (htop_p(ps:pe) + hbot_p(ps:pe)) / 2 + lsai(:) = lai_p(ps:pe) + sai_p(ps:pe) + + ! calculate weighted plant optical properties + ! loop for each PFT + rho = 0. + tau = 0. + DO i = ps, pe + + p = pftclass(i) + canlay(i) = canlay_p(p) + chil(i) = chil_p(p) + + IF (lsai(i) > 0.) THEN + rho(i,:) = rho_p(:,1,p)*lai_p(i)/lsai(i) & + + rho_p(:,2,p)*sai_p(i)/lsai(i) + tau(i,:) = tau_p(:,1,p)*lai_p(i)/lsai(i) & + + tau_p(:,2,p)*sai_p(i)/lsai(i) + ENDIF + ENDDO + + ! CALL 3D canopy radiation transfer model + CALL ThreeDCanopy(ps, pe, canlay, pftfrac(ps:pe), csiz, chgt, chil, czen, & + lsai, rho, tau, albg(:,1), albg(:,2), albd, albi, & + fabd, fabi, ftdd, ftid, ftii, fadd, psun, & + thermk_p(ps:pe), fshade_p(ps:pe) ) + + ! calculate extkb_p, extkd_p + ! applied for 1D case + extkd_p(ps:pe) = 0.719 !used for scaling-up coefficients from leaf to canopy + + ! 11/07/2018: calculate gee FUNCTION consider LAD + DO i = ps, pe + p = pftclass(i) + phi1(i) = 0.5 - 0.633 * chil_p(p) - 0.33 * chil_p(p) * chil_p(p) + phi2(i) = 0.877 * ( 1. - 2. * phi1(i) ) + ENDDO + + ! 11/07/2018: calculate gee FUNCTION consider LAD + gdir = phi1 + phi2*czen + extkb_p(ps:pe) = gdir/czen + + fsun_id(:) = 0. + fsun_ii(:) = 0. + + DO p = ps, pe + IF (lsai(p) > 0.) THEN + fsun_id(p) = (1._r8 - exp(-2._r8*extkb_p(p)*lsai(p))) / & + (1._r8 - exp(-extkb_p(p)*lsai(p))) / 2.0_r8 * psun(p) + + fsun_ii(p) = (1._r8 - exp(-extkb_p(p)*lsai(p)-0.5/0.5_r8*lsai(p))) / & + (extkb_p(p)+0.5/0.5_r8) / & + (1._r8 - exp(-0.5/0.5_r8*lsai(p))) * & + (0.5/0.5_r8) * psun(p) + ENDIF + ENDDO + + ! calculate albv, ssun, ssha + ! NOTE: CoLM (1/2,): vis/nir; (,1/2): dir/dif + albv(1,1) = albd(ps,1); albv(1,2) = albi(ps,1) + albv(2,1) = albd(ps,2); albv(2,2) = albi(ps,2) + + ! ssun(band, dir/dif, pft), fabd/fadd(pft, band) + ssun_p(1,1,ps:pe) = fadd(:,1) + (fabd(:,1)-fadd(:,1))*fsun_id + ssun_p(2,1,ps:pe) = fadd(:,2) + (fabd(:,2)-fadd(:,2))*fsun_id + ssha_p(1,1,ps:pe) = (fabd(:,1)-fadd(:,1)) * (1.-fsun_id) + ssha_p(2,1,ps:pe) = (fabd(:,2)-fadd(:,2)) * (1.-fsun_id) + ssun_p(1,2,ps:pe) = fabi(:,1) * fsun_ii + ssun_p(2,2,ps:pe) = fabi(:,2) * fsun_ii + ssha_p(1,2,ps:pe) = fabi(:,1) * (1.-fsun_ii) + ssha_p(2,2,ps:pe) = fabi(:,2) * (1.-fsun_ii) + + ssun(1,1) = sum( ssun_p(1,1,ps:pe) * pftfrac(ps:pe) ) + ssun(2,1) = sum( ssun_p(2,1,ps:pe) * pftfrac(ps:pe) ) + ssun(1,2) = sum( ssun_p(1,2,ps:pe) * pftfrac(ps:pe) ) + ssun(2,2) = sum( ssun_p(2,2,ps:pe) * pftfrac(ps:pe) ) + + ssha(1,1) = sum( ssha_p(1,1,ps:pe) * pftfrac(ps:pe) ) + ssha(2,1) = sum( ssha_p(2,1,ps:pe) * pftfrac(ps:pe) ) + ssha(1,2) = sum( ssha_p(1,2,ps:pe) * pftfrac(ps:pe) ) + ssha(2,2) = sum( ssha_p(2,2,ps:pe) * pftfrac(ps:pe) ) + + tran(1,1) = ftid(ps,1) + tran(2,1) = ftid(ps,2) + tran(1,3) = ftdd(ps,1) + tran(2,3) = ftdd(ps,2) + tran(1,2) = ftii(ps,1) + tran(2,2) = ftii(ps,2) + + ! deallocate memory for defined variables + deallocate (albd ) + deallocate (albi ) + deallocate (fabd ) + deallocate (fabi ) + deallocate (fadd ) + deallocate (ftdd ) + deallocate (ftid ) + deallocate (ftii ) + deallocate (rho ) + deallocate (tau ) + deallocate (csiz ) + deallocate (chgt ) + deallocate (chil ) + deallocate (lsai ) + deallocate (canlay ) + deallocate (fsun_id ) + deallocate (fsun_ii ) + deallocate (psun ) + deallocate (phi1 ) + deallocate (phi2 ) + deallocate (gdir ) + + END SUBROUTINE ThreeDCanopy_wrap #endif - SUBROUTINE ThreeDCanopy(ps, pe, canlay, fcover, csiz, chgt, chil, coszen, & + SUBROUTINE ThreeDCanopy(ps, pe, canlay, fcover, csiz, chgt, chil, coszen, & lsai, rho, tau, albgrd, albgri, albd, albi, & fabd, fabi, ftdd, ftid, ftii, fadd, psun, & thermk, fshade) @@ -389,238 +389,238 @@ SUBROUTINE ThreeDCanopy(ps, pe, canlay, fcover, csiz, chgt, chil, coszen, & real(r8) :: phi1(ps:pe), phi2(ps:pe) - ! 11/07/2018: calculate gee FUNCTION consider LAD - phi1 = 0.5 - 0.633 * chil - 0.33 * chil * chil - phi2 = 0.877 * ( 1. - 2. * phi1 ) + ! 11/07/2018: calculate gee FUNCTION consider LAD + phi1 = 0.5 - 0.633 * chil - 0.33 * chil * chil + phi2 = 0.877 * ( 1. - 2. * phi1 ) - cosz = coszen - cosd = cos(60._r8/180._r8*pi) + cosz = coszen + cosd = cos(60._r8/180._r8*pi) - ! 11/07/2018: calculate gee FUNCTION consider LAD - gdir = phi1 + phi2*cosz - gdif = phi1 + phi2*cosd + ! 11/07/2018: calculate gee FUNCTION consider LAD + gdir = phi1 + phi2*cosz + gdif = phi1 + phi2*cosd - nsoilveg = 0 + nsoilveg = 0 - fc0 = D0 - omg_lay = D0 - rho_lay = D0 - tau_lay = D0 - hgt_lay = D0 - bot_lay = D0 - siz_lay = D0 - lsai_lay = D0 - gdir_lay = D0 - gdif_lay = D0 + fc0 = D0 + omg_lay = D0 + rho_lay = D0 + tau_lay = D0 + hgt_lay = D0 + bot_lay = D0 + siz_lay = D0 + lsai_lay = D0 + gdir_lay = D0 + gdif_lay = D0 - DO ip = ps, pe - shadow_sky(ip) = D1 + DO ip = ps, pe + shadow_sky(ip) = D1 - ! check elai and pft weight are non-zero - IF ( lsai(ip)>1.e-6_r8 .and. fcover(ip)>D0 ) THEN + ! check elai and pft weight are non-zero + IF ( lsai(ip)>1.e-6_r8 .and. fcover(ip)>D0 ) THEN - soilveg(ip) = .true. - nsoilveg = nsoilveg + 1 + soilveg(ip) = .true. + nsoilveg = nsoilveg + 1 - clev = canlay(ip) - fc0(clev) = fc0(clev) + fcover(ip) + clev = canlay(ip) + fc0(clev) = fc0(clev) + fcover(ip) - siz_lay (clev) = siz_lay (clev) + fcover(ip)*csiz(ip) - hgt_lay (clev) = hgt_lay (clev) + fcover(ip)*chgt(ip) - lsai_lay(clev) = lsai_lay(clev) + fcover(ip)*lsai(ip) - gdir_lay(clev) = gdir_lay(clev) + fcover(ip)*gdir(ip) - gdif_lay(clev) = gdif_lay(clev) + fcover(ip)*gdif(ip) + siz_lay (clev) = siz_lay (clev) + fcover(ip)*csiz(ip) + hgt_lay (clev) = hgt_lay (clev) + fcover(ip)*chgt(ip) + lsai_lay(clev) = lsai_lay(clev) + fcover(ip)*lsai(ip) + gdir_lay(clev) = gdir_lay(clev) + fcover(ip)*gdir(ip) + gdif_lay(clev) = gdif_lay(clev) + fcover(ip)*gdif(ip) - ! set optical properties - DO ib = 1, numrad - omega(ip,ib) = rho(ip,ib) + tau(ip,ib) + ! set optical properties + DO ib = 1, numrad + omega(ip,ib) = rho(ip,ib) + tau(ip,ib) - ! sum of tau,rho and omega for pfts in a layer - tau_lay(clev,ib) = tau_lay(clev,ib) + fcover(ip)*(tau(ip,ib)) - rho_lay(clev,ib) = rho_lay(clev,ib) + fcover(ip)*(rho(ip,ib)) - omg_lay(clev,ib) = omg_lay(clev,ib) + fcover(ip)*(omega(ip,ib)) + ! sum of tau,rho and omega for pfts in a layer + tau_lay(clev,ib) = tau_lay(clev,ib) + fcover(ip)*(tau(ip,ib)) + rho_lay(clev,ib) = rho_lay(clev,ib) + fcover(ip)*(rho(ip,ib)) + omg_lay(clev,ib) = omg_lay(clev,ib) + fcover(ip)*(omega(ip,ib)) - ENDDO ! ENDDO ib=1, numrad - ELSE - soilveg(ip) = .false. - ENDIF - ENDDO ! ENDDO ip + ENDDO ! ENDDO ib=1, numrad + ELSE + soilveg(ip) = .false. + ENDIF + ENDDO ! ENDDO ip !============================================================= ! layer average of lsai,tau,rho,omega... !============================================================= - DO lev = 1, 3 - IF (fc0(lev) > D0) THEN - siz_lay(lev) = max(siz_lay(lev)/fc0(lev),D0) - hgt_lay(lev) = max(hgt_lay(lev)/fc0(lev),D0) - bot_lay(lev) = hgt_lay(lev)-siz_lay(lev) - lsai_lay(lev) = max(lsai_lay(lev)/fc0(lev),D0) - DO ib = 1, numrad - tau_lay(lev,ib) = max(tau_lay(lev,ib)/fc0(lev),D0) - rho_lay(lev,ib) = max(rho_lay(lev,ib)/fc0(lev),D0) - omg_lay(lev,ib) = max(omg_lay(lev,ib)/fc0(lev),D0) - ENDDO - gdir_lay(lev) = max(gdir_lay(lev)/fc0(lev),D0) - gdif_lay(lev) = max(gdif_lay(lev)/fc0(lev),D0) - ENDIF - ENDDO ! ENDDO ib + DO lev = 1, 3 + IF (fc0(lev) > D0) THEN + siz_lay(lev) = max(siz_lay(lev)/fc0(lev),D0) + hgt_lay(lev) = max(hgt_lay(lev)/fc0(lev),D0) + bot_lay(lev) = hgt_lay(lev)-siz_lay(lev) + lsai_lay(lev) = max(lsai_lay(lev)/fc0(lev),D0) + DO ib = 1, numrad + tau_lay(lev,ib) = max(tau_lay(lev,ib)/fc0(lev),D0) + rho_lay(lev,ib) = max(rho_lay(lev,ib)/fc0(lev),D0) + omg_lay(lev,ib) = max(omg_lay(lev,ib)/fc0(lev),D0) + ENDDO + gdir_lay(lev) = max(gdir_lay(lev)/fc0(lev),D0) + gdif_lay(lev) = max(gdif_lay(lev)/fc0(lev),D0) + ENDIF + ENDDO ! ENDDO ib !============================================================= ! layer shadows !============================================================= - shadow_d = D0 - shadow_i = D0 - DO lev =1, 3 - IF ( fc0(lev)>D0 .and. cosz>D0 ) THEN - shadow_d(lev) = (D1 - exp(-D1*fc0(lev)/cosz))/& - (D1 - fc0(lev)*exp(-D1/cosz)) - shadow_d(lev) = max(fc0(lev), shadow_d(lev)) - shadow_i(lev) = (D1 - exp(-D1*fc0(lev)/cosd))/& - (D1 - fc0(lev)*exp(-D1/cosd)) - shadow_i(lev) = max(fc0(lev), shadow_i(lev)) - ENDIF - ENDDO + shadow_d = D0 + shadow_i = D0 + DO lev =1, 3 + IF ( fc0(lev)>D0 .and. cosz>D0 ) THEN + shadow_d(lev) = (D1 - exp(-D1*fc0(lev)/cosz))/& + (D1 - fc0(lev)*exp(-D1/cosz)) + shadow_d(lev) = max(fc0(lev), shadow_d(lev)) + shadow_i(lev) = (D1 - exp(-D1*fc0(lev)/cosd))/& + (D1 - fc0(lev)*exp(-D1/cosd)) + shadow_i(lev) = max(fc0(lev), shadow_i(lev)) + ENDIF + ENDDO !============================================================= ! taud and ftdd for layers !============================================================= - taud_lay = D0 - taui_lay = D0 - ftdd_lay = D0 - ftdi_lay = D0 - fcad_lay = D1 - fcai_lay = D1 - ftdd_lay_orig = D0 - ftdi_lay_orig = D0 + taud_lay = D0 + taui_lay = D0 + ftdd_lay = D0 + ftdi_lay = D0 + fcad_lay = D1 + fcai_lay = D1 + ftdd_lay_orig = D0 + ftdi_lay_orig = D0 - DO lev = 1, 3 - IF ( fc0(lev)>D0 .and. lsai_lay(lev)>D0 ) THEN + DO lev = 1, 3 + IF ( fc0(lev)>D0 .and. lsai_lay(lev)>D0 ) THEN - taud_lay(lev) = D3/D4*gee*fc0(lev)*lsai_lay(lev)/& - (cosz*shadow_d(lev)) - taui_lay(lev) = D3/D4*gee*fc0(lev)*lsai_lay(lev)/& - (cosd*shadow_i(lev)) + taud_lay(lev) = D3/D4*gee*fc0(lev)*lsai_lay(lev)/& + (cosz*shadow_d(lev)) + taui_lay(lev) = D3/D4*gee*fc0(lev)*lsai_lay(lev)/& + (cosd*shadow_i(lev)) - ! 11/07/2018: LAD calibration - ftdd_lay_orig(lev) = tee(DD1*taud_lay(lev)) - ftdi_lay_orig(lev) = tee(DD1*taui_lay(lev)) + ! 11/07/2018: LAD calibration + ftdd_lay_orig(lev) = tee(DD1*taud_lay(lev)) + ftdi_lay_orig(lev) = tee(DD1*taui_lay(lev)) - ! 11/07/2018: gdir/gdif = FUNCTION(xl, cos) - ftdd_lay(lev) = tee(DD1*taud_lay(lev)/gee*gdir_lay(lev)) - ftdi_lay(lev) = tee(DD1*taui_lay(lev)/gee*gdif_lay(lev)) + ! 11/07/2018: gdir/gdif = FUNCTION(xl, cos) + ftdd_lay(lev) = tee(DD1*taud_lay(lev)/gee*gdir_lay(lev)) + ftdi_lay(lev) = tee(DD1*taui_lay(lev)/gee*gdif_lay(lev)) - ! calibration for chil - fcad_lay(lev) = (D1-ftdd_lay(lev)) / (D1-ftdd_lay_orig(lev)) - fcai_lay(lev) = (D1-ftdi_lay(lev)) / (D1-ftdi_lay_orig(lev)) + ! calibration for chil + fcad_lay(lev) = (D1-ftdd_lay(lev)) / (D1-ftdd_lay_orig(lev)) + fcai_lay(lev) = (D1-ftdi_lay(lev)) / (D1-ftdi_lay_orig(lev)) - ENDIF - ENDDO + ENDIF + ENDDO !============================================================= ! initialize local variables for layers !============================================================= - albd_col = D0 - albi_col = D0 - fabd_col = D0 - fabd_lay = D0 - fabi_col = D0 - fabi_lay = D0 - frid_lay = D0 - frii_lay = D0 - tt = D0 + albd_col = D0 + albi_col = D0 + fabd_col = D0 + fabd_lay = D0 + fabi_col = D0 + fabi_lay = D0 + frid_lay = D0 + frii_lay = D0 + tt = D0 !============================================================= ! projection shadow overlapping fractions !============================================================= - zenith = acos(coszen) - shad_oa(3,2) = fc0(3)*OverlapArea(siz_lay(3),hgt_lay(3)-bot_lay(2),& - zenith) - shad_oa(3,1) = fc0(3)*OverlapArea(siz_lay(3),hgt_lay(3)-bot_lay(1),& - zenith) - shad_oa(2,1) = fc0(2)*OverlapArea(siz_lay(2),hgt_lay(2)-bot_lay(1),& - zenith) + zenith = acos(coszen) + shad_oa(3,2) = fc0(3)*OverlapArea(siz_lay(3),hgt_lay(3)-bot_lay(2),& + zenith) + shad_oa(3,1) = fc0(3)*OverlapArea(siz_lay(3),hgt_lay(3)-bot_lay(1),& + zenith) + shad_oa(2,1) = fc0(2)*OverlapArea(siz_lay(2),hgt_lay(2)-bot_lay(1),& + zenith) - ! for test - !shad_oa(3,2) = D0 - !shad_oa(3,1) = D0 - !shad_oa(2,1) = D0 + ! for test + !shad_oa(3,2) = D0 + !shad_oa(3,1) = D0 + !shad_oa(2,1) = D0 !============================================================= ! unscattered direct sunlight available at each layer ! 4:sky, 3:top 2:middle 1:bottom and 0:ground layer !============================================================= - ftdd_col = D0 - tt = D0 - tt(4,3) = shadow_d(3) - tt(4,3) = min(D1, max(D0, tt(4,3))) - tt(4,2) = shadow_d(2)*(D1-shadow_d(3)+shad_oa(3,2)) - tt(4,2) = min(1-tt(4,3), max(D0, tt(4,2))) - tt(4,1) = shadow_d(1)*(D1-(shadow_d(2)-shad_oa(2,1)) & - - (shadow_d(3)-shad_oa(3,1)) & - + (shadow_d(2)-shad_oa(2,1))*(shadow_d(3)-shad_oa(3,2))) - tt(4,1) = min(1-tt(4,3)-tt(4,2), max(D0, tt(4,1))) - - tt(4,0) = D1-(shadow_d(1)+shadow_d(2)+shadow_d(3) & - - (shadow_d(2)-shad_oa(2,1))*shadow_d(1) & - - (shadow_d(3)-shad_oa(3,2))*shadow_d(2) & - - (shadow_d(3)-shad_oa(3,1))*shadow_d(1) & - + (shadow_d(2)-shad_oa(2,1))*(shadow_d(3)-shad_oa(3,2))*shadow_d(1)) - tt(4,0) = min(1-tt(4,3)-tt(4,2)-tt(4,1), max(D0, tt(4,0))) - - IF (tt(4,0) < 0) THEN - print *, abs(tt(4,0)) - ENDIF - - ! direct sunlight passing through top canopy layer - IF (shadow_d(3) > 0) THEN - tt(3,2) = shadow_d(2)*(shadow_d(3)-shad_oa(3,2)) - tt(3,2) = min(shadow_d(3), max(D0, tt(3,2))) - tt(3,1) = shadow_d(1)*(shadow_d(3)-shad_oa(3,1)- & - (shadow_d(3)-shad_oa(3,2))*(shadow_d(2)-shad_oa(2,1))) - tt(3,1) = min(shadow_d(3)-tt(3,2), max(D0, tt(3,1))) - tt(3,0) = shadow_d(3)-tt(3,2)-tt(3,1) - - tt(3,2) = tt(3,2)*ftdd_lay(3) - tt(3,1) = tt(3,1)*ftdd_lay(3) - tt(3,0) = tt(3,0)*ftdd_lay(3) - ENDIF - - ! direct sunlight passing through middle canopy layer - IF (shadow_d(2) > 0) THEN - tt(2,1) = shadow_d(1)*(shadow_d(2)-shad_oa(2,1)) - tt(2,1) = min(shadow_d(2), max(D0, tt(2,1))) - tt(2,0) = shadow_d(2)-tt(2,1) - - tt(2,1) = tt(2,1)*ftdd_lay(2)*(tt(4,2) + tt(3,2))/shadow_d(2) - tt(2,0) = tt(2,0)*ftdd_lay(2)*(tt(4,2) + tt(3,2))/shadow_d(2) - ENDIF - - ! direct sunlight passing through third canopy layer - IF (shadow_d(1) > 0) THEN - tt(1,0) = ftdd_lay(1)*(tt(4,1) + tt(3,1) + tt(2,1))!*shadow_d(1)/shadow_d(1) - ENDIF + ftdd_col = D0 + tt = D0 + tt(4,3) = shadow_d(3) + tt(4,3) = min(D1, max(D0, tt(4,3))) + tt(4,2) = shadow_d(2)*(D1-shadow_d(3)+shad_oa(3,2)) + tt(4,2) = min(1-tt(4,3), max(D0, tt(4,2))) + tt(4,1) = shadow_d(1)*(D1-(shadow_d(2)-shad_oa(2,1)) & + - (shadow_d(3)-shad_oa(3,1)) & + + (shadow_d(2)-shad_oa(2,1))*(shadow_d(3)-shad_oa(3,2))) + tt(4,1) = min(1-tt(4,3)-tt(4,2), max(D0, tt(4,1))) + + tt(4,0) = D1-(shadow_d(1)+shadow_d(2)+shadow_d(3) & + - (shadow_d(2)-shad_oa(2,1))*shadow_d(1) & + - (shadow_d(3)-shad_oa(3,2))*shadow_d(2) & + - (shadow_d(3)-shad_oa(3,1))*shadow_d(1) & + + (shadow_d(2)-shad_oa(2,1))*(shadow_d(3)-shad_oa(3,2))*shadow_d(1)) + tt(4,0) = min(1-tt(4,3)-tt(4,2)-tt(4,1), max(D0, tt(4,0))) + + IF (tt(4,0) < 0) THEN + print *, abs(tt(4,0)) + ENDIF + + ! direct sunlight passing through top canopy layer + IF (shadow_d(3) > 0) THEN + tt(3,2) = shadow_d(2)*(shadow_d(3)-shad_oa(3,2)) + tt(3,2) = min(shadow_d(3), max(D0, tt(3,2))) + tt(3,1) = shadow_d(1)*(shadow_d(3)-shad_oa(3,1)- & + (shadow_d(3)-shad_oa(3,2))*(shadow_d(2)-shad_oa(2,1))) + tt(3,1) = min(shadow_d(3)-tt(3,2), max(D0, tt(3,1))) + tt(3,0) = shadow_d(3)-tt(3,2)-tt(3,1) + + tt(3,2) = tt(3,2)*ftdd_lay(3) + tt(3,1) = tt(3,1)*ftdd_lay(3) + tt(3,0) = tt(3,0)*ftdd_lay(3) + ENDIF + + ! direct sunlight passing through middle canopy layer + IF (shadow_d(2) > 0) THEN + tt(2,1) = shadow_d(1)*(shadow_d(2)-shad_oa(2,1)) + tt(2,1) = min(shadow_d(2), max(D0, tt(2,1))) + tt(2,0) = shadow_d(2)-tt(2,1) + + tt(2,1) = tt(2,1)*ftdd_lay(2)*(tt(4,2) + tt(3,2))/shadow_d(2) + tt(2,0) = tt(2,0)*ftdd_lay(2)*(tt(4,2) + tt(3,2))/shadow_d(2) + ENDIF + + ! direct sunlight passing through third canopy layer + IF (shadow_d(1) > 0) THEN + tt(1,0) = ftdd_lay(1)*(tt(4,1) + tt(3,1) + tt(2,1))!*shadow_d(1)/shadow_d(1) + ENDIF !============================================= ! Aggregate direct radiation to layers !============================================= - tt(4,3) = tt(4,3) - tt(3,2) = tt(4,2) + tt(3,2) - tt(2,1) = tt(4,1) + tt(3,1) + tt(2,1) - tt(1,0) = tt(4,0) + tt(3,0) + tt(2,0) + tt(1,0) - ftdd_col= tt(1,0) + tt(4,3) = tt(4,3) + tt(3,2) = tt(4,2) + tt(3,2) + tt(2,1) = tt(4,1) + tt(3,1) + tt(2,1) + tt(1,0) = tt(4,0) + tt(3,0) + tt(2,0) + tt(1,0) + ftdd_col= tt(1,0) - tt(0:4,4) = D0 - tt(0:3,3) = D0 - tt(4:4,2) = D0; tt(0:2,2) = D0 - tt(3:4,1) = D0; tt(0:1,1) = D0 - tt(2:4,0) = D0; tt(0:0,0) = D0 + tt(0:4,4) = D0 + tt(0:3,3) = D0 + tt(4:4,2) = D0; tt(0:2,2) = D0 + tt(3:4,1) = D0; tt(0:1,1) = D0 + tt(2:4,0) = D0; tt(0:0,0) = D0 !======================================= @@ -628,304 +628,304 @@ SUBROUTINE ThreeDCanopy(ps, pe, canlay, fcover, csiz, chgt, chil, coszen, & ! ib=1:visible band 2:nir band !======================================= - DO ib = 1, numrad - - !=============================== - ! get pft level tau and ftdd - !=============================== - - ! 10/12/2017 - ftdi(:,ib) = D1 - - DO ip = ps, pe - - taud(ip)=D0 - taui(ip)=D0 - shadow_pd(ip)=D0 - shadow_pi(ip)=D0 - - IF (soilveg(ip)) THEN - clev = canlay(ip) - - !================================================ - ! fractional contribution of current pft in layer - !================================================ - - pfc = min( fcover(ip)/fc0(clev), D1) - shadow_pd(ip)=pfc*shadow_d(clev) - shadow_pi(ip)=pfc*shadow_i(clev) - - !===================================== - ! get taud,taui at pft level - !===================================== - - taud(ip)=D3/D4*gee*fcover(ip)*(lsai(ip))/& - (cosz*shadow_pd(ip)) - - taui(ip)=D3/D4*gee*fcover(ip)*(lsai(ip))/& - (cosd*shadow_pi(ip)) - - !==================================== - ! transmission at pft level - !==================================== - - ftdd_orig(ip,ib) = tee(DD1*taud(ip)) - ftdi_orig(ip,ib) = tee(DD1*taui(ip)) - - ! 11/07/2018: gdir/gdif = FUNCTION(xl, cos) - ftdd(ip,ib) = tee(DD1*taud(ip)/gee*gdir(ip)) - ftdi(ip,ib) = tee(DD1*taui(ip)/gee*gdif(ip)) - - ! calibration for chil - fcad(ip) = (D1-ftdd(ip,ib)) / (D1-ftdd_orig(ip,ib)) - fcai(ip) = (D1-ftdi(ip,ib)) / (D1-ftdi_orig(ip,ib)) - - ENDIF ! ENDIF soilveg - ENDDO ! ENDDO ip - - !=============================================================== - ! absorption, reflection and transmittance for three canopy layer - ! using average optical properties of layers - ! subroutine CanopyRad calculates fluxes for unit input radiation - !=============================================================== - - ftid_lay=D0; ftii_lay=D1 - frid_lay=D0; frii_lay=D0 - faid_lay=D0; faii_lay=D0 + DO ib = 1, numrad + + !=============================== + ! get pft level tau and ftdd + !=============================== + + ! 10/12/2017 + ftdi(:,ib) = D1 + + DO ip = ps, pe + + taud(ip)=D0 + taui(ip)=D0 + shadow_pd(ip)=D0 + shadow_pi(ip)=D0 + + IF (soilveg(ip)) THEN + clev = canlay(ip) + + !================================================ + ! fractional contribution of current pft in layer + !================================================ + + pfc = min( fcover(ip)/fc0(clev), D1) + shadow_pd(ip)=pfc*shadow_d(clev) + shadow_pi(ip)=pfc*shadow_i(clev) + + !===================================== + ! get taud,taui at pft level + !===================================== + + taud(ip)=D3/D4*gee*fcover(ip)*(lsai(ip))/& + (cosz*shadow_pd(ip)) + + taui(ip)=D3/D4*gee*fcover(ip)*(lsai(ip))/& + (cosd*shadow_pi(ip)) + + !==================================== + ! transmission at pft level + !==================================== + + ftdd_orig(ip,ib) = tee(DD1*taud(ip)) + ftdi_orig(ip,ib) = tee(DD1*taui(ip)) + + ! 11/07/2018: gdir/gdif = FUNCTION(xl, cos) + ftdd(ip,ib) = tee(DD1*taud(ip)/gee*gdir(ip)) + ftdi(ip,ib) = tee(DD1*taui(ip)/gee*gdif(ip)) + + ! calibration for chil + fcad(ip) = (D1-ftdd(ip,ib)) / (D1-ftdd_orig(ip,ib)) + fcai(ip) = (D1-ftdi(ip,ib)) / (D1-ftdi_orig(ip,ib)) + + ENDIF ! ENDIF soilveg + ENDDO ! ENDDO ip + + !=============================================================== + ! absorption, reflection and transmittance for three canopy layer + ! using average optical properties of layers + ! subroutine CanopyRad calculates fluxes for unit input radiation + !=============================================================== + + ftid_lay=D0; ftii_lay=D1 + frid_lay=D0; frii_lay=D0 + faid_lay=D0; faii_lay=D0 + + DO lev = 1, 3 + IF (shadow_d(lev) > D0) THEN + CALL CanopyRad(taud_lay(lev), taui_lay(lev), ftdd_lay_orig(lev),& + ftdi_lay_orig(lev), cosz, cosd, shadow_d(lev), shadow_i(lev), & + fc0(lev), omg_lay(lev,ib), lsai_lay(lev), & + tau_lay(lev,ib), rho_lay(lev,ib), ftid_lay(lev), & + ftii_lay(lev), frid_lay(lev), frii_lay(lev),& + faid_lay(lev), faii_lay(lev)) + ENDIF + ENDDO ! ENDDO lev + + ! 11/07/2018: calibration for LAD + ftid_lay(:) = fcad_lay(:)*ftid_lay(:) + ftii_lay(:) = fcai_lay(:)*(ftii_lay(:)-ftdi_lay_orig(:)) + ftdi_lay(:) + frid_lay(:) = fcad_lay(:)*frid_lay(:) + frii_lay(:) = fcai_lay(:)*frii_lay(:) + faid_lay(:) = fcad_lay(:)*faid_lay(:) + faii_lay(:) = fcai_lay(:)*faii_lay(:) + + !============================================= + ! Calculate layer direct beam radiation absorbed + ! in the sunlit canopy as direct + !============================================= + + fadd_lay(:,ib) = D0 + + DO lev = 1, nlay + IF ( fc0(lev)>D0 .and. lsai_lay(lev)>D0 ) THEN + fadd_lay(lev,ib) = tt(lev+1,lev) * & + (D1-ftdd_lay(lev)) * (D1-omg_lay(lev,ib)) + ENDIF + ENDDO - DO lev = 1, 3 - IF (shadow_d(lev) > D0) THEN - CALL CanopyRad(taud_lay(lev), taui_lay(lev), ftdd_lay_orig(lev),& - ftdi_lay_orig(lev), cosz, cosd, shadow_d(lev), shadow_i(lev), & - fc0(lev), omg_lay(lev,ib), lsai_lay(lev), & - tau_lay(lev,ib), rho_lay(lev,ib), ftid_lay(lev), & - ftii_lay(lev), frid_lay(lev), frii_lay(lev),& - faid_lay(lev), faii_lay(lev)) + A = D0; B = D0; + fabs_leq = D0 + + ! Calculate the coefficients matrix A + A(1,1) = 1.0; A(1,3) = -shadow_i(3)*ftii_lay(3) + shadow_i(3) - 1.0; + A(2,2) = 1.0; A(2,3) = -shadow_i(3)*frii_lay(3); + A(3,3) = 1.0; A(3,2) = -shadow_i(2)*frii_lay(2); A(3,5) = -shadow_i(2)*ftii_lay(2) + shadow_i(2) - 1.0; + A(4,4) = 1.0; A(4,5) = -shadow_i(2)*frii_lay(2); A(4,2) = -shadow_i(2)*ftii_lay(2) + shadow_i(2) - 1.0; + A(5,5) = 1.0; A(5,4) = -shadow_i(1)*frii_lay(1); A(5,6) =(-shadow_i(1)*ftii_lay(1) + shadow_i(1) - 1.0) * albgri(ib); + A(6,6) = 1.0 - albgri(ib)*shadow_i(1)*frii_lay(1); A(6,4) = -shadow_i(1)*ftii_lay(1) + shadow_i(1) - 1.0; + + ! The constant vector B at right side + B(1,1) = tt(4,3)*frid_lay(3); B(1,2) = shadow_i(3)*frii_lay(3); + B(2,1) = tt(4,3)*ftid_lay(3); B(2,2) = shadow_i(3)*ftii_lay(3) - shadow_i(3) + 1.0; + B(3,1) = tt(3,2)*frid_lay(2); B(3,2) = 0.0; + B(4,1) = tt(3,2)*ftid_lay(2); B(4,2) = 0.0; + B(5,1) = tt(2,1)*frid_lay(1) + tt(1,0)*albgrd(ib)*(shadow_i(1)*ftii_lay(1) - shadow_i(1) + 1.0); B(5,2) = 0.0; + B(6,1) = tt(2,1)*ftid_lay(1) + tt(1,0)*albgrd(ib)*shadow_i(1)*frii_lay(1); B(6,2) = 0.0; + + ! Get the resolution + CALL mGauss(A, B, X) + + ! ==================================================== + ! Set back to the absorption for each layer and albedo + ! ==================================================== + + ! Albedo + fabs_leq(4,:) = X(1,:) + + ! Three layers' absorption + fabs_leq(3,1) = tt(4,3)*faid_lay(3) + X(3,1)*shadow_i(3)*faii_lay(3) + fabs_leq(3,2) = shadow_i(3)*faii_lay(3) + X(3,2)*shadow_i(3)*faii_lay(3) + fabs_leq(2,1) = tt(3,2)*faid_lay(2) + (X(2,1) + X(5,1))*shadow_i(2)*faii_lay(2) + fabs_leq(2,2) = (X(2,2) + X(5,2)) * shadow_i(2) * faii_lay(2) + fabs_leq(1,1) = tt(2,1)*faid_lay(1) + (X(4,1) + X(6,1)*albgri(ib) + tt(1,0)*albgrd(ib))*shadow_i(1)*faii_lay(1) + fabs_leq(1,2) = (X(4,2) + X(6,2)*albgri(ib)) * shadow_i(1) * faii_lay(1) + + ! Ground absorption + fabs_leq(0,1) = X(6,1) * (1.0 - albgri(ib)) + tt(1,0) * (1.0 - albgrd(ib)) + fabs_leq(0,2) = X(6,2) * (1.0 - albgri(ib)) + + ! IF everything is ok, substitute fabs_lay for fabs_leq + ! and delete the following line and the variables defined + ! but not used anymore + fabs_lay = fabs_leq + + ! set column absorption and reflection + fabd_lay(1:3,ib) = fabs_lay(1:3,1) + fabi_lay(1:3,ib) = fabs_lay(1:3,2) + fabd_col(ib) = fabs_lay(1,1)+fabs_lay(2,1)+fabs_lay(3,1) + fabi_col(ib) = fabs_lay(1,2)+fabs_lay(2,2)+fabs_lay(3,2) + albd_col(ib) = fabs_lay(4,1) + albi_col(ib) = fabs_lay(4,2) + + ! balance check + IF (abs(fabd_col(ib)+albd_col(ib)+fabs_lay(0,1)-1) > 1e-6) THEN + print *, "Imbalance kband=1" + print *, fabd_col(ib)+albd_col(ib)+fabs_lay(0,1)-1 ENDIF - ENDDO ! ENDDO lev - - ! 11/07/2018: calibration for LAD - ftid_lay(:) = fcad_lay(:)*ftid_lay(:) - ftii_lay(:) = fcai_lay(:)*(ftii_lay(:)-ftdi_lay_orig(:)) + ftdi_lay(:) - frid_lay(:) = fcad_lay(:)*frid_lay(:) - frii_lay(:) = fcai_lay(:)*frii_lay(:) - faid_lay(:) = fcad_lay(:)*faid_lay(:) - faii_lay(:) = fcai_lay(:)*faii_lay(:) - - !============================================= - ! Calculate layer direct beam radiation absorbed - ! in the sunlit canopy as direct - !============================================= - - fadd_lay(:,ib) = D0 - - DO lev = 1, nlay - IF ( fc0(lev)>D0 .and. lsai_lay(lev)>D0 ) THEN - fadd_lay(lev,ib) = tt(lev+1,lev) * & - (D1-ftdd_lay(lev)) * (D1-omg_lay(lev,ib)) + IF (abs(fabi_col(ib)+albi_col(ib)+fabs_lay(0,2)-1) > 1e-6) THEN + print *, "Imbalance kband=2" + print *, fabi_col(ib)+albi_col(ib)+fabs_lay(0,2)-1 ENDIF - ENDDO - - A = D0; B = D0; - fabs_leq = D0 - - ! Calculate the coefficients matrix A - A(1,1) = 1.0; A(1,3) = -shadow_i(3)*ftii_lay(3) + shadow_i(3) - 1.0; - A(2,2) = 1.0; A(2,3) = -shadow_i(3)*frii_lay(3); - A(3,3) = 1.0; A(3,2) = -shadow_i(2)*frii_lay(2); A(3,5) = -shadow_i(2)*ftii_lay(2) + shadow_i(2) - 1.0; - A(4,4) = 1.0; A(4,5) = -shadow_i(2)*frii_lay(2); A(4,2) = -shadow_i(2)*ftii_lay(2) + shadow_i(2) - 1.0; - A(5,5) = 1.0; A(5,4) = -shadow_i(1)*frii_lay(1); A(5,6) =(-shadow_i(1)*ftii_lay(1) + shadow_i(1) - 1.0) * albgri(ib); - A(6,6) = 1.0 - albgri(ib)*shadow_i(1)*frii_lay(1); A(6,4) = -shadow_i(1)*ftii_lay(1) + shadow_i(1) - 1.0; - - ! The constant vector B at right side - B(1,1) = tt(4,3)*frid_lay(3); B(1,2) = shadow_i(3)*frii_lay(3); - B(2,1) = tt(4,3)*ftid_lay(3); B(2,2) = shadow_i(3)*ftii_lay(3) - shadow_i(3) + 1.0; - B(3,1) = tt(3,2)*frid_lay(2); B(3,2) = 0.0; - B(4,1) = tt(3,2)*ftid_lay(2); B(4,2) = 0.0; - B(5,1) = tt(2,1)*frid_lay(1) + tt(1,0)*albgrd(ib)*(shadow_i(1)*ftii_lay(1) - shadow_i(1) + 1.0); B(5,2) = 0.0; - B(6,1) = tt(2,1)*ftid_lay(1) + tt(1,0)*albgrd(ib)*shadow_i(1)*frii_lay(1); B(6,2) = 0.0; - - ! Get the resolution - CALL mGauss(A, B, X) - - ! ==================================================== - ! Set back to the absorption for each layer and albedo - ! ==================================================== - - ! Albedo - fabs_leq(4,:) = X(1,:) - - ! Three layers' absorption - fabs_leq(3,1) = tt(4,3)*faid_lay(3) + X(3,1)*shadow_i(3)*faii_lay(3) - fabs_leq(3,2) = shadow_i(3)*faii_lay(3) + X(3,2)*shadow_i(3)*faii_lay(3) - fabs_leq(2,1) = tt(3,2)*faid_lay(2) + (X(2,1) + X(5,1))*shadow_i(2)*faii_lay(2) - fabs_leq(2,2) = (X(2,2) + X(5,2)) * shadow_i(2) * faii_lay(2) - fabs_leq(1,1) = tt(2,1)*faid_lay(1) + (X(4,1) + X(6,1)*albgri(ib) + tt(1,0)*albgrd(ib))*shadow_i(1)*faii_lay(1) - fabs_leq(1,2) = (X(4,2) + X(6,2)*albgri(ib)) * shadow_i(1) * faii_lay(1) - - ! Ground absorption - fabs_leq(0,1) = X(6,1) * (1.0 - albgri(ib)) + tt(1,0) * (1.0 - albgrd(ib)) - fabs_leq(0,2) = X(6,2) * (1.0 - albgri(ib)) - - ! IF everything is ok, substitute fabs_lay for fabs_leq - ! and delete the following line and the variables defined - ! but not used anymore - fabs_lay = fabs_leq - - ! set column absorption and reflection - fabd_lay(1:3,ib) = fabs_lay(1:3,1) - fabi_lay(1:3,ib) = fabs_lay(1:3,2) - fabd_col(ib) = fabs_lay(1,1)+fabs_lay(2,1)+fabs_lay(3,1) - fabi_col(ib) = fabs_lay(1,2)+fabs_lay(2,2)+fabs_lay(3,2) - albd_col(ib) = fabs_lay(4,1) - albi_col(ib) = fabs_lay(4,2) - - ! balance check - IF (abs(fabd_col(ib)+albd_col(ib)+fabs_lay(0,1)-1) > 1e-6) THEN - print *, "Imbalance kband=1" - print *, fabd_col(ib)+albd_col(ib)+fabs_lay(0,1)-1 - ENDIF - IF (abs(fabi_col(ib)+albi_col(ib)+fabs_lay(0,2)-1) > 1e-6) THEN - print *, "Imbalance kband=2" - print *, fabi_col(ib)+albi_col(ib)+fabs_lay(0,2)-1 - ENDIF !==================================================== ! Calculate individule PFT absorption !==================================================== - sum_fabd=D0 - sum_fabi=D0 - sum_fadd=D0 - - DO ip = ps, pe - clev = canlay(ip) - IF (clev == D0) CYCLE - IF ( shadow_d(clev)>D0 .and. soilveg(ip) ) THEN - - !================================================= - ! fractional contribution of current pft in layer - !================================================= - - pfc = min( fcover(ip)/fc0(clev), D1) - - !========================================= - ! shadow contribution from ground to sky - !========================================= - - shadow_sky(ip) = shadow_pi(ip) - - !======================================================= - ! absorption, reflection and transmittance fluxes for - ! unit incident radiation over pft. - !======================================================= - - CALL CanopyRad(taud(ip), taui(ip), ftdd_orig(ip,ib), ftdi_orig(ip,ib), & - cosz,cosd, shadow_pd(ip), shadow_pi(ip), fcover(ip),& - omega(ip,ib), lsai(ip), tau(ip,ib),& - rho(ip,ib), ftid(ip,ib), ftii(ip,ib), albd(ip,ib),& - albi(ip,ib), faid_p, faii_p) - - ! calibration for LAD - ! 11/07/2018: calibration for LAD - ftid(ip,ib) = fcad(ip)*ftid(ip,ib) - ftii(ip,ib) = fcai(ip)*(ftii(ip,ib)-ftdi_orig(ip,ib)) + ftdi(ip,ib) - albd(ip,ib) = fcad(ip)*albd(ip,ib) - albi(ip,ib) = fcai(ip)*albi(ip,ib) - faid_p = fcad(ip)*faid_p - faii_p = fcai(ip)*faii_p - - ! absorptions after multiple reflections for each pft - probm = albi(ip,ib)*shadow_sky(ip)*albgri(ib) - ftran = (D1-shadow_pd(ip)+shadow_pd(ip)*ftdd(ip,ib))*albgrd(ib) & - + shadow_pd(ip)*ftid(ip,ib)*albgri(ib) - fabsm = ftran*faii_p*shadow_sky(ip)/(D1-probm) - fabd(ip,ib) = shadow_pd(ip)*faid_p + fabsm - - probm = albi(ip,ib)*shadow_sky(ip)*albgri(ib) - ftran = D1-shadow_pi(ip)*(D1 -ftii(ip,ib)) - fabsm = ftran*albgri(ib)*faii_p*shadow_sky(ip)/(D1-probm) - fabi(ip,ib) = shadow_pi(ip)*faii_p + fabsm - - ! sum of pft absorptions in column - sum_fabd(clev) = sum_fabd(clev) + fabd(ip,ib) - sum_fabi(clev) = sum_fabi(clev) + fabi(ip,ib) - - ! pft absorption in sunlit as direct beam - fadd(ip,ib) = shadow_pd(ip) * (D1-ftdd(ip,ib)) * (D1-omega(ip,ib)) - - ! sum of pft absorption in sunlit as direct beam - sum_fadd(clev) = sum_fadd(clev) + fadd(ip,ib) - - ENDIF ! ENDIF shadow & soilveg - ENDDO ! ENDDO ip + sum_fabd=D0 + sum_fabi=D0 + sum_fadd=D0 - DO ip = ps, pe - clev = canlay(ip) + DO ip = ps, pe + clev = canlay(ip) + IF (clev == D0) CYCLE + IF ( shadow_d(clev)>D0 .and. soilveg(ip) ) THEN + + !================================================= + ! fractional contribution of current pft in layer + !================================================= + + pfc = min( fcover(ip)/fc0(clev), D1) + + !========================================= + ! shadow contribution from ground to sky + !========================================= + + shadow_sky(ip) = shadow_pi(ip) + + !======================================================= + ! absorption, reflection and transmittance fluxes for + ! unit incident radiation over pft. + !======================================================= + + CALL CanopyRad(taud(ip), taui(ip), ftdd_orig(ip,ib), ftdi_orig(ip,ib), & + cosz,cosd, shadow_pd(ip), shadow_pi(ip), fcover(ip),& + omega(ip,ib), lsai(ip), tau(ip,ib),& + rho(ip,ib), ftid(ip,ib), ftii(ip,ib), albd(ip,ib),& + albi(ip,ib), faid_p, faii_p) + + ! calibration for LAD + ! 11/07/2018: calibration for LAD + ftid(ip,ib) = fcad(ip)*ftid(ip,ib) + ftii(ip,ib) = fcai(ip)*(ftii(ip,ib)-ftdi_orig(ip,ib)) + ftdi(ip,ib) + albd(ip,ib) = fcad(ip)*albd(ip,ib) + albi(ip,ib) = fcai(ip)*albi(ip,ib) + faid_p = fcad(ip)*faid_p + faii_p = fcai(ip)*faii_p + + ! absorptions after multiple reflections for each pft + probm = albi(ip,ib)*shadow_sky(ip)*albgri(ib) + ftran = (D1-shadow_pd(ip)+shadow_pd(ip)*ftdd(ip,ib))*albgrd(ib) & + + shadow_pd(ip)*ftid(ip,ib)*albgri(ib) + fabsm = ftran*faii_p*shadow_sky(ip)/(D1-probm) + fabd(ip,ib) = shadow_pd(ip)*faid_p + fabsm + + probm = albi(ip,ib)*shadow_sky(ip)*albgri(ib) + ftran = D1-shadow_pi(ip)*(D1 -ftii(ip,ib)) + fabsm = ftran*albgri(ib)*faii_p*shadow_sky(ip)/(D1-probm) + fabi(ip,ib) = shadow_pi(ip)*faii_p + fabsm + + ! sum of pft absorptions in column + sum_fabd(clev) = sum_fabd(clev) + fabd(ip,ib) + sum_fabi(clev) = sum_fabi(clev) + fabi(ip,ib) + + ! pft absorption in sunlit as direct beam + fadd(ip,ib) = shadow_pd(ip) * (D1-ftdd(ip,ib)) * (D1-omega(ip,ib)) + + ! sum of pft absorption in sunlit as direct beam + sum_fadd(clev) = sum_fadd(clev) + fadd(ip,ib) + + ENDIF ! ENDIF shadow & soilveg + ENDDO ! ENDDO ip + + DO ip = ps, pe + clev = canlay(ip) - !=========================================================== - ! adjust pft absorption for total column absorption per - ! unit column area - !=========================================================== + !=========================================================== + ! adjust pft absorption for total column absorption per + ! unit column area + !=========================================================== - IF (soilveg(ip)) THEN - fabd(ip,ib)=fabd(ip,ib)*fabd_lay(clev,ib)/& - sum_fabd(clev)/fcover(ip) - fabi(ip,ib)=fabi(ip,ib)*fabi_lay(clev,ib)/& - sum_fabi(clev)/fcover(ip) + IF (soilveg(ip)) THEN + fabd(ip,ib)=fabd(ip,ib)*fabd_lay(clev,ib)/& + sum_fabd(clev)/fcover(ip) + fabi(ip,ib)=fabi(ip,ib)*fabi_lay(clev,ib)/& + sum_fabi(clev)/fcover(ip) - fadd(ip,ib) = fadd(ip,ib)*fadd_lay(clev,ib)/& - sum_fadd(clev)/fcover(ip) + fadd(ip,ib) = fadd(ip,ib)*fadd_lay(clev,ib)/& + sum_fadd(clev)/fcover(ip) - fadd(ip,ib) = min(fabd(ip,ib), fadd(ip,ib)) - psun(ip) = tt(clev+1,clev)/shadow_d(clev) - ELSE - fabd(ip,ib) = D0 - fabi(ip,ib) = D0 - fadd(ip,ib) = D0 - psun(ip) = D0 - ENDIF + fadd(ip,ib) = min(fabd(ip,ib), fadd(ip,ib)) + psun(ip) = tt(clev+1,clev)/shadow_d(clev) + ELSE + fabd(ip,ib) = D0 + fabi(ip,ib) = D0 + fadd(ip,ib) = D0 + psun(ip) = D0 + ENDIF - ! column albedo is assigned to each pft in column - ! Added by Yuan, 06/03/2012 - albd(ip,ib) =albd_col(ib) - albi(ip,ib) =albi_col(ib) + ! column albedo is assigned to each pft in column + ! Added by Yuan, 06/03/2012 + albd(ip,ib) =albd_col(ib) + albi(ip,ib) =albi_col(ib) - ! adjust ftdd and ftii for multi reflections between layers + ! adjust ftdd and ftii for multi reflections between layers ! 03/06/2020, yuan: NOTE! there is no physical mean of ftdd, ! ftid, ftii anymore. they are the same for each PFT can only ! be used to calculate the ground absorption. - ftdd(ip,ib) = ftdd_col - ftid(ip,ib)=(D1-albd(ip,ib)-fabd_col(ib)-& - ftdd(ip,ib)*(D1-albgrd(ib)))/(D1-albgri(ib)) - ftii(ip,ib)=(D1-albi(ip,ib)-fabi_col(ib))/(D1-albgri(ib)) - - !ftdd(ip,ib) = min(max(ftdd(ip,ib),D0),D1) - !ftii(ip,ib) = min(max(ftii(ip,ib),D0),D1) - !ftid(ip,ib) = min(max(ftid(ip,ib),D0),D1) - - ! check energy balance - !fabd(ip,ib) = D1 - albd(ip,ib) - & - ! ftdd(ip,ib)*(D1-albgrd(ib)) - & - ! ftid(ip,ib)*(D1-albgri(ib)) - !fabi(ip,ib) = D1 - albi(ip,ib) - & - ! ftii(ip,ib)*(D1-albgri(ib)) + ftdd(ip,ib) = ftdd_col + ftid(ip,ib)=(D1-albd(ip,ib)-fabd_col(ib)-& + ftdd(ip,ib)*(D1-albgrd(ib)))/(D1-albgri(ib)) + ftii(ip,ib)=(D1-albi(ip,ib)-fabi_col(ib))/(D1-albgri(ib)) - ENDDO ! ENDDO ip - ENDDO !ENDDO ib + !ftdd(ip,ib) = min(max(ftdd(ip,ib),D0),D1) + !ftii(ip,ib) = min(max(ftii(ip,ib),D0),D1) + !ftid(ip,ib) = min(max(ftid(ip,ib),D0),D1) - ! set parameters for longwave calculation - fshade(:) = shadow_pi(:) - thermk(:) = ftdi(:,1) + ! check energy balance + !fabd(ip,ib) = D1 - albd(ip,ib) - & + ! ftdd(ip,ib)*(D1-albgrd(ib)) - & + ! ftid(ip,ib)*(D1-albgri(ib)) + !fabi(ip,ib) = D1 - albi(ip,ib) - & + ! ftii(ip,ib)*(D1-albgri(ib)) - END SUBROUTINE ThreeDCanopy + ENDDO ! ENDDO ip + ENDDO !ENDDO ib + + ! set parameters for longwave calculation + fshade(:) = shadow_pi(:) + thermk(:) = ftdi(:,1) + + END SUBROUTINE ThreeDCanopy !===================== ! FUNCTION tee !===================== - real(selected_real_kind(12)) FUNCTION tee(tau) + real(selected_real_kind(12)) FUNCTION tee(tau) IMPLICIT NONE @@ -934,15 +934,15 @@ real(selected_real_kind(12)) FUNCTION tee(tau) real(r16),parameter :: DD2 = 2.0_r16 !128-bit accuracy real real(r16) :: tau ! transmittance - tee = DDH*(DD1/tau/tau-(DD1/tau/tau+DD2/tau)*exp(-DD2*tau)) + tee = DDH*(DD1/tau/tau-(DD1/tau/tau+DD2/tau)*exp(-DD2*tau)) - END FUNCTION tee + END FUNCTION tee !=========================================== ! FUNCTION overlapArea !=========================================== - real(selected_real_kind(12)) FUNCTION OverlapArea(radius, hgt, zenith) + real(selected_real_kind(12)) FUNCTION OverlapArea(radius, hgt, zenith) IMPLICIT NONE @@ -956,28 +956,28 @@ real(selected_real_kind(12)) FUNCTION OverlapArea(radius, hgt, zenith) real(r8) :: cost !cosine of angle real(r8) :: theta !angle - IF (radius == D0) THEN - OverlapArea= D0 - RETURN - ENDIF - cost = hgt*tan(zenith)/radius/(D1+D1/cos(zenith)) - IF (cost >= 1) THEN - OverlapArea= D0 + IF (radius == D0) THEN + OverlapArea= D0 + RETURN + ENDIF + cost = hgt*tan(zenith)/radius/(D1+D1/cos(zenith)) + IF (cost >= 1) THEN + OverlapArea= D0 + RETURN + ENDIF + theta = acos(cost) + OverlapArea = (theta-cost*sin(theta))*(D1+D1/cos(zenith))/rpi RETURN - ENDIF - theta = acos(cost) - OverlapArea = (theta-cost*sin(theta))*(D1+D1/cos(zenith))/rpi - RETURN - END FUNCTION OverlapArea + END FUNCTION OverlapArea !========================================================= ! FUNCTION to calculate scattering, absorption, reflection and ! transmittance for unit input radiation !========================================================= - SUBROUTINE CanopyRad(tau_d, tau_i, ftdd, ftdi, cosz,cosd, & - shadow_d, shadow_i, fc, omg, lsai, tau_p, rho_p, & - ftid, ftii, frid, frii, faid, faii) + SUBROUTINE CanopyRad(tau_d, tau_i, ftdd, ftdi, cosz,cosd, & + shadow_d, shadow_i, fc, omg, lsai, tau_p, rho_p, & + ftid, ftii, frid, frii, faid, faii) IMPLICIT NONE ! input variables @@ -1036,88 +1036,88 @@ SUBROUTINE CanopyRad(tau_d, tau_i, ftdd, ftdi, cosz,cosd, & real(r8),parameter :: pi = 3.14159265358979323846_R8 !pi - tau = D3/D4*gee*lsai + tau = D3/D4*gee*lsai - CALL phi(runmode, tau_d, omg, tau_p, rho_p, phi_tot_d, phi_dif_d, pa2) - CALL phi(runmode, tau_i, omg, tau_p, rho_p, phi_tot_i, phi_dif_i, pa2) - CALL phi(runmode, tau , omg, tau_p, rho_p, phi_tot_o, phi_dif_o, pa2) + CALL phi(runmode, tau_d, omg, tau_p, rho_p, phi_tot_d, phi_dif_d, pa2) + CALL phi(runmode, tau_i, omg, tau_p, rho_p, phi_tot_i, phi_dif_i, pa2) + CALL phi(runmode, tau , omg, tau_p, rho_p, phi_tot_o, phi_dif_o, pa2) - IF (runmode) THEN - ! NOTE: modified - frio = DH*(phi_tot_o - DH*phi_dif_o) - frio = max(min(frio,D1),D0) + IF (runmode) THEN + ! NOTE: modified + frio = DH*(phi_tot_o - DH*phi_dif_o) + frio = max(min(frio,D1),D0) - muv = D3*( D1 - sqrt(D1-sqrt(D3)*fc/(D2*pi)) ) + & - D3*( D1 - sqrt(D1-sqrt(D3)*fc/(D6*pi)) ) + muv = D3*( D1 - sqrt(D1-sqrt(D3)*fc/(D2*pi)) ) + & + D3*( D1 - sqrt(D1-sqrt(D3)*fc/(D6*pi)) ) - wb = D2/D3*rho_p + D1/D3*tau_p - alpha = sqrt(D1-omg) * sqrt(D1-omg+D2*wb) - nd = (D1 + D2*alpha) / (D1 + D2*alpha*cosz) - ni = (D1 + D2*alpha) / (D1 + D2*alpha*cosd) + wb = D2/D3*rho_p + D1/D3*tau_p + alpha = sqrt(D1-omg) * sqrt(D1-omg+D2*wb) + nd = (D1 + D2*alpha) / (D1 + D2*alpha*cosz) + ni = (D1 + D2*alpha) / (D1 + D2*alpha*cosd) - ac = phi_tot_o * muv * (D1-tee(DD1*tau)) * (D1-omg) / (D1-omg*pa2) - ald = (nd-D1) * frio * fc * (D1/shadow_d - cosz/fc) - ali = (ni-D1) * frio * fc * (D1/shadow_i - cosd/fc) - ENDIF + ac = phi_tot_o * muv * (D1-tee(DD1*tau)) * (D1-omg) / (D1-omg*pa2) + ald = (nd-D1) * frio * fc * (D1/shadow_d - cosz/fc) + ali = (ni-D1) * frio * fc * (D1/shadow_i - cosd/fc) + ENDIF !----------------------------------------------------------------------- !frac indirect downward rad through canopy for black soil & direct solar !----------------------------------------------------------------------- - frid = DH*(phi_tot_d - DH*cosz*phi_dif_d) - frii = DH*(phi_tot_i - DH*cosd*phi_dif_i) + frid = DH*(phi_tot_d - DH*cosz*phi_dif_d) + frii = DH*(phi_tot_i - DH*cosd*phi_dif_i) - IF (runmode) THEN - frid = frid + ald - DH*ac - frii = frii + ali - DH*ac - ENDIF + IF (runmode) THEN + frid = frid + ald - DH*ac + frii = frii + ali - DH*ac + ENDIF - frid = max(min(frid,D1),D0) - frii = max(min(frii,D1),D0) + frid = max(min(frid,D1),D0) + frii = max(min(frii,D1),D0) !--------------------------------------------------------------------- !downward diffuse fraction from direct and diffuse sun !--------------------------------------------------------------------- - ftid = DH*(phi_tot_d + DH*cosz*phi_dif_d) - ftii = DH*(phi_tot_i + DH*cosd*phi_dif_i)+ftdi + ftid = DH*(phi_tot_d + DH*cosz*phi_dif_d) + ftii = DH*(phi_tot_i + DH*cosd*phi_dif_i)+ftdi - IF (runmode) THEN - ftid = ftid - DH*ald - DH*ac - ftii = ftii - DH*ali - DH*ac - ENDIF + IF (runmode) THEN + ftid = ftid - DH*ald - DH*ac + ftii = ftii - DH*ali - DH*ac + ENDIF - ftid = max(min(ftid,D1),D0) - ftii = max(min(ftii,D1),D0) + ftid = max(min(ftid,D1),D0) + ftii = max(min(ftii,D1),D0) !--------------------------------------------------------------------- ! canopy absorption for direct or diffuse beams !--------------------------------------------------------------------- - IF (.not. runmode) THEN - faid = D1 - ftdd - phi_tot_d - faii = D1 - ftdi - phi_tot_i - ELSE - faid = D1 - ftdd - frid - ftid - faii = D1 - frii - ftii - ENDIF - - faid = max(min(faid,D1),D0) - faii = max(min(faii,D1),D0) - - IF (shadow_d == D0) THEN - ! NOTE: corrected from D1 -> D0 - ftid = D0 - frid = D0 - faid = D0 - ENDIF - IF (shadow_i == D0) THEN - ftii = D1 - frii = D0 - faii = D0 - ENDIF - - END SUBROUTINE CanopyRad - - - SUBROUTINE phi(runmode, tau, omg, tau_p, rho_p, phi_tot, phi_dif, pa2) + IF (.not. runmode) THEN + faid = D1 - ftdd - phi_tot_d + faii = D1 - ftdi - phi_tot_i + ELSE + faid = D1 - ftdd - frid - ftid + faii = D1 - frii - ftii + ENDIF + + faid = max(min(faid,D1),D0) + faii = max(min(faii,D1),D0) + + IF (shadow_d == D0) THEN + ! NOTE: corrected from D1 -> D0 + ftid = D0 + frid = D0 + faid = D0 + ENDIF + IF (shadow_i == D0) THEN + ftii = D1 + frii = D0 + faii = D0 + ENDIF + + END SUBROUTINE CanopyRad + + + SUBROUTINE phi(runmode, tau, omg, tau_p, rho_p, phi_tot, phi_dif, pa2) IMPLICIT NONE @@ -1162,75 +1162,75 @@ SUBROUTINE phi(runmode, tau, omg, tau_p, rho_p, phi_tot, phi_dif, pa2) ! for direct and diffuse beams !---------------------------------------------------------------------- - ! forward first order normalized scattering - phi_1f = (DD1/tau/tau - (DD1/tau/tau + DD2/tau + DD2)*exp(-DD2*tau)) + ! forward first order normalized scattering + phi_1f = (DD1/tau/tau - (DD1/tau/tau + DD2/tau + DD2)*exp(-DD2*tau)) - ! backward first order normalized scattering - phi_1b = DDH*(DD1 - tee(DD2*tau)) + ! backward first order normalized scattering + phi_1b = DDH*(DD1 - tee(DD2*tau)) !---------------------------------------------------------------------- ! sphere double scattering terms (RED 2008 Eq 19,20) !---------------------------------------------------------------------- - IF (.not. runmode) THEN + IF (.not. runmode) THEN - ! forward double scattering - phi_2f = DDH*(DD4*phi_1f/DD3 + tee(DD2*tau) + tee(DD4*tau)/DD9 - & - DD10*tee(DD1*tau)/DD9) + ! forward double scattering + phi_2f = DDH*(DD4*phi_1f/DD3 + tee(DD2*tau) + tee(DD4*tau)/DD9 - & + DD10*tee(DD1*tau)/DD9) - ! backward double scattering - phi_2b = DDH*(DD1/DD3 - tee(DD2*tau) + DD2*tee(DD3*tau)/DD3) + ! backward double scattering + phi_2b = DDH*(DD1/DD3 - tee(DD2*tau) + DD2*tee(DD3*tau)/DD3) - ELSE - ! fitting FUNCTION for second order scattering - aa = 0.70_r8 - bb = 1.74_r8 + ELSE + ! fitting FUNCTION for second order scattering + aa = 0.70_r8 + bb = 1.74_r8 - phi_2b = aa*( DD1/(bb+DD1) -DD1/(bb-D1)*tee(DD2*tau) + & - DD2/(bb+DD1)/(bb-DD1)*tee((DD1+bb)*tau) ) + phi_2b = aa*( DD1/(bb+DD1) -DD1/(bb-D1)*tee(DD2*tau) + & + DD2/(bb+DD1)/(bb-DD1)*tee((DD1+bb)*tau) ) - phi_2f = aa*( DD2*bb/(bb*bb-DD1)*phi_1f - & - (DD1/(bb+DD1)/(bb+DD1) + DD1/(bb-DD1)/(bb-DD1))*tee(DD1*tau) + & - DD1/(bb-DD1)/(bb-DD1)*tee(DD1*tau*bb) + & - DD1/(bb+DD1)/(bb+DD1)*tee(DD1*(bb+DD2)*tau) ) - ENDIF + phi_2f = aa*( DD2*bb/(bb*bb-DD1)*phi_1f - & + (DD1/(bb+DD1)/(bb+DD1) + DD1/(bb-DD1)/(bb-DD1))*tee(DD1*tau) + & + DD1/(bb-DD1)/(bb-DD1)*tee(DD1*tau*bb) + & + DD1/(bb+DD1)/(bb+DD1)*tee(DD1*(bb+DD2)*tau) ) + ENDIF - ! second order avaerage scattering - phi_2a = DDH*(phi_2b + phi_2f) + ! second order avaerage scattering + phi_2a = DDH*(phi_2b + phi_2f) !---------------------------------------------------------------------- ! probabilty of absorption after two scattering !---------------------------------------------------------------------- - ! probabilty of absorption for diffuse beam - ! corrected probabilty of absorption for direct beam - pac = DD1-phi_2a / & - (DD1 - tee(DD1*tau) - (rho_p*phi_1b + tau_p*phi_1f)/(tau_p+rho_p)) + ! probabilty of absorption for diffuse beam + ! corrected probabilty of absorption for direct beam + pac = DD1-phi_2a / & + (DD1 - tee(DD1*tau) - (rho_p*phi_1b + tau_p*phi_1f)/(tau_p+rho_p)) - ! NOTE: for test only - pac = max(min(pac,D1),D0) - pa2 = pac + ! NOTE: for test only + pac = max(min(pac,D1),D0) + pa2 = pac !---------------------------------------------------------------------- !third order and higher order scatterings !---------------------------------------------------------------------- - phi_mf = phi_2f + omg*pac*phi_2a/(DD1-omg*pac) - phi_mb = phi_2b + omg*pac*phi_2a/(DD1-omg*pac) + phi_mf = phi_2f + omg*pac*phi_2a/(DD1-omg*pac) + phi_mb = phi_2b + omg*pac*phi_2a/(DD1-omg*pac) !---------------------------------------------------------------------- ! total sphere scattering,forward,backward, avg & diff for direct beam !---------------------------------------------------------------------- - phi_tf = tau_p*phi_1f + DDH*omg*omg*phi_mf - phi_tb = rho_p*phi_1b + DDH*omg*omg*phi_mb + phi_tf = tau_p*phi_1f + DDH*omg*omg*phi_mf + phi_tb = rho_p*phi_1b + DDH*omg*omg*phi_mb - phi_tot = phi_tf + phi_tb - phi_dif = phi_tf - phi_tb + phi_tot = phi_tf + phi_tb + phi_dif = phi_tf - phi_tb - END SUBROUTINE phi + END SUBROUTINE phi - SUBROUTINE mGauss(A, B, X) + SUBROUTINE mGauss(A, B, X) IMPLICIT NONE @@ -1243,26 +1243,27 @@ SUBROUTINE mGauss(A, B, X) real(r8) :: f - ! Elimination - DO i = 1, 5 - DO j = i+1, i+nstep(i) - IF (abs(A(i,i)) < 1.e-10) THEN - print *, "Error in Gauss's solution" - RETURN - ENDIF - f = - A(j,i)/A(i,i) - A(j,:) = A(j,:) + f*A(i,:) - B(j,:) = B(j,:) + f*B(i,:) + ! Elimination + DO i = 1, 5 + DO j = i+1, i+nstep(i) + IF (abs(A(i,i)) < 1.e-10) THEN + print *, "Error in Gauss's solution" + RETURN + ENDIF + f = - A(j,i)/A(i,i) + A(j,:) = A(j,:) + f*A(i,:) + B(j,:) = B(j,:) + f*B(i,:) + ENDDO ENDDO - ENDDO - ! Back substitution - X(6,:) = B(6,:)/A(6,6) - DO i = 5, 1, -1 - X(i,1) = (B(i,1) - sum(A(i,i+1:6)*X(i+1:6,1))) / A(i,i) - X(i,2) = (B(i,2) - sum(A(i,i+1:6)*X(i+1:6,2))) / A(i,i) - ENDDO + ! Back substitution + X(6,:) = B(6,:)/A(6,6) + DO i = 5, 1, -1 + X(i,1) = (B(i,1) - sum(A(i,i+1:6)*X(i+1:6,1))) / A(i,i) + X(i,2) = (B(i,2) - sum(A(i,i+1:6)*X(i+1:6,2))) / A(i,i) + ENDDO - END SUBROUTINE mGauss + END SUBROUTINE mGauss END MODULE MOD_3DCanopyRadiation +! --------- EOP ---------- diff --git a/main/MOD_Aerosol.F90 b/main/MOD_Aerosol.F90 index 9e411b5e..464b17ea 100644 --- a/main/MOD_Aerosol.F90 +++ b/main/MOD_Aerosol.F90 @@ -2,429 +2,429 @@ MODULE MOD_Aerosol - !----------------------------------------------------------------------- - USE MOD_Precision - USE MOD_Grid - USE MOD_DataType - USE MOD_Mapping_Grid2Pset - USE MOD_Vars_Global, only: maxsnl - IMPLICIT NONE - SAVE - ! !PUBLIC MEMBER FUNCTIONS: - PUBLIC :: AerosolMasses - PUBLIC :: AerosolFluxes - PUBLIC :: AerosolDepInit - PUBLIC :: AerosolDepReadin - ! - ! !PUBLIC DATA MEMBERS: - !----------------------------------------------------------------------- - - logical, parameter :: use_extrasnowlayers = .false. - real(r8), parameter :: snw_rds_min = 54.526_r8 ! minimum allowed snow effective radius (also "fresh snow" value) [microns] - real(r8), parameter :: fresh_snw_rds_max = 204.526_r8 ! maximum warm fresh snow effective radius [microns] - - character(len=256) :: file_aerosol - - type(grid_type) :: grid_aerosol - type(block_data_real8_2d) :: f_aerdep - type(mapping_grid2pset_type) :: mg2p_aerdep - - integer, parameter :: start_year = 1849 - integer, parameter :: end_year = 2001 - - integer :: month_p +!----------------------------------------------------------------------- + USE MOD_Precision + USE MOD_Grid + USE MOD_DataType + USE MOD_Mapping_Grid2Pset + USE MOD_Vars_Global, only: maxsnl + IMPLICIT NONE + SAVE + +! !PUBLIC MEMBER FUNCTIONS: + PUBLIC :: AerosolMasses + PUBLIC :: AerosolFluxes + PUBLIC :: AerosolDepInit + PUBLIC :: AerosolDepReadin +! +! !PUBLIC DATA MEMBERS: +!----------------------------------------------------------------------- + + logical, parameter :: use_extrasnowlayers = .false. + real(r8), parameter :: snw_rds_min = 54.526_r8 ! minimum allowed snow effective radius (also "fresh snow" value) [microns] + real(r8), parameter :: fresh_snw_rds_max = 204.526_r8 ! maximum warm fresh snow effective radius [microns] + + character(len=256) :: file_aerosol + + type(grid_type) :: grid_aerosol + type(block_data_real8_2d) :: f_aerdep + type(mapping_grid2pset_type) :: mg2p_aerdep + + integer, parameter :: start_year = 1849 + integer, parameter :: end_year = 2001 + + integer :: month_p CONTAINS - !----------------------------------------------------------------------- - SUBROUTINE AerosolMasses( dtime ,snl ,do_capsnow ,& - h2osno_ice ,h2osno_liq ,qflx_snwcp_ice ,snw_rds ,& - - mss_bcpho ,mss_bcphi ,mss_ocpho ,mss_ocphi ,& - mss_dst1 ,mss_dst2 ,mss_dst3 ,mss_dst4 ,& - - mss_cnc_bcphi ,mss_cnc_bcpho ,mss_cnc_ocphi ,mss_cnc_ocpho ,& - mss_cnc_dst1 ,mss_cnc_dst2 ,mss_cnc_dst3 ,mss_cnc_dst4 ) - - ! - ! !DESCRIPTION: - ! Calculate column-integrated aerosol masses, and - ! mass concentrations for radiative calculations and output - ! (based on new snow level state, after SnowFilter is rebuilt. - ! NEEDS TO BE AFTER SnowFiler is rebuilt in Hydrology2, otherwise there - ! can be zero snow layers but an active column in filter) - - IMPLICIT NONE - - ! !ARGUMENTS: - ! - real(r8),intent(in) :: dtime !seconds in a time step [second] - integer, intent(in) :: snl ! number of snow layers - - logical, intent(in) :: do_capsnow ! true => do snow capping - real(r8), intent(in) :: h2osno_ice ( maxsnl+1:0 ) ! ice lens (kg/m2) - real(r8), intent(in) :: h2osno_liq ( maxsnl+1:0 ) ! liquid water (kg/m2) - real(r8), intent(in) :: qflx_snwcp_ice ! excess snowfall due to snow capping (mm H2O /s) [+] - - real(r8), intent(inout) :: snw_rds ( maxsnl+1:0 ) ! effective snow grain radius (col,lyr) [microns, m^-6] - - real(r8), intent(inout) :: mss_bcpho ( maxsnl+1:0 ) ! mass of hydrophobic BC in snow (col,lyr) [kg] - real(r8), intent(inout) :: mss_bcphi ( maxsnl+1:0 ) ! mass of hydrophillic BC in snow (col,lyr) [kg] - real(r8), intent(inout) :: mss_ocpho ( maxsnl+1:0 ) ! mass of hydrophobic OC in snow (col,lyr) [kg] - real(r8), intent(inout) :: mss_ocphi ( maxsnl+1:0 ) ! mass of hydrophillic OC in snow (col,lyr) [kg] - real(r8), intent(inout) :: mss_dst1 ( maxsnl+1:0 ) ! mass of dust species 1 in snow (col,lyr) [kg] - real(r8), intent(inout) :: mss_dst2 ( maxsnl+1:0 ) ! mass of dust species 2 in snow (col,lyr) [kg] - real(r8), intent(inout) :: mss_dst3 ( maxsnl+1:0 ) ! mass of dust species 3 in snow (col,lyr) [kg] - real(r8), intent(inout) :: mss_dst4 ( maxsnl+1:0 ) ! mass of dust species 4 in snow (col,lyr) [kg] - - real(r8), intent(out) :: mss_cnc_bcphi ( maxsnl+1:0 ) ! mass concentration of BC species 1 (col,lyr) [kg/kg] - real(r8), intent(out) :: mss_cnc_bcpho ( maxsnl+1:0 ) ! mass concentration of BC species 2 (col,lyr) [kg/kg] - real(r8), intent(out) :: mss_cnc_ocphi ( maxsnl+1:0 ) ! mass concentration of OC species 1 (col,lyr) [kg/kg] - real(r8), intent(out) :: mss_cnc_ocpho ( maxsnl+1:0 ) ! mass concentration of OC species 2 (col,lyr) [kg/kg] - real(r8), intent(out) :: mss_cnc_dst1 ( maxsnl+1:0 ) ! mass concentration of dust species 1 (col,lyr) [kg/kg] - real(r8), intent(out) :: mss_cnc_dst2 ( maxsnl+1:0 ) ! mass concentration of dust species 2 (col,lyr) [kg/kg] - real(r8), intent(out) :: mss_cnc_dst3 ( maxsnl+1:0 ) ! mass concentration of dust species 3 (col,lyr) [kg/kg] - real(r8), intent(out) :: mss_cnc_dst4 ( maxsnl+1:0 ) ! mass concentration of dust species 4 (col,lyr) [kg/kg] - - ! !LOCAL VARIABLES: - integer :: c,j ! indices - real(r8) :: snowmass ! liquid+ice snow mass in a layer [kg/m2] - real(r8) :: snowcap_scl_fct ! temporary factor used to correct for snow capping - - !----------------------------------------------------------------------- - - DO j = maxsnl+1, 0 - - ! layer mass of snow: - snowmass = h2osno_ice(j) + h2osno_liq(j) - - IF (.not. use_extrasnowlayers) THEN - ! Correct the top layer aerosol mass to account for snow capping. - ! This approach conserves the aerosol mass concentration - ! (but not the aerosol amss) when snow-capping is invoked - - IF (j == snl+1) THEN - IF (do_capsnow) THEN - - snowcap_scl_fct = snowmass / (snowmass + (qflx_snwcp_ice*dtime)) - - mss_bcpho(j) = mss_bcpho(j)*snowcap_scl_fct - mss_bcphi(j) = mss_bcphi(j)*snowcap_scl_fct - mss_ocpho(j) = mss_ocpho(j)*snowcap_scl_fct - mss_ocphi(j) = mss_ocphi(j)*snowcap_scl_fct - - mss_dst1(j) = mss_dst1(j)*snowcap_scl_fct - mss_dst2(j) = mss_dst2(j)*snowcap_scl_fct - mss_dst3(j) = mss_dst3(j)*snowcap_scl_fct - mss_dst4(j) = mss_dst4(j)*snowcap_scl_fct - ENDIF - ENDIF - ENDIF - - IF (j >= snl+1) THEN - - mss_cnc_bcphi(j) = mss_bcphi(j) / snowmass - mss_cnc_bcpho(j) = mss_bcpho(j) / snowmass - - mss_cnc_ocphi(j) = mss_ocphi(j) / snowmass - mss_cnc_ocpho(j) = mss_ocpho(j) / snowmass - - mss_cnc_dst1(j) = mss_dst1(j) / snowmass - mss_cnc_dst2(j) = mss_dst2(j) / snowmass - mss_cnc_dst3(j) = mss_dst3(j) / snowmass - mss_cnc_dst4(j) = mss_dst4(j) / snowmass - - ELSE - ! 01/10/2023, yuan: set empty snow layers to snw_rds_min - !snw_rds(j) = 0._r8 - snw_rds(j) = snw_rds_min - - mss_bcpho(j) = 0._r8 - mss_bcphi(j) = 0._r8 - mss_cnc_bcphi(j) = 0._r8 - mss_cnc_bcpho(j) = 0._r8 - - mss_ocpho(j) = 0._r8 - mss_ocphi(j) = 0._r8 - mss_cnc_ocphi(j) = 0._r8 - mss_cnc_ocpho(j) = 0._r8 - - mss_dst1(j) = 0._r8 - mss_dst2(j) = 0._r8 - mss_dst3(j) = 0._r8 - mss_dst4(j) = 0._r8 - mss_cnc_dst1(j) = 0._r8 - mss_cnc_dst2(j) = 0._r8 - mss_cnc_dst3(j) = 0._r8 - mss_cnc_dst4(j) = 0._r8 - ENDIF - ENDDO - - END SUBROUTINE AerosolMasses - - - - !----------------------------------------------------------------------- - SUBROUTINE AerosolFluxes( dtime, snl, forc_aer, & - mss_bcphi ,mss_bcpho ,mss_ocphi ,mss_ocpho ,& - mss_dst1 ,mss_dst2 ,mss_dst3 ,mss_dst4 ) - ! - ! !DESCRIPTION: - ! Compute aerosol fluxes through snowpack and aerosol deposition fluxes into top layere - ! - IMPLICIT NONE - ! - !----------------------------------------------------------------------- - ! !ARGUMENTS: - real(r8),intent(in) :: dtime !seconds in a time step [second] - integer, intent(in) :: snl ! number of snow layers - - real(r8), intent(in) :: forc_aer (14 ) ! aerosol deposition from atmosphere model (grd,aer) [kg m-1 s-1] - - real(r8), intent(inout) :: mss_bcphi (maxsnl+1:0 ) ! hydrophillic BC mass in snow (col,lyr) [kg] - real(r8), intent(inout) :: mss_bcpho (maxsnl+1:0 ) ! hydrophobic BC mass in snow (col,lyr) [kg] - real(r8), intent(inout) :: mss_ocphi (maxsnl+1:0 ) ! hydrophillic OC mass in snow (col,lyr) [kg] - real(r8), intent(inout) :: mss_ocpho (maxsnl+1:0 ) ! hydrophobic OC mass in snow (col,lyr) [kg] - real(r8), intent(inout) :: mss_dst1 (maxsnl+1:0 ) ! mass of dust species 1 in snow (col,lyr) [kg] - real(r8), intent(inout) :: mss_dst2 (maxsnl+1:0 ) ! mass of dust species 2 in snow (col,lyr) [kg] - real(r8), intent(inout) :: mss_dst3 (maxsnl+1:0 ) ! mass of dust species 3 in snow (col,lyr) [kg] - real(r8), intent(inout) :: mss_dst4 (maxsnl+1:0 ) ! mass of dust species 4 in snow (col,lyr) [kg] - - ! !LOCAL VARIABLES: - real(r8) :: flx_bc_dep ! total BC deposition (col) [kg m-2 s-1] - real(r8) :: flx_bc_dep_phi ! hydrophillic BC deposition (col) [kg m-1 s-1] - real(r8) :: flx_bc_dep_pho ! hydrophobic BC deposition (col) [kg m-1 s-1] - real(r8) :: flx_oc_dep ! total OC deposition (col) [kg m-2 s-1] - real(r8) :: flx_oc_dep_phi ! hydrophillic OC deposition (col) [kg m-1 s-1] - real(r8) :: flx_oc_dep_pho ! hydrophobic OC deposition (col) [kg m-1 s-1] - real(r8) :: flx_dst_dep ! total dust deposition (col) [kg m-2 s-1] - - real(r8) :: flx_dst_dep_wet1 ! wet dust (species 1) deposition (col) [kg m-2 s-1] - real(r8) :: flx_dst_dep_dry1 ! dry dust (species 1) deposition (col) [kg m-2 s-1] - real(r8) :: flx_dst_dep_wet2 ! wet dust (species 2) deposition (col) [kg m-2 s-1] - real(r8) :: flx_dst_dep_dry2 ! dry dust (species 2) deposition (col) [kg m-2 s-1] - real(r8) :: flx_dst_dep_wet3 ! wet dust (species 3) deposition (col) [kg m-2 s-1] - real(r8) :: flx_dst_dep_dry3 ! dry dust (species 3) deposition (col) [kg m-2 s-1] - real(r8) :: flx_dst_dep_wet4 ! wet dust (species 4) deposition (col) [kg m-2 s-1] - real(r8) :: flx_dst_dep_dry4 ! dry dust (species 4) deposition (col) [kg m-2 s-1] - - integer :: c - - !----------------------------------------------------------------------- - ! set aerosol deposition fluxes from forcing array - ! The forcing array is either set from an external file - ! or from fluxes received from the atmosphere model + !----------------------------------------------------------------------- + SUBROUTINE AerosolMasses( dtime ,snl ,do_capsnow ,& + h2osno_ice ,h2osno_liq ,qflx_snwcp_ice ,snw_rds ,& + + mss_bcpho ,mss_bcphi ,mss_ocpho ,mss_ocphi ,& + mss_dst1 ,mss_dst2 ,mss_dst3 ,mss_dst4 ,& + + mss_cnc_bcphi ,mss_cnc_bcpho ,mss_cnc_ocphi ,mss_cnc_ocpho ,& + mss_cnc_dst1 ,mss_cnc_dst2 ,mss_cnc_dst3 ,mss_cnc_dst4 ) + + ! + ! !DESCRIPTION: + ! Calculate column-integrated aerosol masses, and + ! mass concentrations for radiative calculations and output + ! (based on new snow level state, after SnowFilter is rebuilt. + ! NEEDS TO BE AFTER SnowFiler is rebuilt in Hydrology2, otherwise there + ! can be zero snow layers but an active column in filter) + + IMPLICIT NONE + + ! !ARGUMENTS: + ! + real(r8),intent(in) :: dtime !seconds in a time step [second] + integer, intent(in) :: snl ! number of snow layers + + logical, intent(in) :: do_capsnow ! true => do snow capping + real(r8), intent(in) :: h2osno_ice ( maxsnl+1:0 ) ! ice lens (kg/m2) + real(r8), intent(in) :: h2osno_liq ( maxsnl+1:0 ) ! liquid water (kg/m2) + real(r8), intent(in) :: qflx_snwcp_ice ! excess snowfall due to snow capping (mm H2O /s) [+] + + real(r8), intent(inout) :: snw_rds ( maxsnl+1:0 ) ! effective snow grain radius (col,lyr) [microns, m^-6] + + real(r8), intent(inout) :: mss_bcpho ( maxsnl+1:0 ) ! mass of hydrophobic BC in snow (col,lyr) [kg] + real(r8), intent(inout) :: mss_bcphi ( maxsnl+1:0 ) ! mass of hydrophillic BC in snow (col,lyr) [kg] + real(r8), intent(inout) :: mss_ocpho ( maxsnl+1:0 ) ! mass of hydrophobic OC in snow (col,lyr) [kg] + real(r8), intent(inout) :: mss_ocphi ( maxsnl+1:0 ) ! mass of hydrophillic OC in snow (col,lyr) [kg] + real(r8), intent(inout) :: mss_dst1 ( maxsnl+1:0 ) ! mass of dust species 1 in snow (col,lyr) [kg] + real(r8), intent(inout) :: mss_dst2 ( maxsnl+1:0 ) ! mass of dust species 2 in snow (col,lyr) [kg] + real(r8), intent(inout) :: mss_dst3 ( maxsnl+1:0 ) ! mass of dust species 3 in snow (col,lyr) [kg] + real(r8), intent(inout) :: mss_dst4 ( maxsnl+1:0 ) ! mass of dust species 4 in snow (col,lyr) [kg] + + real(r8), intent(out) :: mss_cnc_bcphi ( maxsnl+1:0 ) ! mass concentration of BC species 1 (col,lyr) [kg/kg] + real(r8), intent(out) :: mss_cnc_bcpho ( maxsnl+1:0 ) ! mass concentration of BC species 2 (col,lyr) [kg/kg] + real(r8), intent(out) :: mss_cnc_ocphi ( maxsnl+1:0 ) ! mass concentration of OC species 1 (col,lyr) [kg/kg] + real(r8), intent(out) :: mss_cnc_ocpho ( maxsnl+1:0 ) ! mass concentration of OC species 2 (col,lyr) [kg/kg] + real(r8), intent(out) :: mss_cnc_dst1 ( maxsnl+1:0 ) ! mass concentration of dust species 1 (col,lyr) [kg/kg] + real(r8), intent(out) :: mss_cnc_dst2 ( maxsnl+1:0 ) ! mass concentration of dust species 2 (col,lyr) [kg/kg] + real(r8), intent(out) :: mss_cnc_dst3 ( maxsnl+1:0 ) ! mass concentration of dust species 3 (col,lyr) [kg/kg] + real(r8), intent(out) :: mss_cnc_dst4 ( maxsnl+1:0 ) ! mass concentration of dust species 4 (col,lyr) [kg/kg] + + ! !LOCAL VARIABLES: + integer :: c,j ! indices + real(r8) :: snowmass ! liquid+ice snow mass in a layer [kg/m2] + real(r8) :: snowcap_scl_fct ! temporary factor used to correct for snow capping + + !----------------------------------------------------------------------- + + DO j = maxsnl+1, 0 + + ! layer mass of snow: + snowmass = h2osno_ice(j) + h2osno_liq(j) + + IF (.not. use_extrasnowlayers) THEN + ! Correct the top layer aerosol mass to account for snow capping. + ! This approach conserves the aerosol mass concentration + ! (but not the aerosol amss) when snow-capping is invoked + + IF (j == snl+1) THEN + IF (do_capsnow) THEN + + snowcap_scl_fct = snowmass / (snowmass + (qflx_snwcp_ice*dtime)) + + mss_bcpho(j) = mss_bcpho(j)*snowcap_scl_fct + mss_bcphi(j) = mss_bcphi(j)*snowcap_scl_fct + mss_ocpho(j) = mss_ocpho(j)*snowcap_scl_fct + mss_ocphi(j) = mss_ocphi(j)*snowcap_scl_fct + + mss_dst1(j) = mss_dst1(j)*snowcap_scl_fct + mss_dst2(j) = mss_dst2(j)*snowcap_scl_fct + mss_dst3(j) = mss_dst3(j)*snowcap_scl_fct + mss_dst4(j) = mss_dst4(j)*snowcap_scl_fct + ENDIF + ENDIF + ENDIF + + IF (j >= snl+1) THEN + + mss_cnc_bcphi(j) = mss_bcphi(j) / snowmass + mss_cnc_bcpho(j) = mss_bcpho(j) / snowmass + + mss_cnc_ocphi(j) = mss_ocphi(j) / snowmass + mss_cnc_ocpho(j) = mss_ocpho(j) / snowmass + + mss_cnc_dst1(j) = mss_dst1(j) / snowmass + mss_cnc_dst2(j) = mss_dst2(j) / snowmass + mss_cnc_dst3(j) = mss_dst3(j) / snowmass + mss_cnc_dst4(j) = mss_dst4(j) / snowmass + + ELSE + ! 01/10/2023, yuan: set empty snow layers to snw_rds_min + !snw_rds(j) = 0._r8 + snw_rds(j) = snw_rds_min + + mss_bcpho(j) = 0._r8 + mss_bcphi(j) = 0._r8 + mss_cnc_bcphi(j) = 0._r8 + mss_cnc_bcpho(j) = 0._r8 + + mss_ocpho(j) = 0._r8 + mss_ocphi(j) = 0._r8 + mss_cnc_ocphi(j) = 0._r8 + mss_cnc_ocpho(j) = 0._r8 + + mss_dst1(j) = 0._r8 + mss_dst2(j) = 0._r8 + mss_dst3(j) = 0._r8 + mss_dst4(j) = 0._r8 + mss_cnc_dst1(j) = 0._r8 + mss_cnc_dst2(j) = 0._r8 + mss_cnc_dst3(j) = 0._r8 + mss_cnc_dst4(j) = 0._r8 + ENDIF + ENDDO + + END SUBROUTINE AerosolMasses + + + + !----------------------------------------------------------------------- + SUBROUTINE AerosolFluxes( dtime, snl, forc_aer, & + mss_bcphi ,mss_bcpho ,mss_ocphi ,mss_ocpho ,& + mss_dst1 ,mss_dst2 ,mss_dst3 ,mss_dst4 ) + ! + ! !DESCRIPTION: + ! Compute aerosol fluxes through snowpack and aerosol deposition fluxes into top layere + ! + IMPLICIT NONE + ! + !----------------------------------------------------------------------- + ! !ARGUMENTS: + real(r8),intent(in) :: dtime !seconds in a time step [second] + integer, intent(in) :: snl ! number of snow layers + + real(r8), intent(in) :: forc_aer (14 ) ! aerosol deposition from atmosphere model (grd,aer) [kg m-1 s-1] + + real(r8), intent(inout) :: mss_bcphi (maxsnl+1:0 ) ! hydrophillic BC mass in snow (col,lyr) [kg] + real(r8), intent(inout) :: mss_bcpho (maxsnl+1:0 ) ! hydrophobic BC mass in snow (col,lyr) [kg] + real(r8), intent(inout) :: mss_ocphi (maxsnl+1:0 ) ! hydrophillic OC mass in snow (col,lyr) [kg] + real(r8), intent(inout) :: mss_ocpho (maxsnl+1:0 ) ! hydrophobic OC mass in snow (col,lyr) [kg] + real(r8), intent(inout) :: mss_dst1 (maxsnl+1:0 ) ! mass of dust species 1 in snow (col,lyr) [kg] + real(r8), intent(inout) :: mss_dst2 (maxsnl+1:0 ) ! mass of dust species 2 in snow (col,lyr) [kg] + real(r8), intent(inout) :: mss_dst3 (maxsnl+1:0 ) ! mass of dust species 3 in snow (col,lyr) [kg] + real(r8), intent(inout) :: mss_dst4 (maxsnl+1:0 ) ! mass of dust species 4 in snow (col,lyr) [kg] + + ! !LOCAL VARIABLES: + real(r8) :: flx_bc_dep ! total BC deposition (col) [kg m-2 s-1] + real(r8) :: flx_bc_dep_phi ! hydrophillic BC deposition (col) [kg m-1 s-1] + real(r8) :: flx_bc_dep_pho ! hydrophobic BC deposition (col) [kg m-1 s-1] + real(r8) :: flx_oc_dep ! total OC deposition (col) [kg m-2 s-1] + real(r8) :: flx_oc_dep_phi ! hydrophillic OC deposition (col) [kg m-1 s-1] + real(r8) :: flx_oc_dep_pho ! hydrophobic OC deposition (col) [kg m-1 s-1] + real(r8) :: flx_dst_dep ! total dust deposition (col) [kg m-2 s-1] + + real(r8) :: flx_dst_dep_wet1 ! wet dust (species 1) deposition (col) [kg m-2 s-1] + real(r8) :: flx_dst_dep_dry1 ! dry dust (species 1) deposition (col) [kg m-2 s-1] + real(r8) :: flx_dst_dep_wet2 ! wet dust (species 2) deposition (col) [kg m-2 s-1] + real(r8) :: flx_dst_dep_dry2 ! dry dust (species 2) deposition (col) [kg m-2 s-1] + real(r8) :: flx_dst_dep_wet3 ! wet dust (species 3) deposition (col) [kg m-2 s-1] + real(r8) :: flx_dst_dep_dry3 ! dry dust (species 3) deposition (col) [kg m-2 s-1] + real(r8) :: flx_dst_dep_wet4 ! wet dust (species 4) deposition (col) [kg m-2 s-1] + real(r8) :: flx_dst_dep_dry4 ! dry dust (species 4) deposition (col) [kg m-2 s-1] + + integer :: c + + !----------------------------------------------------------------------- + ! set aerosol deposition fluxes from forcing array + ! The forcing array is either set from an external file + ! or from fluxes received from the atmosphere model #ifdef MODAL_AER - ! Mapping for modal aerosol scheme where within-hydrometeor and - ! interstitial aerosol fluxes are differentiated. Here, "phi" - ! flavors of BC and OC correspond to within-hydrometeor - ! (cloud-borne) aerosol, and "pho" flavors are interstitial - ! aerosol. "wet" and "dry" fluxes of BC and OC specified here are - ! purely diagnostic - ! - ! NOTE: right now the macro 'MODAL_AER' is not defined anywhere, i.e., - ! the below (modal aerosol scheme) is not available and can not be - ! active either. It depends on the specific input aerosol deposition - ! data which is suitable for modal scheme. [06/15/2023, Hua Yuan] - - - flx_bc_dep_phi = forc_aer(3) - flx_bc_dep_pho = forc_aer(1) + forc_aer(2) - flx_bc_dep = forc_aer(1) + forc_aer(2) + forc_aer(3) - - flx_oc_dep_phi = forc_aer(6) - flx_oc_dep_pho = forc_aer(4) + forc_aer(5) - flx_oc_dep = forc_aer(4) + forc_aer(5) + forc_aer(6) - - flx_dst_dep_wet1 = forc_aer(7) - flx_dst_dep_dry1 = forc_aer(8) - flx_dst_dep_wet2 = forc_aer(9) - flx_dst_dep_dry2 = forc_aer(10) - flx_dst_dep_wet3 = forc_aer(11) - flx_dst_dep_dry3 = forc_aer(12) - flx_dst_dep_wet4 = forc_aer(13) - flx_dst_dep_dry4 = forc_aer(14) - flx_dst_dep = forc_aer(7) + forc_aer(8) + forc_aer(9) + & - forc_aer(10) + forc_aer(11) + forc_aer(12) + & - forc_aer(13) + forc_aer(14) + ! Mapping for modal aerosol scheme where within-hydrometeor and + ! interstitial aerosol fluxes are differentiated. Here, "phi" + ! flavors of BC and OC correspond to within-hydrometeor + ! (cloud-borne) aerosol, and "pho" flavors are interstitial + ! aerosol. "wet" and "dry" fluxes of BC and OC specified here are + ! purely diagnostic + ! + ! NOTE: right now the macro 'MODAL_AER' is not defined anywhere, i.e., + ! the below (modal aerosol scheme) is not available and can not be + ! active either. It depends on the specific input aerosol deposition + ! data which is suitable for modal scheme. [06/15/2023, Hua Yuan] + + + flx_bc_dep_phi = forc_aer(3) + flx_bc_dep_pho = forc_aer(1) + forc_aer(2) + flx_bc_dep = forc_aer(1) + forc_aer(2) + forc_aer(3) + + flx_oc_dep_phi = forc_aer(6) + flx_oc_dep_pho = forc_aer(4) + forc_aer(5) + flx_oc_dep = forc_aer(4) + forc_aer(5) + forc_aer(6) + + flx_dst_dep_wet1 = forc_aer(7) + flx_dst_dep_dry1 = forc_aer(8) + flx_dst_dep_wet2 = forc_aer(9) + flx_dst_dep_dry2 = forc_aer(10) + flx_dst_dep_wet3 = forc_aer(11) + flx_dst_dep_dry3 = forc_aer(12) + flx_dst_dep_wet4 = forc_aer(13) + flx_dst_dep_dry4 = forc_aer(14) + flx_dst_dep = forc_aer(7) + forc_aer(8) + forc_aer(9) + & + forc_aer(10) + forc_aer(11) + forc_aer(12) + & + forc_aer(13) + forc_aer(14) #else - ! Original mapping for bulk aerosol deposition. phi and pho BC/OC - ! species are distinguished in model, other fluxes (e.g., dry and - ! wet BC/OC) are purely diagnostic. - - flx_bc_dep_phi = forc_aer(1) + forc_aer(3) - flx_bc_dep_pho = forc_aer(2) - flx_bc_dep = forc_aer(1) + forc_aer(2) + forc_aer(3) - - flx_oc_dep_phi = forc_aer(4) + forc_aer(6) - flx_oc_dep_pho = forc_aer(5) - flx_oc_dep = forc_aer(4) + forc_aer(5) + forc_aer(6) - - flx_dst_dep_wet1 = forc_aer(7) - flx_dst_dep_dry1 = forc_aer(8) - flx_dst_dep_wet2 = forc_aer(9) - flx_dst_dep_dry2 = forc_aer(10) - flx_dst_dep_wet3 = forc_aer(11) - flx_dst_dep_dry3 = forc_aer(12) - flx_dst_dep_wet4 = forc_aer(13) - flx_dst_dep_dry4 = forc_aer(14) - flx_dst_dep = forc_aer(7) + forc_aer(8) + forc_aer(9) + & - forc_aer(10) + forc_aer(11) + forc_aer(12) + & - forc_aer(13) + forc_aer(14) + ! Original mapping for bulk aerosol deposition. phi and pho BC/OC + ! species are distinguished in model, other fluxes (e.g., dry and + ! wet BC/OC) are purely diagnostic. + + flx_bc_dep_phi = forc_aer(1) + forc_aer(3) + flx_bc_dep_pho = forc_aer(2) + flx_bc_dep = forc_aer(1) + forc_aer(2) + forc_aer(3) + + flx_oc_dep_phi = forc_aer(4) + forc_aer(6) + flx_oc_dep_pho = forc_aer(5) + flx_oc_dep = forc_aer(4) + forc_aer(5) + forc_aer(6) + + flx_dst_dep_wet1 = forc_aer(7) + flx_dst_dep_dry1 = forc_aer(8) + flx_dst_dep_wet2 = forc_aer(9) + flx_dst_dep_dry2 = forc_aer(10) + flx_dst_dep_wet3 = forc_aer(11) + flx_dst_dep_dry3 = forc_aer(12) + flx_dst_dep_wet4 = forc_aer(13) + flx_dst_dep_dry4 = forc_aer(14) + flx_dst_dep = forc_aer(7) + forc_aer(8) + forc_aer(9) + & + forc_aer(10) + forc_aer(11) + forc_aer(12) + & + forc_aer(13) + forc_aer(14) #endif - ! aerosol deposition fluxes into top layer - ! This is done after the inter-layer fluxes so that some aerosol - ! is in the top layer after deposition, and is not immediately - ! washed out before radiative calculations are done + ! aerosol deposition fluxes into top layer + ! This is done after the inter-layer fluxes so that some aerosol + ! is in the top layer after deposition, and is not immediately + ! washed out before radiative calculations are done - mss_bcphi(snl+1) = mss_bcphi(snl+1) + (flx_bc_dep_phi*dtime) - mss_bcpho(snl+1) = mss_bcpho(snl+1) + (flx_bc_dep_pho*dtime) - mss_ocphi(snl+1) = mss_ocphi(snl+1) + (flx_oc_dep_phi*dtime) - mss_ocpho(snl+1) = mss_ocpho(snl+1) + (flx_oc_dep_pho*dtime) + mss_bcphi(snl+1) = mss_bcphi(snl+1) + (flx_bc_dep_phi*dtime) + mss_bcpho(snl+1) = mss_bcpho(snl+1) + (flx_bc_dep_pho*dtime) + mss_ocphi(snl+1) = mss_ocphi(snl+1) + (flx_oc_dep_phi*dtime) + mss_ocpho(snl+1) = mss_ocpho(snl+1) + (flx_oc_dep_pho*dtime) - mss_dst1(snl+1) = mss_dst1(snl+1) + (flx_dst_dep_dry1 + flx_dst_dep_wet1)*dtime - mss_dst2(snl+1) = mss_dst2(snl+1) + (flx_dst_dep_dry2 + flx_dst_dep_wet2)*dtime - mss_dst3(snl+1) = mss_dst3(snl+1) + (flx_dst_dep_dry3 + flx_dst_dep_wet3)*dtime - mss_dst4(snl+1) = mss_dst4(snl+1) + (flx_dst_dep_dry4 + flx_dst_dep_wet4)*dtime + mss_dst1(snl+1) = mss_dst1(snl+1) + (flx_dst_dep_dry1 + flx_dst_dep_wet1)*dtime + mss_dst2(snl+1) = mss_dst2(snl+1) + (flx_dst_dep_dry2 + flx_dst_dep_wet2)*dtime + mss_dst3(snl+1) = mss_dst3(snl+1) + (flx_dst_dep_dry3 + flx_dst_dep_wet3)*dtime + mss_dst4(snl+1) = mss_dst4(snl+1) + (flx_dst_dep_dry4 + flx_dst_dep_wet4)*dtime - END SUBROUTINE AerosolFluxes + END SUBROUTINE AerosolFluxes - SUBROUTINE AerosolDepInit () + SUBROUTINE AerosolDepInit () - USE MOD_Namelist - USE MOD_Grid - USE MOD_NetCDFSerial - USE MOD_NetCDFBlock - USE MOD_LandPatch - IMPLICIT NONE + USE MOD_Namelist + USE MOD_Grid + USE MOD_NetCDFSerial + USE MOD_NetCDFBlock + USE MOD_LandPatch + IMPLICIT NONE - real(r8), allocatable :: lat(:), lon(:) + real(r8), allocatable :: lat(:), lon(:) - IF (DEF_Aerosol_Clim) THEN - ! climatology data - file_aerosol = trim(DEF_dir_runtime) // '/aerosol/aerosoldep_monthly_2000_mean_0.9x1.25_c090529.nc' - ELSE - ! yearly change data - file_aerosol = trim(DEF_dir_runtime) // '/aerosol/aerosoldep_monthly_1849-2001_0.9x1.25_c090529.nc' - ENDIF + IF (DEF_Aerosol_Clim) THEN + ! climatology data + file_aerosol = trim(DEF_dir_runtime) // '/aerosol/aerosoldep_monthly_2000_mean_0.9x1.25_c090529.nc' + ELSE + ! yearly change data + file_aerosol = trim(DEF_dir_runtime) // '/aerosol/aerosoldep_monthly_1849-2001_0.9x1.25_c090529.nc' + ENDIF - CALL ncio_read_bcast_serial (file_aerosol, 'lat', lat) - CALL ncio_read_bcast_serial (file_aerosol, 'lon', lon) + CALL ncio_read_bcast_serial (file_aerosol, 'lat', lat) + CALL ncio_read_bcast_serial (file_aerosol, 'lon', lon) - CALL grid_aerosol%define_by_center (lat, lon) + CALL grid_aerosol%define_by_center (lat, lon) - CALL allocate_block_data (grid_aerosol, f_aerdep) + CALL allocate_block_data (grid_aerosol, f_aerdep) - CALL mg2p_aerdep%build (grid_aerosol, landpatch) + CALL mg2p_aerdep%build (grid_aerosol, landpatch) - month_p = -1 + month_p = -1 - END SUBROUTINE AerosolDepInit + END SUBROUTINE AerosolDepInit - SUBROUTINE AerosolDepReadin (idate) + SUBROUTINE AerosolDepReadin (idate) - USE MOD_TimeManager - USE MOD_NetCDFBlock - USE MOD_Namelist - USE MOD_Vars_1DForcing -#ifdef RangeCheck - USE MOD_RangeCheck + USE MOD_TimeManager + USE MOD_NetCDFBlock + USE MOD_Namelist + USE MOD_Vars_1DForcing +#ifdef RangeCheck + USE MOD_RangeCheck #endif - IMPLICIT NONE + IMPLICIT NONE - integer, intent(in) :: idate(3) + integer, intent(in) :: idate(3) - integer :: itime, year, month, mday + integer :: itime, year, month, mday - year = idate(1) - CALL julian2monthday (idate(1), idate(2), month, mday) + year = idate(1) + CALL julian2monthday (idate(1), idate(2), month, mday) - ! data before the start year, will use the start year - IF (year < start_year) year = start_year - ! data after the end year, will use the end year - IF (year > end_year ) year = end_year + ! data before the start year, will use the start year + IF (year < start_year) year = start_year + ! data after the end year, will use the end year + IF (year > end_year ) year = end_year - IF (month.eq.month_p) RETURN + IF (month.eq.month_p) RETURN - month_p = month + month_p = month - ! calculate itime - ! NOTE: aerosol deposition is monthly data - IF (DEF_Aerosol_Clim) THEN - ! for climatology data - itime = month - ELSE - ! for yearly change data - itime = (year-start_year)*12 + month - ENDIF + ! calculate itime + ! NOTE: aerosol deposition is monthly data + IF (DEF_Aerosol_Clim) THEN + ! for climatology data + itime = month + ELSE + ! for yearly change data + itime = (year-start_year)*12 + month + ENDIF - ! BCPHIDRY , hydrophilic BC dry deposition - CALL ncio_read_block_time (file_aerosol, 'BCPHIDRY', grid_aerosol, itime, f_aerdep) - CALL mg2p_aerdep%map_aweighted (f_aerdep, forc_aerdep(1,:)) + ! BCPHIDRY , hydrophilic BC dry deposition + CALL ncio_read_block_time (file_aerosol, 'BCPHIDRY', grid_aerosol, itime, f_aerdep) + CALL mg2p_aerdep%map_aweighted (f_aerdep, forc_aerdep(1,:)) - ! BCPHODRY , hydrophobic BC dry deposition - CALL ncio_read_block_time (file_aerosol, 'BCPHODRY', grid_aerosol, itime, f_aerdep) - CALL mg2p_aerdep%map_aweighted (f_aerdep, forc_aerdep(2,:)) + ! BCPHODRY , hydrophobic BC dry deposition + CALL ncio_read_block_time (file_aerosol, 'BCPHODRY', grid_aerosol, itime, f_aerdep) + CALL mg2p_aerdep%map_aweighted (f_aerdep, forc_aerdep(2,:)) - ! BCDEPWET , hydrophilic BC wet deposition - CALL ncio_read_block_time (file_aerosol, 'BCDEPWET', grid_aerosol, itime, f_aerdep) - CALL mg2p_aerdep%map_aweighted (f_aerdep, forc_aerdep(3,:)) + ! BCDEPWET , hydrophilic BC wet deposition + CALL ncio_read_block_time (file_aerosol, 'BCDEPWET', grid_aerosol, itime, f_aerdep) + CALL mg2p_aerdep%map_aweighted (f_aerdep, forc_aerdep(3,:)) - ! OCPHIDRY , hydrophilic OC dry deposition - CALL ncio_read_block_time (file_aerosol, 'OCPHIDRY', grid_aerosol, itime, f_aerdep) - CALL mg2p_aerdep%map_aweighted (f_aerdep, forc_aerdep(4,:)) + ! OCPHIDRY , hydrophilic OC dry deposition + CALL ncio_read_block_time (file_aerosol, 'OCPHIDRY', grid_aerosol, itime, f_aerdep) + CALL mg2p_aerdep%map_aweighted (f_aerdep, forc_aerdep(4,:)) - ! OCPHODRY , hydrophobic OC dry deposition - CALL ncio_read_block_time (file_aerosol, 'OCPHODRY', grid_aerosol, itime, f_aerdep) - CALL mg2p_aerdep%map_aweighted (f_aerdep, forc_aerdep(5,:)) + ! OCPHODRY , hydrophobic OC dry deposition + CALL ncio_read_block_time (file_aerosol, 'OCPHODRY', grid_aerosol, itime, f_aerdep) + CALL mg2p_aerdep%map_aweighted (f_aerdep, forc_aerdep(5,:)) - ! OCDEPWET , hydrophilic OC wet deposition - CALL ncio_read_block_time (file_aerosol, 'OCDEPWET', grid_aerosol, itime, f_aerdep) - CALL mg2p_aerdep%map_aweighted (f_aerdep, forc_aerdep(6,:)) + ! OCDEPWET , hydrophilic OC wet deposition + CALL ncio_read_block_time (file_aerosol, 'OCDEPWET', grid_aerosol, itime, f_aerdep) + CALL mg2p_aerdep%map_aweighted (f_aerdep, forc_aerdep(6,:)) - ! DSTX01WD , DSTX01 wet deposition flux at bottom - CALL ncio_read_block_time (file_aerosol, 'DSTX01WD', grid_aerosol, itime, f_aerdep) - CALL mg2p_aerdep%map_aweighted (f_aerdep, forc_aerdep(7,:)) + ! DSTX01WD , DSTX01 wet deposition flux at bottom + CALL ncio_read_block_time (file_aerosol, 'DSTX01WD', grid_aerosol, itime, f_aerdep) + CALL mg2p_aerdep%map_aweighted (f_aerdep, forc_aerdep(7,:)) - ! DSTX01DD , DSTX01 dry deposition flux at bottom - CALL ncio_read_block_time (file_aerosol, 'DSTX01DD', grid_aerosol, itime, f_aerdep) - CALL mg2p_aerdep%map_aweighted (f_aerdep, forc_aerdep(8,:)) + ! DSTX01DD , DSTX01 dry deposition flux at bottom + CALL ncio_read_block_time (file_aerosol, 'DSTX01DD', grid_aerosol, itime, f_aerdep) + CALL mg2p_aerdep%map_aweighted (f_aerdep, forc_aerdep(8,:)) - ! DSTX02WD , DSTX02 wet deposition flux at bottom - CALL ncio_read_block_time (file_aerosol, 'DSTX02WD', grid_aerosol, itime, f_aerdep) - CALL mg2p_aerdep%map_aweighted (f_aerdep, forc_aerdep(9,:)) + ! DSTX02WD , DSTX02 wet deposition flux at bottom + CALL ncio_read_block_time (file_aerosol, 'DSTX02WD', grid_aerosol, itime, f_aerdep) + CALL mg2p_aerdep%map_aweighted (f_aerdep, forc_aerdep(9,:)) - ! DSTX02DD , DSTX02 dry deposition flux at bottom - CALL ncio_read_block_time (file_aerosol, 'DSTX02DD', grid_aerosol, itime, f_aerdep) - CALL mg2p_aerdep%map_aweighted (f_aerdep, forc_aerdep(10,:)) + ! DSTX02DD , DSTX02 dry deposition flux at bottom + CALL ncio_read_block_time (file_aerosol, 'DSTX02DD', grid_aerosol, itime, f_aerdep) + CALL mg2p_aerdep%map_aweighted (f_aerdep, forc_aerdep(10,:)) - ! DSTX03WD , DSTX03 wet deposition flux at bottom - CALL ncio_read_block_time (file_aerosol, 'DSTX03WD', grid_aerosol, itime, f_aerdep) - CALL mg2p_aerdep%map_aweighted (f_aerdep, forc_aerdep(11,:)) + ! DSTX03WD , DSTX03 wet deposition flux at bottom + CALL ncio_read_block_time (file_aerosol, 'DSTX03WD', grid_aerosol, itime, f_aerdep) + CALL mg2p_aerdep%map_aweighted (f_aerdep, forc_aerdep(11,:)) - ! DSTX03DD , DSTX03 dry deposition flux at bottom - CALL ncio_read_block_time (file_aerosol, 'DSTX03DD', grid_aerosol, itime, f_aerdep) - CALL mg2p_aerdep%map_aweighted (f_aerdep, forc_aerdep(12,:)) + ! DSTX03DD , DSTX03 dry deposition flux at bottom + CALL ncio_read_block_time (file_aerosol, 'DSTX03DD', grid_aerosol, itime, f_aerdep) + CALL mg2p_aerdep%map_aweighted (f_aerdep, forc_aerdep(12,:)) - ! DSTX04WD , DSTX04 wet deposition flux at bottom - CALL ncio_read_block_time (file_aerosol, 'DSTX04WD', grid_aerosol, itime, f_aerdep) - CALL mg2p_aerdep%map_aweighted (f_aerdep, forc_aerdep(13,:)) + ! DSTX04WD , DSTX04 wet deposition flux at bottom + CALL ncio_read_block_time (file_aerosol, 'DSTX04WD', grid_aerosol, itime, f_aerdep) + CALL mg2p_aerdep%map_aweighted (f_aerdep, forc_aerdep(13,:)) - ! DSTX04DD , DSTX04 dry deposition flux at bottom - CALL ncio_read_block_time (file_aerosol, 'DSTX04DD', grid_aerosol, itime, f_aerdep) - CALL mg2p_aerdep%map_aweighted (f_aerdep, forc_aerdep(14,:)) + ! DSTX04DD , DSTX04 dry deposition flux at bottom + CALL ncio_read_block_time (file_aerosol, 'DSTX04DD', grid_aerosol, itime, f_aerdep) + CALL mg2p_aerdep%map_aweighted (f_aerdep, forc_aerdep(14,:)) -#ifdef RangeCheck - ! CALL check_block_data ('aerosol', f_aerdep) - CALL check_vector_data (' aerosol [kg/m/s]', forc_aerdep) +#ifdef RangeCheck + !CALL check_block_data ('aerosol', f_aerdep) + CALL check_vector_data (' aerosol [kg/m/s]', forc_aerdep) #endif - END SUBROUTINE AerosolDepReadin - + END SUBROUTINE AerosolDepReadin END MODULE MOD_Aerosol diff --git a/main/MOD_Albedo.F90 b/main/MOD_Albedo.F90 index dfcbbd62..1cb0cb8c 100644 --- a/main/MOD_Albedo.F90 +++ b/main/MOD_Albedo.F90 @@ -3,34 +3,31 @@ MODULE MOD_Albedo !----------------------------------------------------------------------- - USE MOD_Precision - IMPLICIT NONE - SAVE + USE MOD_Precision + IMPLICIT NONE + SAVE ! PUBLIC MEMBER FUNCTIONS: - PUBLIC :: albland - PUBLIC :: snowage - PUBLIC :: SnowAlbedo - PUBLIC :: albocean - + PUBLIC :: albland + PUBLIC :: snowage + PUBLIC :: SnowAlbedo + PUBLIC :: albocean ! PRIVATE MEMBER FUNCTIONS: - PRIVATE :: twostream + PRIVATE :: twostream #if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) - PRIVATE :: twostream_mod - PRIVATE :: twostream_wrap + PRIVATE :: twostream_mod + PRIVATE :: twostream_wrap #endif !----------------------------------------------------------------------- - CONTAINS +CONTAINS !----------------------------------------------------------------------- - - - SUBROUTINE albland (ipatch, patchtype, deltim,& + SUBROUTINE albland (ipatch, patchtype, deltim,& soil_s_v_alb,soil_d_v_alb,soil_s_n_alb,soil_d_n_alb,& chil,rho,tau,fveg,green,lai,sai,coszen,& wt,fsno,scv,scvold,sag,ssw,pg_snow,forc_t,t_grnd,t_soisno,dz_soisno,& @@ -75,94 +72,94 @@ SUBROUTINE albland (ipatch, patchtype, deltim,& ! added SNICAR related variables !======================================================================= - USE MOD_Precision - USE MOD_Vars_Global - USE MOD_Const_Physical, only: tfrz - USE MOD_Namelist, only: DEF_USE_SNICAR - USE MOD_Vars_TimeInvariants, only: patchclass + USE MOD_Precision + USE MOD_Vars_Global + USE MOD_Const_Physical, only: tfrz + USE MOD_Namelist, only: DEF_USE_SNICAR + USE MOD_Vars_TimeInvariants, only: patchclass #if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) - USE MOD_LandPFT, only: patch_pft_s, patch_pft_e - USE MOD_Vars_PFTimeInvariants - USE MOD_Vars_PFTimeVariables + USE MOD_LandPFT, only: patch_pft_s, patch_pft_e + USE MOD_Vars_PFTimeInvariants + USE MOD_Vars_PFTimeVariables #endif - USE MOD_Aerosol, only: AerosolMasses - USE MOD_SnowSnicar, only: SnowAge_grain + USE MOD_Aerosol, only: AerosolMasses + USE MOD_SnowSnicar, only: SnowAge_grain #ifdef LULC_IGBP_PC - USE MOD_3DCanopyRadiation, only: ThreeDCanopy_wrap + USE MOD_3DCanopyRadiation, only: ThreeDCanopy_wrap #endif - IMPLICIT NONE + IMPLICIT NONE !------------------------- Dummy Arguments ----------------------------- ! ground cover index - integer, intent(in) :: & - ipatch, &! patch index - patchtype ! land patch type (0=soil, 1=urban or built-up, 2=wetland, - ! 3=land ice, 4=deep lake) - integer, intent(in) :: & - snl ! number of snow layers - - real(r8), intent(in) :: & - deltim, &! seconds in a time step [second] - soil_s_v_alb, &! albedo of visible of the saturated soil - soil_d_v_alb, &! albedo of visible of the dry soil - soil_s_n_alb, &! albedo of near infrared of the saturated soil - soil_d_n_alb, &! albedo of near infrared of the dry soil - chil, &! leaf angle distribution factor - 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 [-] - green, &! green leaf fraction - lai, &! leaf area index (LAI+SAI) [m2/m2] - sai, &! stem area index (LAI+SAI) [m2/m2] - - coszen, &! cosine of solar zenith angle [-] - wt, &! fraction of vegetation covered by snow [-] - fsno, &! fraction of soil covered by snow [-] - ssw, &! water volumetric content of soil surface layer [m3/m3] - scv, &! snow cover, water equivalent [mm] - scvold, &! snow cover for previous time step [mm] - pg_snow, &! snowfall onto ground including canopy runoff [kg/(m2 s)] - forc_t, &! atmospheric temperature [K] - t_grnd ! ground surface temperature [K] - - real(r8), intent(in) :: & - wliq_soisno ( maxsnl+1:0 ), &! liquid water (kg/m2) - wice_soisno ( maxsnl+1:0 ), &! ice lens (kg/m2) - snofrz ( maxsnl+1:0 ), &! snow freezing rate (col,lyr) [kg m-2 s-1] - t_soisno ( maxsnl+1:1 ), &! soil + snow layer temperature [K] - dz_soisno ( maxsnl+1:1 ) ! layer thickness (m) - - real(r8), intent(inout) :: & - snw_rds ( maxsnl+1:0 ), &! effective grain radius (col,lyr) [microns, m-6] - mss_bcpho ( maxsnl+1:0 ), &! mass of hydrophobic BC in snow (col,lyr) [kg] - mss_bcphi ( maxsnl+1:0 ), &! mass of hydrophillic BC in snow (col,lyr) [kg] - mss_ocpho ( maxsnl+1:0 ), &! mass of hydrophobic OC in snow (col,lyr) [kg] - mss_ocphi ( maxsnl+1:0 ), &! mass of hydrophillic OC in snow (col,lyr) [kg] - mss_dst1 ( maxsnl+1:0 ), &! mass of dust species 1 in snow (col,lyr) [kg] - mss_dst2 ( maxsnl+1:0 ), &! mass of dust species 2 in snow (col,lyr) [kg] - mss_dst3 ( maxsnl+1:0 ), &! mass of dust species 3 in snow (col,lyr) [kg] - mss_dst4 ( maxsnl+1:0 ) ! mass of dust species 4 in snow (col,lyr) [kg] - - real(r8), intent(inout) :: sag ! non dimensional snow age [-] - - real(r8), intent(out) :: & - alb(2,2), &! averaged albedo [-] - ssun(2,2), &! sunlit canopy absorption for solar radiation - ssha(2,2), &! shaded canopy absorption for solar radiation, - ! normalized by the incident flux - thermk, &! canopy gap fraction for tir radiation - extkb, &! (k, g(mu)/mu) direct solar extinction coefficient - extkd ! diffuse and scattered diffuse PAR extinction coefficient - - real(r8), intent(out) :: & - ssoi(2,2), &! ground soil absorption [-] - ssno(2,2), &! ground snow absorption [-] - ssno_lyr(2,2,maxsnl+1:1) ! ground snow layer absorption, by SNICAR [-] + integer, intent(in) :: & + ipatch, &! patch index + patchtype ! land patch type (0=soil, 1=urban or built-up, 2=wetland, + ! 3=land ice, 4=deep lake) + integer, intent(in) :: & + snl ! number of snow layers + + real(r8), intent(in) :: & + deltim, &! seconds in a time step [second] + soil_s_v_alb, &! albedo of visible of the saturated soil + soil_d_v_alb, &! albedo of visible of the dry soil + soil_s_n_alb, &! albedo of near infrared of the saturated soil + soil_d_n_alb, &! albedo of near infrared of the dry soil + chil, &! leaf angle distribution factor + 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 [-] + green, &! green leaf fraction + lai, &! leaf area index (LAI+SAI) [m2/m2] + sai, &! stem area index (LAI+SAI) [m2/m2] + + coszen, &! cosine of solar zenith angle [-] + wt, &! fraction of vegetation covered by snow [-] + fsno, &! fraction of soil covered by snow [-] + ssw, &! water volumetric content of soil surface layer [m3/m3] + scv, &! snow cover, water equivalent [mm] + scvold, &! snow cover for previous time step [mm] + pg_snow, &! snowfall onto ground including canopy runoff [kg/(m2 s)] + forc_t, &! atmospheric temperature [K] + t_grnd ! ground surface temperature [K] + + real(r8), intent(in) :: & + wliq_soisno ( maxsnl+1:0 ), &! liquid water (kg/m2) + wice_soisno ( maxsnl+1:0 ), &! ice lens (kg/m2) + snofrz ( maxsnl+1:0 ), &! snow freezing rate (col,lyr) [kg m-2 s-1] + t_soisno ( maxsnl+1:1 ), &! soil + snow layer temperature [K] + dz_soisno ( maxsnl+1:1 ) ! layer thickness (m) + + real(r8), intent(inout) :: & + snw_rds ( maxsnl+1:0 ), &! effective grain radius (col,lyr) [microns, m-6] + mss_bcpho ( maxsnl+1:0 ), &! mass of hydrophobic BC in snow (col,lyr) [kg] + mss_bcphi ( maxsnl+1:0 ), &! mass of hydrophillic BC in snow (col,lyr) [kg] + mss_ocpho ( maxsnl+1:0 ), &! mass of hydrophobic OC in snow (col,lyr) [kg] + mss_ocphi ( maxsnl+1:0 ), &! mass of hydrophillic OC in snow (col,lyr) [kg] + mss_dst1 ( maxsnl+1:0 ), &! mass of dust species 1 in snow (col,lyr) [kg] + mss_dst2 ( maxsnl+1:0 ), &! mass of dust species 2 in snow (col,lyr) [kg] + mss_dst3 ( maxsnl+1:0 ), &! mass of dust species 3 in snow (col,lyr) [kg] + mss_dst4 ( maxsnl+1:0 ) ! mass of dust species 4 in snow (col,lyr) [kg] + + real(r8), intent(inout) :: sag ! non dimensional snow age [-] + + real(r8), intent(out) :: & + alb(2,2), &! averaged albedo [-] + ssun(2,2), &! sunlit canopy absorption for solar radiation + ssha(2,2), &! shaded canopy absorption for solar radiation, + ! normalized by the incident flux + thermk, &! canopy gap fraction for tir radiation + extkb, &! (k, g(mu)/mu) direct solar extinction coefficient + extkd ! diffuse and scattered diffuse PAR extinction coefficient + + real(r8), intent(out) :: & + ssoi(2,2), &! ground soil absorption [-] + ssno(2,2), &! ground snow absorption [-] + ssno_lyr(2,2,maxsnl+1:1) ! ground snow layer absorption, by SNICAR [-] !-------------------------- Local variables ---------------------------- - real(r8) :: &! + real(r8) :: &! age, &! factor to reduce visible snow alb due to snow age [-] albg0, &! temporary varaiable [-] albsoi(2,2), &! soil albedo [-] @@ -457,11 +454,11 @@ SUBROUTINE albland (ipatch, patchtype, deltim,& !----------------------------------------------------------------------- - END SUBROUTINE albland + END SUBROUTINE albland - SUBROUTINE twostream ( chil, rho, tau, green, lai, sai, & - coszen, albg, albv, tran, thermk, extkb, extkd, ssun, ssha ) + SUBROUTINE twostream ( chil, rho, tau, green, lai, sai, & + coszen, albg, albv, tran, thermk, extkb, extkd, ssun, ssha ) !----------------------------------------------------------------------- ! @@ -472,11 +469,11 @@ SUBROUTINE twostream ( chil, rho, tau, green, lai, sai, & ! !----------------------------------------------------------------------- - USE MOD_Precision - IMPLICIT NONE + USE MOD_Precision + IMPLICIT NONE ! parameters - real(r8), intent(in) :: & + real(r8), intent(in) :: & ! static parameters associated with vegetation type chil, &! leaf angle distribution factor rho(2,2), &! leaf reflectance (iw=iband, il=life and dead) @@ -488,12 +485,12 @@ SUBROUTINE twostream ( chil, rho, tau, green, lai, sai, & sai ! stem area index ! environmental variables - real(r8), intent(in) :: & + real(r8), intent(in) :: & coszen, &! consine of solar zenith angle albg(2,2) ! albedos of ground ! output - real(r8), intent(out) :: & + real(r8), intent(out) :: & albv(2,2), &! albedo, vegetation [-] tran(2,3), &! canopy transmittances for solar radiation thermk, &! canopy gap fraction for tir radiation @@ -504,7 +501,7 @@ SUBROUTINE twostream ( chil, rho, tau, green, lai, sai, & ! normalized by the incident flux !-------------------------- local ----------------------------------- - real(r8) :: & + real(r8) :: & lsai, &! lai+sai sai_, &! sai=0 for USGS, no stem phi1, &! (phi-1) @@ -559,7 +556,7 @@ SUBROUTINE twostream ( chil, rho, tau, green, lai, sai, & eup(2,2), &! (integral of i_up*exp(-kx) ) edown(2,2) ! (integral of i_down*exp(-kx) ) - integer iw ! + integer iw ! !----------------------------------------------------------------------- ! projected area of phytoelements in direction of mu and @@ -769,12 +766,12 @@ SUBROUTINE twostream ( chil, rho, tau, green, lai, sai, & ! 03/14/2020, yuan: save direct T to 3rd position of tran tran(:,3) = s2 - END SUBROUTINE twostream + END SUBROUTINE twostream #if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) - SUBROUTINE twostream_mod ( chil, rho, tau, green, lai, sai, & - coszen, albg, albv, tran, thermk, extkb, extkd, ssun, ssha ) + SUBROUTINE twostream_mod ( chil, rho, tau, green, lai, sai, & + coszen, albg, albv, tran, thermk, extkb, extkd, ssun, ssha ) !----------------------------------------------------------------------- ! @@ -792,11 +789,11 @@ SUBROUTINE twostream_mod ( chil, rho, tau, green, lai, sai, & ! !----------------------------------------------------------------------- - USE MOD_Precision - IMPLICIT NONE + USE MOD_Precision + IMPLICIT NONE ! parameters - real(r8), intent(in) :: & + real(r8), intent(in) :: & ! static parameters associated with vegetation type chil, &! leaf angle distribution factor rho(2,2), &! leaf reflectance (iw=iband, il=life and dead) @@ -808,12 +805,12 @@ SUBROUTINE twostream_mod ( chil, rho, tau, green, lai, sai, & sai ! stem area index ! environmental variables - real(r8), intent(in) :: & + real(r8), intent(in) :: & coszen, &! consine of solar zenith angle albg(2,2) ! albedos of ground ! output - real(r8), intent(out) :: & + real(r8), intent(out) :: & albv(2,2), &! albedo, vegetation [-] tran(2,3), &! canopy transmittances for solar radiation thermk, &! canopy gap fraction for tir radiation @@ -824,7 +821,7 @@ SUBROUTINE twostream_mod ( chil, rho, tau, green, lai, sai, & ! normalized by the incident flux !-------------------------- local ----------------------------------- - real(r8) :: & + real(r8) :: & lsai, &! lai+sai phi1, &! (phi-1) phi2, &! (phi-2) @@ -878,13 +875,13 @@ SUBROUTINE twostream_mod ( chil, rho, tau, green, lai, sai, & eup, &! (integral of i_up*exp(-kx) ) edw ! (integral of i_down*exp(-kx) ) - integer iw ! band loop index - integer ic ! direct/diffuse loop index + integer iw ! band loop index + integer ic ! direct/diffuse loop index - ! variables for modified version - real(r8) :: cosz, theta, cosdif, albgblk - real(r8) :: tmptau, wrho, wtau - real(r8) :: s2d, extkbd, sall(2,2), q, ssun_rev + ! variables for modified version + real(r8) :: cosz, theta, cosdif, albgblk + real(r8) :: tmptau, wrho, wtau + real(r8) :: s2d, extkbd, sall(2,2), q, ssun_rev !----------------------------------------------------------------------- ! projected area of phytoelements in direction of mu and @@ -1140,13 +1137,13 @@ SUBROUTINE twostream_mod ( chil, rho, tau, green, lai, sai, & ! restore extkb extkb = extkbd - END SUBROUTINE twostream_mod + END SUBROUTINE twostream_mod #endif #if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) - SUBROUTINE twostream_wrap ( ipatch, coszen, albg, & - albv, tran, ssun, ssha ) + SUBROUTINE twostream_wrap ( ipatch, coszen, albg, & + albv, tran, ssun, ssha ) !----------------------------------------------------------------------- ! @@ -1237,11 +1234,11 @@ SUBROUTINE twostream_wrap ( ipatch, coszen, albg, & deallocate ( tran_p ) deallocate ( albv_p ) - END SUBROUTINE twostream_wrap + END SUBROUTINE twostream_wrap #endif - SUBROUTINE snowage ( deltim,tg,scv,scvold,sag ) + SUBROUTINE snowage ( deltim,tg,scv,scvold,sag ) !======================================================================= ! Original version: Robert Dickinson @@ -1272,32 +1269,32 @@ SUBROUTINE snowage ( deltim,tg,scv,scvold,sag ) real(r8) :: sge ! temporary variable used in snow age calculation [-] !----------------------------------------------------------------------- - IF(scv <= 0.) THEN - sag = 0. + IF(scv <= 0.) THEN + sag = 0. ! ! Over antarctica ! - ELSE IF (scv > 800.) THEN - sag = 0. + ELSE IF (scv > 800.) THEN + sag = 0. ! ! Away from antarctica ! - ELSE - age3 = 0.3 - arg = 5.e3*(1./tfrz-1./tg) - arg2 = min(0.,10.*arg) - age2 = exp(arg2) - age1 = exp(arg) - dela = 1.e-6*deltim*(age1+age2+age3) - dels = 0.1*max(0.0,scv-scvold) - sge = (sag+dela)*(1.0-dels) - sag = max(0.0,sge) - ENDIF - - END SUBROUTINE snowage - - - SUBROUTINE SnowAlbedo( use_snicar_frc,use_snicar_ad ,coszen_col ,& + ELSE + age3 = 0.3 + arg = 5.e3*(1./tfrz-1./tg) + arg2 = min(0.,10.*arg) + age2 = exp(arg2) + age1 = exp(arg) + dela = 1.e-6*deltim*(age1+age2+age3) + dels = 0.1*max(0.0,scv-scvold) + sge = (sag+dela)*(1.0-dels) + sag = max(0.0,sge) + ENDIF + + END SUBROUTINE snowage + + + SUBROUTINE SnowAlbedo( use_snicar_frc,use_snicar_ad ,coszen_col ,& albsod ,albsoi ,snl ,frac_sno ,& h2osno ,h2osno_liq ,h2osno_ice ,snw_rds ,& @@ -1334,592 +1331,592 @@ SUBROUTINE SnowAlbedo( use_snicar_frc,use_snicar_ad ,coszen_col ,& !----------------------------------------------------------------------- ! !USES: - USE MOD_Vars_Global, only: maxsnl - USE MOD_SnowSnicar, only: SNICAR_RT, SNICAR_AD_RT + USE MOD_Vars_Global, only: maxsnl + USE MOD_SnowSnicar, only: SNICAR_RT, SNICAR_AD_RT ! and the evolution of snow effective radius ! ! DAI, Dec. 28, 2022 - IMPLICIT NONE + IMPLICIT NONE !------------------------------------------------------------------------- ! temporay setting - integer, parameter :: numrad = 2 ! number of solar radiation bands: vis, nir - integer, parameter :: sno_nbr_aer = 8 ! number of aerosol species in snowpack - logical, parameter :: DO_SNO_OC = .true. ! parameter to include organic carbon (OC) - logical, parameter :: DO_SNO_AER = .true. ! parameter to include aerosols in snowpack radiative calculations - integer, parameter :: subgridflag = 1 ! = 0 USE subgrid fluxes, = 1 not USE subgrid fluxes - ! - ! !ARGUMENTS: - ! - logical , intent(in) :: use_snicar_frc ! true: IF radiative forcing is being calculated, first estimate clean-snow albedo - logical , intent(in) :: use_snicar_ad ! true: USE SNICAR_AD_RT, false: USE SNICAR_RT - - real(r8), intent(in) :: coszen_col ! cosine of solar zenith angle - real(r8), intent(in) :: albsod ( numrad ) ! direct-beam soil albedo (col,bnd) [frc] - real(r8), intent(in) :: albsoi ( numrad ) ! diffuse soil albedo (col,bnd) [frc] - - integer , intent(in) :: snl ! negative number of snow layers (col) [nbr] - real(r8), intent(in) :: frac_sno ! fraction of ground covered by snow (0 to 1) - real(r8), intent(in) :: h2osno ! snow water equivalent (mm H2O) - real(r8), intent(in) :: h2osno_liq ( maxsnl+1:0 ) ! liquid water content (col,lyr) [kg/m2] - real(r8), intent(in) :: h2osno_ice ( maxsnl+1:0 ) ! ice lens content (col,lyr) [kg/m2] - real(r8), intent(in) :: snw_rds ( maxsnl+1:0 ) ! snow grain radius (col,lyr) [microns] - - real(r8), intent(in) :: mss_cnc_bcphi ( maxsnl+1:0 ) ! mass concentration of hydrophilic BC (col,lyr) [kg/kg] - real(r8), intent(in) :: mss_cnc_bcpho ( maxsnl+1:0 ) ! mass concentration of hydrophobic BC (col,lyr) [kg/kg] - real(r8), intent(in) :: mss_cnc_ocphi ( maxsnl+1:0 ) ! mass concentration of hydrophilic OC (col,lyr) [kg/kg] - real(r8), intent(in) :: mss_cnc_ocpho ( maxsnl+1:0 ) ! mass concentration of hydrophobic OC (col,lyr) [kg/kg] - real(r8), intent(in) :: mss_cnc_dst1 ( maxsnl+1:0 ) ! mass concentration of dust aerosol species 1 (col,lyr) [kg/kg] - real(r8), intent(in) :: mss_cnc_dst2 ( maxsnl+1:0 ) ! mass concentration of dust aerosol species 2 (col,lyr) [kg/kg] - real(r8), intent(in) :: mss_cnc_dst3 ( maxsnl+1:0 ) ! mass concentration of dust aerosol species 3 (col,lyr) [kg/kg] - real(r8), intent(in) :: mss_cnc_dst4 ( maxsnl+1:0 ) ! mass concentration of dust aerosol species 4 (col,lyr) [kg/kg] - - real(r8), intent(out) :: albgrd ( numrad ) ! ground albedo (direct) - real(r8), intent(out) :: albgri ( numrad ) ! ground albedo (diffuse) - real(r8), intent(out) :: albgrd_pur ( numrad ) ! pure snow ground albedo (direct) - real(r8), intent(out) :: albgri_pur ( numrad ) ! pure snow ground albedo (diffuse) - real(r8), intent(out) :: albgrd_bc ( numrad ) ! ground albedo without BC (direct) - real(r8), intent(out) :: albgri_bc ( numrad ) ! ground albedo without BC (diffuse) - real(r8), intent(out) :: albgrd_oc ( numrad ) ! ground albedo without OC (direct) - real(r8), intent(out) :: albgri_oc ( numrad ) ! ground albedo without OC (diffuse) - real(r8), intent(out) :: albgrd_dst ( numrad ) ! ground albedo without dust (direct) - real(r8), intent(out) :: albgri_dst ( numrad ) ! ground albedo without dust (diffuse) - real(r8), intent(out) :: flx_absdv ( maxsnl+1:1 ) ! direct flux absorption factor (col,lyr): VIS [frc] - real(r8), intent(out) :: flx_absdn ( maxsnl+1:1 ) ! direct flux absorption factor (col,lyr): NIR [frc] - real(r8), intent(out) :: flx_absiv ( maxsnl+1:1 ) ! diffuse flux absorption factor (col,lyr): VIS [frc] - real(r8), intent(out) :: flx_absin ( maxsnl+1:1 ) ! diffuse flux absorption factor (col,lyr): NIR [frc] - - !----------------------------------------------------------------------- - ! - ! !LOCAL VARIABLES: - integer :: i ! index for layers [idx] - integer :: aer ! index for sno_nbr_aer - integer :: ib ! band index - integer :: ic ! 0=unit incoming direct; 1=unit incoming diffuse - integer :: flg_slr ! flag for SNICAR (=1 IF direct, =2 IF diffuse) - integer :: flg_snw_ice ! flag for SNICAR (=1 when called from ELM, =2 when called from sea-ice) - - real(r8) :: mss_cnc_aer_in_frc_pur (maxsnl+1:0,sno_nbr_aer) ! mass concentration of aerosol species for forcing calculation (zero) (col,lyr,aer) [kg kg-1] - real(r8) :: mss_cnc_aer_in_frc_bc (maxsnl+1:0,sno_nbr_aer) ! mass concentration of aerosol species for BC forcing (col,lyr,aer) [kg kg-1] - real(r8) :: mss_cnc_aer_in_frc_oc (maxsnl+1:0,sno_nbr_aer) ! mass concentration of aerosol species for OC forcing (col,lyr,aer) [kg kg-1] - real(r8) :: mss_cnc_aer_in_frc_dst (maxsnl+1:0,sno_nbr_aer) ! mass concentration of aerosol species for dust forcing (col,lyr,aer) [kg kg-1] - real(r8) :: mss_cnc_aer_in_fdb (maxsnl+1:0,sno_nbr_aer) ! mass concentration of all aerosol species for feedback calculation (col,lyr,aer) [kg kg-1] - - real(r8) :: albsfc (numrad) ! albedo of surface underneath snow (col,bnd) - real(r8) :: albsnd (numrad) ! snow albedo (direct) - real(r8) :: albsni (numrad) ! snow albedo (diffuse) - real(r8) :: albsnd_pur (numrad) ! direct pure snow albedo (radiative forcing) - real(r8) :: albsni_pur (numrad) ! diffuse pure snow albedo (radiative forcing) - real(r8) :: albsnd_bc (numrad) ! direct snow albedo without BC (radiative forcing) - real(r8) :: albsni_bc (numrad) ! diffuse snow albedo without BC (radiative forcing) - real(r8) :: albsnd_oc (numrad) ! direct snow albedo without OC (radiative forcing) - real(r8) :: albsni_oc (numrad) ! diffuse snow albedo without OC (radiative forcing) - real(r8) :: albsnd_dst (numrad) ! direct snow albedo without dust (radiative forcing) - real(r8) :: albsni_dst (numrad) ! diffuse snow albedo without dust (radiative forcing) - real(r8) :: flx_absd_snw (maxsnl+1:1,numrad) ! flux absorption factor for just snow (direct) [frc] - real(r8) :: flx_absi_snw (maxsnl+1:1,numrad) ! flux absorption factor for just snow (diffuse) [frc] - real(r8) :: foo_snw (maxsnl+1:1,numrad) ! dummy array for forcing calls - - integer :: snw_rds_in (maxsnl+1:0) ! snow grain size sent to SNICAR (col,lyr) [microns] - - integer , parameter :: nband =numrad ! number of solar radiation waveband classes - - !----------------------------------------------------------------------- - - ! Initialize output because solar radiation only done IF coszen > 0 - - DO ib = 1, numrad - albgrd(ib) = 0._r8 - albgri(ib) = 0._r8 - albgrd_pur(ib) = 0._r8 - albgri_pur(ib) = 0._r8 - albgrd_bc(ib) = 0._r8 - albgri_bc(ib) = 0._r8 - albgrd_oc(ib) = 0._r8 - albgri_oc(ib) = 0._r8 - albgrd_dst(ib) = 0._r8 - albgri_dst(ib) = 0._r8 - DO i=maxsnl+1,1,1 - flx_absdv(i) = 0._r8 - flx_absdn(i) = 0._r8 - flx_absiv(i) = 0._r8 - flx_absin(i) = 0._r8 - ENDDO - ENDDO ! END of numrad loop - - ! set variables to pass to SNICAR. - - flg_snw_ice = 1 - albsfc(:) = albsoi(:) - snw_rds_in(:) = nint(snw_rds(:)) - - ! zero aerosol input arrays - DO aer = 1, sno_nbr_aer - DO i = maxsnl+1, 0 - mss_cnc_aer_in_frc_pur(i,aer) = 0._r8 - mss_cnc_aer_in_frc_bc(i,aer) = 0._r8 - mss_cnc_aer_in_frc_oc(i,aer) = 0._r8 - mss_cnc_aer_in_frc_dst(i,aer) = 0._r8 - mss_cnc_aer_in_fdb(i,aer) = 0._r8 - ENDDO - ENDDO - - ! If radiative forcing is being calculated, first estimate clean-snow albedo - - IF (use_snicar_frc) THEN - - ! 1. PURE SNOW ALBEDO CALCULATIONS - flg_slr = 1 ! direct-beam - IF (use_snicar_ad) THEN - CALL SNICAR_AD_RT(flg_snw_ice, & - flg_slr, & - coszen_col, & - snl, & - h2osno, & - frac_sno, & - h2osno_liq(:), & - h2osno_ice(:), & - snw_rds_in(:), & - mss_cnc_aer_in_frc_pur(:, :), & - albsfc(:), & - albsnd_pur(:), & - foo_snw(:, :) ) - ELSE - CALL SNICAR_RT(flg_snw_ice, & - flg_slr, & - coszen_col, & - snl, & - h2osno, & - frac_sno, & - h2osno_liq(:), & - h2osno_ice(:), & - snw_rds_in(:), & - mss_cnc_aer_in_frc_pur(:, :), & - albsfc(:), & - albsnd_pur(:), & - foo_snw(:, :) ) - ENDIF ! END IF use_snicar_ad - - flg_slr = 2 ! diffuse - IF (use_snicar_ad) THEN - CALL SNICAR_AD_RT(flg_snw_ice, & - flg_slr, & - coszen_col, & - snl, & - h2osno, & - frac_sno, & - h2osno_liq(:), & - h2osno_ice(:), & - snw_rds_in(:), & - mss_cnc_aer_in_frc_pur(:, :), & - albsfc(:), & - albsni_pur(:), & - foo_snw(:, :) ) - ELSE - CALL SNICAR_RT(flg_snw_ice, & - flg_slr, & - coszen_col, & - snl, & - h2osno, & - frac_sno, & - h2osno_liq(:), & - h2osno_ice(:), & - snw_rds_in(:), & - mss_cnc_aer_in_frc_pur(:, :), & - albsfc(:), & - albsni_pur(:), & - foo_snw(:, :) ) - ENDIF ! END IF use_snicar_ad - - ! 2. BC input array: - ! set dust and (optionally) OC concentrations, so BC_FRC=[(BC+OC+dust)-(OC+dust)] - IF (DO_SNO_OC) THEN - mss_cnc_aer_in_frc_bc(:,3) = mss_cnc_ocphi(:) - mss_cnc_aer_in_frc_bc(:,4) = mss_cnc_ocpho(:) - ENDIF - mss_cnc_aer_in_frc_bc(:,5) = mss_cnc_dst1(:) - mss_cnc_aer_in_frc_bc(:,6) = mss_cnc_dst2(:) - mss_cnc_aer_in_frc_bc(:,7) = mss_cnc_dst3(:) - mss_cnc_aer_in_frc_bc(:,8) = mss_cnc_dst4(:) - - ! BC FORCING CALCULATIONS - flg_slr = 1 ! direct-beam - IF (use_snicar_ad) THEN - CALL SNICAR_AD_RT(flg_snw_ice, & - flg_slr, & - coszen_col, & - snl, & - h2osno, & - frac_sno, & - h2osno_liq(:), & - h2osno_ice(:), & - snw_rds_in(:), & - mss_cnc_aer_in_frc_bc(:, :), & - albsfc(:), & - albsnd_bc(:), & - foo_snw(:, :) ) - ELSE - CALL SNICAR_RT (flg_snw_ice, & - flg_slr, & - coszen_col, & - snl, & - h2osno, & - frac_sno, & - h2osno_liq(:), & - h2osno_ice(:), & - snw_rds_in(:), & - mss_cnc_aer_in_frc_bc(:, :), & - albsfc(:), & - albsnd_bc(:), & - foo_snw(:, :) ) - ENDIF ! END IF use_snicar_ad - - flg_slr = 2 ! diffuse - IF (use_snicar_ad) THEN - CALL SNICAR_AD_RT(flg_snw_ice, & - flg_slr, & - coszen_col, & - snl, & - h2osno, & - frac_sno, & - h2osno_liq(:), & - h2osno_ice(:), & - snw_rds_in(:), & - mss_cnc_aer_in_frc_bc(:, :), & - albsfc(:), & - albsni_bc(:), & - foo_snw(:, :) ) - ELSE - CALL SNICAR_RT (flg_snw_ice, & - flg_slr, & - coszen_col, & - snl, & - h2osno, & - frac_sno, & - h2osno_liq(:), & - h2osno_ice(:), & - snw_rds_in(:), & - mss_cnc_aer_in_frc_bc(:, :), & - albsfc(:), & - albsni_bc(:), & - foo_snw(:, :) ) - ENDIF ! END IF use_snicar_ad - - ! 3. OC input array: - ! set BC and dust concentrations, so OC_FRC=[(BC+OC+dust)-(BC+dust)] - IF (DO_SNO_OC) THEN - mss_cnc_aer_in_frc_oc(:,1) = mss_cnc_bcphi(:) - mss_cnc_aer_in_frc_oc(:,2) = mss_cnc_bcpho(:) - - mss_cnc_aer_in_frc_oc(:,5) = mss_cnc_dst1(:) - mss_cnc_aer_in_frc_oc(:,6) = mss_cnc_dst2(:) - mss_cnc_aer_in_frc_oc(:,7) = mss_cnc_dst3(:) - mss_cnc_aer_in_frc_oc(:,8) = mss_cnc_dst4(:) - - ! OC FORCING CALCULATIONS - flg_slr = 1 ! direct-beam - IF (use_snicar_ad) THEN - CALL SNICAR_AD_RT(flg_snw_ice, & - flg_slr, & - coszen_col, & - snl, & - h2osno, & - frac_sno, & - h2osno_liq(:), & - h2osno_ice(:), & - snw_rds_in(:), & - mss_cnc_aer_in_frc_oc(:, :), & - albsfc(:), & - albsnd_oc(:), & - foo_snw(:, :) ) - ELSE - CALL SNICAR_RT(flg_snw_ice, & - flg_slr, & - coszen_col, & - snl, & - h2osno, & - frac_sno, & - h2osno_liq(:), & - h2osno_ice(:), & - snw_rds_in(:), & - mss_cnc_aer_in_frc_oc(:, :), & - albsfc(:), & - albsnd_oc(:), & - foo_snw(:, :) ) - ENDIF ! END IF use_snicar_ad - - flg_slr = 2 ! diffuse - IF (use_snicar_ad) THEN - CALL SNICAR_AD_RT(flg_snw_ice, & - flg_slr, & - coszen_col, & - snl, & - h2osno, & - frac_sno, & - h2osno_liq(:), & - h2osno_ice(:), & - snw_rds_in(:), & - mss_cnc_aer_in_frc_oc(:, :), & - albsfc(:), & - albsni_oc(:), & - foo_snw(:, :) ) - ELSE - CALL SNICAR_RT(flg_snw_ice, & - flg_slr, & - coszen_col, & - snl, & - h2osno, & - frac_sno, & - h2osno_liq(:), & - h2osno_ice(:), & - snw_rds_in(:), & - mss_cnc_aer_in_frc_oc(:, :), & - albsfc(:), & - albsni_oc(:), & - foo_snw(:, :) ) - ENDIF ! END IF use_snicar_ad - ENDIF ! END IF (DO_SNO_OC) - - ! 4. DUST FORCING CALCULATIONS - ! DUST input array: - ! set BC and OC concentrations, so DST_FRC=[(BC+OC+dust)-(BC+OC)] - mss_cnc_aer_in_frc_dst(:,1) = mss_cnc_bcphi(:) - mss_cnc_aer_in_frc_dst(:,2) = mss_cnc_bcpho(:) + integer, parameter :: numrad = 2 ! number of solar radiation bands: vis, nir + integer, parameter :: sno_nbr_aer = 8 ! number of aerosol species in snowpack + logical, parameter :: DO_SNO_OC = .true. ! parameter to include organic carbon (OC) + logical, parameter :: DO_SNO_AER = .true. ! parameter to include aerosols in snowpack radiative calculations + integer, parameter :: subgridflag = 1 ! = 0 USE subgrid fluxes, = 1 not USE subgrid fluxes + ! + ! !ARGUMENTS: + ! + logical , intent(in) :: use_snicar_frc ! true: IF radiative forcing is being calculated, first estimate clean-snow albedo + logical , intent(in) :: use_snicar_ad ! true: USE SNICAR_AD_RT, false: USE SNICAR_RT + + real(r8), intent(in) :: coszen_col ! cosine of solar zenith angle + real(r8), intent(in) :: albsod ( numrad ) ! direct-beam soil albedo (col,bnd) [frc] + real(r8), intent(in) :: albsoi ( numrad ) ! diffuse soil albedo (col,bnd) [frc] + + integer , intent(in) :: snl ! negative number of snow layers (col) [nbr] + real(r8), intent(in) :: frac_sno ! fraction of ground covered by snow (0 to 1) + real(r8), intent(in) :: h2osno ! snow water equivalent (mm H2O) + real(r8), intent(in) :: h2osno_liq ( maxsnl+1:0 ) ! liquid water content (col,lyr) [kg/m2] + real(r8), intent(in) :: h2osno_ice ( maxsnl+1:0 ) ! ice lens content (col,lyr) [kg/m2] + real(r8), intent(in) :: snw_rds ( maxsnl+1:0 ) ! snow grain radius (col,lyr) [microns] + + real(r8), intent(in) :: mss_cnc_bcphi ( maxsnl+1:0 ) ! mass concentration of hydrophilic BC (col,lyr) [kg/kg] + real(r8), intent(in) :: mss_cnc_bcpho ( maxsnl+1:0 ) ! mass concentration of hydrophobic BC (col,lyr) [kg/kg] + real(r8), intent(in) :: mss_cnc_ocphi ( maxsnl+1:0 ) ! mass concentration of hydrophilic OC (col,lyr) [kg/kg] + real(r8), intent(in) :: mss_cnc_ocpho ( maxsnl+1:0 ) ! mass concentration of hydrophobic OC (col,lyr) [kg/kg] + real(r8), intent(in) :: mss_cnc_dst1 ( maxsnl+1:0 ) ! mass concentration of dust aerosol species 1 (col,lyr) [kg/kg] + real(r8), intent(in) :: mss_cnc_dst2 ( maxsnl+1:0 ) ! mass concentration of dust aerosol species 2 (col,lyr) [kg/kg] + real(r8), intent(in) :: mss_cnc_dst3 ( maxsnl+1:0 ) ! mass concentration of dust aerosol species 3 (col,lyr) [kg/kg] + real(r8), intent(in) :: mss_cnc_dst4 ( maxsnl+1:0 ) ! mass concentration of dust aerosol species 4 (col,lyr) [kg/kg] + + real(r8), intent(out) :: albgrd ( numrad ) ! ground albedo (direct) + real(r8), intent(out) :: albgri ( numrad ) ! ground albedo (diffuse) + real(r8), intent(out) :: albgrd_pur ( numrad ) ! pure snow ground albedo (direct) + real(r8), intent(out) :: albgri_pur ( numrad ) ! pure snow ground albedo (diffuse) + real(r8), intent(out) :: albgrd_bc ( numrad ) ! ground albedo without BC (direct) + real(r8), intent(out) :: albgri_bc ( numrad ) ! ground albedo without BC (diffuse) + real(r8), intent(out) :: albgrd_oc ( numrad ) ! ground albedo without OC (direct) + real(r8), intent(out) :: albgri_oc ( numrad ) ! ground albedo without OC (diffuse) + real(r8), intent(out) :: albgrd_dst ( numrad ) ! ground albedo without dust (direct) + real(r8), intent(out) :: albgri_dst ( numrad ) ! ground albedo without dust (diffuse) + real(r8), intent(out) :: flx_absdv ( maxsnl+1:1 ) ! direct flux absorption factor (col,lyr): VIS [frc] + real(r8), intent(out) :: flx_absdn ( maxsnl+1:1 ) ! direct flux absorption factor (col,lyr): NIR [frc] + real(r8), intent(out) :: flx_absiv ( maxsnl+1:1 ) ! diffuse flux absorption factor (col,lyr): VIS [frc] + real(r8), intent(out) :: flx_absin ( maxsnl+1:1 ) ! diffuse flux absorption factor (col,lyr): NIR [frc] + !----------------------------------------------------------------------- + ! + ! !LOCAL VARIABLES: + integer :: i ! index for layers [idx] + integer :: aer ! index for sno_nbr_aer + integer :: ib ! band index + integer :: ic ! 0=unit incoming direct; 1=unit incoming diffuse + integer :: flg_slr ! flag for SNICAR (=1 IF direct, =2 IF diffuse) + integer :: flg_snw_ice ! flag for SNICAR (=1 when called from ELM, =2 when called from sea-ice) + + real(r8) :: mss_cnc_aer_in_frc_pur (maxsnl+1:0,sno_nbr_aer) ! mass concentration of aerosol species for forcing calculation (zero) (col,lyr,aer) [kg kg-1] + real(r8) :: mss_cnc_aer_in_frc_bc (maxsnl+1:0,sno_nbr_aer) ! mass concentration of aerosol species for BC forcing (col,lyr,aer) [kg kg-1] + real(r8) :: mss_cnc_aer_in_frc_oc (maxsnl+1:0,sno_nbr_aer) ! mass concentration of aerosol species for OC forcing (col,lyr,aer) [kg kg-1] + real(r8) :: mss_cnc_aer_in_frc_dst (maxsnl+1:0,sno_nbr_aer) ! mass concentration of aerosol species for dust forcing (col,lyr,aer) [kg kg-1] + real(r8) :: mss_cnc_aer_in_fdb (maxsnl+1:0,sno_nbr_aer) ! mass concentration of all aerosol species for feedback calculation (col,lyr,aer) [kg kg-1] + + real(r8) :: albsfc (numrad) ! albedo of surface underneath snow (col,bnd) + real(r8) :: albsnd (numrad) ! snow albedo (direct) + real(r8) :: albsni (numrad) ! snow albedo (diffuse) + real(r8) :: albsnd_pur (numrad) ! direct pure snow albedo (radiative forcing) + real(r8) :: albsni_pur (numrad) ! diffuse pure snow albedo (radiative forcing) + real(r8) :: albsnd_bc (numrad) ! direct snow albedo without BC (radiative forcing) + real(r8) :: albsni_bc (numrad) ! diffuse snow albedo without BC (radiative forcing) + real(r8) :: albsnd_oc (numrad) ! direct snow albedo without OC (radiative forcing) + real(r8) :: albsni_oc (numrad) ! diffuse snow albedo without OC (radiative forcing) + real(r8) :: albsnd_dst (numrad) ! direct snow albedo without dust (radiative forcing) + real(r8) :: albsni_dst (numrad) ! diffuse snow albedo without dust (radiative forcing) + real(r8) :: flx_absd_snw (maxsnl+1:1,numrad) ! flux absorption factor for just snow (direct) [frc] + real(r8) :: flx_absi_snw (maxsnl+1:1,numrad) ! flux absorption factor for just snow (diffuse) [frc] + real(r8) :: foo_snw (maxsnl+1:1,numrad) ! dummy array for forcing calls + + integer :: snw_rds_in (maxsnl+1:0) ! snow grain size sent to SNICAR (col,lyr) [microns] + + integer , parameter :: nband =numrad ! number of solar radiation waveband classes + + !----------------------------------------------------------------------- + + ! Initialize output because solar radiation only done IF coszen > 0 + + DO ib = 1, numrad + albgrd(ib) = 0._r8 + albgri(ib) = 0._r8 + albgrd_pur(ib) = 0._r8 + albgri_pur(ib) = 0._r8 + albgrd_bc(ib) = 0._r8 + albgri_bc(ib) = 0._r8 + albgrd_oc(ib) = 0._r8 + albgri_oc(ib) = 0._r8 + albgrd_dst(ib) = 0._r8 + albgri_dst(ib) = 0._r8 + DO i=maxsnl+1,1,1 + flx_absdv(i) = 0._r8 + flx_absdn(i) = 0._r8 + flx_absiv(i) = 0._r8 + flx_absin(i) = 0._r8 + ENDDO + ENDDO ! END of numrad loop + + ! set variables to pass to SNICAR. + + flg_snw_ice = 1 + albsfc(:) = albsoi(:) + snw_rds_in(:) = nint(snw_rds(:)) + + ! zero aerosol input arrays + DO aer = 1, sno_nbr_aer + DO i = maxsnl+1, 0 + mss_cnc_aer_in_frc_pur(i,aer) = 0._r8 + mss_cnc_aer_in_frc_bc(i,aer) = 0._r8 + mss_cnc_aer_in_frc_oc(i,aer) = 0._r8 + mss_cnc_aer_in_frc_dst(i,aer) = 0._r8 + mss_cnc_aer_in_fdb(i,aer) = 0._r8 + ENDDO + ENDDO + + ! If radiative forcing is being calculated, first estimate clean-snow albedo + + IF (use_snicar_frc) THEN + + ! 1. PURE SNOW ALBEDO CALCULATIONS + flg_slr = 1 ! direct-beam + IF (use_snicar_ad) THEN + CALL SNICAR_AD_RT(flg_snw_ice, & + flg_slr, & + coszen_col, & + snl, & + h2osno, & + frac_sno, & + h2osno_liq(:), & + h2osno_ice(:), & + snw_rds_in(:), & + mss_cnc_aer_in_frc_pur(:, :), & + albsfc(:), & + albsnd_pur(:), & + foo_snw(:, :) ) + ELSE + CALL SNICAR_RT(flg_snw_ice, & + flg_slr, & + coszen_col, & + snl, & + h2osno, & + frac_sno, & + h2osno_liq(:), & + h2osno_ice(:), & + snw_rds_in(:), & + mss_cnc_aer_in_frc_pur(:, :), & + albsfc(:), & + albsnd_pur(:), & + foo_snw(:, :) ) + ENDIF ! END IF use_snicar_ad + + flg_slr = 2 ! diffuse + IF (use_snicar_ad) THEN + CALL SNICAR_AD_RT(flg_snw_ice, & + flg_slr, & + coszen_col, & + snl, & + h2osno, & + frac_sno, & + h2osno_liq(:), & + h2osno_ice(:), & + snw_rds_in(:), & + mss_cnc_aer_in_frc_pur(:, :), & + albsfc(:), & + albsni_pur(:), & + foo_snw(:, :) ) + ELSE + CALL SNICAR_RT(flg_snw_ice, & + flg_slr, & + coszen_col, & + snl, & + h2osno, & + frac_sno, & + h2osno_liq(:), & + h2osno_ice(:), & + snw_rds_in(:), & + mss_cnc_aer_in_frc_pur(:, :), & + albsfc(:), & + albsni_pur(:), & + foo_snw(:, :) ) + ENDIF ! END IF use_snicar_ad + + ! 2. BC input array: + ! set dust and (optionally) OC concentrations, so BC_FRC=[(BC+OC+dust)-(OC+dust)] + IF (DO_SNO_OC) THEN + mss_cnc_aer_in_frc_bc(:,3) = mss_cnc_ocphi(:) + mss_cnc_aer_in_frc_bc(:,4) = mss_cnc_ocpho(:) + ENDIF + mss_cnc_aer_in_frc_bc(:,5) = mss_cnc_dst1(:) + mss_cnc_aer_in_frc_bc(:,6) = mss_cnc_dst2(:) + mss_cnc_aer_in_frc_bc(:,7) = mss_cnc_dst3(:) + mss_cnc_aer_in_frc_bc(:,8) = mss_cnc_dst4(:) + + ! BC FORCING CALCULATIONS + flg_slr = 1 ! direct-beam + IF (use_snicar_ad) THEN + CALL SNICAR_AD_RT(flg_snw_ice, & + flg_slr, & + coszen_col, & + snl, & + h2osno, & + frac_sno, & + h2osno_liq(:), & + h2osno_ice(:), & + snw_rds_in(:), & + mss_cnc_aer_in_frc_bc(:, :), & + albsfc(:), & + albsnd_bc(:), & + foo_snw(:, :) ) + ELSE + CALL SNICAR_RT (flg_snw_ice, & + flg_slr, & + coszen_col, & + snl, & + h2osno, & + frac_sno, & + h2osno_liq(:), & + h2osno_ice(:), & + snw_rds_in(:), & + mss_cnc_aer_in_frc_bc(:, :), & + albsfc(:), & + albsnd_bc(:), & + foo_snw(:, :) ) + ENDIF ! END IF use_snicar_ad + + flg_slr = 2 ! diffuse + IF (use_snicar_ad) THEN + CALL SNICAR_AD_RT(flg_snw_ice, & + flg_slr, & + coszen_col, & + snl, & + h2osno, & + frac_sno, & + h2osno_liq(:), & + h2osno_ice(:), & + snw_rds_in(:), & + mss_cnc_aer_in_frc_bc(:, :), & + albsfc(:), & + albsni_bc(:), & + foo_snw(:, :) ) + ELSE + CALL SNICAR_RT (flg_snw_ice, & + flg_slr, & + coszen_col, & + snl, & + h2osno, & + frac_sno, & + h2osno_liq(:), & + h2osno_ice(:), & + snw_rds_in(:), & + mss_cnc_aer_in_frc_bc(:, :), & + albsfc(:), & + albsni_bc(:), & + foo_snw(:, :) ) + ENDIF ! END IF use_snicar_ad + + ! 3. OC input array: + ! set BC and dust concentrations, so OC_FRC=[(BC+OC+dust)-(BC+dust)] + IF (DO_SNO_OC) THEN + mss_cnc_aer_in_frc_oc(:,1) = mss_cnc_bcphi(:) + mss_cnc_aer_in_frc_oc(:,2) = mss_cnc_bcpho(:) + + mss_cnc_aer_in_frc_oc(:,5) = mss_cnc_dst1(:) + mss_cnc_aer_in_frc_oc(:,6) = mss_cnc_dst2(:) + mss_cnc_aer_in_frc_oc(:,7) = mss_cnc_dst3(:) + mss_cnc_aer_in_frc_oc(:,8) = mss_cnc_dst4(:) + + ! OC FORCING CALCULATIONS + flg_slr = 1 ! direct-beam + IF (use_snicar_ad) THEN + CALL SNICAR_AD_RT(flg_snw_ice, & + flg_slr, & + coszen_col, & + snl, & + h2osno, & + frac_sno, & + h2osno_liq(:), & + h2osno_ice(:), & + snw_rds_in(:), & + mss_cnc_aer_in_frc_oc(:, :), & + albsfc(:), & + albsnd_oc(:), & + foo_snw(:, :) ) + ELSE + CALL SNICAR_RT(flg_snw_ice, & + flg_slr, & + coszen_col, & + snl, & + h2osno, & + frac_sno, & + h2osno_liq(:), & + h2osno_ice(:), & + snw_rds_in(:), & + mss_cnc_aer_in_frc_oc(:, :), & + albsfc(:), & + albsnd_oc(:), & + foo_snw(:, :) ) + ENDIF ! END IF use_snicar_ad + + flg_slr = 2 ! diffuse + IF (use_snicar_ad) THEN + CALL SNICAR_AD_RT(flg_snw_ice, & + flg_slr, & + coszen_col, & + snl, & + h2osno, & + frac_sno, & + h2osno_liq(:), & + h2osno_ice(:), & + snw_rds_in(:), & + mss_cnc_aer_in_frc_oc(:, :), & + albsfc(:), & + albsni_oc(:), & + foo_snw(:, :) ) + ELSE + CALL SNICAR_RT(flg_snw_ice, & + flg_slr, & + coszen_col, & + snl, & + h2osno, & + frac_sno, & + h2osno_liq(:), & + h2osno_ice(:), & + snw_rds_in(:), & + mss_cnc_aer_in_frc_oc(:, :), & + albsfc(:), & + albsni_oc(:), & + foo_snw(:, :) ) + ENDIF ! END IF use_snicar_ad + ENDIF ! END IF (DO_SNO_OC) + + ! 4. DUST FORCING CALCULATIONS + ! DUST input array: + ! set BC and OC concentrations, so DST_FRC=[(BC+OC+dust)-(BC+OC)] + mss_cnc_aer_in_frc_dst(:,1) = mss_cnc_bcphi(:) + mss_cnc_aer_in_frc_dst(:,2) = mss_cnc_bcpho(:) + + IF (DO_SNO_OC) THEN + mss_cnc_aer_in_frc_dst(:,3) = mss_cnc_ocphi(:) + mss_cnc_aer_in_frc_dst(:,4) = mss_cnc_ocpho(:) + ENDIF + + flg_slr = 1 ! direct-beam + IF (use_snicar_ad) THEN + CALL SNICAR_AD_RT(flg_snw_ice, & + flg_slr, & + coszen_col, & + snl, & + h2osno, & + frac_sno, & + h2osno_liq(:), & + h2osno_ice(:), & + snw_rds_in(:), & + mss_cnc_aer_in_frc_dst(:, :), & + albsfc(:), & + albsnd_dst(:), & + foo_snw(:, :) ) + ELSE + CALL SNICAR_RT(flg_snw_ice, & + flg_slr, & + coszen_col, & + snl, & + h2osno, & + frac_sno, & + h2osno_liq(:), & + h2osno_ice(:), & + snw_rds_in(:), & + mss_cnc_aer_in_frc_dst(:, :), & + albsfc(:), & + albsnd_dst(:), & + foo_snw(:, :) ) + ENDIF ! END IF use_snicar_ad + + flg_slr = 2 ! diffuse + IF (use_snicar_ad) THEN + CALL SNICAR_AD_RT(flg_snw_ice, & + flg_slr, & + coszen_col, & + snl, & + h2osno, & + frac_sno, & + h2osno_liq(:), & + h2osno_ice(:), & + snw_rds_in(:), & + mss_cnc_aer_in_frc_dst(:, :), & + albsfc(:), & + albsni_dst(:), & + foo_snw(:, :) ) + ELSE + CALL SNICAR_RT(flg_snw_ice, & + flg_slr, & + coszen_col, & + snl, & + h2osno, & + frac_sno, & + h2osno_liq(:), & + h2osno_ice(:), & + snw_rds_in(:), & + mss_cnc_aer_in_frc_dst(:, :), & + albsfc(:), & + albsni_dst(:), & + foo_snw(:, :) ) + ENDIF ! END IF use_snicar_ad + + ENDIF !END IF use_snicar_frc + + + ! -------------------------------------------- + ! CLIMATE FEEDBACK CALCULATIONS, ALL AEROSOLS: + ! -------------------------------------------- + ! Set aerosol input arrays + ! feedback input arrays have been zeroed + ! set soot and dust aerosol concentrations: + IF (DO_SNO_AER) THEN + mss_cnc_aer_in_fdb(:,1) = mss_cnc_bcphi(:) + mss_cnc_aer_in_fdb(:,2) = mss_cnc_bcpho(:) + + ! DO_SNO_OC is set in SNICAR_varpar. Default case is to ignore OC concentrations because: + ! 1) Knowledge of their optical properties is primitive + ! 2) When 'water-soluble' OPAC optical properties are applied to OC in snow, + ! it has a negligible darkening effect. IF (DO_SNO_OC) THEN - mss_cnc_aer_in_frc_dst(:,3) = mss_cnc_ocphi(:) - mss_cnc_aer_in_frc_dst(:,4) = mss_cnc_ocpho(:) + mss_cnc_aer_in_fdb(:,3) = mss_cnc_ocphi(:) + mss_cnc_aer_in_fdb(:,4) = mss_cnc_ocpho(:) ENDIF - flg_slr = 1 ! direct-beam - IF (use_snicar_ad) THEN - CALL SNICAR_AD_RT(flg_snw_ice, & - flg_slr, & - coszen_col, & - snl, & - h2osno, & - frac_sno, & - h2osno_liq(:), & - h2osno_ice(:), & - snw_rds_in(:), & - mss_cnc_aer_in_frc_dst(:, :), & - albsfc(:), & - albsnd_dst(:), & - foo_snw(:, :) ) - ELSE - CALL SNICAR_RT(flg_snw_ice, & - flg_slr, & - coszen_col, & - snl, & - h2osno, & - frac_sno, & - h2osno_liq(:), & - h2osno_ice(:), & - snw_rds_in(:), & - mss_cnc_aer_in_frc_dst(:, :), & - albsfc(:), & - albsnd_dst(:), & - foo_snw(:, :) ) - ENDIF ! END IF use_snicar_ad - - flg_slr = 2 ! diffuse - IF (use_snicar_ad) THEN - CALL SNICAR_AD_RT(flg_snw_ice, & - flg_slr, & - coszen_col, & - snl, & - h2osno, & - frac_sno, & - h2osno_liq(:), & - h2osno_ice(:), & - snw_rds_in(:), & - mss_cnc_aer_in_frc_dst(:, :), & - albsfc(:), & - albsni_dst(:), & - foo_snw(:, :) ) - ELSE - CALL SNICAR_RT(flg_snw_ice, & - flg_slr, & - coszen_col, & - snl, & - h2osno, & - frac_sno, & - h2osno_liq(:), & - h2osno_ice(:), & - snw_rds_in(:), & - mss_cnc_aer_in_frc_dst(:, :), & - albsfc(:), & - albsni_dst(:), & - foo_snw(:, :) ) - ENDIF ! END IF use_snicar_ad - - ENDIF !END IF use_snicar_frc - - - ! -------------------------------------------- - ! CLIMATE FEEDBACK CALCULATIONS, ALL AEROSOLS: - ! -------------------------------------------- - ! Set aerosol input arrays - ! feedback input arrays have been zeroed - ! set soot and dust aerosol concentrations: - IF (DO_SNO_AER) THEN - mss_cnc_aer_in_fdb(:,1) = mss_cnc_bcphi(:) - mss_cnc_aer_in_fdb(:,2) = mss_cnc_bcpho(:) - - ! DO_SNO_OC is set in SNICAR_varpar. Default case is to ignore OC concentrations because: - ! 1) Knowledge of their optical properties is primitive - ! 2) When 'water-soluble' OPAC optical properties are applied to OC in snow, - ! it has a negligible darkening effect. - IF (DO_SNO_OC) THEN - mss_cnc_aer_in_fdb(:,3) = mss_cnc_ocphi(:) - mss_cnc_aer_in_fdb(:,4) = mss_cnc_ocpho(:) - ENDIF + mss_cnc_aer_in_fdb(:,5) = mss_cnc_dst1(:) + mss_cnc_aer_in_fdb(:,6) = mss_cnc_dst2(:) + mss_cnc_aer_in_fdb(:,7) = mss_cnc_dst3(:) + mss_cnc_aer_in_fdb(:,8) = mss_cnc_dst4(:) + ENDIF - mss_cnc_aer_in_fdb(:,5) = mss_cnc_dst1(:) - mss_cnc_aer_in_fdb(:,6) = mss_cnc_dst2(:) - mss_cnc_aer_in_fdb(:,7) = mss_cnc_dst3(:) - mss_cnc_aer_in_fdb(:,8) = mss_cnc_dst4(:) - ENDIF - - flg_slr = 1 ! direct-beam - IF (use_snicar_ad) THEN - CALL SNICAR_AD_RT(flg_snw_ice, & - flg_slr, & - coszen_col, & - snl, & - h2osno, & - frac_sno, & - h2osno_liq(:), & - h2osno_ice(:), & - snw_rds_in(:), & - mss_cnc_aer_in_fdb(:, :), & - albsfc(:), & - albsnd(:), & - flx_absd_snw(:, :) ) - ELSE - CALL SNICAR_RT (flg_snw_ice, & - flg_slr, & - coszen_col, & - snl, & - h2osno, & - frac_sno, & - h2osno_liq(:), & - h2osno_ice(:), & - snw_rds_in(:), & - mss_cnc_aer_in_fdb(:, :), & - albsfc(:), & - albsnd(:), & - flx_absd_snw(:, :) ) - ENDIF ! END IF use_snicar_ad - - flg_slr = 2 ! diffuse - IF (use_snicar_ad) THEN - CALL SNICAR_AD_RT(flg_snw_ice, & - flg_slr, & - coszen_col, & - snl, & - h2osno, & - frac_sno, & - h2osno_liq(:), & - h2osno_ice(:), & - snw_rds_in(:), & - mss_cnc_aer_in_fdb(:, :), & - albsfc(:), & - albsni(:), & - flx_absi_snw(:, :) ) - ELSE - CALL SNICAR_RT (flg_snw_ice, & - flg_slr, & - coszen_col, & - snl, & - h2osno, & - frac_sno, & - h2osno_liq(:), & - h2osno_ice(:), & - snw_rds_in(:), & - mss_cnc_aer_in_fdb(:, :), & - albsfc(:), & - albsni(:), & - flx_absi_snw(:, :) ) - ENDIF ! END IF use_snicar_ad - - - ! ground albedos and snow-fraction weighting of snow absorption factors - DO ib = 1, nband - IF (coszen_col > 0._r8) THEN - ! ground albedo was originally computed in SoilAlbedo, but is now computed here - ! because the order of SoilAlbedo and SNICAR_RT/SNICAR_AD_RT was switched for SNICAR/SNICAR_AD_RT. - ! 09/01/2023, yuan: change to only snow albedo, the same below - !albgrd(ib) = albsod(ib)*(1._r8-frac_sno) + albsnd(ib)*frac_sno - !albgri(ib) = albsoi(ib)*(1._r8-frac_sno) + albsni(ib)*frac_sno - albgrd(ib) = albsnd(ib) - albgri(ib) = albsni(ib) - - ! albedos for radiative forcing calculations: - IF (use_snicar_frc) THEN - ! pure snow albedo for all-aerosol radiative forcing - !albgrd_pur(ib) = albsod(ib)*(1.-frac_sno) + albsnd_pur(ib)*frac_sno - !albgri_pur(ib) = albsoi(ib)*(1.-frac_sno) + albsni_pur(ib)*frac_sno - albgrd_pur(ib) = albsnd_pur(ib) - albgri_pur(ib) = albsni_pur(ib) - - ! BC forcing albedo - !albgrd_bc(ib) = albsod(ib)*(1.-frac_sno) + albsnd_bc(ib)*frac_sno - !albgri_bc(ib) = albsoi(ib)*(1.-frac_sno) + albsni_bc(ib)*frac_sno - albgrd_bc(ib) = albsnd_bc(ib) - albgri_bc(ib) = albsni_bc(ib) - - IF (DO_SNO_OC) THEN - ! OC forcing albedo - !albgrd_oc(ib) = albsod(ib)*(1.-frac_sno) + albsnd_oc(ib)*frac_sno - !albgri_oc(ib) = albsoi(ib)*(1.-frac_sno) + albsni_oc(ib)*frac_sno - albgrd_oc(ib) = albsnd_oc(ib) - albgri_oc(ib) = albsni_oc(ib) - ENDIF - - ! dust forcing albedo - !albgrd_dst(ib) = albsod(ib)*(1.-frac_sno) + albsnd_dst(ib)*frac_sno - !albgri_dst(ib) = albsoi(ib)*(1.-frac_sno) + albsni_dst(ib)*frac_sno - albgrd_dst(ib) = albsnd_dst(ib) - albgri_dst(ib) = albsni_dst(ib) - ENDIF + flg_slr = 1 ! direct-beam + IF (use_snicar_ad) THEN + CALL SNICAR_AD_RT(flg_snw_ice, & + flg_slr, & + coszen_col, & + snl, & + h2osno, & + frac_sno, & + h2osno_liq(:), & + h2osno_ice(:), & + snw_rds_in(:), & + mss_cnc_aer_in_fdb(:, :), & + albsfc(:), & + albsnd(:), & + flx_absd_snw(:, :) ) + ELSE + CALL SNICAR_RT (flg_snw_ice, & + flg_slr, & + coszen_col, & + snl, & + h2osno, & + frac_sno, & + h2osno_liq(:), & + h2osno_ice(:), & + snw_rds_in(:), & + mss_cnc_aer_in_fdb(:, :), & + albsfc(:), & + albsnd(:), & + flx_absd_snw(:, :) ) + ENDIF ! END IF use_snicar_ad + + flg_slr = 2 ! diffuse + IF (use_snicar_ad) THEN + CALL SNICAR_AD_RT(flg_snw_ice, & + flg_slr, & + coszen_col, & + snl, & + h2osno, & + frac_sno, & + h2osno_liq(:), & + h2osno_ice(:), & + snw_rds_in(:), & + mss_cnc_aer_in_fdb(:, :), & + albsfc(:), & + albsni(:), & + flx_absi_snw(:, :) ) + ELSE + CALL SNICAR_RT (flg_snw_ice, & + flg_slr, & + coszen_col, & + snl, & + h2osno, & + frac_sno, & + h2osno_liq(:), & + h2osno_ice(:), & + snw_rds_in(:), & + mss_cnc_aer_in_fdb(:, :), & + albsfc(:), & + albsni(:), & + flx_absi_snw(:, :) ) + ENDIF ! END IF use_snicar_ad + + + ! ground albedos and snow-fraction weighting of snow absorption factors + DO ib = 1, nband + IF (coszen_col > 0._r8) THEN + ! ground albedo was originally computed in SoilAlbedo, but is now computed here + ! because the order of SoilAlbedo and SNICAR_RT/SNICAR_AD_RT was switched for SNICAR/SNICAR_AD_RT. + ! 09/01/2023, yuan: change to only snow albedo, the same below + !albgrd(ib) = albsod(ib)*(1._r8-frac_sno) + albsnd(ib)*frac_sno + !albgri(ib) = albsoi(ib)*(1._r8-frac_sno) + albsni(ib)*frac_sno + albgrd(ib) = albsnd(ib) + albgri(ib) = albsni(ib) + + ! albedos for radiative forcing calculations: + IF (use_snicar_frc) THEN + ! pure snow albedo for all-aerosol radiative forcing + !albgrd_pur(ib) = albsod(ib)*(1.-frac_sno) + albsnd_pur(ib)*frac_sno + !albgri_pur(ib) = albsoi(ib)*(1.-frac_sno) + albsni_pur(ib)*frac_sno + albgrd_pur(ib) = albsnd_pur(ib) + albgri_pur(ib) = albsni_pur(ib) + + ! BC forcing albedo + !albgrd_bc(ib) = albsod(ib)*(1.-frac_sno) + albsnd_bc(ib)*frac_sno + !albgri_bc(ib) = albsoi(ib)*(1.-frac_sno) + albsni_bc(ib)*frac_sno + albgrd_bc(ib) = albsnd_bc(ib) + albgri_bc(ib) = albsni_bc(ib) + + IF (DO_SNO_OC) THEN + ! OC forcing albedo + !albgrd_oc(ib) = albsod(ib)*(1.-frac_sno) + albsnd_oc(ib)*frac_sno + !albgri_oc(ib) = albsoi(ib)*(1.-frac_sno) + albsni_oc(ib)*frac_sno + albgrd_oc(ib) = albsnd_oc(ib) + albgri_oc(ib) = albsni_oc(ib) + ENDIF + + ! dust forcing albedo + !albgrd_dst(ib) = albsod(ib)*(1.-frac_sno) + albsnd_dst(ib)*frac_sno + !albgri_dst(ib) = albsoi(ib)*(1.-frac_sno) + albsni_dst(ib)*frac_sno + albgrd_dst(ib) = albsnd_dst(ib) + albgri_dst(ib) = albsni_dst(ib) + ENDIF - ! also in this loop (but optionally in a different loop for vectorized code) - ! weight snow layer radiative absorption factors based on snow fraction and soil albedo - ! (NEEDED FOR ENERGY CONSERVATION) - DO i = maxsnl+1,1,1 - IF (subgridflag == 0 ) THEN - IF (ib == 1) THEN - flx_absdv(i) = flx_absd_snw(i,ib)*frac_sno + & - ((1.-frac_sno)*(1-albsod(ib))*(flx_absd_snw(i,ib)/(1.-albsnd(ib)))) - flx_absiv(i) = flx_absi_snw(i,ib)*frac_sno + & - ((1.-frac_sno)*(1-albsoi(ib))*(flx_absi_snw(i,ib)/(1.-albsni(ib)))) - elseif (ib == 2) THEN - flx_absdn(i) = flx_absd_snw(i,ib)*frac_sno + & - ((1.-frac_sno)*(1-albsod(ib))*(flx_absd_snw(i,ib)/(1.-albsnd(ib)))) - flx_absin(i) = flx_absi_snw(i,ib)*frac_sno + & - ((1.-frac_sno)*(1-albsoi(ib))*(flx_absi_snw(i,ib)/(1.-albsni(ib)))) - ENDIF - ELSE - IF (ib == 1) THEN - flx_absdv(i) = flx_absd_snw(i,ib)*(1.-albsnd(ib)) - flx_absiv(i) = flx_absi_snw(i,ib)*(1.-albsni(ib)) - elseif (ib == 2) THEN - flx_absdn(i) = flx_absd_snw(i,ib)*(1.-albsnd(ib)) - flx_absin(i) = flx_absi_snw(i,ib)*(1.-albsni(ib)) - ENDIF - ENDIF - ENDDO - ENDIF - ENDDO - - END SUBROUTINE SnowAlbedo - - - SUBROUTINE albocean (oro, scv, coszrs, alb) + ! also in this loop (but optionally in a different loop for vectorized code) + ! weight snow layer radiative absorption factors based on snow fraction and soil albedo + ! (NEEDED FOR ENERGY CONSERVATION) + DO i = maxsnl+1,1,1 + IF (subgridflag == 0 ) THEN + IF (ib == 1) THEN + flx_absdv(i) = flx_absd_snw(i,ib)*frac_sno + & + ((1.-frac_sno)*(1-albsod(ib))*(flx_absd_snw(i,ib)/(1.-albsnd(ib)))) + flx_absiv(i) = flx_absi_snw(i,ib)*frac_sno + & + ((1.-frac_sno)*(1-albsoi(ib))*(flx_absi_snw(i,ib)/(1.-albsni(ib)))) + elseif (ib == 2) THEN + flx_absdn(i) = flx_absd_snw(i,ib)*frac_sno + & + ((1.-frac_sno)*(1-albsod(ib))*(flx_absd_snw(i,ib)/(1.-albsnd(ib)))) + flx_absin(i) = flx_absi_snw(i,ib)*frac_sno + & + ((1.-frac_sno)*(1-albsoi(ib))*(flx_absi_snw(i,ib)/(1.-albsni(ib)))) + ENDIF + ELSE + IF (ib == 1) THEN + flx_absdv(i) = flx_absd_snw(i,ib)*(1.-albsnd(ib)) + flx_absiv(i) = flx_absi_snw(i,ib)*(1.-albsni(ib)) + elseif (ib == 2) THEN + flx_absdn(i) = flx_absd_snw(i,ib)*(1.-albsnd(ib)) + flx_absin(i) = flx_absi_snw(i,ib)*(1.-albsni(ib)) + ENDIF + ENDIF + ENDDO + ENDIF + ENDDO + + END SUBROUTINE SnowAlbedo + + + SUBROUTINE albocean (oro, scv, coszrs, alb) !----------------------------------------------------------------------- ! @@ -1952,28 +1949,28 @@ SUBROUTINE albocean (oro, scv, coszrs, alb) !------------------------------Arguments-------------------------------- - real(r8), intent(in) :: oro ! /ocean(0)/seaice(2) flag - real(r8), intent(in) :: scv ! snow water equivalent) [mm] - real(r8), intent(in) :: coszrs ! Cosine solar zenith angle + real(r8), intent(in) :: oro ! /ocean(0)/seaice(2) flag + real(r8), intent(in) :: scv ! snow water equivalent) [mm] + real(r8), intent(in) :: coszrs ! Cosine solar zenith angle - real(r8), intent(out) :: alb(2,2) ! srf alb for direct (diffuse) rad 0.2-0.7 micro-ms - ! Srf alb for direct (diffuse) rad 0.7-5.0 micro-ms + real(r8), intent(out) :: alb(2,2) ! srf alb for direct (diffuse) rad 0.2-0.7 micro-ms + ! Srf alb for direct (diffuse) rad 0.7-5.0 micro-ms !---------------------------Local variables----------------------------- - real(r8) frsnow ! horizontal fraction of snow cover - real(r8) snwhgt ! physical snow height - real(r8) rghsnw ! roughness for horizontal snow cover fractn + real(r8) frsnow ! horizontal fraction of snow cover + real(r8) snwhgt ! physical snow height + real(r8) rghsnw ! roughness for horizontal snow cover fractn - real(r8) sasdir ! snow alb for direct rad 0.2-0.7 micro-ms - real(r8) saldir ! snow alb for direct rad 0.7-5.0 micro-ms - real(r8) sasdif ! snow alb for diffuse rad 0.2-0.7 micro-ms - real(r8) saldif ! snow alb for diffuse rad 0.7-5.0 micro-ms + real(r8) sasdir ! snow alb for direct rad 0.2-0.7 micro-ms + real(r8) saldir ! snow alb for direct rad 0.7-5.0 micro-ms + real(r8) sasdif ! snow alb for diffuse rad 0.2-0.7 micro-ms + real(r8) saldif ! snow alb for diffuse rad 0.7-5.0 micro-ms - real(r8), parameter :: asices = 0.70 ! sea ice albedo for 0.2-0.7 micro-meters [-] - real(r8), parameter :: asicel = 0.50 ! sea ice albedo for 0.7-5.0 micro-meters [-] - real(r8), parameter :: asnows = 0.95 ! snow albedo for 0.2-0.7 micro-meters [-] - real(r8), parameter :: asnowl = 0.70 ! snow albedo for 0.7-5.0 micro-meters + real(r8), parameter :: asices = 0.70 ! sea ice albedo for 0.2-0.7 micro-meters [-] + real(r8), parameter :: asicel = 0.50 ! sea ice albedo for 0.7-5.0 micro-meters [-] + real(r8), parameter :: asnows = 0.95 ! snow albedo for 0.2-0.7 micro-meters [-] + real(r8), parameter :: asnowl = 0.70 ! snow albedo for 0.7-5.0 micro-meters !----------------------------------------------------------------------- ! initialize all ocean/sea ice surface albedos to zero @@ -2023,8 +2020,7 @@ SUBROUTINE albocean (oro, scv, coszrs, alb) alb(2,2) = 0.06 ENDIF - END SUBROUTINE albocean - + END SUBROUTINE albocean END MODULE MOD_Albedo ! --------- EOP ---------- diff --git a/main/MOD_AssimStomataConductance.F90 b/main/MOD_AssimStomataConductance.F90 index 040c3fc4..12ca513c 100644 --- a/main/MOD_AssimStomataConductance.F90 +++ b/main/MOD_AssimStomataConductance.F90 @@ -3,36 +3,34 @@ MODULE MOD_AssimStomataConductance !----------------------------------------------------------------------- - use MOD_Precision - use MOD_Namelist - IMPLICIT NONE - SAVE + USE MOD_Precision + USE MOD_Namelist + IMPLICIT NONE + SAVE ! PUBLIC MEMBER FUNCTIONS: - public :: stomata - public :: update_photosyn + PUBLIC :: stomata + PUBLIC :: update_photosyn ! PRIVATE MEMBER FUNCTIONS: - private :: sortin - private :: calc_photo_params + PRIVATE :: sortin + PRIVATE :: calc_photo_params !----------------------------------------------------------------------- - CONTAINS +CONTAINS !----------------------------------------------------------------------- - - - subroutine stomata (vmax25,effcon,slti,hlti,shti, & - hhti,trda,trdm,trop,g1,g0,gradm,binter,tm, & - psrf,po2m,pco2m,pco2a,ea,ei,tlef,par & + SUBROUTINE stomata (vmax25,effcon,slti,hlti,shti, & + hhti,trda,trdm,trop,g1,g0,gradm,binter,tm, & + psrf,po2m,pco2m,pco2a,ea,ei,tlef,par & !Ozone stress variables - ,o3coefv,o3coefg & + ,o3coefv,o3coefg & !End ozone stress variables - ,rb,ra,rstfac,cint,assim,respc,rst & - ) + ,rb,ra,rstfac,cint,assim,respc,rst & + ) !======================================================================= ! @@ -73,10 +71,10 @@ subroutine stomata (vmax25,effcon,slti,hlti,shti, & ! !---------------------------------------------------------------------- - use MOD_Precision - IMPLICIT NONE + USE MOD_Precision + IMPLICIT NONE - real(r8),intent(in) :: & + real(r8),intent(in) :: & effcon, &! quantum efficiency of RuBP regeneration (mol CO2 / mol quanta) vmax25, &! maximum carboxylation rate at 25 C at canopy top @@ -92,7 +90,7 @@ subroutine stomata (vmax25,effcon,slti,hlti,shti, & gradm, &! conductance-photosynthesis slope parameter binter ! conductance-photosynthesis intercept - real(r8),intent(in) :: & + real(r8),intent(in) :: & tm, &! atmospheric air temperature (K) psrf, &! surface atmospheric pressure (pa) po2m, &! O2 concentration in atmos. (pascals) @@ -111,21 +109,21 @@ subroutine stomata (vmax25,effcon,slti,hlti,shti, & ra, &! aerodynamic resistance from cas to refence height (s m-1) rstfac ! canopy resistance stress factors to soil moisture - real(r8),intent(in), dimension(3) :: & + real(r8),intent(in), dimension(3) :: & cint ! scaling up from leaf to canopy - real(r8),intent(out) :: &! ATTENTION : all for canopy not leaf + real(r8),intent(out) :: &! ATTENTION : all for canopy not leaf assim, &! canopy assimilation rate (mol m-2 s-1) respc, &! canopy respiration (mol m-2 s-1) rst ! canopy stomatal resistance (s m-1) - real(r8) gammas + real(r8) gammas !-------------------- local -------------------------------------------- - integer, parameter :: iterationtotal = 6 ! total iteration number in pco2i calculation + integer, parameter :: iterationtotal = 6 ! total iteration number in pco2i calculation - real(r8) & + real(r8) & c3, &! c3 vegetation : 1; 0 for c4 c4, &! c4 vegetation : 1; 0 for c3 rrkk, &! kc (1+o2/ko) @@ -165,14 +163,14 @@ subroutine stomata (vmax25,effcon,slti,hlti,shti, & bquad, &! b: ax^2 + bx + c = 0 cquad ! c: ax^2 + bx + c = 0 - real(r8) :: & + real(r8) :: & eyy(iterationtotal), &! differnce of pco2i at two iteration step pco2y(iterationtotal), &! adjusted to total iteration number range ! - integer ic + integer ic - call calc_photo_params(tlef, po2m, par , psrf, rstfac, rb, effcon, vmax25, & + CALL calc_photo_params(tlef, po2m, par , psrf, rstfac, rb, effcon, vmax25, & trop, slti, hlti, shti, hhti, trda, trdm, cint, & vm, epar, respc, omss, gbh2o, gammas, rrkk, c3, c4) @@ -190,14 +188,14 @@ subroutine stomata (vmax25,effcon,slti,hlti,shti, & range = pco2m * ( 1. - 1.6/gradm ) - gammas - do ic = 1, iterationtotal ! loop for total iteration number + DO ic = 1, iterationtotal ! loop for total iteration number pco2y(ic) = 0. eyy(ic) = 0. - enddo + ENDDO - ITERATION_LOOP: do ic = 1, iterationtotal + ITERATION_LOOP: DO ic = 1, iterationtotal - call sortin(eyy, pco2y, range, gammas, ic, iterationtotal) + CALL sortin(eyy, pco2y, range, gammas, ic, iterationtotal) pco2i = pco2y(ic) !----------------------------------------------------------------------- @@ -276,17 +274,17 @@ subroutine stomata (vmax25,effcon,slti,hlti,shti, & co2st = max( co2st,1.e-5 ) assmt = max( 1.e-12, assimn ) - if(DEF_USE_MEDLYNST)then + IF(DEF_USE_MEDLYNST)THEN vpd = amax1((ei - ea),50._r8) * 1.e-3 ! in kpa acp = 1.6*assmt/co2st ! in mol m-2 s-1 aquad = 1._r8 bquad = -2*(g0*1.e-6 + acp) - (g1*acp)**2/(gbh2o*vpd) ! in mol m-2 s-1 cquad = (g0*1.e-6)**2 + (2*g0*1.e-6+acp*(1-g1**2)/vpd)*acp ! in (mol m-2 s-1)**2 - + sqrtin= max( 0., ( bquad**2 - 4.*aquad*cquad ) ) - gsh2o = ( -bquad + sqrt ( sqrtin ) ) / (2.*aquad) + gsh2o = ( -bquad + sqrt ( sqrtin ) ) / (2.*aquad) - else + ELSE hcdma = ei*co2st / ( gradm*assmt ) aquad = hcdma @@ -295,32 +293,31 @@ subroutine stomata (vmax25,effcon,slti,hlti,shti, & sqrtin= max( 0., ( bquad**2 - 4.*aquad*cquad ) ) gsh2o = ( -bquad + sqrt ( sqrtin ) ) / (2.*aquad) - + es = ( gsh2o-bintc ) * hcdma ! pa es = min( es, ei ) es = max( es, 1.e-2) - + gsh2o = es/hcdma + bintc ! mol m-2 s-1 - end if + ENDIF pco2in = ( co2s - 1.6 * assimn / gsh2o )*psrf ! pa eyy(ic) = pco2i - pco2in ! pa !----------------------------------------------------------------------- - if( abs(eyy(ic)) .lt. 0.1 ) exit + IF( abs(eyy(ic)) .lt. 0.1 ) EXIT - enddo ITERATION_LOOP + ENDDO ITERATION_LOOP ! convert gsh2o (mol m-2 s-1) to resistance rst ( s m-1) rst = min( 1.e6, 1./(gsh2o*tlef/tprcor) ) ! s m-1 - - end subroutine stomata + END SUBROUTINE stomata - subroutine sortin( eyy, pco2y, range, gammas, ic, iterationtotal ) + SUBROUTINE sortin( eyy, pco2y, range, gammas, ic, iterationtotal ) !----------------------------------------------------------------------- ! arranges successive pco2/error pairs in order of increasing pco2. @@ -330,42 +327,42 @@ subroutine sortin( eyy, pco2y, range, gammas, ic, iterationtotal ) ! original author: P. J. Sellers (SiB2) !----------------------------------------------------------------------- - use MOD_Precision - IMPLICIT NONE + USE MOD_Precision + IMPLICIT NONE - integer, intent(in) :: ic,iterationtotal - real(r8), INTENT(in) :: range - real(r8), INTENT(in) :: gammas - real(r8), INTENT(inout), dimension(iterationtotal) :: eyy, pco2y + integer, intent(in) :: ic,iterationtotal + real(r8), intent(in) :: range + real(r8), intent(in) :: gammas + real(r8), intent(inout), dimension(iterationtotal) :: eyy, pco2y !----- Local ----------------------------------------------------------- - integer i, j, n, i1, i2, i3, is, isp, ix - real(r8) a, b, pmin, emin, eyy_a - real(r8) pco2b, pco2yl, pco2yq - real(r8) ac1, ac2, bc1, bc2, cc1, cc2 - real(r8) bterm, aterm, cterm + integer i, j, n, i1, i2, i3, is, isp, ix + real(r8) a, b, pmin, emin, eyy_a + real(r8) pco2b, pco2yl, pco2yq + real(r8) ac1, ac2, bc1, bc2, cc1, cc2 + real(r8) bterm, aterm, cterm !----------------------------------------------------------------------- - if( ic .ge. 4 ) go to 500 + IF( ic .ge. 4 ) go to 500 eyy_a = 1.0 - if(eyy(1).lt.0.) eyy_a = -1.0 + IF(eyy(1).lt.0.) eyy_a = -1.0 pco2y(1) = gammas + 0.5*range pco2y(2) = gammas + range*( 0.5 - 0.3*eyy_a ) pco2y(3) = pco2y(1) - (pco2y(1)-pco2y(2))/(eyy(1)-eyy(2)+1.e-10)*eyy(1) pmin = min( pco2y(1), pco2y(2) ) emin = min( eyy(1), eyy(2) ) - if ( emin .gt. 0. .and. pco2y(3) .gt. pmin ) pco2y(3) = gammas + IF ( emin .gt. 0. .and. pco2y(3) .gt. pmin ) pco2y(3) = gammas go to 200 500 continue n = ic - 1 - do 1000 j = 2, n + DO 1000 j = 2, n a = eyy(j) b = pco2y(j) - do 2000 i = j-1,1,-1 - if(eyy(i) .le. a ) go to 100 + DO 2000 i = j-1,1,-1 + IF(eyy(i) .le. a ) go to 100 eyy(i+1) = eyy(i) pco2y(i+1) = pco2y(i) 2000 continue @@ -376,9 +373,9 @@ subroutine sortin( eyy, pco2y, range, gammas, ic, iterationtotal ) pco2b = 0. is = 1 - do 3000 ix = 1, n - if( eyy(ix) .lt. 0. ) pco2b = pco2y(ix) - if( eyy(ix) .lt. 0. ) is = ix + DO 3000 ix = 1, n + IF( eyy(ix) .lt. 0. ) pco2b = pco2y(ix) + IF( eyy(ix) .lt. 0. ) is = ix 3000 continue i1 = is-1 i1 = max(1, i1) @@ -412,64 +409,64 @@ subroutine sortin( eyy, pco2y, range, gammas, ic, iterationtotal ) pco2y(ic) = max ( pco2y(ic), 0.01 ) - end subroutine sortin + END SUBROUTINE sortin - subroutine calc_photo_params(tlef, po2m, par , psrf, rstfac, rb, effcon, vmax25, & + SUBROUTINE calc_photo_params(tlef, po2m, par , psrf, rstfac, rb, effcon, vmax25, & trop, slti, hlti, shti, hhti, trda, trdm, cint, & vm, epar, respc, omss, gbh2o, gammas, rrkk, c3, c4) - use MOD_Precision - IMPLICIT NONE - - real(r8),intent(in) :: & - tlef, &! leaf temperature (K) - po2m, &! O2 concentration in atmos. (pascals) - par, &! photosynthetic active radiation (W m-2) - rstfac, &! canopy resistance stress factors to soil moisture - rb, &! boundary resistance from canopy to cas (s m-1) - - effcon, &! quantum efficiency of RuBP regeneration (mol CO2 / mol quanta) - vmax25, &! maximum carboxylation rate at 25 C at canopy top - ! the range : 30.e-6 <-> 100.e-6 (mol co2 m-2 s-1) - trop, &! temperature coefficient in gs-a model (298.16) - slti, &! slope of low temperature inhibition function (0.2) - hlti, &! 1/2 point of low temperature inhibition function (288.16) - shti, &! slope of high temperature inhibition function (0.3) - hhti, &! 1/2 point of high temperature inhibition function (313.16) - trda, &! temperature coefficient in gs-a model (1.3) - trdm, &! temperature coefficient in gs-a model (328.16) - psrf ! surface atmospheric pressure (pa) - - real(r8),intent(in), dimension(3) :: & - cint ! scaling up from leaf to canopy - - real(r8),intent(out) :: & - vm, &! maximum catalytic activity of Rubison (mol co2 m-2 s-1) - epar, &! electron transport rate (mol electron m-2 s-1) - respc, &! canopy respiration (mol m-2 s-1) - omss, &! intermediate calcuation for oms - gbh2o, &! one side leaf boundary layer conductance (mol m-2 s-1) - gammas, &! CO2 compensation point - rrkk, &! kc (1+o2/ko) - c3, &! c3 vegetation : 1; 0 for c4 - c4 ! c4 vegetation : 1; 0 for c3 - - real(r8) :: & - qt, &! (tleaf - 298.16) / 10 - kc, &! Michaelis-Menten constant for co2 - ko, &! Michaelis-Menten constant for o2 - templ, &! intermediate value - temph, &! intermediate value - rgas, &! universal gas contant (8.314 J mol-1 K-1) - jmax25, &! potential rate of whole-chain electron transport at 25 C - jmax, &! potential rate of whole-chain electron transport (mol electron m-2 s-1) - respcp, &! respiration fraction of vmax (mol co2 m-2 s-1) - tprcor ! coefficient for unit transfer + USE MOD_Precision + IMPLICIT NONE + + real(r8),intent(in) :: & + tlef, &! leaf temperature (K) + po2m, &! O2 concentration in atmos. (pascals) + par, &! photosynthetic active radiation (W m-2) + rstfac, &! canopy resistance stress factors to soil moisture + rb, &! boundary resistance from canopy to cas (s m-1) + + effcon, &! quantum efficiency of RuBP regeneration (mol CO2 / mol quanta) + vmax25, &! maximum carboxylation rate at 25 C at canopy top + ! the range : 30.e-6 <-> 100.e-6 (mol co2 m-2 s-1) + trop, &! temperature coefficient in gs-a model (298.16) + slti, &! slope of low temperature inhibition function (0.2) + hlti, &! 1/2 point of low temperature inhibition function (288.16) + shti, &! slope of high temperature inhibition function (0.3) + hhti, &! 1/2 point of high temperature inhibition function (313.16) + trda, &! temperature coefficient in gs-a model (1.3) + trdm, &! temperature coefficient in gs-a model (328.16) + psrf ! surface atmospheric pressure (pa) + + real(r8),intent(in), dimension(3) :: & + cint ! scaling up from leaf to canopy + + real(r8),intent(out) :: & + vm, &! maximum catalytic activity of Rubison (mol co2 m-2 s-1) + epar, &! electron transport rate (mol electron m-2 s-1) + respc, &! canopy respiration (mol m-2 s-1) + omss, &! intermediate calcuation for oms + gbh2o, &! one side leaf boundary layer conductance (mol m-2 s-1) + gammas, &! CO2 compensation point + rrkk, &! kc (1+o2/ko) + c3, &! c3 vegetation : 1; 0 for c4 + c4 ! c4 vegetation : 1; 0 for c3 + + real(r8) :: & + qt, &! (tleaf - 298.16) / 10 + kc, &! Michaelis-Menten constant for co2 + ko, &! Michaelis-Menten constant for o2 + templ, &! intermediate value + temph, &! intermediate value + rgas, &! universal gas contant (8.314 J mol-1 K-1) + jmax25, &! potential rate of whole-chain electron transport at 25 C + jmax, &! potential rate of whole-chain electron transport (mol electron m-2 s-1) + respcp, &! respiration fraction of vmax (mol co2 m-2 s-1) + tprcor ! coefficient for unit transfer !======================================================================= c3 = 0. - if( effcon .gt. 0.07 ) c3 = 1. + IF( effcon .gt. 0.07 ) c3 = 1. c4 = 1. - c3 !----------------------------------------------------------------------- @@ -546,85 +543,85 @@ subroutine calc_photo_params(tlef, po2m, par , psrf, rstfac, rb, effcon, vmax25, ! thus, there is no need for gbh2o *cint(3) (sunlit/shaded LAI) ! gbh2o = gbh2o * cint(3) - end subroutine calc_photo_params + END SUBROUTINE calc_photo_params - subroutine update_photosyn(tlef, po2m, pco2m, pco2a, par, psrf, rstfac, rb, gsh2o, & + SUBROUTINE update_photosyn(tlef, po2m, pco2m, pco2a, par, psrf, rstfac, rb, gsh2o, & effcon, vmax25, gradm, trop, slti, hlti, shti, hhti, trda, trdm, cint, & assim, respc) - use MOD_Precision - IMPLICIT NONE - - real(r8),intent(in) :: & - tlef, &! leaf temperature (K) - po2m, &! O2 concentration in atmos. (pascals) - pco2m, &! CO2 concentration in atmos. (pascals) - pco2a, &! CO2 concentration in canopy air space (pa) - par, &! photosynthetic active radiation (W m-2) - psrf, &! surface atmospheric pressure (pa) - rstfac, &! canopy resistance stress factors to soil moisture - rb, &! boundary resistance from canopy to cas (s m-1) - gsh2o, &! canopy conductance (mol m-2 s-1) - - effcon, &! quantum efficiency of RuBP regeneration (mol CO2 / mol quanta) - vmax25, &! maximum carboxylation rate at 25 C at canopy top - ! the range : 30.e-6 <-> 100.e-6 (mol co2 m-2 s-1) - gradm, &! conductance-photosynthesis slope parameter - trop, &! temperature coefficient in gs-a model (298.16) - slti, &! slope of low temperature inhibition function (0.2) - hlti, &! 1/2 point of low temperature inhibition function (288.16) - shti, &! slope of high temperature inhibition function (0.3) - hhti, &! 1/2 point of high temperature inhibition function (313.16) - trda, &! temperature coefficient in gs-a model (1.3) - trdm ! temperature coefficient in gs-a model (328.16) - - real(r8),intent(in), dimension(3) :: & - cint ! scaling up from leaf to canopy - - real(r8),intent(out) :: & - assim, &! canopy assimilation rate (mol m-2 s-1) - respc ! canopy respiration (mol m-2 s-1) - - real(r8) :: & - vm, &! maximum catalytic activity of Rubison (mol co2 m-2 s-1) - epar, &! electron transport rate (mol electron m-2 s-1) - gbh2o, &! one side leaf boundary layer conductance (mol m-2 s-1) - gammas, &! CO2 compensation point - rrkk, &! kc (1+o2/ko) - c3, &! c3 vegetation : 1; 0 for c4 - c4 ! c4 vegetation : 1; 0 for c3 - - real(r8) :: & - atheta, &! wc, we coupling parameter - btheta, &! wc & we, ws coupling parameter - omss, &! intermediate calcuation for oms - omc, &! rubisco limited assimilation (omega-c: mol m-2 s-1) - ome, &! light limited assimilation (omega-e: mol m-2 s-1) - oms, &! sink limited assimilation (omega-s: mol m-2 s-1) - omp, &! intermediate calcuation for omc, ome - - co2a, &! co2 concentration at cas (mol mol-1) - co2s, &! co2 concentration at canopy surface (mol mol-1) - co2st, &! co2 concentration at canopy surface (mol mol-1) - co2i, &! internal co2 concentration (mol mol-1) - pco2in, &! internal co2 concentration at the new iteration (pa) - pco2i, &! internal co2 concentration (pa) - es, &! canopy surface h2o vapor pressure (pa) - - sqrtin, &! intermediate calculation for quadratic - assmt, &! net assimilation with a positive limitation (mol co2 m-2 s-1) - assimn ! net assimilation (mol co2 m-2 s-1) - - integer, parameter :: iterationtotal = 6 ! total iteration number in pco2i calculation - - real(r8) :: & - eyy(iterationtotal), &! differnce of pco2i at two iteration step - pco2y(iterationtotal), &! adjusted to total iteration number - range ! - - integer ic - - call calc_photo_params(tlef, po2m, par , psrf, rstfac, rb, effcon, vmax25, & + USE MOD_Precision + IMPLICIT NONE + + real(r8),intent(in) :: & + tlef, &! leaf temperature (K) + po2m, &! O2 concentration in atmos. (pascals) + pco2m, &! CO2 concentration in atmos. (pascals) + pco2a, &! CO2 concentration in canopy air space (pa) + par, &! photosynthetic active radiation (W m-2) + psrf, &! surface atmospheric pressure (pa) + rstfac, &! canopy resistance stress factors to soil moisture + rb, &! boundary resistance from canopy to cas (s m-1) + gsh2o, &! canopy conductance (mol m-2 s-1) + + effcon, &! quantum efficiency of RuBP regeneration (mol CO2 / mol quanta) + vmax25, &! maximum carboxylation rate at 25 C at canopy top + ! the range : 30.e-6 <-> 100.e-6 (mol co2 m-2 s-1) + gradm, &! conductance-photosynthesis slope parameter + trop, &! temperature coefficient in gs-a model (298.16) + slti, &! slope of low temperature inhibition function (0.2) + hlti, &! 1/2 point of low temperature inhibition function (288.16) + shti, &! slope of high temperature inhibition function (0.3) + hhti, &! 1/2 point of high temperature inhibition function (313.16) + trda, &! temperature coefficient in gs-a model (1.3) + trdm ! temperature coefficient in gs-a model (328.16) + + real(r8),intent(in), dimension(3) :: & + cint ! scaling up from leaf to canopy + + real(r8),intent(out) :: & + assim, &! canopy assimilation rate (mol m-2 s-1) + respc ! canopy respiration (mol m-2 s-1) + + real(r8) :: & + vm, &! maximum catalytic activity of Rubison (mol co2 m-2 s-1) + epar, &! electron transport rate (mol electron m-2 s-1) + gbh2o, &! one side leaf boundary layer conductance (mol m-2 s-1) + gammas, &! CO2 compensation point + rrkk, &! kc (1+o2/ko) + c3, &! c3 vegetation : 1; 0 for c4 + c4 ! c4 vegetation : 1; 0 for c3 + + real(r8) :: & + atheta, &! wc, we coupling parameter + btheta, &! wc & we, ws coupling parameter + omss, &! intermediate calcuation for oms + omc, &! rubisco limited assimilation (omega-c: mol m-2 s-1) + ome, &! light limited assimilation (omega-e: mol m-2 s-1) + oms, &! sink limited assimilation (omega-s: mol m-2 s-1) + omp, &! intermediate calcuation for omc, ome + + co2a, &! co2 concentration at cas (mol mol-1) + co2s, &! co2 concentration at canopy surface (mol mol-1) + co2st, &! co2 concentration at canopy surface (mol mol-1) + co2i, &! internal co2 concentration (mol mol-1) + pco2in, &! internal co2 concentration at the new iteration (pa) + pco2i, &! internal co2 concentration (pa) + es, &! canopy surface h2o vapor pressure (pa) + + sqrtin, &! intermediate calculation for quadratic + assmt, &! net assimilation with a positive limitation (mol co2 m-2 s-1) + assimn ! net assimilation (mol co2 m-2 s-1) + + integer, parameter :: iterationtotal = 6 ! total iteration number in pco2i calculation + + real(r8) :: & + eyy(iterationtotal), &! differnce of pco2i at two iteration step + pco2y(iterationtotal), &! adjusted to total iteration number + range ! + + integer ic + + CALL calc_photo_params(tlef, po2m, par , psrf, rstfac, rb, effcon, vmax25, & trop, slti, hlti, shti, hhti, trda, trdm, cint, & vm, epar, respc, omss, gbh2o, gammas, rrkk, c3, c4) @@ -632,14 +629,14 @@ subroutine update_photosyn(tlef, po2m, pco2m, pco2a, par, psrf, rstfac, rb, gsh2 range = pco2m * ( 1. - 1.6/gradm ) - gammas - do ic = 1, iterationtotal ! loop for total iteration number + DO ic = 1, iterationtotal ! loop for total iteration number pco2y(ic) = 0. eyy(ic) = 0. - enddo + ENDDO - ITERATION_LOOP_UPDATE: do ic = 1, iterationtotal + ITERATION_LOOP_UPDATE: DO ic = 1, iterationtotal - call sortin(eyy, pco2y, range, gammas, ic, iterationtotal) + CALL sortin(eyy, pco2y, range, gammas, ic, iterationtotal) pco2i = pco2y(ic) !----------------------------------------------------------------------- @@ -720,11 +717,11 @@ subroutine update_photosyn(tlef, po2m, pco2m, pco2a, par, psrf, rstfac, rb, gsh2 !----------------------------------------------------------------------- - if( abs(eyy(ic)) .lt. 0.1 ) exit + IF( abs(eyy(ic)) .lt. 0.1 ) EXIT - enddo ITERATION_LOOP_UPDATE + ENDDO ITERATION_LOOP_UPDATE - end subroutine update_photosyn + END SUBROUTINE update_photosyn END MODULE MOD_AssimStomataConductance ! -------------- EOP --------------- diff --git a/main/MOD_CanopyLayerProfile.F90 b/main/MOD_CanopyLayerProfile.F90 index 13c54978..9b340f4f 100644 --- a/main/MOD_CanopyLayerProfile.F90 +++ b/main/MOD_CanopyLayerProfile.F90 @@ -3,727 +3,727 @@ MODULE MOD_CanopyLayerProfile !----------------------------------------------------------------------- - USE MOD_Precision - IMPLICIT NONE - SAVE + USE MOD_Precision + IMPLICIT NONE + SAVE ! PUBLIC MEMBER SUBROUTINE/FUNCTIONS: - PUBLIC :: uprofile - PUBLIC :: kprofile - PUBLIC :: uintegral - PUBLIC :: uintegralz - PUBLIC :: ueffect - PUBLIC :: ueffectz - PUBLIC :: fuint - PUBLIC :: udiff - PUBLIC :: kintegral - PUBLIC :: frd - PUBLIC :: fkint - PUBLIC :: kdiff + PUBLIC :: uprofile + PUBLIC :: kprofile + PUBLIC :: uintegral + PUBLIC :: uintegralz + PUBLIC :: ueffect + PUBLIC :: ueffectz + PUBLIC :: fuint + PUBLIC :: udiff + PUBLIC :: kintegral + PUBLIC :: frd + PUBLIC :: fkint + PUBLIC :: kdiff - PUBLIC :: ufindroots - PUBLIC :: kfindroots + PUBLIC :: ufindroots + PUBLIC :: kfindroots - PUBLIC :: cal_z0_displa + PUBLIC :: cal_z0_displa !----------------------------------------------------------------------- CONTAINS - real(r8) FUNCTION uprofile(utop, fc, bee, alpha, z0mg, htop, hbot, z) + real(r8) FUNCTION uprofile(utop, fc, bee, alpha, z0mg, htop, hbot, z) - USE MOD_Precision - USE MOD_FrictionVelocity - IMPLICIT NONE + USE MOD_Precision + USE MOD_FrictionVelocity + IMPLICIT NONE - real(r8), intent(in) :: utop - real(r8), intent(in) :: fc - real(r8), intent(in) :: bee - real(r8), intent(in) :: alpha - real(r8), intent(in) :: z0mg - real(r8), intent(in) :: htop - real(r8), intent(in) :: hbot - real(r8), intent(in) :: z + real(r8), intent(in) :: utop + real(r8), intent(in) :: fc + real(r8), intent(in) :: bee + real(r8), intent(in) :: alpha + real(r8), intent(in) :: z0mg + real(r8), intent(in) :: htop + real(r8), intent(in) :: hbot + real(r8), intent(in) :: z - real(r8) :: ulog,uexp + real(r8) :: ulog,uexp - ! when canopy LAI->0, z0->zs, fac->1, u->umoninobuk - ! canopy LAI->large, fac->0 or=0, u->log profile - ulog = utop*log(z/z0mg)/log(htop/z0mg) - uexp = utop*exp(-alpha*(1-(z-hbot)/(htop-hbot))) + ! when canopy LAI->0, z0->zs, fac->1, u->umoninobuk + ! canopy LAI->large, fac->0 or=0, u->log profile + ulog = utop*log(z/z0mg)/log(htop/z0mg) + uexp = utop*exp(-alpha*(1-(z-hbot)/(htop-hbot))) - uprofile = bee*fc*min(uexp,ulog) + (1-bee*fc)*ulog + uprofile = bee*fc*min(uexp,ulog) + (1-bee*fc)*ulog - RETURN - END FUNCTION uprofile + RETURN + END FUNCTION uprofile - real(r8) FUNCTION kprofile(ktop, fc, bee, alpha, & - displah, htop, hbot, obu, ustar, z) + real(r8) FUNCTION kprofile(ktop, fc, bee, alpha, & + displah, htop, hbot, obu, ustar, z) - USE MOD_Precision - USE MOD_FrictionVelocity - IMPLICIT NONE + USE MOD_Precision + USE MOD_FrictionVelocity + IMPLICIT NONE - real(r8), parameter :: com1 = 0.4 - real(r8), parameter :: com2 = 0.08 + real(r8), parameter :: com1 = 0.4 + real(r8), parameter :: com2 = 0.08 - real(r8), intent(in) :: ktop - real(r8), intent(in) :: fc - real(r8), intent(in) :: bee - real(r8), intent(in) :: alpha - real(r8), intent(in) :: displah - real(r8), intent(in) :: htop - real(r8), intent(in) :: hbot - real(r8), intent(in) :: obu - real(r8), intent(in) :: ustar - real(r8), intent(in) :: z + real(r8), intent(in) :: ktop + real(r8), intent(in) :: fc + real(r8), intent(in) :: bee + real(r8), intent(in) :: alpha + real(r8), intent(in) :: displah + real(r8), intent(in) :: htop + real(r8), intent(in) :: hbot + real(r8), intent(in) :: obu + real(r8), intent(in) :: ustar + real(r8), intent(in) :: z - real(r8) :: fac - real(r8) :: kcob, klin, kexp + real(r8) :: fac + real(r8) :: kcob, klin, kexp - klin = ktop*z/htop + klin = ktop*z/htop - fac = 1. / (1.+exp(-(displah-com1)/com2)) - kcob = 1. / (fac/klin + (1.-fac)/kmoninobuk(0.,obu,ustar,z)) + fac = 1. / (1.+exp(-(displah-com1)/com2)) + kcob = 1. / (fac/klin + (1.-fac)/kmoninobuk(0.,obu,ustar,z)) - kexp = ktop*exp(-alpha*(htop-z)/(htop-hbot)) - kprofile = 1./( bee*fc/min(kexp,kcob) + (1-bee*fc)/kcob ) + kexp = ktop*exp(-alpha*(htop-z)/(htop-hbot)) + kprofile = 1./( bee*fc/min(kexp,kcob) + (1-bee*fc)/kcob ) - RETURN - END FUNCTION kprofile + RETURN + END FUNCTION kprofile - real(r8) FUNCTION uintegral(utop, fc, bee, alpha, z0mg, htop, hbot) + real(r8) FUNCTION uintegral(utop, fc, bee, alpha, z0mg, htop, hbot) - USE MOD_Precision - IMPLICIT NONE + USE MOD_Precision + IMPLICIT NONE - real(r8), intent(in) :: utop - real(r8), intent(in) :: fc - real(r8), intent(in) :: bee - real(r8), intent(in) :: alpha - real(r8), intent(in) :: z0mg - real(r8), intent(in) :: htop - real(r8), intent(in) :: hbot + real(r8), intent(in) :: utop + real(r8), intent(in) :: fc + real(r8), intent(in) :: bee + real(r8), intent(in) :: alpha + real(r8), intent(in) :: z0mg + real(r8), intent(in) :: htop + real(r8), intent(in) :: hbot - integer :: i, n - real(r8) :: dz, z, u + integer :: i, n + real(r8) :: dz, z, u - ! 09/26/2017: change fixed n -> fixed dz - dz = 0.001 !fordebug only - n = int( (htop-hbot) / dz ) + 1 + ! 09/26/2017: change fixed n -> fixed dz + dz = 0.001 !fordebug only + n = int( (htop-hbot) / dz ) + 1 - uintegral = 0. + uintegral = 0. - DO i = 1, n - IF (i < n) THEN - z = htop - (i-0.5)*dz - ELSE - dz = htop - hbot - (n-1)*dz - z = hbot + 0.5*dz - ENDIF + DO i = 1, n + IF (i < n) THEN + z = htop - (i-0.5)*dz + ELSE + dz = htop - hbot - (n-1)*dz + z = hbot + 0.5*dz + ENDIF - u = uprofile(utop, fc, bee, alpha, z0mg, htop, hbot, z) + u = uprofile(utop, fc, bee, alpha, z0mg, htop, hbot, z) - u = max(0._r8, u) - !uintegral = uintegral + sqrt(u)*dz / (htop-hbot) -! 03/04/2020, yuan: NOTE: the above is hard to solve - !NOTE: The integral cannot be solved analytically after - !the square root sign of u, and the integral can be approximated - !directly for u, In this way, there is no need to square - uintegral = uintegral + u*dz / (htop-hbot) - ENDDO + u = max(0._r8, u) + !uintegral = uintegral + sqrt(u)*dz / (htop-hbot) + ! 03/04/2020, yuan: NOTE: the above is hard to solve + !NOTE: The integral cannot be solved analytically after + !the square root sign of u, and the integral can be approximated + !directly for u, In this way, there is no need to square + uintegral = uintegral + u*dz / (htop-hbot) + ENDDO - !uintegral = uintegral * uintegral + !uintegral = uintegral * uintegral - RETURN - END FUNCTION uintegral + RETURN + END FUNCTION uintegral - real(r8) FUNCTION uintegralz(utop, fc, bee, alpha, z0mg, & + real(r8) FUNCTION uintegralz(utop, fc, bee, alpha, z0mg, & htop, hbot, ztop, zbot) - USE MOD_Precision - IMPLICIT NONE - - real(r8), intent(in) :: utop - real(r8), intent(in) :: fc - real(r8), intent(in) :: bee - real(r8), intent(in) :: alpha - real(r8), intent(in) :: z0mg - real(r8), intent(in) :: htop - real(r8), intent(in) :: hbot - real(r8), intent(in) :: ztop - real(r8), intent(in) :: zbot - - integer :: i, n - real(r8) :: dz, z, u - - ! 09/26/2017: change fixed n -> fixed dz - dz = 0.001 !fordebug only - n = int( (ztop-zbot) / dz ) + 1 - - uintegralz = 0. - - DO i = 1, n - IF (i < n) THEN - z = ztop - (i-0.5)*dz - ELSE - dz = ztop - zbot - (n-1)*dz - z = zbot + 0.5*dz - ENDIF - - u = uprofile(utop, fc, bee, alpha, z0mg, htop, hbot, z) - - u = max(0._r8, u) - !uintegral = uintegral + sqrt(u)*dz / (htop-hbot) -! 03/04/2020, yuan: NOTE: the above is hard to solve - !NOTE: The integral cannot be solved analytically after - !the square root sign of u, and the integral can be approximated - !directly for u, In this way, there is no need to square - uintegralz = uintegralz + u*dz / (ztop-zbot) - ENDDO - - !uintegralz = uintegralz * uintegralz - - RETURN - END FUNCTION uintegralz - - - real(r8) FUNCTION ueffect(utop, htop, hbot, & - z0mg, alpha, bee, fc) - USE MOD_Precision - IMPLICIT NONE - - real(r8), intent(in) :: utop - real(r8), intent(in) :: htop - real(r8), intent(in) :: hbot - real(r8), intent(in) :: z0mg - real(r8), intent(in) :: alpha - real(r8), intent(in) :: bee - real(r8), intent(in) :: fc - - real(r8) :: roots(2), uint - integer :: rootn - - rootn = 0 - uint = 0. - - ! The dichotomy method to find the root satisfies a certain accuracy, - ! assuming that there are at most 2 roots - CALL ufindroots(htop,hbot,(htop+hbot)/2., & - utop, htop, hbot, z0mg, alpha, roots, rootn) - - IF (rootn == 0) THEN !no root - uint = uint + fuint(utop, htop, hbot, & - htop, hbot, z0mg, alpha, bee, fc) - ENDIF - - IF (rootn == 1) THEN - uint = uint + fuint(utop, htop, roots(1), & - htop, hbot, z0mg, alpha, bee, fc) - uint = uint + fuint(utop, roots(1), hbot, & - htop, hbot, z0mg, alpha, bee, fc) - ENDIF - - IF (rootn == 2) THEN - uint = uint + fuint(utop, htop, roots(1), & - htop, hbot, z0mg, alpha, bee, fc) - uint = uint + fuint(utop, roots(1), roots(2), & - htop, hbot, z0mg, alpha, bee, fc) - uint = uint + fuint(utop, roots(2), hbot, & - htop, hbot, z0mg, alpha, bee, fc) - ENDIF - - ueffect = uint / (htop-hbot) - - RETURN - END FUNCTION ueffect - - - ! Calculate the effective wind speed between ztop and zbot - real(r8) FUNCTION ueffectz(utop, htop, hbot, & - ztop, zbot, z0mg, alpha, bee, fc) - USE MOD_Precision - IMPLICIT NONE - - real(r8), intent(in) :: utop - real(r8), intent(in) :: htop - real(r8), intent(in) :: hbot - real(r8), intent(in) :: ztop - real(r8), intent(in) :: zbot - real(r8), intent(in) :: z0mg - real(r8), intent(in) :: alpha - real(r8), intent(in) :: bee - real(r8), intent(in) :: fc - - real(r8) :: roots(2), uint - integer :: rootn - - rootn = 0 - uint = 0. - - ! The dichotomy method to find the root satisfies a certain accuracy, - ! assuming that there are at most 2 roots - CALL ufindroots(ztop,zbot,(ztop+zbot)/2., & - utop, htop, hbot, z0mg, alpha, roots, rootn) - - IF (rootn == 0) THEN !no root - uint = uint + fuint(utop, ztop, zbot, & - htop, hbot, z0mg, alpha, bee, fc) - ENDIF - - IF (rootn == 1) THEN - uint = uint + fuint(utop, ztop, roots(1), & - htop, hbot, z0mg, alpha, bee, fc) - uint = uint + fuint(utop, roots(1), zbot, & - htop, hbot, z0mg, alpha, bee, fc) - ENDIF - - IF (rootn == 2) THEN - uint = uint + fuint(utop, ztop, roots(1), & - htop, hbot, z0mg, alpha, bee, fc) - uint = uint + fuint(utop, roots(1), roots(2), & - htop, hbot, z0mg, alpha, bee, fc) - uint = uint + fuint(utop, roots(2), zbot, & - htop, hbot, z0mg, alpha, bee, fc) - ENDIF - - ueffectz = uint / (ztop-zbot) - - RETURN - END FUNCTION ueffectz - - - real(r8) FUNCTION fuint(utop, ztop, zbot, & - htop, hbot, z0mg, alpha, bee, fc) - - USE MOD_Precision - IMPLICIT NONE - - real(r8), intent(in) :: utop, ztop, zbot - real(r8), intent(in) :: htop, hbot - real(r8), intent(in) :: z0mg, alpha - real(r8), intent(in) :: bee, fc - - ! local variables - real(r8) :: fuexpint, fulogint - - fulogint = utop/log(htop/z0mg) *& - (ztop*log(ztop/z0mg) - zbot*log(zbot/z0mg) + zbot - ztop) - - IF (udiff((ztop+zbot)/2.,utop,htop,hbot,z0mg,alpha) <= 0) THEN - ! uexp is smaller - fuexpint = utop*(htop-hbot)/alpha*( & - exp(-alpha*(htop-ztop)/(htop-hbot))-& - exp(-alpha*(htop-zbot)/(htop-hbot)) ) - - fuint = bee*fc*fuexpint + (1.-bee*fc)*fulogint - ELSE - ! ulog is smaller - fuint = fulogint - ENDIF - - RETURN - END FUNCTION fuint - - - RECURSIVE SUBROUTINE ufindroots(ztop,zbot,zmid, & - utop, htop, hbot, z0mg, alpha, roots, rootn) - - USE MOD_Precision - IMPLICIT NONE - - real(r8), intent(in) :: ztop, zbot, zmid - real(r8), intent(in) :: utop, htop, hbot - real(r8), intent(in) :: z0mg, alpha - - real(r8), intent(inout) :: roots(2) - integer, intent(inout) :: rootn - - ! local variables - real(r8) :: udiff_ub, udiff_lb - - udiff_ub = udiff(ztop,utop,htop,hbot,z0mg,alpha) - udiff_lb = udiff(zmid,utop,htop,hbot,z0mg,alpha) - - IF (udiff_ub*udiff_lb == 0) THEN - IF (udiff_lb == 0) THEN !root found - rootn = rootn + 1 - IF (rootn > 2) THEN - print *, "U root number > 2, abort!" - CALL abort - ENDIF - roots(rootn) = zmid - ENDIF - ELSE IF (udiff_ub*udiff_lb < 0) THEN - IF (ztop-zmid < 0.01) THEN - rootn = rootn + 1 !root found - IF (rootn > 2) THEN - print *, "U root number > 2, abort!" - CALL abort - ENDIF - roots(rootn) = (ztop+zmid)/2. - ELSE - CALL ufindroots(ztop,zmid,(ztop+zmid)/2., & - utop, htop, hbot, z0mg, alpha, roots, rootn) - ENDIF - ENDIF - - udiff_ub = udiff(zmid,utop,htop,hbot,z0mg,alpha) - udiff_lb = udiff(zbot,utop,htop,hbot,z0mg,alpha) - - IF (udiff_ub*udiff_lb == 0) THEN - IF (udiff_ub == 0) THEN !root found - rootn = rootn + 1 - IF (rootn > 2) THEN - print *, "U root number > 2, abort!" - CALL abort - ENDIF - roots(rootn) = zmid - ENDIF - ELSE IF (udiff_ub*udiff_lb < 0) THEN - IF (zmid-zbot < 0.01) THEN - rootn = rootn + 1 !root found - IF (rootn > 2) THEN - print *, "U root number > 2, abort!" - CALL abort - ENDIF - roots(rootn) = (zmid+zbot)/2. - ELSE - CALL ufindroots(zmid,zbot,(zmid+zbot)/2., & - utop, htop, hbot, z0mg, alpha, roots, rootn) - ENDIF - ENDIF - END SUBROUTINE ufindroots - - - real(r8) FUNCTION udiff(z, utop, htop, hbot, z0mg, alpha) - - USE MOD_Precision - IMPLICIT NONE - - real(r8), intent(in) :: z, utop, htop, hbot - real(r8), intent(in) :: z0mg, alpha - - real(r8) :: uexp, ulog - - ! yuan, 12/28/2020: - uexp = utop*exp(-alpha*(htop-z)/(htop-hbot)) - ulog = utop*log(z/z0mg)/log(htop/z0mg) - - udiff = uexp - ulog - - RETURN - END FUNCTION udiff - - - real(r8) FUNCTION kintegral(ktop, fc, bee, alpha, z0mg, & - displah, htop, hbot, obu, ustar, ztop, zbot) - USE MOD_Precision - IMPLICIT NONE - - real(r8), intent(in) :: ktop - real(r8), intent(in) :: fc - real(r8), intent(in) :: bee - real(r8), intent(in) :: alpha - real(r8), intent(in) :: z0mg - real(r8), intent(in) :: displah - real(r8), intent(in) :: htop - real(r8), intent(in) :: hbot - real(r8), intent(in) :: obu - real(r8), intent(in) :: ustar - real(r8), intent(in) :: ztop - real(r8), intent(in) :: zbot - - integer :: i, n - real(r8) :: dz, z, k - - kintegral = 0. - - IF (ztop <= zbot) THEN - RETURN - ENDIF - - ! 09/26/2017: change fixed n -> fixed dz - dz = 0.001 ! fordebug only - n = int( (ztop-zbot) / dz ) + 1 - - DO i = 1, n - IF (i < n) THEN - z = ztop - (i-0.5)*dz - ELSE - dz = ztop - zbot - (n-1)*dz - z = zbot + 0.5*dz - ENDIF - - k = kprofile(ktop, fc, bee, alpha, & - displah, htop, hbot, obu, ustar, z) - - kintegral = kintegral + 1./k * dz - - ENDDO - - RETURN - END FUNCTION kintegral - - - real(r8) FUNCTION frd(ktop, htop, hbot, & - ztop, zbot, displah, z0h, obu, ustar, & - z0mg, alpha, bee, fc) - - USE MOD_Precision - IMPLICIT NONE - - real(r8), intent(in) :: ktop, htop, hbot - real(r8), intent(in) :: ztop, zbot - real(r8), intent(in) :: displah, z0h, obu, ustar - real(r8), intent(in) :: z0mg, alpha, bee, fc - - ! local parameters - real(r8), parameter :: com1 = 0.4 - real(r8), parameter :: com2 = 0.08 + USE MOD_Precision + IMPLICIT NONE + + real(r8), intent(in) :: utop + real(r8), intent(in) :: fc + real(r8), intent(in) :: bee + real(r8), intent(in) :: alpha + real(r8), intent(in) :: z0mg + real(r8), intent(in) :: htop + real(r8), intent(in) :: hbot + real(r8), intent(in) :: ztop + real(r8), intent(in) :: zbot + + integer :: i, n + real(r8) :: dz, z, u + + ! 09/26/2017: change fixed n -> fixed dz + dz = 0.001 !fordebug only + n = int( (ztop-zbot) / dz ) + 1 + + uintegralz = 0. + + DO i = 1, n + IF (i < n) THEN + z = ztop - (i-0.5)*dz + ELSE + dz = ztop - zbot - (n-1)*dz + z = zbot + 0.5*dz + ENDIF + + u = uprofile(utop, fc, bee, alpha, z0mg, htop, hbot, z) + + u = max(0._r8, u) + !uintegral = uintegral + sqrt(u)*dz / (htop-hbot) + ! 03/04/2020, yuan: NOTE: the above is hard to solve + !NOTE: The integral cannot be solved analytically after + !the square root sign of u, and the integral can be approximated + !directly for u, In this way, there is no need to square + uintegralz = uintegralz + u*dz / (ztop-zbot) + ENDDO + + !uintegralz = uintegralz * uintegralz + + RETURN + END FUNCTION uintegralz + + + real(r8) FUNCTION ueffect(utop, htop, hbot, & + z0mg, alpha, bee, fc) + USE MOD_Precision + IMPLICIT NONE + + real(r8), intent(in) :: utop + real(r8), intent(in) :: htop + real(r8), intent(in) :: hbot + real(r8), intent(in) :: z0mg + real(r8), intent(in) :: alpha + real(r8), intent(in) :: bee + real(r8), intent(in) :: fc + + real(r8) :: roots(2), uint + integer :: rootn + + rootn = 0 + uint = 0. + + ! The dichotomy method to find the root satisfies a certain accuracy, + ! assuming that there are at most 2 roots + CALL ufindroots(htop,hbot,(htop+hbot)/2., & + utop, htop, hbot, z0mg, alpha, roots, rootn) + + IF (rootn == 0) THEN !no root + uint = uint + fuint(utop, htop, hbot, & + htop, hbot, z0mg, alpha, bee, fc) + ENDIF + + IF (rootn == 1) THEN + uint = uint + fuint(utop, htop, roots(1), & + htop, hbot, z0mg, alpha, bee, fc) + uint = uint + fuint(utop, roots(1), hbot, & + htop, hbot, z0mg, alpha, bee, fc) + ENDIF + + IF (rootn == 2) THEN + uint = uint + fuint(utop, htop, roots(1), & + htop, hbot, z0mg, alpha, bee, fc) + uint = uint + fuint(utop, roots(1), roots(2), & + htop, hbot, z0mg, alpha, bee, fc) + uint = uint + fuint(utop, roots(2), hbot, & + htop, hbot, z0mg, alpha, bee, fc) + ENDIF + + ueffect = uint / (htop-hbot) + + RETURN + END FUNCTION ueffect + + + ! Calculate the effective wind speed between ztop and zbot + real(r8) FUNCTION ueffectz(utop, htop, hbot, & + ztop, zbot, z0mg, alpha, bee, fc) + USE MOD_Precision + IMPLICIT NONE + + real(r8), intent(in) :: utop + real(r8), intent(in) :: htop + real(r8), intent(in) :: hbot + real(r8), intent(in) :: ztop + real(r8), intent(in) :: zbot + real(r8), intent(in) :: z0mg + real(r8), intent(in) :: alpha + real(r8), intent(in) :: bee + real(r8), intent(in) :: fc + + real(r8) :: roots(2), uint + integer :: rootn + + rootn = 0 + uint = 0. + + ! The dichotomy method to find the root satisfies a certain accuracy, + ! assuming that there are at most 2 roots + CALL ufindroots(ztop,zbot,(ztop+zbot)/2., & + utop, htop, hbot, z0mg, alpha, roots, rootn) + + IF (rootn == 0) THEN !no root + uint = uint + fuint(utop, ztop, zbot, & + htop, hbot, z0mg, alpha, bee, fc) + ENDIF + + IF (rootn == 1) THEN + uint = uint + fuint(utop, ztop, roots(1), & + htop, hbot, z0mg, alpha, bee, fc) + uint = uint + fuint(utop, roots(1), zbot, & + htop, hbot, z0mg, alpha, bee, fc) + ENDIF + + IF (rootn == 2) THEN + uint = uint + fuint(utop, ztop, roots(1), & + htop, hbot, z0mg, alpha, bee, fc) + uint = uint + fuint(utop, roots(1), roots(2), & + htop, hbot, z0mg, alpha, bee, fc) + uint = uint + fuint(utop, roots(2), zbot, & + htop, hbot, z0mg, alpha, bee, fc) + ENDIF + + ueffectz = uint / (ztop-zbot) + + RETURN + END FUNCTION ueffectz + + + real(r8) FUNCTION fuint(utop, ztop, zbot, & + htop, hbot, z0mg, alpha, bee, fc) + + USE MOD_Precision + IMPLICIT NONE + + real(r8), intent(in) :: utop, ztop, zbot + real(r8), intent(in) :: htop, hbot + real(r8), intent(in) :: z0mg, alpha + real(r8), intent(in) :: bee, fc + + ! local variables + real(r8) :: fuexpint, fulogint + + fulogint = utop/log(htop/z0mg) *& + (ztop*log(ztop/z0mg) - zbot*log(zbot/z0mg) + zbot - ztop) + + IF (udiff((ztop+zbot)/2.,utop,htop,hbot,z0mg,alpha) <= 0) THEN + ! uexp is smaller + fuexpint = utop*(htop-hbot)/alpha*( & + exp(-alpha*(htop-ztop)/(htop-hbot))-& + exp(-alpha*(htop-zbot)/(htop-hbot)) ) + + fuint = bee*fc*fuexpint + (1.-bee*fc)*fulogint + ELSE + ! ulog is smaller + fuint = fulogint + ENDIF + + RETURN + END FUNCTION fuint + + + RECURSIVE SUBROUTINE ufindroots(ztop,zbot,zmid, & + utop, htop, hbot, z0mg, alpha, roots, rootn) + + USE MOD_Precision + IMPLICIT NONE + + real(r8), intent(in) :: ztop, zbot, zmid + real(r8), intent(in) :: utop, htop, hbot + real(r8), intent(in) :: z0mg, alpha + + real(r8), intent(inout) :: roots(2) + integer, intent(inout) :: rootn + + ! local variables + real(r8) :: udiff_ub, udiff_lb + + udiff_ub = udiff(ztop,utop,htop,hbot,z0mg,alpha) + udiff_lb = udiff(zmid,utop,htop,hbot,z0mg,alpha) + + IF (udiff_ub*udiff_lb == 0) THEN + IF (udiff_lb == 0) THEN !root found + rootn = rootn + 1 + IF (rootn > 2) THEN + print *, "U root number > 2, abort!" + CALL abort + ENDIF + roots(rootn) = zmid + ENDIF + ELSE IF (udiff_ub*udiff_lb < 0) THEN + IF (ztop-zmid < 0.01) THEN + rootn = rootn + 1 !root found + IF (rootn > 2) THEN + print *, "U root number > 2, abort!" + CALL abort + ENDIF + roots(rootn) = (ztop+zmid)/2. + ELSE + CALL ufindroots(ztop,zmid,(ztop+zmid)/2., & + utop, htop, hbot, z0mg, alpha, roots, rootn) + ENDIF + ENDIF + + udiff_ub = udiff(zmid,utop,htop,hbot,z0mg,alpha) + udiff_lb = udiff(zbot,utop,htop,hbot,z0mg,alpha) + + IF (udiff_ub*udiff_lb == 0) THEN + IF (udiff_ub == 0) THEN !root found + rootn = rootn + 1 + IF (rootn > 2) THEN + print *, "U root number > 2, abort!" + CALL abort + ENDIF + roots(rootn) = zmid + ENDIF + ELSE IF (udiff_ub*udiff_lb < 0) THEN + IF (zmid-zbot < 0.01) THEN + rootn = rootn + 1 !root found + IF (rootn > 2) THEN + print *, "U root number > 2, abort!" + CALL abort + ENDIF + roots(rootn) = (zmid+zbot)/2. + ELSE + CALL ufindroots(zmid,zbot,(zmid+zbot)/2., & + utop, htop, hbot, z0mg, alpha, roots, rootn) + ENDIF + ENDIF + END SUBROUTINE ufindroots + + + real(r8) FUNCTION udiff(z, utop, htop, hbot, z0mg, alpha) + + USE MOD_Precision + IMPLICIT NONE + + real(r8), intent(in) :: z, utop, htop, hbot + real(r8), intent(in) :: z0mg, alpha + + real(r8) :: uexp, ulog + + ! yuan, 12/28/2020: + uexp = utop*exp(-alpha*(htop-z)/(htop-hbot)) + ulog = utop*log(z/z0mg)/log(htop/z0mg) + + udiff = uexp - ulog + + RETURN + END FUNCTION udiff + + + real(r8) FUNCTION kintegral(ktop, fc, bee, alpha, z0mg, & + displah, htop, hbot, obu, ustar, ztop, zbot) + USE MOD_Precision + IMPLICIT NONE + + real(r8), intent(in) :: ktop + real(r8), intent(in) :: fc + real(r8), intent(in) :: bee + real(r8), intent(in) :: alpha + real(r8), intent(in) :: z0mg + real(r8), intent(in) :: displah + real(r8), intent(in) :: htop + real(r8), intent(in) :: hbot + real(r8), intent(in) :: obu + real(r8), intent(in) :: ustar + real(r8), intent(in) :: ztop + real(r8), intent(in) :: zbot + + integer :: i, n + real(r8) :: dz, z, k + + kintegral = 0. + + IF (ztop <= zbot) THEN + RETURN + ENDIF + + ! 09/26/2017: change fixed n -> fixed dz + dz = 0.001 ! fordebug only + n = int( (ztop-zbot) / dz ) + 1 + + DO i = 1, n + IF (i < n) THEN + z = ztop - (i-0.5)*dz + ELSE + dz = ztop - zbot - (n-1)*dz + z = zbot + 0.5*dz + ENDIF + + k = kprofile(ktop, fc, bee, alpha, & + displah, htop, hbot, obu, ustar, z) + + kintegral = kintegral + 1./k * dz + + ENDDO + + RETURN + END FUNCTION kintegral + + + real(r8) FUNCTION frd(ktop, htop, hbot, & + ztop, zbot, displah, z0h, obu, ustar, & + z0mg, alpha, bee, fc) + + USE MOD_Precision + IMPLICIT NONE + + real(r8), intent(in) :: ktop, htop, hbot + real(r8), intent(in) :: ztop, zbot + real(r8), intent(in) :: displah, z0h, obu, ustar + real(r8), intent(in) :: z0mg, alpha, bee, fc + + ! local parameters + real(r8), parameter :: com1 = 0.4 + real(r8), parameter :: com2 = 0.08 - real(r8) :: roots(2), fac, kint - integer :: rootn + real(r8) :: roots(2), fac, kint + integer :: rootn - rootn = 0 - kint = 0. + rootn = 0 + kint = 0. - ! calculate fac - fac = 1. / (1.+exp(-(displah-com1)/com2)) - roots(:) = 0. + ! calculate fac + fac = 1. / (1.+exp(-(displah-com1)/com2)) + roots(:) = 0. - CALL kfindroots(ztop,zbot,(ztop+zbot)/2., & - ktop, htop, hbot, obu, ustar, fac, alpha, roots, rootn) + CALL kfindroots(ztop,zbot,(ztop+zbot)/2., & + ktop, htop, hbot, obu, ustar, fac, alpha, roots, rootn) - IF (rootn == 0) THEN !no root - kint = kint + fkint(ktop, ztop, zbot, htop, hbot, & - z0h, obu, ustar, fac, alpha, bee, fc) - ENDIF - - IF (rootn == 1) THEN - kint = kint + fkint(ktop, ztop, roots(1), htop, hbot, & - z0h, obu, ustar, fac, alpha, bee, fc) - kint = kint + fkint(ktop, roots(1), zbot, htop, hbot, & - z0h, obu, ustar, fac, alpha, bee, fc) - ENDIF - - IF (rootn == 2) THEN - kint = kint + fkint(ktop, ztop, roots(1), htop, hbot, & - z0h, obu, ustar, fac, alpha, bee, fc) - kint = kint + fkint(ktop, roots(1), roots(2), htop, hbot, & - z0h, obu, ustar, fac, alpha, bee, fc) - kint = kint + fkint(ktop, roots(2), zbot, htop, hbot, & - z0h, obu, ustar, fac, alpha, bee, fc) - ENDIF - - frd = kint - - RETURN - END FUNCTION frd - - - real(r8) FUNCTION fkint(ktop, ztop, zbot, htop, hbot, & - z0h, obu, ustar, fac, alpha, bee, fc) - - USE MOD_Precision - USE MOD_FrictionVelocity - IMPLICIT NONE - - real(r8), intent(in) :: ktop, ztop, zbot - real(r8), intent(in) :: htop, hbot - real(r8), intent(in) :: z0h, obu, ustar, fac, alpha - real(r8), intent(in) :: bee, fc - - ! local variables - real(r8) :: fkexpint, fkcobint - - !NOTE: - ! klin = ktop*z/htop - ! kcob = 1./(fac/klin + (1.-fac)/kmoninobuk(0.,obu,ustar,z)) - fkcobint = fac*htop/ktop*(log(ztop)-log(zbot)) +& - (1.-fac)*kintmoninobuk(0.,z0h,obu,ustar,ztop,zbot) - - IF (kdiff((ztop+zbot)/2.,ktop,htop,hbot,obu,ustar,fac,alpha) <= 0) THEN - ! kexp is smaller - IF (alpha > 0) THEN - fkexpint = -(htop-hbot)/alpha/ktop*( & - exp(alpha*(htop-ztop)/(htop-hbot))-& - exp(alpha*(htop-zbot)/(htop-hbot)) ) - ELSE - fkexpint = (ztop-zbot)/ktop - ENDIF - - fkint = bee*fc*fkexpint + (1.-bee*fc)*fkcobint - ELSE - ! kcob is smaller - fkint = fkcobint - ENDIF - - RETURN - END FUNCTION fkint - - - RECURSIVE SUBROUTINE kfindroots(ztop,zbot,zmid, & - ktop, htop, hbot, obu, ustar, fac, alpha, roots, rootn) - - USE MOD_Precision - IMPLICIT NONE - - real(r8), intent(in) :: ztop, zbot, zmid - real(r8), intent(in) :: ktop, htop, hbot - real(r8), intent(in) :: obu, ustar, fac, alpha - - real(r8), intent(inout) :: roots(2) - integer, intent(inout) :: rootn - - ! local variables - real(r8) :: kdiff_ub, kdiff_lb - - !print *, "*** CALL recursive SUBROUTINE kfindroots!!" - kdiff_ub = kdiff(ztop,ktop,htop,hbot,obu,ustar,fac,alpha) - kdiff_lb = kdiff(zmid,ktop,htop,hbot,obu,ustar,fac,alpha) - - IF (kdiff_ub*kdiff_lb == 0) THEN - IF (kdiff_lb == 0) THEN !root found - rootn = rootn + 1 - IF (rootn > 2) THEN - print *, "K root number > 2, abort!" - CALL abort - ENDIF - roots(rootn) = zmid - ENDIF - ELSE IF (kdiff_ub*kdiff_lb < 0) THEN - IF (ztop-zmid < 0.01) THEN - rootn = rootn + 1 !root found - IF (rootn > 2) THEN - print *, "K root number > 2, abort!" - CALL abort - ENDIF - roots(rootn) = (ztop+zmid)/2. - ELSE - CALL kfindroots(ztop,zmid,(ztop+zmid)/2., & - ktop, htop, hbot, obu, ustar, fac, alpha, roots, rootn) - ENDIF - ENDIF - - kdiff_ub = kdiff(zmid,ktop,htop,hbot,obu,ustar,fac,alpha) - kdiff_lb = kdiff(zbot,ktop,htop,hbot,obu,ustar,fac,alpha) - - IF (kdiff_ub*kdiff_lb == 0) THEN - IF (kdiff_ub == 0) THEN !root found - rootn = rootn + 1 - IF (rootn > 2) THEN - print *, "K root number > 2, abort!" - CALL abort - ENDIF - roots(rootn) = zmid - ENDIF - ELSE IF (kdiff_ub*kdiff_lb < 0) THEN - IF (zmid-zbot < 0.01) THEN - rootn = rootn + 1 !root found - IF (rootn > 2) THEN - print *, "K root number > 2, abort!" - CALL abort - ENDIF - roots(rootn) = (zmid+zbot)/2. - ELSE - CALL kfindroots(zmid,zbot,(zmid+zbot)/2., & - ktop, htop, hbot, obu, ustar, fac, alpha, roots, rootn) - ENDIF - ENDIF - END SUBROUTINE kfindroots - - - real(r8) FUNCTION kdiff(z, ktop, htop, hbot, & - obu, ustar, fac, alpha) - - USE MOD_Precision - USE MOD_FrictionVelocity - IMPLICIT NONE - - real(r8), intent(in) :: z, ktop, htop, hbot - real(r8), intent(in) :: obu, ustar, fac, alpha - - real(r8) :: kexp, klin, kcob - - kexp = ktop*exp(-alpha*(htop-z)/(htop-hbot)) - - klin = ktop*z/htop - kcob = 1./(fac/klin + (1.-fac)/kmoninobuk(0.,obu,ustar,z)) - - kdiff = kexp - kcob - - RETURN - END FUNCTION kdiff - - - SUBROUTINE cal_z0_displa (lai, h, fc, z0, displa) - - USE MOD_Const_Physical, only: vonkar - IMPLICIT NONE - - real(r8), intent(in) :: lai - real(r8), intent(in) :: h - real(r8), intent(in) :: fc - real(r8), intent(out) :: z0 - real(r8), intent(out) :: displa - - real(r8), parameter :: Cd = 0.2 !leaf drag coefficient - real(r8), parameter :: cd1 = 7.5 !a free parameter for d/h calculation, Raupach 1992, 1994 - real(r8), parameter :: psih = 0.193 !psih = ln(cw) - 1 + cw^-1, cw = 2, Raupach 1994 - - ! local variables - real(r8) :: fai, sqrtdragc, temp1, delta , lai0 - - ! when assume z0=0.01, displa=0 - ! to calculate lai0, delta displa - !---------------------------------------------------- - sqrtdragc = -vonkar/(log(0.01/h) - psih) - sqrtdragc = max(sqrtdragc, 0.0031**0.5) - IF (sqrtdragc .le. 0.3) THEN - fai = (sqrtdragc**2-0.003) / 0.3 - fai = min(fai, fc*(1-exp(-20.))) - ELSE - fai = 0.29 - print *, "z0m, displa error!" - ENDIF - - ! calculate delta displa when z0 = 0.01 - lai0 = -log(1.-fai/fc)/0.5 - temp1 = (2.*cd1*fai)**0.5 - delta = -h * ( fc*1.1*log(1. + (Cd*lai0*fc)**0.25) + & - (1.-fc)*(1.-(1.-exp(-temp1))/temp1) ) - - ! calculate z0m, displa - !---------------------------------------------------- - ! NOTE: potential bug below, only apply for spheric - ! crowns. For other cases, fc*(...) ==> a*fc*(...) - fai = fc*(1. - exp(-0.5*lai)) - sqrtdragc = min( (0.003+0.3*fai)**0.5, 0.3 ) - temp1 = (2.*cd1*fai)**0.5 - - IF (lai > lai0) THEN - displa = delta + h*( & - ( fc)*1.1*log(1. + (Cd*lai*fc)**0.25) + & - (1-fc)*(1.-(1.-exp(-temp1))/temp1) ) - ELSE - displa = h*( & - ( fc)*1.1*log(1. + (Cd*lai*fc)**0.25) + & - (1-fc)*(1.-(1.-exp(-temp1))/temp1) ) - ENDIF - - displa = max(displa, 0.) - z0 = (h-displa) * exp(-vonkar/sqrtdragc + psih) - - IF (z0 < 0.01) THEN - z0 = 0.01 - displa = 0. - ENDIF - - END SUBROUTINE cal_z0_displa + IF (rootn == 0) THEN !no root + kint = kint + fkint(ktop, ztop, zbot, htop, hbot, & + z0h, obu, ustar, fac, alpha, bee, fc) + ENDIF + + IF (rootn == 1) THEN + kint = kint + fkint(ktop, ztop, roots(1), htop, hbot, & + z0h, obu, ustar, fac, alpha, bee, fc) + kint = kint + fkint(ktop, roots(1), zbot, htop, hbot, & + z0h, obu, ustar, fac, alpha, bee, fc) + ENDIF + + IF (rootn == 2) THEN + kint = kint + fkint(ktop, ztop, roots(1), htop, hbot, & + z0h, obu, ustar, fac, alpha, bee, fc) + kint = kint + fkint(ktop, roots(1), roots(2), htop, hbot, & + z0h, obu, ustar, fac, alpha, bee, fc) + kint = kint + fkint(ktop, roots(2), zbot, htop, hbot, & + z0h, obu, ustar, fac, alpha, bee, fc) + ENDIF + + frd = kint + + RETURN + END FUNCTION frd + + + real(r8) FUNCTION fkint(ktop, ztop, zbot, htop, hbot, & + z0h, obu, ustar, fac, alpha, bee, fc) + + USE MOD_Precision + USE MOD_FrictionVelocity + IMPLICIT NONE + + real(r8), intent(in) :: ktop, ztop, zbot + real(r8), intent(in) :: htop, hbot + real(r8), intent(in) :: z0h, obu, ustar, fac, alpha + real(r8), intent(in) :: bee, fc + + ! local variables + real(r8) :: fkexpint, fkcobint + + !NOTE: + ! klin = ktop*z/htop + ! kcob = 1./(fac/klin + (1.-fac)/kmoninobuk(0.,obu,ustar,z)) + fkcobint = fac*htop/ktop*(log(ztop)-log(zbot)) +& + (1.-fac)*kintmoninobuk(0.,z0h,obu,ustar,ztop,zbot) + + IF (kdiff((ztop+zbot)/2.,ktop,htop,hbot,obu,ustar,fac,alpha) <= 0) THEN + ! kexp is smaller + IF (alpha > 0) THEN + fkexpint = -(htop-hbot)/alpha/ktop*( & + exp(alpha*(htop-ztop)/(htop-hbot))-& + exp(alpha*(htop-zbot)/(htop-hbot)) ) + ELSE + fkexpint = (ztop-zbot)/ktop + ENDIF + + fkint = bee*fc*fkexpint + (1.-bee*fc)*fkcobint + ELSE + ! kcob is smaller + fkint = fkcobint + ENDIF + + RETURN + END FUNCTION fkint + + + RECURSIVE SUBROUTINE kfindroots(ztop,zbot,zmid, & + ktop, htop, hbot, obu, ustar, fac, alpha, roots, rootn) + + USE MOD_Precision + IMPLICIT NONE + + real(r8), intent(in) :: ztop, zbot, zmid + real(r8), intent(in) :: ktop, htop, hbot + real(r8), intent(in) :: obu, ustar, fac, alpha + + real(r8), intent(inout) :: roots(2) + integer, intent(inout) :: rootn + + ! local variables + real(r8) :: kdiff_ub, kdiff_lb + + !print *, "*** CALL recursive SUBROUTINE kfindroots!!" + kdiff_ub = kdiff(ztop,ktop,htop,hbot,obu,ustar,fac,alpha) + kdiff_lb = kdiff(zmid,ktop,htop,hbot,obu,ustar,fac,alpha) + + IF (kdiff_ub*kdiff_lb == 0) THEN + IF (kdiff_lb == 0) THEN !root found + rootn = rootn + 1 + IF (rootn > 2) THEN + print *, "K root number > 2, abort!" + CALL abort + ENDIF + roots(rootn) = zmid + ENDIF + ELSE IF (kdiff_ub*kdiff_lb < 0) THEN + IF (ztop-zmid < 0.01) THEN + rootn = rootn + 1 !root found + IF (rootn > 2) THEN + print *, "K root number > 2, abort!" + CALL abort + ENDIF + roots(rootn) = (ztop+zmid)/2. + ELSE + CALL kfindroots(ztop,zmid,(ztop+zmid)/2., & + ktop, htop, hbot, obu, ustar, fac, alpha, roots, rootn) + ENDIF + ENDIF + + kdiff_ub = kdiff(zmid,ktop,htop,hbot,obu,ustar,fac,alpha) + kdiff_lb = kdiff(zbot,ktop,htop,hbot,obu,ustar,fac,alpha) + + IF (kdiff_ub*kdiff_lb == 0) THEN + IF (kdiff_ub == 0) THEN !root found + rootn = rootn + 1 + IF (rootn > 2) THEN + print *, "K root number > 2, abort!" + CALL abort + ENDIF + roots(rootn) = zmid + ENDIF + ELSE IF (kdiff_ub*kdiff_lb < 0) THEN + IF (zmid-zbot < 0.01) THEN + rootn = rootn + 1 !root found + IF (rootn > 2) THEN + print *, "K root number > 2, abort!" + CALL abort + ENDIF + roots(rootn) = (zmid+zbot)/2. + ELSE + CALL kfindroots(zmid,zbot,(zmid+zbot)/2., & + ktop, htop, hbot, obu, ustar, fac, alpha, roots, rootn) + ENDIF + ENDIF + END SUBROUTINE kfindroots + + + real(r8) FUNCTION kdiff(z, ktop, htop, hbot, & + obu, ustar, fac, alpha) + + USE MOD_Precision + USE MOD_FrictionVelocity + IMPLICIT NONE + + real(r8), intent(in) :: z, ktop, htop, hbot + real(r8), intent(in) :: obu, ustar, fac, alpha + + real(r8) :: kexp, klin, kcob + + kexp = ktop*exp(-alpha*(htop-z)/(htop-hbot)) + + klin = ktop*z/htop + kcob = 1./(fac/klin + (1.-fac)/kmoninobuk(0.,obu,ustar,z)) + + kdiff = kexp - kcob + + RETURN + END FUNCTION kdiff + + + SUBROUTINE cal_z0_displa (lai, h, fc, z0, displa) + + USE MOD_Const_Physical, only: vonkar + IMPLICIT NONE + + real(r8), intent(in) :: lai + real(r8), intent(in) :: h + real(r8), intent(in) :: fc + real(r8), intent(out) :: z0 + real(r8), intent(out) :: displa + + real(r8), parameter :: Cd = 0.2 !leaf drag coefficient + real(r8), parameter :: cd1 = 7.5 !a free parameter for d/h calculation, Raupach 1992, 1994 + real(r8), parameter :: psih = 0.193 !psih = ln(cw) - 1 + cw^-1, cw = 2, Raupach 1994 + + ! local variables + real(r8) :: fai, sqrtdragc, temp1, delta , lai0 + + ! when assume z0=0.01, displa=0 + ! to calculate lai0, delta displa + !---------------------------------------------------- + sqrtdragc = -vonkar/(log(0.01/h) - psih) + sqrtdragc = max(sqrtdragc, 0.0031**0.5) + IF (sqrtdragc .le. 0.3) THEN + fai = (sqrtdragc**2-0.003) / 0.3 + fai = min(fai, fc*(1-exp(-20.))) + ELSE + fai = 0.29 + print *, "z0m, displa error!" + ENDIF + + ! calculate delta displa when z0 = 0.01 + lai0 = -log(1.-fai/fc)/0.5 + temp1 = (2.*cd1*fai)**0.5 + delta = -h * ( fc*1.1*log(1. + (Cd*lai0*fc)**0.25) + & + (1.-fc)*(1.-(1.-exp(-temp1))/temp1) ) + + ! calculate z0m, displa + !---------------------------------------------------- + ! NOTE: potential bug below, only apply for spheric + ! crowns. For other cases, fc*(...) ==> a*fc*(...) + fai = fc*(1. - exp(-0.5*lai)) + sqrtdragc = min( (0.003+0.3*fai)**0.5, 0.3 ) + temp1 = (2.*cd1*fai)**0.5 + + IF (lai > lai0) THEN + displa = delta + h*( & + ( fc)*1.1*log(1. + (Cd*lai*fc)**0.25) + & + (1-fc)*(1.-(1.-exp(-temp1))/temp1) ) + ELSE + displa = h*( & + ( fc)*1.1*log(1. + (Cd*lai*fc)**0.25) + & + (1-fc)*(1.-(1.-exp(-temp1))/temp1) ) + ENDIF + + displa = max(displa, 0.) + z0 = (h-displa) * exp(-vonkar/sqrtdragc + psih) + + IF (z0 < 0.01) THEN + z0 = 0.01 + displa = 0. + ENDIF + + END SUBROUTINE cal_z0_displa END MODULE MOD_CanopyLayerProfile diff --git a/main/MOD_Const_LC.F90 b/main/MOD_Const_LC.F90 index 9828033d..a6d458a2 100644 --- a/main/MOD_Const_LC.F90 +++ b/main/MOD_Const_LC.F90 @@ -657,9 +657,9 @@ MODULE MOD_Const_LC SUBROUTINE Init_LC_Const - IMPLICIT NONE + IMPLICIT NONE - integer :: i, nsl + integer :: i, nsl #ifdef LULC_USGS patchtypes (:) = patchtypes_usgs (:) diff --git a/main/MOD_Const_PFT.F90 b/main/MOD_Const_PFT.F90 index 2f6a35bd..73003391 100644 --- a/main/MOD_Const_PFT.F90 +++ b/main/MOD_Const_PFT.F90 @@ -104,7 +104,7 @@ MODULE MOD_Const_PFT !78 irrigated_tropical_soybean ! canopy layer number - INTEGER , parameter :: canlay_p(0:N_PFT+N_CFT-1) & + integer , parameter :: canlay_p(0:N_PFT+N_CFT-1) & = (/0, 2, 2, 2, 2, 2, 2, 2 & , 2, 1, 1, 1, 1, 1, 1, 1 & #ifdef CROP @@ -120,7 +120,7 @@ MODULE MOD_Const_PFT /) ! canopy top height - REAL(r8), parameter :: htop0_p(0:N_PFT+N_CFT-1) & + real(r8), parameter :: htop0_p(0:N_PFT+N_CFT-1) & =(/ 0.5, 17.0, 17.0, 14.0, 35.0, 35.0, 18.0, 20.0& ,20.0, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5& #ifdef CROP @@ -137,7 +137,7 @@ MODULE MOD_Const_PFT ! canopy bottom height ! 01/06/2020, yuan: adjust htop: grass/shrub -> 0, tree->1 - REAL(r8), parameter :: hbot0_p(0:N_PFT+N_CFT-1) & + real(r8), parameter :: hbot0_p(0:N_PFT+N_CFT-1) & !TODO: check the setting values !=(/0.01, 8.5, 8.5, 7.0, 1.0, 1.0, 10.0, 11.5& ! 11.5, 0.1, 0.1, 0.1, 0.01, 0.01, 0.01, 0.01/) @@ -156,11 +156,11 @@ MODULE MOD_Const_PFT /) ! defulat vegetation fractional cover - REAL(r8), parameter :: fveg0_p(0:N_PFT+N_CFT-1) & + real(r8), parameter :: fveg0_p(0:N_PFT+N_CFT-1) & = 1.0 !(/.../) ! default stem area index - REAL(r8), parameter :: sai0_p(0:N_PFT+N_CFT-1) & + real(r8), parameter :: sai0_p(0:N_PFT+N_CFT-1) & =(/0.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0& , 2.0, 0.5, 0.5, 0.5, 0.2, 0.2, 0.2, 0.2& #ifdef CROP @@ -176,16 +176,16 @@ MODULE MOD_Const_PFT /) ! ratio to calculate roughness length z0m - REAL(r8), parameter :: z0mr_p(0:N_PFT+N_CFT-1) = 0.1 + real(r8), parameter :: z0mr_p(0:N_PFT+N_CFT-1) = 0.1 ! ratio to calculate displacement height d - REAL(r8), parameter :: displar_p(0:N_PFT+N_CFT-1) = 0.667 + real(r8), parameter :: displar_p(0:N_PFT+N_CFT-1) = 0.667 ! inverse&sqrt leaf specific dimension size 4 cm - REAL(r8), parameter :: sqrtdi_p(0:N_PFT+N_CFT-1) = 5.0 + real(r8), parameter :: sqrtdi_p(0:N_PFT+N_CFT-1) = 5.0 ! leaf angle distribution parameter - REAL(r8), parameter :: chil_p(0:N_PFT+N_CFT-1) & + real(r8), parameter :: chil_p(0:N_PFT+N_CFT-1) & = (/-0.300, 0.010, 0.010, 0.010, 0.100, 0.100, 0.010, 0.250& , 0.250, 0.010, 0.250, 0.250, -0.300, -0.300, -0.300, -0.300& #ifdef CROP @@ -203,11 +203,11 @@ MODULE MOD_Const_PFT ! reflectance of green leaf in virsible band #if(defined LULC_IGBP_PC) ! Leaf optical properties adapted from measured data (Dong et al., 2021) - REAL(r8), parameter :: rhol_vis_p(0:N_PFT+N_CFT-1) & + real(r8), parameter :: rhol_vis_p(0:N_PFT+N_CFT-1) & = (/0.110, 0.070, 0.070, 0.070, 0.100, 0.110, 0.100, 0.100& , 0.100, 0.070, 0.100, 0.100, 0.110, 0.110, 0.110, 0.110& #else - REAL(r8), parameter :: rhol_vis_p(0:N_PFT+N_CFT-1) & + real(r8), parameter :: rhol_vis_p(0:N_PFT+N_CFT-1) & = (/0.110, 0.070, 0.070, 0.070, 0.100, 0.100, 0.100, 0.100& , 0.100, 0.070, 0.100, 0.100, 0.110, 0.110, 0.110, 0.110& #endif @@ -224,7 +224,7 @@ MODULE MOD_Const_PFT /) ! reflectance of dead leaf in virsible band - REAL(r8), parameter :: rhos_vis_p(0:N_PFT+N_CFT-1) & + real(r8), parameter :: rhos_vis_p(0:N_PFT+N_CFT-1) & = (/0.310, 0.160, 0.160, 0.160, 0.160, 0.160, 0.160, 0.160& , 0.160, 0.160, 0.160, 0.160, 0.310, 0.310, 0.310, 0.310& #ifdef CROP @@ -242,11 +242,11 @@ MODULE MOD_Const_PFT ! reflectance of green leaf in near infrared band #if(defined LULC_IGBP_PC) ! Leaf optical properties adapted from measured data (Dong et al., 2021) - REAL(r8), parameter :: rhol_nir_p(0:N_PFT+N_CFT-1) & + real(r8), parameter :: rhol_nir_p(0:N_PFT+N_CFT-1) & = (/0.350, 0.360, 0.370, 0.360, 0.450, 0.460, 0.450, 0.420& , 0.450, 0.350, 0.450, 0.450, 0.350, 0.350, 0.350, 0.350& #else - REAL(r8), parameter :: rhol_nir_p(0:N_PFT+N_CFT-1) & + real(r8), parameter :: rhol_nir_p(0:N_PFT+N_CFT-1) & = (/0.350, 0.350, 0.350, 0.350, 0.450, 0.450, 0.450, 0.450& , 0.450, 0.350, 0.450, 0.450, 0.350, 0.350, 0.350, 0.350& #endif @@ -263,7 +263,7 @@ MODULE MOD_Const_PFT /) ! reflectance of dead leaf in near infrared band - REAL(r8), parameter :: rhos_nir_p(0:N_PFT+N_CFT-1) & + real(r8), parameter :: rhos_nir_p(0:N_PFT+N_CFT-1) & = (/0.530, 0.390, 0.390, 0.390, 0.390, 0.390, 0.390, 0.390& , 0.390, 0.390, 0.390, 0.390, 0.530, 0.530, 0.530, 0.530& #ifdef CROP @@ -281,11 +281,11 @@ MODULE MOD_Const_PFT ! transmittance of green leaf in visible band #if(defined LULC_IGBP_PC) ! Leaf optical properties adpated from measured data (Dong et al., 2021) - REAL(r8), parameter :: taul_vis_p(0:N_PFT+N_CFT-1) & + real(r8), parameter :: taul_vis_p(0:N_PFT+N_CFT-1) & = (/0.050, 0.050, 0.050, 0.050, 0.050, 0.060, 0.050, 0.060& , 0.050, 0.050, 0.050, 0.050, 0.050, 0.050, 0.050, 0.050& #else - REAL(r8), parameter :: taul_vis_p(0:N_PFT+N_CFT-1) & + real(r8), parameter :: taul_vis_p(0:N_PFT+N_CFT-1) & = (/0.050, 0.050, 0.050, 0.050, 0.050, 0.050, 0.050, 0.050& , 0.050, 0.050, 0.050, 0.050, 0.050, 0.050, 0.050, 0.050& #endif @@ -302,7 +302,7 @@ MODULE MOD_Const_PFT /) ! transmittance of dead leaf in visible band - REAL(r8), parameter :: taus_vis_p(0:N_PFT+N_CFT-1) & + real(r8), parameter :: taus_vis_p(0:N_PFT+N_CFT-1) & = (/0.120, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001& , 0.001, 0.001, 0.001, 0.001, 0.120, 0.120, 0.120, 0.120& #ifdef CROP @@ -320,11 +320,11 @@ MODULE MOD_Const_PFT ! transmittance of green leaf in near infrared band #if(defined LULC_IGBP_PC) ! Leaf optical properties adapted from measured data (Dong et al., 2021) - REAL(r8), parameter :: taul_nir_p(0:N_PFT+N_CFT-1) & + real(r8), parameter :: taul_nir_p(0:N_PFT+N_CFT-1) & = (/0.340, 0.280, 0.290, 0.380, 0.250, 0.330, 0.250, 0.430& , 0.400, 0.100, 0.250, 0.250, 0.340, 0.340, 0.340, 0.340& #else - REAL(r8), parameter :: taul_nir_p(0:N_PFT+N_CFT-1) & + real(r8), parameter :: taul_nir_p(0:N_PFT+N_CFT-1) & = (/0.340, 0.100, 0.100, 0.100, 0.250, 0.250, 0.250, 0.250& , 0.250, 0.100, 0.250, 0.250, 0.340, 0.340, 0.340, 0.340& #endif @@ -341,7 +341,7 @@ MODULE MOD_Const_PFT /) ! transmittance of dead leaf in near infrared band - REAL(r8), parameter :: taus_nir_p(0:N_PFT+N_CFT-1) & + real(r8), parameter :: taus_nir_p(0:N_PFT+N_CFT-1) & = (/0.250, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001& , 0.001, 0.001, 0.001, 0.001, 0.250, 0.250, 0.250, 0.250& #ifdef CROP @@ -358,11 +358,11 @@ MODULE MOD_Const_PFT ! maximum carboxylation rate at 25 C at canopy top ! /06/03/2014/ based on Bonan et al., 2011 (Table 2) - !REAL(r8), parameter :: vmax25_p(0:N_PFT+N_CFT-1) & + !real(r8), parameter :: vmax25_p(0:N_PFT+N_CFT-1) & ! = (/ 52.0, 61.0, 54.0, 57.0, 72.0, 72.0, 52.0, 52.0& ! , 52.0, 72.0, 52.0, 52.0, 52.0, 52.0, 52.0, 57.0& ! /07/27/2022/ based on Bonan et al., 2011 (Table 2, VmaxF(N)) - REAL(r8), parameter :: vmax25_p(0:N_PFT+N_CFT-1) & + real(r8), parameter :: vmax25_p(0:N_PFT+N_CFT-1) & = (/ 52.0, 55.0, 42.0, 29.0, 41.0, 51.0, 36.0, 30.0& , 40.0, 36.0, 30.0, 19.0, 21.0, 26.0, 25.0, 57.0& #ifdef CROP @@ -378,7 +378,7 @@ MODULE MOD_Const_PFT /) * 1.e-6 ! quantum efficiency - REAL(r8), parameter :: effcon_p(0:N_PFT+N_CFT-1) & + real(r8), parameter :: effcon_p(0:N_PFT+N_CFT-1) & = (/0.08, 0.08, 0.08, 0.08, 0.08, 0.08, 0.08, 0.08& , 0.08, 0.08, 0.08, 0.08, 0.08, 0.08, 0.05, 0.08& #ifdef CROP @@ -394,7 +394,7 @@ MODULE MOD_Const_PFT /) ! conductance-photosynthesis slope parameter - REAL(r8), parameter :: g1_p(0:N_PFT+N_CFT-1) & + real(r8), parameter :: g1_p(0:N_PFT+N_CFT-1) & = (/4.0, 4.0, 4.0, 4.0, 4.0, 4.0, 4.0, 4.0& , 4.0, 4.0, 4.0, 4.0, 4.0, 4.0, 4.0, 4.0& #ifdef CROP @@ -410,7 +410,7 @@ MODULE MOD_Const_PFT /) ! conductance-photosynthesis intercept - REAL(r8), parameter :: g0_p(0:N_PFT+N_CFT-1) & + real(r8), parameter :: g0_p(0:N_PFT+N_CFT-1) & = (/100, 100, 100, 100, 100, 100, 100, 100& , 100, 100, 100, 100, 100, 100, 100, 100& #ifdef CROP @@ -426,7 +426,7 @@ MODULE MOD_Const_PFT /) ! conductance-photosynthesis slope parameter - REAL(r8), parameter :: gradm_p(0:N_PFT+N_CFT-1) & + real(r8), parameter :: gradm_p(0:N_PFT+N_CFT-1) & = (/9.0, 9.0, 9.0, 9.0, 9.0, 9.0, 9.0, 9.0& , 9.0, 9.0, 9.0, 9.0, 9.0, 9.0, 4.0, 9.0& #ifdef CROP @@ -442,7 +442,7 @@ MODULE MOD_Const_PFT /) ! conductance-photosynthesis intercept - REAL(r8), parameter :: binter_p(0:N_PFT+N_CFT-1) & + real(r8), parameter :: binter_p(0:N_PFT+N_CFT-1) & = (/0.01, 0.01, 0.01, 0.01, 0.01, 0.01, 0.01, 0.01& , 0.01, 0.01, 0.01, 0.01, 0.01, 0.01, 0.04, 0.01& #ifdef CROP @@ -458,7 +458,7 @@ MODULE MOD_Const_PFT /) ! respiration fraction - REAL(r8), parameter :: respcp_p(0:N_PFT+N_CFT-1) & + real(r8), parameter :: respcp_p(0:N_PFT+N_CFT-1) & = (/0.015, 0.015, 0.015, 0.015, 0.015, 0.015, 0.015, 0.015& , 0.015, 0.015, 0.015, 0.015, 0.015, 0.015, 0.025, 0.015& #ifdef CROP @@ -474,22 +474,22 @@ MODULE MOD_Const_PFT /) ! slope of high temperature inhibition FUNCTION (s1) - REAL(r8), parameter :: shti_p(0:N_PFT+N_CFT-1) = 0.3 + real(r8), parameter :: shti_p(0:N_PFT+N_CFT-1) = 0.3 ! slope of low temperature inhibition FUNCTION (s3) - REAL(r8), parameter :: slti_p(0:N_PFT+N_CFT-1) = 0.2 + real(r8), parameter :: slti_p(0:N_PFT+N_CFT-1) = 0.2 ! temperature coefficient in gs-a model (s5) - REAL(r8), parameter :: trda_p(0:N_PFT+N_CFT-1) = 1.3 + real(r8), parameter :: trda_p(0:N_PFT+N_CFT-1) = 1.3 ! temperature coefficient in gs-a model (s6) - REAL(r8), parameter :: trdm_p(0:N_PFT+N_CFT-1) = 328.0 + real(r8), parameter :: trdm_p(0:N_PFT+N_CFT-1) = 328.0 ! temperature coefficient in gs-a model (273.16+25) - REAL(r8), parameter :: trop_p(0:N_PFT+N_CFT-1) = 298.0 + real(r8), parameter :: trop_p(0:N_PFT+N_CFT-1) = 298.0 ! 1/2 point of high temperature inhibition FUNCTION (s2) - REAL(r8), parameter :: hhti_p(0:N_PFT+N_CFT-1) & + real(r8), parameter :: hhti_p(0:N_PFT+N_CFT-1) & =(/308.0, 303.0, 303.0, 303.0, 313.0, 313.0, 311.0, 311.0& ,311.0, 313.0, 313.0, 303.0, 303.0, 308.0, 313.0, 308.0& #ifdef CROP @@ -505,7 +505,7 @@ MODULE MOD_Const_PFT /) ! 1/2 point of low temperature inhibition FUNCTION (s4) - REAL(r8), parameter :: hlti_p(0:N_PFT+N_CFT-1) & + real(r8), parameter :: hlti_p(0:N_PFT+N_CFT-1) & =(/281.0, 278.0, 278.0, 278.0, 288.0, 288.0, 283.0, 283.0& ,283.0, 283.0, 283.0, 278.0, 278.0, 281.0, 288.0, 281.0& #ifdef CROP @@ -521,9 +521,9 @@ MODULE MOD_Const_PFT /) ! coefficient of leaf nitrogen allocation - REAL(r8), parameter :: extkn_p(0:N_PFT+N_CFT-1) = 0.5 + real(r8), parameter :: extkn_p(0:N_PFT+N_CFT-1) = 0.5 - REAL(r8) :: & + real(r8) :: & #ifndef CROP rho_p(2,2,0:N_PFT-1), &!leaf reflectance tau_p(2,2,0:N_PFT-1) !leaf transmittance @@ -533,7 +533,7 @@ MODULE MOD_Const_PFT #endif ! depth at 50% roots - REAL(r8), parameter, dimension(0:N_PFT+N_CFT-1) :: d50_p & + real(r8), parameter, dimension(0:N_PFT+N_CFT-1) :: d50_p & =(/27.0, 21.0, 12.0, 12.0, 15.0, 23.0, 16.0, 23.0& ,12.0, 23.5, 23.5, 23.5, 9.0, 7.0, 16.0, 22.0& #ifdef CROP @@ -549,7 +549,7 @@ MODULE MOD_Const_PFT /) ! coefficient of root profile - REAL(r8), parameter, dimension(0:N_PFT+N_CFT-1) :: beta_p & + real(r8), parameter, dimension(0:N_PFT+N_CFT-1) :: beta_p & =(/-2.051, -1.835, -1.880, -1.880, -1.632, -1.757, -1.681, -1.757& , -1.880, -1.623, -1.623, -1.623, -2.621, -1.176, -1.452, -1.796& #ifdef CROP @@ -565,7 +565,7 @@ MODULE MOD_Const_PFT /) ! woody (1) or grass (0) - INTEGER , parameter, dimension(0:N_PFT+N_CFT-1) :: woody & + integer , parameter, dimension(0:N_PFT+N_CFT-1) :: woody & =(/0, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 0, 0, 0, 0 & #ifdef CROP , 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 & @@ -576,7 +576,7 @@ MODULE MOD_Const_PFT /) ! Set the root distribution parameters of PFT - REAL(r8), PRIVATE, parameter :: roota(0:N_PFT+N_CFT-1) & + real(r8), PRIVATE, parameter :: roota(0:N_PFT+N_CFT-1) & =(/ 0.0, 7.0, 7.0, 7.0, 7.0, 7.0, 6.0, 6.0& , 6.0, 7.0, 7.0, 7.0, 11.0, 11.0, 11.0, 6.0& #ifdef CROP @@ -591,7 +591,7 @@ MODULE MOD_Const_PFT #endif /) - REAL(r8), PRIVATE, parameter :: rootb(0:N_PFT+N_CFT-1) & + real(r8), PRIVATE, parameter :: rootb(0:N_PFT+N_CFT-1) & =(/ 0.0, 2.0, 2.0, 2.0, 1.0, 1.0, 2.0, 2.0& , 2.0, 1.5, 1.5, 1.5, 2.0, 2.0, 2.0, 3.0& #ifdef CROP @@ -609,31 +609,31 @@ MODULE MOD_Const_PFT ! bgc PFT constants - REAL(r8), parameter, dimension(0:N_PFT+N_CFT-1) :: grperc = 0.11_r8 + real(r8), parameter, dimension(0:N_PFT+N_CFT-1) :: grperc = 0.11_r8 - REAL(r8), parameter, dimension(0:N_PFT+N_CFT-1) :: grpnow = 1._r8 + real(r8), parameter, dimension(0:N_PFT+N_CFT-1) :: grpnow = 1._r8 - REAL(r8), parameter, dimension(0:N_PFT+N_CFT-1) :: lf_flab = 0.25_r8 + real(r8), parameter, dimension(0:N_PFT+N_CFT-1) :: lf_flab = 0.25_r8 - REAL(r8), parameter, dimension(0:N_PFT+N_CFT-1) :: lf_fcel = 0.5_r8 + real(r8), parameter, dimension(0:N_PFT+N_CFT-1) :: lf_fcel = 0.5_r8 - REAL(r8), parameter, dimension(0:N_PFT+N_CFT-1) :: lf_flig = 0.25_r8 + real(r8), parameter, dimension(0:N_PFT+N_CFT-1) :: lf_flig = 0.25_r8 - REAL(r8), parameter, dimension(0:N_PFT+N_CFT-1) :: fr_flab = 0.25_r8 + real(r8), parameter, dimension(0:N_PFT+N_CFT-1) :: fr_flab = 0.25_r8 - REAL(r8), parameter, dimension(0:N_PFT+N_CFT-1) :: fr_fcel = 0.5_r8 + real(r8), parameter, dimension(0:N_PFT+N_CFT-1) :: fr_fcel = 0.5_r8 - REAL(r8), parameter, dimension(0:N_PFT+N_CFT-1) :: fr_flig = 0.25_r8 + real(r8), parameter, dimension(0:N_PFT+N_CFT-1) :: fr_flig = 0.25_r8 - LOGICAL , parameter, dimension(0:N_PFT+N_CFT-1) :: isshrub & ! True => is a shrub + logical , parameter, dimension(0:N_PFT+N_CFT-1) :: isshrub & ! True => is a shrub =(/.False., .False., .False., .False., .False., .False., .False., .False. & , .False., .True., .True., .True., .False., .False., .False., .False. & #ifdef CROP @@ -648,7 +648,7 @@ MODULE MOD_Const_PFT #endif /) - LOGICAL , parameter, dimension(0:N_PFT+N_CFT-1) :: isgrass & ! True => is a grass + logical , parameter, dimension(0:N_PFT+N_CFT-1) :: isgrass & ! True => is a grass =(/.False., .False., .False., .False., .False., .False., .False., .False. & , .False., .False., .False., .False., .True., .True., .True., .False. & #ifdef CROP @@ -663,7 +663,7 @@ MODULE MOD_Const_PFT #endif /) - LOGICAL , parameter, dimension(0:N_PFT+N_CFT-1) :: isbetr & ! True => is tropical broadleaf evergreen tree + logical , parameter, dimension(0:N_PFT+N_CFT-1) :: isbetr & ! True => is tropical broadleaf evergreen tree =(/.False., .False., .False., .False., .True., .False., .False., .False. & , .False., .False., .False., .False., .False., .False., .False., .False. & #ifdef CROP @@ -678,7 +678,7 @@ MODULE MOD_Const_PFT #endif /) - LOGICAL , parameter, dimension(0:N_PFT+N_CFT-1) :: isbdtr & ! True => is a broadleaf deciduous tree + logical , parameter, dimension(0:N_PFT+N_CFT-1) :: isbdtr & ! True => is a broadleaf deciduous tree =(/.False., .False., .False., .False., .False., .False., .True., .False. & , .False., .False., .False., .False., .False., .False., .False., .False. & #ifdef CROP @@ -693,7 +693,7 @@ MODULE MOD_Const_PFT #endif /) - LOGICAL , parameter, dimension(0:N_PFT+N_CFT-1) :: isevg & ! True => is a evergreen tree + logical , parameter, dimension(0:N_PFT+N_CFT-1) :: isevg & ! True => is a evergreen tree =(/.False., .True., .True., .False., .True., .True., .False., .False. & , .False., .True., .False., .False., .False., .False., .False., .False. & #ifdef CROP @@ -708,7 +708,7 @@ MODULE MOD_Const_PFT #endif /) - LOGICAL , parameter, dimension(0:N_PFT+N_CFT-1) :: issed & ! True => is a seasonal deciduous tree + logical , parameter, dimension(0:N_PFT+N_CFT-1) :: issed & ! True => is a seasonal deciduous tree =(/.False., .False., .False., .True., .False., .False., .False., .True. & , .True., .False., .False., .True., .True., .False., .False., .False. & #ifdef CROP @@ -723,7 +723,7 @@ MODULE MOD_Const_PFT #endif /) - LOGICAL , parameter, dimension(0:N_PFT+N_CFT-1) :: isstd & ! True => is a stress deciduous tree + logical , parameter, dimension(0:N_PFT+N_CFT-1) :: isstd & ! True => is a stress deciduous tree =(/.False., .False., .False., .False., .False., .False., .True., .False. & , .False., .False., .True., .False., .False., .True., .True., .True. & #ifdef CROP @@ -738,7 +738,7 @@ MODULE MOD_Const_PFT #endif /) - LOGICAL , parameter, dimension(0:N_PFT+N_CFT-1) :: isbare & ! True => is a bare land + logical , parameter, dimension(0:N_PFT+N_CFT-1) :: isbare & ! True => is a bare land =(/.True., .False., .False., .False., .False., .False., .False., .False. & , .False., .False., .False., .False., .False., .False., .False., .False. & #ifdef CROP @@ -753,7 +753,7 @@ MODULE MOD_Const_PFT #endif /) - LOGICAL , parameter, dimension(0:N_PFT+N_CFT-1) :: iscrop & ! True => is a crop land + logical , parameter, dimension(0:N_PFT+N_CFT-1) :: iscrop & ! True => is a crop land =(/.False., .False., .False., .False., .False., .False., .False., .False. & , .False., .False., .False., .False., .False., .False., .False., .True. & #ifdef CROP @@ -768,7 +768,7 @@ MODULE MOD_Const_PFT #endif /) - LOGICAL , parameter, dimension(0:N_PFT+N_CFT-1) :: isnatveg &! True => is a natural vegetation + logical , parameter, dimension(0:N_PFT+N_CFT-1) :: isnatveg &! True => is a natural vegetation =(/.False., .True., .True., .True., .True., .True., .True., .True. & , .True., .True., .True., .True., .True., .True., .True., .False. & #ifdef CROP @@ -783,7 +783,7 @@ MODULE MOD_Const_PFT #endif /) - REAL(r8), parameter, dimension(0:N_PFT+N_CFT-1) :: fsr_pft & + real(r8), parameter, dimension(0:N_PFT+N_CFT-1) :: fsr_pft & =(/ 0., 0.26, 0.26, 0.26, 0.25, 0.25, 0.25, 0.25 & , 0.25, 0.28, 0.28, 0.28, 0.33, 0.33, 0.33, 0.33 & #ifdef CROP @@ -798,7 +798,7 @@ MODULE MOD_Const_PFT #endif /) - REAL(r8), parameter, dimension(0:N_PFT+N_CFT-1) :: fd_pft & + real(r8), parameter, dimension(0:N_PFT+N_CFT-1) :: fd_pft & =(/ 0., 24., 24., 24., 24., 24., 24., 24. & , 24., 24., 24., 24., 24., 24., 24., 24. & #ifdef CROP @@ -813,7 +813,7 @@ MODULE MOD_Const_PFT #endif /) - REAL(r8), parameter, dimension(0:N_PFT+N_CFT-1) :: leafcn & + real(r8), parameter, dimension(0:N_PFT+N_CFT-1) :: leafcn & =(/ 1., 58., 58., 25.8131130614352 & , 29.603315571344, 29.603315571344, 23.4521575984991, 23.4521575984991 & , 23.4521575984991, 36.4166059723234, 23.2558139534884, 23.2558139534884 & @@ -838,7 +838,7 @@ MODULE MOD_Const_PFT #endif /) - REAL(r8), parameter, dimension(0:N_PFT+N_CFT-1) :: frootcn & + real(r8), parameter, dimension(0:N_PFT+N_CFT-1) :: frootcn & =(/ 1., 42., 42., 42., 42., 42., 42., 42.& , 42., 42., 42., 42., 42., 42., 42., 42.& #ifdef CROP @@ -853,7 +853,7 @@ MODULE MOD_Const_PFT #endif /) - REAL(r8), parameter, dimension(0:N_PFT+N_CFT-1) :: livewdcn & + real(r8), parameter, dimension(0:N_PFT+N_CFT-1) :: livewdcn & =(/ 1., 50., 50., 50., 50., 50., 50., 50.& , 50., 50., 50., 50., 0., 0., 0., 0.& #ifdef CROP @@ -868,7 +868,7 @@ MODULE MOD_Const_PFT #endif /) - REAL(r8), parameter, dimension(0:N_PFT+N_CFT-1) :: deadwdcn & + real(r8), parameter, dimension(0:N_PFT+N_CFT-1) :: deadwdcn & =(/ 1., 500., 500., 500., 500., 500., 500., 500.& , 500., 500., 500., 500., 0., 0., 0., 0.& #ifdef CROP @@ -883,7 +883,7 @@ MODULE MOD_Const_PFT #endif /) - REAL(r8), parameter, dimension(0:N_PFT+N_CFT-1) :: graincn & + real(r8), parameter, dimension(0:N_PFT+N_CFT-1) :: graincn & =(/-999., -999., -999., -999., -999., -999., -999., -999.& , -999., -999., -999., -999., -999., -999., -999., -999.& #ifdef CROP @@ -898,7 +898,7 @@ MODULE MOD_Const_PFT #endif /) - REAL(r8), parameter, dimension(0:N_PFT+N_CFT-1) :: lflitcn & + real(r8), parameter, dimension(0:N_PFT+N_CFT-1) :: lflitcn & =(/ 1., 70., 80., 50., 60., 60., 50., 50.& , 50., 60., 50., 50., 50., 50., 50., 50.& #ifdef CROP @@ -913,7 +913,7 @@ MODULE MOD_Const_PFT #endif /) - REAL(r8), parameter, dimension(0:N_PFT+N_CFT-1) :: leaf_long & + real(r8), parameter, dimension(0:N_PFT+N_CFT-1) :: leaf_long & =(/ 0., 3.30916666666667, 3.30916666666667, 0.506666666666667& , 1.4025, 1.4025, 0.48333333333333, 0.483333333333333& , 0.483333333333333, 1.32333333333333, 0.39, 0.39& @@ -938,7 +938,7 @@ MODULE MOD_Const_PFT #endif /) - REAL(r8), parameter, dimension(0:N_PFT+N_CFT-1) :: cc_leaf & + real(r8), parameter, dimension(0:N_PFT+N_CFT-1) :: cc_leaf & =(/ 0., 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8& , 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8& #ifdef CROP @@ -953,7 +953,7 @@ MODULE MOD_Const_PFT #endif /) - REAL(r8), parameter, dimension(0:N_PFT+N_CFT-1) :: cc_lstem & + real(r8), parameter, dimension(0:N_PFT+N_CFT-1) :: cc_lstem & =(/ 0., 0.3, 0.3, 0.3, 0.27, 0.27, 0.27, 0.27& , 0.27, 0.35, 0.35, 0.35, 0.8, 0.8, 0.8, 0.8& #ifdef CROP @@ -968,7 +968,7 @@ MODULE MOD_Const_PFT #endif /) - REAL(r8), parameter, dimension(0:N_PFT+N_CFT-1) :: cc_dstem & + real(r8), parameter, dimension(0:N_PFT+N_CFT-1) :: cc_dstem & =(/ 0., 0.3, 0.3, 0.3, 0.27, 0.27, 0.27, 0.27& , 0.27, 0.35, 0.35, 0.35, 0.8, 0.8, 0.8, 0.8& #ifdef CROP @@ -983,7 +983,7 @@ MODULE MOD_Const_PFT #endif /) - REAL(r8), parameter, dimension(0:N_PFT+N_CFT-1) :: cc_other & + real(r8), parameter, dimension(0:N_PFT+N_CFT-1) :: cc_other & =(/ 0., 0.5, 0.5, 0.5, 0.45, 0.45, 0.45, 0.45& , 0.45, 0.55, 0.55, 0.55, 0.8, 0.8, 0.8, 0.8& #ifdef CROP @@ -998,7 +998,7 @@ MODULE MOD_Const_PFT #endif /) - REAL(r8), parameter, dimension(0:N_PFT+N_CFT-1) :: fm_leaf & + real(r8), parameter, dimension(0:N_PFT+N_CFT-1) :: fm_leaf & =(/ 0., 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8& , 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8& #ifdef CROP @@ -1013,7 +1013,7 @@ MODULE MOD_Const_PFT #endif /) - REAL(r8), parameter, dimension(0:N_PFT+N_CFT-1) :: fm_lstem & + real(r8), parameter, dimension(0:N_PFT+N_CFT-1) :: fm_lstem & =(/ 0., 0.5, 0.5, 0.5, 0.45, 0.45, 0.35, 0.35& , 0.45, 0.55, 0.55, 0.55, 0.8, 0.8, 0.8, 0.8& #ifdef CROP @@ -1028,7 +1028,7 @@ MODULE MOD_Const_PFT #endif /) - REAL(r8), parameter, dimension(0:N_PFT+N_CFT-1) :: fm_lroot & + real(r8), parameter, dimension(0:N_PFT+N_CFT-1) :: fm_lroot & =(/ 0., 0.15, 0.15, 0.15, 0.13, 0.13, 0.1, 0.1& , 0.13, 0.17, 0.17, 0.17, 0.2, 0.2, 0.2, 0.2& #ifdef CROP @@ -1043,7 +1043,7 @@ MODULE MOD_Const_PFT #endif /) - REAL(r8), parameter, dimension(0:N_PFT+N_CFT-1) :: fm_root & + real(r8), parameter, dimension(0:N_PFT+N_CFT-1) :: fm_root & =(/ 0., 0.15, 0.15, 0.15, 0.13, 0.13, 0.1, 0.1& , 0.13, 0.17, 0.17, 0.17, 0.2, 0.2, 0.2, 0.2& #ifdef CROP @@ -1058,7 +1058,7 @@ MODULE MOD_Const_PFT #endif /) - REAL(r8), parameter, dimension(0:N_PFT+N_CFT-1) :: fm_droot & + real(r8), parameter, dimension(0:N_PFT+N_CFT-1) :: fm_droot & =(/ 0., 0.15, 0.15, 0.15, 0.13, 0.13, 0.1, 0.1& , 0.13, 0.17, 0.17, 0.17, 0.2, 0.2, 0.2, 0.2& #ifdef CROP @@ -1073,7 +1073,7 @@ MODULE MOD_Const_PFT #endif /) - REAL(r8), parameter, dimension(0:N_PFT+N_CFT-1) :: fm_other & + real(r8), parameter, dimension(0:N_PFT+N_CFT-1) :: fm_other & =(/ 0., 0.5, 0.5, 0.5, 0.45, 0.45, 0.35, 0.35& , 0.45, 0.55, 0.55, 0.55, 0.8, 0.8, 0.8, 0.8& #ifdef CROP @@ -1088,7 +1088,7 @@ MODULE MOD_Const_PFT #endif /) - REAL(r8), parameter, dimension(0:N_PFT+N_CFT-1) :: froot_leaf & + real(r8), parameter, dimension(0:N_PFT+N_CFT-1) :: froot_leaf & =(/ 0., 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 1.5& , 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 1.5& #ifdef CROP @@ -1103,7 +1103,7 @@ MODULE MOD_Const_PFT #endif /) - REAL(r8), parameter, dimension(0:N_PFT+N_CFT-1) :: croot_stem & + real(r8), parameter, dimension(0:N_PFT+N_CFT-1) :: croot_stem & =(/ 0.3, 0.3, 0.3, 0.3, 0.3, 0.3, 0.3, 0.3& , 0.3, 0.3, 0.3, 0.3, 0., 0., 0., 0.& #ifdef CROP @@ -1118,7 +1118,7 @@ MODULE MOD_Const_PFT #endif /) - REAL(r8), parameter, dimension(0:N_PFT+N_CFT-1) :: stem_leaf & + real(r8), parameter, dimension(0:N_PFT+N_CFT-1) :: stem_leaf & =(/ 0., 2.3, 2.3, 1., 2.3, 1.5, 1., 2.3& , 2.3, 1.4, 0.24, 0.24, 0., 0., 0., 0.& #ifdef CROP @@ -1133,7 +1133,7 @@ MODULE MOD_Const_PFT #endif /) - REAL(r8), parameter, dimension(0:N_PFT+N_CFT-1) :: flivewd & + real(r8), parameter, dimension(0:N_PFT+N_CFT-1) :: flivewd & =(/ 0., 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1& , 0.1, 0.5, 0.5, 0.1, 0., 0., 0., 0.& #ifdef CROP @@ -1148,7 +1148,7 @@ MODULE MOD_Const_PFT #endif /) - REAL(r8), parameter, dimension(0:N_PFT+N_CFT-1) :: fcur2 & + real(r8), parameter, dimension(0:N_PFT+N_CFT-1) :: fcur2 & =(/ 0., 1., 1., 0., 1., 1., 0., 0.& , 0., 1., 0., 0., 0., 0., 0., 0.& #ifdef CROP @@ -1163,7 +1163,7 @@ MODULE MOD_Const_PFT #endif /) - REAL(r8), parameter, dimension(0:N_PFT+N_CFT-1) :: dsladlai & + real(r8), parameter, dimension(0:N_PFT+N_CFT-1) :: dsladlai & =(/ 0., 0.00125, 0.001, 0.003, 0.00122, 0.0015, 0.0027, 0.0027& , 0.0027, 0., 0., 0., 0., 0., 0., 0.& #ifdef CROP @@ -1178,7 +1178,7 @@ MODULE MOD_Const_PFT #endif /) - REAL(r8), parameter, dimension(0:N_PFT+N_CFT-1) :: slatop & + real(r8), parameter, dimension(0:N_PFT+N_CFT-1) :: slatop & =(/ 0., 0.01, 0.01, 0.02018, 0.019, 0.019, 0.0308, 0.0308& , 0.0308, 0.01798, 0.03072, 0.03072, 0.04024, 0.04024, 0.03846, 0.04024& #ifdef CROP @@ -1194,7 +1194,7 @@ MODULE MOD_Const_PFT /) !--- crop variables --- - REAL(r8),parameter, dimension(0:N_PFT+N_CFT-1) :: manunitro & ! Max fertilizer to be applied in total (kg N/m2) + real(r8),parameter, dimension(0:N_PFT+N_CFT-1) :: manunitro & ! Max fertilizer to be applied in total (kg N/m2) = (/ 0., 0., 0., 0., 0., 0., 0., 0. & , 0., 0., 0., 0., 0., 0., 0., 0. & #ifdef CROP @@ -1209,7 +1209,7 @@ MODULE MOD_Const_PFT #endif /) - REAL(r8),parameter, dimension(0:N_PFT+N_CFT-1) :: lfemerg & ! parameter used in CNPhenology + real(r8),parameter, dimension(0:N_PFT+N_CFT-1) :: lfemerg & ! parameter used in CNPhenology = (/-999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9 & , -999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9 & #ifdef CROP @@ -1224,7 +1224,7 @@ MODULE MOD_Const_PFT #endif /) - INTEGER, parameter, dimension(0:N_PFT+N_CFT-1) :: mxmat & ! parameter used in CNPhenology + integer, parameter, dimension(0:N_PFT+N_CFT-1) :: mxmat & ! parameter used in CNPhenology = (/-999, -999, -999, -999, -999, -99 , -999, -999 & , -999, -999, -999, -999, -999, -999, -999, -999 & #ifdef CROP @@ -1239,7 +1239,7 @@ MODULE MOD_Const_PFT #endif /) - REAL(r8),parameter, dimension(0:N_PFT+N_CFT-1) :: grnfill & ! parameter used in CNPhenology + real(r8),parameter, dimension(0:N_PFT+N_CFT-1) :: grnfill & ! parameter used in CNPhenology = (/-999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9 & , -999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9 & #ifdef CROP @@ -1255,7 +1255,7 @@ MODULE MOD_Const_PFT /) - REAL(r8),parameter, dimension(0:N_PFT+N_CFT-1) :: baset & ! parameter used in accFlds + real(r8),parameter, dimension(0:N_PFT+N_CFT-1) :: baset & ! parameter used in accFlds = (/0., 0., 0., 0., 0., 0., 0., 0. & , 0., 0., 0., 0., 0., 0., 0., 0. & #ifdef CROP @@ -1270,7 +1270,7 @@ MODULE MOD_Const_PFT #endif /) - REAL(r8),parameter, dimension(0:N_PFT+N_CFT-1) :: astemf & ! parameter used in CNAllocation + real(r8),parameter, dimension(0:N_PFT+N_CFT-1) :: astemf & ! parameter used in CNAllocation = (/-999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9 & , -999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9 & #ifdef CROP @@ -1285,7 +1285,7 @@ MODULE MOD_Const_PFT #endif /) - REAL(r8),parameter, dimension(0:N_PFT+N_CFT-1) :: arooti & ! parameter used in CNAllocation + real(r8),parameter, dimension(0:N_PFT+N_CFT-1) :: arooti & ! parameter used in CNAllocation = (/-999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9 & , -999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9 & #ifdef CROP @@ -1300,7 +1300,7 @@ MODULE MOD_Const_PFT #endif /) - REAL(r8),parameter, dimension(0:N_PFT+N_CFT-1) :: arootf & ! parameter used in CNAllocation + real(r8),parameter, dimension(0:N_PFT+N_CFT-1) :: arootf & ! parameter used in CNAllocation = (/-999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9 & , -999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9 & #ifdef CROP @@ -1315,7 +1315,7 @@ MODULE MOD_Const_PFT #endif /) - REAL(r8),parameter, dimension(0:N_PFT+N_CFT-1) ::fleafi & ! parameter used in CNAllocation + real(r8),parameter, dimension(0:N_PFT+N_CFT-1) ::fleafi & ! parameter used in CNAllocation = (/-999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9 & , -999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9 & #ifdef CROP @@ -1330,7 +1330,7 @@ MODULE MOD_Const_PFT #endif /) - REAL(r8),parameter, dimension(0:N_PFT+N_CFT-1) :: bfact & ! parameter used in CNAllocation + real(r8),parameter, dimension(0:N_PFT+N_CFT-1) :: bfact & ! parameter used in CNAllocation = (/-999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9 & , -999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9 & #ifdef CROP @@ -1345,7 +1345,7 @@ MODULE MOD_Const_PFT #endif /) - REAL(r8),parameter, dimension(0:N_PFT+N_CFT-1) :: declfact & ! parameter used in CNAllocation + real(r8),parameter, dimension(0:N_PFT+N_CFT-1) :: declfact & ! parameter used in CNAllocation = (/-999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9 & , -999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9 & #ifdef CROP @@ -1360,7 +1360,7 @@ MODULE MOD_Const_PFT #endif /) - REAL(r8),parameter, dimension(0:N_PFT+N_CFT-1) :: allconss & ! parameter used in CNAllocation + real(r8),parameter, dimension(0:N_PFT+N_CFT-1) :: allconss & ! parameter used in CNAllocation = (/-999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9 & , -999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9 & #ifdef CROP @@ -1375,7 +1375,7 @@ MODULE MOD_Const_PFT #endif /) - REAL(r8),parameter, dimension(0:N_PFT+N_CFT-1) :: allconsl & ! parameter used in CNAllocation + real(r8),parameter, dimension(0:N_PFT+N_CFT-1) :: allconsl & ! parameter used in CNAllocation = (/-999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9 & , -999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9 & #ifdef CROP @@ -1391,7 +1391,7 @@ MODULE MOD_Const_PFT /) - REAL(r8),parameter, dimension(0:N_PFT+N_CFT-1) :: fleafcn & ! C:N during grain fill; leaf + real(r8),parameter, dimension(0:N_PFT+N_CFT-1) :: fleafcn & ! C:N during grain fill; leaf = (/999., 999., 999., 999., 999., 999., 999., 999. & , 999., 999., 999., 999., 999., 999., 999., 999. & #ifdef CROP @@ -1406,7 +1406,7 @@ MODULE MOD_Const_PFT #endif /) - REAL(r8),parameter, dimension(0:N_PFT+N_CFT-1) :: fstemcn & ! C:N during grain fill; stem + real(r8),parameter, dimension(0:N_PFT+N_CFT-1) :: fstemcn & ! C:N during grain fill; stem = (/999., 999., 999., 999., 999., 999., 999., 999. & , 999., 999., 999., 999., 999., 999., 999., 999. & #ifdef CROP @@ -1421,7 +1421,7 @@ MODULE MOD_Const_PFT #endif /) - REAL(r8),parameter, dimension(0:N_PFT+N_CFT-1) :: ffrootcn & ! C:N during grain fill; fine root + real(r8),parameter, dimension(0:N_PFT+N_CFT-1) :: ffrootcn & ! C:N during grain fill; fine root = (/999., 999., 999., 999., 999., 999., 999., 999. & , 999., 999., 999., 999., 999., 999., 999., 999. & #ifdef CROP @@ -1436,7 +1436,7 @@ MODULE MOD_Const_PFT #endif /) - REAL(r8),parameter, dimension(0:N_PFT+N_CFT-1) :: laimx & ! maximum leaf area index + real(r8),parameter, dimension(0:N_PFT+N_CFT-1) :: laimx & ! maximum leaf area index = (/-999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9 & , -999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9 & #ifdef CROP @@ -1451,7 +1451,7 @@ MODULE MOD_Const_PFT #endif /) #ifdef CROP - INTEGER, parameter, dimension(0:N_PFT+N_CFT-1) :: mergetoclmpft & ! merge crop functional types + integer, parameter, dimension(0:N_PFT+N_CFT-1) :: mergetoclmpft & ! merge crop functional types = (/0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18 & , 19, 20, 21, 22, 23, 24, 19, 20, 21, 22, 19, 20, 21, 22, 61, 62, 19, 20, 61 & , 62, 61, 62, 41, 42, 41, 42, 19, 20, 19, 20, 61, 62, 75, 76, 61, 62, 19, 20 & @@ -1461,7 +1461,7 @@ MODULE MOD_Const_PFT ! end bgc variables ! Plant Hydraulics Paramters - REAL(r8), parameter :: kmax_sun_p(0:N_PFT+N_CFT-1) & + real(r8), parameter :: kmax_sun_p(0:N_PFT+N_CFT-1) & = (/ 0.,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007& ,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007& #ifdef CROP @@ -1476,7 +1476,7 @@ MODULE MOD_Const_PFT #endif /) - REAL(r8), parameter :: kmax_sha_p(0:N_PFT+N_CFT-1) & + real(r8), parameter :: kmax_sha_p(0:N_PFT+N_CFT-1) & = (/ 0.,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007& ,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007& #ifdef CROP @@ -1490,7 +1490,7 @@ MODULE MOD_Const_PFT ,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007& #endif /) - REAL(r8), parameter :: kmax_xyl_p(0:N_PFT+N_CFT-1) & + real(r8), parameter :: kmax_xyl_p(0:N_PFT+N_CFT-1) & = (/ 0.,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007& ,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007& #ifdef CROP @@ -1505,7 +1505,7 @@ MODULE MOD_Const_PFT #endif /) - REAL(r8), parameter :: kmax_root_p(0:N_PFT+N_CFT-1) & + real(r8), parameter :: kmax_root_p(0:N_PFT+N_CFT-1) & = (/ 0.,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007& ,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007& #ifdef CROP @@ -1521,7 +1521,7 @@ MODULE MOD_Const_PFT /) ! water potential at 50% loss of sunlit leaf tissue conductance (mmH2O) - REAL(r8), parameter :: psi50_sun_p(0:N_PFT+N_CFT-1) & + real(r8), parameter :: psi50_sun_p(0:N_PFT+N_CFT-1) & = (/-150000, -530000, -400000, -380000, -250000, -270000, -340000, -270000& ,-200000, -400000, -390000, -390000, -340000, -340000, -340000, -340000& #ifdef CROP @@ -1537,7 +1537,7 @@ MODULE MOD_Const_PFT /) ! water potential at 50% loss of shaded leaf tissue conductance (mmH2O) - REAL(r8), parameter :: psi50_sha_p(0:N_PFT+N_CFT-1) & + real(r8), parameter :: psi50_sha_p(0:N_PFT+N_CFT-1) & = (/-150000, -530000, -400000, -380000, -250000, -270000, -340000, -270000& ,-200000, -400000, -390000, -390000, -340000, -340000, -340000, -340000& #ifdef CROP @@ -1553,7 +1553,7 @@ MODULE MOD_Const_PFT /) ! water potential at 50% loss of xylem tissue conductance (mmH2O) - REAL(r8), parameter :: psi50_xyl_p(0:N_PFT+N_CFT-1) & + real(r8), parameter :: psi50_xyl_p(0:N_PFT+N_CFT-1) & = (/-200000, -530000, -400000, -380000, -250000, -270000, -340000, -270000& ,-200000, -400000, -390000, -390000, -340000, -340000, -340000, -340000& #ifdef CROP @@ -1569,7 +1569,7 @@ MODULE MOD_Const_PFT /) ! water potential at 50% loss of root tissue conductance (mmH2O) - REAL(r8), parameter :: psi50_root_p(0:N_PFT+N_CFT-1) & + real(r8), parameter :: psi50_root_p(0:N_PFT+N_CFT-1) & = (/-200000, -530000, -400000, -380000, -250000, -270000, -340000, -270000& ,-200000, -400000, -390000, -390000, -340000, -340000, -340000, -340000& #ifdef CROP @@ -1585,7 +1585,7 @@ MODULE MOD_Const_PFT /) ! shape-fitting parameter for vulnerability curve (-) - REAL(r8), parameter :: ck_p(0:N_PFT+N_CFT-1) & + real(r8), parameter :: ck_p(0:N_PFT+N_CFT-1) & = (/ 0., 3.95, 3.95, 3.95, 3.95, 3.95, 3.95, 3.95& ,3.95, 3.95, 3.95, 3.95, 3.95, 3.95, 3.95, 3.95& #ifdef CROP @@ -1602,7 +1602,7 @@ MODULE MOD_Const_PFT !end plant hydraulic parameters ! irrigation parameter for irrigated crop - LOGICAL , parameter :: irrig_crop(0:N_PFT+N_CFT-1) & ! True => is tropical broadleaf evergreen tree + logical , parameter :: irrig_crop(0:N_PFT+N_CFT-1) & ! True => is tropical broadleaf evergreen tree =(/.False., .False., .False., .False., .False., .False., .False., .False. & , .False., .False., .False., .False., .False., .False., .False., .False. & #ifdef CROP @@ -1619,18 +1619,18 @@ MODULE MOD_Const_PFT ! scheme 1: Zeng 2001, 2: Schenk and Jackson, 2002 - INTEGER, PRIVATE :: ROOTFR_SCHEME = 1 + integer, PRIVATE :: ROOTFR_SCHEME = 1 !fraction of roots in each soil layer #ifdef CROP - REAL(r8), dimension(nl_soil,N_PFT+N_CFT) :: & + real(r8), dimension(nl_soil,N_PFT+N_CFT) :: & rootfr_p(1:nl_soil, 0:N_PFT+N_CFT-1) #else - REAL(r8), dimension(nl_soil,N_PFT) :: & + real(r8), dimension(nl_soil,N_PFT) :: & rootfr_p(1:nl_soil, 0:N_PFT-1) #endif - INTEGER, PRIVATE :: i, nsl + integer, PRIVATE :: i, nsl ! PUBLIC MEMBER FUNCTIONS: @@ -1640,7 +1640,7 @@ MODULE MOD_Const_PFT SUBROUTINE Init_PFT_Const - IMPLICIT NONE + IMPLICIT NONE rho_p(1,1,:) = rhol_vis_p(:) rho_p(2,1,:) = rhol_nir_p(:) diff --git a/main/MOD_Const_Physical.F90 b/main/MOD_Const_Physical.F90 index 899bb1d1..73df0dc5 100644 --- a/main/MOD_Const_Physical.F90 +++ b/main/MOD_Const_Physical.F90 @@ -8,23 +8,23 @@ MODULE MOD_Const_Physical IMPLICIT NONE PUBLIC - REAL(r8), parameter :: denice = 917. ! density of ice [kg/m3] - REAL(r8), parameter :: denh2o = 1000. ! density of liquid water [kg/m3] - REAL(r8), parameter :: cpliq = 4188. ! Specific heat of water [J/kg-K] - REAL(r8), parameter :: cpice = 2117.27 ! Specific heat of ice [J/kg-K] - REAL(r8), parameter :: cpair = 1004.64 ! specific heat of dry air [J/kg/K] - REAL(r8), parameter :: hfus = 0.3336e6 ! latent heat of fusion for ice [J/kg] - REAL(r8), parameter :: hvap = 2.5104e6 ! latent heat of evap for water [J/kg] - REAL(r8), parameter :: hsub = 2.8440e6 ! latent heat of sublimation [J/kg] - REAL(r8), parameter :: tkair = 0.023 ! thermal conductivity of air [W/m/k] - REAL(r8), parameter :: tkice = 2.290 ! thermal conductivity of ice [W/m/k] - REAL(r8), parameter :: tkwat = 0.6 ! thermal conductivity of water [W/m/k] - REAL(r8), parameter :: tfrz = 273.16 ! freezing temperature [K] - REAL(r8), parameter :: rgas = 287.04 ! gas constant for dry air [J/kg/K] - REAL(r8), parameter :: roverg = 4.71047e4 ! rw/g = (8.3144/0.018)/(9.80616)*1000. mm/K - REAL(r8), parameter :: rwat = 461.296 ! gas constant for water vapor [J/(kg K)] - REAL(r8), parameter :: grav = 9.80616 ! gravity constant [m/s2] - REAL(r8), parameter :: vonkar = 0.4 ! von Karman constant [-] - REAL(r8), parameter :: stefnc = 5.67e-8 ! Stefan-Boltzmann constant [W/m2/K4] + real(r8), parameter :: denice = 917. ! density of ice [kg/m3] + real(r8), parameter :: denh2o = 1000. ! density of liquid water [kg/m3] + real(r8), parameter :: cpliq = 4188. ! Specific heat of water [J/kg-K] + real(r8), parameter :: cpice = 2117.27 ! Specific heat of ice [J/kg-K] + real(r8), parameter :: cpair = 1004.64 ! specific heat of dry air [J/kg/K] + real(r8), parameter :: hfus = 0.3336e6 ! latent heat of fusion for ice [J/kg] + real(r8), parameter :: hvap = 2.5104e6 ! latent heat of evap for water [J/kg] + real(r8), parameter :: hsub = 2.8440e6 ! latent heat of sublimation [J/kg] + real(r8), parameter :: tkair = 0.023 ! thermal conductivity of air [W/m/k] + real(r8), parameter :: tkice = 2.290 ! thermal conductivity of ice [W/m/k] + real(r8), parameter :: tkwat = 0.6 ! thermal conductivity of water [W/m/k] + real(r8), parameter :: tfrz = 273.16 ! freezing temperature [K] + real(r8), parameter :: rgas = 287.04 ! gas constant for dry air [J/kg/K] + real(r8), parameter :: roverg = 4.71047e4 ! rw/g = (8.3144/0.018)/(9.80616)*1000. mm/K + real(r8), parameter :: rwat = 461.296 ! gas constant for water vapor [J/(kg K)] + real(r8), parameter :: grav = 9.80616 ! gravity constant [m/s2] + real(r8), parameter :: vonkar = 0.4 ! von Karman constant [-] + real(r8), parameter :: stefnc = 5.67e-8 ! Stefan-Boltzmann constant [W/m2/K4] END MODULE MOD_Const_Physical diff --git a/main/MOD_CropReadin.F90 b/main/MOD_CropReadin.F90 index 8e4f831e..fca1e5d5 100644 --- a/main/MOD_CropReadin.F90 +++ b/main/MOD_CropReadin.F90 @@ -11,59 +11,60 @@ MODULE MOD_CropReadin ! PUBLIC MEMBER FUNCTIONS: PUBLIC :: CROP_readin - CONTAINS +CONTAINS SUBROUTINE CROP_readin () - ! =========================================================== - ! ! DESCRIPTION: - ! Read in crop planting date from data, and fertilization from data. - ! Save these data in patch vector. - ! - ! Original: Shupeng Zhang, Zhongwang Wei, and Xingjie Lu, 2022 - ! =========================================================== - - use MOD_Precision - use MOD_Namelist - use MOD_SPMD_Task - use MOD_LandPatch - USE MOD_NetCDFSerial - USE MOD_NetCDFBlock - USE MOD_Mapping_Grid2Pset - use MOD_Vars_TimeInvariants - use MOD_Vars_TimeVariables - - USE MOD_Vars_Global - USE MOD_LandPFT - USE MOD_Vars_PFTimeVariables - USE MOD_RangeCheck - USE MOD_Block - - IMPLICIT NONE - - CHARACTER(len=256) :: file_crop - TYPE(grid_type) :: grid_crop - TYPE(block_data_real8_2d) :: f_xy_crop - type(mapping_grid2pset_type) :: mg2patch_crop - type(mapping_grid2pset_type) :: mg2pft_crop - CHARACTER(len=256) :: file_irrig - TYPE(grid_type) :: grid_irrig - TYPE(block_data_int32_2d) :: f_xy_irrig - type(mapping_grid2pset_type) :: mg2pft_irrig - - real(r8),allocatable :: pdrice2_tmp (:) - real(r8),allocatable :: plantdate_tmp (:) - real(r8),allocatable :: fertnitro_tmp (:) - integer ,allocatable :: irrig_method_tmp (:) - - ! Local variables - REAL(r8), allocatable :: lat(:), lon(:) - real(r8) :: missing_value - integer :: cft, npatch, ipft - CHARACTER(LEN=2) :: cx - integer :: iblkme, iblk, jblk - integer :: maxvalue, minvalue + ! =========================================================== + ! ! DESCRIPTION: + ! Read in crop planting date from data, and fertilization from data. + ! Save these data in patch vector. + ! + ! Original: Shupeng Zhang, Zhongwang Wei, and Xingjie Lu, 2022 + ! =========================================================== + + USE MOD_Precision + USE MOD_Namelist + USE MOD_SPMD_Task + USE MOD_LandPatch + USE MOD_NetCDFSerial + USE MOD_NetCDFBlock + USE MOD_Mapping_Grid2Pset + USE MOD_Vars_TimeInvariants + USE MOD_Vars_TimeVariables + + USE MOD_Vars_Global + USE MOD_LandPFT + USE MOD_Vars_PFTimeVariables + USE MOD_RangeCheck + USE MOD_Block + + IMPLICIT NONE + + character(len=256) :: file_crop + type(grid_type) :: grid_crop + type(block_data_real8_2d) :: f_xy_crop + type(mapping_grid2pset_type) :: mg2patch_crop + type(mapping_grid2pset_type) :: mg2pft_crop + character(len=256) :: file_irrig + type(grid_type) :: grid_irrig + type(block_data_int32_2d) :: f_xy_irrig + type(mapping_grid2pset_type) :: mg2pft_irrig + + real(r8),allocatable :: pdrice2_tmp (:) + real(r8),allocatable :: plantdate_tmp (:) + real(r8),allocatable :: fertnitro_tmp (:) + integer ,allocatable :: irrig_method_tmp (:) + + ! Local variables + real(r8), allocatable :: lat(:), lon(:) + real(r8) :: missing_value + integer :: cft, npatch, ipft + character(LEN=2) :: cx + integer :: iblkme, iblk, jblk + integer :: maxvalue, minvalue + ! READ in crops - + file_crop = trim(DEF_dir_runtime) // '/crop/plantdt-colm-64cfts-rice2_fillcoast.nc' CALL ncio_read_bcast_serial (file_crop, 'lat', lat) @@ -74,7 +75,7 @@ SUBROUTINE CROP_readin () IF (p_is_io) THEN CALL allocate_block_data (grid_crop, f_xy_crop) ENDIF - + ! missing value IF (p_is_master) THEN CALL ncio_get_attr (file_crop, 'pdrice2', 'missing_value', missing_value) @@ -86,12 +87,12 @@ SUBROUTINE CROP_readin () CALL ncio_read_block (file_crop, 'pdrice2', grid_crop, f_xy_crop) ENDIF - call mg2patch_crop%build (grid_crop, landpatch, f_xy_crop, missing_value) - call mg2pft_crop%build (grid_crop, landpft, f_xy_crop, missing_value) + CALL mg2patch_crop%build (grid_crop, landpatch, f_xy_crop, missing_value) + CALL mg2pft_crop%build (grid_crop, landpft, f_xy_crop, missing_value) IF (allocated(lon)) deallocate(lon) IF (allocated(lat)) deallocate(lat) - + IF (p_is_worker) THEN IF (numpatch > 0) allocate(pdrice2_tmp (numpatch)) IF (numpft > 0) allocate(plantdate_tmp (numpft)) @@ -104,10 +105,10 @@ SUBROUTINE CROP_readin () IF (p_is_io) THEN CALL ncio_read_block (file_crop, 'pdrice2', grid_crop, f_xy_crop) ENDIF - - call mg2patch_crop%map_aweighted (f_xy_crop, pdrice2_tmp) - IF (p_is_worker) then + CALL mg2patch_crop%map_aweighted (f_xy_crop, pdrice2_tmp) + + IF (p_is_worker) THEN DO npatch = 1, numpatch IF (pdrice2_tmp(npatch) /= spval) THEN pdrice2 (npatch) = int(pdrice2_tmp (npatch)) @@ -132,18 +133,18 @@ SUBROUTINE CROP_readin () IF (p_is_io) THEN CALL ncio_read_block_time (file_crop, 'PLANTDATE_CFT_'//trim(cx), grid_crop, 1, f_xy_crop) ENDIF - - call mg2pft_crop%map_aweighted (f_xy_crop, plantdate_tmp) - - if (p_is_worker) then + + CALL mg2pft_crop%map_aweighted (f_xy_crop, plantdate_tmp) + + if (p_is_worker) THEN do ipft = 1, numpft IF(landpft%settyp(ipft) .eq. cft)THEN plantdate_p(ipft) = plantdate_tmp(ipft) if(plantdate_p(ipft) <= 0._r8) then plantdate_p(ipft) = -99999999._r8 - end if + END if endif - end do + END do ENDIF ENDDO @@ -161,21 +162,21 @@ SUBROUTINE CROP_readin () IF (p_is_io) THEN CALL ncio_read_block_time (file_crop, 'CONST_FERTNITRO_CFT_'//trim(cx), grid_crop, 1, f_xy_crop) ENDIF - - call mg2pft_crop%map_aweighted (f_xy_crop, fertnitro_tmp) - + + CALL mg2pft_crop%map_aweighted (f_xy_crop, fertnitro_tmp) + if (p_is_worker) then do ipft = 1, numpft IF(landpft%settyp(ipft) .eq. cft)THEN fertnitro_p(ipft) = fertnitro_tmp(ipft) if(fertnitro_p(ipft) <= 0._r8) then fertnitro_p(ipft) = 0._r8 - end if + END if endif - end do + END do ENDIF ENDDO - + #ifdef RangeCheck CALL check_vector_data ('fert nitro value ', fertnitro_p) #endif @@ -193,7 +194,7 @@ SUBROUTINE CROP_readin () CALL allocate_block_data (grid_irrig, f_xy_irrig) ENDIF - call mg2pft_irrig%build (grid_irrig, landpft) + CALL mg2pft_irrig%build (grid_irrig, landpft) IF (allocated(lon)) deallocate(lon) IF (allocated(lat)) deallocate(lat) @@ -207,18 +208,18 @@ SUBROUTINE CROP_readin () CALL ncio_read_block_time (file_irrig, 'irrigation_method', grid_irrig, cft, f_xy_irrig) ENDIF - call mg2pft_irrig%map_max_frenquency_2d (f_xy_irrig, irrig_method_tmp) + CALL mg2pft_irrig%map_max_frenquency_2d (f_xy_irrig, irrig_method_tmp) if (p_is_worker) then do ipft = 1, numpft - + IF(landpft%settyp(ipft) .eq. cft + 14)THEN irrig_method_p(ipft) = irrig_method_tmp(ipft) if(irrig_method_p(ipft) < 0) then irrig_method_p(ipft) = -99999999 - end if + END if endif - end do + END do ENDIF ENDDO diff --git a/main/MOD_Eroot.F90 b/main/MOD_Eroot.F90 index 676c6d9a..f45a6506 100644 --- a/main/MOD_Eroot.F90 +++ b/main/MOD_Eroot.F90 @@ -13,12 +13,12 @@ MODULE MOD_Eroot !----------------------------------------------------------------------- - CONTAINS +CONTAINS !----------------------------------------------------------------------- - subroutine eroot (nl_soil,trsmx0,porsl, & + SUBROUTINE eroot (nl_soil,trsmx0,porsl, & #ifdef Campbell_SOIL_MODEL bsw, & #endif @@ -34,86 +34,86 @@ subroutine eroot (nl_soil,trsmx0,porsl, & ! Revision author : Shupeng Zhang and Xingjie Lu. !======================================================================= - use MOD_Precision - use MOD_Const_Physical, only : tfrz + USE MOD_Precision + USE MOD_Const_Physical, only : tfrz #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) :: nl_soil ! upper bound of array + integer, intent(in) :: nl_soil ! upper bound of array - real(r8), INTENT(in) :: trsmx0 ! max transpiration for moist soil+100% veg.[mm/s] - real(r8), INTENT(in) :: porsl(1:nl_soil) ! soil porosity [-] + real(r8), intent(in) :: trsmx0 ! max transpiration for moist soil+100% veg.[mm/s] + real(r8), intent(in) :: porsl(1:nl_soil) ! soil porosity [-] #ifdef Campbell_SOIL_MODEL - real(r8), INTENT(in) :: bsw(1:nl_soil) ! Clapp-Hornberger "B" + real(r8), intent(in) :: bsw(1:nl_soil) ! Clapp-Hornberger "B" #endif #ifdef vanGenuchten_Mualem_SOIL_MODEL - REAL(r8), intent(in) :: theta_r (1:nl_soil) - REAL(r8), intent(in) :: alpha_vgm(1:nl_soil) - REAL(r8), intent(in) :: n_vgm (1:nl_soil) - REAL(r8), intent(in) :: L_vgm (1:nl_soil) - REAL(r8), intent(in) :: sc_vgm (1:nl_soil) - REAL(r8), intent(in) :: fc_vgm (1:nl_soil) + real(r8), intent(in) :: theta_r (1:nl_soil) + real(r8), intent(in) :: alpha_vgm(1:nl_soil) + real(r8), intent(in) :: n_vgm (1:nl_soil) + real(r8), intent(in) :: L_vgm (1:nl_soil) + real(r8), intent(in) :: sc_vgm (1:nl_soil) + real(r8), intent(in) :: fc_vgm (1:nl_soil) #endif - real(r8), INTENT(in) :: psi0(1:nl_soil) ! saturated soil suction (mm) (NEGATIVE) - real(r8), INTENT(in) :: rootfr(1:nl_soil) ! fraction of roots in a layer, - real(r8), INTENT(in) :: dz_soisno(1:nl_soil) ! layer thickness (m) - real(r8), INTENT(in) :: t_soisno(1:nl_soil) ! soil/snow skin temperature (K) - real(r8), INTENT(in) :: wliq_soisno(1:nl_soil) ! liquid water (kg/m2) + real(r8), intent(in) :: psi0(1:nl_soil) ! saturated soil suction (mm) (NEGATIVE) + real(r8), intent(in) :: rootfr(1:nl_soil) ! fraction of roots in a layer, + real(r8), intent(in) :: dz_soisno(1:nl_soil) ! layer thickness (m) + real(r8), intent(in) :: t_soisno(1:nl_soil) ! soil/snow skin temperature (K) + real(r8), intent(in) :: wliq_soisno(1:nl_soil) ! liquid water (kg/m2) - real(r8), INTENT(out) :: rootr(1:nl_soil) ! root resistance of a layer, all layers add to 1 - real(r8), INTENT(out) :: etrc ! maximum possible transpiration rate (mm h2o/s) - real(r8), INTENT(out) :: rstfac ! factor of soil water stress for photosynthesis + real(r8), intent(out) :: rootr(1:nl_soil) ! root resistance of a layer, all layers add to 1 + real(r8), intent(out) :: etrc ! maximum possible transpiration rate (mm h2o/s) + real(r8), intent(out) :: rstfac ! factor of soil water stress for photosynthesis !-----------------------Local Variables------------------------------ - real(r8) roota ! accumulates root resistance factors - real(r8) rresis(1:nl_soil) ! soil water contribution to root resistance - real(r8) s_node ! vol_liq/porosity - real(r8) smpmax ! wilting point potential in mm - real(r8) smp_node ! matrix potential + real(r8) roota ! accumulates root resistance factors + real(r8) rresis(1:nl_soil) ! soil water contribution to root resistance + real(r8) s_node ! vol_liq/porosity + real(r8) smpmax ! wilting point potential in mm + real(r8) smp_node ! matrix potential - integer i ! loop counter + integer i ! loop counter !-----------------------End Variables list--------------------------- - ! transpiration potential(etrc) and root resistance factors (rstfac) + ! transpiration potential(etrc) and root resistance factors (rstfac) - roota = 1.e-10 ! must be non-zero to begin - do i = 1, nl_soil + roota = 1.e-10 ! must be non-zero to begin + DO i = 1, nl_soil - if(t_soisno(i)>tfrz .and. porsl(i)>=1.e-6)then - smpmax = -1.5e5 - s_node = max(wliq_soisno(i)/(1000.*dz_soisno(i)*porsl(i)),0.001) - s_node = min(1., s_node) + IF(t_soisno(i)>tfrz .and. porsl(i)>=1.e-6)THEN + smpmax = -1.5e5 + s_node = max(wliq_soisno(i)/(1000.*dz_soisno(i)*porsl(i)),0.001) + s_node = min(1., s_node) #ifdef Campbell_SOIL_MODEL - smp_node = max(smpmax, psi0(i)*s_node**(-bsw(i))) + smp_node = max(smpmax, psi0(i)*s_node**(-bsw(i))) #endif #ifdef vanGenuchten_Mualem_SOIL_MODEL - smp_node = soil_psi_from_vliq ( s_node*(porsl(i)-theta_r(i)) + theta_r(i), & - porsl(i), theta_r(i), psi0(i), & - 5, (/alpha_vgm(i), n_vgm(i), L_vgm(i), sc_vgm(i), fc_vgm(i)/)) - smp_node = max(smpmax, smp_node) + smp_node = soil_psi_from_vliq ( s_node*(porsl(i)-theta_r(i)) + theta_r(i), & + porsl(i), theta_r(i), psi0(i), & + 5, (/alpha_vgm(i), n_vgm(i), L_vgm(i), sc_vgm(i), fc_vgm(i)/)) + smp_node = max(smpmax, smp_node) #endif - rresis(i) =(1.-smp_node/smpmax)/(1.-psi0(i)/smpmax) - rootr(i) = rootfr(i)*rresis(i) - roota = roota + rootr(i) - else - rootr(i) = 0. - endif + rresis(i) =(1.-smp_node/smpmax)/(1.-psi0(i)/smpmax) + rootr(i) = rootfr(i)*rresis(i) + roota = roota + rootr(i) + ELSE + rootr(i) = 0. + ENDIF - end do + ENDDO - ! normalize root resistances to get layer contribution to ET - rootr(:) = rootr(:)/roota + ! normalize root resistances to get layer contribution to ET + rootr(:) = rootr(:)/roota - ! determine maximum possible transpiration rate - etrc = trsmx0*roota - rstfac = roota + ! determine maximum possible transpiration rate + etrc = trsmx0*roota + rstfac = roota - end subroutine eroot + END SUBROUTINE eroot END MODULE MOD_Eroot diff --git a/main/MOD_FireData.F90 b/main/MOD_FireData.F90 index ecd0138a..82b0f2d8 100644 --- a/main/MOD_FireData.F90 +++ b/main/MOD_FireData.F90 @@ -2,22 +2,22 @@ #ifdef BGC MODULE MOD_FireData - !----------------------------------------------------------------------- - ! !DESCRIPTION: - ! This module read in fire data. - ! - ! !ORIGINAL: - ! Lu Xingjie and Zhang Shupeng, 2023, prepare the original version of the fire data module. +!----------------------------------------------------------------------- +! !DESCRIPTION: +! This module read in fire data. +! +! !ORIGINAL: +! Lu Xingjie and Zhang Shupeng, 2023, prepare the original version of the fire data module. USE MOD_Grid USE MOD_Mapping_Grid2Pset - use MOD_Vars_TimeInvariants, only: abm_lf, gdp_lf, peatf_lf - use MOD_Vars_TimeVariables, only: hdm_lf + USE MOD_Vars_TimeInvariants, only: abm_lf, gdp_lf, peatf_lf + USE MOD_Vars_TimeVariables, only: hdm_lf IMPLICIT NONE - - CHARACTER(len=256) :: file_fire - TYPE(grid_type) :: grid_fire + character(len=256) :: file_fire + + type(grid_type) :: grid_fire type(mapping_grid2pset_type) :: mg2p_fire CONTAINS @@ -30,20 +30,20 @@ SUBROUTINE init_fire_data (YY) ! open fire netcdf file from DEF_dir_runtime, read latitude and longitude info. ! Initialize fire data read in. - use MOD_SPMD_Task - USE MOD_Namelist - USE MOD_Grid - USE MOD_NetCDFSerial - USE MOD_NetCDFBlock - USE MOD_LandPatch - USE MOD_RangeCheck - IMPLICIT NONE + USE MOD_SPMD_Task + USE MOD_Namelist + USE MOD_Grid + USE MOD_NetCDFSerial + USE MOD_NetCDFBlock + USE MOD_LandPatch + USE MOD_RangeCheck + IMPLICIT NONE integer, intent(in) :: YY ! Local Variables - REAL(r8), allocatable :: lat(:), lon(:) - TYPE(block_data_real8_2d) :: f_xy_fire + real(r8), allocatable :: lat(:), lon(:) + type(block_data_real8_2d) :: f_xy_fire file_fire = trim(DEF_dir_runtime) // '/fire/abm_colm_double_fillcoast.nc' @@ -52,40 +52,40 @@ SUBROUTINE init_fire_data (YY) CALL grid_fire%define_by_center (lat, lon) - call mg2p_fire%build (grid_fire, landpatch) + CALL mg2p_fire%build (grid_fire, landpatch) IF (allocated(lon)) deallocate(lon) IF (allocated(lat)) deallocate(lat) - + IF (p_is_io) THEN CALL allocate_block_data (grid_fire, f_xy_fire) ENDIF - + file_fire = trim(DEF_dir_runtime) // '/fire/abm_colm_double_fillcoast.nc' IF (p_is_io) THEN CALL ncio_read_block (file_fire, 'abm', grid_fire, f_xy_fire) ENDIF - call mg2p_fire%map_aweighted (f_xy_fire, abm_lf) + CALL mg2p_fire%map_aweighted (f_xy_fire, abm_lf) #ifdef RangeCheck - call check_vector_data ('abm', abm_lf) + CALL check_vector_data ('abm', abm_lf) #endif file_fire = trim(DEF_dir_runtime) // '/fire/peatf_colm_360x720_c100428.nc' IF (p_is_io) THEN CALL ncio_read_block (file_fire, 'peatf', grid_fire, f_xy_fire) ENDIF - call mg2p_fire%map_aweighted (f_xy_fire, peatf_lf) + CALL mg2p_fire%map_aweighted (f_xy_fire, peatf_lf) #ifdef RangeCheck - call check_vector_data ('peatf', peatf_lf) + CALL check_vector_data ('peatf', peatf_lf) #endif file_fire = trim(DEF_dir_runtime) // '/fire/gdp_colm_360x720_c100428.nc' IF (p_is_io) THEN CALL ncio_read_block (file_fire, 'gdp', grid_fire, f_xy_fire) ENDIF - call mg2p_fire%map_aweighted (f_xy_fire, gdp_lf) + CALL mg2p_fire%map_aweighted (f_xy_fire, gdp_lf) #ifdef RangeCheck - call check_vector_data ('gdp', gdp_lf) + CALL check_vector_data ('gdp', gdp_lf) #endif CALL update_hdm_data (YY) @@ -94,27 +94,27 @@ END SUBROUTINE init_fire_data ! ---------- SUBROUTINE update_hdm_data (YY) - ! ====================================================================================================== - ! - ! !DESCRIPTION: - ! Read in the Fire data from CLM5 dataset (month when crop fire peak (abm), GDP, peatland fraction (peatf), - ! and population density - ! - ! !ORIGINAL: Xingjie Lu and Shupeng Zhang, 2022 - ! ====================================================================================================== - - use MOD_SPMD_Task - USE MOD_DataType - USE MOD_Namelist - USE MOD_NetCDFBlock - USE MOD_RangeCheck - IMPLICIT NONE + ! ====================================================================================================== + ! + ! !DESCRIPTION: + ! Read in the Fire data from CLM5 dataset (month when crop fire peak (abm), GDP, peatland fraction (peatf), + ! and population density + ! + ! !ORIGINAL: Xingjie Lu and Shupeng Zhang, 2022 + ! ====================================================================================================== + + USE MOD_SPMD_Task + USE MOD_DataType + USE MOD_Namelist + USE MOD_NetCDFBlock + USE MOD_RangeCheck + IMPLICIT NONE - integer, intent(in) :: YY + integer, intent(in) :: YY - ! Local Variables - TYPE(block_data_real8_2d) :: f_xy_fire - integer :: itime + ! Local Variables + type(block_data_real8_2d) :: f_xy_fire + integer :: itime itime = max(1850,min(YY,2016)) - 1849 @@ -126,10 +126,10 @@ SUBROUTINE update_hdm_data (YY) CALL ncio_read_block_time (file_fire, 'hdm', grid_fire, itime, f_xy_fire) ENDIF - call mg2p_fire%map_aweighted (f_xy_fire, hdm_lf) + CALL mg2p_fire%map_aweighted (f_xy_fire, hdm_lf) #ifdef RangeCheck - call check_vector_data ('hdm', hdm_lf) + CALL check_vector_data ('hdm', hdm_lf) #endif END SUBROUTINE update_hdm_data diff --git a/main/MOD_Forcing.F90 b/main/MOD_Forcing.F90 index e24809f5..c1ea0bb5 100644 --- a/main/MOD_Forcing.F90 +++ b/main/MOD_Forcing.F90 @@ -1,7 +1,7 @@ #include !----------------------------------------------------------------------- -module MOD_Forcing +MODULE MOD_Forcing ! DESCRIPTION: ! read in the atmospheric forcing using user defined interpolation method @@ -17,36 +17,36 @@ module MOD_Forcing ! ! TODO...(need complement) - use MOD_Precision + USE MOD_Precision USE MOD_Namelist - use MOD_Grid - use MOD_Mapping_Grid2Pset - use MOD_UserSpecifiedForcing - use MOD_TimeManager - use MOD_SPMD_Task + USE MOD_Grid + USE MOD_Mapping_Grid2Pset + USE MOD_UserSpecifiedForcing + USE MOD_TimeManager + USE MOD_SPMD_Task USE MOD_MonthlyinSituCO2MaunaLoa USE MOD_Vars_Global, only : pi USE MOD_OrbCoszen - implicit none + IMPLICIT NONE - type (grid_type), public :: gforc + type (grid_type), PUBLIC :: gforc type (mapping_grid2pset_type) :: mg2p_forc - LOGICAL, allocatable :: forcmask (:) + logical, allocatable :: forcmask (:) ! for Forcing_Downscaling type (mapping_grid2pset_type) :: mg2p_forc_elm - LOGICAL, allocatable :: forcmask_elm (:) - LOGICAL, allocatable :: glacierss (:) + logical, allocatable :: forcmask_elm (:) + logical, allocatable :: glacierss (:) ! local variables integer :: deltim_int ! model time step length ! real(r8) :: deltim_real ! model time step length ! for SinglePoint - TYPE(timestamp), allocatable :: forctime (:) - INTEGER, allocatable :: iforctime(:) + type(timestamp), allocatable :: forctime (:) + integer, allocatable :: iforctime(:) logical :: forcing_read_ahead real(r8), allocatable :: forc_disk(:,:) @@ -65,46 +65,46 @@ module MOD_Forcing type(block_data_real8_2d), allocatable :: forcn_LB (:) ! forcing data at lower bondary type(block_data_real8_2d), allocatable :: forcn_UB (:) ! forcing data at upper bondary - public :: forcing_init - public :: read_forcing + PUBLIC :: forcing_init + PUBLIC :: read_forcing -contains +CONTAINS !-------------------------------- - subroutine forcing_init (dir_forcing, deltatime, ststamp, lc_year, etstamp) - - use MOD_SPMD_Task - USE MOD_Namelist - use MOD_DataType - USE MOD_Mesh - USE MOD_LandElm - USE MOD_LandPatch + SUBROUTINE forcing_init (dir_forcing, deltatime, ststamp, lc_year, etstamp) + + USE MOD_SPMD_Task + USE MOD_Namelist + USE MOD_DataType + USE MOD_Mesh + USE MOD_LandElm + USE MOD_LandPatch #ifdef CROP - USE MOD_LandCrop + USE MOD_LandCrop #endif - use MOD_Mapping_Grid2Pset - use MOD_UserSpecifiedForcing - USE MOD_NetCDFSerial - USE MOD_NetCDFVector - USE MOD_NetCDFBlock - USE MOD_Vars_TimeInvariants - USE MOD_Vars_1DForcing - implicit none - - character(len=*), intent(in) :: dir_forcing - real(r8), intent(in) :: deltatime ! model time step - type(timestamp), intent(in) :: ststamp - INTEGER, intent(in) :: lc_year ! which year of land cover data used - type(timestamp), intent(in), optional :: etstamp - - ! Local variables - integer :: idate(3) - CHARACTER(len=256) :: filename, lndname, cyear - integer :: ivar, year, month, day, time_i - REAL(r8) :: missing_value - INTEGER :: ielm, istt, iend - - call init_user_specified_forcing + USE MOD_Mapping_Grid2Pset + USE MOD_UserSpecifiedForcing + USE MOD_NetCDFSerial + USE MOD_NetCDFVector + USE MOD_NetCDFBlock + USE MOD_Vars_TimeInvariants + USE MOD_Vars_1DForcing + IMPLICIT NONE + + character(len=*), intent(in) :: dir_forcing + real(r8), intent(in) :: deltatime ! model time step + type(timestamp), intent(in) :: ststamp + integer, intent(in) :: lc_year ! which year of land cover data used + type(timestamp), intent(in), optional :: etstamp + + ! Local variables + integer :: idate(3) + character(len=256) :: filename, lndname, cyear + integer :: ivar, year, month, day, time_i + real(r8) :: missing_value + integer :: ielm, istt, iend + + CALL init_user_specified_forcing ! CO2 data initialization CALL init_monthly_co2_mlo @@ -123,9 +123,9 @@ subroutine forcing_init (dir_forcing, deltatime, ststamp, lc_year, etstamp) idate = (/ststamp%year, ststamp%day, ststamp%sec/) - call metread_latlon (dir_forcing, idate) + CALL metread_latlon (dir_forcing, idate) - if (p_is_io) then + IF (p_is_io) THEN IF (allocated(forcn )) deallocate(forcn ) IF (allocated(forcn_LB)) deallocate(forcn_LB) @@ -134,29 +134,29 @@ subroutine forcing_init (dir_forcing, deltatime, ststamp, lc_year, etstamp) allocate (forcn_LB (NVAR)) allocate (forcn_UB (NVAR)) - do ivar = 1, NVAR - call allocate_block_data (gforc, forcn (ivar)) - call allocate_block_data (gforc, forcn_LB(ivar)) - call allocate_block_data (gforc, forcn_UB(ivar)) - end do + DO ivar = 1, NVAR + CALL allocate_block_data (gforc, forcn (ivar)) + CALL allocate_block_data (gforc, forcn_LB(ivar)) + CALL allocate_block_data (gforc, forcn_UB(ivar)) + ENDDO ! allocate memory for forcing data - call allocate_block_data (gforc, metdata) ! forcing data - call allocate_block_data (gforc, avgcos ) ! time-average of cos(zenith) + CALL allocate_block_data (gforc, metdata) ! forcing data + CALL allocate_block_data (gforc, avgcos ) ! time-average of cos(zenith) #if(defined URBAN_MODEL && defined SinglePoint) - call allocate_block_data (gforc, rainf) - call allocate_block_data (gforc, snowf) + CALL allocate_block_data (gforc, rainf) + CALL allocate_block_data (gforc, snowf) #endif - end if + ENDIF IF (.not. DEF_forcing%has_missing_value) THEN - call mg2p_forc%build (gforc, landpatch) + CALL mg2p_forc%build (gforc, landpatch) IF (DEF_USE_Forcing_Downscaling) THEN - call mg2p_forc_elm%build (gforc, landelm) + CALL mg2p_forc_elm%build (gforc, landelm) ENDIF ELSE - call setstampLB(ststamp, 1, year, month, day, time_i) + CALL setstampLB(ststamp, 1, year, month, day, time_i) filename = trim(dir_forcing)//trim(metfilename(year, month, day, 1)) tstamp_LB(1) = timestamp(-1, -1, -1) @@ -180,10 +180,10 @@ subroutine forcing_init (dir_forcing, deltatime, ststamp, lc_year, etstamp) CALL mpi_bcast (missing_value, 1, MPI_REAL8, p_root, p_comm_glb, p_err) #endif - call ncio_read_block_time (filename, vname(1), gforc, time_i, metdata) - call mg2p_forc%build (gforc, landpatch, metdata, missing_value, forcmask) + CALL ncio_read_block_time (filename, vname(1), gforc, time_i, metdata) + CALL mg2p_forc%build (gforc, landpatch, metdata, missing_value, forcmask) IF (DEF_USE_Forcing_Downscaling) THEN - call mg2p_forc_elm%build (gforc, landelm, metdata, missing_value, forcmask_elm) + CALL mg2p_forc_elm%build (gforc, landelm, metdata, missing_value, forcmask_elm) ENDIF ENDIF @@ -191,7 +191,7 @@ subroutine forcing_init (dir_forcing, deltatime, ststamp, lc_year, etstamp) write(cyear,'(i4.4)') lc_year lndname = trim(DEF_dir_landdata) // '/topography/'//trim(cyear)//'/topography_patches.nc' - call ncio_read_vector (lndname, 'topography_patches', landpatch, forc_topo) + CALL ncio_read_vector (lndname, 'topography_patches', landpatch, forc_topo) IF (p_is_worker) THEN #if (defined CROP) @@ -215,7 +215,7 @@ subroutine forcing_init (dir_forcing, deltatime, ststamp, lc_year, etstamp) ENDIF forcing_read_ahead = .false. - IF (trim(DEF_forcing%dataset) == 'POINT') then + IF (trim(DEF_forcing%dataset) == 'POINT') THEN IF (USE_SITE_ForcingReadAhead .and. present(etstamp)) THEN forcing_read_ahead = .true. CALL metread_time (dir_forcing, ststamp, etstamp, deltatime) @@ -225,7 +225,7 @@ subroutine forcing_init (dir_forcing, deltatime, ststamp, lc_year, etstamp) allocate (iforctime(NVAR)) ENDIF - IF (trim(DEF_forcing%dataset) == 'POINT') then + IF (trim(DEF_forcing%dataset) == 'POINT') THEN filename = trim(dir_forcing)//trim(fprefix(1)) @@ -251,12 +251,12 @@ subroutine forcing_init (dir_forcing, deltatime, ststamp, lc_year, etstamp) ENDIF - end subroutine forcing_init + END SUBROUTINE forcing_init ! ---- forcing finalize ---- SUBROUTINE forcing_final () - IMPLICIT NONE + IMPLICIT NONE IF (allocated(forcmask )) deallocate(forcmask ) IF (allocated(forcmask_elm)) deallocate(forcmask_elm) @@ -272,7 +272,7 @@ END SUBROUTINE forcing_final ! ------------ SUBROUTINE forcing_reset () - IMPLICIT NONE + IMPLICIT NONE tstamp_LB(:) = timestamp(-1, -1, -1) tstamp_UB(:) = timestamp(-1, -1, -1) @@ -282,110 +282,110 @@ END SUBROUTINE forcing_reset !-------------------------------- SUBROUTINE read_forcing (idate, dir_forcing) - use MOD_Precision - use MOD_Namelist - use MOD_Const_Physical, only: rgas, grav - use MOD_Vars_TimeInvariants - use MOD_Vars_1DForcing - use MOD_Vars_2DForcing - use MOD_Block - use MOD_SPMD_Task - use MOD_DataType - use MOD_Mesh - use MOD_LandPatch - use MOD_Mapping_Grid2Pset - use MOD_RangeCheck - use MOD_UserSpecifiedForcing - USE MOD_ForcingDownscaling, only : rair, cpair, downscale_forcings - - IMPLICIT NONE - integer, INTENT(in) :: idate(3) - character(len=*), intent(in) :: dir_forcing - - ! local variables: - integer :: ivar - integer :: iblkme, ib, jb, i, j, ilon, ilat, np, ne - real(r8) :: calday ! Julian cal day (1.xx to 365.xx) - real(r8) :: sunang, cloud, difrat, vnrat - real(r8) :: a, hsolar, ratio_rvrf - type(block_data_real8_2d) :: forc_xy_solarin - - type(timestamp) :: mtstamp - integer :: id(3) - integer :: dtLB, dtUB - real(r8) :: cosz - INTEGER :: year, month, mday - logical :: has_u,has_v - - real solar, frl, prcp, tm, us, vs, pres, qm - real(r8) :: pco2m - - if (p_is_io) then + USE MOD_Precision + USE MOD_Namelist + USE MOD_Const_Physical, only: rgas, grav + USE MOD_Vars_TimeInvariants + USE MOD_Vars_1DForcing + USE MOD_Vars_2DForcing + USE MOD_Block + USE MOD_SPMD_Task + USE MOD_DataType + USE MOD_Mesh + USE MOD_LandPatch + USE MOD_Mapping_Grid2Pset + USE MOD_RangeCheck + USE MOD_UserSpecifiedForcing + USE MOD_ForcingDownscaling, only : rair, cpair, downscale_forcings + + IMPLICIT NONE + integer, intent(in) :: idate(3) + character(len=*), intent(in) :: dir_forcing + + ! local variables: + integer :: ivar + integer :: iblkme, ib, jb, i, j, ilon, ilat, np, ne + real(r8) :: calday ! Julian cal day (1.xx to 365.xx) + real(r8) :: sunang, cloud, difrat, vnrat + real(r8) :: a, hsolar, ratio_rvrf + type(block_data_real8_2d) :: forc_xy_solarin + + type(timestamp) :: mtstamp + integer :: id(3) + integer :: dtLB, dtUB + real(r8) :: cosz + integer :: year, month, mday + logical :: has_u,has_v + + real solar, frl, prcp, tm, us, vs, pres, qm + real(r8) :: pco2m + + IF (p_is_io) THEN !------------------------------------------------------------ - ! READ IN THE ATMOSPHERIC FORCING + ! READ in THE ATMOSPHERIC FORCING ! read lower and upper boundary forcing data CALL metreadLBUB(idate, dir_forcing) ! set model time stamp id(:) = idate(:) - !call adj2end(id) + !CALL adj2end(id) mtstamp = id has_u = .true. has_v = .true. ! loop for variables - do ivar = 1, NVAR + DO ivar = 1, NVAR IF (ivar == 5 .and. trim(vname(ivar)) == 'NULL') has_u = .false. IF (ivar == 6 .and. trim(vname(ivar)) == 'NULL') has_v = .false. - if (trim(vname(ivar)) == 'NULL') cycle ! no data, cycle - if (trim(tintalgo(ivar)) == 'NULL') cycle + IF (trim(vname(ivar)) == 'NULL') CYCLE ! no data, CYCLE + IF (trim(tintalgo(ivar)) == 'NULL') CYCLE ! to make sure the forcing data calculated is in the range of time ! interval [LB, UB] - if ( (mtstamp < tstamp_LB(ivar)) .or. (tstamp_UB(ivar) < mtstamp) ) then - write(6, *) "the data required is out of range! stop!"; CALL CoLM_stop() - end if + IF ( (mtstamp < tstamp_LB(ivar)) .or. (tstamp_UB(ivar) < mtstamp) ) THEN + write(6, *) "the data required is out of range! STOP!"; CALL CoLM_stop() + ENDIF ! calcualte distance to lower/upper boundary dtLB = mtstamp - tstamp_LB(ivar) dtUB = tstamp_UB(ivar) - mtstamp ! nearest method, for precipitation - if (tintalgo(ivar) == 'nearest') then - if (dtLB <= dtUB) then - call block_data_copy (forcn_LB(ivar), forcn(ivar)) - else - call block_data_copy (forcn_UB(ivar), forcn(ivar)) - end if - end if + IF (tintalgo(ivar) == 'nearest') THEN + IF (dtLB <= dtUB) THEN + CALL block_data_copy (forcn_LB(ivar), forcn(ivar)) + ELSE + CALL block_data_copy (forcn_UB(ivar), forcn(ivar)) + ENDIF + ENDIF ! linear method, for T, Pres, Q, W, LW - if (tintalgo(ivar) == 'linear') then - if ( (dtLB+dtUB) > 0 ) then - call block_data_linear_interp ( & + IF (tintalgo(ivar) == 'linear') THEN + IF ( (dtLB+dtUB) > 0 ) THEN + CALL block_data_linear_interp ( & forcn_LB(ivar), real(dtUB,r8)/real(dtLB+dtUB,r8), & forcn_UB(ivar), real(dtLB,r8)/real(dtLB+dtUB,r8), & forcn(ivar)) - else - call block_data_copy (forcn_LB(ivar), forcn(ivar)) - end if - end if + ELSE + CALL block_data_copy (forcn_LB(ivar), forcn(ivar)) + ENDIF + ENDIF ! coszen method, for SW - if (tintalgo(ivar) == 'coszen') then + IF (tintalgo(ivar) == 'coszen') THEN DO iblkme = 1, gblock%nblkme ib = gblock%xblkme(iblkme) jb = gblock%yblkme(iblkme) - do j = 1, gforc%ycnt(jb) - do i = 1, gforc%xcnt(ib) + DO j = 1, gforc%ycnt(jb) + DO i = 1, gforc%xcnt(ib) ilat = gforc%ydsp(jb) + j ilon = gforc%xdsp(ib) + i - if (ilon > gforc%nlon) ilon = ilon - gforc%nlon + IF (ilon > gforc%nlon) ilon = ilon - gforc%nlon calday = calendarday(mtstamp) cosz = orb_coszen(calday, gforc%rlon(ilon), gforc%rlat(ilat)) @@ -393,53 +393,53 @@ SUBROUTINE read_forcing (idate, dir_forcing) forcn(ivar)%blk(ib,jb)%val(i,j) = & cosz / avgcos%blk(ib,jb)%val(i,j) * forcn_LB(ivar)%blk(ib,jb)%val(i,j) - end do - end do - end do - end if + ENDDO + ENDDO + ENDDO + ENDIF - end do + ENDDO ! preprocess for forcing data, only for QIAN data right now? CALL metpreprocess (gforc, forcn) - call allocate_block_data (gforc, forc_xy_solarin) - - call block_data_copy (forcn(1), forc_xy_t ) - call block_data_copy (forcn(2), forc_xy_q ) - call block_data_copy (forcn(3), forc_xy_psrf ) - call block_data_copy (forcn(3), forc_xy_pbot ) - call block_data_copy (forcn(4), forc_xy_prl, sca = 2/3._r8) - call block_data_copy (forcn(4), forc_xy_prc, sca = 1/3._r8) - call block_data_copy (forcn(7), forc_xy_solarin) - call block_data_copy (forcn(8), forc_xy_frl ) - if (DEF_USE_CBL_HEIGHT) then - call block_data_copy (forcn(9), forc_xy_hpbl ) - endif - - if (has_u .and. has_v) then - call block_data_copy (forcn(5), forc_xy_us ) - call block_data_copy (forcn(6), forc_xy_vs ) - ELSEif (has_u) then - call block_data_copy (forcn(5), forc_xy_us , sca = 1/sqrt(2.0_r8)) - call block_data_copy (forcn(5), forc_xy_vs , sca = 1/sqrt(2.0_r8)) - ELSEif (has_v) then - call block_data_copy (forcn(6), forc_xy_us , sca = 1/sqrt(2.0_r8)) - call block_data_copy (forcn(6), forc_xy_vs , sca = 1/sqrt(2.0_r8)) + CALL allocate_block_data (gforc, forc_xy_solarin) + + CALL block_data_copy (forcn(1), forc_xy_t ) + CALL block_data_copy (forcn(2), forc_xy_q ) + CALL block_data_copy (forcn(3), forc_xy_psrf ) + CALL block_data_copy (forcn(3), forc_xy_pbot ) + CALL block_data_copy (forcn(4), forc_xy_prl, sca = 2/3._r8) + CALL block_data_copy (forcn(4), forc_xy_prc, sca = 1/3._r8) + CALL block_data_copy (forcn(7), forc_xy_solarin) + CALL block_data_copy (forcn(8), forc_xy_frl ) + IF (DEF_USE_CBL_HEIGHT) THEN + CALL block_data_copy (forcn(9), forc_xy_hpbl ) + ENDIF + + IF (has_u .and. has_v) THEN + CALL block_data_copy (forcn(5), forc_xy_us ) + CALL block_data_copy (forcn(6), forc_xy_vs ) + ELSEif (has_u) THEN + CALL block_data_copy (forcn(5), forc_xy_us , sca = 1/sqrt(2.0_r8)) + CALL block_data_copy (forcn(5), forc_xy_vs , sca = 1/sqrt(2.0_r8)) + ELSEif (has_v) THEN + CALL block_data_copy (forcn(6), forc_xy_us , sca = 1/sqrt(2.0_r8)) + CALL block_data_copy (forcn(6), forc_xy_vs , sca = 1/sqrt(2.0_r8)) ELSE - if (.not.trim(DEF_forcing%dataset) == 'CPL7') then - write(6, *) "At least one of the wind components must be provided! stop!"; + IF (.not.trim(DEF_forcing%dataset) == 'CPL7') THEN + write(6, *) "At least one of the wind components must be provided! STOP!"; CALL CoLM_stop() ENDIF ENDIF - call flush_block_data (forc_xy_hgt_u, real(HEIGHT_V,r8)) - call flush_block_data (forc_xy_hgt_t, real(HEIGHT_T,r8)) - call flush_block_data (forc_xy_hgt_q, real(HEIGHT_Q,r8)) + CALL flush_block_data (forc_xy_hgt_u, real(HEIGHT_V,r8)) + CALL flush_block_data (forc_xy_hgt_t, real(HEIGHT_T,r8)) + CALL flush_block_data (forc_xy_hgt_q, real(HEIGHT_Q,r8)) - if (solarin_all_band) then + IF (solarin_all_band) THEN - if (trim(DEF_forcing%dataset) == 'QIAN') then + IF (trim(DEF_forcing%dataset) == 'QIAN') THEN !--------------------------------------------------------------- ! 04/2014, yuan: NOTE! codes from CLM4.5-CESM1.2.0 ! relationship between incoming NIR or VIS radiation and ratio of @@ -450,8 +450,8 @@ SUBROUTINE read_forcing (idate, dir_forcing) ib = gblock%xblkme(iblkme) jb = gblock%yblkme(iblkme) - do j = 1, gforc%ycnt(jb) - do i = 1, gforc%xcnt(ib) + DO j = 1, gforc%ycnt(jb) + DO i = 1, gforc%xcnt(ib) hsolar = forc_xy_solarin%blk(ib,jb)%val(i,j)*0.5_R8 @@ -467,11 +467,11 @@ SUBROUTINE read_forcing (idate, dir_forcing) forc_xy_sols %blk(ib,jb)%val(i,j) = ratio_rvrf*hsolar forc_xy_solsd%blk(ib,jb)%val(i,j) = (1._R8 - ratio_rvrf)*hsolar - end do - end do - end do + ENDDO + ENDDO + ENDDO - else + ELSE !--------------------------------------------------------------- ! as the downward solar is in full band, an empirical expression ! will be used to divide fractions of band and incident @@ -482,12 +482,12 @@ SUBROUTINE read_forcing (idate, dir_forcing) ib = gblock%xblkme(iblkme) jb = gblock%yblkme(iblkme) - do j = 1, gforc%ycnt(jb) - do i = 1, gforc%xcnt(ib) + DO j = 1, gforc%ycnt(jb) + DO i = 1, gforc%xcnt(ib) ilat = gforc%ydsp(jb) + j ilon = gforc%xdsp(ib) + i - if (ilon > gforc%nlon) ilon = ilon - gforc%nlon + IF (ilon > gforc%nlon) ilon = ilon - gforc%nlon a = forc_xy_solarin%blk(ib,jb)%val(i,j) calday = calendarday(idate) @@ -499,8 +499,8 @@ SUBROUTINE read_forcing (idate, dir_forcing) cloud = max(0.58,cloud) difrat = 0.0604/(sunang-0.0223)+0.0683 - if(difrat.lt.0.) difrat = 0. - if(difrat.gt.1.) difrat = 1. + IF(difrat.lt.0.) difrat = 0. + IF(difrat.gt.1.) difrat = 1. difrat = difrat+(1.0-difrat)*cloud vnrat = (580.-cloud*464.)/((580.-cloud*499.)+(580.-cloud*464.)) @@ -509,99 +509,99 @@ SUBROUTINE read_forcing (idate, dir_forcing) forc_xy_soll %blk(ib,jb)%val(i,j) = a*(1.0-difrat)*(1.0-vnrat) forc_xy_solsd%blk(ib,jb)%val(i,j) = a*difrat*vnrat forc_xy_solld%blk(ib,jb)%val(i,j) = a*difrat*(1.0-vnrat) - end do - end do - end do - end if + ENDDO + ENDDO + ENDDO + ENDIF - end if + ENDIF ! [GET ATMOSPHERE CO2 CONCENTRATION DATA] year = idate(1) CALL julian2monthday (idate(1), idate(2), month, mday) pco2m = get_monthly_co2_mlo(year, month)*1.e-6 - call block_data_copy (forc_xy_pbot, forc_xy_pco2m, sca = pco2m ) - call block_data_copy (forc_xy_pbot, forc_xy_po2m , sca = 0.209_r8 ) + CALL block_data_copy (forc_xy_pbot, forc_xy_pco2m, sca = pco2m ) + CALL block_data_copy (forc_xy_pbot, forc_xy_po2m , sca = 0.209_r8 ) - end if + ENDIF ! Mapping the 2d atmospheric fields [lon_points]x[lat_points] ! -> the 1d vector of subgrid points [numpatch] - call mg2p_forc%map_aweighted (forc_xy_pco2m, forc_pco2m) - call mg2p_forc%map_aweighted (forc_xy_po2m , forc_po2m ) - call mg2p_forc%map_aweighted (forc_xy_us , forc_us ) - call mg2p_forc%map_aweighted (forc_xy_vs , forc_vs ) - - call mg2p_forc%map_aweighted (forc_xy_psrf , forc_psrf ) - - call mg2p_forc%map_aweighted (forc_xy_sols , forc_sols ) - call mg2p_forc%map_aweighted (forc_xy_soll , forc_soll ) - call mg2p_forc%map_aweighted (forc_xy_solsd, forc_solsd) - call mg2p_forc%map_aweighted (forc_xy_solld, forc_solld) - - call mg2p_forc%map_aweighted (forc_xy_hgt_t, forc_hgt_t) - call mg2p_forc%map_aweighted (forc_xy_hgt_u, forc_hgt_u) - call mg2p_forc%map_aweighted (forc_xy_hgt_q, forc_hgt_q) - if (DEF_USE_CBL_HEIGHT) then - call mg2p_forc%map_aweighted (forc_xy_hpbl, forc_hpbl) - endif + CALL mg2p_forc%map_aweighted (forc_xy_pco2m, forc_pco2m) + CALL mg2p_forc%map_aweighted (forc_xy_po2m , forc_po2m ) + CALL mg2p_forc%map_aweighted (forc_xy_us , forc_us ) + CALL mg2p_forc%map_aweighted (forc_xy_vs , forc_vs ) + + CALL mg2p_forc%map_aweighted (forc_xy_psrf , forc_psrf ) + + CALL mg2p_forc%map_aweighted (forc_xy_sols , forc_sols ) + CALL mg2p_forc%map_aweighted (forc_xy_soll , forc_soll ) + CALL mg2p_forc%map_aweighted (forc_xy_solsd, forc_solsd) + CALL mg2p_forc%map_aweighted (forc_xy_solld, forc_solld) + + CALL mg2p_forc%map_aweighted (forc_xy_hgt_t, forc_hgt_t) + CALL mg2p_forc%map_aweighted (forc_xy_hgt_u, forc_hgt_u) + CALL mg2p_forc%map_aweighted (forc_xy_hgt_q, forc_hgt_q) + IF (DEF_USE_CBL_HEIGHT) THEN + CALL mg2p_forc%map_aweighted (forc_xy_hpbl, forc_hpbl) + ENDIF IF (.not. DEF_USE_Forcing_Downscaling) THEN - call mg2p_forc%map_aweighted (forc_xy_t , forc_t ) - call mg2p_forc%map_aweighted (forc_xy_q , forc_q ) - call mg2p_forc%map_aweighted (forc_xy_prc , forc_prc ) - call mg2p_forc%map_aweighted (forc_xy_prl , forc_prl ) - call mg2p_forc%map_aweighted (forc_xy_pbot , forc_pbot ) - call mg2p_forc%map_aweighted (forc_xy_frl , forc_frl ) + CALL mg2p_forc%map_aweighted (forc_xy_t , forc_t ) + CALL mg2p_forc%map_aweighted (forc_xy_q , forc_q ) + CALL mg2p_forc%map_aweighted (forc_xy_prc , forc_prc ) + CALL mg2p_forc%map_aweighted (forc_xy_prl , forc_prl ) + CALL mg2p_forc%map_aweighted (forc_xy_pbot , forc_pbot ) + CALL mg2p_forc%map_aweighted (forc_xy_frl , forc_frl ) - if (p_is_worker) then + IF (p_is_worker) THEN - do np = 1, numpatch + DO np = 1, numpatch IF (DEF_forcing%has_missing_value) THEN - IF (.not. forcmask(np)) cycle + IF (.not. forcmask(np)) CYCLE ENDIF ! The standard measuring conditions for temperature are two meters above the ground ! Scientists have measured the most frigid temperature ever ! recorded on the continent's eastern highlands: about (180K) colder than dry ice. - if(forc_t(np) < 180.) forc_t(np) = 180. + IF(forc_t(np) < 180.) forc_t(np) = 180. ! the highest air temp was found in Kuwait 326 K, Sulaibya 2012-07-31; ! Pakistan, Sindh 2010-05-26; Iraq, Nasiriyah 2011-08-03 - if(forc_t(np) > 326.) forc_t(np) = 326. + IF(forc_t(np) > 326.) forc_t(np) = 326. forc_rhoair(np) = (forc_pbot(np) & - 0.378*forc_q(np)*forc_pbot(np)/(0.622+0.378*forc_q(np)))& / (rgas*forc_t(np)) - end do + ENDDO - end if + ENDIF ELSE - call mg2p_forc_elm%map_aweighted (forc_xy_t , forc_t_elm ) - call mg2p_forc_elm%map_aweighted (forc_xy_q , forc_q_elm ) - call mg2p_forc_elm%map_aweighted (forc_xy_prc , forc_prc_elm ) - call mg2p_forc_elm%map_aweighted (forc_xy_prl , forc_prl_elm ) - call mg2p_forc_elm%map_aweighted (forc_xy_pbot , forc_pbot_elm ) - call mg2p_forc_elm%map_aweighted (forc_xy_frl , forc_lwrad_elm) - call mg2p_forc_elm%map_aweighted (forc_xy_hgt_t, forc_hgt_elm ) + CALL mg2p_forc_elm%map_aweighted (forc_xy_t , forc_t_elm ) + CALL mg2p_forc_elm%map_aweighted (forc_xy_q , forc_q_elm ) + CALL mg2p_forc_elm%map_aweighted (forc_xy_prc , forc_prc_elm ) + CALL mg2p_forc_elm%map_aweighted (forc_xy_prl , forc_prl_elm ) + CALL mg2p_forc_elm%map_aweighted (forc_xy_pbot , forc_pbot_elm ) + CALL mg2p_forc_elm%map_aweighted (forc_xy_frl , forc_lwrad_elm) + CALL mg2p_forc_elm%map_aweighted (forc_xy_hgt_t, forc_hgt_elm ) - if (p_is_worker) then + IF (p_is_worker) THEN - do ne = 1, numelm + DO ne = 1, numelm IF (DEF_forcing%has_missing_value) THEN - IF (.not. forcmask_elm(ne)) cycle + IF (.not. forcmask_elm(ne)) CYCLE ENDIF ! The standard measuring conditions for temperature are two meters above the ground ! Scientists have measured the most frigid temperature ever ! recorded on the continent's eastern highlands: about (180K) colder than dry ice. - if(forc_t_elm(ne) < 180.) forc_t_elm(ne) = 180. + IF(forc_t_elm(ne) < 180.) forc_t_elm(ne) = 180. ! the highest air temp was found in Kuwait 326 K, Sulaibya 2012-07-31; ! Pakistan, Sindh 2010-05-26; Iraq, Nasiriyah 2011-08-03 - if(forc_t_elm(ne) > 326.) forc_t_elm(ne) = 326. + IF(forc_t_elm(ne) > 326.) forc_t_elm(ne) = 326. forc_rho_elm(ne) = (forc_pbot_elm(ne) & - 0.378*forc_q_elm(ne)*forc_pbot_elm(ne)/(0.622+0.378*forc_q_elm(ne)))& @@ -609,7 +609,7 @@ SUBROUTINE read_forcing (idate, dir_forcing) forc_th_elm(ne) = forc_t_elm(ne) * (1.e5/forc_pbot_elm(ne)) ** (rair/cpair) - end do + ENDDO CALL downscale_forcings ( & numelm, numpatch, elm_patch%substt, elm_patch%subend, glacierss, elm_patch%subfrc, & @@ -620,32 +620,32 @@ SUBROUTINE read_forcing (idate, dir_forcing) forc_topo, forc_t, forc_th, forc_q, forc_pbot, & forc_rhoair, forc_prc, forc_prl, forc_frl) - end if + ENDIF ENDIF #ifdef RangeCheck #ifdef USEMPI - call mpi_barrier (p_comm_glb, p_err) + CALL mpi_barrier (p_comm_glb, p_err) #endif - if (p_is_master) write(*,'(/, A20)') 'Checking forcing ...' - - call check_vector_data ('Forcing t [kelvin]', forc_t ) - call check_vector_data ('Forcing q [kg/kg] ', forc_q ) - call check_vector_data ('Forcing prc [mm/s] ', forc_prc ) - call check_vector_data ('Forcing psrf [pa] ', forc_psrf ) - call check_vector_data ('Forcing prl [mm/s] ', forc_prl ) - call check_vector_data ('Forcing sols [W/m2] ', forc_sols ) - call check_vector_data ('Forcing soll [W/m2] ', forc_soll ) - call check_vector_data ('Forcing solsd [W/m2] ', forc_solsd) - call check_vector_data ('Forcing solld [W/m2] ', forc_solld) - call check_vector_data ('Forcing frl [W/m2] ', forc_frl ) - if (DEF_USE_CBL_HEIGHT) then - call check_vector_data ('Forcing hpbl ', forc_hpbl ) - endif + IF (p_is_master) write(*,'(/, A20)') 'Checking forcing ...' + + CALL check_vector_data ('Forcing t [kelvin]', forc_t ) + CALL check_vector_data ('Forcing q [kg/kg] ', forc_q ) + CALL check_vector_data ('Forcing prc [mm/s] ', forc_prc ) + CALL check_vector_data ('Forcing psrf [pa] ', forc_psrf ) + CALL check_vector_data ('Forcing prl [mm/s] ', forc_prl ) + CALL check_vector_data ('Forcing sols [W/m2] ', forc_sols ) + CALL check_vector_data ('Forcing soll [W/m2] ', forc_soll ) + CALL check_vector_data ('Forcing solsd [W/m2] ', forc_solsd) + CALL check_vector_data ('Forcing solld [W/m2] ', forc_solld) + CALL check_vector_data ('Forcing frl [W/m2] ', forc_frl ) + IF (DEF_USE_CBL_HEIGHT) THEN + CALL check_vector_data ('Forcing hpbl ', forc_hpbl ) + ENDIF #ifdef USEMPI - call mpi_barrier (p_comm_glb, p_err) + CALL mpi_barrier (p_comm_glb, p_err) #endif #endif @@ -656,46 +656,46 @@ END SUBROUTINE read_forcing ! ! !DESCRIPTION: ! read lower and upper boundary forcing data, a major interface of this - ! module + ! MODULE ! ! REVISIONS: ! Hua Yuan, 04/2014: initial code ! ------------------------------------------------------------ SUBROUTINE metreadLBUB (idate, dir_forcing) - use MOD_UserSpecifiedForcing - USE MOD_Namelist - USE MOD_Block - use MOD_DataType - use MOD_Block - use MOD_NetCDFBlock - use MOD_RangeCheck - implicit none - - integer, intent(in) :: idate(3) - character(len=*), intent(in) :: dir_forcing - - ! Local variables - integer :: ivar, year, month, day, time_i - INTEGER :: iblkme, ib, jb, i, j - type(timestamp) :: mtstamp - character(len=256) :: filename + USE MOD_UserSpecifiedForcing + USE MOD_Namelist + USE MOD_Block + USE MOD_DataType + USE MOD_Block + USE MOD_NetCDFBlock + USE MOD_RangeCheck + IMPLICIT NONE + + integer, intent(in) :: idate(3) + character(len=*), intent(in) :: dir_forcing + + ! Local variables + integer :: ivar, year, month, day, time_i + integer :: iblkme, ib, jb, i, j + type(timestamp) :: mtstamp + character(len=256) :: filename mtstamp = idate - do ivar = 1, NVAR + DO ivar = 1, NVAR - if (trim(vname(ivar)) == 'NULL') cycle ! no data, cycle + IF (trim(vname(ivar)) == 'NULL') CYCLE ! no data, CYCLE - ! lower and upper boundary data already exist, cycle - if ( .NOT.(tstamp_LB(ivar)=='NULL') .AND. .NOT.(tstamp_UB(ivar)=='NULL') .AND. & - tstamp_LB(ivar)<=mtstamp .AND. mtstamp Model end ', etstamp - write(*,*) 'Forc start ', forctime(1), ' -> Forc end ', etstamp_f + write(*,*) 'Model start ', ststamp, ' -> Model END ', etstamp + write(*,*) 'Forc start ', forctime(1), ' -> Forc END ', etstamp_f CALL CoLM_stop () ELSE its = 1 @@ -953,7 +953,7 @@ SUBROUTINE metread_time (dir_forcing, ststamp, etstamp, deltime) filename = trim(dir_forcing)//trim(metfilename(-1,-1,-1,-1)) DO ivar = 1, NVAR - if (trim(vname(ivar)) /= 'NULL') THEN + IF (trim(vname(ivar)) /= 'NULL') THEN CALL ncio_read_period_serial (filename, vname(ivar), its, ite, metcache) forc_disk(:,ivar) = metcache(1,1,:) ENDIF @@ -968,7 +968,7 @@ END SUBROUTINE metread_time ! ! !DESCRIPTION: ! set the lower boundary time stamp and record information, - ! a KEY function of this module + ! a KEY FUNCTION of this MODULE ! ! - for time stamp, set it regularly as the model time step. ! - for record information, account for: @@ -982,16 +982,16 @@ END SUBROUTINE metread_time ! ------------------------------------------------------------ SUBROUTINE setstampLB(mtstamp, var_i, year, month, mday, time_i) - implicit none - type(timestamp), intent(in) :: mtstamp - integer, intent(in) :: var_i - integer, intent(out) :: year - integer, intent(out) :: month - integer, intent(out) :: mday - integer, intent(out) :: time_i + IMPLICIT NONE + type(timestamp), intent(in) :: mtstamp + integer, intent(in) :: var_i + integer, intent(out) :: year + integer, intent(out) :: month + integer, intent(out) :: mday + integer, intent(out) :: time_i - integer :: i, day, sec, ntime - integer :: months(0:12) + integer :: i, day, sec, ntime + integer :: months(0:12) year = mtstamp%year day = mtstamp%day @@ -1021,7 +1021,7 @@ SUBROUTINE setstampLB(mtstamp, var_i, year, month, mday, time_i) tstamp_LB(var_i)%day = day ! in the case of one year one file - if ( trim(groupby) == 'year' ) then + IF ( trim(groupby) == 'year' ) THEN ! calculate the intitial second sec = 86400*(day-1) + sec @@ -1030,64 +1030,64 @@ SUBROUTINE setstampLB(mtstamp, var_i, year, month, mday, time_i) tstamp_LB(var_i)%sec = sec ! set time stamp (ststamp_LB) - if (sec < 0) then + IF (sec < 0) THEN tstamp_LB(var_i)%sec = 86400 + sec tstamp_LB(var_i)%day = day - 1 - if (tstamp_LB(var_i)%day == 0) then + IF (tstamp_LB(var_i)%day == 0) THEN tstamp_LB(var_i)%year = year - 1 - if ( isleapyear(tstamp_LB(var_i)%year) ) then + IF ( isleapyear(tstamp_LB(var_i)%year) ) THEN tstamp_LB(var_i)%day = 366 - else + ELSE tstamp_LB(var_i)%day = 365 - end if - end if - end if + ENDIF + ENDIF + ENDIF ! set record info (year, time_i) - if ( sec<0 .OR. (sec==0 .AND. offset(var_i).NE.0) ) then + IF ( sec<0 .or. (sec==0 .and. offset(var_i).NE.0) ) THEN - ! if the required dada just behind the first record + ! IF the required dada just behind the first record ! -> set to the first record - if ( year==startyr .AND. month==startmo .AND. day==1 ) then + IF ( year==startyr .and. month==startmo .and. day==1 ) THEN sec = offset(var_i) - ! else, set to one record backward - else + ! ELSE, set to one record backward + ELSE sec = 86400 + sec day = day - 1 - if (day == 0) then + IF (day == 0) THEN year = year - 1 - if ( isleapyear(year) .AND. leapyear) then + IF ( isleapyear(year) .and. leapyear) THEN day = 366 - else + ELSE day = 365 - end if - end if - end if - end if ! end if (sec <= 0) + ENDIF + ENDIF + ENDIF + ENDIF ! ENDIF (sec <= 0) ! in case of leapyear with a non-leayyear calendar - ! use the data 1 day before after FEB 28th (Julian day 59). - if ( .NOT. leapyear .AND. isleapyear(year) .AND. day>59 ) then + ! USE the data 1 day before after FEB 28th (Julian day 59). + IF ( .not. leapyear .and. isleapyear(year) .and. day>59 ) THEN day = day - 1 - end if + ENDIF ! get record time index sec = 86400*(day-1) + sec time_i = floor( (sec-offset(var_i)) *1. / dtime(var_i) ) + 1 - end if + ENDIF ! in the case of one month one file - if ( trim(groupby) == 'month' ) then + IF ( trim(groupby) == 'month' ) THEN - if ( isleapyear(year) ) then + IF ( isleapyear(year) ) THEN months = (/0,31,60,91,121,152,182,213,244,274,305,335,366/) - else + ELSE months = (/0,31,59,90,120,151,181,212,243,273,304,334,365/) - end if + ENDIF ! calculate initial month and day values - call julian2monthday(year, day, month, mday) + CALL julian2monthday(year, day, month, mday) ! calculate initial second value sec = 86400*(mday-1) + sec @@ -1096,62 +1096,62 @@ SUBROUTINE setstampLB(mtstamp, var_i, year, month, mday, time_i) tstamp_LB(var_i)%sec = sec ! set time stamp (ststamp_LB) - if (sec < 0) then + IF (sec < 0) THEN tstamp_LB(var_i)%sec = 86400 + sec tstamp_LB(var_i)%day = day - 1 - if (tstamp_LB(var_i)%day == 0) then + IF (tstamp_LB(var_i)%day == 0) THEN tstamp_LB(var_i)%year = year - 1 - if ( isleapyear(tstamp_LB(var_i)%year) ) then + IF ( isleapyear(tstamp_LB(var_i)%year) ) THEN tstamp_LB(var_i)%day = 366 - else + ELSE tstamp_LB(var_i)%day = 365 - end if - end if - end if + ENDIF + ENDIF + ENDIF ! set record info (year, month, time_i) - if ( sec<0 .OR. (sec==0 .AND. offset(var_i).NE.0) ) then + IF ( sec<0 .or. (sec==0 .and. offset(var_i).NE.0) ) THEN - ! if just behind the first record -> set to first record - if ( year==startyr .AND. month==startmo .AND. mday==1 ) then + ! IF just behind the first record -> set to first record + IF ( year==startyr .and. month==startmo .and. mday==1 ) THEN sec = offset(var_i) ! set to one record backward - else + ELSE sec = 86400 + sec mday = mday - 1 - if (mday == 0) then + IF (mday == 0) THEN month = month - 1 ! bug found by Zhu Siguang & Zhang Xiangxiang, 05/19/2014 - ! move the below line in the 'else' statement + ! move the below line in the 'ELSE' statement !mday = months(month) - months(month-1) - if (month == 0) then + IF (month == 0) THEN month = 12 year = year - 1 mday = 31 - else + ELSE mday = months(month) - months(month-1) - end if - end if - end if - end if + ENDIF + ENDIF + ENDIF + ENDIF ! in case of leapyear with a non-leayyear calendar - ! use the data 1 day before, i.e., FEB 28th. - if ( .NOT. leapyear .AND. isleapyear(year) .AND. month==2 .AND. mday==29 ) then + ! USE the data 1 day before, i.e., FEB 28th. + IF ( .not. leapyear .and. isleapyear(year) .and. month==2 .and. mday==29 ) THEN mday = 28 - end if + ENDIF ! get record time index sec = 86400*(mday-1) + sec time_i = floor( (sec-offset(var_i)) *1. / dtime(var_i) ) + 1 - end if + ENDIF ! in the case of one day one file - if ( trim(groupby) == 'day' ) then + IF ( trim(groupby) == 'day' ) THEN ! calculate initial month and day values - call julian2monthday(year, day, month, mday) + CALL julian2monthday(year, day, month, mday) ! calculate initial second value time_i = floor( (sec-offset(var_i)) *1. / dtime(var_i) ) + 1 @@ -1159,69 +1159,69 @@ SUBROUTINE setstampLB(mtstamp, var_i, year, month, mday, time_i) tstamp_LB(var_i)%sec = sec ! set time stamp (ststamp_LB) - if (sec < 0) then + IF (sec < 0) THEN tstamp_LB(var_i)%sec = 86400 + sec tstamp_LB(var_i)%day = day - 1 - if (tstamp_LB(var_i)%day == 0) then + IF (tstamp_LB(var_i)%day == 0) THEN tstamp_LB(var_i)%year = year - 1 - if ( isleapyear(tstamp_LB(var_i)%year) ) then + IF ( isleapyear(tstamp_LB(var_i)%year) ) THEN tstamp_LB(var_i)%day = 366 - else + ELSE tstamp_LB(var_i)%day = 365 - end if - end if - - if ( year==startyr .AND. month==startmo .AND. mday==1 ) then - sec = offset(var_i) - ! set to one record backward - else - sec = 86400 + sec - year = tstamp_LB(var_i)%year - call julian2monthday(tstamp_LB(var_i)%year, tstamp_LB(var_i)%day, month, mday) - end if - end if - - ! in case of leapyear with a non-leayyear calendar - ! use the data 1 day before, i.e., FEB 28th. - if ( .NOT. leapyear .AND. isleapyear(year) .AND. month==2 .AND. mday==29 ) then - mday = 28 - end if - - ! get record time index - time_i = floor( (sec-offset(var_i)) *1. / dtime(var_i) ) + 1 - end if - - if (time_i <= 0) then - write(6, *) "got the wrong time record of forcing! stop!"; CALL CoLM_stop() - end if - - return - - END SUBROUTINE setstampLB - - ! ------------------------------------------------------------ - ! - ! !DESCRIPTION: - ! set the upper boundary time stamp and record information, - ! a KEY function of this module - ! - ! REVISIONS: - ! Hua Yuan, 04/2014: initial code - ! ------------------------------------------------------------ - SUBROUTINE setstampUB(var_i, year, month, mday, time_i) - - implicit none - integer, intent(in) :: var_i - integer, intent(out) :: year - integer, intent(out) :: month - integer, intent(out) :: mday - integer, intent(out) :: time_i - - integer :: day, sec - integer :: months(0:12) + ENDIF + ENDIF + + IF ( year==startyr .and. month==startmo .and. mday==1 ) THEN + sec = offset(var_i) + ! set to one record backward + ELSE + sec = 86400 + sec + year = tstamp_LB(var_i)%year + CALL julian2monthday(tstamp_LB(var_i)%year, tstamp_LB(var_i)%day, month, mday) + ENDIF + ENDIF + + ! in case of leapyear with a non-leayyear calendar + ! USE the data 1 day before, i.e., FEB 28th. + IF ( .not. leapyear .and. isleapyear(year) .and. month==2 .and. mday==29 ) THEN + mday = 28 + ENDIF + + ! get record time index + time_i = floor( (sec-offset(var_i)) *1. / dtime(var_i) ) + 1 + ENDIF + + IF (time_i <= 0) THEN + write(6, *) "got the wrong time record of forcing! STOP!"; CALL CoLM_stop() + ENDIF + + RETURN + + END SUBROUTINE setstampLB + + ! ------------------------------------------------------------ + ! + ! !DESCRIPTION: + ! set the upper boundary time stamp and record information, + ! a KEY FUNCTION of this MODULE + ! + ! REVISIONS: + ! Hua Yuan, 04/2014: initial code + ! ------------------------------------------------------------ + SUBROUTINE setstampUB(var_i, year, month, mday, time_i) + + IMPLICIT NONE + integer, intent(in) :: var_i + integer, intent(out) :: year + integer, intent(out) :: month + integer, intent(out) :: mday + integer, intent(out) :: time_i + + integer :: day, sec + integer :: months(0:12) IF (trim(DEF_forcing%dataset) == 'POINT') THEN - if ( tstamp_UB(var_i) == 'NULL' ) then + IF ( tstamp_UB(var_i) == 'NULL' ) THEN tstamp_UB(var_i) = forctime(iforctime(var_i)+1) ELSE iforctime(var_i) = iforctime(var_i) + 1 @@ -1235,185 +1235,185 @@ SUBROUTINE setstampUB(var_i, year, month, mday, time_i) ENDIF ! calculate the time stamp - if ( tstamp_UB(var_i) == 'NULL' ) then + IF ( tstamp_UB(var_i) == 'NULL' ) THEN tstamp_UB(var_i) = tstamp_LB(var_i) + dtime(var_i) - else + ELSE tstamp_LB(var_i) = tstamp_UB(var_i) tstamp_UB(var_i) = tstamp_UB(var_i) + dtime(var_i) - end if + ENDIF - ! calcualte initial year, day, and second values - year = tstamp_UB(var_i)%year - day = tstamp_UB(var_i)%day - sec = tstamp_UB(var_i)%sec - - if ( trim(groupby) == 'year' ) then - - ! adjust year value - if ( sec==86400 .AND. offset(var_i).EQ.0 ) then - sec = 0 - day = day + 1 - if( isleapyear(year) .AND. day==367) then - year = year + 1; day = 1 - end if - if( .NOT. isleapyear(year) .AND. day==366) then - year = year + 1; day = 1 - end if - end if - - ! in case of leapyear with a non-leayyear calendar - ! use the data 1 day before after FEB 28th (Julian day 59). - if ( .NOT. leapyear .AND. isleapyear(year) .AND. day>59 ) then - day = day - 1 - end if - - ! set record index - sec = 86400*(day-1) + sec - time_i = floor( (sec-offset(var_i)) *1. / dtime(var_i) ) + 1 - end if - - if ( trim(groupby) == 'month' ) then - - if ( isleapyear(year) ) then - months = (/0,31,60,91,121,152,182,213,244,274,305,335,366/) - else - months = (/0,31,59,90,120,151,181,212,243,273,304,334,365/) - end if - - ! calculate initial month and day values - call julian2monthday(year, day, month, mday) - - ! record in the next day, adjust year, month and second values - if ( sec==86400 .AND. offset(var_i).EQ.0 ) then - sec = 0 - mday = mday + 1 - if ( mday > (months(month)-months(month-1)) ) then - mday = 1 - ! bug found by Zhu Siguang, 05/25/2014 - ! move the below line in the 'else' statement - !month = month + 1 - if (month == 12) then - month = 1 - year = year + 1 - else - month = month + 1 - end if - end if - end if - - ! in case of leapyear with a non-leayyear calendar - ! for day 29th Feb, use the data 1 day before, i.e., 28th FEB. - if ( .NOT. leapyear .AND. isleapyear(year) .AND. month==2 .AND. mday==29 ) then - mday = 28 - end if - - ! set record index - sec = 86400*(mday-1) + sec - time_i = floor( (sec-offset(var_i)) *1. / dtime(var_i) ) + 1 - end if - - if ( trim(groupby) == 'day' ) then - if ( isleapyear(year) ) then - months = (/0,31,60,91,121,152,182,213,244,274,305,335,366/) - else - months = (/0,31,59,90,120,151,181,212,243,273,304,334,365/) - end if - - ! calculate initial month and day values - call julian2monthday(year, day, month, mday) - !mday = day - - ! record in the next day, adjust year, month and second values - if ( sec==86400 .AND. offset(var_i).EQ.0 ) then - sec = 0 - mday = mday + 1 - if ( mday > (months(month)-months(month-1)) ) then - mday = 1 - ! bug found by Zhu Siguang, 05/25/2014 - ! move the below line in the 'else' statement - !month = month + 1 - if (month == 12) then - month = 1 - year = year + 1 - else - month = month + 1 - end if - end if - end if - - ! in case of leapyear with a non-leayyear calendar - ! for day 29th Feb, use the data 1 day before, i.e., 28th FEB. - if ( .NOT. leapyear .AND. isleapyear(year) .AND. month==2 .AND. mday==29 ) then - mday = 28 - end if - - ! set record index - time_i = floor( (sec-offset(var_i)) *1. / dtime(var_i) ) + 1 - end if - - if (time_i < 0) then - write(6, *) "got the wrong time record of forcing! stop!"; CALL CoLM_stop() - end if - - return - - END SUBROUTINE setstampUB - - ! ------------------------------------------------------------ - ! !DESCRIPTION: - ! calculate time average coszen value bwteeen [LB, UB] - ! - ! REVISIONS: - ! 04/2014, yuan: this method is adapted from CLM - ! ------------------------------------------------------------ - SUBROUTINE calavgcos(idate) - - use MOD_Block - use MOD_DataType - implicit none - - integer, intent(in) :: idate(3) - - integer :: ntime, iblkme, ib, jb, i, j, ilon, ilat - real(r8) :: calday, cosz - type(timestamp) :: tstamp - - tstamp = idate !tstamp_LB(7) - ntime = 0 - do while (tstamp < tstamp_UB(7)) - ntime = ntime + 1 - tstamp = tstamp + deltim_int - ENDDO + ! calcualte initial year, day, and second values + year = tstamp_UB(var_i)%year + day = tstamp_UB(var_i)%day + sec = tstamp_UB(var_i)%sec + + IF ( trim(groupby) == 'year' ) THEN + + ! adjust year value + IF ( sec==86400 .and. offset(var_i).eq.0 ) THEN + sec = 0 + day = day + 1 + IF( isleapyear(year) .and. day==367) THEN + year = year + 1; day = 1 + ENDIF + IF( .not. isleapyear(year) .and. day==366) THEN + year = year + 1; day = 1 + ENDIF + ENDIF + + ! in case of leapyear with a non-leayyear calendar + ! USE the data 1 day before after FEB 28th (Julian day 59). + IF ( .not. leapyear .and. isleapyear(year) .and. day>59 ) THEN + day = day - 1 + ENDIF + + ! set record index + sec = 86400*(day-1) + sec + time_i = floor( (sec-offset(var_i)) *1. / dtime(var_i) ) + 1 + ENDIF + + IF ( trim(groupby) == 'month' ) THEN + + IF ( isleapyear(year) ) THEN + months = (/0,31,60,91,121,152,182,213,244,274,305,335,366/) + ELSE + months = (/0,31,59,90,120,151,181,212,243,273,304,334,365/) + ENDIF + + ! calculate initial month and day values + CALL julian2monthday(year, day, month, mday) + + ! record in the next day, adjust year, month and second values + IF ( sec==86400 .and. offset(var_i).eq.0 ) THEN + sec = 0 + mday = mday + 1 + IF ( mday > (months(month)-months(month-1)) ) THEN + mday = 1 + ! bug found by Zhu Siguang, 05/25/2014 + ! move the below line in the 'ELSE' statement + !month = month + 1 + IF (month == 12) THEN + month = 1 + year = year + 1 + ELSE + month = month + 1 + ENDIF + ENDIF + ENDIF + + ! in case of leapyear with a non-leayyear calendar + ! for day 29th Feb, USE the data 1 day before, i.e., 28th FEB. + IF ( .not. leapyear .and. isleapyear(year) .and. month==2 .and. mday==29 ) THEN + mday = 28 + ENDIF + + ! set record index + sec = 86400*(mday-1) + sec + time_i = floor( (sec-offset(var_i)) *1. / dtime(var_i) ) + 1 + ENDIF + + IF ( trim(groupby) == 'day' ) THEN + IF ( isleapyear(year) ) THEN + months = (/0,31,60,91,121,152,182,213,244,274,305,335,366/) + ELSE + months = (/0,31,59,90,120,151,181,212,243,273,304,334,365/) + ENDIF + + ! calculate initial month and day values + CALL julian2monthday(year, day, month, mday) + !mday = day + + ! record in the next day, adjust year, month and second values + IF ( sec==86400 .and. offset(var_i).eq.0 ) THEN + sec = 0 + mday = mday + 1 + IF ( mday > (months(month)-months(month-1)) ) THEN + mday = 1 + ! bug found by Zhu Siguang, 05/25/2014 + ! move the below line in the 'ELSE' statement + !month = month + 1 + IF (month == 12) THEN + month = 1 + year = year + 1 + ELSE + month = month + 1 + ENDIF + ENDIF + ENDIF + + ! in case of leapyear with a non-leayyear calendar + ! for day 29th Feb, USE the data 1 day before, i.e., 28th FEB. + IF ( .not. leapyear .and. isleapyear(year) .and. month==2 .and. mday==29 ) THEN + mday = 28 + ENDIF + + ! set record index + time_i = floor( (sec-offset(var_i)) *1. / dtime(var_i) ) + 1 + ENDIF - tstamp = idate !tstamp_LB(7) - call flush_block_data (avgcos, 0._r8) + IF (time_i < 0) THEN + write(6, *) "got the wrong time record of forcing! STOP!"; CALL CoLM_stop() + ENDIF - do while (tstamp < tstamp_UB(7)) + RETURN - DO iblkme = 1, gblock%nblkme - ib = gblock%xblkme(iblkme) - jb = gblock%yblkme(iblkme) - do j = 1, gforc%ycnt(jb) - do i = 1, gforc%xcnt(ib) + END SUBROUTINE setstampUB - ilat = gforc%ydsp(jb) + j - ilon = gforc%xdsp(ib) + i - if (ilon > gforc%nlon) ilon = ilon - gforc%nlon + ! ------------------------------------------------------------ + ! !DESCRIPTION: + ! calculate time average coszen value bwteeen [LB, UB] + ! + ! REVISIONS: + ! 04/2014, yuan: this method is adapted from CLM + ! ------------------------------------------------------------ + SUBROUTINE calavgcos(idate) - calday = calendarday(tstamp) - cosz = orb_coszen(calday, gforc%rlon(ilon), gforc%rlat(ilat)) - cosz = max(0.001, cosz) - avgcos%blk(ib,jb)%val(i,j) = avgcos%blk(ib,jb)%val(i,j) & - + cosz / real(ntime,r8) ! * deltim_real /real(tstamp_UB(7)-tstamp_LB(7)) + USE MOD_Block + USE MOD_DataType + IMPLICIT NONE - end do - end do - end do + integer, intent(in) :: idate(3) - tstamp = tstamp + deltim_int + integer :: ntime, iblkme, ib, jb, i, j, ilon, ilat + real(r8) :: calday, cosz + type(timestamp) :: tstamp - end do + tstamp = idate !tstamp_LB(7) + ntime = 0 + DO WHILE (tstamp < tstamp_UB(7)) + ntime = ntime + 1 + tstamp = tstamp + deltim_int + ENDDO + + tstamp = idate !tstamp_LB(7) + CALL flush_block_data (avgcos, 0._r8) + + DO WHILE (tstamp < tstamp_UB(7)) + + DO iblkme = 1, gblock%nblkme + ib = gblock%xblkme(iblkme) + jb = gblock%yblkme(iblkme) + DO j = 1, gforc%ycnt(jb) + DO i = 1, gforc%xcnt(ib) + + ilat = gforc%ydsp(jb) + j + ilon = gforc%xdsp(ib) + i + IF (ilon > gforc%nlon) ilon = ilon - gforc%nlon + + calday = calendarday(tstamp) + cosz = orb_coszen(calday, gforc%rlon(ilon), gforc%rlat(ilat)) + cosz = max(0.001, cosz) + avgcos%blk(ib,jb)%val(i,j) = avgcos%blk(ib,jb)%val(i,j) & + + cosz / real(ntime,r8) ! * deltim_real /real(tstamp_UB(7)-tstamp_LB(7)) + + ENDDO + ENDDO + ENDDO + + tstamp = tstamp + deltim_int + + ENDDO - END SUBROUTINE calavgcos + END SUBROUTINE calavgcos - end module MOD_Forcing +END MODULE MOD_Forcing diff --git a/main/MOD_FrictionVelocity.F90 b/main/MOD_FrictionVelocity.F90 index 8028b4f2..33579d40 100644 --- a/main/MOD_FrictionVelocity.F90 +++ b/main/MOD_FrictionVelocity.F90 @@ -1,28 +1,27 @@ MODULE MOD_FrictionVelocity !----------------------------------------------------------------------- - use MOD_Precision - IMPLICIT NONE - SAVE + USE MOD_Precision + IMPLICIT NONE + SAVE ! PUBLIC MEMBER FUNCTIONS: - public :: moninobuk - public :: moninobukm - public :: moninobukini - + PUBLIC :: moninobuk + PUBLIC :: moninobukm + PUBLIC :: moninobukini ! PRIVATE MEMBER FUNCTIONS: - private :: psi + PRIVATE :: psi !----------------------------------------------------------------------- - CONTAINS +CONTAINS !----------------------------------------------------------------------- - subroutine moninobuk(hu,ht,hq,displa,z0m,z0h,z0q,obu,um,& - ustar,fh2m,fq2m,fm10m,fm,fh,fq) + SUBROUTINE moninobuk(hu,ht,hq,displa,z0m,z0h,z0q,obu,um,& + ustar,fh2m,fq2m,fm10m,fm,fh,fq) ! ====================================================================== ! Original author : Yongjiu Dai, September 15, 1999 @@ -34,140 +33,140 @@ subroutine moninobuk(hu,ht,hq,displa,z0m,z0h,z0q,obu,um,& ! of sea surface fluxes using TOGA CORE and TAO data. J. Climate, Vol. 11: 2628-2644 ! ====================================================================== - use MOD_Precision - use MOD_Const_Physical, only : vonkar - implicit none + USE MOD_Precision + USE MOD_Const_Physical, only : vonkar + IMPLICIT NONE ! ---------------------- dummy argument -------------------------------- - real(r8), INTENT(in) :: hu ! observational height of wind [m] - real(r8), INTENT(in) :: ht ! observational height of temperature [m] - real(r8), INTENT(in) :: hq ! observational height of humidity [m] - real(r8), INTENT(in) :: displa ! displacement height [m] - real(r8), INTENT(in) :: z0m ! roughness length, momentum [m] - real(r8), INTENT(in) :: z0h ! roughness length, sensible heat [m] - real(r8), INTENT(in) :: z0q ! roughness length, latent heat [m] - real(r8), INTENT(in) :: obu ! monin-obukhov length (m) - real(r8), INTENT(in) :: um ! wind speed including the stablity effect [m/s] - - real(r8), INTENT(out) :: ustar ! friction velocity [m/s] - real(r8), INTENT(out) :: fh2m ! relation for temperature at 2m - real(r8), INTENT(out) :: fq2m ! relation for specific humidity at 2m - real(r8), INTENT(out) :: fm10m ! integral of profile function for momentum at 10m - real(r8), INTENT(out) :: fm ! integral of profile function for momentum - real(r8), INTENT(out) :: fh ! integral of profile function for heat - real(r8), INTENT(out) :: fq ! integral of profile function for moisture + real(r8), intent(in) :: hu ! observational height of wind [m] + real(r8), intent(in) :: ht ! observational height of temperature [m] + real(r8), intent(in) :: hq ! observational height of humidity [m] + real(r8), intent(in) :: displa ! displacement height [m] + real(r8), intent(in) :: z0m ! roughness length, momentum [m] + real(r8), intent(in) :: z0h ! roughness length, sensible heat [m] + real(r8), intent(in) :: z0q ! roughness length, latent heat [m] + real(r8), intent(in) :: obu ! monin-obukhov length (m) + real(r8), intent(in) :: um ! wind speed including the stablity effect [m/s] + + real(r8), intent(out) :: ustar ! friction velocity [m/s] + real(r8), intent(out) :: fh2m ! relation for temperature at 2m + real(r8), intent(out) :: fq2m ! relation for specific humidity at 2m + real(r8), intent(out) :: fm10m ! integral of profile FUNCTION for momentum at 10m + real(r8), intent(out) :: fm ! integral of profile FUNCTION for momentum + real(r8), intent(out) :: fh ! integral of profile FUNCTION for heat + real(r8), intent(out) :: fq ! integral of profile FUNCTION for moisture !------------------------ local variables ------------------------------ - real(r8) zldis ! reference height "minus" zero displacement heght [m] - real(r8) zetam ! transition point of flux-gradient relation (wind profile) - real(r8) zetat ! transition point of flux-gradient relation (temp. profile) - real(r8) zeta ! dimensionless height used in Monin-Obukhov theory + real(r8) zldis ! reference height "minus" zero displacement heght [m] + real(r8) zetam ! transition point of flux-gradient relation (wind profile) + real(r8) zetat ! transition point of flux-gradient relation (temp. profile) + real(r8) zeta ! dimensionless height used in Monin-Obukhov theory -! real(r8), external :: psi ! stability function for unstable case +! real(r8), external :: psi ! stability FUNCTION for unstable case !----------------------------------------------------------------------- ! adjustment factors for unstable (moz < 0) or stable (moz > 0) conditions. ! wind profile - zldis=hu-displa - zeta=zldis/obu - zetam=1.574 - if(zeta < -zetam)then ! zeta < -1 - fm = log(-zetam*obu/z0m) - psi(1,-zetam) & - + psi(1,z0m/obu) + 1.14*((-zeta)**0.333-(zetam)**0.333) - ustar = vonkar*um / fm - else if(zeta < 0.)then ! -1 <= zeta < 0 - fm = log(zldis/z0m) - psi(1,zeta) + psi(1,z0m/obu) - ustar = vonkar*um / fm - else if(zeta <= 1.)then ! 0 <= ztea <= 1 - fm = log(zldis/z0m) + 5.*zeta - 5.*z0m/obu - ustar = vonkar*um / fm - else ! 1 < zeta, phi=5+zeta - fm = log(obu/z0m) + 5. - 5.*z0m/obu + (5.*log(zeta)+zeta-1.) - ustar = vonkar*um / fm - endif - - ! for 10 meter wind-velocity - zldis=10.+z0m - zeta=zldis/obu - zetam=1.574 - if(zeta < -zetam)then ! zeta < -1 - fm10m = log(-zetam*obu/z0m) - psi(1,-zetam) & - + psi(1,z0m/obu) + 1.14*((-zeta)**0.333-(zetam)**0.333) - else if(zeta < 0.)then ! -1 <= zeta < 0 - fm10m = log(zldis/z0m) - psi(1,zeta) + psi(1,z0m/obu) - else if(zeta <= 1.)then ! 0 <= ztea <= 1 - fm10m = log(zldis/z0m) + 5.*zeta - 5.*z0m/obu - else ! 1 < zeta, phi=5+zeta - fm10m = log(obu/z0m) + 5. - 5.*z0m/obu + (5.*log(zeta)+zeta-1.) - endif + zldis=hu-displa + zeta=zldis/obu + zetam=1.574 + IF(zeta < -zetam)THEN ! zeta < -1 + fm = log(-zetam*obu/z0m) - psi(1,-zetam) & + + psi(1,z0m/obu) + 1.14*((-zeta)**0.333-(zetam)**0.333) + ustar = vonkar*um / fm + ELSE IF(zeta < 0.)THEN ! -1 <= zeta < 0 + fm = log(zldis/z0m) - psi(1,zeta) + psi(1,z0m/obu) + ustar = vonkar*um / fm + ELSE IF(zeta <= 1.)THEN ! 0 <= ztea <= 1 + fm = log(zldis/z0m) + 5.*zeta - 5.*z0m/obu + ustar = vonkar*um / fm + ELSE ! 1 < zeta, phi=5+zeta + fm = log(obu/z0m) + 5. - 5.*z0m/obu + (5.*log(zeta)+zeta-1.) + ustar = vonkar*um / fm + ENDIF + + ! for 10 meter wind-velocity + zldis=10.+z0m + zeta=zldis/obu + zetam=1.574 + IF(zeta < -zetam)THEN ! zeta < -1 + fm10m = log(-zetam*obu/z0m) - psi(1,-zetam) & + + psi(1,z0m/obu) + 1.14*((-zeta)**0.333-(zetam)**0.333) + ELSE IF(zeta < 0.)THEN ! -1 <= zeta < 0 + fm10m = log(zldis/z0m) - psi(1,zeta) + psi(1,z0m/obu) + ELSE IF(zeta <= 1.)THEN ! 0 <= ztea <= 1 + fm10m = log(zldis/z0m) + 5.*zeta - 5.*z0m/obu + ELSE ! 1 < zeta, phi=5+zeta + fm10m = log(obu/z0m) + 5. - 5.*z0m/obu + (5.*log(zeta)+zeta-1.) + ENDIF ! temperature profile - zldis=ht-displa - zeta=zldis/obu - zetat=0.465 - if(zeta < -zetat)then ! zeta < -1 - fh = log(-zetat*obu/z0h)-psi(2,-zetat) & - + psi(2,z0h/obu) + 0.8*((zetat)**(-0.333)-(-zeta)**(-0.333)) - else if(zeta < 0.)then ! -1 <= zeta < 0 - fh = log(zldis/z0h) - psi(2,zeta) + psi(2,z0h/obu) - else if(zeta <= 1.)then ! 0 <= ztea <= 1 - fh = log(zldis/z0h) + 5.*zeta - 5.*z0h/obu - else ! 1 < zeta, phi=5+zeta - fh = log(obu/z0h) + 5. - 5.*z0h/obu + (5.*log(zeta)+zeta-1.) - endif - - ! for 2 meter screen temperature - zldis=2.+z0h ! ht-displa - zeta=zldis/obu - zetat=0.465 - if(zeta < -zetat)then ! zeta < -1 - fh2m = log(-zetat*obu/z0h)-psi(2,-zetat) & - + psi(2,z0h/obu) + 0.8*((zetat)**(-0.333)-(-zeta)**(-0.333)) - else if(zeta < 0.)then ! -1 <= zeta < 0 - fh2m = log(zldis/z0h) - psi(2,zeta) + psi(2,z0h/obu) - else if(zeta <= 1.)then ! 0 <= ztea <= 1 - fh2m = log(zldis/z0h) + 5.*zeta - 5.*z0h/obu - else ! 1 < zeta, phi=5+zeta - fh2m = log(obu/z0h) + 5. - 5.*z0h/obu + (5.*log(zeta)+zeta-1.) - endif + zldis=ht-displa + zeta=zldis/obu + zetat=0.465 + IF(zeta < -zetat)THEN ! zeta < -1 + fh = log(-zetat*obu/z0h)-psi(2,-zetat) & + + psi(2,z0h/obu) + 0.8*((zetat)**(-0.333)-(-zeta)**(-0.333)) + ELSE IF(zeta < 0.)THEN ! -1 <= zeta < 0 + fh = log(zldis/z0h) - psi(2,zeta) + psi(2,z0h/obu) + ELSE IF(zeta <= 1.)THEN ! 0 <= ztea <= 1 + fh = log(zldis/z0h) + 5.*zeta - 5.*z0h/obu + ELSE ! 1 < zeta, phi=5+zeta + fh = log(obu/z0h) + 5. - 5.*z0h/obu + (5.*log(zeta)+zeta-1.) + ENDIF + + ! for 2 meter screen temperature + zldis=2.+z0h ! ht-displa + zeta=zldis/obu + zetat=0.465 + IF(zeta < -zetat)THEN ! zeta < -1 + fh2m = log(-zetat*obu/z0h)-psi(2,-zetat) & + + psi(2,z0h/obu) + 0.8*((zetat)**(-0.333)-(-zeta)**(-0.333)) + ELSE IF(zeta < 0.)THEN ! -1 <= zeta < 0 + fh2m = log(zldis/z0h) - psi(2,zeta) + psi(2,z0h/obu) + ELSE IF(zeta <= 1.)THEN ! 0 <= ztea <= 1 + fh2m = log(zldis/z0h) + 5.*zeta - 5.*z0h/obu + ELSE ! 1 < zeta, phi=5+zeta + fh2m = log(obu/z0h) + 5. - 5.*z0h/obu + (5.*log(zeta)+zeta-1.) + ENDIF ! humidity profile - zldis=hq-displa - zeta=zldis/obu - zetat=0.465 - if(zeta < -zetat)then ! zeta < -1 - fq = log(-zetat*obu/z0q) - psi(2,-zetat) & - + psi(2,z0q/obu) + 0.8*((zetat)**(-0.333)-(-zeta)**(-0.333)) - else if(zeta < 0.)then ! -1 <= zeta < 0 - fq = log(zldis/z0q) - psi(2,zeta) + psi(2,z0q/obu) - else if(zeta <= 1.)then ! 0 <= ztea <= 1 - fq = log(zldis/z0q) + 5.*zeta - 5.*z0q/obu - else ! 1 < zeta, phi=5+zeta - fq = log(obu/z0q) + 5. - 5.*z0q/obu + (5.*log(zeta)+zeta-1.) - endif + zldis=hq-displa + zeta=zldis/obu + zetat=0.465 + IF(zeta < -zetat)THEN ! zeta < -1 + fq = log(-zetat*obu/z0q) - psi(2,-zetat) & + + psi(2,z0q/obu) + 0.8*((zetat)**(-0.333)-(-zeta)**(-0.333)) + ELSE IF(zeta < 0.)THEN ! -1 <= zeta < 0 + fq = log(zldis/z0q) - psi(2,zeta) + psi(2,z0q/obu) + ELSE IF(zeta <= 1.)THEN ! 0 <= ztea <= 1 + fq = log(zldis/z0q) + 5.*zeta - 5.*z0q/obu + ELSE ! 1 < zeta, phi=5+zeta + fq = log(obu/z0q) + 5. - 5.*z0q/obu + (5.*log(zeta)+zeta-1.) + ENDIF ! for 2 meter screen humidity - zldis=2.+z0h - zeta=zldis/obu - zetat=0.465 - if(zeta < -zetat)then ! zeta < -1 - fq2m = log(-zetat*obu/z0q)-psi(2,-zetat) & - + psi(2,z0q/obu) + 0.8*((zetat)**(-0.333)-(-zeta)**(-0.333)) - elseif (zeta < 0.) then ! -1 <= zeta < 0 - fq2m = log(zldis/z0q)-psi(2,zeta)+psi(2,z0q/obu) - else if (zeta <= 1.) then ! 0 <= zeta <= 1 - fq2m = log(zldis/z0q)+5.*zeta-5.*z0q/obu - else ! 1 < zeta, phi=5+zeta - fq2m = log(obu/z0q)+5.-5.*z0q/obu+(5.*log(zeta)+zeta-1.) - endif - - end subroutine moninobuk - - - subroutine moninobukm(hu,ht,hq,displa,z0m,z0h,z0q,obu,um,displat,z0mt,& - ustar,fh2m,fq2m,htop,fmtop,fm,fh,fq,fht,fqt,phih) + zldis=2.+z0h + zeta=zldis/obu + zetat=0.465 + IF(zeta < -zetat)THEN ! zeta < -1 + fq2m = log(-zetat*obu/z0q)-psi(2,-zetat) & + + psi(2,z0q/obu) + 0.8*((zetat)**(-0.333)-(-zeta)**(-0.333)) + elseif (zeta < 0.) THEN ! -1 <= zeta < 0 + fq2m = log(zldis/z0q)-psi(2,zeta)+psi(2,z0q/obu) + ELSE IF (zeta <= 1.) THEN ! 0 <= zeta <= 1 + fq2m = log(zldis/z0q)+5.*zeta-5.*z0q/obu + ELSE ! 1 < zeta, phi=5+zeta + fq2m = log(obu/z0q)+5.-5.*z0q/obu+(5.*log(zeta)+zeta-1.) + ENDIF + + END SUBROUTINE moninobuk + + + SUBROUTINE moninobukm(hu,ht,hq,displa,z0m,z0h,z0q,obu,um,displat,z0mt,& + ustar,fh2m,fq2m,htop,fmtop,fm,fh,fq,fht,fqt,phih) ! ====================================================================== ! @@ -187,241 +186,241 @@ subroutine moninobukm(hu,ht,hq,displa,z0m,z0h,z0q,obu,um,displat,z0mt,& ! fm, fq and phih for roughness sublayer u/k profile calculation ! ====================================================================== - use MOD_Precision - use MOD_Const_Physical, only : vonkar - implicit none + USE MOD_Precision + USE MOD_Const_Physical, only : vonkar + IMPLICIT NONE ! ---------------------- dummy argument -------------------------------- - real(r8), INTENT(in) :: hu ! observational height of wind [m] - real(r8), INTENT(in) :: ht ! observational height of temperature [m] - real(r8), INTENT(in) :: hq ! observational height of humidity [m] - real(r8), INTENT(in) :: displa ! displacement height [m] - real(r8), INTENT(in) :: displat ! displacement height of the top layer [m] - real(r8), INTENT(in) :: z0m ! roughness length, momentum [m] - real(r8), INTENT(in) :: z0h ! roughness length, sensible heat [m] - real(r8), INTENT(in) :: z0q ! roughness length, latent heat [m] - real(r8), INTENT(in) :: z0mt ! roughness length of the top layer, latent heat [m] - real(r8), INTENT(in) :: htop ! canopy top height of the top layer [m] - real(r8), INTENT(in) :: obu ! monin-obukhov length (m) - real(r8), INTENT(in) :: um ! wind speed including the stablity effect [m/s] - - real(r8), INTENT(out) :: ustar ! friction velocity [m/s] - real(r8), INTENT(out) :: fh2m ! relation for temperature at 2m - real(r8), INTENT(out) :: fq2m ! relation for specific humidity at 2m - real(r8), INTENT(out) :: fmtop ! integral of profile function for momentum at 10m - real(r8), INTENT(out) :: fm ! integral of profile function for momentum - real(r8), INTENT(out) :: fh ! integral of profile function for heat - real(r8), INTENT(out) :: fq ! integral of profile function for moisture - real(r8), INTENT(out) :: fht ! integral of profile function for heat at the top layer - real(r8), INTENT(out) :: fqt ! integral of profile function for moisture at the top layer - real(r8), INTENT(out) :: phih ! phi(h), similarity function for sensible heat + real(r8), intent(in) :: hu ! observational height of wind [m] + real(r8), intent(in) :: ht ! observational height of temperature [m] + real(r8), intent(in) :: hq ! observational height of humidity [m] + real(r8), intent(in) :: displa ! displacement height [m] + real(r8), intent(in) :: displat ! displacement height of the top layer [m] + real(r8), intent(in) :: z0m ! roughness length, momentum [m] + real(r8), intent(in) :: z0h ! roughness length, sensible heat [m] + real(r8), intent(in) :: z0q ! roughness length, latent heat [m] + real(r8), intent(in) :: z0mt ! roughness length of the top layer, latent heat [m] + real(r8), intent(in) :: htop ! canopy top height of the top layer [m] + real(r8), intent(in) :: obu ! monin-obukhov length (m) + real(r8), intent(in) :: um ! wind speed including the stablity effect [m/s] + + real(r8), intent(out) :: ustar ! friction velocity [m/s] + real(r8), intent(out) :: fh2m ! relation for temperature at 2m + real(r8), intent(out) :: fq2m ! relation for specific humidity at 2m + real(r8), intent(out) :: fmtop ! integral of profile FUNCTION for momentum at 10m + real(r8), intent(out) :: fm ! integral of profile FUNCTION for momentum + real(r8), intent(out) :: fh ! integral of profile FUNCTION for heat + real(r8), intent(out) :: fq ! integral of profile FUNCTION for moisture + real(r8), intent(out) :: fht ! integral of profile FUNCTION for heat at the top layer + real(r8), intent(out) :: fqt ! integral of profile FUNCTION for moisture at the top layer + real(r8), intent(out) :: phih ! phi(h), similarity FUNCTION for sensible heat !------------------------ local variables ------------------------------ - real(r8) zldis ! reference height "minus" zero displacement heght [m] - real(r8) zetam ! transition point of flux-gradient relation (wind profile) - real(r8) zetat ! transition point of flux-gradient relation (temp. profile) - real(r8) zeta ! dimensionless height used in Monin-Obukhov theory + real(r8) zldis ! reference height "minus" zero displacement heght [m] + real(r8) zetam ! transition point of flux-gradient relation (wind profile) + real(r8) zetat ! transition point of flux-gradient relation (temp. profile) + real(r8) zeta ! dimensionless height used in Monin-Obukhov theory -! real(r8), external :: psi ! stability function for unstable case +! real(r8), external :: psi ! stability FUNCTION for unstable case !----------------------------------------------------------------------- ! adjustment factors for unstable (moz < 0) or stable (moz > 0) conditions. ! wind profile - zldis=hu-displa - zeta=zldis/obu - zetam=1.574 - if(zeta < -zetam)then ! zeta < -1 - fm = log(-zetam*obu/z0m) - psi(1,-zetam) & - + psi(1,z0m/obu) + 1.14*((-zeta)**0.333-(zetam)**0.333) - ustar = vonkar*um / fm - else if(zeta < 0.)then ! -1 <= zeta < 0 - fm = log(zldis/z0m) - psi(1,zeta) + psi(1,z0m/obu) - ustar = vonkar*um / fm - else if(zeta <= 1.)then ! 0 <= ztea <= 1 - fm = log(zldis/z0m) + 5.*zeta - 5.*z0m/obu - ustar = vonkar*um / fm - else ! 1 < zeta, phi=5+zeta - fm = log(obu/z0m) + 5. - 5.*z0m/obu + (5.*log(zeta)+zeta-1.) - ustar = vonkar*um / fm - endif - - ! for canopy top wind-velocity - !NOTE: changed for canopy top wind-velocity (no wake assumed) - zldis=htop-displa - zeta=zldis/obu - zetam=1.574 - if(zeta < -zetam)then ! zeta < -1 - fmtop = log(-zetam*obu/z0m) - psi(1,-zetam) & - + psi(1,z0m/obu) + 1.14*((-zeta)**0.333-(zetam)**0.333) - else if(zeta < 0.)then ! -1 <= zeta < 0 - fmtop = log(zldis/z0m) - psi(1,zeta) + psi(1,z0m/obu) - else if(zeta <= 1.)then ! 0 <= ztea <= 1 - fmtop = log(zldis/z0m) + 5.*zeta - 5.*z0m/obu - else ! 1 < zeta, phi=5+zeta - fmtop = log(obu/z0m) + 5. - 5.*z0m/obu + (5.*log(zeta)+zeta-1.) - endif + zldis=hu-displa + zeta=zldis/obu + zetam=1.574 + IF(zeta < -zetam)THEN ! zeta < -1 + fm = log(-zetam*obu/z0m) - psi(1,-zetam) & + + psi(1,z0m/obu) + 1.14*((-zeta)**0.333-(zetam)**0.333) + ustar = vonkar*um / fm + ELSE IF(zeta < 0.)THEN ! -1 <= zeta < 0 + fm = log(zldis/z0m) - psi(1,zeta) + psi(1,z0m/obu) + ustar = vonkar*um / fm + ELSE IF(zeta <= 1.)THEN ! 0 <= ztea <= 1 + fm = log(zldis/z0m) + 5.*zeta - 5.*z0m/obu + ustar = vonkar*um / fm + ELSE ! 1 < zeta, phi=5+zeta + fm = log(obu/z0m) + 5. - 5.*z0m/obu + (5.*log(zeta)+zeta-1.) + ustar = vonkar*um / fm + ENDIF + + ! for canopy top wind-velocity + !NOTE: changed for canopy top wind-velocity (no wake assumed) + zldis=htop-displa + zeta=zldis/obu + zetam=1.574 + IF(zeta < -zetam)THEN ! zeta < -1 + fmtop = log(-zetam*obu/z0m) - psi(1,-zetam) & + + psi(1,z0m/obu) + 1.14*((-zeta)**0.333-(zetam)**0.333) + ELSE IF(zeta < 0.)THEN ! -1 <= zeta < 0 + fmtop = log(zldis/z0m) - psi(1,zeta) + psi(1,z0m/obu) + ELSE IF(zeta <= 1.)THEN ! 0 <= ztea <= 1 + fmtop = log(zldis/z0m) + 5.*zeta - 5.*z0m/obu + ELSE ! 1 < zeta, phi=5+zeta + fmtop = log(obu/z0m) + 5. - 5.*z0m/obu + (5.*log(zeta)+zeta-1.) + ENDIF ! temperature profile - zldis=ht-displa - zeta=zldis/obu - zetat=0.465 - if(zeta < -zetat)then ! zeta < -1 - fh = log(-zetat*obu/z0h)-psi(2,-zetat) & - + psi(2,z0h/obu) + 0.8*((zetat)**(-0.333)-(-zeta)**(-0.333)) - else if(zeta < 0.)then ! -1 <= zeta < 0 - fh = log(zldis/z0h) - psi(2,zeta) + psi(2,z0h/obu) - else if(zeta <= 1.)then ! 0 <= ztea <= 1 - fh = log(zldis/z0h) + 5.*zeta - 5.*z0h/obu - else ! 1 < zeta, phi=5+zeta - fh = log(obu/z0h) + 5. - 5.*z0h/obu + (5.*log(zeta)+zeta-1.) - endif - - ! for 2 meter screen temperature - zldis=2.+z0h ! ht-displa - zeta=zldis/obu - zetat=0.465 - if(zeta < -zetat)then ! zeta < -1 - fh2m = log(-zetat*obu/z0h)-psi(2,-zetat) & - + psi(2,z0h/obu) + 0.8*((zetat)**(-0.333)-(-zeta)**(-0.333)) - else if(zeta < 0.)then ! -1 <= zeta < 0 - fh2m = log(zldis/z0h) - psi(2,zeta) + psi(2,z0h/obu) - else if(zeta <= 1.)then ! 0 <= ztea <= 1 - fh2m = log(zldis/z0h) + 5.*zeta - 5.*z0h/obu - else ! 1 < zeta, phi=5+zeta - fh2m = log(obu/z0h) + 5. - 5.*z0h/obu + (5.*log(zeta)+zeta-1.) - endif - - ! for top layer temperature - zldis=displat+z0mt-displa ! ht-displa - zeta=zldis/obu - zetat=0.465 - if(zeta < -zetat)then ! zeta < -1 - fht = log(-zetat*obu/z0h)-psi(2,-zetat) & - + psi(2,z0h/obu) + 0.8*((zetat)**(-0.333)-(-zeta)**(-0.333)) - else if(zeta < 0.)then ! -1 <= zeta < 0 - fht = log(zldis/z0h) - psi(2,zeta) + psi(2,z0h/obu) - else if(zeta <= 1.)then ! 0 <= ztea <= 1 - fht = log(zldis/z0h) + 5.*zeta - 5.*z0h/obu - else ! 1 < zeta, phi=5+zeta - fht = log(obu/z0h) + 5. - 5.*z0h/obu + (5.*log(zeta)+zeta-1.) - endif - - ! for canopy top phi(h) - ! CESM TECH NOTE EQ. (5.31) - zldis=htop-displa ! ht-displa - zeta=zldis/obu - zetat=0.465 - if(zeta < -zetat)then ! zeta < -1 - phih = 0.9*vonkar**(1.333)*(-zeta)**(-0.333) - else if(zeta < 0.)then ! -1 <= zeta < 0 - phih = (1. - 16.*zeta)**(-0.5) - else if(zeta <= 1.)then ! 0 <= ztea <= 1 - phih = 1. + 5.*zeta - else ! 1 < zeta, phi=5+zeta - phih = 5. + zeta - endif + zldis=ht-displa + zeta=zldis/obu + zetat=0.465 + IF(zeta < -zetat)THEN ! zeta < -1 + fh = log(-zetat*obu/z0h)-psi(2,-zetat) & + + psi(2,z0h/obu) + 0.8*((zetat)**(-0.333)-(-zeta)**(-0.333)) + ELSE IF(zeta < 0.)THEN ! -1 <= zeta < 0 + fh = log(zldis/z0h) - psi(2,zeta) + psi(2,z0h/obu) + ELSE IF(zeta <= 1.)THEN ! 0 <= ztea <= 1 + fh = log(zldis/z0h) + 5.*zeta - 5.*z0h/obu + ELSE ! 1 < zeta, phi=5+zeta + fh = log(obu/z0h) + 5. - 5.*z0h/obu + (5.*log(zeta)+zeta-1.) + ENDIF + + ! for 2 meter screen temperature + zldis=2.+z0h ! ht-displa + zeta=zldis/obu + zetat=0.465 + IF(zeta < -zetat)THEN ! zeta < -1 + fh2m = log(-zetat*obu/z0h)-psi(2,-zetat) & + + psi(2,z0h/obu) + 0.8*((zetat)**(-0.333)-(-zeta)**(-0.333)) + ELSE IF(zeta < 0.)THEN ! -1 <= zeta < 0 + fh2m = log(zldis/z0h) - psi(2,zeta) + psi(2,z0h/obu) + ELSE IF(zeta <= 1.)THEN ! 0 <= ztea <= 1 + fh2m = log(zldis/z0h) + 5.*zeta - 5.*z0h/obu + ELSE ! 1 < zeta, phi=5+zeta + fh2m = log(obu/z0h) + 5. - 5.*z0h/obu + (5.*log(zeta)+zeta-1.) + ENDIF + + ! for top layer temperature + zldis=displat+z0mt-displa ! ht-displa + zeta=zldis/obu + zetat=0.465 + IF(zeta < -zetat)THEN ! zeta < -1 + fht = log(-zetat*obu/z0h)-psi(2,-zetat) & + + psi(2,z0h/obu) + 0.8*((zetat)**(-0.333)-(-zeta)**(-0.333)) + ELSE IF(zeta < 0.)THEN ! -1 <= zeta < 0 + fht = log(zldis/z0h) - psi(2,zeta) + psi(2,z0h/obu) + ELSE IF(zeta <= 1.)THEN ! 0 <= ztea <= 1 + fht = log(zldis/z0h) + 5.*zeta - 5.*z0h/obu + ELSE ! 1 < zeta, phi=5+zeta + fht = log(obu/z0h) + 5. - 5.*z0h/obu + (5.*log(zeta)+zeta-1.) + ENDIF + + ! for canopy top phi(h) + ! CESM TECH NOTE EQ. (5.31) + zldis=htop-displa ! ht-displa + zeta=zldis/obu + zetat=0.465 + IF(zeta < -zetat)THEN ! zeta < -1 + phih = 0.9*vonkar**(1.333)*(-zeta)**(-0.333) + ELSE IF(zeta < 0.)THEN ! -1 <= zeta < 0 + phih = (1. - 16.*zeta)**(-0.5) + ELSE IF(zeta <= 1.)THEN ! 0 <= ztea <= 1 + phih = 1. + 5.*zeta + ELSE ! 1 < zeta, phi=5+zeta + phih = 5. + zeta + ENDIF ! humidity profile - zldis=hq-displa - zeta=zldis/obu - zetat=0.465 - if(zeta < -zetat)then ! zeta < -1 - fq = log(-zetat*obu/z0q) - psi(2,-zetat) & - + psi(2,z0q/obu) + 0.8*((zetat)**(-0.333)-(-zeta)**(-0.333)) - else if(zeta < 0.)then ! -1 <= zeta < 0 - fq = log(zldis/z0q) - psi(2,zeta) + psi(2,z0q/obu) - else if(zeta <= 1.)then ! 0 <= ztea <= 1 - fq = log(zldis/z0q) + 5.*zeta - 5.*z0q/obu - else ! 1 < zeta, phi=5+zeta - fq = log(obu/z0q) + 5. - 5.*z0q/obu + (5.*log(zeta)+zeta-1.) - endif - - ! for 2 meter screen humidity - zldis=2.+z0h - zeta=zldis/obu - zetat=0.465 - if(zeta < -zetat)then ! zeta < -1 - fq2m = log(-zetat*obu/z0q)-psi(2,-zetat) & - + psi(2,z0q/obu) + 0.8*((zetat)**(-0.333)-(-zeta)**(-0.333)) - elseif (zeta < 0.) then ! -1 <= zeta < 0 - fq2m = log(zldis/z0q)-psi(2,zeta)+psi(2,z0q/obu) - else if (zeta <= 1.) then ! 0 <= zeta <= 1 - fq2m = log(zldis/z0q)+5.*zeta-5.*z0q/obu - else ! 1 < zeta, phi=5+zeta - fq2m = log(obu/z0q)+5.-5.*z0q/obu+(5.*log(zeta)+zeta-1.) - endif - - ! for top layer humidity - zldis=displat+z0mt-displa ! ht-displa - zeta=zldis/obu - zetat=0.465 - if(zeta < -zetat)then ! zeta < -1 - fqt = log(-zetat*obu/z0q)-psi(2,-zetat) & - + psi(2,z0q/obu) + 0.8*((zetat)**(-0.333)-(-zeta)**(-0.333)) - elseif (zeta < 0.) then ! -1 <= zeta < 0 - fqt = log(zldis/z0q)-psi(2,zeta)+psi(2,z0q/obu) - else if (zeta <= 1.) then ! 0 <= zeta <= 1 - fqt = log(zldis/z0q)+5.*zeta-5.*z0q/obu - else ! 1 < zeta, phi=5+zeta - fqt = log(obu/z0q)+5.-5.*z0q/obu+(5.*log(zeta)+zeta-1.) - endif - - end subroutine moninobukm + zldis=hq-displa + zeta=zldis/obu + zetat=0.465 + IF(zeta < -zetat)THEN ! zeta < -1 + fq = log(-zetat*obu/z0q) - psi(2,-zetat) & + + psi(2,z0q/obu) + 0.8*((zetat)**(-0.333)-(-zeta)**(-0.333)) + ELSE IF(zeta < 0.)THEN ! -1 <= zeta < 0 + fq = log(zldis/z0q) - psi(2,zeta) + psi(2,z0q/obu) + ELSE IF(zeta <= 1.)THEN ! 0 <= ztea <= 1 + fq = log(zldis/z0q) + 5.*zeta - 5.*z0q/obu + ELSE ! 1 < zeta, phi=5+zeta + fq = log(obu/z0q) + 5. - 5.*z0q/obu + (5.*log(zeta)+zeta-1.) + ENDIF + + ! for 2 meter screen humidity + zldis=2.+z0h + zeta=zldis/obu + zetat=0.465 + IF(zeta < -zetat)THEN ! zeta < -1 + fq2m = log(-zetat*obu/z0q)-psi(2,-zetat) & + + psi(2,z0q/obu) + 0.8*((zetat)**(-0.333)-(-zeta)**(-0.333)) + elseif (zeta < 0.) THEN ! -1 <= zeta < 0 + fq2m = log(zldis/z0q)-psi(2,zeta)+psi(2,z0q/obu) + ELSE IF (zeta <= 1.) THEN ! 0 <= zeta <= 1 + fq2m = log(zldis/z0q)+5.*zeta-5.*z0q/obu + ELSE ! 1 < zeta, phi=5+zeta + fq2m = log(obu/z0q)+5.-5.*z0q/obu+(5.*log(zeta)+zeta-1.) + ENDIF + + ! for top layer humidity + zldis=displat+z0mt-displa ! ht-displa + zeta=zldis/obu + zetat=0.465 + IF(zeta < -zetat)THEN ! zeta < -1 + fqt = log(-zetat*obu/z0q)-psi(2,-zetat) & + + psi(2,z0q/obu) + 0.8*((zetat)**(-0.333)-(-zeta)**(-0.333)) + elseif (zeta < 0.) THEN ! -1 <= zeta < 0 + fqt = log(zldis/z0q)-psi(2,zeta)+psi(2,z0q/obu) + ELSE IF (zeta <= 1.) THEN ! 0 <= zeta <= 1 + fqt = log(zldis/z0q)+5.*zeta-5.*z0q/obu + ELSE ! 1 < zeta, phi=5+zeta + fqt = log(obu/z0q)+5.-5.*z0q/obu+(5.*log(zeta)+zeta-1.) + ENDIF + + END SUBROUTINE moninobukm !----------------------------------------------------------------------- - real(r8) function kmoninobuk(displa,obu,ustar,z) + real(r8) FUNCTION kmoninobuk(displa,obu,ustar,z) ! ! !DESCRIPTION: ! k profile calculation for bare ground case ! ! Created by Hua Yuan, 09/2017 ! - use MOD_Precision - use MOD_Const_Physical, only : vonkar - implicit none + USE MOD_Precision + USE MOD_Const_Physical, only : vonkar + IMPLICIT NONE ! ---------------------- dummy argument -------------------------------- - real(r8), INTENT(in) :: displa ! displacement height [m] - real(r8), INTENT(in) :: obu ! monin-obukhov length (m) - real(r8), INTENT(in) :: ustar ! friction velocity [m/s] - real(r8), INTENT(in) :: z ! height of windspeed [m] + real(r8), intent(in) :: displa ! displacement height [m] + real(r8), intent(in) :: obu ! monin-obukhov length (m) + real(r8), intent(in) :: ustar ! friction velocity [m/s] + real(r8), intent(in) :: z ! height of windspeed [m] !------------------------ local variables ------------------------------ - real(r8) zldis ! reference height "minus" zero displacement heght [m] - real(r8) zetam ! transition point of flux-gradient relation (wind profile) - real(r8) zetat ! transition point of flux-gradient relation (temp. profile) - real(r8) zeta ! dimensionless height used in Monin-Obukhov theory - real(r8) phih ! phi(h), similarity function for sensible heat - - if ( z .le. displa ) then - kmoninobuk = 0. - return - end if - - ! for canopy top phi(h) - zldis=z-displa ! ht-displa - zeta=zldis/obu - zetat=0.465 - if(zeta < -zetat)then ! zeta < -1 - phih = 0.9*vonkar**(1.333)*(-zeta)**(-0.333) - else if(zeta < 0.)then ! -1 <= zeta < 0 - phih = (1. - 16.*zeta)**(-0.5) - else if(zeta <= 1.)then ! 0 <= ztea <= 1 - phih = 1. + 5.*zeta - else ! 1 < zeta, phi=5+zeta - phih = 5. + zeta - endif - - kmoninobuk = vonkar*(z-displa)*ustar/phih - - end function kmoninobuk + real(r8) zldis ! reference height "minus" zero displacement heght [m] + real(r8) zetam ! transition point of flux-gradient relation (wind profile) + real(r8) zetat ! transition point of flux-gradient relation (temp. profile) + real(r8) zeta ! dimensionless height used in Monin-Obukhov theory + real(r8) phih ! phi(h), similarity FUNCTION for sensible heat + + IF ( z .le. displa ) THEN + kmoninobuk = 0. + RETURN + ENDIF + + ! for canopy top phi(h) + zldis=z-displa ! ht-displa + zeta=zldis/obu + zetat=0.465 + IF(zeta < -zetat)THEN ! zeta < -1 + phih = 0.9*vonkar**(1.333)*(-zeta)**(-0.333) + ELSE IF(zeta < 0.)THEN ! -1 <= zeta < 0 + phih = (1. - 16.*zeta)**(-0.5) + ELSE IF(zeta <= 1.)THEN ! 0 <= ztea <= 1 + phih = 1. + 5.*zeta + ELSE ! 1 < zeta, phi=5+zeta + phih = 5. + zeta + ENDIF + + kmoninobuk = vonkar*(z-displa)*ustar/phih + + END FUNCTION kmoninobuk !----------------------------------------------------------------------- - real(r8) function kintmoninobuk(displa,z0h,obu,ustar,ztop,zbot) + real(r8) FUNCTION kintmoninobuk(displa,z0h,obu,ustar,ztop,zbot) ! ! !DESCRIPTION: ! k profile integration for bare ground case @@ -429,62 +428,62 @@ real(r8) function kintmoninobuk(displa,z0h,obu,ustar,ztop,zbot) ! Created by Hua Yuan, 09/2017 ! - use MOD_Precision - use MOD_Const_Physical, only : vonkar - implicit none + USE MOD_Precision + USE MOD_Const_Physical, only : vonkar + IMPLICIT NONE ! ---------------------- dummy argument -------------------------------- - real(r8), INTENT(in) :: displa ! displacement height [m] - real(r8), INTENT(in) :: z0h ! roughness length, sensible heat [m] - real(r8), INTENT(in) :: obu ! monin-obukhov length (m) - real(r8), INTENT(in) :: ustar ! friction velocity [m/s] - real(r8), INTENT(in) :: ztop ! height top - real(r8), INTENT(in) :: zbot ! height bottom + real(r8), intent(in) :: displa ! displacement height [m] + real(r8), intent(in) :: z0h ! roughness length, sensible heat [m] + real(r8), intent(in) :: obu ! monin-obukhov length (m) + real(r8), intent(in) :: ustar ! friction velocity [m/s] + real(r8), intent(in) :: ztop ! height top + real(r8), intent(in) :: zbot ! height bottom !------------------------ local variables ------------------------------ - real(r8) zldis ! reference height "minus" zero displacement heght [m] - real(r8) zetam ! transition point of flux-gradient relation (wind profile) - real(r8) zetat ! transition point of flux-gradient relation (temp. profile) - real(r8) zeta ! dimensionless height used in Monin-Obukhov theory - - REAL(r8) :: fh_top, fh_bot ! integral of profile function for heat - - zldis=ztop-displa - zeta=zldis/obu - zetat=0.465 - if(zeta < -zetat)then ! zeta < -1 - fh_top = log(-zetat*obu/z0h)-psi(2,-zetat) & - + psi(2,z0h/obu) + 0.8*((zetat)**(-0.333)-(-zeta)**(-0.333)) - else if(zeta < 0.)then ! -1 <= zeta < 0 - fh_top = log(zldis/z0h) - psi(2,zeta) + psi(2,z0h/obu) - else if(zeta <= 1.)then ! 0 <= ztea <= 1 - fh_top = log(zldis/z0h) + 5.*zeta - 5.*z0h/obu - else ! 1 < zeta, phi=5+zeta - fh_top = log(obu/z0h) + 5. - 5.*z0h/obu + (5.*log(zeta)+zeta-1.) - endif - - zldis=zbot-displa - zeta=zldis/obu - zetat=0.465 - if(zeta < -zetat)then ! zeta < -1 - fh_bot = log(-zetat*obu/z0h)-psi(2,-zetat) & - + psi(2,z0h/obu) + 0.8*((zetat)**(-0.333)-(-zeta)**(-0.333)) - else if(zeta < 0.)then ! -1 <= zeta < 0 - fh_bot = log(zldis/z0h) - psi(2,zeta) + psi(2,z0h/obu) - else if(zeta <= 1.)then ! 0 <= ztea <= 1 - fh_bot = log(zldis/z0h) + 5.*zeta - 5.*z0h/obu - else ! 1 < zeta, phi=5+zeta - fh_bot = log(obu/z0h) + 5. - 5.*z0h/obu + (5.*log(zeta)+zeta-1.) - endif - - kintmoninobuk = 1./(vonkar/(fh_top-fh_bot)*ustar) - - END FUNCTION kintmoninobuk - - - subroutine moninobukini(ur,th,thm,thv,dth,dqh,dthv,zldis,z0m,um,obu) + real(r8) zldis ! reference height "minus" zero displacement heght [m] + real(r8) zetam ! transition point of flux-gradient relation (wind profile) + real(r8) zetat ! transition point of flux-gradient relation (temp. profile) + real(r8) zeta ! dimensionless height used in Monin-Obukhov theory + + real(r8) :: fh_top, fh_bot ! integral of profile FUNCTION for heat + + zldis=ztop-displa + zeta=zldis/obu + zetat=0.465 + IF(zeta < -zetat)THEN ! zeta < -1 + fh_top = log(-zetat*obu/z0h)-psi(2,-zetat) & + + psi(2,z0h/obu) + 0.8*((zetat)**(-0.333)-(-zeta)**(-0.333)) + ELSE IF(zeta < 0.)THEN ! -1 <= zeta < 0 + fh_top = log(zldis/z0h) - psi(2,zeta) + psi(2,z0h/obu) + ELSE IF(zeta <= 1.)THEN ! 0 <= ztea <= 1 + fh_top = log(zldis/z0h) + 5.*zeta - 5.*z0h/obu + ELSE ! 1 < zeta, phi=5+zeta + fh_top = log(obu/z0h) + 5. - 5.*z0h/obu + (5.*log(zeta)+zeta-1.) + ENDIF + + zldis=zbot-displa + zeta=zldis/obu + zetat=0.465 + IF(zeta < -zetat)THEN ! zeta < -1 + fh_bot = log(-zetat*obu/z0h)-psi(2,-zetat) & + + psi(2,z0h/obu) + 0.8*((zetat)**(-0.333)-(-zeta)**(-0.333)) + ELSE IF(zeta < 0.)THEN ! -1 <= zeta < 0 + fh_bot = log(zldis/z0h) - psi(2,zeta) + psi(2,z0h/obu) + ELSE IF(zeta <= 1.)THEN ! 0 <= ztea <= 1 + fh_bot = log(zldis/z0h) + 5.*zeta - 5.*z0h/obu + ELSE ! 1 < zeta, phi=5+zeta + fh_bot = log(obu/z0h) + 5. - 5.*z0h/obu + (5.*log(zeta)+zeta-1.) + ENDIF + + kintmoninobuk = 1./(vonkar/(fh_top-fh_bot)*ustar) + + END FUNCTION kintmoninobuk + + + SUBROUTINE moninobukini(ur,th,thm,thv,dth,dqh,dthv,zldis,z0m,um,obu) ! ====================================================================== ! Original author : Yongjiu Dai, September 15, 1999 @@ -495,76 +494,74 @@ subroutine moninobukini(ur,th,thm,thv,dth,dqh,dthv,zldis,z0m,um,obu) ! of sea surface fluxes using TOGA CORE and TAO data. J. Climate, Vol. 11: 2628-2644 ! ====================================================================== - use MOD_Precision - use MOD_Const_Physical, only : grav, vonkar - implicit none + USE MOD_Precision + USE MOD_Const_Physical, only : grav, vonkar + IMPLICIT NONE ! Dummy argument - real(r8), INTENT(in) :: ur ! wind speed at reference height [m/s] - real(r8), INTENT(in) :: thm ! intermediate variable (tm+0.0098*ht) - real(r8), INTENT(in) :: th ! potential temperature [kelvin] - real(r8), INTENT(in) :: thv ! virtual potential temperature (kelvin) - real(r8), INTENT(in) :: dth ! diff of virtual temp. between ref. height and surface - real(r8), INTENT(in) :: dthv ! diff of vir. poten. temp. between ref. height and surface - real(r8), INTENT(in) :: dqh ! diff of humidity between ref. height and surface - real(r8), INTENT(in) :: zldis ! reference height "minus" zero displacement heght [m] - real(r8), INTENT(in) :: z0m ! roughness length, momentum [m] - - real(r8), INTENT(out) :: um ! wind speed including the stablity effect [m/s] - real(r8), INTENT(out) :: obu ! monin-obukhov length (m) + real(r8), intent(in) :: ur ! wind speed at reference height [m/s] + real(r8), intent(in) :: thm ! intermediate variable (tm+0.0098*ht) + real(r8), intent(in) :: th ! potential temperature [kelvin] + real(r8), intent(in) :: thv ! virtual potential temperature (kelvin) + real(r8), intent(in) :: dth ! diff of virtual temp. between ref. height and surface + real(r8), intent(in) :: dthv ! diff of vir. poten. temp. between ref. height and surface + real(r8), intent(in) :: dqh ! diff of humidity between ref. height and surface + real(r8), intent(in) :: zldis ! reference height "minus" zero displacement heght [m] + real(r8), intent(in) :: z0m ! roughness length, momentum [m] + + real(r8), intent(out) :: um ! wind speed including the stablity effect [m/s] + real(r8), intent(out) :: obu ! monin-obukhov length (m) ! Local - real(r8) wc ! convective velocity [m/s] - real(r8) rib ! bulk Richardson number - real(r8) zeta ! dimensionless height used in Monin-Obukhov theory + real(r8) wc ! convective velocity [m/s] + real(r8) rib ! bulk Richardson number + real(r8) zeta ! dimensionless height used in Monin-Obukhov theory !----------------------------------------------------------------------- ! Initial values of u* and convective velocity - wc=0.5 - if(dthv >= 0.)then - um=max(ur,0.1) - else - um=sqrt(ur*ur+wc*wc) - endif + wc=0.5 + IF(dthv >= 0.)THEN + um=max(ur,0.1) + ELSE + um=sqrt(ur*ur+wc*wc) + ENDIF - rib=grav*zldis*dthv/(thv*um*um) + rib=grav*zldis*dthv/(thv*um*um) - if(rib >= 0.)then ! neutral or stable - zeta = rib*log(zldis/z0m)/(1.-5.*min(rib,0.19)) - zeta = min(2.,max(zeta,1.e-6)) - else ! unstable - zeta = rib*log(zldis/z0m) - zeta = max(-100.,min(zeta,-1.e-6)) - endif - obu=zldis/zeta + IF(rib >= 0.)THEN ! neutral or stable + zeta = rib*log(zldis/z0m)/(1.-5.*min(rib,0.19)) + zeta = min(2.,max(zeta,1.e-6)) + ELSE ! unstable + zeta = rib*log(zldis/z0m) + zeta = max(-100.,min(zeta,-1.e-6)) + ENDIF + obu=zldis/zeta - end subroutine moninobukini + END SUBROUTINE moninobukini - real(r8) function psi(k,zeta) + real(r8) FUNCTION psi(k,zeta) !======================================================================= -! stability function for unstable case (rib < 0) +! stability FUNCTION for unstable case (rib < 0) - use MOD_Precision - implicit none + USE MOD_Precision + IMPLICIT NONE - integer k - real(r8) zeta ! dimensionless height used in Monin-Obukhov theory - real(r8) chik ! + integer k + real(r8) zeta ! dimensionless height used in Monin-Obukhov theory + real(r8) chik ! chik = (1.-16.*zeta)**0.25 - if(k == 1)then + IF(k == 1)THEN psi = 2.*log((1.+chik)*0.5)+log((1.+chik*chik)*0.5)-2.*atan(chik)+2.*atan(1.) - else + ELSE psi = 2.*log((1.+chik*chik)*0.5) - endif - - end function psi + ENDIF + END FUNCTION psi END MODULE MOD_FrictionVelocity ! --------- EOP ------------ - diff --git a/main/MOD_Glacier.F90 b/main/MOD_Glacier.F90 index 335e97cf..71cf13f6 100644 --- a/main/MOD_Glacier.F90 +++ b/main/MOD_Glacier.F90 @@ -1,6 +1,6 @@ #include - MODULE MOD_Glacier +MODULE MOD_Glacier !----------------------------------------------------------------------- ! Energy and Mass Balance Model of LAND ICE (GLACIER / ICE SHEET) @@ -15,48 +15,48 @@ MODULE MOD_Glacier ! ! Hua Yuan, 01/2023: added snow layer absorption in GLACIER_TEMP() !----------------------------------------------------------------------- - use MOD_Precision - IMPLICIT NONE - SAVE + USE MOD_Precision + IMPLICIT NONE + SAVE ! PUBLIC MEMBER FUNCTIONS: - public :: GLACIER_TEMP - public :: GLACIER_WATER - public :: GLACIER_WATER_snicar + PUBLIC :: GLACIER_TEMP + PUBLIC :: GLACIER_WATER + PUBLIC :: GLACIER_WATER_snicar ! PRIVATE MEMBER FUNCTIONS: - private :: groundfluxes_glacier - private :: groundtem_glacier + PRIVATE :: groundfluxes_glacier + PRIVATE :: groundtem_glacier !----------------------------------------------------------------------- - CONTAINS +CONTAINS !----------------------------------------------------------------------- - subroutine GLACIER_TEMP (patchtype, lb ,nl_ice ,deltim ,& - zlnd ,zsno ,capr ,cnfac ,& - forc_hgt_u ,forc_hgt_t ,forc_hgt_q ,& - forc_us ,forc_vs ,forc_t ,forc_q ,& - forc_hpbl ,& - forc_rhoair ,forc_psrf ,coszen ,sabg ,& - forc_frl ,fsno ,dz_icesno ,z_icesno ,& - zi_icesno ,t_icesno ,wice_icesno ,wliq_icesno ,& - scv ,snowdp ,imelt ,taux ,& - tauy ,fsena ,fevpa ,lfevpa ,& - fseng ,fevpg ,olrg ,fgrnd ,& - qseva ,qsdew ,qsubl ,qfros ,& - sm ,tref ,qref ,trad ,& - errore ,emis ,z0m ,zol ,& - rib ,ustar ,qstar ,tstar ,& - fm ,fh ,fq ,pg_rain ,& - pg_snow ,t_precip ,snofrz ,sabg_snow_lyr) + SUBROUTINE GLACIER_TEMP (patchtype, lb ,nl_ice ,deltim ,& + zlnd ,zsno ,capr ,cnfac ,& + forc_hgt_u ,forc_hgt_t ,forc_hgt_q ,& + forc_us ,forc_vs ,forc_t ,forc_q ,& + forc_hpbl ,& + forc_rhoair ,forc_psrf ,coszen ,sabg ,& + forc_frl ,fsno ,dz_icesno ,z_icesno ,& + zi_icesno ,t_icesno ,wice_icesno ,wliq_icesno ,& + scv ,snowdp ,imelt ,taux ,& + tauy ,fsena ,fevpa ,lfevpa ,& + fseng ,fevpg ,olrg ,fgrnd ,& + qseva ,qsdew ,qsubl ,qfros ,& + sm ,tref ,qref ,trad ,& + errore ,emis ,z0m ,zol ,& + rib ,ustar ,qstar ,tstar ,& + fm ,fh ,fq ,pg_rain ,& + pg_snow ,t_precip ,snofrz ,sabg_snow_lyr) !======================================================================= -! this is the main subroutine to execute the calculation +! this is the main SUBROUTINE to execute the calculation ! of thermal processes and surface fluxes of the land ice (glacier and ice sheet) ! ! Original author : Yongjiu Dai and Nan Wei, /05/2014/ @@ -71,21 +71,21 @@ subroutine GLACIER_TEMP (patchtype, lb ,nl_ice ,deltim ,& ! !======================================================================= - use MOD_Precision - use MOD_Const_Physical, only : hvap,hsub,rgas,cpair,stefnc,tfrz,cpliq,cpice - use MOD_FrictionVelocity - USE MOD_Qsadv + USE MOD_Precision + USE MOD_Const_Physical, only: hvap,hsub,rgas,cpair,stefnc,tfrz,cpliq,cpice + USE MOD_FrictionVelocity + USE MOD_Qsadv - IMPLICIT NONE + IMPLICIT NONE !---------------------Argument------------------------------------------ - integer, INTENT(in) :: & + integer, intent(in) :: & patchtype,& ! land patch type (0=soil, 1=urban and built-up, 2=wetland, 3=land ice, 4=land water bodies, 99 = ocean) lb, &! lower bound of array nl_ice ! upper bound of array - real(r8), INTENT(in) :: & + real(r8), intent(in) :: & deltim, &! model time step [second] zlnd, &! roughness length for ice surface [m] zsno, &! roughness length for snow [m] @@ -118,25 +118,25 @@ subroutine GLACIER_TEMP (patchtype, lb ,nl_ice ,deltim ,& z_icesno (lb:nl_ice), &! node depth [m] zi_icesno(lb-1:nl_ice) ! interface depth [m] - REAL(r8), intent(in) :: & + real(r8), intent(in) :: & sabg_snow_lyr (lb:1) ! snow layer absorption [W/m-2] ! State variables (2) - real(r8), INTENT(inout) :: & + real(r8), intent(inout) :: & t_icesno(lb:nl_ice), &! snow/ice temperature [K] wice_icesno(lb:nl_ice),&! ice lens [kg/m2] wliq_icesno(lb:nl_ice),&! liqui water [kg/m2] scv, &! snow cover, water equivalent [mm, kg/m2] snowdp ! snow depth [m] - REAL(r8), intent(inout) :: & + real(r8), intent(inout) :: & snofrz (lb:0) ! snow freezing rate (lyr) [kg m-2 s-1] - integer, INTENT(out) :: & - imelt(lb:nl_ice) ! flag for melting or freezing [-] + integer, intent(out) :: & + imelt(lb:nl_ice) ! flag for melting or freezing [-] ! Output 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 to atmosphere [W/m2] @@ -164,38 +164,38 @@ subroutine GLACIER_TEMP (patchtype, lb ,nl_ice ,deltim ,& ustar, &! u* in similarity theory [m/s] qstar, &! q* in similarity theory [kg/kg] tstar, &! t* in similarity theory [K] - fm, &! integral of profile function for momentum - fh, &! integral of profile function for heat - fq ! integral of profile function for moisture + fm, &! integral of profile FUNCTION for momentum + fh, &! integral of profile FUNCTION for heat + fq ! integral of profile FUNCTION for moisture !---------------------Local Variables----------------------------------- - integer i,j - - real(r8) :: & - cgrnd, &! deriv. of ice energy flux wrt to ice temp [w/m2/k] - cgrndl, &! deriv, of ice sensible heat flux wrt ice temp [w/m2/k] - cgrnds, &! deriv of ice latent heat flux wrt ice temp [w/m**2/k] - degdT, &! d(eg)/dT - dqgdT, &! d(qg)/dT - eg, &! water vapor pressure at temperature T [pa] - egsmax, &! max. evaporation which ice can provide at one time step - egidif, &! the excess of evaporation over "egsmax" - emg, &! ground emissivity (0.96) - errore, &! energy balnce error [w/m2] - fact(lb:nl_ice), &! used in computing tridiagonal matrix - htvp, &! latent heat of vapor of water (or sublimation) [j/kg] - qg, &! ground specific humidity [kg/kg] - qsatg, &! saturated humidity [kg/kg] - qsatgdT, &! d(qsatg)/dT - qred, &! ice surface relative humidity - thm, &! intermediate variable (forc_t+0.0098*forc_hgt_t) - th, &! potential temperature (kelvin) - thv, &! virtual potential temperature (kelvin) - t_grnd, &! ground surface temperature [K] - t_icesno_bef(lb:nl_ice), &! ice/snow temperature before update - tinc, &! temperature difference of two time step - ur, &! wind speed at reference height [m/s] - xmf ! total latent heat of phase change of ground water + integer i,j + + real(r8) :: & + cgrnd, &! deriv. of ice energy flux wrt to ice temp [w/m2/k] + cgrndl, &! deriv, of ice sensible heat flux wrt ice temp [w/m2/k] + cgrnds, &! deriv of ice latent heat flux wrt ice temp [w/m**2/k] + degdT, &! d(eg)/dT + dqgdT, &! d(qg)/dT + eg, &! water vapor pressure at temperature T [pa] + egsmax, &! max. evaporation which ice can provide at one time step + egidif, &! the excess of evaporation over "egsmax" + emg, &! ground emissivity (0.96) + errore, &! energy balnce error [w/m2] + fact(lb:nl_ice), &! used in computing tridiagonal matrix + htvp, &! latent heat of vapor of water (or sublimation) [j/kg] + qg, &! ground specific humidity [kg/kg] + qsatg, &! saturated humidity [kg/kg] + qsatgdT, &! d(qsatg)/dT + qred, &! ice surface relative humidity + thm, &! intermediate variable (forc_t+0.0098*forc_hgt_t) + th, &! potential temperature (kelvin) + thv, &! virtual potential temperature (kelvin) + t_grnd, &! ground surface temperature [K] + t_icesno_bef(lb:nl_ice), &! ice/snow temperature before update + tinc, &! temperature difference of two time step + ur, &! wind speed at reference height [m/s] + xmf ! total latent heat of phase change of ground water !======================================================================= ! [1] Initial set and propositional variables @@ -210,7 +210,7 @@ subroutine GLACIER_TEMP (patchtype, lb ,nl_ice ,deltim ,& ! latent heat, assumed that the sublimation occured only as wliq_icesno=0 htvp = hvap - if(wliq_icesno(lb)<=0. .and. wice_icesno(lb)>0.) htvp = hsub + IF(wliq_icesno(lb)<=0. .and. wice_icesno(lb)>0.) htvp = hsub ! potential temperatur at the reference height thm = forc_t + 0.0098*forc_hgt_t ! intermediate variable equivalent to @@ -224,7 +224,7 @@ subroutine GLACIER_TEMP (patchtype, lb ,nl_ice ,deltim ,& !======================================================================= qred = 1. - call qsadv(t_grnd,forc_psrf,eg,degdT,qsatg,qsatgdT) + CALL qsadv(t_grnd,forc_psrf,eg,degdT,qsatg,qsatgdT) qg = qred*qsatg dqgdT = qred*qsatgdT @@ -234,7 +234,7 @@ subroutine GLACIER_TEMP (patchtype, lb ,nl_ice ,deltim ,& ! to ground temperature using ground temperatures from previous time step. !======================================================================= - call groundfluxes_glacier (zlnd,zsno,forc_hgt_u,forc_hgt_t,forc_hgt_q,& + CALL groundfluxes_glacier (zlnd,zsno,forc_hgt_u,forc_hgt_t,forc_hgt_q,& forc_us,forc_vs,forc_t,forc_q,forc_rhoair,forc_psrf, & ur,thm,th,thv,t_grnd,qg,dqgdT,htvp,& forc_hpbl,& @@ -246,7 +246,7 @@ subroutine GLACIER_TEMP (patchtype, lb ,nl_ice ,deltim ,& ! [4] Gound temperature !======================================================================= - call groundtem_glacier (patchtype,lb,nl_ice,deltim,& + CALL groundtem_glacier (patchtype,lb,nl_ice,deltim,& capr,cnfac,dz_icesno,z_icesno,zi_icesno,& t_icesno,wice_icesno,wliq_icesno,scv,snowdp,& forc_frl,sabg,sabg_snow_lyr,fseng,fevpg,cgrnd,htvp,emg,& @@ -262,7 +262,7 @@ subroutine GLACIER_TEMP (patchtype, lb ,nl_ice ,deltim ,& fevpg = fevpg + tinc*cgrndl ! 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. egsmax = (wice_icesno(lb)+wliq_icesno(lb)) / deltim @@ -281,16 +281,16 @@ subroutine GLACIER_TEMP (patchtype, lb ,nl_ice ,deltim ,& qfros = 0. qsdew = 0. - if(fevpg >= 0)then + IF(fevpg >= 0)THEN qseva = min(wliq_icesno(lb)/deltim, fevpg) qsubl = fevpg - qseva - else - if(t_grnd < tfrz)then + ELSE + IF(t_grnd < tfrz)THEN qfros = abs(fevpg) - else + ELSE qsdew = abs(fevpg) - endif - end if + ENDIF + ENDIF ! ground heat flux fgrnd = sabg + emg*forc_frl & @@ -317,52 +317,52 @@ subroutine GLACIER_TEMP (patchtype, lb ,nl_ice ,deltim ,& errore = sabg + forc_frl - olrg - fsena - lfevpa - xmf & + cpliq * pg_rain * (t_precip-t_icesno(lb)) & + cpice * pg_snow * (t_precip-t_icesno(lb)) - do j = lb, nl_ice + DO j = lb, nl_ice errore = errore - (t_icesno(j)-t_icesno_bef(j))/fact(j) - enddo + ENDDO #if (defined CoLMDEBUG) - if(abs(errore)>.2)then + IF(abs(errore)>.2)THEN write(6,*) 'GLACIER_TEMP.F90 : energy balance violation' write(6,100) errore,sabg,forc_frl,olrg,fsena,lfevpa,xmf,t_precip,t_icesno(lb) STOP - endif + ENDIF 100 format(10(f7.3)) #endif - end subroutine GLACIER_TEMP + END SUBROUTINE GLACIER_TEMP - subroutine groundfluxes_glacier (zlnd,zsno,hu,ht,hq,& - us,vs,tm,qm,rhoair,psrf,& - ur,thm,th,thv,t_grnd,qg,dqgdT,htvp,& - hpbl,& - fsno,cgrnd,cgrndl,cgrnds,& - taux,tauy,fsena,fevpa,fseng,fevpg,tref,qref,& - z0m,zol,rib,ustar,qstar,tstar,fm,fh,fq) + SUBROUTINE groundfluxes_glacier (zlnd,zsno,hu,ht,hq,& + us,vs,tm,qm,rhoair,psrf,& + ur,thm,th,thv,t_grnd,qg,dqgdT,htvp,& + hpbl,& + fsno,cgrnd,cgrndl,cgrnds,& + taux,tauy,fsena,fevpa,fseng,fevpg,tref,qref,& + z0m,zol,rib,ustar,qstar,tstar,fm,fh,fq) !======================================================================= -! this is the main subroutine to execute the calculation of thermal processes +! this is the main SUBROUTINE to execute the calculation of thermal processes ! and surface fluxes of land ice (glacier and ice sheet) ! ! Original author : Yongjiu Dai and Nan Wei, /05/2014/ ! ! REVISIONS: -! Shaofeng Liu, 05/2023: add option to call moninobuk_leddy, the LargeEddy +! Shaofeng Liu, 05/2023: add option to CALL moninobuk_leddy, the LargeEddy ! surface turbulence scheme (LZD2022); ! make a proper update of um. !======================================================================= - use MOD_Precision - use MOD_Const_Physical, only : cpair,vonkar,grav - use MOD_FrictionVelocity - USE MOD_Namelist, only: DEF_USE_CBL_HEIGHT - USE MOD_TurbulenceLEddy - implicit none + USE MOD_Precision + USE MOD_Const_Physical, only : cpair,vonkar,grav + USE MOD_FrictionVelocity + USE MOD_Namelist, only: DEF_USE_CBL_HEIGHT + USE MOD_TurbulenceLEddy + IMPLICIT NONE !----------------------- Dummy argument -------------------------------- - real(r8), INTENT(in) :: & + real(r8), intent(in) :: & zlnd, &! roughness length for ice [m] zsno, &! roughness length for snow [m] @@ -388,11 +388,11 @@ subroutine groundfluxes_glacier (zlnd,zsno,hu,ht,hq,& qg, &! ground specific humidity [kg/kg] dqgdT, &! d(qg)/dT htvp ! latent heat of vapor of water (or sublimation) [j/kg] - real(r8), INTENT(in) :: & + real(r8), intent(in) :: & hpbl ! atmospheric boundary layer height [m] - 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 to atmosphere [W/m2] @@ -411,16 +411,16 @@ subroutine groundfluxes_glacier (zlnd,zsno,hu,ht,hq,& ustar, &! friction velocity [m/s] tstar, &! temperature scaling parameter qstar, &! moisture scaling parameter - fm, &! integral of profile function for momentum - fh, &! integral of profile function for heat - fq ! integral of profile function for moisture + fm, &! integral of profile FUNCTION for momentum + fh, &! integral of profile FUNCTION for heat + 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] dth, &! diff of virtual temp. between ref. height and surface @@ -435,7 +435,7 @@ subroutine groundfluxes_glacier (zlnd,zsno,hu,ht,hq,& raiw, &! temporary variable [kg/m2/s] fh2m, &! relation for temperature at 2m fq2m, &! relation for specific humidity at 2m - fm10m, &! integral of profile function for momentum at 10m + fm10m, &! integral of profile FUNCTION for momentum at 10m thvstar, &! virtual potential temperature scaling parameter um, &! wind speed including the stablity effect [m/s] wc, &! convective velocity [m/s] @@ -449,17 +449,17 @@ subroutine groundfluxes_glacier (zlnd,zsno,hu,ht,hq,& !----------------------- Dummy argument -------------------------------- ! initial roughness length - if(fsno > 0.)then + IF(fsno > 0.)THEN ! z0mg = zsno z0mg = 0.002 ! Table 1 of Brock et al., (2006) z0hg = z0mg z0qg = z0mg - else + ELSE ! z0mg = zlnd z0mg = 0.001 ! Table 1 of Brock et al., (2006) z0hg = z0mg z0qg = z0mg - endif + ENDIF ! potential temperatur at the reference height beta = 1. ! - (in computing W_*) @@ -479,22 +479,22 @@ subroutine groundfluxes_glacier (zlnd,zsno,hu,ht,hq,& dthv = dth*(1.+0.61*qm)+0.61*th*dqh zldis = hu-0. - call moninobukini(ur,th,thm,thv,dth,dqh,dthv,zldis,z0mg,um,obu) + CALL moninobukini(ur,th,thm,thv,dth,dqh,dthv,zldis,z0mg,um,obu) ! Evaluated stability-dependent variables using moz from prior iteration niters=6 !---------------------------------------------------------------- - ITERATION : do iter = 1, niters ! begin stability iteration + ITERATION : DO iter = 1, niters ! begin stability iteration !---------------------------------------------------------------- displax = 0. - if (DEF_USE_CBL_HEIGHT) then - call moninobuk_leddy(hu,ht,hq,displax,z0mg,z0hg,z0qg,obu,um, hpbl, & + IF (DEF_USE_CBL_HEIGHT) THEN + CALL moninobuk_leddy(hu,ht,hq,displax,z0mg,z0hg,z0qg,obu,um, hpbl, & ustar,fh2m,fq2m,fm10m,fm,fh,fq) - else - call moninobuk(hu,ht,hq,displax,z0mg,z0hg,z0qg,obu,um,& + ELSE + CALL moninobuk(hu,ht,hq,displax,z0mg,z0hg,z0qg,obu,um,& ustar,fh2m,fq2m,fm10m,fm,fh,fq) - endif + ENDIF tstar = vonkar/fh*dth qstar = vonkar/fq*dqh @@ -504,31 +504,31 @@ subroutine groundfluxes_glacier (zlnd,zsno,hu,ht,hq,& thvstar=tstar*(1.+0.61*qm)+0.61*th*qstar zeta=zldis*vonkar*grav*thvstar/(ustar**2*thv) - if(zeta >= 0.) then !stable + IF(zeta >= 0.) THEN !stable zeta = min(2.,max(zeta,1.e-6)) - else !unstable + ELSE !unstable zeta = max(-100.,min(zeta,-1.e-6)) - endif + ENDIF obu = zldis/zeta - if(zeta >= 0.)then + IF(zeta >= 0.)THEN um = max(ur,0.1) - else - if (DEF_USE_CBL_HEIGHT) then !//TODO: Shaofeng, 2023.05.18 + ELSE + IF (DEF_USE_CBL_HEIGHT) THEN !//TODO: Shaofeng, 2023.05.18 zii = max(5.*hu,hpbl) - endif !//TODO: Shaofeng, 2023.05.18 + ENDIF !//TODO: Shaofeng, 2023.05.18 wc = (-grav*ustar*thvstar*zii/thv)**(1./3.) wc2 = beta*beta*(wc*wc) um = sqrt(ur*ur+wc2) - endif + ENDIF - if (obuold*obu < 0.) nmozsgn = nmozsgn+1 - if (nmozsgn >= 4) EXIT + IF (obuold*obu < 0.) nmozsgn = nmozsgn+1 + IF (nmozsgn >= 4) EXIT obuold = obu !---------------------------------------------------------------- - enddo ITERATION ! end stability iteration + ENDDO ITERATION ! END stability iteration !---------------------------------------------------------------- ! Get derivative of fluxes with repect to ground temperature @@ -559,15 +559,15 @@ subroutine groundfluxes_glacier (zlnd,zsno,hu,ht,hq,& tref = (thm + vonkar/fh*dth * (fh2m/vonkar - fh/vonkar)) qref = ( qm + vonkar/fq*dqh * (fq2m/vonkar - fq/vonkar)) - end subroutine groundfluxes_glacier + END SUBROUTINE groundfluxes_glacier - subroutine groundtem_glacier (patchtype,lb,nl_ice,deltim,& - capr,cnfac,dz_icesno,z_icesno,zi_icesno,& - t_icesno,wice_icesno,wliq_icesno,scv,snowdp,& - forc_frl,sabg,sabg_snow_lyr,fseng,fevpg,cgrnd,htvp,emg,& - imelt,snofrz,sm,xmf,fact,pg_rain,pg_snow,t_precip) + SUBROUTINE groundtem_glacier (patchtype,lb,nl_ice,deltim,& + capr,cnfac,dz_icesno,z_icesno,zi_icesno,& + t_icesno,wice_icesno,wliq_icesno,scv,snowdp,& + forc_frl,sabg,sabg_snow_lyr,fseng,fevpg,cgrnd,htvp,emg,& + imelt,snofrz,sm,xmf,fact,pg_rain,pg_snow,t_precip) !======================================================================= ! SNOW and LAND ICE temperatures @@ -594,107 +594,107 @@ subroutine groundtem_glacier (patchtype,lb,nl_ice,deltim,& ! flux, temperature and melt calculation. !======================================================================= - use MOD_Precision - USE MOD_Namelist, only: DEF_USE_SNICAR - use MOD_Const_Physical, only : stefnc,cpice,cpliq,denh2o,denice,tfrz,tkwat,tkice,tkair - USE MOD_PhaseChange - USE MOD_Utils - - IMPLICIT NONE - - integer, INTENT(in) :: patchtype ! land patch type (0=soil, 1=urban and built-up, - ! 2=wetland, 3=land ice, 4=land water bodies, 99 = ocean) - integer, INTENT(in) :: lb !lower bound of array - integer, INTENT(in) :: nl_ice !upper 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) :: dz_icesno(lb:nl_ice) !layer thickiness [m] - real(r8), INTENT(in) :: z_icesno (lb:nl_ice) !node depth [m] - real(r8), INTENT(in) :: zi_icesno(lb-1:nl_ice) !interface depth [m] - - real(r8), INTENT(in) :: sabg !solar radiation absorbed by ground [W/m2] - real(r8), INTENT(in) :: forc_frl !atmospheric infrared (longwave) radiation [W/m2] - real(r8), INTENT(in) :: fseng !sensible heat flux from ground [W/m2] - real(r8), INTENT(in) :: fevpg !evaporation heat flux from ground [mm/s] - real(r8), INTENT(in) :: cgrnd !deriv. of ice energy flux wrt to ice temp [W/m2/k] - real(r8), INTENT(in) :: htvp !latent heat of vapor of water (or sublimation) [J/kg] - real(r8), INTENT(in) :: emg !ground emissivity (0.97 for snow, - real(r8), INTENT(in) :: t_precip ! snowfall/rainfall temperature [kelvin] - real(r8), INTENT(in) :: pg_rain ! rainfall [kg/(m2 s)] - real(r8), INTENT(in) :: pg_snow ! snowfall [kg/(m2 s)] - - REAL(r8), intent(in) :: sabg_snow_lyr (lb:1) !snow layer absorption [W/m-2] - - real(r8), INTENT(inout) :: t_icesno (lb:nl_ice) !snow and ice temperature [K] - real(r8), INTENT(inout) :: wice_icesno(lb:nl_ice) !ice lens [kg/m2] - real(r8), INTENT(inout) :: wliq_icesno(lb:nl_ice) !liqui water [kg/m2] - real(r8), INTENT(inout) :: scv !snow cover, water equivalent [mm, kg/m2] - real(r8), INTENT(inout) :: snowdp !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_ice) !used in computing tridiagonal matrix - integer, INTENT(out) :: imelt(lb:nl_ice) !flag for melting or freezing [-] - - REAL(r8), intent(out) :: snofrz(lb:0) !snow freezing rate (lyr) [kg m-2 s-1] + USE MOD_Precision + USE MOD_Namelist, only: DEF_USE_SNICAR + USE MOD_Const_Physical, only : stefnc,cpice,cpliq,denh2o,denice,tfrz,tkwat,tkice,tkair + USE MOD_PhaseChange + USE MOD_Utils + + IMPLICIT NONE + + integer, intent(in) :: patchtype ! land patch type (0=soil, 1=urban and built-up, + ! 2=wetland, 3=land ice, 4=land water bodies, 99 = ocean) + integer, intent(in) :: lb !lower bound of array + integer, intent(in) :: nl_ice !upper 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) :: dz_icesno(lb:nl_ice) !layer thickiness [m] + real(r8), intent(in) :: z_icesno (lb:nl_ice) !node depth [m] + real(r8), intent(in) :: zi_icesno(lb-1:nl_ice) !interface depth [m] + + real(r8), intent(in) :: sabg !solar radiation absorbed by ground [W/m2] + real(r8), intent(in) :: forc_frl !atmospheric infrared (longwave) radiation [W/m2] + real(r8), intent(in) :: fseng !sensible heat flux from ground [W/m2] + real(r8), intent(in) :: fevpg !evaporation heat flux from ground [mm/s] + real(r8), intent(in) :: cgrnd !deriv. of ice energy flux wrt to ice temp [W/m2/k] + real(r8), intent(in) :: htvp !latent heat of vapor of water (or sublimation) [J/kg] + real(r8), intent(in) :: emg !ground emissivity (0.97 for snow, + real(r8), intent(in) :: t_precip ! snowfall/rainfall temperature [kelvin] + real(r8), intent(in) :: pg_rain ! rainfall [kg/(m2 s)] + real(r8), intent(in) :: pg_snow ! snowfall [kg/(m2 s)] + + real(r8), intent(in) :: sabg_snow_lyr (lb:1) !snow layer absorption [W/m-2] + + real(r8), intent(inout) :: t_icesno (lb:nl_ice) !snow and ice temperature [K] + real(r8), intent(inout) :: wice_icesno(lb:nl_ice) !ice lens [kg/m2] + real(r8), intent(inout) :: wliq_icesno(lb:nl_ice) !liqui water [kg/m2] + real(r8), intent(inout) :: scv !snow cover, water equivalent [mm, kg/m2] + real(r8), intent(inout) :: snowdp !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_ice) !used in computing tridiagonal matrix + integer, intent(out) :: imelt(lb:nl_ice) !flag for melting or freezing [-] + + real(r8), intent(out) :: snofrz(lb:0) !snow freezing rate (lyr) [kg m-2 s-1] !------------------------ local variables ------------------------------ - real(r8) rhosnow ! partitial density of water (ice + liquid) - real(r8) cv(lb:nl_ice) ! heat capacity [J/(m2 K)] - real(r8) thk(lb:nl_ice) ! thermal conductivity of layer - real(r8) tk(lb:nl_ice) ! thermal conductivity [W/(m K)] - - real(r8) at(lb:nl_ice) !"a" vector for tridiagonal matrix - real(r8) bt(lb:nl_ice) !"b" vector for tridiagonal matrix - real(r8) ct(lb:nl_ice) !"c" vector for tridiagonal matrix - real(r8) rt(lb:nl_ice) !"r" vector for tridiagonal solution - - real(r8) fn (lb:nl_ice) ! heat diffusion through the layer interface [W/m2] - real(r8) fn1 (lb:nl_ice) ! 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_icesno_bef(lb:nl_ice) ! snow/ice temperature before update - real(r8) wice_icesno_bef(lb:0) ! ice lens [kg/m2] - real(r8) hs ! net energy flux into the surface (w/m2) - real(r8) dhsdt ! d(hs)/dT - real(r8) brr(lb:nl_ice) ! temporay set - - integer i,j - - real(r8) :: porsl(1:nl_ice) ! not used - real(r8) :: psi0 (1:nl_ice) ! not used + real(r8) rhosnow ! partitial density of water (ice + liquid) + real(r8) cv(lb:nl_ice) ! heat capacity [J/(m2 K)] + real(r8) thk(lb:nl_ice) ! thermal conductivity of layer + real(r8) tk(lb:nl_ice) ! thermal conductivity [W/(m K)] + + real(r8) at(lb:nl_ice) !"a" vector for tridiagonal matrix + real(r8) bt(lb:nl_ice) !"b" vector for tridiagonal matrix + real(r8) ct(lb:nl_ice) !"c" vector for tridiagonal matrix + real(r8) rt(lb:nl_ice) !"r" vector for tridiagonal solution + + real(r8) fn (lb:nl_ice) ! heat diffusion through the layer interface [W/m2] + real(r8) fn1 (lb:nl_ice) ! 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_icesno_bef(lb:nl_ice) ! snow/ice temperature before update + real(r8) wice_icesno_bef(lb:0) ! ice lens [kg/m2] + real(r8) hs ! net energy flux into the surface (w/m2) + real(r8) dhsdt ! d(hs)/dT + real(r8) brr(lb:nl_ice) ! temporay set + + integer i,j + + real(r8) :: porsl(1:nl_ice) ! not used + real(r8) :: psi0 (1:nl_ice) ! not used #ifdef Campbell_SOIL_MODEL - real(r8) :: bsw(1:nl_ice) ! not used + real(r8) :: bsw(1:nl_ice) ! not used #endif #ifdef vanGenuchten_Mualem_SOIL_MODEL - real(r8) :: theta_r (1:nl_ice), & - alpha_vgm(1:nl_ice), & - n_vgm (1:nl_ice), & - L_vgm (1:nl_ice), & - sc_vgm (1:nl_ice), & - fc_vgm (1:nl_ice) + real(r8) :: theta_r (1:nl_ice), & + alpha_vgm(1:nl_ice), & + n_vgm (1:nl_ice), & + L_vgm (1:nl_ice), & + sc_vgm (1:nl_ice), & + fc_vgm (1:nl_ice) #endif !======================================================================= ! SNOW and LAND ICE heat capacity cv(1:) = wice_icesno(1:)*cpice + wliq_icesno(1:)*cpliq - if(lb==1 .and. scv>0.) cv(1) = cv(1) + cpice*scv + IF(lb==1 .and. scv>0.) cv(1) = cv(1) + cpice*scv - if(lb<=0)then + IF(lb<=0)THEN cv(:0) = cpliq*wliq_icesno(:0) + cpice*wice_icesno(:0) - endif + ENDIF ! SNOW and LAND ICE thermal conductivity [W/(m K)] - do j = lb, nl_ice + DO j = lb, nl_ice thk(j) = tkwat - if(t_icesno(j)<=tfrz) thk(j) = 9.828*exp(-0.0057*t_icesno(j)) - enddo + IF(t_icesno(j)<=tfrz) thk(j) = 9.828*exp(-0.0057*t_icesno(j)) + ENDDO - if(lb < 1)then - do j = lb, 0 + IF(lb < 1)THEN + DO j = lb, 0 rhosnow = (wice_icesno(j)+wliq_icesno(j))/dz_icesno(j) ! presently option [1] is the default option @@ -711,11 +711,11 @@ subroutine groundtem_glacier (patchtype,lb,nl_ice,deltim,& ! thk(j) = 2.2*(rhosnow/denice)**1.88 ! [6] van Dusen (1992) presented in Sturm et al. (1997) ! thk(j) = 0.021 + 0.42e-3*rhosnow + 0.22e-6*rhosnow**2 - enddo - endif + ENDDO + ENDIF ! Thermal conductivity at the layer interface - do j = lb, nl_ice-1 + DO j = lb, nl_ice-1 ! the following consideration is try to avoid the snow conductivity ! to be dominant in the thermal conductivity of the interface. @@ -723,14 +723,14 @@ subroutine groundtem_glacier (patchtype,lb,nl_ice,deltim,& ! is larger than that of interface to top ice node, ! the snow thermal conductivity will be dominant, and the result is that ! lees heat tranfer between snow and ice - if((j==0) .and. (z_icesno(j+1)-zi_icesno(j)=1)then + IF (lb>=1)THEN gwat = pg_rain + sm - qseva - else - call snowwater (lb,deltim,ssi,wimp,& + ELSE + CALL snowwater (lb,deltim,ssi,wimp,& pg_rain,qseva,qsdew,qsubl,qfros,& dz_icesno(lb:0),wice_icesno(lb:0),wliq_icesno(lb:0),gwat) - endif + ENDIF !======================================================================= ! [2] surface runoff and infiltration !======================================================================= - if(snl<0)then + IF(snl<0)THEN ! Compaction rate for snow ! Natural compaction and metamorphosis. The compaction rate ! is recalculated for every new timestep lb = snl + 1 ! lower bound of array - call snowcompaction (lb,deltim,& + CALL snowcompaction (lb,deltim,& imelt(lb:0),fiold(lb:0),t_icesno(lb:0),& wliq_icesno(lb:0),wice_icesno(lb:0),forc_us,forc_vs,dz_icesno(lb:0)) ! Combine thin snow elements lb = maxsnl + 1 - call snowlayerscombine (lb,snl,& + CALL snowlayerscombine (lb,snl,& z_icesno(lb:1),dz_icesno(lb:1),zi_icesno(lb-1:1),& wliq_icesno(lb:1),wice_icesno(lb:1),t_icesno(lb:1),scv,snowdp) ! Divide thick snow elements - if(snl<0) & - call snowlayersdivide (lb,snl,& + IF(snl<0) & + CALL snowlayersdivide (lb,snl,& z_icesno(lb:0),dz_icesno(lb:0),zi_icesno(lb-1:0),& wliq_icesno(lb:0),wice_icesno(lb:0),t_icesno(lb:0)) - endif + ENDIF - if (snl > maxsnl) then + IF (snl > maxsnl) THEN wice_icesno(maxsnl+1:snl) = 0. wliq_icesno(maxsnl+1:snl) = 0. t_icesno (maxsnl+1:snl) = 0. z_icesno (maxsnl+1:snl) = 0. dz_icesno (maxsnl+1:snl) = 0. - endif + ENDIF - if(lb >= 1)then + IF(lb >= 1)THEN wliq_icesno(1) = max(1.e-8, wliq_icesno(1) + qsdew * deltim) wice_icesno(1) = max(1.e-8, wice_icesno(1) + (qfros-qsubl) * deltim) - end if + ENDIF - end subroutine GLACIER_WATER + END SUBROUTINE GLACIER_WATER - subroutine GLACIER_WATER_snicar ( nl_ice,maxsnl,deltim,& - z_icesno ,dz_icesno ,zi_icesno ,t_icesno,& - wliq_icesno ,wice_icesno ,pg_rain ,pg_snow ,& - sm ,scv ,snowdp ,imelt ,& - fiold ,snl ,qseva ,qsdew ,& - qsubl ,qfros ,gwat , & - ssi ,wimp ,forc_us ,forc_vs ,& - ! SNICAR - forc_aer ,& - mss_bcpho ,mss_bcphi ,mss_ocpho,mss_ocphi,& - mss_dst1 ,mss_dst2 ,mss_dst3 ,mss_dst4 ) + SUBROUTINE GLACIER_WATER_snicar ( nl_ice,maxsnl,deltim,& + z_icesno ,dz_icesno ,zi_icesno ,t_icesno,& + wliq_icesno ,wice_icesno ,pg_rain ,pg_snow ,& + sm ,scv ,snowdp ,imelt ,& + fiold ,snl ,qseva ,qsdew ,& + qsubl ,qfros ,gwat , & + ssi ,wimp ,forc_us ,forc_vs ,& + ! SNICAR + forc_aer ,& + mss_bcpho ,mss_bcphi ,mss_ocpho,mss_ocphi,& + mss_dst1 ,mss_dst2 ,mss_dst3 ,mss_dst4 ) !======================================================================= - use MOD_Precision - use MOD_Const_Physical, only : denice, denh2o, tfrz - use MOD_SnowLayersCombineDivide - use MOD_SoilSnowHydrology + USE MOD_Precision + USE MOD_Const_Physical, only : denice, denh2o, tfrz + USE MOD_SnowLayersCombineDivide + USE MOD_SoilSnowHydrology - IMPLICIT NONE + IMPLICIT NONE !-----------------------Argument---------- ------------------------------ - integer, INTENT(in) :: nl_ice ! upper bound of array - integer, INTENT(in) :: maxsnl ! maximum number of snow layers + integer, intent(in) :: nl_ice ! upper bound of array + integer, intent(in) :: maxsnl ! maximum number of snow layers - real(r8), INTENT(in) :: & + real(r8), intent(in) :: & deltim , &! time step (s) ssi , &! irreducible water saturation of snow - wimp , &! water impremeable if porosity less than wimp + wimp , &! water impremeable IF porosity less than wimp pg_rain , &! rainfall (mm h2o/s) pg_snow , &! snowfall (mm h2o/s) sm , &! snow melt (mm h2o/s) @@ -1023,10 +1023,10 @@ subroutine GLACIER_WATER_snicar ( nl_ice,maxsnl,deltim,& qfros , &! surface dew added to snow pack (mm h2o /s) [+] fiold(maxsnl+1:nl_ice) ! fraction of ice relative to the total water - integer, INTENT(in) :: imelt(maxsnl+1:nl_ice) ! flag for: melting=1, freezing=2, nothing happended=0 - integer, INTENT(inout) :: snl ! lower bound of array + integer, intent(in) :: imelt(maxsnl+1:nl_ice) ! flag for: melting=1, freezing=2, nothing happended=0 + integer, intent(inout) :: snl ! lower bound of array - real(r8), INTENT(inout) :: & + real(r8), intent(inout) :: & z_icesno (maxsnl+1:nl_ice) , &! layer depth (m) dz_icesno (maxsnl+1:nl_ice) , &! layer thickness (m) zi_icesno (maxsnl :nl_ice) , &! interface level below a "z" level (m) @@ -1036,16 +1036,16 @@ subroutine GLACIER_WATER_snicar ( nl_ice,maxsnl,deltim,& scv , &! snow mass (kg/m2) snowdp ! snow depth (m) - real(r8), INTENT(out) :: & + real(r8), intent(out) :: & gwat ! net water input from top (mm/s) - real(r8), intent(in) :: forc_us - real(r8), intent(in) :: forc_vs + real(r8), intent(in) :: forc_us + real(r8), intent(in) :: forc_vs ! 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 (maxsnl+1:0), &! mass of hydrophobic BC in snow (col,lyr) [kg] mss_bcphi (maxsnl+1:0), &! mass of hydrophillic BC in snow (col,lyr) [kg] mss_ocpho (maxsnl+1:0), &! mass of hydrophobic OC in snow (col,lyr) [kg] @@ -1059,7 +1059,7 @@ subroutine GLACIER_WATER_snicar ( nl_ice,maxsnl,deltim,& ! !-----------------------Local Variables------------------------------ ! - integer lb, j + integer lb, j !======================================================================= ! [1] update the liquid water within snow layer and the water onto the ice surface @@ -1072,27 +1072,27 @@ subroutine GLACIER_WATER_snicar ( nl_ice,maxsnl,deltim,& !======================================================================= lb = snl + 1 - if (lb>=1)then + IF (lb>=1)THEN gwat = pg_rain + sm - qseva - else - call snowwater_snicar (lb,deltim,ssi,wimp,& + ELSE + CALL snowwater_snicar (lb,deltim,ssi,wimp,& pg_rain,qseva,qsdew,qsubl,qfros,& dz_icesno(lb:0),wice_icesno(lb:0),wliq_icesno(lb:0),gwat,& forc_aer,& mss_bcpho(lb:0), mss_bcphi(lb:0), mss_ocpho(lb:0), mss_ocphi(lb:0),& mss_dst1(lb:0), mss_dst2(lb:0), mss_dst3(lb:0), mss_dst4(lb:0) ) - endif + ENDIF !======================================================================= ! [2] surface runoff and infiltration !======================================================================= - if(snl<0)then + IF(snl<0)THEN ! Compaction rate for snow ! Natural compaction and metamorphosis. The compaction rate ! is recalculated for every new timestep lb = snl + 1 ! lower bound of array - call snowcompaction (lb,deltim,& + CALL snowcompaction (lb,deltim,& imelt(lb:0),fiold(lb:0),t_icesno(lb:0),& wliq_icesno(lb:0),wice_icesno(lb:0),forc_us,forc_vs,dz_icesno(lb:0)) @@ -1105,29 +1105,27 @@ subroutine GLACIER_WATER_snicar ( nl_ice,maxsnl,deltim,& mss_dst1(lb:0), mss_dst2(lb:0), mss_dst3(lb:0), mss_dst4(lb:0) ) ! Divide thick snow elements - if(snl<0) & + IF(snl<0) & CALL snowlayersdivide_snicar (lb,snl,& z_icesno(lb:0),dz_icesno(lb:0),zi_icesno(lb-1:0),& wliq_icesno(lb:0),wice_icesno(lb:0),t_icesno(lb:0),& mss_bcpho(lb:0), mss_bcphi(lb:0), mss_ocpho(lb:0), mss_ocphi(lb:0),& mss_dst1(lb:0), mss_dst2(lb:0), mss_dst3(lb:0), mss_dst4(lb:0) ) - endif + ENDIF - if (snl > maxsnl) then + IF (snl > maxsnl) THEN wice_icesno(maxsnl+1:snl) = 0. wliq_icesno(maxsnl+1:snl) = 0. t_icesno (maxsnl+1:snl) = 0. z_icesno (maxsnl+1:snl) = 0. dz_icesno (maxsnl+1:snl) = 0. - endif + ENDIF - if(lb >= 1)then + IF(lb >= 1)THEN wliq_icesno(1) = max(1.e-8, wliq_icesno(1) + qsdew * deltim) wice_icesno(1) = max(1.e-8, wice_icesno(1) + (qfros-qsubl) * deltim) - end if - - end subroutine GLACIER_WATER_snicar - + ENDIF + END SUBROUTINE GLACIER_WATER_snicar - END MODULE MOD_Glacier +END MODULE MOD_Glacier diff --git a/main/MOD_GroundFluxes.F90 b/main/MOD_GroundFluxes.F90 index f6ad9e49..414267f3 100644 --- a/main/MOD_GroundFluxes.F90 +++ b/main/MOD_GroundFluxes.F90 @@ -11,12 +11,12 @@ MODULE MOD_GroundFluxes !----------------------------------------------------------------------- - CONTAINS +CONTAINS !----------------------------------------------------------------------- - subroutine GroundFluxes (zlnd, zsno, hu, ht, hq, hpbl, & + SUBROUTINE GroundFluxes (zlnd, zsno, hu, ht, hq, hpbl, & us, vs, tm, qm, rhoair, psrf, & ur, thm, th, thv, t_grnd, qg, rss, dqgdT, htvp, & fsno, cgrnd, cgrndl, cgrnds, & @@ -26,7 +26,7 @@ subroutine GroundFluxes (zlnd, zsno, hu, ht, hq, hpbl, & z0m, z0hg, zol, rib, ustar, qstar, tstar, fm, fh, fq) !======================================================================= -! this is the main subroutine to execute the calculation of thermal processes +! this is the main SUBROUTINE to execute the calculation of thermal processes ! and surface fluxes ! ! Original author : Yongjiu Dai, 09/15/1999; 08/30/2002 @@ -39,15 +39,15 @@ subroutine GroundFluxes (zlnd, zsno, hu, ht, hq, hpbl, & ! make a proper update of um. !======================================================================= - use MOD_Precision - use MOD_Const_Physical, only: cpair,vonkar,grav - use MOD_FrictionVelocity - USE mod_namelist, only: DEF_USE_CBL_HEIGHT,DEF_RSS_SCHEME - USE MOD_TurbulenceLEddy - implicit none + USE MOD_Precision + USE MOD_Const_Physical, only: cpair,vonkar,grav + USE MOD_FrictionVelocity + USE mod_namelist, only: DEF_USE_CBL_HEIGHT,DEF_RSS_SCHEME + USE MOD_TurbulenceLEddy + IMPLICIT NONE !----------------------- Dummy argument -------------------------------- - real(r8), INTENT(in) :: & + real(r8), intent(in) :: & zlnd, &! roughness length for soil [m] zsno, &! roughness length for snow [m] @@ -80,7 +80,7 @@ subroutine GroundFluxes (zlnd, zsno, hu, ht, hq, hpbl, & rss, &! soil surface resistance for evaporation [s/m] htvp ! latent heat of vapor of water (or sublimation) [j/kg] - 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] fseng, &! sensible heat flux from ground [W/m2] @@ -102,16 +102,16 @@ subroutine GroundFluxes (zlnd, zsno, hu, ht, hq, hpbl, & ustar, &! friction velocity [m/s] tstar, &! temperature scaling parameter qstar, &! moisture scaling parameter - fm, &! integral of profile function for momentum - fh, &! integral of profile function for heat - fq ! integral of profile function for moisture + fm, &! integral of profile FUNCTION for momentum + fh, &! integral of profile FUNCTION for heat + 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] dth, &! diff of virtual temp. between ref. height and surface @@ -126,7 +126,7 @@ subroutine GroundFluxes (zlnd, zsno, hu, ht, hq, hpbl, & raiw, &! temporary variable [kg/m2/s] fh2m, &! relation for temperature at 2m fq2m, &! relation for specific humidity at 2m - fm10m, &! integral of profile function for momentum at 10m + fm10m, &! integral of profile FUNCTION for momentum at 10m thvstar, &! virtual potential temperature scaling parameter um, &! wind speed including the stablity effect [m/s] wc, &! convective velocity [m/s] @@ -139,124 +139,124 @@ subroutine GroundFluxes (zlnd, zsno, hu, ht, hq, hpbl, & !----------------------- Dummy argument -------------------------------- ! initial roughness length - ! 09/2019, yuan: change to a combination of zlnd and zsno - z0mg = (1.-fsno)*zlnd + fsno*zsno - z0hg = z0mg - z0qg = z0mg + ! 09/2019, yuan: change to a combination of zlnd and zsno + z0mg = (1.-fsno)*zlnd + fsno*zsno + z0hg = z0mg + z0qg = z0mg ! potential temperatur at the reference height - beta = 1. ! - (in computing W_*) - zii = 1000. ! m (pbl height) - z0m = z0mg + beta = 1. ! - (in computing W_*) + zii = 1000. ! m (pbl height) + z0m = z0mg !----------------------------------------------------------------------- - ! Compute sensible and latent fluxes and their derivatives with respect - ! to ground temperature using ground temperatures from previous time step. + ! Compute sensible and latent fluxes and their derivatives with respect + ! to ground temperature using ground temperatures from previous time step. !----------------------------------------------------------------------- ! Initialization variables - nmozsgn = 0 - obuold = 0. + nmozsgn = 0 + obuold = 0. - dth = thm-t_grnd - dqh = qm-qg - dthv = dth*(1.+0.61*qm)+0.61*th*dqh - zldis = hu-0. + dth = thm-t_grnd + dqh = qm-qg + dthv = dth*(1.+0.61*qm)+0.61*th*dqh + zldis = hu-0. - call moninobukini(ur,th,thm,thv,dth,dqh,dthv,zldis,z0mg,um,obu) + CALL moninobukini(ur,th,thm,thv,dth,dqh,dthv,zldis,z0mg,um,obu) ! Evaluated stability-dependent variables using moz from prior iteration - niters=6 - - !---------------------------------------------------------------- - ITERATION : do iter = 1, niters ! begin stability iteration - !---------------------------------------------------------------- - displax = 0. - if (DEF_USE_CBL_HEIGHT) then - call moninobuk_leddy(hu,ht,hq,displax,z0mg,z0hg,z0qg,obu,um, hpbl, & - ustar,fh2m,fq2m,fm10m,fm,fh,fq) - else - call moninobuk(hu,ht,hq,displax,z0mg,z0hg,z0qg,obu,um,& - ustar,fh2m,fq2m,fm10m,fm,fh,fq) - endif - - tstar = vonkar/fh*dth - qstar = vonkar/fq*dqh - - z0hg = z0mg/exp(0.13 * (ustar*z0mg/1.5e-5)**0.45) - z0qg = z0hg + niters=6 + + !---------------------------------------------------------------- + ITERATION : DO iter = 1, niters ! begin stability iteration + !---------------------------------------------------------------- + displax = 0. + IF (DEF_USE_CBL_HEIGHT) THEN + CALL moninobuk_leddy(hu,ht,hq,displax,z0mg,z0hg,z0qg,obu,um, hpbl, & + ustar,fh2m,fq2m,fm10m,fm,fh,fq) + ELSE + CALL moninobuk(hu,ht,hq,displax,z0mg,z0hg,z0qg,obu,um,& + ustar,fh2m,fq2m,fm10m,fm,fh,fq) + ENDIF + + tstar = vonkar/fh*dth + qstar = vonkar/fq*dqh + + z0hg = z0mg/exp(0.13 * (ustar*z0mg/1.5e-5)**0.45) + z0qg = z0hg ! 2023.04.06, weinan - !thvstar=tstar+0.61*th*qstar - thvstar=tstar*(1.+0.61*qm)+0.61*th*qstar - zeta=zldis*vonkar*grav*thvstar/(ustar**2*thv) - if(zeta >= 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 >= 0.)then - um = max(ur,0.1) - else - if (DEF_USE_CBL_HEIGHT) then !//TODO: Shaofeng, 2023.05.18 - zii = max(5.*hu,hpbl) - endif !//TODO: Shaofeng, 2023.05.18 - wc = (-grav*ustar*thvstar*zii/thv)**(1./3.) - wc2 = beta*beta*(wc*wc) - um = sqrt(ur*ur+wc2) - endif - - if (obuold*obu < 0.) nmozsgn = nmozsgn+1 - if (nmozsgn >= 4) EXIT - - obuold = obu - - !---------------------------------------------------------------- - enddo ITERATION ! end stability iteration - !---------------------------------------------------------------- + !thvstar=tstar+0.61*th*qstar + thvstar=tstar*(1.+0.61*qm)+0.61*th*qstar + zeta=zldis*vonkar*grav*thvstar/(ustar**2*thv) + IF(zeta >= 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 >= 0.)THEN + um = max(ur,0.1) + ELSE + IF (DEF_USE_CBL_HEIGHT) THEN !//TODO: Shaofeng, 2023.05.18 + zii = max(5.*hu,hpbl) + ENDIF !//TODO: Shaofeng, 2023.05.18 + wc = (-grav*ustar*thvstar*zii/thv)**(1./3.) + wc2 = beta*beta*(wc*wc) + um = sqrt(ur*ur+wc2) + ENDIF + + IF (obuold*obu < 0.) nmozsgn = nmozsgn+1 + IF (nmozsgn >= 4) EXIT + + obuold = obu + + !---------------------------------------------------------------- + ENDDO ITERATION ! END stability iteration + !---------------------------------------------------------------- ! Get derivative of fluxes with repect to ground temperature - ram = 1./(ustar*ustar/um) - rah = 1./(vonkar/fh*ustar) - raw = 1./(vonkar/fq*ustar) + ram = 1./(ustar*ustar/um) + rah = 1./(vonkar/fh*ustar) + raw = 1./(vonkar/fq*ustar) - raih = rhoair*cpair/rah + raih = rhoair*cpair/rah ! 08/23/2019, yuan: add soil surface resistance (rss) - IF (dqh > 0.) THEN - raiw = rhoair/raw !dew case. assume no soil resistance - ELSE - IF (DEF_RSS_SCHEME .eq. 4) THEN - raiw = rss*rhoair/raw - ELSE - raiw = rhoair/(raw+rss) - ENDIF - ENDIF - - cgrnds = raih - cgrndl = raiw*dqgdT - cgrnd = cgrnds + htvp*cgrndl - - zol = zeta - rib = min(5.,zol*ustar**2/(vonkar**2/fh*um**2)) + IF (dqh > 0.) THEN + raiw = rhoair/raw !dew case. assume no soil resistance + ELSE + IF (DEF_RSS_SCHEME .eq. 4) THEN + raiw = rss*rhoair/raw + ELSE + raiw = rhoair/(raw+rss) + ENDIF + ENDIF + + cgrnds = raih + cgrndl = raiw*dqgdT + cgrnd = cgrnds + htvp*cgrndl + + zol = zeta + rib = min(5.,zol*ustar**2/(vonkar**2/fh*um**2)) ! surface fluxes of momentum, sensible and latent ! using ground temperatures from previous time step - taux = -rhoair*us/ram - tauy = -rhoair*vs/ram - fseng = -raih*dth - fevpg = -raiw*dqh + taux = -rhoair*us/ram + tauy = -rhoair*vs/ram + fseng = -raih*dth + fevpg = -raiw*dqh - fseng_soil = -raih * (thm - t_soil) - fseng_snow = -raih * (thm - t_snow) - fevpg_soil = -raiw * ( qm - q_soil) - fevpg_snow = -raiw * ( qm - q_snow) + fseng_soil = -raih * (thm - t_soil) + fseng_snow = -raih * (thm - t_snow) + fevpg_soil = -raiw * ( qm - q_soil) + fevpg_snow = -raiw * ( qm - q_snow) ! 2 m height air temperature - 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 GroundFluxes + END SUBROUTINE GroundFluxes END MODULE MOD_GroundFluxes diff --git a/main/MOD_GroundTemperature.F90 b/main/MOD_GroundTemperature.F90 index 0dd726fd..0aab9573 100644 --- a/main/MOD_GroundTemperature.F90 +++ b/main/MOD_GroundTemperature.F90 @@ -13,7 +13,7 @@ MODULE MOD_GroundTemperature !----------------------------------------------------------------------- - CONTAINS +CONTAINS !----------------------------------------------------------------------- @@ -143,7 +143,7 @@ SUBROUTINE GroundTemperature (patchtype,lb,nl_soil,deltim,& real(r8), intent(inout) :: wliq_soisno(lb:nl_soil) !liqui water [kg/m2] real(r8), intent(inout) :: scv !snow cover, water equivalent [mm, kg/m2] real(r8), intent(inout) :: snowdp !snow depth [m] - real(r8), INTENT(in) :: fsno !snow fractional cover [-] + real(r8), intent(in) :: fsno !snow fractional cover [-] 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 @@ -182,48 +182,48 @@ SUBROUTINE GroundTemperature (patchtype,lb,nl_soil,deltim,& !======================================================================= ! soil ground and wetland heat capacity - DO i = 1, nl_soil - vf_water(i) = wliq_soisno(i)/(dz_soisno(i)*denh2o) - vf_ice(i) = wice_soisno(i)/(dz_soisno(i)*denice) - CALL soil_hcap_cond(vf_gravels(i),vf_om(i),vf_sand(i),porsl(i),& - wf_gravels(i),wf_sand(i),k_solids(i),& - csol(i),dkdry(i),dksatu(i),dksatf(i),& - BA_alpha(i),BA_beta(i),& - t_soisno(i),vf_water(i),vf_ice(i),hcap(i),thk(i)) - cv(i) = hcap(i)*dz_soisno(i) - ENDDO - IF(lb==1 .and. scv>0.) cv(1) = cv(1) + cpice*scv + DO i = 1, nl_soil + vf_water(i) = wliq_soisno(i)/(dz_soisno(i)*denh2o) + vf_ice(i) = wice_soisno(i)/(dz_soisno(i)*denice) + CALL soil_hcap_cond(vf_gravels(i),vf_om(i),vf_sand(i),porsl(i),& + wf_gravels(i),wf_sand(i),k_solids(i),& + csol(i),dkdry(i),dksatu(i),dksatf(i),& + BA_alpha(i),BA_beta(i),& + t_soisno(i),vf_water(i),vf_ice(i),hcap(i),thk(i)) + cv(i) = hcap(i)*dz_soisno(i) + ENDDO + IF(lb==1 .and. scv>0.) cv(1) = cv(1) + cpice*scv ! Snow heat capacity - IF(lb <= 0)THEN - cv(:0) = cpliq*wliq_soisno(:0) + cpice*wice_soisno(:0) - ENDIF + IF(lb <= 0)THEN + cv(:0) = cpliq*wliq_soisno(:0) + cpice*wice_soisno(:0) + ENDIF ! Snow thermal conductivity - IF(lb <= 0)THEN - DO i = lb, 0 - rhosnow = (wice_soisno(i)+wliq_soisno(i))/dz_soisno(i) - - ! presently option [1] is the default option - ! [1] Jordan (1991) pp. 18 - thk(i) = tkair+(7.75e-5*rhosnow+1.105e-6*rhosnow*rhosnow)*(tkice-tkair) - - ! [2] Sturm et al (1997) - ! thk(i) = 0.0138 + 1.01e-3*rhosnow + 3.233e-6*rhosnow**2 - ! [3] Ostin and Andersson presented in Sturm et al., (1997) - ! thk(i) = -0.871e-2 + 0.439e-3*rhosnow + 1.05e-6*rhosnow**2 - ! [4] Jansson(1901) presented in Sturm et al. (1997) - ! thk(i) = 0.0293 + 0.7953e-3*rhosnow + 1.512e-12*rhosnow**2 - ! [5] Douville et al., (1995) - ! thk(i) = 2.2*(rhosnow/denice)**1.88 - ! [6] van Dusen (1992) presented in Sturm et al. (1997) - ! thk(i) = 0.021 + 0.42e-3*rhosnow + 0.22e-6*rhosnow**2 - - ENDDO - ENDIF + IF(lb <= 0)THEN + DO i = lb, 0 + rhosnow = (wice_soisno(i)+wliq_soisno(i))/dz_soisno(i) + + ! presently option [1] is the default option + ! [1] Jordan (1991) pp. 18 + thk(i) = tkair+(7.75e-5*rhosnow+1.105e-6*rhosnow*rhosnow)*(tkice-tkair) + + ! [2] Sturm et al (1997) + ! thk(i) = 0.0138 + 1.01e-3*rhosnow + 3.233e-6*rhosnow**2 + ! [3] Ostin and Andersson presented in Sturm et al., (1997) + ! thk(i) = -0.871e-2 + 0.439e-3*rhosnow + 1.05e-6*rhosnow**2 + ! [4] Jansson(1901) presented in Sturm et al. (1997) + ! thk(i) = 0.0293 + 0.7953e-3*rhosnow + 1.512e-12*rhosnow**2 + ! [5] Douville et al., (1995) + ! thk(i) = 2.2*(rhosnow/denice)**1.88 + ! [6] van Dusen (1992) presented in Sturm et al. (1997) + ! thk(i) = 0.021 + 0.42e-3*rhosnow + 0.22e-6*rhosnow**2 + + ENDDO + ENDIF ! Thermal conductivity at the layer interface - DO i = lb, nl_soil-1 + DO i = lb, nl_soil-1 ! the following consideration is try to avoid the snow conductivity ! to be dominant in the thermal conductivity of the interface. @@ -231,207 +231,207 @@ SUBROUTINE GroundTemperature (patchtype,lb,nl_soil,deltim,& ! is larger than that of interface to top soil node, ! the snow thermal conductivity will be dominant, and the result is that ! lees heat tranfer between snow and soil - IF((i==0) .and. (z_soisno(i+1)-zi_soisno(i)100% cover - IF (DEF_USE_SNICAR .and. lb < 1) THEN - hs = sabg_snow_lyr(lb) + sabg_soil + dlrad*emg & - - (fseng+fevpg*htvp) & - + cpliq*pg_rain*(t_precip-t_grnd) & - + cpice*pg_snow*(t_precip-t_grnd) - ELSE - hs = sabg + dlrad*emg & - - (fseng+fevpg*htvp) & - + cpliq*pg_rain*(t_precip-t_grnd) & - + cpice*pg_snow*(t_precip-t_grnd) - ENDIF - - IF (.not.DEF_SPLIT_SOILSNOW) THEN - hs = hs - emg*stefnc*t_grnd**4 - ELSE - ! 03/08/2020, yuan: separate soil and snow - hs = hs - fsno*emg*stefnc*t_snow**4 & - - (1.-fsno)*emg*stefnc*t_soil**4 - - ! 03/08/2020, yuan: calculate hs_soil, hs_snow for - ! soil/snow fractional cover separately. - hs_soil = dlrad*emg & - - emg*stefnc*t_soil**4 & - - (fseng_soil+fevpg_soil*htvp) & - + cpliq*pg_rain*(t_precip-t_soil) & - + cpice*pg_snow*(t_precip-t_soil) - - hs_soil = hs_soil*(1.-fsno) + sabg_soil - - hs_snow = dlrad*emg & - - emg*stefnc*t_snow**4 & - - (fseng_snow+fevpg_snow*htvp) & - + cpliq*pg_rain*(t_precip-t_snow) & - + cpice*pg_snow*(t_precip-t_snow) - + ! 08/19/2021, yuan: NOTE! removed sigf, LAI->100% cover IF (DEF_USE_SNICAR .and. lb < 1) THEN - hs_snow = hs_snow*fsno + sabg_snow_lyr(lb) + hs = sabg_snow_lyr(lb) + sabg_soil + dlrad*emg & + - (fseng+fevpg*htvp) & + + cpliq*pg_rain*(t_precip-t_grnd) & + + cpice*pg_snow*(t_precip-t_grnd) ELSE - hs_snow = hs_snow*fsno + sabg_snow + hs = sabg + dlrad*emg & + - (fseng+fevpg*htvp) & + + cpliq*pg_rain*(t_precip-t_grnd) & + + cpice*pg_snow*(t_precip-t_grnd) ENDIF - dhsdT = -cgrnd - 4.*emg*stefnc*t_grnd**3 - cpliq*pg_rain - cpice*pg_snow + IF (.not.DEF_SPLIT_SOILSNOW) THEN + hs = hs - emg*stefnc*t_grnd**4 + ELSE + ! 03/08/2020, yuan: separate soil and snow + hs = hs - fsno*emg*stefnc*t_snow**4 & + - (1.-fsno)*emg*stefnc*t_soil**4 + + ! 03/08/2020, yuan: calculate hs_soil, hs_snow for + ! soil/snow fractional cover separately. + hs_soil = dlrad*emg & + - emg*stefnc*t_soil**4 & + - (fseng_soil+fevpg_soil*htvp) & + + cpliq*pg_rain*(t_precip-t_soil) & + + cpice*pg_snow*(t_precip-t_soil) + + hs_soil = hs_soil*(1.-fsno) + sabg_soil + + hs_snow = dlrad*emg & + - emg*stefnc*t_snow**4 & + - (fseng_snow+fevpg_snow*htvp) & + + cpliq*pg_rain*(t_precip-t_snow) & + + cpice*pg_snow*(t_precip-t_snow) + + IF (DEF_USE_SNICAR .and. lb < 1) THEN + hs_snow = hs_snow*fsno + sabg_snow_lyr(lb) + ELSE + hs_snow = hs_snow*fsno + sabg_snow + ENDIF + + dhsdT = -cgrnd - 4.*emg*stefnc*t_grnd**3 - cpliq*pg_rain - cpice*pg_snow - IF (sabg_soil+sabg_snow-sabg>1.e-6 .or. hs_soil+hs_snow-hs>1.e-6) THEN - print *, "MOD_GroundTemperature.F90: Error in spliting soil and snow surface!" - print *, "sabg:", sabg, "sabg_soil:", sabg_soil, "sabg_snow", sabg_snow - print *, "hs", hs, "hs_soil", hs_soil, "hs_snow:", hs_snow, "fsno:", fsno - print *, "hs_soil+hs_snow", hs_soil+hs_snow, "sabg_soil+sabg_snow:", sabg_soil+sabg_snow - print *, "lb:", lb, "sabg_snow_lyr:", sabg_snow_lyr - CALL CoLM_stop() + IF (sabg_soil+sabg_snow-sabg>1.e-6 .or. hs_soil+hs_snow-hs>1.e-6) THEN + print *, "MOD_GroundTemperature.F90: Error in spliting soil and snow surface!" + print *, "sabg:", sabg, "sabg_soil:", sabg_soil, "sabg_snow", sabg_snow + print *, "hs", hs, "hs_soil", hs_soil, "hs_snow:", hs_snow, "fsno:", fsno + print *, "hs_soil+hs_snow", hs_soil+hs_snow, "sabg_soil+sabg_snow:", sabg_soil+sabg_snow + print *, "lb:", lb, "sabg_snow_lyr:", sabg_snow_lyr + CALL CoLM_stop() + ENDIF ENDIF - ENDIF - dhsdT = -cgrnd - 4.*emg*stefnc*t_grnd**3 - cpliq*pg_rain - cpice*pg_snow - t_soisno_bef(lb:) = t_soisno(lb:) + dhsdT = -cgrnd - 4.*emg*stefnc*t_grnd**3 - cpliq*pg_rain - cpice*pg_snow + t_soisno_bef(lb:) = t_soisno(lb:) - j = lb - fact(j) = deltim / cv(j) & - * dz_soisno(j) / (0.5*(z_soisno(j)-zi_soisno(j-1)+capr*(z_soisno(j+1)-zi_soisno(j-1)))) + j = lb + fact(j) = deltim / cv(j) & + * dz_soisno(j) / (0.5*(z_soisno(j)-zi_soisno(j-1)+capr*(z_soisno(j+1)-zi_soisno(j-1)))) - DO j = lb + 1, nl_soil - fact(j) = deltim/cv(j) - ENDDO + DO j = lb + 1, nl_soil + fact(j) = deltim/cv(j) + ENDDO - DO j = lb, nl_soil - 1 - fn(j) = tk(j)*(t_soisno(j+1)-t_soisno(j))/(z_soisno(j+1)-z_soisno(j)) - ENDDO - fn(nl_soil) = 0. + DO j = lb, nl_soil - 1 + fn(j) = tk(j)*(t_soisno(j+1)-t_soisno(j))/(z_soisno(j+1)-z_soisno(j)) + ENDDO + fn(nl_soil) = 0. ! set up vector r and vectors a, b, c that define tridiagonal matrix - j = lb - dzp = z_soisno(j+1)-z_soisno(j) - at(j) = 0. - ct(j) = -(1.-cnfac)*fact(j)*tk(j)/dzp - - ! the first layer - IF (j<1 .and. DEF_SPLIT_SOILSNOW) THEN ! snow covered and split soil and snow - bt(j) = 1+(1.-cnfac)*fact(j)*tk(j)/dzp-fact(j)*fsno*dhsdT - rt(j) = t_soisno(j) +fact(j)*( hs_snow - fsno*dhsdT*t_soisno(j) + cnfac*fn(j) ) - ELSE ! not a snow layer or don't split soil and snow - bt(j) = 1+(1.-cnfac)*fact(j)*tk(j)/dzp-fact(j)*dhsdT - rt(j) = t_soisno(j) +fact(j)*( hs - dhsdT*t_soisno(j) + cnfac*fn(j) ) - ENDIF - - DO j = lb + 1, nl_soil - 1 - - dzm = (z_soisno(j)-z_soisno(j-1)) - dzp = (z_soisno(j+1)-z_soisno(j)) - - IF (j < 1) THEN ! snow layer - at(j) = - (1.-cnfac)*fact(j)* tk(j-1)/dzm - bt(j) = 1.+ (1.-cnfac)*fact(j)*(tk(j)/dzp + tk(j-1)/dzm) - ct(j) = - (1.-cnfac)*fact(j)* tk(j)/dzp - IF (DEF_USE_SNICAR) THEN - rt(j) = t_soisno(j) + fact(j)*sabg_snow_lyr(j) + cnfac*fact(j)*( fn(j) - fn(j-1) ) - ELSE - rt(j) = t_soisno(j) + cnfac*fact(j)*( fn(j) - fn(j-1) ) - ENDIF + j = lb + dzp = z_soisno(j+1)-z_soisno(j) + at(j) = 0. + ct(j) = -(1.-cnfac)*fact(j)*tk(j)/dzp + + ! the first layer + IF (j<1 .and. DEF_SPLIT_SOILSNOW) THEN ! snow covered and split soil and snow + bt(j) = 1+(1.-cnfac)*fact(j)*tk(j)/dzp-fact(j)*fsno*dhsdT + rt(j) = t_soisno(j) +fact(j)*( hs_snow - fsno*dhsdT*t_soisno(j) + cnfac*fn(j) ) + ELSE ! not a snow layer or don't split soil and snow + bt(j) = 1+(1.-cnfac)*fact(j)*tk(j)/dzp-fact(j)*dhsdT + rt(j) = t_soisno(j) +fact(j)*( hs - dhsdT*t_soisno(j) + cnfac*fn(j) ) ENDIF - IF (j == 1) THEN ! the first soil layer - at(j) = - (1.-cnfac)*fact(j)* tk(j-1)/dzm - ct(j) = - (1.-cnfac)*fact(j)* tk(j)/dzp - IF (.not.DEF_SPLIT_SOILSNOW) THEN + DO j = lb + 1, nl_soil - 1 + + dzm = (z_soisno(j)-z_soisno(j-1)) + dzp = (z_soisno(j+1)-z_soisno(j)) + + IF (j < 1) THEN ! snow layer + at(j) = - (1.-cnfac)*fact(j)* tk(j-1)/dzm bt(j) = 1.+ (1.-cnfac)*fact(j)*(tk(j)/dzp + tk(j-1)/dzm) - rt(j) = t_soisno(j) + cnfac*fact(j)*( fn(j) - fn(j-1) ) - ELSE - bt(j) = 1.+ (1.-cnfac)*fact(j)*(tk(j)/dzp + tk(j-1)/dzm) & - - (1.-fsno)*dhsdT*fact(j) - rt(j) = t_soisno(j) + cnfac*fact(j)*( fn(j) - fn(j-1) ) & - + fact(j)*( hs_soil - (1.-fsno)*dhsdT*t_soisno(j) ) + ct(j) = - (1.-cnfac)*fact(j)* tk(j)/dzp + IF (DEF_USE_SNICAR) THEN + rt(j) = t_soisno(j) + fact(j)*sabg_snow_lyr(j) + cnfac*fact(j)*( fn(j) - fn(j-1) ) + ELSE + rt(j) = t_soisno(j) + cnfac*fact(j)*( fn(j) - fn(j-1) ) + ENDIF ENDIF - ENDIF - IF (j > 1) THEN ! inner soil layer - at(j) = - (1.-cnfac)*fact(j)* tk(j-1)/dzm - bt(j) = 1.+ (1.-cnfac)*fact(j)*(tk(j)/dzp + tk(j-1)/dzm) - ct(j) = - (1.-cnfac)*fact(j)* tk(j)/dzp - rt(j) = t_soisno(j) + cnfac*fact(j)*( fn(j) - fn(j-1) ) - ENDIF + IF (j == 1) THEN ! the first soil layer + at(j) = - (1.-cnfac)*fact(j)* tk(j-1)/dzm + ct(j) = - (1.-cnfac)*fact(j)* tk(j)/dzp + IF (.not.DEF_SPLIT_SOILSNOW) THEN + bt(j) = 1.+ (1.-cnfac)*fact(j)*(tk(j)/dzp + tk(j-1)/dzm) + rt(j) = t_soisno(j) + cnfac*fact(j)*( fn(j) - fn(j-1) ) + ELSE + bt(j) = 1.+ (1.-cnfac)*fact(j)*(tk(j)/dzp + tk(j-1)/dzm) & + - (1.-fsno)*dhsdT*fact(j) + rt(j) = t_soisno(j) + cnfac*fact(j)*( fn(j) - fn(j-1) ) & + + fact(j)*( hs_soil - (1.-fsno)*dhsdT*t_soisno(j) ) + ENDIF + ENDIF + + IF (j > 1) THEN ! inner soil layer + at(j) = - (1.-cnfac)*fact(j)* tk(j-1)/dzm + bt(j) = 1.+ (1.-cnfac)*fact(j)*(tk(j)/dzp + tk(j-1)/dzm) + ct(j) = - (1.-cnfac)*fact(j)* tk(j)/dzp + rt(j) = t_soisno(j) + cnfac*fact(j)*( fn(j) - fn(j-1) ) + ENDIF - ENDDO + ENDDO - j = nl_soil - dzm = (z_soisno(j)-z_soisno(j-1)) - at(j) = - (1.-cnfac)*fact(j)*tk(j-1)/dzm - bt(j) = 1.+ (1.-cnfac)*fact(j)*tk(j-1)/dzm - ct(j) = 0. - rt(j) = t_soisno(j) - cnfac*fact(j)*fn(j-1) + j = nl_soil + dzm = (z_soisno(j)-z_soisno(j-1)) + at(j) = - (1.-cnfac)*fact(j)*tk(j-1)/dzm + bt(j) = 1.+ (1.-cnfac)*fact(j)*tk(j-1)/dzm + ct(j) = 0. + rt(j) = t_soisno(j) - cnfac*fact(j)*fn(j-1) ! solve for t_soisno - i = size(at) - CALL tridia (i ,at ,bt ,ct ,rt ,t_soisno) + i = size(at) + CALL tridia (i ,at ,bt ,ct ,rt ,t_soisno) !======================================================================= ! melting or freezing !======================================================================= - DO j = lb, nl_soil - 1 - fn1(j) = tk(j)*(t_soisno(j+1)-t_soisno(j))/(z_soisno(j+1)-z_soisno(j)) - ENDDO - fn1(nl_soil) = 0. + DO j = lb, nl_soil - 1 + fn1(j) = tk(j)*(t_soisno(j+1)-t_soisno(j))/(z_soisno(j+1)-z_soisno(j)) + ENDDO + fn1(nl_soil) = 0. - j = lb - brr(j) = cnfac*fn(j) + (1.-cnfac)*fn1(j) + j = lb + brr(j) = cnfac*fn(j) + (1.-cnfac)*fn1(j) - DO j = lb + 1, nl_soil - brr(j) = cnfac*(fn(j)-fn(j-1)) + (1.-cnfac)*(fn1(j)-fn1(j-1)) - ENDDO + DO j = lb + 1, nl_soil + brr(j) = cnfac*(fn(j)-fn(j-1)) + (1.-cnfac)*(fn1(j)-fn1(j-1)) + ENDDO - IF (DEF_USE_SNICAR) THEN + IF (DEF_USE_SNICAR) THEN - wice_soisno_bef(lb:0) = wice_soisno(lb:0) + wice_soisno_bef(lb:0) = wice_soisno(lb:0) - CALL meltf_snicar (patchtype,lb,nl_soil,deltim, & - fact(lb:),brr(lb:),hs,hs_soil,hs_snow,fsno,sabg_snow_lyr(lb:),dhsdT, & - t_soisno_bef(lb:),t_soisno(lb:),wliq_soisno(lb:),wice_soisno(lb:),imelt(lb:), & - scv,snowdp,sm,xmf,porsl,psi0,& + CALL meltf_snicar (patchtype,lb,nl_soil,deltim, & + fact(lb:),brr(lb:),hs,hs_soil,hs_snow,fsno,sabg_snow_lyr(lb:),dhsdT, & + t_soisno_bef(lb:),t_soisno(lb:),wliq_soisno(lb:),wice_soisno(lb:),imelt(lb:), & + scv,snowdp,sm,xmf,porsl,psi0,& #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_soisno(1:nl_soil)) + dz_soisno(1:nl_soil)) - ! layer freezing mass flux (positive): - DO j = lb, 0 - IF (imelt(j)==2 .and. j<1) THEN - snofrz(j) = max(0._r8,(wice_soisno(j)-wice_soisno_bef(j)))/deltim - ENDIF - ENDDO + ! layer freezing mass flux (positive): + DO j = lb, 0 + IF (imelt(j)==2 .and. j<1) THEN + snofrz(j) = max(0._r8,(wice_soisno(j)-wice_soisno_bef(j)))/deltim + ENDIF + ENDDO - ELSE - CALL meltf (patchtype,lb,nl_soil,deltim, & - fact(lb:),brr(lb:),hs,hs_soil,hs_snow,fsno,dhsdT, & - t_soisno_bef(lb:),t_soisno(lb:),wliq_soisno(lb:),wice_soisno(lb:),imelt(lb:), & - scv,snowdp,sm,xmf,porsl,psi0,& + ELSE + CALL meltf (patchtype,lb,nl_soil,deltim, & + fact(lb:),brr(lb:),hs,hs_soil,hs_snow,fsno,dhsdT, & + t_soisno_bef(lb:),t_soisno(lb:),wliq_soisno(lb:),wice_soisno(lb:),imelt(lb:), & + scv,snowdp,sm,xmf,porsl,psi0,& #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_soisno(1:nl_soil)) - ENDIF + dz_soisno(1:nl_soil)) + ENDIF !----------------------------------------------------------------------- diff --git a/main/MOD_Hist.F90 b/main/MOD_Hist.F90 index 09328f58..37bfb16d 100644 --- a/main/MOD_Hist.F90 +++ b/main/MOD_Hist.F90 @@ -1,6 +1,6 @@ #include -module MOD_Hist +MODULE MOD_Hist !---------------------------------------------------------------------------- ! DESCRIPTION: @@ -15,39 +15,39 @@ module MOD_Hist ! TODO...(need complement) !---------------------------------------------------------------------------- - use MOD_Vars_1DAccFluxes + USE MOD_Vars_1DAccFluxes USE MOD_Vars_Global, only : spval USE MOD_NetCDFSerial - use MOD_HistGridded + USE MOD_HistGridded #if (defined UNSTRUCTURED || defined CATCHMENT) - use MOD_HistVector + USE MOD_HistVector #endif #ifdef SinglePoint - use MOD_HistSingle + USE MOD_HistSingle #endif #ifdef LATERAL_FLOW USE MOD_Hydro_Hist #endif - public :: hist_init - public :: hist_out - public :: hist_final + PUBLIC :: hist_init + PUBLIC :: hist_out + PUBLIC :: hist_final character(len=10) :: HistForm ! 'Gridded', 'Vector', 'Single' !-------------------------------------------------------------------------- -contains +CONTAINS !--------------------------------------- - subroutine hist_init (dir_hist) + SUBROUTINE hist_init (dir_hist) - implicit none + IMPLICIT NONE character(len=*), intent(in) :: dir_hist - call allocate_acc_fluxes () - call FLUSH_acc_fluxes () + CALL allocate_acc_fluxes () + CALL FLUSH_acc_fluxes () HistForm = 'Gridded' #if (defined UNSTRUCTURED || defined CATCHMENT) @@ -71,14 +71,14 @@ subroutine hist_init (dir_hist) CALL hist_basin_init () #endif - end subroutine hist_init + END SUBROUTINE hist_init !-------------------------------------- - subroutine hist_final () + SUBROUTINE hist_final () - implicit none + IMPLICIT NONE - call deallocate_acc_fluxes () + CALL deallocate_acc_fluxes () #ifdef SinglePoint CALL hist_single_final () @@ -88,7 +88,7 @@ subroutine hist_final () CALL hist_basin_final () #endif - end subroutine hist_final + END SUBROUTINE hist_final !--------------------------------------- SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & @@ -98,16 +98,16 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & ! Original version: Yongjiu Dai, September 15, 1999, 03/2014 !======================================================================= - use MOD_Precision - use MOD_Namelist - use MOD_TimeManager - use MOD_SPMD_Task - use MOD_Vars_1DAccFluxes + USE MOD_Precision + USE MOD_Namelist + USE MOD_TimeManager + USE MOD_SPMD_Task + USE MOD_Vars_1DAccFluxes USE MOD_Vars_TimeVariables, only : wa, wat, wetwat, wdsrf - use MOD_Block - use MOD_DataType - use MOD_LandPatch - use MOD_Mapping_Pset2Grid + USE MOD_Block + USE MOD_DataType + USE MOD_LandPatch + USE MOD_Mapping_Pset2Grid USE MOD_Vars_TimeInvariants, only: patchtype, patchclass, patchmask #ifdef URBAN_MODEL USE MOD_LandUrban @@ -117,7 +117,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & USE MOD_LandPFT, only: patch_pft_s #endif #if(defined CaMa_Flood) - use MOD_CaMa_Vars !defination of CaMa variables + USE MOD_CaMa_Vars !defination of CaMa variables #endif USE MOD_Forcing, only: forcmask #ifdef DataAssimilation @@ -126,8 +126,8 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & IMPLICIT NONE - integer, INTENT(in) :: idate(3) - real(r8), INTENT(in) :: deltim + integer, intent(in) :: idate(3) + real(r8), intent(in) :: deltim type(timestamp), intent(in) :: itstamp type(timestamp), intent(in) :: etstamp type(timestamp), intent(in) :: ptstamp @@ -160,30 +160,30 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & #endif if (itstamp <= ptstamp) then - call FLUSH_acc_fluxes () - return + CALL FLUSH_acc_fluxes () + RETURN else - call accumulate_fluxes () - end if + CALL accumulate_fluxes () + END if - select case (trim(adjustl(DEF_HIST_FREQ))) - case ('TIMESTEP') + select CASE (trim(adjustl(DEF_HIST_FREQ))) + CASE ('TIMESTEP') lwrite = .true. - case ('HOURLY') + CASE ('HOURLY') lwrite = isendofhour (idate, deltim) .or. (.not. (itstamp < etstamp)) - case ('DAILY') + CASE ('DAILY') lwrite = isendofday (idate, deltim) .or. (.not. (itstamp < etstamp)) - case ('MONTHLY') + CASE ('MONTHLY') lwrite = isendofmonth(idate, deltim) .or. (.not. (itstamp < etstamp)) - case ('YEARLY') + CASE ('YEARLY') lwrite = isendofyear (idate, deltim) .or. (.not. (itstamp < etstamp)) - case default - write(*,*) 'Warning : Please use one of TIMESTEP/HOURLY/DAILY/MONTHLY/YEARLY for history frequency.' - end select + CASE default + write(*,*) 'Warning : Please USE one of TIMESTEP/HOURLY/DAILY/MONTHLY/YEARLY for history frequency.' + END select if (lwrite) then - call julian2monthday(idate(1), idate(2), month, day) + CALL julian2monthday(idate(1), idate(2), month, day) days_month = (/31,28,31,30,31,30,31,31,30,31,30,31/) if (isleapyear(idate(1))) days_month(2) = 29 @@ -210,20 +210,20 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & ENDIF #endif else - write(*,*) 'Warning : Please use one of DAY/MONTH/YEAR for history group.' - end if + write(*,*) 'Warning : Please USE one of DAY/MONTH/YEAR for history group.' + END if #if(defined CaMa_Flood) ! add variables to write cama-flood output. ! file name of cama-flood output file_hist_cama = trim(dir_hist) // '/' // trim(site) //'_hist_cama_'//trim(cdate)//'.nc' ! write CaMa-Flood output - call hist_write_cama_time (file_hist_cama, 'time', idate, itime_in_file_cama) + CALL hist_write_cama_time (file_hist_cama, 'time', idate, itime_in_file_cama) #endif file_hist = trim(dir_hist) // '/' // trim(site) //'_hist_'//trim(cdate)//'.nc' - call hist_write_time (file_hist, 'time', idate, itime_in_file) + CALL hist_write_time (file_hist, 'time', idate, itime_in_file) if (p_is_worker) then if (numpatch > 0) then @@ -231,7 +231,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & allocate (VecOnes (numpatch)) allocate (vecacc (numpatch)) VecOnes(:) = 1.0_r8 - end if + END if #ifdef URBAN_MODEL IF (numurban > 0) THEN allocate (filter_urb (numurban)) @@ -239,15 +239,15 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & VecOnes_urb(:) = 1.0_r8 ENDIF #endif - end if + END if IF (HistForm == 'Gridded') THEN if (p_is_io) then - call allocate_block_data (ghist, sumarea) + CALL allocate_block_data (ghist, sumarea) #ifdef URBAN_MODEL - call allocate_block_data (ghist, sumarea_urb) + CALL allocate_block_data (ghist, sumarea_urb) #endif - end if + END if ENDIF ! --------------------------------------------------- @@ -263,78 +263,78 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & ENDIF filter = filter .and. patchmask - end if - end if + END if + END if IF (HistForm == 'Gridded') THEN - call mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) + CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) ENDIF IF (HistForm == 'Gridded') THEN IF (itime_in_file == 1) then - call hist_write_var_real8_2d (file_hist, 'landarea', ghist, 1, sumarea, & + CALL hist_write_var_real8_2d (file_hist, 'landarea', ghist, 1, sumarea, & compress = 1, longname = 'land area', units = 'km2') ENDIF ENDIF ! wind in eastward direction [m/s] - call write_history_variable_2d ( DEF_hist_vars%xy_us, & + CALL write_history_variable_2d ( DEF_hist_vars%xy_us, & a_us, file_hist, 'f_xy_us', itime_in_file, sumarea, filter, & 'wind in eastward direction', 'm/s') ! wind in northward direction [m/s] - call write_history_variable_2d ( DEF_hist_vars%xy_vs, & + CALL write_history_variable_2d ( DEF_hist_vars%xy_vs, & a_vs, file_hist, 'f_xy_vs', itime_in_file, sumarea, filter, & 'wind in northward direction','m/s') ! temperature at reference height [kelvin] - call write_history_variable_2d ( DEF_hist_vars%xy_t, & + CALL write_history_variable_2d ( DEF_hist_vars%xy_t, & a_t, file_hist, 'f_xy_t', itime_in_file, sumarea, filter, & 'temperature at reference height','kelvin') ! specific humidity at reference height [kg/kg] - call write_history_variable_2d ( DEF_hist_vars%xy_q, & + CALL write_history_variable_2d ( DEF_hist_vars%xy_q, & a_q, file_hist, 'f_xy_q', itime_in_file, sumarea, filter, & 'specific humidity at reference height','kg/kg') ! convective precipitation [mm/s] - call write_history_variable_2d ( DEF_hist_vars%xy_prc, & + CALL write_history_variable_2d ( DEF_hist_vars%xy_prc, & a_prc, file_hist, 'f_xy_prc', itime_in_file, sumarea, filter, & 'convective precipitation','mm/s') ! large scale precipitation [mm/s] - call write_history_variable_2d ( DEF_hist_vars%xy_prl, & + CALL write_history_variable_2d ( DEF_hist_vars%xy_prl, & a_prl, file_hist, 'f_xy_prl', itime_in_file, sumarea, filter, & 'large scale precipitation','mm/s') ! atmospheric pressure at the surface [pa] - call write_history_variable_2d ( DEF_hist_vars%xy_pbot, & + CALL write_history_variable_2d ( DEF_hist_vars%xy_pbot, & a_pbot, file_hist, 'f_xy_pbot', itime_in_file, sumarea, filter, & 'atmospheric pressure at the surface','pa') ! atmospheric infrared (longwave) radiation [W/m2] - call write_history_variable_2d ( DEF_hist_vars%xy_frl, & + CALL write_history_variable_2d ( DEF_hist_vars%xy_frl, & a_frl, file_hist, 'f_xy_frl', itime_in_file, sumarea, filter, & 'atmospheric infrared (longwave) radiation','W/m2') ! downward solar radiation at surface [W/m2] - call write_history_variable_2d ( DEF_hist_vars%xy_solarin, & + CALL write_history_variable_2d ( DEF_hist_vars%xy_solarin, & a_solarin, file_hist, 'f_xy_solarin', itime_in_file, sumarea, filter, & 'downward solar radiation at surface','W/m2') ! rain [mm/s] - call write_history_variable_2d ( DEF_hist_vars%xy_rain, & + CALL write_history_variable_2d ( DEF_hist_vars%xy_rain, & a_rain, file_hist, 'f_xy_rain', itime_in_file, sumarea, filter, & 'rain','mm/s') ! snow [mm/s] - call write_history_variable_2d ( DEF_hist_vars%xy_snow, & + CALL write_history_variable_2d ( DEF_hist_vars%xy_snow, & a_snow, file_hist, 'f_xy_snow', itime_in_file, sumarea, filter, & 'snow','mm/s') if (DEF_USE_CBL_HEIGHT) then ! atmospheric boundary layer height [m] - call write_history_variable_2d ( DEF_hist_vars%xy_hpbl, & + CALL write_history_variable_2d ( DEF_hist_vars%xy_hpbl, & a_hpbl, file_hist, 'f_xy_hpbl', itime_in_file, sumarea, filter, & 'boundary layer height','m') endif @@ -352,115 +352,115 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & ENDIF filter = filter .and. patchmask - end if - end if + END if + END if IF (HistForm == 'Gridded') THEN - call mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) + CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) ENDIF ! wind stress: E-W [kg/m/s2] - call write_history_variable_2d ( DEF_hist_vars%taux, & + CALL write_history_variable_2d ( DEF_hist_vars%taux, & a_taux, file_hist, 'f_taux', itime_in_file, sumarea, filter, & 'wind stress: E-W','kg/m/s2') ! wind stress: N-S [kg/m/s2] - call write_history_variable_2d ( DEF_hist_vars%tauy, & + CALL write_history_variable_2d ( DEF_hist_vars%tauy, & a_tauy, file_hist, 'f_tauy', itime_in_file, sumarea, filter, & 'wind stress: N-S','kg/m/s2') ! sensible heat from canopy height to atmosphere [W/m2] - call write_history_variable_2d ( DEF_hist_vars%fsena, & + CALL write_history_variable_2d ( DEF_hist_vars%fsena, & a_fsena, file_hist, 'f_fsena', itime_in_file, sumarea, filter, & 'sensible heat from canopy height to atmosphere','W/m2') ! latent heat flux from canopy height to atmosphere [W/m2] - call write_history_variable_2d ( DEF_hist_vars%lfevpa, & + CALL write_history_variable_2d ( DEF_hist_vars%lfevpa, & a_lfevpa, file_hist, 'f_lfevpa', itime_in_file, sumarea, filter, & 'latent heat flux from canopy height to atmosphere','W/m2') ! evapotranspiration from canopy to atmosphere [mm/s] - call write_history_variable_2d ( DEF_hist_vars%fevpa, & + CALL write_history_variable_2d ( DEF_hist_vars%fevpa, & a_fevpa, file_hist, 'f_fevpa', itime_in_file, sumarea, filter, & 'evapotranspiration from canopy height to atmosphere','mm/s') ! sensible heat from leaves [W/m2] - call write_history_variable_2d ( DEF_hist_vars%fsenl, & + CALL write_history_variable_2d ( DEF_hist_vars%fsenl, & a_fsenl, file_hist, 'f_fsenl', itime_in_file, sumarea, filter, & 'sensible heat from leaves','W/m2') ! evaporation+transpiration from leaves [mm/s] - call write_history_variable_2d ( DEF_hist_vars%fevpl, & + CALL write_history_variable_2d ( DEF_hist_vars%fevpl, & a_fevpl, file_hist, 'f_fevpl', itime_in_file, sumarea, filter, & 'evaporation+transpiration from leaves','mm/s') ! transpiration rate [mm/s] - call write_history_variable_2d ( DEF_hist_vars%etr, & + CALL write_history_variable_2d ( DEF_hist_vars%etr, & a_etr, file_hist, 'f_etr', itime_in_file, sumarea, filter, & 'transpiration rate','mm/s') ! sensible heat flux from ground [W/m2] - call write_history_variable_2d ( DEF_hist_vars%fseng, & + CALL write_history_variable_2d ( DEF_hist_vars%fseng, & a_fseng, file_hist, 'f_fseng', itime_in_file, sumarea, filter, & 'sensible heat flux from ground','W/m2') ! evaporation heat flux from ground [mm/s] - call write_history_variable_2d ( DEF_hist_vars%fevpg, & + CALL write_history_variable_2d ( DEF_hist_vars%fevpg, & a_fevpg, file_hist, 'f_fevpg', itime_in_file, sumarea, filter, & 'evaporation heat flux from ground','mm/s') ! ground heat flux [W/m2] - call write_history_variable_2d ( DEF_hist_vars%fgrnd, & + CALL write_history_variable_2d ( DEF_hist_vars%fgrnd, & a_fgrnd, file_hist, 'f_fgrnd', itime_in_file, sumarea, filter, & 'ground heat flux','W/m2') ! solar absorbed by sunlit canopy [W/m2] - call write_history_variable_2d ( DEF_hist_vars%sabvsun, & + CALL write_history_variable_2d ( DEF_hist_vars%sabvsun, & a_sabvsun, file_hist, 'f_sabvsun', itime_in_file, sumarea, filter, & 'solar absorbed by sunlit canopy','W/m2') ! solar absorbed by shaded [W/m2] - call write_history_variable_2d ( DEF_hist_vars%sabvsha, & + CALL write_history_variable_2d ( DEF_hist_vars%sabvsha, & a_sabvsha, file_hist, 'f_sabvsha', itime_in_file, sumarea, filter, & 'solar absorbed by shaded','W/m2') ! solar absorbed by ground [W/m2] - call write_history_variable_2d ( DEF_hist_vars%sabg, & + CALL write_history_variable_2d ( DEF_hist_vars%sabg, & a_sabg, file_hist, 'f_sabg', itime_in_file, sumarea, filter, & 'solar absorbed by ground','W/m2') ! outgoing long-wave radiation from ground+canopy [W/m2] - call write_history_variable_2d ( DEF_hist_vars%olrg, & + CALL write_history_variable_2d ( DEF_hist_vars%olrg, & a_olrg, file_hist, 'f_olrg', itime_in_file, sumarea, filter, & 'outgoing long-wave radiation from ground+canopy','W/m2') ! net radiation [W/m2] - call write_history_variable_2d ( DEF_hist_vars%rnet, & + CALL write_history_variable_2d ( DEF_hist_vars%rnet, & a_rnet, file_hist, 'f_rnet', itime_in_file, sumarea, filter, & 'net radiation','W/m2') ! the error of water banace [mm/s] - call write_history_variable_2d ( DEF_hist_vars%xerr, & + CALL write_history_variable_2d ( DEF_hist_vars%xerr, & a_xerr, file_hist, 'f_xerr', itime_in_file, sumarea, filter, & 'the error of water banace','mm/s') ! the error of energy balance [W/m2] - call write_history_variable_2d ( DEF_hist_vars%zerr, & + CALL write_history_variable_2d ( DEF_hist_vars%zerr, & a_zerr, file_hist, 'f_zerr', itime_in_file, sumarea, filter, & 'the error of energy balance','W/m2') ! surface runoff [mm/s] - call write_history_variable_2d ( DEF_hist_vars%rsur, & + CALL write_history_variable_2d ( DEF_hist_vars%rsur, & a_rsur, file_hist, 'f_rsur', itime_in_file, sumarea, filter, & 'surface runoff','mm/s') ! subsurface runoff [mm/s] - call write_history_variable_2d ( DEF_hist_vars%rsub, & + CALL write_history_variable_2d ( DEF_hist_vars%rsub, & a_rsub, file_hist, 'f_rsub', itime_in_file, sumarea, filter, & 'subsurface runoff','mm/s') ! total runoff [mm/s] - call write_history_variable_2d ( DEF_hist_vars%rnof, & + CALL write_history_variable_2d ( DEF_hist_vars%rnof, & a_rnof, file_hist, 'f_rnof', itime_in_file, sumarea, filter, & 'total runoff','mm/s') @@ -470,40 +470,40 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & vecacc = fslp_k_mon(month,:) WHERE(vecacc /= spval) vecacc = vecacc * nac ENDIF - call write_history_variable_2d ( .true., & + CALL write_history_variable_2d ( .true., & vecacc, file_hist, 'f_slope_factor_k', itime_in_file, sumarea, filter, & 'slope factor [k] for runoff', '-') #endif #ifdef LATERAL_FLOW ! rate of surface water depth change [mm/s] - call write_history_variable_2d ( DEF_hist_vars%xwsur, & + CALL write_history_variable_2d ( DEF_hist_vars%xwsur, & a_xwsur, file_hist, 'f_xwsur', itime_in_file, sumarea, filter, & 'rate of surface water depth change','mm/s') ! rate of ground water change [mm/s] - call write_history_variable_2d ( DEF_hist_vars%xwsub, & + CALL write_history_variable_2d ( DEF_hist_vars%xwsub, & a_xwsub, file_hist, 'f_xwsub', itime_in_file, sumarea, filter, & 'rate of ground water change','mm/s') #endif ! interception [mm/s] - call write_history_variable_2d ( DEF_hist_vars%qintr, & + CALL write_history_variable_2d ( DEF_hist_vars%qintr, & a_qintr, file_hist, 'f_qintr', itime_in_file, sumarea, filter, & 'interception','mm/s') ! inflitraton [mm/s] - call write_history_variable_2d ( DEF_hist_vars%qinfl, & + CALL write_history_variable_2d ( DEF_hist_vars%qinfl, & a_qinfl, file_hist, 'f_qinfl', itime_in_file, sumarea, filter, & 'f_qinfl','mm/s') ! throughfall [mm/s] - call write_history_variable_2d ( DEF_hist_vars%qdrip, & + CALL write_history_variable_2d ( DEF_hist_vars%qdrip, & a_qdrip, file_hist, 'f_qdrip', itime_in_file, sumarea, filter, & 'total throughfall','mm/s') ! total water storage [mm] - call write_history_variable_2d ( DEF_hist_vars%wat, & + CALL write_history_variable_2d ( DEF_hist_vars%wat, & a_wat, file_hist, 'f_wat', itime_in_file, sumarea, filter, & 'total water storage','mm') @@ -512,112 +512,112 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & vecacc = wat WHERE(vecacc /= spval) vecacc = vecacc * nac ENDIF - call write_history_variable_2d ( DEF_hist_vars%wat_inst, & + CALL write_history_variable_2d ( DEF_hist_vars%wat_inst, & vecacc, file_hist, 'f_wat_inst', itime_in_file, sumarea, filter, & 'instantaneous total water storage','mm') ! canopy assimilation rate [mol m-2 s-1] - call write_history_variable_2d ( DEF_hist_vars%assim, & + CALL write_history_variable_2d ( DEF_hist_vars%assim, & a_assim, file_hist, 'f_assim', itime_in_file, sumarea, filter, & 'canopy assimilation rate','mol m-2 s-1') ! respiration (plant+soil) [mol m-2 s-1] - call write_history_variable_2d ( DEF_hist_vars%respc, & + CALL write_history_variable_2d ( DEF_hist_vars%respc, & a_respc, file_hist, 'f_respc', itime_in_file, sumarea, filter, & 'respiration (plant+soil)','mol m-2 s-1') ! groundwater recharge rate [mm/s] - call write_history_variable_2d ( DEF_hist_vars%qcharge, & + CALL write_history_variable_2d ( DEF_hist_vars%qcharge, & a_qcharge, file_hist, 'f_qcharge', itime_in_file, sumarea, filter, & 'groundwater recharge rate','mm/s') ! ground surface temperature [K] - call write_history_variable_2d ( DEF_hist_vars%t_grnd, & + CALL write_history_variable_2d ( DEF_hist_vars%t_grnd, & a_t_grnd, file_hist, 'f_t_grnd', itime_in_file, sumarea, filter, & 'ground surface temperature','K') ! leaf temperature [K] - call write_history_variable_2d ( DEF_hist_vars%tleaf, & + CALL write_history_variable_2d ( DEF_hist_vars%tleaf, & a_tleaf, file_hist, 'f_tleaf', itime_in_file, sumarea, filter, & 'leaf temperature','K') ! depth of water on foliage [mm] - call write_history_variable_2d ( DEF_hist_vars%ldew, & + CALL write_history_variable_2d ( DEF_hist_vars%ldew, & a_ldew, file_hist, 'f_ldew', itime_in_file, sumarea, filter, & 'depth of water on foliage','mm') ! snow cover, water equivalent [mm] - call write_history_variable_2d ( DEF_hist_vars%scv, & + CALL write_history_variable_2d ( DEF_hist_vars%scv, & a_scv, file_hist, 'f_scv', itime_in_file, sumarea, filter, & 'snow cover, water equivalent','mm') ! snow depth [meter] - call write_history_variable_2d ( DEF_hist_vars%snowdp, & + CALL write_history_variable_2d ( DEF_hist_vars%snowdp, & a_snowdp, file_hist, 'f_snowdp', itime_in_file, sumarea, filter, & 'snow depth','meter') ! fraction of snow cover on ground - call write_history_variable_2d ( DEF_hist_vars%fsno, & + CALL write_history_variable_2d ( DEF_hist_vars%fsno, & a_fsno, file_hist, 'f_fsno', itime_in_file, sumarea, filter, & 'fraction of snow cover on ground','-') ! fraction of veg cover, excluding snow-covered veg [-] - call write_history_variable_2d ( DEF_hist_vars%sigf, & + CALL write_history_variable_2d ( DEF_hist_vars%sigf, & a_sigf, file_hist, 'f_sigf', itime_in_file, sumarea, filter, & 'fraction of veg cover, excluding snow-covered veg','-') ! leaf greenness - call write_history_variable_2d ( DEF_hist_vars%green, & + CALL write_history_variable_2d ( DEF_hist_vars%green, & a_green, file_hist, 'f_green', itime_in_file, sumarea, filter, & 'leaf greenness','-') ! leaf area index - call write_history_variable_2d ( DEF_hist_vars%lai, & + CALL write_history_variable_2d ( DEF_hist_vars%lai, & a_lai, file_hist, 'f_lai', itime_in_file, sumarea, filter, & 'leaf area index','m2/m2') ! leaf area index - call write_history_variable_2d ( DEF_hist_vars%laisun, & + CALL write_history_variable_2d ( DEF_hist_vars%laisun, & a_laisun, file_hist, 'f_laisun', itime_in_file, sumarea, filter, & 'sunlit leaf area index','m2/m2') ! leaf area index - call write_history_variable_2d ( DEF_hist_vars%laisha, & + CALL write_history_variable_2d ( DEF_hist_vars%laisha, & a_laisha, file_hist, 'f_laisha', itime_in_file, sumarea, filter, & 'shaded leaf area index','m2/m2') ! stem area index - call write_history_variable_2d ( DEF_hist_vars%sai, & + CALL write_history_variable_2d ( DEF_hist_vars%sai, & a_sai, file_hist, 'f_sai', itime_in_file, sumarea, filter, & 'stem area index','m2/m2') ! averaged albedo [visible, direct; direct, diffuse] - call write_history_variable_4d ( DEF_hist_vars%alb, & + CALL write_history_variable_4d ( DEF_hist_vars%alb, & a_alb, file_hist, 'f_alb', itime_in_file, 'band', 1, 2, 'rtyp', 1, 2, sumarea, filter, & 'averaged albedo direct','%') ! averaged bulk surface emissivity - call write_history_variable_2d ( DEF_hist_vars%emis, & + CALL write_history_variable_2d ( DEF_hist_vars%emis, & a_emis, file_hist, 'f_emis', itime_in_file, sumarea, filter, & 'averaged bulk surface emissivity','-') ! effective roughness [m] - call write_history_variable_2d ( DEF_hist_vars%z0m, & + CALL write_history_variable_2d ( DEF_hist_vars%z0m, & a_z0m, file_hist, 'f_z0m', itime_in_file, sumarea, filter, & 'effective roughness','m') ! radiative temperature of surface [K] - call write_history_variable_2d ( DEF_hist_vars%trad, & + CALL write_history_variable_2d ( DEF_hist_vars%trad, & a_trad, file_hist, 'f_trad', itime_in_file, sumarea, filter, & 'radiative temperature of surface','kelvin') ! 2 m height air temperature [kelvin] - call write_history_variable_2d ( DEF_hist_vars%tref, & + CALL write_history_variable_2d ( DEF_hist_vars%tref, & a_tref, file_hist, 'f_tref', itime_in_file, sumarea, filter, & '2 m height air temperature','kelvin') ! 2 m height air specific humidity [kg/kg] - call write_history_variable_2d ( DEF_hist_vars%qref, & + CALL write_history_variable_2d ( DEF_hist_vars%qref, & a_qref, file_hist, 'f_qref', itime_in_file, sumarea, filter, & '2 m height air specific humidity','kg/kg') @@ -631,11 +631,11 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & ENDIF filter = filter .and. patchmask - end if - end if + END if + END if ! wetland water storage [mm] - call write_history_variable_2d ( DEF_hist_vars%wetwat, & + CALL write_history_variable_2d ( DEF_hist_vars%wetwat, & a_wetwat, file_hist, 'f_wetwat', itime_in_file, sumarea, filter, & 'wetland water storage','mm') @@ -644,7 +644,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & vecacc = wetwat WHERE(vecacc /= spval) vecacc = vecacc * nac ENDIF - call write_history_variable_2d ( DEF_hist_vars%wetwat_inst, & + CALL write_history_variable_2d ( DEF_hist_vars%wetwat_inst, & vecacc, file_hist, 'f_wetwat_inst', itime_in_file, sumarea, filter, & 'instantaneous wetland water storage','mm') @@ -666,110 +666,110 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & ENDIF ENDIF ENDDO - end if - end if + END if + END if IF (HistForm == 'Gridded') THEN - call mp2g_hist_urb%map (VecOnes_urb, sumarea_urb, spv = spval, msk = filter_urb) + CALL mp2g_hist_urb%map (VecOnes_urb, sumarea_urb, spv = spval, msk = filter_urb) ENDIF ! sensible heat from building roof [W/m2] - call write_history_variable_urb_2d ( DEF_hist_vars%fsen_roof, & + CALL write_history_variable_urb_2d ( DEF_hist_vars%fsen_roof, & a_senroof, file_hist, 'f_fsenroof', itime_in_file, sumarea_urb, filter_urb, & 'sensible heat from urban roof [W/m2]','W/m2') ! sensible heat from building sunlit wall [W/m2] - call write_history_variable_urb_2d ( DEF_hist_vars%fsen_wsun, & + CALL write_history_variable_urb_2d ( DEF_hist_vars%fsen_wsun, & a_senwsun, file_hist, 'f_fsenwsun', itime_in_file, sumarea_urb, filter_urb, & 'sensible heat from urban sunlit wall [W/m2]','W/m2') ! sensible heat from building shaded wall [W/m2] - call write_history_variable_urb_2d ( DEF_hist_vars%fsen_wsha, & + CALL write_history_variable_urb_2d ( DEF_hist_vars%fsen_wsha, & a_senwsha, file_hist, 'f_fsenwsha', itime_in_file, sumarea_urb, filter_urb, & 'sensible heat from urban shaded wall [W/m2]','W/m2') ! sensible heat from impervious ground [W/m2] - call write_history_variable_urb_2d ( DEF_hist_vars%fsen_gimp, & + CALL write_history_variable_urb_2d ( DEF_hist_vars%fsen_gimp, & a_sengimp, file_hist, 'f_fsengimp', itime_in_file, sumarea_urb, filter_urb, & 'sensible heat from urban impervious ground [W/m2]','W/m2') ! sensible heat from pervious ground [W/m2] - call write_history_variable_urb_2d ( DEF_hist_vars%fsen_gper, & + CALL write_history_variable_urb_2d ( DEF_hist_vars%fsen_gper, & a_sengper, file_hist, 'f_fsengper', itime_in_file, sumarea_urb, filter_urb, & 'sensible heat from urban pervious ground [W/m2]','W/m2') ! sensible heat from urban tree [W/m2] - call write_history_variable_urb_2d ( DEF_hist_vars%fsen_urbl, & + CALL write_history_variable_urb_2d ( DEF_hist_vars%fsen_urbl, & a_senurbl, file_hist, 'f_fsenurbl', itime_in_file, sumarea_urb, filter_urb, & 'sensible heat from urban tree [W/m2]','W/m2') ! latent heat flux from building roof [W/m2] - call write_history_variable_urb_2d ( DEF_hist_vars%lfevp_roof, & + CALL write_history_variable_urb_2d ( DEF_hist_vars%lfevp_roof, & a_lfevproof, file_hist, 'f_lfevproof', itime_in_file, sumarea_urb, filter_urb, & 'latent heat from urban roof [W/m2]','W/m2') ! latent heat flux from impervious ground [W/m2] - call write_history_variable_urb_2d ( DEF_hist_vars%lfevp_gimp, & + CALL write_history_variable_urb_2d ( DEF_hist_vars%lfevp_gimp, & a_lfevpgimp, file_hist, 'f_lfevpgimp', itime_in_file, sumarea_urb, filter_urb, & 'latent heat from urban impervious ground [W/m2]','W/m2') ! latent heat flux from pervious ground [W/m2] - call write_history_variable_urb_2d ( DEF_hist_vars%lfevp_gper, & + CALL write_history_variable_urb_2d ( DEF_hist_vars%lfevp_gper, & a_lfevpgper, file_hist, 'f_lfevpgper', itime_in_file, sumarea_urb, filter_urb, & 'latent heat from urban pervious ground [W/m2]','W/m2') ! latent heat flux from urban tree [W/m2] - call write_history_variable_urb_2d ( DEF_hist_vars%lfevp_urbl, & + CALL write_history_variable_urb_2d ( DEF_hist_vars%lfevp_urbl, & a_lfevpurbl, file_hist, 'f_lfevpurbl', itime_in_file, sumarea_urb, filter_urb, & 'latent heat from urban tree [W/m2]','W/m2') ! sensible flux from heat or cool AC [W/m2] - call write_history_variable_urb_2d ( DEF_hist_vars%fhac, & + CALL write_history_variable_urb_2d ( DEF_hist_vars%fhac, & a_fhac, file_hist, 'f_fhac', itime_in_file, sumarea_urb, filter_urb, & 'sensible flux from heat or cool AC [W/m2]','W/m2') ! waste heat flux from heat or cool AC [W/m2] - call write_history_variable_urb_2d ( DEF_hist_vars%fwst, & + CALL write_history_variable_urb_2d ( DEF_hist_vars%fwst, & a_fwst, file_hist, 'f_fwst', itime_in_file, sumarea_urb, filter_urb, & 'waste heat flux from heat or cool AC [W/m2]','W/m2') ! flux from inner and outter air exchange [W/m2] - call write_history_variable_urb_2d ( DEF_hist_vars%fach, & + CALL write_history_variable_urb_2d ( DEF_hist_vars%fach, & a_fach, file_hist, 'f_fach', itime_in_file, sumarea_urb, filter_urb, & 'flux from inner and outter air exchange [W/m2]','W/m2') ! flux from total heating/cooling [W/m2] - call write_history_variable_urb_2d ( DEF_hist_vars%fhah, & + CALL write_history_variable_urb_2d ( DEF_hist_vars%fhah, & a_fhah, file_hist, 'f_fhah', itime_in_file, sumarea_urb, filter_urb, & 'flux from heating/cooling [W/m2]','W/m2') ! flux from metabolism [W/m2] - call write_history_variable_urb_2d ( DEF_hist_vars%meta, & + CALL write_history_variable_urb_2d ( DEF_hist_vars%meta, & a_meta, file_hist, 'f_fmeta', itime_in_file, sumarea_urb, filter_urb, & 'flux from human metabolism [W/m2]','W/m2') ! flux from vehicle [W/m2] - call write_history_variable_urb_2d ( DEF_hist_vars%vehc, & + CALL write_history_variable_urb_2d ( DEF_hist_vars%vehc, & a_vehc, file_hist, 'f_fvehc', itime_in_file, sumarea_urb, filter_urb, & 'flux from traffic [W/m2]','W/m2') ! temperature of inner building [K] - call write_history_variable_urb_2d ( DEF_hist_vars%t_room, & + CALL write_history_variable_urb_2d ( DEF_hist_vars%t_room, & a_t_room, file_hist, 'f_t_room', itime_in_file, sumarea_urb, filter_urb, & 'temperature of inner building [K]','kelvin') ! temperature of outer building [K] - call write_history_variable_urb_2d ( DEF_hist_vars%tafu, & + CALL write_history_variable_urb_2d ( DEF_hist_vars%tafu, & a_tafu, file_hist, 'f_tafu', itime_in_file, sumarea_urb, filter_urb, & 'temperature of outer building [K]','kelvin') ! temperature of building roof [K] - call write_history_variable_urb_2d ( DEF_hist_vars%t_roof, & + CALL write_history_variable_urb_2d ( DEF_hist_vars%t_roof, & a_troof, file_hist, 'f_t_roof', itime_in_file, sumarea_urb, filter_urb, & 'temperature of urban roof [K]','kelvin') ! temperature of building wall [K] - call write_history_variable_urb_2d ( DEF_hist_vars%t_wall, & + CALL write_history_variable_urb_2d ( DEF_hist_vars%t_wall, & a_twall, file_hist, 'f_t_wall', itime_in_file, sumarea_urb, filter_urb, & 'temperature of urban wall [K]','kelvin') #endif @@ -783,319 +783,319 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & IF (DEF_forcing%has_missing_value) THEN filter = filter .and. forcmask ENDIF - end if - end if + END if + END if IF (HistForm == 'Gridded') THEN - call mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) + CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) ENDIF ! 1: assimsun enf temperate - call write_history_variable_2d ( DEF_hist_vars%assimsun, & + CALL write_history_variable_2d ( DEF_hist_vars%assimsun, & a_assimsun, file_hist, 'f_assimsun', itime_in_file, sumarea, filter, & 'Photosynthetic assimilation rate of sunlit leaf for needleleaf evergreen temperate tree','mol m-2 s-1') ! 1: assimsha enf temperate - call write_history_variable_2d ( DEF_hist_vars%assimsha, & + CALL write_history_variable_2d ( DEF_hist_vars%assimsha, & a_assimsha, file_hist, 'f_assimsha', itime_in_file, sumarea, filter, & 'Photosynthetic assimilation rate of shaded leaf for needleleaf evergreen temperate tree','mol m-2 s-1') ! 1: etrsun enf temperate - call write_history_variable_2d ( DEF_hist_vars%etrsun, & + CALL write_history_variable_2d ( DEF_hist_vars%etrsun, & a_etrsun, file_hist, 'f_etrsun', itime_in_file, sumarea, filter, & 'Transpiration rate of sunlit leaf for needleleaf evergreen temperate tree','mm s-1') ! 1: etrsha enf temperate - call write_history_variable_2d ( DEF_hist_vars%etrsha, & + CALL write_history_variable_2d ( DEF_hist_vars%etrsha, & a_etrsha, file_hist, 'f_etrsha', itime_in_file, sumarea, filter, & 'Transpiration rate of shaded leaf for needleleaf evergreen temperate tree','mm s-1') ! rstfacsun - call write_history_variable_2d ( DEF_hist_vars%rstfacsun, & + CALL write_history_variable_2d ( DEF_hist_vars%rstfacsun, & a_rstfacsun, file_hist, 'f_rstfacsun', itime_in_file, sumarea, filter, & 'Ecosystem level Water stress factor on sunlit canopy','unitless') ! rstfacsha - call write_history_variable_2d ( DEF_hist_vars%rstfacsha, & + CALL write_history_variable_2d ( DEF_hist_vars%rstfacsha, & a_rstfacsha, file_hist, 'f_rstfacsha', itime_in_file, sumarea, filter, & 'Ecosystem level Water stress factor on shaded canopy','unitless') ! gssun - call write_history_variable_2d ( DEF_hist_vars%gssun, & + CALL write_history_variable_2d ( DEF_hist_vars%gssun, & a_gssun, file_hist, 'f_gssun', itime_in_file, sumarea, filter, & 'Ecosystem level canopy conductance on sunlit canopy','mol m-2 s-1') ! gssha - call write_history_variable_2d ( DEF_hist_vars%gssha, & + CALL write_history_variable_2d ( DEF_hist_vars%gssha, & a_gssha, file_hist, 'f_gssha', itime_in_file, sumarea, filter, & 'Ecosystem level canopy conductance on shaded canopy','mol m-2 s-1') ! soil resistance [m/s] - call write_history_variable_2d ( DEF_hist_vars%rss, & + CALL write_history_variable_2d ( DEF_hist_vars%rss, & a_rss, file_hist, 'f_rss', itime_in_file, sumarea, filter, & 'soil surface resistance','s/m') #ifdef BGC ! leaf carbon display pool - call write_history_variable_2d ( DEF_hist_vars%leafc, & + CALL write_history_variable_2d ( DEF_hist_vars%leafc, & a_leafc, file_hist, 'f_leafc', itime_in_file, sumarea, filter, & 'leaf carbon display pool','gC/m2') ! leaf carbon storage pool - call write_history_variable_2d ( DEF_hist_vars%leafc_storage, & + CALL write_history_variable_2d ( DEF_hist_vars%leafc_storage, & a_leafc_storage, file_hist, 'f_leafc_storage', itime_in_file, sumarea, filter, & 'leaf carbon storage pool','gC/m2') ! leaf carbon transfer pool - call write_history_variable_2d ( DEF_hist_vars%leafc_xfer, & + CALL write_history_variable_2d ( DEF_hist_vars%leafc_xfer, & a_leafc_xfer, file_hist, 'f_leafc_xfer', itime_in_file, sumarea, filter, & 'leaf carbon transfer pool','gC/m2') ! fine root carbon display pool - call write_history_variable_2d ( DEF_hist_vars%frootc, & + CALL write_history_variable_2d ( DEF_hist_vars%frootc, & a_frootc, file_hist, 'f_frootc', itime_in_file, sumarea, filter, & 'fine root carbon display pool','gC/m2') ! fine root carbon storage pool - call write_history_variable_2d ( DEF_hist_vars%frootc_storage, & + CALL write_history_variable_2d ( DEF_hist_vars%frootc_storage, & a_frootc_storage, file_hist, 'f_frootc_storage', itime_in_file, sumarea, filter, & 'fine root carbon storage pool','gC/m2') ! fine root carbon transfer pool - call write_history_variable_2d ( DEF_hist_vars%frootc_xfer, & + CALL write_history_variable_2d ( DEF_hist_vars%frootc_xfer, & a_frootc_xfer, file_hist, 'f_frootc_xfer', itime_in_file, sumarea, filter, & 'fine root carbon transfer pool','gC/m2') ! live stem carbon display pool - call write_history_variable_2d ( DEF_hist_vars%livestemc, & + CALL write_history_variable_2d ( DEF_hist_vars%livestemc, & a_livestemc, file_hist, 'f_livestemc', itime_in_file, sumarea, filter, & 'live stem carbon display pool','gC/m2') ! live stem carbon storage pool - call write_history_variable_2d ( DEF_hist_vars%livestemc_storage, & + CALL write_history_variable_2d ( DEF_hist_vars%livestemc_storage, & a_livestemc_storage, file_hist, 'f_livestemc_storage', itime_in_file, sumarea, filter, & 'live stem carbon storage pool','gC/m2') ! live stem carbon transfer pool - call write_history_variable_2d ( DEF_hist_vars%livestemc_xfer, & + CALL write_history_variable_2d ( DEF_hist_vars%livestemc_xfer, & a_livestemc_xfer, file_hist, 'f_livestemc_xfer', itime_in_file, sumarea, filter, & 'live stem carbon transfer pool','gC/m2') ! dead stem carbon display pool - call write_history_variable_2d ( DEF_hist_vars%deadstemc, & + CALL write_history_variable_2d ( DEF_hist_vars%deadstemc, & a_deadstemc, file_hist, 'f_deadstemc', itime_in_file, sumarea, filter, & 'dead stem carbon display pool','gC/m2') ! dead stem carbon storage pool - call write_history_variable_2d ( DEF_hist_vars%deadstemc_storage, & + CALL write_history_variable_2d ( DEF_hist_vars%deadstemc_storage, & a_deadstemc_storage, file_hist, 'f_deadstemc_storage', itime_in_file, sumarea, filter, & 'dead stem carbon storage pool','gC/m2') ! dead stem carbon transfer pool - call write_history_variable_2d ( DEF_hist_vars%deadstemc_xfer, & + CALL write_history_variable_2d ( DEF_hist_vars%deadstemc_xfer, & a_deadstemc_xfer, file_hist, 'f_deadstemc_xfer', itime_in_file, sumarea, filter, & 'dead stem carbon transfer pool','gC/m2') ! live coarse root carbon display pool - call write_history_variable_2d ( DEF_hist_vars%livecrootc, & + CALL write_history_variable_2d ( DEF_hist_vars%livecrootc, & a_livecrootc, file_hist, 'f_livecrootc', itime_in_file, sumarea, filter, & 'live coarse root carbon display pool','gC/m2') ! live coarse root carbon storage pool - call write_history_variable_2d ( DEF_hist_vars%livecrootc_storage, & + CALL write_history_variable_2d ( DEF_hist_vars%livecrootc_storage, & a_livecrootc_storage, file_hist, 'f_livecrootc_storage', itime_in_file, sumarea, filter, & 'live coarse root carbon storage pool','gC/m2') ! live coarse root carbon transfer pool - call write_history_variable_2d ( DEF_hist_vars%livecrootc_xfer, & + CALL write_history_variable_2d ( DEF_hist_vars%livecrootc_xfer, & a_livecrootc_xfer, file_hist, 'f_livecrootc_xfer', itime_in_file, sumarea, filter, & 'live coarse root carbon transfer pool','gC/m2') ! dead coarse root carbon display pool - call write_history_variable_2d ( DEF_hist_vars%deadcrootc, & + CALL write_history_variable_2d ( DEF_hist_vars%deadcrootc, & a_deadcrootc, file_hist, 'f_deadcrootc', itime_in_file, sumarea, filter, & 'dead coarse root carbon display pool','gC/m2') ! dead coarse root carbon storage pool - call write_history_variable_2d ( DEF_hist_vars%deadcrootc_storage, & + CALL write_history_variable_2d ( DEF_hist_vars%deadcrootc_storage, & a_deadcrootc_storage, file_hist, 'f_deadcrootc_storage', itime_in_file, sumarea, filter, & 'dead coarse root carbon storage pool','gC/m2') ! dead coarse root carbon transfer pool - call write_history_variable_2d ( DEF_hist_vars%deadcrootc_xfer, & + CALL write_history_variable_2d ( DEF_hist_vars%deadcrootc_xfer, & a_deadcrootc_xfer, file_hist, 'f_deadcrootc_xfer', itime_in_file, sumarea, filter, & 'dead coarse root carbon transfer pool','gC/m2') #ifdef CROP ! grain carbon display pool - call write_history_variable_2d ( DEF_hist_vars%grainc, & + CALL write_history_variable_2d ( DEF_hist_vars%grainc, & a_grainc, file_hist, 'f_grainc', itime_in_file, sumarea, filter, & 'grain carbon display pool','gC/m2') ! grain carbon storage pool - call write_history_variable_2d ( DEF_hist_vars%grainc_storage, & + CALL write_history_variable_2d ( DEF_hist_vars%grainc_storage, & a_grainc_storage, file_hist, 'f_grainc_storage', itime_in_file, sumarea, filter, & 'grain carbon storage pool','gC/m2') ! grain carbon transfer pool - call write_history_variable_2d ( DEF_hist_vars%grainc_xfer, & + CALL write_history_variable_2d ( DEF_hist_vars%grainc_xfer, & a_grainc_xfer, file_hist, 'f_grainc_xfer', itime_in_file, sumarea, filter, & 'grain carbon transfer pool','gC/m2') #endif ! leaf nitrogen display pool - call write_history_variable_2d ( DEF_hist_vars%leafn, & + CALL write_history_variable_2d ( DEF_hist_vars%leafn, & a_leafn, file_hist, 'f_leafn', itime_in_file, sumarea, filter, & 'leaf nitrogen display pool','gN/m2') ! leaf nitrogen storage pool - call write_history_variable_2d ( DEF_hist_vars%leafn_storage, & + CALL write_history_variable_2d ( DEF_hist_vars%leafn_storage, & a_leafn_storage, file_hist, 'f_leafn_storage', itime_in_file, sumarea, filter, & 'leaf nitrogen storage pool','gN/m2') ! leaf nitrogen transfer pool - call write_history_variable_2d ( DEF_hist_vars%leafn_xfer, & + CALL write_history_variable_2d ( DEF_hist_vars%leafn_xfer, & a_leafn_xfer, file_hist, 'f_leafn_xfer', itime_in_file, sumarea, filter, & 'leaf nitrogen transfer pool','gN/m2') ! fine root nitrogen display pool - call write_history_variable_2d ( DEF_hist_vars%frootn, & + CALL write_history_variable_2d ( DEF_hist_vars%frootn, & a_frootn, file_hist, 'f_frootn', itime_in_file, sumarea, filter, & 'fine root nitrogen display pool','gN/m2') ! fine root nitrogen storage pool - call write_history_variable_2d ( DEF_hist_vars%frootn_storage, & + CALL write_history_variable_2d ( DEF_hist_vars%frootn_storage, & a_frootn_storage, file_hist, 'f_frootn_storage', itime_in_file, sumarea, filter, & 'fine root nitrogen storage pool','gN/m2') ! fine root nitrogen transfer pool - call write_history_variable_2d ( DEF_hist_vars%frootn_xfer, & + CALL write_history_variable_2d ( DEF_hist_vars%frootn_xfer, & a_frootn_xfer, file_hist, 'f_frootn_xfer', itime_in_file, sumarea, filter, & 'fine root nitrogen transfer pool','gN/m2') ! live stem nitrogen display pool - call write_history_variable_2d ( DEF_hist_vars%livestemn, & + CALL write_history_variable_2d ( DEF_hist_vars%livestemn, & a_livestemn, file_hist, 'f_livestemn', itime_in_file, sumarea, filter, & 'live stem nitrogen display pool','gN/m2') ! live stem nitrogen storage pool - call write_history_variable_2d ( DEF_hist_vars%livestemn_storage, & + CALL write_history_variable_2d ( DEF_hist_vars%livestemn_storage, & a_livestemn_storage, file_hist, 'f_livestemn_storage', itime_in_file, sumarea, filter, & 'live stem nitrogen storage pool','gN/m2') ! live stem nitrogen transfer pool - call write_history_variable_2d ( DEF_hist_vars%livestemn_xfer, & + CALL write_history_variable_2d ( DEF_hist_vars%livestemn_xfer, & a_livestemn_xfer, file_hist, 'f_livestemn_xfer', itime_in_file, sumarea, filter, & 'live stem nitrogen transfer pool','gN/m2') ! dead stem nitrogen display pool - call write_history_variable_2d ( DEF_hist_vars%deadstemn, & + CALL write_history_variable_2d ( DEF_hist_vars%deadstemn, & a_deadstemn, file_hist, 'f_deadstemn', itime_in_file, sumarea, filter, & 'dead stem nitrogen display pool','gN/m2') ! dead stem nitrogen storage pool - call write_history_variable_2d ( DEF_hist_vars%deadstemn_storage, & + CALL write_history_variable_2d ( DEF_hist_vars%deadstemn_storage, & a_deadstemn_storage, file_hist, 'f_deadstemn_storage', itime_in_file, sumarea, filter, & 'dead stem nitrogen storage pool','gN/m2') ! dead stem nitrogen transfer pool - call write_history_variable_2d ( DEF_hist_vars%deadstemn_xfer, & + CALL write_history_variable_2d ( DEF_hist_vars%deadstemn_xfer, & a_deadstemn_xfer, file_hist, 'f_deadstemn_xfer', itime_in_file, sumarea, filter, & 'dead stem nitrogen transfer pool','gN/m2') ! live coarse root nitrogen display pool - call write_history_variable_2d ( DEF_hist_vars%livecrootn, & + CALL write_history_variable_2d ( DEF_hist_vars%livecrootn, & a_livecrootn, file_hist, 'f_livecrootn', itime_in_file, sumarea, filter, & 'live coarse root nitrogen display pool','gN/m2') ! live coarse root nitrogen storage pool - call write_history_variable_2d ( DEF_hist_vars%livecrootn_storage, & + CALL write_history_variable_2d ( DEF_hist_vars%livecrootn_storage, & a_livecrootn_storage, file_hist, 'f_livecrootn_storage', itime_in_file, sumarea, filter, & 'live coarse root nitrogen storage pool','gN/m2') ! live coarse root nitrogen transfer pool - call write_history_variable_2d ( DEF_hist_vars%livecrootn_xfer, & + CALL write_history_variable_2d ( DEF_hist_vars%livecrootn_xfer, & a_livecrootn_xfer, file_hist, 'f_livecrootn_xfer', itime_in_file, sumarea, filter, & 'live coarse root nitrogen transfer pool','gN/m2') ! dead coarse root nitrogen display pool - call write_history_variable_2d ( DEF_hist_vars%deadcrootn, & + CALL write_history_variable_2d ( DEF_hist_vars%deadcrootn, & a_deadcrootn, file_hist, 'f_deadcrootn', itime_in_file, sumarea, filter, & 'dead coarse root nitrogen display pool','gN/m2') ! dead coarse root nitrogen storage pool - call write_history_variable_2d ( DEF_hist_vars%deadcrootn_storage, & + CALL write_history_variable_2d ( DEF_hist_vars%deadcrootn_storage, & a_deadcrootn_storage, file_hist, 'f_deadcrootn_storage', itime_in_file, sumarea, filter, & 'dead coarse root nitrogen storage pool','gN/m2') ! dead coarse root nitrogen transfer pool - call write_history_variable_2d ( DEF_hist_vars%deadcrootn_xfer, & + CALL write_history_variable_2d ( DEF_hist_vars%deadcrootn_xfer, & a_deadcrootn_xfer, file_hist, 'f_deadcrootn_xfer', itime_in_file, sumarea, filter, & 'dead coarse root nitrogen transfer pool','gN/m2') #ifdef CROP ! grain nitrogen display pool - call write_history_variable_2d ( DEF_hist_vars%grainn, & + CALL write_history_variable_2d ( DEF_hist_vars%grainn, & a_grainn, file_hist, 'f_grainn', itime_in_file, sumarea, filter, & 'grain nitrogen display pool','gN/m2') ! grain nitrogen storage pool - call write_history_variable_2d ( DEF_hist_vars%grainn_storage, & + CALL write_history_variable_2d ( DEF_hist_vars%grainn_storage, & a_grainn_storage, file_hist, 'f_grainn_storage', itime_in_file, sumarea, filter, & 'grain nitrogen storage pool','gN/m2') ! grain nitrogen transfer pool - call write_history_variable_2d ( DEF_hist_vars%grainn_xfer, & + CALL write_history_variable_2d ( DEF_hist_vars%grainn_xfer, & a_grainn_xfer, file_hist, 'f_grainn_xfer', itime_in_file, sumarea, filter, & 'grain nitrogen transfer pool','gN/m2') #endif ! retranslocation nitrogen pool - call write_history_variable_2d ( DEF_hist_vars%retrasn, & + CALL write_history_variable_2d ( DEF_hist_vars%retrasn, & a_retransn, file_hist, 'f_retrasn', itime_in_file, sumarea, filter, & 'retranslocation nitrogen pool','gN/m2') ! gross primary productivity - call write_history_variable_2d ( DEF_hist_vars%gpp, & + CALL write_history_variable_2d ( DEF_hist_vars%gpp, & a_gpp, file_hist, 'f_gpp', itime_in_file, sumarea, filter, & 'gross primary productivity','gC/m2/s') ! gross primary productivity - call write_history_variable_2d ( DEF_hist_vars%downreg, & + CALL write_history_variable_2d ( DEF_hist_vars%downreg, & a_downreg, file_hist, 'f_downreg', itime_in_file, sumarea, filter, & 'gpp downregulation due to N limitation','unitless') - call write_history_variable_2d ( DEF_hist_vars%fpg, & + CALL write_history_variable_2d ( DEF_hist_vars%fpg, & a_fpg, file_hist, 'f_fpg', itime_in_file, sumarea, filter, & 'fraction of gpp potential','unitless') - call write_history_variable_2d ( DEF_hist_vars%fpi, & + CALL write_history_variable_2d ( DEF_hist_vars%fpi, & a_fpi, file_hist, 'f_fpi', itime_in_file, sumarea, filter, & 'fraction of immobalization','unitless') ! autotrophic respiration - call write_history_variable_2d ( DEF_hist_vars%ar , & + CALL write_history_variable_2d ( DEF_hist_vars%ar , & a_ar, file_hist, 'f_ar', itime_in_file, sumarea, filter, & 'autotrophic respiration','gC/m2/s') ! CWD production - call write_history_variable_2d ( DEF_hist_vars%cwdprod , & + CALL write_history_variable_2d ( DEF_hist_vars%cwdprod , & a_cwdprod, file_hist, 'f_cwdprod', itime_in_file, sumarea, filter, & 'CWD production','gC/m2/s') ! CWD decomposition - call write_history_variable_2d ( DEF_hist_vars%cwddecomp , & + CALL write_history_variable_2d ( DEF_hist_vars%cwddecomp , & a_cwddecomp, file_hist, 'f_cwddecomp', itime_in_file, sumarea, filter, & 'CWD decomposition','gC/m2/s') ! heterotrophic respiration - call write_history_variable_2d ( DEF_hist_vars%hr , & + CALL write_history_variable_2d ( DEF_hist_vars%hr , & a_hr, file_hist, 'f_hr', itime_in_file, sumarea, filter, & 'heterotrophic respiration','gC/m2/s') #ifdef CROP ! crop phase - call write_history_variable_2d ( DEF_hist_vars%cphase, & + CALL write_history_variable_2d ( DEF_hist_vars%cphase, & a_cphase, file_hist, 'f_cphase', itime_in_file, sumarea, filter, & 'crop phase','unitless') @@ -1103,217 +1103,217 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & if (p_is_worker) then if (numpatch > 0) then vecacc (:) = a_hui (:) - end if - end if + END if + END if - call write_history_variable_2d ( DEF_hist_vars%hui, & + CALL write_history_variable_2d ( DEF_hist_vars%hui, & vecacc, file_hist, 'f_hui', itime_in_file, sumarea, filter, & 'heat unit index','unitless') ! gdd needed to harvest - call write_history_variable_2d ( DEF_hist_vars%gddmaturity, & + CALL write_history_variable_2d ( DEF_hist_vars%gddmaturity, & a_gddmaturity, file_hist, 'f_gddmaturity', itime_in_file, sumarea, filter, & 'gdd needed to harvest','ddays') ! gdd past planting date for crop - call write_history_variable_2d ( DEF_hist_vars%gddplant, & + CALL write_history_variable_2d ( DEF_hist_vars%gddplant, & a_gddplant, file_hist, 'f_gddplant', itime_in_file, sumarea, filter, & 'gdd past planting date for crop','ddays') ! vernalization response - call write_history_variable_2d ( DEF_hist_vars%vf, & + CALL write_history_variable_2d ( DEF_hist_vars%vf, & a_vf, file_hist, 'f_vf', itime_in_file, sumarea, filter, & 'vernalization response', 'unitless') ! 1-yr crop production carbon - call write_history_variable_2d ( DEF_hist_vars%cropprod1c, & + CALL write_history_variable_2d ( DEF_hist_vars%cropprod1c, & a_cropprod1c, file_hist, 'f_cropprod1c', itime_in_file, sumarea, filter, & '1-yr crop production carbon','gC/m2') ! loss rate of 1-yr crop production carbon - call write_history_variable_2d ( DEF_hist_vars%cropprod1c_loss, & + CALL write_history_variable_2d ( DEF_hist_vars%cropprod1c_loss, & a_cropprod1c_loss, file_hist, 'f_cropprod1c_loss', itime_in_file, sumarea, filter, & 'loss rate of 1-yr crop production carbon','gC/m2/s') ! crop seed deficit - call write_history_variable_2d ( DEF_hist_vars%cropseedc_deficit, & + CALL write_history_variable_2d ( DEF_hist_vars%cropseedc_deficit, & a_cropseedc_deficit, file_hist, 'f_cropseedc_deficit', itime_in_file, sumarea, filter, & 'crop seed deficit','gC/m2/s') if (p_is_worker) then if (numpatch > 0) then vecacc (:) = a_grainc_to_cropprodc (:) - end if - end if + END if + END if ! grain to crop production carbon - call write_history_variable_2d ( DEF_hist_vars%grainc_to_cropprodc, & + CALL write_history_variable_2d ( DEF_hist_vars%grainc_to_cropprodc, & vecacc, file_hist, 'f_grainc_to_cropprodc', itime_in_file, sumarea, filter, & 'grain to crop production carbon','gC/m2/s') ! grain to crop seed carbon - call write_history_variable_2d ( DEF_hist_vars%grainc_to_seed, & + CALL write_history_variable_2d ( DEF_hist_vars%grainc_to_seed, & a_grainc_to_seed, file_hist, 'f_grainc_to_seed', itime_in_file, sumarea, filter, & 'grain to crop seed carbon','gC/m2/s') ! grain to crop seed carbon - call write_history_variable_2d ( DEF_hist_vars%fert_to_sminn, & + CALL write_history_variable_2d ( DEF_hist_vars%fert_to_sminn, & a_fert_to_sminn, file_hist, 'f_fert_to_sminn', itime_in_file, sumarea, filter, & 'fertilization','gN/m2/s') if(DEF_USE_IRRIGATION)then ! irrigation rate mm/s in 4h is averaged to the given time resolution mm/s - call write_history_variable_2d ( DEF_hist_vars%irrig_rate, & + CALL write_history_variable_2d ( DEF_hist_vars%irrig_rate, & a_irrig_rate, file_hist, 'f_irrig_rate', itime_in_file, sumarea, filter, & 'irrigation rate mm/s in 4h is averaged to the given time resolution mm/s','mm/s') ! still need irrigation amounts - call write_history_variable_2d ( DEF_hist_vars%deficit_irrig, & + CALL write_history_variable_2d ( DEF_hist_vars%deficit_irrig, & a_deficit_irrig, file_hist, 'f_deficit_irrig', itime_in_file, sumarea, filter, & 'still need irrigation amounts','kg/m2') ! total irrigation amounts at growing season - call write_history_variable_2d ( DEF_hist_vars%sum_irrig, & + CALL write_history_variable_2d ( DEF_hist_vars%sum_irrig, & a_sum_irrig, file_hist, 'f_sum_irrig', itime_in_file, sumarea, filter, & 'total irrigation amounts at growing season','kg/m2') ! total irrigation times at growing season - call write_history_variable_2d ( DEF_hist_vars%sum_irrig_count, & + CALL write_history_variable_2d ( DEF_hist_vars%sum_irrig_count, & a_sum_irrig_count, file_hist, 'f_sum_irrig_count', itime_in_file, sumarea, filter, & 'total irrigation times at growing season','-') - end if + END if #endif ! grain to crop seed carbon - call write_history_variable_2d ( DEF_hist_vars%ndep_to_sminn, & + CALL write_history_variable_2d ( DEF_hist_vars%ndep_to_sminn, & a_ndep_to_sminn, file_hist, 'f_ndep_to_sminn', itime_in_file, sumarea, filter, & 'nitrogen deposition','gN/m2/s') IF(DEF_USE_OZONESTRESS)THEN ! ozone concentration - call write_history_variable_2d ( DEF_hist_vars%xy_ozone, & + CALL write_history_variable_2d ( DEF_hist_vars%xy_ozone, & a_ozone, file_hist, 'f_xy_ozone', itime_in_file, sumarea, filter, & 'Ozone concentration','mol/mol') ENDIF ! litter 1 carbon density in soil layers - call write_history_variable_3d ( DEF_hist_vars%litr1c_vr, & + CALL write_history_variable_3d ( DEF_hist_vars%litr1c_vr, & a_litr1c_vr, file_hist, 'f_litr1c_vr', itime_in_file, 'soil', 1, nl_soil, & sumarea, filter,'litter 1 carbon density in soil layers','gC/m3') ! litter 2 carbon density in soil layers - call write_history_variable_3d ( DEF_hist_vars%litr2c_vr, & + CALL write_history_variable_3d ( DEF_hist_vars%litr2c_vr, & a_litr2c_vr, file_hist, 'f_litr2c_vr', itime_in_file, 'soil', 1, nl_soil, & sumarea, filter,'litter 2 carbon density in soil layers','gC/m3') ! litter 3 carbon density in soil layers - call write_history_variable_3d ( DEF_hist_vars%litr3c_vr, & + CALL write_history_variable_3d ( DEF_hist_vars%litr3c_vr, & a_litr3c_vr, file_hist, 'f_litr3c_vr', itime_in_file, 'soil', 1, nl_soil, & sumarea, filter,'litter 3 carbon density in soil layers','gC/m3') ! soil 1 carbon density in soil layers - call write_history_variable_3d ( DEF_hist_vars%soil1c_vr, & + CALL write_history_variable_3d ( DEF_hist_vars%soil1c_vr, & a_soil1c_vr, file_hist, 'f_soil1c_vr', itime_in_file, 'soil', 1, nl_soil, & sumarea, filter,'soil 1 carbon density in soil layers','gC/m3') ! soil 2 carbon density in soil layers - call write_history_variable_3d ( DEF_hist_vars%soil2c_vr, & + CALL write_history_variable_3d ( DEF_hist_vars%soil2c_vr, & a_soil2c_vr, file_hist, 'f_soil2c_vr', itime_in_file, 'soil', 1, nl_soil, & sumarea, filter,'soil 2 carbon density in soil layers','gC/m3') ! soil 3 carbon density in soil layers - call write_history_variable_3d ( DEF_hist_vars%soil3c_vr, & + CALL write_history_variable_3d ( DEF_hist_vars%soil3c_vr, & a_soil3c_vr, file_hist, 'f_soil3c_vr', itime_in_file, 'soil', 1, nl_soil, & sumarea, filter,'soil 3 carbon density in soil layers','gC/m3') ! coarse woody debris carbon density in soil layers - call write_history_variable_3d ( DEF_hist_vars%cwdc_vr, & + CALL write_history_variable_3d ( DEF_hist_vars%cwdc_vr, & a_cwdc_vr, file_hist, 'f_cwdc_vr', itime_in_file, 'soil', 1, nl_soil, & sumarea, filter,'coarse woody debris carbon density in soil layers','gC/m3') ! litter 1 nitrogen density in soil layers - call write_history_variable_3d ( DEF_hist_vars%litr1n_vr, & + CALL write_history_variable_3d ( DEF_hist_vars%litr1n_vr, & a_litr1n_vr, file_hist, 'f_litr1n_vr', itime_in_file, 'soil', 1, nl_soil, & sumarea, filter,'litter 1 nitrogen density in soil layers','gN/m3') ! litter 2 nitrogen density in soil layers - call write_history_variable_3d ( DEF_hist_vars%litr2n_vr, & + CALL write_history_variable_3d ( DEF_hist_vars%litr2n_vr, & a_litr2n_vr, file_hist, 'f_litr2n_vr', itime_in_file, 'soil', 1, nl_soil, & sumarea, filter,'litter 2 nitrogen density in soil layers','gN/m3') ! litter 3 nitrogen density in soil layers - call write_history_variable_3d ( DEF_hist_vars%litr3n_vr, & + CALL write_history_variable_3d ( DEF_hist_vars%litr3n_vr, & a_litr3n_vr, file_hist, 'f_litr3n_vr', itime_in_file, 'soil', 1, nl_soil, & sumarea, filter,'litter 3 nitrogen density in soil layers','gN/m3') ! soil 1 nitrogen density in soil layers - call write_history_variable_3d ( DEF_hist_vars%soil1n_vr, & + CALL write_history_variable_3d ( DEF_hist_vars%soil1n_vr, & a_soil1n_vr, file_hist, 'f_soil1n_vr', itime_in_file, 'soil', 1, nl_soil, & sumarea, filter,'soil 1 nitrogen density in soil layers','gN/m3') ! soil 2 nitrogen density in soil layers - call write_history_variable_3d ( DEF_hist_vars%soil2n_vr, & + CALL write_history_variable_3d ( DEF_hist_vars%soil2n_vr, & a_soil2n_vr, file_hist, 'f_soil2n_vr', itime_in_file, 'soil', 1, nl_soil, & sumarea, filter,'soil 2 nitrogen density in soil layers','gN/m3') ! soil 3 nitrogen density in soil layers - call write_history_variable_3d ( DEF_hist_vars%soil3n_vr, & + CALL write_history_variable_3d ( DEF_hist_vars%soil3n_vr, & a_soil3n_vr, file_hist, 'f_soil3n_vr', itime_in_file, 'soil', 1, nl_soil, & sumarea, filter,'soil 3 nitrogen density in soil layers','gN/m3') ! coarse woody debris nitrogen density in soil layers - call write_history_variable_3d ( DEF_hist_vars%cwdn_vr, & + CALL write_history_variable_3d ( DEF_hist_vars%cwdn_vr, & a_cwdn_vr, file_hist, 'f_cwdn_vr', itime_in_file, 'soil', 1, nl_soil, & sumarea, filter,'coarse woody debris nitrogen density in soil layers','gN/m3') ! mineral nitrogen density in soil layers - call write_history_variable_3d ( DEF_hist_vars%sminn_vr, & + CALL write_history_variable_3d ( DEF_hist_vars%sminn_vr, & a_sminn_vr, file_hist, 'f_sminn_vr', itime_in_file, 'soil', 1, nl_soil, & sumarea, filter,'mineral nitrogen density in soil layers','gN/m3') ! bulk density in soil layers - call write_history_variable_3d ( DEF_hist_vars%BD_all, & + CALL write_history_variable_3d ( DEF_hist_vars%BD_all, & a_BD_all, file_hist, 'f_BD_all', itime_in_file, 'soil', 1, nl_soil, & sumarea, filter,'bulk density in soil layers','kg/m3') ! field capacity in soil layers - call write_history_variable_3d ( DEF_hist_vars%wfc, & + CALL write_history_variable_3d ( DEF_hist_vars%wfc, & a_wfc, file_hist, 'f_wfc', itime_in_file, 'soil', 1, nl_soil, & sumarea, filter,'field capacity in soil layers','m3/m3') ! organic matter density in soil layers - call write_history_variable_3d ( DEF_hist_vars%OM_density, & + CALL write_history_variable_3d ( DEF_hist_vars%OM_density, & a_OM_density, file_hist, 'f_OM_density', itime_in_file, 'soil', 1, nl_soil, & sumarea, filter,'organic matter density in soil layers','kg/m3') if (DEF_USE_NITRIF) then ! O2 soil Concentration for non-inundated area - call write_history_variable_3d ( DEF_hist_vars%CONC_O2_UNSAT, & + CALL write_history_variable_3d ( DEF_hist_vars%CONC_O2_UNSAT, & a_conc_o2_unsat, file_hist, 'f_CONC_O2_UNSAT', itime_in_file, 'soil', 1, nl_soil, & sumarea, filter,'O2 soil Concentration for non-inundated area','mol/m3') ! O2 consumption from HR and AR for non-inundated area - call write_history_variable_3d ( DEF_hist_vars%O2_DECOMP_DEPTH_UNSAT, & + CALL write_history_variable_3d ( DEF_hist_vars%O2_DECOMP_DEPTH_UNSAT, & a_o2_decomp_depth_unsat, file_hist, 'f_O2_DECOMP_DEPTH_UNSAT', itime_in_file, 'soil', 1, nl_soil, & sumarea, filter,'O2 consumption from HR and AR for non-inundated area','mol/m3/s') - end if + END if if (DEF_USE_FIRE) then - call write_history_variable_2d ( DEF_hist_vars%abm, & + CALL write_history_variable_2d ( DEF_hist_vars%abm, & vecacc, file_hist, 'f_abm', itime_in_file, sumarea, filter, & 'peak crop fire month','unitless') - call write_history_variable_2d ( DEF_hist_vars%gdp, & + CALL write_history_variable_2d ( DEF_hist_vars%gdp, & vecacc, file_hist, 'f_gdp', itime_in_file, sumarea, filter, & 'gdp','unitless') - call write_history_variable_2d ( DEF_hist_vars%peatf, & + CALL write_history_variable_2d ( DEF_hist_vars%peatf, & vecacc, file_hist, 'f_peatf', itime_in_file, sumarea, filter, & 'peatf','unitless') - call write_history_variable_2d ( DEF_hist_vars%hdm, & + CALL write_history_variable_2d ( DEF_hist_vars%hdm, & vecacc, file_hist, 'f_hdm', itime_in_file, sumarea, filter, & 'hdm','unitless') - call write_history_variable_2d ( DEF_hist_vars%lnfm, & + CALL write_history_variable_2d ( DEF_hist_vars%lnfm, & vecacc, file_hist, 'f_lnfm', itime_in_file, sumarea, filter, & 'lnfm','unitless') - end if + END if if (p_is_worker) then @@ -1323,152 +1323,152 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & filter(i) = .true. else filter(i) = .false. - end if - end do - end if - end if + END if + END do + END if + END if IF (HistForm == 'Gridded') then - call mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) + CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) ENDIF ! 1: gpp enf temperate - call write_history_variable_2d ( DEF_hist_vars%gpp_enftemp, & + CALL write_history_variable_2d ( DEF_hist_vars%gpp_enftemp, & a_gpp_enftemp, file_hist, 'f_gpp_enftemp', itime_in_file, sumarea, filter, & 'gross primary productivity for needleleaf evergreen temperate tree','gC/m2/s') ! 1: leaf carbon display pool enf temperate - call write_history_variable_2d ( DEF_hist_vars%leafc_enftemp, & + CALL write_history_variable_2d ( DEF_hist_vars%leafc_enftemp, & a_leafc_enftemp, file_hist, 'f_leafc_enftemp', itime_in_file, sumarea, filter, & 'leaf carbon display pool for needleleaf evergreen temperate tree','gC/m2') ! 2: gpp enf boreal - call write_history_variable_2d ( DEF_hist_vars%gpp_enfboreal, & + CALL write_history_variable_2d ( DEF_hist_vars%gpp_enfboreal, & a_gpp_enfboreal, file_hist, 'f_gpp_enfboreal', itime_in_file, sumarea, filter, & 'gross primary productivity for needleleaf evergreen boreal tree','gC/m2/s') ! 2: leaf carbon display pool enf boreal - call write_history_variable_2d ( DEF_hist_vars%leafc_enfboreal, & + CALL write_history_variable_2d ( DEF_hist_vars%leafc_enfboreal, & a_leafc_enfboreal, file_hist, 'f_leafc_enfboreal', itime_in_file, sumarea, filter, & 'leaf carbon display pool for needleleaf evergreen boreal tree','gC/m2') ! 3: gpp dnf boreal - call write_history_variable_2d ( DEF_hist_vars%gpp_dnfboreal, & + CALL write_history_variable_2d ( DEF_hist_vars%gpp_dnfboreal, & a_gpp_dnfboreal, file_hist, 'f_gpp_dnfboreal', itime_in_file, sumarea, filter, & 'gross primary productivity for needleleaf deciduous boreal tree','gC/m2/s') ! 3: leaf carbon display pool dnf boreal - call write_history_variable_2d ( DEF_hist_vars%leafc_dnfboreal, & + CALL write_history_variable_2d ( DEF_hist_vars%leafc_dnfboreal, & a_leafc_dnfboreal, file_hist, 'f_leafc_dnfboreal', itime_in_file, sumarea, filter, & 'leaf carbon display pool for needleleaf deciduous boreal tree','gC/m2') ! 4: gpp ebf trop - call write_history_variable_2d ( DEF_hist_vars%gpp_ebftrop, & + CALL write_history_variable_2d ( DEF_hist_vars%gpp_ebftrop, & a_gpp_ebftrop, file_hist, 'f_gpp_ebftrop', itime_in_file, sumarea, filter, & 'gross primary productivity for broadleaf evergreen tropical tree','gC/m2/s') ! 4: leaf carbon display pool ebf trop - call write_history_variable_2d ( DEF_hist_vars%leafc_ebftrop, & + CALL write_history_variable_2d ( DEF_hist_vars%leafc_ebftrop, & a_leafc_ebftrop, file_hist, 'f_leafc_ebftrop', itime_in_file, sumarea, filter, & 'leaf carbon display pool for broadleaf evergreen tropical tree','gC/m2') ! 5: gpp ebf temp - call write_history_variable_2d ( DEF_hist_vars%gpp_ebftemp, & + CALL write_history_variable_2d ( DEF_hist_vars%gpp_ebftemp, & a_gpp_ebftemp, file_hist, 'f_gpp_ebftemp', itime_in_file, sumarea, filter, & 'gross primary productivity for broadleaf evergreen temperate tree','gC/m2/s') ! 5: leaf carbon display pool ebf temp - call write_history_variable_2d ( DEF_hist_vars%leafc_ebftemp, & + CALL write_history_variable_2d ( DEF_hist_vars%leafc_ebftemp, & a_leafc_ebftemp, file_hist, 'f_leafc_ebftemp', itime_in_file, sumarea, filter, & 'leaf carbon display pool for broadleaf evergreen temperate tree','gC/m2') ! 6: gpp dbf trop - call write_history_variable_2d ( DEF_hist_vars%gpp_dbftrop, & + CALL write_history_variable_2d ( DEF_hist_vars%gpp_dbftrop, & a_gpp_dbftrop, file_hist, 'f_gpp_dbftrop', itime_in_file, sumarea, filter, & 'gross primary productivity for broadleaf deciduous tropical tree','gC/m2/s') ! 6: leaf carbon display pool dbf trop - call write_history_variable_2d ( DEF_hist_vars%leafc_dbftrop, & + CALL write_history_variable_2d ( DEF_hist_vars%leafc_dbftrop, & a_leafc_dbftrop, file_hist, 'f_leafc_dbftrop', itime_in_file, sumarea, filter, & 'leaf carbon display pool for broadleaf deciduous tropical tree','gC/m2') ! 7: gpp dbf temp - call write_history_variable_2d ( DEF_hist_vars%gpp_dbftemp, & + CALL write_history_variable_2d ( DEF_hist_vars%gpp_dbftemp, & a_gpp_dbftemp, file_hist, 'f_gpp_dbftemp', itime_in_file, sumarea, filter, & 'gross primary productivity for broadleaf deciduous temperate tree','gC/m2/s') ! 7: leaf carbon display pool dbf temp - call write_history_variable_2d ( DEF_hist_vars%leafc_dbftemp, & + CALL write_history_variable_2d ( DEF_hist_vars%leafc_dbftemp, & a_leafc_dbftemp, file_hist, 'f_leafc_dbftemp', itime_in_file, sumarea, filter, & 'leaf carbon display pool for broadleaf deciduous temperate tree','gC/m2') ! 8: gpp dbf boreal - call write_history_variable_2d ( DEF_hist_vars%gpp_dbfboreal, & + CALL write_history_variable_2d ( DEF_hist_vars%gpp_dbfboreal, & a_gpp_dbfboreal, file_hist, 'f_gpp_dbfboreal', itime_in_file, sumarea, filter, & 'gross primary productivity for broadleaf deciduous boreal tree','gC/m2/s') ! 8: leaf carbon display pool dbf boreal - call write_history_variable_2d ( DEF_hist_vars%leafc_dbfboreal, & + CALL write_history_variable_2d ( DEF_hist_vars%leafc_dbfboreal, & a_leafc_dbfboreal, file_hist, 'f_leafc_dbfboreal', itime_in_file, sumarea, filter, & 'leaf carbon display pool for broadleaf deciduous boreal tree','gC/m2') ! 9: gpp ebs temp - call write_history_variable_2d ( DEF_hist_vars%gpp_ebstemp, & + CALL write_history_variable_2d ( DEF_hist_vars%gpp_ebstemp, & a_gpp_ebstemp, file_hist, 'f_gpp_ebstemp', itime_in_file, sumarea, filter, & 'gross primary productivity for broadleaf evergreen temperate shrub','gC/m2/s') ! 9: leaf carbon display pool ebs temp - call write_history_variable_2d ( DEF_hist_vars%leafc_ebstemp, & + CALL write_history_variable_2d ( DEF_hist_vars%leafc_ebstemp, & a_leafc_ebstemp, file_hist, 'f_leafc_ebstemp', itime_in_file, sumarea, filter, & 'leaf carbon display pool for broadleaf evergreen temperate shrub','gC/m2') ! 10: gpp dbs temp - call write_history_variable_2d ( DEF_hist_vars%gpp_dbstemp, & + CALL write_history_variable_2d ( DEF_hist_vars%gpp_dbstemp, & a_gpp_dbstemp, file_hist, 'f_gpp_dbstemp', itime_in_file, sumarea, filter, & 'gross primary productivity for broadleaf deciduous temperate shrub','gC/m2/s') ! 10: leaf carbon display pool dbs temp - call write_history_variable_2d ( DEF_hist_vars%leafc_dbstemp, & + CALL write_history_variable_2d ( DEF_hist_vars%leafc_dbstemp, & a_leafc_dbstemp, file_hist, 'f_leafc_dbstemp', itime_in_file, sumarea, filter, & 'leaf carbon display pool for broadleaf deciduous temperate shrub','gC/m2') ! 11: gpp dbs boreal - call write_history_variable_2d ( DEF_hist_vars%gpp_dbsboreal, & + CALL write_history_variable_2d ( DEF_hist_vars%gpp_dbsboreal, & a_gpp_dbsboreal, file_hist, 'f_gpp_dbsboreal', itime_in_file, sumarea, filter, & 'gross primary productivity for broadleaf deciduous boreal shrub','gC/m2/s') ! 11: leaf carbon display pool dbs boreal - call write_history_variable_2d ( DEF_hist_vars%leafc_dbsboreal, & + CALL write_history_variable_2d ( DEF_hist_vars%leafc_dbsboreal, & a_leafc_dbsboreal, file_hist, 'f_leafc_dbsboreal', itime_in_file, sumarea, filter, & 'leaf carbon display pool for broadleaf deciduous boreal shrub','gC/m2') ! 12: gpp arctic c3 grass - call write_history_variable_2d ( DEF_hist_vars%gpp_c3arcgrass, & + CALL write_history_variable_2d ( DEF_hist_vars%gpp_c3arcgrass, & a_gpp_c3arcgrass, file_hist, 'f_gpp_c3arcgrass', itime_in_file, sumarea, filter, & 'gross primary productivity for c3 arctic grass','gC/m2/s') ! 12: leaf carbon display pool c3 grass - call write_history_variable_2d ( DEF_hist_vars%leafc_c3grass, & + CALL write_history_variable_2d ( DEF_hist_vars%leafc_c3grass, & a_leafc_c3grass, file_hist, 'f_leafc_c3grass', itime_in_file, sumarea, filter, & 'leaf carbon display pool for c3 grass','gC/m2') ! 13: gpp c3 grass - call write_history_variable_2d ( DEF_hist_vars%gpp_c3grass, & + CALL write_history_variable_2d ( DEF_hist_vars%gpp_c3grass, & a_gpp_c3grass, file_hist, 'f_gpp_c3grass', itime_in_file, sumarea, filter, & 'gross primary productivity for c3 grass','gC/m2/s') ! 13: leaf carbon display pool arctic c3 grass - call write_history_variable_2d ( DEF_hist_vars%leafc_c3grass, & + CALL write_history_variable_2d ( DEF_hist_vars%leafc_c3grass, & a_leafc_c3grass, file_hist, 'f_leafc_c3grass', itime_in_file, sumarea, filter, & 'leaf carbon display pool for c3 arctic grass','gC/m2') ! 14: gpp c4 grass - call write_history_variable_2d ( DEF_hist_vars%gpp_c4grass, & + CALL write_history_variable_2d ( DEF_hist_vars%gpp_c4grass, & a_gpp_c4grass, file_hist, 'f_gpp_c4grass', itime_in_file, sumarea, filter, & 'gross primary productivity for c4 grass','gC/m2/s') ! 14: leaf carbon display pool arctic c4 grass - call write_history_variable_2d ( DEF_hist_vars%leafc_c4grass, & + CALL write_history_variable_2d ( DEF_hist_vars%leafc_c4grass, & a_leafc_c4grass, file_hist, 'f_leafc_c4grass', itime_in_file, sumarea, filter, & 'leaf carbon display pool for c4 arctic grass','gC/m2') @@ -1482,24 +1482,24 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & filter(i) = .true. else filter(i) = .false. - end if + END if else filter(i) = .false. - end if - end do - end if - end if + END if + END do + END if + END if IF (HistForm == 'Gridded') THEN - call mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) + CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) ENDIF if (p_is_worker) then if (numpatch > 0) then vecacc (:) = a_hui (:) - end if - end if - call write_history_variable_2d ( DEF_hist_vars%huiswheat, & + END if + END if + CALL write_history_variable_2d ( DEF_hist_vars%huiswheat, & vecacc, file_hist, 'f_huiswheat', itime_in_file, sumarea, filter, & 'heat unit index (rainfed spring wheat)','unitless') @@ -1513,19 +1513,19 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & filter(i) = .true. else filter(i) = .false. - end if + END if else filter(i) = .false. - end if - end do - end if - end if + END if + END do + END if + END if IF (HistForm == 'Gridded') THEN - call mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) + CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) ENDIF - call write_history_variable_2d ( DEF_hist_vars%pdcorn, & + CALL write_history_variable_2d ( DEF_hist_vars%pdcorn, & a_pdcorn, file_hist, 'f_pdcorn', & itime_in_file, sumarea, filter, 'planting date of corn', 'day') @@ -1537,19 +1537,19 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & filter(i) = .true. else filter(i) = .false. - end if + END if else filter(i) = .false. - end if - end do - end if - end if + END if + END do + END if + END if IF (HistForm == 'Gridded') THEN - call mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) + CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) ENDIF - call write_history_variable_2d ( DEF_hist_vars%pdswheat, & + CALL write_history_variable_2d ( DEF_hist_vars%pdswheat, & a_pdswheat, file_hist, 'f_pdswheat', & itime_in_file, sumarea, filter,'planting date of spring wheat','day') @@ -1561,19 +1561,19 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & filter(i) = .true. else filter(i) = .false. - end if + END if else filter(i) = .false. - end if - end do - end if - end if + END if + END do + END if + END if IF (HistForm == 'Gridded') THEN - call mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) + CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) ENDIF - call write_history_variable_2d ( DEF_hist_vars%pdwwheat, & + CALL write_history_variable_2d ( DEF_hist_vars%pdwwheat, & a_pdwwheat, file_hist, 'f_pdwwheat', & itime_in_file, sumarea, filter,'planting date of winter wheat','day') @@ -1586,19 +1586,19 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & filter(i) = .true. else filter(i) = .false. - end if + END if else filter(i) = .false. - end if - end do - end if - end if + END if + END do + END if + END if IF (HistForm == 'Gridded') THEN - call mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) + CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) ENDIF - call write_history_variable_2d ( DEF_hist_vars%pdsoybean, & + CALL write_history_variable_2d ( DEF_hist_vars%pdsoybean, & a_pdsoybean, file_hist, 'f_pdsoybean', & itime_in_file, sumarea, filter,'planting date of soybean','day') @@ -1610,19 +1610,19 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & filter(i) = .true. else filter(i) = .false. - end if + END if else filter(i) = .false. - end if - end do - end if - end if + END if + END do + END if + END if IF (HistForm == 'Gridded') THEN - call mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) + CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) ENDIF - call write_history_variable_2d ( DEF_hist_vars%pdcotton, & + CALL write_history_variable_2d ( DEF_hist_vars%pdcotton, & a_pdcotton, file_hist, 'f_pdcotton', & itime_in_file, sumarea, filter,'planting date of cotton','day') @@ -1634,19 +1634,19 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & filter(i) = .true. else filter(i) = .false. - end if + END if else filter(i) = .false. - end if - end do - end if - end if + END if + END do + END if + END if IF (HistForm == 'Gridded') THEN - call mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) + CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) ENDIF - call write_history_variable_2d ( DEF_hist_vars%pdrice1, & + CALL write_history_variable_2d ( DEF_hist_vars%pdrice1, & a_pdrice1, file_hist, 'f_pdrice1', & itime_in_file, sumarea, filter,'planting date of rice1','day') @@ -1658,19 +1658,19 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & filter(i) = .true. else filter(i) = .false. - end if + END if else filter(i) = .false. - end if - end do - end if - end if + END if + END do + END if + END if IF (HistForm == 'Gridded') THEN - call mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) + CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) ENDIF - call write_history_variable_2d ( DEF_hist_vars%pdrice2, & + CALL write_history_variable_2d ( DEF_hist_vars%pdrice2, & a_pdrice2, file_hist, 'f_pdrice2', & itime_in_file, sumarea, filter,'planting date of rice2','day') @@ -1682,19 +1682,19 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & filter(i) = .true. else filter(i) = .false. - end if + END if else filter(i) = .false. - end if - end do - end if - end if + END if + END do + END if + END if IF (HistForm == 'Gridded') THEN - call mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) + CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) ENDIF - call write_history_variable_2d ( DEF_hist_vars%pdsugarcane, & + CALL write_history_variable_2d ( DEF_hist_vars%pdsugarcane, & a_pdsugarcane, file_hist, 'f_pdsugarcane', & itime_in_file, sumarea, filter,'planting date of sugarcane','day') @@ -1707,19 +1707,19 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & filter(i) = .true. else filter(i) = .false. - end if + END if else filter(i) = .false. - end if - end do - end if - end if + END if + END do + END if + END if IF (HistForm == 'Gridded') THEN - call mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) + CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) ENDIF - call write_history_variable_2d ( DEF_hist_vars%fertnitro_corn, & + CALL write_history_variable_2d ( DEF_hist_vars%fertnitro_corn, & a_fertnitro_corn, file_hist, 'f_fertnitro_corn', & itime_in_file, sumarea, filter,'nitrogen fertilizer for corn','gN/m2/yr') @@ -1731,19 +1731,19 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & filter(i) = .true. else filter(i) = .false. - end if + END if else filter(i) = .false. - end if - end do - end if - end if + END if + END do + END if + END if IF (HistForm == 'Gridded') THEN - call mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) + CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) ENDIF - call write_history_variable_2d ( DEF_hist_vars%fertnitro_swheat, & + CALL write_history_variable_2d ( DEF_hist_vars%fertnitro_swheat, & a_fertnitro_swheat, file_hist, 'f_fertnitro_swheat', & itime_in_file, sumarea, filter,'nitrogen fertilizer for spring wheat','gN/m2/yr') @@ -1755,19 +1755,19 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & filter(i) = .true. else filter(i) = .false. - end if + END if else filter(i) = .false. - end if - end do - end if - end if + END if + END do + END if + END if IF (HistForm == 'Gridded') THEN - call mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) + CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) ENDIF - call write_history_variable_2d ( DEF_hist_vars%fertnitro_wwheat, & + CALL write_history_variable_2d ( DEF_hist_vars%fertnitro_wwheat, & a_fertnitro_wwheat, file_hist, 'f_fertnitro_wwheat', & itime_in_file, sumarea, filter,'nitrogen fertilizer for winter wheat','gN/m2/yr') @@ -1780,19 +1780,19 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & filter(i) = .true. else filter(i) = .false. - end if + END if else filter(i) = .false. - end if - end do - end if - end if + END if + END do + END if + END if IF (HistForm == 'Gridded') THEN - call mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) + CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) ENDIF - call write_history_variable_2d ( DEF_hist_vars%fertnitro_soybean, & + CALL write_history_variable_2d ( DEF_hist_vars%fertnitro_soybean, & a_fertnitro_soybean, file_hist, 'f_fertnitro_soybean', & itime_in_file, sumarea, filter,'nitrogen fertilizer for soybean','gN/m2/yr') @@ -1804,19 +1804,19 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & filter(i) = .true. else filter(i) = .false. - end if + END if else filter(i) = .false. - end if - end do - end if - end if + END if + END do + END if + END if IF (HistForm == 'Gridded') THEN - call mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) + CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) ENDIF - call write_history_variable_2d ( DEF_hist_vars%fertnitro_cotton, & + CALL write_history_variable_2d ( DEF_hist_vars%fertnitro_cotton, & a_fertnitro_cotton, file_hist, 'f_fertnitro_cotton', & itime_in_file, sumarea, filter,'nitrogen fertilizer for cotton','gN/m2/yr') @@ -1828,19 +1828,19 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & filter(i) = .true. else filter(i) = .false. - end if + END if else filter(i) = .false. - end if - end do - end if - end if + END if + END do + END if + END if IF (HistForm == 'Gridded') THEN - call mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) + CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) ENDIF - call write_history_variable_2d ( DEF_hist_vars%fertnitro_rice1, & + CALL write_history_variable_2d ( DEF_hist_vars%fertnitro_rice1, & a_fertnitro_rice1, file_hist, 'f_fertnitro_rice1', & itime_in_file, sumarea, filter,'nitrogen fertilizer for rice1','gN/m2/yr') @@ -1852,19 +1852,19 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & filter(i) = .true. else filter(i) = .false. - end if + END if else filter(i) = .false. - end if - end do - end if - end if + END if + END do + END if + END if IF (HistForm == 'Gridded') THEN - call mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) + CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) ENDIF - call write_history_variable_2d ( DEF_hist_vars%fertnitro_rice2, & + CALL write_history_variable_2d ( DEF_hist_vars%fertnitro_rice2, & a_fertnitro_rice2, file_hist, 'f_fertnitro_rice2', & itime_in_file, sumarea, filter,'nitrogen fertilizer for rice2','gN/m2/yr') @@ -1876,19 +1876,19 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & filter(i) = .true. else filter(i) = .false. - end if + END if else filter(i) = .false. - end if - end do - end if - end if + END if + END do + END if + END if IF (HistForm == 'Gridded') THEN - call mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) + CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) ENDIF - call write_history_variable_2d ( DEF_hist_vars%fertnitro_sugarcane, & + CALL write_history_variable_2d ( DEF_hist_vars%fertnitro_sugarcane, & a_fertnitro_sugarcane, file_hist, 'f_fertnitro_sugarcane', & itime_in_file, sumarea, filter,'nitrogen fertilizer for sugarcane','gN/m2/yr') @@ -1901,19 +1901,19 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & filter(i) = .true. else filter(i) = .false. - end if + END if else filter(i) = .false. - end if - end do - end if - end if + END if + END do + END if + END if IF (HistForm == 'Gridded') THEN - call mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) + CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) ENDIF - call write_history_variable_2d ( DEF_hist_vars%irrig_method_corn, & + CALL write_history_variable_2d ( DEF_hist_vars%irrig_method_corn, & a_irrig_method_corn, file_hist, 'f_irrig_method_corn', & itime_in_file, sumarea, filter,'irrigation method for corn','-') @@ -1925,19 +1925,19 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & filter(i) = .true. else filter(i) = .false. - end if + END if else filter(i) = .false. - end if - end do - end if - end if + END if + END do + END if + END if IF (HistForm == 'Gridded') THEN - call mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) + CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) ENDIF - call write_history_variable_2d ( DEF_hist_vars%irrig_method_swheat, & + CALL write_history_variable_2d ( DEF_hist_vars%irrig_method_swheat, & a_irrig_method_swheat, file_hist, 'f_irrig_method_swheat', & itime_in_file, sumarea, filter,'irrigation method for spring wheat','-') @@ -1949,19 +1949,19 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & filter(i) = .true. else filter(i) = .false. - end if + END if else filter(i) = .false. - end if - end do - end if - end if + END if + END do + END if + END if IF (HistForm == 'Gridded') THEN - call mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) + CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) ENDIF - call write_history_variable_2d ( DEF_hist_vars%irrig_method_wwheat, & + CALL write_history_variable_2d ( DEF_hist_vars%irrig_method_wwheat, & a_irrig_method_wwheat, file_hist, 'f_irrig_method_wwheat', & itime_in_file, sumarea, filter,'irrigation method for winter wheat','-') @@ -1974,19 +1974,19 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & filter(i) = .true. else filter(i) = .false. - end if + END if else filter(i) = .false. - end if - end do - end if - end if + END if + END do + END if + END if IF (HistForm == 'Gridded') THEN - call mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) + CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) ENDIF - call write_history_variable_2d ( DEF_hist_vars%irrig_method_soybean, & + CALL write_history_variable_2d ( DEF_hist_vars%irrig_method_soybean, & a_irrig_method_soybean, file_hist, 'f_irrig_method_soybean', & itime_in_file, sumarea, filter,'irrigation method for soybean','-') @@ -1998,19 +1998,19 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & filter(i) = .true. else filter(i) = .false. - end if + END if else filter(i) = .false. - end if - end do - end if - end if + END if + END do + END if + END if IF (HistForm == 'Gridded') THEN - call mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) + CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) ENDIF - call write_history_variable_2d ( DEF_hist_vars%irrig_method_cotton, & + CALL write_history_variable_2d ( DEF_hist_vars%irrig_method_cotton, & a_irrig_method_cotton, file_hist, 'f_irrig_method_cotton', & itime_in_file, sumarea, filter,'irrigation method for cotton','-') @@ -2022,19 +2022,19 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & filter(i) = .true. else filter(i) = .false. - end if + END if else filter(i) = .false. - end if - end do - end if - end if + END if + END do + END if + END if IF (HistForm == 'Gridded') THEN - call mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) + CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) ENDIF - call write_history_variable_2d ( DEF_hist_vars%irrig_method_rice1, & + CALL write_history_variable_2d ( DEF_hist_vars%irrig_method_rice1, & a_irrig_method_rice1, file_hist, 'f_irrig_method_rice1', & itime_in_file, sumarea, filter,'irrigation method for rice1','-') @@ -2046,19 +2046,19 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & filter(i) = .true. else filter(i) = .false. - end if + END if else filter(i) = .false. - end if - end do - end if - end if + END if + END do + END if + END if IF (HistForm == 'Gridded') THEN - call mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) + CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) ENDIF - call write_history_variable_2d ( DEF_hist_vars%irrig_method_rice2, & + CALL write_history_variable_2d ( DEF_hist_vars%irrig_method_rice2, & a_irrig_method_rice2, file_hist, 'f_irrig_method_rice2', & itime_in_file, sumarea, filter,'irrigation method for rice2','-') @@ -2070,23 +2070,23 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & filter(i) = .true. else filter(i) = .false. - end if + END if else filter(i) = .false. - end if - end do - end if - end if + END if + END do + END if + END if IF (HistForm == 'Gridded') THEN - call mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) + CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) ENDIF - call write_history_variable_2d ( DEF_hist_vars%irrig_method_sugarcane, & + CALL write_history_variable_2d ( DEF_hist_vars%irrig_method_sugarcane, & a_irrig_method_sugarcane, file_hist, 'f_irrig_method_sugarcane', & itime_in_file, sumarea, filter,'irrigation method for sugarcane','-') - end if + END if if (p_is_worker) then if (numpatch > 0) then @@ -2096,25 +2096,25 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & filter(i) = .true. else filter(i) = .false. - end if + END if else filter(i) = .false. - end if - end do - end if - end if + END if + END do + END if + END if IF (HistForm == 'Gridded') THEN - call mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) + CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) ENDIF ! planting date of rainfed temperate corn if (p_is_worker) then if (numpatch > 0) then vecacc (:) = a_plantdate (:) - end if - end if - call write_history_variable_2d ( DEF_hist_vars%plantdate_rainfed_temp_corn, & + END if + END if + CALL write_history_variable_2d ( DEF_hist_vars%plantdate_rainfed_temp_corn, & vecacc, file_hist, 'f_plantdate_rainfed_temp_corn', itime_in_file, sumarea, filter, & 'Crop planting date (rainfed temperate corn)','day') @@ -2126,25 +2126,25 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & filter(i) = .true. else filter(i) = .false. - end if + END if else filter(i) = .false. - end if - end do - end if - end if + END if + END do + END if + END if IF (HistForm == 'Gridded') THEN - call mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) + CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) ENDIF ! planting date of irrigated temperate corn if (p_is_worker) then if (numpatch > 0) then vecacc (:) = a_plantdate (:) - end if - end if - call write_history_variable_2d ( DEF_hist_vars%plantdate_irrigated_temp_corn, & + END if + END if + CALL write_history_variable_2d ( DEF_hist_vars%plantdate_irrigated_temp_corn, & vecacc, file_hist, 'f_plantdate_irrigated_temp_corn', itime_in_file, sumarea, filter, & 'Crop planting date (irrigated temperate corn)','day') @@ -2156,26 +2156,26 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & filter(i) = .true. else filter(i) = .false. - end if + END if else filter(i) = .false. - end if - end do - end if - end if + END if + END do + END if + END if IF (HistForm == 'Gridded') THEN - call mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) + CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) ENDIF ! planting date of rainfed spring wheat if (p_is_worker) then if (numpatch > 0) then vecacc (:) = a_plantdate (:) - end if - end if - call write_history_variable_2d ( DEF_hist_vars%plantdate_rainfed_spwheat, & + END if + END if + CALL write_history_variable_2d ( DEF_hist_vars%plantdate_rainfed_spwheat, & vecacc, file_hist, 'f_plantdate_rainfed_spwheat', itime_in_file, sumarea, filter, & 'Crop planting date (rainfed spring wheat)','day') @@ -2187,26 +2187,26 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & filter(i) = .true. else filter(i) = .false. - end if + END if else filter(i) = .false. - end if - end do - end if - end if + END if + END do + END if + END if IF (HistForm == 'Gridded') THEN - call mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) + CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) ENDIF ! planting date of irrigated spring wheat if (p_is_worker) then if (numpatch > 0) then vecacc (:) = a_plantdate (:) - end if - end if - call write_history_variable_2d ( DEF_hist_vars%plantdate_irrigated_spwheat, & + END if + END if + CALL write_history_variable_2d ( DEF_hist_vars%plantdate_irrigated_spwheat, & vecacc, file_hist, 'f_plantdate_irrigated_spwheat', itime_in_file, sumarea, filter, & 'Crop planting date (irrigated spring wheat)','day') @@ -2218,25 +2218,25 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & filter(i) = .true. else filter(i) = .false. - end if + END if else filter(i) = .false. - end if - end do - end if - end if + END if + END do + END if + END if IF (HistForm == 'Gridded') THEN - call mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) + CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) ENDIF ! planting date of rainfed winter wheat if (p_is_worker) then if (numpatch > 0) then vecacc (:) = a_plantdate (:) - end if - end if - call write_history_variable_2d ( DEF_hist_vars%plantdate_rainfed_wtwheat, & + END if + END if + CALL write_history_variable_2d ( DEF_hist_vars%plantdate_rainfed_wtwheat, & vecacc, file_hist, 'f_plantdate_rainfed_wtwheat', itime_in_file, sumarea, filter, & 'Crop planting date (rainfed winter wheat)','day') @@ -2248,25 +2248,25 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & filter(i) = .true. else filter(i) = .false. - end if + END if else filter(i) = .false. - end if - end do - end if - end if + END if + END do + END if + END if IF (HistForm == 'Gridded') THEN - call mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) + CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) ENDIF ! planting date of irrigated winter wheat if (p_is_worker) then if (numpatch > 0) then vecacc (:) = a_plantdate (:) - end if - end if - call write_history_variable_2d ( DEF_hist_vars%plantdate_irrigated_wtwheat, & + END if + END if + CALL write_history_variable_2d ( DEF_hist_vars%plantdate_irrigated_wtwheat, & vecacc, file_hist, 'f_plantdate_irrigated_wtwheat', itime_in_file, sumarea, filter, & 'Crop planting date (irrigated winter wheat)','day') @@ -2278,25 +2278,25 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & filter(i) = .true. else filter(i) = .false. - end if + END if else filter(i) = .false. - end if - end do - end if - end if + END if + END do + END if + END if IF (HistForm == 'Gridded') THEN - call mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) + CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) ENDIF ! planting date of rainfed temperate soybean if (p_is_worker) then if (numpatch > 0) then vecacc (:) = a_plantdate (:) - end if - end if - call write_history_variable_2d ( DEF_hist_vars%plantdate_rainfed_temp_soybean, & + END if + END if + CALL write_history_variable_2d ( DEF_hist_vars%plantdate_rainfed_temp_soybean, & vecacc, file_hist, 'f_plantdate_rainfed_temp_soybean', itime_in_file, sumarea, filter, & 'Crop planting date (rainfed temperate soybean)','day') @@ -2308,25 +2308,25 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & filter(i) = .true. else filter(i) = .false. - end if + END if else filter(i) = .false. - end if - end do - end if - end if + END if + END do + END if + END if IF (HistForm == 'Gridded') THEN - call mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) + CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) ENDIF ! planting date of irrigated temperate soybean if (p_is_worker) then if (numpatch > 0) then vecacc (:) = a_plantdate (:) - end if - end if - call write_history_variable_2d ( DEF_hist_vars%plantdate_irrigated_temp_soybean, & + END if + END if + CALL write_history_variable_2d ( DEF_hist_vars%plantdate_irrigated_temp_soybean, & vecacc, file_hist, 'f_plantdate_irrigated_temp_soybean', itime_in_file, sumarea, filter, & 'Crop planting date (irrigated temperate soybean)','day') @@ -2338,25 +2338,25 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & filter(i) = .true. else filter(i) = .false. - end if + END if else filter(i) = .false. - end if - end do - end if - end if + END if + END do + END if + END if IF (HistForm == 'Gridded') THEN - call mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) + CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) ENDIF ! planting date of rainfed cotton if (p_is_worker) then if (numpatch > 0) then vecacc (:) = a_plantdate (:) - end if - end if - call write_history_variable_2d ( DEF_hist_vars%plantdate_rainfed_cotton, & + END if + END if + CALL write_history_variable_2d ( DEF_hist_vars%plantdate_rainfed_cotton, & vecacc, file_hist, 'f_plantdate_rainfed_cotton', itime_in_file, sumarea, filter, & 'Crop planting date (rainfed cotton)','day') @@ -2368,25 +2368,25 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & filter(i) = .true. else filter(i) = .false. - end if + END if else filter(i) = .false. - end if - end do - end if - end if + END if + END do + END if + END if IF (HistForm == 'Gridded') THEN - call mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) + CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) ENDIF ! planting date of irrigated cotton if (p_is_worker) then if (numpatch > 0) then vecacc (:) = a_plantdate (:) - end if - end if - call write_history_variable_2d ( DEF_hist_vars%plantdate_irrigated_cotton, & + END if + END if + CALL write_history_variable_2d ( DEF_hist_vars%plantdate_irrigated_cotton, & vecacc, file_hist, 'f_plantdate_irrigated_cotton', itime_in_file, sumarea, filter, & 'Crop planting date (irrigated cotton)','day') @@ -2398,25 +2398,25 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & filter(i) = .true. else filter(i) = .false. - end if + END if else filter(i) = .false. - end if - end do - end if - end if + END if + END do + END if + END if IF (HistForm == 'Gridded') THEN - call mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) + CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) ENDIF ! planting date of rainfed rice if (p_is_worker) then if (numpatch > 0) then vecacc (:) = a_plantdate (:) - end if - end if - call write_history_variable_2d ( DEF_hist_vars%plantdate_rainfed_rice, & + END if + END if + CALL write_history_variable_2d ( DEF_hist_vars%plantdate_rainfed_rice, & vecacc, file_hist, 'f_plantdate_rainfed_rice', itime_in_file, sumarea, filter, & 'Crop planting date (rainfed rice)','day') @@ -2428,25 +2428,25 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & filter(i) = .true. else filter(i) = .false. - end if + END if else filter(i) = .false. - end if - end do - end if - end if + END if + END do + END if + END if IF (HistForm == 'Gridded') THEN - call mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) + CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) ENDIF ! planting date of irrigated rice if (p_is_worker) then if (numpatch > 0) then vecacc (:) = a_plantdate (:) - end if - end if - call write_history_variable_2d ( DEF_hist_vars%plantdate_irrigated_rice, & + END if + END if + CALL write_history_variable_2d ( DEF_hist_vars%plantdate_irrigated_rice, & vecacc, file_hist, 'f_plantdate_irrigated_rice', itime_in_file, sumarea, filter, & 'Crop planting date (irrigated rice)','day') @@ -2458,25 +2458,25 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & filter(i) = .true. else filter(i) = .false. - end if + END if else filter(i) = .false. - end if - end do - end if - end if + END if + END do + END if + END if IF (HistForm == 'Gridded') THEN - call mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) + CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) ENDIF ! planting date of rainfed sugarcane if (p_is_worker) then if (numpatch > 0) then vecacc (:) = a_plantdate (:) - end if - end if - call write_history_variable_2d ( DEF_hist_vars%plantdate_rainfed_sugarcane, & + END if + END if + CALL write_history_variable_2d ( DEF_hist_vars%plantdate_rainfed_sugarcane, & vecacc, file_hist, 'f_plantdate_rainfed_sugarcane', itime_in_file, sumarea, filter, & 'Crop planting date (rainfed sugarcane)','day') @@ -2488,25 +2488,25 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & filter(i) = .true. else filter(i) = .false. - end if + END if else filter(i) = .false. - end if - end do - end if - end if + END if + END do + END if + END if IF (HistForm == 'Gridded') THEN - call mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) + CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) ENDIF ! planting date of irrigated sugarcane if (p_is_worker) then if (numpatch > 0) then vecacc (:) = a_plantdate (:) - end if - end if - call write_history_variable_2d ( DEF_hist_vars%plantdate_irrigated_sugarcane, & + END if + END if + CALL write_history_variable_2d ( DEF_hist_vars%plantdate_irrigated_sugarcane, & vecacc, file_hist, 'f_plantdate_irrigated_sugarcane', itime_in_file, sumarea, filter, & 'Crop planting date (irrigated sugarcane)','day') @@ -2518,25 +2518,25 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & filter(i) = .true. else filter(i) = .false. - end if + END if else filter(i) = .false. - end if - end do - end if - end if + END if + END do + END if + END if IF (HistForm == 'Gridded') THEN - call mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) + CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) ENDIF ! planting date of rainfed trop corn if (p_is_worker) then if (numpatch > 0) then vecacc (:) = a_plantdate (:) - end if - end if - call write_history_variable_2d ( DEF_hist_vars%plantdate_rainfed_trop_corn, & + END if + END if + CALL write_history_variable_2d ( DEF_hist_vars%plantdate_rainfed_trop_corn, & vecacc, file_hist, 'f_plantdate_rainfed_trop_corn', itime_in_file, sumarea, filter, & 'Crop planting date (rainfed trop corn)','day') @@ -2548,25 +2548,25 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & filter(i) = .true. else filter(i) = .false. - end if + END if else filter(i) = .false. - end if - end do - end if - end if + END if + END do + END if + END if IF (HistForm == 'Gridded') THEN - call mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) + CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) ENDIF ! planting date of irrigated trop corn if (p_is_worker) then if (numpatch > 0) then vecacc (:) = a_plantdate (:) - end if - end if - call write_history_variable_2d ( DEF_hist_vars%plantdate_irrigated_trop_corn, & + END if + END if + CALL write_history_variable_2d ( DEF_hist_vars%plantdate_irrigated_trop_corn, & vecacc, file_hist, 'f_plantdate_irrigated_trop_corn', itime_in_file, sumarea, filter, & 'Crop planting date (irrigated trop corn)','day') @@ -2578,25 +2578,25 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & filter(i) = .true. else filter(i) = .false. - end if + END if else filter(i) = .false. - end if - end do - end if - end if + END if + END do + END if + END if IF (HistForm == 'Gridded') THEN - call mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) + CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) ENDIF ! planting date of rainfed trop soybean if (p_is_worker) then if (numpatch > 0) then vecacc (:) = a_plantdate (:) - end if - end if - call write_history_variable_2d ( DEF_hist_vars%plantdate_rainfed_trop_soybean, & + END if + END if + CALL write_history_variable_2d ( DEF_hist_vars%plantdate_rainfed_trop_soybean, & vecacc, file_hist, 'f_plantdate_rainfed_trop_soybean', itime_in_file, sumarea, filter, & 'Crop planting date (rainfed trop soybean)','day') @@ -2608,25 +2608,25 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & filter(i) = .true. else filter(i) = .false. - end if + END if else filter(i) = .false. - end if - end do - end if - end if + END if + END do + END if + END if IF (HistForm == 'Gridded') THEN - call mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) + CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) ENDIF ! planting date of irrigated trop soybean if (p_is_worker) then if (numpatch > 0) then vecacc (:) = a_plantdate (:) - end if - end if - call write_history_variable_2d ( DEF_hist_vars%plantdate_irrigated_trop_soybean, & + END if + END if + CALL write_history_variable_2d ( DEF_hist_vars%plantdate_irrigated_trop_soybean, & vecacc, file_hist, 'f_plantdate_irrigated_trop_soybean', itime_in_file, sumarea, filter, & 'Crop planting date (irrigated trop soybean)','day') @@ -2638,26 +2638,26 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & filter(i) = .true. else filter(i) = .false. - end if + END if else filter(i) = .false. - end if - end do - end if - end if + END if + END do + END if + END if IF (HistForm == 'Gridded') THEN - call mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) + CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) ENDIF ! planting date of unmanaged crop production if (p_is_worker) then if (numpatch > 0) then vecacc (:) = a_plantdate (:) - end if - end if - call write_history_variable_2d ( DEF_hist_vars%plantdate_unmanagedcrop, & + END if + END if + CALL write_history_variable_2d ( DEF_hist_vars%plantdate_unmanagedcrop, & vecacc, file_hist, 'f_plantdate_unmanagedcrop', itime_in_file, sumarea, filter, & 'Crop planting date (unmanaged crop production)','day') @@ -2669,25 +2669,25 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & filter(i) = .true. else filter(i) = .false. - end if + END if else filter(i) = .false. - end if - end do - end if - end if + END if + END do + END if + END if IF (HistForm == 'Gridded') THEN - call mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) + CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) ENDIF ! grain to corn production carbon if (p_is_worker) then if (numpatch > 0) then vecacc (:) = a_grainc_to_cropprodc (:) - end if - end if - call write_history_variable_2d ( DEF_hist_vars%cropprodc_rainfed_temp_corn, & + END if + END if + CALL write_history_variable_2d ( DEF_hist_vars%cropprodc_rainfed_temp_corn, & vecacc, file_hist, 'f_cropprodc_rainfed_temp_corn', itime_in_file, sumarea, filter, & 'Crop production (rainfed temperate corn)','gC/m2/s') @@ -2699,25 +2699,25 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & filter(i) = .true. else filter(i) = .false. - end if + END if else filter(i) = .false. - end if - end do - end if - end if + END if + END do + END if + END if IF (HistForm == 'Gridded') THEN - call mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) + CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) ENDIF ! grain to corn production carbon if (p_is_worker) then if (numpatch > 0) then vecacc (:) = a_grainc_to_cropprodc (:) - end if - end if - call write_history_variable_2d ( DEF_hist_vars%cropprodc_irrigated_temp_corn, & + END if + END if + CALL write_history_variable_2d ( DEF_hist_vars%cropprodc_irrigated_temp_corn, & vecacc, file_hist, 'f_cropprodc_irrigated_temp_corn', itime_in_file, sumarea, filter, & 'Crop production (irrigated temperate corn)','gC/m2/s') @@ -2729,25 +2729,25 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & filter(i) = .true. else filter(i) = .false. - end if + END if else filter(i) = .false. - end if - end do - end if - end if + END if + END do + END if + END if IF (HistForm == 'Gridded') THEN - call mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) + CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) ENDIF ! grain to spring wheat production carbon if (p_is_worker) then if (numpatch > 0) then vecacc (:) = a_grainc_to_cropprodc (:) - end if - end if - call write_history_variable_2d ( DEF_hist_vars%cropprodc_rainfed_spwheat, & + END if + END if + CALL write_history_variable_2d ( DEF_hist_vars%cropprodc_rainfed_spwheat, & vecacc, file_hist, 'f_cropprodc_rainfed_spwheat', itime_in_file, sumarea, filter, & 'Crop production (rainfed spring wheat)','gC/m2/s') @@ -2759,25 +2759,25 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & filter(i) = .true. else filter(i) = .false. - end if + END if else filter(i) = .false. - end if - end do - end if - end if + END if + END do + END if + END if IF (HistForm == 'Gridded') THEN - call mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) + CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) ENDIF ! grain to spring wheat production carbon if (p_is_worker) then if (numpatch > 0) then vecacc (:) = a_grainc_to_cropprodc (:) - end if - end if - call write_history_variable_2d ( DEF_hist_vars%cropprodc_irrigated_spwheat, & + END if + END if + CALL write_history_variable_2d ( DEF_hist_vars%cropprodc_irrigated_spwheat, & vecacc, file_hist, 'f_cropprodc_irrigated_spwheat', itime_in_file, sumarea, filter, & 'Crop production (irrigated spring wheat)','gC/m2/s') @@ -2789,25 +2789,25 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & filter(i) = .true. else filter(i) = .false. - end if + END if else filter(i) = .false. - end if - end do - end if - end if + END if + END do + END if + END if IF (HistForm == 'Gridded') THEN - call mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) + CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) ENDIF ! grain to winter wheat production carbon if (p_is_worker) then if (numpatch > 0) then vecacc (:) = a_grainc_to_cropprodc (:) - end if - end if - call write_history_variable_2d ( DEF_hist_vars%cropprodc_rainfed_wtwheat, & + END if + END if + CALL write_history_variable_2d ( DEF_hist_vars%cropprodc_rainfed_wtwheat, & vecacc, file_hist, 'f_cropprodc_rainfed_wtwheat', itime_in_file, sumarea, filter, & 'Crop production (rainfed winter wheat)','gC/m2/s') @@ -2819,25 +2819,25 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & filter(i) = .true. else filter(i) = .false. - end if + END if else filter(i) = .false. - end if - end do - end if - end if + END if + END do + END if + END if IF (HistForm == 'Gridded') THEN - call mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) + CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) ENDIF ! grain to winter wheat production carbon if (p_is_worker) then if (numpatch > 0) then vecacc (:) = a_grainc_to_cropprodc (:) - end if - end if - call write_history_variable_2d ( DEF_hist_vars%cropprodc_irrigated_wtwheat, & + END if + END if + CALL write_history_variable_2d ( DEF_hist_vars%cropprodc_irrigated_wtwheat, & vecacc, file_hist, 'f_cropprodc_irrigated_wtwheat', itime_in_file, sumarea, filter, & 'Crop production (irrigated winter wheat)','gC/m2/s') @@ -2849,25 +2849,25 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & filter(i) = .true. else filter(i) = .false. - end if + END if else filter(i) = .false. - end if - end do - end if - end if + END if + END do + END if + END if IF (HistForm == 'Gridded') THEN - call mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) + CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) ENDIF ! grain to soybean production carbon if (p_is_worker) then if (numpatch > 0) then vecacc (:) = a_grainc_to_cropprodc (:) - end if - end if - call write_history_variable_2d ( DEF_hist_vars%cropprodc_rainfed_temp_soybean, & + END if + END if + CALL write_history_variable_2d ( DEF_hist_vars%cropprodc_rainfed_temp_soybean, & vecacc, file_hist, 'f_cropprodc_rainfed_temp_soybean', itime_in_file, sumarea, filter, & 'Crop production (rainfed temperate soybean)','gC/m2/s') @@ -2879,25 +2879,25 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & filter(i) = .true. else filter(i) = .false. - end if + END if else filter(i) = .false. - end if - end do - end if - end if + END if + END do + END if + END if IF (HistForm == 'Gridded') THEN - call mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) + CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) ENDIF ! grain to soybean production carbon if (p_is_worker) then if (numpatch > 0) then vecacc (:) = a_grainc_to_cropprodc (:) - end if - end if - call write_history_variable_2d ( DEF_hist_vars%cropprodc_irrigated_temp_soybean, & + END if + END if + CALL write_history_variable_2d ( DEF_hist_vars%cropprodc_irrigated_temp_soybean, & vecacc, file_hist, 'f_cropprodc_irrigated_temp_soybean', itime_in_file, sumarea, filter, & 'Crop production (irrigated temperate soybean)','gC/m2/s') @@ -2909,25 +2909,25 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & filter(i) = .true. else filter(i) = .false. - end if + END if else filter(i) = .false. - end if - end do - end if - end if + END if + END do + END if + END if IF (HistForm == 'Gridded') THEN - call mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) + CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) ENDIF ! grain to cotton production carbon if (p_is_worker) then if (numpatch > 0) then vecacc (:) = a_grainc_to_cropprodc (:) - end if - end if - call write_history_variable_2d ( DEF_hist_vars%cropprodc_rainfed_cotton, & + END if + END if + CALL write_history_variable_2d ( DEF_hist_vars%cropprodc_rainfed_cotton, & vecacc, file_hist, 'f_cropprodc_rainfed_cotton', itime_in_file, sumarea, filter, & 'Crop production (rainfed cotton)','gC/m2/s') @@ -2939,25 +2939,25 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & filter(i) = .true. else filter(i) = .false. - end if + END if else filter(i) = .false. - end if - end do - end if - end if + END if + END do + END if + END if IF (HistForm == 'Gridded') THEN - call mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) + CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) ENDIF ! grain to cotton production carbon if (p_is_worker) then if (numpatch > 0) then vecacc (:) = a_grainc_to_cropprodc (:) - end if - end if - call write_history_variable_2d ( DEF_hist_vars%cropprodc_irrigated_cotton, & + END if + END if + CALL write_history_variable_2d ( DEF_hist_vars%cropprodc_irrigated_cotton, & vecacc, file_hist, 'f_cropprodc_irrigated_cotton', itime_in_file, sumarea, filter, & 'Crop production (irrigated cotton)','gC/m2/s') @@ -2969,25 +2969,25 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & filter(i) = .true. else filter(i) = .false. - end if + END if else filter(i) = .false. - end if - end do - end if - end if + END if + END do + END if + END if IF (HistForm == 'Gridded') THEN - call mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) + CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) ENDIF ! grain to rice production carbon if (p_is_worker) then if (numpatch > 0) then vecacc (:) = a_grainc_to_cropprodc (:) - end if - end if - call write_history_variable_2d ( DEF_hist_vars%cropprodc_rainfed_rice, & + END if + END if + CALL write_history_variable_2d ( DEF_hist_vars%cropprodc_rainfed_rice, & vecacc, file_hist, 'f_cropprodc_rainfed_rice', itime_in_file, sumarea, filter, & 'Crop production (rainfed rice)','gC/m2/s') @@ -2999,25 +2999,25 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & filter(i) = .true. else filter(i) = .false. - end if + END if else filter(i) = .false. - end if - end do - end if - end if + END if + END do + END if + END if IF (HistForm == 'Gridded') THEN - call mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) + CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) ENDIF ! grain to rice production carbon if (p_is_worker) then if (numpatch > 0) then vecacc (:) = a_grainc_to_cropprodc (:) - end if - end if - call write_history_variable_2d ( DEF_hist_vars%cropprodc_irrigated_rice, & + END if + END if + CALL write_history_variable_2d ( DEF_hist_vars%cropprodc_irrigated_rice, & vecacc, file_hist, 'f_cropprodc_irrigated_rice', itime_in_file, sumarea, filter, & 'Crop production (irrigated rice)','gC/m2/s') @@ -3029,25 +3029,25 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & filter(i) = .true. else filter(i) = .false. - end if + END if else filter(i) = .false. - end if - end do - end if - end if + END if + END do + END if + END if IF (HistForm == 'Gridded') THEN - call mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) + CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) ENDIF ! grain to sugarcane production carbon if (p_is_worker) then if (numpatch > 0) then vecacc (:) = a_grainc_to_cropprodc (:) - end if - end if - call write_history_variable_2d ( DEF_hist_vars%cropprodc_rainfed_sugarcane, & + END if + END if + CALL write_history_variable_2d ( DEF_hist_vars%cropprodc_rainfed_sugarcane, & vecacc, file_hist, 'f_cropprodc_rainfed_sugarcane', itime_in_file, sumarea, filter, & 'Crop production (rainfed sugarcane)','gC/m2/s') @@ -3059,25 +3059,25 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & filter(i) = .true. else filter(i) = .false. - end if + END if else filter(i) = .false. - end if - end do - end if - end if + END if + END do + END if + END if IF (HistForm == 'Gridded') THEN - call mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) + CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) ENDIF ! grain to sugarcane production carbon if (p_is_worker) then if (numpatch > 0) then vecacc (:) = a_grainc_to_cropprodc (:) - end if - end if - call write_history_variable_2d ( DEF_hist_vars%cropprodc_irrigated_sugarcane, & + END if + END if + CALL write_history_variable_2d ( DEF_hist_vars%cropprodc_irrigated_sugarcane, & vecacc, file_hist, 'f_cropprodc_irrigated_sugarcane', itime_in_file, sumarea, filter, & 'Crop production (irrigated sugarcane)','gC/m2/s') @@ -3089,25 +3089,25 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & filter(i) = .true. else filter(i) = .false. - end if + END if else filter(i) = .false. - end if - end do - end if - end if + END if + END do + END if + END if IF (HistForm == 'Gridded') THEN - call mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) + CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) ENDIF ! grain to sugarcane production carbon if (p_is_worker) then if (numpatch > 0) then vecacc (:) = a_grainc_to_cropprodc (:) - end if - end if - call write_history_variable_2d ( DEF_hist_vars%cropprodc_rainfed_trop_corn, & + END if + END if + CALL write_history_variable_2d ( DEF_hist_vars%cropprodc_rainfed_trop_corn, & vecacc, file_hist, 'f_cropprodc_rainfed_trop_corn', itime_in_file, sumarea, filter, & 'Crop production (rainfed_trop_corn)','gC/m2/s') @@ -3119,25 +3119,25 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & filter(i) = .true. else filter(i) = .false. - end if + END if else filter(i) = .false. - end if - end do - end if - end if + END if + END do + END if + END if IF (HistForm == 'Gridded') THEN - call mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) + CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) ENDIF ! grain to sugarcane production carbon if (p_is_worker) then if (numpatch > 0) then vecacc (:) = a_grainc_to_cropprodc (:) - end if - end if - call write_history_variable_2d ( DEF_hist_vars%cropprodc_irrigated_trop_corn, & + END if + END if + CALL write_history_variable_2d ( DEF_hist_vars%cropprodc_irrigated_trop_corn, & vecacc, file_hist, 'f_cropprodc_irrigated_trop_corn', itime_in_file, sumarea, filter, & 'Crop production (irrigated_trop_corn)','gC/m2/s') @@ -3149,25 +3149,25 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & filter(i) = .true. else filter(i) = .false. - end if + END if else filter(i) = .false. - end if - end do - end if - end if + END if + END do + END if + END if IF (HistForm == 'Gridded') THEN - call mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) + CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) ENDIF ! grain to sugarcane production carbon if (p_is_worker) then if (numpatch > 0) then vecacc (:) = a_grainc_to_cropprodc (:) - end if - end if - call write_history_variable_2d ( DEF_hist_vars%cropprodc_rainfed_trop_soybean, & + END if + END if + CALL write_history_variable_2d ( DEF_hist_vars%cropprodc_rainfed_trop_soybean, & vecacc, file_hist, 'f_cropprodc_rainfed_trop_soybean', itime_in_file, sumarea, filter, & 'Crop production (rainfed trop soybean)','gC/m2/s') @@ -3179,25 +3179,25 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & filter(i) = .true. else filter(i) = .false. - end if + END if else filter(i) = .false. - end if - end do - end if - end if + END if + END do + END if + END if IF (HistForm == 'Gridded') THEN - call mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) + CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) ENDIF ! grain to sugarcane production carbon if (p_is_worker) then if (numpatch > 0) then vecacc (:) = a_grainc_to_cropprodc (:) - end if - end if - call write_history_variable_2d ( DEF_hist_vars%cropprodc_irrigated_trop_soybean, & + END if + END if + CALL write_history_variable_2d ( DEF_hist_vars%cropprodc_irrigated_trop_soybean, & vecacc, file_hist, 'f_cropprodc_irrigated_trop_soybean', itime_in_file, sumarea, filter, & 'Crop production (irrigated trop soybean)','gC/m2/s') @@ -3209,25 +3209,25 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & filter(i) = .true. else filter(i) = .false. - end if + END if else filter(i) = .false. - end if - end do - end if - end if + END if + END do + END if + END if IF (HistForm == 'Gridded') THEN - call mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) + CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) ENDIF ! grain to unmanaged crop production carbon if (p_is_worker) then if (numpatch > 0) then vecacc (:) = a_grainc_to_cropprodc (:) - end if - end if - call write_history_variable_2d ( DEF_hist_vars%cropprodc_unmanagedcrop, & + END if + END if + CALL write_history_variable_2d ( DEF_hist_vars%cropprodc_unmanagedcrop, & vecacc, file_hist, 'f_cropprodc_unmanagedcrop', itime_in_file, sumarea, filter, & 'Crop production (unmanaged crop production)','gC/m2/s') #endif @@ -3248,25 +3248,25 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & ENDIF filter = filter .and. patchmask - end if - end if + END if + END if IF (HistForm == 'Gridded') THEN - call mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) + CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) ENDIF ! soil temperature [K] - call write_history_variable_3d ( DEF_hist_vars%t_soisno, & + CALL write_history_variable_3d ( DEF_hist_vars%t_soisno, & a_t_soisno, file_hist, 'f_t_soisno', itime_in_file, 'soilsnow', maxsnl+1, nl_soil-maxsnl, & sumarea, filter, 'soil temperature','K') ! liquid water in soil layers [kg/m2] - call write_history_variable_3d ( DEF_hist_vars%wliq_soisno, & + CALL write_history_variable_3d ( DEF_hist_vars%wliq_soisno, & a_wliq_soisno, file_hist, 'f_wliq_soisno', itime_in_file, 'soilsnow', maxsnl+1, nl_soil-maxsnl, & sumarea, filter,'liquid water in soil layers','kg/m2') ! ice lens in soil layers [kg/m2] - call write_history_variable_3d ( DEF_hist_vars%wice_soisno, & + CALL write_history_variable_3d ( DEF_hist_vars%wice_soisno, & a_wice_soisno, file_hist, 'f_wice_soisno', itime_in_file, 'soilsnow', maxsnl+1, nl_soil-maxsnl, & sumarea, filter, 'ice lens in soil layers', 'kg/m2') @@ -3286,33 +3286,33 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & ENDIF filter = filter .and. patchmask - end if - end if + END if + END if IF (HistForm == 'Gridded') THEN - call mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) + CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) ENDIF ! volumetric soil water in layers [m3/m3] - call write_history_variable_3d ( DEF_hist_vars%h2osoi, & + CALL write_history_variable_3d ( DEF_hist_vars%h2osoi, & a_h2osoi, file_hist, 'f_h2osoi', itime_in_file, 'soil', 1, nl_soil, sumarea, filter, & 'volumetric water in soil layers','m3/m3') ! fraction of root water uptake from each soil layer, all layers add to 1, when PHS is not defined ! water exchange between soil layers and root. Positive: soil->root [mm h2o/s], when PHS is defined - call write_history_variable_3d ( DEF_hist_vars%rootr, & + CALL write_history_variable_3d ( DEF_hist_vars%rootr, & a_rootr, file_hist, 'f_rootr', itime_in_file, 'soil', 1, nl_soil, sumarea, filter, & 'root water uptake', 'mm h2o/s') if (DEF_USE_PLANTHYDRAULICS) then ! vegetation water potential [mm] - call write_history_variable_3d ( DEF_hist_vars%vegwp, & + CALL write_history_variable_3d ( DEF_hist_vars%vegwp, & a_vegwp, file_hist, 'f_vegwp', itime_in_file, 'vegnodes', 1, nvegwcs, sumarea, filter, & 'vegetation water potential', 'mm') - end if + END if ! water table depth [m] - call write_history_variable_2d ( DEF_hist_vars%zwt, & + CALL write_history_variable_2d ( DEF_hist_vars%zwt, & a_zwt, file_hist, 'f_zwt', itime_in_file, sumarea, filter, & 'the depth to water table','m') @@ -3322,22 +3322,22 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & if (p_is_worker) then if (numpatch > 0) then - filter(:) = (patchtype <= 4) + filter(:) = (patchtype <= 4) IF (DEF_forcing%has_missing_value) THEN filter = filter .and. forcmask ENDIF filter = filter .and. patchmask - end if - end if + END if + END if IF (HistForm == 'Gridded') THEN - call mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) + CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) ENDIF ! water storage in aquifer [mm] - call write_history_variable_2d ( DEF_hist_vars%wa, & + CALL write_history_variable_2d ( DEF_hist_vars%wa, & a_wa, file_hist, 'f_wa', itime_in_file, sumarea, filter, & 'water storage in aquifer','mm') @@ -3346,12 +3346,12 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & vecacc = wa WHERE(vecacc /= spval) vecacc = vecacc * nac ENDIF - call write_history_variable_2d ( DEF_hist_vars%wa_inst, & + CALL write_history_variable_2d ( DEF_hist_vars%wa_inst, & vecacc, file_hist, 'f_wa_inst', itime_in_file, sumarea, filter, & 'instantaneous water storage in aquifer','mm') ! depth of surface water [mm] - call write_history_variable_2d ( DEF_hist_vars%wdsrf, & + CALL write_history_variable_2d ( DEF_hist_vars%wdsrf, & a_wdsrf, file_hist, 'f_wdsrf', itime_in_file, sumarea, filter, & 'depth of surface water','mm') @@ -3360,7 +3360,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & vecacc = wdsrf WHERE(vecacc /= spval) vecacc = vecacc * nac ENDIF - call write_history_variable_2d ( DEF_hist_vars%wdsrf_inst, & + CALL write_history_variable_2d ( DEF_hist_vars%wdsrf_inst, & vecacc, file_hist, 'f_wdsrf_inst', itime_in_file, sumarea, filter, & 'instantaneous depth of surface water','mm') @@ -3374,20 +3374,20 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & IF (DEF_forcing%has_missing_value) THEN filter = filter .and. forcmask ENDIF - end if - end if + END if + END if IF (HistForm == 'Gridded') THEN - call mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) + CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) ENDIF ! lake temperature [K] - call write_history_variable_3d ( DEF_hist_vars%t_lake, & + CALL write_history_variable_3d ( DEF_hist_vars%t_lake, & a_t_lake, file_hist, 'f_t_lake', itime_in_file, 'lake', 1, nl_lake, sumarea, filter, & 'lake temperature','K') ! lake ice fraction cover [0-1] - call write_history_variable_3d ( DEF_hist_vars%lake_icefrac, & + CALL write_history_variable_3d ( DEF_hist_vars%lake_icefrac, & a_lake_icefrac, file_hist, 'f_lake_icefrac', itime_in_file, 'lake', 1, nl_lake, & sumarea, filter, 'lake ice fraction cover','0-1') @@ -3404,115 +3404,115 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & ENDIF filter = filter .and. patchmask - end if - end if + END if + END if IF (HistForm == 'Gridded') THEN - call mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) + CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) ENDIF ! u* in similarity theory [m/s] - call write_history_variable_2d ( DEF_hist_vars%ustar, & + CALL write_history_variable_2d ( DEF_hist_vars%ustar, & a_ustar, file_hist, 'f_ustar', itime_in_file, sumarea, filter, & 'u* in similarity theory based on patch','m/s') ! u* in similarity theory [m/s] - call write_history_variable_2d ( DEF_hist_vars%ustar2, & + CALL write_history_variable_2d ( DEF_hist_vars%ustar2, & a_ustar2, file_hist, 'f_ustar2', itime_in_file, sumarea, filter, & 'u* in similarity theory based on grid','m/s') ! t* in similarity theory [K] - call write_history_variable_2d ( DEF_hist_vars%tstar, & + CALL write_history_variable_2d ( DEF_hist_vars%tstar, & a_tstar, file_hist, 'f_tstar', itime_in_file, sumarea, filter, & 't* in similarity theory','K') ! q* in similarity theory [kg/kg] - call write_history_variable_2d ( DEF_hist_vars%qstar, & + CALL write_history_variable_2d ( DEF_hist_vars%qstar, & a_qstar, file_hist, 'f_qstar', itime_in_file, sumarea, filter, & 'q* in similarity theory', 'kg/kg') ! dimensionless height (z/L) used in Monin-Obukhov theory - call write_history_variable_2d ( DEF_hist_vars%zol, & + CALL write_history_variable_2d ( DEF_hist_vars%zol, & a_zol, file_hist, 'f_zol', itime_in_file, sumarea, filter, & 'dimensionless height (z/L) used in Monin-Obukhov theory','-') ! bulk Richardson number in surface layer - call write_history_variable_2d ( DEF_hist_vars%rib, & + CALL write_history_variable_2d ( DEF_hist_vars%rib, & a_rib, file_hist, 'f_rib', itime_in_file, sumarea, filter, & 'bulk Richardson number in surface layer','-') - ! integral of profile function for momentum - call write_history_variable_2d ( DEF_hist_vars%fm, & + ! integral of profile FUNCTION for momentum + CALL write_history_variable_2d ( DEF_hist_vars%fm, & a_fm, file_hist, 'f_fm', itime_in_file, sumarea, filter, & - 'integral of profile function for momentum','-') + 'integral of profile FUNCTION for momentum','-') - ! integral of profile function for heat - call write_history_variable_2d ( DEF_hist_vars%fh, & + ! integral of profile FUNCTION for heat + CALL write_history_variable_2d ( DEF_hist_vars%fh, & a_fh, file_hist, 'f_fh', itime_in_file, sumarea, filter, & - 'integral of profile function for heat','-') + 'integral of profile FUNCTION for heat','-') - ! integral of profile function for moisture - call write_history_variable_2d ( DEF_hist_vars%fq, & + ! integral of profile FUNCTION for moisture + CALL write_history_variable_2d ( DEF_hist_vars%fq, & a_fq, file_hist, 'f_fq', itime_in_file, sumarea, filter, & - 'integral of profile function for moisture','-') + 'integral of profile FUNCTION for moisture','-') ! 10m u-velocity [m/s] - call write_history_variable_2d ( DEF_hist_vars%us10m, & + CALL write_history_variable_2d ( DEF_hist_vars%us10m, & a_us10m, file_hist, 'f_us10m', itime_in_file, sumarea, filter, & '10m u-velocity','m/s') ! 10m v-velocity [m/s] - call write_history_variable_2d ( DEF_hist_vars%vs10m, & + CALL write_history_variable_2d ( DEF_hist_vars%vs10m, & a_vs10m, file_hist, 'f_vs10m', itime_in_file, sumarea, filter, & '10m v-velocity','m/s') - ! integral of profile function for momentum at 10m [-] - call write_history_variable_2d ( DEF_hist_vars%fm10m, & + ! integral of profile FUNCTION for momentum at 10m [-] + CALL write_history_variable_2d ( DEF_hist_vars%fm10m, & a_fm10m, file_hist, 'f_fm10m', itime_in_file, sumarea, filter, & - 'integral of profile function for momentum at 10m','-') + 'integral of profile FUNCTION for momentum at 10m','-') ! total reflected solar radiation (W/m2) - call write_history_variable_2d ( DEF_hist_vars%sr, & + CALL write_history_variable_2d ( DEF_hist_vars%sr, & a_sr, file_hist, 'f_sr', itime_in_file, sumarea, filter, & 'reflected solar radiation at surface [W/m2]','W/m2') ! incident direct beam vis solar radiation (W/m2) - call write_history_variable_2d ( DEF_hist_vars%solvd, & + CALL write_history_variable_2d ( DEF_hist_vars%solvd, & a_solvd, file_hist, 'f_solvd', itime_in_file, sumarea, filter, & 'incident direct beam vis solar radiation (W/m2)','W/m2') ! incident diffuse beam vis solar radiation (W/m2) - call write_history_variable_2d ( DEF_hist_vars%solvi, & + CALL write_history_variable_2d ( DEF_hist_vars%solvi, & a_solvi, file_hist, 'f_solvi', itime_in_file, sumarea, filter, & 'incident diffuse beam vis solar radiation (W/m2)','W/m2') ! incident direct beam nir solar radiation (W/m2) - call write_history_variable_2d ( DEF_hist_vars%solnd, & + CALL write_history_variable_2d ( DEF_hist_vars%solnd, & a_solnd, file_hist, 'f_solnd', itime_in_file, sumarea, filter, & 'incident direct beam nir solar radiation (W/m2)','W/m2') ! incident diffuse beam nir solar radiation (W/m2) - call write_history_variable_2d ( DEF_hist_vars%solni, & + CALL write_history_variable_2d ( DEF_hist_vars%solni, & a_solni, file_hist, 'f_solni', itime_in_file, sumarea, filter, & 'incident diffuse beam nir solar radiation (W/m2)','W/m2') ! reflected direct beam vis solar radiation (W/m2) - call write_history_variable_2d ( DEF_hist_vars%srvd, & + CALL write_history_variable_2d ( DEF_hist_vars%srvd, & a_srvd, file_hist, 'f_srvd', itime_in_file, sumarea, filter, & 'reflected direct beam vis solar radiation (W/m2)','W/m2') ! reflected diffuse beam vis solar radiation (W/m2) - call write_history_variable_2d ( DEF_hist_vars%srvi, & + CALL write_history_variable_2d ( DEF_hist_vars%srvi, & a_srvi, file_hist, 'f_srvi', itime_in_file, sumarea, filter, & 'reflected diffuse beam vis solar radiation (W/m2)','W/m2') ! reflected direct beam nir solar radiation (W/m2) - call write_history_variable_2d ( DEF_hist_vars%srnd, & + CALL write_history_variable_2d ( DEF_hist_vars%srnd, & a_srnd, file_hist, 'f_srnd', itime_in_file, sumarea, filter, & 'reflected direct beam nir solar radiation (W/m2)','W/m2') ! reflected diffuse beam nir solar radiation (W/m2) - call write_history_variable_2d ( DEF_hist_vars%srni, & + CALL write_history_variable_2d ( DEF_hist_vars%srni, & a_srni, file_hist, 'f_srni', itime_in_file, sumarea, filter, & 'reflected diffuse beam nir solar radiation (W/m2)','W/m2') @@ -3523,50 +3523,50 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & IF (DEF_forcing%has_missing_value) THEN filter = filter .and. forcmask ENDIF - end if - end if + END if + END if IF (HistForm == 'Gridded') THEN - call mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) + CALL mp2g_hist%map (VecOnes, sumarea, spv = spval, msk = filter) ENDIF ! incident direct beam vis solar radiation at local noon (W/m2) - call write_history_variable_ln ( DEF_hist_vars%solvdln, & + CALL write_history_variable_ln ( DEF_hist_vars%solvdln, & a_solvdln, file_hist, 'f_solvdln', itime_in_file, sumarea, filter, & 'incident direct beam vis solar radiation at local noon(W/m2)','W/m2') ! incident diffuse beam vis solar radiation at local noon (W/m2) - call write_history_variable_ln ( DEF_hist_vars%solviln, & + CALL write_history_variable_ln ( DEF_hist_vars%solviln, & a_solviln, file_hist, 'f_solviln', itime_in_file, sumarea, filter, & 'incident diffuse beam vis solar radiation at local noon(W/m2)','W/m2') ! incident direct beam nir solar radiation at local noon (W/m2) - call write_history_variable_ln ( DEF_hist_vars%solndln, & + CALL write_history_variable_ln ( DEF_hist_vars%solndln, & a_solndln, file_hist, 'f_solndln', itime_in_file, sumarea, filter, & 'incident direct beam nir solar radiation at local noon(W/m2)','W/m2') ! incident diffuse beam nir solar radiation at local noon (W/m2) - call write_history_variable_ln ( DEF_hist_vars%solniln, & + CALL write_history_variable_ln ( DEF_hist_vars%solniln, & a_solniln, file_hist, 'f_solniln', itime_in_file, sumarea, filter, & 'incident diffuse beam nir solar radiation at local noon(W/m2)','W/m2') ! reflected direct beam vis solar radiation at local noon (W/m2) - call write_history_variable_ln ( DEF_hist_vars%srvdln, & + CALL write_history_variable_ln ( DEF_hist_vars%srvdln, & a_srvdln, file_hist, 'f_srvdln', itime_in_file, sumarea, filter, & 'reflected direct beam vis solar radiation at local noon(W/m2)','W/m2') ! reflected diffuse beam vis solar radiation at local noon (W/m2) - call write_history_variable_ln ( DEF_hist_vars%srviln, & + CALL write_history_variable_ln ( DEF_hist_vars%srviln, & a_srviln, file_hist, 'f_srviln', itime_in_file, sumarea, filter, & 'reflected diffuse beam vis solar radiation at local noon(W/m2)','W/m2') ! reflected direct beam nir solar radiation at local noon (W/m2) - call write_history_variable_ln ( DEF_hist_vars%srndln, & + CALL write_history_variable_ln ( DEF_hist_vars%srndln, & a_srndln, file_hist, 'f_srndln', itime_in_file, sumarea, filter, & 'reflected direct beam nir solar radiation at local noon(W/m2)','W/m2') ! reflected diffuse beam nir solar radiation at local noon(W/m2) - call write_history_variable_ln ( DEF_hist_vars%srniln, & + CALL write_history_variable_ln ( DEF_hist_vars%srniln, & a_srniln, file_hist, 'f_srniln', itime_in_file, sumarea, filter, & 'reflected diffuse beam nir solar radiation at local noon(W/m2)','W/m2') @@ -3590,7 +3590,7 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & if (allocated(VecOnes_urb)) deallocate(VecOnes_urb) #endif - call FLUSH_acc_fluxes () + CALL FLUSH_acc_fluxes () #ifdef SinglePoint IF (USE_SITE_HistWriteBack .and. memory_to_disk) THEN @@ -3598,16 +3598,16 @@ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, & ENDIF #endif - end if + END if END SUBROUTINE hist_out ! ------- - subroutine write_history_variable_2d ( is_hist, & + SUBROUTINE write_history_variable_2d ( is_hist, & acc_vec, file_hist, varname, itime_in_file, sumarea, filter, & longname, units) - implicit none + IMPLICIT NONE logical, intent(in) :: is_hist @@ -3621,33 +3621,33 @@ subroutine write_history_variable_2d ( is_hist, & type(block_data_real8_2d), intent(in) :: sumarea logical, intent(in) :: filter(:) - if (.not. is_hist) return + if (.not. is_hist) RETURN - select case (HistForm) - case ('Gridded') + select CASE (HistForm) + CASE ('Gridded') CALL flux_map_and_write_2d ( & acc_vec, file_hist, varname, itime_in_file, sumarea, filter, longname, units) #if (defined UNSTRUCTURED || defined CATCHMENT) - case ('Vector') + CASE ('Vector') CALL aggregate_to_vector_and_write_2d ( & acc_vec, file_hist, varname, itime_in_file, filter, longname, units) #endif #ifdef SinglePoint - case ('Single') + CASE ('Single') CALL single_write_2d ( & acc_vec, file_hist, varname, itime_in_file, longname, units) #endif - end select + END select - end subroutine write_history_variable_2d + END SUBROUTINE write_history_variable_2d ! ------- #ifdef URBAN_MODEL - subroutine write_history_variable_urb_2d ( is_hist, & + SUBROUTINE write_history_variable_urb_2d ( is_hist, & acc_vec, file_hist, varname, itime_in_file, sumarea, filter, & longname, units) - implicit none + IMPLICIT NONE logical, intent(in) :: is_hist @@ -3661,33 +3661,33 @@ subroutine write_history_variable_urb_2d ( is_hist, & type(block_data_real8_2d), intent(in) :: sumarea logical, intent(in) :: filter(:) - if (.not. is_hist) return + if (.not. is_hist) RETURN - select case (HistForm) - case ('Gridded') + select CASE (HistForm) + CASE ('Gridded') CALL flux_map_and_write_urb_2d ( & acc_vec, file_hist, varname, itime_in_file, sumarea, filter, longname, units) #if (defined UNSTRUCTURED || defined CATCHMENT) - case ('Vector') + CASE ('Vector') CALL aggregate_to_vector_and_write_2d ( & acc_vec, file_hist, varname, itime_in_file, filter, longname, units) #endif #ifdef SinglePoint - case ('Single') + CASE ('Single') CALL single_write_urb_2d ( & acc_vec, file_hist, varname, itime_in_file, longname, units) #endif - end select + END select - end subroutine write_history_variable_urb_2d + END SUBROUTINE write_history_variable_urb_2d #endif ! ------- - subroutine write_history_variable_3d ( is_hist, & + SUBROUTINE write_history_variable_3d ( is_hist, & acc_vec, file_hist, varname, itime_in_file, dim1name, lb1, ndim1, & sumarea, filter, longname, units) - implicit none + IMPLICIT NONE logical, intent(in) :: is_hist @@ -3707,35 +3707,35 @@ subroutine write_history_variable_3d ( is_hist, & integer :: iblkme, xblk, yblk, xloc, yloc, i1 integer :: compress - if (.not. is_hist) return + if (.not. is_hist) RETURN - select case (HistForm) - case ('Gridded') + select CASE (HistForm) + CASE ('Gridded') CALL flux_map_and_write_3d ( & acc_vec, file_hist, varname, itime_in_file, dim1name, lb1, ndim1, & sumarea, filter, longname, units) #if (defined UNSTRUCTURED || defined CATCHMENT) - case ('Vector') + CASE ('Vector') CALL aggregate_to_vector_and_write_3d ( & acc_vec, file_hist, varname, itime_in_file, dim1name, lb1, ndim1, & filter, longname, units) #endif #ifdef SinglePoint - case ('Single') + CASE ('Single') CALL single_write_3d (acc_vec, file_hist, varname, itime_in_file, & dim1name, ndim1, longname, units) #endif - end select + END select - end subroutine write_history_variable_3d + END SUBROUTINE write_history_variable_3d ! ------- - subroutine write_history_variable_4d ( is_hist, & + SUBROUTINE write_history_variable_4d ( is_hist, & acc_vec, file_hist, varname, itime_in_file, & dim1name, lb1, ndim1, dim2name, lb2, ndim2, & sumarea, filter, longname, units) - implicit none + IMPLICIT NONE logical, intent(in) :: is_hist @@ -3751,34 +3751,34 @@ subroutine write_history_variable_4d ( is_hist, & character (len=*), intent(in) :: longname character (len=*), intent(in) :: units - if (.not. is_hist) return + if (.not. is_hist) RETURN - select case (HistForm) - case ('Gridded') + select CASE (HistForm) + CASE ('Gridded') CALL flux_map_and_write_4d ( & acc_vec, file_hist, varname, itime_in_file, dim1name, lb1, ndim1, & dim2name, lb2, ndim2, sumarea, filter, longname, units) #if (defined UNSTRUCTURED || defined CATCHMENT) - case ('Vector') + CASE ('Vector') CALL aggregate_to_vector_and_write_4d ( & acc_vec, file_hist, varname, itime_in_file, dim1name, lb1, ndim1, & dim2name, lb2, ndim2, filter, longname, units) #endif #ifdef SinglePoint - case ('Single') + CASE ('Single') CALL single_write_4d (acc_vec, file_hist, varname, itime_in_file, & dim1name, ndim1, dim2name, ndim2, longname, units) #endif - end select + END select - end subroutine write_history_variable_4d + END SUBROUTINE write_history_variable_4d ! ------- - subroutine write_history_variable_ln ( is_hist, & + SUBROUTINE write_history_variable_ln ( is_hist, & acc_vec, file_hist, varname, itime_in_file, sumarea, filter, & longname, units) - implicit none + IMPLICIT NONE logical, intent(in) :: is_hist @@ -3792,48 +3792,48 @@ subroutine write_history_variable_ln ( is_hist, & character (len=*), intent(in), optional :: longname character (len=*), intent(in), optional :: units - if (.not. is_hist) return + if (.not. is_hist) RETURN - select case (HistForm) - case ('Gridded') + select CASE (HistForm) + CASE ('Gridded') CALL flux_map_and_write_ln ( & acc_vec, file_hist, varname, itime_in_file, sumarea, filter, longname, units) #if (defined UNSTRUCTURED || defined CATCHMENT) - case ('Vector') + CASE ('Vector') CALL aggregate_to_vector_and_write_ln ( & acc_vec, file_hist, varname, itime_in_file, filter, longname, units) #endif #ifdef SinglePoint - case ('Single') + CASE ('Single') CALL single_write_ln (acc_vec, file_hist, varname, itime_in_file, longname, units) #endif - end select + END select - end subroutine write_history_variable_ln + END SUBROUTINE write_history_variable_ln !------------------------------ - subroutine hist_write_time (filename, dataname, time, itime) + SUBROUTINE hist_write_time (filename, dataname, time, itime) - implicit none + IMPLICIT NONE character (len=*), intent(in) :: filename character (len=*), intent(in) :: dataname integer, intent(in) :: time(3) integer, intent(out) :: itime - select case (HistForm) - case ('Gridded') + select CASE (HistForm) + CASE ('Gridded') CALL hist_gridded_write_time (filename, dataname, time, itime) #if (defined UNSTRUCTURED || defined CATCHMENT) - case ('Vector') + CASE ('Vector') CALL hist_vector_write_time (filename, dataname, time, itime) #endif #ifdef SinglePoint - case ('Single') + CASE ('Single') CALL hist_single_write_time (filename, dataname, time, itime) #endif - end select + END select - end subroutine hist_write_time + END SUBROUTINE hist_write_time -end module MOD_Hist +END MODULE MOD_Hist diff --git a/main/MOD_Irrigation.F90 b/main/MOD_Irrigation.F90 index 969eff74..21c6e2c0 100644 --- a/main/MOD_Irrigation.F90 +++ b/main/MOD_Irrigation.F90 @@ -1,348 +1,348 @@ #include #ifdef CROP -module MOD_Irrigation - -! DESCRIPTION: -! This module has all irrigation related subroutines for irrigated crop at either IGBP/USGS or PFT Land type classification and even in the C and N cycle. - use MOD_Precision - USE MOD_TimeManager - USE MOD_Namelist, only: DEF_simulation_time - ! ,DEF_IRRIGATION_METHOD - use MOD_Const_Physical, only: tfrz - use MOD_Const_PFT, only: irrig_crop - use MOD_Vars_Global, only: irrig_start_time, irrig_max_depth, irrig_threshold_fraction, irrig_min_cphase, irrig_max_cphase, irrig_time_per_day - use MOD_Qsadv, only: qsadv - use MOD_Vars_TimeInvariants, only: & +MODULE MOD_Irrigation + +! DESCRIPTION: +! This MODULE has all irrigation related subroutines for irrigated crop at either IGBP/USGS or PFT Land type classification and even in the C and N cycle. + USE MOD_Precision + USE MOD_TimeManager + USE MOD_Namelist, only: DEF_simulation_time + ! ,DEF_IRRIGATION_METHOD + USE MOD_Const_Physical, only: tfrz + USE MOD_Const_PFT, only: irrig_crop + USE MOD_Vars_Global, only: irrig_start_time, irrig_max_depth, irrig_threshold_fraction, irrig_min_cphase, irrig_max_cphase, irrig_time_per_day + USE MOD_Qsadv, only: qsadv + USE MOD_Vars_TimeInvariants, only: & #ifdef vanGenuchten_Mualem_SOIL_MODEL - theta_r, alpha_vgm, n_vgm, L_vgm, fc_vgm, sc_vgm,& + theta_r, alpha_vgm, n_vgm, L_vgm, fc_vgm, sc_vgm,& #endif - porsl, psi0, bsw - use MOD_Vars_TimeVariables, only : tref, t_soisno, wliq_soisno, irrig_rate, deficit_irrig, sum_irrig, sum_irrig_count, n_irrig_steps_left, & - tairday, usday, vsday, pairday, rnetday, fgrndday, potential_evapotranspiration - use MOD_Vars_PFTimeInvariants, only: pftclass - use MOD_Vars_PFTimeVariables, only: irrig_method_p - use MOD_BGC_Vars_PFTimeVariables, only: cphase_p - use MOD_Vars_1DForcing, only: forc_t, forc_frl, forc_psrf, forc_us, forc_vs - use MOD_Vars_1DFluxes, only: sabg, sabvsun, sabvsha, olrg, fgrnd - use MOD_Hydro_SoilFunction, only: soil_vliq_from_psi - - implicit none - - public :: CalIrrigationNeeded - public :: CalIrrigationApplicationFluxes - - ! local variable - integer :: irrig_method_drip = 1 - integer :: irrig_method_sprinkler = 2 - integer :: irrig_method_flood = 3 - integer :: irrig_method_paddy = 4 - -contains - - subroutine CalIrrigationNeeded(i,ps,pe,idate,nl_soil,nbedrock,z_soi,dz_soi,deltim,dlon,npcropmin) - - ! DESCRIPTION: - ! This subroutine is used to calculate how much irrigation needed in each irrigated crop patch - integer , intent(in) :: i - integer , intent(in) :: ps, pe - integer , intent(in) :: idate(3) - integer , intent(in) :: nl_soil - integer , intent(in) :: nbedrock - real(r8), intent(in) :: z_soi(1:nl_soil) - real(r8), intent(in) :: dz_soi(1:nl_soil) - real(r8), intent(in) :: deltim - real(r8), intent(in) :: dlon - integer , intent(in) :: npcropmin - - ! local - integer :: m - integer :: irrig_nsteps_per_day - logical :: check_for_irrig - - ! ! calculate last day potential evapotranspiration - ! call CalPotentialEvapotranspiration(i,idate,dlon,deltim) - - ! calculate whether irrigation needed - call PointNeedsCheckForIrrig(i,ps,pe,idate,deltim,dlon,npcropmin,check_for_irrig) - - ! calculate irrigation needed - if (check_for_irrig) then - call CalIrrigationPotentialNeeded(i,ps,pe,nl_soil,nbedrock,z_soi,dz_soi) - ! call CalIrrigationLimitedNeeded(i,ps,pe) - end if - - ! calculate irrigation rate kg/m2->mm/s - if ((check_for_irrig) .and. (deficit_irrig(i) > 0)) then - irrig_nsteps_per_day = nint(irrig_time_per_day/deltim) - irrig_rate(i) = deficit_irrig(i)/deltim/irrig_nsteps_per_day - n_irrig_steps_left(i) = irrig_nsteps_per_day - sum_irrig(i) = sum_irrig(i) + deficit_irrig(i) - sum_irrig_count(i) = sum_irrig_count(i) + 1._r8 - end if - - ! ! zero irrigation at the end of growing season - ! do m = ps, pe - ! if (cphase_p(m) >= 4._r8) then - ! sum_irrig(i) = 0._r8 - ! sum_irrig_count(i) = 0._r8 - ! end if - ! end do - end subroutine CalIrrigationNeeded - - - subroutine CalIrrigationPotentialNeeded(i,ps,pe,nl_soil,nbedrock,z_soi,dz_soi) - - ! DESCRIPTION: - ! This subroutine is used to calculate how much irrigation needed in each irrigated crop patch without water supply restriction - integer , intent(in) :: i - integer , intent(in) :: ps, pe - integer , intent(in) :: nbedrock - integer , intent(in) :: nl_soil - real(r8), intent(in) :: z_soi(1:nl_soil) - real(r8), intent(in) :: dz_soi(1:nl_soil) - - ! local variables - integer :: j - integer :: m - logical :: reached_max_depth - real(r8) :: h2osoi_liq_tot - real(r8) :: h2osoi_liq_target_tot - real(r8) :: h2osoi_liq_wilting_point_tot - real(r8) :: h2osoi_liq_saturation_capacity_tot - real(r8) :: h2osoi_liq_wilting_point(1:nl_soil) - real(r8) :: h2osoi_liq_field_capacity(1:nl_soil) - real(r8) :: h2osoi_liq_saturation_capacity(1:nl_soil) - real(r8) :: h2osoi_liq_at_threshold - - real(r8) :: smpswc = -1.5e5 - real(r8) :: smpsfc = -3.3e3 - - ! initialize local variables - reached_max_depth = .false. - h2osoi_liq_tot = 0._r8 - h2osoi_liq_target_tot = 0._r8 - h2osoi_liq_wilting_point_tot = 0._r8 - h2osoi_liq_saturation_capacity_tot = 0._r8 - - ! ! single site initialization - ! do m = ps, pe - ! irrig_method_p(m) = DEF_IRRIGATION_METHOD - ! enddo + porsl, psi0, bsw + USE MOD_Vars_TimeVariables, only : tref, t_soisno, wliq_soisno, irrig_rate, deficit_irrig, sum_irrig, sum_irrig_count, n_irrig_steps_left, & + tairday, usday, vsday, pairday, rnetday, fgrndday, potential_evapotranspiration + USE MOD_Vars_PFTimeInvariants, only: pftclass + USE MOD_Vars_PFTimeVariables, only: irrig_method_p + USE MOD_BGC_Vars_PFTimeVariables, only: cphase_p + USE MOD_Vars_1DForcing, only: forc_t, forc_frl, forc_psrf, forc_us, forc_vs + USE MOD_Vars_1DFluxes, only: sabg, sabvsun, sabvsha, olrg, fgrnd + USE MOD_Hydro_SoilFunction, only: soil_vliq_from_psi + + IMPLICIT NONE + + PUBLIC :: CalIrrigationNeeded + PUBLIC :: CalIrrigationApplicationFluxes + + ! local variable + integer :: irrig_method_drip = 1 + integer :: irrig_method_sprinkler = 2 + integer :: irrig_method_flood = 3 + integer :: irrig_method_paddy = 4 + +CONTAINS + + SUBROUTINE CalIrrigationNeeded(i,ps,pe,idate,nl_soil,nbedrock,z_soi,dz_soi,deltim,dlon,npcropmin) + + ! DESCRIPTION: + ! This SUBROUTINE is used to calculate how much irrigation needed in each irrigated crop patch + integer , intent(in) :: i + integer , intent(in) :: ps, pe + integer , intent(in) :: idate(3) + integer , intent(in) :: nl_soil + integer , intent(in) :: nbedrock + real(r8), intent(in) :: z_soi(1:nl_soil) + real(r8), intent(in) :: dz_soi(1:nl_soil) + real(r8), intent(in) :: deltim + real(r8), intent(in) :: dlon + integer , intent(in) :: npcropmin + + ! local + integer :: m + integer :: irrig_nsteps_per_day + logical :: check_for_irrig + + ! ! calculate last day potential evapotranspiration + ! CALL CalPotentialEvapotranspiration(i,idate,dlon,deltim) + + ! calculate whether irrigation needed + CALL PointNeedsCheckForIrrig(i,ps,pe,idate,deltim,dlon,npcropmin,check_for_irrig) + + ! calculate irrigation needed + IF (check_for_irrig) THEN + CALL CalIrrigationPotentialNeeded(i,ps,pe,nl_soil,nbedrock,z_soi,dz_soi) + ! CALL CalIrrigationLimitedNeeded(i,ps,pe) + ENDIF + + ! calculate irrigation rate kg/m2->mm/s + IF ((check_for_irrig) .and. (deficit_irrig(i) > 0)) THEN + irrig_nsteps_per_day = nint(irrig_time_per_day/deltim) + irrig_rate(i) = deficit_irrig(i)/deltim/irrig_nsteps_per_day + n_irrig_steps_left(i) = irrig_nsteps_per_day + sum_irrig(i) = sum_irrig(i) + deficit_irrig(i) + sum_irrig_count(i) = sum_irrig_count(i) + 1._r8 + ENDIF + + ! ! zero irrigation at the END of growing season + ! DO m = ps, pe + ! IF (cphase_p(m) >= 4._r8) THEN + ! sum_irrig(i) = 0._r8 + ! sum_irrig_count(i) = 0._r8 + ! ENDIF + ! ENDDO + END SUBROUTINE CalIrrigationNeeded + + + SUBROUTINE CalIrrigationPotentialNeeded(i,ps,pe,nl_soil,nbedrock,z_soi,dz_soi) + + ! DESCRIPTION: + ! This SUBROUTINE is used to calculate how much irrigation needed in each irrigated crop patch without water supply restriction + integer , intent(in) :: i + integer , intent(in) :: ps, pe + integer , intent(in) :: nbedrock + integer , intent(in) :: nl_soil + real(r8), intent(in) :: z_soi(1:nl_soil) + real(r8), intent(in) :: dz_soi(1:nl_soil) + + ! local variables + integer :: j + integer :: m + logical :: reached_max_depth + real(r8) :: h2osoi_liq_tot + real(r8) :: h2osoi_liq_target_tot + real(r8) :: h2osoi_liq_wilting_point_tot + real(r8) :: h2osoi_liq_saturation_capacity_tot + real(r8) :: h2osoi_liq_wilting_point(1:nl_soil) + real(r8) :: h2osoi_liq_field_capacity(1:nl_soil) + real(r8) :: h2osoi_liq_saturation_capacity(1:nl_soil) + real(r8) :: h2osoi_liq_at_threshold + + real(r8) :: smpswc = -1.5e5 + real(r8) :: smpsfc = -3.3e3 + + ! initialize local variables + reached_max_depth = .false. + h2osoi_liq_tot = 0._r8 + h2osoi_liq_target_tot = 0._r8 + h2osoi_liq_wilting_point_tot = 0._r8 + h2osoi_liq_saturation_capacity_tot = 0._r8 + + ! ! single site initialization + ! DO m = ps, pe + ! irrig_method_p(m) = DEF_IRRIGATION_METHOD + ! ENDDO ! calculate wilting point and field capacity - do j = 1, nl_soil - if (t_soisno(j,i) > tfrz .and. porsl(j,i) >= 1.e-6) then + DO j = 1, nl_soil + IF (t_soisno(j,i) > tfrz .and. porsl(j,i) >= 1.e-6) THEN #ifdef Campbell_SOIL_MODEL - h2osoi_liq_wilting_point(j) = 1000.*dz_soi(j)*porsl(j,i)*((smpswc/psi0(j,i))**(-1/bsw(j,i))) - h2osoi_liq_field_capacity(j) = 1000.*dz_soi(j)*porsl(j,i)*((smpsfc/psi0(j,i))**(-1/bsw(j,i))) - h2osoi_liq_saturation_capacity(j) = 1000.*dz_soi(j)*porsl(j,i) + h2osoi_liq_wilting_point(j) = 1000.*dz_soi(j)*porsl(j,i)*((smpswc/psi0(j,i))**(-1/bsw(j,i))) + h2osoi_liq_field_capacity(j) = 1000.*dz_soi(j)*porsl(j,i)*((smpsfc/psi0(j,i))**(-1/bsw(j,i))) + h2osoi_liq_saturation_capacity(j) = 1000.*dz_soi(j)*porsl(j,i) #endif #ifdef vanGenuchten_Mualem_SOIL_MODEL - h2osoi_liq_wilting_point(j) = soil_vliq_from_psi(smpswc, porsl(j,i), theta_r(j,i), psi0(j,i), 5, & - (/alpha_vgm(j,i), n_vgm(j,i), L_vgm(j,i), sc_vgm(j,i), fc_vgm(j,i)/)) - h2osoi_liq_wilting_point(j) = 1000.*dz_soi(j)*h2osoi_liq_wilting_point(j) - h2osoi_liq_field_capacity(j) = soil_vliq_from_psi(smpsfc, porsl(j,i), theta_r(j,i), psi0(j,i), 5, & - (/alpha_vgm(j,i), n_vgm(j,i), L_vgm(j,i), sc_vgm(j,i), fc_vgm(j,i)/)) - h2osoi_liq_field_capacity(j) = 1000.*dz_soi(j)*h2osoi_liq_field_capacity(j) - h2osoi_liq_saturation_capacity(j) = 1000.*dz_soi(j)*porsl(j,i) + h2osoi_liq_wilting_point(j) = soil_vliq_from_psi(smpswc, porsl(j,i), theta_r(j,i), psi0(j,i), 5, & + (/alpha_vgm(j,i), n_vgm(j,i), L_vgm(j,i), sc_vgm(j,i), fc_vgm(j,i)/)) + h2osoi_liq_wilting_point(j) = 1000.*dz_soi(j)*h2osoi_liq_wilting_point(j) + h2osoi_liq_field_capacity(j) = soil_vliq_from_psi(smpsfc, porsl(j,i), theta_r(j,i), psi0(j,i), 5, & + (/alpha_vgm(j,i), n_vgm(j,i), L_vgm(j,i), sc_vgm(j,i), fc_vgm(j,i)/)) + h2osoi_liq_field_capacity(j) = 1000.*dz_soi(j)*h2osoi_liq_field_capacity(j) + h2osoi_liq_saturation_capacity(j) = 1000.*dz_soi(j)*porsl(j,i) #endif - end if - end do - - ! calculate total irrigation needed in all soil layers - do m = ps, pe - do j = 1, nl_soil - if (.not. reached_max_depth) then - if (z_soi(j) > irrig_max_depth) then - reached_max_depth = .true. - else if (j > nbedrock) then - reached_max_depth = .true. - else if (t_soisno(j,i) <= tfrz) then - reached_max_depth = .true. - else - h2osoi_liq_tot = h2osoi_liq_tot + wliq_soisno(j,i) - h2osoi_liq_wilting_point_tot = h2osoi_liq_wilting_point_tot + h2osoi_liq_wilting_point(j) - if (irrig_method_p(m) == irrig_method_drip .or. irrig_method_p(m) == irrig_method_sprinkler) then - h2osoi_liq_target_tot = h2osoi_liq_target_tot + h2osoi_liq_field_capacity(j) - ! irrigation threshold at field capacity, but irrigation amount at saturation capacity - else if (irrig_method_p(m) == irrig_method_flood) then - h2osoi_liq_target_tot = h2osoi_liq_target_tot + h2osoi_liq_field_capacity(j) - h2osoi_liq_saturation_capacity_tot = h2osoi_liq_saturation_capacity_tot + h2osoi_liq_saturation_capacity(j) - else if (irrig_method_p(m) == irrig_method_paddy) then - h2osoi_liq_target_tot = h2osoi_liq_target_tot + h2osoi_liq_saturation_capacity(j) - else - h2osoi_liq_target_tot = h2osoi_liq_target_tot + h2osoi_liq_field_capacity(j) - end if - end if - end if - end do - end do - - ! calculate irrigation threshold - deficit_irrig(i) = 0._r8 - h2osoi_liq_at_threshold = h2osoi_liq_wilting_point_tot + irrig_threshold_fraction * (h2osoi_liq_target_tot - h2osoi_liq_wilting_point_tot) - - ! calculate total irrigation - do m = ps, pe - if (h2osoi_liq_tot < h2osoi_liq_at_threshold) then - if (irrig_method_p(m) == irrig_method_sprinkler) then - deficit_irrig(i) = h2osoi_liq_target_tot - h2osoi_liq_tot - ! deficit_irrig(i) = h2osoi_liq_target_tot - h2osoi_liq_tot + potential_evapotranspiration(i) - else if (irrig_method_p(m) == irrig_method_flood) then - deficit_irrig(i) = h2osoi_liq_saturation_capacity_tot - h2osoi_liq_tot - else - deficit_irrig(i) = h2osoi_liq_at_threshold - h2osoi_liq_tot - end if - else - deficit_irrig(i) = 0 - end if - end do - - end subroutine CalIrrigationPotentialNeeded - - subroutine CalIrrigationApplicationFluxes(i,ps,pe,deltim,qflx_irrig_drip,qflx_irrig_sprinkler,qflx_irrig_flood,qflx_irrig_paddy,irrig_flag) - ! DESCRIPTION: - ! This subroutine is used to calculate irrigation application fluxes for each irrigated crop patch - integer , intent(in) :: i - integer , intent(in) :: ps, pe - real(r8), intent(in) :: deltim - integer , intent(in) :: irrig_flag ! 1 if sprinker, 2 if others - real(r8), intent(out):: qflx_irrig_drip,qflx_irrig_sprinkler,qflx_irrig_flood,qflx_irrig_paddy - - integer :: m - - qflx_irrig_drip = 0._r8 - qflx_irrig_sprinkler = 0._r8 - qflx_irrig_flood = 0._r8 - qflx_irrig_paddy = 0._r8 - - ! ! single site initialization - ! do m = ps, pe - ! irrig_method_p(m) = DEF_IRRIGATION_METHOD - ! enddo - - ! add irrigation fluxes to precipitation or land surface - do m = ps, pe - if (n_irrig_steps_left(i) > 0) then - if ((irrig_flag == 1) .and. (irrig_method_p(m) == irrig_method_sprinkler)) then - qflx_irrig_sprinkler = irrig_rate(i) - n_irrig_steps_left(i) = n_irrig_steps_left(i) -1 - deficit_irrig(i) = deficit_irrig(i) - irrig_rate(i)*deltim - else if (irrig_flag == 2) then - if (irrig_method_p(m) == irrig_method_drip) then - qflx_irrig_drip = irrig_rate(i) - else if (irrig_method_p(m) == irrig_method_flood) then - qflx_irrig_flood = irrig_rate(i) - else if (irrig_method_p(m) == irrig_method_paddy) then - qflx_irrig_paddy = irrig_rate(i) - else if ((irrig_method_p(m) /= irrig_method_drip) .and. (irrig_method_p(m) /= irrig_method_sprinkler) & - .and. (irrig_method_p(m) /= irrig_method_flood) .and. (irrig_method_p(m) /= irrig_method_paddy)) then - qflx_irrig_drip = irrig_rate(i) - end if - n_irrig_steps_left(i) = n_irrig_steps_left(i) -1 - deficit_irrig(i) = deficit_irrig(i) - irrig_rate(i)*deltim - end if - if (deficit_irrig(i) < 0._r8) then - deficit_irrig(i) = 0._r8 - end if - else - irrig_rate(i) = 0._r8 - end if - end do - end subroutine CalIrrigationApplicationFluxes - - subroutine PointNeedsCheckForIrrig(i,ps,pe,idate,deltim,dlon,npcropmin,check_for_irrig) - ! DESCRIPTION: - ! This subroutine is used to calculate whether irrigation needed in each patch - integer , intent(in) :: i - integer , intent(in) :: ps, pe - integer , intent(in) :: idate(3) - real(r8), intent(in) :: deltim - real(r8), intent(in) :: dlon - integer , intent(in) :: npcropmin - logical , intent(out):: check_for_irrig - - ! local variable - integer :: m, ivt - real(r8):: ldate(3) - real(r8):: seconds_since_irrig_start_time - - do m = ps, pe - ivt = pftclass(m) - if ((ivt >= npcropmin) .and. (irrig_crop(ivt)) .and. & - (cphase_p(m) >= irrig_min_cphase) .and. (cphase_p(m)= 0._r8) .and. (seconds_since_irrig_start_time < deltim)) then - check_for_irrig = .true. - else - check_for_irrig = .false. - end if - else - check_for_irrig = .false. - end if - end do - - end subroutine PointNeedsCheckForIrrig - - ! subroutine CalPotentialEvapotranspiration(i,idate,dlon,deltim) - ! ! DESCRIPTION: - ! ! This subroutine is used to calculate daily potential evapotranspiration - ! integer , intent(in) :: i - ! integer , intent(in) :: idate(3) - ! real(r8), intent(in) :: dlon - ! real(r8), intent(in) :: deltim - - ! ! local variable - ! real(r8):: ldate(3) - ! real(r8):: seconds_since_irrig_start_time - ! real(r8) :: es,esdT,qs,qsdT ! saturation vapour pressure - ! real(r8) :: evsat ! vapour pressure - ! real(r8) :: ur ! wind speed - ! real(r8) :: delta ! slope of saturation vapour pressure curve - ! real(r8) :: gamma ! Psychrometric constant - - ! if (DEF_simulation_time%greenwich) then - ! call gmt2local(idate, dlon, ldate) - ! seconds_since_irrig_start_time = ldate(3) - irrig_start_time + deltim - ! else - ! seconds_since_irrig_start_time = idate(3) - irrig_start_time + deltim - ! end if - - ! if (((seconds_since_irrig_start_time-deltim) >= 0) .and. ((seconds_since_irrig_start_time-deltim) < deltim)) then - ! tairday(i) = (forc_t(i)-tfrz)*deltim/86400 - ! usday(i) = forc_us(i)*deltim/86400 - ! vsday(i) = forc_vs(i)*deltim/86400 - ! pairday(i) = forc_psrf(i)*deltim/86400/1000 - ! rnetday(i) = (sabg(i)+sabvsun(i)+sabvsha(i)-olrg(i)+forc_frl(i))*deltim/1000000 - ! fgrndday(i) = fgrnd(i)*deltim/1000000 - ! else - ! tairday(i) = tairday(i) + (forc_t(i)-tfrz)*deltim/86400 - ! usday(i) = usday(i) + forc_us(i)*deltim/86400 - ! vsday(i) = vsday(i) + forc_vs(i)*deltim/86400 - ! pairday(i) = pairday(i) + forc_psrf(i)*deltim/86400/1000 - ! rnetday(i) = rnetday(i) + (sabg(i)+sabvsun(i)+sabvsha(i)-olrg(i)+forc_frl(i))*deltim/1000000 - ! fgrndday(i) = fgrndday(i) + fgrnd(i)*deltim/1000000 - ! endif - - ! if ((seconds_since_irrig_start_time >= 0) .and. (seconds_since_irrig_start_time < deltim)) then - ! call qsadv(tairday(i),pairday(i),es,esdT,qs,qsdT) - ! if (tairday(i) > 0)then - ! evsat = 0.611*EXP(17.27*tairday(i)/(tairday(i)+237.3)) - ! else - ! evsat = 0.611*EXP(21.87*tairday(i)/(tairday(i)+265.5)) - ! endif - ! ur = max(0.1,sqrt(usday(i)*usday(i)+vsday(i)*vsday(i))) - ! delta = 4098*evsat/((tairday(i)+237.3)*(tairday(i)+237.3)) - ! gamma = 0.665*0.001*pairday(i) - ! potential_evapotranspiration(i) = (0.408*delta*(rnetday(i)-fgrndday(i))+gamma*(900/(tairday(i)+273))*ur* & - ! (evsat-es))/(delta+(gamma*(1+0.34*ur))) - ! end if - ! end subroutine CalPotentialEvapotranspiration - -end module MOD_Irrigation + ENDIF + ENDDO + + ! calculate total irrigation needed in all soil layers + DO m = ps, pe + DO j = 1, nl_soil + IF (.not. reached_max_depth) THEN + IF (z_soi(j) > irrig_max_depth) THEN + reached_max_depth = .true. + ELSE IF (j > nbedrock) THEN + reached_max_depth = .true. + ELSE IF (t_soisno(j,i) <= tfrz) THEN + reached_max_depth = .true. + ELSE + h2osoi_liq_tot = h2osoi_liq_tot + wliq_soisno(j,i) + h2osoi_liq_wilting_point_tot = h2osoi_liq_wilting_point_tot + h2osoi_liq_wilting_point(j) + IF (irrig_method_p(m) == irrig_method_drip .or. irrig_method_p(m) == irrig_method_sprinkler) THEN + h2osoi_liq_target_tot = h2osoi_liq_target_tot + h2osoi_liq_field_capacity(j) + ! irrigation threshold at field capacity, but irrigation amount at saturation capacity + ELSE IF (irrig_method_p(m) == irrig_method_flood) THEN + h2osoi_liq_target_tot = h2osoi_liq_target_tot + h2osoi_liq_field_capacity(j) + h2osoi_liq_saturation_capacity_tot = h2osoi_liq_saturation_capacity_tot + h2osoi_liq_saturation_capacity(j) + ELSE IF (irrig_method_p(m) == irrig_method_paddy) THEN + h2osoi_liq_target_tot = h2osoi_liq_target_tot + h2osoi_liq_saturation_capacity(j) + ELSE + h2osoi_liq_target_tot = h2osoi_liq_target_tot + h2osoi_liq_field_capacity(j) + ENDIF + ENDIF + ENDIF + ENDDO + ENDDO + + ! calculate irrigation threshold + deficit_irrig(i) = 0._r8 + h2osoi_liq_at_threshold = h2osoi_liq_wilting_point_tot + irrig_threshold_fraction * (h2osoi_liq_target_tot - h2osoi_liq_wilting_point_tot) + + ! calculate total irrigation + DO m = ps, pe + IF (h2osoi_liq_tot < h2osoi_liq_at_threshold) THEN + IF (irrig_method_p(m) == irrig_method_sprinkler) THEN + deficit_irrig(i) = h2osoi_liq_target_tot - h2osoi_liq_tot + ! deficit_irrig(i) = h2osoi_liq_target_tot - h2osoi_liq_tot + potential_evapotranspiration(i) + ELSE IF (irrig_method_p(m) == irrig_method_flood) THEN + deficit_irrig(i) = h2osoi_liq_saturation_capacity_tot - h2osoi_liq_tot + ELSE + deficit_irrig(i) = h2osoi_liq_at_threshold - h2osoi_liq_tot + ENDIF + ELSE + deficit_irrig(i) = 0 + ENDIF + ENDDO + + END SUBROUTINE CalIrrigationPotentialNeeded + + SUBROUTINE CalIrrigationApplicationFluxes(i,ps,pe,deltim,qflx_irrig_drip,qflx_irrig_sprinkler,qflx_irrig_flood,qflx_irrig_paddy,irrig_flag) + ! DESCRIPTION: + ! This SUBROUTINE is used to calculate irrigation application fluxes for each irrigated crop patch + integer , intent(in) :: i + integer , intent(in) :: ps, pe + real(r8), intent(in) :: deltim + integer , intent(in) :: irrig_flag ! 1 IF sprinker, 2 IF others + real(r8), intent(out):: qflx_irrig_drip,qflx_irrig_sprinkler,qflx_irrig_flood,qflx_irrig_paddy + + integer :: m + + qflx_irrig_drip = 0._r8 + qflx_irrig_sprinkler = 0._r8 + qflx_irrig_flood = 0._r8 + qflx_irrig_paddy = 0._r8 + + ! ! single site initialization + ! DO m = ps, pe + ! irrig_method_p(m) = DEF_IRRIGATION_METHOD + ! ENDDO + + ! add irrigation fluxes to precipitation or land surface + DO m = ps, pe + IF (n_irrig_steps_left(i) > 0) THEN + IF ((irrig_flag == 1) .and. (irrig_method_p(m) == irrig_method_sprinkler)) THEN + qflx_irrig_sprinkler = irrig_rate(i) + n_irrig_steps_left(i) = n_irrig_steps_left(i) -1 + deficit_irrig(i) = deficit_irrig(i) - irrig_rate(i)*deltim + ELSE IF (irrig_flag == 2) THEN + IF (irrig_method_p(m) == irrig_method_drip) THEN + qflx_irrig_drip = irrig_rate(i) + ELSE IF (irrig_method_p(m) == irrig_method_flood) THEN + qflx_irrig_flood = irrig_rate(i) + ELSE IF (irrig_method_p(m) == irrig_method_paddy) THEN + qflx_irrig_paddy = irrig_rate(i) + ELSE IF ((irrig_method_p(m) /= irrig_method_drip) .and. (irrig_method_p(m) /= irrig_method_sprinkler) & + .and. (irrig_method_p(m) /= irrig_method_flood) .and. (irrig_method_p(m) /= irrig_method_paddy)) THEN + qflx_irrig_drip = irrig_rate(i) + ENDIF + n_irrig_steps_left(i) = n_irrig_steps_left(i) -1 + deficit_irrig(i) = deficit_irrig(i) - irrig_rate(i)*deltim + ENDIF + IF (deficit_irrig(i) < 0._r8) THEN + deficit_irrig(i) = 0._r8 + ENDIF + ELSE + irrig_rate(i) = 0._r8 + ENDIF + ENDDO + END SUBROUTINE CalIrrigationApplicationFluxes + + SUBROUTINE PointNeedsCheckForIrrig(i,ps,pe,idate,deltim,dlon,npcropmin,check_for_irrig) + ! DESCRIPTION: + ! This SUBROUTINE is used to calculate whether irrigation needed in each patch + integer , intent(in) :: i + integer , intent(in) :: ps, pe + integer , intent(in) :: idate(3) + real(r8), intent(in) :: deltim + real(r8), intent(in) :: dlon + integer , intent(in) :: npcropmin + logical , intent(out):: check_for_irrig + + ! local variable + integer :: m, ivt + real(r8):: ldate(3) + real(r8):: seconds_since_irrig_start_time + + DO m = ps, pe + ivt = pftclass(m) + IF ((ivt >= npcropmin) .and. (irrig_crop(ivt)) .and. & + (cphase_p(m) >= irrig_min_cphase) .and. (cphase_p(m)= 0._r8) .and. (seconds_since_irrig_start_time < deltim)) THEN + check_for_irrig = .true. + ELSE + check_for_irrig = .false. + ENDIF + ELSE + check_for_irrig = .false. + ENDIF + ENDDO + + END SUBROUTINE PointNeedsCheckForIrrig + + ! SUBROUTINE CalPotentialEvapotranspiration(i,idate,dlon,deltim) + ! ! DESCRIPTION: + ! ! This SUBROUTINE is used to calculate daily potential evapotranspiration + ! integer , intent(in) :: i + ! integer , intent(in) :: idate(3) + ! real(r8), intent(in) :: dlon + ! real(r8), intent(in) :: deltim + + ! ! local variable + ! real(r8):: ldate(3) + ! real(r8):: seconds_since_irrig_start_time + ! real(r8) :: es,esdT,qs,qsdT ! saturation vapour pressure + ! real(r8) :: evsat ! vapour pressure + ! real(r8) :: ur ! wind speed + ! real(r8) :: delta ! slope of saturation vapour pressure curve + ! real(r8) :: gamma ! Psychrometric constant + + ! IF (DEF_simulation_time%greenwich) THEN + ! CALL gmt2local(idate, dlon, ldate) + ! seconds_since_irrig_start_time = ldate(3) - irrig_start_time + deltim + ! ELSE + ! seconds_since_irrig_start_time = idate(3) - irrig_start_time + deltim + ! ENDIF + + ! IF (((seconds_since_irrig_start_time-deltim) >= 0) .and. ((seconds_since_irrig_start_time-deltim) < deltim)) THEN + ! tairday(i) = (forc_t(i)-tfrz)*deltim/86400 + ! usday(i) = forc_us(i)*deltim/86400 + ! vsday(i) = forc_vs(i)*deltim/86400 + ! pairday(i) = forc_psrf(i)*deltim/86400/1000 + ! rnetday(i) = (sabg(i)+sabvsun(i)+sabvsha(i)-olrg(i)+forc_frl(i))*deltim/1000000 + ! fgrndday(i) = fgrnd(i)*deltim/1000000 + ! ELSE + ! tairday(i) = tairday(i) + (forc_t(i)-tfrz)*deltim/86400 + ! usday(i) = usday(i) + forc_us(i)*deltim/86400 + ! vsday(i) = vsday(i) + forc_vs(i)*deltim/86400 + ! pairday(i) = pairday(i) + forc_psrf(i)*deltim/86400/1000 + ! rnetday(i) = rnetday(i) + (sabg(i)+sabvsun(i)+sabvsha(i)-olrg(i)+forc_frl(i))*deltim/1000000 + ! fgrndday(i) = fgrndday(i) + fgrnd(i)*deltim/1000000 + ! ENDIF + + ! IF ((seconds_since_irrig_start_time >= 0) .and. (seconds_since_irrig_start_time < deltim)) THEN + ! CALL qsadv(tairday(i),pairday(i),es,esdT,qs,qsdT) + ! IF (tairday(i) > 0)THEN + ! evsat = 0.611*EXP(17.27*tairday(i)/(tairday(i)+237.3)) + ! ELSE + ! evsat = 0.611*EXP(21.87*tairday(i)/(tairday(i)+265.5)) + ! ENDIF + ! ur = max(0.1,sqrt(usday(i)*usday(i)+vsday(i)*vsday(i))) + ! delta = 4098*evsat/((tairday(i)+237.3)*(tairday(i)+237.3)) + ! gamma = 0.665*0.001*pairday(i) + ! potential_evapotranspiration(i) = (0.408*delta*(rnetday(i)-fgrndday(i))+gamma*(900/(tairday(i)+273))*ur* & + ! (evsat-es))/(delta+(gamma*(1+0.34*ur))) + ! ENDIF + ! END SUBROUTINE CalPotentialEvapotranspiration + +END MODULE MOD_Irrigation #endif diff --git a/main/MOD_LAIEmpirical.F90 b/main/MOD_LAIEmpirical.F90 index fe95d821..d43123e9 100644 --- a/main/MOD_LAIEmpirical.F90 +++ b/main/MOD_LAIEmpirical.F90 @@ -13,20 +13,20 @@ MODULE MOD_LAIEmpirical !----------------------------------------------------------------------- - CONTAINS +CONTAINS !----------------------------------------------------------------------- - subroutine LAI_empirical(ivt,nl_soil,rootfr,t,lai,sai,fveg,green) + SUBROUTINE LAI_empirical(ivt,nl_soil,rootfr,t,lai,sai,fveg,green) !----------------------------------------------------------------------- ! provides leaf and stem area parameters ! Original author : Yongjiu Dai, 08/31/2002 !----------------------------------------------------------------------- - use MOD_Precision - implicit none + USE MOD_Precision + IMPLICIT NONE integer, intent(in) :: ivt !land cover type integer, intent(in) :: nl_soil !number of soil layers @@ -109,30 +109,30 @@ subroutine LAI_empirical(ivt,nl_soil,rootfr,t,lai,sai,fveg,green) #endif !----------------------------------------------------------------------- - roota = 0. - jrt = 1 - do j = 1, nl_soil - roota = roota + rootfr(j) - if(roota>0.9)then - jrt = j - exit - endif - enddo + roota = 0. + jrt = 1 + DO j = 1, nl_soil + roota = roota + rootfr(j) + IF(roota>0.9)THEN + jrt = j + EXIT + ENDIF + ENDDO ! Adjust leaf area index for seasonal variation - f = max(0.0,1.-0.0016*max(298.-t(jrt),0.0)**2) - lai = xla(ivt) + (xla0(ivt)-xla(ivt))*(1.-f) + f = max(0.0,1.-0.0016*max(298.-t(jrt),0.0)**2) + lai = xla(ivt) + (xla0(ivt)-xla(ivt))*(1.-f) ! Sum leaf area index and stem area index - sai = sai0(ivt) + sai = sai0(ivt) ! Fractional vegetation cover - fveg = vegc(ivt) + fveg = vegc(ivt) - green = 0.0 - if(fveg > 0.) green = 1.0 + green = 0.0 + IF(fveg > 0.) green = 1.0 - end subroutine LAI_empirical + END SUBROUTINE LAI_empirical END MODULE MOD_LAIEmpirical diff --git a/main/MOD_LAIReadin.F90 b/main/MOD_LAIReadin.F90 index 99126240..ed292d4a 100644 --- a/main/MOD_LAIReadin.F90 +++ b/main/MOD_LAIReadin.F90 @@ -13,53 +13,53 @@ MODULE MOD_LAIReadin !----------------------------------------------------------------------- - CONTAINS +CONTAINS !----------------------------------------------------------------------- SUBROUTINE LAI_readin (year, time, dir_landdata) - ! =========================================================== - ! Read in the LAI, the LAI dataset was created by Yuan et al. (2011) - ! http://globalchange.bnu.edu.cn - ! - ! Created by Yongjiu Dai, March, 2014 - ! =========================================================== - - use MOD_Precision - use MOD_Namelist - use MOD_SPMD_Task - use MOD_NetCDFVector - use MOD_LandPatch - use MOD_Vars_TimeInvariants - use MOD_Vars_TimeVariables - - USE MOD_Vars_Global - USE MOD_Const_LC + ! =========================================================== + ! Read in the LAI, the LAI dataset was created by Yuan et al. (2011) + ! http://globalchange.bnu.edu.cn + ! + ! Created by Yongjiu Dai, March, 2014 + ! =========================================================== + + USE MOD_Precision + USE MOD_Namelist + USE MOD_SPMD_Task + USE MOD_NetCDFVector + USE MOD_LandPatch + USE MOD_Vars_TimeInvariants + USE MOD_Vars_TimeVariables + + USE MOD_Vars_Global + USE MOD_Const_LC #if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) - USE MOD_LandPFT - USE MOD_Vars_PFTimeVariables + USE MOD_LandPFT + USE MOD_Vars_PFTimeVariables #endif #ifdef SinglePoint - USE MOD_SingleSrfdata + USE MOD_SingleSrfdata #endif - IMPLICIT NONE + IMPLICIT NONE - integer, INTENT(in) :: year, time - character(LEN=256), INTENT(in) :: dir_landdata + integer, intent(in) :: year, time + character(LEN=256), intent(in) :: dir_landdata - ! Local variables - integer :: iyear, itime - character(LEN=256) :: cyear, ctime - character(LEN=256) :: landdir, lndname - integer :: m, npatch, pc + ! Local variables + integer :: iyear, itime + character(LEN=256) :: cyear, ctime + character(LEN=256) :: landdir, lndname + integer :: m, npatch, pc #ifdef LULC_USGS - real(r8), dimension(24), parameter :: & ! Maximum fractional cover of vegetation [-] - vegc=(/1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, & - 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 0.0, & - 1.0, 1.0, 0.0, 1.0, 1.0, 1.0, 0.0, 0.0 /) + real(r8), dimension(24), parameter :: & ! Maximum fractional cover of vegetation [-] + vegc=(/1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, & + 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 0.0, & + 1.0, 1.0, 0.0, 1.0, 1.0, 1.0, 0.0, 0.0 /) #endif ! READ in Leaf area index and stem area index @@ -93,32 +93,32 @@ SUBROUTINE LAI_readin (year, time, dir_landdata) write(ctime,'(i2.2)') time lndname = trim(landdir)//'/'//trim(cyear)//'/LAI_patches'//trim(ctime)//'.nc' - call ncio_read_vector (lndname, 'LAI_patches', landpatch, tlai) + CALL ncio_read_vector (lndname, 'LAI_patches', landpatch, tlai) lndname = trim(landdir)//'/'//trim(cyear)//'/SAI_patches'//trim(ctime)//'.nc' - call ncio_read_vector (lndname, 'SAI_patches', landpatch, tsai) + CALL ncio_read_vector (lndname, 'SAI_patches', landpatch, tsai) ELSE write(cyear,'(i4.4)') year write(ctime,'(i3.3)') time lndname = trim(landdir)//'/'//trim(cyear)//'/LAI_patches'//trim(ctime)//'.nc' - call ncio_read_vector (lndname, 'LAI_patches', landpatch, tlai) + CALL ncio_read_vector (lndname, 'LAI_patches', landpatch, tlai) ENDIF #endif - if (p_is_worker) then - if (numpatch > 0) then + IF (p_is_worker) THEN + IF (numpatch > 0) THEN - do npatch = 1, numpatch + DO npatch = 1, numpatch m = patchclass(npatch) #ifdef URBAN_MODEL IF(m == URBAN) CYCLE #endif - if( m == 0 )then + IF( m == 0 )THEN fveg(npatch) = 0. tlai(npatch) = 0. tsai(npatch) = 0. green(npatch) = 0. - else + ELSE fveg(npatch) = fveg0(m) !fraction of veg. cover IF (fveg0(m) > 0) THEN tlai(npatch) = tlai(npatch)/fveg0(m) !leaf area index @@ -133,8 +133,8 @@ SUBROUTINE LAI_readin (year, time, dir_landdata) tsai(npatch) = 0. green(npatch) = 0. ENDIF - endif - end do + ENDIF + ENDDO ENDIF ENDIF @@ -166,22 +166,22 @@ SUBROUTINE LAI_readin (year, time, dir_landdata) write(ctime,'(i2.2)') time IF (.not. DEF_USE_LAIFEEDBACK)THEN lndname = trim(landdir)//'/'//trim(cyear)//'/LAI_patches'//trim(ctime)//'.nc' - call ncio_read_vector (lndname, 'LAI_patches', landpatch, tlai ) - END IF + CALL ncio_read_vector (lndname, 'LAI_patches', landpatch, tlai ) + ENDIF lndname = trim(landdir)//'/'//trim(cyear)//'/SAI_patches'//trim(ctime)//'.nc' - call ncio_read_vector (lndname, 'SAI_patches', landpatch, tsai ) + CALL ncio_read_vector (lndname, 'SAI_patches', landpatch, tsai ) IF (.not. DEF_USE_LAIFEEDBACK)THEN lndname = trim(landdir)//'/'//trim(cyear)//'/LAI_pfts'//trim(ctime)//'.nc' - call ncio_read_vector (lndname, 'LAI_pfts', landpft, tlai_p ) - END IF + CALL ncio_read_vector (lndname, 'LAI_pfts', landpft, tlai_p ) + ENDIF lndname = trim(landdir)//'/'//trim(cyear)//'/SAI_pfts'//trim(ctime)//'.nc' - call ncio_read_vector (lndname, 'SAI_pfts', landpft, tsai_p ) + CALL ncio_read_vector (lndname, 'SAI_pfts', landpft, tsai_p ) #endif - if (p_is_worker) then - if (numpatch > 0) then - do npatch = 1, numpatch + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + DO npatch = 1, numpatch m = patchclass(npatch) #ifdef URBAN_MODEL @@ -191,7 +191,7 @@ SUBROUTINE LAI_readin (year, time, dir_landdata) green(npatch) = 1. fveg (npatch) = fveg0(m) - end do + ENDDO ENDIF ENDIF diff --git a/main/MOD_LeafTemperature.F90 b/main/MOD_LeafTemperature.F90 index 19a4da5f..09fe6326 100644 --- a/main/MOD_LeafTemperature.F90 +++ b/main/MOD_LeafTemperature.F90 @@ -89,35 +89,35 @@ SUBROUTINE LeafTemperature ( & ! make a proper update of um. !======================================================================= - USE MOD_Precision - USE MOD_Vars_Global - USE MOD_Const_Physical, only: vonkar, grav, hvap, cpair, stefnc, cpliq, cpice, tfrz - USE MOD_FrictionVelocity - USE MOD_CanopyLayerProfile - USE mod_namelist, only: DEF_USE_CBL_HEIGHT - USE MOD_TurbulenceLEddy - USE MOD_AssimStomataConductance - USE MOD_Vars_TimeInvariants, only: patchclass - USE MOD_Const_LC, only: z0mr, displar - USE MOD_PlantHydraulic, only :PlantHydraulicStress_twoleaf, getvegwp_twoleaf - USE MOD_Ozone, only: CalcOzoneStress - USE MOD_Qsadv - - IMPLICIT NONE + USE MOD_Precision + USE MOD_Vars_Global + USE MOD_Const_Physical, only: vonkar, grav, hvap, cpair, stefnc, cpliq, cpice, tfrz + USE MOD_FrictionVelocity + USE MOD_CanopyLayerProfile + USE mod_namelist, only: DEF_USE_CBL_HEIGHT + USE MOD_TurbulenceLEddy + USE MOD_AssimStomataConductance + USE MOD_Vars_TimeInvariants, only: patchclass + USE MOD_Const_LC, only: z0mr, displar + USE MOD_PlantHydraulic, only :PlantHydraulicStress_twoleaf, getvegwp_twoleaf + USE MOD_Ozone, only: CalcOzoneStress + USE MOD_Qsadv + + IMPLICIT NONE !-----------------------Arguments--------------------------------------- - integer, intent(in) :: ipatch,ivt - real(r8), intent(in) :: & + integer, intent(in) :: ipatch,ivt + real(r8), intent(in) :: & deltim, &! seconds in a time step [second] csoilc, &! drag coefficient for soil under canopy [-] dewmx, &! maximum dew htvp ! latent heat of evaporation (/sublimation) [J/kg] ! vegetation parameters - real(r8), intent(inout) :: & + real(r8), intent(inout) :: & sai ! stem area index [-] - real(r8), intent(in) :: & + real(r8), intent(in) :: & sqrtdi, &! inverse sqrt of leaf dimension [m**-0.5] htop, &! PFT crown top height [m] hbot, &! PFT crown bot height [m] @@ -137,7 +137,7 @@ SUBROUTINE LeafTemperature ( & gradm, &! conductance-photosynthesis slope parameter binter, &! conductance-photosynthesis intercept extkn ! coefficient of leaf nitrogen allocation - real(r8), intent(in) :: & ! for plant hydraulic scheme + real(r8), intent(in) :: & ! for plant hydraulic scheme kmax_sun, &! Plant Hydraulics Paramters kmax_sha, &! Plant Hydraulics Paramters kmax_xyl, &! Plant Hydraulics Paramters @@ -147,13 +147,13 @@ SUBROUTINE LeafTemperature ( & psi50_xyl, &! water potential at 50% loss of xylem tissue conductance (mmH2O) psi50_root, &! water potential at 50% loss of root tissue conductance (mmH2O) ck ! shape-fitting parameter for vulnerability curve (-) - real(r8), intent(inout) :: & + real(r8), intent(inout) :: & vegwp(1:nvegwcs),&! vegetation water potential gs0sun, &! maximum stomata conductance of sunlit leaf gs0sha ! maximum stomata conductance of shaded leaf ! input variables - real(r8), intent(in) :: & + real(r8), intent(in) :: & hu, &! observational height of wind [m] ht, &! observational height of temperature [m] hq, &! observational height of humidity [m] @@ -199,7 +199,7 @@ SUBROUTINE LeafTemperature ( & rss, &! soil surface resistance [s/m] emg ! vegetation emissivity - real(r8), intent(in) :: & + real(r8), intent(in) :: & t_precip, &! snowfall/rainfall temperature [kelvin] qintr_rain, &! rainfall interception (mm h2o/s) qintr_snow, &! snowfall interception (mm h2o/s) @@ -207,10 +207,10 @@ SUBROUTINE LeafTemperature ( & rootfr (1:nl_soil), &! root fraction hksati (1:nl_soil), &! hydraulic conductivity at saturation [mm h2o/s] hk (1:nl_soil) ! soil hydraulic conducatance - real(r8), intent(in) :: & + real(r8), intent(in) :: & hpbl ! atmospheric boundary layer height [m] - real(r8), intent(inout) :: & + real(r8), intent(inout) :: & tl, &! leaf temperature [K] ldew, &! depth of water on foliage [mm] ldew_rain, &! depth of rain on foliage [mm] @@ -241,13 +241,13 @@ SUBROUTINE LeafTemperature ( & gssha, &! stomata conductance of shaded leaf rootflux(1:nl_soil) ! root water uptake from different layers - real(r8), intent(inout) :: & + real(r8), intent(inout) :: & assimsun, &! sunlit leaf assimilation rate [umol co2 /m**2/ s] [+] etrsun, &! transpiration rate of sunlit leaf [mm/s] assimsha, &! shaded leaf assimilation rate [umol co2 /m**2/ s] [+] etrsha ! transpiration rate of shaded leaf [mm/s] - real(r8), intent(out) :: & + real(r8), intent(out) :: & rst, &! stomatal resistance assim, &! rate of assimilation respc, &! rate of respiration @@ -395,159 +395,159 @@ SUBROUTINE LeafTemperature ( & !-----------------------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) = 0. - fevpl_bef = 0. + dtl(0) = 0. + fevpl_bef = 0. - fht = 0. !integral of profile function for heat - fqt = 0. !integral of profile function for moisture + fht = 0. !integral of profile function for heat + fqt = 0. !integral of profile function for moisture !----------------------------------------------------------------------- ! scaling-up coefficients from leaf to canopy !----------------------------------------------------------------------- - fsha = 1. -fsun - laisun = lai*fsun - laisha = lai*fsha + fsha = 1. -fsun + laisun = lai*fsun + laisha = lai*fsha ! scaling-up coefficients from leaf to canopy - cintsun(1) = (1.-exp(-(0.110+extkb)*lai))/(0.110+extkb) - cintsun(2) = (1.-exp(-(extkb+extkd)*lai))/(extkb+extkd) - cintsun(3) = (1.-exp(-extkb*lai))/extkb + cintsun(1) = (1.-exp(-(0.110+extkb)*lai))/(0.110+extkb) + cintsun(2) = (1.-exp(-(extkb+extkd)*lai))/(extkb+extkd) + cintsun(3) = (1.-exp(-extkb*lai))/extkb - cintsha(1) = (1.-exp(-0.110*lai))/0.110 - cintsun(1) - cintsha(2) = (1.-exp(-extkd*lai))/extkd - cintsun(2) - cintsha(3) = lai - cintsun(3) + cintsha(1) = (1.-exp(-0.110*lai))/0.110 - cintsun(1) + cintsha(2) = (1.-exp(-extkd*lai))/extkd - cintsun(2) + cintsha(3) = lai - cintsun(3) !----------------------------------------------------------------------- ! get fraction of wet and dry canopy surface (fwet & fdry) ! initial saturated vapor pressure and humidity and their derivation !----------------------------------------------------------------------- - !clai = 4.2 * 1000. * 0.2 - clai = 0.0 + !clai = 4.2 * 1000. * 0.2 + clai = 0.0 - CALL dewfraction (sigf,lai,sai,dewmx,ldew,ldew_rain,ldew_snow,fwet,fdry) + CALL dewfraction (sigf,lai,sai,dewmx,ldew,ldew_rain,ldew_snow,fwet,fdry) - CALL qsadv(tl,psrf,ei,deiDT,qsatl,qsatlDT) + CALL qsadv(tl,psrf,ei,deiDT,qsatl,qsatlDT) !----------------------------------------------------------------------- ! 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_*) - z0mg = (1.-fsno)*zlnd + fsno*zsno - z0hg = z0mg - z0qg = z0mg + 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_*) + z0mg = (1.-fsno)*zlnd + fsno*zsno + z0hg = z0mg + z0qg = z0mg - z0m = htop * z0mr(patchclass(ipatch)) - displa = htop * displar(patchclass(ipatch)) + z0m = htop * z0mr(patchclass(ipatch)) + displa = htop * displar(patchclass(ipatch)) - z0mv = z0m; z0hv = z0m; z0qv = z0m + z0mv = z0m; z0hv = z0m; z0qv = z0m - ! Modify aerodynamic parameters for sparse/dense canopy (X. Zeng) - lt = min(lai+sai, 2.) - egvf = (1._r8 - exp(-lt)) / (1._r8 - exp(-2.)) - displa = egvf * displa - z0mv = exp(egvf * log(z0mv) + (1._r8 - egvf) * log(z0mg)) + ! Modify aerodynamic parameters for sparse/dense canopy (X. Zeng) + lt = min(lai+sai, 2.) + egvf = (1._r8 - exp(-lt)) / (1._r8 - exp(-2.)) + displa = egvf * displa + z0mv = exp(egvf * log(z0mv) + (1._r8 - egvf) * log(z0mg)) - z0hv = z0mv - z0qv = z0mv + z0hv = z0mv + z0qv = z0mv ! 10/17/2017, yuan: z0m and displa with vertical profile solution - IF (zd_opt == 3) THEN + IF (zd_opt == 3) THEN - CALL cal_z0_displa(lai+sai, htop, 1., z0mv, displa) + CALL cal_z0_displa(lai+sai, htop, 1., z0mv, displa) - ! NOTE: adjusted for samll displa - displasink = max(htop/2., displa) - hsink = z0mv + displasink + ! NOTE: adjusted for samll displa + displasink = max(htop/2., displa) + hsink = z0mv + displasink - z0hv = z0mv - z0qv = z0mv + z0hv = z0mv + z0qv = z0mv - ENDIF + ENDIF - fai = 1. - exp(-0.5*(lai+sai)) - sqrtdragc = min( (0.003+0.3*fai)**0.5, 0.3 ) + fai = 1. - exp(-0.5*(lai+sai)) + sqrtdragc = min( (0.003+0.3*fai)**0.5, 0.3 ) - a_k71 = htop/(htop-displa)/(vonkar/sqrtdragc) + a_k71 = htop/(htop-displa)/(vonkar/sqrtdragc) - taf = 0.5 * (tg + thm) - qaf = 0.5 * (qm + qg) + taf = 0.5 * (tg + thm) + qaf = 0.5 * (qm + qg) - 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 - ur = max(0.1, sqrt(us*us+vs*vs)) !limit set to 0.1 - dth = thm - taf - dqh = qm - qaf - dthv = dth*(1.+0.61*qm) + 0.61*th*dqh - zldis = hu - displa + ur = max(0.1, sqrt(us*us+vs*vs)) !limit set to 0.1 + dth = thm - taf + dqh = qm - qaf + dthv = dth*(1.+0.61*qm) + 0.61*th*dqh + zldis = hu - 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,z0mv,um,obu) + CALL moninobukini(ur,th,thm,thv,dth,dqh,dthv,zldis,z0mv,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 - IF (rd_opt == 3) THEN - IF (DEF_USE_CBL_HEIGHT) THEN - CALL moninobukm_leddy(hu,ht,hq,displa,z0mv,z0hv,z0qv,obu,um, & - displasink,z0mv,hpbl,ustar,fh2m,fq2m, & - htop,fmtop,fm,fh,fq,fht,fqt,phih) - ELSE - CALL moninobukm(hu,ht,hq,displa,z0mv,z0hv,z0qv,obu,um, & - displasink,z0mv,ustar,fh2m,fq2m, & - htop,fmtop,fm,fh,fq,fht,fqt,phih) - ENDIF - ! Aerodynamic resistance - ram = 1./(ustar*ustar/um) - rah = 1./(vonkar/(fh-fht)*ustar) - raw = 1./(vonkar/(fq-fqt)*ustar) - ELSE - IF (DEF_USE_CBL_HEIGHT) THEN - CALL moninobuk_leddy(hu,ht,hq,displa,z0mv,z0hv,z0qv,obu,um,hpbl, & - ustar,fh2m,fq2m,fm10m,fm,fh,fq) - ELSE - CALL moninobuk(hu,ht,hq,displa,z0mv,z0hv,z0qv,obu,um,& - ustar,fh2m,fq2m,fm10m,fm,fh,fq) - ENDIF - ! Aerodynamic resistance - ram = 1./(ustar*ustar/um) - rah = 1./(vonkar/fh*ustar) - raw = 1./(vonkar/fq*ustar) - ENDIF - - z0hg = z0mg/exp(0.13 * (ustar*z0mg/1.5e-5)**0.45) - z0qg = z0hg + IF (rd_opt == 3) THEN + IF (DEF_USE_CBL_HEIGHT) THEN + CALL moninobukm_leddy(hu,ht,hq,displa,z0mv,z0hv,z0qv,obu,um, & + displasink,z0mv,hpbl,ustar,fh2m,fq2m, & + htop,fmtop,fm,fh,fq,fht,fqt,phih) + ELSE + CALL moninobukm(hu,ht,hq,displa,z0mv,z0hv,z0qv,obu,um, & + displasink,z0mv,ustar,fh2m,fq2m, & + htop,fmtop,fm,fh,fq,fht,fqt,phih) + ENDIF + ! Aerodynamic resistance + ram = 1./(ustar*ustar/um) + rah = 1./(vonkar/(fh-fht)*ustar) + raw = 1./(vonkar/(fq-fqt)*ustar) + ELSE + IF (DEF_USE_CBL_HEIGHT) THEN + CALL moninobuk_leddy(hu,ht,hq,displa,z0mv,z0hv,z0qv,obu,um,hpbl, & + ustar,fh2m,fq2m,fm10m,fm,fh,fq) + ELSE + CALL moninobuk(hu,ht,hq,displa,z0mv,z0hv,z0qv,obu,um,& + ustar,fh2m,fq2m,fm10m,fm,fh,fq) + ENDIF + ! Aerodynamic resistance + ram = 1./(ustar*ustar/um) + rah = 1./(vonkar/fh*ustar) + raw = 1./(vonkar/fq*ustar) + ENDIF + + z0hg = z0mg/exp(0.13 * (ustar*z0mg/1.5e-5)**0.45) + z0qg = z0hg ! Bulk boundary layer resistance of leaves uaf = ustar @@ -556,579 +556,579 @@ SUBROUTINE LeafTemperature ( & ! 11/17/2017, yuan: 3D rb calculation (with vertical profile consideration) ! 03/13/2020, yuan: added analytical solution - IF (rb_opt == 3) THEN - utop = ustar/vonkar * fmtop - ueff = ueffect(utop, htop, z0mg, z0mg, a_k71, 1._r8, 1._r8) - cf = 0.01*sqrtdi*sqrt(ueff) - rb = 1./cf - ENDIF - -! rd = 1./(csoilc*uaf) ! BATS legacy -! w = exp(-0.5*(lai+sai)) ! Dickinson's modification : -! csoilc = ( 1.-w + w*um/uaf)/rah ! "rah" here is the resistance over -! rd = 1./(csoilc*uaf) ! bare ground fraction + IF (rb_opt == 3) THEN + utop = ustar/vonkar * fmtop + ueff = ueffect(utop, htop, z0mg, z0mg, a_k71, 1._r8, 1._r8) + cf = 0.01*sqrtdi*sqrt(ueff) + rb = 1./cf + ENDIF + +! rd = 1./(csoilc*uaf) ! BATS legacy +! w = exp(-0.5*(lai+sai)) ! Dickinson's modification : +! csoilc = ( 1.-w + w*um/uaf)/rah ! "rah" here is the resistance over +! rd = 1./(csoilc*uaf) ! bare ground fraction ! modified by Xubin Zeng's suggestion at 08-07-2002 - w = exp(-(lai+sai)) - csoilcn = (vonkar/(0.13*(z0mg*uaf/1.5e-5)**0.45))*w + csoilc*(1.-w) - rd = 1./(csoilcn*uaf) + w = exp(-(lai+sai)) + csoilcn = (vonkar/(0.13*(z0mg*uaf/1.5e-5)**0.45))*w + csoilc*(1.-w) + rd = 1./(csoilcn*uaf) ! 11/17/2017, yuan: 3D rd calculation with vertical profile solution ! 03/13/2020, yuan: added analytical solution - IF (rd_opt == 3) THEN - ktop = vonkar * (htop-displa) * ustar / phih - rd = frd(ktop, htop, z0qg, hsink, z0qg, displa/htop, & - z0qg, obug, ustar, z0mg, a_k71, 1._r8, 1._r8) - ENDIF + IF (rd_opt == 3) THEN + ktop = vonkar * (htop-displa) * ustar / phih + rd = frd(ktop, htop, z0qg, hsink, z0qg, displa/htop, & + z0qg, obug, ustar, z0mg, a_k71, 1._r8, 1._r8) + ENDIF !----------------------------------------------------------------------- ! stomatal resistances !----------------------------------------------------------------------- - IF(lai .gt. 0.001) THEN - - eah = qaf * psrf / ( 0.622 + 0.378 * qaf ) !pa - - ! If use PHS, calculate maximum stomata conductance (minimum stomata resistance) - ! by setting rstfac = 1. (no water stress). When use PHS, stomata only calculate - ! non-stress stomata conductance, assimilation rate and leaf respiration - IF (DEF_USE_PLANTHYDRAULICS) THEN - rstfacsun = 1. - rstfacsha = 1. - ENDIF - - ! leaf to canopy level - rbsun = rb / laisun - rbsha = rb / laisha - - ! Sunlit leaves - CALL stomata (vmax25 ,effcon ,slti ,hlti ,& - shti ,hhti ,trda ,trdm ,trop ,& - g1 ,g0 ,gradm ,binter ,thm ,& - psrf ,po2m ,pco2m ,pco2a ,eah ,& - ei ,tl ,parsun ,& - !Ozone stress variables - o3coefv_sun ,o3coefg_sun ,& - !End ozone stress variables - rbsun ,raw ,rstfacsun,cintsun ,& - assimsun ,respcsun ,rssun ) - - ! Shaded leaves - CALL stomata (vmax25 ,effcon ,slti ,hlti ,& - shti ,hhti ,trda ,trdm ,trop ,& - g1 ,g0 ,gradm ,binter ,thm ,& - psrf ,po2m ,pco2m ,pco2a ,eah ,& - ei ,tl ,parsha ,& - ! Ozone stress variables - o3coefv_sha ,o3coefg_sha ,& - ! End ozone stress variables - rbsha ,raw ,rstfacsha,cintsha ,& - assimsha ,respcsha ,rssha ) - - IF (DEF_USE_PLANTHYDRAULICS) THEN - - gs0sun = min( 1.e6, 1./(rssun*tl/tprcor) )/ laisun * 1.e6 - gs0sha = min( 1.e6, 1./(rssha*tl/tprcor) )/ laisha * 1.e6 - - sai = amax1(sai,0.1) - ! PHS update actual stomata conductance (resistance), assimilation rate - ! and leaf respiration. above stomatal resistances are for the canopy, - ! the stomatal rsistances and the "rb" in the following calculations are - ! the average for single leaf. thus, - CALL PlantHydraulicStress_twoleaf ( nl_soil ,nvegwcs ,& - z_soi ,dz_soi ,rootfr ,psrf ,qsatl ,& - qaf ,tl ,rb ,rss ,raw ,& - rd ,rstfacsun ,rstfacsha ,cintsun ,cintsha ,& - laisun ,laisha ,rhoair ,fwet ,sai ,& - kmax_sun ,kmax_sha ,kmax_xyl ,kmax_root ,psi50_sun ,& - psi50_sha ,psi50_xyl ,psi50_root ,htop ,ck ,& - smp ,hk ,hksati ,vegwp ,etrsun ,& - etrsha ,rootflux ,qg ,qm ,gs0sun ,& - gs0sha ,k_soil_root,k_ax_root ,gssun ,gssha ) - - etr = etrsun + etrsha - gssun = gssun * laisun - gssha = gssha * laisha - - call update_photosyn(tl, po2m, pco2m, pco2a, parsun, psrf, rstfacsun, rb, gssun, & - effcon, vmax25, gradm, trop, slti, hlti, shti, hhti, trda, trdm, cintsun, & - assimsun, respcsun) - - CALL update_photosyn(tl, po2m, pco2m, pco2a, parsha, psrf, rstfacsha, rb, gssha, & - effcon, vmax25, gradm, trop, slti, hlti, shti, hhti, trda, trdm, cintsha, & - assimsha, respcsha) - - rssun = tprcor/tl * 1.e6 / gssun - rssha = tprcor/tl * 1.e6 / gssha - ENDIF - - ELSE - rssun = 2.e20; assimsun = 0.; respcsun = 0. - rssha = 2.e20; assimsha = 0.; respcsha = 0. - gssun = 0._r8 - gssha = 0._r8 - - ! 07/2023, yuan: a bug for imbalanced water, rootflux only change - ! in DEF_USE_PLANTHYDRAULICS case in this routine. - IF (DEF_USE_PLANTHYDRAULICS) THEN - etr = 0. - etrsun = 0._r8 - etrsha = 0._r8 - rootflux = 0. - ENDIF - ENDIF + IF(lai .gt. 0.001) THEN + + eah = qaf * psrf / ( 0.622 + 0.378 * qaf ) !pa + + ! If use PHS, calculate maximum stomata conductance (minimum stomata resistance) + ! by setting rstfac = 1. (no water stress). When use PHS, stomata only calculate + ! non-stress stomata conductance, assimilation rate and leaf respiration + IF (DEF_USE_PLANTHYDRAULICS) THEN + rstfacsun = 1. + rstfacsha = 1. + ENDIF + + ! leaf to canopy level + rbsun = rb / laisun + rbsha = rb / laisha + + ! Sunlit leaves + CALL stomata (vmax25 ,effcon ,slti ,hlti ,& + shti ,hhti ,trda ,trdm ,trop ,& + g1 ,g0 ,gradm ,binter ,thm ,& + psrf ,po2m ,pco2m ,pco2a ,eah ,& + ei ,tl ,parsun ,& + !Ozone stress variables + o3coefv_sun ,o3coefg_sun ,& + !End ozone stress variables + rbsun ,raw ,rstfacsun,cintsun ,& + assimsun ,respcsun ,rssun ) + + ! Shaded leaves + CALL stomata (vmax25 ,effcon ,slti ,hlti ,& + shti ,hhti ,trda ,trdm ,trop ,& + g1 ,g0 ,gradm ,binter ,thm ,& + psrf ,po2m ,pco2m ,pco2a ,eah ,& + ei ,tl ,parsha ,& + ! Ozone stress variables + o3coefv_sha ,o3coefg_sha ,& + ! End ozone stress variables + rbsha ,raw ,rstfacsha,cintsha ,& + assimsha ,respcsha ,rssha ) + + IF (DEF_USE_PLANTHYDRAULICS) THEN + + gs0sun = min( 1.e6, 1./(rssun*tl/tprcor) )/ laisun * 1.e6 + gs0sha = min( 1.e6, 1./(rssha*tl/tprcor) )/ laisha * 1.e6 + + sai = amax1(sai,0.1) + ! PHS update actual stomata conductance (resistance), assimilation rate + ! and leaf respiration. above stomatal resistances are for the canopy, + ! the stomatal rsistances and the "rb" in the following calculations are + ! the average for single leaf. thus, + CALL PlantHydraulicStress_twoleaf ( nl_soil ,nvegwcs ,& + z_soi ,dz_soi ,rootfr ,psrf ,qsatl ,& + qaf ,tl ,rb ,rss ,raw ,& + rd ,rstfacsun ,rstfacsha ,cintsun ,cintsha ,& + laisun ,laisha ,rhoair ,fwet ,sai ,& + kmax_sun ,kmax_sha ,kmax_xyl ,kmax_root ,psi50_sun ,& + psi50_sha ,psi50_xyl ,psi50_root ,htop ,ck ,& + smp ,hk ,hksati ,vegwp ,etrsun ,& + etrsha ,rootflux ,qg ,qm ,gs0sun ,& + gs0sha ,k_soil_root,k_ax_root ,gssun ,gssha ) + + etr = etrsun + etrsha + gssun = gssun * laisun + gssha = gssha * laisha + + CALL update_photosyn(tl, po2m, pco2m, pco2a, parsun, psrf, rstfacsun, rb, gssun, & + effcon, vmax25, gradm, trop, slti, hlti, shti, hhti, trda, trdm, cintsun, & + assimsun, respcsun) + + CALL update_photosyn(tl, po2m, pco2m, pco2a, parsha, psrf, rstfacsha, rb, gssha, & + effcon, vmax25, gradm, trop, slti, hlti, shti, hhti, trda, trdm, cintsha, & + assimsha, respcsha) + + rssun = tprcor/tl * 1.e6 / gssun + rssha = tprcor/tl * 1.e6 / gssha + ENDIF + + ELSE + rssun = 2.e20; assimsun = 0.; respcsun = 0. + rssha = 2.e20; assimsha = 0.; respcsha = 0. + gssun = 0._r8 + gssha = 0._r8 + + ! 07/2023, yuan: a bug for imbalanced water, rootflux only change + ! in DEF_USE_PLANTHYDRAULICS case in this routine. + IF (DEF_USE_PLANTHYDRAULICS) THEN + etr = 0. + etrsun = 0._r8 + etrsha = 0._r8 + rootflux = 0. + ENDIF + 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, - rssun = rssun * laisun - rssha = rssha * laisha + rssun = rssun * laisun + rssha = rssha * laisha !----------------------------------------------------------------------- ! dimensional and non-dimensional sensible and latent heat conductances ! for canopy and soil flux calculations. !----------------------------------------------------------------------- - delta = 0.0 - IF(qsatl-qaf .gt. 0.) delta = 1.0 - - cah = 1. / rah - cgh = 1. / rd - cfh = (lai + sai) / rb - - caw = 1. / raw - IF (qg < qaf) THEN - cgw = 1. / rd !dew case. no soil resistance - ELSE - IF (DEF_RSS_SCHEME .eq. 4) THEN - cgw = rss / rd - ELSE - cgw = 1. / (rd + rss) - ENDIF - ENDIF - cfw = (1.-delta*(1.-fwet))*(lai+sai)/rb + (1.-fwet)*delta* & - ( laisun/(rb+rssun) + laisha/(rb+rssha) ) - - wtshi = 1. / ( cah + cgh + cfh ) - wtsqi = 1. / ( caw + cgw + cfw ) - - wta0 = cah * wtshi - wtg0 = cgh * wtshi - wtl0 = cfh * wtshi - - wtaq0 = caw * wtsqi - wtgq0 = cgw * wtsqi - wtlq0 = cfw * wtsqi + delta = 0.0 + IF(qsatl-qaf .gt. 0.) delta = 1.0 + + cah = 1. / rah + cgh = 1. / rd + cfh = (lai + sai) / rb + + caw = 1. / raw + IF (qg < qaf) THEN + cgw = 1. / rd !dew case. no soil resistance + ELSE + IF (DEF_RSS_SCHEME .eq. 4) THEN + cgw = rss / rd + ELSE + cgw = 1. / (rd + rss) + ENDIF + ENDIF + cfw = (1.-delta*(1.-fwet))*(lai+sai)/rb + (1.-fwet)*delta* & + ( laisun/(rb+rssun) + laisha/(rb+rssha) ) + + wtshi = 1. / ( cah + cgh + cfh ) + wtsqi = 1. / ( caw + cgw + cfw ) + + wta0 = cah * wtshi + wtg0 = cgh * wtshi + wtl0 = cfh * wtshi + + wtaq0 = caw * wtsqi + wtgq0 = cgw * wtsqi + wtlq0 = cfw * wtsqi !----------------------------------------------------------------------- ! IR radiation, sensible and latent heat fluxes and their derivatives !----------------------------------------------------------------------- ! the partial derivatives of areodynamical resistance are ignored ! which cannot be determined analtically - fac = 1. - thermk + fac = 1. - thermk ! longwave absorption and their derivatives - ! 10/16/2017, yuan: added reflected longwave by the ground + ! 10/16/2017, yuan: added reflected longwave by the ground IF (.not.DEF_SPLIT_SOILSNOW) THEN - irab = (frl - 2. * stefnc * tl**4 + emg*stefnc*tg**4 ) * fac & - + (1-emg)*thermk*fac*frl + (1-emg)*(1-thermk)*fac*stefnc*tl**4 + irab = (frl - 2. * stefnc * tl**4 + emg*stefnc*tg**4 ) * fac & + + (1-emg)*thermk*fac*frl + (1-emg)*(1-thermk)*fac*stefnc*tl**4 ELSE - irab = (frl - 2. * stefnc * tl**4 & - + (1.-fsno)*emg*stefnc*t_soil**4 & - + fsno*emg*stefnc*t_snow**4 ) * fac & - + (1-emg)*thermk*fac*frl + (1-emg)*(1-thermk)*fac*stefnc*tl**4 + irab = (frl - 2. * stefnc * tl**4 & + + (1.-fsno)*emg*stefnc*t_soil**4 & + + fsno*emg*stefnc*t_snow**4 ) * fac & + + (1-emg)*thermk*fac*frl + (1-emg)*(1-thermk)*fac*stefnc*tl**4 ENDIF - dirab_dtl = - 8. * stefnc * tl**3 * fac & - + 4.*(1-emg)*(1-thermk)*fac*stefnc*tl**3 + dirab_dtl = - 8. * stefnc * tl**3 * fac & + + 4.*(1-emg)*(1-thermk)*fac*stefnc*tl**3 ! sensible heat fluxes and their derivatives - fsenl = rhoair * cpair * cfh * ( (wta0 + wtg0)*tl - wta0*thm - wtg0*tg ) - fsenl_dtl = rhoair * cpair * cfh * (wta0 + wtg0) + fsenl = rhoair * cpair * cfh * ( (wta0 + wtg0)*tl - wta0*thm - wtg0*tg ) + fsenl_dtl = rhoair * cpair * cfh * (wta0 + wtg0) ! latent heat fluxes and their derivatives - etr = rhoair * (1.-fwet) * delta & - * ( laisun/(rb+rssun) + laisha/(rb+rssha) ) & - * ( (wtaq0 + wtgq0)*qsatl - wtaq0*qm - wtgq0*qg ) - - etrsun = rhoair * (1.-fwet) * delta & - * ( laisun/(rb+rssun) ) * ( (wtaq0 + wtgq0)*qsatl - wtaq0*qm - wtgq0*qg ) - etrsha = rhoair * (1.-fwet) * delta & - * ( laisha/(rb+rssha) ) * ( (wtaq0 + wtgq0)*qsatl - wtaq0*qm - wtgq0*qg ) - - etr_dtl = rhoair * (1.-fwet) * delta & - * ( laisun/(rb+rssun) + laisha/(rb+rssha) ) & - * (wtaq0 + wtgq0)*qsatlDT - - IF (.not. DEF_USE_PLANTHYDRAULICS) THEN - IF(etr.ge.etrc)THEN - etr = etrc - etr_dtl = 0. - ENDIF - ELSE - IF(rstfacsun .lt. 1.e-2 .or. etrsun .le. 0.)etrsun = 0._r8 - IF(rstfacsha .lt. 1.e-2 .or. etrsha .le. 0.)etrsha = 0._r8 - etr = etrsun + etrsha - IF(abs(etr - sum(rootflux)) .gt. 1.e-7)THEN - write(6,*) 'Warning: water balance violation in vegetation PHS', & - ipatch,p_iam_glb, etr, sum(rootflux), abs(etr-sum(rootflux)) - CALL CoLM_stop() - ENDIF - ENDIF - - evplwet = rhoair * (1.-delta*(1.-fwet)) * (lai+sai) / rb & - * ( (wtaq0 + wtgq0)*qsatl - wtaq0*qm - wtgq0*qg ) - evplwet_dtl = rhoair * (1.-delta*(1.-fwet)) * (lai+sai) / rb & - * (wtaq0 + wtgq0)*qsatlDT - - IF(evplwet.ge.ldew/deltim)THEN - evplwet = ldew/deltim - evplwet_dtl = 0. - ENDIF - - fevpl = etr + evplwet - fevpl_dtl = etr_dtl + evplwet_dtl - - ! 07/09/2014, yuan: added for energy balance - 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 & + * ( laisun/(rb+rssun) + laisha/(rb+rssha) ) & + * ( (wtaq0 + wtgq0)*qsatl - wtaq0*qm - wtgq0*qg ) + + etrsun = rhoair * (1.-fwet) * delta & + * ( laisun/(rb+rssun) ) * ( (wtaq0 + wtgq0)*qsatl - wtaq0*qm - wtgq0*qg ) + etrsha = rhoair * (1.-fwet) * delta & + * ( laisha/(rb+rssha) ) * ( (wtaq0 + wtgq0)*qsatl - wtaq0*qm - wtgq0*qg ) + + etr_dtl = rhoair * (1.-fwet) * delta & + * ( laisun/(rb+rssun) + laisha/(rb+rssha) ) & + * (wtaq0 + wtgq0)*qsatlDT + + IF (.not. DEF_USE_PLANTHYDRAULICS) THEN + IF(etr.ge.etrc)THEN + etr = etrc + etr_dtl = 0. + ENDIF + ELSE + IF(rstfacsun .lt. 1.e-2 .or. etrsun .le. 0.)etrsun = 0._r8 + IF(rstfacsha .lt. 1.e-2 .or. etrsha .le. 0.)etrsha = 0._r8 + etr = etrsun + etrsha + IF(abs(etr - sum(rootflux)) .gt. 1.e-7)THEN + write(6,*) 'Warning: water balance violation in vegetation PHS', & + ipatch,p_iam_glb, etr, sum(rootflux), abs(etr-sum(rootflux)) + CALL CoLM_stop() + ENDIF + ENDIF + + evplwet = rhoair * (1.-delta*(1.-fwet)) * (lai+sai) / rb & + * ( (wtaq0 + wtgq0)*qsatl - wtaq0*qm - wtgq0*qg ) + evplwet_dtl = rhoair * (1.-delta*(1.-fwet)) * (lai+sai) / rb & + * (wtaq0 + wtgq0)*qsatlDT + + IF(evplwet.ge.ldew/deltim)THEN + evplwet = ldew/deltim + evplwet_dtl = 0. + ENDIF + + fevpl = etr + evplwet + fevpl_dtl = etr_dtl + evplwet_dtl + + ! 07/09/2014, yuan: added for energy balance + 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 !----------------------------------------------------------------------- - dtl(it) = (sabv + irab - fsenl - hvap*fevpl & - + cpliq*qintr_rain*(t_precip-tl) + cpice*qintr_snow*(t_precip-tl)) & - / ((lai+sai)*clai/deltim - dirab_dtl + fsenl_dtl + hvap*fevpl_dtl & - + cpliq*qintr_rain + cpice*qintr_snow) + dtl(it) = (sabv + irab - fsenl - hvap*fevpl & + + cpliq*qintr_rain*(t_precip-tl) + cpice*qintr_snow*(t_precip-tl)) & + / ((lai+sai)*clai/deltim - dirab_dtl + fsenl_dtl + hvap*fevpl_dtl & + + cpliq*qintr_rain + cpice*qintr_snow) - dtl_noadj = dtl(it) + 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 - ! 06/12/2014, yuan: .lt. -> .le. - IF(it .le. itmax) THEN + ! 06/12/2014, yuan: .lt. -> .le. + 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 - ! 06/12/2014, yuan: .lt. -> .le. - ! NOTE: could be a bug IF dtl*dtl==0, changed from lt->le - IF((it.ge.2) .and. (dtl(it-1)*dtl(it).le.0.))THEN - dtl(it) = 0.5*(dtl(it-1) + dtl(it)) - ENDIF + ! 06/12/2014, yuan: .lt. -> .le. + ! NOTE: could be a bug IF dtl*dtl==0, changed from lt->le + 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) + tl = tlbef + dtl(it) !----------------------------------------------------------------------- ! 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(tl,psrf,ei,deiDT,qsatl,qsatlDT) + CALL qsadv(tl,psrf,ei,deiDT,qsatl,qsatlDT) ! update vegetation/ground surface temperature, canopy air temperature, ! canopy air humidity - taf = wta0*thm + wtg0*tg + wtl0*tl - qaf = wtaq0*qm + wtgq0*qg + wtlq0*qsatl + taf = wta0*thm + wtg0*tg + wtl0*tl + qaf = wtaq0*qm + wtgq0*qg + wtlq0*qsatl ! update co2 partial pressure within canopy air - gah2o = 1.0/raw * tprcor/thm !mol m-2 s-1 - IF (DEF_RSS_SCHEME .eq. 4) THEN - gdh2o = rss/rd * tprcor/thm !mol m-2 s-1 - ELSE - gdh2o = 1.0/(rd+rss) * tprcor/thm !mol m-2 s-1 - ENDIF - pco2a = pco2m - 1.37*psrf/max(0.446,gah2o) * & - (assimsun + assimsha - respcsun -respcsha - rsoil) + gah2o = 1.0/raw * tprcor/thm !mol m-2 s-1 + IF (DEF_RSS_SCHEME .eq. 4) THEN + gdh2o = rss/rd * tprcor/thm !mol m-2 s-1 + ELSE + gdh2o = 1.0/(rd+rss) * tprcor/thm !mol m-2 s-1 + ENDIF + pco2a = pco2m - 1.37*psrf/max(0.446,gah2o) * & + (assimsun + assimsha - respcsun -respcsha - rsoil) !----------------------------------------------------------------------- ! Update monin-obukhov length and wind speed including the stability effect !----------------------------------------------------------------------- - dth = thm - taf - dqh = qm - qaf - - tstar = vonkar/(fh-fht)*dth - qstar = vonkar/(fq-fqt)*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 - - IF(zeta .ge. 0.)THEN - um = max(ur,.1) - ELSE - IF (DEF_USE_CBL_HEIGHT) THEN !//TODO: Shaofeng, 2023.05.18 - zii = max(5.*hu,hpbl) - ENDIF !//TODO: Shaofeng, 2023.05.18 - 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 + dth = thm - taf + dqh = qm - qaf + + tstar = vonkar/(fh-fht)*dth + qstar = vonkar/(fq-fqt)*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 + + IF(zeta .ge. 0.)THEN + um = max(ur,.1) + ELSE + IF (DEF_USE_CBL_HEIGHT) THEN !//TODO: Shaofeng, 2023.05.18 + zii = max(5.*hu,hpbl) + ENDIF !//TODO: Shaofeng, 2023.05.18 + 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 !----------------------------------------------------------------------- ! Test for convergence !----------------------------------------------------------------------- - it = it+1 - - IF(it .gt. itmin) THEN - fevpl_bef = fevpl - det = max(del,del2) - ! 10/03/2017, yuan: possible bugs here, solution: - ! define dee, change del => dee - dee = max(dele,dele2) - IF(det .lt. dtmin .and. dee .lt. dlemin) EXIT - ENDIF - - ENDDO - - IF(DEF_USE_OZONESTRESS)THEN - CALL CalcOzoneStress(o3coefv_sun,o3coefg_sun,forc_ozone,psrf,th,ram,& - rssun,rb,lai,lai_old,ivt,o3uptakesun,deltim) - CALL CalcOzoneStress(o3coefv_sha,o3coefg_sha,forc_ozone,psrf,th,ram,& - rssha,rb,lai,lai_old,ivt,o3uptakesha,deltim) - lai_old = lai - assimsun = assimsun * o3coefv_sun - assimsha = assimsha * o3coefv_sha - rssun = rssun / o3coefg_sun - rssha = rssha / o3coefg_sha - ENDIF + it = it+1 + + IF(it .gt. itmin) THEN + fevpl_bef = fevpl + det = max(del,del2) + ! 10/03/2017, yuan: possible bugs here, solution: + ! define dee, change del => dee + dee = max(dele,dele2) + IF(det .lt. dtmin .and. dee .lt. dlemin) EXIT + ENDIF + + ENDDO + + IF(DEF_USE_OZONESTRESS)THEN + CALL CalcOzoneStress(o3coefv_sun,o3coefg_sun,forc_ozone,psrf,th,ram,& + rssun,rb,lai,lai_old,ivt,o3uptakesun,deltim) + CALL CalcOzoneStress(o3coefv_sha,o3coefg_sha,forc_ozone,psrf,th,ram,& + rssha,rb,lai,lai_old,ivt,o3uptakesha,deltim) + lai_old = lai + assimsun = assimsun * o3coefv_sun + assimsha = assimsha * o3coefv_sha + rssun = rssun / o3coefg_sun + rssha = rssha / o3coefg_sha + ENDIF ! ====================================================================== -! END stability iteration +! END stability iteration ! ====================================================================== - z0m = z0mv - zol = zeta - rib = min(5.,zol*ustar**2/(vonkar**2/fh*um**2)) + z0m = z0mv + 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 = 1./(laisun/rssun + laisha/rssha) - ELSE - rssun = 2.0e4 ; rssha = 2.0e4 - assimsun = 0. ; assimsha = 0. - respcsun = 0. ; respcsha = 0. - rst = 2.0e4 - ENDIF - assim = assimsun + assimsha - respc = respcsun + respcsha! + rsoil + IF(lai .gt. 0.001) THEN + rst = 1./(laisun/rssun + laisha/rssha) + ELSE + rssun = 2.0e4 ; rssha = 2.0e4 + assimsun = 0. ; assimsha = 0. + respcsun = 0. ; respcsha = 0. + rst = 2.0e4 + ENDIF + assim = assimsun + assimsha + respc = respcsun + respcsha! + rsoil ! canopy fluxes and total assimilation amd respiration - fsenl = fsenl + fsenl_dtl*dtl(it-1) & - ! yuan: add the imbalanced energy below due to T adjustment to sensibel heat - + (dtl_noadj-dtl(it-1)) * ((lai+sai)*clai/deltim - dirab_dtl + fsenl_dtl + hvap*fevpl_dtl & - + cpliq * qintr_rain + cpice * qintr_snow) & - ! yuan: add the imbalanced energy below due to q adjustment to sensibel heat - + hvap*erre - - etr0 = etr - etr = etr + etr_dtl*dtl(it-1) - - IF (DEF_USE_PLANTHYDRAULICS) THEN - !TODO@yuan: rootflux may not be consistent with etr, - ! water imbalance could happen. - IF (abs(etr0) .ge. 1.e-15) THEN - rootflux = rootflux * etr / etr0 - ELSE - rootflux = rootflux + dz_soi / sum(dz_soi) * etr_dtl* dtl(it-1) - ENDIF - -! !NOTE: temporal solution to make etr and rootflux consistent. -! !TODO: need double check -! sumrootr = sum(rootr(:), rootr(:)>0.) -! IF (abs(sumrootr) > 0.) THEN -! rootr(:) = max(rootr(:),0.) * (etr/sumrootr) -! ELSE -! rootr(:) = etr*rootfr(:) -! ENDIF - ENDIF - - evplwet = evplwet + evplwet_dtl*dtl(it-1) - fevpl = fevpl_noadj - fevpl = fevpl + fevpl_dtl*dtl(it-1) - - elwmax = ldew/deltim - elwdif = max(0., evplwet-elwmax) - evplwet = min(evplwet, elwmax) - - fevpl = fevpl - elwdif - fsenl = fsenl + hvap*elwdif - - taux = - rhoair*us/ram - tauy = - rhoair*vs/ram + fsenl = fsenl + fsenl_dtl*dtl(it-1) & + ! yuan: add the imbalanced energy below due to T adjustment to sensibel heat + + (dtl_noadj-dtl(it-1)) * ((lai+sai)*clai/deltim - dirab_dtl + fsenl_dtl + hvap*fevpl_dtl & + + cpliq * qintr_rain + cpice * qintr_snow) & + ! yuan: add the imbalanced energy below due to q adjustment to sensibel heat + + hvap*erre + + etr0 = etr + etr = etr + etr_dtl*dtl(it-1) + + IF (DEF_USE_PLANTHYDRAULICS) THEN + !TODO@yuan: rootflux may not be consistent with etr, + ! water imbalance could happen. + IF (abs(etr0) .ge. 1.e-15) THEN + rootflux = rootflux * etr / etr0 + ELSE + rootflux = rootflux + dz_soi / sum(dz_soi) * etr_dtl* dtl(it-1) + ENDIF + +! !NOTE: temporal solution to make etr and rootflux consistent. +! !TODO: need double check +! sumrootr = sum(rootr(:), rootr(:)>0.) +! IF (abs(sumrootr) > 0.) THEN +! rootr(:) = max(rootr(:),0.) * (etr/sumrootr) +! ELSE +! rootr(:) = etr*rootfr(:) +! ENDIF + ENDIF + + evplwet = evplwet + evplwet_dtl*dtl(it-1) + fevpl = fevpl_noadj + fevpl = fevpl + fevpl_dtl*dtl(it-1) + + elwmax = ldew/deltim + elwdif = max(0., evplwet-elwmax) + evplwet = min(evplwet, elwmax) + + fevpl = fevpl - elwdif + fsenl = fsenl + hvap*elwdif + + taux = - rhoair*us/ram + tauy = - rhoair*vs/ram !----------------------------------------------------------------------- ! fluxes from ground to canopy space !----------------------------------------------------------------------- - fseng = cpair*rhoair*cgh*(tg-taf) + fseng = cpair*rhoair*cgh*(tg-taf) ! 03/07/2020, yuan: calculate fseng_soil/snow - !NOTE: taf = wta0*thm + wtg0*tg + wtl0*tl - fseng_soil = cpair*rhoair*cgh*((1.-wtg0)*t_soil - wta0*thm - wtl0*tl) - fseng_snow = cpair*rhoair*cgh*((1.-wtg0)*t_snow - wta0*thm - wtl0*tl) + !NOTE: taf = wta0*thm + wtg0*tg + wtl0*tl + fseng_soil = cpair*rhoair*cgh*((1.-wtg0)*t_soil - wta0*thm - wtl0*tl) + fseng_snow = cpair*rhoair*cgh*((1.-wtg0)*t_snow - wta0*thm - wtl0*tl) ! 03/07/2020, yuan: calculate fevpg_soil/snow - !NOTE: qaf = wtaq0*qm + wtgq0*qg + wtlq0*qsatl - fevpg = rhoair*cgw*(qg-qaf) - fevpg_soil = rhoair*cgw*((1.-wtgq0)*q_soil - wtaq0*qm - wtlq0*qsatl) - fevpg_snow = rhoair*cgw*((1.-wtgq0)*q_snow - wtaq0*qm - wtlq0*qsatl) + !NOTE: qaf = wtaq0*qm + wtgq0*qg + wtlq0*qsatl + fevpg = rhoair*cgw*(qg-qaf) + fevpg_soil = rhoair*cgw*((1.-wtgq0)*q_soil - wtaq0*qm - wtlq0*qsatl) + fevpg_snow = rhoair*cgw*((1.-wtgq0)*q_snow - wtaq0*qm - wtlq0*qsatl) !----------------------------------------------------------------------- ! downward (upward) longwave radiation below (above) the canopy and prec. sensible heat !----------------------------------------------------------------------- - ! 10/16/2017, yuan: added reflected longwave by the ground - dlrad = thermk * frl & - + stefnc * fac * tlbef**3 * (tlbef + 4.*dtl(it-1)) + ! 10/16/2017, yuan: added reflected longwave by the ground + dlrad = thermk * frl & + + stefnc * fac * tlbef**3 * (tlbef + 4.*dtl(it-1)) IF (.not.DEF_SPLIT_SOILSNOW) THEN - ulrad = stefnc * ( fac * tlbef**3 * (tlbef + 4.*dtl(it-1)) & - + thermk*emg*tg**4 ) & - + (1-emg)*thermk*thermk*frl & - + (1-emg)*thermk*fac*stefnc*tlbef**4 & - + 4.*(1-emg)*thermk*fac*stefnc*tlbef**3*dtl(it-1) + ulrad = stefnc * ( fac * tlbef**3 * (tlbef + 4.*dtl(it-1)) & + + thermk*emg*tg**4 ) & + + (1-emg)*thermk*thermk*frl & + + (1-emg)*thermk*fac*stefnc*tlbef**4 & + + 4.*(1-emg)*thermk*fac*stefnc*tlbef**3*dtl(it-1) ELSE - ulrad = stefnc * ( fac * tlbef**3 * (tlbef + 4.*dtl(it-1)) & - + (1.-fsno)*thermk*emg*t_soil**4 & - + fsno*thermk*emg*t_snow**4 ) & - + (1-emg)*thermk*thermk*frl & - + (1-emg)*thermk*fac*stefnc*tlbef**4 & - + 4.*(1-emg)*thermk*fac*stefnc*tlbef**3*dtl(it-1) + ulrad = stefnc * ( fac * tlbef**3 * (tlbef + 4.*dtl(it-1)) & + + (1.-fsno)*thermk*emg*t_soil**4 & + + fsno*thermk*emg*t_snow**4 ) & + + (1-emg)*thermk*thermk*frl & + + (1-emg)*thermk*fac*stefnc*tlbef**4 & + + 4.*(1-emg)*thermk*fac*stefnc*tlbef**3*dtl(it-1) ENDIF - hprl = cpliq * qintr_rain*(t_precip-tl) + cpice * qintr_snow*(t_precip-tl) + hprl = cpliq * qintr_rain*(t_precip-tl) + cpice * qintr_snow*(t_precip-tl) !----------------------------------------------------------------------- ! Derivative of soil energy flux with respect to soil temperature (cgrnd) !----------------------------------------------------------------------- - cgrnds = cpair*rhoair*cgh*(1.-wtg0) - cgrndl = rhoair*cgw*(1.-wtgq0)*dqgdT - cgrnd = cgrnds + cgrndl*htvp + cgrnds = cpair*rhoair*cgh*(1.-wtg0) + cgrndl = rhoair*cgw*(1.-wtgq0)*dqgdT + cgrnd = cgrnds + cgrndl*htvp !----------------------------------------------------------------------- ! balance check ! (the computational error was created by the assumed 'dtl' in line 406-408) !----------------------------------------------------------------------- - err = sabv + irab + dirab_dtl*dtl(it-1) - fsenl - hvap*fevpl + hprl + err = sabv + irab + dirab_dtl*dtl(it-1) - fsenl - hvap*fevpl + hprl #if(defined CoLMDEBUG) - IF(abs(err) .gt. .2) & - write(6,*) 'energy imbalance in LeafTemperature.F90',it-1,err,sabv,irab,fsenl,hvap*fevpl,hprl + IF(abs(err) .gt. .2) & + write(6,*) 'energy imbalance in LeafTemperature.F90',it-1,err,sabv,irab,fsenl,hvap*fevpl,hprl #endif !----------------------------------------------------------------------- ! Update dew accumulation (kg/m2) !----------------------------------------------------------------------- - IF (DEF_Interception_scheme .eq. 1) THEN - ldew = max(0., ldew-evplwet*deltim) - - ELSEIF (DEF_Interception_scheme .eq. 2) THEN!CLM4.5 - ldew = max(0., ldew-evplwet*deltim) - - ELSEIF (DEF_Interception_scheme .eq. 3) THEN !CLM5 - IF (ldew_rain .gt. evplwet*deltim) THEN - ldew_rain = ldew_rain-evplwet*deltim - ldew_snow = ldew_snow - ldew=ldew_rain+ldew_snow - ELSE - ldew_rain = 0.0 - ldew_snow = max(0., ldew-evplwet*deltim) - ldew = ldew_snow - ENDIF - - ELSEIF (DEF_Interception_scheme .eq. 4) THEN !Noah-MP - IF (ldew_rain .gt. evplwet*deltim) THEN - ldew_rain = ldew_rain-evplwet*deltim - ldew_snow = ldew_snow - ldew=ldew_rain+ldew_snow - ELSE - ldew_rain = 0.0 - ldew_snow = max(0., ldew-evplwet*deltim) - ldew = ldew_snow - ENDIF - - ELSEIF (DEF_Interception_scheme .eq. 5) THEN !MATSIRO - IF (ldew_rain .gt. evplwet*deltim) THEN - ldew_rain = ldew_rain-evplwet*deltim - ldew_snow = ldew_snow - ldew=ldew_rain+ldew_snow - ELSE - ldew_rain = 0.0 - ldew_snow = max(0., ldew-evplwet*deltim) - ldew = ldew_snow - ENDIF - - ELSEIF (DEF_Interception_scheme .eq. 6) THEN !VIC - IF (ldew_rain .gt. evplwet*deltim) THEN - ldew_rain = ldew_rain-evplwet*deltim - ldew_snow = ldew_snow - ldew=ldew_rain+ldew_snow - ELSE - ldew_rain = 0.0 - ldew_snow = max(0., ldew-evplwet*deltim) - ldew = ldew_snow - ENDIF - ELSEIF (DEF_Interception_scheme .eq. 7) THEN !JULES - IF (ldew_rain .gt. evplwet*deltim) THEN - ldew_rain = ldew_rain-evplwet*deltim - ldew_snow = ldew_snow - ldew=ldew_rain+ldew_snow - ELSE - ldew_rain = 0.0 - ldew_snow = max(0., ldew-evplwet*deltim) - ldew = ldew_snow - ENDIF - ELSEIF (DEF_Interception_scheme .eq. 8) THEN !JULES - IF (ldew_rain .gt. evplwet*deltim) THEN - ldew_rain = ldew_rain-evplwet*deltim - ldew_snow = ldew_snow - ldew=ldew_rain+ldew_snow - ELSE - ldew_rain = 0.0 - ldew_snow = max(0., ldew-evplwet*deltim) - ldew = ldew_snow - ENDIF - ELSE - CALL abort - ENDIF + IF (DEF_Interception_scheme .eq. 1) THEN + ldew = max(0., ldew-evplwet*deltim) + + ELSEIF (DEF_Interception_scheme .eq. 2) THEN!CLM4.5 + ldew = max(0., ldew-evplwet*deltim) + + ELSEIF (DEF_Interception_scheme .eq. 3) THEN !CLM5 + IF (ldew_rain .gt. evplwet*deltim) THEN + ldew_rain = ldew_rain-evplwet*deltim + ldew_snow = ldew_snow + ldew=ldew_rain+ldew_snow + ELSE + ldew_rain = 0.0 + ldew_snow = max(0., ldew-evplwet*deltim) + ldew = ldew_snow + ENDIF + + ELSEIF (DEF_Interception_scheme .eq. 4) THEN !Noah-MP + IF (ldew_rain .gt. evplwet*deltim) THEN + ldew_rain = ldew_rain-evplwet*deltim + ldew_snow = ldew_snow + ldew=ldew_rain+ldew_snow + ELSE + ldew_rain = 0.0 + ldew_snow = max(0., ldew-evplwet*deltim) + ldew = ldew_snow + ENDIF + + ELSEIF (DEF_Interception_scheme .eq. 5) THEN !MATSIRO + IF (ldew_rain .gt. evplwet*deltim) THEN + ldew_rain = ldew_rain-evplwet*deltim + ldew_snow = ldew_snow + ldew=ldew_rain+ldew_snow + ELSE + ldew_rain = 0.0 + ldew_snow = max(0., ldew-evplwet*deltim) + ldew = ldew_snow + ENDIF + + ELSEIF (DEF_Interception_scheme .eq. 6) THEN !VIC + IF (ldew_rain .gt. evplwet*deltim) THEN + ldew_rain = ldew_rain-evplwet*deltim + ldew_snow = ldew_snow + ldew=ldew_rain+ldew_snow + ELSE + ldew_rain = 0.0 + ldew_snow = max(0., ldew-evplwet*deltim) + ldew = ldew_snow + ENDIF + ELSEIF (DEF_Interception_scheme .eq. 7) THEN !JULES + IF (ldew_rain .gt. evplwet*deltim) THEN + ldew_rain = ldew_rain-evplwet*deltim + ldew_snow = ldew_snow + ldew=ldew_rain+ldew_snow + ELSE + ldew_rain = 0.0 + ldew_snow = max(0., ldew-evplwet*deltim) + ldew = ldew_snow + ENDIF + ELSEIF (DEF_Interception_scheme .eq. 8) THEN !JULES + IF (ldew_rain .gt. evplwet*deltim) THEN + ldew_rain = ldew_rain-evplwet*deltim + ldew_snow = ldew_snow + ldew=ldew_rain+ldew_snow + ELSE + ldew_rain = 0.0 + ldew_snow = max(0., ldew-evplwet*deltim) + ldew = ldew_snow + ENDIF + ELSE + CALL abort + ENDIF !----------------------------------------------------------------------- ! 2 m height air temperature !----------------------------------------------------------------------- - tref = thm + vonkar/(fh-fht)*dth * (fh2m/vonkar - fh/vonkar) - qref = qm + vonkar/(fq-fqt)*dqh * (fq2m/vonkar - fq/vonkar) + tref = thm + vonkar/(fh-fht)*dth * (fh2m/vonkar - fh/vonkar) + qref = qm + vonkar/(fq-fqt)*dqh * (fq2m/vonkar - fq/vonkar) - END SUBROUTINE LeafTemperature + END SUBROUTINE LeafTemperature !---------------------------------------------------------------------- SUBROUTINE dewfraction (sigf,lai,sai,dewmx,ldew,ldew_rain,ldew_snow,fwet,fdry) @@ -1156,25 +1156,25 @@ SUBROUTINE dewfraction (sigf,lai,sai,dewmx,ldew,ldew_rain,ldew_snow,fwet,fdry) !---1999.09.15 Yongjiu Dai !======================================================================= - USE MOD_Precision - - IMPLICIT NONE + USE MOD_Precision - 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) :: ldew_rain ! depth of rain on foliage [kg/m2/s] - real(r8), intent(in) :: ldew_snow ! depth of snow on foliage [kg/m2/s] - real(r8), intent(out) :: fwet ! fraction of foliage covered by water [-] - real(r8), intent(out) :: fdry ! fraction of foliage that is green and dry [-] + IMPLICIT NONE - real(r8) :: lsai ! lai + sai - real(r8) :: dewmxi ! inverse of maximum allowed dew [1/mm] - real(r8) :: vegt ! sigf*lsai, NOTE: remove sigf - real(r8) :: satcap_rain ! saturation capacity of foliage for rain [kg/m2] - real(r8) :: satcap_snow ! saturation capacity of foliage for snow [kg/m2] + 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) :: ldew_rain ! depth of rain on foliage [kg/m2/s] + real(r8), intent(in) :: ldew_snow ! depth of snow on foliage [kg/m2/s] + real(r8), intent(out) :: fwet ! fraction of foliage covered by water [-] + real(r8), intent(out) :: fdry ! fraction of foliage that is green and dry [-] + + real(r8) :: lsai ! lai + sai + real(r8) :: dewmxi ! inverse of maximum allowed dew [1/mm] + real(r8) :: vegt ! sigf*lsai, NOTE: remove sigf + real(r8) :: satcap_rain ! saturation capacity of foliage for rain [kg/m2] + real(r8) :: satcap_snow ! saturation capacity of foliage for snow [kg/m2] !----------------------------------------------------------------------- ! Fwet is the fraction of all vegetation surfaces which are wet @@ -1195,6 +1195,6 @@ SUBROUTINE dewfraction (sigf,lai,sai,dewmx,ldew,ldew_rain,ldew_snow,fwet,fdry) ! transpire. Adjusted for stem area which does not transpire fdry = (1.-fwet)*lai/lsai - END SUBROUTINE dewfraction + END SUBROUTINE dewfraction END MODULE MOD_LeafTemperature diff --git a/main/MOD_LeafTemperaturePC.F90 b/main/MOD_LeafTemperaturePC.F90 index 7e20ffcc..55d027e2 100644 --- a/main/MOD_LeafTemperaturePC.F90 +++ b/main/MOD_LeafTemperaturePC.F90 @@ -3,15 +3,15 @@ MODULE MOD_LeafTemperaturePC !----------------------------------------------------------------------- - USE MOD_Precision - IMPLICIT NONE - SAVE + USE MOD_Precision + IMPLICIT NONE + SAVE ! PUBLIC MEMBER FUNCTIONS: - PUBLIC :: LeafTemperaturePC + PUBLIC :: LeafTemperaturePC ! PRIVATE MEMBER FUNCTIONS: - PRIVATE :: dewfraction + PRIVATE :: dewfraction !----------------------------------------------------------------------- @@ -20,31 +20,31 @@ MODULE MOD_LeafTemperaturePC !----------------------------------------------------------------------- - SUBROUTINE LeafTemperaturePC ( & - ipatch ,ps ,pe ,deltim ,csoilc ,dewmx ,& - htvp ,pftclass ,fcover ,htop ,hbot ,lai ,& - sai ,extkb ,extkd ,hu ,ht ,hq ,& - us ,vs ,forc_t ,thm ,th ,thv ,& - qm ,psrf ,rhoair ,parsun ,parsha ,fsun ,& - sabv ,frl ,thermk ,fshade ,rstfacsun ,rstfacsha ,& - gssun ,gssha ,po2m ,pco2m ,z0h_g ,obug ,& - ustarg ,zlnd ,zsno ,fsno ,sigf ,etrc ,& - tg ,qg ,rss ,dqgdT ,emg ,t_soil ,& - t_snow ,q_soil ,q_snow ,z0mpc ,tl ,ldew ,& - ldew_rain ,ldew_snow ,taux ,tauy ,fseng ,fseng_soil,& - fseng_snow,fevpg ,fevpg_soil,fevpg_snow,cgrnd ,cgrndl ,& - cgrnds ,tref ,qref ,rst ,assim ,respc ,& - fsenl ,fevpl ,etr ,dlrad ,ulrad ,z0m ,& - zol ,rib ,ustar ,qstar ,tstar ,fm ,& - fh ,fq ,vegwp ,gs0sun ,gs0sha ,assimsun ,& - etrsun ,assimsha ,etrsha ,& + SUBROUTINE LeafTemperaturePC ( & + ipatch ,ps ,pe ,deltim ,csoilc ,dewmx ,& + htvp ,pftclass ,fcover ,htop ,hbot ,lai ,& + sai ,extkb ,extkd ,hu ,ht ,hq ,& + us ,vs ,forc_t ,thm ,th ,thv ,& + qm ,psrf ,rhoair ,parsun ,parsha ,fsun ,& + sabv ,frl ,thermk ,fshade ,rstfacsun ,rstfacsha ,& + gssun ,gssha ,po2m ,pco2m ,z0h_g ,obug ,& + ustarg ,zlnd ,zsno ,fsno ,sigf ,etrc ,& + tg ,qg ,rss ,dqgdT ,emg ,t_soil ,& + t_snow ,q_soil ,q_snow ,z0mpc ,tl ,ldew ,& + ldew_rain ,ldew_snow ,taux ,tauy ,fseng ,fseng_soil,& + fseng_snow,fevpg ,fevpg_soil,fevpg_snow,cgrnd ,cgrndl ,& + cgrnds ,tref ,qref ,rst ,assim ,respc ,& + fsenl ,fevpl ,etr ,dlrad ,ulrad ,z0m ,& + zol ,rib ,ustar ,qstar ,tstar ,fm ,& + fh ,fq ,vegwp ,gs0sun ,gs0sha ,assimsun ,& + etrsun ,assimsha ,etrsha ,& !Ozone stress variables - o3coefv_sun ,o3coefv_sha ,o3coefg_sun ,o3coefg_sha,& - lai_old ,o3uptakesun ,o3uptakesha ,forc_ozone ,& + o3coefv_sun ,o3coefv_sha ,o3coefg_sun ,o3coefg_sha,& + lai_old ,o3uptakesun ,o3uptakesha ,forc_ozone ,& !End ozone stress variables - hpbl, & - qintr_rain ,qintr_snow ,t_precip ,hprl ,& - smp ,hk ,hksati ,rootflux ) + hpbl, & + qintr_rain ,qintr_snow ,t_precip ,hprl ,& + smp ,hk ,hksati ,rootflux ) !======================================================================= ! @@ -74,52 +74,52 @@ SUBROUTINE LeafTemperaturePC ( & ! make a proper update of um. !======================================================================= - USE MOD_Precision - USE MOD_Vars_Global - USE MOD_Const_Physical, only: vonkar, grav, hvap, cpair, stefnc, cpliq, cpice - USE MOD_Const_PFT - USE MOD_FrictionVelocity - USE MOD_CanopyLayerProfile - USE MOD_Namelist, only: DEF_USE_CBL_HEIGHT, DEF_USE_PLANTHYDRAULICS, DEF_USE_OZONESTRESS, & - DEF_RSS_SCHEME, DEF_Interception_scheme, DEF_SPLIT_SOILSNOW - USE MOD_TurbulenceLEddy - USE MOD_Qsadv - USE MOD_AssimStomataConductance - USE MOD_PlantHydraulic, only: PlantHydraulicStress_twoleaf - USE MOD_Ozone, only: CalcOzoneStress - IMPLICIT NONE + USE MOD_Precision + USE MOD_Vars_Global + USE MOD_Const_Physical, only: vonkar, grav, hvap, cpair, stefnc, cpliq, cpice + USE MOD_Const_PFT + USE MOD_FrictionVelocity + USE MOD_CanopyLayerProfile + USE MOD_Namelist, only: DEF_USE_CBL_HEIGHT, DEF_USE_PLANTHYDRAULICS, DEF_USE_OZONESTRESS, & + DEF_RSS_SCHEME, DEF_Interception_scheme, DEF_SPLIT_SOILSNOW + USE MOD_TurbulenceLEddy + USE MOD_Qsadv + USE MOD_AssimStomataConductance + USE MOD_PlantHydraulic, only: PlantHydraulicStress_twoleaf + USE MOD_Ozone, only: CalcOzoneStress + IMPLICIT NONE !-----------------------Arguments--------------------------------------- - integer, intent(in) :: ipatch - integer, intent(in) :: & + integer, intent(in) :: ipatch + integer, intent(in) :: & ps, &! start PFT index in a patch pe ! end PFT index in a patch - real(r8), intent(in) :: & + real(r8), intent(in) :: & deltim, &! seconds in a time step [second] csoilc, &! drag coefficient for soil under canopy [-] dewmx, &! maximum dew htvp ! latent heat of evaporation (/sublimation) [J/kg] ! vegetation parameters - integer, dimension(ps:pe), intent(in) :: & + integer, dimension(ps:pe), intent(in) :: & pftclass ! PFT class - real(r8), dimension(ps:pe), intent(in) :: & + real(r8), dimension(ps:pe), intent(in) :: & fcover, &! PFT fractiona coverage [-] htop, &! PFT crown top height [m] hbot, &! PFT crown bottom height [m] lai, &! adjusted leaf area index for seasonal variation [-] sai ! stem area index [-] - real(r8), intent(inout) :: & + real(r8), intent(inout) :: & vegwp(1:nvegwcs,ps:pe), &! vegetation water potential gs0sun(ps:pe), &! maximum stomata conductance of sunlit leaf gs0sha(ps:pe) ! maximum stomata conductance of shaded leaf ! input variables - real(r8), intent(in) :: & + real(r8), intent(in) :: & hu, &! observational height of wind [m] ht, &! observational height of temperature [m] hq, &! observational height of humidity [m] @@ -166,7 +166,7 @@ SUBROUTINE LeafTemperaturePC ( & rss, &! soil surface resistance [s/m] emg ! vegetation emissivity - real(r8), intent(in) :: & + real(r8), intent(in) :: & t_precip, &! snowfall/rainfall temperature [kelvin] qintr_rain(ps:pe), &! rainfall interception (mm h2o/s) qintr_snow(ps:pe), &! snowfall interception (mm h2o/s) @@ -174,10 +174,10 @@ SUBROUTINE LeafTemperaturePC ( & hksati (1:nl_soil), &! hydraulic conductivity at saturation [mm h2o/s] hk (1:nl_soil) ! soil hydraulic conducatance - real(r8), intent(in) :: & + real(r8), intent(in) :: & hpbl ! atmospheric boundary layer height [m] - real(r8), dimension(ps:pe), intent(inout) :: & + real(r8), dimension(ps:pe), intent(inout) :: & tl, &! leaf temperature [K] ldew, &! depth of water on foliage [mm] ldew_rain, &! depth of rain on foliage [mm] @@ -196,17 +196,17 @@ SUBROUTINE LeafTemperaturePC ( & gssun, &! stomata conductance of sunlit leaf gssha ! stomata conductance of shaded leaf - real(r8), dimension(ps:pe), intent(inout) :: & + real(r8), dimension(ps:pe), intent(inout) :: & assimsun, &! sunlit leaf assimilation rate [umol co2 /m**2/ s] [+] etrsun, &! transpiration rate of sunlit leaf [mm/s] assimsha, &! shaded leaf assimilation rate [umol co2 /m**2/ s] [+] etrsha ! transpiration rate of shaded leaf [mm/s] !Ozone stress variables - real(r8), intent(inout) :: forc_ozone + real(r8), intent(inout) :: forc_ozone !End ozone stress variables - real(r8), intent(inout) :: & + real(r8), intent(inout) :: & dlrad, &! downward longwave radiation blow the canopy [W/m2] ulrad, &! upward longwave radiation above the canopy [W/m2] taux, &! wind stress: E-W [kg/m/s**2] @@ -221,7 +221,7 @@ SUBROUTINE LeafTemperaturePC ( & qref, &! 2 m height air specific humidity rootflux(nl_soil,ps:pe) ! root water uptake from different layers - real(r8), dimension(ps:pe), intent(out) :: & + real(r8), dimension(ps:pe), intent(out) :: & z0mpc, &! z0m for individual PFT rst, &! stomatal resistance assim, &! rate of assimilation @@ -231,7 +231,7 @@ SUBROUTINE LeafTemperaturePC ( & etr, &! transpiration rate [mm/s] hprl ! precipitation sensible heat from canopy - 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 @@ -242,7 +242,7 @@ SUBROUTINE LeafTemperaturePC ( & fh, &! integral of profile function for heat fq ! integral of profile function for moisture - real(r8), intent(inout) :: & + real(r8), intent(inout) :: & cgrnd, &! deriv. of soil energy flux wrt to soil temp [w/m2/k] cgrndl, &! deriv, of soil latent heat flux wrt soil temp [w/m2/k] cgrnds ! deriv of soil sensible heat flux wrt soil temp [w/m**2/k] @@ -280,7 +280,7 @@ SUBROUTINE LeafTemperaturePC ( & binter, &! conductance-photosynthesis intercept extkn ! coefficient of leaf nitrogen allocation - real(r8), dimension(ps:pe) :: & + real(r8), dimension(ps:pe) :: & kmax_sun, &! Plant Hydraulics Paramters kmax_sha, &! Plant Hydraulics Paramters kmax_xyl, &! Plant Hydraulics Paramters @@ -474,76 +474,76 @@ SUBROUTINE LeafTemperaturePC ( & ! only process with vegetated patches - lsai(:) = lai(:) + sai(:) - is_vegetated_patch = .false. + lsai(:) = lai(:) + sai(:) + is_vegetated_patch = .false. - DO i = ps, pe - IF (fcover(i)>0 .and. lsai(i)>1.e-6) THEN - is_vegetated_patch = .true. - ELSE - tl(i) = forc_t - ENDIF - ENDDO + DO i = ps, pe + IF (fcover(i)>0 .and. lsai(i)>1.e-6) THEN + is_vegetated_patch = .true. + ELSE + tl(i) = forc_t + ENDIF + ENDDO - IF (.not. is_vegetated_patch) THEN - print *, "NOTE: There is no vegetation in this Plant Community Patch, RETURN." - RETURN - ENDIF + IF (.not. is_vegetated_patch) THEN + print *, "NOTE: There is no vegetation in this Plant Community Patch, RETURN." + RETURN + ENDIF ! 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. - d_opt = 2 - rd_opt = 3 - rb_opt = 3 + d_opt = 2 + rd_opt = 3 + rb_opt = 3 ! initial values for z0hg, z0qg - z0mg = (1.-fsno)*zlnd + fsno*zsno - z0hg = z0mg - z0qg = z0mg + z0mg = (1.-fsno)*zlnd + fsno*zsno + z0hg = z0mg + z0qg = z0mg - !clai = 4.2 * 1000. * 0.2 - clai = 0.0 + !clai = 4.2 * 1000. * 0.2 + clai = 0.0 ! initialization of PFT constants - DO i = ps, pe - p = pftclass(i) - - canlay (i) = canlay_p (p) - sqrtdi (i) = sqrtdi_p (p) - - effcon (i) = effcon_p (p) - vmax25 (i) = vmax25_p (p) - shti (i) = shti_p (p) - hhti (i) = hhti_p (p) - slti (i) = slti_p (p) - hlti (i) = hlti_p (p) - trda (i) = trda_p (p) - trdm (i) = trdm_p (p) - trop (i) = trop_p (p) - g1 (i) = g1_p (p) - g0 (i) = g0_p (p) - gradm (i) = gradm_p (p) - binter (i) = binter_p (p) - extkn (i) = extkn_p (p) - - kmax_sun (i) = kmax_sun_p (p) - kmax_sha (i) = kmax_sha_p (p) - kmax_xyl (i) = kmax_xyl_p (p) - kmax_root (i) = kmax_root_p (p) - psi50_sun (i) = psi50_sun_p (p) - psi50_sha (i) = psi50_sha_p (p) - psi50_xyl (i) = psi50_xyl_p (p) - psi50_root (i) = psi50_root_p (p) - ck (i) = ck_p (p) - - rootfr (:,i) = rootfr_p (:,p) - ENDDO + DO i = ps, pe + p = pftclass(i) + + canlay (i) = canlay_p (p) + sqrtdi (i) = sqrtdi_p (p) + + effcon (i) = effcon_p (p) + vmax25 (i) = vmax25_p (p) + shti (i) = shti_p (p) + hhti (i) = hhti_p (p) + slti (i) = slti_p (p) + hlti (i) = hlti_p (p) + trda (i) = trda_p (p) + trdm (i) = trdm_p (p) + trop (i) = trop_p (p) + g1 (i) = g1_p (p) + g0 (i) = g0_p (p) + gradm (i) = gradm_p (p) + binter (i) = binter_p (p) + extkn (i) = extkn_p (p) + + kmax_sun (i) = kmax_sun_p (p) + kmax_sha (i) = kmax_sha_p (p) + kmax_xyl (i) = kmax_xyl_p (p) + kmax_root (i) = kmax_root_p (p) + psi50_sun (i) = psi50_sun_p (p) + psi50_sha (i) = psi50_sha_p (p) + psi50_xyl (i) = psi50_xyl_p (p) + psi50_root (i) = psi50_root_p (p) + ck (i) = ck_p (p) + + rootfr (:,i) = rootfr_p (:,p) + ENDDO !----------------------------------------------------------------------- ! scaling-up coefficients from leaf to canopy @@ -554,220 +554,220 @@ SUBROUTINE LeafTemperaturePC ( & ! partion visible canopy absorption to sunlit and shaded fractions ! to get average absorbed par for sunlit and shaded leaves - fsha(:) = 1. - fsun(:) - laisun(:) = lai(:)*fsun(:) - laisha(:) = lai(:)*fsha(:) + fsha(:) = 1. - fsun(:) + laisun(:) = lai(:)*fsun(:) + laisha(:) = lai(:)*fsha(:) - cintsun(1,:) = (1.-exp(-(0.110+extkb)*lai))/(0.110+extkb) - cintsun(2,:) = (1.-exp(-(extkb+extkd)*lai))/(extkb+extkd) - cintsun(3,:) = (1.-exp(-extkb*lai))/extkb + cintsun(1,:) = (1.-exp(-(0.110+extkb)*lai))/(0.110+extkb) + cintsun(2,:) = (1.-exp(-(extkb+extkd)*lai))/(extkb+extkd) + cintsun(3,:) = (1.-exp(-extkb*lai))/extkb - cintsha(1,:) = (1.-exp(-0.110*lai))/0.110 - cintsun(1,:) - cintsha(2,:) = (1.-exp(-extkd*lai))/extkd - cintsun(2,:) - cintsha(3,:) = lai(:) - cintsun(3,:) + cintsha(1,:) = (1.-exp(-0.110*lai))/0.110 - cintsun(1,:) + cintsha(2,:) = (1.-exp(-extkd*lai))/extkd - cintsun(2,:) + cintsha(3,:) = lai(:) - cintsun(3,:) !----------------------------------------------------------------------- ! get fraction of wet and dry canopy surface (fwet & fdry) ! initial saturated vapor pressure and humidity and their derivation !----------------------------------------------------------------------- - DO i = ps, pe - IF (fcover(i)>0 .and. lsai(i)>1.e-6) THEN - CALL dewfraction (sigf(i),lai(i),sai(i),dewmx,ldew(i),ldew_rain(i),ldew_snow(i),fwet(i),fdry(i)) - CALL qsadv(tl(i),psrf,ei(i),deiDT(i),qsatl(i),qsatlDT(i)) - ENDIF - ENDDO + DO i = ps, pe + IF (fcover(i)>0 .and. lsai(i)>1.e-6) THEN + CALL dewfraction (sigf(i),lai(i),sai(i),dewmx,ldew(i),ldew_rain(i),ldew_snow(i),fwet(i),fdry(i)) + CALL qsadv(tl(i),psrf,ei(i),deiDT(i),qsatl(i),qsatlDT(i)) + ENDIF + ENDDO !----------------------------------------------------------------------- ! 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_*) !----------------------------------------------------------------------- ! calculate layer average propeties: height (htop_lay, hbot_lay), lsai_lay, ... ! !!NOTE: adjustment may needed for htop_lay/hbot_lay !----------------------------------------------------------------------- - htop_lay(:) = 0 - hbot_lay(:) = 0 - lsai_lay(:) = 0 - fcover_lay(:) = 0 - - DO i = ps, pe - IF (fcover(i)>0 .and. lsai(i)>1.e-6) THEN - clev = canlay(i) - htop_lay(clev) = htop_lay(clev) + htop(i) * fcover(i) - hbot_lay(clev) = hbot_lay(clev) + hbot(i) * fcover(i) - lsai_lay(clev) = lsai_lay(clev) + lsai(i) * fcover(i) - fcover_lay(clev) = fcover_lay(clev) + fcover(i) - ENDIF - ENDDO - - DO i = 1, nlay - IF (fcover_lay(i) > 0) THEN - htop_lay(i) = htop_lay(i) / fcover_lay(i) - hbot_lay(i) = hbot_lay(i) / fcover_lay(i) - lsai_lay(i) = lsai_lay(i) / fcover_lay(i) - ENDIF - ENDDO - - ! calculate fcover_lays + htop_lay(:) = 0 + hbot_lay(:) = 0 + lsai_lay(:) = 0 + fcover_lay(:) = 0 + + DO i = ps, pe + IF (fcover(i)>0 .and. lsai(i)>1.e-6) THEN + clev = canlay(i) + htop_lay(clev) = htop_lay(clev) + htop(i) * fcover(i) + hbot_lay(clev) = hbot_lay(clev) + hbot(i) * fcover(i) + lsai_lay(clev) = lsai_lay(clev) + lsai(i) * fcover(i) + fcover_lay(clev) = fcover_lay(clev) + fcover(i) + ENDIF + ENDDO + + DO i = 1, nlay + IF (fcover_lay(i) > 0) THEN + htop_lay(i) = htop_lay(i) / fcover_lay(i) + hbot_lay(i) = hbot_lay(i) / fcover_lay(i) + lsai_lay(i) = lsai_lay(i) / fcover_lay(i) + ENDIF + ENDDO + + ! calculate fcover_lays ! 03/16/2020, yuan: determine to set fc=0 or fcover above for ! gaps between layers, 0 maybe more consistent - fcover_lays(0) = sum(fcover_lay(:)) - fcover_lays(1) = sum(fcover_lay(1:3)) - fcover_lays(2) = sum(fcover_lay(2:3)) - fcover_lays(3) = sum(fcover_lay(3:3)) - fcover_lays(:) = 0. + fcover_lays(0) = sum(fcover_lay(:)) + fcover_lays(1) = sum(fcover_lay(1:3)) + fcover_lays(2) = sum(fcover_lay(2:3)) + fcover_lays(3) = sum(fcover_lay(3:3)) + fcover_lays(:) = 0. !----------------------------------------------------------------------- ! scaling factor bee !----------------------------------------------------------------------- ! 09/26/2017, yuan: NOTE! bee value, the default is 1 - bee = 1. + bee = 1. !----------------------------------------------------------------------- ! calculate z0m and displa for PFTs !----------------------------------------------------------------------- - DO i = ps, pe - IF (lsai(i) > 1.e-6) THEN - CALL cal_z0_displa(lsai(i), htop(i), 1., z0mpc(i), displa) - ELSE - z0mpc(i) = z0mg - ENDIF - ENDDO + DO i = ps, pe + IF (lsai(i) > 1.e-6) THEN + CALL cal_z0_displa(lsai(i), htop(i), 1., z0mpc(i), displa) + ELSE + z0mpc(i) = z0mg + ENDIF + ENDDO !----------------------------------------------------------------------- ! calculate z0m and displa for layers !----------------------------------------------------------------------- - displa_lay (:) = 0. - displa_lays(:) = 0. - z0m_lay (:) = 0. - z0m_lays (:) = 0. + displa_lay (:) = 0. + displa_lays(:) = 0. + z0m_lay (:) = 0. + z0m_lays (:) = 0. - DO i = 1, nlay - IF (fcover_lay(i)>0 .and. lsai_lay(i)>0) THEN - CALL cal_z0_displa(lsai_lay(i), htop_lay(i), 1., z0m_lay(i), displa_lay(i)) - CALL cal_z0_displa(lsai_lay(i), htop_lay(i), fcover_lay(i), z0m_lays(i), displa_lays(i)) - ENDIF - ENDDO + DO i = 1, nlay + IF (fcover_lay(i)>0 .and. lsai_lay(i)>0) THEN + CALL cal_z0_displa(lsai_lay(i), htop_lay(i), 1., z0m_lay(i), displa_lay(i)) + CALL cal_z0_displa(lsai_lay(i), htop_lay(i), fcover_lay(i), z0m_lays(i), displa_lays(i)) + ENDIF + ENDDO - ! ground - z0m_lays (0) = z0mg - displa_lays(0) = 0. + ! ground + z0m_lays (0) = z0mg + displa_lays(0) = 0. - ! 10/05/2017: robust check - WHERE (z0m_lays(:) < z0mg) z0m_lays(:) = z0mg - WHERE (z0m_lay (:) < z0mg) z0m_lay (:) = z0mg + ! 10/05/2017: robust check + WHERE (z0m_lays(:) < z0mg) z0m_lays(:) = z0mg + WHERE (z0m_lay (:) < z0mg) z0m_lay (:) = z0mg - ! maximum assumption - z0m_lays(1) = maxval(z0m_lays(0:1)) - z0m_lays(2) = maxval(z0m_lays(0:2)) - z0m_lays(3) = maxval(z0m_lays(0:3)) + ! maximum assumption + z0m_lays(1) = maxval(z0m_lays(0:1)) + z0m_lays(2) = maxval(z0m_lays(0:2)) + z0m_lays(3) = maxval(z0m_lays(0:3)) - displa_lays(1) = maxval(displa_lays(0:1)) - displa_lays(2) = maxval(displa_lays(0:2)) - displa_lays(3) = maxval(displa_lays(0:3)) + displa_lays(1) = maxval(displa_lays(0:1)) + displa_lays(2) = maxval(displa_lays(0:2)) + displa_lays(3) = maxval(displa_lays(0:3)) - ! roughness length and displacement height for sensible - ! and latent heat transfer - z0h_lays(:) = z0m_lays(:) - z0q_lays(:) = z0m_lays(:) + ! roughness length and displacement height for sensible + ! and latent heat transfer + z0h_lays(:) = z0m_lays(:) + z0q_lays(:) = z0m_lays(:) !----------------------------------------------------------------------- ! calculate layer a_lay !----------------------------------------------------------------------- - ! initialization - a_lay (:) = 0. - a_lay_i63(:) = 0. - a_lay_k71(:) = 0. - a_lay_g77(:) = 0. - a_lay_m97(:) = 0. + ! initialization + a_lay (:) = 0. + a_lay_i63(:) = 0. + a_lay_k71(:) = 0. + a_lay_g77(:) = 0. + a_lay_m97(:) = 0. - DO i = 1, nlay - IF (fcover_lay(i)>0 .and. lsai_lay(i)>0) THEN + DO i = 1, nlay + IF (fcover_lay(i)>0 .and. lsai_lay(i)>0) THEN - ! mixing length and sqrt(drag coefficient) - lm = vonkar*(htop_lay(i) - displa_lay(i)) + ! mixing length and sqrt(drag coefficient) + lm = vonkar*(htop_lay(i) - displa_lay(i)) - ! Raupach, 1992 - fai = 1. - exp(-0.5*lsai_lay(i)) - sqrtdragc = min( (0.003+0.3*fai)**0.5, 0.3 ) + ! Raupach, 1992 + fai = 1. - exp(-0.5*lsai_lay(i)) + sqrtdragc = min( (0.003+0.3*fai)**0.5, 0.3 ) - ! Inoue, 1963 - a_lay_i63(i) = htop_lay(i) * & - (Cd*lsai_lay(i)/(2.*htop_lay(i)*lm**2))**(1./3.) + ! Inoue, 1963 + a_lay_i63(i) = htop_lay(i) * & + (Cd*lsai_lay(i)/(2.*htop_lay(i)*lm**2))**(1./3.) - ! Kondo, 1971 - a_lay_k71(i) = htop_lay(i)/(htop_lay(i)-displa_lay(i))/ & - (vonkar/sqrtdragc) + ! Kondo, 1971 + a_lay_k71(i) = htop_lay(i)/(htop_lay(i)-displa_lay(i))/ & + (vonkar/sqrtdragc) - ! Goudriaan, 1977 - a_lay_g77(i) = (Cd*lsai_lay(i)*htop_lay(i)/lm)**0.5 + ! Goudriaan, 1977 + a_lay_g77(i) = (Cd*lsai_lay(i)*htop_lay(i)/lm)**0.5 - ! Massman, 1997 - a_lay_m97(i) = Cd*lsai_lay(i) / (2.*sqrtdragc**2) + ! Massman, 1997 + a_lay_m97(i) = Cd*lsai_lay(i) / (2.*sqrtdragc**2) - a_lay(i) = a_lay_k71(i) + a_lay(i) = a_lay_k71(i) - displa_lay(i) = max(htop_lay(i)/2., displa_lay(i)) + displa_lay(i) = max(htop_lay(i)/2., displa_lay(i)) - ENDIF - ENDDO + ENDIF + ENDDO !----------------------------------------------------------------------- ! claculate layer info ! how may layers, top layer and bottom layer number !----------------------------------------------------------------------- - toplay = 0 - botlay = 0 - numlay = 0 + toplay = 0 + botlay = 0 + numlay = 0 - DO i = nlay, 1, -1 - IF (fcover_lay(i)>0 .and. lsai_lay(i)>0) THEN + DO i = nlay, 1, -1 + IF (fcover_lay(i)>0 .and. lsai_lay(i)>0) THEN - ! to count the layer number - numlay = numlay + 1 - IF (toplay .eq. 0) THEN - ! set the top layer to current layer - toplay = i - ENDIF + ! to count the layer number + numlay = numlay + 1 + IF (toplay .eq. 0) THEN + ! set the top layer to current layer + toplay = i + ENDIF - ! set this layer to be the bottom layer - botlay = i + ! set this layer to be the bottom layer + botlay = i - displa_lay(i) = max(displa_lay(i), hbot_lay(i)) - ENDIF - ENDDO + displa_lay(i) = max(displa_lay(i), hbot_lay(i)) + ENDIF + ENDDO !----------------------------------------------------------------------- ! calculate transmittance of longwave radiation for each layer ! diffuse case !----------------------------------------------------------------------- - thermk_lay(:) = 0. - fshade_lay(:) = 0. + thermk_lay(:) = 0. + fshade_lay(:) = 0. - DO i = ps, pe - IF (fshade(i)>0 .and. canlay(i)>0) THEN - clev = canlay(i) - thermk_lay(clev) = thermk_lay(clev) + fshade(i) * thermk(i) - fshade_lay(clev) = fshade_lay(clev) + fshade(i) - ENDIF - ENDDO + DO i = ps, pe + IF (fshade(i)>0 .and. canlay(i)>0) THEN + clev = canlay(i) + thermk_lay(clev) = thermk_lay(clev) + fshade(i) * thermk(i) + fshade_lay(clev) = fshade_lay(clev) + fshade(i) + ENDIF + ENDDO - DO i = 1, nlay - IF (fshade_lay(i) > 0) THEN - thermk_lay(i) = thermk_lay(i) / fshade_lay(i) - ELSE - thermk_lay(i) = 1. - ENDIF - ENDDO + DO i = 1, nlay + IF (fshade_lay(i) > 0) THEN + thermk_lay(i) = thermk_lay(i) / fshade_lay(i) + ELSE + thermk_lay(i) = 1. + ENDIF + ENDDO !----------------------------------------------------------------------- ! calculate the transfer matrix for long-wave radiation transfer @@ -775,516 +775,516 @@ SUBROUTINE LeafTemperaturePC ( & ! NOTE: don't need to calculate at each step !----------------------------------------------------------------------- - tdn(:,:) = 0. - tup(:,:) = 0. + tdn(:,:) = 0. + tup(:,:) = 0. - tdn(1,0) = 1. - tdn(2,0) = 1 - fshade_lay(1) - tdn(3,0) = 1 - fshade_lay(1) - fshade_lay(2) + fshade_lay(1)*fshade_lay(2) - tdn(4,0) = 1 - fshade_lay(1) - fshade_lay(2) - fshade_lay(3) & - + fshade_lay(1)*fshade_lay(2) & - + fshade_lay(1)*fshade_lay(3) & - + fshade_lay(2)*fshade_lay(3) & - - fshade_lay(1)*fshade_lay(2)*fshade_lay(3) + tdn(1,0) = 1. + tdn(2,0) = 1 - fshade_lay(1) + tdn(3,0) = 1 - fshade_lay(1) - fshade_lay(2) + fshade_lay(1)*fshade_lay(2) + tdn(4,0) = 1 - fshade_lay(1) - fshade_lay(2) - fshade_lay(3) & + + fshade_lay(1)*fshade_lay(2) & + + fshade_lay(1)*fshade_lay(3) & + + fshade_lay(2)*fshade_lay(3) & + - fshade_lay(1)*fshade_lay(2)*fshade_lay(3) - tdn(2,1) = fshade_lay(1) - tdn(3,1) = (1 - fshade_lay(2))*fshade_lay(1) - tdn(4,1) = (1 - fshade_lay(2) - fshade_lay(3) + fshade_lay(2)*fshade_lay(3))*fshade_lay(1) + tdn(2,1) = fshade_lay(1) + tdn(3,1) = (1 - fshade_lay(2))*fshade_lay(1) + tdn(4,1) = (1 - fshade_lay(2) - fshade_lay(3) + fshade_lay(2)*fshade_lay(3))*fshade_lay(1) - tdn(3,2) = fshade_lay(2) - tdn(4,2) = (1 - fshade_lay(3))*fshade_lay(2) - tdn(4,3) = fshade_lay(3) + tdn(3,2) = fshade_lay(2) + tdn(4,2) = (1 - fshade_lay(3))*fshade_lay(2) + tdn(4,3) = fshade_lay(3) - tup(0,1) = fshade_lay(1) - tup(0,2) = (1 - fshade_lay(1))*fshade_lay(2) - tup(1,2) = fshade_lay(2) + tup(0,1) = fshade_lay(1) + tup(0,2) = (1 - fshade_lay(1))*fshade_lay(2) + tup(1,2) = fshade_lay(2) - tup(0,3) = (1 - fshade_lay(1) - fshade_lay(2) + fshade_lay(1)*fshade_lay(2))*fshade_lay(3) - tup(1,3) = (1 - fshade_lay(2))*fshade_lay(3) - tup(2,3) = fshade_lay(3) + tup(0,3) = (1 - fshade_lay(1) - fshade_lay(2) + fshade_lay(1)*fshade_lay(2))*fshade_lay(3) + tup(1,3) = (1 - fshade_lay(2))*fshade_lay(3) + tup(2,3) = fshade_lay(3) - tup(0,4) = tdn(4,0) - tup(1,4) = 1 - fshade_lay(2) - fshade_lay(3) + fshade_lay(2)*fshade_lay(3) - tup(2,4) = 1 - fshade_lay(3) - tup(3,4) = 1. + tup(0,4) = tdn(4,0) + tup(1,4) = 1 - fshade_lay(2) - fshade_lay(3) + fshade_lay(2)*fshade_lay(3) + tup(2,4) = 1 - fshade_lay(3) + tup(3,4) = 1. !----------------------------------------------------------------------- ! calculate parameters for delta(Lv) for LW radiation transfer !----------------------------------------------------------------------- - dLvpar(1) = 1. - dLvpar(2) = ( (1-fshade_lay(1)) + thermk_lay(1)*fshade_lay(1) )**2 - dLvpar(3) = ( tdn(3,0) + thermk_lay(2)*fshade_lay(2)*(1-fshade_lay(1)+thermk_lay(1)*fshade_lay(1)) & - + (1-fshade_lay(2))*thermk_lay(1)*fshade_lay(1) )**2 + dLvpar(1) = 1. + dLvpar(2) = ( (1-fshade_lay(1)) + thermk_lay(1)*fshade_lay(1) )**2 + dLvpar(3) = ( tdn(3,0) + thermk_lay(2)*fshade_lay(2)*(1-fshade_lay(1)+thermk_lay(1)*fshade_lay(1)) & + + (1-fshade_lay(2))*thermk_lay(1)*fshade_lay(1) )**2 !----------------------------------------------------------------------- ! first guess for taf and qaf for each layer ! a large differece from previous schemes !----------------------------------------------------------------------- - taf(:) = 0. - qaf(:) = 0. + taf(:) = 0. + qaf(:) = 0. - ! 05/02/2016: set taf/qaf according to layer number - IF (numlay .eq. 1) THEN - taf(toplay) = 0.5 * (tg + thm) - qaf(toplay) = 0.5 * (qm + qg ) - ENDIF + ! 05/02/2016: set taf/qaf according to layer number + IF (numlay .eq. 1) THEN + taf(toplay) = 0.5 * (tg + thm) + qaf(toplay) = 0.5 * (qm + qg ) + ENDIF - IF (numlay .eq. 2) THEN - taf(botlay) = (2.*tg + thm)/3. - qaf(botlay) = (2.*qg + qm )/3. - taf(toplay) = (tg + 2.*thm)/3. - qaf(toplay) = (qg + 2.*qm )/3. - ENDIF + IF (numlay .eq. 2) THEN + taf(botlay) = (2.*tg + thm)/3. + qaf(botlay) = (2.*qg + qm )/3. + taf(toplay) = (tg + 2.*thm)/3. + qaf(toplay) = (qg + 2.*qm )/3. + ENDIF - IF (numlay .eq. 3) THEN - taf(1) = (3.*tg + thm)/4. - qaf(1) = (3.*qg + qm )/4. - taf(2) = (tg + thm )/2. - qaf(2) = (qg + qm )/2. - taf(3) = (tg + 3.*thm)/4. - qaf(3) = (qg + 3.*qm )/4. - ENDIF + IF (numlay .eq. 3) THEN + taf(1) = (3.*tg + thm)/4. + qaf(1) = (3.*qg + qm )/4. + taf(2) = (tg + thm )/2. + qaf(2) = (qg + qm )/2. + taf(3) = (tg + 3.*thm)/4. + qaf(3) = (qg + 3.*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 - z0mv = z0m_lays(3); z0hv = z0m_lays(3); z0qv = z0m_lays(3) - ur = max(0.1, sqrt(us*us+vs*vs)) !limit set to 0.1 - dth = thm - taf(toplay) - dqh = qm - qaf(toplay) - dthv = dth*(1.+0.61*qm) + 0.61*th*dqh - zldis = hu - displa_lays(3) - - IF(zldis <= 0.0) THEN - write(6,*) 'the obs height of u less than the zero displacement heght' - CALL abort - ENDIF + ! have been set before + z0mv = z0m_lays(3); z0hv = z0m_lays(3); z0qv = z0m_lays(3) + ur = max(0.1, sqrt(us*us+vs*vs)) !limit set to 0.1 + dth = thm - taf(toplay) + dqh = qm - qaf(toplay) + dthv = dth*(1.+0.61*qm) + 0.61*th*dqh + zldis = hu - displa_lays(3) + + 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,z0mv,um,obu) + CALL moninobukini(ur,th,thm,thv,dth,dqh,dthv,zldis,z0mv,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 - IF (DEF_USE_CBL_HEIGHT) THEN - CALL moninobukm_leddy(hu,ht,hq,displa_lays(toplay),z0mv,z0hv,z0qv,obu,um, & - displa_lay(toplay),z0m_lay(toplay),hpbl,ustar,fh2m,fq2m, & - htop_lay(toplay),fmtop,fm,fh,fq,fht,fqt,phih) - ELSE - CALL moninobukm(hu,ht,hq,displa_lays(toplay),z0mv,z0hv,z0qv,obu,um, & - displa_lay(toplay),z0m_lay(toplay),ustar,fh2m,fq2m, & - htop_lay(toplay),fmtop,fm,fh,fq,fht,fqt,phih) - ENDIF + IF (DEF_USE_CBL_HEIGHT) THEN + CALL moninobukm_leddy(hu,ht,hq,displa_lays(toplay),z0mv,z0hv,z0qv,obu,um, & + displa_lay(toplay),z0m_lay(toplay),hpbl,ustar,fh2m,fq2m, & + htop_lay(toplay),fmtop,fm,fh,fq,fht,fqt,phih) + ELSE + CALL moninobukm(hu,ht,hq,displa_lays(toplay),z0mv,z0hv,z0qv,obu,um, & + displa_lay(toplay),z0m_lay(toplay),ustar,fh2m,fq2m, & + htop_lay(toplay),fmtop,fm,fh,fq,fht,fqt,phih) + ENDIF ! 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. - ! 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 - 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 z0mv+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 + 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_lays(0) = z0hg - z0q_lays(0) = z0qg + z0h_lays(0) = z0hg + z0q_lays(0) = z0qg - z0h_lays(1) = maxval(z0h_lays(0:1)) - z0h_lays(2) = maxval(z0h_lays(0:2)) - z0h_lays(3) = maxval(z0h_lays(0:3)) + z0h_lays(1) = maxval(z0h_lays(0:1)) + z0h_lays(2) = maxval(z0h_lays(0:2)) + z0h_lays(3) = maxval(z0h_lays(0:3)) - z0q_lays(:) = z0h_lays(:) - z0hv = z0h_lays(3) - z0qv = z0q_lays(3) + z0q_lays(:) = z0h_lays(:) + z0hv = z0h_lays(3) + z0qv = z0q_lays(3) ! ...................................................................... ! new method to calculate rd and ueffect ! the kernel part of 3d model ! ...................................................................... - ! initialization - rd(:) = 0. - upplay = 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 * (htop_lay(toplay)-displa_lays(toplay)) * ustar / phih - - ! start layer loop - DO i = toplay, 1, -1 - - IF (fcover_lay(i)>0 .and. lsai_lay(i)>0) THEN - - IF (i .eq. toplay) THEN - utop_lay(i) = utop - ktop_lay(i) = ktop - ELSE - ! calculate utop of this layer - utop_lay(i) = uprofile(ubot_lay(upplay), fcover_lays(upplay), bee, 0., & - z0mg, hbot_lay(upplay), htop_lay(i), htop_lay(i)) - - ! calculate ktop of this layer - ktop_lay(i) = kprofile(kbot_lay(upplay), fcover_lays(upplay), bee, 0., & - displa_lays(toplay)/htop_lay(toplay), & - hbot_lay(upplay), htop_lay(i), obug, ustarg, htop_lay(i)) - - ! areodynamic resistance between this layer top and above layer bottom - ! 03/15/2020, yuan: vertical gaps between layers, fc = fcover_lays(upplay) or just 0? - rd(upplay) = rd(upplay) + frd(kbot_lay(upplay), hbot_lay(upplay), htop_lay(i), & - hbot_lay(upplay), htop_lay(i), displa_lays(toplay)/htop_lay(toplay), & - z0h_g, obug, ustarg, z0mg, 0., bee, fcover_lays(upplay)) - - ENDIF - - ! for robust check - hbot_lay(i) = max(hbot_lay(i), displa_lays(i-1)+z0m_lays(i-1)) - - ! wind speed at layer bottom - ubot_lay(i) = uprofile(utop_lay(i), fcover_lay(i), bee, a_lay(i), & - z0mg, htop_lay(i), hbot_lay(i), hbot_lay(i)) - - IF (it == 1) THEN - ueff_lay_norm(i) = ueffect(1., htop_lay(i), hbot_lay(i), & - z0mg, a_lay(i), bee, fcover_lay(i)) - ENDIF - ueff_lay(i) = utop_lay(i)*ueff_lay_norm(i) - - ! normalized eddy coefficient (K) at layer bottom - kbot_lay(i) = kprofile(ktop_lay(i), fcover_lay(i), bee, a_lay(i), & - displa_lays(toplay)/htop_lay(toplay), & - htop_lay(i), hbot_lay(i), obug, ustarg, hbot_lay(i)) - - ! areodynamic resistance from effective fluxes exchange height of - ! of this layer to the top of this layer - IF (upplay > 0) THEN - rd(upplay) = rd(upplay) + frd(ktop_lay(i), htop_lay(i), hbot_lay(i), & - htop_lay(i), displa_lay(i)+z0m_lay(i), displa_lays(toplay)/htop_lay(toplay), & - z0h_g, obug, ustarg, z0mg, a_lay(i), bee, fcover_lay(i)) - ENDIF - - rd(i) = rd(i) + frd(ktop_lay(i), htop_lay(i), hbot_lay(i), & - displa_lay(i)+z0m_lay(i), max(z0qg,hbot_lay(i)), & - displa_lays(toplay)/htop_lay(toplay), z0h_g, obug, ustarg, & - z0mg, a_lay(i), bee, fcover_lay(i)) - - upplay = i - - ENDIF - ENDDO + ! initialization + rd(:) = 0. + upplay = 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 * (htop_lay(toplay)-displa_lays(toplay)) * ustar / phih + + ! start layer loop + DO i = toplay, 1, -1 + + IF (fcover_lay(i)>0 .and. lsai_lay(i)>0) THEN + + IF (i .eq. toplay) THEN + utop_lay(i) = utop + ktop_lay(i) = ktop + ELSE + ! calculate utop of this layer + utop_lay(i) = uprofile(ubot_lay(upplay), fcover_lays(upplay), bee, 0., & + z0mg, hbot_lay(upplay), htop_lay(i), htop_lay(i)) + + ! calculate ktop of this layer + ktop_lay(i) = kprofile(kbot_lay(upplay), fcover_lays(upplay), bee, 0., & + displa_lays(toplay)/htop_lay(toplay), & + hbot_lay(upplay), htop_lay(i), obug, ustarg, htop_lay(i)) + + ! areodynamic resistance between this layer top and above layer bottom + ! 03/15/2020, yuan: vertical gaps between layers, fc = fcover_lays(upplay) or just 0? + rd(upplay) = rd(upplay) + frd(kbot_lay(upplay), hbot_lay(upplay), htop_lay(i), & + hbot_lay(upplay), htop_lay(i), displa_lays(toplay)/htop_lay(toplay), & + z0h_g, obug, ustarg, z0mg, 0., bee, fcover_lays(upplay)) + + ENDIF + + ! for robust check + hbot_lay(i) = max(hbot_lay(i), displa_lays(i-1)+z0m_lays(i-1)) + + ! wind speed at layer bottom + ubot_lay(i) = uprofile(utop_lay(i), fcover_lay(i), bee, a_lay(i), & + z0mg, htop_lay(i), hbot_lay(i), hbot_lay(i)) + + IF (it == 1) THEN + ueff_lay_norm(i) = ueffect(1., htop_lay(i), hbot_lay(i), & + z0mg, a_lay(i), bee, fcover_lay(i)) + ENDIF + ueff_lay(i) = utop_lay(i)*ueff_lay_norm(i) + + ! normalized eddy coefficient (K) at layer bottom + kbot_lay(i) = kprofile(ktop_lay(i), fcover_lay(i), bee, a_lay(i), & + displa_lays(toplay)/htop_lay(toplay), & + htop_lay(i), hbot_lay(i), obug, ustarg, hbot_lay(i)) + + ! areodynamic resistance from effective fluxes exchange height of + ! of this layer to the top of this layer + IF (upplay > 0) THEN + rd(upplay) = rd(upplay) + frd(ktop_lay(i), htop_lay(i), hbot_lay(i), & + htop_lay(i), displa_lay(i)+z0m_lay(i), displa_lays(toplay)/htop_lay(toplay), & + z0h_g, obug, ustarg, z0mg, a_lay(i), bee, fcover_lay(i)) + ENDIF + + rd(i) = rd(i) + frd(ktop_lay(i), htop_lay(i), hbot_lay(i), & + displa_lay(i)+z0m_lay(i), max(z0qg,hbot_lay(i)), & + displa_lays(toplay)/htop_lay(toplay), z0h_g, obug, ustarg, & + z0mg, a_lay(i), bee, fcover_lay(i)) + + upplay = i + + ENDIF + ENDDO ! ...................................................................... ! areodynamic resistance between ground and the upper layer bottom ! ...................................................................... - ! uncomment the below when the upper codes change to hbot_lay - !rd(botlay) = rd(botlay) + kintegral(kbot_lay(botlay), fcover_lays(botlay), bee, 0., & - ! z0mg, displa_lays(toplay)/htop_lay(toplay), & - ! hbot_lay(botlay), z0qg, obug, ustarg, hbot_lay(botlay), z0qg ) + ! uncomment the below when the upper codes change to hbot_lay + !rd(botlay) = rd(botlay) + kintegral(kbot_lay(botlay), fcover_lays(botlay), bee, 0., & + ! z0mg, displa_lays(toplay)/htop_lay(toplay), & + ! hbot_lay(botlay), z0qg, obug, ustarg, hbot_lay(botlay), z0qg ) - rd(botlay) = rd(botlay) + frd(kbot_lay(botlay), hbot_lay(botlay), z0qg, & - hbot_lay(botlay), z0qg, displa_lays(toplay)/htop_lay(toplay), & - z0h_g, obug, ustarg, z0mg, 0., bee, fcover_lays(botlay)) + rd(botlay) = rd(botlay) + frd(kbot_lay(botlay), hbot_lay(botlay), z0qg, & + hbot_lay(botlay), z0qg, displa_lays(toplay)/htop_lay(toplay), & + z0h_g, obug, ustarg, z0mg, 0., bee, fcover_lays(botlay)) ! ...................................................................... ! Bulk boundary layer resistance of leaves ! ...................................................................... - rb(:) = 0. - - DO i = ps, pe - IF (fcover(i)>0 .and. lsai(i)>1.e-6) THEN - clev = canlay(i) - cf = 0.01*sqrtdi(i)*sqrt(ueff_lay(clev)) - rb(i) = 1./cf - ENDIF - ENDDO - - ! 10/01/2017, back to 1D case, for test only - IF (rb_opt == 1) THEN - uaf = ustar - cf = 0.01*sqrtdi(2)/sqrt(uaf) - rb(:) = 1/(cf*uaf) - ENDIF - -! rd = 1./(csoilc*uaf) ! BATS legacy -! w = exp(-0.5*(lai+sai)) ! Dickinson's modification : -! csoilc = ( 1.-w + w*um/uaf)/rah ! "rah" here is the resistance over -! rd = 1./(csoilc*uaf) ! bare ground fraction - - ! 10/01/2017, back to 1D case, for test only - IF (rd_opt == 1 ) THEN + rb(:) = 0. + + DO i = ps, pe + IF (fcover(i)>0 .and. lsai(i)>1.e-6) THEN + clev = canlay(i) + cf = 0.01*sqrtdi(i)*sqrt(ueff_lay(clev)) + rb(i) = 1./cf + ENDIF + ENDDO + + ! 10/01/2017, back to 1D case, for test only + IF (rb_opt == 1) THEN + uaf = ustar + cf = 0.01*sqrtdi(2)/sqrt(uaf) + rb(:) = 1/(cf*uaf) + ENDIF + +! rd = 1./(csoilc*uaf) ! BATS legacy +! w = exp(-0.5*(lai+sai)) ! Dickinson's modification : +! csoilc = ( 1.-w + w*um/uaf)/rah ! "rah" here is the resistance over +! rd = 1./(csoilc*uaf) ! bare ground fraction + + ! 10/01/2017, back to 1D case, for test only + IF (rd_opt == 1 ) THEN ! modified by Xubin Zeng's suggestion at 08-07-2002 - uaf = ustar - w = exp(-(lai(2)+sai(2))) - csoilcn = (vonkar/(0.13*(z0mg*uaf/1.5e-5)**0.45))*w + csoilc*(1.-w) - rd(:) = 1./(csoilcn*uaf) - ENDIF + uaf = ustar + w = exp(-(lai(2)+sai(2))) + csoilcn = (vonkar/(0.13*(z0mg*uaf/1.5e-5)**0.45))*w + csoilc*(1.-w) + rd(:) = 1./(csoilcn*uaf) + ENDIF !----------------------------------------------------------------------- ! stomatal resistances !----------------------------------------------------------------------- - DO i = ps, pe - p = pftclass(i) - IF(fcover(i)>0 .and. lai(i)>0.001) THEN + DO i = ps, pe + p = pftclass(i) + IF(fcover(i)>0 .and. lai(i)>0.001) THEN - rbsun = rb(i) / laisun(i) - rbsha = rb(i) / laisha(i) + rbsun = rb(i) / laisun(i) + rbsha = rb(i) / laisha(i) - clev = canlay(i) - eah = qaf(clev) * psrf / ( 0.622 + 0.378 * qaf(clev) ) !pa + clev = canlay(i) + eah = qaf(clev) * psrf / ( 0.622 + 0.378 * qaf(clev) ) !pa - IF (DEF_USE_PLANTHYDRAULICS) THEN - rstfacsun(i) = 1. - rstfacsha(i) = 1. - END IF + IF (DEF_USE_PLANTHYDRAULICS) THEN + rstfacsun(i) = 1. + rstfacsha(i) = 1. + ENDIF ! note: calculate resistance for sunlit/shaded leaves !----------------------------------------------------------------------- - CALL stomata ( vmax25(i) ,effcon(i) ,slti(i) ,hlti(i) ,& - shti(i) ,hhti(i) ,trda(i) ,trdm(i) ,trop(i) ,& - g1(i) ,g0(i) ,gradm(i) ,binter(i) ,thm ,& - psrf ,po2m ,pco2m ,pco2a ,eah ,& - ei(i) ,tl(i) ,parsun(i) ,& + CALL stomata ( vmax25(i) ,effcon(i) ,slti(i) ,hlti(i) ,& + shti(i) ,hhti(i) ,trda(i) ,trdm(i) ,trop(i) ,& + g1(i) ,g0(i) ,gradm(i) ,binter(i) ,thm ,& + psrf ,po2m ,pco2m ,pco2a ,eah ,& + ei(i) ,tl(i) ,parsun(i) ,& !Ozone stress variables - o3coefv_sun(i), o3coefg_sun(i),& + o3coefv_sun(i), o3coefg_sun(i),& !End ozone stress variables - rbsun ,raw ,rstfacsun(i),cintsun(:,i),& - assimsun(i),respcsun(i),rssun(i) ) - - CALL stomata ( vmax25(i) ,effcon(i) ,slti(i) ,hlti(i) ,& - shti(i) ,hhti(i) ,trda(i) ,trdm(i) ,trop(i) ,& - g1(i) ,g0(i) ,gradm(i) ,binter(i) ,thm ,& - psrf ,po2m ,pco2m ,pco2a ,eah ,& - ei(i) ,tl(i) ,parsha(i) ,& + rbsun ,raw ,rstfacsun(i),cintsun(:,i),& + assimsun(i),respcsun(i),rssun(i) ) + + CALL stomata ( vmax25(i) ,effcon(i) ,slti(i) ,hlti(i) ,& + shti(i) ,hhti(i) ,trda(i) ,trdm(i) ,trop(i) ,& + g1(i) ,g0(i) ,gradm(i) ,binter(i) ,thm ,& + psrf ,po2m ,pco2m ,pco2a ,eah ,& + ei(i) ,tl(i) ,parsha(i) ,& !Ozone stress variables - o3coefv_sun(i), o3coefg_sun(i),& + o3coefv_sun(i), o3coefg_sun(i),& !End ozone stress variables - rbsha ,raw ,rstfacsha(i),cintsha(:,i),& - assimsha(i),respcsha(i),rssha(i) ) - - IF (DEF_USE_PLANTHYDRAULICS) THEN - - gs0sun(i) = min( 1.e6, 1./(rssun(i)*tl(i)/tprcor) )/ laisun(i) * 1.e6 - gs0sha(i) = min( 1.e6, 1./(rssha(i)*tl(i)/tprcor) )/ laisha(i) * 1.e6 - - CALL PlantHydraulicStress_twoleaf (nl_soil ,nvegwcs ,z_soi ,& - dz_soi ,rootfr(:,i) ,psrf ,qsatl(i) ,qaf(clev) ,& - tl(i) ,rbsun ,rss ,raw ,sum(rd(1:clev)),& - rstfacsun(i) ,rstfacsha(i) ,cintsun(:,i) ,cintsha(:,i) ,laisun(i) ,& - laisha(i) ,rhoair ,fwet(i) ,sai(i) ,kmax_sun(i) ,& - kmax_sha(i) ,kmax_xyl(i) ,kmax_root(i) ,psi50_sun(i) ,psi50_sha(i) ,& - psi50_xyl(i) ,psi50_root(i),htop(i) ,ck(i) ,smp ,& - hk ,hksati ,vegwp(:,i) ,etrsun(i) ,etrsha(i) ,& - rootflux(:,i),qg ,qm ,gs0sun(i) ,gs0sha(i) ,& - k_soil_root ,k_ax_root ,gssun(i) ,gssha(i) ) - - etr(i) = etrsun(i) + etrsha(i) - gssun(i) = gssun(i) * laisun(i) - gssha(i) = gssha(i) * laisha(i) - - CALL update_photosyn(tl(i), po2m, pco2m, pco2a, parsun(i), psrf, rstfacsun(i), rb(i), gssun(i), & - effcon(i), vmax25(i), gradm(i), trop(i), slti(i), hlti(i), shti(i), hhti(i), & - trda(i), trdm(i), cintsun(:,i), assimsun(i), respcsun(i)) - - CALL update_photosyn(tl(i), po2m, pco2m, pco2a, parsha(i), psrf, rstfacsha(i), rb(i), gssha(i), & - effcon(i), vmax25(i), gradm(i), trop(i), slti(i), hlti(i), shti(i), hhti(i), & - trda(i), trdm(i), cintsha(:,i), assimsha(i), respcsha(i)) - - ! leaf scale stomata resisitence - rssun(i) = tprcor / tl(i) * 1.e6 /gssun(i) - rssha(i) = tprcor / tl(i) * 1.e6 /gssha(i) - - ENDIF - - ELSE - rssun(i) = 2.e4; assimsun(i) = 0.; respcsun(i) = 0. - rssha(i) = 2.e4; assimsha(i) = 0.; respcsha(i) = 0. - IF (DEF_USE_PLANTHYDRAULICS) THEN - etr(i) = 0. - rootflux(:,i) = 0. - ENDIF - ENDIF - ENDDO + rbsha ,raw ,rstfacsha(i),cintsha(:,i),& + assimsha(i),respcsha(i),rssha(i) ) + + IF (DEF_USE_PLANTHYDRAULICS) THEN + + gs0sun(i) = min( 1.e6, 1./(rssun(i)*tl(i)/tprcor) )/ laisun(i) * 1.e6 + gs0sha(i) = min( 1.e6, 1./(rssha(i)*tl(i)/tprcor) )/ laisha(i) * 1.e6 + + CALL PlantHydraulicStress_twoleaf (nl_soil ,nvegwcs ,z_soi ,& + dz_soi ,rootfr(:,i) ,psrf ,qsatl(i) ,qaf(clev) ,& + tl(i) ,rbsun ,rss ,raw ,sum(rd(1:clev)),& + rstfacsun(i) ,rstfacsha(i) ,cintsun(:,i) ,cintsha(:,i) ,laisun(i) ,& + laisha(i) ,rhoair ,fwet(i) ,sai(i) ,kmax_sun(i) ,& + kmax_sha(i) ,kmax_xyl(i) ,kmax_root(i) ,psi50_sun(i) ,psi50_sha(i) ,& + psi50_xyl(i) ,psi50_root(i),htop(i) ,ck(i) ,smp ,& + hk ,hksati ,vegwp(:,i) ,etrsun(i) ,etrsha(i) ,& + rootflux(:,i),qg ,qm ,gs0sun(i) ,gs0sha(i) ,& + k_soil_root ,k_ax_root ,gssun(i) ,gssha(i) ) + + etr(i) = etrsun(i) + etrsha(i) + gssun(i) = gssun(i) * laisun(i) + gssha(i) = gssha(i) * laisha(i) + + CALL update_photosyn(tl(i), po2m, pco2m, pco2a, parsun(i), psrf, rstfacsun(i), rb(i), gssun(i), & + effcon(i), vmax25(i), gradm(i), trop(i), slti(i), hlti(i), shti(i), hhti(i), & + trda(i), trdm(i), cintsun(:,i), assimsun(i), respcsun(i)) + + CALL update_photosyn(tl(i), po2m, pco2m, pco2a, parsha(i), psrf, rstfacsha(i), rb(i), gssha(i), & + effcon(i), vmax25(i), gradm(i), trop(i), slti(i), hlti(i), shti(i), hhti(i), & + trda(i), trdm(i), cintsha(:,i), assimsha(i), respcsha(i)) + + ! leaf scale stomata resisitence + rssun(i) = tprcor / tl(i) * 1.e6 /gssun(i) + rssha(i) = tprcor / tl(i) * 1.e6 /gssha(i) + + ENDIF + + ELSE + rssun(i) = 2.e4; assimsun(i) = 0.; respcsun(i) = 0. + rssha(i) = 2.e4; assimsha(i) = 0.; respcsha(i) = 0. + IF (DEF_USE_PLANTHYDRAULICS) THEN + etr(i) = 0. + rootflux(:,i) = 0. + ENDIF + ENDIF + ENDDO ! above stomatal resistances are for the canopy, the stomatal rsistances ! and the "rb" in the following calculations are the average for single leaf. thus, - rssun = rssun * laisun - rssha = rssha * laisha + rssun = rssun * laisun + rssha = rssha * laisha !----------------------------------------------------------------------- ! dimensional and non-dimensional sensible and latent heat conductances ! for canopy and soil flux calculations. !----------------------------------------------------------------------- - cfh(:) = 0. - cfw(:) = 0. + cfh(:) = 0. + cfw(:) = 0. - DO i = ps, pe - IF (fcover(i)>0 .and. lsai(i)>1.e-6) THEN + DO i = ps, pe + IF (fcover(i)>0 .and. lsai(i)>1.e-6) THEN - clev = canlay(i) - delta(i) = 0.0 - IF(qsatl(i)-qaf(clev) .gt. 0.) delta(i) = 1.0 + clev = canlay(i) + delta(i) = 0.0 + IF(qsatl(i)-qaf(clev) .gt. 0.) delta(i) = 1.0 - cfh(i) = lsai(i) / rb(i) + cfh(i) = lsai(i) / rb(i) ! note: combine sunlit and shaded leaves !----------------------------------------------------------------------- - cfw(i) = (1.-delta(i)*(1.-fwet(i)))*lsai(i)/rb(i) + & - (1.-fwet(i))*delta(i)* & - ( laisun(i)/(rb(i)+rssun(i)) + laisha(i)/(rb(i)+rssha(i)) ) - ENDIF - ENDDO - - ! initialization - cah(:) = 0. - caw(:) = 0. - cgh(:) = 0. - cgw(:) = 0. - - DO i = 1, nlay - IF (fcover_lay(i)>0 .and. lsai_lay(i)>0) THEN - IF (i == toplay) 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) - IF (i == botlay) THEN - IF (qg < qaf(botlay)) THEN - cgw(i) = 1. / rd(i) !dew case. no soil resistance - ELSE - IF (DEF_RSS_SCHEME .eq. 4) THEN - cgw(i) = rss/ rd(i) - ELSE - cgw(i) = 1. / (rd(i) + rss) - ENDIF - ENDIF - ELSE - cgw(i) = 1. / rd(i) - ENDIF - ENDIF - ENDDO - - ! claculate wtshi, wtsqi - wtshi(:) = cah(:) + cgh(:) - wtsqi(:) = caw(:) + cgw(:) - - DO i = ps, pe - IF (fcover(i)>0 .and. lsai(i)>1.e-6) THEN - clev = canlay(i) - wtshi(clev) = wtshi(clev) + fcover(i)*cfh(i) - wtsqi(clev) = wtsqi(clev) + fcover(i)*cfw(i) - ENDIF - ENDDO - - DO i = 1, nlay - IF (fcover_lay(i)>0 .and. lsai_lay(i)>0) THEN - wtshi(i) = 1./wtshi(i) - wtsqi(i) = 1./wtsqi(i) - ENDIF - ENDDO - - wta0(:) = cah(:) * wtshi(:) - wtg0(:) = cgh(:) * wtshi(:) - - wtaq0(:) = caw(:) * wtsqi(:) - wtgq0(:) = cgw(:) * wtsqi(:) - - ! calculate wtl0, wtll, wtlq0, wtlql - wtll(:) = 0. - wtlql(:) = 0. - - DO i = ps, pe - IF (fcover(i)>0 .and. lsai(i)>1.e-6) THEN - clev = canlay(i) - - wtl0(i) = cfh(i) * wtshi(clev) * fcover(i) - wtll(clev) = wtll(clev) + wtl0(i)*tl(i) - - wtlq0(i) = cfw(i) * wtsqi(clev) * fcover(i) - wtlql(clev) = wtlql(clev) + wtlq0(i)*qsatl(i) - ENDIF - ENDDO - - ! to solve taf(:) and qaf(:) - IF (numlay .eq. 1) THEN - - taf(toplay) = wta0(toplay)*thm + wtg0(toplay)*tg + wtll(toplay) - qaf(toplay) = wtaq0(toplay)*qm + wtgq0(toplay)*qg + wtlql(toplay) - fact = 1. - facq = 1. - - ENDIF - - IF (numlay .eq. 2) THEN - - tmpw1 = wtg0(botlay)*tg + wtll(botlay) - fact = 1. - wtg0(toplay)*wta0(botlay) - taf(toplay) = ( wta0(toplay)*thm + wtg0(toplay)*tmpw1 + wtll(toplay) ) / fact - - tmpw1 = wtgq0(botlay)*qg + wtlql(botlay) - facq = 1. - wtgq0(toplay)*wtaq0(botlay) - qaf(toplay) = ( wtaq0(toplay)*qm + wtgq0(toplay)*tmpw1 + wtlql(toplay) ) / facq - - taf(botlay) = wta0(botlay)*taf(toplay) + wtg0(botlay)*tg + wtll(botlay) - qaf(botlay) = wtaq0(botlay)*qaf(toplay) + wtgq0(botlay)*qg + wtlql(botlay) - - ENDIF - - IF (numlay .eq. 3) THEN - - tmpw1 = wta0(3)*thm + wtll(3) - tmpw2 = wtg0(1)*tg + wtll(1) - fact = 1. - wta0(2)*wtg0(3) - wtg0(2)*wta0(1) - taf(2) = ( wta0(2)*tmpw1 + wtg0(2)*tmpw2 + wtll(2) ) / fact - - tmpw1 = wtaq0(3)*qm + wtlql(3) - tmpw2 = wtgq0(1)*qg + wtlql(1) - facq = 1. - wtaq0(2)*wtgq0(3) - wtgq0(2)*wtaq0(1) - qaf(2) = ( wtaq0(2)*tmpw1 + wtgq0(2)*tmpw2 + wtlql(2) ) / facq - - taf(1) = wta0(1)*taf(2) + wtg0(1)*tg + wtll(1) - qaf(1) = wtaq0(1)*qaf(2) + wtgq0(1)*qg + wtlql(1) + cfw(i) = (1.-delta(i)*(1.-fwet(i)))*lsai(i)/rb(i) + & + (1.-fwet(i))*delta(i)* & + ( laisun(i)/(rb(i)+rssun(i)) + laisha(i)/(rb(i)+rssha(i)) ) + ENDIF + ENDDO + + ! initialization + cah(:) = 0. + caw(:) = 0. + cgh(:) = 0. + cgw(:) = 0. + + DO i = 1, nlay + IF (fcover_lay(i)>0 .and. lsai_lay(i)>0) THEN + IF (i == toplay) 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) + IF (i == botlay) THEN + IF (qg < qaf(botlay)) THEN + cgw(i) = 1. / rd(i) !dew case. no soil resistance + ELSE + IF (DEF_RSS_SCHEME .eq. 4) THEN + cgw(i) = rss/ rd(i) + ELSE + cgw(i) = 1. / (rd(i) + rss) + ENDIF + ENDIF + ELSE + cgw(i) = 1. / rd(i) + ENDIF + ENDIF + ENDDO + + ! claculate wtshi, wtsqi + wtshi(:) = cah(:) + cgh(:) + wtsqi(:) = caw(:) + cgw(:) + + DO i = ps, pe + IF (fcover(i)>0 .and. lsai(i)>1.e-6) THEN + clev = canlay(i) + wtshi(clev) = wtshi(clev) + fcover(i)*cfh(i) + wtsqi(clev) = wtsqi(clev) + fcover(i)*cfw(i) + ENDIF + ENDDO + + DO i = 1, nlay + IF (fcover_lay(i)>0 .and. lsai_lay(i)>0) THEN + wtshi(i) = 1./wtshi(i) + wtsqi(i) = 1./wtsqi(i) + ENDIF + ENDDO + + wta0(:) = cah(:) * wtshi(:) + wtg0(:) = cgh(:) * wtshi(:) + + wtaq0(:) = caw(:) * wtsqi(:) + wtgq0(:) = cgw(:) * wtsqi(:) + + ! calculate wtl0, wtll, wtlq0, wtlql + wtll(:) = 0. + wtlql(:) = 0. + + DO i = ps, pe + IF (fcover(i)>0 .and. lsai(i)>1.e-6) THEN + clev = canlay(i) + + wtl0(i) = cfh(i) * wtshi(clev) * fcover(i) + wtll(clev) = wtll(clev) + wtl0(i)*tl(i) + + wtlq0(i) = cfw(i) * wtsqi(clev) * fcover(i) + wtlql(clev) = wtlql(clev) + wtlq0(i)*qsatl(i) + ENDIF + ENDDO + + ! to solve taf(:) and qaf(:) + IF (numlay .eq. 1) THEN + + taf(toplay) = wta0(toplay)*thm + wtg0(toplay)*tg + wtll(toplay) + qaf(toplay) = wtaq0(toplay)*qm + wtgq0(toplay)*qg + wtlql(toplay) + fact = 1. + facq = 1. + + ENDIF + + IF (numlay .eq. 2) THEN + + tmpw1 = wtg0(botlay)*tg + wtll(botlay) + fact = 1. - wtg0(toplay)*wta0(botlay) + taf(toplay) = ( wta0(toplay)*thm + wtg0(toplay)*tmpw1 + wtll(toplay) ) / fact + + tmpw1 = wtgq0(botlay)*qg + wtlql(botlay) + facq = 1. - wtgq0(toplay)*wtaq0(botlay) + qaf(toplay) = ( wtaq0(toplay)*qm + wtgq0(toplay)*tmpw1 + wtlql(toplay) ) / facq + + taf(botlay) = wta0(botlay)*taf(toplay) + wtg0(botlay)*tg + wtll(botlay) + qaf(botlay) = wtaq0(botlay)*qaf(toplay) + wtgq0(botlay)*qg + wtlql(botlay) + + ENDIF + + IF (numlay .eq. 3) THEN + + tmpw1 = wta0(3)*thm + wtll(3) + tmpw2 = wtg0(1)*tg + wtll(1) + fact = 1. - wta0(2)*wtg0(3) - wtg0(2)*wta0(1) + taf(2) = ( wta0(2)*tmpw1 + wtg0(2)*tmpw2 + wtll(2) ) / fact + + tmpw1 = wtaq0(3)*qm + wtlql(3) + tmpw2 = wtgq0(1)*qg + wtlql(1) + facq = 1. - wtaq0(2)*wtgq0(3) - wtgq0(2)*wtaq0(1) + qaf(2) = ( wtaq0(2)*tmpw1 + wtgq0(2)*tmpw2 + wtlql(2) ) / facq + + taf(1) = wta0(1)*taf(2) + wtg0(1)*tg + wtll(1) + qaf(1) = wtaq0(1)*qaf(2) + wtgq0(1)*qg + wtlql(1) - taf(3) = wta0(3)*thm + wtg0(3)*taf(2) + wtll(3) - qaf(3) = wtaq0(3)*qm + wtgq0(3)*qaf(2) + wtlql(3) - - ENDIF + taf(3) = wta0(3)*thm + wtg0(3)*taf(2) + wtll(3) + qaf(3) = wtaq0(3)*qm + wtgq0(3)*qaf(2) + wtlql(3) + + ENDIF !----------------------------------------------------------------------- ! IR radiation, sensible and latent heat fluxes and their derivatives @@ -1293,574 +1293,574 @@ SUBROUTINE LeafTemperaturePC ( & ! which cannot be determined analtically ! calculate L for each canopy layer - L(:) = 0. - DO i = ps, pe - IF (fcover(i)>0 .and. lsai(i)>1.e-6) THEN - clev = canlay(i) - ! according to absorption = emissivity, fcover -> fshade - L(clev) = L(clev) + fshade(i) * (1-thermk(i)) * stefnc * tl(i)**4 - ENDIF - ENDDO + L(:) = 0. + DO i = ps, pe + IF (fcover(i)>0 .and. lsai(i)>1.e-6) THEN + clev = canlay(i) + ! according to absorption = emissivity, fcover -> fshade + L(clev) = L(clev) + fshade(i) * (1-thermk(i)) * stefnc * tl(i)**4 + ENDIF + ENDDO ! calculate Ltd - Ltd(:) = 0. - Ltd(3) = thermk_lay(3) * tdn(4,3) * frl - Ltd(2) = thermk_lay(2) * ( tdn(4,2)*frl + tdn(3,2)*(Ltd(3) + L(3)) ) - Ltd(1) = thermk_lay(1) * ( tdn(4,1)*frl + tdn(3,1)*(Ltd(3) + L(3)) + & - tdn(2,1)*(Ltd(2) + L(2)) ) + Ltd(:) = 0. + Ltd(3) = thermk_lay(3) * tdn(4,3) * frl + Ltd(2) = thermk_lay(2) * ( tdn(4,2)*frl + tdn(3,2)*(Ltd(3) + L(3)) ) + Ltd(1) = thermk_lay(1) * ( tdn(4,1)*frl + tdn(3,1)*(Ltd(3) + L(3)) + & + tdn(2,1)*(Ltd(2) + L(2)) ) ! calculate Ld = Ltd + L - Ld(0) = 0. - Ld(4) = frl - Ld(1:3) = Ltd + L + Ld(0) = 0. + Ld(4) = frl + Ld(1:3) = Ltd + L ! calculate Lin = Ld * tdn - Lin(:) = matmul(Ld(:), tdn(:,:)) + Lin(:) = matmul(Ld(:), tdn(:,:)) ! calcilate Lg = (1-emg)*dlrad + emg*stefnc*tg**4 ! dlrad = Lin(0) IF (.not.DEF_SPLIT_SOILSNOW) THEN - Lg = (1 - emg)*Lin(0) + emg*stefnc*tg**4 + Lg = (1 - emg)*Lin(0) + emg*stefnc*tg**4 ELSE - Lg = (1 - emg)*Lin(0) & - + (1.-fsno)*emg*stefnc*t_soil**4 & - + fsno*emg*stefnc*t_snow**4 + Lg = (1 - emg)*Lin(0) & + + (1.-fsno)*emg*stefnc*t_soil**4 & + + fsno*emg*stefnc*t_snow**4 ENDIF ! calculate Ltu - Ltu(1) = thermk_lay(1) * tup(0,1) * Lg - Ltu(2) = thermk_lay(2) * ( tup(0,2)*Lg + tup(1,2)*(Ltu(1) + L(1)) ) - Ltu(3) = thermk_lay(3) * ( tup(0,3)*Lg + tup(1,3)*(Ltu(1) + L(1)) + & + Ltu(1) = thermk_lay(1) * tup(0,1) * Lg + Ltu(2) = thermk_lay(2) * ( tup(0,2)*Lg + tup(1,2)*(Ltu(1) + L(1)) ) + Ltu(3) = thermk_lay(3) * ( tup(0,3)*Lg + tup(1,3)*(Ltu(1) + L(1)) + & tup(2,3)*(Ltu(2) + L(2)) ) ! calculate Lu = Ltu + L - Lu(0) = Lg - Lu(4) = 0. - Lu(1:3) = Ltu + L + Lu(0) = Lg + Lu(4) = 0. + Lu(1:3) = Ltu + L ! calculate Lin = Lin + Lu*tup - Lin(:) = Lin(:) + matmul(Lu(:), tup(:,:)) + Lin(:) = Lin(:) + matmul(Lu(:), tup(:,:)) ! calculate Lv - Lv(:) = 0. - DO i = ps, pe - IF (fshade(i)>0 .and. canlay(i)>0) THEN - clev = canlay(i) - Lv(i) = fshade(i)/fshade_lay(clev) * (1-thermk(i)) * Lin(clev) / fcover(i) & - - 2. * fshade(i) * (1-thermk(i)) * stefnc * tl(i)**4 / fcover(i) - ENDIF - ENDDO + Lv(:) = 0. + DO i = ps, pe + IF (fshade(i)>0 .and. canlay(i)>0) THEN + clev = canlay(i) + Lv(i) = fshade(i)/fshade_lay(clev) * (1-thermk(i)) * Lin(clev) / fcover(i) & + - 2. * fshade(i) * (1-thermk(i)) * stefnc * tl(i)**4 / fcover(i) + ENDIF + ENDDO ! calculate delata(Lv) - dLv(:) = 0. - DO i = ps, pe - IF (fshade(i)>0 .and. canlay(i)>0) THEN - clev = canlay(i) - dLv(i) = (4.*dLvpar(clev)*(1-emg)*fshade(i)*(1-thermk(i)) - 8.) & - * fshade(i) * (1-thermk(i)) * stefnc * tl(i)**3 / fcover(i) - ENDIF - ENDDO + dLv(:) = 0. + DO i = ps, pe + IF (fshade(i)>0 .and. canlay(i)>0) THEN + clev = canlay(i) + dLv(i) = (4.*dLvpar(clev)*(1-emg)*fshade(i)*(1-thermk(i)) - 8.) & + * fshade(i) * (1-thermk(i)) * stefnc * tl(i)**3 / fcover(i) + ENDIF + ENDDO !----------------------------------------------------------------------- - irab(:) = Lv(:) - dirab_dtl(:) = dLv(:) + irab(:) = Lv(:) + dirab_dtl(:) = dLv(:) - DO i = ps, pe + DO i = ps, pe - IF (fcover(i)>0 .and. lsai(i)>1.e-6) THEN + IF (fcover(i)>0 .and. lsai(i)>1.e-6) THEN - clev = canlay(i) - fac(i) = 1. - thermk(i) + clev = canlay(i) + fac(i) = 1. - thermk(i) ! sensible heat fluxes and their derivatives - fsenl(i) = rhoair * cpair * cfh(i) * (tl(i) - taf(clev)) - - ! 09/25/2017: re-written, check it clearfully - ! When numlay<3, no matter how to calculate, /fact is consistent - IF (numlay < 3 .or. clev == 2) THEN - fsenl_dtl(i) = rhoair * cpair * cfh(i) * (1. - wtl0(i)/fact) - ELSE - IF (clev == 1) THEN - fsenl_dtl(i) = rhoair * cpair * cfh(i) * & - !(1. - (1.-wta0(2)*wtg0(3))*wtl0(i)/fact) or - (1. - wta0(1)*wtg0(2)*wtl0(i)/fact - wtl0(i)) - ENDIF - IF (clev == 3) THEN - fsenl_dtl(i) = rhoair * cpair * cfh(i) * & - !(1. - (1.-wtg0(2)*wta0(1))*wtl0(i)/fact) or - (1. - wtg0(3)*wta0(2)*wtl0(i)/fact - wtl0(i)) - ENDIF - ENDIF + fsenl(i) = rhoair * cpair * cfh(i) * (tl(i) - taf(clev)) + + ! 09/25/2017: re-written, check it clearfully + ! When numlay<3, no matter how to calculate, /fact is consistent + IF (numlay < 3 .or. clev == 2) THEN + fsenl_dtl(i) = rhoair * cpair * cfh(i) * (1. - wtl0(i)/fact) + ELSE + IF (clev == 1) THEN + fsenl_dtl(i) = rhoair * cpair * cfh(i) * & + !(1. - (1.-wta0(2)*wtg0(3))*wtl0(i)/fact) or + (1. - wta0(1)*wtg0(2)*wtl0(i)/fact - wtl0(i)) + ENDIF + IF (clev == 3) THEN + fsenl_dtl(i) = rhoair * cpair * cfh(i) * & + !(1. - (1.-wtg0(2)*wta0(1))*wtl0(i)/fact) or + (1. - wtg0(3)*wta0(2)*wtl0(i)/fact - wtl0(i)) + ENDIF + ENDIF ! latent heat fluxes and their derivatives - etr(i) = rhoair * (1.-fwet(i)) * delta(i) & - * ( laisun(i)/(rb(i)+rssun(i)) + laisha(i)/(rb(i)+rssha(i)) ) & - * ( qsatl(i) - qaf(clev) ) - ! 09/25/2017: re-written - IF (numlay < 3 .or. clev == 2) THEN - etr_dtl(i) = rhoair * (1.-fwet(i)) * delta(i) & + etr(i) = rhoair * (1.-fwet(i)) * delta(i) & * ( laisun(i)/(rb(i)+rssun(i)) + laisha(i)/(rb(i)+rssha(i)) ) & - * (1. - wtlq0(i)/facq)*qsatlDT(i) - ELSE - IF (clev == 1) THEN - etr_dtl(i) = rhoair * (1.-fwet(i)) * delta(i) & - * ( laisun(i)/(rb(i)+rssun(i)) + laisha(i)/(rb(i)+rssha(i)) ) & - !* (1. - (1.-wtaq0(2)*wtgq0(3))*wtlq0(i)/facq)*qsatlDT(i) or - * (1. - wtaq0(1)*wtgq0(2)*wtlq0(i)/facq - wtlq0(i))*qsatlDT(i) - ENDIF - IF (clev == 3) THEN - etr_dtl(i) = rhoair * (1.-fwet(i)) * delta(i) & - * ( laisun(i)/(rb(i)+rssun(i)) + laisha(i)/(rb(i)+rssha(i)) ) & - !* (1. - (1.-wtgq0(2)*wtaq0(1))*wtlq0(i)/facq)*qsatlDT(i) or - * (1. - wtgq0(3)*wtaq0(2)*wtlq0(i)/facq - wtlq0(i))*qsatlDT(i) - ENDIF - ENDIF - - IF (.not. DEF_USE_PLANTHYDRAULICS) THEN - IF(etr(i).ge.etrc(i))THEN - etr(i) = etrc(i) - etr_dtl(i) = 0. - ENDIF - ENDIF - - evplwet(i) = rhoair * (1.-delta(i)*(1.-fwet(i))) * lsai(i)/rb(i) & - * ( qsatl(i) - qaf(clev) ) - - ! 09/25/2017: re-written - IF (numlay < 3 .or. clev == 2) THEN - evplwet_dtl(i) = rhoair * (1.-delta(i)*(1.-fwet(i))) * lsai(i)/rb(i) & - * (1. - wtlq0(i)/facq)*qsatlDT(i) - ELSE - IF (clev == 1) THEN - evplwet_dtl(i) = rhoair * (1.-delta(i)*(1.-fwet(i))) * lsai(i)/rb(i) & - !* (1. - (1-wtaq0(2)*wtgq0(3))*wtlq0(i)/facq)*qsatlDT(i) or - * (1. - wtaq0(1)*wtgq0(2)*wtlq0(i)/facq - wtlq0(i))*qsatlDT(i) - ENDIF - IF (clev == 3) THEN - evplwet_dtl(i) = rhoair * (1.-delta(i)*(1.-fwet(i))) * lsai(i)/rb(i) & - !* (1. - (1.-wtgq0(2)*wtaq0(1))*wtlq0(i)/facq)*qsatlDT(i) - * (1. - wtgq0(3)*wtaq0(2)*wtlq0(i)/facq - wtlq0(i))*qsatlDT(i) - ENDIF - ENDIF - - ! 03/02/2018: convert evplwet from fc to whole area - ! because ldew right now is for the whole area - ! 09/05/2019: back to fc area - IF(evplwet(i).ge.ldew(i)/deltim)THEN - evplwet(i) = ldew(i)/deltim - evplwet_dtl(i) = 0. - ENDIF - - fevpl(i) = etr(i) + evplwet(i) - fevpl_dtl(i) = etr_dtl(i) + evplwet_dtl(i) - - erre(i) = 0. - fevpl_noadj(i) = fevpl(i) - IF ( fevpl(i)*fevpl_bef(i) < 0. ) THEN - erre(i) = -0.9*fevpl(i) - fevpl(i) = 0.1*fevpl(i) - ENDIF + * ( qsatl(i) - qaf(clev) ) + ! 09/25/2017: re-written + IF (numlay < 3 .or. clev == 2) THEN + etr_dtl(i) = rhoair * (1.-fwet(i)) * delta(i) & + * ( laisun(i)/(rb(i)+rssun(i)) + laisha(i)/(rb(i)+rssha(i)) ) & + * (1. - wtlq0(i)/facq)*qsatlDT(i) + ELSE + IF (clev == 1) THEN + etr_dtl(i) = rhoair * (1.-fwet(i)) * delta(i) & + * ( laisun(i)/(rb(i)+rssun(i)) + laisha(i)/(rb(i)+rssha(i)) ) & + !* (1. - (1.-wtaq0(2)*wtgq0(3))*wtlq0(i)/facq)*qsatlDT(i) or + * (1. - wtaq0(1)*wtgq0(2)*wtlq0(i)/facq - wtlq0(i))*qsatlDT(i) + ENDIF + IF (clev == 3) THEN + etr_dtl(i) = rhoair * (1.-fwet(i)) * delta(i) & + * ( laisun(i)/(rb(i)+rssun(i)) + laisha(i)/(rb(i)+rssha(i)) ) & + !* (1. - (1.-wtgq0(2)*wtaq0(1))*wtlq0(i)/facq)*qsatlDT(i) or + * (1. - wtgq0(3)*wtaq0(2)*wtlq0(i)/facq - wtlq0(i))*qsatlDT(i) + ENDIF + ENDIF + + IF (.not. DEF_USE_PLANTHYDRAULICS) THEN + IF(etr(i).ge.etrc(i))THEN + etr(i) = etrc(i) + etr_dtl(i) = 0. + ENDIF + ENDIF + + evplwet(i) = rhoair * (1.-delta(i)*(1.-fwet(i))) * lsai(i)/rb(i) & + * ( qsatl(i) - qaf(clev) ) + + ! 09/25/2017: re-written + IF (numlay < 3 .or. clev == 2) THEN + evplwet_dtl(i) = rhoair * (1.-delta(i)*(1.-fwet(i))) * lsai(i)/rb(i) & + * (1. - wtlq0(i)/facq)*qsatlDT(i) + ELSE + IF (clev == 1) THEN + evplwet_dtl(i) = rhoair * (1.-delta(i)*(1.-fwet(i))) * lsai(i)/rb(i) & + !* (1. - (1-wtaq0(2)*wtgq0(3))*wtlq0(i)/facq)*qsatlDT(i) or + * (1. - wtaq0(1)*wtgq0(2)*wtlq0(i)/facq - wtlq0(i))*qsatlDT(i) + ENDIF + IF (clev == 3) THEN + evplwet_dtl(i) = rhoair * (1.-delta(i)*(1.-fwet(i))) * lsai(i)/rb(i) & + !* (1. - (1.-wtgq0(2)*wtaq0(1))*wtlq0(i)/facq)*qsatlDT(i) + * (1. - wtgq0(3)*wtaq0(2)*wtlq0(i)/facq - wtlq0(i))*qsatlDT(i) + ENDIF + ENDIF + + ! 03/02/2018: convert evplwet from fc to whole area + ! because ldew right now is for the whole area + ! 09/05/2019: back to fc area + IF(evplwet(i).ge.ldew(i)/deltim)THEN + evplwet(i) = ldew(i)/deltim + evplwet_dtl(i) = 0. + ENDIF + + fevpl(i) = etr(i) + evplwet(i) + fevpl_dtl(i) = etr_dtl(i) + evplwet_dtl(i) + + erre(i) = 0. + fevpl_noadj(i) = fevpl(i) + IF ( fevpl(i)*fevpl_bef(i) < 0. ) THEN + erre(i) = -0.9*fevpl(i) + fevpl(i) = 0.1*fevpl(i) + ENDIF !----------------------------------------------------------------------- ! difference of temperatures by quasi-newton-raphson method for the non-linear system equations !----------------------------------------------------------------------- - dtl(it,i) = (sabv(i) + irab(i) - fsenl(i) - hvap*fevpl(i) & - + cpliq*qintr_rain(i)*(t_precip-tl(i)) + cpice*qintr_snow(i)*(t_precip-tl(i))) & - / (lsai(i)*clai/deltim - dirab_dtl(i) + fsenl_dtl(i) + hvap*fevpl_dtl(i) & - + cpliq*qintr_rain(i) + cpice*qintr_snow(i)) + dtl(it,i) = (sabv(i) + irab(i) - fsenl(i) - hvap*fevpl(i) & + + cpliq*qintr_rain(i)*(t_precip-tl(i)) + cpice*qintr_snow(i)*(t_precip-tl(i))) & + / (lsai(i)*clai/deltim - dirab_dtl(i) + fsenl_dtl(i) + hvap*fevpl_dtl(i) & + + cpliq*qintr_rain(i) + cpice*qintr_snow(i)) - dtl_noadj(i) = dtl(it,i) + dtl_noadj(i) = dtl(it,i) - ! 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,i)).gt.delmax)THEN - dtl(it,i) = delmax*dtl(it,i)/abs(dtl(it,i)) - ENDIF + ! put brakes on large temperature excursions + IF(abs(dtl(it,i)).gt.delmax)THEN + dtl(it,i) = delmax*dtl(it,i)/abs(dtl(it,i)) + ENDIF - ! NOTE: could be a bug if dtl*dtl==0, changed from lt->le - IF((it.ge.2) .and. (dtl(it-1,i)*dtl(it,i).le.0.))THEN - dtl(it,i) = 0.5*(dtl(it-1,i) + dtl(it,i)) - ENDIF + ! NOTE: could be a bug if dtl*dtl==0, changed from lt->le + IF((it.ge.2) .and. (dtl(it-1,i)*dtl(it,i).le.0.))THEN + dtl(it,i) = 0.5*(dtl(it-1,i) + dtl(it,i)) + ENDIF - ENDIF + ENDIF - tl(i) = tlbef(i) + dtl(it,i) + tl(i) = tlbef(i) + dtl(it,i) !----------------------------------------------------------------------- ! square roots differences of temperatures and fluxes for USE as the condition of convergences !----------------------------------------------------------------------- - del(i) = sqrt( dtl(it,i)*dtl(it,i) ) - dele(i) = dtl(it,i) * dtl(it,i) * & - ( dirab_dtl(i)**2 + fsenl_dtl(i)**2 + hvap*fevpl_dtl(i)**2 ) - dele(i) = sqrt(dele(i)) + del(i) = sqrt( dtl(it,i)*dtl(it,i) ) + dele(i) = dtl(it,i) * dtl(it,i) * & + ( dirab_dtl(i)**2 + fsenl_dtl(i)**2 + hvap*fevpl_dtl(i)**2 ) + dele(i) = sqrt(dele(i)) !----------------------------------------------------------------------- ! 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(tl(i),psrf,ei(i),deiDT(i),qsatl(i),qsatlDT(i)) + CALL qsadv(tl(i),psrf,ei(i),deiDT(i),qsatl(i),qsatlDT(i)) - ENDIF - ENDDO !END pft loop + ENDIF + ENDDO !END pft loop ! update vegetation/ground surface temperature, canopy air temperature, ! canopy air humidity - ! calculate wtll, wtlql - wtll (:) = 0. - wtlql(:) = 0. + ! calculate wtll, wtlql + wtll (:) = 0. + wtlql(:) = 0. - DO i = ps, pe - IF (fcover(i)>0 .and. lsai(i)>1.e-6) THEN - clev = canlay(i) - wtll(clev) = wtll(clev) + wtl0(i)*tl(i) - wtlql(clev) = wtlql(clev) + wtlq0(i)*qsatl(i) - ENDIF - ENDDO + DO i = ps, pe + IF (fcover(i)>0 .and. lsai(i)>1.e-6) THEN + clev = canlay(i) + wtll(clev) = wtll(clev) + wtl0(i)*tl(i) + wtlql(clev) = wtlql(clev) + wtlq0(i)*qsatl(i) + ENDIF + ENDDO - IF (numlay .eq. 1) THEN + IF (numlay .eq. 1) THEN - taf(toplay) = wta0(toplay)*thm + wtg0(toplay)*tg + wtll(toplay) - qaf(toplay) = wtaq0(toplay)*qm + wtgq0(toplay)*qg + wtlql(toplay) - fact = 1. - facq = 1. + taf(toplay) = wta0(toplay)*thm + wtg0(toplay)*tg + wtll(toplay) + qaf(toplay) = wtaq0(toplay)*qm + wtgq0(toplay)*qg + wtlql(toplay) + fact = 1. + facq = 1. - ENDIF + ENDIF - IF (numlay .eq. 2) THEN + IF (numlay .eq. 2) THEN - tmpw1 = wtg0(botlay)*tg + wtll(botlay) - fact = 1. - wtg0(toplay)*wta0(botlay) - taf(toplay) = (wta0(toplay)*thm + wtg0(toplay)*tmpw1 + wtll(toplay)) / fact + tmpw1 = wtg0(botlay)*tg + wtll(botlay) + fact = 1. - wtg0(toplay)*wta0(botlay) + taf(toplay) = (wta0(toplay)*thm + wtg0(toplay)*tmpw1 + wtll(toplay)) / fact - tmpw1 = wtgq0(botlay)*qg + wtlql(botlay) - facq = 1. - wtgq0(toplay)*wtaq0(botlay) - qaf(toplay) = (wtaq0(toplay)*qm + wtgq0(toplay)*tmpw1 + wtlql(toplay)) / facq + tmpw1 = wtgq0(botlay)*qg + wtlql(botlay) + facq = 1. - wtgq0(toplay)*wtaq0(botlay) + qaf(toplay) = (wtaq0(toplay)*qm + wtgq0(toplay)*tmpw1 + wtlql(toplay)) / facq - taf(botlay) = wta0(botlay)*taf(toplay) + wtg0(botlay)*tg + wtll(botlay) - qaf(botlay) = wtaq0(botlay)*qaf(toplay) + wtgq0(botlay)*qg + wtlql(botlay) + taf(botlay) = wta0(botlay)*taf(toplay) + wtg0(botlay)*tg + wtll(botlay) + qaf(botlay) = wtaq0(botlay)*qaf(toplay) + wtgq0(botlay)*qg + wtlql(botlay) - ENDIF + ENDIF - IF (numlay .eq. 3) THEN + IF (numlay .eq. 3) THEN - tmpw1 = wta0(3)*thm + wtll(3) - tmpw2 = wtg0(1)*tg + wtll(1) - fact = 1. - wta0(2)*wtg0(3) - wtg0(2)*wta0(1) - taf(2) = (wta0(2)*tmpw1 + wtg0(2)*tmpw2 + wtll(2)) / fact + tmpw1 = wta0(3)*thm + wtll(3) + tmpw2 = wtg0(1)*tg + wtll(1) + fact = 1. - wta0(2)*wtg0(3) - wtg0(2)*wta0(1) + taf(2) = (wta0(2)*tmpw1 + wtg0(2)*tmpw2 + wtll(2)) / fact - tmpw1 = wtaq0(3)*qm + wtlql(3) - tmpw2 = wtgq0(1)*qg + wtlql(1) - facq = 1. - wtaq0(2)*wtgq0(3) - wtgq0(2)*wtaq0(1) - qaf(2) = (wtaq0(2)*tmpw1 + wtgq0(2)*tmpw2 + wtlql(2)) / facq + tmpw1 = wtaq0(3)*qm + wtlql(3) + tmpw2 = wtgq0(1)*qg + wtlql(1) + facq = 1. - wtaq0(2)*wtgq0(3) - wtgq0(2)*wtaq0(1) + qaf(2) = (wtaq0(2)*tmpw1 + wtgq0(2)*tmpw2 + wtlql(2)) / facq - taf(1) = wta0(1)*taf(2) + wtg0(1)*tg + wtll(1) - qaf(1) = wtaq0(1)*qaf(2) + wtgq0(1)*qg + wtlql(1) + taf(1) = wta0(1)*taf(2) + wtg0(1)*tg + wtll(1) + qaf(1) = wtaq0(1)*qaf(2) + wtgq0(1)*qg + wtlql(1) - taf(3) = wta0(3)*thm + wtg0(3)*taf(2) + wtll(3) - qaf(3) = wtaq0(3)*qm + wtgq0(3)*qaf(2) + wtlql(3) + taf(3) = wta0(3)*thm + wtg0(3)*taf(2) + wtll(3) + qaf(3) = wtaq0(3)*qm + wtgq0(3)*qaf(2) + wtlql(3) - ENDIF + ENDIF ! 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 + ! 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 - IF (DEF_RSS_SCHEME .eq. 4) THEN - gdh2o = rss/rd(botlay) * tprcor/thm !mol m-2 s-1 - ELSE - gdh2o = 1.0/(rd(botlay)+rss) * tprcor/thm !mol m-2 s-1 - ENDIF - pco2a = pco2m - 1.37*psrf/max(0.446,gah2o) * & - sum(fcover*(assimsun + assimsha - respcsun - respcsha - rsoil)) + IF (DEF_RSS_SCHEME .eq. 4) THEN + gdh2o = rss/rd(botlay) * tprcor/thm !mol m-2 s-1 + ELSE + gdh2o = 1.0/(rd(botlay)+rss) * tprcor/thm !mol m-2 s-1 + ENDIF + pco2a = pco2m - 1.37*psrf/max(0.446,gah2o) * & + sum(fcover*(assimsun + assimsha - respcsun - respcsha - rsoil)) !----------------------------------------------------------------------- ! Update monin-obukhov length and wind speed including the stability effect !----------------------------------------------------------------------- - dth = thm - taf(toplay) - dqh = qm - qaf(toplay) + dth = thm - taf(toplay) + dqh = qm - qaf(toplay) - tstar = vonkar/(fh-fht)*dth - qstar = vonkar/(fq-fqt)*dqh + tstar = vonkar/(fh-fht)*dth + qstar = vonkar/(fq-fqt)*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 - IF (DEF_USE_CBL_HEIGHT) THEN !//TODO: Shaofeng, 2023.05.18 - zii = max(5.*hu,hpbl) - ENDIF !//TODO: Shaofeng, 2023.05.18 - 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 + IF (DEF_USE_CBL_HEIGHT) THEN !//TODO: Shaofeng, 2023.05.18 + zii = max(5.*hu,hpbl) + ENDIF !//TODO: Shaofeng, 2023.05.18 + 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 = maxval(max(del,del2)) - ! 10/03/2017, yuan: possible bugs here, solution: - ! define dee, change del => dee - dee = maxval(max(dele,dele2)) - IF(det .lt. dtmin .and. dee .lt. dlemin) EXIT - ENDIF + IF(it .gt. itmin) THEN + fevpl_bef = fevpl + det = maxval(max(del,del2)) + ! 10/03/2017, yuan: possible bugs here, solution: + ! define dee, change del => dee + dee = maxval(max(dele,dele2)) + IF(det .lt. dtmin .and. dee .lt. dlemin) EXIT + ENDIF - ENDDO + ENDDO ! ====================================================================== ! END stability iteration ! ====================================================================== - IF(DEF_USE_OZONESTRESS)THEN - CALL CalcOzoneStress(o3coefv_sun(i),o3coefg_sun(i),forc_ozone,psrf,th,ram,& - rssun(i),rbsun,lai(i),lai_old(i),p,o3uptakesun(i),deltim) - CALL CalcOzoneStress(o3coefv_sha(i),o3coefg_sha(i),forc_ozone,psrf,th,ram,& - rssha(i),rbsha,lai(i),lai_old(i),p,o3uptakesha(i),deltim) - lai_old(i) = lai(i) - ENDIF + IF(DEF_USE_OZONESTRESS)THEN + CALL CalcOzoneStress(o3coefv_sun(i),o3coefg_sun(i),forc_ozone,psrf,th,ram,& + rssun(i),rbsun,lai(i),lai_old(i),p,o3uptakesun(i),deltim) + CALL CalcOzoneStress(o3coefv_sha(i),o3coefg_sha(i),forc_ozone,psrf,th,ram,& + rssha(i),rbsha,lai(i),lai_old(i),p,o3uptakesha(i),deltim) + lai_old(i) = lai(i) + ENDIF - z0m = z0mv - zol = zeta - rib = min(5.,zol*ustar**2/(vonkar**2/fh*um**2)) + z0m = z0mv + zol = zeta + rib = min(5.,zol*ustar**2/(vonkar**2/fh*um**2)) ! canopy fluxes and total assimilation amd respiration - DO i = ps, pe - IF (fcover(i)>0 .and. lsai(i)>1.e-6) THEN + DO i = ps, pe + IF (fcover(i)>0 .and. lsai(i)>1.e-6) THEN - IF(lai(i) .gt. 0.001) THEN - rst(i) = 1./(laisun(i)/rssun(i) + laisha(i)/rssha(i)) - ELSE - rssun(i) = 2.0e4 ; rssha(i) = 2.0e4 - assimsun(i) = 0. ; assimsha(i) = 0. - respcsun(i) = 0. ; respcsha(i) = 0. - rst(i) = 2.0e4 - ENDIF - assim(i) = assimsun(i) + assimsha(i) - respc(i) = respcsun(i) + respcsha(i) + rsoil + IF(lai(i) .gt. 0.001) THEN + rst(i) = 1./(laisun(i)/rssun(i) + laisha(i)/rssha(i)) + ELSE + rssun(i) = 2.0e4 ; rssha(i) = 2.0e4 + assimsun(i) = 0. ; assimsha(i) = 0. + respcsun(i) = 0. ; respcsha(i) = 0. + rst(i) = 2.0e4 + ENDIF + assim(i) = assimsun(i) + assimsha(i) + respc(i) = respcsun(i) + respcsha(i) + rsoil ! canopy fluxes and total assimilation amd respiration - fsenl(i) = fsenl(i) + fsenl_dtl(i)*dtl(it-1,i) & - ! add the imbalanced energy below due to T adjustment to sensibel heat - + (dtl_noadj(i)-dtl(it-1,i)) * (lsai(i)*clai/deltim - dirab_dtl(i) & - + fsenl_dtl(i) + hvap*fevpl_dtl(i) + cpliq*qintr_rain(i) + cpice*qintr_snow(i)) & - ! add the imbalanced energy below due to q adjustment to sensibel heat - + hvap*erre(i) - - etr0(i) = etr(i) - etr (i) = etr(i) + etr_dtl(i)*dtl(it-1,i) - - IF (DEF_USE_PLANTHYDRAULICS) THEN - !TODO@yuan: rootflux may not be consistent with etr, - ! water imbalance could happen. - IF(abs(etr0(i)) .ge. 1.e-15)THEN - rootflux(:,i) = rootflux(:,i) * etr(i) / etr0(i) - ELSE - rootflux(:,i) = rootflux(:,i) + dz_soi / sum(dz_soi) * etr_dtl(i)* dtl(it-1,i) - ENDIF - - !NOTE: temporal solution to make etr and rootflux consistent. - !TODO: need double check - sumrootflux = sum(rootflux(:,i), rootflux(:,i)>0.) - IF (abs(sumrootflux) > 0.) THEN - rootflux(:,i) = max(rootflux(:,i),0.) * (etr(i)/sumrootflux) - ELSE - rootflux(:,i) = etr(i)*rootfr(:,i) - ENDIF - ENDIF - - evplwet(i) = evplwet(i) + evplwet_dtl(i)*dtl(it-1,i) - fevpl (i) = fevpl_noadj(i) - fevpl (i) = fevpl(i) + fevpl_dtl(i)*dtl(it-1,i) - - elwmax = ldew(i)/deltim - - ! 03/02/2018, yuan: convert fc to whole area - ! because ldew now is for the whole area - ! may need to change to canopy covered area - ! 09/14/2019, yuan: change back to canopy area - elwdif = max(0., evplwet(i)-elwmax) - evplwet(i) = min(evplwet(i), elwmax) - - fevpl(i) = fevpl(i) - elwdif - fsenl(i) = fsenl(i) + hvap*elwdif - hprl (i) = cpliq*qintr_rain(i)*(t_precip-tl(i)) + cpice*qintr_snow(i)*(t_precip-tl(i)) + fsenl(i) = fsenl(i) + fsenl_dtl(i)*dtl(it-1,i) & + ! add the imbalanced energy below due to T adjustment to sensibel heat + + (dtl_noadj(i)-dtl(it-1,i)) * (lsai(i)*clai/deltim - dirab_dtl(i) & + + fsenl_dtl(i) + hvap*fevpl_dtl(i) + cpliq*qintr_rain(i) + cpice*qintr_snow(i)) & + ! add the imbalanced energy below due to q adjustment to sensibel heat + + hvap*erre(i) + + etr0(i) = etr(i) + etr (i) = etr(i) + etr_dtl(i)*dtl(it-1,i) + + IF (DEF_USE_PLANTHYDRAULICS) THEN + !TODO@yuan: rootflux may not be consistent with etr, + ! water imbalance could happen. + IF(abs(etr0(i)) .ge. 1.e-15)THEN + rootflux(:,i) = rootflux(:,i) * etr(i) / etr0(i) + ELSE + rootflux(:,i) = rootflux(:,i) + dz_soi / sum(dz_soi) * etr_dtl(i)* dtl(it-1,i) + ENDIF + + !NOTE: temporal solution to make etr and rootflux consistent. + !TODO: need double check + sumrootflux = sum(rootflux(:,i), rootflux(:,i)>0.) + IF (abs(sumrootflux) > 0.) THEN + rootflux(:,i) = max(rootflux(:,i),0.) * (etr(i)/sumrootflux) + ELSE + rootflux(:,i) = etr(i)*rootfr(:,i) + ENDIF + ENDIF + + evplwet(i) = evplwet(i) + evplwet_dtl(i)*dtl(it-1,i) + fevpl (i) = fevpl_noadj(i) + fevpl (i) = fevpl(i) + fevpl_dtl(i)*dtl(it-1,i) + + elwmax = ldew(i)/deltim + + ! 03/02/2018, yuan: convert fc to whole area + ! because ldew now is for the whole area + ! may need to change to canopy covered area + ! 09/14/2019, yuan: change back to canopy area + elwdif = max(0., evplwet(i)-elwmax) + evplwet(i) = min(evplwet(i), elwmax) + + fevpl(i) = fevpl(i) - elwdif + fsenl(i) = fsenl(i) + hvap*elwdif + hprl (i) = cpliq*qintr_rain(i)*(t_precip-tl(i)) + cpice*qintr_snow(i)*(t_precip-tl(i)) !----------------------------------------------------------------------- ! Update dew accumulation (kg/m2) !----------------------------------------------------------------------- - IF (DEF_Interception_scheme .eq. 1) THEN !colm2014 - ldew(i) = max(0., ldew(i)-evplwet(i)*deltim) - ELSEIF (DEF_Interception_scheme .eq. 2) THEN!CLM4.5 - ldew(i) = max(0., ldew(i)-evplwet(i)*deltim) - ELSEIF (DEF_Interception_scheme .eq. 3) THEN !CLM5 - IF (ldew_rain(i) .gt. evplwet(i)*deltim) THEN - ldew_rain(i) = ldew_rain(i)-evplwet(i)*deltim - ldew_snow(i) = ldew_snow(i) - ldew(i)=ldew_rain(i)+ldew_snow(i) - ELSE - ldew_rain(i) = 0.0 - ldew_snow(i) = max(0., ldew(i)-evplwet(i)*deltim) - ldew (i) = ldew_snow(i) - ENDIF - ELSEIF (DEF_Interception_scheme .eq. 4) THEN !Noah-MP - IF (ldew_rain(i) .gt. evplwet(i)*deltim) THEN - ldew_rain(i) = ldew_rain(i)-evplwet(i)*deltim - ldew_snow(i) = ldew_snow(i) - ldew(i)=ldew_rain(i)+ldew_snow(i) - ELSE - ldew_rain(i) = 0.0 - ldew_snow(i) = max(0., ldew(i)-evplwet(i)*deltim) - ldew (i) = ldew_snow(i) - ENDIF - ELSEIF (DEF_Interception_scheme .eq. 5) THEN !MATSIRO - IF (ldew_rain(i) .gt. evplwet(i)*deltim) THEN - ldew_rain(i) = ldew_rain(i)-evplwet(i)*deltim - ldew_snow(i) = ldew_snow(i) - ldew(i)=ldew_rain(i)+ldew_snow(i) - ELSE - ldew_rain(i) = 0.0 - ldew_snow(i) = max(0., ldew(i)-evplwet(i)*deltim) - ldew (i) = ldew_snow(i) - ENDIF - ELSEIF (DEF_Interception_scheme .eq. 6) THEN !VIC - IF (ldew_rain(i) .gt. evplwet(i)*deltim) THEN - ldew_rain(i) = ldew_rain(i)-evplwet(i)*deltim - ldew_snow(i) = ldew_snow(i) - ldew(i)=ldew_rain(i)+ldew_snow(i) - ELSE - ldew_rain(i) = 0.0 - ldew_snow(i) = max(0., ldew(i)-evplwet(i)*deltim) - ldew (i) = ldew_snow(i) - ENDIF - ELSE - CALL abort - ENDIF + IF (DEF_Interception_scheme .eq. 1) THEN !colm2014 + ldew(i) = max(0., ldew(i)-evplwet(i)*deltim) + ELSEIF (DEF_Interception_scheme .eq. 2) THEN!CLM4.5 + ldew(i) = max(0., ldew(i)-evplwet(i)*deltim) + ELSEIF (DEF_Interception_scheme .eq. 3) THEN !CLM5 + IF (ldew_rain(i) .gt. evplwet(i)*deltim) THEN + ldew_rain(i) = ldew_rain(i)-evplwet(i)*deltim + ldew_snow(i) = ldew_snow(i) + ldew(i)=ldew_rain(i)+ldew_snow(i) + ELSE + ldew_rain(i) = 0.0 + ldew_snow(i) = max(0., ldew(i)-evplwet(i)*deltim) + ldew (i) = ldew_snow(i) + ENDIF + ELSEIF (DEF_Interception_scheme .eq. 4) THEN !Noah-MP + IF (ldew_rain(i) .gt. evplwet(i)*deltim) THEN + ldew_rain(i) = ldew_rain(i)-evplwet(i)*deltim + ldew_snow(i) = ldew_snow(i) + ldew(i)=ldew_rain(i)+ldew_snow(i) + ELSE + ldew_rain(i) = 0.0 + ldew_snow(i) = max(0., ldew(i)-evplwet(i)*deltim) + ldew (i) = ldew_snow(i) + ENDIF + ELSEIF (DEF_Interception_scheme .eq. 5) THEN !MATSIRO + IF (ldew_rain(i) .gt. evplwet(i)*deltim) THEN + ldew_rain(i) = ldew_rain(i)-evplwet(i)*deltim + ldew_snow(i) = ldew_snow(i) + ldew(i)=ldew_rain(i)+ldew_snow(i) + ELSE + ldew_rain(i) = 0.0 + ldew_snow(i) = max(0., ldew(i)-evplwet(i)*deltim) + ldew (i) = ldew_snow(i) + ENDIF + ELSEIF (DEF_Interception_scheme .eq. 6) THEN !VIC + IF (ldew_rain(i) .gt. evplwet(i)*deltim) THEN + ldew_rain(i) = ldew_rain(i)-evplwet(i)*deltim + ldew_snow(i) = ldew_snow(i) + ldew(i)=ldew_rain(i)+ldew_snow(i) + ELSE + ldew_rain(i) = 0.0 + ldew_snow(i) = max(0., ldew(i)-evplwet(i)*deltim) + ldew (i) = ldew_snow(i) + ENDIF + ELSE + CALL abort + ENDIF !----------------------------------------------------------------------- ! balance check ! (the computational error was created by the assumed 'dtl' in line 406-408) !----------------------------------------------------------------------- - err = sabv(i) + irab(i) + dirab_dtl(i)*dtl(it-1,i) & - - fsenl(i) - hvap*fevpl(i) + hprl(i) + err = sabv(i) + irab(i) + dirab_dtl(i)*dtl(it-1,i) & + - fsenl(i) - hvap*fevpl(i) + hprl(i) #if(defined CoLMDEBUG) - IF(abs(err) .gt. .2) & - write(6,*) 'energy imbalance in LeafTemperaturePC.F90', & - i,it-1,err,sabv(i),irab(i),fsenl(i),hvap*fevpl(i),hprl(i) + IF(abs(err) .gt. .2) & + write(6,*) 'energy imbalance in LeafTemperaturePC.F90', & + i,it-1,err,sabv(i),irab(i),fsenl(i),hvap*fevpl(i),hprl(i) #endif - ENDIF - ENDDO + ENDIF + ENDDO !----------------------------------------------------------------------- ! downward (upward) longwave radiation below (above) the canopy !----------------------------------------------------------------------- - dlrad = Lin(0) & - + sum( 4.* fshade * (1-thermk) * stefnc * tlbef**3 * dtl(it-1,:) ) + dlrad = Lin(0) & + + sum( 4.* fshade * (1-thermk) * stefnc * tlbef**3 * dtl(it-1,:) ) - ulrad = Lin(4) - sum( fcover * dLv * dtl(it-1,:) ) & - - emg * sum( 4.* fshade * (1-thermk) * stefnc * tlbef**3 * dtl(it-1,:) ) + ulrad = Lin(4) - sum( fcover * dLv * dtl(it-1,:) ) & + - emg * sum( 4.* fshade * (1-thermk) * stefnc * tlbef**3 * dtl(it-1,:) ) !----------------------------------------------------------------------- ! wind stresses !----------------------------------------------------------------------- - taux = - rhoair*us/ram - tauy = - rhoair*vs/ram + taux = - rhoair*us/ram + tauy = - rhoair*vs/ram !----------------------------------------------------------------------- ! fluxes from ground to canopy space !----------------------------------------------------------------------- ! 03/07/2020, yuan: TODO-done, calculate fseng_soil/snow, fevpg_soil/snow - IF (numlay .eq. 1) THEN - ttaf = thm - tqaf = qm - ENDIF - - IF (numlay .eq. 2) THEN - ttaf = taf(toplay) - tqaf = qaf(toplay) - ENDIF - - IF (numlay .eq. 3) THEN - ttaf = taf(2) - tqaf = qaf(2) - ENDIF - - !NOTE: the below EQs for check purpose only - ! taf = wta0*thm + wtg0*tg + wtl0*tl - ! taf(1) = wta0(1)*taf(2) + wtg0(1)*tg + wtll(1) - ! qaf(1) = wtaq0(1)*qaf(2) + wtgq0(1)*qg + wtlql(1) - ! taf(botlay) = wta0(botlay)*taf(toplay) + wtg0(botlay)*tg + wtll(botlay) - ! qaf(botlay) = wtaq0(botlay)*qaf(toplay) + wtgq0(botlay)*qg + wtlql(botlay) - ! taf(toplay) = wta0(toplay)*thm + wtg0(toplay)*tg + wtll(toplay) - ! qaf(toplay) = wtaq0(toplay)*qm + wtgq0(toplay)*qg + wtlql(toplay) - - fseng = cpair*rhoair*cgh(botlay)*(tg-taf(botlay)) - fseng_soil = cpair*rhoair*cgh(botlay)*((1.-wtg0(botlay))*t_soil-wta0(botlay)*ttaf-wtll(botlay)) - fseng_snow = cpair*rhoair*cgh(botlay)*((1.-wtg0(botlay))*t_snow-wta0(botlay)*ttaf-wtll(botlay)) - - fevpg = rhoair*cgw(botlay)*(qg-qaf(botlay)) - fevpg_soil = rhoair*cgw(botlay)*((1.-wtgq0(botlay))*q_soil-wtaq0(botlay)*tqaf-wtlql(botlay)) - fevpg_snow = rhoair*cgw(botlay)*((1.-wtgq0(botlay))*q_snow-wtaq0(botlay)*tqaf-wtlql(botlay)) + IF (numlay .eq. 1) THEN + ttaf = thm + tqaf = qm + ENDIF + + IF (numlay .eq. 2) THEN + ttaf = taf(toplay) + tqaf = qaf(toplay) + ENDIF + + IF (numlay .eq. 3) THEN + ttaf = taf(2) + tqaf = qaf(2) + ENDIF + + !NOTE: the below EQs for check purpose only + ! taf = wta0*thm + wtg0*tg + wtl0*tl + ! taf(1) = wta0(1)*taf(2) + wtg0(1)*tg + wtll(1) + ! qaf(1) = wtaq0(1)*qaf(2) + wtgq0(1)*qg + wtlql(1) + ! taf(botlay) = wta0(botlay)*taf(toplay) + wtg0(botlay)*tg + wtll(botlay) + ! qaf(botlay) = wtaq0(botlay)*qaf(toplay) + wtgq0(botlay)*qg + wtlql(botlay) + ! taf(toplay) = wta0(toplay)*thm + wtg0(toplay)*tg + wtll(toplay) + ! qaf(toplay) = wtaq0(toplay)*qm + wtgq0(toplay)*qg + wtlql(toplay) + + fseng = cpair*rhoair*cgh(botlay)*(tg-taf(botlay)) + fseng_soil = cpair*rhoair*cgh(botlay)*((1.-wtg0(botlay))*t_soil-wta0(botlay)*ttaf-wtll(botlay)) + fseng_snow = cpair*rhoair*cgh(botlay)*((1.-wtg0(botlay))*t_snow-wta0(botlay)*ttaf-wtll(botlay)) + + fevpg = rhoair*cgw(botlay)*(qg-qaf(botlay)) + fevpg_soil = rhoair*cgw(botlay)*((1.-wtgq0(botlay))*q_soil-wtaq0(botlay)*tqaf-wtlql(botlay)) + fevpg_snow = rhoair*cgw(botlay)*((1.-wtgq0(botlay))*q_snow-wtaq0(botlay)*tqaf-wtlql(botlay)) !----------------------------------------------------------------------- ! Derivative of soil energy flux with respect to soil temperature (cgrnd) !----------------------------------------------------------------------- - !NOTE: When numlay<3, no matter how to get the solution, /fact is consistent - IF (numlay < 3) THEN - cgrnds = cpair*rhoair*cgh(botlay)*(1.-wtg0(botlay)/fact) - cgrndl = rhoair*cgw(botlay)*(1.-wtgq0(botlay)/fact)*dqgdT - ELSE - cgrnds = cpair*rhoair*cgh(botlay)*(1.-wta0(1)*wtg0(2)*wtg0(1)/fact-wtg0(1)) - cgrndl = rhoair*cgw(botlay)*(1.-wtaq0(1)*wtgq0(2)*wtgq0(1)/facq-wtgq0(1))*dqgdT - ENDIF - cgrnd = cgrnds + cgrndl*htvp + !NOTE: When numlay<3, no matter how to get the solution, /fact is consistent + IF (numlay < 3) THEN + cgrnds = cpair*rhoair*cgh(botlay)*(1.-wtg0(botlay)/fact) + cgrndl = rhoair*cgw(botlay)*(1.-wtgq0(botlay)/fact)*dqgdT + ELSE + cgrnds = cpair*rhoair*cgh(botlay)*(1.-wta0(1)*wtg0(2)*wtg0(1)/fact-wtg0(1)) + cgrndl = rhoair*cgw(botlay)*(1.-wtaq0(1)*wtgq0(2)*wtgq0(1)/facq-wtgq0(1))*dqgdT + ENDIF + cgrnd = cgrnds + cgrndl*htvp !----------------------------------------------------------------------- ! 2 m height air temperature !----------------------------------------------------------------------- - tref = thm + vonkar/(fh-fht)*dth * (fh2m/vonkar - fh/vonkar) - qref = qm + vonkar/(fq-fqt)*dqh * (fq2m/vonkar - fq/vonkar) + tref = thm + vonkar/(fh-fht)*dth * (fh2m/vonkar - fh/vonkar) + qref = qm + vonkar/(fq-fqt)*dqh * (fq2m/vonkar - fq/vonkar) - END SUBROUTINE LeafTemperaturePC + END SUBROUTINE LeafTemperaturePC !---------------------------------------------------------------------- - SUBROUTINE dewfraction (sigf,lai,sai,dewmx,ldew,ldew_rain,ldew_snow,fwet,fdry) + SUBROUTINE dewfraction (sigf,lai,sai,dewmx,ldew,ldew_rain,ldew_snow,fwet,fdry) !======================================================================= ! Original author: Yongjiu Dai, September 15, 1999 ! @@ -1869,22 +1869,22 @@ SUBROUTINE dewfraction (sigf,lai,sai,dewmx,ldew,ldew_rain,ldew_snow,fwet,fdry) ! !======================================================================= - 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) :: ldew_rain !depth of rain on foliage [kg/m2/s] - real(r8), intent(in) :: ldew_snow !depth of snow on foliage [kg/m2/s] - real(r8), intent(out) :: fwet !fraction of foliage covered by water [-] - real(r8), intent(out) :: fdry !fraction of foliage that is green and dry [-] - - real(r8) lsai !lai + sai - real(r8) dewmxi !inverse of maximum allowed dew [1/mm] - real(r8) vegt !sigf*lsai, NOTE: remove sigf + 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) :: ldew_rain !depth of rain on foliage [kg/m2/s] + real(r8), intent(in) :: ldew_snow !depth of snow on foliage [kg/m2/s] + real(r8), intent(out) :: fwet !fraction of foliage covered by water [-] + real(r8), intent(out) :: fdry !fraction of foliage that is green and dry [-] + + real(r8) lsai !lai + sai + real(r8) dewmxi !inverse of maximum allowed dew [1/mm] + real(r8) vegt !sigf*lsai, NOTE: remove sigf ! !----------------------------------------------------------------------- ! Fwet is the fraction of all vegetation surfaces which are wet @@ -1907,7 +1907,6 @@ SUBROUTINE dewfraction (sigf,lai,sai,dewmx,ldew,ldew_rain,ldew_snow,fwet,fdry) ! transpire. Adjusted for stem area which does not transpire fdry = (1.-fwet)*lai/lsai - - END SUBROUTINE dewfraction + END SUBROUTINE dewfraction END MODULE MOD_LeafTemperaturePC diff --git a/main/MOD_LightningData.F90 b/main/MOD_LightningData.F90 index 60466946..6d0cee6b 100644 --- a/main/MOD_LightningData.F90 +++ b/main/MOD_LightningData.F90 @@ -13,13 +13,13 @@ MODULE MOD_LightningData USE MOD_Grid USE MOD_DataType USE MOD_Mapping_Grid2Pset - use MOD_BGC_Vars_TimeVariables, only: lnfm + USE MOD_BGC_Vars_TimeVariables, only: lnfm IMPLICIT NONE - CHARACTER(len=256) :: file_lightning - TYPE(grid_type) :: grid_lightning + character(len=256) :: file_lightning + type(grid_type) :: grid_lightning - TYPE(block_data_real8_2d) :: f_lnfm + type(block_data_real8_2d) :: f_lnfm type (mapping_grid2pset_type) :: mg2p_lnfm @@ -33,21 +33,21 @@ SUBROUTINE init_lightning_data (idate) ! open lightning netcdf file from DEF_dir_rawdata, read latitude and longitude info. ! Initialize lightning data read in. - USE MOD_SPMD_Task - USE MOD_Namelist - USE MOD_TimeManager - USE MOD_Grid - USE MOD_NetCDFSerial - USE MOD_NetCDFBlock - USE MOD_LandPatch - USE MOD_RangeCheck - IMPLICIT NONE + USE MOD_SPMD_Task + USE MOD_Namelist + USE MOD_TimeManager + USE MOD_Grid + USE MOD_NetCDFSerial + USE MOD_NetCDFBlock + USE MOD_LandPatch + USE MOD_RangeCheck + IMPLICIT NONE - integer, intent(in) :: idate(3) + integer, intent(in) :: idate(3) - ! Local Variables - REAL(r8), allocatable :: lat(:), lon(:) - INTEGER :: itime + ! Local Variables + real(r8), allocatable :: lat(:), lon(:) + integer :: itime file_lightning = trim(DEF_dir_runtime) // '/fire/clmforc.Li_2012_climo1995-2011.T62.lnfm_Total_c140423.nc' @@ -58,10 +58,10 @@ SUBROUTINE init_lightning_data (idate) CALL allocate_block_data (grid_lightning, f_lnfm) - call mg2p_lnfm%build (grid_lightning, landpatch) + CALL mg2p_lnfm%build (grid_lightning, landpatch) itime = (idate(2)-1)*8 + min(idate(3)/10800+1,8) - if (itime .gt. 2920)itime = itime - 8 ! for the leap year + IF (itime .gt. 2920)itime = itime - 8 ! for the leap year CALL ncio_read_block_time (file_lightning, 'lnfm', grid_lightning, itime, f_lnfm) #ifdef RangeCheck @@ -77,17 +77,17 @@ SUBROUTINE update_lightning_data (time, deltim) ! DESCTIPTION: ! read lightning data during simulation - USE MOD_TimeManager - USE MOD_NetCDFBlock - USE MOD_RangeCheck - IMPLICIT NONE + USE MOD_TimeManager + USE MOD_NetCDFBlock + USE MOD_RangeCheck + IMPLICIT NONE - type(timestamp), intent(in) :: time - REAL(r8), intent(in) :: deltim + type(timestamp), intent(in) :: time + real(r8), intent(in) :: deltim - ! Local Variables - type(timestamp) :: time_next - INTEGER :: itime, itime_next + ! Local Variables + type(timestamp) :: time_next + integer :: itime, itime_next itime = (time%day-1)*8 + min(time%sec/10800+1,8) IF (mod(time%sec,10800) == 0) itime = itime - 1 @@ -102,9 +102,9 @@ SUBROUTINE update_lightning_data (time, deltim) CALL check_block_data ('lightning', f_lnfm) #endif - call mg2p_lnfm%map_aweighted (f_lnfm, lnfm) + CALL mg2p_lnfm%map_aweighted (f_lnfm, lnfm) #ifdef RangeCheck - call check_vector_data ('lightning', lnfm) + CALL check_vector_data ('lightning', lnfm) #endif ENDIF diff --git a/main/MOD_MonthlyinSituCO2MaunaLoa.F90 b/main/MOD_MonthlyinSituCO2MaunaLoa.F90 index c45ec5d9..d9e8ed0c 100644 --- a/main/MOD_MonthlyinSituCO2MaunaLoa.F90 +++ b/main/MOD_MonthlyinSituCO2MaunaLoa.F90 @@ -53,23 +53,23 @@ MODULE MOD_MonthlyinSituCO2MaunaLoa ! ------------------------------- USE MOD_Precision - use MOD_Namelist, only: DEF_SSP + USE MOD_Namelist, only: DEF_SSP IMPLICIT NONE SAVE ! define the CO2 data time range - INTEGER, parameter :: syear = 1849 - INTEGER, parameter :: eyear = 2100 - INTEGER, parameter :: smonth = 1 - INTEGER, parameter :: emonth = 12 + integer, parameter :: syear = 1849 + integer, parameter :: eyear = 2100 + integer, parameter :: smonth = 1 + integer, parameter :: emonth = 12 - REAL(r8), dimension(syear:eyear, 12) :: co2mlo + real(r8), dimension(syear:eyear, 12) :: co2mlo ! PUBLIC MEMBER FUNCTIONS: PUBLIC :: init_monthly_co2_mlo PUBLIC :: get_monthly_co2_mlo - CONTAINS +CONTAINS SUBROUTINE init_monthly_co2_mlo !DESCRIPTION @@ -103,7 +103,7 @@ SUBROUTINE init_monthly_co2_mlo !---2022.12.12 Zhongwang Wei @ SYSU !---2021.05.05 Hua Yuan @ SYSU - IMPLICIT NONE + IMPLICIT NONE ! fillvalue co2mlo(:,:) = -99.99 !monthly mean CO2 concentration in ppm @@ -353,8 +353,8 @@ SUBROUTINE init_monthly_co2_mlo !Matthias Büchner, Christopher Reyer (2022): ISIMIP3b atmospheric composition input data (v1.1). ISIMIP Repository. !https://doi.org/10.48364/ISIMIP.482153.1 !added by Zhongwang Wei @ SYSU 2022.12.12 - select case (trim(DEF_SSP)) - case ('126') + select CASE (trim(DEF_SSP)) + CASE ('126') !co2mlo(2015,:) = (/ 399.95, 399.95, 399.95, 399.95, 399.95, 399.95, 399.95, 399.95, 399.95, 399.95, 399.95, 399.95 /) !co2mlo(2016,:) = (/ 403.12, 403.12, 403.12, 403.12, 403.12, 403.12, 403.12, 403.12, 403.12, 403.12, 403.12, 403.12 /) !co2mlo(2017,:) = (/ 405.75, 405.75, 405.75, 405.75, 405.75, 405.75, 405.75, 405.75, 405.75, 405.75, 405.75, 405.75 /) @@ -442,7 +442,7 @@ SUBROUTINE init_monthly_co2_mlo co2mlo(2099,:) = (/ 446.67, 446.67, 446.67, 446.67, 446.67, 446.67, 446.67, 446.67, 446.67, 446.67, 446.67, 446.67 /) co2mlo(2100,:) = (/ 445.62, 445.62, 445.62, 445.62, 445.62, 445.62, 445.62, 445.62, 445.62, 445.62, 445.62, 445.62 /) !added by Zhongwang Wei @ SYSU 2022.12.12 - case ('245') + CASE ('245') print *,'245' !co2mlo(2015,:) = (/ 399.95, 399.95, 399.95, 399.95, 399.95, 399.95, 399.95, 399.95, 399.95, 399.95, 399.95, 399.95 /) !co2mlo(2016,:) = (/ 403.12, 403.12, 403.12, 403.12, 403.12, 403.12, 403.12, 403.12, 403.12, 403.12, 403.12, 403.12 /) @@ -531,7 +531,7 @@ SUBROUTINE init_monthly_co2_mlo co2mlo(2099,:) = (/ 602.51, 602.51, 602.51, 602.51, 602.51, 602.51, 602.51, 602.51, 602.51, 602.51, 858.83, 858.83 /) co2mlo(2100,:) = (/ 602.78, 602.78, 602.78, 602.78, 602.78, 602.78, 602.78, 602.78, 602.78, 602.78, 867.19, 867.19 /) !added by Zhongwang Wei @ SYSU 2022.12.12 - case ('370') + CASE ('370') !co2mlo(2015,:) = (/ 399.95, 399.95, 399.95, 399.95, 399.95, 399.95, 399.95, 399.95, 399.95, 399.95, 399.95, 399.95 /) !co2mlo(2016,:) = (/ 403.12, 403.12, 403.12, 403.12, 403.12, 403.12, 403.12, 403.12, 403.12, 403.12, 403.12, 403.12 /) !co2mlo(2017,:) = (/ 405.81, 405.81, 405.81, 405.81, 405.81, 405.81, 405.81, 405.81, 405.81, 405.81, 405.81, 405.81 /) @@ -619,7 +619,7 @@ SUBROUTINE init_monthly_co2_mlo co2mlo(2099,:) = (/ 858.83, 858.83, 858.83, 858.83, 858.83, 858.83, 858.83, 858.83, 858.83, 858.83, 858.83, 858.83 /) co2mlo(2100,:) = (/ 867.19, 867.19, 867.19, 867.19, 867.19, 867.19, 867.19, 867.19, 867.19, 867.19, 867.19, 867.19 /) !added by Zhongwang Wei @ SYSU 2022.12.12 - case ('585') + CASE ('585') !co2mlo(2015,:) = (/ 399.95, 399.95, 399.95, 399.95, 399.95, 399.95, 399.95, 399.95, 399.95, 399.95, 399.95, 399.95 /) !co2mlo(2016,:) = (/ 403.12, 403.12, 403.12, 403.12, 403.12, 403.12, 403.12, 403.12, 403.12, 403.12, 403.12, 403.12 /) !co2mlo(2017,:) = (/ 405.79, 405.79, 405.79, 405.79, 405.79, 405.79, 405.79, 405.79, 405.79, 405.79, 405.79, 405.79 /) @@ -706,16 +706,16 @@ SUBROUTINE init_monthly_co2_mlo co2mlo(2098,:) = (/ 1107.89, 1107.89, 1107.89, 1107.89, 1107.89, 1107.89, 1107.89, 1107.89, 1107.89, 1107.89, 1107.89, 1107.89 /) co2mlo(2099,:) = (/ 1121.55, 1121.55, 1121.55, 1121.55, 1121.55, 1121.55, 1121.55, 1121.55, 1121.55, 1121.55, 1121.55, 1121.55 /) co2mlo(2100,:) = (/ 1135.21, 1135.21, 1135.21, 1135.21, 1135.21, 1135.21, 1135.21, 1135.21, 1135.21, 1135.21, 1135.21, 1135.21 /) - end select + END select END SUBROUTINE init_monthly_co2_mlo - REAL(r8) FUNCTION get_monthly_co2_mlo (year, month) + real(r8) FUNCTION get_monthly_co2_mlo (year, month) - IMPLICIT NONE + IMPLICIT NONE - INTEGER, intent(in) :: year - INTEGER, intent(in) :: month + integer, intent(in) :: year + integer, intent(in) :: month IF (year 0) then - do npatch = 1, numpatch + IF (p_is_worker .and. iswrite) THEN + IF (numpatch > 0) THEN + DO npatch = 1, numpatch m = patchclass(npatch) - if(m == 0)then + IF(m == 0)THEN ndep_to_sminn(npatch) = 0. - else - if(DEF_USE_PN)then + ELSE + IF(DEF_USE_PN)THEN ndep_to_sminn(npatch) = ndep(npatch) / 3600. / 365. / 24. * 5 - else + ELSE ndep_to_sminn(npatch) = ndep(npatch) / 3600. / 365. / 24. - end if - end if - end do + ENDIF + ENDIF + ENDDO ENDIF ENDIF #ifdef RangeCheck - call check_vector_data ('ndep', ndep) + CALL check_vector_data ('ndep', ndep) #endif END SUBROUTINE update_ndep_data_annually - ! ---------- + ! ---------- SUBROUTINE update_ndep_data_monthly (YY, MM, iswrite) !sf_add ! =========================================================== ! @@ -171,21 +171,21 @@ SUBROUTINE update_ndep_data_monthly (YY, MM, iswrite) !sf_add ! Created by Xingjie Lu and Shupeng Zhang, 2022 ! =========================================================== - use MOD_SPMD_Task - USE MOD_Namelist, only : DEF_USE_PN - USE MOD_DataType - USE MOD_NetCDFBlock - use MOD_LandPatch - use MOD_Vars_TimeInvariants - USE MOD_RangeCheck - IMPLICIT NONE + USE MOD_SPMD_Task + USE MOD_Namelist, only : DEF_USE_PN + USE MOD_DataType + USE MOD_NetCDFBlock + USE MOD_LandPatch + USE MOD_Vars_TimeInvariants + USE MOD_RangeCheck + IMPLICIT NONE - integer, intent(in) :: YY,MM ! sf_add - logical, INTENT(in) :: iswrite + integer, intent(in) :: YY,MM ! sf_add + logical, intent(in) :: iswrite - ! Local Variables - TYPE(block_data_real8_2d) :: f_xy_ndep - integer :: itime, npatch, m + ! Local Variables + type(block_data_real8_2d) :: f_xy_ndep + integer :: itime, npatch, m itime = (max(min(YY,2006),1849) - 1849)*12 + MM ! sf_add ! print*,"YY=",YY ! sf_add @@ -197,28 +197,28 @@ SUBROUTINE update_ndep_data_monthly (YY, MM, iswrite) !sf_add CALL ncio_read_block_time (file_ndep, 'NDEP_month', grid_ndep, itime, f_xy_ndep) ! sf_add ENDIF - call mg2p_ndep%map_aweighted (f_xy_ndep, ndep) + CALL mg2p_ndep%map_aweighted (f_xy_ndep, ndep) - if (p_is_worker .and. iswrite) then - if (numpatch > 0) then - do npatch = 1, numpatch + IF (p_is_worker .and. iswrite) THEN + IF (numpatch > 0) THEN + DO npatch = 1, numpatch m = patchclass(npatch) - if(m == 0)then + IF(m == 0)THEN ndep_to_sminn(npatch) = 0. - else - if(DEF_USE_PN)then + ELSE + IF(DEF_USE_PN)THEN ndep_to_sminn(npatch) = ndep(npatch) / 3600. / 365. / 24. * 5 - else + ELSE ndep_to_sminn(npatch) = ndep(npatch) / 3600. / 365. / 24. - end if - end if - end do + ENDIF + ENDIF + ENDDO ENDIF ENDIF #ifdef RangeCheck - call check_vector_data ('ndep', ndep) + CALL check_vector_data ('ndep', ndep) #endif END SUBROUTINE update_ndep_data_monthly diff --git a/main/MOD_NewSnow.F90 b/main/MOD_NewSnow.F90 index b19c4f26..a1fa4cff 100644 --- a/main/MOD_NewSnow.F90 +++ b/main/MOD_NewSnow.F90 @@ -11,12 +11,12 @@ MODULE MOD_NewSnow !----------------------------------------------------------------------- - CONTAINS +CONTAINS !----------------------------------------------------------------------- - subroutine newsnow (patchtype,maxsnl,deltim,t_grnd,pg_rain,pg_snow,bifall,& + SUBROUTINE newsnow (patchtype,maxsnl,deltim,t_grnd,pg_rain,pg_snow,bifall,& t_precip,zi_soisno,z_soisno,dz_soisno,t_soisno,& wliq_soisno,wice_soisno,fiold,snl,sag,scv,snowdp,fsno,wetwat) @@ -25,38 +25,38 @@ subroutine newsnow (patchtype,maxsnl,deltim,t_grnd,pg_rain,pg_snow,bifall,& ! Original author : Yongjiu Dai, 09/15/1999; 08/31/2002, 07/2013, 04/2014 !======================================================================= ! - use MOD_Precision + USE MOD_Precision USE MOD_Namelist, only : DEF_USE_VariablySaturatedFlow - use MOD_Const_Physical, only : tfrz, cpliq, cpice + USE MOD_Const_Physical, only : tfrz, cpliq, cpice - implicit none + IMPLICIT NONE ! ------------------------ Dummy Argument ------------------------------ - integer, INTENT(in) :: maxsnl ! maximum number of snow layers - integer, INTENT(in) :: patchtype ! land patch type (0=soil, 1=urban and built-up, + integer, intent(in) :: maxsnl ! maximum number of snow layers + integer, intent(in) :: 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) :: deltim ! model time step [second] - real(r8), INTENT(in) :: t_grnd ! ground surface temperature [k] - real(r8), INTENT(in) :: pg_rain ! rainfall onto ground including canopy runoff [kg/(m2 s)] - real(r8), INTENT(in) :: pg_snow ! snowfall onto ground including canopy runoff [kg/(m2 s)] - real(r8), INTENT(in) :: bifall ! bulk density of newly fallen dry snow [kg/m3] - real(r8), INTENT(in) :: t_precip ! snowfall/rainfall temperature [kelvin] - - real(r8), INTENT(inout) :: zi_soisno(maxsnl:0) ! interface level below a "z" level (m) - real(r8), INTENT(inout) :: z_soisno(maxsnl+1:0) ! layer depth (m) - real(r8), INTENT(inout) :: dz_soisno(maxsnl+1:0) ! layer thickness (m) - real(r8), INTENT(inout) :: t_soisno(maxsnl+1:0) ! soil + snow layer temperature [K] - real(r8), INTENT(inout) :: wliq_soisno(maxsnl+1:0) ! liquid water (kg/m2) - real(r8), INTENT(inout) :: wice_soisno(maxsnl+1:0) ! ice lens (kg/m2) - real(r8), INTENT(inout) :: fiold(maxsnl+1:0) ! fraction of ice relative to the total water - integer, INTENT(inout) :: snl ! number of snow layers - real(r8), INTENT(inout) :: sag ! non dimensional snow age [-] - real(r8), INTENT(inout) :: scv ! snow mass (kg/m2) - real(r8), INTENT(inout) :: snowdp ! snow depth (m) - real(r8), INTENT(inout) :: fsno ! fraction of soil covered by snow [-] - - real(r8), INTENT(inout), optional :: wetwat ! wetland water [mm] + real(r8), intent(in) :: deltim ! model time step [second] + real(r8), intent(in) :: t_grnd ! ground surface temperature [k] + real(r8), intent(in) :: pg_rain ! rainfall onto ground including canopy runoff [kg/(m2 s)] + real(r8), intent(in) :: pg_snow ! snowfall onto ground including canopy runoff [kg/(m2 s)] + real(r8), intent(in) :: bifall ! bulk density of newly fallen dry snow [kg/m3] + real(r8), intent(in) :: t_precip ! snowfall/rainfall temperature [kelvin] + + real(r8), intent(inout) :: zi_soisno(maxsnl:0) ! interface level below a "z" level (m) + real(r8), intent(inout) :: z_soisno(maxsnl+1:0) ! layer depth (m) + real(r8), intent(inout) :: dz_soisno(maxsnl+1:0) ! layer thickness (m) + real(r8), intent(inout) :: t_soisno(maxsnl+1:0) ! soil + snow layer temperature [K] + real(r8), intent(inout) :: wliq_soisno(maxsnl+1:0) ! liquid water (kg/m2) + real(r8), intent(inout) :: wice_soisno(maxsnl+1:0) ! ice lens (kg/m2) + real(r8), intent(inout) :: fiold(maxsnl+1:0) ! fraction of ice relative to the total water + integer , intent(inout) :: snl ! number of snow layers + real(r8), intent(inout) :: sag ! non dimensional snow age [-] + real(r8), intent(inout) :: scv ! snow mass (kg/m2) + real(r8), intent(inout) :: snowdp ! snow depth (m) + real(r8), intent(inout) :: fsno ! fraction of soil covered by snow [-] + + real(r8), intent(inout), optional :: wetwat ! wetland water [mm] ! ----------------------- Local Variables ----------------------------- @@ -65,59 +65,59 @@ subroutine newsnow (patchtype,maxsnl,deltim,t_grnd,pg_rain,pg_snow,bifall,& integer lb !----------------------------------------------------------------------- - newnode = 0 + newnode = 0 - dz_snowf = pg_snow/bifall - snowdp = snowdp + dz_snowf*deltim - scv = scv + pg_snow*deltim ! snow water equivalent (mm) + dz_snowf = pg_snow/bifall + snowdp = snowdp + dz_snowf*deltim + scv = scv + pg_snow*deltim ! snow water equivalent (mm) - if(patchtype==2 .AND. t_grnd>tfrz)then ! snowfall on warmer wetland - IF (present(wetwat) .and. DEF_USE_VariablySaturatedFlow) THEN - wetwat = wetwat + scv - ENDIF - scv=0.; snowdp=0.; sag=0.; fsno = 0. - endif + IF(patchtype==2 .and. t_grnd>tfrz)THEN ! snowfall on warmer wetland + IF (present(wetwat) .and. DEF_USE_VariablySaturatedFlow) THEN + wetwat = wetwat + scv + ENDIF + scv=0.; snowdp=0.; sag=0.; fsno = 0. + ENDIF - zi_soisno(0) = 0. + zi_soisno(0) = 0. ! when the snow accumulation exceeds 10 mm, initialize a snow layer - if(snl==0 .AND. pg_snow>0.0 .AND. snowdp>=0.01)then - snl = -1 - newnode = 1 - dz_soisno(0) = snowdp ! meter - z_soisno (0) = -0.5*dz_soisno(0) - zi_soisno(-1) = -dz_soisno(0) - - sag = 0. ! snow age - t_soisno (0) = min(tfrz, t_precip) ! K - wice_soisno(0) = scv ! kg/m2 - wliq_soisno(0) = 0. ! kg/m2 - fiold(0) = 1. - fsno = min(1.,tanh(0.1*pg_snow*deltim)) - endif - - ! -------------------------------------------------- - ! snowfall on snow pack - ! -------------------------------------------------- - ! the change of ice partial density of surface node due to precipitation - ! only ice part of snowfall is added here, the liquid part will be added latter - - if(snl<0 .AND. newnode==0)then - lb = snl + 1 - - wice_soisno(lb) = wice_soisno(lb)+deltim*pg_snow - dz_soisno(lb) = dz_soisno(lb)+dz_snowf*deltim - z_soisno(lb) = zi_soisno(lb) - 0.5*dz_soisno(lb) - zi_soisno(lb-1) = zi_soisno(lb) - dz_soisno(lb) - - ! update fsno by new snow event, add to previous fsno - ! shape factor for accumulation of snow = 0.1 - fsno = 1. - (1. - tanh(0.1*pg_snow*deltim))*(1. - fsno) - fsno = min(1., fsno) - - endif - - end subroutine newsnow + IF(snl==0 .and. pg_snow>0.0 .and. snowdp>=0.01)THEN + snl = -1 + newnode = 1 + dz_soisno(0) = snowdp ! meter + z_soisno (0) = -0.5*dz_soisno(0) + zi_soisno(-1) = -dz_soisno(0) + + sag = 0. ! snow age + t_soisno (0) = min(tfrz, t_precip) ! K + wice_soisno(0) = scv ! kg/m2 + wliq_soisno(0) = 0. ! kg/m2 + fiold(0) = 1. + fsno = min(1.,tanh(0.1*pg_snow*deltim)) + ENDIF + + ! -------------------------------------------------- + ! snowfall on snow pack + ! -------------------------------------------------- + ! the change of ice partial density of surface node due to precipitation + ! only ice part of snowfall is added here, the liquid part will be added latter + + IF(snl<0 .and. newnode==0)THEN + lb = snl + 1 + + wice_soisno(lb) = wice_soisno(lb)+deltim*pg_snow + dz_soisno(lb) = dz_soisno(lb)+dz_snowf*deltim + z_soisno(lb) = zi_soisno(lb) - 0.5*dz_soisno(lb) + zi_soisno(lb-1) = zi_soisno(lb) - dz_soisno(lb) + + ! update fsno by new snow event, add to previous fsno + ! shape factor for accumulation of snow = 0.1 + fsno = 1. - (1. - tanh(0.1*pg_snow*deltim))*(1. - fsno) + fsno = min(1., fsno) + + ENDIF + + END SUBROUTINE newsnow END MODULE MOD_NewSnow diff --git a/main/MOD_NitrifData.F90 b/main/MOD_NitrifData.F90 index 250947db..ac8b5aa6 100644 --- a/main/MOD_NitrifData.F90 +++ b/main/MOD_NitrifData.F90 @@ -11,10 +11,10 @@ MODULE MOD_NitrifData USE MOD_Grid USE MOD_Mapping_Grid2Pset - use MOD_BGC_Vars_TimeVariables, only : tCONC_O2_UNSAT, tO2_DECOMP_DEPTH_UNSAT + USE MOD_BGC_Vars_TimeVariables, only : tCONC_O2_UNSAT, tO2_DECOMP_DEPTH_UNSAT IMPLICIT NONE - TYPE(grid_type) :: grid_nitrif + type(grid_type) :: grid_nitrif type(mapping_grid2pset_type) :: mg2p_nitrif CONTAINS @@ -27,19 +27,19 @@ SUBROUTINE init_nitrif_data (idate) ! open nitrif netcdf file from DEF_dir_runtime, read latitude and longitude info. ! Initialize nitrif data read in. - use MOD_TimeManager - USE MOD_Namelist - USE MOD_Grid - USE MOD_NetCDFSerial - USE MOD_LandPatch - IMPLICIT NONE + USE MOD_TimeManager + USE MOD_Namelist + USE MOD_Grid + USE MOD_NetCDFSerial + USE MOD_LandPatch + IMPLICIT NONE - integer, intent(in) :: idate(3) + integer, intent(in) :: idate(3) - ! Local Variables - CHARACTER(len=256) :: file_nitrif - REAL(r8), allocatable :: lat(:), lon(:) - integer :: month, mday + ! Local Variables + character(len=256) :: file_nitrif + real(r8), allocatable :: lat(:), lon(:) + integer :: month, mday file_nitrif = trim(DEF_dir_runtime)//'/nitrif/CONC_O2_UNSAT/CONC_O2_UNSAT_l01.nc' @@ -48,7 +48,7 @@ SUBROUTINE init_nitrif_data (idate) CALL grid_nitrif%define_by_center (lat, lon) - call mg2p_nitrif%build (grid_nitrif, landpatch) + CALL mg2p_nitrif%build (grid_nitrif, landpatch) IF (allocated(lon)) deallocate(lon) IF (allocated(lat)) deallocate(lat) @@ -62,97 +62,97 @@ END SUBROUTINE init_nitrif_data ! ---------- SUBROUTINE update_nitrif_data (month) - use MOD_SPMD_Task - use MOD_Namelist - USE MOD_DataType - USE MOD_Vars_Global, only : nl_soil - USE MOD_NetCDFBlock - use MOD_LandPatch - use MOD_Vars_TimeInvariants - USE MOD_RangeCheck - IMPLICIT NONE - - integer, intent(in) :: month - - ! Local Variables - CHARACTER(len=256) :: file_nitrif - TYPE(block_data_real8_2d) :: f_xy_nitrif - REAL(r8), allocatable :: tCONC_O2_UNSAT_tmp(:) - REAL(r8), allocatable :: tO2_DECOMP_DEPTH_UNSAT_tmp(:) - character(len=2) :: cx - integer :: nsl, npatch, m + USE MOD_SPMD_Task + USE MOD_Namelist + USE MOD_DataType + USE MOD_Vars_Global, only: nl_soil + USE MOD_NetCDFBlock + USE MOD_LandPatch + USE MOD_Vars_TimeInvariants + USE MOD_RangeCheck + IMPLICIT NONE + + integer, intent(in) :: month + + ! Local Variables + character(len=256) :: file_nitrif + type(block_data_real8_2d) :: f_xy_nitrif + real(r8), allocatable :: tCONC_O2_UNSAT_tmp(:) + real(r8), allocatable :: tO2_DECOMP_DEPTH_UNSAT_tmp(:) + character(len=2) :: cx + integer :: nsl, npatch, m IF (p_is_worker) THEN allocate(tCONC_O2_UNSAT_tmp (numpatch)) allocate(tO2_DECOMP_DEPTH_UNSAT_tmp(numpatch)) - ENDIF - + ENDIF + IF (p_is_io) THEN CALL allocate_block_data (grid_nitrif, f_xy_nitrif) ENDIF DO nsl = 1, nl_soil - + write(cx,'(i2.2)') nsl file_nitrif = trim(DEF_dir_runtime)//'/nitrif/CONC_O2_UNSAT/CONC_O2_UNSAT_l'//trim(cx)//'.nc' IF (p_is_io) THEN CALL ncio_read_block_time (file_nitrif, 'CONC_O2_UNSAT', grid_nitrif, month, f_xy_nitrif) ENDIF - call mg2p_nitrif%map_aweighted (f_xy_nitrif, tCONC_O2_UNSAT_tmp) + CALL mg2p_nitrif%map_aweighted (f_xy_nitrif, tCONC_O2_UNSAT_tmp) - if (p_is_worker) then - if (numpatch > 0) then - do npatch = 1, numpatch + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + DO npatch = 1, numpatch m = patchclass(npatch) - if( m == 0 )then + IF( m == 0 )THEN tCONC_O2_UNSAT(nsl,npatch) = 0. - else + ELSE tCONC_O2_UNSAT(nsl,npatch) = tCONC_O2_UNSAT_tmp(npatch) - endif - if (tCONC_O2_UNSAT(nsl,npatch) < 1E-10) then + ENDIF + IF (tCONC_O2_UNSAT(nsl,npatch) < 1E-10) THEN tCONC_O2_UNSAT(nsl,npatch)=0.0 - endif - end do + ENDIF + ENDDO ENDIF ENDIF - END do + ENDDO #ifdef RangeCheck - call check_vector_data ('CONC_O2_UNSAT', tCONC_O2_UNSAT) + CALL check_vector_data ('CONC_O2_UNSAT', tCONC_O2_UNSAT) #endif DO nsl = 1, nl_soil - + write(cx,'(i2.2)') nsl file_nitrif = trim(DEF_dir_runtime)//'/nitrif/O2_DECOMP_DEPTH_UNSAT/O2_DECOMP_DEPTH_UNSAT_l'//trim(cx)//'.nc' IF (p_is_io) THEN CALL ncio_read_block_time (file_nitrif, 'O2_DECOMP_DEPTH_UNSAT', grid_nitrif, month, f_xy_nitrif) - ENDIF + ENDIF - call mg2p_nitrif%map_aweighted (f_xy_nitrif, tO2_DECOMP_DEPTH_UNSAT_tmp) + CALL mg2p_nitrif%map_aweighted (f_xy_nitrif, tO2_DECOMP_DEPTH_UNSAT_tmp) - if (p_is_worker) then - if (numpatch > 0) then - do npatch = 1, numpatch + IF (p_is_worker) THEN + IF (numpatch > 0) THEN + DO npatch = 1, numpatch m = patchclass(npatch) - if( m == 0 )then + IF( m == 0 )THEN tO2_DECOMP_DEPTH_UNSAT(nsl,npatch) = 0. - else + ELSE tO2_DECOMP_DEPTH_UNSAT(nsl,npatch) = tO2_DECOMP_DEPTH_UNSAT_tmp(npatch) - endif - if (tO2_DECOMP_DEPTH_UNSAT(nsl,npatch) < 1E-10) then + ENDIF + IF (tO2_DECOMP_DEPTH_UNSAT(nsl,npatch) < 1E-10) THEN tO2_DECOMP_DEPTH_UNSAT(nsl,npatch)=0.0 - endif - end do + ENDIF + ENDDO ENDIF ENDIF - END do + ENDDO #ifdef RangeCheck - call check_vector_data ('O2_DECOMP_DEPTH_UNSAT', tO2_DECOMP_DEPTH_UNSAT) + CALL check_vector_data ('O2_DECOMP_DEPTH_UNSAT', tO2_DECOMP_DEPTH_UNSAT) #endif IF (p_is_worker) THEN diff --git a/main/MOD_OrbCoszen.F90 b/main/MOD_OrbCoszen.F90 index 40b9c473..7dc1093e 100644 --- a/main/MOD_OrbCoszen.F90 +++ b/main/MOD_OrbCoszen.F90 @@ -1,3 +1,5 @@ +#include + MODULE MOD_OrbCoszen !----------------------------------------------------------------------- @@ -11,14 +13,13 @@ MODULE MOD_OrbCoszen !----------------------------------------------------------------------- - CONTAINS +CONTAINS !----------------------------------------------------------------------- + FUNCTION orb_coszen(calday,dlon,dlat) - function orb_coszen(calday,dlon,dlat) - -!------------------------------------------------------------------------------- +!----------------------------------------------------------------------- ! FUNCTION to return the cosine of the solar zenith angle. Assumes 365.0 days/year. ! Compute earth/orbit parameters using formula suggested by ! Duane Thresher. Use formulas from Berger, Andre 1978: Long-Term Variations of Daily @@ -27,10 +28,10 @@ function orb_coszen(calday,dlon,dlat) ! Original version: Erik Kluzek, Oct/1997, Brian Kauffman, Jan/98 ! CCSM2.0 standard ! yongjiu dai (07/23/2002) -!------------------------------------------------------------------------------- +!----------------------------------------------------------------------- - use MOD_Precision - implicit none + USE MOD_Precision + IMPLICIT NONE real(r8), intent(in) :: calday !Julian cal day (1.xx to 365.xx) real(r8), intent(in) :: dlat !Centered latitude (radians) @@ -54,23 +55,23 @@ function orb_coszen(calday,dlon,dlat) lambm0=-3.2625366E-2, &!Mean long of perihelion at the vernal equinox (radians) mvelpp=4.92251015 !moving vernal equinox longitude of !perihelion plus pi (radians) - !------------------------------------------------------------------------------- + !--------------------------------------------------------------------- - pi = 4.*atan(1.) - lambm = lambm0 + (calday - ve)*2.*pi/dayspy - lmm = lambm - mvelpp + pi = 4.*atan(1.) + lambm = lambm0 + (calday - ve)*2.*pi/dayspy + lmm = lambm - mvelpp - sinl = sin(lmm) - lamb = lambm + eccen*(2.*sinl + eccen*(1.25*sin(2.*lmm) & + sinl = sin(lmm) + lamb = lambm + eccen*(2.*sinl + eccen*(1.25*sin(2.*lmm) & + eccen*((13.0/12.0)*sin(3.*lmm) - 0.25*sinl))) - invrho = (1. + eccen*cos(lamb - mvelpp)) / (1. - eccen*eccen) + invrho = (1. + eccen*cos(lamb - mvelpp)) / (1. - eccen*eccen) - declin = asin(sin(obliqr)*sin(lamb)) - eccf = invrho*invrho + declin = asin(sin(obliqr)*sin(lamb)) + eccf = invrho*invrho - orb_coszen = sin(dlat)*sin(declin) & - - cos(dlat)*cos(declin)*cos(calday*2.0*pi+dlon) + orb_coszen = sin(dlat)*sin(declin) & + - cos(dlat)*cos(declin)*cos(calday*2.0*pi+dlon) - end function orb_coszen + END FUNCTION orb_coszen END MODULE MOD_OrbCoszen diff --git a/main/MOD_Ozone.F90 b/main/MOD_Ozone.F90 index 7a758b58..43197ec0 100644 --- a/main/MOD_Ozone.F90 +++ b/main/MOD_Ozone.F90 @@ -15,277 +15,277 @@ Module MOD_Ozone - use MOD_Precision - USE MOD_Const_Physical, only: rgas - USE MOD_Const_PFT, only: isevg, leaf_long, woody - USE MOD_Grid - USE MOD_DataType - USE MOD_Mapping_Grid2Pset - USE MOD_Vars_1DForcing, only: forc_ozone - USE MOD_Namelist, only: DEF_USE_OZONEDATA - IMPLICIT NONE - - CHARACTER(len=256) :: file_ozone - - TYPE(grid_type) :: grid_ozone - - TYPE(block_data_real8_2d) :: f_ozone - + USE MOD_Precision + USE MOD_Const_Physical, only: rgas + USE MOD_Const_PFT, only: isevg, leaf_long, woody + USE MOD_Grid + USE MOD_DataType + USE MOD_Mapping_Grid2Pset + USE MOD_Vars_1DForcing, only: forc_ozone + USE MOD_Namelist, only: DEF_USE_OZONEDATA + IMPLICIT NONE + + character(len=256) :: file_ozone + + type(grid_type) :: grid_ozone + + type(block_data_real8_2d) :: f_ozone + type (mapping_grid2pset_type) :: mg2p_ozone - SAVE + SAVE - public :: CalcOzoneStress - public :: init_ozone_data - public :: update_ozone_data + PUBLIC :: CalcOzoneStress + PUBLIC :: init_ozone_data + PUBLIC :: update_ozone_data - CONTAINS +CONTAINS - subroutine CalcOzoneStress (o3coefv,o3coefg, forc_ozone, forc_psrf, th, ram, & + SUBROUTINE CalcOzoneStress (o3coefv,o3coefg, forc_ozone, forc_psrf, th, ram, & rs, rb, lai, lai_old, ivt, o3uptake, deltim) !------------------------------------------------- ! DESCRIPTION: ! Calculate Ozone Stress on both vcmax and stomata conductance. ! - ! convert o3 from mol/mol to nmol m^-3 - real(r8), intent(out) :: o3coefv - real(r8), intent(out) :: o3coefg - real(r8), intent(inout) :: forc_ozone - real(r8), intent(in) :: forc_psrf - real(r8), intent(in) :: th - real(r8), intent(in) :: ram - real(r8), intent(in) :: rs - real(r8), intent(in) :: rb - real(r8), intent(in) :: lai - real(r8), intent(in) :: lai_old - integer , intent(in) :: ivt - real(r8), intent(inout) :: o3uptake - real(r8), intent(in) :: deltim - - real(r8) :: o3concnmolm3 ! o3 concentration (nmol/m^3) - real(r8) :: o3flux ! instantaneous o3 flux (nmol m^-2 s^-1) - real(r8) :: o3fluxcrit ! instantaneous o3 flux beyond threshold (nmol m^-2 s^-1) - real(r8) :: o3fluxperdt ! o3 flux per timestep (mmol m^-2) - real(r8) :: heal ! o3uptake healing rate based on % of new leaves growing (mmol m^-2) - real(r8) :: leafturn ! leaf turnover time / mortality rate (per hour) - real(r8) :: decay ! o3uptake decay rate based on leaf lifetime (mmol m^-2) - real(r8) :: photoInt ! intercept for photosynthesis - real(r8) :: photoSlope ! slope for photosynthesis - real(r8) :: condInt ! intercept for conductance - real(r8) :: condSlope ! slope for conductance - - real(r8), parameter :: ko3 = 1.51_r8 !F. Li - - ! LAI threshold for LAIs that asymptote and don't reach 0 - real(r8), parameter :: lai_thresh = 0.5_r8 - - ! threshold below which o3flux is set to 0 (nmol m^-2 s^-1) - real(r8), parameter :: o3_flux_threshold = 0.5_r8 !F. Li - - ! o3 intercepts and slopes for photosynthesis - real(r8), parameter :: needleleafPhotoInt = 0.8390_r8 ! units = unitless - real(r8), parameter :: needleleafPhotoSlope = 0._r8 ! units = per mmol m^-2 - real(r8), parameter :: broadleafPhotoInt = 0.8752_r8 ! units = unitless - real(r8), parameter :: broadleafPhotoSlope = 0._r8 ! units = per mmol m^-2 - real(r8), parameter :: nonwoodyPhotoInt = 0.8021_r8 ! units = unitless - real(r8), parameter :: nonwoodyPhotoSlope = -0.0009_r8 ! units = per mmol m^-2 - - ! o3 intercepts and slopes for conductance - real(r8), parameter :: needleleafCondInt = 0.7823_r8 ! units = unitless - real(r8), parameter :: needleleafCondSlope = 0.0048_r8 ! units = per mmol m^-2 - real(r8), parameter :: broadleafCondInt = 0.9125_r8 ! units = unitless - real(r8), parameter :: broadleafCondSlope = 0._r8 ! units = per mmol m^-2 - real(r8), parameter :: nonwoodyCondInt = 0.7511_r8 ! units = unitless - real(r8), parameter :: nonwoodyCondSlope = 0._r8 ! units = per mmol m^-2 - - IF(.not. DEF_USE_OZONEDATA)then - forc_ozone = 100._r8 * 1.e-9_r8 ! ozone partial pressure [mol/mol] - ENDIF - - o3concnmolm3 = forc_ozone * 1.e9_r8 * (forc_psrf/(th*rgas*0.001_r8 )) - - ! calculate instantaneous flux - o3flux = o3concnmolm3/ (ko3*rs+ rb + ram) - - ! apply o3 flux threshold - if (o3flux < o3_flux_threshold) then - o3fluxcrit = 0._r8 - else - o3fluxcrit = o3flux - o3_flux_threshold - endif - - ! calculate o3 flux per timestep - o3fluxperdt = o3fluxcrit * deltim * 0.000001_r8 - - if (lai > lai_thresh) then - ! checking if new leaf area was added - if (lai - lai_old > 0) then - ! minimizing o3 damage to new leaves - heal = max(0._r8,(((lai-lai_old)/lai)*o3fluxperdt)) - else - heal = 0._r8 - endif - - if (isevg(ivt)) then - leafturn = 1._r8/(leaf_long(ivt)*365._r8*24._r8) - else - leafturn = 0._r8 - endif - - ! o3 uptake decay based on leaf lifetime for evergreen plants - decay = o3uptake * leafturn * deltim/3600._r8 - !cumulative uptake (mmol m^-2) - o3uptake = max(0._r8, o3uptake + o3fluxperdt - decay - heal) - - else - o3uptake = 0._r8 - end if - - if (o3uptake == 0._r8) then - ! No o3 damage if no o3 uptake - o3coefv = 1._r8 - o3coefg = 1._r8 - else - ! Determine parameter values for this pft - ! TODO(wjs, 2014-10-01) Once these parameters are moved into the params file, this - ! logic can be removed. - ! add GPAM ozone impact on crop and change logic by F. Li - if (ivt>16)then - o3coefv = max(0._r8, min(1._r8, 0.883_r8 - 0.058 * log10(o3uptake))) - o3coefg = max(0._r8, min(1._r8, 0.951_r8 - 0.109 * tanh(o3uptake))) - else - if (ivt>3) then - if (woody(ivt)==0) then - photoInt = nonwoodyPhotoInt - photoSlope = nonwoodyPhotoSlope - condInt = nonwoodyCondInt - condSlope = nonwoodyCondSlope - else - photoInt = broadleafPhotoInt - photoSlope = broadleafPhotoSlope - condInt = broadleafCondInt - condSlope = broadleafCondSlope - end if - else - photoInt = needleleafPhotoInt - photoSlope = needleleafPhotoSlope - condInt = needleleafCondInt - condSlope = needleleafCondSlope - end if - - ! Apply parameter values to compute o3 coefficients - o3coefv = max(0._r8, min(1._r8, photoInt + photoSlope * o3uptake)) - o3coefg = max(0._r8, min(1._r8, condInt + condSlope * o3uptake)) - end if - end if - - end subroutine CalcOzoneStress - - - SUBROUTINE init_ozone_data (idate) - + ! convert o3 from mol/mol to nmol m^-3 + real(r8), intent(out) :: o3coefv + real(r8), intent(out) :: o3coefg + real(r8), intent(inout) :: forc_ozone + real(r8), intent(in) :: forc_psrf + real(r8), intent(in) :: th + real(r8), intent(in) :: ram + real(r8), intent(in) :: rs + real(r8), intent(in) :: rb + real(r8), intent(in) :: lai + real(r8), intent(in) :: lai_old + integer , intent(in) :: ivt + real(r8), intent(inout) :: o3uptake + real(r8), intent(in) :: deltim + + real(r8) :: o3concnmolm3 ! o3 concentration (nmol/m^3) + real(r8) :: o3flux ! instantaneous o3 flux (nmol m^-2 s^-1) + real(r8) :: o3fluxcrit ! instantaneous o3 flux beyond threshold (nmol m^-2 s^-1) + real(r8) :: o3fluxperdt ! o3 flux per timestep (mmol m^-2) + real(r8) :: heal ! o3uptake healing rate based on % of new leaves growing (mmol m^-2) + real(r8) :: leafturn ! leaf turnover time / mortality rate (per hour) + real(r8) :: decay ! o3uptake decay rate based on leaf lifetime (mmol m^-2) + real(r8) :: photoInt ! intercept for photosynthesis + real(r8) :: photoSlope ! slope for photosynthesis + real(r8) :: condInt ! intercept for conductance + real(r8) :: condSlope ! slope for conductance + + real(r8), parameter :: ko3 = 1.51_r8 !F. Li + + ! LAI threshold for LAIs that asymptote and don't reach 0 + real(r8), parameter :: lai_thresh = 0.5_r8 + + ! threshold below which o3flux is set to 0 (nmol m^-2 s^-1) + real(r8), parameter :: o3_flux_threshold = 0.5_r8 !F. Li + + ! o3 intercepts and slopes for photosynthesis + real(r8), parameter :: needleleafPhotoInt = 0.8390_r8 ! units = unitless + real(r8), parameter :: needleleafPhotoSlope = 0._r8 ! units = per mmol m^-2 + real(r8), parameter :: broadleafPhotoInt = 0.8752_r8 ! units = unitless + real(r8), parameter :: broadleafPhotoSlope = 0._r8 ! units = per mmol m^-2 + real(r8), parameter :: nonwoodyPhotoInt = 0.8021_r8 ! units = unitless + real(r8), parameter :: nonwoodyPhotoSlope = -0.0009_r8 ! units = per mmol m^-2 + + ! o3 intercepts and slopes for conductance + real(r8), parameter :: needleleafCondInt = 0.7823_r8 ! units = unitless + real(r8), parameter :: needleleafCondSlope = 0.0048_r8 ! units = per mmol m^-2 + real(r8), parameter :: broadleafCondInt = 0.9125_r8 ! units = unitless + real(r8), parameter :: broadleafCondSlope = 0._r8 ! units = per mmol m^-2 + real(r8), parameter :: nonwoodyCondInt = 0.7511_r8 ! units = unitless + real(r8), parameter :: nonwoodyCondSlope = 0._r8 ! units = per mmol m^-2 + + IF(.not. DEF_USE_OZONEDATA)THEN + forc_ozone = 100._r8 * 1.e-9_r8 ! ozone partial pressure [mol/mol] + ENDIF + + o3concnmolm3 = forc_ozone * 1.e9_r8 * (forc_psrf/(th*rgas*0.001_r8 )) + + ! calculate instantaneous flux + o3flux = o3concnmolm3/ (ko3*rs+ rb + ram) + + ! apply o3 flux threshold + IF (o3flux < o3_flux_threshold) THEN + o3fluxcrit = 0._r8 + ELSE + o3fluxcrit = o3flux - o3_flux_threshold + ENDIF + + ! calculate o3 flux per timestep + o3fluxperdt = o3fluxcrit * deltim * 0.000001_r8 + + IF (lai > lai_thresh) THEN + ! checking IF new leaf area was added + IF (lai - lai_old > 0) THEN + ! minimizing o3 damage to new leaves + heal = max(0._r8,(((lai-lai_old)/lai)*o3fluxperdt)) + ELSE + heal = 0._r8 + ENDIF + + IF (isevg(ivt)) THEN + leafturn = 1._r8/(leaf_long(ivt)*365._r8*24._r8) + ELSE + leafturn = 0._r8 + ENDIF + + ! o3 uptake decay based on leaf lifetime for evergreen plants + decay = o3uptake * leafturn * deltim/3600._r8 + !cumulative uptake (mmol m^-2) + o3uptake = max(0._r8, o3uptake + o3fluxperdt - decay - heal) + + ELSE + o3uptake = 0._r8 + ENDIF + + IF (o3uptake == 0._r8) THEN + ! No o3 damage IF no o3 uptake + o3coefv = 1._r8 + o3coefg = 1._r8 + ELSE + ! Determine parameter values for this pft + ! TODO(wjs, 2014-10-01) Once these parameters are moved into the params file, this + ! logic can be removed. + ! add GPAM ozone impact on crop and change logic by F. Li + IF (ivt>16)THEN + o3coefv = max(0._r8, min(1._r8, 0.883_r8 - 0.058 * log10(o3uptake))) + o3coefg = max(0._r8, min(1._r8, 0.951_r8 - 0.109 * tanh(o3uptake))) + ELSE + IF (ivt>3) THEN + IF (woody(ivt)==0) THEN + photoInt = nonwoodyPhotoInt + photoSlope = nonwoodyPhotoSlope + condInt = nonwoodyCondInt + condSlope = nonwoodyCondSlope + ELSE + photoInt = broadleafPhotoInt + photoSlope = broadleafPhotoSlope + condInt = broadleafCondInt + condSlope = broadleafCondSlope + ENDIF + ELSE + photoInt = needleleafPhotoInt + photoSlope = needleleafPhotoSlope + condInt = needleleafCondInt + condSlope = needleleafCondSlope + ENDIF + + ! Apply parameter values to compute o3 coefficients + o3coefv = max(0._r8, min(1._r8, photoInt + photoSlope * o3uptake)) + o3coefg = max(0._r8, min(1._r8, condInt + condSlope * o3uptake)) + ENDIF + ENDIF + + END SUBROUTINE CalcOzoneStress + + + SUBROUTINE init_ozone_data (idate) + !---------------------- ! DESCTIPTION: ! open ozone netcdf file from DEF_dir_rawdata, read latitude and longitude info. ! Initialize Ozone data read in. - USE MOD_SPMD_Task - USE MOD_Namelist - USE MOD_TimeManager - USE MOD_Grid - USE MOD_NetCDFSerial - USE MOD_NetCDFBlock - USE MOD_LandPatch - USE MOD_RangeCheck - IMPLICIT NONE - - integer, intent(in) :: idate(3) - - ! Local Variables - REAL(r8), allocatable :: lat(:), lon(:) - INTEGER :: itime - INTEGER :: iyear, month, mday - CHARACTER(LEN=8) :: syear, smonth - - call julian2monthday(idate(1),idate(2),month,mday) - iyear = idate(1) - if(idate(1) .lt. 2013)iyear = 2013 - if(idate(1) .gt. 2021)iyear = 2021 - write(syear,"(I4.4)") iyear - write(smonth,"(I2.2)") month - file_ozone = trim(DEF_dir_runtime) // '/Ozone/China/'//trim(syear)//trim(smonth)//'_O3_v2.nc' - - CALL ncio_read_bcast_serial (file_ozone, 'latitude', lat) - CALL ncio_read_bcast_serial (file_ozone, 'longitude', lon) - - CALL grid_ozone%define_by_center (lat, lon) - - CALL allocate_block_data (grid_ozone, f_ozone) - - call mg2p_ozone%build (grid_ozone, landpatch) - - itime = mday - - CALL ncio_read_block_time (file_ozone, 'O3', grid_ozone, itime, f_ozone) + USE MOD_SPMD_Task + USE MOD_Namelist + USE MOD_TimeManager + USE MOD_Grid + USE MOD_NetCDFSerial + USE MOD_NetCDFBlock + USE MOD_LandPatch + USE MOD_RangeCheck + IMPLICIT NONE + + integer, intent(in) :: idate(3) + + ! Local Variables + real(r8), allocatable :: lat(:), lon(:) + integer :: itime + integer :: iyear, month, mday + character(LEN=8) :: syear, smonth + + CALL julian2monthday(idate(1),idate(2),month,mday) + iyear = idate(1) + IF(idate(1) .lt. 2013)iyear = 2013 + IF(idate(1) .gt. 2021)iyear = 2021 + write(syear,"(I4.4)") iyear + write(smonth,"(I2.2)") month + file_ozone = trim(DEF_dir_runtime) // '/Ozone/China/'//trim(syear)//trim(smonth)//'_O3_v2.nc' + + CALL ncio_read_bcast_serial (file_ozone, 'latitude', lat) + CALL ncio_read_bcast_serial (file_ozone, 'longitude', lon) + + CALL grid_ozone%define_by_center (lat, lon) + + CALL allocate_block_data (grid_ozone, f_ozone) + + CALL mg2p_ozone%build (grid_ozone, landpatch) + + itime = mday + + CALL ncio_read_block_time (file_ozone, 'O3', grid_ozone, itime, f_ozone) #ifdef RangeCheck - CALL check_block_data ('Ozone', f_ozone) + CALL check_block_data ('Ozone', f_ozone) #endif - END SUBROUTINE init_ozone_data + END SUBROUTINE init_ozone_data ! ---------- - SUBROUTINE update_ozone_data (time, deltim) - + SUBROUTINE update_ozone_data (time, deltim) + !---------------------- ! DESCTIPTION: ! read ozone data during simulation - USE MOD_TimeManager - USE MOD_Namelist - USE MOD_NetCDFBlock - USE MOD_RangeCheck - IMPLICIT NONE - - type(timestamp), intent(in) :: time - REAL(r8), intent(in) :: deltim - - ! Local Variables - type(timestamp) :: time_next - INTEGER :: month, mday - INTEGER :: iyear, imonth, imonth_next, iday, iday_next - CHARACTER(LEN=8) :: syear, smonth - - call julian2monthday(time%year,time%day,month,mday) - imonth = month - iday = mday - - time_next = time + int(deltim) - call julian2monthday(time_next%year,time_next%day,month,mday) - imonth_next = month - iday_next = mday - - iyear = time_next%year - if(time_next%year .lt. 2013)iyear=2013 - if(time_next%year .gt. 2021)iyear=2021 - if(imonth_next /= imonth)then - write(syear,"(I4.4)") iyear - write(smonth,"(I2.2)") month - file_ozone = trim(DEF_dir_runtime) // '/Ozone/China/'//trim(syear)//trim(smonth)//'_O3_v2.nc' - end if - - IF (iday_next /= iday .and. .not.(month .eq. 2 .and. iday_next .eq. 29 .and. .not.(isleapyear(iyear)))) THEN - CALL ncio_read_block_time (file_ozone, 'O3', grid_ozone, iday_next, f_ozone) + USE MOD_TimeManager + USE MOD_Namelist + USE MOD_NetCDFBlock + USE MOD_RangeCheck + IMPLICIT NONE + + type(timestamp), intent(in) :: time + real(r8), intent(in) :: deltim + + ! Local Variables + type(timestamp) :: time_next + integer :: month, mday + integer :: iyear, imonth, imonth_next, iday, iday_next + character(LEN=8) :: syear, smonth + + CALL julian2monthday(time%year,time%day,month,mday) + imonth = month + iday = mday + + time_next = time + int(deltim) + CALL julian2monthday(time_next%year,time_next%day,month,mday) + imonth_next = month + iday_next = mday + + iyear = time_next%year + IF(time_next%year .lt. 2013)iyear=2013 + IF(time_next%year .gt. 2021)iyear=2021 + IF(imonth_next /= imonth)THEN + write(syear,"(I4.4)") iyear + write(smonth,"(I2.2)") month + file_ozone = trim(DEF_dir_runtime) // '/Ozone/China/'//trim(syear)//trim(smonth)//'_O3_v2.nc' + ENDIF + + IF (iday_next /= iday .and. .not.(month .eq. 2 .and. iday_next .eq. 29 .and. .not.(isleapyear(iyear)))) THEN + CALL ncio_read_block_time (file_ozone, 'O3', grid_ozone, iday_next, f_ozone) #ifdef RangeCheck - CALL check_block_data ('Ozone', f_ozone) -#endif - - call mg2p_ozone%map_aweighted (f_ozone, forc_ozone) - forc_ozone = forc_ozone * 1.e-9 + CALL check_block_data ('Ozone', f_ozone) +#endif + + CALL mg2p_ozone%map_aweighted (f_ozone, forc_ozone) + forc_ozone = forc_ozone * 1.e-9 #ifdef RangeCheck - call check_vector_data ('Ozone', forc_ozone) -#endif - ENDIF + CALL check_vector_data ('Ozone', forc_ozone) +#endif + ENDIF - END SUBROUTINE update_ozone_data + END SUBROUTINE update_ozone_data -end module MOD_Ozone +END MODULE MOD_Ozone diff --git a/main/MOD_PhaseChange.F90 b/main/MOD_PhaseChange.F90 index 852f273c..323a5684 100644 --- a/main/MOD_PhaseChange.F90 +++ b/main/MOD_PhaseChange.F90 @@ -14,12 +14,12 @@ MODULE MOD_PhaseChange !----------------------------------------------------------------------- - CONTAINS +CONTAINS !----------------------------------------------------------------------- - subroutine meltf (patchtype,lb,nl_soil,deltim, & + SUBROUTINE meltf (patchtype,lb,nl_soil,deltim, & fact,brr,hs,hs_soil,hs_snow,fsno,dhsdT, & t_soisno_bef,t_soisno,wliq_soisno,wice_soisno,imelt, & scv,snowdp,sm,xmf,porsl,psi0,& @@ -50,51 +50,51 @@ subroutine meltf (patchtype,lb,nl_soil,deltim, & ! Nan Wei, 04/2023: supercooled soil water is included IF supercool is defined. !----------------------------------------------------------------------- - use MOD_Precision + USE MOD_Precision USE MOD_Hydro_SoilFunction - use MOD_Const_Physical, only : tfrz, hfus,grav + USE MOD_Const_Physical, only : tfrz, hfus,grav USE MOD_Namelist IMPLICIT NONE !----------------------------------------------------------------------- - integer, INTENT(in) :: patchtype !land patch type (0=soil,1=urban or built-up,2=wetland, + 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) - integer, INTENT(in) :: nl_soil ! upper bound of array (i.e., soil layers) - integer, INTENT(in) :: lb ! lower bound of array (i.e., snl +1) - real(r8), INTENT(in) :: deltim ! time step [second] - real(r8), INTENT(in) :: t_soisno_bef(lb:nl_soil) ! temperature at previous time step [K] - real(r8), INTENT(in) :: brr (lb:nl_soil) ! - real(r8), INTENT(in) :: fact(lb:nl_soil) ! temporary variables - real(r8), INTENT(in) :: hs ! net ground heat flux into the surface - real(r8), INTENT(in) :: hs_soil ! net ground heat flux into the surface soil - real(r8), INTENT(in) :: hs_snow ! net ground heat flux into the surface snow - real(r8), INTENT(in) :: fsno ! snow fractional cover - real(r8), INTENT(in) :: dhsdT ! temperature derivative of "hs" - real(r8), INTENT(in) :: porsl(1:nl_soil) ! soil porosity [-] - real(r8), INTENT(in) :: psi0 (1:nl_soil) ! soil water suction, negative potential [mm] + integer, intent(in) :: nl_soil ! upper bound of array (i.e., soil layers) + integer, intent(in) :: lb ! lower bound of array (i.e., snl +1) + real(r8), intent(in) :: deltim ! time step [second] + real(r8), intent(in) :: t_soisno_bef(lb:nl_soil) ! temperature at previous time step [K] + real(r8), intent(in) :: brr (lb:nl_soil) ! + real(r8), intent(in) :: fact(lb:nl_soil) ! temporary variables + real(r8), intent(in) :: hs ! net ground heat flux into the surface + real(r8), intent(in) :: hs_soil ! net ground heat flux into the surface soil + real(r8), intent(in) :: hs_snow ! net ground heat flux into the surface snow + real(r8), intent(in) :: fsno ! snow fractional cover + real(r8), intent(in) :: dhsdT ! temperature derivative of "hs" + real(r8), intent(in) :: porsl(1:nl_soil) ! soil porosity [-] + real(r8), intent(in) :: psi0 (1:nl_soil) ! soil water suction, negative potential [mm] #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), & + real(r8), intent(in) :: theta_r (1:nl_soil), & alpha_vgm(1:nl_soil), & n_vgm (1:nl_soil), & L_vgm (1:nl_soil), & sc_vgm (1:nl_soil), & fc_vgm (1:nl_soil) #endif - real(r8), INTENT(in) :: dz(1:nl_soil) ! soil layer thickiness [m] + real(r8), intent(in) :: dz(1:nl_soil) ! soil layer thickiness [m] - real(r8), INTENT(inout) :: t_soisno (lb:nl_soil) ! temperature at current time step [K] - real(r8), INTENT(inout) :: wice_soisno(lb:nl_soil) ! ice lens [kg/m2] - real(r8), INTENT(inout) :: wliq_soisno(lb:nl_soil) ! liquid water [kg/m2] - real(r8), INTENT(inout) :: scv ! snow mass [kg/m2] - real(r8), INTENT(inout) :: snowdp ! snow depth [m] + real(r8), intent(inout) :: t_soisno (lb:nl_soil) ! temperature at current time step [K] + real(r8), intent(inout) :: wice_soisno(lb:nl_soil) ! ice lens [kg/m2] + real(r8), intent(inout) :: wliq_soisno(lb:nl_soil) ! liquid water [kg/m2] + real(r8), intent(inout) :: scv ! snow mass [kg/m2] + real(r8), intent(inout) :: snowdp ! snow depth [m] - real(r8), INTENT(out) :: sm ! rate of snowmelt [mm/s, kg/(m2 s)] - real(r8), INTENT(out) :: xmf ! total latent heat of phase change - integer, INTENT(out) :: imelt(lb:nl_soil) ! flag for melting or freezing [-] + real(r8), intent(out) :: sm ! rate of snowmelt [mm/s, kg/(m2 s)] + real(r8), intent(out) :: xmf ! total latent heat of phase change + integer, intent(out) :: imelt(lb:nl_soil) ! flag for melting or freezing [-] ! Local real(r8) :: hm(lb:nl_soil) ! energy residual [W/m2] @@ -102,219 +102,219 @@ subroutine meltf (patchtype,lb,nl_soil,deltim, & real(r8) :: heatr ! energy residual or loss after melting or freezing real(r8) :: temp1 ! temporary variables [kg/m2] real(r8) :: temp2 ! temporary variables [kg/m2] - REAL(r8) :: smp - REAL(r8) :: supercool(1:nl_soil) ! the maximum liquid water when the soil temperature is below the freezing point [mm3/mm3] + real(r8) :: smp + real(r8) :: supercool(1:nl_soil) ! the maximum liquid water when the soil temperature is below the freezing point [mm3/mm3] real(r8), dimension(lb:nl_soil) :: wmass0, wice0, wliq0 real(r8) :: propor, tinc, we, scvold integer j !----------------------------------------------------------------------- - sm = 0. - xmf = 0. - do j = lb, nl_soil - imelt(j) = 0 - hm(j) = 0. - xm(j) = 0. - wice0(j) = wice_soisno(j) - wliq0(j) = wliq_soisno(j) - wmass0(j) = wice_soisno(j) + wliq_soisno(j) - enddo - - scvold=scv - we=0. - if(lb<=0) we = sum(wice_soisno(lb:0)+wliq_soisno(lb:0)) + sm = 0. + xmf = 0. + DO j = lb, nl_soil + imelt(j) = 0 + hm(j) = 0. + xm(j) = 0. + wice0(j) = wice_soisno(j) + wliq0(j) = wliq_soisno(j) + wmass0(j) = wice_soisno(j) + wliq_soisno(j) + ENDDO + + scvold=scv + we=0. + IF(lb<=0) we = sum(wice_soisno(lb:0)+wliq_soisno(lb:0)) ! supercooling water - IF (DEF_USE_SUPERCOOL_WATER) THEN - DO j = 1, nl_soil - supercool(j) = 0.0 - if(t_soisno(j) < tfrz .and. patchtype <=2 ) then - smp = hfus * (t_soisno(j)-tfrz)/(grav*t_soisno(j)) * 1000. ! mm - if (porsl(j) > 0.) then + IF (DEF_USE_SUPERCOOL_WATER) THEN + DO j = 1, nl_soil + supercool(j) = 0.0 + IF(t_soisno(j) < tfrz .and. patchtype <=2 ) THEN + smp = hfus * (t_soisno(j)-tfrz)/(grav*t_soisno(j)) * 1000. ! mm + IF (porsl(j) > 0.) THEN #ifdef Campbell_SOIL_MODEL - supercool(j) = porsl(j)*(smp/psi0(j))**(-1.0/bsw(j)) + supercool(j) = porsl(j)*(smp/psi0(j))**(-1.0/bsw(j)) #else - supercool(j) = soil_vliq_from_psi(smp, porsl(j), theta_r(j), -10.0, 5, & - (/alpha_vgm(j), n_vgm(j), L_vgm(j), sc_vgm(j), fc_vgm(j)/)) + supercool(j) = soil_vliq_from_psi(smp, porsl(j), theta_r(j), -10.0, 5, & + (/alpha_vgm(j), n_vgm(j), L_vgm(j), sc_vgm(j), fc_vgm(j)/)) #endif - else - supercool(j) = 0. - end if - supercool(j) = supercool(j)*dz(j)*1000. ! mm - end if - END do - ENDIF - - do j = lb, nl_soil - ! Melting identification - ! if ice exists above melt point, melt some to liquid. - if(wice_soisno(j) > 0. .and. t_soisno(j) > tfrz)then - imelt(j) = 1 - t_soisno(j) = tfrz - endif - - ! Freezing identification - ! if liquid exists below melt point, freeze some to ice. - IF(j <= 0)then - if(wliq_soisno(j) > 0. .and. t_soisno(j) < tfrz) then - imelt(j) = 2 + ELSE + supercool(j) = 0. + ENDIF + supercool(j) = supercool(j)*dz(j)*1000. ! mm + ENDIF + ENDDO + ENDIF + + DO j = lb, nl_soil + ! Melting identification + ! IF ice exists above melt point, melt some to liquid. + IF(wice_soisno(j) > 0. .and. t_soisno(j) > tfrz)THEN + imelt(j) = 1 t_soisno(j) = tfrz - endif - ELSE - if (DEF_USE_SUPERCOOL_WATER) then - if(wliq_soisno(j) > supercool(j) .and. t_soisno(j) < tfrz) then - imelt(j) = 2 - t_soisno(j) = tfrz - endif - else - if(wliq_soisno(j) > 0. .and. t_soisno(j) < tfrz) then + ENDIF + + ! Freezing identification + ! IF liquid exists below melt point, freeze some to ice. + IF(j <= 0)THEN + IF(wliq_soisno(j) > 0. .and. t_soisno(j) < tfrz) THEN imelt(j) = 2 t_soisno(j) = tfrz - endif - endif - END if - enddo - -! If snow exists, but its thickness less than the critical value (0.01 m) - if(lb == 1 .and. scv > 0.)then - if(t_soisno(1) > tfrz)then - imelt(1) = 1 - t_soisno(1) = tfrz - endif - endif - -! Calculate the energy surplus and loss for melting and freezing - do j = lb, nl_soil - if(imelt(j) > 0)then - tinc = t_soisno(j)-t_soisno_bef(j) - - if(j > lb)then ! => not the top layer - IF (j==1 .and. DEF_SPLIT_SOILSNOW .and. patchtype<3) THEN - ! -> interface soil layer - ! 03/08/2020, yuan: seperate soil/snow heat flux, exclude glacier(3) - hm(j) = hs_soil + (1.-fsno)*dhsdT*tinc + brr(j) - tinc/fact(j) - ELSE ! -> internal layers other than the interface soil layer - hm(j) = brr(j) - tinc/fact(j) ENDIF - else ! => top layer - IF (j==1 .or. (.not.DEF_SPLIT_SOILSNOW) .or. patchtype==3) THEN - ! -> soil layer - hm(j) = hs + dhsdT*tinc + brr(j) - tinc/fact(j) - ELSE ! -> snow cover - ! 03/08/2020, yuan: seperate soil/snow heat flux, exclude glacier(3) - hm(j) = hs_snow + fsno*dhsdT*tinc + brr(j) - tinc/fact(j) + ELSE + IF (DEF_USE_SUPERCOOL_WATER) THEN + IF(wliq_soisno(j) > supercool(j) .and. t_soisno(j) < tfrz) THEN + imelt(j) = 2 + t_soisno(j) = tfrz + ENDIF + ELSE + IF(wliq_soisno(j) > 0. .and. t_soisno(j) < tfrz) THEN + imelt(j) = 2 + t_soisno(j) = tfrz + ENDIF ENDIF - endif + ENDIF + ENDDO - endif - enddo - - do j = lb, nl_soil - if(imelt(j) == 1 .and. hm(j) < 0.) then - hm(j) = 0. - imelt(j) = 0 - endif -! this error was checked carefully, it results from the the computed error -! of "Tridiagonal-Matrix" in subroutine "thermal". - if(imelt(j) == 2 .and. hm(j) > 0.) then - hm(j) = 0. - imelt(j) = 0 - endif - enddo - -! The rate of melting and freezing - do j = lb, nl_soil - if(imelt(j) > 0 .and. abs(hm(j)) > .0) then - xm(j) = hm(j)*deltim/hfus ! kg/m2 - - ! if snow exists, but its thickness less than the critical value (1 cm) - ! Note: more work is need on how to tune the snow depth at this case - if(j == 1 .and. lb == 1 .and. scv > 0. .and. xm(j) > 0.)then - temp1 = scv ! kg/m2 - scv = max(0.,temp1-xm(j)) - propor = scv/temp1 - snowdp = propor * snowdp - heatr = hm(j) - hfus*(temp1-scv)/deltim ! W/m2 - if(heatr > 0.) then - xm(j) = heatr*deltim/hfus ! kg/m2 - hm(j) = heatr ! W/m2 - else - xm(j) = 0. - hm(j) = 0. - endif - sm = max(0.,(temp1-scv))/deltim ! kg/(m2 s) - xmf = hfus*sm - endif - - heatr = 0. - if(xm(j) > 0.) then - wice_soisno(j) = max(0., wice0(j)-xm(j)) - heatr = hm(j) - hfus*(wice0(j)-wice_soisno(j))/deltim - else - if(j <= 0) then ! snow - wice_soisno(j) = min(wmass0(j), wice0(j)-xm(j)) - else - if (DEF_USE_SUPERCOOL_WATER) then - if(wmass0(j) < supercool(j)) then - wice_soisno(j) = 0. - else - wice_soisno(j) = min(wmass0(j)-supercool(j), wice0(j)-xm(j)) - endif - else - wice_soisno(j) = min(wmass0(j), wice0(j)-xm(j)) - endif - endif - heatr = hm(j) - hfus*(wice0(j)-wice_soisno(j))/deltim - endif +! If snow exists, but its thickness less than the critical value (0.01 m) + IF(lb == 1 .and. scv > 0.)THEN + IF(t_soisno(1) > tfrz)THEN + imelt(1) = 1 + t_soisno(1) = tfrz + ENDIF + ENDIF - wliq_soisno(j) = max(0.,wmass0(j)-wice_soisno(j)) +! Calculate the energy surplus and loss for melting and freezing + DO j = lb, nl_soil + IF(imelt(j) > 0)THEN + tinc = t_soisno(j)-t_soisno_bef(j) - if(abs(heatr) > 0.)then - if(j > lb)then ! => not the top layer + IF(j > lb)THEN ! => not the top layer IF (j==1 .and. DEF_SPLIT_SOILSNOW .and. patchtype<3) THEN ! -> interface soil layer - t_soisno(j) = t_soisno(j) + fact(j)*heatr/(1.-fact(j)*(1.-fsno)*dhsdT) + ! 03/08/2020, yuan: seperate soil/snow heat flux, exclude glacier(3) + hm(j) = hs_soil + (1.-fsno)*dhsdT*tinc + brr(j) - tinc/fact(j) ELSE ! -> internal layers other than the interface soil layer - t_soisno(j) = t_soisno(j) + fact(j)*heatr + hm(j) = brr(j) - tinc/fact(j) ENDIF - else ! => top layer + ELSE ! => top layer IF (j==1 .or. (.not.DEF_SPLIT_SOILSNOW) .or. patchtype==3) THEN ! -> soil layer - t_soisno(j) = t_soisno(j) + fact(j)*heatr/(1.-fact(j)*dhsdT) + hm(j) = hs + dhsdT*tinc + brr(j) - tinc/fact(j) ELSE ! -> snow cover - t_soisno(j) = t_soisno(j) + fact(j)*heatr/(1.-fact(j)*fsno*dhsdT) + ! 03/08/2020, yuan: seperate soil/snow heat flux, exclude glacier(3) + hm(j) = hs_snow + fsno*dhsdT*tinc + brr(j) - tinc/fact(j) ENDIF - endif + ENDIF + + ENDIF + ENDDO + + DO j = lb, nl_soil + IF(imelt(j) == 1 .and. hm(j) < 0.) THEN + hm(j) = 0. + imelt(j) = 0 + ENDIF +! this error was checked carefully, it results from the the computed error +! of "Tridiagonal-Matrix" in SUBROUTINE "thermal". + IF(imelt(j) == 2 .and. hm(j) > 0.) THEN + hm(j) = 0. + imelt(j) = 0 + ENDIF + ENDDO - if (DEF_USE_SUPERCOOL_WATER) then - IF(j <= 0 .or. patchtype == 3)THEN !snow - if(wliq_soisno(j)*wice_soisno(j) > 0.) t_soisno(j) = tfrz +! The rate of melting and freezing + DO j = lb, nl_soil + IF(imelt(j) > 0 .and. abs(hm(j)) > .0) THEN + xm(j) = hm(j)*deltim/hfus ! kg/m2 + + ! IF snow exists, but its thickness less than the critical value (1 cm) + ! Note: more work is need on how to tune the snow depth at this case + IF(j == 1 .and. lb == 1 .and. scv > 0. .and. xm(j) > 0.)THEN + temp1 = scv ! kg/m2 + scv = max(0.,temp1-xm(j)) + propor = scv/temp1 + snowdp = propor * snowdp + heatr = hm(j) - hfus*(temp1-scv)/deltim ! W/m2 + IF(heatr > 0.) THEN + xm(j) = heatr*deltim/hfus ! kg/m2 + hm(j) = heatr ! W/m2 + ELSE + xm(j) = 0. + hm(j) = 0. ENDIF + sm = max(0.,(temp1-scv))/deltim ! kg/(m2 s) + xmf = hfus*sm + ENDIF + + heatr = 0. + IF(xm(j) > 0.) THEN + wice_soisno(j) = max(0., wice0(j)-xm(j)) + heatr = hm(j) - hfus*(wice0(j)-wice_soisno(j))/deltim ELSE - if(wliq_soisno(j)*wice_soisno(j) > 0.) t_soisno(j) = tfrz + IF(j <= 0) THEN ! snow + wice_soisno(j) = min(wmass0(j), wice0(j)-xm(j)) + ELSE + IF (DEF_USE_SUPERCOOL_WATER) THEN + IF(wmass0(j) < supercool(j)) THEN + wice_soisno(j) = 0. + ELSE + wice_soisno(j) = min(wmass0(j)-supercool(j), wice0(j)-xm(j)) + ENDIF + ELSE + wice_soisno(j) = min(wmass0(j), wice0(j)-xm(j)) + ENDIF + ENDIF + heatr = hm(j) - hfus*(wice0(j)-wice_soisno(j))/deltim ENDIF - endif - xmf = xmf + hfus * (wice0(j)-wice_soisno(j))/deltim + wliq_soisno(j) = max(0.,wmass0(j)-wice_soisno(j)) + + IF(abs(heatr) > 0.)THEN + IF(j > lb)THEN ! => not the top layer + IF (j==1 .and. DEF_SPLIT_SOILSNOW .and. patchtype<3) THEN + ! -> interface soil layer + t_soisno(j) = t_soisno(j) + fact(j)*heatr/(1.-fact(j)*(1.-fsno)*dhsdT) + ELSE ! -> internal layers other than the interface soil layer + t_soisno(j) = t_soisno(j) + fact(j)*heatr + ENDIF + ELSE ! => top layer + IF (j==1 .or. (.not.DEF_SPLIT_SOILSNOW) .or. patchtype==3) THEN + ! -> soil layer + t_soisno(j) = t_soisno(j) + fact(j)*heatr/(1.-fact(j)*dhsdT) + ELSE ! -> snow cover + t_soisno(j) = t_soisno(j) + fact(j)*heatr/(1.-fact(j)*fsno*dhsdT) + ENDIF + ENDIF + + IF (DEF_USE_SUPERCOOL_WATER) THEN + IF(j <= 0 .or. patchtype == 3)THEN !snow + IF(wliq_soisno(j)*wice_soisno(j) > 0.) t_soisno(j) = tfrz + ENDIF + ELSE + IF(wliq_soisno(j)*wice_soisno(j) > 0.) t_soisno(j) = tfrz + ENDIF + ENDIF - if(imelt(j) == 1 .and. j < 1) & - sm = sm + max(0.,(wice0(j)-wice_soisno(j)))/deltim + xmf = xmf + hfus * (wice0(j)-wice_soisno(j))/deltim - endif - enddo + IF(imelt(j) == 1 .and. j < 1) & + sm = sm + max(0.,(wice0(j)-wice_soisno(j)))/deltim - !scvold=scv - if(lb<=0) then - we = sum(wice_soisno(lb:0)+wliq_soisno(lb:0))-we - if(abs(we)>1.e-6) then - print*, 'meltf err : ', we - endif - endif + ENDIF + ENDDO - end subroutine meltf + !scvold=scv + IF(lb<=0) THEN + we = sum(wice_soisno(lb:0)+wliq_soisno(lb:0))-we + IF(abs(we)>1.e-6) THEN + print*, 'meltf err : ', we + ENDIF + ENDIF + END SUBROUTINE meltf - subroutine meltf_snicar (patchtype,lb,nl_soil,deltim, & + + SUBROUTINE meltf_snicar (patchtype,lb,nl_soil,deltim, & fact,brr,hs,hs_soil,hs_snow,fsno,sabg_snow_lyr,dhsdT, & t_soisno_bef,t_soisno,wliq_soisno,wice_soisno,imelt, & scv,snowdp,sm,xmf,porsl,psi0,& @@ -346,52 +346,52 @@ subroutine meltf_snicar (patchtype,lb,nl_soil,deltim, & ! Nan Wei , 04/2023: supercooled soil water is included IF supercool is defined. !----------------------------------------------------------------------- - use MOD_Precision + USE MOD_Precision USE MOD_Hydro_SoilFunction - use MOD_Const_Physical, only : tfrz, hfus, grav + USE MOD_Const_Physical, only : tfrz, hfus, grav USE MOD_Namelist IMPLICIT NONE !----------------------------------------------------------------------- - integer, INTENT(in) :: patchtype !land patch type (0=soil,1=urban or built-up,2=wetland, + 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) - integer, INTENT(in) :: nl_soil ! upper bound of array (i.e., soil layers) - integer, INTENT(in) :: lb ! lower bound of array (i.e., snl +1) - real(r8), INTENT(in) :: deltim ! time step [second] - real(r8), INTENT(in) :: t_soisno_bef(lb:nl_soil) ! temperature at previous time step [K] - real(r8), INTENT(in) :: brr (lb:nl_soil) ! - real(r8), INTENT(in) :: fact(lb:nl_soil) ! temporary variables - real(r8), INTENT(in) :: hs ! net ground heat flux into the surface - real(r8), INTENT(in) :: hs_soil ! net ground heat flux into the surface soil - real(r8), INTENT(in) :: hs_snow ! net ground heat flux into the surface snow - real(r8), INTENT(in) :: fsno ! snow fractional cover - real(r8), INTENT(in) :: dhsdT ! temperature derivative of "hs" - real(r8), INTENT(in) :: sabg_snow_lyr (lb:1)! snow layer absorption [W/m-2] - real(r8), INTENT(in) :: porsl(1:nl_soil) ! soil porosity [-] - real(r8), INTENT(in) :: psi0 (1:nl_soil) ! soil water suction, negative potential [mm] + integer, intent(in) :: nl_soil ! upper bound of array (i.e., soil layers) + integer, intent(in) :: lb ! lower bound of array (i.e., snl +1) + real(r8), intent(in) :: deltim ! time step [second] + real(r8), intent(in) :: t_soisno_bef(lb:nl_soil) ! temperature at previous time step [K] + real(r8), intent(in) :: brr (lb:nl_soil) ! + real(r8), intent(in) :: fact(lb:nl_soil) ! temporary variables + real(r8), intent(in) :: hs ! net ground heat flux into the surface + real(r8), intent(in) :: hs_soil ! net ground heat flux into the surface soil + real(r8), intent(in) :: hs_snow ! net ground heat flux into the surface snow + real(r8), intent(in) :: fsno ! snow fractional cover + real(r8), intent(in) :: dhsdT ! temperature derivative of "hs" + real(r8), intent(in) :: sabg_snow_lyr (lb:1)! snow layer absorption [W/m-2] + real(r8), intent(in) :: porsl(1:nl_soil) ! soil porosity [-] + real(r8), intent(in) :: psi0 (1:nl_soil) ! soil water suction, negative potential [mm] #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), & + real(r8), intent(in) :: theta_r (1:nl_soil), & alpha_vgm(1:nl_soil), & n_vgm (1:nl_soil), & L_vgm (1:nl_soil), & sc_vgm (1:nl_soil), & fc_vgm (1:nl_soil) #endif - real(r8), INTENT(in) :: dz(1:nl_soil) ! soil layer thickiness [m] + real(r8), intent(in) :: dz(1:nl_soil) ! soil layer thickiness [m] - real(r8), INTENT(inout) :: t_soisno (lb:nl_soil) ! temperature at current time step [K] - real(r8), INTENT(inout) :: wice_soisno(lb:nl_soil) ! ice lens [kg/m2] - real(r8), INTENT(inout) :: wliq_soisno(lb:nl_soil) ! liquid water [kg/m2] - real(r8), INTENT(inout) :: scv ! snow mass [kg/m2] - real(r8), INTENT(inout) :: snowdp ! snow depth [m] + real(r8), intent(inout) :: t_soisno (lb:nl_soil) ! temperature at current time step [K] + real(r8), intent(inout) :: wice_soisno(lb:nl_soil) ! ice lens [kg/m2] + real(r8), intent(inout) :: wliq_soisno(lb:nl_soil) ! liquid water [kg/m2] + real(r8), intent(inout) :: scv ! snow mass [kg/m2] + real(r8), intent(inout) :: snowdp ! snow depth [m] - real(r8), INTENT(out) :: sm ! rate of snowmelt [mm/s, kg/(m2 s)] - real(r8), INTENT(out) :: xmf ! total latent heat of phase change - integer, INTENT(out) :: imelt(lb:nl_soil) ! flag for melting or freezing [-] + real(r8), intent(out) :: sm ! rate of snowmelt [mm/s, kg/(m2 s)] + real(r8), intent(out) :: xmf ! total latent heat of phase change + integer, intent(out) :: imelt(lb:nl_soil) ! flag for melting or freezing [-] ! Local real(r8) :: hm(lb:nl_soil) ! energy residual [W/m2] @@ -399,225 +399,225 @@ subroutine meltf_snicar (patchtype,lb,nl_soil,deltim, & real(r8) :: heatr ! energy residual or loss after melting or freezing real(r8) :: temp1 ! temporary variables [kg/m2] real(r8) :: temp2 ! temporary variables [kg/m2] - REAL(r8) :: smp - REAL(r8) :: supercool(1:nl_soil) ! the maximum liquid water when the soil temperature is below the freezing point [mm3/mm3] + real(r8) :: smp + real(r8) :: supercool(1:nl_soil) ! the maximum liquid water when the soil temperature is below the freezing point [mm3/mm3] real(r8), dimension(lb:nl_soil) :: wmass0, wice0, wliq0 real(r8) :: propor, tinc, we, scvold integer j !----------------------------------------------------------------------- - sm = 0. - xmf = 0. - do j = lb, nl_soil - imelt(j) = 0 - hm(j) = 0. - xm(j) = 0. - wice0(j) = wice_soisno(j) - wliq0(j) = wliq_soisno(j) - wmass0(j) = wice_soisno(j) + wliq_soisno(j) - enddo - - scvold=scv - we=0. - if(lb<=0) we = sum(wice_soisno(lb:0)+wliq_soisno(lb:0)) + sm = 0. + xmf = 0. + DO j = lb, nl_soil + imelt(j) = 0 + hm(j) = 0. + xm(j) = 0. + wice0(j) = wice_soisno(j) + wliq0(j) = wliq_soisno(j) + wmass0(j) = wice_soisno(j) + wliq_soisno(j) + ENDDO + + scvold=scv + we=0. + IF(lb<=0) we = sum(wice_soisno(lb:0)+wliq_soisno(lb:0)) ! supercooling water - if (DEF_USE_SUPERCOOL_WATER) then - DO j = 1, nl_soil - supercool(j) = 0.0 - if(t_soisno(j) < tfrz .and. patchtype <= 2) then - smp = hfus * (t_soisno(j)-tfrz)/(grav*t_soisno(j)) * 1000. ! mm - if (porsl(j) > 0.) then + IF (DEF_USE_SUPERCOOL_WATER) THEN + DO j = 1, nl_soil + supercool(j) = 0.0 + IF(t_soisno(j) < tfrz .and. patchtype <= 2) THEN + smp = hfus * (t_soisno(j)-tfrz)/(grav*t_soisno(j)) * 1000. ! mm + IF (porsl(j) > 0.) THEN #ifdef Campbell_SOIL_MODEL - supercool(j) = porsl(j)*(smp/psi0(j))**(-1.0/bsw(j)) + supercool(j) = porsl(j)*(smp/psi0(j))**(-1.0/bsw(j)) #else - supercool(j) = soil_vliq_from_psi(smp, porsl(j), theta_r(j), -10.0, 5, & - (/alpha_vgm(j), n_vgm(j), L_vgm(j), sc_vgm(j), fc_vgm(j)/)) + supercool(j) = soil_vliq_from_psi(smp, porsl(j), theta_r(j), -10.0, 5, & + (/alpha_vgm(j), n_vgm(j), L_vgm(j), sc_vgm(j), fc_vgm(j)/)) #endif - else - supercool(j) = 0. - end if - supercool(j) = supercool(j)*dz(j)*1000. ! mm - end if - END do - endif - - - do j = lb, nl_soil - ! Melting identification - ! if ice exists above melt point, melt some to liquid. - if(wice_soisno(j) > 0. .and. t_soisno(j) > tfrz)then - imelt(j) = 1 - t_soisno(j) = tfrz - endif + ELSE + supercool(j) = 0. + ENDIF + supercool(j) = supercool(j)*dz(j)*1000. ! mm + ENDIF + ENDDO + ENDIF - ! Freezing identification - ! if liquid exists below melt point, freeze some to ice. - IF(j <= 0)then - if(wliq_soisno(j) > 0. .and. t_soisno(j) < tfrz) then - imelt(j) = 2 + + DO j = lb, nl_soil + ! Melting identification + ! IF ice exists above melt point, melt some to liquid. + IF(wice_soisno(j) > 0. .and. t_soisno(j) > tfrz)THEN + imelt(j) = 1 t_soisno(j) = tfrz - endif - ELSE - if (DEF_USE_SUPERCOOL_WATER) then - if(wliq_soisno(j) > supercool(j) .and. t_soisno(j) < tfrz) then - imelt(j) = 2 - t_soisno(j) = tfrz - endif - else - if(wliq_soisno(j) > 0. .and. t_soisno(j) < tfrz) then + ENDIF + + ! Freezing identification + ! IF liquid exists below melt point, freeze some to ice. + IF(j <= 0)THEN + IF(wliq_soisno(j) > 0. .and. t_soisno(j) < tfrz) THEN imelt(j) = 2 t_soisno(j) = tfrz - endif - endif - END if - enddo + ENDIF + ELSE + IF (DEF_USE_SUPERCOOL_WATER) THEN + IF(wliq_soisno(j) > supercool(j) .and. t_soisno(j) < tfrz) THEN + imelt(j) = 2 + t_soisno(j) = tfrz + ENDIF + ELSE + IF(wliq_soisno(j) > 0. .and. t_soisno(j) < tfrz) THEN + imelt(j) = 2 + t_soisno(j) = tfrz + ENDIF + ENDIF + ENDIF + ENDDO ! If snow exists, but its thickness less than the critical value (0.01 m) - if(lb == 1 .and. scv > 0.)then - if(t_soisno(1) > tfrz)then - imelt(1) = 1 - t_soisno(1) = tfrz - endif - endif + IF(lb == 1 .and. scv > 0.)THEN + IF(t_soisno(1) > tfrz)THEN + imelt(1) = 1 + t_soisno(1) = tfrz + ENDIF + ENDIF ! Calculate the energy surplus and loss for melting and freezing - do j = lb, nl_soil - if(imelt(j) > 0)then - tinc = t_soisno(j)-t_soisno_bef(j) - - if(j > lb)then ! => not the top layer - IF (j==1 .and. DEF_SPLIT_SOILSNOW .and. patchtype<3) THEN - ! -> interface soil layer - ! 03/08/2020, yuan: seperate soil/snow heat flux, exclude glacier(3) - hm(j) = hs_soil + (1.-fsno)*dhsdT*tinc + brr(j) - tinc/fact(j) - ELSE ! -> internal layers other than the interface soil layer - IF (j<1 .or. (j==1 .and. patchtype==3)) THEN - hm(j) = brr(j) - tinc/fact(j) + sabg_snow_lyr(j) - ELSE - hm(j) = brr(j) - tinc/fact(j) + DO j = lb, nl_soil + IF(imelt(j) > 0)THEN + tinc = t_soisno(j)-t_soisno_bef(j) + + IF(j > lb)THEN ! => not the top layer + IF (j==1 .and. DEF_SPLIT_SOILSNOW .and. patchtype<3) THEN + ! -> interface soil layer + ! 03/08/2020, yuan: seperate soil/snow heat flux, exclude glacier(3) + hm(j) = hs_soil + (1.-fsno)*dhsdT*tinc + brr(j) - tinc/fact(j) + ELSE ! -> internal layers other than the interface soil layer + IF (j<1 .or. (j==1 .and. patchtype==3)) THEN + hm(j) = brr(j) - tinc/fact(j) + sabg_snow_lyr(j) + ELSE + hm(j) = brr(j) - tinc/fact(j) + ENDIF + ENDIF + ELSE ! => top layer + IF (j==1 .or. (.not.DEF_SPLIT_SOILSNOW) .or. patchtype==3) THEN + ! -> soil layer + hm(j) = hs + dhsdT*tinc + brr(j) - tinc/fact(j) + ELSE ! -> snow cover + ! 03/08/2020, yuan: seperate soil/snow heat flux, exclude glacier(3) + hm(j) = hs_snow + fsno*dhsdT*tinc + brr(j) - tinc/fact(j) ENDIF ENDIF - else ! => top layer - IF (j==1 .or. (.not.DEF_SPLIT_SOILSNOW) .or. patchtype==3) THEN - ! -> soil layer - hm(j) = hs + dhsdT*tinc + brr(j) - tinc/fact(j) - ELSE ! -> snow cover - ! 03/08/2020, yuan: seperate soil/snow heat flux, exclude glacier(3) - hm(j) = hs_snow + fsno*dhsdT*tinc + brr(j) - tinc/fact(j) - ENDIF - endif - endif - enddo + ENDIF + ENDDO - do j = lb, nl_soil - if(imelt(j) == 1 .and. hm(j) < 0.) then - hm(j) = 0. - imelt(j) = 0 - endif + DO j = lb, nl_soil + IF(imelt(j) == 1 .and. hm(j) < 0.) THEN + hm(j) = 0. + imelt(j) = 0 + ENDIF ! this error was checked carefully, it results from the the computed error -! of "Tridiagonal-Matrix" in subroutine "thermal". - if(imelt(j) == 2 .and. hm(j) > 0.) then - hm(j) = 0. - imelt(j) = 0 - endif - enddo +! of "Tridiagonal-Matrix" in SUBROUTINE "thermal". + IF(imelt(j) == 2 .and. hm(j) > 0.) THEN + hm(j) = 0. + imelt(j) = 0 + ENDIF + ENDDO ! The rate of melting and freezing - do j = lb, nl_soil - if(imelt(j) > 0 .and. abs(hm(j)) > .0) then - xm(j) = hm(j)*deltim/hfus ! kg/m2 + DO j = lb, nl_soil + IF(imelt(j) > 0 .and. abs(hm(j)) > .0) THEN + xm(j) = hm(j)*deltim/hfus ! kg/m2 + + ! IF snow exists, but its thickness less than the critical value (1 cm) + ! Note: more work is need on how to tune the snow depth at this case + IF(j == 1 .and. lb == 1 .and. scv > 0. .and. xm(j) > 0.)THEN + temp1 = scv ! kg/m2 + scv = max(0.,temp1-xm(j)) + propor = scv/temp1 + snowdp = propor * snowdp + heatr = hm(j) - hfus*(temp1-scv)/deltim ! W/m2 + IF(heatr > 0.) THEN + xm(j) = heatr*deltim/hfus ! kg/m2 + hm(j) = heatr ! W/m2 + ELSE + xm(j) = 0. + hm(j) = 0. + ENDIF + sm = max(0.,(temp1-scv))/deltim ! kg/(m2 s) + xmf = hfus*sm + ENDIF - ! if snow exists, but its thickness less than the critical value (1 cm) - ! Note: more work is need on how to tune the snow depth at this case - if(j == 1 .and. lb == 1 .and. scv > 0. .and. xm(j) > 0.)then - temp1 = scv ! kg/m2 - scv = max(0.,temp1-xm(j)) - propor = scv/temp1 - snowdp = propor * snowdp - heatr = hm(j) - hfus*(temp1-scv)/deltim ! W/m2 - if(heatr > 0.) then - xm(j) = heatr*deltim/hfus ! kg/m2 - hm(j) = heatr ! W/m2 - else - xm(j) = 0. - hm(j) = 0. - endif - sm = max(0.,(temp1-scv))/deltim ! kg/(m2 s) - xmf = hfus*sm - endif - - heatr = 0. - if(xm(j) > 0.) then - wice_soisno(j) = max(0., wice0(j)-xm(j)) - heatr = hm(j) - hfus*(wice0(j)-wice_soisno(j))/deltim - else - IF(j <= 0) THEN ! snow - wice_soisno(j) = min(wmass0(j), wice0(j)-xm(j)) + heatr = 0. + IF(xm(j) > 0.) THEN + wice_soisno(j) = max(0., wice0(j)-xm(j)) + heatr = hm(j) - hfus*(wice0(j)-wice_soisno(j))/deltim ELSE - if (DEF_USE_SUPERCOOL_WATER) then - if(wmass0(j) < supercool(j)) then - wice_soisno(j) = 0. - else - wice_soisno(j) = min(wmass0(j)-supercool(j), wice0(j)-xm(j)) - endif - else + IF(j <= 0) THEN ! snow wice_soisno(j) = min(wmass0(j), wice0(j)-xm(j)) - endif - endif - heatr = hm(j) - hfus*(wice0(j)-wice_soisno(j))/deltim - endif - - wliq_soisno(j) = max(0.,wmass0(j)-wice_soisno(j)) - - if(abs(heatr) > 0.)then - if(j > lb)then ! => not the top layer - IF (j==1 .and. DEF_SPLIT_SOILSNOW .and. patchtype<3) THEN - ! -> interface soil layer - t_soisno(j) = t_soisno(j) + fact(j)*heatr/(1.-fact(j)*(1.-fsno)*dhsdT) - ELSE ! -> internal layers other than the interface soil layer - t_soisno(j) = t_soisno(j) + fact(j)*heatr + ELSE + IF (DEF_USE_SUPERCOOL_WATER) THEN + IF(wmass0(j) < supercool(j)) THEN + wice_soisno(j) = 0. + ELSE + wice_soisno(j) = min(wmass0(j)-supercool(j), wice0(j)-xm(j)) + ENDIF + ELSE + wice_soisno(j) = min(wmass0(j), wice0(j)-xm(j)) + ENDIF ENDIF - else ! => top layer - IF (j==1 .or. (.not.DEF_SPLIT_SOILSNOW) .or. patchtype==3) THEN - ! -> soil layer - t_soisno(j) = t_soisno(j) + fact(j)*heatr/(1.-fact(j)*dhsdT) - ELSE ! -> snow cover - t_soisno(j) = t_soisno(j) + fact(j)*heatr/(1.-fact(j)*fsno*dhsdT) + heatr = hm(j) - hfus*(wice0(j)-wice_soisno(j))/deltim + ENDIF + + wliq_soisno(j) = max(0.,wmass0(j)-wice_soisno(j)) + + IF(abs(heatr) > 0.)THEN + IF(j > lb)THEN ! => not the top layer + IF (j==1 .and. DEF_SPLIT_SOILSNOW .and. patchtype<3) THEN + ! -> interface soil layer + t_soisno(j) = t_soisno(j) + fact(j)*heatr/(1.-fact(j)*(1.-fsno)*dhsdT) + ELSE ! -> internal layers other than the interface soil layer + t_soisno(j) = t_soisno(j) + fact(j)*heatr + ENDIF + ELSE ! => top layer + IF (j==1 .or. (.not.DEF_SPLIT_SOILSNOW) .or. patchtype==3) THEN + ! -> soil layer + t_soisno(j) = t_soisno(j) + fact(j)*heatr/(1.-fact(j)*dhsdT) + ELSE ! -> snow cover + t_soisno(j) = t_soisno(j) + fact(j)*heatr/(1.-fact(j)*fsno*dhsdT) + ENDIF ENDIF - endif - if (DEF_USE_SUPERCOOL_WATER) then - IF(j <= 0 .or. patchtype == 3)THEN !snow - if(wliq_soisno(j)*wice_soisno(j) > 0.) t_soisno(j) = tfrz + IF (DEF_USE_SUPERCOOL_WATER) THEN + IF(j <= 0 .or. patchtype == 3)THEN !snow + IF(wliq_soisno(j)*wice_soisno(j) > 0.) t_soisno(j) = tfrz + ENDIF + ELSE + IF(wliq_soisno(j)*wice_soisno(j) > 0.) t_soisno(j) = tfrz ENDIF - ELSE - if(wliq_soisno(j)*wice_soisno(j) > 0.) t_soisno(j) = tfrz - ENDIF - endif + ENDIF - xmf = xmf + hfus * (wice0(j)-wice_soisno(j))/deltim + xmf = xmf + hfus * (wice0(j)-wice_soisno(j))/deltim - if(imelt(j) == 1 .and. j < 1) & - sm = sm + max(0.,(wice0(j)-wice_soisno(j)))/deltim + IF(imelt(j) == 1 .and. j < 1) & + sm = sm + max(0.,(wice0(j)-wice_soisno(j)))/deltim - endif - enddo + ENDIF + ENDDO - !scvold=scv - if(lb<=0) then - we = sum(wice_soisno(lb:0)+wliq_soisno(lb:0))-we - if(abs(we)>1.e-6) then - print*, 'meltf err : ', we - endif - endif + !scvold=scv + IF(lb<=0) THEN + we = sum(wice_soisno(lb:0)+wliq_soisno(lb:0))-we + IF(abs(we)>1.e-6) THEN + print*, 'meltf err : ', we + ENDIF + ENDIF - end subroutine meltf_snicar + END SUBROUTINE meltf_snicar - subroutine meltf_urban (lb,nl_soil,deltim, & + SUBROUTINE meltf_urban (lb,nl_soil,deltim, & fact,brr,hs,dhsdT, & t_soisno_bef,t_soisno,wliq_soisno,wice_soisno,imelt, & scv,snowdp,sm,xmf) @@ -638,168 +638,168 @@ subroutine meltf_urban (lb,nl_soil,deltim, & ! !----------------------------------------------------------------------- - use MOD_Precision - use MOD_Const_Physical, only : tfrz, hfus - IMPLICIT NONE + USE MOD_Precision + USE MOD_Const_Physical, only : tfrz, hfus + IMPLICIT NONE !----------------------------------------------------------------------- - integer, INTENT(in) :: nl_soil ! upper bound of array (i.e., soil layers) - integer, INTENT(in) :: lb ! lower bound of array (i.e., snl +1) - real(r8), INTENT(in) :: deltim ! time step [second] - real(r8), INTENT(in) :: t_soisno_bef(lb:nl_soil) ! temperature at previous time step [K] - real(r8), INTENT(in) :: brr (lb:nl_soil) ! - real(r8), INTENT(in) :: fact(lb:nl_soil) ! temporary variables - real(r8), INTENT(in) :: hs ! net ground heat flux into the surface - real(r8), INTENT(in) :: dhsdT ! temperature derivative of "hs" - - real(r8), INTENT(inout) :: t_soisno (lb:nl_soil) ! temperature at current time step [K] - real(r8), INTENT(inout) :: wice_soisno(lb:nl_soil) ! ice lens [kg/m2] - real(r8), INTENT(inout) :: wliq_soisno(lb:nl_soil) ! liquid water [kg/m2] - real(r8), INTENT(inout) :: scv ! snow mass [kg/m2] - real(r8), INTENT(inout) :: snowdp ! snow depth [m] - - real(r8), INTENT(out) :: sm ! rate of snowmelt [mm/s, kg/(m2 s)] - real(r8), INTENT(out) :: xmf ! total latent heat of phase change - integer, INTENT(out) :: imelt(lb:nl_soil) ! flag for melting or freezing [-] + integer, intent(in) :: nl_soil ! upper bound of array (i.e., soil layers) + integer, intent(in) :: lb ! lower bound of array (i.e., snl +1) + real(r8), intent(in) :: deltim ! time step [second] + real(r8), intent(in) :: t_soisno_bef(lb:nl_soil) ! temperature at previous time step [K] + real(r8), intent(in) :: brr (lb:nl_soil) ! + real(r8), intent(in) :: fact(lb:nl_soil) ! temporary variables + real(r8), intent(in) :: hs ! net ground heat flux into the surface + real(r8), intent(in) :: dhsdT ! temperature derivative of "hs" + + real(r8), intent(inout) :: t_soisno (lb:nl_soil) ! temperature at current time step [K] + real(r8), intent(inout) :: wice_soisno(lb:nl_soil) ! ice lens [kg/m2] + real(r8), intent(inout) :: wliq_soisno(lb:nl_soil) ! liquid water [kg/m2] + real(r8), intent(inout) :: scv ! snow mass [kg/m2] + real(r8), intent(inout) :: snowdp ! snow depth [m] + + real(r8), intent(out) :: sm ! rate of snowmelt [mm/s, kg/(m2 s)] + real(r8), intent(out) :: xmf ! total latent heat of phase change + integer, intent(out) :: imelt(lb:nl_soil) ! flag for melting or freezing [-] ! Local - real(r8) :: hm(lb:nl_soil) ! energy residual [W/m2] - real(r8) :: xm(lb:nl_soil) ! metling or freezing within a time step [kg/m2] - real(r8) :: heatr ! energy residual or loss after melting or freezing - real(r8) :: temp1 ! temporary variables [kg/m2] - real(r8) :: temp2 ! temporary variables [kg/m2] + real(r8) :: hm(lb:nl_soil) ! energy residual [W/m2] + real(r8) :: xm(lb:nl_soil) ! metling or freezing within a time step [kg/m2] + real(r8) :: heatr ! energy residual or loss after melting or freezing + real(r8) :: temp1 ! temporary variables [kg/m2] + real(r8) :: temp2 ! temporary variables [kg/m2] - real(r8), dimension(lb:nl_soil) :: wmass0, wice0, wliq0 - real(r8) :: propor, tinc, we, scvold - integer j + real(r8), dimension(lb:nl_soil) :: wmass0, wice0, wliq0 + real(r8) :: propor, tinc, we, scvold + integer j !----------------------------------------------------------------------- - sm = 0. - xmf = 0. - do j = lb, nl_soil - imelt(j) = 0 - hm(j) = 0. - xm(j) = 0. - wice0(j) = wice_soisno(j) - wliq0(j) = wliq_soisno(j) - wmass0(j) = wice_soisno(j) + wliq_soisno(j) - enddo - - scvold=scv - we=0. - if(lb<=0) we = sum(wice_soisno(lb:0)+wliq_soisno(lb:0)) - - do j = lb, nl_soil - ! Melting identification - ! if ice exists above melt point, melt some to liquid. - if(wice_soisno(j) > 0. .and. t_soisno(j) > tfrz)then - imelt(j) = 1 - t_soisno(j) = tfrz - endif - - ! Freezing identification - ! if liquid exists below melt point, freeze some to ice. - if(wliq_soisno(j) > 0. .and. t_soisno(j) < tfrz) then - imelt(j) = 2 - t_soisno(j) = tfrz - endif - enddo + sm = 0. + xmf = 0. + DO j = lb, nl_soil + imelt(j) = 0 + hm(j) = 0. + xm(j) = 0. + wice0(j) = wice_soisno(j) + wliq0(j) = wliq_soisno(j) + wmass0(j) = wice_soisno(j) + wliq_soisno(j) + ENDDO + + scvold=scv + we=0. + IF(lb<=0) we = sum(wice_soisno(lb:0)+wliq_soisno(lb:0)) + + DO j = lb, nl_soil + ! Melting identification + ! IF ice exists above melt point, melt some to liquid. + IF(wice_soisno(j) > 0. .and. t_soisno(j) > tfrz)THEN + imelt(j) = 1 + t_soisno(j) = tfrz + ENDIF + + ! Freezing identification + ! IF liquid exists below melt point, freeze some to ice. + IF(wliq_soisno(j) > 0. .and. t_soisno(j) < tfrz) THEN + imelt(j) = 2 + t_soisno(j) = tfrz + ENDIF + ENDDO ! If snow exists, but its thickness less than the critical value (0.01 m) - if(lb == 1 .and. scv > 0.)then - if(t_soisno(1) > tfrz)then - imelt(1) = 1 - t_soisno(1) = tfrz - endif - endif + IF(lb == 1 .and. scv > 0.)THEN + IF(t_soisno(1) > tfrz)THEN + imelt(1) = 1 + t_soisno(1) = tfrz + ENDIF + ENDIF ! Calculate the energy surplus and loss for melting and freezing - do j = lb, nl_soil - if(imelt(j) > 0)then - tinc = t_soisno(j)-t_soisno_bef(j) - if(j > lb)then - hm(j) = brr(j) - tinc/fact(j) - else - hm(j) = hs + dhsdT*tinc + brr(j) - tinc/fact(j) - endif - endif - enddo - - do j = lb, nl_soil - if(imelt(j) == 1 .and. hm(j) < 0.) then - hm(j) = 0. - imelt(j) = 0 - endif + DO j = lb, nl_soil + IF(imelt(j) > 0)THEN + tinc = t_soisno(j)-t_soisno_bef(j) + IF(j > lb)THEN + hm(j) = brr(j) - tinc/fact(j) + ELSE + hm(j) = hs + dhsdT*tinc + brr(j) - tinc/fact(j) + ENDIF + ENDIF + ENDDO + + DO j = lb, nl_soil + IF(imelt(j) == 1 .and. hm(j) < 0.) THEN + hm(j) = 0. + imelt(j) = 0 + ENDIF ! this error was checked carefully, it results from the the computed error -! of "Tridiagonal-Matrix" in subroutine "thermal". - if(imelt(j) == 2 .and. hm(j) > 0.) then - hm(j) = 0. - imelt(j) = 0 - endif - enddo +! of "Tridiagonal-Matrix" in SUBROUTINE "thermal". + IF(imelt(j) == 2 .and. hm(j) > 0.) THEN + hm(j) = 0. + imelt(j) = 0 + ENDIF + ENDDO ! The rate of melting and freezing - do j = lb, nl_soil - if(imelt(j) > 0 .and. abs(hm(j)) > .0) then - xm(j) = hm(j)*deltim/hfus ! kg/m2 - - ! if snow exists, but its thickness less than the critical value (1 cm) - ! Note: more work is need on how to tune the snow depth at this case - if(j == 1 .and. lb == 1 .and. scv > 0. .and. xm(j) > 0.)then - temp1 = scv ! kg/m2 - scv = max(0.,temp1-xm(j)) - propor = scv/temp1 - snowdp = propor * snowdp - heatr = hm(j) - hfus*(temp1-scv)/deltim ! W/m2 - if(heatr > 0.) then - xm(j) = heatr*deltim/hfus ! kg/m2 - hm(j) = heatr ! W/m2 - else - xm(j) = 0. - hm(j) = 0. - endif - sm = max(0.,(temp1-scv))/deltim ! kg/(m2 s) - xmf = hfus*sm - endif - - heatr = 0. - if(xm(j) > 0.) then - wice_soisno(j) = max(0., wice0(j)-xm(j)) - heatr = hm(j) - hfus*(wice0(j)-wice_soisno(j))/deltim - else - wice_soisno(j) = min(wmass0(j), wice0(j)-xm(j)) - heatr = hm(j) - hfus*(wice0(j)-wice_soisno(j))/deltim - endif - - wliq_soisno(j) = max(0.,wmass0(j)-wice_soisno(j)) - - if(abs(heatr) > 0.)then - if(j > lb)then - t_soisno(j) = t_soisno(j) + fact(j)*heatr - else - t_soisno(j) = t_soisno(j) + fact(j)*heatr/(1.-fact(j)*dhsdT) - endif - if(wliq_soisno(j)*wice_soisno(j) > 0.) t_soisno(j) = tfrz - endif - - xmf = xmf + hfus * (wice0(j)-wice_soisno(j))/deltim - - if(imelt(j) == 1 .and. j < 1) & - sm = sm + max(0.,(wice0(j)-wice_soisno(j)))/deltim - - endif - enddo + DO j = lb, nl_soil + IF(imelt(j) > 0 .and. abs(hm(j)) > .0) THEN + xm(j) = hm(j)*deltim/hfus ! kg/m2 + + ! IF snow exists, but its thickness less than the critical value (1 cm) + ! Note: more work is need on how to tune the snow depth at this case + IF(j == 1 .and. lb == 1 .and. scv > 0. .and. xm(j) > 0.)THEN + temp1 = scv ! kg/m2 + scv = max(0.,temp1-xm(j)) + propor = scv/temp1 + snowdp = propor * snowdp + heatr = hm(j) - hfus*(temp1-scv)/deltim ! W/m2 + IF(heatr > 0.) THEN + xm(j) = heatr*deltim/hfus ! kg/m2 + hm(j) = heatr ! W/m2 + ELSE + xm(j) = 0. + hm(j) = 0. + ENDIF + sm = max(0.,(temp1-scv))/deltim ! kg/(m2 s) + xmf = hfus*sm + ENDIF + + heatr = 0. + IF(xm(j) > 0.) THEN + wice_soisno(j) = max(0., wice0(j)-xm(j)) + heatr = hm(j) - hfus*(wice0(j)-wice_soisno(j))/deltim + ELSE + wice_soisno(j) = min(wmass0(j), wice0(j)-xm(j)) + heatr = hm(j) - hfus*(wice0(j)-wice_soisno(j))/deltim + ENDIF + + wliq_soisno(j) = max(0.,wmass0(j)-wice_soisno(j)) + + IF(abs(heatr) > 0.)THEN + IF(j > lb)THEN + t_soisno(j) = t_soisno(j) + fact(j)*heatr + ELSE + t_soisno(j) = t_soisno(j) + fact(j)*heatr/(1.-fact(j)*dhsdT) + ENDIF + IF(wliq_soisno(j)*wice_soisno(j) > 0.) t_soisno(j) = tfrz + ENDIF + + xmf = xmf + hfus * (wice0(j)-wice_soisno(j))/deltim + + IF(imelt(j) == 1 .and. j < 1) & + sm = sm + max(0.,(wice0(j)-wice_soisno(j)))/deltim + + ENDIF + ENDDO !scvold=scv - if(lb<=0) then - we = sum(wice_soisno(lb:0)+wliq_soisno(lb:0))-we - if(abs(we)>1.e-6) then - print*, 'meltf err : ', we - endif - endif - - end subroutine meltf_urban + IF(lb<=0) THEN + we = sum(wice_soisno(lb:0)+wliq_soisno(lb:0))-we + IF(abs(we)>1.e-6) THEN + print*, 'meltf err : ', we + ENDIF + ENDIF + + END SUBROUTINE meltf_urban END MODULE MOD_PhaseChange diff --git a/main/MOD_PlantHydraulic.F90 b/main/MOD_PlantHydraulic.F90 index b4fa559e..3bc4b58f 100644 --- a/main/MOD_PlantHydraulic.F90 +++ b/main/MOD_PlantHydraulic.F90 @@ -2,29 +2,29 @@ MODULE MOD_PlantHydraulic !----------------------------------------------------------------------- - use MOD_Precision - use MOD_Namelist, only: DEF_RSS_SCHEME - use MOD_SPMD_Task - IMPLICIT NONE - SAVE + USE MOD_Precision + USE MOD_Namelist, only: DEF_RSS_SCHEME + USE MOD_SPMD_Task + IMPLICIT NONE + SAVE ! PUBLIC MEMBER FUNCTIONS: - public :: PlantHydraulicStress_twoleaf - public :: getvegwp_twoleaf + PUBLIC :: PlantHydraulicStress_twoleaf + PUBLIC :: getvegwp_twoleaf ! PRIVATE MEMBER FUNCTIONS: - private :: calcstress_twoleaf + PRIVATE :: calcstress_twoleaf !----------------------------------------------------------------------- - CONTAINS +CONTAINS !----------------------------------------------------------------------- - subroutine PlantHydraulicStress_twoleaf (nl_soil ,nvegwcs ,z_soi ,& + SUBROUTINE PlantHydraulicStress_twoleaf (nl_soil ,nvegwcs ,z_soi ,& dz_soi ,rootfr ,psrf ,qsatl ,& qaf ,tl ,rb ,rss, & ra ,rd ,rstfacsun ,rstfacsha ,cintsun ,& @@ -38,33 +38,33 @@ subroutine PlantHydraulicStress_twoleaf (nl_soil ,nvegwcs ,z_soi ,& !======================================================================= ! -! calculation of plant hydraulic stress +! calculation of plant hydraulic stress ! -! Author: Xingjie Lu, 16/01/2019, modified from CLM5 plant_hydraulic_stress module +! Author: Xingjie Lu, 16/01/2019, modified from CLM5 plant_hydraulic_stress module ! !---------------------------------------------------------------------- - use MOD_Precision - IMPLICIT NONE + USE MOD_Precision + IMPLICIT NONE - integer ,intent(in) :: nl_soil ! upper bound of array - integer ,intent(in) :: nvegwcs ! upper bound of array - real(r8),intent(in), dimension(nl_soil) :: & + integer ,intent(in) :: nl_soil ! upper bound of array + integer ,intent(in) :: nvegwcs ! upper bound of array + real(r8),intent(in), dimension(nl_soil) :: & z_soi, &! soil node depth (m) dz_soi ! soil layer thicknesses (m) - real(r8),intent(inout), dimension(nvegwcs) :: & - vegwp ! vegetation water potential - real(r8),intent(inout):: & + real(r8),intent(inout), dimension(nvegwcs) :: & + vegwp ! vegetation water potential + real(r8),intent(inout):: & gs0sun, & ! maximum stomata conductance of sunlit leaf gs0sha ! maximum stomata conductance of shaded leaf - real(r8),intent(in) :: & + real(r8),intent(in) :: & rss, &! soil surface resistance [s/m] psrf, & ! surface atmospheric pressure (pa) qg, &! specific humidity at ground surface [kg/kg] qm ! specific humidity at reference height [kg/kg] - real(r8),intent(in) :: & + real(r8),intent(in) :: & qsatl, &! leaf specific humidity [kg/kg] qaf, &! humidity of canopy air [kg/kg] tl, &! leaf temperature (K) @@ -73,11 +73,11 @@ subroutine PlantHydraulicStress_twoleaf (nl_soil ,nvegwcs ,z_soi ,& rd, &! aerodynamical resistance between ground and canopy air ra ! aerodynamic resistance from cas to refence height (s m-1) - real(r8),intent(inout) :: & + real(r8),intent(inout) :: & rstfacsun, &! canopy resistance stress factors to soil moisture for sunlit leaf rstfacsha ! canopy resistance stress factors to soil moisture for shaded leaf - real(r8),intent(in) :: & + real(r8),intent(in) :: & laisun, &! sunlit leaf area index, one-sided laisha, &! shaded leaf area index, one-sided sai, &! stem area index @@ -94,76 +94,76 @@ subroutine PlantHydraulicStress_twoleaf (nl_soil ,nvegwcs ,z_soi ,& rhoair, &! density [kg/m**3] fwet ! fraction of foliage that is wet [-] - real(r8),intent(in), dimension(3) :: & + real(r8),intent(in), dimension(3) :: & cintsun, &! scaling up from sunlit leaf to canopy cintsha ! scaling up from shaded leaf to canopy - real(r8),intent(in), dimension(nl_soil) :: & + real(r8),intent(in), dimension(nl_soil) :: & smp, & ! precipitation sensible heat from canopy rootfr, & ! root fraction hksati, & ! hydraulic conductivity at saturation [mm h2o/s] hk ! soil hydraulic conducatance [mm h2o/s] - real(r8),intent(out) :: &! ATTENTION : all for canopy not leaf + real(r8),intent(out) :: &! ATTENTION : all for canopy not leaf etrsun, &! transpiration from sunlit leaf (mm/s) etrsha ! transpiration from shaded leaf (mm/s) - real(r8),intent(out),dimension(nl_soil) :: & + real(r8),intent(out),dimension(nl_soil) :: & rootflux ! root water uptake from different layers - real(r8),intent(inout),dimension(nl_soil) :: k_soil_root ! radial root and soil conductance - real(r8),intent(inout),dimension(nl_soil) :: k_ax_root ! axial root conductance - real(r8),intent(inout) :: gssun ! sunlit leaf conductance - real(r8),intent(inout) :: gssha ! shaded leaf conductance + real(r8),intent(inout),dimension(nl_soil) :: k_soil_root ! radial root and soil conductance + real(r8),intent(inout),dimension(nl_soil) :: k_ax_root ! axial root conductance + real(r8),intent(inout) :: gssun ! sunlit leaf conductance + real(r8),intent(inout) :: gssha ! shaded leaf conductance !-------------------- local -------------------------------------------- - integer, parameter :: iterationtotal = 6 + integer, parameter :: iterationtotal = 6 - real(r8) c3, &! c3 vegetation : 1; 0 for c4 + real(r8) c3, &! c3 vegetation : 1; 0 for c4 - tprcor, &! coefficient for unit transfer - gb_mol ! one side leaf boundary layer conductance of sunlit leaf (leaf scale:umol H2O m-2 s-1) + tprcor, &! coefficient for unit transfer + gb_mol ! one side leaf boundary layer conductance of sunlit leaf (leaf scale:umol H2O m-2 s-1) - real(r8), dimension(nl_soil) :: & + real(r8), dimension(nl_soil) :: & fs !root conductance scale factor (reduction in conductance due to decreasing (more negative) root water potential) - real(r8), dimension(nl_soil) :: & + real(r8), dimension(nl_soil) :: & rai ! soil-root interface conductance [mm/s] - real(r8) :: soilflux ! soil-root interface conductance [mm/s] - real(r8) :: soil_conductance ! soil conductance - real(r8) :: root_conductance ! root conductance - real(r8) :: r_soil ! root spacing [m] - real(r8) :: root_biomass_density ! root biomass density [g/m3] - real(r8) :: root_cross_sec_area ! root cross sectional area [m2] - real(r8) :: root_length_density ! root length density [m/m3] - real(r8) :: croot_average_length ! average coarse root length [m] - real(r8) :: rs_resis ! combined soil-root resistance [s] - real(r8) :: cf ! s m**2/umol -> s/m - - real(r8), parameter :: croot_lateral_length = 0.25_r8 ! specified lateral coarse root length [m] - real(r8), parameter :: c_to_b = 2.0_r8 !(g biomass /g C) - real(r8), parameter :: rpi = 3.14159265358979_r8 - integer , parameter :: root = 4 - real(r8), parameter :: toldb = 1.e-2_r8 ! tolerance for satisfactory bsun/bsha solution - real(r8), parameter :: K_axs = 2.0e-1 + real(r8) :: soilflux ! soil-root interface conductance [mm/s] + real(r8) :: soil_conductance ! soil conductance + real(r8) :: root_conductance ! root conductance + real(r8) :: r_soil ! root spacing [m] + real(r8) :: root_biomass_density ! root biomass density [g/m3] + real(r8) :: root_cross_sec_area ! root cross sectional area [m2] + real(r8) :: root_length_density ! root length density [m/m3] + real(r8) :: croot_average_length ! average coarse root length [m] + real(r8) :: rs_resis ! combined soil-root resistance [s] + real(r8) :: cf ! s m**2/umol -> s/m + + real(r8), parameter :: croot_lateral_length = 0.25_r8 ! specified lateral coarse root length [m] + real(r8), parameter :: c_to_b = 2.0_r8 !(g biomass /g C) + real(r8), parameter :: rpi = 3.14159265358979_r8 + integer , parameter :: root = 4 + real(r8), parameter :: toldb = 1.e-2_r8 ! tolerance for satisfactory bsun/bsha solution + real(r8), parameter :: K_axs = 2.0e-1 ! temporary input - real(r8), parameter :: froot_carbon = 288.392056287006_r8 - real(r8), parameter :: root_radius = 2.9e-4_r8 - real(r8), parameter :: root_density = 310000._r8 - real(r8), parameter :: froot_leaf = 1.5_r8 - real(r8), parameter :: krmax = 3.981071705534969e-009_r8 + real(r8), parameter :: froot_carbon = 288.392056287006_r8 + real(r8), parameter :: root_radius = 2.9e-4_r8 + real(r8), parameter :: root_density = 310000._r8 + real(r8), parameter :: froot_leaf = 1.5_r8 + real(r8), parameter :: krmax = 3.981071705534969e-009_r8 - real(r8),dimension(nvegwcs) :: x ! vegetation water potential + real(r8),dimension(nvegwcs) :: x ! vegetation water potential - integer j + integer j !----------------calculate root-soil interface conductance----------------- - do j = 1,nl_soil + DO j = 1,nl_soil ! calculate conversion from conductivity to conductance root_biomass_density = c_to_b * froot_carbon * rootfr(j) / dz_soi(j) @@ -186,7 +186,7 @@ subroutine PlantHydraulicStress_twoleaf (nl_soil ,nvegwcs ,z_soi ,& ! length scale approach soil_conductance = min(hksati(j),hk(j))/(1.e3*r_soil) - ! use vegetation plc function to adjust root conductance + ! USE vegetation plc function to adjust root conductance fs(j)= plc(amax1(smp(j),-1._r8),psi50_root,ck) ! krmax is root conductance per area per length @@ -199,13 +199,13 @@ subroutine PlantHydraulicStress_twoleaf (nl_soil ,nvegwcs ,z_soi ,& ! conductance is inverse resistance ! explicitly set conductance to zero for top soil layer - if(rai(j)*rootfr(j) > 0._r8) then + IF(rai(j)*rootfr(j) > 0._r8) THEN k_soil_root(j) = 1._r8/rs_resis - else + ELSE k_soil_root(j) = 0. - end if + ENDIF k_ax_root(j) = (rootfr(j)/(dz_soi(j)*1000))*K_axs*0.6 - end do + ENDDO !======================================================================= tprcor = 44.6*273.16*psrf/1.013e5 @@ -218,7 +218,7 @@ subroutine PlantHydraulicStress_twoleaf (nl_soil ,nvegwcs ,z_soi ,& x = vegwp(1:nvegwcs) - call calcstress_twoleaf(x, nvegwcs, rstfacsun, rstfacsha, etrsun, etrsha, rootflux,& + CALL calcstress_twoleaf(x, nvegwcs, rstfacsun, rstfacsha, etrsun, etrsha, rootflux,& gb_mol, gs0sun, gs0sha, qsatl, qaf, qg, qm, rhoair, & psrf, fwet, laisun, laisha, sai, htop, tl, kmax_sun, & kmax_sha, kmax_xyl, kmax_root, psi50_sun, psi50_sha, psi50_xyl, psi50_root, ck, & @@ -226,867 +226,868 @@ subroutine PlantHydraulicStress_twoleaf (nl_soil ,nvegwcs ,z_soi ,& vegwp(1:nvegwcs) = x - end subroutine PlantHydraulicStress_twoleaf - - subroutine calcstress_twoleaf(x,nvegwcs,rstfacsun, rstfacsha, etrsun, etrsha, rootflux,& - gb_mol, gs0sun, gs0sha, qsatl, qaf, qg, qm,rhoair,& - psrf, fwet, laisun, laisha, sai, htop, tl, kmax_sun, kmax_sha, kmax_xyl, kmax_root, & - psi50_sun, psi50_sha, psi50_xyl, psi50_root, ck, nl_soil, z_soi, rss, raw, rd, smp, & - k_soil_root, k_ax_root, gssun, gssha) - ! - ! DESCRIPTIONS - ! compute the transpiration stress using a plant hydraulics approach - ! calls spacF, spacA, and getvegwp - ! - ! !ARGUMENTS: - integer , intent(in) :: nvegwcs - real(r8) , intent(inout) :: x(nvegwcs) ! working copy of vegwp(p,:) - real(r8) , intent(out) :: rstfacsun ! sunlit canopy transpiration wetness factor (0 to 1) - real(r8) , intent(out) :: rstfacsha ! shaded sunlit canopy transpiration wetness factor (0 to 1) - real(r8) , intent(out) :: etrsun ! transpiration from sunlit leaf (mm/s) - real(r8) , intent(out) :: etrsha ! transpiration from shaded leaf (mm/s) - real(r8) , intent(out) :: rootflux(nl_soil) ! root water uptake from different layers - integer , intent(in) :: nl_soil - real(r8) , intent(in) :: z_soi(nl_soil) - real(r8) , intent(in) :: gb_mol ! leaf boundary layer conductance (umol H2O/m**2/s) - real(r8) , intent(in) :: gs0sun ! sunlit Ball-Berry minimum leaf conductance (umol H2O/m**2/s) - real(r8) , intent(in) :: gs0sha ! shaded Ball-Berry minimum leaf conductance (umol H2O/m**2/s) - real(r8) , intent(in) :: qsatl ! leaf specific humidity [kg/kg] - real(r8) , intent(in) :: qaf ! humidity of canopy air [kg/kg] - real(r8) , intent(in) :: qg ! specific humidity at ground surface [kg/kg] - real(r8) , intent(in) :: qm ! specific humidity at reference height [kg/kg] - real(r8) , intent(in) :: rhoair ! density [kg/m**3] - real(r8) , intent(in) :: psrf ! atmospheric pressure [Pa] - real(r8) , intent(in) :: fwet ! fraction of foliage that is green and dry [-] - real(r8) , intent(in) :: rss ! soil surface resistance [s/m] - real(r8) , intent(in) :: raw ! moisture resistance [s/m] - real(r8) , intent(in) :: rd ! aerodynamical resistance between ground and canopy air - real(r8) , intent(in) :: laisun ! Sunlit leaf area index - real(r8) , intent(in) :: laisha ! Shaded leaf area index - real(r8) , intent(in) :: sai ! stem area index - real(r8) , intent(in) :: htop ! canopy top [m] - real(r8) , intent(in) :: tl ! leaf temperature - real(r8) , intent(in) :: kmax_sun - real(r8) , intent(in) :: kmax_sha - real(r8) , intent(in) :: kmax_xyl - real(r8) , intent(in) :: kmax_root - real(r8) , intent(in) :: psi50_sun ! water potential at 50% loss of sunlit leaf tissue conductance (mmH2O) - real(r8) , intent(in) :: psi50_sha ! water potential at 50% loss of shaded leaf tissue conductance (mmH2O) - real(r8) , intent(in) :: psi50_xyl ! water potential at 50% loss of xylem tissue conductance (mmH2O) - real(r8) , intent(in) :: psi50_root ! water potential at 50% loss of root tissue conductance (mmH2O) - real(r8) , intent(in) :: ck ! - real(r8) , intent(in) :: smp(nl_soil) ! soil matrix potential - real(r8) , intent(in) :: k_soil_root(nl_soil) ! soil-root interface conductance [mm/s] - real(r8) , intent(in) :: k_ax_root(nl_soil) ! root axial-direction conductance [mm/s] - real(r8) , intent(out) :: gssun ! sunlit leaf conductance - real(r8) , intent(out) :: gssha ! shaded leaf conductance - - - real(r8) :: wtl ! water conductance for leaf [m/s] - real(r8) :: A(nvegwcs,nvegwcs) ! matrix relating d(vegwp) and f: d(vegwp)=A*f - real(r8) :: f(nvegwcs) ! flux divergence (mm/s) - real(r8) :: dx(nvegwcs) ! change in vegwp from one iter to the next [mm] - real(r8) :: qflx_sun ! [kg/m2/s] - real(r8) :: qflx_sha ! [kg/m2/s] - real(r8) :: qeroot,dqeroot - real(r8),dimension(nl_soil) :: xroot ! local gs_mol copies - integer :: i,j ! index - real(r8) :: cf ! s m**2/umol -> s/m - integer :: iter,iterqflx ! newton's method iteration number - logical :: flag ! signal that matrix was not invertible - logical :: night ! signal to store vegwp within this routine, b/c it is night-time and full suite won't be called - integer, parameter :: itmax=50 ! exit newton's method if iters>itmax - real(r8),parameter :: toldx=1.e-9 !tolerances for a satisfactory solution - real(r8),parameter :: tolf = 1.e-6_r8 - real(r8),parameter :: tolf_leafxyl = 1.e-16_r8 - real(r8),parameter :: tolf_root = 1.e-14_r8 !tolerances for a satisfactory solution - logical :: havegs ! signals direction of calculation gs->qflx or qflx->gs - logical :: haroot ! signals direction of calculation x_root_top->qeroot or qeroot->x_root_top - real(r8) :: soilflux ! total soil column transpiration [mm/s] - real(r8) :: x_root_top - real(r8) :: x_root_top1 - real(r8) :: x_root_top2 - real(r8) :: dxsoiltop - real(r8) :: maxscale - real(r8), parameter :: tol_lai=1.e-7_r8 ! minimum lai where transpiration is calc'd - integer, parameter :: leafsun=1 - integer, parameter :: leafsha=2 - integer, parameter :: xyl=3 - integer, parameter :: root=4 - real(r8) fsto1,fsto2,fx,fr,grav1 - real(r8) tprcor - !------------------------------------------------------------------------------ - - !temporary flag for night time vegwp(sun)>0 - - gssun=gs0sun - gssha=gs0sha - call getqflx_gs2qflx_twoleaf(gb_mol,gssun,gssha,qflx_sun,qflx_sha,qsatl,qaf, & - rhoair,psrf,laisun,laisha,sai,fwet,tl,rss,raw,rd,qg,qm) - x_root_top = x(root) - - if(qflx_sun .gt. 0 .or. qflx_sha .gt. 0)then - call getrootqflx_x2qe(nl_soil,smp,x_root_top ,z_soi,k_soil_root,k_ax_root,qeroot,dqeroot) - - call spacAF_twoleaf(x,nvegwcs,dx,nl_soil,qflx_sun,qflx_sha,laisun,laisha,sai,htop,& - qeroot,dqeroot,kmax_sun,kmax_sha,kmax_xyl,kmax_root,& - psi50_sun,psi50_sha,psi50_xyl,psi50_root,ck) - - if ( maxval(abs(dx)) > 200000._r8) then - maxscale = min(maxval(abs(dx)),maxval(abs(x))) / 2 - dx = maxscale * dx / maxval(abs(dx))! * log(maxval(abs(dx))/maxscale) !rescale step to max of 50000 - end if - - x=x+dx - - ! this is a catch to force spac gradient to atmosphere - if ( x(xyl) > x(root) ) x(xyl) = x(root) - if ( x(leafsun) > x(xyl) ) x(leafsun) = x(xyl) - if ( x(leafsha) > x(xyl) ) x(leafsha) = x(xyl) - - ! compute attenuated flux; the actual transpiration - etrsun=qflx_sun*plc(x(leafsun),psi50_sun,ck) - etrsha=qflx_sha*plc(x(leafsha),psi50_sha,ck) - - ! retrieve stressed stomatal conductance - call getqflx_qflx2gs_twoleaf(gb_mol,gssun,gssha,etrsun,etrsha,qsatl,qaf, & - rhoair,psrf,laisun,laisha,sai,fwet,tl,rss,raw,rd,qg,qm) - - tprcor = 44.6*273.16*psrf/1.013e5 - ! compute water stress - ! .. generally -> B= gs_stressed / gs_unstressed - ! .. when gs=0 -> B= plc( x ) - rstfacsun = amax1(gssun/gs0sun,1.e-2_r8) - rstfacsha = amax1(gssha/gs0sha,1.e-2_r8) - qeroot = etrsun + etrsha - call getrootqflx_qe2x(nl_soil,smp,z_soi,k_soil_root,k_ax_root,qeroot,xroot,x_root_top) - x(root) = x_root_top - do j = 1,nl_soil - rootflux(j) = k_soil_root(j)*(smp(j)-xroot(j)) - enddo - else - if ( x(xyl) > x(root) ) x(xyl) = x(root) - if ( x(leafsun) > x(xyl) ) x(leafsun) = x(xyl) - if ( x(leafsha) > x(xyl) ) x(leafsha) = x(xyl) - etrsun = 0._r8 - etrsha = 0._r8 - rstfacsun = amax1(plc(x(leafsun),psi50_sun,ck),1.e-2_r8) - rstfacsha = amax1(plc(x(leafsha),psi50_sha,ck),1.e-2_r8) - gssun = gs0sun * rstfacsun - gssha = gs0sha * rstfacsha - rootflux = 0._r8 - end if - - soilflux = sum(rootflux(:)) - - end subroutine calcstress_twoleaf - - !------------------------------------------------------------------------------ - subroutine spacAF_twoleaf(x,nvegwcs,dx,nl_soil,qflx_sun,qflx_sha,laisun,laisha,sai,htop,& + END SUBROUTINE PlantHydraulicStress_twoleaf + + SUBROUTINE calcstress_twoleaf(x,nvegwcs,rstfacsun, rstfacsha, etrsun, etrsha, rootflux,& + gb_mol, gs0sun, gs0sha, qsatl, qaf, qg, qm,rhoair,& + psrf, fwet, laisun, laisha, sai, htop, tl, kmax_sun, kmax_sha, kmax_xyl, kmax_root, & + psi50_sun, psi50_sha, psi50_xyl, psi50_root, ck, nl_soil, z_soi, rss, raw, rd, smp, & + k_soil_root, k_ax_root, gssun, gssha) + ! + ! DESCRIPTIONS + ! compute the transpiration stress using a plant hydraulics approach + ! calls spacF, spacA, and getvegwp + ! + ! !ARGUMENTS: + integer , intent(in) :: nvegwcs + real(r8) , intent(inout) :: x(nvegwcs) ! working copy of vegwp(p,:) + real(r8) , intent(out) :: rstfacsun ! sunlit canopy transpiration wetness factor (0 to 1) + real(r8) , intent(out) :: rstfacsha ! shaded sunlit canopy transpiration wetness factor (0 to 1) + real(r8) , intent(out) :: etrsun ! transpiration from sunlit leaf (mm/s) + real(r8) , intent(out) :: etrsha ! transpiration from shaded leaf (mm/s) + real(r8) , intent(out) :: rootflux(nl_soil) ! root water uptake from different layers + integer , intent(in) :: nl_soil + real(r8) , intent(in) :: z_soi(nl_soil) + real(r8) , intent(in) :: gb_mol ! leaf boundary layer conductance (umol H2O/m**2/s) + real(r8) , intent(in) :: gs0sun ! sunlit Ball-Berry minimum leaf conductance (umol H2O/m**2/s) + real(r8) , intent(in) :: gs0sha ! shaded Ball-Berry minimum leaf conductance (umol H2O/m**2/s) + real(r8) , intent(in) :: qsatl ! leaf specific humidity [kg/kg] + real(r8) , intent(in) :: qaf ! humidity of canopy air [kg/kg] + real(r8) , intent(in) :: qg ! specific humidity at ground surface [kg/kg] + real(r8) , intent(in) :: qm ! specific humidity at reference height [kg/kg] + real(r8) , intent(in) :: rhoair ! density [kg/m**3] + real(r8) , intent(in) :: psrf ! atmospheric pressure [Pa] + real(r8) , intent(in) :: fwet ! fraction of foliage that is green and dry [-] + real(r8) , intent(in) :: rss ! soil surface resistance [s/m] + real(r8) , intent(in) :: raw ! moisture resistance [s/m] + real(r8) , intent(in) :: rd ! aerodynamical resistance between ground and canopy air + real(r8) , intent(in) :: laisun ! Sunlit leaf area index + real(r8) , intent(in) :: laisha ! Shaded leaf area index + real(r8) , intent(in) :: sai ! stem area index + real(r8) , intent(in) :: htop ! canopy top [m] + real(r8) , intent(in) :: tl ! leaf temperature + real(r8) , intent(in) :: kmax_sun + real(r8) , intent(in) :: kmax_sha + real(r8) , intent(in) :: kmax_xyl + real(r8) , intent(in) :: kmax_root + real(r8) , intent(in) :: psi50_sun ! water potential at 50% loss of sunlit leaf tissue conductance (mmH2O) + real(r8) , intent(in) :: psi50_sha ! water potential at 50% loss of shaded leaf tissue conductance (mmH2O) + real(r8) , intent(in) :: psi50_xyl ! water potential at 50% loss of xylem tissue conductance (mmH2O) + real(r8) , intent(in) :: psi50_root ! water potential at 50% loss of root tissue conductance (mmH2O) + real(r8) , intent(in) :: ck ! + real(r8) , intent(in) :: smp(nl_soil) ! soil matrix potential + real(r8) , intent(in) :: k_soil_root(nl_soil) ! soil-root interface conductance [mm/s] + real(r8) , intent(in) :: k_ax_root(nl_soil) ! root axial-direction conductance [mm/s] + real(r8) , intent(out) :: gssun ! sunlit leaf conductance + real(r8) , intent(out) :: gssha ! shaded leaf conductance + + + real(r8) :: wtl ! water conductance for leaf [m/s] + real(r8) :: A(nvegwcs,nvegwcs) ! matrix relating d(vegwp) and f: d(vegwp)=A*f + real(r8) :: f(nvegwcs) ! flux divergence (mm/s) + real(r8) :: dx(nvegwcs) ! change in vegwp from one iter to the next [mm] + real(r8) :: qflx_sun ! [kg/m2/s] + real(r8) :: qflx_sha ! [kg/m2/s] + real(r8) :: qeroot,dqeroot + real(r8),dimension(nl_soil) :: xroot ! local gs_mol copies + integer :: i,j ! index + real(r8) :: cf ! s m**2/umol -> s/m + integer :: iter,iterqflx ! newton's method iteration number + logical :: flag ! signal that matrix was not invertible + logical :: night ! signal to store vegwp within this routine, b/c it is night-time and full suite won't be called + integer, parameter :: itmax=50 ! EXIT newton's method IF iters>itmax + real(r8),parameter :: toldx=1.e-9 !tolerances for a satisfactory solution + real(r8),parameter :: tolf = 1.e-6_r8 + real(r8),parameter :: tolf_leafxyl = 1.e-16_r8 + real(r8),parameter :: tolf_root = 1.e-14_r8 !tolerances for a satisfactory solution + logical :: havegs ! signals direction of calculation gs->qflx or qflx->gs + logical :: haroot ! signals direction of calculation x_root_top->qeroot or qeroot->x_root_top + real(r8) :: soilflux ! total soil column transpiration [mm/s] + real(r8) :: x_root_top + real(r8) :: x_root_top1 + real(r8) :: x_root_top2 + real(r8) :: dxsoiltop + real(r8) :: maxscale + real(r8), parameter :: tol_lai=1.e-7_r8 ! minimum lai WHERE transpiration is calc'd + integer, parameter :: leafsun=1 + integer, parameter :: leafsha=2 + integer, parameter :: xyl=3 + integer, parameter :: root=4 + real(r8) fsto1,fsto2,fx,fr,grav1 + real(r8) tprcor + !------------------------------------------------------------------------------ + + !temporary flag for night time vegwp(sun)>0 + + gssun=gs0sun + gssha=gs0sha + CALL getqflx_gs2qflx_twoleaf(gb_mol,gssun,gssha,qflx_sun,qflx_sha,qsatl,qaf, & + rhoair,psrf,laisun,laisha,sai,fwet,tl,rss,raw,rd,qg,qm) + x_root_top = x(root) + + IF(qflx_sun .gt. 0 .or. qflx_sha .gt. 0)THEN + CALL getrootqflx_x2qe(nl_soil,smp,x_root_top ,z_soi,k_soil_root,k_ax_root,qeroot,dqeroot) + + CALL spacAF_twoleaf(x,nvegwcs,dx,nl_soil,qflx_sun,qflx_sha,laisun,laisha,sai,htop,& + qeroot,dqeroot,kmax_sun,kmax_sha,kmax_xyl,kmax_root,& + psi50_sun,psi50_sha,psi50_xyl,psi50_root,ck) + + IF ( maxval(abs(dx)) > 200000._r8) THEN + maxscale = min(maxval(abs(dx)),maxval(abs(x))) / 2 + dx = maxscale * dx / maxval(abs(dx))! * log(maxval(abs(dx))/maxscale) !rescale step to max of 50000 + ENDIF + + x=x+dx + + ! this is a catch to force spac gradient to atmosphere + IF ( x(xyl) > x(root) ) x(xyl) = x(root) + IF ( x(leafsun) > x(xyl) ) x(leafsun) = x(xyl) + IF ( x(leafsha) > x(xyl) ) x(leafsha) = x(xyl) + + ! compute attenuated flux; the actual transpiration + etrsun=qflx_sun*plc(x(leafsun),psi50_sun,ck) + etrsha=qflx_sha*plc(x(leafsha),psi50_sha,ck) + + ! retrieve stressed stomatal conductance + CALL getqflx_qflx2gs_twoleaf(gb_mol,gssun,gssha,etrsun,etrsha,qsatl,qaf, & + rhoair,psrf,laisun,laisha,sai,fwet,tl,rss,raw,rd,qg,qm) + + tprcor = 44.6*273.16*psrf/1.013e5 + ! compute water stress + ! .. generally -> B= gs_stressed / gs_unstressed + ! .. when gs=0 -> B= plc( x ) + rstfacsun = amax1(gssun/gs0sun,1.e-2_r8) + rstfacsha = amax1(gssha/gs0sha,1.e-2_r8) + qeroot = etrsun + etrsha + CALL getrootqflx_qe2x(nl_soil,smp,z_soi,k_soil_root,k_ax_root,qeroot,xroot,x_root_top) + x(root) = x_root_top + DO j = 1,nl_soil + rootflux(j) = k_soil_root(j)*(smp(j)-xroot(j)) + ENDDO + ELSE + IF ( x(xyl) > x(root) ) x(xyl) = x(root) + IF ( x(leafsun) > x(xyl) ) x(leafsun) = x(xyl) + IF ( x(leafsha) > x(xyl) ) x(leafsha) = x(xyl) + etrsun = 0._r8 + etrsha = 0._r8 + rstfacsun = amax1(plc(x(leafsun),psi50_sun,ck),1.e-2_r8) + rstfacsha = amax1(plc(x(leafsha),psi50_sha,ck),1.e-2_r8) + gssun = gs0sun * rstfacsun + gssha = gs0sha * rstfacsha + rootflux = 0._r8 + ENDIF + + soilflux = sum(rootflux(:)) + + END SUBROUTINE calcstress_twoleaf + + !------------------------------------------------------------------------------ + SUBROUTINE spacAF_twoleaf(x,nvegwcs,dx,nl_soil,qflx_sun,qflx_sha,laisun,laisha,sai,htop,& qeroot,dqeroot,kmax_sun,kmax_sha,kmax_xyl,kmax_root,& psi50_sun,psi50_sha,psi50_xyl,psi50_root,ck) - ! - ! DESCRIPTION - ! Returns invA, the inverse matrix relating delta(vegwp) to f - ! d(vegwp)=invA*f - ! evaluated at vegwp(p) - ! - ! The methodology is currently hardcoded for linear algebra assuming the - ! number of vegetation segments is four. Thus the matrix A and it's inverse - ! invA are both 4x4 matrices. A more general method could be done using for - ! example a LINPACK linear algebra solver. - ! - ! !ARGUMENTS: - integer , intent(in) :: nvegwcs - real(r8) , intent(in) :: x(nvegwcs) ! working copy of veg water potential for patch p [mm H2O] - real(r8) , intent(out) :: dx(nvegwcs) ! matrix relating d(vegwp) and f: d(vegwp)=invA*f - integer , intent(in) :: nl_soil - real(r8) , intent(in) :: qflx_sun ! Sunlit leaf transpiration [kg/m2/s] - real(r8) , intent(in) :: qflx_sha ! Shaded leaf transpiration [kg/m2/s] - real(r8) , intent(in) :: laisun ! Sunlit leaf area index - real(r8) , intent(in) :: laisha ! Shaded leaf area index - real(r8) , intent(in) :: sai ! Stem area index - real(r8) , intent(in) :: htop ! Canopy top [m] - real(r8) , intent(in) :: qeroot ! soil-root interface conductance [mm/s] - real(r8) , intent(in) :: dqeroot ! soil-root interface conductance [mm/s] - real(r8) , intent(in) :: kmax_sun - real(r8) , intent(in) :: kmax_sha - real(r8) , intent(in) :: kmax_xyl - real(r8) , intent(in) :: kmax_root - real(r8) , intent(in) :: psi50_sun ! water potential at 50% loss of sunlit leaf tissue conductance (mmH2O) - real(r8) , intent(in) :: psi50_sha ! water potential at 50% loss of shaded leaf tissue conductance (mmH2O) - real(r8) , intent(in) :: psi50_xyl ! water potential at 50% loss of xylem tissue conductance (mmH2O) - real(r8) , intent(in) :: psi50_root ! water potential at 50% loss of root tissue conductance (mmH2O) - real(r8) , intent(in) :: ck - ! - ! !LOCAL VARIABLES: - real(r8) :: wtl ! heat conductance for leaf [m/s] - real(r8) :: fsto1 ! sunlit transpiration reduction function [-] - real(r8) :: fsto2 ! shaded transpiration reduction function [-] - real(r8) :: fx ! fraction of maximum conductance, xylem-to-leaf [-] - real(r8) :: fr ! fraction of maximum conductance, root-to-xylem [-] - real(r8) :: dfsto1 ! 1st derivative of fsto1 w.r.t. change in vegwp - real(r8) :: dfsto2 ! 1st derivative of fsto2 w.r.t. change in vegwp - real(r8) :: dfx ! 1st derivative of fx w.r.t. change in vegwp - real(r8) :: dfr ! 1st derivative of fr w.r.t. change in vegwp - real(r8) :: A11, A13, A22, A23, A31, A32, A33, A34, A43, A44 ! matrix relating vegwp to flux divergence f=A*d(vegwp) - real(r8) :: leading ! inverse of determiniant - real(r8) :: determ ! determinant of matrix - real(r8) :: grav1 ! gravitational potential surface to canopy top (mm H2O) - real(r8) :: invfactor ! - real(r8) :: f(nvegwcs) - real(r8), parameter :: tol_lai=1.e-7_r8 ! minimum lai where transpiration is calc'd - integer, parameter :: leafsun=1 - integer, parameter :: leafsha=2 - integer, parameter :: xyl=3 - integer, parameter :: root=4 - integer :: j ! index - !------------------------------------------------------------------------------ - - grav1 = htop*1000._r8 - - !compute conductance attentuation for each segment - fsto1= plc(x(leafsun),psi50_sun,ck) - fsto2= plc(x(leafsha),psi50_sha,ck) - fx= plc(x(xyl),psi50_xyl,ck) - fr= plc(x(root),psi50_root,ck) - - !compute 1st deriv of conductance attenuation for each segment - dfsto1= d1plc(x(leafsun),psi50_sun,ck) - dfsto2= d1plc(x(leafsha),psi50_sha,ck) - dfx= d1plc(x(xyl),psi50_xyl,ck) - dfr= d1plc(x(root),psi50_root,ck) - - - A11= - laisun * kmax_sun * fx& - - qflx_sun * dfsto1 - A13= laisun * kmax_sun * dfx * (x(xyl)-x(leafsun))& - + laisun * kmax_sun * fx - A22= - laisha * kmax_sha * fx& - - qflx_sha * dfsto2 - A23= laisha * kmax_sha * dfx * (x(xyl)-x(leafsha))& - + laisha * kmax_sha * fx - A31= laisun * kmax_sun * fx - A32= laisha * kmax_sha * fx - A33= - laisun * kmax_sun * dfx * (x(xyl)-x(leafsun)) - laisun * kmax_sun * fx& - - laisha * kmax_sha * dfx * (x(xyl)-x(leafsha)) - laisha * kmax_sha * fx& - - sai * kmax_xyl / htop * fr - A34= sai * kmax_xyl / htop * dfr * (x(root)-x(xyl)-grav1)& - + sai * kmax_xyl / htop * fr - A43= sai * kmax_xyl / htop * fr - A44= - sai * kmax_xyl / htop * fr& - - sai * kmax_xyl / htop * dfr * (x(root)-x(xyl)-grav1)& - + dqeroot - - !compute flux divergence across each plant segment - f(leafsun) = qflx_sun * fsto1 - laisun * kmax_sun * fx * (x(xyl)-x(leafsun)) - f(leafsha) = qflx_sha * fsto2 - laisha * kmax_sha * fx * (x(xyl)-x(leafsha)) - f(xyl) = laisun * kmax_sun * fx * (x(xyl)-x(leafsun))& - + laisha * kmax_sha * fx * (x(xyl)-x(leafsha)) & - - sai * kmax_xyl / htop * fr * (x(root)-x(xyl)-grav1) - f(root) = sai * kmax_xyl / htop * fr * (x(root)-x(xyl)-grav1) - qeroot - - if(qflx_sha > 0 )then - determ=A44*A22*A33*A11-A44*A22*A31*A13-A44*A32*A23*A11-A43*A11*A22*A34 - - if(determ .ne. 0)then - dx(leafsun) = ((A22*A33*A44 - A22*A34*A43 - A23*A32*A44)*f(leafsun) + A13*A32*A44*f(leafsha) & - - A13*A22*A44*f(xyl) + A13*A22*A34*f(root)) / determ - dx(leafsha) = ( A23*A31*A44*f(leafsun) + (A11*A33*A44 - A11*A34*A43 - A13*A31*A44)*f(leafsha) & - - A11*A23*A44*f(xyl) + A11*A23*A34*f(root)) / determ - dx(xyl) = (-A22*A31*A44*f(leafsun) - A11*A32*A44*f(leafsha) & - + A11*A22*A44*f(xyl) - A11*A22*A34*f(root)) / determ - dx(root) = ( A22*A31*A43*f(leafsun) + A11*A32*A43*f(leafsha) & - - A11*A22*A43*f(xyl) +(A11*A22*A33 - A11*A23*A32 - A13*A22*A31)*f(root)) / determ - else - dx = 0._r8 - end if - else - A33 = - laisun * kmax_sun * dfx * (x(xyl)-x(leafsun)) - laisun * kmax_sun * fx - sai * kmax_xyl / htop * fr - f(xyl) = laisun * kmax_sun * fx * (x(xyl)-x(leafsun)) - sai * kmax_xyl / htop * fr * (x(root)-x(xyl)-grav1) - determ=A11*A33*A44-A34*A11*A43-A13*A31*A44 - if(determ .ne. 0)then - dx(leafsun) = (- A13*A44*f(xyl) + A13*A34*f(root) + (A33*A44 - A34*A43)*f(leafsun)) / determ - dx(xyl) = ( A11*A44*f(xyl) - A11*A34*f(root) - A31*A44*f(leafsun)) / determ - dx(root) = (- A11*A43*f(xyl) + (A11*A33 - A13*A31)*f(root) + A31*A43*f(leafsun)) / determ - - dx(leafsha) = x(leafsun) - x(leafsha) + dx(leafsun) - else - dx = 0._r8 - end if - end if - - end subroutine spacAF_twoleaf - - !-------------------------------------------------------------------------------- - subroutine getvegwp_twoleaf(x, nvegwcs, nl_soil, z_soi, gb_mol, gs_mol_sun, gs_mol_sha, & + ! + ! DESCRIPTION + ! Returns invA, the inverse matrix relating delta(vegwp) to f + ! d(vegwp)=invA*f + ! evaluated at vegwp(p) + ! + ! The methodology is currently hardcoded for linear algebra assuming the + ! number of vegetation segments is four. Thus the matrix A and it's inverse + ! invA are both 4x4 matrices. A more general method could be done using for + ! example a LINPACK linear algebra solver. + ! + ! !ARGUMENTS: + integer , intent(in) :: nvegwcs + real(r8) , intent(in) :: x(nvegwcs) ! working copy of veg water potential for patch p [mm H2O] + real(r8) , intent(out) :: dx(nvegwcs) ! matrix relating d(vegwp) and f: d(vegwp)=invA*f + integer , intent(in) :: nl_soil + real(r8) , intent(in) :: qflx_sun ! Sunlit leaf transpiration [kg/m2/s] + real(r8) , intent(in) :: qflx_sha ! Shaded leaf transpiration [kg/m2/s] + real(r8) , intent(in) :: laisun ! Sunlit leaf area index + real(r8) , intent(in) :: laisha ! Shaded leaf area index + real(r8) , intent(in) :: sai ! Stem area index + real(r8) , intent(in) :: htop ! Canopy top [m] + real(r8) , intent(in) :: qeroot ! soil-root interface conductance [mm/s] + real(r8) , intent(in) :: dqeroot ! soil-root interface conductance [mm/s] + real(r8) , intent(in) :: kmax_sun + real(r8) , intent(in) :: kmax_sha + real(r8) , intent(in) :: kmax_xyl + real(r8) , intent(in) :: kmax_root + real(r8) , intent(in) :: psi50_sun ! water potential at 50% loss of sunlit leaf tissue conductance (mmH2O) + real(r8) , intent(in) :: psi50_sha ! water potential at 50% loss of shaded leaf tissue conductance (mmH2O) + real(r8) , intent(in) :: psi50_xyl ! water potential at 50% loss of xylem tissue conductance (mmH2O) + real(r8) , intent(in) :: psi50_root ! water potential at 50% loss of root tissue conductance (mmH2O) + real(r8) , intent(in) :: ck + ! + ! !LOCAL VARIABLES: + real(r8) :: wtl ! heat conductance for leaf [m/s] + real(r8) :: fsto1 ! sunlit transpiration reduction function [-] + real(r8) :: fsto2 ! shaded transpiration reduction function [-] + real(r8) :: fx ! fraction of maximum conductance, xylem-to-leaf [-] + real(r8) :: fr ! fraction of maximum conductance, root-to-xylem [-] + real(r8) :: dfsto1 ! 1st derivative of fsto1 w.r.t. change in vegwp + real(r8) :: dfsto2 ! 1st derivative of fsto2 w.r.t. change in vegwp + real(r8) :: dfx ! 1st derivative of fx w.r.t. change in vegwp + real(r8) :: dfr ! 1st derivative of fr w.r.t. change in vegwp + real(r8) :: A11, A13, A22, A23, A31, A32, A33, A34, A43, A44 ! matrix relating vegwp to flux divergence f=A*d(vegwp) + real(r8) :: leading ! inverse of determiniant + real(r8) :: determ ! determinant of matrix + real(r8) :: grav1 ! gravitational potential surface to canopy top (mm H2O) + real(r8) :: invfactor ! + real(r8) :: f(nvegwcs) + real(r8), parameter :: tol_lai=1.e-7_r8 ! minimum lai WHERE transpiration is calc'd + integer, parameter :: leafsun=1 + integer, parameter :: leafsha=2 + integer, parameter :: xyl=3 + integer, parameter :: root=4 + integer :: j ! index + !------------------------------------------------------------------------------ + + grav1 = htop*1000._r8 + + !compute conductance attentuation for each segment + fsto1= plc(x(leafsun),psi50_sun,ck) + fsto2= plc(x(leafsha),psi50_sha,ck) + fx= plc(x(xyl),psi50_xyl,ck) + fr= plc(x(root),psi50_root,ck) + + !compute 1st deriv of conductance attenuation for each segment + dfsto1= d1plc(x(leafsun),psi50_sun,ck) + dfsto2= d1plc(x(leafsha),psi50_sha,ck) + dfx= d1plc(x(xyl),psi50_xyl,ck) + dfr= d1plc(x(root),psi50_root,ck) + + + A11= - laisun * kmax_sun * fx& + - qflx_sun * dfsto1 + A13= laisun * kmax_sun * dfx * (x(xyl)-x(leafsun))& + + laisun * kmax_sun * fx + A22= - laisha * kmax_sha * fx& + - qflx_sha * dfsto2 + A23= laisha * kmax_sha * dfx * (x(xyl)-x(leafsha))& + + laisha * kmax_sha * fx + A31= laisun * kmax_sun * fx + A32= laisha * kmax_sha * fx + A33= - laisun * kmax_sun * dfx * (x(xyl)-x(leafsun)) - laisun * kmax_sun * fx& + - laisha * kmax_sha * dfx * (x(xyl)-x(leafsha)) - laisha * kmax_sha * fx& + - sai * kmax_xyl / htop * fr + A34= sai * kmax_xyl / htop * dfr * (x(root)-x(xyl)-grav1)& + + sai * kmax_xyl / htop * fr + A43= sai * kmax_xyl / htop * fr + A44= - sai * kmax_xyl / htop * fr& + - sai * kmax_xyl / htop * dfr * (x(root)-x(xyl)-grav1)& + + dqeroot + + !compute flux divergence across each plant segment + f(leafsun) = qflx_sun * fsto1 - laisun * kmax_sun * fx * (x(xyl)-x(leafsun)) + f(leafsha) = qflx_sha * fsto2 - laisha * kmax_sha * fx * (x(xyl)-x(leafsha)) + f(xyl) = laisun * kmax_sun * fx * (x(xyl)-x(leafsun))& + + laisha * kmax_sha * fx * (x(xyl)-x(leafsha)) & + - sai * kmax_xyl / htop * fr * (x(root)-x(xyl)-grav1) + f(root) = sai * kmax_xyl / htop * fr * (x(root)-x(xyl)-grav1) - qeroot + + IF(qflx_sha > 0 )THEN + determ=A44*A22*A33*A11-A44*A22*A31*A13-A44*A32*A23*A11-A43*A11*A22*A34 + + IF(determ .ne. 0)THEN + dx(leafsun) = ((A22*A33*A44 - A22*A34*A43 - A23*A32*A44)*f(leafsun) + A13*A32*A44*f(leafsha) & + - A13*A22*A44*f(xyl) + A13*A22*A34*f(root)) / determ + dx(leafsha) = ( A23*A31*A44*f(leafsun) + (A11*A33*A44 - A11*A34*A43 - A13*A31*A44)*f(leafsha) & + - A11*A23*A44*f(xyl) + A11*A23*A34*f(root)) / determ + dx(xyl) = (-A22*A31*A44*f(leafsun) - A11*A32*A44*f(leafsha) & + + A11*A22*A44*f(xyl) - A11*A22*A34*f(root)) / determ + dx(root) = ( A22*A31*A43*f(leafsun) + A11*A32*A43*f(leafsha) & + - A11*A22*A43*f(xyl) +(A11*A22*A33 - A11*A23*A32 - A13*A22*A31)*f(root)) / determ + ELSE + dx = 0._r8 + ENDIF + ELSE + A33 = - laisun * kmax_sun * dfx * (x(xyl)-x(leafsun)) - laisun * kmax_sun * fx - sai * kmax_xyl / htop * fr + f(xyl) = laisun * kmax_sun * fx * (x(xyl)-x(leafsun)) - sai * kmax_xyl / htop * fr * (x(root)-x(xyl)-grav1) + determ=A11*A33*A44-A34*A11*A43-A13*A31*A44 + IF(determ .ne. 0)THEN + dx(leafsun) = (- A13*A44*f(xyl) + A13*A34*f(root) + (A33*A44 - A34*A43)*f(leafsun)) / determ + dx(xyl) = ( A11*A44*f(xyl) - A11*A34*f(root) - A31*A44*f(leafsun)) / determ + dx(root) = (- A11*A43*f(xyl) + (A11*A33 - A13*A31)*f(root) + A31*A43*f(leafsun)) / determ + + dx(leafsha) = x(leafsun) - x(leafsha) + dx(leafsun) + ELSE + dx = 0._r8 + ENDIF + ENDIF + + END SUBROUTINE spacAF_twoleaf + + !-------------------------------------------------------------------------------- + SUBROUTINE getvegwp_twoleaf(x, nvegwcs, nl_soil, z_soi, gb_mol, gs_mol_sun, gs_mol_sha, & qsatl, qaf,qg,qm,rhoair, psrf, fwet, laisun, laisha, htop, sai, tl, rss, & raw, rd, smp, k_soil_root, k_ax_root, kmax_xyl, kmax_root, rstfacsun, rstfacsha, & psi50_sun, psi50_sha, psi50_xyl, psi50_root, ck, rootflux, etrsun, etrsha) - ! !DESCRIPTION: - ! Calculates transpiration and returns corresponding vegwp in x - ! - ! !USES: - ! calls getqflx - use MOD_Const_Physical, only : tfrz - implicit none - ! - ! !ARGUMENTS: - integer , intent(in) :: nvegwcs - real(r8) , intent(out) :: x(nvegwcs) ! working copy of veg water potential for patch p - integer , intent(in) :: nl_soil ! number of soil layers - real(r8) , intent(in) :: z_soi(nl_soil) ! node depth [m] - real(r8) , intent(in) :: gb_mol ! Leaf boundary layer conductance [umol H2O/m**2/s] - real(r8) , intent(inout) :: gs_mol_sun ! Ball-Berry leaf conductance [umol H2O/m**2/s] - real(r8) , intent(inout) :: gs_mol_sha ! Ball-Berry leaf conductance [umol H2O/m**2/s] - real(r8) , intent(in) :: qsatl ! Sunlit leaf specific humidity [kg/kg] - real(r8) , intent(in) :: qaf ! humidity of canopy air [kg/kg] - real(r8) , intent(in) :: qg ! specific humidity at ground surface [kg/kg] - real(r8) , intent(in) :: qm ! specific humidity at reference height [kg/kg] - real(r8) , intent(in) :: rhoair ! density [kg/m**3] - real(r8) , intent(in) :: psrf ! atmospheric pressure [Pa] - real(r8) , intent(in) :: fwet ! fraction of foliage that is green and dry [-] - real(r8) , intent(in) :: laisun ! Sunlit leaf area index - real(r8) , intent(in) :: laisha ! Shaded leaf area index - real(r8) , intent(in) :: htop ! canopy top [m] - real(r8) , intent(in) :: sai ! stem area index - real(r8) , intent(in) :: tl ! leaf temperature - real(r8) , intent(in) :: kmax_xyl - real(r8) , intent(in) :: kmax_root - real(r8) , intent(in) :: rstfacsun - real(r8) , intent(in) :: rstfacsha - real(r8) , intent(in) :: psi50_sun ! water potential at 50% loss of sunlit leaf tissue conductance (mmH2O) - real(r8) , intent(in) :: psi50_sha ! water potential at 50% loss of shaded leaf tissue conductance (mmH2O) - real(r8) , intent(in) :: psi50_xyl ! water potential at 50% loss of xylem tissue conductance (mmH2O) - real(r8) , intent(in) :: psi50_root ! water potential at 50% loss of root tissue conductance (mmH2O) - real(r8) , intent(in) :: ck ! - real(r8) , intent(in) :: rss ! soil surface resistance [s/m] - real(r8) , intent(in) :: raw ! moisture resistance [s/m] - real(r8) , intent(in) :: rd ! aerodynamical resistance between ground and canopy air - real(r8) , intent(in) :: smp(nl_soil) ! soil matrix potential - real(r8) , intent(in) :: k_soil_root(nl_soil) ! soil-root interface conductance [mm/s] - real(r8) , intent(in) :: k_ax_root(nl_soil) ! root axial-direction conductance [mm/s] - real(r8) , intent(out) :: etrsun ! transpiration from sunlit leaf (mm/s) - real(r8) , intent(out) :: etrsha ! transpiration from shaded leaf (mm/s) - real(r8) , intent(out) :: rootflux(nl_soil) ! root water uptake from different layers - ! - ! !LOCAL VARIABLES: -! real(r8) :: qflx_sun ! Sunlit leaf transpiration [kg/m2/s] -! real(r8) :: qflx_sha ! Shaded leaf transpiration [kg/m2/s] - real(r8) :: qeroot - real(r8) :: dummy - real(r8) :: fx ! fraction of maximum conductance, xylem-to-leaf [-] - real(r8) :: fr ! fraction of maximum conductance, root-to-xylem [-] - real(r8) :: x_root_top - real(r8) :: xroot(nl_soil) - real(r8) :: grav1 ! gravitational potential surface to canopy top (mm H2O) - real(r8) :: grav2(nl_soil) ! soil layer gravitational potential relative to surface (mm H2O) - integer :: j ! index - logical :: havegs ! signals direction of calculation gs->qflx or qflx->gs - logical :: haroot ! signals direction of calculation x_root_top->qeroot or qeroot->x_root_top - integer, parameter :: leafsun=1 - integer, parameter :: leafsha=2 - integer, parameter :: xyl=3 - integer, parameter :: root=4 - real(r8) :: soilflux ! total soil column transpiration [mm/s] - !---------------------------------------------------------------------- - grav1 = 1000._r8 * htop - grav2(1:nl_soil) = 1000._r8 * z_soi(1:nl_soil) - - !compute transpiration demand - havegs=.true. - call getqflx_gs2qflx_twoleaf(gb_mol,gs_mol_sun,gs_mol_sha,etrsun,etrsha,qsatl,qaf, & - rhoair,psrf,laisun,laisha,sai,fwet,tl,rss,raw,rd,qg,qm,rstfacsun,rstfacsha) - - !calculate root water potential - qeroot = etrsun + etrsha - - call getrootqflx_qe2x(nl_soil,smp,z_soi,k_soil_root,k_ax_root,qeroot,xroot,x_root_top) - x(root) = x_root_top - - !calculate xylem water potential - fr = plc(x(root),psi50_root,ck) - x(xyl) = x(root) - grav1 - (etrsun+etrsha)/(fr*kmax_root/htop*sai) - - !calculate sun/sha leaf water potential - fx = plc(x(xyl),psi50_xyl,ck) - x(leafsha) = x(xyl) - (etrsha/(fx*kmax_xyl*laisha)) - x(leafsun) = x(xyl) - (etrsun/(fx*kmax_xyl*laisun)) - - - !calculate soil flux - do j = 1,nl_soil - rootflux(j) = k_soil_root(j)*(smp(j)-xroot(j)) - enddo - - soilflux = sum(rootflux(:)) - - end subroutine getvegwp_twoleaf - - !-------------------------------------------------------------------------------- - subroutine getqflx_gs2qflx_twoleaf(gb_mol,gs_mol_sun,gs_mol_sha,qflx_sun,qflx_sha,qsatl,qaf,& + ! !DESCRIPTION: + ! Calculates transpiration and returns corresponding vegwp in x + ! + ! !USES: + ! calls getqflx + USE MOD_Const_Physical, only : tfrz + IMPLICIT NONE + ! + ! !ARGUMENTS: + integer , intent(in) :: nvegwcs + real(r8) , intent(out) :: x(nvegwcs) ! working copy of veg water potential for patch p + integer , intent(in) :: nl_soil ! number of soil layers + real(r8) , intent(in) :: z_soi(nl_soil) ! node depth [m] + real(r8) , intent(in) :: gb_mol ! Leaf boundary layer conductance [umol H2O/m**2/s] + real(r8) , intent(inout) :: gs_mol_sun ! Ball-Berry leaf conductance [umol H2O/m**2/s] + real(r8) , intent(inout) :: gs_mol_sha ! Ball-Berry leaf conductance [umol H2O/m**2/s] + real(r8) , intent(in) :: qsatl ! Sunlit leaf specific humidity [kg/kg] + real(r8) , intent(in) :: qaf ! humidity of canopy air [kg/kg] + real(r8) , intent(in) :: qg ! specific humidity at ground surface [kg/kg] + real(r8) , intent(in) :: qm ! specific humidity at reference height [kg/kg] + real(r8) , intent(in) :: rhoair ! density [kg/m**3] + real(r8) , intent(in) :: psrf ! atmospheric pressure [Pa] + real(r8) , intent(in) :: fwet ! fraction of foliage that is green and dry [-] + real(r8) , intent(in) :: laisun ! Sunlit leaf area index + real(r8) , intent(in) :: laisha ! Shaded leaf area index + real(r8) , intent(in) :: htop ! canopy top [m] + real(r8) , intent(in) :: sai ! stem area index + real(r8) , intent(in) :: tl ! leaf temperature + real(r8) , intent(in) :: kmax_xyl + real(r8) , intent(in) :: kmax_root + real(r8) , intent(in) :: rstfacsun + real(r8) , intent(in) :: rstfacsha + real(r8) , intent(in) :: psi50_sun ! water potential at 50% loss of sunlit leaf tissue conductance (mmH2O) + real(r8) , intent(in) :: psi50_sha ! water potential at 50% loss of shaded leaf tissue conductance (mmH2O) + real(r8) , intent(in) :: psi50_xyl ! water potential at 50% loss of xylem tissue conductance (mmH2O) + real(r8) , intent(in) :: psi50_root ! water potential at 50% loss of root tissue conductance (mmH2O) + real(r8) , intent(in) :: ck ! + real(r8) , intent(in) :: rss ! soil surface resistance [s/m] + real(r8) , intent(in) :: raw ! moisture resistance [s/m] + real(r8) , intent(in) :: rd ! aerodynamical resistance between ground and canopy air + real(r8) , intent(in) :: smp(nl_soil) ! soil matrix potential + real(r8) , intent(in) :: k_soil_root(nl_soil) ! soil-root interface conductance [mm/s] + real(r8) , intent(in) :: k_ax_root(nl_soil) ! root axial-direction conductance [mm/s] + real(r8) , intent(out) :: etrsun ! transpiration from sunlit leaf (mm/s) + real(r8) , intent(out) :: etrsha ! transpiration from shaded leaf (mm/s) + real(r8) , intent(out) :: rootflux(nl_soil) ! root water uptake from different layers + ! + ! !LOCAL VARIABLES: +! real(r8) :: qflx_sun ! Sunlit leaf transpiration [kg/m2/s] +! real(r8) :: qflx_sha ! Shaded leaf transpiration [kg/m2/s] + real(r8) :: qeroot + real(r8) :: dummy + real(r8) :: fx ! fraction of maximum conductance, xylem-to-leaf [-] + real(r8) :: fr ! fraction of maximum conductance, root-to-xylem [-] + real(r8) :: x_root_top + real(r8) :: xroot(nl_soil) + real(r8) :: grav1 ! gravitational potential surface to canopy top (mm H2O) + real(r8) :: grav2(nl_soil) ! soil layer gravitational potential relative to surface (mm H2O) + integer :: j ! index + logical :: havegs ! signals direction of calculation gs->qflx or qflx->gs + logical :: haroot ! signals direction of calculation x_root_top->qeroot or qeroot->x_root_top + integer, parameter :: leafsun=1 + integer, parameter :: leafsha=2 + integer, parameter :: xyl=3 + integer, parameter :: root=4 + real(r8) :: soilflux ! total soil column transpiration [mm/s] + + !---------------------------------------------------------------------- + grav1 = 1000._r8 * htop + grav2(1:nl_soil) = 1000._r8 * z_soi(1:nl_soil) + + !compute transpiration demand + havegs=.true. + CALL getqflx_gs2qflx_twoleaf(gb_mol,gs_mol_sun,gs_mol_sha,etrsun,etrsha,qsatl,qaf, & + rhoair,psrf,laisun,laisha,sai,fwet,tl,rss,raw,rd,qg,qm,rstfacsun,rstfacsha) + + !calculate root water potential + qeroot = etrsun + etrsha + + CALL getrootqflx_qe2x(nl_soil,smp,z_soi,k_soil_root,k_ax_root,qeroot,xroot,x_root_top) + x(root) = x_root_top + + !calculate xylem water potential + fr = plc(x(root),psi50_root,ck) + x(xyl) = x(root) - grav1 - (etrsun+etrsha)/(fr*kmax_root/htop*sai) + + !calculate sun/sha leaf water potential + fx = plc(x(xyl),psi50_xyl,ck) + x(leafsha) = x(xyl) - (etrsha/(fx*kmax_xyl*laisha)) + x(leafsun) = x(xyl) - (etrsun/(fx*kmax_xyl*laisun)) + + + !calculate soil flux + DO j = 1,nl_soil + rootflux(j) = k_soil_root(j)*(smp(j)-xroot(j)) + ENDDO + + soilflux = sum(rootflux(:)) + + END SUBROUTINE getvegwp_twoleaf + + !-------------------------------------------------------------------------------- + SUBROUTINE getqflx_gs2qflx_twoleaf(gb_mol,gs_mol_sun,gs_mol_sha,qflx_sun,qflx_sha,qsatl,qaf,& rhoair,psrf,laisun,laisha,sai,fwet,tl,rss,raw,rd,qg,qm,rstfacsun,rstfacsha) - ! !DESCRIPTION: - ! calculate sunlit and shaded transpiration using gb_MOL and gs_MOL - ! !USES: - ! - implicit none - ! - ! !ARGUMENTS: - real(r8) , intent(in) :: gb_mol ! leaf boundary layer conductance (mol H2O/m**2/s), leaf scale - real(r8) , intent(inout) :: gs_mol_sun ! Ball-Berry leaf conductance (mol H2O/m**2/s), leaf scale - real(r8) , intent(inout) :: gs_mol_sha ! Ball-Berry leaf conductance (mol H2O/m**2/s), leaf scale - real(r8) , intent(inout) :: qflx_sun ! Sunlit leaf transpiration [kg/m2/s] - real(r8) , intent(inout) :: qflx_sha ! Shaded leaf transpiration [kg/m2/s] - real(r8) , intent(in) :: qsatl ! leaf specific humidity [kg/kg] - real(r8) , intent(in) :: qaf ! humidity of canopy air [kg/kg] - real(r8) , intent(in) :: qg ! specific humidity at ground surface [kg/kg] - real(r8) , intent(in) :: qm ! specific humidity at reference height [kg/kg] - real(r8) , intent(in) :: rhoair ! density (kg/m**3) - real(r8) , intent(in) :: psrf ! atmospheric pressure (Pa) - real(r8) , intent(in) :: laisun ! sunlit leaf area index (m2/m2) - real(r8) , intent(in) :: laisha ! shaded leaf area index (m2/m2) - real(r8) , intent(in) :: sai ! stem area index (m2/m2) - real(r8) , intent(in) :: fwet ! fraction of foliage that is green and dry [-] - real(r8) , intent(in) :: tl ! shaded leaf temperature - real(r8) , intent(in) :: rss ! soil surface resistance [s/m] - real(r8) , intent(in) :: raw ! moisture resistance [s/m] - real(r8) , intent(in) :: rd ! aerodynamical resistance between ground and canopy air - real(r8) ,optional, intent(in) :: rstfacsun - real(r8) ,optional, intent(in) :: rstfacsha - - ! - ! !LOCAL VARIABLES: - real(r8) :: cf ! (umol/m**3) r = cf./g gmol(umol/m**2/s) -> r(s/m) - real(r8) :: tprcor ! tf*psur*100./1.013e5 - - real(r8) :: wtaq0 ! normalized latent heat conductance for air [-] - real(r8) :: wtgq0 ! normalized latent heat conductance for ground [-] - real(r8) :: wtlq0 ! normalized latent heat cond. for air and sunlit leaf [-] - real(r8) :: wtsqi ! latent heat resistance for air, grd and leaf [-] - - real(r8) :: delta - real(r8) :: caw ! latent heat conductance for air [m/s] - real(r8) :: cgw ! latent heat conductance for ground [m/s] - real(r8) :: cfw ! latent heat conductance for leaf [m/s] - - !---------------------------------------------------------------------- - tprcor = 44.6*273.16*psrf/1.013e5 - cf = tprcor/tl * 1.e6_r8 ! gb->gbmol conversion factor - - delta = 0.0 - if(qsatl-qaf .gt. 0.) delta = 1.0 - - caw = 1. / raw - IF (qg < qaf)THEN - cgw = 1. / rd - ELSE - IF (DEF_RSS_SCHEME .eq. 4) THEN - cgw = rss / rd - ELSE - cgw = 1. / (rd + rss) - END IF - END IF - cfw = (1.-delta*(1.-fwet)) * (laisun+laisha+sai)*gb_mol/cf + (1.-fwet)*delta*& - (laisun/(1._r8/gb_mol+1._r8/gs_mol_sun)/cf+laisha/(1._r8/gb_mol+1._r8/gs_mol_sha)/cf) - wtsqi = 1. / ( caw + cgw + cfw ) - - wtaq0 = caw * wtsqi - wtgq0 = cgw * wtsqi - wtlq0 = cfw * wtsqi - - qflx_sun = rhoair * (1.-fwet) * delta & - * laisun / (1./gb_mol+1./gs_mol_sun)/cf & - * ( (wtaq0 + wtgq0)*qsatl - wtaq0*qm - wtgq0*qg ) -! if(qflx_sun < 1.e-7_r8)then -! qflx_sun = 0._r8 -! end if - if(present(rstfacsun))then - if(rstfacsun .le. 1.e-2)qflx_sun = 0._r8 - end if - qflx_sha = rhoair * (1.-fwet) * delta & - * laisha / (1./gb_mol+1./gs_mol_sha)/cf & - * ( (wtaq0 + wtgq0)*qsatl - wtaq0*qm - wtgq0*qg ) -! if(qflx_sha < 1.e-7)then -! qflx_sha = 0._r8 -! end if - if(present(rstfacsha))then - if(rstfacsha .le. 1.e-2)qflx_sha = 0._r8 - end if - - end subroutine getqflx_gs2qflx_twoleaf - - subroutine getqflx_qflx2gs_twoleaf(gb_mol,gs_mol_sun,gs_mol_sha,qflx_sun,qflx_sha,qsatl,qaf, & - rhoair,psrf,laisun,laisha,sai,fwet,tl,rss,raw,rd,qg,qm) - ! !DESCRIPTION: - ! calculate sunlit and shaded transpiration using gb_MOL and gs_MOL - ! !USES: - ! - implicit none - ! - ! !ARGUMENTS: - real(r8) , intent(in) :: gb_mol ! leaf boundary layer conductance (mol H2O/m**2/s), leaf scale - real(r8) , intent(inout) :: gs_mol_sun ! Ball-Berry leaf conductance (mol H2O/m**2/s), leaf scale - real(r8) , intent(inout) :: gs_mol_sha ! Ball-Berry leaf conductance (mol H2O/m**2/s), leaf scale - real(r8) , intent(inout) :: qflx_sun ! Sunlit leaf transpiration [kg/m2/s] - real(r8) , intent(inout) :: qflx_sha ! Shaded leaf transpiration [kg/m2/s] - real(r8) , intent(in) :: qsatl ! leaf specific humidity [kg/kg] - real(r8) , intent(in) :: qaf ! humidity of canopy air [kg/kg] - real(r8) , intent(in) :: qg ! specific humidity at ground surface [kg/kg] - real(r8) , intent(in) :: qm ! specific humidity at reference height [kg/kg] - real(r8) , intent(in) :: rhoair ! density (kg/m**3) - real(r8) , intent(in) :: psrf ! atmospheric pressure (Pa) - real(r8) , intent(in) :: laisun ! sunlit leaf area index (m2/m2) - real(r8) , intent(in) :: laisha ! shaded leaf area index (m2/m2) - real(r8) , intent(in) :: sai ! stem area index (m2/m2) - real(r8) , intent(in) :: fwet ! fraction of foliage that is green and dry [-] - real(r8) , intent(in) :: tl ! leaf temperature - real(r8) , intent(in) :: rss ! soil surface resistance [s/m] - real(r8) , intent(in) :: raw ! moisture resistance [s/m] - real(r8) , intent(in) :: rd ! aerodynamical resistance between ground and canopy air - - ! - ! !LOCAL VARIABLES: - real(r8) :: wtlsun ! heat conductance for sunlit leaf boundary [m/s] - real(r8) :: wtlsha ! heat conductance for shaded leaf boundary [m/s] - real(r8) :: cf ! s m**2/umol -> s/m - real(r8) :: tprcor !tf*psur*100./1.013e5 - - real(r8) :: wtaq0 ! normalized latent heat conductance for air [-] - real(r8) :: wtgq0 ! normalized latent heat conductance for ground [-] - real(r8) :: wtlsunq0 ! normalized latent heat cond. for air and sunlit leaf [-] - real(r8) :: wtlshaq0 ! normalized latent heat cond. for air and shaded leaf [-] - - real(r8) :: delta - real(r8) :: caw ! latent heat conductance for air [m/s] - real(r8) :: cgw ! latent heat conductance for ground [m/s] - real(r8) :: cwet ! latent heat conductance for wet leaf [m/s] - real(r8) :: csunw_dry ! latent heat conductance for sunlit dry leaf [m/s] - real(r8) :: cshaw_dry ! latent heat conductance for shaded dry leaf [m/s] - real(r8) :: cqi_wet ! latent heat conductance for air, grd and wet leaf [-] - real(r8) :: cqi_leaf ! (wtaq0 + wtgq0)*qsatl - wtaq0*qm - wtgq0*qg [m/s] - real(r8) :: A1,B1,C1,A2,B2,C2 ! in binary quadratic equations - - !---------------------------------------------------------------------- - if(qflx_sun .gt. 0 .or. qflx_sha .gt. 0)then - tprcor = 44.6*273.16*psrf/1.013e5 - cf = tprcor/tl * 1.e6_r8 ! gb->gbmol conversion factor - - delta = 0.0 - if(qsatl-qaf .gt. 0.) delta = 1.0 - - caw = 1. / raw - IF (qg < qaf)THEN - cgw = 1. / rd - ELSE - IF (DEF_RSS_SCHEME .eq. 4) THEN - cgw = rss / rd - ELSE - cgw = 1. / (rd + rss) - END IF - END IF - cwet = (1.-delta*(1.-fwet)) * (laisun + laisha + sai) * gb_mol / cf - cqi_wet = caw + cgw + cwet - cqi_leaf = caw * (qsatl - qm) + cgw * (qsatl - qg) - - ! Solve equations: - ! A1 * csunw_dry + B1 * cfshaw_dry = C1 - ! A2 * csunw_dry + B2 * cfshaw_dry = C2 - - A1 = cqi_leaf - qflx_sun / rhoair - B1 = - qflx_sun / rhoair - C1 = qflx_sun * cqi_wet / rhoair - A2 = - qflx_sha / rhoair - B2 = cqi_leaf - qflx_sha / rhoair - C2 = qflx_sha * cqi_wet / rhoair - - csunw_dry = (B1*C2 - B2*C1)/(B1*A2 - B2*A1) - cshaw_dry = (A1*C2 - A2*C1)/(A1*B2 - B1*A2) - - if (qflx_sun > 0._r8) then - gs_mol_sun = 1._r8 / ((1. - fwet) * delta * laisun / csunw_dry / cf - 1._r8 / gb_mol) - endif - if (qflx_sha > 0._r8) then - gs_mol_sha = 1._r8 / ((1. - fwet) * delta * laisha / cshaw_dry / cf - 1._r8 / gb_mol) - endif - end if - - end subroutine getqflx_qflx2gs_twoleaf - - subroutine getrootqflx_x2qe(nl_soil,smp,x_root_top,z_soisno,krad,kax,qeroot,dqeroot) - - USE MOD_Utils - ! DESCRIPTION - ! Return root water potential at top soil node. Return soil-root water flux. - ! - - integer ,intent(in) :: nl_soil - real(r8),intent(in) :: smp (nl_soil) - real(r8),intent(in) :: x_root_top - real(r8),intent(in) :: z_soisno (nl_soil) - real(r8),intent(in) :: krad (nl_soil) - real(r8),intent(in) :: kax (nl_soil) - real(r8),intent(out) :: qeroot - real(r8),intent(out) :: dqeroot + ! !DESCRIPTION: + ! calculate sunlit and shaded transpiration using gb_MOL and gs_MOL + ! !USES: + ! + IMPLICIT NONE + ! + ! !ARGUMENTS: + real(r8) , intent(in) :: gb_mol ! leaf boundary layer conductance (mol H2O/m**2/s), leaf scale + real(r8) , intent(inout) :: gs_mol_sun ! Ball-Berry leaf conductance (mol H2O/m**2/s), leaf scale + real(r8) , intent(inout) :: gs_mol_sha ! Ball-Berry leaf conductance (mol H2O/m**2/s), leaf scale + real(r8) , intent(inout) :: qflx_sun ! Sunlit leaf transpiration [kg/m2/s] + real(r8) , intent(inout) :: qflx_sha ! Shaded leaf transpiration [kg/m2/s] + real(r8) , intent(in) :: qsatl ! leaf specific humidity [kg/kg] + real(r8) , intent(in) :: qaf ! humidity of canopy air [kg/kg] + real(r8) , intent(in) :: qg ! specific humidity at ground surface [kg/kg] + real(r8) , intent(in) :: qm ! specific humidity at reference height [kg/kg] + real(r8) , intent(in) :: rhoair ! density (kg/m**3) + real(r8) , intent(in) :: psrf ! atmospheric pressure (Pa) + real(r8) , intent(in) :: laisun ! sunlit leaf area index (m2/m2) + real(r8) , intent(in) :: laisha ! shaded leaf area index (m2/m2) + real(r8) , intent(in) :: sai ! stem area index (m2/m2) + real(r8) , intent(in) :: fwet ! fraction of foliage that is green and dry [-] + real(r8) , intent(in) :: tl ! shaded leaf temperature + real(r8) , intent(in) :: rss ! soil surface resistance [s/m] + real(r8) , intent(in) :: raw ! moisture resistance [s/m] + real(r8) , intent(in) :: rd ! aerodynamical resistance between ground and canopy air + real(r8) ,optional, intent(in) :: rstfacsun + real(r8) ,optional, intent(in) :: rstfacsha + + ! + ! !LOCAL VARIABLES: + real(r8) :: cf ! (umol/m**3) r = cf./g gmol(umol/m**2/s) -> r(s/m) + real(r8) :: tprcor ! tf*psur*100./1.013e5 + + real(r8) :: wtaq0 ! normalized latent heat conductance for air [-] + real(r8) :: wtgq0 ! normalized latent heat conductance for ground [-] + real(r8) :: wtlq0 ! normalized latent heat cond. for air and sunlit leaf [-] + real(r8) :: wtsqi ! latent heat resistance for air, grd and leaf [-] + + real(r8) :: delta + real(r8) :: caw ! latent heat conductance for air [m/s] + real(r8) :: cgw ! latent heat conductance for ground [m/s] + real(r8) :: cfw ! latent heat conductance for leaf [m/s] + + !---------------------------------------------------------------------- + tprcor = 44.6*273.16*psrf/1.013e5 + cf = tprcor/tl * 1.e6_r8 ! gb->gbmol conversion factor + + delta = 0.0 + IF(qsatl-qaf .gt. 0.) delta = 1.0 + + caw = 1. / raw + IF (qg < qaf)THEN + cgw = 1. / rd + ELSE + IF (DEF_RSS_SCHEME .eq. 4) THEN + cgw = rss / rd + ELSE + cgw = 1. / (rd + rss) + ENDIF + ENDIF + cfw = (1.-delta*(1.-fwet)) * (laisun+laisha+sai)*gb_mol/cf + (1.-fwet)*delta*& + (laisun/(1._r8/gb_mol+1._r8/gs_mol_sun)/cf+laisha/(1._r8/gb_mol+1._r8/gs_mol_sha)/cf) + wtsqi = 1. / ( caw + cgw + cfw ) + + wtaq0 = caw * wtsqi + wtgq0 = cgw * wtsqi + wtlq0 = cfw * wtsqi + + qflx_sun = rhoair * (1.-fwet) * delta & + * laisun / (1./gb_mol+1./gs_mol_sun)/cf & + * ( (wtaq0 + wtgq0)*qsatl - wtaq0*qm - wtgq0*qg ) +! IF(qflx_sun < 1.e-7_r8)THEN +! qflx_sun = 0._r8 +! ENDIF + IF(present(rstfacsun))THEN + IF(rstfacsun .le. 1.e-2)qflx_sun = 0._r8 + ENDIF + qflx_sha = rhoair * (1.-fwet) * delta & + * laisha / (1./gb_mol+1./gs_mol_sha)/cf & + * ( (wtaq0 + wtgq0)*qsatl - wtaq0*qm - wtgq0*qg ) +! IF(qflx_sha < 1.e-7)THEN +! qflx_sha = 0._r8 +! ENDIF + IF(present(rstfacsha))THEN + IF(rstfacsha .le. 1.e-2)qflx_sha = 0._r8 + ENDIF + + END SUBROUTINE getqflx_gs2qflx_twoleaf + + SUBROUTINE getqflx_qflx2gs_twoleaf(gb_mol,gs_mol_sun,gs_mol_sha,qflx_sun,qflx_sha,qsatl,qaf, & + rhoair,psrf,laisun,laisha,sai,fwet,tl,rss,raw,rd,qg,qm) + ! !DESCRIPTION: + ! calculate sunlit and shaded transpiration using gb_MOL and gs_MOL + ! !USES: + ! + IMPLICIT NONE + ! + ! !ARGUMENTS: + real(r8) , intent(in) :: gb_mol ! leaf boundary layer conductance (mol H2O/m**2/s), leaf scale + real(r8) , intent(inout) :: gs_mol_sun ! Ball-Berry leaf conductance (mol H2O/m**2/s), leaf scale + real(r8) , intent(inout) :: gs_mol_sha ! Ball-Berry leaf conductance (mol H2O/m**2/s), leaf scale + real(r8) , intent(inout) :: qflx_sun ! Sunlit leaf transpiration [kg/m2/s] + real(r8) , intent(inout) :: qflx_sha ! Shaded leaf transpiration [kg/m2/s] + real(r8) , intent(in) :: qsatl ! leaf specific humidity [kg/kg] + real(r8) , intent(in) :: qaf ! humidity of canopy air [kg/kg] + real(r8) , intent(in) :: qg ! specific humidity at ground surface [kg/kg] + real(r8) , intent(in) :: qm ! specific humidity at reference height [kg/kg] + real(r8) , intent(in) :: rhoair ! density (kg/m**3) + real(r8) , intent(in) :: psrf ! atmospheric pressure (Pa) + real(r8) , intent(in) :: laisun ! sunlit leaf area index (m2/m2) + real(r8) , intent(in) :: laisha ! shaded leaf area index (m2/m2) + real(r8) , intent(in) :: sai ! stem area index (m2/m2) + real(r8) , intent(in) :: fwet ! fraction of foliage that is green and dry [-] + real(r8) , intent(in) :: tl ! leaf temperature + real(r8) , intent(in) :: rss ! soil surface resistance [s/m] + real(r8) , intent(in) :: raw ! moisture resistance [s/m] + real(r8) , intent(in) :: rd ! aerodynamical resistance between ground and canopy air + + ! + ! !LOCAL VARIABLES: + real(r8) :: wtlsun ! heat conductance for sunlit leaf boundary [m/s] + real(r8) :: wtlsha ! heat conductance for shaded leaf boundary [m/s] + real(r8) :: cf ! s m**2/umol -> s/m + real(r8) :: tprcor !tf*psur*100./1.013e5 + + real(r8) :: wtaq0 ! normalized latent heat conductance for air [-] + real(r8) :: wtgq0 ! normalized latent heat conductance for ground [-] + real(r8) :: wtlsunq0 ! normalized latent heat cond. for air and sunlit leaf [-] + real(r8) :: wtlshaq0 ! normalized latent heat cond. for air and shaded leaf [-] + + real(r8) :: delta + real(r8) :: caw ! latent heat conductance for air [m/s] + real(r8) :: cgw ! latent heat conductance for ground [m/s] + real(r8) :: cwet ! latent heat conductance for wet leaf [m/s] + real(r8) :: csunw_dry ! latent heat conductance for sunlit dry leaf [m/s] + real(r8) :: cshaw_dry ! latent heat conductance for shaded dry leaf [m/s] + real(r8) :: cqi_wet ! latent heat conductance for air, grd and wet leaf [-] + real(r8) :: cqi_leaf ! (wtaq0 + wtgq0)*qsatl - wtaq0*qm - wtgq0*qg [m/s] + real(r8) :: A1,B1,C1,A2,B2,C2 ! in binary quadratic equations + + !---------------------------------------------------------------------- + IF(qflx_sun .gt. 0 .or. qflx_sha .gt. 0)THEN + tprcor = 44.6*273.16*psrf/1.013e5 + cf = tprcor/tl * 1.e6_r8 ! gb->gbmol conversion factor + + delta = 0.0 + IF(qsatl-qaf .gt. 0.) delta = 1.0 + + caw = 1. / raw + IF (qg < qaf)THEN + cgw = 1. / rd + ELSE + IF (DEF_RSS_SCHEME .eq. 4) THEN + cgw = rss / rd + ELSE + cgw = 1. / (rd + rss) + ENDIF + ENDIF + cwet = (1.-delta*(1.-fwet)) * (laisun + laisha + sai) * gb_mol / cf + cqi_wet = caw + cgw + cwet + cqi_leaf = caw * (qsatl - qm) + cgw * (qsatl - qg) + + ! Solve equations: + ! A1 * csunw_dry + B1 * cfshaw_dry = C1 + ! A2 * csunw_dry + B2 * cfshaw_dry = C2 + + A1 = cqi_leaf - qflx_sun / rhoair + B1 = - qflx_sun / rhoair + C1 = qflx_sun * cqi_wet / rhoair + A2 = - qflx_sha / rhoair + B2 = cqi_leaf - qflx_sha / rhoair + C2 = qflx_sha * cqi_wet / rhoair + + csunw_dry = (B1*C2 - B2*C1)/(B1*A2 - B2*A1) + cshaw_dry = (A1*C2 - A2*C1)/(A1*B2 - B1*A2) + + IF (qflx_sun > 0._r8) THEN + gs_mol_sun = 1._r8 / ((1. - fwet) * delta * laisun / csunw_dry / cf - 1._r8 / gb_mol) + ENDIF + IF (qflx_sha > 0._r8) THEN + gs_mol_sha = 1._r8 / ((1. - fwet) * delta * laisha / cshaw_dry / cf - 1._r8 / gb_mol) + ENDIF + ENDIF + + END SUBROUTINE getqflx_qflx2gs_twoleaf + + SUBROUTINE getrootqflx_x2qe(nl_soil,smp,x_root_top,z_soisno,krad,kax,qeroot,dqeroot) + + USE MOD_Utils + ! DESCRIPTION + ! Return root water potential at top soil node. Return soil-root water flux. + ! + + integer ,intent(in) :: nl_soil + real(r8),intent(in) :: smp (nl_soil) + real(r8),intent(in) :: x_root_top + real(r8),intent(in) :: z_soisno (nl_soil) + real(r8),intent(in) :: krad (nl_soil) + real(r8),intent(in) :: kax (nl_soil) + real(r8),intent(out) :: qeroot + real(r8),intent(out) :: dqeroot ! Local variables - real(r8) :: den_AHR,den1,den2 ! used in calculating HR(Amenu model) - real(r8),dimension(nl_soil-1) :: amx_hr ! "a" left off diagonal of tridiagonal matrix - real(r8),dimension(nl_soil-1) :: bmx_hr ! "b" diagonal column for tridiagonal matrix - real(r8),dimension(nl_soil-1) :: cmx_hr ! "c" right off diagonal tridiagonal matrix - real(r8),dimension(nl_soil-1) :: rmx_hr ! "r" forcing term of tridiagonal matrix - real(r8),dimension(nl_soil-1) :: drmx_hr ! "dr" forcing term of tridiagonal matrix for d/dxroot(1) - real(r8),dimension(nl_soil-1) :: x ! root water potential from layer 2 to nl_soil - real(r8),dimension(nl_soil-1) :: dx ! derivate of root water potential from layer 2 to nl_soil (dxroot(:)/dxroot(1)) - real(r8),dimension(nl_soil) :: xroot ! root water potential from layer 2 to nl_soil - real(r8) :: zmm(1:nl_soil) ! layer depth [mm] - real(r8) :: qeroot_nl(1:nl_soil) ! root water potential from layer 2 to nl_soil - real(r8) :: dxroot2 ! dxroot(2)/dxroot(1) - integer j - - ! Because the depths in this routine are in mm, use local - ! variable arrays instead of pointers - do j = 1, nl_soil - zmm(j) = z_soisno(j)*1000. - end do - - xroot(1) = x_root_top + zmm(1) - ! For the 2nd soil layer - j = 2 - den1 = zmm(j) - zmm(j-1) - den2 = zmm(j+1) - zmm(j) - amx_hr(j-1) = 0 - bmx_hr(j-1) = kax(j-1)/den1 + kax(j)/den2 + krad(j) - cmx_hr(j-1) = -kax(j)/den2 - rmx_hr(j-1) = krad(j)*smp(j) + kax(j-1) - kax(j) + kax(j-1)/den1*xroot(1) - drmx_hr(j-1) = kax(j-1)/den1 - - ! For the middile soil layers - do j = 3, nl_soil - 1 - den1 = zmm(j) - zmm(j-1) - den2 = zmm(j+1) - zmm(j) - amx_hr (j-1) = -kax(j-1)/den1 - bmx_hr (j-1) = kax(j-1)/den1 + kax(j)/den2 + krad(j) - cmx_hr (j-1) = -kax(j)/den2 - rmx_hr (j-1) = krad(j)*smp(j) + kax(j-1) - kax(j) - drmx_hr(j-1) = 0._r8 - end do - - ! For the bottom soil layer - j = nl_soil - den_AHR = zmm(j) - zmm(j-1) - amx_hr (j-1) = -kax(j-1)/den_AHR - bmx_hr (j-1) = kax(j-1)/den_AHR + krad(j) - cmx_hr (j-1) = 0 - rmx_hr (j-1) = krad(j)*smp(j) + kax(j-1) - drmx_hr(j-1) = 0._r8 - - ! Solve for root pressure potential using tridiagonal matric solver x = A^-1 * r - call tridia (nl_soil-1 ,amx_hr ,bmx_hr ,cmx_hr ,rmx_hr ,x) - - do j = 2,nl_soil - xroot(j) = x(j-1) - end do - - ! Solve the dx(:)/dxroot(1) = A^-1 * dr - call tridia (nl_soil-1 ,amx_hr ,bmx_hr ,cmx_hr ,drmx_hr, dx) - - dxroot2 = dx(1) - - ! calculate the water flux - j = 1 - den2 = zmm(j+1) - zmm(j) - qeroot = krad(j) * (smp(1) - xroot(1)) + (xroot(2) - xroot(1)) * kax(j)/den2 - kax(j) - - ! calculate the dqeroot/dx_root_top; - dqeroot = - krad(j) + (dxroot2 - 1) * kax(j)/den2 - do j = 1,nl_soil - qeroot_nl(j) = krad(j)*(smp(j) - xroot(j)) - end do - - end subroutine getrootqflx_x2qe - - subroutine getrootqflx_qe2x(nl_soil,smp,z_soisno,krad,kax,qeroot,xroot,x_root_top) - - USE MOD_Utils - ! DESCRIPTION - ! Return root water potential at top soil node. Return soil-root water flux. - ! - - integer ,intent(in) :: nl_soil - real(r8),intent(in) :: smp (nl_soil) - real(r8),intent(in) :: z_soisno (nl_soil) - real(r8),intent(in) :: krad (nl_soil) - real(r8),intent(in) :: kax (nl_soil) - real(r8),intent(in) :: qeroot - real(r8),intent(out) :: xroot (nl_soil) - real(r8),intent(out) :: x_root_top + real(r8) :: den_AHR,den1,den2 ! used in calculating HR(Amenu model) + real(r8),dimension(nl_soil-1) :: amx_hr ! "a" left off diagonal of tridiagonal matrix + real(r8),dimension(nl_soil-1) :: bmx_hr ! "b" diagonal column for tridiagonal matrix + real(r8),dimension(nl_soil-1) :: cmx_hr ! "c" right off diagonal tridiagonal matrix + real(r8),dimension(nl_soil-1) :: rmx_hr ! "r" forcing term of tridiagonal matrix + real(r8),dimension(nl_soil-1) :: drmx_hr ! "dr" forcing term of tridiagonal matrix for d/dxroot(1) + real(r8),dimension(nl_soil-1) :: x ! root water potential from layer 2 to nl_soil + real(r8),dimension(nl_soil-1) :: dx ! derivate of root water potential from layer 2 to nl_soil (dxroot(:)/dxroot(1)) + real(r8),dimension(nl_soil) :: xroot ! root water potential from layer 2 to nl_soil + real(r8) :: zmm(1:nl_soil) ! layer depth [mm] + real(r8) :: qeroot_nl(1:nl_soil) ! root water potential from layer 2 to nl_soil + real(r8) :: dxroot2 ! dxroot(2)/dxroot(1) + integer j + + ! Because the depths in this routine are in mm, USE local + ! variable arrays instead of pointers + DO j = 1, nl_soil + zmm(j) = z_soisno(j)*1000. + ENDDO + + xroot(1) = x_root_top + zmm(1) + ! For the 2nd soil layer + j = 2 + den1 = zmm(j) - zmm(j-1) + den2 = zmm(j+1) - zmm(j) + amx_hr(j-1) = 0 + bmx_hr(j-1) = kax(j-1)/den1 + kax(j)/den2 + krad(j) + cmx_hr(j-1) = -kax(j)/den2 + rmx_hr(j-1) = krad(j)*smp(j) + kax(j-1) - kax(j) + kax(j-1)/den1*xroot(1) + drmx_hr(j-1) = kax(j-1)/den1 + + ! For the middile soil layers + DO j = 3, nl_soil - 1 + den1 = zmm(j) - zmm(j-1) + den2 = zmm(j+1) - zmm(j) + amx_hr (j-1) = -kax(j-1)/den1 + bmx_hr (j-1) = kax(j-1)/den1 + kax(j)/den2 + krad(j) + cmx_hr (j-1) = -kax(j)/den2 + rmx_hr (j-1) = krad(j)*smp(j) + kax(j-1) - kax(j) + drmx_hr(j-1) = 0._r8 + ENDDO + + ! For the bottom soil layer + j = nl_soil + den_AHR = zmm(j) - zmm(j-1) + amx_hr (j-1) = -kax(j-1)/den_AHR + bmx_hr (j-1) = kax(j-1)/den_AHR + krad(j) + cmx_hr (j-1) = 0 + rmx_hr (j-1) = krad(j)*smp(j) + kax(j-1) + drmx_hr(j-1) = 0._r8 + + ! Solve for root pressure potential using tridiagonal matric solver x = A^-1 * r + CALL tridia (nl_soil-1 ,amx_hr ,bmx_hr ,cmx_hr ,rmx_hr ,x) + + DO j = 2,nl_soil + xroot(j) = x(j-1) + ENDDO + + ! Solve the dx(:)/dxroot(1) = A^-1 * dr + CALL tridia (nl_soil-1 ,amx_hr ,bmx_hr ,cmx_hr ,drmx_hr, dx) + + dxroot2 = dx(1) + + ! calculate the water flux + j = 1 + den2 = zmm(j+1) - zmm(j) + qeroot = krad(j) * (smp(1) - xroot(1)) + (xroot(2) - xroot(1)) * kax(j)/den2 - kax(j) + + ! calculate the dqeroot/dx_root_top; + dqeroot = - krad(j) + (dxroot2 - 1) * kax(j)/den2 + DO j = 1,nl_soil + qeroot_nl(j) = krad(j)*(smp(j) - xroot(j)) + ENDDO + + END SUBROUTINE getrootqflx_x2qe + + SUBROUTINE getrootqflx_qe2x(nl_soil,smp,z_soisno,krad,kax,qeroot,xroot,x_root_top) + + USE MOD_Utils + ! DESCRIPTION + ! Return root water potential at top soil node. Return soil-root water flux. + ! + + integer ,intent(in) :: nl_soil + real(r8),intent(in) :: smp (nl_soil) + real(r8),intent(in) :: z_soisno (nl_soil) + real(r8),intent(in) :: krad (nl_soil) + real(r8),intent(in) :: kax (nl_soil) + real(r8),intent(in) :: qeroot + real(r8),intent(out) :: xroot (nl_soil) + real(r8),intent(out) :: x_root_top ! Local variables - real(r8) :: den_AHR,den1,den2 ! used in calculating HR(Amenu model) - real(r8),dimension(nl_soil) :: amx_hr ! "a" left off diagonal of tridiagonal matrix - real(r8),dimension(nl_soil) :: bmx_hr ! "b" diagonal column for tridiagonal matrix - real(r8),dimension(nl_soil) :: cmx_hr ! "c" right off diagonal tridiagonal matrix - real(r8),dimension(nl_soil) :: rmx_hr ! "r" forcing term of tridiagonal matrix - real(r8),dimension(nl_soil) :: x ! root water potential from layer 2 to nl_soil - real(r8) :: zmm(1:nl_soil) ! layer depth [mm] - real(r8) :: qeroot_nl(1:nl_soil) ! root water potential from layer 2 to nl_soil - integer j - - ! Because the depths in this routine are in mm, use local - ! variable arrays instead of pointers - do j = 1, nl_soil - zmm(j) = z_soisno(j)*1000. - end do - - j = 1 - den2 = zmm(j+1) - zmm(j) - amx_hr(j) = 0 - bmx_hr(j) = kax(j)/den2 + krad(j) - cmx_hr(j) = -kax(j)/den2 - rmx_hr(j) = krad(j)*smp(j) - qeroot - kax(j) - - ! For the middile soil layers - do j = 2, nl_soil - 1 - den1 = zmm(j) - zmm(j-1) - den2 = zmm(j+1) - zmm(j) - amx_hr(j) = -kax(j-1)/den1 - bmx_hr(j) = kax(j-1)/den1 + kax(j)/den2 + krad(j) + real(r8) :: den_AHR,den1,den2 ! used in calculating HR(Amenu model) + real(r8),dimension(nl_soil) :: amx_hr ! "a" left off diagonal of tridiagonal matrix + real(r8),dimension(nl_soil) :: bmx_hr ! "b" diagonal column for tridiagonal matrix + real(r8),dimension(nl_soil) :: cmx_hr ! "c" right off diagonal tridiagonal matrix + real(r8),dimension(nl_soil) :: rmx_hr ! "r" forcing term of tridiagonal matrix + real(r8),dimension(nl_soil) :: x ! root water potential from layer 2 to nl_soil + real(r8) :: zmm(1:nl_soil) ! layer depth [mm] + real(r8) :: qeroot_nl(1:nl_soil) ! root water potential from layer 2 to nl_soil + integer j + + ! Because the depths in this routine are in mm, USE local + ! variable arrays instead of pointers + DO j = 1, nl_soil + zmm(j) = z_soisno(j)*1000. + ENDDO + + j = 1 + den2 = zmm(j+1) - zmm(j) + amx_hr(j) = 0 + bmx_hr(j) = kax(j)/den2 + krad(j) cmx_hr(j) = -kax(j)/den2 - rmx_hr(j) = krad(j)*smp(j) + kax(j-1) - kax(j) - end do - - ! For the bottom soil layer - j = nl_soil - den_AHR = zmm(j) - zmm(j-1) - amx_hr(j) = -kax(j-1)/den_AHR - bmx_hr(j) = kax(j-1)/den_AHR + krad(j) - cmx_hr(j) = 0 - rmx_hr(j) = krad(j)*smp(j) + kax(j-1) - - ! Solve for root pressure potential using tridiagonal matric solver - call tridia (nl_soil ,amx_hr ,bmx_hr ,cmx_hr ,rmx_hr ,x) - - xroot(1:nl_soil) = x(1:nl_soil) - x_root_top = xroot(1) - zmm(1) - - end subroutine getrootqflx_qe2x - - !-------------------------------------------------------------------------------- - function plc(x,psi50,ck) - ! !DESCRIPTION - ! Return value of vulnerability curve at x - ! - ! !ARGUMENTS - real(r8) , intent(in) :: x ! water potential input -! integer , intent(in) :: level ! veg segment lvl (1:nvegwcs) -! integer , intent(in) :: plc_method ! - real(r8) , intent(in) :: psi50 ! water potential at 50% loss of sunlit leaf tissue conductance (mmH2O) -! real(r8) , intent(in) :: psi50_sun ! water potential at 50% loss of sunlit leaf tissue conductance (mmH2O) -! real(r8) , intent(in) :: psi50_sha ! water potential at 50% loss of shaded leaf tissue conductance (mmH2O) -! real(r8) , intent(in) :: psi50_xyl ! water potential at 50% loss of xylem tissue conductance (mmH2O) -! real(r8) , intent(in) :: psi50_root ! water potential at 50% loss of root tissue conductance (mmH2O) - real(r8) , intent(in) :: ck - real(r8) :: plc ! attenuated conductance [0:1] 0=no flow - ! - ! !PARAMETERS -! integer , parameter :: vegetation_weibull=0 ! case number -! integer , parameter :: leafsun = 1 ! index for sunlit leaf -! integer , parameter :: leafsha = 2 ! index for shaded leaf -! integer , parameter :: xyl = 3 ! index for xylem -! integer , parameter :: root = 4 ! index for root - - ! !LOCAL VARIABLES - !real(r8) psi50,tmp - real(r8) tmp - integer i + rmx_hr(j) = krad(j)*smp(j) - qeroot - kax(j) + + ! For the middile soil layers + DO j = 2, nl_soil - 1 + den1 = zmm(j) - zmm(j-1) + den2 = zmm(j+1) - zmm(j) + amx_hr(j) = -kax(j-1)/den1 + bmx_hr(j) = kax(j-1)/den1 + kax(j)/den2 + krad(j) + cmx_hr(j) = -kax(j)/den2 + rmx_hr(j) = krad(j)*smp(j) + kax(j-1) - kax(j) + ENDDO + + ! For the bottom soil layer + j = nl_soil + den_AHR = zmm(j) - zmm(j-1) + amx_hr(j) = -kax(j-1)/den_AHR + bmx_hr(j) = kax(j-1)/den_AHR + krad(j) + cmx_hr(j) = 0 + rmx_hr(j) = krad(j)*smp(j) + kax(j-1) + + ! Solve for root pressure potential using tridiagonal matric solver + CALL tridia (nl_soil ,amx_hr ,bmx_hr ,cmx_hr ,rmx_hr ,x) + + xroot(1:nl_soil) = x(1:nl_soil) + x_root_top = xroot(1) - zmm(1) + + END SUBROUTINE getrootqflx_qe2x + + !-------------------------------------------------------------------------------- + FUNCTION plc(x,psi50,ck) + ! !DESCRIPTION + ! Return value of vulnerability curve at x + ! + ! !ARGUMENTS + real(r8) , intent(in) :: x ! water potential input +! integer , intent(in) :: level ! veg segment lvl (1:nvegwcs) +! integer , intent(in) :: plc_method ! + real(r8) , intent(in) :: psi50 ! water potential at 50% loss of sunlit leaf tissue conductance (mmH2O) +! real(r8) , intent(in) :: psi50_sun ! water potential at 50% loss of sunlit leaf tissue conductance (mmH2O) +! real(r8) , intent(in) :: psi50_sha ! water potential at 50% loss of shaded leaf tissue conductance (mmH2O) +! real(r8) , intent(in) :: psi50_xyl ! water potential at 50% loss of xylem tissue conductance (mmH2O) +! real(r8) , intent(in) :: psi50_root ! water potential at 50% loss of root tissue conductance (mmH2O) + real(r8) , intent(in) :: ck + real(r8) :: plc ! attenuated conductance [0:1] 0=no flow + ! + ! !PARAMETERS +! integer , parameter :: vegetation_weibull=0 ! case number +! integer , parameter :: leafsun = 1 ! index for sunlit leaf +! integer , parameter :: leafsha = 2 ! index for shaded leaf +! integer , parameter :: xyl = 3 ! index for xylem +! integer , parameter :: root = 4 ! index for root + + ! !LOCAL VARIABLES + !real(r8) psi50,tmp + real(r8) tmp + integer i !------------------------------------------------------------------------------ -! select case(level) -! case (leafsun) +! select CASE(level) +! CASE (leafsun) ! psi50 = psi50_sun -! case (leafsha) +! CASE (leafsha) ! psi50 = psi50_sha -! case (xyl) +! CASE (xyl) ! psi50 = psi50_xyl -! case (root) +! CASE (root) ! psi50 = psi50_root -! case default +! CASE default ! write(*,*),'must choose level from 1 to 4 (sunlit leaf to root)' -! end select +! END select -! select case (plc_method) +! select CASE (plc_method) !possible to add other methods later -! case (vegetation_weibull) - tmp = amax1(-(x/psi50)**ck,-500._r8) -! if(tmp .lt. -500._r8)then +! CASE (vegetation_weibull) + tmp = amax1(-(x/psi50)**ck,-500._r8) +! IF(tmp .lt. -500._r8)THEN ! plc = 0._r8 -! else - plc=2._r8**tmp -! end if - if ( plc < 0.00001_r8) plc = 1.e-5_r8 -! case default +! ELSE + plc=2._r8**tmp +! ENDIF + IF ( plc < 0.00001_r8) plc = 1.e-5_r8 +! CASE default ! write(*,*),'must choose plc method' -! end select - - end function plc - !-------------------------------------------------------------------------------- - - !-------------------------------------------------------------------------------- - function d1plc(x,psi50,ck) - ! !DESCRIPTION - ! Return 1st derivative of vulnerability curve at x - ! - ! !ARGUMENTS - real(r8) , intent(in) :: x ! water potential input -! integer , intent(in) :: level ! veg segment lvl (1:nvegwcs) -! integer , intent(in) :: plc_method ! 0 for vegetation, 1 for soil - real(r8) , intent(in) :: psi50 ! water potential at 50% loss of sunlit leaf tissue conductance (mmH2O) -! real(r8) , intent(in) :: psi50_sun ! water potential at 50% loss of sunlit leaf tissue conductance (mmH2O) -! real(r8) , intent(in) :: psi50_sha ! water potential at 50% loss of shaded leaf tissue conductance (mmH2O) -! real(r8) , intent(in) :: psi50_xyl ! water potential at 50% loss of xylem tissue conductance (mmH2O) -! real(r8) , intent(in) :: psi50_root ! water potential at 50% loss of root tissue conductance (mmH2O) - real(r8) , intent(in) :: ck - real(r8) :: d1plc ! first deriv of plc curve at x - ! - ! !PARAMETERS -! integer , parameter :: vegetation_weibull=0 ! case number -! integer , parameter :: leafsun = 1 ! index for sunlit leaf -! integer , parameter :: leafsha = 2 ! index for shaded leaf -! integer , parameter :: xyl = 3 ! index for xylem -! integer , parameter :: root = 4 ! index for root - - ! !LOCAL VARIABLES -! real(r8) psi50,tmp - real(r8) tmp - !------------------------------------------------------------------------------ -! select case(level) -! case (leafsun) -! psi50 = psi50_sun -! case (leafsha) -! psi50 = psi50_sha -! case (xyl) -! psi50 = psi50_xyl -! case (root) -! psi50 = psi50_root -! case default -! write(*,*),'must choose level from 1 to 4 (sunlit leaf to root)' -! end select - -! select case (plc_method) - !possible to add other methods later -! case (vegetation_weibull) - tmp = amax1(-(x/psi50)**ck,-500._r8) -! if(tmp .lt. -500._r8)then -! d1plc = 0._r8 -! else - d1plc= ck * log(2._r8) * (2._r8**tmp) * tmp / x -! end if -! case default -! write(*,*),'must choose plc method' -! end select - - end function d1plc +! END select + + END FUNCTION plc + !-------------------------------------------------------------------------------- + + !-------------------------------------------------------------------------------- + FUNCTION d1plc(x,psi50,ck) + ! !DESCRIPTION + ! Return 1st derivative of vulnerability curve at x + ! + ! !ARGUMENTS + real(r8) , intent(in) :: x ! water potential input +! integer , intent(in) :: level ! veg segment lvl (1:nvegwcs) +! integer , intent(in) :: plc_method ! 0 for vegetation, 1 for soil + real(r8) , intent(in) :: psi50 ! water potential at 50% loss of sunlit leaf tissue conductance (mmH2O) +! real(r8) , intent(in) :: psi50_sun ! water potential at 50% loss of sunlit leaf tissue conductance (mmH2O) +! real(r8) , intent(in) :: psi50_sha ! water potential at 50% loss of shaded leaf tissue conductance (mmH2O) +! real(r8) , intent(in) :: psi50_xyl ! water potential at 50% loss of xylem tissue conductance (mmH2O) +! real(r8) , intent(in) :: psi50_root ! water potential at 50% loss of root tissue conductance (mmH2O) + real(r8) , intent(in) :: ck + real(r8) :: d1plc ! first deriv of plc curve at x + ! + ! !PARAMETERS +! integer , parameter :: vegetation_weibull=0 ! CASE number +! integer , parameter :: leafsun = 1 ! index for sunlit leaf +! integer , parameter :: leafsha = 2 ! index for shaded leaf +! integer , parameter :: xyl = 3 ! index for xylem +! integer , parameter :: root = 4 ! index for root + + ! !LOCAL VARIABLES +! real(r8) psi50,tmp + real(r8) tmp + !------------------------------------------------------------------------------ +! select CASE(level) +! CASE (leafsun) +! psi50 = psi50_sun +! CASE (leafsha) +! psi50 = psi50_sha +! CASE (xyl) +! psi50 = psi50_xyl +! CASE (root) +! psi50 = psi50_root +! CASE default +! write(*,*),'must choose level from 1 to 4 (sunlit leaf to root)' +! END select + +! select CASE (plc_method) + !possible to add other methods later +! CASE (vegetation_weibull) + tmp = amax1(-(x/psi50)**ck,-500._r8) +! IF(tmp .lt. -500._r8)THEN +! d1plc = 0._r8 +! ELSE + d1plc= ck * log(2._r8) * (2._r8**tmp) * tmp / x +! ENDIF +! CASE default +! write(*,*),'must choose plc method' +! END select + + END FUNCTION d1plc END MODULE MOD_PlantHydraulic diff --git a/main/MOD_Qsadv.F90 b/main/MOD_Qsadv.F90 index 344146e5..ea55797d 100644 --- a/main/MOD_Qsadv.F90 +++ b/main/MOD_Qsadv.F90 @@ -11,7 +11,7 @@ MODULE MOD_Qsadv !----------------------------------------------------------------------- - CONTAINS +CONTAINS !----------------------------------------------------------------------- @@ -33,74 +33,74 @@ SUBROUTINE qsadv(T,p,es,esdT,qs,qsdT) IMPLICIT NONE ! dummy arguments - REAL(r8), intent(in) :: T ! temperature (K) - REAL(r8), intent(in) :: p ! surface atmospheric pressure (pa) + real(r8), intent(in) :: T ! temperature (K) + real(r8), intent(in) :: p ! surface atmospheric pressure (pa) - REAL(r8), intent(out) :: es ! vapor pressure (pa) - REAL(r8), intent(out) :: esdT ! d(es)/d(T) - REAL(r8), intent(out) :: qs ! humidity (kg/kg) - REAL(r8), intent(out) :: qsdT ! d(qs)/d(T) + real(r8), intent(out) :: es ! vapor pressure (pa) + real(r8), intent(out) :: esdT ! d(es)/d(T) + real(r8), intent(out) :: qs ! humidity (kg/kg) + real(r8), intent(out) :: qsdT ! d(qs)/d(T) ! local - REAL(r8) td,vp,vp1,vp2 - REAL(r8) a0,a1,a2,a3,a4,a5,a6,a7,a8 - REAL(r8) b0,b1,b2,b3,b4,b5,b6,b7,b8 + real(r8) td,vp,vp1,vp2 + real(r8) a0,a1,a2,a3,a4,a5,a6,a7,a8 + real(r8) b0,b1,b2,b3,b4,b5,b6,b7,b8 - REAL(r8) c0,c1,c2,c3,c4,c5,c6,c7,c8 - REAL(r8) d0,d1,d2,d3,d4,d5,d6,d7,d8 + real(r8) c0,c1,c2,c3,c4,c5,c6,c7,c8 + real(r8) d0,d1,d2,d3,d4,d5,d6,d7,d8 ! for water vapor (temperature range 0C-100C) - data a0/6.11213476 /,a1/ 0.444007856 /,a2/0.143064234e-01/ & - ,a3/0.264461437e-03/,a4/ 0.305903558e-05/,a5/0.196237241e-07/ & - ,a6/0.892344772e-10/,a7/-0.373208410e-12/,a8/0.209339997e-15/ + data a0/6.11213476 /,a1/ 0.444007856 /,a2/0.143064234e-01/ & + ,a3/0.264461437e-03/,a4/ 0.305903558e-05/,a5/0.196237241e-07/ & + ,a6/0.892344772e-10/,a7/-0.373208410e-12/,a8/0.209339997e-15/ ! for derivative:water vapor - data b0/0.444017302 /,b1/ 0.286064092e-01/,b2/ 0.794683137e-03/ & - ,b3/ 0.121211669e-04/,b4/ 0.103354611e-06/,b5/ 0.404125005e-09/ & - ,b6/-0.788037859e-12/,b7/-0.114596802e-13/,b8/ 0.381294516e-16/ + data b0/0.444017302 /,b1/ 0.286064092e-01/,b2/ 0.794683137e-03/ & + ,b3/ 0.121211669e-04/,b4/ 0.103354611e-06/,b5/ 0.404125005e-09/ & + ,b6/-0.788037859e-12/,b7/-0.114596802e-13/,b8/ 0.381294516e-16/ ! for ice (temperature range -75C-0C) - data c0/6.11123516 /,c1/0.503109514 /,c2/0.188369801e-01/ & - ,c3/0.420547422e-03/,c4/0.614396778e-05/,c5/0.602780717e-07/ & - ,c6/0.387940929e-09/,c7/0.149436277e-11/,c8/0.262655803e-14/ + data c0/6.11123516 /,c1/0.503109514 /,c2/0.188369801e-01/ & + ,c3/0.420547422e-03/,c4/0.614396778e-05/,c5/0.602780717e-07/ & + ,c6/0.387940929e-09/,c7/0.149436277e-11/,c8/0.262655803e-14/ ! for derivative:ice - data d0/0.503277922 /,d1/0.377289173e-01/,d2/0.126801703e-02/ & - ,d3/0.249468427e-04/,d4/0.313703411e-06/,d5/0.257180651e-08/ & - ,d6/0.133268878e-10/,d7/0.394116744e-13/,d8/0.498070196e-16/ + data d0/0.503277922 /,d1/0.377289173e-01/,d2/0.126801703e-02/ & + ,d3/0.249468427e-04/,d4/0.313703411e-06/,d5/0.257180651e-08/ & + ,d6/0.133268878e-10/,d7/0.394116744e-13/,d8/0.498070196e-16/ !======================================================================= - td = T-273.16 + td = T-273.16 -! IF (td < -75.0 .or. td > 75.0) THEN +! IF (td < -75.0 .or. td > 75.0) THEN !* print *, "qsadv: abnormal temperature", T -! ENDIF - - IF (td < -75.0) td = -75.0 - IF (td > 75.0) td = 75.0 - - IF (td >= 0.0)THEN - es = a0 + td*(a1 + td*(a2 + td*(a3 + td*(a4 & - + td*(a5 + td*(a6 + td*(a7 + td*a8))))))) - esdT = b0 + td*(b1 + td*(b2 + td*(b3 + td*(b4 & - + td*(b5 + td*(b6 + td*(b7 + td*b8))))))) - ELSE - es = c0 + td*(c1 + td*(c2 + td*(c3 + td*(c4 & - + td*(c5 + td*(c6 + td*(c7 + td*c8))))))) - esdT = d0 + td*(d1 + td*(d2 + td*(d3 + td*(d4 & - + td*(d5 + td*(d6 + td*(d7 + td*d8))))))) - ENDIF - - es = es * 100. ! pa - esdT = esdT * 100. ! pa/K - - vp = 1.0 / (p - 0.378*es) - vp1 = 0.622 * vp - vp2 = vp1 * vp - - qs = es * vp1 ! kg/kg - qsdT = esdT * vp2 * p ! 1 / K +! ENDIF + + IF (td < -75.0) td = -75.0 + IF (td > 75.0) td = 75.0 + + IF (td >= 0.0)THEN + es = a0 + td*(a1 + td*(a2 + td*(a3 + td*(a4 & + + td*(a5 + td*(a6 + td*(a7 + td*a8))))))) + esdT = b0 + td*(b1 + td*(b2 + td*(b3 + td*(b4 & + + td*(b5 + td*(b6 + td*(b7 + td*b8))))))) + ELSE + es = c0 + td*(c1 + td*(c2 + td*(c3 + td*(c4 & + + td*(c5 + td*(c6 + td*(c7 + td*c8))))))) + esdT = d0 + td*(d1 + td*(d2 + td*(d3 + td*(d4 & + + td*(d5 + td*(d6 + td*(d7 + td*d8))))))) + ENDIF + + es = es * 100. ! pa + esdT = esdT * 100. ! pa/K + + vp = 1.0 / (p - 0.378*es) + vp1 = 0.622 * vp + vp2 = vp1 * vp + + qs = es * vp1 ! kg/kg + qsdT = esdT * vp2 * p ! 1 / K END SUBROUTINE qsadv diff --git a/main/MOD_RainSnowTemp.F90 b/main/MOD_RainSnowTemp.F90 index 6520d4a4..b77e5cac 100644 --- a/main/MOD_RainSnowTemp.F90 +++ b/main/MOD_RainSnowTemp.F90 @@ -14,7 +14,7 @@ MODULE MOD_RainSnowTemp !----------------------------------------------------------------------- - CONTAINS +CONTAINS !----------------------------------------------------------------------- @@ -28,32 +28,32 @@ SUBROUTINE rain_snow_temp (patchtype,& ! Original author : Yongjiu Dai, 09/1999; 08/31/2002, 04/2014, 01/2023 !======================================================================= ! - use MOD_Precision - use MOD_Const_Physical, only : tfrz + USE MOD_Precision + USE MOD_Const_Physical, only : tfrz USE MOD_WetBulb IMPLICIT NONE ! ------------------------ Dummy Argument ------------------------------ - integer, INTENT(in) :: patchtype ! land patch type (3=glaciers) + integer, intent(in) :: patchtype ! land patch type (3=glaciers) - real(r8), INTENT(in) :: forc_t ! temperature at agcm reference height [kelvin] - real(r8), INTENT(in) :: forc_q ! specific humidity at agcm reference height [kg/kg] - real(r8), INTENT(in) :: forc_psrf ! atmosphere pressure at the surface [pa] - real(r8), INTENT(in) :: forc_prc ! convective precipitation [mm/s] - real(r8), INTENT(in) :: forc_prl ! large scale precipitation [mm/s] - real(r8), INTENT(in) :: forc_us ! wind speed in eastward direction [m/s] - real(r8), INTENT(in) :: forc_vs ! wind speed in northward direction [m/s] + real(r8), intent(in) :: forc_t ! temperature at agcm reference height [kelvin] + real(r8), intent(in) :: forc_q ! specific humidity at agcm reference height [kg/kg] + real(r8), intent(in) :: forc_psrf ! atmosphere pressure at the surface [pa] + real(r8), intent(in) :: forc_prc ! convective precipitation [mm/s] + real(r8), intent(in) :: forc_prl ! large scale precipitation [mm/s] + real(r8), intent(in) :: forc_us ! wind speed in eastward direction [m/s] + real(r8), intent(in) :: forc_vs ! wind speed in northward direction [m/s] - real(r8), INTENT(in) :: tcrit ! critical temp. to determine rain or snow + real(r8), intent(in) :: tcrit ! critical temp. to determine rain or snow - real(r8), INTENT(out) :: prc_rain ! convective rainfall [kg/(m2 s)] - real(r8), INTENT(out) :: prc_snow ! convective snowfall [kg/(m2 s)] - real(r8), INTENT(out) :: prl_rain ! large scale rainfall [kg/(m2 s)] - real(r8), INTENT(out) :: prl_snow ! large scale snowfall [kg/(m2 s)] - real(r8), INTENT(out) :: t_precip ! snowfall/rainfall temperature [kelvin] - real(r8), INTENT(out) :: bifall ! bulk density of newly fallen dry snow [kg/m3] + real(r8), intent(out) :: prc_rain ! convective rainfall [kg/(m2 s)] + real(r8), intent(out) :: prc_snow ! convective snowfall [kg/(m2 s)] + real(r8), intent(out) :: prl_rain ! large scale rainfall [kg/(m2 s)] + real(r8), intent(out) :: prl_snow ! large scale snowfall [kg/(m2 s)] + real(r8), intent(out) :: t_precip ! snowfall/rainfall temperature [kelvin] + real(r8), intent(out) :: bifall ! bulk density of newly fallen dry snow [kg/m3] real(r8) :: flfall ! fraction of liquid water within falling precip. real(r8) :: all_snow_t ! temperature at which all precip falls entirely as snow (K) @@ -62,100 +62,100 @@ SUBROUTINE rain_snow_temp (patchtype,& real(r8) :: all_rain_t_c ! Temperature at which precip falls entirely as snow (deg C) logical :: glaciers ! true: glacier column - real(r8) :: t_for_bifall_degC ! temperature to use in bifall equation (deg C) + real(r8) :: t_for_bifall_degC ! temperature to USE in bifall equation (deg C) real(r8) :: forc_wind ! wind speed [m/s] real(r8) :: t_hydro ! temperature of falling hydrometeor [deg C] !----------------------------------------------------------------------- ! wet-bulb temperature - call wetbulb(forc_t,forc_psrf,forc_q,t_precip) + CALL wetbulb(forc_t,forc_psrf,forc_q,t_precip) + + IF (trim(DEF_precip_phase_discrimination_scheme) == 'I') THEN + ! Wang, Y.H., Broxton, P., Fang, Y., Behrangi, A., Barlage, M., Zeng, X., & Niu, G.Y. (2019). + ! A Wet-Bulb Temperature Based Rain-Snow Partitioning Scheme Improves Snowpack Prediction + ! Over the Drier Western United States. Geophysical Research Letters, 46, 13,825-13,835. + ! + ! Behrangi et al. (2018) On distinguishing snowfall from rainfall + ! using near-surface atmospheric information: Comparative analysis, + ! uncertainties and hydrologic importance. Q J R Meteorol Soc. 144 (Suppl. 1):89-102 + + IF(t_precip - tfrz > 3.0)THEN + flfall = 1.0 ! fraction of liquid water within falling precip + ELSE IF (t_precip - tfrz >= -2.0)THEN + flfall = max(0.0, 1.0 - 1.0/(1.0+5.00e-5*exp(2.0*(t_precip-tfrz+4.)))) !Figure 5c of Behrangi et al. (2018) + !* flfall = max(0.0, 1.0 - 1.0/(1.0+6.99e-5*exp(2.0*(t_precip-tfrz+3.97)))) !Equation 1 of Wang et al. (2019) + ELSE + flfall = 0.0 + ENDIF + + ELSEIF (trim(DEF_precip_phase_discrimination_scheme) == 'II') THEN + glaciers = .false. + IF (patchtype == 3) glaciers = .true. + + IF(glaciers) THEN + all_snow_t_c = -2.0 + all_rain_t_c = 0.0 + ELSE + all_snow_t_c = 0.0 + all_rain_t_c = 2.0 + ENDIF + + all_snow_t = all_snow_t_c + tfrz + frac_rain_slope = 1._r8 / (all_rain_t_c - all_snow_t_c) + + ! Re-partition precipitation into rain/snow for a single column. + ! Rain and snow variables should be set initially, and are updated here + + flfall = min(1.0_r8, max(0.0_r8,(forc_t - all_snow_t)*frac_rain_slope)) + ELSEIF (trim(DEF_precip_phase_discrimination_scheme) == 'III') THEN + ! Phillip Harder and John Pomeroy (2013) + ! Estimating precipitation phase using a psychrometric energy + ! balance method . Hydrol Process, 27, 1901–1914 + ! Hydromet_Temp [K] + CALL Hydromet_Temp(forc_psrf,(forc_t-273.15),forc_q,t_hydro) + + IF(t_hydro > 3.0)THEN + flfall = 1.0 ! fraction of liquid water within falling precip + ELSE IF ((t_hydro >= -3.0).and.(t_hydro <= 3.0))THEN + flfall = max(0.0, 1.0/(1.0+2.50286*0.125006**t_hydro)) + ELSE + flfall = 0.0 + ENDIF - IF (trim(DEF_precip_phase_discrimination_scheme) == 'I') THEN - ! Wang, Y.H., Broxton, P., Fang, Y., Behrangi, A., Barlage, M., Zeng, X., & Niu, G.Y. (2019). - ! A Wet-Bulb Temperature Based Rain-Snow Partitioning Scheme Improves Snowpack Prediction - ! Over the Drier Western United States. Geophysical Research Letters, 46, 13,825-13,835. - ! - ! Behrangi et al. (2018) On distinguishing snowfall from rainfall - ! using near-surface atmospheric information: Comparative analysis, - ! uncertainties and hydrologic importance. Q J R Meteorol Soc. 144 (Suppl. 1):89-102 - - if(t_precip - tfrz > 3.0)then - flfall = 1.0 ! fraction of liquid water within falling precip - else if (t_precip - tfrz >= -2.0)then - flfall = max(0.0, 1.0 - 1.0/(1.0+5.00e-5*exp(2.0*(t_precip-tfrz+4.)))) !Figure 5c of Behrangi et al. (2018) - !* flfall = max(0.0, 1.0 - 1.0/(1.0+6.99e-5*exp(2.0*(t_precip-tfrz+3.97)))) !Equation 1 of Wang et al. (2019) - else - flfall = 0.0 - endif - - ELSEIF (trim(DEF_precip_phase_discrimination_scheme) == 'II') THEN - glaciers = .false. - if (patchtype == 3) glaciers = .true. - - if(glaciers) then - all_snow_t_c = -2.0 - all_rain_t_c = 0.0 - else - all_snow_t_c = 0.0 - all_rain_t_c = 2.0 - endif - - all_snow_t = all_snow_t_c + tfrz - frac_rain_slope = 1._r8 / (all_rain_t_c - all_snow_t_c) - - ! Re-partition precipitation into rain/snow for a single column. - ! Rain and snow variables should be set initially, and are updated here - - flfall = min(1.0_r8, max(0.0_r8,(forc_t - all_snow_t)*frac_rain_slope)) - ELSEIF (trim(DEF_precip_phase_discrimination_scheme) == 'III') THEN - ! Phillip Harder and John Pomeroy (2013) - ! Estimating precipitation phase using a psychrometric energy - ! balance method . Hydrol Process, 27, 1901–1914 - ! Hydromet_Temp [K] - CALL Hydromet_Temp(forc_psrf,(forc_t-273.15),forc_q,t_hydro) - - if(t_hydro > 3.0)then - flfall = 1.0 ! fraction of liquid water within falling precip - else if ((t_hydro >= -3.0).and.(t_hydro <= 3.0))then - flfall = max(0.0, 1.0/(1.0+2.50286*0.125006**t_hydro)) - else - flfall = 0.0 - endif - - ELSE - ! the upper limit of air temperature is set for snowfall, this cut-off - ! was selected based on Fig. 1, Plate 3-1, of Snow Hydrology (1956). - ! the percentage of liquid water by mass, which is arbitrarily set to - ! vary linearly with air temp, from 0% at 273.16 to 40% max at 275.16. - - if(forc_t>tfrz+2.0)then - flfall = 1.0 ! fraction of liquid water within falling precip. - else - flfall = max(0.0, -54.632+0.2*forc_t) - end if - - ENDIF - - ! new scheme for "bifall" from CLM5.0 - CALL NewSnowBulkDensity(forc_t,forc_us,forc_vs,bifall) - - prc_rain = forc_prc*flfall ! convective rainfall (mm/s) - prl_rain = forc_prl*flfall ! large scale rainfall (mm/s) - prc_snow = forc_prc*(1.-flfall) ! convective snowfall (mm/s) - prl_snow = forc_prl*(1.-flfall) ! large scale snowfall (mm/s) - - ! ------------------------------------------------------------- - ! temperature of rainfall or snowfall - ! ------------------------------------------------------------- - - if (forc_t > 275.65) then - if (t_precip < tfrz) t_precip = tfrz - else - t_precip = min(tfrz,t_precip) - if(flfall > 1.e-6)then - t_precip = tfrz - sqrt((1.0/flfall)-1.0)/100.0 - endif - endif + ELSE + ! the upper limit of air temperature is set for snowfall, this cut-off + ! was selected based on Fig. 1, Plate 3-1, of Snow Hydrology (1956). + ! the percentage of liquid water by mass, which is arbitrarily set to + ! vary linearly with air temp, from 0% at 273.16 to 40% max at 275.16. + + IF(forc_t>tfrz+2.0)THEN + flfall = 1.0 ! fraction of liquid water within falling precip. + ELSE + flfall = max(0.0, -54.632+0.2*forc_t) + ENDIF + + ENDIF + + ! new scheme for "bifall" from CLM5.0 + CALL NewSnowBulkDensity(forc_t,forc_us,forc_vs,bifall) + + prc_rain = forc_prc*flfall ! convective rainfall (mm/s) + prl_rain = forc_prl*flfall ! large scale rainfall (mm/s) + prc_snow = forc_prc*(1.-flfall) ! convective snowfall (mm/s) + prl_snow = forc_prl*(1.-flfall) ! large scale snowfall (mm/s) + + ! ------------------------------------------------------------- + ! temperature of rainfall or snowfall + ! ------------------------------------------------------------- + + IF (forc_t > 275.65) THEN + IF (t_precip < tfrz) t_precip = tfrz + ELSE + t_precip = min(tfrz,t_precip) + IF(flfall > 1.e-6)THEN + t_precip = tfrz - sqrt((1.0/flfall)-1.0)/100.0 + ENDIF + ENDIF END SUBROUTINE rain_snow_temp @@ -165,44 +165,44 @@ SUBROUTINE NewSnowBulkDensity(forc_t,forc_us,forc_vs,bifall) ! Scheme for bulk density of newly fallen dry snow !======================================================================= ! - use MOD_Precision - use MOD_Const_Physical, only : tfrz + USE MOD_Precision + USE MOD_Const_Physical, only : tfrz - real(r8), INTENT(in) :: forc_t ! temperature at agcm reference height [kelvin] - real(r8), INTENT(in) :: forc_us ! wind speed in eastward direction [m/s] - real(r8), INTENT(in) :: forc_vs ! wind speed in northward direction [m/s] + real(r8), intent(in) :: forc_t ! temperature at agcm reference height [kelvin] + real(r8), intent(in) :: forc_us ! wind speed in eastward direction [m/s] + real(r8), intent(in) :: forc_vs ! wind speed in northward direction [m/s] - real(r8), INTENT(out) :: bifall ! bulk density of newly fallen dry snow [kg/m3] + real(r8), intent(out) :: bifall ! bulk density of newly fallen dry snow [kg/m3] - real(r8) :: t_for_bifall_degC ! temperature to use in bifall equation (deg C) + real(r8) :: t_for_bifall_degC ! temperature to USE in bifall equation (deg C) real(r8) :: forc_wind ! wind speed [m/s] !----------------------------------------------------------------------- - if (forc_t > tfrz + 2.0) then - bifall = 50.0 + 1.7*(17.0)**1.5 - else if (forc_t > tfrz - 15.0) then - bifall = 50.0 + 1.7*(forc_t - tfrz + 15.0)**1.5 - else - ! Andrew Slater: A temp of about -15C gives the nicest - ! "blower" powder, but as you get colder the flake size decreases so - ! density goes up. e.g. the smaller snow crystals from the Arctic and Antarctic winters - if (forc_t > tfrz - 57.55) then - t_for_bifall_degC = (forc_t-tfrz) - else - ! Below -57.55 deg C, the following function starts to decrease with - ! decreasing temperatures. Limit the function to avoid this turning over. - t_for_bifall_degC = -57.55 - end if - bifall = -(50.0/15.0 + 0.0333*15.0)*t_for_bifall_degC - 0.0333*t_for_bifall_degC**2 - end if - - forc_wind = sqrt(forc_us**2 + forc_vs**2) - if (forc_wind > 0.1) then - ! Density offset for wind-driven compaction, initial ideas based on Liston et. al (2007) J. Glaciology, - ! 53(181), 241-255. Modified for a continuous wind impact and slightly more sensitive to wind - Andrew Slater, 2016 - bifall = bifall + (266.861 * ((1.0 + TANH(forc_wind/5.0))/2.0)**8.8) - end if + IF (forc_t > tfrz + 2.0) THEN + bifall = 50.0 + 1.7*(17.0)**1.5 + ELSE IF (forc_t > tfrz - 15.0) THEN + bifall = 50.0 + 1.7*(forc_t - tfrz + 15.0)**1.5 + ELSE + ! Andrew Slater: A temp of about -15C gives the nicest + ! "blower" powder, but as you get colder the flake size decreases so + ! density goes up. e.g. the smaller snow crystals from the Arctic and Antarctic winters + IF (forc_t > tfrz - 57.55) THEN + t_for_bifall_degC = (forc_t-tfrz) + ELSE + ! Below -57.55 deg C, the following function starts to decrease with + ! decreasing temperatures. Limit the function to avoid this turning over. + t_for_bifall_degC = -57.55 + ENDIF + bifall = -(50.0/15.0 + 0.0333*15.0)*t_for_bifall_degC - 0.0333*t_for_bifall_degC**2 + ENDIF + + forc_wind = sqrt(forc_us**2 + forc_vs**2) + IF (forc_wind > 0.1) THEN + ! Density offset for wind-driven compaction, initial ideas based on Liston et. al (2007) J. Glaciology, + ! 53(181), 241-255. Modified for a continuous wind impact and slightly more sensitive to wind - Andrew Slater, 2016 + bifall = bifall + (266.861 * ((1.0 + TANH(forc_wind/5.0))/2.0)**8.8) + ENDIF END SUBROUTINE NewSnowBulkDensity @@ -227,10 +227,10 @@ SUBROUTINE HYDROMET_TEMP(PPA, PTA, PQA,PTI) !---------------- !---2023.07.30 Aobo Tan & Zhongwang Wei @ SYSU - real(r8), INTENT(in) :: PPA ! Air pressure (Pa) - real(r8), INTENT(in) :: PTA ! Air temperature (deg C) - real(r8), INTENT(in) :: PQA ! Air specific humidity (kg/kg) - real(r8), INTENT(out) :: PTI ! Hydrometeo temprtature in deg C + real(r8), intent(in) :: PPA ! Air pressure (Pa) + real(r8), intent(in) :: PTA ! Air temperature (deg C) + real(r8), intent(in) :: PQA ! Air specific humidity (kg/kg) + real(r8), intent(out) :: PTI ! Hydrometeo temprtature in deg C real(r8) :: ZD !diffusivity of water vapour in air [m^2 s-1] real(r8) :: ZLAMBDAT !thermal conductivity of air [J m^-1 s^-1 K^-1] real(r8) :: ZL !latent heat of sublimation of vaporisation[J kg^-1] @@ -241,61 +241,61 @@ SUBROUTINE HYDROMET_TEMP(PPA, PTA, PQA,PTI) integer :: JITER integer :: JJ,I,NN - ! 1. Compute diffusivity of water vapour in air [m2 s-1] (Thorpe and Mason, 1966) - ZD = 2.063e-5 * ((PTA+273.15)/273.15)**1.75 - - ! 2. Compute thermal conductivity of air [J m-1 s-1 K-1] - ZLAMBDAT = 0.000063 * (PTA+273.15) + 0.00673 + ! 1. Compute diffusivity of water vapour in air [m2 s-1] (Thorpe and Mason, 1966) + ZD = 2.063e-5 * ((PTA+273.15)/273.15)**1.75 - ! 3. Compute latent heat of sublimation or vaporisation (depending on air temperature) - IF(PTA <0.) THEN - ZL = 1000.0 * (2834.1 - 0.29 *PTA - 0.004*PTA**2.) - ELSE - ZL = 1000.0 * (2501.0 - (2.361 * PTA)) - ENDIF + ! 2. Compute thermal conductivity of air [J m-1 s-1 K-1] + ZLAMBDAT = 0.000063 * (PTA+273.15) + 0.00673 - !TODO:check use of dry air? - - ! 4. Compute density of dry air [kg m-3] - ZRHODA = PPA/(287.04*(PTA+273.15)) - - ! 5. Compute saturated water vapour pressure [Pa] - IF(PTA>0) THEN - EVSAT = 611.0*EXP(17.27*PTA/(PTA+237.3)) - ELSE - EVSAT = 611.0*EXP(21.87*PTA/(PTA+265.5)) - ENDIF - - ! 6. Solve iteratively to get Ti in Harder and Pomeroy (2013). using a Newton-Raphston approach - !set the 1st guess to PTA - ZT = PTA - !loop until convergence - DO JITER = 1,10 - ZTINI = ZT ! - - IF(ZT>0) THEN - ESAT = 611.0*EXP(17.27*ZT/(ZT+237.3)) + ! 3. Compute latent heat of sublimation or vaporisation (depending on air temperature) + IF(PTA <0.) THEN + ZL = 1000.0 * (2834.1 - 0.29 *PTA - 0.004*PTA**2.) ELSE - ESAT = 611.0*EXP(21.87*ZT/(ZT+265.5)) + ZL = 1000.0 * (2501.0 - (2.361 * PTA)) ENDIF - RHO_VSAT = ESAT/(461.5*(ZT+273.15)) ! Saturated water vapour density + !TODO:check USE of dry air? - ZF = ZT - PTA - ZD*ZL/ZLAMBDAT * ( PQA*ZRHODA - RHO_VSAT) + ! 4. Compute density of dry air [kg m-3] + ZRHODA = PPA/(287.04*(PTA+273.15)) - IF(ZT>0) THEN - RHO_VSAT_DIFF = 611.0/( 461.5*(ZT+273.15)) * EXP( 17.27*ZT/(ZT+ 237.3)) * & - (-1/(ZT+273.15) + 17.27* 237.3/((ZT+ 237.3))**2.) + ! 5. Compute saturated water vapour pressure [Pa] + IF(PTA>0) THEN + EVSAT = 611.0*EXP(17.27*PTA/(PTA+237.3)) ELSE - RHO_VSAT_DIFF = 611.0/( 461.5*(ZT+273.15)) * EXP( 21.87*ZT/(ZT+ 265.5)) * & - (-1/(ZT+273.15) + 21.87* 265.5/((ZT+ 265.5))**2.) + EVSAT = 611.0*EXP(21.87*PTA/(PTA+265.5)) ENDIF - - ZFDIFF = 1 + ZD*ZL/ZLAMBDAT * RHO_VSAT_DIFF - ZT = ZTINI - ZF/ZFDIFF - IF(ABS(ZT- ZTINI) .LT. 0.01) EXIT - ENDDO - PTI = ZT + ! 6. Solve iteratively to get Ti in Harder and Pomeroy (2013). using a Newton-Raphston approach + !set the 1st guess to PTA + ZT = PTA + !loop until convergence + DO JITER = 1,10 + ZTINI = ZT ! + + IF(ZT>0) THEN + ESAT = 611.0*EXP(17.27*ZT/(ZT+237.3)) + ELSE + ESAT = 611.0*EXP(21.87*ZT/(ZT+265.5)) + ENDIF + + RHO_VSAT = ESAT/(461.5*(ZT+273.15)) ! Saturated water vapour density + + ZF = ZT - PTA - ZD*ZL/ZLAMBDAT * ( PQA*ZRHODA - RHO_VSAT) + + IF(ZT>0) THEN + RHO_VSAT_DIFF = 611.0/( 461.5*(ZT+273.15)) * EXP( 17.27*ZT/(ZT+ 237.3)) * & + (-1/(ZT+273.15) + 17.27* 237.3/((ZT+ 237.3))**2.) + ELSE + RHO_VSAT_DIFF = 611.0/( 461.5*(ZT+273.15)) * EXP( 21.87*ZT/(ZT+ 265.5)) * & + (-1/(ZT+273.15) + 21.87* 265.5/((ZT+ 265.5))**2.) + ENDIF + + + ZFDIFF = 1 + ZD*ZL/ZLAMBDAT * RHO_VSAT_DIFF + ZT = ZTINI - ZF/ZFDIFF + IF(ABS(ZT- ZTINI) .lt. 0.01) EXIT + ENDDO + PTI = ZT END SUBROUTINE HYDROMET_TEMP END MODULE MOD_RainSnowTemp diff --git a/main/MOD_SimpleOcean.F90 b/main/MOD_SimpleOcean.F90 index 19a08459..2f8ddb06 100644 --- a/main/MOD_SimpleOcean.F90 +++ b/main/MOD_SimpleOcean.F90 @@ -3,30 +3,30 @@ MODULE MOD_SimpleOcean !----------------------------------------------------------------------- - use MOD_Precision - IMPLICIT NONE - SAVE + USE MOD_Precision + IMPLICIT NONE + SAVE ! PUBLIC MEMBER FUNCTIONS: - public :: socean + PUBLIC :: socean ! PRIVATE MEMBER FUNCTIONS: - private :: seafluxes - private :: srftsb + PRIVATE :: seafluxes + PRIVATE :: srftsb !----------------------------------------------------------------------- - CONTAINS +CONTAINS !----------------------------------------------------------------------- - subroutine socean (dosst,deltim,oro,hu,ht,hq,& - us,vs,tm,qm,rhoair,psrf,sabg,frl,tssea,tssub,scv,& - taux,tauy,fsena,fevpa,lfevpa,fseng,fevpg,tref,qref,& - z0m,zol,rib,ustar,qstar,tstar,fm,fh,fq,emis,olrg) + SUBROUTINE socean (dosst,deltim,oro,hu,ht,hq,& + us,vs,tm,qm,rhoair,psrf,sabg,frl,tssea,tssub,scv,& + taux,tauy,fsena,fevpa,lfevpa,fseng,fevpg,tref,qref,& + z0m,zol,rib,ustar,qstar,tstar,fm,fh,fq,emis,olrg) !----------------------------------------------------------------------- ! Simple Ocean Model ! 1. calculate sea surface fluxes, based on CLM @@ -35,173 +35,173 @@ subroutine socean (dosst,deltim,oro,hu,ht,hq,& ! Original authors : yongjiu dai and xin-zhong liang (08/30/2001) !----------------------------------------------------------------------- - use MOD_Precision - use MOD_Const_Physical, only : tfrz, hvap, hsub, stefnc, vonkar - implicit none + USE MOD_Precision + USE MOD_Const_Physical, only : tfrz, hvap, hsub, stefnc, vonkar + IMPLICIT NONE !------------------------------Arguments-------------------------------- - integer, parameter :: psrfty=7 ! Number of surface types - integer, parameter :: plsice=4 ! number of seaice levels - - logical, INTENT(IN) :: dosst ! true to update sst/ice/snow before calculation - real(r8), INTENT(in) :: deltim ! seconds in a time-step (s) - real(r8), INTENT(in) :: hu ! agcm reference height of wind [m] - real(r8), INTENT(in) :: ht ! agcm reference height of temperature [m] - real(r8), INTENT(in) :: hq ! agcm reference height of humidity [m] - real(r8), INTENT(in) :: us ! wind component in eastward direction [m/s] - real(r8), INTENT(in) :: vs ! wind component in northward direction [m/s] - real(r8), INTENT(in) :: tm ! temperature at agcm reference height [kelvin] - real(r8), INTENT(in) :: qm ! specific humidity at agcm reference height [kg/kg] - real(r8), INTENT(in) :: rhoair ! density air [kg/m3] - real(r8), INTENT(in) :: psrf ! atmosphere pressure at the surface [pa] [not used] - real(r8), INTENT(in) :: sabg ! surface solar absorbed flux [W/m2] - real(r8), INTENT(in) :: frl ! downward longwave radiation [W/m2] - - real(r8), INTENT(inout) :: oro ! ocean(0)/seaice(2)/ flag - real(r8), INTENT(inout) :: scv ! snow water equivalent depth (mm) - real(r8), INTENT(inout) :: tssub(plsice) ! surface/sub-surface temperatures [K] - real(r8), INTENT(out) :: tssea ! sea surface temperature [K] - - real(r8), INTENT(out) :: taux ! wind stress: E-W [kg/m/s**2] - real(r8), INTENT(out) :: tauy ! wind stress: N-S [kg/m/s**2] - real(r8), INTENT(out) :: fsena ! sensible heat from reference height to atmosphere [W/m2] - real(r8), INTENT(out) :: fevpa ! evaporation from refence height to atmosphere [mm/s] - real(r8), INTENT(out) :: lfevpa ! laten heat from reference height to atmosphere [W/m2] - real(r8), INTENT(out) :: fseng ! sensible heat flux from ground [W/m2] - real(r8), INTENT(out) :: fevpg ! evaporation heat flux from ground [mm/s] - - real(r8), INTENT(out) :: tref ! 2 m height air temperature [kelvin] - real(r8), INTENT(out) :: qref ! 2 m height air humidity - real(r8), INTENT(out) :: z0m ! effective roughness [m] - real(r8), INTENT(out) :: zol ! dimensionless height (z/L) used in Monin-Obukhov theory - real(r8), INTENT(out) :: rib ! bulk Richardson number in surface layer - real(r8), INTENT(out) :: ustar ! friction velocity [m/s] - real(r8), INTENT(out) :: tstar ! temperature scaling parameter - real(r8), INTENT(out) :: qstar ! moisture scaling parameter - real(r8), INTENT(out) :: fm ! integral of profile function for momentum - real(r8), INTENT(out) :: fh ! integral of profile function for heat - real(r8), INTENT(out) :: fq ! integral of profile function for moisture - real(r8), INTENT(out) :: emis ! averaged bulk surface emissivity - real(r8), INTENT(out) :: olrg ! longwave up flux at surface [W/m2] + integer, parameter :: psrfty=7 ! Number of surface types + integer, parameter :: plsice=4 ! number of seaice levels + + logical, intent(in) :: dosst ! true to update sst/ice/snow before calculation + real(r8), intent(in) :: deltim ! seconds in a time-step (s) + real(r8), intent(in) :: hu ! agcm reference height of wind [m] + real(r8), intent(in) :: ht ! agcm reference height of temperature [m] + real(r8), intent(in) :: hq ! agcm reference height of humidity [m] + real(r8), intent(in) :: us ! wind component in eastward direction [m/s] + real(r8), intent(in) :: vs ! wind component in northward direction [m/s] + real(r8), intent(in) :: tm ! temperature at agcm reference height [kelvin] + real(r8), intent(in) :: qm ! specific humidity at agcm reference height [kg/kg] + real(r8), intent(in) :: rhoair ! density air [kg/m3] + real(r8), intent(in) :: psrf ! atmosphere pressure at the surface [pa] [not used] + real(r8), intent(in) :: sabg ! surface solar absorbed flux [W/m2] + real(r8), intent(in) :: frl ! downward longwave radiation [W/m2] + + real(r8), intent(inout) :: oro ! ocean(0)/seaice(2)/ flag + real(r8), intent(inout) :: scv ! snow water equivalent depth (mm) + real(r8), intent(inout) :: tssub(plsice) ! surface/sub-surface temperatures [K] + real(r8), intent(out) :: tssea ! sea surface temperature [K] + + real(r8), intent(out) :: taux ! wind stress: E-W [kg/m/s**2] + real(r8), intent(out) :: tauy ! wind stress: N-S [kg/m/s**2] + real(r8), intent(out) :: fsena ! sensible heat from reference height to atmosphere [W/m2] + real(r8), intent(out) :: fevpa ! evaporation from refence height to atmosphere [mm/s] + real(r8), intent(out) :: lfevpa ! laten heat from reference height to atmosphere [W/m2] + real(r8), intent(out) :: fseng ! sensible heat flux from ground [W/m2] + real(r8), intent(out) :: fevpg ! evaporation heat flux from ground [mm/s] + + real(r8), intent(out) :: tref ! 2 m height air temperature [kelvin] + real(r8), intent(out) :: qref ! 2 m height air humidity + real(r8), intent(out) :: z0m ! effective roughness [m] + real(r8), intent(out) :: zol ! dimensionless height (z/L) used in Monin-Obukhov theory + real(r8), intent(out) :: rib ! bulk Richardson number in surface layer + real(r8), intent(out) :: ustar ! friction velocity [m/s] + real(r8), intent(out) :: tstar ! temperature scaling parameter + real(r8), intent(out) :: qstar ! moisture scaling parameter + real(r8), intent(out) :: fm ! integral of profile FUNCTION for momentum + real(r8), intent(out) :: fh ! integral of profile FUNCTION for heat + real(r8), intent(out) :: fq ! integral of profile FUNCTION for moisture + real(r8), intent(out) :: emis ! averaged bulk surface emissivity + real(r8), intent(out) :: olrg ! longwave up flux at surface [W/m2] !----------------------------------------------------------------------- - integer isrfty ! surface type index (1-7) - real(r8) cgrndl ! deriv, of soil sensible heat flux wrt soil temp [w/m2/k] - real(r8) cgrnds ! deriv of soil latent heat flux wrt soil temp [w/m**2/k] - real(r8) dshf ! Ts partial derivative for sensible heat flux - real(r8) dlhf ! Ts partial derivative for latent heat flux - real(r8) fnt ! net surface flux for input conditions [W/m2] - real(r8) dfntdt ! net surface flux ts partial derivative [W/m2] - real(r8) tsbsf(plsice) ! Non-adjusted srfc/sub-srfc temperatures - real(r8) snowh ! snow depth (liquid water equivalent) [m] - real(r8) sicthk ! sea-ice thickness [m] - - real(r8), parameter :: emisi = 1.0 ! (0.97) surface emissivity for ice or snow [-] - real(r8), parameter :: emisw = 1.0 ! (0.97) surface emissivity for water [-] - real(r8), parameter :: tsice = 271.36 ! freezing point of sea ice [K] - real(r8), parameter :: thsice = 2.0 ! initial thickness of sea ice [m] - real(r8), parameter :: snsice = 0.005 ! initial snow water equivalent over sea ice [m] - - integer j + integer isrfty ! surface type index (1-7) + real(r8) cgrndl ! deriv, of soil sensible heat flux wrt soil temp [w/m2/k] + real(r8) cgrnds ! deriv of soil latent heat flux wrt soil temp [w/m**2/k] + real(r8) dshf ! Ts partial derivative for sensible heat flux + real(r8) dlhf ! Ts partial derivative for latent heat flux + real(r8) fnt ! net surface flux for input conditions [W/m2] + real(r8) dfntdt ! net surface flux ts partial derivative [W/m2] + real(r8) tsbsf(plsice) ! Non-adjusted srfc/sub-srfc temperatures + real(r8) snowh ! snow depth (liquid water equivalent) [m] + real(r8) sicthk ! sea-ice thickness [m] + + real(r8), parameter :: emisi = 1.0 ! (0.97) surface emissivity for ice or snow [-] + real(r8), parameter :: emisw = 1.0 ! (0.97) surface emissivity for water [-] + real(r8), parameter :: tsice = 271.36 ! freezing point of sea ice [K] + real(r8), parameter :: thsice = 2.0 ! initial thickness of sea ice [m] + real(r8), parameter :: snsice = 0.005 ! initial snow water equivalent over sea ice [m] + + integer j !----------------------------------------------------------------------- - snowh = scv/1000. + snowh = scv/1000. - if(dosst)then + IF(dosst)THEN ! update sea temperatures and sea ice distribution ! as well as snow cover over sea ice - if(nint(oro).eq.2 .and. tssea.gt.tsice) then - oro = 0.0 ! old sea ice melt out - snowh = 0. - scv = 0. - sicthk = 0. - do j = 1,plsice - tssub(j) = tssea - enddo - else if(nint(oro).eq.0 .and. tssea.le.tsice) then - oro = 2.0 ! new sea ice formed - snowh = snsice - scv = snowh*1000. - sicthk = thsice - do j = 1,plsice - tssub(j) = tssea - enddo - endif - endif - - tssea = tssub(1) + IF(nint(oro).eq.2 .and. tssea.gt.tsice) THEN + oro = 0.0 ! old sea ice melt out + snowh = 0. + scv = 0. + sicthk = 0. + DO j = 1,plsice + tssub(j) = tssea + ENDDO + ELSE IF(nint(oro).eq.0 .and. tssea.le.tsice) THEN + oro = 2.0 ! new sea ice formed + snowh = snsice + scv = snowh*1000. + sicthk = thsice + DO j = 1,plsice + tssub(j) = tssea + ENDDO + ENDIF + ENDIF + + tssea = tssub(1) ! compute surface fluxes, derviatives, and exchange coefficiants - call seafluxes (oro,hu,ht,hq,& - us,vs,tm,qm,rhoair,psrf,tssea,& - taux,tauy,fsena,fevpa,fseng,fevpg,tref,qref,& - z0m,zol,rib,ustar,qstar,tstar,fm,fh,fq,cgrndl,cgrnds) + CALL seafluxes (oro,hu,ht,hq,& + us,vs,tm,qm,rhoair,psrf,tssea,& + taux,tauy,fsena,fevpa,fseng,fevpg,tref,qref,& + z0m,zol,rib,ustar,qstar,tstar,fm,fh,fq,cgrndl,cgrnds) - if(nint(oro).eq.0)then ! ocean - lfevpa = fevpa*hvap - olrg = stefnc*emisw*tssea**4 + (1.-emisw)*frl - emis = emisw + IF(nint(oro).eq.0)THEN ! ocean + lfevpa = fevpa*hvap + olrg = stefnc*emisw*tssea**4 + (1.-emisw)*frl + emis = emisw - else if(nint(oro).eq.2)then ! sea ice - lfevpa = fevpa*hsub + ELSE IF(nint(oro).eq.2)THEN ! sea ice + lfevpa = fevpa*hsub - ! net surface flux and derivate at current surface temperature - dshf = cgrnds - dlhf = hsub*cgrndl - olrg = stefnc*emisi*tssea**4 + (1.-emisi)*frl + ! net surface flux and derivate at current surface temperature + dshf = cgrnds + dlhf = hsub*cgrndl + olrg = stefnc*emisi*tssea**4 + (1.-emisi)*frl - fnt = sabg + frl - olrg - fsena - lfevpa - dfntdt = -(dshf + dlhf) - stefnc*emisi*4.*tssea**3 + fnt = sabg + frl - olrg - fsena - lfevpa + dfntdt = -(dshf + dlhf) - stefnc*emisi*4.*tssea**3 - ! initialize surface/subsurface temperatures for srftsb - do j=1,plsice - tsbsf(j) = tssub(j) - end do + ! initialize surface/subsurface temperatures for srftsb + DO j=1,plsice + tsbsf(j) = tssub(j) + ENDDO -! set sea ice surface type - isrfty = 2 + ! set sea ice surface type + isrfty = 2 - ! diffusion calculation for temperature - call srftsb(isrfty,deltim,fnt,dfntdt,snowh,tsbsf) + ! diffusion calculation for temperature + CALL srftsb(isrfty,deltim,fnt,dfntdt,snowh,tsbsf) - do j=1,plsice - tsbsf(j) = min(tsbsf(j),tfrz) - tssub(j) = tsbsf(j) - end do - tssea = tssub(1) + DO j=1,plsice + tsbsf(j) = min(tsbsf(j),tfrz) + tssub(j) = tsbsf(j) + ENDDO + tssea = tssub(1) - olrg = stefnc*emisi*tssea**4 + (1.-emisi)*frl - emis = emisi + olrg = stefnc*emisi*tssea**4 + (1.-emisi)*frl + emis = emisi - endif + ENDIF - end subroutine socean + END SUBROUTINE socean - subroutine seafluxes (oro,hu,ht,hq,& - us,vs,tm,qm,rhoair,psrf,tssea,& - taux,tauy,fsena,fevpa,fseng,fevpg,tref,qref,& - z0m,zol,rib,ustar,qstar,tstar,fm,fh,fq,cgrndl,cgrnds) + SUBROUTINE seafluxes (oro,hu,ht,hq,& + us,vs,tm,qm,rhoair,psrf,tssea,& + taux,tauy,fsena,fevpa,fseng,fevpg,tref,qref,& + z0m,zol,rib,ustar,qstar,tstar,fm,fh,fq,cgrndl,cgrnds) !======================================================================= -! this is the main subroutine to execute the calculation of thermal processes +! this is the main SUBROUTINE to execute the calculation of thermal processes ! and surface fluxes ! ! Original author : Yongjiu Dai, 09/15/1999; 08/30/2002 !======================================================================= - use MOD_Precision - use MOD_Const_Physical, only : cpair,rgas,vonkar,grav - use MOD_FrictionVelocity - USE MOD_Qsadv - implicit none + USE MOD_Precision + USE MOD_Const_Physical, only : cpair,rgas,vonkar,grav + USE MOD_FrictionVelocity + USE MOD_Qsadv + IMPLICIT NONE !----------------------- Dummy argument -------------------------------- - real(r8), INTENT(in) :: & + real(r8), intent(in) :: & oro, &! ocean(0)/seaice(2)/ flag ! atmospherical variables and agcm reference height @@ -217,7 +217,7 @@ subroutine seafluxes (oro,hu,ht,hq,& tssea ! sea surface temperature [K] - 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 agcm reference height to atmosphere [W/m2] @@ -233,19 +233,19 @@ subroutine seafluxes (oro,hu,ht,hq,& ustar, &! friction velocity [m/s] tstar, &! temperature scaling parameter qstar, &! moisture scaling parameter - fm, &! integral of profile function for momentum - fh, &! integral of profile function for heat - fq, &! integral of profile function for moisture + fm, &! integral of profile FUNCTION for momentum + fh, &! integral of profile FUNCTION for heat + fq, &! integral of profile FUNCTION for moisture cgrndl, &! deriv, of soil sensible heat flux wrt soil temp [w/m2/k] cgrnds ! deriv of soil latent heat flux wrt soil temp [w/m**2/k] !------------------------ LOCAL VARIABLES ------------------------------ - integer i - integer niters, &! maximum number of iterations for surface temperature + integer i + 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] dth, &! diff of virtual temp. between ref. height and surface @@ -264,7 +264,7 @@ subroutine seafluxes (oro,hu,ht,hq,& raiw, &! temporary variable [kg/m2/s] fh2m, &! relation for temperature at 2m fq2m, &! relation for specific humidity at 2m - fm10m, &! integral of profile function for momentum at 10m + fm10m, &! integral of profile FUNCTION for momentum at 10m thm, &! intermediate variable (tm+0.0098*ht) th, &! potential temperature (kelvin) thv, &! virtual potential temperature (kelvin) @@ -282,7 +282,7 @@ subroutine seafluxes (oro,hu,ht,hq,& z0hg, &! roughness length over ground, sensible heat [m] z0qg ! roughness length over ground, latent heat [m] - real, parameter :: zsice = 0.04 ! sea ice aerodynamic roughness length [m] + real, parameter :: zsice = 0.04 ! sea ice aerodynamic roughness length [m] !----------------------------------------------------------------------- ! potential temperatur at the reference height @@ -297,7 +297,7 @@ subroutine seafluxes (oro,hu,ht,hq,& nmozsgn = 0 obuold = 0. - call qsadv(tssea,psrf,eg,degdT,qsatg,qsatgdT) + CALL qsadv(tssea,psrf,eg,degdT,qsatg,qsatgdT) ! potential temperatur at the reference height thm = tm + 0.0098*ht ! intermediate variable equivalent to @@ -311,49 +311,49 @@ subroutine seafluxes (oro,hu,ht,hq,& dthv = dth*(1.+0.61*qm)+0.61*th*dqh zldis = hu-0. - if(nint(oro).eq.0)then ! ocean + IF(nint(oro).eq.0)THEN ! ocean ! Kinematic viscosity of dry air (m2/s)- Andreas (1989) CRREL Rep. 89-11 visa=1.326e-5*(1.+6.542e-3*tm + 8.301e-6*tm**2 - 4.84e-9*tm**3) ! loop to obtain initial and good ustar and zo ustar=0.06 wc=0.5 - if(dthv.ge.0.) then + IF(dthv.ge.0.) THEN um=max(ur,0.1) - else + ELSE um=sqrt(ur*ur+wc*wc) - endif + ENDIF - do i=1,5 + DO i=1,5 z0mg=0.013*ustar*ustar/grav+0.11*visa/ustar ustar=vonkar*um/log(zldis/z0mg) - enddo + ENDDO - else if(nint(oro).eq.2)then ! sea ice + ELSE IF(nint(oro).eq.2)THEN ! sea ice z0mg = zsice z0qg = z0mg z0hg = z0mg - endif + ENDIF - call moninobukini(ur,th,thm,thv,dth,dqh,dthv,zldis,z0mg,um,obu) + CALL moninobukini(ur,th,thm,thv,dth,dqh,dthv,zldis,z0mg,um,obu) ! Evaluated stability-dependent variables using moz from prior iteration niters=10 displax = 0. !---------------------------------------------------------------- - ITERATION : do iter = 1, niters ! begin stability iteration + ITERATION : DO iter = 1, niters ! begin stability iteration !---------------------------------------------------------------- - if(nint(oro).eq.0)then ! ocean + IF(nint(oro).eq.0)THEN ! ocean z0mg=0.013*ustar*ustar/grav + 0.11*visa/ustar xq=2.67*(ustar*z0mg/visa)**0.25 - 2.57 xt= xq z0qg=z0mg/exp(xq) z0hg=z0mg/exp(xt) - endif + ENDIF - call moninobuk(hu,ht,hq,displax,z0mg,z0hg,z0qg,obu,um,& + CALL moninobuk(hu,ht,hq,displax,z0mg,z0hg,z0qg,obu,um,& ustar,fh2m,fq2m,fm10m,fm,fh,fq) tstar = vonkar/fh*dth @@ -361,28 +361,28 @@ subroutine seafluxes (oro,hu,ht,hq,& thvstar=tstar*(1.+0.61*qm)+0.61*th*qstar zol=zldis*vonkar*grav*thvstar/(ustar**2*thv) - if(zol >= 0.) then ! stable + IF(zol >= 0.) THEN ! stable zol = min(2.,max(zol,1.e-6)) - else ! unstable + ELSE ! unstable zol = max(-100.,min(zol,-1.e-6)) - endif + ENDIF obu = zldis/zol - if(zol >= 0.)then + IF(zol >= 0.)THEN um = max(ur,0.1) - else + ELSE wc = (-grav*ustar*thvstar*zii/thv)**(1./3.) wc2 = beta*beta*(wc*wc) um = sqrt(ur*ur+wc2) - endif + ENDIF - if (obuold*obu < 0.) nmozsgn = nmozsgn+1 - if(nmozsgn >= 4) EXIT + IF (obuold*obu < 0.) nmozsgn = nmozsgn+1 + IF(nmozsgn >= 4) EXIT obuold = obu !---------------------------------------------------------------- - enddo ITERATION ! end stability iteration + ENDDO ITERATION ! END stability iteration !---------------------------------------------------------------- ! Get derivative of fluxes with repect to ground temperature @@ -412,46 +412,46 @@ subroutine seafluxes (oro,hu,ht,hq,& qref = qm + vonkar/fq*dqh * (fq2m/vonkar - fq/vonkar) z0m = z0mg - end subroutine seafluxes + END SUBROUTINE seafluxes - subroutine srftsb(isrfty,deltim,fnt,dfntdt,snowh,tsbsf) + SUBROUTINE srftsb(isrfty,deltim,fnt,dfntdt,snowh,tsbsf) !----------------------------------------------------------------------- ! Compute surface and subsurface temperatures over sea-ice surfaces. ! ! Sea ice temperatures are specified in 'plsice' layers of fixed ! thickness and thermal properties. The forecast temperatures are -! determined from a backward/implicit diffusion calculation using +! determined from a backward/IMPLICIT diffusion calculation using ! linearized sensible/latent heat fluxes. The bottom ocean temperature ! is fixed at -2C, allowing heat flux exchange with underlying ocean. ! ! Sub-surface layers are indexed 1 at the surface, increasing downwards ! to plsice. Layers have mid-points and interfaces between layers. ! -! Temperatures are defined at mid-points, while fluxes between layers +! Temperatures are defined at mid-points, WHILE fluxes between layers ! and the top/bottom media are defined at layer interfaces. ! !----------------------------------------------------------------------- - use MOD_Precision - use MOD_Const_Physical, only: tkice, tkair + USE MOD_Precision + USE MOD_Const_Physical, only: tkice, tkair USE MOD_Utils - implicit none + IMPLICIT NONE !------------------------------Arguments-------------------------------- integer, parameter :: psrfty = 7 ! Number of surface types integer, parameter :: plsice = 4 ! number of seaice levels - integer, INTENT(in) :: isrfty ! surface type index (1 - 7) - real(r8), INTENT(in) :: deltim ! seconds i a time step (s) - real(r8), INTENT(in) :: fnt ! top surface/atmosphere net energy flux - real(r8), INTENT(in) :: dfntdt ! ts partial derivative of net sfc flux - real(r8), INTENT(in) :: snowh ! snow depth (liquid water equivalent) [m] + integer, intent(in) :: isrfty ! surface type index (1 - 7) + real(r8), intent(in) :: deltim ! seconds i a time step (s) + real(r8), intent(in) :: fnt ! top surface/atmosphere net energy flux + real(r8), intent(in) :: dfntdt ! ts partial derivative of net sfc flux + real(r8), intent(in) :: snowh ! snow depth (liquid water equivalent) [m] - real(r8), INTENT(inout) :: tsbsf(1:plsice) ! surface/sub-surface tmps + real(r8), intent(inout) :: tsbsf(1:plsice) ! surface/sub-surface tmps !---------------------------Local variables----------------------------- @@ -498,7 +498,7 @@ subroutine srftsb(isrfty,deltim,fnt,dfntdt,snowh,tsbsf) real(r8) zmpl ! layer below mid-point depth real(r8) zsnow ! snow geometric depth real(r8) ztop ! top layer thickness - logical scvr ! true if surface snow covered + logical scvr ! true IF surface snow covered !--------------------------Data Statements------------------------------ ! specified (and invariant) thermal properties for surface types @@ -512,28 +512,28 @@ subroutine srftsb(isrfty,deltim,fnt,dfntdt,snowh,tsbsf) real(r8),parameter,dimension(psrfty,plsice) :: &!mass specific heat (J/kg/K) cmtype = reshape(& - (/4.20e3,2.07e3,2.07e3,1.04e3,7.20e2,5.60e2,4.16e2,& + (/4.20e3,2.07e3,2.07e3,1.04e3,7.20e2,5.60e2,4.16e2,& 4.20e3,2.07e3,2.07e3,1.04e3,7.20e2,5.60e2,4.16e2,& 4.20e3,2.07e3,2.07e3,1.04e3,7.20e2,5.60e2,4.16e2,& 4.20e3,2.07e3,2.07e3,1.04e3,7.20e2,5.60e2,4.16e2/), (/7,4/)) real(r8),parameter,dimension(psrfty,plsice) :: &! mass density (kg/m3) rhtype = reshape(& - (/1.00e3,9.20e2,9.20e2,2.50e3,2.50e3,2.50e3,2.50e3,& + (/1.00e3,9.20e2,9.20e2,2.50e3,2.50e3,2.50e3,2.50e3,& 1.00e3,9.20e2,9.20e2,2.50e3,2.50e3,2.50e3,2.50e3,& 1.00e3,9.20e2,9.20e2,2.50e3,2.50e3,2.50e3,2.50e3,& 1.00e3,9.20e2,9.20e2,2.50e3,2.50e3,2.50e3,2.50e3/),(/7,4/)) real(r8),parameter,dimension(psrfty,plsice) :: &!layer thicknesses (m) thckly = reshape(& - (/ 2., .500, .250, .050, .090, .080, .120, & + (/ 2., .500, .250, .050, .090, .080, .120, & 5., .500, .500, .366, .390, .435, .492, & 10., .500, .500,1.369,1.459,1.628,1.841, & 33., .500,8.500,6.990,7.450,8.310,9.400/), (/7,4/)) real(r8),parameter,dimension(psrfty,plsice) :: &!thermal conductivity (W/m/K) tktype = reshape(& - (/15.0 ,2.200 ,2.200 ,1.408 ,1.104 ,1.071 ,1.019 , & + (/15.0 ,2.200 ,2.200 ,1.408 ,1.104 ,1.071 ,1.019 , & 15.0 ,2.200 ,2.200 ,1.408 ,1.104 ,1.071 ,1.019 , & 15.0 ,2.200 ,2.200 ,1.408 ,1.104 ,1.071 ,1.019 , & 15.0 ,2.200 ,2.200 ,1.408 ,1.104 ,1.071 ,1.019 /), (/7,4/)) @@ -548,9 +548,9 @@ subroutine srftsb(isrfty,deltim,fnt,dfntdt,snowh,tsbsf) tksnow = (1.-frcair)*tkice + frcair*tkair ! no external heat source - do j=1,plsice + DO j=1,plsice htsrc(j) = 0.0 - end do + ENDDO ! define logical for snow covered surfaces: scvr = snowh.gt.0. @@ -570,11 +570,11 @@ subroutine srftsb(isrfty,deltim,fnt,dfntdt,snowh,tsbsf) rho(1) = rhty tk(1) = tkty -! modify layer 1 fields for snow cover if present +! modify layer 1 fields for snow cover IF present ! snow equivlnt depth times snow liquid water depth gives the physical ! depth of snow for thermal conduction computation; snow is mixed ! uniformly by mass with the top surface layer - if(scvr) then + IF(scvr) THEN zsnow = snowh*snwedp msnow = rhsnow*zsnow mlice = rhty*thck @@ -582,44 +582,44 @@ subroutine srftsb(isrfty,deltim,fnt,dfntdt,snowh,tsbsf) cmass(1) = (msnow*cmsnow + mlice*cmty)/(msnow+mlice) tk(1) = (msnow*tksnow + mlice*tkty)/(msnow+mlice) z(1) = (msnow+mlice) / rho(1) - end if + ENDIF ! set surface thermal properties for the lower sub/surface layers: - do j=2,plsice + DO j=2,plsice jndx = isrfty thck = thckly(jndx,j) cmass(j) = cmtype(jndx,j) rho(j) = rhtype(jndx,j) tk(j) = tktype(jndx,j) z(j) = z(j-1) + thck - end do + ENDDO ! define set of linear equations for temperature - do j=1,plsice + DO j=1,plsice tin(j) = tsbsf(j) - end do + ENDDO -! if sea ice, compute heat flux from underlying ocean, assumed to be at +! IF sea ice, compute heat flux from underlying ocean, assumed to be at ! the temperature of -2C fbt = 0.0 - if(isrfty.eq.2) then + IF(isrfty.eq.2) THEN zbot = 0.5*(z(plsice) - z(plsice-1)) fbt = -tk(plsice)*(271.16 - tin(plsice))/zbot - end if + ENDIF ! set up linear equations sbdiag(1) = 0. spdiag(plsice) = 0. ! single layer - if (plsice.eq.1) then + IF (plsice.eq.1) THEN rztop = 1./(z(1) - z(0)) crt = (cmass(1)*rho(1)*rdtime) diag(1) = crt - dfntdt*rztop rhs(1) = diag(1)*tin(1) + fnt*rztop - fbt*rztop + htsrc(1) ! more than one layer: top layer first - else if (plsice.gt.1) then + ELSE IF (plsice.gt.1) THEN crt = cmass(1)*rho(1)*rdtime ztop = z(1) - z(0) @@ -636,7 +636,7 @@ subroutine srftsb(isrfty,deltim,fnt,dfntdt,snowh,tsbsf) rhs(1) = tmp*tin(1) + fnt*rztop + htsrc(1) ! intermediate layers - do j=2,plsice-1 + DO j=2,plsice-1 crt = cmass(j)*rho(j)*rdtime delz = z(j) - z(j-1) zmpl = 0.5*(z(j+1) + z(j)) @@ -653,7 +653,7 @@ subroutine srftsb(isrfty,deltim,fnt,dfntdt,snowh,tsbsf) diag(j) = crt + (tkpls*fpls + tkmns*fmns) spdiag(j) = -tkpls*fpls rhs(j) = crt*tin(j) + htsrc(j) - end do + ENDDO ! bottom layer crt = cmass(plsice)*rho(plsice)*rdtime @@ -666,15 +666,14 @@ subroutine srftsb(isrfty,deltim,fnt,dfntdt,snowh,tsbsf) sbdiag(plsice) = -tkbot*fmns diag(plsice) = crt + (tkbot*fmns) rhs(plsice) = crt*tin(plsice) - fbt/zbot + htsrc(plsice) - end if + ENDIF - if(plsice.eq.1) then + IF(plsice.eq.1) THEN tsbsf(1) = rhs(1)/diag(1) - else - call tridia (plsice,sbdiag,diag,spdiag,rhs,tsbsf) - end if - - end subroutine srftsb + ELSE + CALL tridia (plsice,sbdiag,diag,spdiag,rhs,tsbsf) + ENDIF + END SUBROUTINE srftsb END MODULE MOD_SimpleOcean diff --git a/main/MOD_SnowFraction.F90 b/main/MOD_SnowFraction.F90 index e58456f0..550a44c2 100644 --- a/main/MOD_SnowFraction.F90 +++ b/main/MOD_SnowFraction.F90 @@ -16,12 +16,12 @@ MODULE MOD_SnowFraction !----------------------------------------------------------------------- - CONTAINS +CONTAINS !----------------------------------------------------------------------- - subroutine snowfraction (lai,sai,z0m,zlnd,scv,snowdp,wt,sigf,fsno) + SUBROUTINE snowfraction (lai,sai,z0m,zlnd,scv,snowdp,wt,sigf,fsno) !======================================================================= ! @@ -34,53 +34,53 @@ subroutine snowfraction (lai,sai,z0m,zlnd,scv,snowdp,wt,sigf,fsno) ! Hua Yuan, 10/2019: removed sigf to be compatible with PFT classification !======================================================================= - use MOD_Precision - implicit none + USE MOD_Precision + IMPLICIT NONE ! dummy arguments - real(r8), INTENT(in) :: scv ! snow water equivalent [mm or kg/m3] - real(r8), INTENT(in) :: snowdp ! snow depth [m] - real(r8), INTENT(in) :: z0m ! aerodynamic roughness length [m] - real(r8), INTENT(in) :: zlnd ! aerodynamic roughness length over soil surface [m] - real(r8), INTENT(in) :: lai ! leaf area index [-] - real(r8), INTENT(in) :: sai ! stem area index [-] + real(r8), intent(in) :: scv ! snow water equivalent [mm or kg/m3] + real(r8), intent(in) :: snowdp ! snow depth [m] + real(r8), intent(in) :: z0m ! aerodynamic roughness length [m] + real(r8), intent(in) :: zlnd ! aerodynamic roughness length over soil surface [m] + real(r8), intent(in) :: lai ! leaf area index [-] + real(r8), intent(in) :: sai ! stem area index [-] - real(r8), INTENT(out) :: wt ! fraction of vegetation covered with snow [-] - real(r8), INTENT(out) :: sigf ! fraction of veg cover, excluding snow-covered veg [-] - real(r8), INTENT(out) :: fsno ! fraction of soil covered by snow [-] + real(r8), intent(out) :: wt ! fraction of vegetation covered with snow [-] + real(r8), intent(out) :: sigf ! fraction of veg cover, excluding snow-covered veg [-] + real(r8), intent(out) :: fsno ! fraction of soil covered by snow [-] real(r8) :: fmelt ! dimensionless metling factor real(r8), parameter :: m = 1.0 ! the value of m used in CLM4.5 is 1.0. - ! while the value of m given by Niu et al (2007) is 1.6 - ! while Niu (2012) suggested 3.0 + ! WHILE the value of m given by Niu et al (2007) is 1.6 + ! WHILE Niu (2012) suggested 3.0 !----------------------------------------------------------------------- - if(lai+sai > 1e-6) then - ! Fraction of vegetation buried (covered) by snow - wt = 0.1*snowdp/z0m - wt = wt/(1.+wt) - - ! Fraction of vegetation cover free of snow - sigf = 1. - wt - else - wt = 0. - sigf = 0. - endif + IF(lai+sai > 1e-6) THEN + ! Fraction of vegetation buried (covered) by snow + wt = 0.1*snowdp/z0m + wt = wt/(1.+wt) + + ! Fraction of vegetation cover free of snow + sigf = 1. - wt + ELSE + wt = 0. + sigf = 0. + ENDIF ! 10/16/2019, yuan: - !if(sigf < 0.001) sigf = 0. - !if(sigf > 0.999) sigf = 1. + !IF(sigf < 0.001) sigf = 0. + !IF(sigf > 0.999) sigf = 1. ! Fraction of soil covered by snow - fsno = 0.0 - if(snowdp > 0.) then - fmelt = (scv/snowdp/100.) ** m - fsno = tanh(snowdp/(2.5 * zlnd * fmelt)) - end if + fsno = 0.0 + IF(snowdp > 0.) THEN + fmelt = (scv/snowdp/100.) ** m + fsno = tanh(snowdp/(2.5 * zlnd * fmelt)) + ENDIF - end subroutine snowfraction + END SUBROUTINE snowfraction #if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) - subroutine snowfraction_pftwrap (ipatch,zlnd,scv,snowdp,wt,sigf,fsno) + SUBROUTINE snowfraction_pftwrap (ipatch,zlnd,scv,snowdp,wt,sigf,fsno) !======================================================================= ! @@ -93,69 +93,69 @@ subroutine snowfraction_pftwrap (ipatch,zlnd,scv,snowdp,wt,sigf,fsno) ! Hua Yuan, 08/2019: removed sigf_p to be compatible with PFT classification !======================================================================= - use MOD_Precision + USE MOD_Precision USE MOD_LandPFT USE MOD_Vars_PFTimeInvariants USE MOD_Vars_PFTimeVariables - implicit none + IMPLICIT NONE ! dummy arguments - INTEGER, INTENT(in) :: ipatch ! patch index + integer, intent(in) :: ipatch ! patch index - real(r8), INTENT(in) :: zlnd ! aerodynamic roughness length over soil surface [m] - real(r8), INTENT(in) :: scv ! snow water equivalent [mm or kg/m3] - real(r8), INTENT(in) :: snowdp ! snow depth [m] + real(r8), intent(in) :: zlnd ! aerodynamic roughness length over soil surface [m] + real(r8), intent(in) :: scv ! snow water equivalent [mm or kg/m3] + real(r8), intent(in) :: snowdp ! snow depth [m] - real(r8), INTENT(out) :: wt ! fraction of vegetation covered with snow [-] - real(r8), INTENT(out) :: sigf ! fraction of veg cover, excluding snow-covered veg [-] - real(r8), INTENT(out) :: fsno ! fraction of soil covered by snow [-] + real(r8), intent(out) :: wt ! fraction of vegetation covered with snow [-] + real(r8), intent(out) :: sigf ! fraction of veg cover, excluding snow-covered veg [-] + real(r8), intent(out) :: fsno ! fraction of soil covered by snow [-] real(r8) :: fmelt ! dimensionless metling factor real(r8), parameter :: m = 1.0 ! the value of m used in CLM4.5 is 1.0. - ! while the value of m given by Niu et al (2007) is 1.6 - ! while Niu (2012) suggested 3.0 + ! WHILE the value of m given by Niu et al (2007) is 1.6 + ! WHILE Niu (2012) suggested 3.0 !----------------------------------------------------------------------- ! local variables - INTEGER i, p, ps, pe - REAL(r8) wt_tmp + integer i, p, ps, pe + real(r8) wt_tmp - wt_tmp = 0. - ps = patch_pft_s(ipatch) - pe = patch_pft_e(ipatch) + wt_tmp = 0. + ps = patch_pft_s(ipatch) + pe = patch_pft_e(ipatch) - DO i = ps, pe - p = pftclass(i) + DO i = ps, pe + p = pftclass(i) - if(tlai_p(i)+tsai_p(i) > 1.e-6) then - ! Fraction of vegetation buried (covered) by snow - wt = 0.1*snowdp/z0m_p(i) - wt = wt/(1.+wt) + IF(tlai_p(i)+tsai_p(i) > 1.e-6) THEN + ! Fraction of vegetation buried (covered) by snow + wt = 0.1*snowdp/z0m_p(i) + wt = wt/(1.+wt) - ! Fraction of vegetation cover free of snow - sigf_p(i) = 1. - wt - else - wt = 0. - sigf_p(i) = 0. - endif + ! Fraction of vegetation cover free of snow + sigf_p(i) = 1. - wt + ELSE + wt = 0. + sigf_p(i) = 0. + ENDIF - !if(sigf_p(i) < 0.001) sigf_p(i) = 0. - !if(sigf_p(i) > 0.999) sigf_p(i) = 1. + !IF(sigf_p(i) < 0.001) sigf_p(i) = 0. + !IF(sigf_p(i) > 0.999) sigf_p(i) = 1. - wt_tmp = wt_tmp + wt*pftfrac(i) - ENDDO + wt_tmp = wt_tmp + wt*pftfrac(i) + ENDDO - wt = wt_tmp - sigf = sum(sigf_p(ps:pe) * pftfrac(ps:pe)) + wt = wt_tmp + sigf = sum(sigf_p(ps:pe) * pftfrac(ps:pe)) - ! Fraction of soil covered by snow - fsno = 0.0 - if(snowdp > 0.) then - fmelt = (scv/snowdp/100.) ** m - fsno = tanh(snowdp/(2.5 * zlnd * fmelt)) - end if + ! Fraction of soil covered by snow + fsno = 0.0 + IF(snowdp > 0.) THEN + fmelt = (scv/snowdp/100.) ** m + fsno = tanh(snowdp/(2.5 * zlnd * fmelt)) + ENDIF - end subroutine snowfraction_pftwrap + END SUBROUTINE snowfraction_pftwrap #endif END MODULE MOD_SnowFraction diff --git a/main/MOD_SnowLayersCombineDivide.F90 b/main/MOD_SnowLayersCombineDivide.F90 index 3072cf06..0fe8a7d8 100644 --- a/main/MOD_SnowLayersCombineDivide.F90 +++ b/main/MOD_SnowLayersCombineDivide.F90 @@ -3,240 +3,240 @@ MODULE MOD_SnowLayersCombineDivide !----------------------------------------------------------------------- - use MOD_Precision - IMPLICIT NONE - SAVE + USE MOD_Precision + IMPLICIT NONE + SAVE ! PUBLIC MEMBER FUNCTIONS: - public :: snowcompaction - public :: snowlayerscombine - public :: SnowLayersCombine_snicar - public :: snowlayersdivide - public :: SnowLayersDivide_snicar + PUBLIC :: snowcompaction + PUBLIC :: snowlayerscombine + PUBLIC :: SnowLayersCombine_snicar + PUBLIC :: snowlayersdivide + PUBLIC :: SnowLayersDivide_snicar ! PRIVATE MEMBER FUNCTIONS: - private :: combo - private :: winddriftcompaction + PRIVATE :: combo + PRIVATE :: winddriftcompaction !----------------------------------------------------------------------- - CONTAINS +CONTAINS !----------------------------------------------------------------------- - subroutine snowcompaction (lb,deltim,imelt,fiold,& - t_soisno,wliq_soisno,wice_soisno,forc_us,forc_vs,dz_soisno) + SUBROUTINE snowcompaction (lb,deltim,imelt,fiold,& + t_soisno,wliq_soisno,wice_soisno,forc_us,forc_vs,dz_soisno) !======================================================================= ! Original author: Yongjiu Dai, September 15, 1999 ! Revision: Yongjiu Dai, /07/31/2023 -! +! ! Four of metamorphisms of changing snow characteristics are implemented, -! i.e., destructive, overburden, melt and wind drift. The treatments of the destructive compaction +! i.e., destructive, overburden, melt and wind drift. The treatments of the destructive compaction ! was from SNTHERM.89 and SNTHERM.99 (1991, 1999). The contribution due to ! melt metamorphism is simply taken as a ratio of snow ice fraction after -! the melting versus before the melting. The treatments of the overburden comaction and the drifing compaction +! the melting versus before the melting. The treatments of the overburden comaction and the drifing compaction ! were borrowed from CLM5.0 which based on Vionnet et al. (2012) and van Kampenhout et al (2017). ! !======================================================================= - use MOD_Precision - use MOD_Const_Physical, only : denice, denh2o, tfrz - implicit none + USE MOD_Precision + USE MOD_Const_Physical, only : denice, denh2o, tfrz + IMPLICIT NONE !-------------------------- Dummy argument ----------------------------- - integer, INTENT(in) :: lb ! lower bound of array - real(r8), INTENT(in) :: deltim ! seconds i a time step [second] - integer, INTENT(in) :: imelt(lb:0) ! signifies if node in melting (imelt = 1) - real(r8), INTENT(in) :: fiold(lb:0) ! fraction of ice relative to the total water content at the previous time step - real(r8), INTENT(in) :: t_soisno(lb:0) ! nodal temperature [K] - real(r8), INTENT(in) :: wice_soisno(lb:0) ! ice lens [kg/m2] - real(r8), INTENT(in) :: wliq_soisno(lb:0) ! liquid water [kg/m2] - real(r8), INTENT(in) :: forc_us ! wind speed in eastward direction [m/s] - real(r8), INTENT(in) :: forc_vs ! wind speed in northward direction [m/s] + integer, intent(in) :: lb ! lower bound of array + real(r8), intent(in) :: deltim ! seconds i a time step [second] + integer, intent(in) :: imelt(lb:0) ! signifies IF node in melting (imelt = 1) + real(r8), intent(in) :: fiold(lb:0) ! fraction of ice relative to the total water content at the previous time step + real(r8), intent(in) :: t_soisno(lb:0) ! nodal temperature [K] + real(r8), intent(in) :: wice_soisno(lb:0) ! ice lens [kg/m2] + real(r8), intent(in) :: wliq_soisno(lb:0) ! liquid water [kg/m2] + real(r8), intent(in) :: forc_us ! wind speed in eastward direction [m/s] + real(r8), intent(in) :: forc_vs ! wind speed in northward direction [m/s] - real(r8), INTENT(inout) :: dz_soisno(lb:0) ! layer thickness [m] + real(r8), intent(inout) :: dz_soisno(lb:0) ! layer thickness [m] !----------------------- local variables ------------------------------ - integer j ! Numeber of doing loop - - real(r8), parameter :: c1 = 2.777e-7 ! [m2/(kg s)] - real(r8), parameter :: c2 = 23.0e-3 ! [m3/kg] - real(r8), parameter :: c3 = 2.777e-6 ! [1/s] - real(r8), parameter :: c4 = 0.04 ! [1/K] - real(r8), parameter :: c5 = 2.0 ! - real(r8), parameter :: c6 = 5.15e-7 ! - real(r8), parameter :: c7 = 4.0 ! - real(r8), parameter :: dm = 100.0 ! Upper Limit on Destructive Metamorphism Compaction [kg/m3] - real(r8), parameter :: eta0 = 9.e5 ! The Viscosity Coefficient Eta0 [kg-s/m2] - - real(r8) :: burden ! pressure of overlying snow [kg/m2] - real(r8) :: ddz1 ! rate of settling of snowpack due to destructive metamorphism. - real(r8) :: ddz2 ! rate of compaction of snowpack due to overburden. - real(r8) :: ddz3 ! rate of compaction of snowpack due to melt [1/s] - real(r8) :: ddz4 ! rate of compaction of snowpack due to wind drift. - - real(r8) :: dexpf ! expf=exp(-c4*(273.15-t_soisno)). - real(r8) :: fi ! fraction of ice relative to the total water content at current time step - real(r8) :: td ! t_soisno - tfrz [K] - real(r8) :: pdzdtc ! nodal rate of change in fractional-thickness due to compaction [fraction/s] - real(r8) :: void ! void (1 - vol_ice - vol_liq) - real(r8) :: wx ! water mass (ice+liquid) [kg/m2] - real(r8) :: bi ! partial density of ice [kg/m3] - - real(r8) :: zpseudo ! wind drift compaction / pseudo depth - ! (only valid if wind_dependent_snow_density is .true.) - logical :: mobile ! current snow layer is mobile, i.e. susceptible to wind drift - ! (only valid if wind_dependent_snow_density is .true.) - real(r8) :: f1, f2, eta, forc_wind + integer j ! Numeber of doing loop + + real(r8), parameter :: c1 = 2.777e-7 ! [m2/(kg s)] + real(r8), parameter :: c2 = 23.0e-3 ! [m3/kg] + real(r8), parameter :: c3 = 2.777e-6 ! [1/s] + real(r8), parameter :: c4 = 0.04 ! [1/K] + real(r8), parameter :: c5 = 2.0 ! + real(r8), parameter :: c6 = 5.15e-7 ! + real(r8), parameter :: c7 = 4.0 ! + real(r8), parameter :: dm = 100.0 ! Upper Limit on Destructive Metamorphism Compaction [kg/m3] + real(r8), parameter :: eta0 = 9.e5 ! The Viscosity Coefficient Eta0 [kg-s/m2] + + real(r8) :: burden ! pressure of overlying snow [kg/m2] + real(r8) :: ddz1 ! rate of settling of snowpack due to destructive metamorphism. + real(r8) :: ddz2 ! rate of compaction of snowpack due to overburden. + real(r8) :: ddz3 ! rate of compaction of snowpack due to melt [1/s] + real(r8) :: ddz4 ! rate of compaction of snowpack due to wind drift. + + real(r8) :: dexpf ! expf=exp(-c4*(273.15-t_soisno)). + real(r8) :: fi ! fraction of ice relative to the total water content at current time step + real(r8) :: td ! t_soisno - tfrz [K] + real(r8) :: pdzdtc ! nodal rate of change in fractional-thickness due to compaction [fraction/s] + real(r8) :: void ! void (1 - vol_ice - vol_liq) + real(r8) :: wx ! water mass (ice+liquid) [kg/m2] + real(r8) :: bi ! partial density of ice [kg/m3] + + real(r8) :: zpseudo ! wind drift compaction / pseudo depth + ! (only valid IF wind_dependent_snow_density is .true.) + logical :: mobile ! current snow layer is mobile, i.e. susceptible to wind drift + ! (only valid IF wind_dependent_snow_density is .true.) + real(r8) :: f1, f2, eta, forc_wind !======================================================================= - ! Begin calculation - note that the following column loops are only invoked if lb < 0 + ! Begin calculation - note that the following column loops are only invoked IF lb < 0 - burden = 0.0 - zpseudo = 0.0 - mobile = .true. + burden = 0.0 + zpseudo = 0.0 + mobile = .true. - do j = lb, 0 - wx = wice_soisno(j) + wliq_soisno(j) - void = 1.0-(wice_soisno(j)/denice + wliq_soisno(j)/denh2o)/dz_soisno(j) + DO j = lb, 0 + wx = wice_soisno(j) + wliq_soisno(j) + void = 1.0-(wice_soisno(j)/denice + wliq_soisno(j)/denh2o)/dz_soisno(j) ! Disallow compaction for water saturated node and lower ice lens node. - if(void <= 0.001 .or. wice_soisno(j) <= .1)then - burden = burden+wx + IF(void <= 0.001 .or. wice_soisno(j) <= .1)THEN + burden = burden+wx - ! saturated node is immobile - ! This is only needed if wind_dependent_snow_density is true, but it's - ! simplest just to update mobile always - mobile = .false. + ! saturated node is immobile + ! This is only needed IF wind_dependent_snow_density is true, but it's + ! simplest just to update mobile always + mobile = .false. - CYCLE - endif + CYCLE + ENDIF - bi = wice_soisno(j) / dz_soisno(j) - fi = wice_soisno(j) / wx - td = tfrz-t_soisno(j) + bi = wice_soisno(j) / dz_soisno(j) + fi = wice_soisno(j) / wx + td = tfrz-t_soisno(j) - dexpf = exp(-c4*td) + dexpf = exp(-c4*td) ! Compaction due to destructive metamorphism - ddz1 = -c3*dexpf - if(bi > dm) ddz1 = ddz1*exp(-46.0e-3*(bi-dm)) + ddz1 = -c3*dexpf + IF(bi > dm) ddz1 = ddz1*exp(-46.0e-3*(bi-dm)) ! Liquid water term - if(wliq_soisno(j) > 0.01*dz_soisno(j)) ddz1=ddz1*c5 + IF(wliq_soisno(j) > 0.01*dz_soisno(j)) ddz1=ddz1*c5 ! Compaction due to overburden -!* ddz2 = -burden*exp(-0.08*td-c2*bi)/eta0 - f1 = 1.0/(1.0+60.0*wliq_soisno(j)/(denh2o*dz_soisno(j))) - f2 = 4.0 ! currently fixed to maximum value, holds in absence of angular grains - eta = f1*f2*(bi/450.0)*exp(0.1*td + c2*bi)*7.62237e6 - ddz2 = -(burden+wx/2.0) / eta +!* ddz2 = -burden*exp(-0.08*td-c2*bi)/eta0 + f1 = 1.0/(1.0+60.0*wliq_soisno(j)/(denh2o*dz_soisno(j))) + f2 = 4.0 ! currently fixed to maximum value, holds in absence of angular grains + eta = f1*f2*(bi/450.0)*exp(0.1*td + c2*bi)*7.62237e6 + ddz2 = -(burden+wx/2.0) / eta ! Compaction occurring during melt - if(imelt(j) == 1)then - ddz3 = - 1.0/deltim * max(0.0,(fiold(j) - fi)/fiold(j)) - else - ddz3 = 0.0 - endif + IF(imelt(j) == 1)THEN + ddz3 = - 1.0/deltim * max(0.0,(fiold(j) - fi)/fiold(j)) + ELSE + ddz3 = 0.0 + ENDIF ! Compaction occurring due to wind drift - forc_wind = sqrt(forc_us**2+forc_vs**2) - call winddriftcompaction( bi,forc_wind,dz_soisno(j),zpseudo,mobile,ddz4 ) + forc_wind = sqrt(forc_us**2+forc_vs**2) + CALL winddriftcompaction( bi,forc_wind,dz_soisno(j),zpseudo,mobile,ddz4 ) ! Time rate of fractional change in dz (units of s-1) - pdzdtc = ddz1 + ddz2 + ddz3 + ddz4 + pdzdtc = ddz1 + ddz2 + ddz3 + ddz4 ! The change in dz_soisno due to compaction ! Limit compaction to be no greater than fully saturated layer thickness - dz_soisno(j) = dz_soisno(j)*(1.0+pdzdtc*deltim) - dz_soisno(j) = max(dz_soisno(j),(wice_soisno(j)/denice+ wliq_soisno(j)/denh2o)) + dz_soisno(j) = dz_soisno(j)*(1.0+pdzdtc*deltim) + dz_soisno(j) = max(dz_soisno(j),(wice_soisno(j)/denice+ wliq_soisno(j)/denh2o)) ! Pressure of overlying snow - burden = burden+wx + burden = burden+wx + + ENDDO - end do + END SUBROUTINE snowcompaction - end subroutine snowcompaction + !----------------------------------------------------------------------- + SUBROUTINE winddriftcompaction(bi,forc_wind,dz,zpseudo,mobile,compaction_rate) - !----------------------------------------------------------------------- - subroutine winddriftcompaction(bi,forc_wind,dz,zpseudo,mobile,compaction_rate) - ! Compute wind drift compaction for a single column and level. ! Also updates zpseudo and mobile for this column. However, zpseudo remains unchanged -! if mobile is already false or becomes false within this subroutine. +! IF mobile is already false or becomes false within this SUBROUTINE. ! ! The structure of the updates done here for zpseudo and mobile requires that this -! subroutine be called first for the top layer of snow, then for the 2nd layer down, +! SUBROUTINE be called first for the top layer of snow, THEN for the 2nd layer down, ! etc. - and finally for the bottom layer. Before beginning the loops over layers, ! mobile should be initialized to .true. and zpseudo should be initialized to 0. ! ! !USES: - use MOD_Precision - ! - ! !ARGUMENTS: - real(r8) , intent(in) :: bi ! partial density of ice [kg/m3] - real(r8) , intent(in) :: forc_wind ! atmospheric wind speed [m/s] - real(r8) , intent(in) :: dz ! layer depth for this column and level [m] - real(r8) , intent(inout) :: zpseudo ! wind drift compaction / pseudo depth for this column at this layer - logical , intent(inout) :: mobile ! whether this snow column is still mobile at this layer (i.e., susceptible to wind drift) - real(r8) , intent(out) :: compaction_rate ! rate of compaction of snowpack due to wind drift, for the current column and layer - ! - ! !LOCAL VARIABLES: - real(r8) :: Frho ! Mobility density factor [-] - real(r8) :: MO ! Mobility index [-] - real(r8) :: SI ! Driftability index [-] - real(r8) :: gamma_drift ! Scaling factor for wind drift time scale [-] - real(r8) :: tau_inverse ! Inverse of the effective time scale [1/s] - - real(r8), parameter :: rho_min = 50._r8 ! wind drift compaction / minimum density [kg/m3] - real(r8), parameter :: rho_max = 350._r8 ! wind drift compaction / maximum density [kg/m3] - real(r8), parameter :: drift_gs = 0.35e-3_r8 ! wind drift compaction / grain size (fixed value for now) - real(r8), parameter :: drift_sph = 1.0_r8 ! wind drift compaction / sphericity - real(r8), parameter :: tau_ref = 48._r8 * 3600._r8 ! wind drift compaction / reference time [s] - - !----------------------------------------------------------------------- - - if (mobile) then - Frho = 1.25_r8 - 0.0042_r8*(max(rho_min, bi)-rho_min) - ! assuming dendricity = 0, sphericity = 1, grain size = 0.35 mm Non-dendritic snow - MO = 0.34_r8 * (-0.583_r8*drift_gs - 0.833_r8*drift_sph + 0.833_r8) + 0.66_r8*Frho - SI = -2.868_r8 * exp(-0.085_r8*forc_wind) + 1._r8 + MO - - if (SI > 0.0_r8) then - SI = min(SI, 3.25_r8) - ! Increase zpseudo (wind drift / pseudo depth) to the middle of - ! the pseudo-node for the sake of the following calculation - zpseudo = zpseudo + 0.5_r8 * dz * (3.25_r8 - SI) - gamma_drift = SI*exp(-zpseudo/0.1_r8) - tau_inverse = gamma_drift / tau_ref - compaction_rate = -max(0.0_r8, rho_max-bi) * tau_inverse - ! Further increase zpseudo to the bottom of the pseudo-node for - ! the sake of calculations done on the underlying layer (i.e., - ! the next time through the j loop). - zpseudo = zpseudo + 0.5_r8 * dz * (3.25_r8 - SI) - else ! SI <= 0 - mobile = .false. - compaction_rate = 0._r8 - end if - else ! .not. mobile - compaction_rate = 0._r8 - end if - - end subroutine winddriftcompaction - - - - !----------------------------------------------------------------------- - subroutine snowlayerscombine (lb,snl, & - z_soisno,dz_soisno,zi_soisno,wliq_soisno,wice_soisno,t_soisno,scv,snowdp) + USE MOD_Precision + ! + ! !ARGUMENTS: + real(r8) , intent(in) :: bi ! partial density of ice [kg/m3] + real(r8) , intent(in) :: forc_wind ! atmospheric wind speed [m/s] + real(r8) , intent(in) :: dz ! layer depth for this column and level [m] + real(r8) , intent(inout) :: zpseudo ! wind drift compaction / pseudo depth for this column at this layer + logical , intent(inout) :: mobile ! whether this snow column is still mobile at this layer (i.e., susceptible to wind drift) + real(r8) , intent(out) :: compaction_rate ! rate of compaction of snowpack due to wind drift, for the current column and layer + ! + ! !LOCAL VARIABLES: + real(r8) :: Frho ! Mobility density factor [-] + real(r8) :: MO ! Mobility index [-] + real(r8) :: SI ! Driftability index [-] + real(r8) :: gamma_drift ! Scaling factor for wind drift time scale [-] + real(r8) :: tau_inverse ! Inverse of the effective time scale [1/s] + + real(r8), parameter :: rho_min = 50._r8 ! wind drift compaction / minimum density [kg/m3] + real(r8), parameter :: rho_max = 350._r8 ! wind drift compaction / maximum density [kg/m3] + real(r8), parameter :: drift_gs = 0.35e-3_r8 ! wind drift compaction / grain size (fixed value for now) + real(r8), parameter :: drift_sph = 1.0_r8 ! wind drift compaction / sphericity + real(r8), parameter :: tau_ref = 48._r8 * 3600._r8 ! wind drift compaction / reference time [s] + + !----------------------------------------------------------------------- + + IF (mobile) THEN + Frho = 1.25_r8 - 0.0042_r8*(max(rho_min, bi)-rho_min) + ! assuming dendricity = 0, sphericity = 1, grain size = 0.35 mm Non-dendritic snow + MO = 0.34_r8 * (-0.583_r8*drift_gs - 0.833_r8*drift_sph + 0.833_r8) + 0.66_r8*Frho + SI = -2.868_r8 * exp(-0.085_r8*forc_wind) + 1._r8 + MO + + IF (SI > 0.0_r8) THEN + SI = min(SI, 3.25_r8) + ! Increase zpseudo (wind drift / pseudo depth) to the middle of + ! the pseudo-node for the sake of the following calculation + zpseudo = zpseudo + 0.5_r8 * dz * (3.25_r8 - SI) + gamma_drift = SI*exp(-zpseudo/0.1_r8) + tau_inverse = gamma_drift / tau_ref + compaction_rate = -max(0.0_r8, rho_max-bi) * tau_inverse + ! Further increase zpseudo to the bottom of the pseudo-node for + ! the sake of calculations done on the underlying layer (i.e., + ! the next time through the j loop). + zpseudo = zpseudo + 0.5_r8 * dz * (3.25_r8 - SI) + ELSE ! SI <= 0 + mobile = .false. + compaction_rate = 0._r8 + ENDIF + ELSE ! .not. mobile + compaction_rate = 0._r8 + ENDIF + + END SUBROUTINE winddriftcompaction + + + + !----------------------------------------------------------------------- + SUBROUTINE snowlayerscombine (lb,snl, & + z_soisno,dz_soisno,zi_soisno,wliq_soisno,wice_soisno,t_soisno,scv,snowdp) !======================================================================= ! Original author : Yongjiu Dai, September 15, 1999 @@ -248,173 +248,173 @@ subroutine snowlayerscombine (lb,snl, & ! !======================================================================= - use MOD_Precision - implicit none + USE MOD_Precision + IMPLICIT NONE !-------------------------- Dummy argument ----------------------------- - integer, INTENT(in) :: lb ! lower bound of array + integer, intent(in) :: lb ! lower bound of array ! numbering from 1 (bottom) mss (surface) - real(r8), INTENT(inout) :: wice_soisno(lb:1) ! ice lens [kg/m2] - real(r8), INTENT(inout) :: wliq_soisno(lb:1) ! liquid water {kg/m2] - real(r8), INTENT(inout) :: t_soisno (lb:1) ! nodel temperature [K] - real(r8), INTENT(inout) :: dz_soisno (lb:1) ! layer thickness [m] - real(r8), INTENT(inout) :: z_soisno (lb:1) ! node depth [m] - real(r8), INTENT(inout) :: zi_soisno (lb-1:1) ! depth of layer interface [m] - real(r8), INTENT(inout) :: snowdp ! snow depth [m] - real(r8), INTENT(inout) :: scv ! snow mass - water equivalent [kg/m2] - integer, INTENT(inout) :: snl ! Number of snow + real(r8), intent(inout) :: wice_soisno(lb:1) ! ice lens [kg/m2] + real(r8), intent(inout) :: wliq_soisno(lb:1) ! liquid water {kg/m2] + real(r8), intent(inout) :: t_soisno (lb:1) ! nodel temperature [K] + real(r8), intent(inout) :: dz_soisno (lb:1) ! layer thickness [m] + real(r8), intent(inout) :: z_soisno (lb:1) ! node depth [m] + real(r8), intent(inout) :: zi_soisno (lb-1:1) ! depth of layer interface [m] + real(r8), intent(inout) :: snowdp ! snow depth [m] + real(r8), intent(inout) :: scv ! snow mass - water equivalent [kg/m2] + integer, intent(inout) :: snl ! Number of snow !----------------------- Local variables ------------------------------ - real(r8) :: drr ! thickness of the combined [m] - real(r8) :: dzmin(5) ! minimum of snow layer 1 (top) to msn0 (bottom) - real(r8) :: zwice ! total ice mass in snow - real(r8) :: zwliq ! total liquid water in snow + real(r8) :: drr ! thickness of the combined [m] + real(r8) :: dzmin(5) ! minimum of snow layer 1 (top) to msn0 (bottom) + real(r8) :: zwice ! total ice mass in snow + real(r8) :: zwliq ! total liquid water in snow - integer :: i ! number of do looping - integer :: j ! node index - integer :: k ! number of do looping - integer :: l ! node index - integer :: msn_old ! number of snow layer 1 (top) to msn0 (bottom) - integer :: mssi ! node index - integer :: neibor ! adjacent node selected for combination + integer :: i ! number of DO looping + integer :: j ! node index + integer :: k ! number of DO looping + integer :: l ! node index + integer :: msn_old ! number of snow layer 1 (top) to msn0 (bottom) + integer :: mssi ! node index + integer :: neibor ! adjacent node selected for combination - data dzmin /0.010, 0.015, 0.025, 0.055, 0.115/ + data dzmin /0.010, 0.015, 0.025, 0.055, 0.115/ !----------------------------------------------------------------------- ! check the mass of ice lens of snow, when the total less than a small value, ! combine it with the underlying neighbor msn_old = snl - do j = msn_old+1, 0 - if(wice_soisno(j) <= .1)then + DO j = msn_old+1, 0 + IF(wice_soisno(j) <= .1)THEN wliq_soisno(j+1) = wliq_soisno(j+1) + wliq_soisno(j) wice_soisno(j+1) = wice_soisno(j+1) + wice_soisno(j) ! shift all elements above this down one. - if(j > snl+1 .AND. snl < -1)then - do i = j, snl+2, -1 + IF(j > snl+1 .and. snl < -1)THEN + DO i = j, snl+2, -1 t_soisno(i) = t_soisno(i-1) wliq_soisno(i) = wliq_soisno(i-1) wice_soisno(i) = wice_soisno(i-1) dz_soisno(i) = dz_soisno(i-1) - enddo - endif + ENDDO + ENDIF snl = snl + 1 !* write(6,*) 'one snow layer is gone' - endif + ENDIF - enddo + ENDDO - if(snl == 0)then + IF(snl == 0)THEN scv = 0. snowdp = 0. !* write(6,*) 'all snow has gone' - return - else + RETURN + ELSE scv = 0. snowdp = 0. zwice = 0. zwliq = 0. - do j = snl + 1, 0 + DO j = snl + 1, 0 scv = scv + wice_soisno(j) + wliq_soisno(j) snowdp = snowdp + dz_soisno(j) zwice = zwice + wice_soisno(j) zwliq = zwliq + wliq_soisno(j) - enddo - endif + ENDDO + ENDIF !----------------------------------------------------------------------- ! check the snow depth - if(snowdp < 0.01)then !!! all snow gone + IF(snowdp < 0.01)THEN !!! all snow gone snl = 0 scv = zwice - if(scv <= 0.) snowdp = 0. + IF(scv <= 0.) snowdp = 0. ! the liquid water assumed ponding on soil surface wliq_soisno(1) = wliq_soisno(1) + zwliq !* write(6,'(17h all snow is gone)') - return + RETURN - else !!! snow layers combined + ELSE !!! snow layers combined ! two or more layers - if(snl < -1)then + IF(snl < -1)THEN msn_old = snl mssi = 1 - do i = msn_old+1, 0 + DO i = msn_old+1, 0 ! If top node is removed, combine with bottom neighbor - if(dz_soisno(i) < dzmin(mssi))then - if(i == snl+1)then + IF(dz_soisno(i) < dzmin(mssi))THEN + IF(i == snl+1)THEN neibor = i + 1 ! If the bottom neighbor is not snow, combine with the top neighbor - else if(i == 0)then + ELSE IF(i == 0)THEN neibor = i - 1 -! If none of the above special cases apply, combine with the thinnest neighbor - else +! If NONE of the above special cases apply, combine with the thinnest neighbor + ELSE neibor = i + 1 - if((dz_soisno(i-1)+dz_soisno(i)) < (dz_soisno(i+1)+dz_soisno(i))) neibor = i-1 - endif + IF((dz_soisno(i-1)+dz_soisno(i)) < (dz_soisno(i+1)+dz_soisno(i))) neibor = i-1 + ENDIF ! Node l and j are combined and stored as node j. - if(neibor > i)then + IF(neibor > i)THEN j = neibor l = i - else + ELSE j = i l = neibor - endif - call combo ( dz_soisno(j), wliq_soisno(j), wice_soisno(j), t_soisno(j),& + ENDIF + CALL combo ( dz_soisno(j), wliq_soisno(j), wice_soisno(j), t_soisno(j),& dz_soisno(l), wliq_soisno(l), wice_soisno(l), t_soisno(l) ) ! Now shift all elements above this down one. - if(j-1 > snl+1) then - do k = j-1, snl+2, -1 + IF(j-1 > snl+1) THEN + DO k = j-1, snl+2, -1 t_soisno(k) = t_soisno(k-1) wice_soisno(k) = wice_soisno(k-1) wliq_soisno(k) = wliq_soisno(k-1) dz_soisno(k) = dz_soisno(k-1) - enddo - endif + ENDDO + ENDIF snl = snl + 1 !* write(6,'(7h Nodes ,i4,4h and,i4,14h combined into,i4)') l,j,j - if(snl >= -1) EXIT + IF(snl >= -1) EXIT ! The layer thickness great than the prescibed minimum value - else + ELSE mssi = mssi + 1 - endif - enddo + ENDIF + ENDDO - end if + ENDIF ! Reset the node depth and the depth of layer interface zi_soisno(0) = 0. - do k = 0, snl+1, -1 + DO k = 0, snl+1, -1 z_soisno(k) = zi_soisno(k) - 0.5*dz_soisno(k) zi_soisno(k-1) = zi_soisno(k) - dz_soisno(k) - enddo + ENDDO - endif !!! snow layers combined + ENDIF !!! snow layers combined - end subroutine snowlayerscombine + END SUBROUTINE snowlayerscombine - subroutine snowlayersdivide (lb,snl,z_soisno,dz_soisno,zi_soisno,wliq_soisno,wice_soisno,t_soisno) + SUBROUTINE snowlayersdivide (lb,snl,z_soisno,dz_soisno,zi_soisno,wliq_soisno,wice_soisno,t_soisno) !======================================================================= ! Original author : Yongjiu Dai, September 15, 1999 @@ -422,46 +422,46 @@ subroutine snowlayersdivide (lb,snl,z_soisno,dz_soisno,zi_soisno,wliq_soisno,wic ! subdivides snow layer when its thickness exceed the prescribed maximum !======================================================================= - use MOD_Precision - implicit none + USE MOD_Precision + IMPLICIT NONE !-------------------------- Dummy argument ----------------------------- - integer, INTENT(in) :: lb ! lower bound of array - integer, INTENT(inout) :: snl ! Number of snow - real(r8), INTENT(inout) :: wice_soisno(lb:0) ! ice lens [kg/m2] - real(r8), INTENT(inout) :: wliq_soisno(lb:0) ! liquid water [kg/m2] - real(r8), INTENT(inout) :: t_soisno (lb:0) ! Nodel temperature [K] - real(r8), INTENT(inout) :: dz_soisno (lb:0) ! Layer thickness [m] - real(r8), INTENT(inout) :: z_soisno (lb:0) ! Node depth [m] - real(r8), INTENT(inout) :: zi_soisno (lb-1:0) ! Depth of layer interface [m] + integer, intent(in) :: lb ! lower bound of array + integer, intent(inout) :: snl ! Number of snow + real(r8), intent(inout) :: wice_soisno(lb:0) ! ice lens [kg/m2] + real(r8), intent(inout) :: wliq_soisno(lb:0) ! liquid water [kg/m2] + real(r8), intent(inout) :: t_soisno (lb:0) ! Nodel temperature [K] + real(r8), intent(inout) :: dz_soisno (lb:0) ! Layer thickness [m] + real(r8), intent(inout) :: z_soisno (lb:0) ! Node depth [m] + real(r8), intent(inout) :: zi_soisno (lb-1:0) ! Depth of layer interface [m] !----------------------- Local variables ------------------------------ ! numbering from 1 (surface) msno (bottom) - real(r8) :: drr ! thickness of the combined [m] - real(r8) :: dzsno(5) ! Snow layer thickness [m] - real(r8) :: swice(5) ! Partial volume of ice [m3/m3] - real(r8) :: swliq(5) ! Partial volume of liquid water [m3/m3] - real(r8) :: tsno(5) ! Nodel temperature [K] + real(r8) :: drr ! thickness of the combined [m] + real(r8) :: dzsno(5) ! Snow layer thickness [m] + real(r8) :: swice(5) ! Partial volume of ice [m3/m3] + real(r8) :: swliq(5) ! Partial volume of liquid water [m3/m3] + real(r8) :: tsno(5) ! Nodel temperature [K] - integer k ! number of do looping - integer msno ! number of snow layer 1 (top) to msno (bottom) + integer k ! number of DO looping + integer msno ! number of snow layer 1 (top) to msno (bottom) - real(r8) zwice,zwliq,propor + real(r8) zwice,zwliq,propor !----------------------------------------------------------------------- msno = abs(snl) - do k = 1, msno + DO k = 1, msno dzsno(k) = dz_soisno (k + snl) swice(k) = wice_soisno(k + snl) swliq(k) = wliq_soisno(k + snl) tsno(k) = t_soisno (k + snl) - enddo + ENDDO - if(msno == 1)then - if(dzsno(1) > 0.03)then + IF(msno == 1)THEN + IF(dzsno(1) > 0.03)THEN msno = 2 ! Specified a new snow layer dzsno(1) = dzsno(1)/2. @@ -473,11 +473,11 @@ subroutine snowlayersdivide (lb,snl,z_soisno,dz_soisno,zi_soisno,wliq_soisno,wic swliq(2) = swliq(1) tsno(2) = tsno(1) ! write(6,*)'Subdivided Top Node into two layer (1/2)' - endif - endif + ENDIF + ENDIF - if(msno > 1)then - if(dzsno(1) > 0.02)then + IF(msno > 1)THEN + IF(dzsno(1) > 0.02)THEN drr = dzsno(1) - 0.02 propor = drr/dzsno(1) zwice = propor*swice(1) @@ -488,13 +488,13 @@ subroutine snowlayersdivide (lb,snl,z_soisno,dz_soisno,zi_soisno,wliq_soisno,wic swliq(1) = propor*swliq(1) dzsno(1) = 0.02 - call combo(dzsno(2),swliq(2),swice(2),tsno(2), & + CALL combo(dzsno(2),swliq(2),swice(2),tsno(2), & drr,zwliq,zwice,tsno(1)) ! write(6,*) 'Subdivided Top Node & ! 20 mm combined into underlying neighbor' - if(msno <= 2 .AND. dzsno(2) > 0.07)then + IF(msno <= 2 .and. dzsno(2) > 0.07)THEN ! subdivided a new layer msno = 3 dzsno(2) = dzsno(2)/2. @@ -505,12 +505,12 @@ subroutine snowlayersdivide (lb,snl,z_soisno,dz_soisno,zi_soisno,wliq_soisno,wic swice(3) = swice(2) swliq(3) = swliq(2) tsno(3) = tsno(2) - endif - endif - endif + ENDIF + ENDIF + ENDIF - if(msno > 2)then - if(dzsno(2) > 0.05)then + IF(msno > 2)THEN + IF(dzsno(2) > 0.05)THEN drr = dzsno(2) - 0.05 propor = drr/dzsno(2) zwice = propor*swice(2) @@ -521,13 +521,13 @@ subroutine snowlayersdivide (lb,snl,z_soisno,dz_soisno,zi_soisno,wliq_soisno,wic swliq(2) = propor*swliq(2) dzsno(2) = 0.05 - call combo(dzsno(3),swliq(3),swice(3),tsno(3), & + CALL combo(dzsno(3),swliq(3),swice(3),tsno(3), & drr, zwliq, zwice, tsno(2)) ! write(6,*)'Subdivided 50 mm from the subsface layer & ! &and combined into underlying neighbor' - if(msno <= 3 .AND. dzsno(3) > 0.18)then + IF(msno <= 3 .and. dzsno(3) > 0.18)THEN ! subdivided a new layer msno = 4 dzsno(3) = dzsno(3)/2. @@ -538,12 +538,12 @@ subroutine snowlayersdivide (lb,snl,z_soisno,dz_soisno,zi_soisno,wliq_soisno,wic swice(4) = swice(3) swliq(4) = swliq(3) tsno(4) = tsno(3) - endif - endif - endif + ENDIF + ENDIF + ENDIF - if(msno > 3)then - if(dzsno(3) > 0.11)then + IF(msno > 3)THEN + IF(dzsno(3) > 0.11)THEN drr = dzsno(3) - 0.11 propor = drr/dzsno(3) zwice = propor*swice(3) @@ -554,13 +554,13 @@ subroutine snowlayersdivide (lb,snl,z_soisno,dz_soisno,zi_soisno,wliq_soisno,wic swliq(3) = propor*swliq(3) dzsno(3) = 0.11 - call combo(dzsno(4),swliq(4),swice(4),tsno(4), & + CALL combo(dzsno(4),swliq(4),swice(4),tsno(4), & drr, zwliq, zwice, tsno(3)) ! write(6,*)'Subdivided 110 mm from the third Node & ! &and combined into underlying neighbor' - if(msno <= 4 .AND. dzsno(4) > 0.41)then + IF(msno <= 4 .and. dzsno(4) > 0.41)THEN ! subdivided a new layer msno = 5 dzsno(4) = dzsno(4)/2. @@ -571,12 +571,12 @@ subroutine snowlayersdivide (lb,snl,z_soisno,dz_soisno,zi_soisno,wliq_soisno,wic swice(5) = swice(4) swliq(5) = swliq(4) tsno(5) = tsno(4) - endif - endif - endif + ENDIF + ENDIF + ENDIF - if(msno > 4)then - if(dzsno(4) > 0.23)then + IF(msno > 4)THEN + IF(dzsno(4) > 0.23)THEN drr = dzsno(4) - 0.23 propor = drr/dzsno(4) zwice = propor*swice(4) @@ -587,35 +587,35 @@ subroutine snowlayersdivide (lb,snl,z_soisno,dz_soisno,zi_soisno,wliq_soisno,wic swliq(4) = propor*swliq(4) dzsno(4) = 0.23 - call combo(dzsno(5),swliq(5),swice(5),tsno(5), & + CALL combo(dzsno(5),swliq(5),swice(5),tsno(5), & drr, zwliq, zwice, tsno(4)) ! write(6,*)'Subdivided 230 mm from the fourth Node & ! 'and combined into underlying neighbor' - endif - endif + ENDIF + ENDIF snl = - msno - do k = snl+1, 0 + DO k = snl+1, 0 dz_soisno(k) = dzsno(k - snl) wice_soisno(k) = swice(k - snl) wliq_soisno(k) = swliq(k - snl) t_soisno(k) = tsno (k - snl) - enddo + ENDDO zi_soisno(0) = 0. - do k = 0, snl+1, -1 + DO k = 0, snl+1, -1 z_soisno(k) = zi_soisno(k) - 0.5*dz_soisno(k) zi_soisno(k-1) = zi_soisno(k) - dz_soisno(k) - enddo + ENDDO - end subroutine snowlayersdivide + END SUBROUTINE snowlayersdivide - subroutine combo ( dz_soisno, wliq_soisno, wice_soisno, t, & - dz2, wliq2, wice2, t2 ) + SUBROUTINE combo ( dz_soisno, wliq_soisno, wice_soisno, t, & + dz2, wliq2, wice2, t2 ) !======================================================================= ! Original author: Yongjiu Dai, September 15, 1999 @@ -627,31 +627,31 @@ subroutine combo ( dz_soisno, wliq_soisno, wice_soisno, t, & ! !======================================================================= - use MOD_Precision - use MOD_Const_Physical, only : cpice, cpliq, hfus, tfrz - implicit none + USE MOD_Precision + USE MOD_Const_Physical, only : cpice, cpliq, hfus, tfrz + IMPLICIT NONE !-------------------------- Dummy argument ----------------------------- - real(r8), INTENT(in) :: dz2 ! nodal thickness of 2 elements being combined [m] - real(r8), INTENT(in) :: wliq2 ! liquid water of element 2 [kg/m2] - real(r8), INTENT(in) :: wice2 ! ice of element 2 [kg/m2] - real(r8), INTENT(in) :: t2 ! nodal temperature of element 2 [K] + real(r8), intent(in) :: dz2 ! nodal thickness of 2 elements being combined [m] + real(r8), intent(in) :: wliq2 ! liquid water of element 2 [kg/m2] + real(r8), intent(in) :: wice2 ! ice of element 2 [kg/m2] + real(r8), intent(in) :: t2 ! nodal temperature of element 2 [K] - real(r8), INTENT(inout) :: dz_soisno ! nodal thickness of 1 elements being combined [m] - real(r8), INTENT(inout) :: wliq_soisno ! liquid water of element 1 - real(r8), INTENT(inout) :: wice_soisno ! ice of element 1 [kg/m2] - real(r8), INTENT(inout) :: t ! nodel temperature of elment 1 [K] + real(r8), intent(inout) :: dz_soisno ! nodal thickness of 1 elements being combined [m] + real(r8), intent(inout) :: wliq_soisno ! liquid water of element 1 + real(r8), intent(inout) :: wice_soisno ! ice of element 1 [kg/m2] + real(r8), intent(inout) :: t ! nodel temperature of elment 1 [K] !----------------------- Local variables ------------------------------ - real(r8) dzc ! Total thickness of nodes 1 and 2 (dzc=dz_soisno+dz2). - real(r8) wliqc ! Combined liquid water [kg/m2] - real(r8) wicec ! Combined ice [kg/m2] - real(r8) tc ! Combined node temperature [K] - real(r8) h ! enthalpy of element 1 [J/m2] - real(r8) h2 ! enthalpy of element 2 [J/m2] - real(r8) hc ! temporary + real(r8) dzc ! Total thickness of nodes 1 and 2 (dzc=dz_soisno+dz2). + real(r8) wliqc ! Combined liquid water [kg/m2] + real(r8) wicec ! Combined ice [kg/m2] + real(r8) tc ! Combined node temperature [K] + real(r8) h ! enthalpy of element 1 [J/m2] + real(r8) h2 ! enthalpy of element 2 [J/m2] + real(r8) hc ! temporary !----------------------------------------------------------------------- @@ -662,28 +662,28 @@ subroutine combo ( dz_soisno, wliq_soisno, wice_soisno, t, & h2 = (cpice*wice2+cpliq*wliq2)*(t2-tfrz)+hfus*wliq2 hc = h + h2 - if(hc < 0.)then + IF(hc < 0.)THEN tc = tfrz + hc/(cpice*wicec+cpliq*wliqc) - else if(hc.le.hfus*wliqc)then + ELSE IF(hc.le.hfus*wliqc)THEN tc = tfrz - else + ELSE tc = tfrz + (hc - hfus*wliqc)/(cpice*wicec+cpliq*wliqc) - endif + ENDIF dz_soisno = dzc wice_soisno = wicec wliq_soisno = wliqc t = tc - end subroutine combo + END SUBROUTINE combo - SUBROUTINE SnowLayersCombine_snicar (lb,snl, & - z_soisno,dz_soisno,zi_soisno,wliq_soisno,wice_soisno,t_soisno,scv,snowdp,& + SUBROUTINE SnowLayersCombine_snicar (lb,snl, & + z_soisno,dz_soisno,zi_soisno,wliq_soisno,wice_soisno,t_soisno,scv,snowdp,& ! Aerosol Fluxes (Jan. 07, 2023) - mss_bcpho, mss_bcphi, mss_ocpho, mss_ocphi,& - mss_dst1 , mss_dst2 , mss_dst3 , mss_dst4 ) + mss_bcpho, mss_bcphi, mss_ocpho, mss_ocphi,& + mss_dst1 , mss_dst2 , mss_dst3 , mss_dst4 ) ! Aerosol Fluxes (Jan. 07, 2023) @@ -699,24 +699,24 @@ SUBROUTINE SnowLayersCombine_snicar (lb,snl, & ! Yongjiu Dai, 01/2023: added Aerosol fluxes from SNICAR model !======================================================================= - IMPLICIT NONE + IMPLICIT NONE !-------------------------- Dummy argument ----------------------------- - integer, INTENT(in) :: lb ! lower bound of array + integer, intent(in) :: lb ! lower bound of array ! numbering from 1 (bottom) mss (surface) - real(r8), INTENT(inout) :: wice_soisno(lb:1) ! ice lens [kg/m2] - real(r8), INTENT(inout) :: wliq_soisno(lb:1) ! liquid water {kg/m2] - real(r8), INTENT(inout) :: t_soisno (lb:1) ! nodel temperature [K] - real(r8), INTENT(inout) :: dz_soisno (lb:1) ! layer thickness [m] - real(r8), INTENT(inout) :: z_soisno (lb:1) ! node depth [m] - real(r8), INTENT(inout) :: zi_soisno (lb-1:1) ! depth of layer interface [m] - real(r8), INTENT(inout) :: snowdp ! snow depth [m] - real(r8), INTENT(inout) :: scv ! snow mass - water equivalent [kg/m2] - integer, INTENT(inout) :: snl ! Number of snow + real(r8), intent(inout) :: wice_soisno(lb:1) ! ice lens [kg/m2] + real(r8), intent(inout) :: wliq_soisno(lb:1) ! liquid water {kg/m2] + real(r8), intent(inout) :: t_soisno (lb:1) ! nodel temperature [K] + real(r8), intent(inout) :: dz_soisno (lb:1) ! layer thickness [m] + real(r8), intent(inout) :: z_soisno (lb:1) ! node depth [m] + real(r8), intent(inout) :: zi_soisno (lb-1:1) ! depth of layer interface [m] + real(r8), intent(inout) :: snowdp ! snow depth [m] + real(r8), intent(inout) :: scv ! snow mass - water equivalent [kg/m2] + integer, intent(inout) :: snl ! Number of snow ! Aerosol Fluxes (Jan. 07, 2023) - real(r8), INTENT(inout) :: & + real(r8), intent(inout) :: & mss_bcpho (lb:0), &! mass of hydrophobic BC in snow (col,lyr) [kg] mss_bcphi (lb:0), &! mass of hydrophillic BC in snow (col,lyr) [kg] mss_ocpho (lb:0), &! mass of hydrophobic OC in snow (col,lyr) [kg] @@ -728,27 +728,27 @@ SUBROUTINE SnowLayersCombine_snicar (lb,snl, & ! Aerosol Fluxes (Jan. 07, 2023) !----------------------- Local variables ------------------------------ - real(r8) :: drr ! thickness of the combined [m] - real(r8) :: dzmin(5) ! minimum of snow layer 1 (top) to msn0 (bottom) - real(r8) :: zwice ! total ice mass in snow - real(r8) :: zwliq ! total liquid water in snow + real(r8) :: drr ! thickness of the combined [m] + real(r8) :: dzmin(5) ! minimum of snow layer 1 (top) to msn0 (bottom) + real(r8) :: zwice ! total ice mass in snow + real(r8) :: zwliq ! total liquid water in snow - integer :: i ! number of do looping - integer :: j ! node index - integer :: k ! number of do looping - integer :: l ! node index - integer :: msn_old ! number of snow layer 1 (top) to msn0 (bottom) - integer :: mssi ! node index - integer :: neibor ! adjacent node selected for combination + integer :: i ! number of DO looping + integer :: j ! node index + integer :: k ! number of DO looping + integer :: l ! node index + integer :: msn_old ! number of snow layer 1 (top) to msn0 (bottom) + integer :: mssi ! node index + integer :: neibor ! adjacent node selected for combination - data dzmin /0.010, 0.015, 0.025, 0.055, 0.115/ + data dzmin /0.010, 0.015, 0.025, 0.055, 0.115/ !----------------------------------------------------------------------- ! check the mass of ice lens of snow, when the total less than a small value, ! combine it with the underlying neighbor msn_old = snl - do j = msn_old+1, 0 - if(wice_soisno(j) <= .1)then + DO j = msn_old+1, 0 + IF(wice_soisno(j) <= .1)THEN wliq_soisno(j+1) = wliq_soisno(j+1) + wliq_soisno(j) wice_soisno(j+1) = wice_soisno(j+1) + wice_soisno(j) @@ -767,8 +767,8 @@ SUBROUTINE SnowLayersCombine_snicar (lb,snl, & ! shift all elements above this down one. - if(j > snl+1 .AND. snl < -1)then - do i = j, snl+2, -1 + IF(j > snl+1 .and. snl < -1)THEN + DO i = j, snl+2, -1 t_soisno(i) = t_soisno(i-1) wliq_soisno(i) = wliq_soisno(i-1) wice_soisno(i) = wice_soisno(i-1) @@ -784,17 +784,17 @@ SUBROUTINE SnowLayersCombine_snicar (lb,snl, & mss_dst3 (i) = mss_dst3 (i-1) mss_dst4 (i) = mss_dst4 (i-1) !Aerosol Fluxes (January 07, 2023) - enddo - endif + ENDDO + ENDIF snl = snl + 1 !* write(6,*) 'one snow layer is gone' - endif + ENDIF - enddo + ENDDO - if(snl == 0)then + IF(snl == 0)THEN scv = 0._r8 snowdp = 0._r8 @@ -810,27 +810,27 @@ SUBROUTINE SnowLayersCombine_snicar (lb,snl, & !Aerosol Fluxes (January 07, 2023) !* write(6,*) 'all snow has gone' - return - else + RETURN + ELSE scv = 0._r8 snowdp = 0._r8 zwice = 0._r8 zwliq = 0._r8 - do j = snl + 1, 0 + DO j = snl + 1, 0 scv = scv + wice_soisno(j) + wliq_soisno(j) snowdp = snowdp + dz_soisno(j) zwice = zwice + wice_soisno(j) zwliq = zwliq + wliq_soisno(j) - enddo - endif + ENDDO + ENDIF !----------------------------------------------------------------------- ! check the snow depth - if(snowdp < 0.01_r8)then !!! all snow gone + IF(snowdp < 0.01_r8)THEN !!! all snow gone snl = 0 scv = zwice - if(scv <= 0._r8) snowdp = 0._r8 + IF(scv <= 0._r8) snowdp = 0._r8 !Aerosol Fluxes (January 07, 2023) mss_bcphi(:) = 0._r8 @@ -846,42 +846,42 @@ SUBROUTINE SnowLayersCombine_snicar (lb,snl, & ! the liquid water assumed ponding on soil surface wliq_soisno(1) = wliq_soisno(1) + zwliq !* write(6,'(17h all snow is gone)') - return + RETURN - else !!! snow layers combined + ELSE !!! snow layers combined ! two or more layers - if(snl < -1)then + IF(snl < -1)THEN msn_old = snl mssi = 1 - do i = msn_old+1, 0 + DO i = msn_old+1, 0 ! If top node is removed, combine with bottom neighbor - if(dz_soisno(i) < dzmin(mssi))then - if(i == snl+1)then + IF(dz_soisno(i) < dzmin(mssi))THEN + IF(i == snl+1)THEN neibor = i + 1 ! If the bottom neighbor is not snow, combine with the top neighbor - else if(i == 0)then + ELSE IF(i == 0)THEN neibor = i - 1 -! If none of the above special cases apply, combine with the thinnest neighbor - else +! If NONE of the above special cases apply, combine with the thinnest neighbor + ELSE neibor = i + 1 - if((dz_soisno(i-1)+dz_soisno(i)) < (dz_soisno(i+1)+dz_soisno(i))) neibor = i-1 - endif + IF((dz_soisno(i-1)+dz_soisno(i)) < (dz_soisno(i+1)+dz_soisno(i))) neibor = i-1 + ENDIF ! Node l and j are combined and stored as node j. - if(neibor > i)then + IF(neibor > i)THEN j = neibor l = i - else + ELSE j = i l = neibor - endif - call combo ( dz_soisno(j), wliq_soisno(j), wice_soisno(j), t_soisno(j),& + ENDIF + CALL combo ( dz_soisno(j), wliq_soisno(j), wice_soisno(j), t_soisno(j),& dz_soisno(l), wliq_soisno(l), wice_soisno(l), t_soisno(l) ) !Aerosol Fluxes (January 07, 2023) @@ -898,8 +898,8 @@ SUBROUTINE SnowLayersCombine_snicar (lb,snl, & ! Now shift all elements above this down one. - if(j-1 > snl+1) then - do k = j-1, snl+2, -1 + IF(j-1 > snl+1) THEN + DO k = j-1, snl+2, -1 t_soisno(k) = t_soisno(k-1) wice_soisno(k) = wice_soisno(k-1) wliq_soisno(k) = wliq_soisno(k-1) @@ -915,44 +915,44 @@ SUBROUTINE SnowLayersCombine_snicar (lb,snl, & mss_dst3 (k) = mss_dst3 (k-1) mss_dst4 (k) = mss_dst4 (k-1) !Aerosol Fluxes (January 07, 2023) - enddo - endif + ENDDO + ENDIF snl = snl + 1 !* write(6,'(7h Nodes ,i4,4h and,i4,14h combined into,i4)') l,j,j - if(snl >= -1) EXIT + IF(snl >= -1) EXIT ! The layer thickness great than the prescibed minimum value - else + ELSE mssi = mssi + 1 - endif - enddo + ENDIF + ENDDO - end if + ENDIF ! Reset the node depth and the depth of layer interface zi_soisno(0) = 0._r8 - do k = 0, snl+1, -1 + DO k = 0, snl+1, -1 z_soisno(k) = zi_soisno(k) - 0.5_r8*dz_soisno(k) zi_soisno(k-1) = zi_soisno(k) - dz_soisno(k) - enddo + ENDDO - endif !!! snow layers combined + ENDIF !!! snow layers combined - END SUBROUTINE SnowLayersCombine_snicar + END SUBROUTINE SnowLayersCombine_snicar !----------------------------------------------------------------------- - SUBROUTINE SnowLayersDivide_snicar (lb,snl,z_soisno,dz_soisno,zi_soisno,& - wliq_soisno,wice_soisno,t_soisno,& + SUBROUTINE SnowLayersDivide_snicar (lb,snl,z_soisno,dz_soisno,zi_soisno,& + wliq_soisno,wice_soisno,t_soisno,& ! Aerosol Fluxes (Jan. 07, 2023) - mss_bcpho, mss_bcphi, mss_ocpho, mss_ocphi,& - mss_dst1 , mss_dst2 , mss_dst3 , mss_dst4 ) + mss_bcpho, mss_bcphi, mss_ocpho, mss_ocphi,& + mss_dst1 , mss_dst2 , mss_dst3 , mss_dst4 ) ! Aerosol Fluxes (Jan. 07, 2023) @@ -965,21 +965,21 @@ SUBROUTINE SnowLayersDivide_snicar (lb,snl,z_soisno,dz_soisno,zi_soisno,& ! Yongjiu Dai, 01/2023: added Aerosol fluxes from SNICAR model !======================================================================= - IMPLICIT NONE + IMPLICIT NONE !-------------------------- Dummy argument ----------------------------- - integer, INTENT(in) :: lb ! lower bound of array - integer, INTENT(inout) :: snl ! Number of snow - real(r8), INTENT(inout) :: wice_soisno(lb:0) ! ice lens [kg/m2] - real(r8), INTENT(inout) :: wliq_soisno(lb:0) ! liquid water [kg/m2] - real(r8), INTENT(inout) :: t_soisno (lb:0) ! Nodel temperature [K] - real(r8), INTENT(inout) :: dz_soisno (lb:0) ! Layer thickness [m] - real(r8), INTENT(inout) :: z_soisno (lb:0) ! Node depth [m] - real(r8), INTENT(inout) :: zi_soisno (lb-1:0) ! Depth of layer interface [m] + integer, intent(in) :: lb ! lower bound of array + integer, intent(inout) :: snl ! Number of snow + real(r8), intent(inout) :: wice_soisno(lb:0) ! ice lens [kg/m2] + real(r8), intent(inout) :: wliq_soisno(lb:0) ! liquid water [kg/m2] + real(r8), intent(inout) :: t_soisno (lb:0) ! Nodel temperature [K] + real(r8), intent(inout) :: dz_soisno (lb:0) ! Layer thickness [m] + real(r8), intent(inout) :: z_soisno (lb:0) ! Node depth [m] + real(r8), intent(inout) :: zi_soisno (lb-1:0) ! Depth of layer interface [m] ! Aerosol Fluxes (Jan. 07, 2023) - real(r8), INTENT(inout) :: & + real(r8), intent(inout) :: & mss_bcpho (lb:0), &! mass of hydrophobic BC in snow (col,lyr) [kg] mss_bcphi (lb:0), &! mass of hydrophillic BC in snow (col,lyr) [kg] mss_ocpho (lb:0), &! mass of hydrophobic OC in snow (col,lyr) [kg] @@ -993,26 +993,26 @@ SUBROUTINE SnowLayersDivide_snicar (lb,snl,z_soisno,dz_soisno,zi_soisno,& !----------------------- Local variables ------------------------------ ! numbering from 1 (surface) msno (bottom) - real(r8) :: drr ! thickness of the combined [m] - real(r8) :: dzsno(5) ! Snow layer thickness [m] - real(r8) :: swice(5) ! Partial volume of ice [m3/m3] - real(r8) :: swliq(5) ! Partial volume of liquid water [m3/m3] - real(r8) :: tsno(5) ! Nodel temperature [K] + real(r8) :: drr ! thickness of the combined [m] + real(r8) :: dzsno(5) ! Snow layer thickness [m] + real(r8) :: swice(5) ! Partial volume of ice [m3/m3] + real(r8) :: swliq(5) ! Partial volume of liquid water [m3/m3] + real(r8) :: tsno(5) ! Nodel temperature [K] - integer k ! number of do looping - integer msno ! number of snow layer 1 (top) to msno (bottom) + integer k ! number of DO looping + integer msno ! number of snow layer 1 (top) to msno (bottom) - real(r8) zwice,zwliq,propor + real(r8) zwice,zwliq,propor !Aerosol Fluxes (January 07, 2023) - real(r8) mss_aerosol(5,8) - real(r8) z_mss_aerosol(8) + real(r8) mss_aerosol(5,8) + real(r8) z_mss_aerosol(8) !Aerosol Fluxes (January 07, 2023) !----------------------------------------------------------------------- msno = abs(snl) - do k = 1, msno + DO k = 1, msno dzsno(k) = dz_soisno (k + snl) swice(k) = wice_soisno(k + snl) swliq(k) = wliq_soisno(k + snl) @@ -1029,10 +1029,10 @@ SUBROUTINE SnowLayersDivide_snicar (lb,snl,z_soisno,dz_soisno,zi_soisno,& mss_aerosol(k, 8) = mss_dst4 (k+snl) !Aerosol Fluxes (January 07, 2023) - enddo + ENDDO - if(msno == 1)then - if(dzsno(1) > 0.03)then + IF(msno == 1)THEN + IF(dzsno(1) > 0.03)THEN msno = 2 ! Specified a new snow layer dzsno(1) = dzsno(1)/2. @@ -1052,11 +1052,11 @@ SUBROUTINE SnowLayersDivide_snicar (lb,snl,z_soisno,dz_soisno,zi_soisno,& tsno(2) = tsno(1) ! write(6,*)'Subdivided Top Node into two layer (1/2)' - endif - endif + ENDIF + ENDIF - if(msno > 1)then - if(dzsno(1) > 0.02)then + IF(msno > 1)THEN + IF(dzsno(1) > 0.02)THEN drr = dzsno(1) - 0.02 propor = drr/dzsno(1) zwice = propor*swice(1) @@ -1074,7 +1074,7 @@ SUBROUTINE SnowLayersDivide_snicar (lb,snl,z_soisno,dz_soisno,zi_soisno,& dzsno(1) = 0.02 - call combo(dzsno(2),swliq(2),swice(2),tsno(2), & + CALL combo(dzsno(2),swliq(2),swice(2),tsno(2), & drr,zwliq,zwice,tsno(1)) !Aerosol Fluxes (January 07, 2023) @@ -1084,7 +1084,7 @@ SUBROUTINE SnowLayersDivide_snicar (lb,snl,z_soisno,dz_soisno,zi_soisno,& ! write(6,*) 'Subdivided Top Node & ! 20 mm combined into underlying neighbor' - if(msno <= 2 .AND. dzsno(2) > 0.07)then + IF(msno <= 2 .and. dzsno(2) > 0.07)THEN ! subdivided a new layer msno = 3 dzsno(2) = dzsno(2)/2. @@ -1102,12 +1102,12 @@ SUBROUTINE SnowLayersDivide_snicar (lb,snl,z_soisno,dz_soisno,zi_soisno,& !Aerosol Fluxes (January 07, 2023) tsno(3) = tsno(2) - endif - endif - endif + ENDIF + ENDIF + ENDIF - if(msno > 2)then - if(dzsno(2) > 0.05)then + IF(msno > 2)THEN + IF(dzsno(2) > 0.05)THEN drr = dzsno(2) - 0.05 propor = drr/dzsno(2) zwice = propor*swice(2) @@ -1125,7 +1125,7 @@ SUBROUTINE SnowLayersDivide_snicar (lb,snl,z_soisno,dz_soisno,zi_soisno,& dzsno(2) = 0.05 - call combo(dzsno(3),swliq(3),swice(3),tsno(3), & + CALL combo(dzsno(3),swliq(3),swice(3),tsno(3), & drr, zwliq, zwice, tsno(2)) !Aerosol Fluxes (January 07, 2023) @@ -1135,7 +1135,7 @@ SUBROUTINE SnowLayersDivide_snicar (lb,snl,z_soisno,dz_soisno,zi_soisno,& ! write(6,*)'Subdivided 50 mm from the subsface layer & ! &and combined into underlying neighbor' - if(msno <= 3 .AND. dzsno(3) > 0.18)then + IF(msno <= 3 .and. dzsno(3) > 0.18)THEN ! subdivided a new layer msno = 4 dzsno(3) = dzsno(3)/2. @@ -1154,12 +1154,12 @@ SUBROUTINE SnowLayersDivide_snicar (lb,snl,z_soisno,dz_soisno,zi_soisno,& tsno(4) = tsno(3) - endif - endif - endif + ENDIF + ENDIF + ENDIF - if(msno > 3)then - if(dzsno(3) > 0.11)then + IF(msno > 3)THEN + IF(dzsno(3) > 0.11)THEN drr = dzsno(3) - 0.11 propor = drr/dzsno(3) zwice = propor*swice(3) @@ -1177,7 +1177,7 @@ SUBROUTINE SnowLayersDivide_snicar (lb,snl,z_soisno,dz_soisno,zi_soisno,& dzsno(3) = 0.11 - call combo(dzsno(4),swliq(4),swice(4),tsno(4), & + CALL combo(dzsno(4),swliq(4),swice(4),tsno(4), & drr, zwliq, zwice, tsno(3)) !Aerosol Fluxes (January 07, 2023) @@ -1187,7 +1187,7 @@ SUBROUTINE SnowLayersDivide_snicar (lb,snl,z_soisno,dz_soisno,zi_soisno,& ! write(6,*)'Subdivided 110 mm from the third Node & ! &and combined into underlying neighbor' - if(msno <= 4 .AND. dzsno(4) > 0.41)then + IF(msno <= 4 .and. dzsno(4) > 0.41)THEN ! subdivided a new layer msno = 5 dzsno(4) = dzsno(4)/2. @@ -1206,12 +1206,12 @@ SUBROUTINE SnowLayersDivide_snicar (lb,snl,z_soisno,dz_soisno,zi_soisno,& tsno(5) = tsno(4) - endif - endif - endif + ENDIF + ENDIF + ENDIF - if(msno > 4)then - if(dzsno(4) > 0.23)then + IF(msno > 4)THEN + IF(dzsno(4) > 0.23)THEN drr = dzsno(4) - 0.23 propor = drr/dzsno(4) zwice = propor*swice(4) @@ -1229,7 +1229,7 @@ SUBROUTINE SnowLayersDivide_snicar (lb,snl,z_soisno,dz_soisno,zi_soisno,& dzsno(4) = 0.23 - call combo(dzsno(5),swliq(5),swice(5),tsno(5), & + CALL combo(dzsno(5),swliq(5),swice(5),tsno(5), & drr, zwliq, zwice, tsno(4)) !Aerosol Fluxes (January 07, 2023) @@ -1238,12 +1238,12 @@ SUBROUTINE SnowLayersDivide_snicar (lb,snl,z_soisno,dz_soisno,zi_soisno,& ! write(6,*)'Subdivided 230 mm from the fourth Node & ! 'and combined into underlying neighbor' - endif - endif + ENDIF + ENDIF snl = - msno - do k = snl+1, 0 + DO k = snl+1, 0 dz_soisno(k) = dzsno(k - snl) wice_soisno(k) = swice(k - snl) wliq_soisno(k) = swliq(k - snl) @@ -1261,17 +1261,16 @@ SUBROUTINE SnowLayersDivide_snicar (lb,snl,z_soisno,dz_soisno,zi_soisno,& t_soisno(k) = tsno (k - snl) - enddo + ENDDO zi_soisno(0) = 0. - do k = 0, snl+1, -1 + DO k = 0, snl+1, -1 z_soisno(k) = zi_soisno(k) - 0.5*dz_soisno(k) zi_soisno(k-1) = zi_soisno(k) - dz_soisno(k) - enddo + ENDDO - END SUBROUTINE SnowLayersDivide_snicar + END SUBROUTINE SnowLayersDivide_snicar !----------------------------------------------------------------------- - END MODULE MOD_SnowLayersCombineDivide diff --git a/main/MOD_SnowSnicar.F90 b/main/MOD_SnowSnicar.F90 index 54538f05..8ccc10d0 100644 --- a/main/MOD_SnowSnicar.F90 +++ b/main/MOD_SnowSnicar.F90 @@ -3,407 +3,407 @@ !------------------------------------------------------------------------- MODULE MOD_SnowSnicar - !----------------------------------------------------------------------- - ! DESCRIPTION: - ! Calculate albedo of snow containing impurities - ! and the evolution of snow effective radius - ! - ! ORIGINAL: - ! 1) The Community Land Model version 5.0 (CLM5.0) - ! 2) Energy Exascale Earth System Model version 2.0 (E3SM v2.0) Land Model (ELM v2.0) - ! - ! REFERENCES: - ! 1) Flanner et al, 2021, SNICAR-ADv3: a community tool for modeling spectral snow albedo. - ! Geosci. Model Dev., 14, 7673–7704, https://doi.org/10.5194/gmd-14-7673-2021 - ! 2) Hao et al., 2023, Improving snow albedo modeling in the E3SM land model (version 2.0) - ! and assessing its impacts on snow and surface fluxes over the Tibetan Plateau. - ! Geosci. Model Dev., 16, 75–94, https://doi.org/10.5194/gmd-16-75-2023 - ! - ! REVISIONS: - ! Yongjiu Dai, and Hua Yuan, December, 2022 : ASSEMBLING and FITTING - ! - ! !USES: - USE MOD_Precision - USE MOD_Vars_Global, only: maxsnl - USE MOD_SPMD_Task - - IMPLICIT NONE -! save - real(R8),parameter :: SHR_CONST_PI = 3.14159265358979323846_R8 - real(R8),parameter :: SHR_CONST_RHOICE = 0.917e3_R8 ! density of ice (kg/m^3) - - integer, parameter :: iulog = 6 ! "stdout" log file unit number, default is 6 - integer, parameter :: numrad = 2 ! number of solar radiation bands: vis, nir + !----------------------------------------------------------------------- + ! DESCRIPTION: + ! Calculate albedo of snow containing impurities + ! and the evolution of snow effective radius + ! + ! ORIGINAL: + ! 1) The Community Land Model version 5.0 (CLM5.0) + ! 2) Energy Exascale Earth System Model version 2.0 (E3SM v2.0) Land Model (ELM v2.0) + ! + ! REFERENCES: + ! 1) Flanner et al, 2021, SNICAR-ADv3: a community tool for modeling spectral snow albedo. + ! Geosci. Model Dev., 14, 7673–7704, https://doi.org/10.5194/gmd-14-7673-2021 + ! 2) Hao et al., 2023, Improving snow albedo modeling in the E3SM land model (version 2.0) + ! and assessing its impacts on snow and surface fluxes over the Tibetan Plateau. + ! Geosci. Model Dev., 16, 75–94, https://doi.org/10.5194/gmd-16-75-2023 + ! + ! REVISIONS: + ! Yongjiu Dai, and Hua Yuan, December, 2022 : ASSEMBLING and FITTING + ! + ! !USES: + USE MOD_Precision + USE MOD_Vars_Global, only: maxsnl + USE MOD_SPMD_Task + + IMPLICIT NONE +! SAVE + real(R8),parameter :: SHR_CONST_PI = 3.14159265358979323846_R8 + real(R8),parameter :: SHR_CONST_RHOICE = 0.917e3_R8 ! density of ice (kg/m^3) + + integer, parameter :: iulog = 6 ! "stdout" log file unit number, default is 6 + integer, parameter :: numrad = 2 ! number of solar radiation bands: vis, nir !-------------------------------------------------------------------- ! DAI, Dec. 29, 2022 ! Temporay setting - logical, parameter :: use_extrasnowlayers = .false. - character(len=256), parameter :: snow_shape = 'sphere' ! (=1), 'spheroid'(=2), 'hexagonal_plate'(=3), 'koch_snowflake'(=4) - logical, parameter :: use_dust_snow_internal_mixing = .false. - character(len=256), parameter :: snicar_atm_type = 'default' ! Atmospheric profile used to obtain surface-incident spectral flux distribution - ! and subsequent broadband albedo - ! = 'mid-latitude_winter' ! => 1 - ! = 'mid-latitude_summer' ! => 2 - ! = 'sub-Arctic_winter' ! => 3 - ! = 'sub-Arctic_summer' ! => 4 - ! = 'summit_Greenland' ! => 5 (sub-Arctic summer, surface pressure of 796hPa) - ! = 'high_mountain' ! => 6 (summer, surface pressure of 556 hPa) + logical, parameter :: use_extrasnowlayers = .false. + character(len=256), parameter :: snow_shape = 'sphere' ! (=1), 'spheroid'(=2), 'hexagonal_plate'(=3), 'koch_snowflake'(=4) + logical, parameter :: use_dust_snow_internal_mixing = .false. + character(len=256), parameter :: snicar_atm_type = 'default' ! Atmospheric profile used to obtain surface-incident spectral flux distribution + ! and subsequent broadband albedo + ! = 'mid-latitude_winter' ! => 1 + ! = 'mid-latitude_summer' ! => 2 + ! = 'sub-Arctic_winter' ! => 3 + ! = 'sub-Arctic_summer' ! => 4 + ! = 'summit_Greenland' ! => 5 (sub-Arctic summer, surface pressure of 796hPa) + ! = 'high_mountain' ! => 6 (summer, surface pressure of 556 hPa) !DAI, Dec. 29, 2022 !----------------------------------------------------------------------- - ! !PUBLIC MEMBER FUNCTIONS: - public :: SNICAR_RT ! Snow albedo and vertically-resolved solar absorption - public :: SNICAR_AD_RT ! Snow albedo and vertically-resolved solar absorption by adding-doubling solution - ! To use this subtroutine, set use_snicar_ad = true - public :: SnowAge_grain ! Snow effective grain size evolution - public :: SnowAge_init ! Initial read in of snow-aging file - public :: SnowOptics_init ! Initial read in of snow-optics file - ! - ! !PUBLIC DATA MEMBERS: - integer, public, parameter :: sno_nbr_aer = 8 ! number of aerosol species in snowpack - ! (indices described above) [nbr] - logical, public, parameter :: DO_SNO_OC = .false. ! parameter to include organic carbon (OC) - ! in snowpack radiative calculations - logical, public, parameter :: DO_SNO_AER = .true. ! parameter to include aerosols in snowpack radiative calculations - ! !PRIVATE DATA MEMBERS: - integer, parameter :: numrad_snw = 5 ! number of spectral bands used in snow model [nbr] - integer, parameter :: nir_bnd_bgn = 2 ! first band index in near-IR spectrum [idx] - integer, parameter :: nir_bnd_end = 5 ! ending near-IR band index [idx] - integer, parameter :: idx_Mie_snw_mx = 1471 ! number of effective radius indices used in Mie lookup table [idx] - integer, parameter :: idx_T_max = 11 ! maxiumum temperature index used in aging lookup table [idx] - integer, parameter :: idx_T_min = 1 ! minimum temperature index used in aging lookup table [idx] - integer, parameter :: idx_Tgrd_max = 31 ! maxiumum temperature gradient index used in aging lookup table [idx] - integer, parameter :: idx_Tgrd_min = 1 ! minimum temperature gradient index used in aging lookup table [idx] - integer, parameter :: idx_rhos_max = 8 ! maxiumum snow density index used in aging lookup table [idx] - integer, parameter :: idx_rhos_min = 1 ! minimum snow density index used in aging lookup table [idx] + ! !PUBLIC MEMBER FUNCTIONS: + PUBLIC :: SNICAR_RT ! Snow albedo and vertically-resolved solar absorption + PUBLIC :: SNICAR_AD_RT ! Snow albedo and vertically-resolved solar absorption by adding-doubling solution + ! To USE this subtroutine, set use_snicar_ad = true + PUBLIC :: SnowAge_grain ! Snow effective grain size evolution + PUBLIC :: SnowAge_init ! Initial read in of snow-aging file + PUBLIC :: SnowOptics_init ! Initial read in of snow-optics file + ! + ! !PUBLIC DATA MEMBERS: + integer, PUBLIC, parameter :: sno_nbr_aer = 8 ! number of aerosol species in snowpack + ! (indices described above) [nbr] + logical, PUBLIC, parameter :: DO_SNO_OC = .false. ! parameter to include organic carbon (OC) + ! in snowpack radiative calculations + logical, PUBLIC, parameter :: DO_SNO_AER = .true. ! parameter to include aerosols in snowpack radiative calculations + ! !PRIVATE DATA MEMBERS: + integer, parameter :: numrad_snw = 5 ! number of spectral bands used in snow model [nbr] + integer, parameter :: nir_bnd_bgn = 2 ! first band index in near-IR spectrum [idx] + integer, parameter :: nir_bnd_end = 5 ! ending near-IR band index [idx] + integer, parameter :: idx_Mie_snw_mx = 1471 ! number of effective radius indices used in Mie lookup table [idx] + integer, parameter :: idx_T_max = 11 ! maxiumum temperature index used in aging lookup table [idx] + integer, parameter :: idx_T_min = 1 ! minimum temperature index used in aging lookup table [idx] + integer, parameter :: idx_Tgrd_max = 31 ! maxiumum temperature gradient index used in aging lookup table [idx] + integer, parameter :: idx_Tgrd_min = 1 ! minimum temperature gradient index used in aging lookup table [idx] + integer, parameter :: idx_rhos_max = 8 ! maxiumum snow density index used in aging lookup table [idx] + integer, parameter :: idx_rhos_min = 1 ! minimum snow density index used in aging lookup table [idx] #ifdef MODAL_AER - ! NOTE: right now the macro 'MODAL_AER' is not defined anywhere, i.e., - ! the below (modal aerosol scheme) is not available and can not be - ! active either. It depends on the specific input aerosol deposition - ! data which is suitable for modal scheme. [06/15/2023, Hua Yuan] - !mgf++ - integer, parameter :: idx_bc_nclrds_min = 1 ! minimum index for BC particle size in optics lookup table - integer, parameter :: idx_bc_nclrds_max = 10 ! maximum index for BC particle size in optics lookup table - integer, parameter :: idx_bcint_icerds_min = 1 ! minimum index for snow grain size in optics lookup table for within-ice BC - integer, parameter :: idx_bcint_icerds_max = 8 ! maximum index for snow grain size in optics lookup table for within-ice BC - !mgf-- + ! NOTE: right now the macro 'MODAL_AER' is not defined anywhere, i.e., + ! the below (modal aerosol scheme) is not available and can not be + ! active either. It depends on the specific input aerosol deposition + ! data which is suitable for modal scheme. [06/15/2023, Hua Yuan] + !mgf++ + integer, parameter :: idx_bc_nclrds_min = 1 ! minimum index for BC particle size in optics lookup table + integer, parameter :: idx_bc_nclrds_max = 10 ! maximum index for BC particle size in optics lookup table + integer, parameter :: idx_bcint_icerds_min = 1 ! minimum index for snow grain size in optics lookup table for within-ice BC + integer, parameter :: idx_bcint_icerds_max = 8 ! maximum index for snow grain size in optics lookup table for within-ice BC + !mgf-- #endif - integer, parameter :: snw_rds_max_tbl = 1500 ! maximum effective radius defined in Mie lookup table [microns] - integer, parameter :: snw_rds_min_tbl = 30 ! minimium effective radius defined in Mie lookup table [microns] - real(r8), parameter :: snw_rds_max = 1500._r8 ! maximum allowed snow effective radius [microns] - real(r8), parameter :: snw_rds_min = 54.526_r8 ! minimum allowed snow effective radius (also "fresh snow" value) [microns - real(r8), parameter :: snw_rds_refrz = 1000._r8 ! effective radius of re-frozen snow [microns] - real(r8), parameter :: min_snw = 1.0E-30_r8 ! minimum snow mass required for SNICAR RT calculation [kg m-2] - !real(r8), parameter :: C1_liq_Brun89 = 1.28E-17_r8 ! constant for liquid water grain growth [m3 s-1], - ! from Brun89 - real(r8), parameter :: C1_liq_Brun89 = 0._r8 ! constant for liquid water grain growth [m3 s-1], - ! from Brun89: zeroed to accomodate dry snow aging - real(r8), parameter :: C2_liq_Brun89 = 4.22E-13_r8 ! constant for liquid water grain growth [m3 s-1], - ! from Brun89: corrected for LWC in units of percent - - real(r8), parameter :: tim_cns_bc_rmv = 2.2E-8_r8 ! time constant for removal of BC in snow on sea-ice - ! [s-1] (50% mass removal/year) - real(r8), parameter :: tim_cns_oc_rmv = 2.2E-8_r8 ! time constant for removal of OC in snow on sea-ice - ! [s-1] (50% mass removal/year) - real(r8), parameter :: tim_cns_dst_rmv = 2.2E-8_r8 ! time constant for removal of dust in snow on sea-ice - ! [s-1] (50% mass removal/year) - !$acc declare copyin(C1_liq_Brun89, C2_liq_Brun89, & - !$acc tim_cns_bc_rmv, tim_cns_oc_rmv, tim_cns_dst_rmv) - - ! scaling of the snow aging rate (tuning option): - logical :: flg_snoage_scl = .false. ! flag for scaling the snow aging rate by some arbitrary factor - real(r8), parameter :: xdrdt = 1.0_r8 ! arbitrary factor applied to snow aging rate - ! snow and aerosol Mie parameters: - ! (arrays declared here, but are set in iniTimeConst) - ! (idx_Mie_snw_mx is number of snow radii with defined parameters (i.e. from 30um to 1500um)) - - ! direct-beam weighted ice optical properties - real(r8), allocatable :: ss_alb_snw_drc (:,:) ! (idx_Mie_snw_mx,numrad_snw); - real(r8), allocatable :: asm_prm_snw_drc (:,:) ! (idx_Mie_snw_mx,numrad_snw); - real(r8), allocatable :: ext_cff_mss_snw_drc(:,:) ! (idx_Mie_snw_mx,numrad_snw); - - ! diffuse radiation weighted ice optical properties - real(r8), allocatable :: ss_alb_snw_dfs (:,:) ! (idx_Mie_snw_mx,numrad_snw); - real(r8), allocatable :: asm_prm_snw_dfs (:,:) ! (idx_Mie_snw_mx,numrad_snw); - real(r8), allocatable :: ext_cff_mss_snw_dfs(:,:) ! (idx_Mie_snw_mx,numrad_snw); - - ! direct & diffuse flux - real(r8), allocatable :: flx_wgt_dir (:,:,:) ! (6, 90, numrad_snw) ! direct flux, six atmospheric types, 0-89 SZA - real(r8), allocatable :: flx_wgt_dif (:,:) ! (6, numrad_snw) ! diffuse flux, six atmospheric types - - ! snow grain shape - integer, parameter :: snow_shape_sphere = 1 - integer, parameter :: snow_shape_spheroid = 2 - integer, parameter :: snow_shape_hexagonal_plate = 3 - integer, parameter :: snow_shape_koch_snowflake = 4 - - ! atmospheric condition for SNICAR-AD - integer, parameter :: atm_type_default = 0 - integer, parameter :: atm_type_mid_latitude_winter = 1 - integer, parameter :: atm_type_mid_latitude_summer = 2 - integer, parameter :: atm_type_sub_Arctic_winter = 3 - integer, parameter :: atm_type_sub_Arctic_summer = 4 - integer, parameter :: atm_type_summit_Greenland = 5 - integer, parameter :: atm_type_high_mountain = 6 + integer, parameter :: snw_rds_max_tbl = 1500 ! maximum effective radius defined in Mie lookup table [microns] + integer, parameter :: snw_rds_min_tbl = 30 ! minimium effective radius defined in Mie lookup table [microns] + real(r8), parameter :: snw_rds_max = 1500._r8 ! maximum allowed snow effective radius [microns] + real(r8), parameter :: snw_rds_min = 54.526_r8 ! minimum allowed snow effective radius (also "fresh snow" value) [microns + real(r8), parameter :: snw_rds_refrz = 1000._r8 ! effective radius of re-frozen snow [microns] + real(r8), parameter :: min_snw = 1.0E-30_r8 ! minimum snow mass required for SNICAR RT calculation [kg m-2] + !real(r8), parameter :: C1_liq_Brun89 = 1.28E-17_r8 ! constant for liquid water grain growth [m3 s-1], + ! from Brun89 + real(r8), parameter :: C1_liq_Brun89 = 0._r8 ! constant for liquid water grain growth [m3 s-1], + ! from Brun89: zeroed to accomodate dry snow aging + real(r8), parameter :: C2_liq_Brun89 = 4.22E-13_r8 ! constant for liquid water grain growth [m3 s-1], + ! from Brun89: corrected for LWC in units of percent + + real(r8), parameter :: tim_cns_bc_rmv = 2.2E-8_r8 ! time constant for removal of BC in snow on sea-ice + ! [s-1] (50% mass removal/year) + real(r8), parameter :: tim_cns_oc_rmv = 2.2E-8_r8 ! time constant for removal of OC in snow on sea-ice + ! [s-1] (50% mass removal/year) + real(r8), parameter :: tim_cns_dst_rmv = 2.2E-8_r8 ! time constant for removal of dust in snow on sea-ice + ! [s-1] (50% mass removal/year) + !$acc declare copyin(C1_liq_Brun89, C2_liq_Brun89, & + !$acc tim_cns_bc_rmv, tim_cns_oc_rmv, tim_cns_dst_rmv) + + ! scaling of the snow aging rate (tuning option): + logical :: flg_snoage_scl = .false. ! flag for scaling the snow aging rate by some arbitrary factor + real(r8), parameter :: xdrdt = 1.0_r8 ! arbitrary factor applied to snow aging rate + ! snow and aerosol Mie parameters: + ! (arrays declared here, but are set in iniTimeConst) + ! (idx_Mie_snw_mx is number of snow radii with defined parameters (i.e. from 30um to 1500um)) + + ! direct-beam weighted ice optical properties + real(r8), allocatable :: ss_alb_snw_drc (:,:) ! (idx_Mie_snw_mx,numrad_snw); + real(r8), allocatable :: asm_prm_snw_drc (:,:) ! (idx_Mie_snw_mx,numrad_snw); + real(r8), allocatable :: ext_cff_mss_snw_drc(:,:) ! (idx_Mie_snw_mx,numrad_snw); + + ! diffuse radiation weighted ice optical properties + real(r8), allocatable :: ss_alb_snw_dfs (:,:) ! (idx_Mie_snw_mx,numrad_snw); + real(r8), allocatable :: asm_prm_snw_dfs (:,:) ! (idx_Mie_snw_mx,numrad_snw); + real(r8), allocatable :: ext_cff_mss_snw_dfs(:,:) ! (idx_Mie_snw_mx,numrad_snw); + + ! direct & diffuse flux + real(r8), allocatable :: flx_wgt_dir (:,:,:) ! (6, 90, numrad_snw) ! direct flux, six atmospheric types, 0-89 SZA + real(r8), allocatable :: flx_wgt_dif (:,:) ! (6, numrad_snw) ! diffuse flux, six atmospheric types + + ! snow grain shape + integer, parameter :: snow_shape_sphere = 1 + integer, parameter :: snow_shape_spheroid = 2 + integer, parameter :: snow_shape_hexagonal_plate = 3 + integer, parameter :: snow_shape_koch_snowflake = 4 + + ! atmospheric condition for SNICAR-AD + integer, parameter :: atm_type_default = 0 + integer, parameter :: atm_type_mid_latitude_winter = 1 + integer, parameter :: atm_type_mid_latitude_summer = 2 + integer, parameter :: atm_type_sub_Arctic_winter = 3 + integer, parameter :: atm_type_sub_Arctic_summer = 4 + integer, parameter :: atm_type_summit_Greenland = 5 + integer, parameter :: atm_type_high_mountain = 6 #ifdef MODAL_AER - !mgf++ - ! Size-dependent BC optical properties. Currently a fixed BC size is - ! assumed, but this framework enables optical properties to be - ! assigned based on the BC effective radius, should this be - ! implemented in the future. - ! - ! within-ice BC (i.e., BC that was deposited within hydrometeors) - real(r8), allocatable :: ss_alb_bc1 (:,:) ! (numrad_snw,idx_bc_nclrds_max); - real(r8), allocatable :: asm_prm_bc1 (:,:) ! (numrad_snw,idx_bc_nclrds_max); - real(r8), allocatable :: ext_cff_mss_bc1(:,:) ! (numrad_snw,idx_bc_nclrds_max); - - ! external BC - real(r8), allocatable :: ss_alb_bc2 (:,:) ! (numrad_snw,idx_bc_nclrds_max); - real(r8), allocatable :: asm_prm_bc2 (:,:) ! (numrad_snw,idx_bc_nclrds_max); - real(r8), allocatable :: ext_cff_mss_bc2(:,:) ! (numrad_snw,idx_bc_nclrds_max); - !mgf-- + !mgf++ + ! Size-dependent BC optical properties. Currently a fixed BC size is + ! assumed, but this framework enables optical properties to be + ! assigned based on the BC effective radius, should this be + ! implemented in the future. + ! + ! within-ice BC (i.e., BC that was deposited within hydrometeors) + real(r8), allocatable :: ss_alb_bc1 (:,:) ! (numrad_snw,idx_bc_nclrds_max); + real(r8), allocatable :: asm_prm_bc1 (:,:) ! (numrad_snw,idx_bc_nclrds_max); + real(r8), allocatable :: ext_cff_mss_bc1(:,:) ! (numrad_snw,idx_bc_nclrds_max); + + ! external BC + real(r8), allocatable :: ss_alb_bc2 (:,:) ! (numrad_snw,idx_bc_nclrds_max); + real(r8), allocatable :: asm_prm_bc2 (:,:) ! (numrad_snw,idx_bc_nclrds_max); + real(r8), allocatable :: ext_cff_mss_bc2(:,:) ! (numrad_snw,idx_bc_nclrds_max); + !mgf-- #else - ! hydrophiliic BC - real(r8), allocatable :: ss_alb_bc1 (:) ! (numrad_snw); - real(r8), allocatable :: asm_prm_bc1 (:) ! (numrad_snw); - real(r8), allocatable :: ext_cff_mss_bc1(:) ! (numrad_snw); - - ! hydrophobic BC - real(r8), allocatable :: ss_alb_bc2 (:) ! (numrad_snw); - real(r8), allocatable :: asm_prm_bc2 (:) ! (numrad_snw); - real(r8), allocatable :: ext_cff_mss_bc2(:) ! (numrad_snw); + ! hydrophiliic BC + real(r8), allocatable :: ss_alb_bc1 (:) ! (numrad_snw); + real(r8), allocatable :: asm_prm_bc1 (:) ! (numrad_snw); + real(r8), allocatable :: ext_cff_mss_bc1(:) ! (numrad_snw); + + ! hydrophobic BC + real(r8), allocatable :: ss_alb_bc2 (:) ! (numrad_snw); + real(r8), allocatable :: asm_prm_bc2 (:) ! (numrad_snw); + real(r8), allocatable :: ext_cff_mss_bc2(:) ! (numrad_snw); #endif - ! hydrophobic OC - real(r8), allocatable :: ss_alb_oc1 (:) ! (numrad_snw); - real(r8), allocatable :: asm_prm_oc1 (:) ! (numrad_snw); - real(r8), allocatable :: ext_cff_mss_oc1(:) ! (numrad_snw); + ! hydrophobic OC + real(r8), allocatable :: ss_alb_oc1 (:) ! (numrad_snw); + real(r8), allocatable :: asm_prm_oc1 (:) ! (numrad_snw); + real(r8), allocatable :: ext_cff_mss_oc1(:) ! (numrad_snw); - ! hydrophilic OC - real(r8), allocatable :: ss_alb_oc2 (:) ! (numrad_snw); - real(r8), allocatable :: asm_prm_oc2 (:) ! (numrad_snw); - real(r8), allocatable :: ext_cff_mss_oc2(:) ! (numrad_snw); + ! hydrophilic OC + real(r8), allocatable :: ss_alb_oc2 (:) ! (numrad_snw); + real(r8), allocatable :: asm_prm_oc2 (:) ! (numrad_snw); + real(r8), allocatable :: ext_cff_mss_oc2(:) ! (numrad_snw); - ! dust species 1: - real(r8), allocatable :: ss_alb_dst1 (:) ! (numrad_snw); - real(r8), allocatable :: asm_prm_dst1 (:) ! (numrad_snw); - real(r8), allocatable :: ext_cff_mss_dst1(:) ! (numrad_snw); + ! dust species 1: + real(r8), allocatable :: ss_alb_dst1 (:) ! (numrad_snw); + real(r8), allocatable :: asm_prm_dst1 (:) ! (numrad_snw); + real(r8), allocatable :: ext_cff_mss_dst1(:) ! (numrad_snw); - ! dust species 2: - real(r8), allocatable :: ss_alb_dst2 (:) ! (numrad_snw); - real(r8), allocatable :: asm_prm_dst2 (:) ! (numrad_snw); - real(r8), allocatable :: ext_cff_mss_dst2(:) ! (numrad_snw); + ! dust species 2: + real(r8), allocatable :: ss_alb_dst2 (:) ! (numrad_snw); + real(r8), allocatable :: asm_prm_dst2 (:) ! (numrad_snw); + real(r8), allocatable :: ext_cff_mss_dst2(:) ! (numrad_snw); - ! dust species 3: - real(r8), allocatable :: ss_alb_dst3 (:) ! (numrad_snw); - real(r8), allocatable :: asm_prm_dst3 (:) ! (numrad_snw); - real(r8), allocatable :: ext_cff_mss_dst3(:) ! (numrad_snw); + ! dust species 3: + real(r8), allocatable :: ss_alb_dst3 (:) ! (numrad_snw); + real(r8), allocatable :: asm_prm_dst3 (:) ! (numrad_snw); + real(r8), allocatable :: ext_cff_mss_dst3(:) ! (numrad_snw); - ! dust species 4: - real(r8), allocatable :: ss_alb_dst4 (:) ! (numrad_snw); - real(r8), allocatable :: asm_prm_dst4 (:) ! (numrad_snw); - real(r8), allocatable :: ext_cff_mss_dst4(:) ! (numrad_snw); + ! dust species 4: + real(r8), allocatable :: ss_alb_dst4 (:) ! (numrad_snw); + real(r8), allocatable :: asm_prm_dst4 (:) ! (numrad_snw); + real(r8), allocatable :: ext_cff_mss_dst4(:) ! (numrad_snw); #ifdef MODAL_AER - ! Absorption enhancement factors for within-ice BC - real(r8), allocatable :: bcenh (:,:,:) ! (numrad_snw,idx_bc_nclrds_max,idx_bcint_icerds_max); + ! Absorption enhancement factors for within-ice BC + real(r8), allocatable :: bcenh (:,:,:) ! (numrad_snw,idx_bc_nclrds_max,idx_bcint_icerds_max); #endif - ! best-fit parameters for snow aging defined over: - ! 11 temperatures from 225 to 273 K - ! 31 temperature gradients from 0 to 300 K/m - ! 8 snow densities from 0 to 350 kg/m3 - ! (arrays declared here, but are set in iniTimeConst) - ! - real(r8), allocatable :: snowage_tau (:,:,:) ! (idx_rhos_max,idx_Tgrd_max,idx_T_max) ! snow aging parameter retrieved from lookup table [hour] - real(r8), allocatable :: snowage_kappa (:,:,:) ! (idx_rhos_max,idx_Tgrd_max,idx_T_max) ! snow aging parameter retrieved from lookup table [unitless] - real(r8), allocatable :: snowage_drdt0 (:,:,:) ! (idx_rhos_max,idx_Tgrd_max,idx_T_max) ! snow aging parameter retrieved from lookup table [um hr-1] - - ! - ! !REVISION HISTORY: - ! Created by Mark Flanner - !----------------------------------------------------------------------- - -contains - - !----------------------------------------------------------------------- - subroutine SNICAR_RT (flg_snw_ice, flg_slr_in, & - coszen, snl, h2osno, frac_sno, & - h2osno_liq, h2osno_ice, snw_rds, & - mss_cnc_aer_in, albsfc, albout, flx_abs) - ! - ! !DESCRIPTION: - ! Determine reflectance of, and vertically-resolved solar absorption in, - ! snow with impurities. - ! - ! Original references on physical models of snow reflectance include: - ! Wiscombe and Warren [1980] and Warren and Wiscombe [1980], - ! Journal of Atmospheric Sciences, 37, - ! - ! The multi-layer solution for multiple-scattering used here is from: - ! Toon et al. [1989], Rapid calculation of radiative heating rates - ! and photodissociation rates in inhomogeneous multiple scattering atmospheres, - ! J. Geophys. Res., 94, D13, 16287-16301 - ! - ! The implementation of the SNICAR model in CLM/CSIM is described in: - ! Flanner, M., C. Zender, J. Randerson, and P. Rasch [2007], - ! Present-day climate forcing and response from black carbon in snow, - ! J. Geophys. Res., 112, D11202, doi: 10.1029/2006JD008003 - ! - ! !USES: - ! - ! !ARGUMENTS: - - IMPLICIT NONE - - integer , intent(in) :: flg_snw_ice ! flag: =1 when called from CLM, =2 when called from CSIM - integer , intent(in) :: flg_slr_in ! flag: =1 for direct-beam incident flux,=2 for diffuse incident flux - real(r8) , intent(in) :: coszen ! cosine of solar zenith angle for next time step (col) [unitless] - - integer , intent(in) :: snl ! negative number of snow layers (col) [nbr] - real(r8) , intent(in) :: h2osno ! snow liquid water equivalent (col) [kg/m2] - real(r8) , intent(in) :: frac_sno ! fraction of ground covered by snow (0 to 1) - - real(r8) , intent(in) :: h2osno_liq ( maxsnl+1:0 ) ! liquid water content (col,lyr) [kg/m2] - real(r8) , intent(in) :: h2osno_ice ( maxsnl+1:0 ) ! ice content (col,lyr) [kg/m2] - integer , intent(in) :: snw_rds ( maxsnl+1:0 ) ! snow effective radius (col,lyr) [microns, m^-6] - real(r8) , intent(in) :: mss_cnc_aer_in ( maxsnl+1:0 , 1:sno_nbr_aer ) ! mass concentration of all aerosol species (col,lyr,aer) [kg/kg] - real(r8) , intent(in) :: albsfc ( 1:numrad ) ! albedo of surface underlying snow (col,bnd) [frc] - real(r8) , intent(out) :: albout ( 1:numrad ) ! snow albedo, averaged into 2 bands (=0 if no sun or no snow) (col,bnd) [frc] - real(r8) , intent(out) :: flx_abs ( maxsnl+1:1 , 1:numrad ) ! absorbed flux in each layer per unit flux incident (col, lyr, bnd) - ! - ! !LOCAL VARIABLES: - ! - ! variables for snow radiative transfer calculations - - ! Local variables representing single-column values of arrays: - integer :: snl_lcl ! negative number of snow layers [nbr] - integer :: snw_rds_lcl(maxsnl+1:0) ! snow effective radius [m^-6] - real(r8):: flx_slrd_lcl(1:numrad_snw) ! direct beam incident irradiance [W/m2] (set to 1) - real(r8):: flx_slri_lcl(1:numrad_snw) ! diffuse incident irradiance [W/m2] (set to 1) - real(r8):: mss_cnc_aer_lcl(maxsnl+1:0,1:sno_nbr_aer) ! aerosol mass concentration (lyr,aer_nbr) [kg/kg] - real(r8):: h2osno_lcl ! total column snow mass [kg/m2] - real(r8):: h2osno_liq_lcl(maxsnl+1:0) ! liquid water mass [kg/m2] - real(r8):: h2osno_ice_lcl(maxsnl+1:0) ! ice mass [kg/m2] - real(r8):: albsfc_lcl(1:numrad_snw) ! albedo of underlying surface [frc] - real(r8):: ss_alb_snw_lcl(maxsnl+1:0) ! single-scatter albedo of ice grains (lyr) [frc] - real(r8):: asm_prm_snw_lcl(maxsnl+1:0) ! asymmetry parameter of ice grains (lyr) [frc] - real(r8):: ext_cff_mss_snw_lcl(maxsnl+1:0) ! mass extinction coefficient of ice grains (lyr) [m2/kg] - real(r8):: ss_alb_aer_lcl(sno_nbr_aer) ! single-scatter albedo of aerosol species (aer_nbr) [frc] - real(r8):: asm_prm_aer_lcl(sno_nbr_aer) ! asymmetry parameter of aerosol species (aer_nbr) [frc] - real(r8):: ext_cff_mss_aer_lcl(sno_nbr_aer) ! mass extinction coefficient of aerosol species (aer_nbr) [m2/kg] + ! best-fit parameters for snow aging defined over: + ! 11 temperatures from 225 to 273 K + ! 31 temperature gradients from 0 to 300 K/m + ! 8 snow densities from 0 to 350 kg/m3 + ! (arrays declared here, but are set in iniTimeConst) + ! + real(r8), allocatable :: snowage_tau (:,:,:) ! (idx_rhos_max,idx_Tgrd_max,idx_T_max) ! snow aging parameter retrieved from lookup table [hour] + real(r8), allocatable :: snowage_kappa (:,:,:) ! (idx_rhos_max,idx_Tgrd_max,idx_T_max) ! snow aging parameter retrieved from lookup table [unitless] + real(r8), allocatable :: snowage_drdt0 (:,:,:) ! (idx_rhos_max,idx_Tgrd_max,idx_T_max) ! snow aging parameter retrieved from lookup table [um hr-1] + + ! + ! !REVISION HISTORY: + ! Created by Mark Flanner + !----------------------------------------------------------------------- + +CONTAINS + + !----------------------------------------------------------------------- + SUBROUTINE SNICAR_RT (flg_snw_ice, flg_slr_in, & + coszen, snl, h2osno, frac_sno, & + h2osno_liq, h2osno_ice, snw_rds, & + mss_cnc_aer_in, albsfc, albout, flx_abs) + ! + ! !DESCRIPTION: + ! Determine reflectance of, and vertically-resolved solar absorption in, + ! snow with impurities. + ! + ! Original references on physical models of snow reflectance include: + ! Wiscombe and Warren [1980] and Warren and Wiscombe [1980], + ! Journal of Atmospheric Sciences, 37, + ! + ! The multi-layer solution for multiple-scattering used here is from: + ! Toon et al. [1989], Rapid calculation of radiative heating rates + ! and photodissociation rates in inhomogeneous multiple scattering atmospheres, + ! J. Geophys. Res., 94, D13, 16287-16301 + ! + ! The implementation of the SNICAR model in CLM/CSIM is described in: + ! Flanner, M., C. Zender, J. Randerson, and P. Rasch [2007], + ! Present-day climate forcing and response from black carbon in snow, + ! J. Geophys. Res., 112, D11202, doi: 10.1029/2006JD008003 + ! + ! !USES: + ! + ! !ARGUMENTS: + + IMPLICIT NONE + + integer , intent(in) :: flg_snw_ice ! flag: =1 when called from CLM, =2 when called from CSIM + integer , intent(in) :: flg_slr_in ! flag: =1 for direct-beam incident flux,=2 for diffuse incident flux + real(r8) , intent(in) :: coszen ! cosine of solar zenith angle for next time step (col) [unitless] + + integer , intent(in) :: snl ! negative number of snow layers (col) [nbr] + real(r8) , intent(in) :: h2osno ! snow liquid water equivalent (col) [kg/m2] + real(r8) , intent(in) :: frac_sno ! fraction of ground covered by snow (0 to 1) + + real(r8) , intent(in) :: h2osno_liq ( maxsnl+1:0 ) ! liquid water content (col,lyr) [kg/m2] + real(r8) , intent(in) :: h2osno_ice ( maxsnl+1:0 ) ! ice content (col,lyr) [kg/m2] + integer , intent(in) :: snw_rds ( maxsnl+1:0 ) ! snow effective radius (col,lyr) [microns, m^-6] + real(r8) , intent(in) :: mss_cnc_aer_in ( maxsnl+1:0 , 1:sno_nbr_aer ) ! mass concentration of all aerosol species (col,lyr,aer) [kg/kg] + real(r8) , intent(in) :: albsfc ( 1:numrad ) ! albedo of surface underlying snow (col,bnd) [frc] + real(r8) , intent(out) :: albout ( 1:numrad ) ! snow albedo, averaged into 2 bands (=0 IF no sun or no snow) (col,bnd) [frc] + real(r8) , intent(out) :: flx_abs ( maxsnl+1:1 , 1:numrad ) ! absorbed flux in each layer per unit flux incident (col, lyr, bnd) + ! + ! !LOCAL VARIABLES: + ! + ! variables for snow radiative transfer calculations + + ! Local variables representing single-column values of arrays: + integer :: snl_lcl ! negative number of snow layers [nbr] + integer :: snw_rds_lcl(maxsnl+1:0) ! snow effective radius [m^-6] + real(r8):: flx_slrd_lcl(1:numrad_snw) ! direct beam incident irradiance [W/m2] (set to 1) + real(r8):: flx_slri_lcl(1:numrad_snw) ! diffuse incident irradiance [W/m2] (set to 1) + real(r8):: mss_cnc_aer_lcl(maxsnl+1:0,1:sno_nbr_aer) ! aerosol mass concentration (lyr,aer_nbr) [kg/kg] + real(r8):: h2osno_lcl ! total column snow mass [kg/m2] + real(r8):: h2osno_liq_lcl(maxsnl+1:0) ! liquid water mass [kg/m2] + real(r8):: h2osno_ice_lcl(maxsnl+1:0) ! ice mass [kg/m2] + real(r8):: albsfc_lcl(1:numrad_snw) ! albedo of underlying surface [frc] + real(r8):: ss_alb_snw_lcl(maxsnl+1:0) ! single-scatter albedo of ice grains (lyr) [frc] + real(r8):: asm_prm_snw_lcl(maxsnl+1:0) ! asymmetry parameter of ice grains (lyr) [frc] + real(r8):: ext_cff_mss_snw_lcl(maxsnl+1:0) ! mass extinction coefficient of ice grains (lyr) [m2/kg] + real(r8):: ss_alb_aer_lcl(sno_nbr_aer) ! single-scatter albedo of aerosol species (aer_nbr) [frc] + real(r8):: asm_prm_aer_lcl(sno_nbr_aer) ! asymmetry parameter of aerosol species (aer_nbr) [frc] + real(r8):: ext_cff_mss_aer_lcl(sno_nbr_aer) ! mass extinction coefficient of aerosol species (aer_nbr) [m2/kg] #ifdef MODAL_AER - !mgf++ - real(r8) :: rds_bcint_lcl(maxsnl+1:0) ! effective radius of within-ice BC [nm] - real(r8) :: rds_bcext_lcl(maxsnl+1:0) ! effective radius of external BC [nm] - !mgf-- + !mgf++ + real(r8) :: rds_bcint_lcl(maxsnl+1:0) ! effective radius of within-ice BC [nm] + real(r8) :: rds_bcext_lcl(maxsnl+1:0) ! effective radius of external BC [nm] + !mgf-- #endif - ! Other local variables - integer :: APRX_TYP ! two-stream approximation type - ! (1=Eddington, 2=Quadrature, 3=Hemispheric Mean) [nbr] - integer :: DELTA ! flag to use Delta approximation (Joseph, 1976) - ! (1= use, 0= don't use) - real(r8):: flx_wgt(1:numrad_snw) ! weights applied to spectral bands, - ! specific to direct and diffuse cases (bnd) [frc] - - integer :: flg_nosnl ! flag: =1 if there is snow, but zero snow layers, - ! =0 if at least 1 snow layer [flg] - integer :: trip ! flag: =1 to redo RT calculation if result is unrealistic - integer :: flg_dover ! defines conditions for RT redo (explained below) - - real(r8):: albedo ! temporary snow albedo [frc] - real(r8):: flx_sum ! temporary summation variable for NIR weighting - real(r8):: albout_lcl(numrad_snw) ! snow albedo by band [frc] - real(r8):: flx_abs_lcl(maxsnl+1:1,numrad_snw) ! absorbed flux per unit incident flux at top of snowpack (lyr,bnd) [frc] - - real(r8):: L_snw(maxsnl+1:0) ! h2o mass (liquid+solid) in snow layer (lyr) [kg/m2] - real(r8):: tau_snw(maxsnl+1:0) ! snow optical depth (lyr) [unitless] - real(r8):: L_aer(maxsnl+1:0,sno_nbr_aer) ! aerosol mass in snow layer (lyr,nbr_aer) [kg/m2] - real(r8):: tau_aer(maxsnl+1:0,sno_nbr_aer) ! aerosol optical depth (lyr,nbr_aer) [unitless] - real(r8):: tau_sum ! cumulative (snow+aerosol) optical depth [unitless] - real(r8):: tau_elm(maxsnl+1:0) ! column optical depth from layer bottom to snowpack top (lyr) [unitless] - real(r8):: omega_sum ! temporary summation of single-scatter albedo of all aerosols [frc] - real(r8):: g_sum ! temporary summation of asymmetry parameter of all aerosols [frc] - - real(r8):: tau(maxsnl+1:0) ! weighted optical depth of snow+aerosol layer (lyr) [unitless] - real(r8):: omega(maxsnl+1:0) ! weighted single-scatter albedo of snow+aerosol layer (lyr) [frc] - real(r8):: g(maxsnl+1:0) ! weighted asymmetry parameter of snow+aerosol layer (lyr) [frc] - real(r8):: tau_star(maxsnl+1:0) ! transformed (i.e. Delta-Eddington) optical depth of snow+aerosol layer - ! (lyr) [unitless] - real(r8):: omega_star(maxsnl+1:0) ! transformed (i.e. Delta-Eddington) SSA of snow+aerosol layer (lyr) [frc] - real(r8):: g_star(maxsnl+1:0) ! transformed (i.e. Delta-Eddington) asymmetry paramater of snow+aerosol layer - ! (lyr) [frc] - - integer :: bnd_idx ! spectral band index (1 <= bnd_idx <= numrad_snw) [idx] - integer :: rds_idx ! snow effective radius index for retrieving - ! Mie parameters from lookup table [idx] - integer :: snl_btm ! index of bottom snow layer (0) [idx] - integer :: snl_top ! index of top snow layer (-4 to 0) [idx] - integer :: fc ! column filter index - integer :: i ! layer index [idx] - integer :: j ! aerosol number index [idx] - integer :: n ! tridiagonal matrix index [idx] - integer :: m ! secondary layer index [idx] - integer :: nint_snw_rds_min ! nearest integer value of snw_rds_min - - real(r8):: F_direct(maxsnl+1:0) ! direct-beam radiation at bottom of layer interface (lyr) [W/m^2] - real(r8):: F_net(maxsnl+1:0) ! net radiative flux at bottom of layer interface (lyr) [W/m^2] - real(r8):: F_abs(maxsnl+1:0) ! net absorbed radiative energy (lyr) [W/m^2] - real(r8):: F_abs_sum ! total absorbed energy in column [W/m^2] - real(r8):: F_sfc_pls ! upward radiative flux at snowpack top [W/m^2] - real(r8):: F_btm_net ! net flux at bottom of snowpack [W/m^2] - real(r8):: F_sfc_net ! net flux at top of snowpack [W/m^2] - real(r8):: energy_sum ! sum of all energy terms; should be 0.0 [W/m^2] - real(r8):: F_direct_btm ! direct-beam radiation at bottom of snowpack [W/m^2] - real(r8):: mu_not ! cosine of solar zenith angle (used locally) [frc] - - integer :: err_idx ! counter for number of times through error loop [nbr] - real(r8):: pi ! 3.1415... - - ! intermediate variables for radiative transfer approximation: - real(r8):: gamma1(maxsnl+1:0) ! two-stream coefficient from Toon et al. (lyr) [unitless] - real(r8):: gamma2(maxsnl+1:0) ! two-stream coefficient from Toon et al. (lyr) [unitless] - real(r8):: gamma3(maxsnl+1:0) ! two-stream coefficient from Toon et al. (lyr) [unitless] - real(r8):: gamma4(maxsnl+1:0) ! two-stream coefficient from Toon et al. (lyr) [unitless] - real(r8):: lambda(maxsnl+1:0) ! two-stream coefficient from Toon et al. (lyr) [unitless] - real(r8):: GAMMA(maxsnl+1:0) ! two-stream coefficient from Toon et al. (lyr) [unitless] - real(r8):: mu_one ! two-stream coefficient from Toon et al. (lyr) [unitless] - real(r8):: e1(maxsnl+1:0) ! tri-diag intermediate variable from Toon et al. (lyr) - real(r8):: e2(maxsnl+1:0) ! tri-diag intermediate variable from Toon et al. (lyr) - real(r8):: e3(maxsnl+1:0) ! tri-diag intermediate variable from Toon et al. (lyr) - real(r8):: e4(maxsnl+1:0) ! tri-diag intermediate variable from Toon et al. (lyr) - real(r8):: C_pls_btm(maxsnl+1:0) ! intermediate variable: upward flux at bottom interface (lyr) [W/m2] - real(r8):: C_mns_btm(maxsnl+1:0) ! intermediate variable: downward flux at bottom interface (lyr) [W/m2] - real(r8):: C_pls_top(maxsnl+1:0) ! intermediate variable: upward flux at top interface (lyr) [W/m2] - real(r8):: C_mns_top(maxsnl+1:0) ! intermediate variable: downward flux at top interface (lyr) [W/m2] - real(r8):: A(2*maxsnl+1:0) ! tri-diag intermediate variable from Toon et al. (2*lyr) - real(r8):: B(2*maxsnl+1:0) ! tri-diag intermediate variable from Toon et al. (2*lyr) - real(r8):: D(2*maxsnl+1:0) ! tri-diag intermediate variable from Toon et al. (2*lyr) - real(r8):: E(2*maxsnl+1:0) ! tri-diag intermediate variable from Toon et al. (2*lyr) - real(r8):: AS(2*maxsnl+1:0) ! tri-diag intermediate variable from Toon et al. (2*lyr) - real(r8):: DS(2*maxsnl+1:0) ! tri-diag intermediate variable from Toon et al. (2*lyr) - real(r8):: X(2*maxsnl+1:0) ! tri-diag intermediate variable from Toon et al. (2*lyr) - real(r8):: Y(2*maxsnl+1:0) ! tri-diag intermediate variable from Toon et al. (2*lyr) - !----------------------------------------------------------------------- + ! Other local variables + integer :: APRX_TYP ! two-stream approximation type + ! (1=Eddington, 2=Quadrature, 3=Hemispheric Mean) [nbr] + integer :: DELTA ! flag to USE Delta approximation (Joseph, 1976) + ! (1= USE, 0= don't USE) + real(r8):: flx_wgt(1:numrad_snw) ! weights applied to spectral bands, + ! specific to direct and diffuse cases (bnd) [frc] + + integer :: flg_nosnl ! flag: =1 IF there is snow, but zero snow layers, + ! =0 IF at least 1 snow layer [flg] + integer :: trip ! flag: =1 to redo RT calculation IF result is unrealistic + integer :: flg_dover ! defines conditions for RT redo (explained below) + + real(r8):: albedo ! temporary snow albedo [frc] + real(r8):: flx_sum ! temporary summation variable for NIR weighting + real(r8):: albout_lcl(numrad_snw) ! snow albedo by band [frc] + real(r8):: flx_abs_lcl(maxsnl+1:1,numrad_snw) ! absorbed flux per unit incident flux at top of snowpack (lyr,bnd) [frc] + + real(r8):: L_snw(maxsnl+1:0) ! h2o mass (liquid+solid) in snow layer (lyr) [kg/m2] + real(r8):: tau_snw(maxsnl+1:0) ! snow optical depth (lyr) [unitless] + real(r8):: L_aer(maxsnl+1:0,sno_nbr_aer) ! aerosol mass in snow layer (lyr,nbr_aer) [kg/m2] + real(r8):: tau_aer(maxsnl+1:0,sno_nbr_aer) ! aerosol optical depth (lyr,nbr_aer) [unitless] + real(r8):: tau_sum ! cumulative (snow+aerosol) optical depth [unitless] + real(r8):: tau_elm(maxsnl+1:0) ! column optical depth from layer bottom to snowpack top (lyr) [unitless] + real(r8):: omega_sum ! temporary summation of single-scatter albedo of all aerosols [frc] + real(r8):: g_sum ! temporary summation of asymmetry parameter of all aerosols [frc] + + real(r8):: tau(maxsnl+1:0) ! weighted optical depth of snow+aerosol layer (lyr) [unitless] + real(r8):: omega(maxsnl+1:0) ! weighted single-scatter albedo of snow+aerosol layer (lyr) [frc] + real(r8):: g(maxsnl+1:0) ! weighted asymmetry parameter of snow+aerosol layer (lyr) [frc] + real(r8):: tau_star(maxsnl+1:0) ! transformed (i.e. Delta-Eddington) optical depth of snow+aerosol layer + ! (lyr) [unitless] + real(r8):: omega_star(maxsnl+1:0) ! transformed (i.e. Delta-Eddington) SSA of snow+aerosol layer (lyr) [frc] + real(r8):: g_star(maxsnl+1:0) ! transformed (i.e. Delta-Eddington) asymmetry paramater of snow+aerosol layer + ! (lyr) [frc] + + integer :: bnd_idx ! spectral band index (1 <= bnd_idx <= numrad_snw) [idx] + integer :: rds_idx ! snow effective radius index for retrieving + ! Mie parameters from lookup table [idx] + integer :: snl_btm ! index of bottom snow layer (0) [idx] + integer :: snl_top ! index of top snow layer (-4 to 0) [idx] + integer :: fc ! column filter index + integer :: i ! layer index [idx] + integer :: j ! aerosol number index [idx] + integer :: n ! tridiagonal matrix index [idx] + integer :: m ! secondary layer index [idx] + integer :: nint_snw_rds_min ! nearest integer value of snw_rds_min + + real(r8):: F_direct(maxsnl+1:0) ! direct-beam radiation at bottom of layer interface (lyr) [W/m^2] + real(r8):: F_net(maxsnl+1:0) ! net radiative flux at bottom of layer interface (lyr) [W/m^2] + real(r8):: F_abs(maxsnl+1:0) ! net absorbed radiative energy (lyr) [W/m^2] + real(r8):: F_abs_sum ! total absorbed energy in column [W/m^2] + real(r8):: F_sfc_pls ! upward radiative flux at snowpack top [W/m^2] + real(r8):: F_btm_net ! net flux at bottom of snowpack [W/m^2] + real(r8):: F_sfc_net ! net flux at top of snowpack [W/m^2] + real(r8):: energy_sum ! sum of all energy terms; should be 0.0 [W/m^2] + real(r8):: F_direct_btm ! direct-beam radiation at bottom of snowpack [W/m^2] + real(r8):: mu_not ! cosine of solar zenith angle (used locally) [frc] + + integer :: err_idx ! counter for number of times through error loop [nbr] + real(r8):: pi ! 3.1415... + + ! intermediate variables for radiative transfer approximation: + real(r8):: gamma1(maxsnl+1:0) ! two-stream coefficient from Toon et al. (lyr) [unitless] + real(r8):: gamma2(maxsnl+1:0) ! two-stream coefficient from Toon et al. (lyr) [unitless] + real(r8):: gamma3(maxsnl+1:0) ! two-stream coefficient from Toon et al. (lyr) [unitless] + real(r8):: gamma4(maxsnl+1:0) ! two-stream coefficient from Toon et al. (lyr) [unitless] + real(r8):: lambda(maxsnl+1:0) ! two-stream coefficient from Toon et al. (lyr) [unitless] + real(r8):: GAMMA(maxsnl+1:0) ! two-stream coefficient from Toon et al. (lyr) [unitless] + real(r8):: mu_one ! two-stream coefficient from Toon et al. (lyr) [unitless] + real(r8):: e1(maxsnl+1:0) ! tri-diag intermediate variable from Toon et al. (lyr) + real(r8):: e2(maxsnl+1:0) ! tri-diag intermediate variable from Toon et al. (lyr) + real(r8):: e3(maxsnl+1:0) ! tri-diag intermediate variable from Toon et al. (lyr) + real(r8):: e4(maxsnl+1:0) ! tri-diag intermediate variable from Toon et al. (lyr) + real(r8):: C_pls_btm(maxsnl+1:0) ! intermediate variable: upward flux at bottom interface (lyr) [W/m2] + real(r8):: C_mns_btm(maxsnl+1:0) ! intermediate variable: downward flux at bottom interface (lyr) [W/m2] + real(r8):: C_pls_top(maxsnl+1:0) ! intermediate variable: upward flux at top interface (lyr) [W/m2] + real(r8):: C_mns_top(maxsnl+1:0) ! intermediate variable: downward flux at top interface (lyr) [W/m2] + real(r8):: A(2*maxsnl+1:0) ! tri-diag intermediate variable from Toon et al. (2*lyr) + real(r8):: B(2*maxsnl+1:0) ! tri-diag intermediate variable from Toon et al. (2*lyr) + real(r8):: D(2*maxsnl+1:0) ! tri-diag intermediate variable from Toon et al. (2*lyr) + real(r8):: E(2*maxsnl+1:0) ! tri-diag intermediate variable from Toon et al. (2*lyr) + real(r8):: AS(2*maxsnl+1:0) ! tri-diag intermediate variable from Toon et al. (2*lyr) + real(r8):: DS(2*maxsnl+1:0) ! tri-diag intermediate variable from Toon et al. (2*lyr) + real(r8):: X(2*maxsnl+1:0) ! tri-diag intermediate variable from Toon et al. (2*lyr) + real(r8):: Y(2*maxsnl+1:0) ! tri-diag intermediate variable from Toon et al. (2*lyr) + !----------------------------------------------------------------------- #ifdef MODAL_AER - !mgf++ - integer :: idx_bcint_icerds ! index of ice effective radius for optical properties lookup table - integer :: idx_bcint_nclrds ! index of within-ice BC effective radius for optical properties lookup table - integer :: idx_bcext_nclrds ! index of external BC effective radius for optical properties lookup table - real(r8):: enh_fct ! extinction/absorption enhancement factor for within-ice BC - real(r8):: tmp1 ! temporary variable - !mgf-- + !mgf++ + integer :: idx_bcint_icerds ! index of ice effective radius for optical properties lookup table + integer :: idx_bcint_nclrds ! index of within-ice BC effective radius for optical properties lookup table + integer :: idx_bcext_nclrds ! index of external BC effective radius for optical properties lookup table + real(r8):: enh_fct ! extinction/absorption enhancement factor for within-ice BC + real(r8):: tmp1 ! temporary variable + !mgf-- #endif - ! Enforce expected array sizes + ! Enforce expected array sizes ! associate(& ! snl => col_pp%snl , & ! Input: [integer (:)] negative number of snow layers (col) [nbr] @@ -415,53 +415,53 @@ subroutine SNICAR_RT (flg_snw_ice, flg_slr_in, & pi = SHR_CONST_PI nint_snw_rds_min = nint(snw_rds_min) - ! always use Delta approximation for snow + ! always USE Delta approximation for snow DELTA = 1 ! (when called from CSIM, there is only one column) ! Zero absorbed radiative fluxes: - do i=maxsnl+1,1,1 + DO i=maxsnl+1,1,1 flx_abs_lcl(:,:) = 0._r8 flx_abs(i,:) = 0._r8 - enddo + ENDDO ! set snow/ice mass to be used for RT: - if (flg_snw_ice == 1) then + IF (flg_snw_ice == 1) THEN h2osno_lcl = h2osno - else + ELSE h2osno_lcl = h2osno_ice(0) - endif + ENDIF ! Qualifier for computing snow RT: ! 1) sunlight from atmosphere model ! 2) minimum amount of snow on ground. ! Otherwise, set snow albedo to zero - if ((coszen > 0._r8) .and. (h2osno_lcl > min_snw)) then + IF ((coszen > 0._r8) .and. (h2osno_lcl > min_snw)) THEN ! Set variables specific to CLM - if (flg_snw_ice == 1) then + IF (flg_snw_ice == 1) THEN ! If there is snow, but zero snow layers, we must create a layer locally. ! This layer is presumed to have the fresh snow effective radius. - if (snl > -1) then + IF (snl > -1) THEN flg_nosnl = 1 snl_lcl = -1 h2osno_ice_lcl(0) = h2osno_lcl h2osno_liq_lcl(0) = 0._r8 snw_rds_lcl(0) = nint_snw_rds_min - else + ELSE flg_nosnl = 0 snl_lcl = snl h2osno_liq_lcl(:) = h2osno_liq(:) h2osno_ice_lcl(:) = h2osno_ice(:) snw_rds_lcl(:) = snw_rds(:) - endif + ENDIF snl_btm = 0 snl_top = snl_lcl+1 ! Set variables specific to CSIM - else + ELSE flg_nosnl = 0 snl_lcl = -1 h2osno_liq_lcl(:) = h2osno_liq(:) @@ -469,7 +469,7 @@ subroutine SNICAR_RT (flg_snw_ice, flg_slr_in, & snw_rds_lcl(:) = snw_rds(:) snl_btm = 0 snl_top = 0 - endif + ENDIF #ifdef MODAL_AER !mgf++ @@ -485,9 +485,9 @@ subroutine SNICAR_RT (flg_snw_ice, flg_slr_in, & #endif ! Set local aerosol array - do j=1,sno_nbr_aer + DO j=1,sno_nbr_aer mss_cnc_aer_lcl(:,j) = mss_cnc_aer_in(:,j) - enddo + ENDDO ! Set spectral underlying surface albedos to their corresponding VIS or NIR albedos @@ -498,15 +498,15 @@ subroutine SNICAR_RT (flg_snw_ice, flg_slr_in, & ! Error check for snow grain size: #ifndef _OPENACC IF (p_is_master) THEN - do i=snl_top,snl_btm,1 - if ((snw_rds_lcl(i) < snw_rds_min_tbl) .or. (snw_rds_lcl(i) > snw_rds_max_tbl)) then + DO i=snl_top,snl_btm,1 + IF ((snw_rds_lcl(i) < snw_rds_min_tbl) .or. (snw_rds_lcl(i) > snw_rds_max_tbl)) THEN write (iulog,*) "SNICAR ERROR: snow grain radius of out of bounds." write (iulog,*) "flg_snw_ice= ", flg_snw_ice write (iulog,*) " level: ", i, " snl(c)= ", snl_lcl write (iulog,*) "h2osno(c)= ", h2osno_lcl - call abort - endif - enddo + CALL abort + ENDIF + ENDDO ENDIF #endif @@ -514,7 +514,7 @@ subroutine SNICAR_RT (flg_snw_ice, flg_slr_in, & ! - sum of all VIS bands must equal 1 ! - sum of all NIR bands must equal 1 ! - ! Spectral bands (5-band case) + ! Spectral bands (5-band CASE) ! Band 1: 0.3-0.7um (VIS) ! Band 2: 0.7-1.0um (NIR) ! Band 3: 1.0-1.2um (NIR) @@ -524,46 +524,46 @@ subroutine SNICAR_RT (flg_snw_ice, flg_slr_in, & ! The following weights are appropriate for surface-incident flux in a mid-latitude winter atmosphere ! ! 3-band weights - if (numrad_snw==3) then + IF (numrad_snw==3) THEN ! Direct: - if (flg_slr_in == 1) then + IF (flg_slr_in == 1) THEN flx_wgt(1) = 1._r8 flx_wgt(2) = 0.66628670195247_r8 flx_wgt(3) = 0.33371329804753_r8 ! Diffuse: - elseif (flg_slr_in == 2) then + elseif (flg_slr_in == 2) THEN flx_wgt(1) = 1._r8 flx_wgt(2) = 0.77887652162877_r8 flx_wgt(3) = 0.22112347837123_r8 - endif + ENDIF ! 5-band weights - elseif(numrad_snw==5) then + elseif(numrad_snw==5) THEN ! Direct: - if (flg_slr_in == 1) then + IF (flg_slr_in == 1) THEN flx_wgt(1) = 1._r8 flx_wgt(2) = 0.49352158521175_r8 flx_wgt(3) = 0.18099494230665_r8 flx_wgt(4) = 0.12094898498813_r8 flx_wgt(5) = 0.20453448749347_r8 ! Diffuse: - elseif (flg_slr_in == 2) then + elseif (flg_slr_in == 2) THEN flx_wgt(1) = 1._r8 flx_wgt(2) = 0.58581507618433_r8 flx_wgt(3) = 0.20156903770812_r8 flx_wgt(4) = 0.10917889346386_r8 flx_wgt(5) = 0.10343699264369_r8 - endif - endif + ENDIF + ENDIF ! Loop over snow spectral bands - do bnd_idx = 1,numrad_snw + DO bnd_idx = 1,numrad_snw mu_not = coszen ! must set here, because of error handling flg_dover = 1 ! default is to redo err_idx = 0 ! number of times through loop - do while (flg_dover > 0) + DO WHILE (flg_dover > 0) ! DEFAULT APPROXIMATIONS: ! VIS: Delta-Eddington @@ -583,79 +583,79 @@ subroutine SNICAR_RT (flg_snw_ice, flg_slr_in, & ! 3rd error (flg_dover=4): switch approximation with new zenith ! Subsequent errors: repeatedly change zenith and approximations... - if (bnd_idx == 1) then - if (flg_dover == 2) then + IF (bnd_idx == 1) THEN + IF (flg_dover == 2) THEN APRX_TYP = 3 - elseif (flg_dover == 3) then + elseif (flg_dover == 3) THEN APRX_TYP = 1 - if (coszen > 0.5_r8) then + IF (coszen > 0.5_r8) THEN mu_not = mu_not - 0.02_r8 - else + ELSE mu_not = mu_not + 0.02_r8 - endif - elseif (flg_dover == 4) then + ENDIF + elseif (flg_dover == 4) THEN APRX_TYP = 3 - else + ELSE APRX_TYP = 1 - endif + ENDIF - else - if (flg_dover == 2) then + ELSE + IF (flg_dover == 2) THEN APRX_TYP = 1 - elseif (flg_dover == 3) then + elseif (flg_dover == 3) THEN APRX_TYP = 3 - if (coszen > 0.5_r8) then + IF (coszen > 0.5_r8) THEN mu_not = mu_not - 0.02_r8 - else + ELSE mu_not = mu_not + 0.02_r8 - endif - elseif (flg_dover == 4) then + ENDIF + elseif (flg_dover == 4) THEN APRX_TYP = 1 - else + ELSE APRX_TYP = 3 - endif + ENDIF - endif + ENDIF ! Set direct or diffuse incident irradiance to 1 ! (This has to be within the bnd loop because mu_not is adjusted in rare cases) - if (flg_slr_in == 1) then + IF (flg_slr_in == 1) THEN flx_slrd_lcl(bnd_idx) = 1._r8/(mu_not*pi) ! this corresponds to incident irradiance of 1.0 flx_slri_lcl(bnd_idx) = 0._r8 - else + ELSE flx_slrd_lcl(bnd_idx) = 0._r8 flx_slri_lcl(bnd_idx) = 1._r8 - endif + ENDIF ! Pre-emptive error handling: aerosols can reap havoc on these absorptive bands. ! Since extremely high soot concentrations have a negligible effect on these bands, zero them. - if ( (numrad_snw == 5).and.((bnd_idx == 5).or.(bnd_idx == 4)) ) then + IF ( (numrad_snw == 5).and.((bnd_idx == 5).or.(bnd_idx == 4)) ) THEN mss_cnc_aer_lcl(:,:) = 0._r8 - endif + ENDIF - if ( (numrad_snw == 3).and.(bnd_idx == 3) ) then + IF ( (numrad_snw == 3).and.(bnd_idx == 3) ) THEN mss_cnc_aer_lcl(:,:) = 0._r8 - endif + ENDIF ! Define local Mie parameters based on snow grain size and aerosol species, ! retrieved from a lookup table. - if (flg_slr_in == 1) then - do i=snl_top,snl_btm,1 + IF (flg_slr_in == 1) THEN + DO i=snl_top,snl_btm,1 rds_idx = snw_rds_lcl(i) - snw_rds_min_tbl + 1 ! snow optical properties (direct radiation) ss_alb_snw_lcl(i) = ss_alb_snw_drc(rds_idx,bnd_idx) asm_prm_snw_lcl(i) = asm_prm_snw_drc(rds_idx,bnd_idx) ext_cff_mss_snw_lcl(i) = ext_cff_mss_snw_drc(rds_idx,bnd_idx) - enddo - elseif (flg_slr_in == 2) then - do i=snl_top,snl_btm,1 + ENDDO + elseif (flg_slr_in == 2) THEN + DO i=snl_top,snl_btm,1 rds_idx = snw_rds_lcl(i) - snw_rds_min_tbl + 1 ! snow optical properties (diffuse radiation) ss_alb_snw_lcl(i) = ss_alb_snw_dfs(rds_idx,bnd_idx) asm_prm_snw_lcl(i) = asm_prm_snw_dfs(rds_idx,bnd_idx) ext_cff_mss_snw_lcl(i) = ext_cff_mss_snw_dfs(rds_idx,bnd_idx) - enddo - endif + ENDDO + ENDIF !H. Wang ! aerosol species 1 optical properties @@ -704,7 +704,7 @@ subroutine SNICAR_RT (flg_snw_ice, flg_slr_in, & ! 3. weighted Mie properties (tau, omega, g) ! Weighted Mie parameters of each layer - do i=snl_top,snl_btm,1 + DO i=snl_top,snl_btm,1 #ifdef MODAL_AER !mgf++ within-ice and external BC optical properties ! @@ -713,27 +713,27 @@ subroutine SNICAR_RT (flg_snw_ice, flg_slr_in, & ! size. ! valid for 25 < snw_rds < 1625 um: - if (snw_rds_lcl(i) < 125) then + IF (snw_rds_lcl(i) < 125) THEN tmp1 = snw_rds_lcl(i)/50 idx_bcint_icerds = nint(tmp1) - elseif (snw_rds_lcl(i) < 175) then + elseif (snw_rds_lcl(i) < 175) THEN idx_bcint_icerds = 2 - else + ELSE tmp1 = (snw_rds_lcl(i)/250)+2 idx_bcint_icerds = nint(tmp1) - endif + ENDIF ! valid for 25 < bc_rds < 525 nm idx_bcint_nclrds = nint(rds_bcint_lcl(i)/50) idx_bcext_nclrds = nint(rds_bcext_lcl(i)/50) ! check bounds: - if (idx_bcint_icerds < idx_bcint_icerds_min) idx_bcint_icerds = idx_bcint_icerds_min - if (idx_bcint_icerds > idx_bcint_icerds_max) idx_bcint_icerds = idx_bcint_icerds_max - if (idx_bcint_nclrds < idx_bc_nclrds_min) idx_bcint_nclrds = idx_bc_nclrds_min - if (idx_bcint_nclrds > idx_bc_nclrds_max) idx_bcint_nclrds = idx_bc_nclrds_max - if (idx_bcext_nclrds < idx_bc_nclrds_min) idx_bcext_nclrds = idx_bc_nclrds_min - if (idx_bcext_nclrds > idx_bc_nclrds_max) idx_bcext_nclrds = idx_bc_nclrds_max + IF (idx_bcint_icerds < idx_bcint_icerds_min) idx_bcint_icerds = idx_bcint_icerds_min + IF (idx_bcint_icerds > idx_bcint_icerds_max) idx_bcint_icerds = idx_bcint_icerds_max + IF (idx_bcint_nclrds < idx_bc_nclrds_min) idx_bcint_nclrds = idx_bc_nclrds_min + IF (idx_bcint_nclrds > idx_bc_nclrds_max) idx_bcint_nclrds = idx_bc_nclrds_max + IF (idx_bcext_nclrds < idx_bc_nclrds_min) idx_bcext_nclrds = idx_bc_nclrds_min + IF (idx_bcext_nclrds > idx_bc_nclrds_max) idx_bcext_nclrds = idx_bc_nclrds_max ! retrieve absorption enhancement factor for within-ice BC enh_fct = bcenh(bnd_idx,idx_bcint_nclrds,idx_bcint_icerds) @@ -767,47 +767,47 @@ subroutine SNICAR_RT (flg_snw_ice, flg_slr_in, & L_snw(i) = h2osno_ice_lcl(i)+h2osno_liq_lcl(i) tau_snw(i) = L_snw(i)*ext_cff_mss_snw_lcl(i) - do j=1,sno_nbr_aer + DO j=1,sno_nbr_aer L_aer(i,j) = L_snw(i)*mss_cnc_aer_lcl(i,j) tau_aer(i,j) = L_aer(i,j)*ext_cff_mss_aer_lcl(j) - enddo + ENDDO tau_sum = 0._r8 omega_sum = 0._r8 g_sum = 0._r8 - do j=1,sno_nbr_aer + DO j=1,sno_nbr_aer tau_sum = tau_sum + tau_aer(i,j) omega_sum = omega_sum + (tau_aer(i,j)*ss_alb_aer_lcl(j)) g_sum = g_sum + (tau_aer(i,j)*ss_alb_aer_lcl(j)*asm_prm_aer_lcl(j)) - enddo + ENDDO tau(i) = tau_sum + tau_snw(i) omega(i) = (1/tau(i))*(omega_sum+(ss_alb_snw_lcl(i)*tau_snw(i))) g(i) = (1/(tau(i)*omega(i)))*(g_sum+ (asm_prm_snw_lcl(i)*ss_alb_snw_lcl(i)*tau_snw(i))) - enddo + ENDDO - ! DELTA transformations, if requested - if (DELTA == 1) then - do i=snl_top,snl_btm,1 + ! DELTA transformations, IF requested + IF (DELTA == 1) THEN + DO i=snl_top,snl_btm,1 g_star(i) = g(i)/(1+g(i)) omega_star(i) = ((1-(g(i)**2))*omega(i)) / (1-(omega(i)*(g(i)**2))) tau_star(i) = (1-(omega(i)*(g(i)**2)))*tau(i) - enddo - else - do i=snl_top,snl_btm,1 + ENDDO + ELSE + DO i=snl_top,snl_btm,1 g_star(i) = g(i) omega_star(i) = omega(i) tau_star(i) = tau(i) - enddo - endif + ENDDO + ENDIF ! Total column optical depth: ! tau_elm(i) = total optical depth above the bottom of layer i tau_elm(snl_top) = 0._r8 - do i=snl_top+1,snl_btm,1 + DO i=snl_top+1,snl_btm,1 tau_elm(i) = tau_elm(i-1)+tau_star(i-1) - enddo + ENDDO ! Direct radiation at bottom of snowpack: F_direct_btm = albsfc_lcl(bnd_idx)*mu_not * & @@ -817,38 +817,38 @@ subroutine SNICAR_RT (flg_snw_ice, flg_slr_in, & ! Gamma values are approximation-specific. ! Eddington - if (APRX_TYP==1) then - do i=snl_top,snl_btm,1 + IF (APRX_TYP==1) THEN + DO i=snl_top,snl_btm,1 gamma1(i) = (7-(omega_star(i)*(4+(3*g_star(i)))))/4 gamma2(i) = -(1-(omega_star(i)*(4-(3*g_star(i)))))/4 gamma3(i) = (2-(3*g_star(i)*mu_not))/4 gamma4(i) = 1-gamma3(i) mu_one = 0.5 - enddo + ENDDO ! Quadrature - elseif (APRX_TYP==2) then - do i=snl_top,snl_btm,1 + elseif (APRX_TYP==2) THEN + DO i=snl_top,snl_btm,1 gamma1(i) = (3**0.5)*(2-(omega_star(i)*(1+g_star(i))))/2 gamma2(i) = omega_star(i)*(3**0.5)*(1-g_star(i))/2 gamma3(i) = (1-((3**0.5)*g_star(i)*mu_not))/2 gamma4(i) = 1-gamma3(i) mu_one = 1/(3**0.5) - enddo + ENDDO ! Hemispheric Mean - elseif (APRX_TYP==3) then - do i=snl_top,snl_btm,1 + elseif (APRX_TYP==3) THEN + DO i=snl_top,snl_btm,1 gamma1(i) = 2 - (omega_star(i)*(1+g_star(i))) gamma2(i) = omega_star(i)*(1-g_star(i)) gamma3(i) = (1-((3**0.5)*g_star(i)*mu_not))/2 gamma4(i) = 1-gamma3(i) mu_one = 0.5 - enddo - endif + ENDDO + ENDIF ! Intermediates for tri-diagonal solution - do i=snl_top,snl_btm,1 + DO i=snl_top,snl_btm,1 lambda(i) = sqrt(abs((gamma1(i)**2) - (gamma2(i)**2))) GAMMA(i) = gamma2(i)/(gamma1(i)+lambda(i)) @@ -856,11 +856,11 @@ subroutine SNICAR_RT (flg_snw_ice, flg_slr_in, & e2(i) = 1-(GAMMA(i)*exp(-lambda(i)*tau_star(i))) e3(i) = GAMMA(i) + exp(-lambda(i)*tau_star(i)) e4(i) = GAMMA(i) - exp(-lambda(i)*tau_star(i)) - enddo !enddo over snow layers + ENDDO !ENDDO over snow layers ! Intermediates for tri-diagonal solution - do i=snl_top,snl_btm,1 - if (flg_slr_in == 1) then + DO i=snl_top,snl_btm,1 + IF (flg_slr_in == 1) THEN C_pls_btm(i) = (omega_star(i)*pi*flx_slrd_lcl(bnd_idx)* & exp(-(tau_elm(i)+tau_star(i))/mu_not)* & @@ -880,66 +880,66 @@ subroutine SNICAR_RT (flg_snw_ice, flg_slr_in, & exp(-tau_elm(i)/mu_not)*(((gamma1(i)+(1/mu_not))* & gamma4(i))+(gamma2(i)*gamma3(i))))/((lambda(i)**2)-(1/(mu_not**2))) - else + ELSE C_pls_btm(i) = 0._r8 C_mns_btm(i) = 0._r8 C_pls_top(i) = 0._r8 C_mns_top(i) = 0._r8 - endif - enddo + ENDIF + ENDDO ! Coefficients for tridiaganol matrix solution - do i=2*snl_lcl+1,0,1 + DO i=2*snl_lcl+1,0,1 !Boundary values for i=1 and i=2*snl_lcl, specifics for i=odd and i=even - if (i==(2*snl_lcl+1)) then + IF (i==(2*snl_lcl+1)) THEN A(i) = 0 B(i) = e1(snl_top) D(i) = -e2(snl_top) E(i) = flx_slri_lcl(bnd_idx)-C_mns_top(snl_top) - elseif(i==0) then + elseif(i==0) THEN A(i) = e1(snl_btm)-(albsfc_lcl(bnd_idx)*e3(snl_btm)) B(i) = e2(snl_btm)-(albsfc_lcl(bnd_idx)*e4(snl_btm)) D(i) = 0 E(i) = F_direct_btm-C_pls_btm(snl_btm)+(albsfc_lcl(bnd_idx)*C_mns_btm(snl_btm)) - elseif(mod(i,2)==-1) then ! If odd and i>=3 (n=1 for i=3) + elseif(mod(i,2)==-1) THEN ! If odd and i>=3 (n=1 for i=3) n=floor(i/2.0) A(i) = (e2(n)*e3(n))-(e4(n)*e1(n)) B(i) = (e1(n)*e1(n+1))-(e3(n)*e3(n+1)) D(i) = (e3(n)*e4(n+1))-(e1(n)*e2(n+1)) E(i) = (e3(n)*(C_pls_top(n+1)-C_pls_btm(n)))+(e1(n)*(C_mns_btm(n)-C_mns_top(n+1))) - elseif(mod(i,2)==0) then ! If even and i<=2*snl_lcl + elseif(mod(i,2)==0) THEN ! If even and i<=2*snl_lcl n=(i/2) A(i) = (e2(n+1)*e1(n))-(e3(n)*e4(n+1)) B(i) = (e2(n)*e2(n+1))-(e4(n)*e4(n+1)) D(i) = (e1(n+1)*e4(n+1))-(e2(n+1)*e3(n+1)) E(i) = (e2(n+1)*(C_pls_top(n+1)-C_pls_btm(n)))+(e4(n+1)*(C_mns_top(n+1)-C_mns_btm(n))) - endif - enddo + ENDIF + ENDDO AS(0) = A(0)/B(0) DS(0) = E(0)/B(0) - do i=-1,(2*snl_lcl+1),-1 + DO i=-1,(2*snl_lcl+1),-1 X(i) = 1/(B(i)-(D(i)*AS(i+1))) AS(i) = A(i)*X(i) DS(i) = (E(i)-(D(i)*DS(i+1)))*X(i) - enddo + ENDDO Y(2*snl_lcl+1) = DS(2*snl_lcl+1) - do i=(2*snl_lcl+2),0,1 + DO i=(2*snl_lcl+2),0,1 Y(i) = DS(i)-(AS(i)*Y(i-1)) - enddo + ENDDO ! Downward direct-beam and net flux (F_net) at the base of each layer: - do i=snl_top,snl_btm,1 + DO i=snl_top,snl_btm,1 F_direct(i) = mu_not*pi*flx_slrd_lcl(bnd_idx)*exp(-(tau_elm(i)+tau_star(i))/mu_not) F_net(i) = (Y(2*i-1)*(e1(i)-e3(i))) + (Y(2*i)*(e2(i)-e4(i))) + & C_pls_btm(i) - C_mns_btm(i) - F_direct(i) - enddo + ENDDO ! Upward flux at snowpack top: F_sfc_pls = (Y(2*snl_lcl+1)*(exp(-lambda(snl_top)*tau_star(snl_top))+ & @@ -956,72 +956,72 @@ subroutine SNICAR_RT (flg_snw_ice, flg_slr_in, & trip = 0 ! Absorbed flux in each layer - do i=snl_top,snl_btm,1 - if(i==snl_top) then + DO i=snl_top,snl_btm,1 + IF(i==snl_top) THEN F_abs(i) = F_net(i)-F_sfc_net - else + ELSE F_abs(i) = F_net(i)-F_net(i-1) - endif + ENDIF flx_abs_lcl(i,bnd_idx) = F_abs(i) ! ERROR check: negative absorption - if (flx_abs_lcl(i,bnd_idx) < -0.00001) then + IF (flx_abs_lcl(i,bnd_idx) < -0.00001) THEN trip = 1 - endif - enddo + ENDIF + ENDDO flx_abs_lcl(1,bnd_idx) = F_btm_net - if (flg_nosnl == 1) then + IF (flg_nosnl == 1) THEN ! If there are no snow layers (but still snow), all absorbed energy must be in top soil layer !flx_abs_lcl(:,bnd_idx) = 0._r8 !flx_abs_lcl(1,bnd_idx) = F_abs(0) + F_btm_net ! changed on 20070408: ! OK to put absorbed energy in the fictitous snow layer because routine SurfaceRadiation - ! handles the case of no snow layers. Then, if a snow layer is addded between now and + ! handles the CASE of no snow layers. Then, IF a snow layer is addded between now and ! SurfaceRadiation (called in CanopyHydrology), absorbed energy will be properly distributed. flx_abs_lcl(0,bnd_idx) = F_abs(0) flx_abs_lcl(1,bnd_idx) = F_btm_net - endif + ENDIF !Underflow check (we've already tripped the error condition above) - do i=snl_top,1,1 - if (flx_abs_lcl(i,bnd_idx) < 0._r8) then + DO i=snl_top,1,1 + IF (flx_abs_lcl(i,bnd_idx) < 0._r8) THEN flx_abs_lcl(i,bnd_idx) = 0._r8 - endif - enddo + ENDIF + ENDDO F_abs_sum = 0._r8 - do i=snl_top,snl_btm,1 + DO i=snl_top,snl_btm,1 F_abs_sum = F_abs_sum + F_abs(i) - enddo + ENDDO !ERROR check: absorption greater than incident flux ! (should make condition more generic than "1._r8") - if (F_abs_sum > 1._r8) then + IF (F_abs_sum > 1._r8) THEN trip = 1 - endif + ENDIF !ERROR check: - if ((albedo < 0._r8).and.(trip==0)) then + IF ((albedo < 0._r8).and.(trip==0)) THEN trip = 1 - endif + ENDIF ! Set conditions for redoing RT calculation - if ((trip == 1).and.(flg_dover == 1)) then + IF ((trip == 1).and.(flg_dover == 1)) THEN flg_dover = 2 - elseif ((trip == 1).and.(flg_dover == 2)) then + elseif ((trip == 1).and.(flg_dover == 2)) THEN flg_dover = 3 - elseif ((trip == 1).and.(flg_dover == 3)) then + elseif ((trip == 1).and.(flg_dover == 3)) THEN flg_dover = 4 - elseif((trip == 1).and.(flg_dover == 4).and.(err_idx < 20)) then + elseif((trip == 1).and.(flg_dover == 4).and.(err_idx < 20)) THEN flg_dover = 3 err_idx = err_idx + 1 - elseif((trip == 1).and.(flg_dover == 4).and.(err_idx >= 20)) then + elseif((trip == 1).and.(flg_dover == 4).and.(err_idx >= 20)) THEN flg_dover = 0 #ifndef _OPENACC IF (p_is_master) THEN @@ -1036,31 +1036,31 @@ subroutine SNICAR_RT (flg_snw_ice, flg_slr_in, & write(iulog,*) "SNICAR STATS: dust3(0)= ", mss_cnc_aer_lcl(0,5) write(iulog,*) "SNICAR STATS: dust4(0)= ", mss_cnc_aer_lcl(0,6) write(iulog,*) "frac_sno: ", frac_sno - call abort + CALL abort ENDIF #endif - else + ELSE flg_dover = 0 - endif + ENDIF - enddo !enddo while (flg_dover > 0) + ENDDO !ENDDO WHILE (flg_dover > 0) ! Energy conservation check: ! Incident direct+diffuse radiation equals (absorbed+bulk_transmitted+bulk_reflected) energy_sum = (mu_not*pi*flx_slrd_lcl(bnd_idx)) + flx_slri_lcl(bnd_idx) - (F_abs_sum + F_btm_net + F_sfc_pls) - if (abs(energy_sum) > 0.00001_r8) then + IF (abs(energy_sum) > 0.00001_r8) THEN #ifndef _OPENACC IF (p_is_master) THEN write(iulog,*) "SNICAR ERROR: Energy conservation error of : ", energy_sum - call abort + CALL abort ENDIF #endif - endif + ENDIF albout_lcl(bnd_idx) = albedo ! Check that albedo is less than 1 - if (albout_lcl(bnd_idx) > 1.0) then + IF (albout_lcl(bnd_idx) > 1.0) THEN #ifndef _OPENACC IF (p_is_master) THEN write(iulog,*) "SNICAR ERROR: Albedo > 1.0: " @@ -1088,384 +1088,384 @@ subroutine SNICAR_RT (flg_snw_ice, flg_slr_in, & write (iulog,*) "SNICAR STATS: snw_rds(-1)= ", snw_rds(-1) write (iulog,*) "SNICAR STATS: snw_rds(0)= ", snw_rds(0) - call abort + CALL abort ENDIF #endif - endif + ENDIF - enddo ! loop over wvl bands + ENDDO ! loop over wvl bands ! Weight output NIR albedo appropriately albout(1) = albout_lcl(1) flx_sum = 0._r8 - do bnd_idx= nir_bnd_bgn,nir_bnd_end + DO bnd_idx= nir_bnd_bgn,nir_bnd_end flx_sum = flx_sum + flx_wgt(bnd_idx)*albout_lcl(bnd_idx) - end do + ENDDO albout(2) = flx_sum / sum(flx_wgt(nir_bnd_bgn:nir_bnd_end)) ! Weight output NIR absorbed layer fluxes (flx_abs) appropriately flx_abs(:,1) = flx_abs_lcl(:,1) - do i=snl_top,1,1 + DO i=snl_top,1,1 flx_sum = 0._r8 - do bnd_idx= nir_bnd_bgn,nir_bnd_end + DO bnd_idx= nir_bnd_bgn,nir_bnd_end flx_sum = flx_sum + flx_wgt(bnd_idx)*flx_abs_lcl(i,bnd_idx) - enddo + ENDDO flx_abs(i,2) = flx_sum / sum(flx_wgt(nir_bnd_bgn:nir_bnd_end)) - end do + ENDDO ! If snow < minimum_snow, but > 0, and there is sun, set albedo to underlying surface albedo - elseif ( (coszen > 0._r8) .and. (h2osno_lcl < min_snw) .and. (h2osno_lcl > 0._r8) ) then + elseif ( (coszen > 0._r8) .and. (h2osno_lcl < min_snw) .and. (h2osno_lcl > 0._r8) ) THEN albout(1) = albsfc(1) albout(2) = albsfc(2) ! There is either zero snow, or no sun - else + ELSE albout(1) = 0._r8 albout(2) = 0._r8 - endif ! if column has snow and coszen > 0 + ENDIF ! IF column has snow and coszen > 0 - ! end associate + ! END associate - end subroutine SNICAR_RT - !----------------------------------------------------------------------- + END SUBROUTINE SNICAR_RT + !----------------------------------------------------------------------- - subroutine SNICAR_AD_RT (flg_snw_ice, flg_slr_in, & + SUBROUTINE SNICAR_AD_RT (flg_snw_ice, flg_slr_in, & coszen, snl, h2osno, frac_sno, & h2osno_liq, h2osno_ice, snw_rds, & mss_cnc_aer_in, albsfc, albout, flx_abs) - ! - ! !DESCRIPTION: - ! Determine reflectance of, and vertically-resolved solar absorption in, - ! snow with impurities, with updated shortwave scheme - ! - ! The multi-layer solution for multiple-scattering used here is from: - ! Briegleb, P. and Light, B.: A Delta-Eddington mutiple scattering - ! parameterization for solar radiation in the sea ice component of the - ! community climate system model, 2007. - ! - ! The implementation of the SNICAR-AD model in ELM is described in: - ! Dang et al., Inter-comparison and improvement of 2-stream shortwave - ! radiative transfer models for unified treatment of cryospheric surfaces - ! in ESMs, in review, 2019 - ! - ! To use this subtroutine, set use_snicar_ad = true in ELM - ! - ! if config_use_snicar_ad = true in MPAS-seaice - ! Snow on land and snow on sea ice will be treated - ! with the same model for their solar radiative properties. - ! - ! The inputs and outputs are the same to subroutine SNICAR_RT - ! - ! !USES: - ! - ! !ARGUMENTS: - - IMPLICIT NONE - - integer , intent(in) :: flg_snw_ice ! flag: =1 when called from CLM, =2 when called from CSIM - integer , intent(in) :: flg_slr_in ! flag: =1 for direct-beam incident flux,=2 for diffuse incident flux - real(r8) , intent(in) :: coszen ! cosine of solar zenith angle for next time step (col) [unitless] - - integer , intent(in) :: snl ! negative number of snow layers (col) [nbr] - real(r8) , intent(in) :: h2osno ! snow liquid water equivalent (col) [kg/m2] - real(r8) , intent(in) :: frac_sno ! fraction of ground covered by snow (0 to 1) - - real(r8) , intent(in) :: h2osno_liq ( maxsnl+1:0 ) ! liquid water content (col,lyr) [kg/m2] - real(r8) , intent(in) :: h2osno_ice ( maxsnl+1:0 ) ! ice content (col,lyr) [kg/m2] - integer , intent(in) :: snw_rds ( maxsnl+1:0 ) ! snow effective radius (col,lyr) [microns, m^-6] - real(r8) , intent(in) :: mss_cnc_aer_in ( maxsnl+1:0 , 1:sno_nbr_aer ) ! mass concentration of all aerosol species (col,lyr,aer) [kg/kg] - real(r8) , intent(in) :: albsfc ( 1:numrad ) ! albedo of surface underlying snow (col,bnd) [frc] - real(r8) , intent(out) :: albout ( 1:numrad ) ! snow albedo, averaged into 2 bands (=0 if no sun or no snow) (col,bnd) [frc] - real(r8) , intent(out) :: flx_abs ( maxsnl+1:1 , 1:numrad ) ! absorbed flux in each layer per unit flux incident (col, lyr, bnd) - ! - ! !LOCAL VARIABLES: - ! - ! variables for snow radiative transfer calculations - - ! Local variables representing single-column values of arrays: - integer :: snl_lcl ! negative number of snow layers [nbr] - integer :: snw_rds_lcl(maxsnl+1:0) ! snow effective radius [m^-6] - real(r8):: flx_slrd_lcl(1:numrad_snw) ! direct beam incident irradiance [W/m2] (set to 1) - real(r8):: flx_slri_lcl(1:numrad_snw) ! diffuse incident irradiance [W/m2] (set to 1) - real(r8):: mss_cnc_aer_lcl(maxsnl+1:0,1:sno_nbr_aer) ! aerosol mass concentration (lyr,aer_nbr) [kg/kg] - real(r8):: h2osno_lcl ! total column snow mass [kg/m2] - real(r8):: h2osno_liq_lcl(maxsnl+1:0) ! liquid water mass [kg/m2] - real(r8):: h2osno_ice_lcl(maxsnl+1:0) ! ice mass [kg/m2] - real(r8):: albsfc_lcl(1:numrad_snw) ! albedo of underlying surface [frc] - real(r8):: ss_alb_snw_lcl(maxsnl+1:0) ! single-scatter albedo of ice grains (lyr) [frc] - real(r8):: asm_prm_snw_lcl(maxsnl+1:0) ! asymmetry parameter of ice grains (lyr) [frc] - real(r8):: ext_cff_mss_snw_lcl(maxsnl+1:0) ! mass extinction coefficient of ice grains (lyr) [m2/kg] - real(r8):: ss_alb_aer_lcl(sno_nbr_aer) ! single-scatter albedo of aerosol species (aer_nbr) [frc] - real(r8):: asm_prm_aer_lcl(sno_nbr_aer) ! asymmetry parameter of aerosol species (aer_nbr) [frc] - real(r8):: ext_cff_mss_aer_lcl(sno_nbr_aer) ! mass extinction coefficient of aerosol species (aer_nbr) [m2/kg] + ! + ! !DESCRIPTION: + ! Determine reflectance of, and vertically-resolved solar absorption in, + ! snow with impurities, with updated shortwave scheme + ! + ! The multi-layer solution for multiple-scattering used here is from: + ! Briegleb, P. and Light, B.: A Delta-Eddington mutiple scattering + ! parameterization for solar radiation in the sea ice component of the + ! community climate system model, 2007. + ! + ! The implementation of the SNICAR-AD model in ELM is described in: + ! Dang et al., Inter-comparison and improvement of 2-stream shortwave + ! radiative transfer models for unified treatment of cryospheric surfaces + ! in ESMs, in review, 2019 + ! + ! To USE this subtroutine, set use_snicar_ad = true in ELM + ! + ! IF config_use_snicar_ad = true in MPAS-seaice + ! Snow on land and snow on sea ice will be treated + ! with the same model for their solar radiative properties. + ! + ! The inputs and outputs are the same to SUBROUTINE SNICAR_RT + ! + ! !USES: + ! + ! !ARGUMENTS: + + IMPLICIT NONE + + integer , intent(in) :: flg_snw_ice ! flag: =1 when called from CLM, =2 when called from CSIM + integer , intent(in) :: flg_slr_in ! flag: =1 for direct-beam incident flux,=2 for diffuse incident flux + real(r8) , intent(in) :: coszen ! cosine of solar zenith angle for next time step (col) [unitless] + + integer , intent(in) :: snl ! negative number of snow layers (col) [nbr] + real(r8) , intent(in) :: h2osno ! snow liquid water equivalent (col) [kg/m2] + real(r8) , intent(in) :: frac_sno ! fraction of ground covered by snow (0 to 1) + + real(r8) , intent(in) :: h2osno_liq ( maxsnl+1:0 ) ! liquid water content (col,lyr) [kg/m2] + real(r8) , intent(in) :: h2osno_ice ( maxsnl+1:0 ) ! ice content (col,lyr) [kg/m2] + integer , intent(in) :: snw_rds ( maxsnl+1:0 ) ! snow effective radius (col,lyr) [microns, m^-6] + real(r8) , intent(in) :: mss_cnc_aer_in ( maxsnl+1:0 , 1:sno_nbr_aer ) ! mass concentration of all aerosol species (col,lyr,aer) [kg/kg] + real(r8) , intent(in) :: albsfc ( 1:numrad ) ! albedo of surface underlying snow (col,bnd) [frc] + real(r8) , intent(out) :: albout ( 1:numrad ) ! snow albedo, averaged into 2 bands (=0 IF no sun or no snow) (col,bnd) [frc] + real(r8) , intent(out) :: flx_abs ( maxsnl+1:1 , 1:numrad ) ! absorbed flux in each layer per unit flux incident (col, lyr, bnd) + ! + ! !LOCAL VARIABLES: + ! + ! variables for snow radiative transfer calculations + + ! Local variables representing single-column values of arrays: + integer :: snl_lcl ! negative number of snow layers [nbr] + integer :: snw_rds_lcl(maxsnl+1:0) ! snow effective radius [m^-6] + real(r8):: flx_slrd_lcl(1:numrad_snw) ! direct beam incident irradiance [W/m2] (set to 1) + real(r8):: flx_slri_lcl(1:numrad_snw) ! diffuse incident irradiance [W/m2] (set to 1) + real(r8):: mss_cnc_aer_lcl(maxsnl+1:0,1:sno_nbr_aer) ! aerosol mass concentration (lyr,aer_nbr) [kg/kg] + real(r8):: h2osno_lcl ! total column snow mass [kg/m2] + real(r8):: h2osno_liq_lcl(maxsnl+1:0) ! liquid water mass [kg/m2] + real(r8):: h2osno_ice_lcl(maxsnl+1:0) ! ice mass [kg/m2] + real(r8):: albsfc_lcl(1:numrad_snw) ! albedo of underlying surface [frc] + real(r8):: ss_alb_snw_lcl(maxsnl+1:0) ! single-scatter albedo of ice grains (lyr) [frc] + real(r8):: asm_prm_snw_lcl(maxsnl+1:0) ! asymmetry parameter of ice grains (lyr) [frc] + real(r8):: ext_cff_mss_snw_lcl(maxsnl+1:0) ! mass extinction coefficient of ice grains (lyr) [m2/kg] + real(r8):: ss_alb_aer_lcl(sno_nbr_aer) ! single-scatter albedo of aerosol species (aer_nbr) [frc] + real(r8):: asm_prm_aer_lcl(sno_nbr_aer) ! asymmetry parameter of aerosol species (aer_nbr) [frc] + real(r8):: ext_cff_mss_aer_lcl(sno_nbr_aer) ! mass extinction coefficient of aerosol species (aer_nbr) [m2/kg] #ifdef MODAL_AER - !mgf++ - real(r8) :: rds_bcint_lcl(maxsnl+1:0) ! effective radius of within-ice BC [nm] - real(r8) :: rds_bcext_lcl(maxsnl+1:0) ! effective radius of external BC [nm] - !mgf-- + !mgf++ + real(r8) :: rds_bcint_lcl(maxsnl+1:0) ! effective radius of within-ice BC [nm] + real(r8) :: rds_bcext_lcl(maxsnl+1:0) ! effective radius of external BC [nm] + !mgf-- #endif - ! Other local variables - integer :: DELTA ! flag to use Delta approximation (Joseph, 1976) - ! (1= use, 0= don't use) - real(r8):: flx_wgt(1:numrad_snw) ! weights applied to spectral bands, - ! specific to direct and diffuse cases (bnd) [frc] - integer :: flg_nosnl ! flag: =1 if there is snow, but zero snow layers, - ! =0 if at least 1 snow layer [flg] - ! integer :: trip ! flag: =1 to redo RT calculation if result is unrealistic - ! integer :: flg_dover ! defines conditions for RT redo (explained below) - - real(r8):: albedo ! temporary snow albedo [frc] - real(r8):: flx_sum ! temporary summation variable for NIR weighting - real(r8):: albout_lcl(numrad_snw) ! snow albedo by band [frc] - real(r8):: flx_abs_lcl(maxsnl+1:1,numrad_snw) ! absorbed flux per unit incident flux at top of snowpack (lyr,bnd) [frc] - - real(r8):: L_snw(maxsnl+1:0) ! h2o mass (liquid+solid) in snow layer (lyr) [kg/m2] - real(r8):: tau_snw(maxsnl+1:0) ! snow optical depth (lyr) [unitless] - real(r8):: L_aer(maxsnl+1:0,sno_nbr_aer) ! aerosol mass in snow layer (lyr,nbr_aer) [kg/m2] - real(r8):: tau_aer(maxsnl+1:0,sno_nbr_aer) ! aerosol optical depth (lyr,nbr_aer) [unitless] - real(r8):: tau_sum ! cumulative (snow+aerosol) optical depth [unitless] - real(r8):: tau_elm(maxsnl+1:0) ! column optical depth from layer bottom to snowpack top (lyr) [unitless] - real(r8):: omega_sum ! temporary summation of single-scatter albedo of all aerosols [frc] - real(r8):: g_sum ! temporary summation of asymmetry parameter of all aerosols [frc] - - real(r8):: tau(maxsnl+1:0) ! weighted optical depth of snow+aerosol layer (lyr) [unitless] - real(r8):: omega(maxsnl+1:0) ! weighted single-scatter albedo of snow+aerosol layer (lyr) [frc] - real(r8):: g(maxsnl+1:0) ! weighted asymmetry parameter of snow+aerosol layer (lyr) [frc] - real(r8):: tau_star(maxsnl+1:0) ! transformed (i.e. Delta-Eddington) optical depth of snow+aerosol layer - ! (lyr) [unitless] - real(r8):: omega_star(maxsnl+1:0) ! transformed (i.e. Delta-Eddington) SSA of snow+aerosol layer (lyr) [frc] - real(r8):: g_star(maxsnl+1:0) ! transformed (i.e. Delta-Eddington) asymmetry paramater of snow+aerosol layer - ! (lyr) [frc] - - ! integer :: c_idx ! column indices [idx] - integer :: bnd_idx ! spectral band index (1 <= bnd_idx <= numrad_snw) [idx] - integer :: rds_idx ! snow effective radius index for retrieving - ! Mie parameters from lookup table [idx] - integer :: snl_btm ! index of bottom snow layer (0) [idx] - integer :: snl_top ! index of top snow layer (-4 to 0) [idx] - integer :: fc ! column filter index - integer :: i ! layer index [idx] - integer :: j ! aerosol number index [idx] - integer :: m ! secondary layer index [idx] - integer :: nint_snw_rds_min ! nearest integer value of snw_rds_min - - real(r8):: F_abs(maxsnl+1:0) ! net absorbed radiative energy (lyr) [W/m^2] - real(r8):: F_abs_sum ! total absorbed energy in column [W/m^2] - real(r8):: F_sfc_pls ! upward radiative flux at snowpack top [W/m^2] - real(r8):: F_btm_net ! net flux at bottom of snowpack [W/m^2] - real(r8):: energy_sum ! sum of all energy terms; should be 0.0 [W/m^2] - real(r8):: mu_not ! cosine of solar zenith angle (used locally) [frc] - - integer :: err_idx ! counter for number of times through error loop [nbr] - real(r8):: pi ! 3.1415... - - integer :: snw_shp_lcl(maxsnl+1:0) ! Snow grain shape option: - ! 1=sphere; 2=spheroid; 3=hexagonal plate; 4=koch snowflake - real(r8):: snw_fs_lcl(maxsnl+1:0) ! Shape factor: ratio of nonspherical grain effective radii to that of equal-volume sphere - ! 0=use recommended default value - ! others(0 1 (i.e. nonspherical) - real(r8):: snw_ar_lcl(maxsnl+1:0) ! % Aspect ratio: ratio of grain width to length - ! 0=use recommended default value - ! others(0.1 1 (i.e. nonspherical) - real(r8):: & - diam_ice , & ! effective snow grain diameter - fs_sphd , & ! shape factor for spheroid - fs_hex0 , & ! shape factor for hexagonal plate - fs_hex , & ! shape factor for hexagonal plate (reference) - fs_koch , & ! shape factor for koch snowflake - AR_tmp , & ! aspect ratio for spheroid - g_ice_Cg_tmp(7) , & ! temporary for calculation of asymetry factor - gg_ice_F07_tmp(7) , & ! temporary for calculation of asymetry factor - g_ice_F07 , & ! temporary for calculation of asymetry factor - g_ice , & ! asymmetry factor - gg_F07_intp , & ! temporary for calculation of asymetry factor (interpolated) - g_Cg_intp , & ! temporary for calculation of asymetry factor (interpolated) - R_1_omega_tmp , & ! temporary for dust-snow mixing calculation - C_dust_total ! dust concentration - - integer :: atm_type_index ! index for atmospheric type - integer :: slr_zen ! integer value of solar zenith angle - - ! SNICAR_AD new variables, follow sea-ice shortwave conventions - real(r8):: & - trndir(maxsnl+1:1) , & ! solar beam down transmission from top - trntdr(maxsnl+1:1) , & ! total transmission to direct beam for layers above - trndif(maxsnl+1:1) , & ! diffuse transmission to diffuse beam for layers above - rupdir(maxsnl+1:1) , & ! reflectivity to direct radiation for layers below - rupdif(maxsnl+1:1) , & ! reflectivity to diffuse radiation for layers below - rdndif(maxsnl+1:1) , & ! reflectivity to diffuse radiation for layers above - dfdir(maxsnl+1:1) , & ! down-up flux at interface due to direct beam at top surface - dfdif(maxsnl+1:1) , & ! down-up flux at interface due to diffuse beam at top surface - dftmp(maxsnl+1:1) ! temporary variable for down-up flux at interface - - real(r8):: & - rdir(maxsnl+1:0) , & ! layer reflectivity to direct radiation - rdif_a(maxsnl+1:0) , & ! layer reflectivity to diffuse radiation from above - rdif_b(maxsnl+1:0) , & ! layer reflectivity to diffuse radiation from below - tdir(maxsnl+1:0) , & ! layer transmission to direct radiation (solar beam + diffuse) - tdif_a(maxsnl+1:0) , & ! layer transmission to diffuse radiation from above - tdif_b(maxsnl+1:0) , & ! layer transmission to diffuse radiation from below - trnlay(maxsnl+1:0) ! solar beam transm for layer (direct beam only) - - real(r8):: & - ts , & ! layer delta-scaled extinction optical depth - ws , & ! layer delta-scaled single scattering albedo - gs , & ! layer delta-scaled asymmetry parameter - extins , & ! extinction - alp , & ! temporary for alpha - gam , & ! temporary for agamm - amg , & ! alp - gam - apg , & ! alp + gam - ue , & ! temporary for u - refk , & ! interface multiple scattering - refkp1 , & ! interface multiple scattering for k+1 - refkm1 , & ! interface multiple scattering for k-1 - tdrrdir , & ! direct tran times layer direct ref - tdndif ! total down diffuse = tot tran - direct tran - - real(r8) :: & - alpha , & ! term in direct reflectivity and transmissivity - agamm , & ! term in direct reflectivity and transmissivity - el , & ! term in alpha,agamm,n,u - taus , & ! scaled extinction optical depth - omgs , & ! scaled single particle scattering albedo - asys , & ! scaled asymmetry parameter - u , & ! term in diffuse reflectivity and transmissivity - n , & ! term in diffuse reflectivity and transmissivity - lm , & ! temporary for el - mu , & ! cosine solar zenith for either snow or water - ne ! temporary for n - - ! perpendicular and parallel relative to plane of incidence and scattering - real(r8) :: & - R1 , & ! perpendicular polarization reflection amplitude - R2 , & ! parallel polarization reflection amplitude - T1 , & ! perpendicular polarization transmission amplitude - T2 , & ! parallel polarization transmission amplitude - Rf_dir_a , & ! fresnel reflection to direct radiation - Tf_dir_a , & ! fresnel transmission to direct radiation - Rf_dif_a , & ! fresnel reflection to diff radiation from above - Rf_dif_b , & ! fresnel reflection to diff radiation from below - Tf_dif_a , & ! fresnel transmission to diff radiation from above - Tf_dif_b ! fresnel transmission to diff radiation from below - - real(r8) :: & - gwt , & ! gaussian weight - swt , & ! sum of weights - trn , & ! layer transmission - rdr , & ! rdir for gaussian integration - tdr , & ! tdir for gaussian integration - smr , & ! accumulator for rdif gaussian integration - smt , & ! accumulator for tdif gaussian integration - exp_min ! minimum exponential value - - integer :: & - ng , & ! gaussian integration index - snl_btm_itf , & ! index of bottom snow layer interfaces (1) [idx] - ngmax = 8 ! gaussian integration index - - ! Gaussian integration angle and coefficients - real(r8) :: difgauspt(1:8) , difgauswt(1:8) - - ! constants used in algorithm - real(r8) :: & - c0 = 0.0_r8 , & - c1 = 1.0_r8 , & - c3 = 3.0_r8 , & - c4 = 4.0_r8 , & - c6 = 6.0_r8 , & - cp01 = 0.01_r8 , & - cp5 = 0.5_r8 , & - cp75 = 0.75_r8 , & - c1p5 = 1.5_r8 , & - trmin = 0.001_r8 , & - argmax = 10.0_r8 ! maximum argument of exponential - - ! cconstant coefficients used for SZA parameterization - real(r8) :: & - sza_a0 = 0.085730_r8 , & - sza_a1 = -0.630883_r8 , & - sza_a2 = 1.303723_r8 , & - sza_b0 = 1.467291_r8 , & - sza_b1 = -3.338043_r8 , & - sza_b2 = 6.807489_r8 , & - puny = 1.0e-11_r8 , & - mu_75 = 0.2588_r8 ! cosine of 75 degree - - ! coefficients used for SZA parameterization - real(r8) :: & - sza_c1 , & ! coefficient, SZA parameteirzation - sza_c0 , & ! coefficient, SZA parameterization - sza_factor , & ! factor used to adjust NIR direct albedo - flx_sza_adjust , & ! direct NIR flux adjustment from sza_factor - mu0 ! incident solar zenith angle + ! Other local variables + integer :: DELTA ! flag to USE Delta approximation (Joseph, 1976) + ! (1= USE, 0= don't USE) + real(r8):: flx_wgt(1:numrad_snw) ! weights applied to spectral bands, + ! specific to direct and diffuse cases (bnd) [frc] + integer :: flg_nosnl ! flag: =1 IF there is snow, but zero snow layers, + ! =0 IF at least 1 snow layer [flg] + ! integer :: trip ! flag: =1 to redo RT calculation IF result is unrealistic + ! integer :: flg_dover ! defines conditions for RT redo (explained below) + + real(r8):: albedo ! temporary snow albedo [frc] + real(r8):: flx_sum ! temporary summation variable for NIR weighting + real(r8):: albout_lcl(numrad_snw) ! snow albedo by band [frc] + real(r8):: flx_abs_lcl(maxsnl+1:1,numrad_snw) ! absorbed flux per unit incident flux at top of snowpack (lyr,bnd) [frc] + + real(r8):: L_snw(maxsnl+1:0) ! h2o mass (liquid+solid) in snow layer (lyr) [kg/m2] + real(r8):: tau_snw(maxsnl+1:0) ! snow optical depth (lyr) [unitless] + real(r8):: L_aer(maxsnl+1:0,sno_nbr_aer) ! aerosol mass in snow layer (lyr,nbr_aer) [kg/m2] + real(r8):: tau_aer(maxsnl+1:0,sno_nbr_aer) ! aerosol optical depth (lyr,nbr_aer) [unitless] + real(r8):: tau_sum ! cumulative (snow+aerosol) optical depth [unitless] + real(r8):: tau_elm(maxsnl+1:0) ! column optical depth from layer bottom to snowpack top (lyr) [unitless] + real(r8):: omega_sum ! temporary summation of single-scatter albedo of all aerosols [frc] + real(r8):: g_sum ! temporary summation of asymmetry parameter of all aerosols [frc] + + real(r8):: tau(maxsnl+1:0) ! weighted optical depth of snow+aerosol layer (lyr) [unitless] + real(r8):: omega(maxsnl+1:0) ! weighted single-scatter albedo of snow+aerosol layer (lyr) [frc] + real(r8):: g(maxsnl+1:0) ! weighted asymmetry parameter of snow+aerosol layer (lyr) [frc] + real(r8):: tau_star(maxsnl+1:0) ! transformed (i.e. Delta-Eddington) optical depth of snow+aerosol layer + ! (lyr) [unitless] + real(r8):: omega_star(maxsnl+1:0) ! transformed (i.e. Delta-Eddington) SSA of snow+aerosol layer (lyr) [frc] + real(r8):: g_star(maxsnl+1:0) ! transformed (i.e. Delta-Eddington) asymmetry paramater of snow+aerosol layer + ! (lyr) [frc] + + ! integer :: c_idx ! column indices [idx] + integer :: bnd_idx ! spectral band index (1 <= bnd_idx <= numrad_snw) [idx] + integer :: rds_idx ! snow effective radius index for retrieving + ! Mie parameters from lookup table [idx] + integer :: snl_btm ! index of bottom snow layer (0) [idx] + integer :: snl_top ! index of top snow layer (-4 to 0) [idx] + integer :: fc ! column filter index + integer :: i ! layer index [idx] + integer :: j ! aerosol number index [idx] + integer :: m ! secondary layer index [idx] + integer :: nint_snw_rds_min ! nearest integer value of snw_rds_min + + real(r8):: F_abs(maxsnl+1:0) ! net absorbed radiative energy (lyr) [W/m^2] + real(r8):: F_abs_sum ! total absorbed energy in column [W/m^2] + real(r8):: F_sfc_pls ! upward radiative flux at snowpack top [W/m^2] + real(r8):: F_btm_net ! net flux at bottom of snowpack [W/m^2] + real(r8):: energy_sum ! sum of all energy terms; should be 0.0 [W/m^2] + real(r8):: mu_not ! cosine of solar zenith angle (used locally) [frc] + + integer :: err_idx ! counter for number of times through error loop [nbr] + real(r8):: pi ! 3.1415... + + integer :: snw_shp_lcl(maxsnl+1:0) ! Snow grain shape option: + ! 1=sphere; 2=spheroid; 3=hexagonal plate; 4=koch snowflake + real(r8):: snw_fs_lcl(maxsnl+1:0) ! Shape factor: ratio of nonspherical grain effective radii to that of equal-volume sphere + ! 0=USE recommended default value + ! others(0 1 (i.e. nonspherical) + real(r8):: snw_ar_lcl(maxsnl+1:0) ! % Aspect ratio: ratio of grain width to length + ! 0=USE recommended default value + ! others(0.1 1 (i.e. nonspherical) + real(r8):: & + diam_ice , & ! effective snow grain diameter + fs_sphd , & ! shape factor for spheroid + fs_hex0 , & ! shape factor for hexagonal plate + fs_hex , & ! shape factor for hexagonal plate (reference) + fs_koch , & ! shape factor for koch snowflake + AR_tmp , & ! aspect ratio for spheroid + g_ice_Cg_tmp(7) , & ! temporary for calculation of asymetry factor + gg_ice_F07_tmp(7) , & ! temporary for calculation of asymetry factor + g_ice_F07 , & ! temporary for calculation of asymetry factor + g_ice , & ! asymmetry factor + gg_F07_intp , & ! temporary for calculation of asymetry factor (interpolated) + g_Cg_intp , & ! temporary for calculation of asymetry factor (interpolated) + R_1_omega_tmp , & ! temporary for dust-snow mixing calculation + C_dust_total ! dust concentration + + integer :: atm_type_index ! index for atmospheric type + integer :: slr_zen ! integer value of solar zenith angle + + ! SNICAR_AD new variables, follow sea-ice shortwave conventions + real(r8):: & + trndir(maxsnl+1:1) , & ! solar beam down transmission from top + trntdr(maxsnl+1:1) , & ! total transmission to direct beam for layers above + trndif(maxsnl+1:1) , & ! diffuse transmission to diffuse beam for layers above + rupdir(maxsnl+1:1) , & ! reflectivity to direct radiation for layers below + rupdif(maxsnl+1:1) , & ! reflectivity to diffuse radiation for layers below + rdndif(maxsnl+1:1) , & ! reflectivity to diffuse radiation for layers above + dfdir(maxsnl+1:1) , & ! down-up flux at interface due to direct beam at top surface + dfdif(maxsnl+1:1) , & ! down-up flux at interface due to diffuse beam at top surface + dftmp(maxsnl+1:1) ! temporary variable for down-up flux at interface + + real(r8):: & + rdir(maxsnl+1:0) , & ! layer reflectivity to direct radiation + rdif_a(maxsnl+1:0) , & ! layer reflectivity to diffuse radiation from above + rdif_b(maxsnl+1:0) , & ! layer reflectivity to diffuse radiation from below + tdir(maxsnl+1:0) , & ! layer transmission to direct radiation (solar beam + diffuse) + tdif_a(maxsnl+1:0) , & ! layer transmission to diffuse radiation from above + tdif_b(maxsnl+1:0) , & ! layer transmission to diffuse radiation from below + trnlay(maxsnl+1:0) ! solar beam transm for layer (direct beam only) + + real(r8):: & + ts , & ! layer delta-scaled extinction optical depth + ws , & ! layer delta-scaled single scattering albedo + gs , & ! layer delta-scaled asymmetry parameter + extins , & ! extinction + alp , & ! temporary for alpha + gam , & ! temporary for agamm + amg , & ! alp - gam + apg , & ! alp + gam + ue , & ! temporary for u + refk , & ! interface multiple scattering + refkp1 , & ! interface multiple scattering for k+1 + refkm1 , & ! interface multiple scattering for k-1 + tdrrdir , & ! direct tran times layer direct ref + tdndif ! total down diffuse = tot tran - direct tran + + real(r8) :: & + alpha , & ! term in direct reflectivity and transmissivity + agamm , & ! term in direct reflectivity and transmissivity + el , & ! term in alpha,agamm,n,u + taus , & ! scaled extinction optical depth + omgs , & ! scaled single particle scattering albedo + asys , & ! scaled asymmetry parameter + u , & ! term in diffuse reflectivity and transmissivity + n , & ! term in diffuse reflectivity and transmissivity + lm , & ! temporary for el + mu , & ! cosine solar zenith for either snow or water + ne ! temporary for n + + ! perpendicular and parallel relative to plane of incidence and scattering + real(r8) :: & + R1 , & ! perpendicular polarization reflection amplitude + R2 , & ! parallel polarization reflection amplitude + T1 , & ! perpendicular polarization transmission amplitude + T2 , & ! parallel polarization transmission amplitude + Rf_dir_a , & ! fresnel reflection to direct radiation + Tf_dir_a , & ! fresnel transmission to direct radiation + Rf_dif_a , & ! fresnel reflection to diff radiation from above + Rf_dif_b , & ! fresnel reflection to diff radiation from below + Tf_dif_a , & ! fresnel transmission to diff radiation from above + Tf_dif_b ! fresnel transmission to diff radiation from below + + real(r8) :: & + gwt , & ! gaussian weight + swt , & ! sum of weights + trn , & ! layer transmission + rdr , & ! rdir for gaussian integration + tdr , & ! tdir for gaussian integration + smr , & ! accumulator for rdif gaussian integration + smt , & ! accumulator for tdif gaussian integration + exp_min ! minimum exponential value + + integer :: & + ng , & ! gaussian integration index + snl_btm_itf , & ! index of bottom snow layer interfaces (1) [idx] + ngmax = 8 ! gaussian integration index + + ! Gaussian integration angle and coefficients + real(r8) :: difgauspt(1:8) , difgauswt(1:8) + + ! constants used in algorithm + real(r8) :: & + c0 = 0.0_r8 , & + c1 = 1.0_r8 , & + c3 = 3.0_r8 , & + c4 = 4.0_r8 , & + c6 = 6.0_r8 , & + cp01 = 0.01_r8 , & + cp5 = 0.5_r8 , & + cp75 = 0.75_r8 , & + c1p5 = 1.5_r8 , & + trmin = 0.001_r8 , & + argmax = 10.0_r8 ! maximum argument of exponential + + ! cconstant coefficients used for SZA parameterization + real(r8) :: & + sza_a0 = 0.085730_r8 , & + sza_a1 = -0.630883_r8 , & + sza_a2 = 1.303723_r8 , & + sza_b0 = 1.467291_r8 , & + sza_b1 = -3.338043_r8 , & + sza_b2 = 6.807489_r8 , & + puny = 1.0e-11_r8 , & + mu_75 = 0.2588_r8 ! cosine of 75 degree + + ! coefficients used for SZA parameterization + real(r8) :: & + sza_c1 , & ! coefficient, SZA parameteirzation + sza_c0 , & ! coefficient, SZA parameterization + sza_factor , & ! factor used to adjust NIR direct albedo + flx_sza_adjust , & ! direct NIR flux adjustment from sza_factor + mu0 ! incident solar zenith angle !----------------------------------------------------------------------- #ifdef MODAL_AER - !mgf++ - integer :: idx_bcint_icerds ! index of ice effective radius for optical properties lookup table - integer :: idx_bcint_nclrds ! index of within-ice BC effective radius for optical properties lookup table - integer :: idx_bcext_nclrds ! index of external BC effective radius for optical properties lookup table - real(r8):: enh_fct ! extinction/absorption enhancement factor for within-ice BC - real(r8):: tmp1 ! temporary variable - !mgf-- + !mgf++ + integer :: idx_bcint_icerds ! index of ice effective radius for optical properties lookup table + integer :: idx_bcint_nclrds ! index of within-ice BC effective radius for optical properties lookup table + integer :: idx_bcext_nclrds ! index of external BC effective radius for optical properties lookup table + real(r8):: enh_fct ! extinction/absorption enhancement factor for within-ice BC + real(r8):: tmp1 ! temporary variable + !mgf-- #endif - ! Constants for non-spherical ice particles and dust-snow internal mixing - real(r8) :: g_b2(7) - real(r8) :: g_b1(7) - real(r8) :: g_b0(7) - real(r8) :: g_F07_c2(7) - real(r8) :: g_F07_c1(7) - real(r8) :: g_F07_c0(7) - real(r8) :: g_F07_p2(7) - real(r8) :: g_F07_p1(7) - real(r8) :: g_F07_p0(7) - real(r8) :: dust_clear_d0(3) - real(r8) :: dust_clear_d1(3) - real(r8) :: dust_clear_d2(3) - real(r8) :: dust_cloudy_d0(3) - real(r8) :: dust_cloudy_d1(3) - real(r8) :: dust_cloudy_d2(3) - - !!! factors for considering snow grain shape - data g_b0(:) / 9.76029E-01_r8, 9.67798E-01_r8, 1.00111E+00_r8, 1.00224E+00_r8,& - 9.64295E-01_r8, 9.97475E-01_r8, 9.97475E-01_r8/ - data g_b1(:) / 5.21042E-01_r8, 4.96181E-01_r8, 1.83711E-01_r8, 1.37082E-01_r8,& - 5.50598E-02_r8, 8.48743E-02_r8, 8.48743E-02_r8/ - data g_b2(:) /-2.66792E-04_r8, 1.14088E-03_r8, 2.37011E-04_r8,-2.35905E-04_r8,& - 8.40449E-04_r8,-4.71484E-04_r8,-4.71484E-04_r8/ - - data g_F07_c2(:) / 1.349959E-1_r8, 1.115697E-1_r8, 9.853958E-2_r8, 5.557793E-2_r8,& - -1.233493E-1_r8, 0.0_r8, 0.0_r8/ - data g_F07_c1(:) /-3.987320E-1_r8,-3.723287E-1_r8,-3.924784E-1_r8,-3.259404E-1_r8,& - 4.429054E-2_r8,-1.726586E-1_r8,-1.726586E-1_r8/ - data g_F07_c0(:) / 7.938904E-1_r8, 8.030084E-1_r8, 8.513932E-1_r8, 8.692241E-1_r8,& - 7.085850E-1_r8, 6.412701E-1_r8, 6.412701E-1_r8/ - data g_F07_p2(:) / 3.165543E-3_r8, 2.014810E-3_r8, 1.780838E-3_r8, 6.987734E-4_r8,& - -1.882932E-2_r8,-2.277872E-2_r8,-2.277872E-2_r8/ - data g_F07_p1(:) / 1.140557E-1_r8, 1.143152E-1_r8, 1.143814E-1_r8, 1.071238E-1_r8,& - 1.353873E-1_r8, 1.914431E-1_r8, 1.914431E-1_r8/ - data g_F07_p0(:) / 5.292852E-1_r8, 5.425909E-1_r8, 5.601598E-1_r8, 6.023407E-1_r8,& - 6.473899E-1_r8, 4.634944E-1_r8, 4.634944E-1_r8/ - - !!! factors for considring dust-snow internal mixing - data dust_clear_d0(:) /1.0413E+00_r8,1.0168E+00_r8,1.0189E+00_r8/ - data dust_clear_d1(:) /1.0016E+00_r8,1.0070E+00_r8,1.0840E+00_r8/ - data dust_clear_d2(:) /2.4208E-01_r8,1.5300E-03_r8,1.1230E-04_r8/ - - data dust_cloudy_d0(:) /1.0388E+00_r8,1.0167E+00_r8,1.0189E+00_r8/ - data dust_cloudy_d1(:) /1.0015E+00_r8,1.0061E+00_r8,1.0823E+00_r8/ - data dust_cloudy_d2(:) /2.5973E-01_r8,1.6200E-03_r8,1.1721E-04_r8/ - - ! Enforce expected array sizes + ! Constants for non-spherical ice particles and dust-snow internal mixing + real(r8) :: g_b2(7) + real(r8) :: g_b1(7) + real(r8) :: g_b0(7) + real(r8) :: g_F07_c2(7) + real(r8) :: g_F07_c1(7) + real(r8) :: g_F07_c0(7) + real(r8) :: g_F07_p2(7) + real(r8) :: g_F07_p1(7) + real(r8) :: g_F07_p0(7) + real(r8) :: dust_clear_d0(3) + real(r8) :: dust_clear_d1(3) + real(r8) :: dust_clear_d2(3) + real(r8) :: dust_cloudy_d0(3) + real(r8) :: dust_cloudy_d1(3) + real(r8) :: dust_cloudy_d2(3) + + !!! factors for considering snow grain shape + data g_b0(:) / 9.76029E-01_r8, 9.67798E-01_r8, 1.00111E+00_r8, 1.00224E+00_r8,& + 9.64295E-01_r8, 9.97475E-01_r8, 9.97475E-01_r8/ + data g_b1(:) / 5.21042E-01_r8, 4.96181E-01_r8, 1.83711E-01_r8, 1.37082E-01_r8,& + 5.50598E-02_r8, 8.48743E-02_r8, 8.48743E-02_r8/ + data g_b2(:) /-2.66792E-04_r8, 1.14088E-03_r8, 2.37011E-04_r8,-2.35905E-04_r8,& + 8.40449E-04_r8,-4.71484E-04_r8,-4.71484E-04_r8/ + + data g_F07_c2(:) / 1.349959E-1_r8, 1.115697E-1_r8, 9.853958E-2_r8, 5.557793E-2_r8,& + -1.233493E-1_r8, 0.0_r8, 0.0_r8/ + data g_F07_c1(:) /-3.987320E-1_r8,-3.723287E-1_r8,-3.924784E-1_r8,-3.259404E-1_r8,& + 4.429054E-2_r8,-1.726586E-1_r8,-1.726586E-1_r8/ + data g_F07_c0(:) / 7.938904E-1_r8, 8.030084E-1_r8, 8.513932E-1_r8, 8.692241E-1_r8,& + 7.085850E-1_r8, 6.412701E-1_r8, 6.412701E-1_r8/ + data g_F07_p2(:) / 3.165543E-3_r8, 2.014810E-3_r8, 1.780838E-3_r8, 6.987734E-4_r8,& + -1.882932E-2_r8,-2.277872E-2_r8,-2.277872E-2_r8/ + data g_F07_p1(:) / 1.140557E-1_r8, 1.143152E-1_r8, 1.143814E-1_r8, 1.071238E-1_r8,& + 1.353873E-1_r8, 1.914431E-1_r8, 1.914431E-1_r8/ + data g_F07_p0(:) / 5.292852E-1_r8, 5.425909E-1_r8, 5.601598E-1_r8, 6.023407E-1_r8,& + 6.473899E-1_r8, 4.634944E-1_r8, 4.634944E-1_r8/ + + !!! factors for considring dust-snow internal mixing + data dust_clear_d0(:) /1.0413E+00_r8,1.0168E+00_r8,1.0189E+00_r8/ + data dust_clear_d1(:) /1.0016E+00_r8,1.0070E+00_r8,1.0840E+00_r8/ + data dust_clear_d2(:) /2.4208E-01_r8,1.5300E-03_r8,1.1230E-04_r8/ + + data dust_cloudy_d0(:) /1.0388E+00_r8,1.0167E+00_r8,1.0189E+00_r8/ + data dust_cloudy_d1(:) /1.0015E+00_r8,1.0061E+00_r8,1.0823E+00_r8/ + data dust_cloudy_d2(:) /2.5973E-01_r8,1.6200E-03_r8,1.1721E-04_r8/ + + ! Enforce expected array sizes ! associate(& ! snl => col_pp%snl , & ! Input: [integer (:)] negative number of snow layers (col) [nbr] @@ -1473,1035 +1473,1035 @@ subroutine SNICAR_AD_RT (flg_snw_ice, flg_slr_in, & ! frac_sno => col_ws%frac_sno_eff & ! Input: [real(r8) (:)] fraction of ground covered by snow (0 to 1) ! ) - ! Define constants - pi = SHR_CONST_PI - nint_snw_rds_min = nint(snw_rds_min) - - ! always use Delta approximation for snow - DELTA = 1 - - !Gaussian integration angle and coefficients for diffuse radiation - difgauspt(1:8) & ! gaussian angles (radians) - = (/ 0.9894009_r8, 0.9445750_r8, & - 0.8656312_r8, 0.7554044_r8, & - 0.6178762_r8, 0.4580168_r8, & - 0.2816036_r8, 0.0950125_r8/) - difgauswt(1:8) & ! gaussian weights - = (/ 0.0271525_r8, 0.0622535_r8, & - 0.0951585_r8, 0.1246290_r8, & - 0.1495960_r8, 0.1691565_r8, & - 0.1826034_r8, 0.1894506_r8/) - - snw_shp_lcl(:) = snow_shape_sphere - snw_fs_lcl(:) = 0._r8 - snw_ar_lcl(:) = 0._r8 - atm_type_index = atm_type_default - - ! Define snow grain shape - if (trim(snow_shape) == 'sphere') then - snw_shp_lcl(:) = snow_shape_sphere - elseif (trim(snow_shape) == 'spheroid') then - snw_shp_lcl(:) = snow_shape_spheroid - elseif (trim(snow_shape) == 'hexagonal_plate') then - snw_shp_lcl(:) = snow_shape_hexagonal_plate - elseif (trim(snow_shape) == 'koch_snowflake') then - snw_shp_lcl(:) = snow_shape_koch_snowflake - else - IF (p_is_master) THEN - write(iulog,*) "snow_shape = ", snow_shape - call abort - ENDIF - endif - - ! Define atmospheric type - if (trim(snicar_atm_type) == 'default') then - atm_type_index = atm_type_default - elseif (trim(snicar_atm_type) == 'mid-latitude_winter') then - atm_type_index = atm_type_mid_latitude_winter - elseif (trim(snicar_atm_type) == 'mid-latitude_summer') then - atm_type_index = atm_type_mid_latitude_summer - elseif (trim(snicar_atm_type) == 'sub-Arctic_winter') then - atm_type_index = atm_type_sub_Arctic_winter - elseif (trim(snicar_atm_type) == 'sub-Arctic_summer') then - atm_type_index = atm_type_sub_Arctic_summer - elseif (trim(snicar_atm_type) == 'summit_Greenland') then - atm_type_index = atm_type_summit_Greenland - elseif (trim(snicar_atm_type) == 'high_mountain') then - atm_type_index = atm_type_high_mountain - else - IF (p_is_master) THEN - write(iulog,*) "snicar_atm_type = ", snicar_atm_type - call abort - ENDIF - endif - - ! (when called from CSIM, there is only one column) - - ! Zero absorbed radiative fluxes: - do i=maxsnl+1,1,1 - flx_abs_lcl(:,:) = 0._r8 - flx_abs(i,:) = 0._r8 - enddo - - ! set snow/ice mass to be used for RT: - if (flg_snw_ice == 1) then - h2osno_lcl = h2osno - else - h2osno_lcl = h2osno_ice(0) - endif - - ! Qualifier for computing snow RT: - ! 1) sunlight from atmosphere model - ! 2) minimum amount of snow on ground. - ! Otherwise, set snow albedo to zero - if ((coszen > 0._r8) .and. (h2osno_lcl > min_snw) ) then - - ! Set variables specific to ELM - if (flg_snw_ice == 1) then - ! If there is snow, but zero snow layers, we must create a layer locally. - ! This layer is presumed to have the fresh snow effective radius. - if (snl > -1) then - flg_nosnl = 1 - snl_lcl = -1 - h2osno_ice_lcl(0) = h2osno_lcl - h2osno_liq_lcl(0) = 0._r8 - snw_rds_lcl(0) = nint_snw_rds_min - else - flg_nosnl = 0 - snl_lcl = snl - h2osno_liq_lcl(:) = h2osno_liq(:) - h2osno_ice_lcl(:) = h2osno_ice(:) - snw_rds_lcl(:) = snw_rds(:) - endif - - snl_btm = 0 - snl_top = snl_lcl+1 - - ! Set variables specific to CSIM - else - flg_nosnl = 0 - snl_lcl = -1 - h2osno_liq_lcl(:) = h2osno_liq(:) - h2osno_ice_lcl(:) = h2osno_ice(:) - snw_rds_lcl(:) = snw_rds(:) - snl_btm = 0 - snl_top = 0 - endif ! end if flg_snw_ice == 1 + ! Define constants + pi = SHR_CONST_PI + nint_snw_rds_min = nint(snw_rds_min) + + ! always USE Delta approximation for snow + DELTA = 1 + + !Gaussian integration angle and coefficients for diffuse radiation + difgauspt(1:8) & ! gaussian angles (radians) + = (/ 0.9894009_r8, 0.9445750_r8, & + 0.8656312_r8, 0.7554044_r8, & + 0.6178762_r8, 0.4580168_r8, & + 0.2816036_r8, 0.0950125_r8/) + difgauswt(1:8) & ! gaussian weights + = (/ 0.0271525_r8, 0.0622535_r8, & + 0.0951585_r8, 0.1246290_r8, & + 0.1495960_r8, 0.1691565_r8, & + 0.1826034_r8, 0.1894506_r8/) + + snw_shp_lcl(:) = snow_shape_sphere + snw_fs_lcl(:) = 0._r8 + snw_ar_lcl(:) = 0._r8 + atm_type_index = atm_type_default + + ! Define snow grain shape + IF (trim(snow_shape) == 'sphere') THEN + snw_shp_lcl(:) = snow_shape_sphere + elseif (trim(snow_shape) == 'spheroid') THEN + snw_shp_lcl(:) = snow_shape_spheroid + elseif (trim(snow_shape) == 'hexagonal_plate') THEN + snw_shp_lcl(:) = snow_shape_hexagonal_plate + elseif (trim(snow_shape) == 'koch_snowflake') THEN + snw_shp_lcl(:) = snow_shape_koch_snowflake + ELSE + IF (p_is_master) THEN + write(iulog,*) "snow_shape = ", snow_shape + CALL abort + ENDIF + ENDIF + + ! Define atmospheric type + IF (trim(snicar_atm_type) == 'default') THEN + atm_type_index = atm_type_default + elseif (trim(snicar_atm_type) == 'mid-latitude_winter') THEN + atm_type_index = atm_type_mid_latitude_winter + elseif (trim(snicar_atm_type) == 'mid-latitude_summer') THEN + atm_type_index = atm_type_mid_latitude_summer + elseif (trim(snicar_atm_type) == 'sub-Arctic_winter') THEN + atm_type_index = atm_type_sub_Arctic_winter + elseif (trim(snicar_atm_type) == 'sub-Arctic_summer') THEN + atm_type_index = atm_type_sub_Arctic_summer + elseif (trim(snicar_atm_type) == 'summit_Greenland') THEN + atm_type_index = atm_type_summit_Greenland + elseif (trim(snicar_atm_type) == 'high_mountain') THEN + atm_type_index = atm_type_high_mountain + ELSE + IF (p_is_master) THEN + write(iulog,*) "snicar_atm_type = ", snicar_atm_type + CALL abort + ENDIF + ENDIF + + ! (when called from CSIM, there is only one column) + + ! Zero absorbed radiative fluxes: + DO i=maxsnl+1,1,1 + flx_abs_lcl(:,:) = 0._r8 + flx_abs(i,:) = 0._r8 + ENDDO + + ! set snow/ice mass to be used for RT: + IF (flg_snw_ice == 1) THEN + h2osno_lcl = h2osno + ELSE + h2osno_lcl = h2osno_ice(0) + ENDIF + + ! Qualifier for computing snow RT: + ! 1) sunlight from atmosphere model + ! 2) minimum amount of snow on ground. + ! Otherwise, set snow albedo to zero + IF ((coszen > 0._r8) .and. (h2osno_lcl > min_snw) ) THEN + + ! Set variables specific to ELM + IF (flg_snw_ice == 1) THEN + ! If there is snow, but zero snow layers, we must create a layer locally. + ! This layer is presumed to have the fresh snow effective radius. + IF (snl > -1) THEN + flg_nosnl = 1 + snl_lcl = -1 + h2osno_ice_lcl(0) = h2osno_lcl + h2osno_liq_lcl(0) = 0._r8 + snw_rds_lcl(0) = nint_snw_rds_min + ELSE + flg_nosnl = 0 + snl_lcl = snl + h2osno_liq_lcl(:) = h2osno_liq(:) + h2osno_ice_lcl(:) = h2osno_ice(:) + snw_rds_lcl(:) = snw_rds(:) + ENDIF + + snl_btm = 0 + snl_top = snl_lcl+1 + + ! Set variables specific to CSIM + ELSE + flg_nosnl = 0 + snl_lcl = -1 + h2osno_liq_lcl(:) = h2osno_liq(:) + h2osno_ice_lcl(:) = h2osno_ice(:) + snw_rds_lcl(:) = snw_rds(:) + snl_btm = 0 + snl_top = 0 + ENDIF ! END IF flg_snw_ice == 1 #ifdef MODAL_AER - !mgf++ - ! - ! Assume fixed BC effective radii of 100nm. This is close to - ! the effective radius of 95nm (number median radius of - ! 40nm) assumed for freshly-emitted BC in MAM. Future - ! implementations may prognose the BC effective radius in - ! snow. - rds_bcint_lcl(:) = 100._r8 - rds_bcext_lcl(:) = 100._r8 - !mgf-- + !mgf++ + ! + ! Assume fixed BC effective radii of 100nm. This is close to + ! the effective radius of 95nm (number median radius of + ! 40nm) assumed for freshly-emitted BC in MAM. Future + ! implementations may prognose the BC effective radius in + ! snow. + rds_bcint_lcl(:) = 100._r8 + rds_bcext_lcl(:) = 100._r8 + !mgf-- #endif - ! Set local aerosol array - do j=1,sno_nbr_aer - mss_cnc_aer_lcl(:,j) = mss_cnc_aer_in(:,j) - enddo - - ! Set spectral underlying surface albedos to their corresponding VIS or NIR albedos - albsfc_lcl(1) = albsfc(1) - albsfc_lcl(nir_bnd_bgn:nir_bnd_end) = albsfc(2) - - ! Error check for snow grain size: - IF (p_is_master) THEN - do i=snl_top,snl_btm,1 - if ((snw_rds_lcl(i) < snw_rds_min_tbl) .or. (snw_rds_lcl(i) > snw_rds_max_tbl)) then - write (iulog,*) "SNICAR ERROR: snow grain radius of ", snw_rds_lcl(i), " out of bounds." - write (iulog,*) "flg_snw_ice= ", flg_snw_ice - write (iulog,*) " level: ", i, " snl(c)= ", snl_lcl - write (iulog,*) "h2osno(c)= ", h2osno_lcl - call abort - endif - enddo - ENDIF - - ! Incident flux weighting parameters - ! - sum of all VIS bands must equal 1 - ! - sum of all NIR bands must equal 1 - ! - ! Spectral bands (5-band case) - ! Band 1: 0.3-0.7um (VIS) - ! Band 2: 0.7-1.0um (NIR) - ! Band 3: 1.0-1.2um (NIR) - ! Band 4: 1.2-1.5um (NIR) - ! Band 5: 1.5-5.0um (NIR) - ! - ! The following weights are appropriate for surface-incident flux in a mid-latitude winter atmosphere - ! - ! 3-band weights - if (numrad_snw==3) then - ! Direct: - if (flg_slr_in == 1) then - flx_wgt(1) = 1._r8 - flx_wgt(2) = 0.66628670195247_r8 - flx_wgt(3) = 0.33371329804753_r8 - ! Diffuse: - elseif (flg_slr_in == 2) then - flx_wgt(1) = 1._r8 - flx_wgt(2) = 0.77887652162877_r8 - flx_wgt(3) = 0.22112347837123_r8 - endif - - ! 5-band weights - elseif(numrad_snw==5) then - ! Direct: - if (flg_slr_in == 1) then - if (atm_type_index == atm_type_default) then - flx_wgt(1) = 1._r8 - flx_wgt(2) = 0.49352158521175_r8 - flx_wgt(3) = 0.18099494230665_r8 - flx_wgt(4) = 0.12094898498813_r8 - flx_wgt(5) = 0.20453448749347_r8 - else - slr_zen = nint(acos(coszen) * 180._r8 / pi) - if (slr_zen>89) then - slr_zen = 89 - endif - flx_wgt(1) = 1._r8 - flx_wgt(2) = flx_wgt_dir(atm_type_index, slr_zen+1, 2) - flx_wgt(3) = flx_wgt_dir(atm_type_index, slr_zen+1, 3) - flx_wgt(4) = flx_wgt_dir(atm_type_index, slr_zen+1, 4) - flx_wgt(5) = flx_wgt_dir(atm_type_index, slr_zen+1, 5) - endif - - ! Diffuse: - elseif (flg_slr_in == 2) then - if (atm_type_index == atm_type_default) then - flx_wgt(1) = 1._r8 - flx_wgt(2) = 0.58581507618433_r8 - flx_wgt(3) = 0.20156903770812_r8 - flx_wgt(4) = 0.10917889346386_r8 - flx_wgt(5) = 0.10343699264369_r8 - else - flx_wgt(1) = 1._r8 - flx_wgt(2) = flx_wgt_dif(atm_type_index, 2) - flx_wgt(3) = flx_wgt_dif(atm_type_index, 3) - flx_wgt(4) = flx_wgt_dif(atm_type_index, 4) - flx_wgt(5) = flx_wgt_dif(atm_type_index, 5) - endif - endif - endif ! end if numrad_snw - - ! Loop over snow spectral bands - - exp_min = exp(-argmax) - do bnd_idx = 1,numrad_snw - - ! note that we can remove flg_dover since this algorithm is - ! stable for mu_not > 0.01 - - ! mu_not is cosine solar zenith angle above the fresnel level; make - ! sure mu_not is large enough for stable and meaningful radiation - ! solution: .01 is like sun just touching horizon with its lower edge - ! equivalent to mu0 in sea-ice shortwave model ice_shortwave.F90 - mu_not = max(coszen, cp01) - - - ! Set direct or diffuse incident irradiance to 1 - ! (This has to be within the bnd loop because mu_not is adjusted in rare cases) - if (flg_slr_in == 1) then - flx_slrd_lcl(bnd_idx) = 1._r8/(mu_not*pi) ! this corresponds to incident irradiance of 1.0 - flx_slri_lcl(bnd_idx) = 0._r8 - else - flx_slrd_lcl(bnd_idx) = 0._r8 - flx_slri_lcl(bnd_idx) = 1._r8 - endif - - ! Pre-emptive error handling: aerosols can reap havoc on these absorptive bands. - ! Since extremely high soot concentrations have a negligible effect on these bands, zero them. - if ( (numrad_snw == 5).and.((bnd_idx == 5).or.(bnd_idx == 4)) ) then - mss_cnc_aer_lcl(:,:) = 0._r8 - endif - - if ( (numrad_snw == 3).and.(bnd_idx == 3) ) then - mss_cnc_aer_lcl(:,:) = 0._r8 - endif - - ! Define local Mie parameters based on snow grain size and aerosol species, - ! retrieved from a lookup table. - if (flg_slr_in == 1) then - do i=snl_top,snl_btm,1 - rds_idx = snw_rds_lcl(i) - snw_rds_min_tbl + 1 - ! snow optical properties (direct radiation) - ss_alb_snw_lcl(i) = ss_alb_snw_drc(rds_idx,bnd_idx) - asm_prm_snw_lcl(i) = asm_prm_snw_drc(rds_idx,bnd_idx) - ext_cff_mss_snw_lcl(i) = ext_cff_mss_snw_drc(rds_idx,bnd_idx) - enddo - elseif (flg_slr_in == 2) then - do i=snl_top,snl_btm,1 - rds_idx = snw_rds_lcl(i) - snw_rds_min_tbl + 1 - ! snow optical properties (diffuse radiation) - ss_alb_snw_lcl(i) = ss_alb_snw_dfs(rds_idx,bnd_idx) - asm_prm_snw_lcl(i) = asm_prm_snw_dfs(rds_idx,bnd_idx) - ext_cff_mss_snw_lcl(i) = ext_cff_mss_snw_dfs(rds_idx,bnd_idx) - enddo - endif - - ! Calculate the asymetry factors under different snow grain shapes - do i=snl_top,snl_btm,1 - if(snw_shp_lcl(i) == snow_shape_spheroid) then ! spheroid - diam_ice = 2._r8*snw_rds_lcl(i) - if(snw_fs_lcl(i) == 0._r8) then - fs_sphd = 0.929_r8 - else - fs_sphd = snw_fs_lcl(i) - endif - fs_hex = 0.788_r8 - if(snw_ar_lcl(i) == 0._r8) then - AR_tmp = 0.5_r8 - else - AR_tmp = snw_ar_lcl(i) - endif - g_ice_Cg_tmp = g_b0 * ((fs_sphd/fs_hex)**g_b1) * (diam_ice**g_b2) - gg_ice_F07_tmp = g_F07_c0 + g_F07_c1 * AR_tmp + g_F07_c2 * (AR_tmp**2) - elseif(snw_shp_lcl(i) == snow_shape_hexagonal_plate) then ! hexagonal plate - diam_ice = 2._r8*snw_rds_lcl(i) - if(snw_fs_lcl(i) == 0._r8) then - fs_hex0 = 0.788_r8 - else - fs_hex0 = snw_fs_lcl(i) - endif - fs_hex = 0.788_r8 - if(snw_ar_lcl(i) == 0._r8) then + ! Set local aerosol array + DO j=1,sno_nbr_aer + mss_cnc_aer_lcl(:,j) = mss_cnc_aer_in(:,j) + ENDDO + + ! Set spectral underlying surface albedos to their corresponding VIS or NIR albedos + albsfc_lcl(1) = albsfc(1) + albsfc_lcl(nir_bnd_bgn:nir_bnd_end) = albsfc(2) + + ! Error check for snow grain size: + IF (p_is_master) THEN + DO i=snl_top,snl_btm,1 + IF ((snw_rds_lcl(i) < snw_rds_min_tbl) .or. (snw_rds_lcl(i) > snw_rds_max_tbl)) THEN + write (iulog,*) "SNICAR ERROR: snow grain radius of ", snw_rds_lcl(i), " out of bounds." + write (iulog,*) "flg_snw_ice= ", flg_snw_ice + write (iulog,*) " level: ", i, " snl(c)= ", snl_lcl + write (iulog,*) "h2osno(c)= ", h2osno_lcl + CALL abort + ENDIF + ENDDO + ENDIF + + ! Incident flux weighting parameters + ! - sum of all VIS bands must equal 1 + ! - sum of all NIR bands must equal 1 + ! + ! Spectral bands (5-band CASE) + ! Band 1: 0.3-0.7um (VIS) + ! Band 2: 0.7-1.0um (NIR) + ! Band 3: 1.0-1.2um (NIR) + ! Band 4: 1.2-1.5um (NIR) + ! Band 5: 1.5-5.0um (NIR) + ! + ! The following weights are appropriate for surface-incident flux in a mid-latitude winter atmosphere + ! + ! 3-band weights + IF (numrad_snw==3) THEN + ! Direct: + IF (flg_slr_in == 1) THEN + flx_wgt(1) = 1._r8 + flx_wgt(2) = 0.66628670195247_r8 + flx_wgt(3) = 0.33371329804753_r8 + ! Diffuse: + elseif (flg_slr_in == 2) THEN + flx_wgt(1) = 1._r8 + flx_wgt(2) = 0.77887652162877_r8 + flx_wgt(3) = 0.22112347837123_r8 + ENDIF + + ! 5-band weights + elseif(numrad_snw==5) THEN + ! Direct: + IF (flg_slr_in == 1) THEN + IF (atm_type_index == atm_type_default) THEN + flx_wgt(1) = 1._r8 + flx_wgt(2) = 0.49352158521175_r8 + flx_wgt(3) = 0.18099494230665_r8 + flx_wgt(4) = 0.12094898498813_r8 + flx_wgt(5) = 0.20453448749347_r8 + ELSE + slr_zen = nint(acos(coszen) * 180._r8 / pi) + IF (slr_zen>89) THEN + slr_zen = 89 + ENDIF + flx_wgt(1) = 1._r8 + flx_wgt(2) = flx_wgt_dir(atm_type_index, slr_zen+1, 2) + flx_wgt(3) = flx_wgt_dir(atm_type_index, slr_zen+1, 3) + flx_wgt(4) = flx_wgt_dir(atm_type_index, slr_zen+1, 4) + flx_wgt(5) = flx_wgt_dir(atm_type_index, slr_zen+1, 5) + ENDIF + + ! Diffuse: + elseif (flg_slr_in == 2) THEN + IF (atm_type_index == atm_type_default) THEN + flx_wgt(1) = 1._r8 + flx_wgt(2) = 0.58581507618433_r8 + flx_wgt(3) = 0.20156903770812_r8 + flx_wgt(4) = 0.10917889346386_r8 + flx_wgt(5) = 0.10343699264369_r8 + ELSE + flx_wgt(1) = 1._r8 + flx_wgt(2) = flx_wgt_dif(atm_type_index, 2) + flx_wgt(3) = flx_wgt_dif(atm_type_index, 3) + flx_wgt(4) = flx_wgt_dif(atm_type_index, 4) + flx_wgt(5) = flx_wgt_dif(atm_type_index, 5) + ENDIF + ENDIF + ENDIF ! END IF numrad_snw + + ! Loop over snow spectral bands + + exp_min = exp(-argmax) + DO bnd_idx = 1,numrad_snw + + ! note that we can remove flg_dover since this algorithm is + ! stable for mu_not > 0.01 + + ! mu_not is cosine solar zenith angle above the fresnel level; make + ! sure mu_not is large enough for stable and meaningful radiation + ! solution: .01 is like sun just touching horizon with its lower edge + ! equivalent to mu0 in sea-ice shortwave model ice_shortwave.F90 + mu_not = max(coszen, cp01) + + + ! Set direct or diffuse incident irradiance to 1 + ! (This has to be within the bnd loop because mu_not is adjusted in rare cases) + IF (flg_slr_in == 1) THEN + flx_slrd_lcl(bnd_idx) = 1._r8/(mu_not*pi) ! this corresponds to incident irradiance of 1.0 + flx_slri_lcl(bnd_idx) = 0._r8 + ELSE + flx_slrd_lcl(bnd_idx) = 0._r8 + flx_slri_lcl(bnd_idx) = 1._r8 + ENDIF + + ! Pre-emptive error handling: aerosols can reap havoc on these absorptive bands. + ! Since extremely high soot concentrations have a negligible effect on these bands, zero them. + IF ( (numrad_snw == 5).and.((bnd_idx == 5).or.(bnd_idx == 4)) ) THEN + mss_cnc_aer_lcl(:,:) = 0._r8 + ENDIF + + IF ( (numrad_snw == 3).and.(bnd_idx == 3) ) THEN + mss_cnc_aer_lcl(:,:) = 0._r8 + ENDIF + + ! Define local Mie parameters based on snow grain size and aerosol species, + ! retrieved from a lookup table. + IF (flg_slr_in == 1) THEN + DO i=snl_top,snl_btm,1 + rds_idx = snw_rds_lcl(i) - snw_rds_min_tbl + 1 + ! snow optical properties (direct radiation) + ss_alb_snw_lcl(i) = ss_alb_snw_drc(rds_idx,bnd_idx) + asm_prm_snw_lcl(i) = asm_prm_snw_drc(rds_idx,bnd_idx) + ext_cff_mss_snw_lcl(i) = ext_cff_mss_snw_drc(rds_idx,bnd_idx) + ENDDO + elseif (flg_slr_in == 2) THEN + DO i=snl_top,snl_btm,1 + rds_idx = snw_rds_lcl(i) - snw_rds_min_tbl + 1 + ! snow optical properties (diffuse radiation) + ss_alb_snw_lcl(i) = ss_alb_snw_dfs(rds_idx,bnd_idx) + asm_prm_snw_lcl(i) = asm_prm_snw_dfs(rds_idx,bnd_idx) + ext_cff_mss_snw_lcl(i) = ext_cff_mss_snw_dfs(rds_idx,bnd_idx) + ENDDO + ENDIF + + ! Calculate the asymetry factors under different snow grain shapes + DO i=snl_top,snl_btm,1 + IF(snw_shp_lcl(i) == snow_shape_spheroid) THEN ! spheroid + diam_ice = 2._r8*snw_rds_lcl(i) + IF(snw_fs_lcl(i) == 0._r8) THEN + fs_sphd = 0.929_r8 + ELSE + fs_sphd = snw_fs_lcl(i) + ENDIF + fs_hex = 0.788_r8 + IF(snw_ar_lcl(i) == 0._r8) THEN + AR_tmp = 0.5_r8 + ELSE + AR_tmp = snw_ar_lcl(i) + ENDIF + g_ice_Cg_tmp = g_b0 * ((fs_sphd/fs_hex)**g_b1) * (diam_ice**g_b2) + gg_ice_F07_tmp = g_F07_c0 + g_F07_c1 * AR_tmp + g_F07_c2 * (AR_tmp**2) + elseif(snw_shp_lcl(i) == snow_shape_hexagonal_plate) THEN ! hexagonal plate + diam_ice = 2._r8*snw_rds_lcl(i) + IF(snw_fs_lcl(i) == 0._r8) THEN + fs_hex0 = 0.788_r8 + ELSE + fs_hex0 = snw_fs_lcl(i) + ENDIF + fs_hex = 0.788_r8 + IF(snw_ar_lcl(i) == 0._r8) THEN + AR_tmp = 2.5_r8 + ELSE + AR_tmp = snw_ar_lcl(i) + ENDIF + g_ice_Cg_tmp = g_b0 * ((fs_hex0/fs_hex)**g_b1) * (diam_ice**g_b2) + gg_ice_F07_tmp = g_F07_p0 + g_F07_p1 * log(AR_tmp) + g_F07_p2 * ((log(AR_tmp))**2) + elseif(snw_shp_lcl(i) == snow_shape_koch_snowflake) THEN ! Koch snowflake + diam_ice = 2._r8 * snw_rds_lcl(i) /0.544_r8 + IF(snw_fs_lcl(i) == 0._r8) THEN + fs_koch = 0.712_r8 + ELSE + fs_koch = snw_fs_lcl(i) + ENDIF + fs_hex = 0.788_r8 + IF(snw_ar_lcl(i) == 0._r8) THEN AR_tmp = 2.5_r8 - else + ELSE AR_tmp = snw_ar_lcl(i) - endif - g_ice_Cg_tmp = g_b0 * ((fs_hex0/fs_hex)**g_b1) * (diam_ice**g_b2) - gg_ice_F07_tmp = g_F07_p0 + g_F07_p1 * log(AR_tmp) + g_F07_p2 * ((log(AR_tmp))**2) - elseif(snw_shp_lcl(i) == snow_shape_koch_snowflake) then ! Koch snowflake - diam_ice = 2._r8 * snw_rds_lcl(i) /0.544_r8 - if(snw_fs_lcl(i) == 0._r8) then - fs_koch = 0.712_r8 - else - fs_koch = snw_fs_lcl(i) - endif - fs_hex = 0.788_r8 - if(snw_ar_lcl(i) == 0._r8) then - AR_tmp = 2.5_r8 - else - AR_tmp = snw_ar_lcl(i) - endif - g_ice_Cg_tmp = g_b0 * ((fs_koch/fs_hex)**g_b1) * (diam_ice**g_b2) - gg_ice_F07_tmp = g_F07_p0 + g_F07_p1 * log(AR_tmp) + g_F07_p2 * ((log(AR_tmp))**2) - endif - - ! Linear interpolation for calculating the asymetry factor at band_idx. - if(snw_shp_lcl(i) > 1) then - if(bnd_idx == 1) then - g_Cg_intp = (g_ice_Cg_tmp(2)-g_ice_Cg_tmp(1))/(1.055_r8-0.475_r8)*(0.5_r8-0.475_r8) +g_ice_Cg_tmp(1) - gg_F07_intp = (gg_ice_F07_tmp(2)-gg_ice_F07_tmp(1))/(1.055_r8-0.475_r8)*(0.5_r8-0.475_r8)+gg_ice_F07_tmp(1) - elseif(bnd_idx == 2) then - g_Cg_intp = (g_ice_Cg_tmp(2)-g_ice_Cg_tmp(1))/(1.055_r8-0.475_r8)*(0.85_r8-0.475_r8)+g_ice_Cg_tmp(1) - gg_F07_intp = (gg_ice_F07_tmp(2)-gg_ice_F07_tmp(1))/(1.055_r8-0.475_r8)*(0.85_r8-0.475_r8)+gg_ice_F07_tmp(1) - elseif(bnd_idx == 3) then - g_Cg_intp = (g_ice_Cg_tmp(3)-g_ice_Cg_tmp(2))/(1.655_r8-1.055_r8)*(1.1_r8-1.055_r8)& - +g_ice_Cg_tmp(2) - gg_F07_intp = (gg_ice_F07_tmp(3)-gg_ice_F07_tmp(2))/(1.655_r8-1.055_r8)*(1.1_r8-1.055_r8)& - +gg_ice_F07_tmp(2) - elseif(bnd_idx == 4) then - g_Cg_intp = (g_ice_Cg_tmp(3)-g_ice_Cg_tmp(2))/(1.655_r8-1.055_r8)*(1.35_r8-1.055_r8)& - +g_ice_Cg_tmp(2) - gg_F07_intp = (gg_ice_F07_tmp(3)-gg_ice_F07_tmp(2))/(1.655_r8-1.055_r8)*(1.35_r8-1.055_r8)& - +gg_ice_F07_tmp(2) - elseif(bnd_idx == 5) then - g_Cg_intp = (g_ice_Cg_tmp(6)-g_ice_Cg_tmp(5))/(3.75_r8-3.0_r8)*(3.25_r8-3.0_r8)& - +g_ice_Cg_tmp(5) - gg_F07_intp = (gg_ice_F07_tmp(6)-gg_ice_F07_tmp(5))/(3.75_r8-3.0_r8)*(3.25_r8-3.0_r8)& - +gg_ice_F07_tmp(5) - endif - g_ice_F07 = gg_F07_intp + (1._r8 - gg_F07_intp) / ss_alb_snw_lcl(i) / 2._r8 - g_ice = g_ice_F07 * g_Cg_intp - asm_prm_snw_lcl(i) = g_ice - endif - - if(asm_prm_snw_lcl(i) > 0.99_r8) then - asm_prm_snw_lcl(i) = 0.99_r8 - endif - - enddo - !!!-end + ENDIF + g_ice_Cg_tmp = g_b0 * ((fs_koch/fs_hex)**g_b1) * (diam_ice**g_b2) + gg_ice_F07_tmp = g_F07_p0 + g_F07_p1 * log(AR_tmp) + g_F07_p2 * ((log(AR_tmp))**2) + ENDIF + + ! Linear interpolation for calculating the asymetry factor at band_idx. + IF(snw_shp_lcl(i) > 1) THEN + IF(bnd_idx == 1) THEN + g_Cg_intp = (g_ice_Cg_tmp(2)-g_ice_Cg_tmp(1))/(1.055_r8-0.475_r8)*(0.5_r8-0.475_r8) +g_ice_Cg_tmp(1) + gg_F07_intp = (gg_ice_F07_tmp(2)-gg_ice_F07_tmp(1))/(1.055_r8-0.475_r8)*(0.5_r8-0.475_r8)+gg_ice_F07_tmp(1) + elseif(bnd_idx == 2) THEN + g_Cg_intp = (g_ice_Cg_tmp(2)-g_ice_Cg_tmp(1))/(1.055_r8-0.475_r8)*(0.85_r8-0.475_r8)+g_ice_Cg_tmp(1) + gg_F07_intp = (gg_ice_F07_tmp(2)-gg_ice_F07_tmp(1))/(1.055_r8-0.475_r8)*(0.85_r8-0.475_r8)+gg_ice_F07_tmp(1) + elseif(bnd_idx == 3) THEN + g_Cg_intp = (g_ice_Cg_tmp(3)-g_ice_Cg_tmp(2))/(1.655_r8-1.055_r8)*(1.1_r8-1.055_r8)& + +g_ice_Cg_tmp(2) + gg_F07_intp = (gg_ice_F07_tmp(3)-gg_ice_F07_tmp(2))/(1.655_r8-1.055_r8)*(1.1_r8-1.055_r8)& + +gg_ice_F07_tmp(2) + elseif(bnd_idx == 4) THEN + g_Cg_intp = (g_ice_Cg_tmp(3)-g_ice_Cg_tmp(2))/(1.655_r8-1.055_r8)*(1.35_r8-1.055_r8)& + +g_ice_Cg_tmp(2) + gg_F07_intp = (gg_ice_F07_tmp(3)-gg_ice_F07_tmp(2))/(1.655_r8-1.055_r8)*(1.35_r8-1.055_r8)& + +gg_ice_F07_tmp(2) + elseif(bnd_idx == 5) THEN + g_Cg_intp = (g_ice_Cg_tmp(6)-g_ice_Cg_tmp(5))/(3.75_r8-3.0_r8)*(3.25_r8-3.0_r8)& + +g_ice_Cg_tmp(5) + gg_F07_intp = (gg_ice_F07_tmp(6)-gg_ice_F07_tmp(5))/(3.75_r8-3.0_r8)*(3.25_r8-3.0_r8)& + +gg_ice_F07_tmp(5) + ENDIF + g_ice_F07 = gg_F07_intp + (1._r8 - gg_F07_intp) / ss_alb_snw_lcl(i) / 2._r8 + g_ice = g_ice_F07 * g_Cg_intp + asm_prm_snw_lcl(i) = g_ice + ENDIF + + IF(asm_prm_snw_lcl(i) > 0.99_r8) THEN + asm_prm_snw_lcl(i) = 0.99_r8 + ENDIF + + ENDDO + !!!-END !H. Wang - ! aerosol species 1 optical properties - ! ss_alb_aer_lcl(1) = ss_alb_bc1(bnd_idx) - ! asm_prm_aer_lcl(1) = asm_prm_bc1(bnd_idx) - ! ext_cff_mss_aer_lcl(1) = ext_cff_mss_bc1(bnd_idx) - - ! aerosol species 2 optical properties - ! ss_alb_aer_lcl(2) = ss_alb_bc2(bnd_idx) - ! asm_prm_aer_lcl(2) = asm_prm_bc2(bnd_idx) - ! ext_cff_mss_aer_lcl(2) = ext_cff_mss_bc2(bnd_idx) + ! aerosol species 1 optical properties + ! ss_alb_aer_lcl(1) = ss_alb_bc1(bnd_idx) + ! asm_prm_aer_lcl(1) = asm_prm_bc1(bnd_idx) + ! ext_cff_mss_aer_lcl(1) = ext_cff_mss_bc1(bnd_idx) + + ! aerosol species 2 optical properties + ! ss_alb_aer_lcl(2) = ss_alb_bc2(bnd_idx) + ! asm_prm_aer_lcl(2) = asm_prm_bc2(bnd_idx) + ! ext_cff_mss_aer_lcl(2) = ext_cff_mss_bc2(bnd_idx) !H. Wang - ! aerosol species 3 optical properties - ss_alb_aer_lcl(3) = ss_alb_oc1(bnd_idx) - asm_prm_aer_lcl(3) = asm_prm_oc1(bnd_idx) - ext_cff_mss_aer_lcl(3) = ext_cff_mss_oc1(bnd_idx) - - ! aerosol species 4 optical properties - ss_alb_aer_lcl(4) = ss_alb_oc2(bnd_idx) - asm_prm_aer_lcl(4) = asm_prm_oc2(bnd_idx) - ext_cff_mss_aer_lcl(4) = ext_cff_mss_oc2(bnd_idx) - - ! aerosol species 5 optical properties - ss_alb_aer_lcl(5) = ss_alb_dst1(bnd_idx) - asm_prm_aer_lcl(5) = asm_prm_dst1(bnd_idx) - ext_cff_mss_aer_lcl(5) = ext_cff_mss_dst1(bnd_idx) - - ! aerosol species 6 optical properties - ss_alb_aer_lcl(6) = ss_alb_dst2(bnd_idx) - asm_prm_aer_lcl(6) = asm_prm_dst2(bnd_idx) - ext_cff_mss_aer_lcl(6) = ext_cff_mss_dst2(bnd_idx) - - ! aerosol species 7 optical properties - ss_alb_aer_lcl(7) = ss_alb_dst3(bnd_idx) - asm_prm_aer_lcl(7) = asm_prm_dst3(bnd_idx) - ext_cff_mss_aer_lcl(7) = ext_cff_mss_dst3(bnd_idx) - - ! aerosol species 8 optical properties - ss_alb_aer_lcl(8) = ss_alb_dst4(bnd_idx) - asm_prm_aer_lcl(8) = asm_prm_dst4(bnd_idx) - ext_cff_mss_aer_lcl(8) = ext_cff_mss_dst4(bnd_idx) - - - ! 1. snow and aerosol layer column mass (L_snw, L_aer [kg/m^2]) - ! 2. optical Depths (tau_snw, tau_aer) - ! 3. weighted Mie properties (tau, omega, g) - - ! Weighted Mie parameters of each layer - do i=snl_top,snl_btm,1 + ! aerosol species 3 optical properties + ss_alb_aer_lcl(3) = ss_alb_oc1(bnd_idx) + asm_prm_aer_lcl(3) = asm_prm_oc1(bnd_idx) + ext_cff_mss_aer_lcl(3) = ext_cff_mss_oc1(bnd_idx) + + ! aerosol species 4 optical properties + ss_alb_aer_lcl(4) = ss_alb_oc2(bnd_idx) + asm_prm_aer_lcl(4) = asm_prm_oc2(bnd_idx) + ext_cff_mss_aer_lcl(4) = ext_cff_mss_oc2(bnd_idx) + + ! aerosol species 5 optical properties + ss_alb_aer_lcl(5) = ss_alb_dst1(bnd_idx) + asm_prm_aer_lcl(5) = asm_prm_dst1(bnd_idx) + ext_cff_mss_aer_lcl(5) = ext_cff_mss_dst1(bnd_idx) + + ! aerosol species 6 optical properties + ss_alb_aer_lcl(6) = ss_alb_dst2(bnd_idx) + asm_prm_aer_lcl(6) = asm_prm_dst2(bnd_idx) + ext_cff_mss_aer_lcl(6) = ext_cff_mss_dst2(bnd_idx) + + ! aerosol species 7 optical properties + ss_alb_aer_lcl(7) = ss_alb_dst3(bnd_idx) + asm_prm_aer_lcl(7) = asm_prm_dst3(bnd_idx) + ext_cff_mss_aer_lcl(7) = ext_cff_mss_dst3(bnd_idx) + + ! aerosol species 8 optical properties + ss_alb_aer_lcl(8) = ss_alb_dst4(bnd_idx) + asm_prm_aer_lcl(8) = asm_prm_dst4(bnd_idx) + ext_cff_mss_aer_lcl(8) = ext_cff_mss_dst4(bnd_idx) + + + ! 1. snow and aerosol layer column mass (L_snw, L_aer [kg/m^2]) + ! 2. optical Depths (tau_snw, tau_aer) + ! 3. weighted Mie properties (tau, omega, g) + + ! Weighted Mie parameters of each layer + DO i=snl_top,snl_btm,1 #ifdef MODAL_AER - !mgf++ within-ice and external BC optical properties - ! - ! Lookup table indices for BC optical properties, - ! dependent on snow grain size and BC particle - ! size. - - ! valid for 25 < snw_rds < 1625 um: - if (snw_rds_lcl(i) < 125) then - tmp1 = snw_rds_lcl(i)/50 - idx_bcint_icerds = nint(tmp1) - elseif (snw_rds_lcl(i) < 175) then - idx_bcint_icerds = 2 - else - tmp1 = (snw_rds_lcl(i)/250)+2 - idx_bcint_icerds = nint(tmp1) - endif - - ! valid for 25 < bc_rds < 525 nm - idx_bcint_nclrds = nint(rds_bcint_lcl(i)/50) - idx_bcext_nclrds = nint(rds_bcext_lcl(i)/50) - - ! check bounds: - if (idx_bcint_icerds < idx_bcint_icerds_min) idx_bcint_icerds = idx_bcint_icerds_min - if (idx_bcint_icerds > idx_bcint_icerds_max) idx_bcint_icerds = idx_bcint_icerds_max - if (idx_bcint_nclrds < idx_bc_nclrds_min) idx_bcint_nclrds = idx_bc_nclrds_min - if (idx_bcint_nclrds > idx_bc_nclrds_max) idx_bcint_nclrds = idx_bc_nclrds_max - if (idx_bcext_nclrds < idx_bc_nclrds_min) idx_bcext_nclrds = idx_bc_nclrds_min - if (idx_bcext_nclrds > idx_bc_nclrds_max) idx_bcext_nclrds = idx_bc_nclrds_max - - ! retrieve absorption enhancement factor for within-ice BC - enh_fct = bcenh(bnd_idx,idx_bcint_nclrds,idx_bcint_icerds) - - ! get BC optical properties (moved from above) - ! aerosol species 1 optical properties (within-ice BC) - ss_alb_aer_lcl(1) = ss_alb_bc1(bnd_idx,idx_bcint_nclrds) - asm_prm_aer_lcl(1) = asm_prm_bc1(bnd_idx,idx_bcint_nclrds) - ext_cff_mss_aer_lcl(1) = ext_cff_mss_bc1(bnd_idx,idx_bcint_nclrds)*enh_fct - - ! aerosol species 2 optical properties (external BC) - ss_alb_aer_lcl(2) = ss_alb_bc2(bnd_idx,idx_bcext_nclrds) - asm_prm_aer_lcl(2) = asm_prm_bc2(bnd_idx,idx_bcext_nclrds) - ext_cff_mss_aer_lcl(2) = ext_cff_mss_bc2(bnd_idx,idx_bcext_nclrds) + !mgf++ within-ice and external BC optical properties + ! + ! Lookup table indices for BC optical properties, + ! dependent on snow grain size and BC particle + ! size. + + ! valid for 25 < snw_rds < 1625 um: + IF (snw_rds_lcl(i) < 125) THEN + tmp1 = snw_rds_lcl(i)/50 + idx_bcint_icerds = nint(tmp1) + elseif (snw_rds_lcl(i) < 175) THEN + idx_bcint_icerds = 2 + ELSE + tmp1 = (snw_rds_lcl(i)/250)+2 + idx_bcint_icerds = nint(tmp1) + ENDIF + + ! valid for 25 < bc_rds < 525 nm + idx_bcint_nclrds = nint(rds_bcint_lcl(i)/50) + idx_bcext_nclrds = nint(rds_bcext_lcl(i)/50) + + ! check bounds: + IF (idx_bcint_icerds < idx_bcint_icerds_min) idx_bcint_icerds = idx_bcint_icerds_min + IF (idx_bcint_icerds > idx_bcint_icerds_max) idx_bcint_icerds = idx_bcint_icerds_max + IF (idx_bcint_nclrds < idx_bc_nclrds_min) idx_bcint_nclrds = idx_bc_nclrds_min + IF (idx_bcint_nclrds > idx_bc_nclrds_max) idx_bcint_nclrds = idx_bc_nclrds_max + IF (idx_bcext_nclrds < idx_bc_nclrds_min) idx_bcext_nclrds = idx_bc_nclrds_min + IF (idx_bcext_nclrds > idx_bc_nclrds_max) idx_bcext_nclrds = idx_bc_nclrds_max + + ! retrieve absorption enhancement factor for within-ice BC + enh_fct = bcenh(bnd_idx,idx_bcint_nclrds,idx_bcint_icerds) + + ! get BC optical properties (moved from above) + ! aerosol species 1 optical properties (within-ice BC) + ss_alb_aer_lcl(1) = ss_alb_bc1(bnd_idx,idx_bcint_nclrds) + asm_prm_aer_lcl(1) = asm_prm_bc1(bnd_idx,idx_bcint_nclrds) + ext_cff_mss_aer_lcl(1) = ext_cff_mss_bc1(bnd_idx,idx_bcint_nclrds)*enh_fct + + ! aerosol species 2 optical properties (external BC) + ss_alb_aer_lcl(2) = ss_alb_bc2(bnd_idx,idx_bcext_nclrds) + asm_prm_aer_lcl(2) = asm_prm_bc2(bnd_idx,idx_bcext_nclrds) + ext_cff_mss_aer_lcl(2) = ext_cff_mss_bc2(bnd_idx,idx_bcext_nclrds) #else - ! bulk aerosol treatment (BC optical properties independent - ! of BC and ice grain size) - ! aerosol species 1 optical properties (within-ice BC) - ss_alb_aer_lcl(1) = ss_alb_bc1(bnd_idx) - asm_prm_aer_lcl(1) = asm_prm_bc1(bnd_idx) - ext_cff_mss_aer_lcl(1) = ext_cff_mss_bc1(bnd_idx) - - ! aerosol species 2 optical properties - ss_alb_aer_lcl(2) = ss_alb_bc2(bnd_idx) - asm_prm_aer_lcl(2) = asm_prm_bc2(bnd_idx) - ext_cff_mss_aer_lcl(2) = ext_cff_mss_bc2(bnd_idx) + ! bulk aerosol treatment (BC optical properties independent + ! of BC and ice grain size) + ! aerosol species 1 optical properties (within-ice BC) + ss_alb_aer_lcl(1) = ss_alb_bc1(bnd_idx) + asm_prm_aer_lcl(1) = asm_prm_bc1(bnd_idx) + ext_cff_mss_aer_lcl(1) = ext_cff_mss_bc1(bnd_idx) + + ! aerosol species 2 optical properties + ss_alb_aer_lcl(2) = ss_alb_bc2(bnd_idx) + asm_prm_aer_lcl(2) = asm_prm_bc2(bnd_idx) + ext_cff_mss_aer_lcl(2) = ext_cff_mss_bc2(bnd_idx) #endif - ! Calculate single-scattering albedo for internal mixing of dust-snow - if (use_dust_snow_internal_mixing) then - if (bnd_idx < 4) then - C_dust_total = mss_cnc_aer_lcl(i,5) + mss_cnc_aer_lcl(i,6) & - + mss_cnc_aer_lcl(i,7) + mss_cnc_aer_lcl(i,8) - C_dust_total = C_dust_total * 1.0E+06_r8 - if(C_dust_total > 0._r8) then - if (flg_slr_in == 1) then - R_1_omega_tmp = dust_clear_d0(bnd_idx) & - + dust_clear_d2(bnd_idx)*(C_dust_total**dust_clear_d1(bnd_idx)) - else - R_1_omega_tmp = dust_cloudy_d0(bnd_idx) & - + dust_cloudy_d2(bnd_idx)*(C_dust_total**dust_cloudy_d1(bnd_idx)) - endif - ss_alb_snw_lcl(i) = 1.0_r8 - (1.0_r8 - ss_alb_snw_lcl(i)) *R_1_omega_tmp - endif - endif - do j = 5,8,1 - ss_alb_aer_lcl(j) = 0._r8 - asm_prm_aer_lcl(j) = 0._r8 - ext_cff_mss_aer_lcl(j) = 0._r8 - enddo - endif - - !mgf-- - - L_snw(i) = h2osno_ice_lcl(i)+h2osno_liq_lcl(i) - tau_snw(i) = L_snw(i)*ext_cff_mss_snw_lcl(i) - - do j=1,sno_nbr_aer - if (use_dust_snow_internal_mixing .and. (j >= 5)) then - L_aer(i,j) = 0._r8 - else - L_aer(i,j) = L_snw(i)*mss_cnc_aer_lcl(i,j) - endif - tau_aer(i,j) = L_aer(i,j)*ext_cff_mss_aer_lcl(j) - enddo - - tau_sum = 0._r8 - omega_sum = 0._r8 - g_sum = 0._r8 - - do j=1,sno_nbr_aer - tau_sum = tau_sum + tau_aer(i,j) - omega_sum = omega_sum + (tau_aer(i,j)*ss_alb_aer_lcl(j)) - g_sum = g_sum + (tau_aer(i,j)*ss_alb_aer_lcl(j)*asm_prm_aer_lcl(j)) - enddo - - tau(i) = tau_sum + tau_snw(i) - omega(i) = (1/tau(i))*(omega_sum+(ss_alb_snw_lcl(i)*tau_snw(i))) - g(i) = (1/(tau(i)*omega(i)))*(g_sum+ (asm_prm_snw_lcl(i)*ss_alb_snw_lcl(i)*tau_snw(i))) - enddo ! endWeighted Mie parameters of each layer - - ! DELTA transformations, if requested - if (DELTA == 1) then - do i=snl_top,snl_btm,1 - g_star(i) = g(i)/(1+g(i)) - omega_star(i) = ((1-(g(i)**2))*omega(i)) / (1-(omega(i)*(g(i)**2))) - tau_star(i) = (1-(omega(i)*(g(i)**2)))*tau(i) - enddo - else - do i=snl_top,snl_btm,1 - g_star(i) = g(i) - omega_star(i) = omega(i) - tau_star(i) = tau(i) - enddo - endif - - ! Begin radiative transfer solver - ! Given input vertical profiles of optical properties, evaluate the - ! monochromatic Delta-Eddington adding-doubling solution - - ! note that trndir, trntdr, trndif, rupdir, rupdif, rdndif - ! are variables at the layer interface, - ! for snow with layers rangeing from snl_top to snl_btm - ! there are snl_top to snl_btm+1 layer interface - snl_btm_itf = snl_btm + 1 - - do i = snl_top,snl_btm_itf,1 - trndir(i) = c0 - trntdr(i) = c0 - trndif(i) = c0 - rupdir(i) = c0 - rupdif(i) = c0 - rdndif(i) = c0 - enddo - - ! initialize top interface of top layer - trndir(snl_top) = c1 - trntdr(snl_top) = c1 - trndif(snl_top) = c1 - rdndif(snl_top) = c0 - - ! begin main level loop - ! for layer interfaces except for the very bottom - do i = snl_top,snl_btm,1 - - ! initialize all layer apparent optical properties to 0 - rdir (i) = c0 - rdif_a(i) = c0 - rdif_b(i) = c0 - tdir (i) = c0 - tdif_a(i) = c0 - tdif_b(i) = c0 - trnlay(i) = c0 - - ! compute next layer Delta-eddington solution only if total transmission - ! of radiation to the interface just above the layer exceeds trmin. - - if (trntdr(i) > trmin ) then - - ! calculation over layers with penetrating radiation - - ! delta-transformed single-scattering properties - ! of this layer - ts = tau_star(i) - ws = omega_star(i) - gs = g_star(i) - - ! Delta-Eddington solution expressions - ! n(uu,et) = ((uu+c1)*(uu+c1)/et ) - ((uu-c1)*(uu-c1)*et) - ! u(w,gg,e) = c1p5*(c1 - w*gg)/e - ! el(w,gg) = sqrt(c3*(c1-w)*(c1 - w*gg)) - lm = sqrt(c3*(c1-ws)*(c1 - ws*gs)) !lm = el(ws,gs) - ue = c1p5*(c1 - ws*gs)/lm !ue = u(ws,gs,lm) - extins = max(exp_min, exp(-lm*ts)) - ne = ((ue+c1)*(ue+c1)/extins) - ((ue-c1)*(ue-c1)*extins) !ne = n(ue,extins) - - ! first calculation of rdif, tdif using Delta-Eddington formulas - ! rdif_a(k) = (ue+c1)*(ue-c1)*(c1/extins - extins)/ne - rdif_a(i) = (ue**2-c1)*(c1/extins - extins)/ne - tdif_a(i) = c4*ue/ne - - ! evaluate rdir,tdir for direct beam - trnlay(i) = max(exp_min, exp(-ts/mu_not)) - - ! Delta-Eddington solution expressions - ! alpha(w,uu,gg,e) = p75*w*uu*((c1 + gg*(c1-w))/(c1 - e*e*uu*uu)) - ! agamm(w,uu,gg,e) = p5*w*((c1 + c3*gg*(c1-w)*uu*uu)/(c1-e*e*uu*uu)) - ! alp = alpha(ws,mu_not,gs,lm) - ! gam = agamm(ws,mu_not,gs,lm) - alp = cp75*ws*mu_not*((c1 + gs*(c1-ws))/(c1 - lm*lm*mu_not*mu_not)) - gam = cp5*ws*((c1 + c3*gs*(c1-ws)*mu_not*mu_not)/(c1-lm*lm*mu_not*mu_not)) - apg = alp + gam - amg = alp - gam - - rdir(i) = apg*rdif_a(i) + amg*(tdif_a(i)*trnlay(i) - c1) - tdir(i) = apg*tdif_a(i) + (amg* rdif_a(i)-apg+c1)*trnlay(i) - - ! recalculate rdif,tdif using direct angular integration over rdir,tdir, - ! since Delta-Eddington rdif formula is not well-behaved (it is usually - ! biased low and can even be negative); use ngmax angles and gaussian - ! integration for most accuracy: - R1 = rdif_a(i) ! use R1 as temporary - T1 = tdif_a(i) ! use T1 as temporary - swt = c0 - smr = c0 - smt = c0 - do ng=1,ngmax - mu = difgauspt(ng) - gwt = difgauswt(ng) - swt = swt + mu*gwt - trn = max(exp_min, exp(-ts/mu)) - ! alp = alpha(ws,mu,gs,lm) - ! gam = agamm(ws,mu,gs,lm) - alp = cp75*ws*mu*((c1 + gs*(c1-ws))/(c1 - lm*lm*mu*mu)) - gam = cp5*ws*((c1 + c3*gs*(c1-ws)*mu*mu)/(c1-lm*lm*mu*mu)) - apg = alp + gam - amg = alp - gam - rdr = apg*R1 + amg*T1*trn - amg - tdr = apg*T1 + amg*R1*trn - apg*trn + trn - smr = smr + mu*rdr*gwt - smt = smt + mu*tdr*gwt - enddo ! ng - rdif_a(i) = smr/swt - tdif_a(i) = smt/swt - - ! homogeneous layer - rdif_b(i) = rdif_a(i) - tdif_b(i) = tdif_a(i) - - endif ! trntdr(k) > trmin - - ! Calculate the solar beam transmission, total transmission, and - ! reflectivity for diffuse radiation from below at interface i, - ! the top of the current layer k: - ! - ! layers interface - ! - ! --------------------- i-1 - ! i-1 - ! --------------------- i - ! i - ! --------------------- - - trndir(i+1) = trndir(i)*trnlay(i) - refkm1 = c1/(c1 - rdndif(i)*rdif_a(i)) - tdrrdir = trndir(i)*rdir(i) - tdndif = trntdr(i) - trndir(i) - trntdr(i+1) = trndir(i)*tdir(i) + & - (tdndif + tdrrdir*rdndif(i))*refkm1*tdif_a(i) - rdndif(i+1) = rdif_b(i) + & - (tdif_b(i)*rdndif(i)*refkm1*tdif_a(i)) - trndif(i+1) = trndif(i)*refkm1*tdif_a(i) - - enddo ! end main level loop - - - ! compute reflectivity to direct and diffuse radiation for layers - ! below by adding succesive layers starting from the underlying - ! ground and working upwards: - ! - ! layers interface - ! - ! --------------------- i - ! i - ! --------------------- i+1 - ! i+1 - ! --------------------- - - ! set the underlying ground albedo == albedo of near-IR - ! unless bnd_idx == 1, for visible - rupdir(snl_btm_itf) = albsfc(2) - rupdif(snl_btm_itf) = albsfc(2) - if (bnd_idx == 1) then - rupdir(snl_btm_itf) = albsfc(1) - rupdif(snl_btm_itf) = albsfc(1) - endif - - do i=snl_btm,snl_top,-1 - ! interface scattering - refkp1 = c1/( c1 - rdif_b(i)*rupdif(i+1)) - ! dir from top layer plus exp tran ref from lower layer, interface - ! scattered and tran thru top layer from below, plus diff tran ref - ! from lower layer with interface scattering tran thru top from below - rupdir(i) = rdir(i) & - + ( trnlay(i) *rupdir(i+1) & - + (tdir(i)-trnlay(i))*rupdif(i+1))*refkp1*tdif_b(i) - ! dif from top layer from above, plus dif tran upwards reflected and - ! interface scattered which tran top from below - rupdif(i) = rdif_a(i) + tdif_a(i)*rupdif(i+1)*refkp1*tdif_b(i) - enddo ! i - - ! net flux (down-up) at each layer interface from the - ! snow top (i = snl_top) to bottom interface above land (i = snl_btm_itf) - ! the interface reflectivities and transmissivities required - ! to evaluate interface fluxes are returned from solution_dEdd; - ! now compute up and down fluxes for each interface, using the - ! combined layer properties at each interface: - ! - ! layers interface - ! - ! --------------------- i - ! i - ! --------------------- - - do i = snl_top, snl_btm_itf - ! interface scattering - refk = c1/(c1 - rdndif(i)*rupdif(i)) - ! dir tran ref from below times interface scattering, plus diff - ! tran and ref from below times interface scattering - ! fdirup(i) = (trndir(i)*rupdir(i) + & - ! (trntdr(i)-trndir(i)) & - ! *rupdif(i))*refk - ! dir tran plus total diff trans times interface scattering plus - ! dir tran with up dir ref and down dif ref times interface scattering - ! fdirdn(i) = trndir(i) + (trntdr(i) & - ! - trndir(i) + trndir(i) & - ! *rupdir(i)*rdndif(i))*refk - ! diffuse tran ref from below times interface scattering - ! fdifup(i) = trndif(i)*rupdif(i)*refk - ! diffuse tran times interface scattering - ! fdifdn(i) = trndif(i)*refk - - ! netflux, down - up - ! dfdir = fdirdn - fdirup - dfdir(i) = trndir(i) & - + (trntdr(i)-trndir(i)) * (c1 - rupdif(i)) * refk & - - trndir(i)*rupdir(i) * (c1 - rdndif(i)) * refk - if (dfdir(i) < puny) dfdir(i) = c0 - ! dfdif = fdifdn - fdifup - dfdif(i) = trndif(i) * (c1 - rupdif(i)) * refk - if (dfdif(i) < puny) dfdif(i) = c0 - enddo ! k - - ! SNICAR_AD_RT is called twice for direct and diffuse incident fluxes - ! direct incident - if (flg_slr_in == 1) then - albedo = rupdir(snl_top) - dftmp = dfdir - refk = c1/(c1 - rdndif(snl_top)*rupdif(snl_top)) - F_sfc_pls = (trndir(snl_top)*rupdir(snl_top) + & - (trntdr(snl_top)-trndir(snl_top)) & - *rupdif(snl_top))*refk - !diffuse incident - else - albedo = rupdif(snl_top) - dftmp = dfdif - refk = c1/(c1 - rdndif(snl_top)*rupdif(snl_top)) - F_sfc_pls = trndif(snl_top)*rupdif(snl_top)*refk - endif - - ! Absorbed flux in each layer - do i=snl_top,snl_btm,1 - F_abs(i) = dftmp(i)-dftmp(i+1) - flx_abs_lcl(i,bnd_idx) = F_abs(i) - - ! ERROR check: negative absorption - IF (p_is_master) THEN - if (flx_abs_lcl(i,bnd_idx) < -0.00001) then - write (iulog,"(a,e13.6,a,i6)") "SNICAR ERROR: negative absoption : ", flx_abs_lcl(i,bnd_idx) - write(iulog,*) "SNICAR_AD STATS: snw_rds(0)= ", snw_rds(0) - write(iulog,*) "SNICAR_AD STATS: L_snw(0)= ", L_snw(0) - write(iulog,*) "SNICAR_AD STATS: h2osno= ", h2osno_lcl, " snl= ", snl_lcl - write(iulog,*) "SNICAR_AD STATS: soot1(0)= ", mss_cnc_aer_lcl(0,1) - write(iulog,*) "SNICAR_AD STATS: soot2(0)= ", mss_cnc_aer_lcl(0,2) - write(iulog,*) "SNICAR_AD STATS: dust1(0)= ", mss_cnc_aer_lcl(0,3) - write(iulog,*) "SNICAR_AD STATS: dust2(0)= ", mss_cnc_aer_lcl(0,4) - write(iulog,*) "SNICAR_AD STATS: dust3(0)= ", mss_cnc_aer_lcl(0,5) - write(iulog,*) "SNICAR_AD STATS: dust4(0)= ", mss_cnc_aer_lcl(0,6) - call abort - endif + ! Calculate single-scattering albedo for internal mixing of dust-snow + IF (use_dust_snow_internal_mixing) THEN + IF (bnd_idx < 4) THEN + C_dust_total = mss_cnc_aer_lcl(i,5) + mss_cnc_aer_lcl(i,6) & + + mss_cnc_aer_lcl(i,7) + mss_cnc_aer_lcl(i,8) + C_dust_total = C_dust_total * 1.0E+06_r8 + IF(C_dust_total > 0._r8) THEN + IF (flg_slr_in == 1) THEN + R_1_omega_tmp = dust_clear_d0(bnd_idx) & + + dust_clear_d2(bnd_idx)*(C_dust_total**dust_clear_d1(bnd_idx)) + ELSE + R_1_omega_tmp = dust_cloudy_d0(bnd_idx) & + + dust_cloudy_d2(bnd_idx)*(C_dust_total**dust_cloudy_d1(bnd_idx)) + ENDIF + ss_alb_snw_lcl(i) = 1.0_r8 - (1.0_r8 - ss_alb_snw_lcl(i)) *R_1_omega_tmp + ENDIF + ENDIF + DO j = 5,8,1 + ss_alb_aer_lcl(j) = 0._r8 + asm_prm_aer_lcl(j) = 0._r8 + ext_cff_mss_aer_lcl(j) = 0._r8 + ENDDO + ENDIF + + !mgf-- + + L_snw(i) = h2osno_ice_lcl(i)+h2osno_liq_lcl(i) + tau_snw(i) = L_snw(i)*ext_cff_mss_snw_lcl(i) + + DO j=1,sno_nbr_aer + IF (use_dust_snow_internal_mixing .and. (j >= 5)) THEN + L_aer(i,j) = 0._r8 + ELSE + L_aer(i,j) = L_snw(i)*mss_cnc_aer_lcl(i,j) + ENDIF + tau_aer(i,j) = L_aer(i,j)*ext_cff_mss_aer_lcl(j) + ENDDO + + tau_sum = 0._r8 + omega_sum = 0._r8 + g_sum = 0._r8 + + DO j=1,sno_nbr_aer + tau_sum = tau_sum + tau_aer(i,j) + omega_sum = omega_sum + (tau_aer(i,j)*ss_alb_aer_lcl(j)) + g_sum = g_sum + (tau_aer(i,j)*ss_alb_aer_lcl(j)*asm_prm_aer_lcl(j)) + ENDDO + + tau(i) = tau_sum + tau_snw(i) + omega(i) = (1/tau(i))*(omega_sum+(ss_alb_snw_lcl(i)*tau_snw(i))) + g(i) = (1/(tau(i)*omega(i)))*(g_sum+ (asm_prm_snw_lcl(i)*ss_alb_snw_lcl(i)*tau_snw(i))) + ENDDO ! endWeighted Mie parameters of each layer + + ! DELTA transformations, IF requested + IF (DELTA == 1) THEN + DO i=snl_top,snl_btm,1 + g_star(i) = g(i)/(1+g(i)) + omega_star(i) = ((1-(g(i)**2))*omega(i)) / (1-(omega(i)*(g(i)**2))) + tau_star(i) = (1-(omega(i)*(g(i)**2)))*tau(i) + ENDDO + ELSE + DO i=snl_top,snl_btm,1 + g_star(i) = g(i) + omega_star(i) = omega(i) + tau_star(i) = tau(i) + ENDDO + ENDIF + + ! Begin radiative transfer solver + ! Given input vertical profiles of optical properties, evaluate the + ! monochromatic Delta-Eddington adding-doubling solution + + ! note that trndir, trntdr, trndif, rupdir, rupdif, rdndif + ! are variables at the layer interface, + ! for snow with layers rangeing from snl_top to snl_btm + ! there are snl_top to snl_btm+1 layer interface + snl_btm_itf = snl_btm + 1 + + DO i = snl_top,snl_btm_itf,1 + trndir(i) = c0 + trntdr(i) = c0 + trndif(i) = c0 + rupdir(i) = c0 + rupdif(i) = c0 + rdndif(i) = c0 + ENDDO + + ! initialize top interface of top layer + trndir(snl_top) = c1 + trntdr(snl_top) = c1 + trndif(snl_top) = c1 + rdndif(snl_top) = c0 + + ! begin main level loop + ! for layer interfaces except for the very bottom + DO i = snl_top,snl_btm,1 + + ! initialize all layer apparent optical properties to 0 + rdir (i) = c0 + rdif_a(i) = c0 + rdif_b(i) = c0 + tdir (i) = c0 + tdif_a(i) = c0 + tdif_b(i) = c0 + trnlay(i) = c0 + + ! compute next layer Delta-eddington solution only IF total transmission + ! of radiation to the interface just above the layer exceeds trmin. + + IF (trntdr(i) > trmin ) THEN + + ! calculation over layers with penetrating radiation + + ! delta-transformed single-scattering properties + ! of this layer + ts = tau_star(i) + ws = omega_star(i) + gs = g_star(i) + + ! Delta-Eddington solution expressions + ! n(uu,et) = ((uu+c1)*(uu+c1)/et ) - ((uu-c1)*(uu-c1)*et) + ! u(w,gg,e) = c1p5*(c1 - w*gg)/e + ! el(w,gg) = sqrt(c3*(c1-w)*(c1 - w*gg)) + lm = sqrt(c3*(c1-ws)*(c1 - ws*gs)) !lm = el(ws,gs) + ue = c1p5*(c1 - ws*gs)/lm !ue = u(ws,gs,lm) + extins = max(exp_min, exp(-lm*ts)) + ne = ((ue+c1)*(ue+c1)/extins) - ((ue-c1)*(ue-c1)*extins) !ne = n(ue,extins) + + ! first calculation of rdif, tdif using Delta-Eddington formulas + ! rdif_a(k) = (ue+c1)*(ue-c1)*(c1/extins - extins)/ne + rdif_a(i) = (ue**2-c1)*(c1/extins - extins)/ne + tdif_a(i) = c4*ue/ne + + ! evaluate rdir,tdir for direct beam + trnlay(i) = max(exp_min, exp(-ts/mu_not)) + + ! Delta-Eddington solution expressions + ! alpha(w,uu,gg,e) = p75*w*uu*((c1 + gg*(c1-w))/(c1 - e*e*uu*uu)) + ! agamm(w,uu,gg,e) = p5*w*((c1 + c3*gg*(c1-w)*uu*uu)/(c1-e*e*uu*uu)) + ! alp = alpha(ws,mu_not,gs,lm) + ! gam = agamm(ws,mu_not,gs,lm) + alp = cp75*ws*mu_not*((c1 + gs*(c1-ws))/(c1 - lm*lm*mu_not*mu_not)) + gam = cp5*ws*((c1 + c3*gs*(c1-ws)*mu_not*mu_not)/(c1-lm*lm*mu_not*mu_not)) + apg = alp + gam + amg = alp - gam + + rdir(i) = apg*rdif_a(i) + amg*(tdif_a(i)*trnlay(i) - c1) + tdir(i) = apg*tdif_a(i) + (amg* rdif_a(i)-apg+c1)*trnlay(i) + + ! recalculate rdif,tdif using direct angular integration over rdir,tdir, + ! since Delta-Eddington rdif formula is not well-behaved (it is usually + ! biased low and can even be negative); USE ngmax angles and gaussian + ! integration for most accuracy: + R1 = rdif_a(i) ! USE R1 as temporary + T1 = tdif_a(i) ! USE T1 as temporary + swt = c0 + smr = c0 + smt = c0 + DO ng=1,ngmax + mu = difgauspt(ng) + gwt = difgauswt(ng) + swt = swt + mu*gwt + trn = max(exp_min, exp(-ts/mu)) + ! alp = alpha(ws,mu,gs,lm) + ! gam = agamm(ws,mu,gs,lm) + alp = cp75*ws*mu*((c1 + gs*(c1-ws))/(c1 - lm*lm*mu*mu)) + gam = cp5*ws*((c1 + c3*gs*(c1-ws)*mu*mu)/(c1-lm*lm*mu*mu)) + apg = alp + gam + amg = alp - gam + rdr = apg*R1 + amg*T1*trn - amg + tdr = apg*T1 + amg*R1*trn - apg*trn + trn + smr = smr + mu*rdr*gwt + smt = smt + mu*tdr*gwt + ENDDO ! ng + rdif_a(i) = smr/swt + tdif_a(i) = smt/swt + + ! homogeneous layer + rdif_b(i) = rdif_a(i) + tdif_b(i) = tdif_a(i) + + ENDIF ! trntdr(k) > trmin + + ! Calculate the solar beam transmission, total transmission, and + ! reflectivity for diffuse radiation from below at interface i, + ! the top of the current layer k: + ! + ! layers interface + ! + ! --------------------- i-1 + ! i-1 + ! --------------------- i + ! i + ! --------------------- + + trndir(i+1) = trndir(i)*trnlay(i) + refkm1 = c1/(c1 - rdndif(i)*rdif_a(i)) + tdrrdir = trndir(i)*rdir(i) + tdndif = trntdr(i) - trndir(i) + trntdr(i+1) = trndir(i)*tdir(i) + & + (tdndif + tdrrdir*rdndif(i))*refkm1*tdif_a(i) + rdndif(i+1) = rdif_b(i) + & + (tdif_b(i)*rdndif(i)*refkm1*tdif_a(i)) + trndif(i+1) = trndif(i)*refkm1*tdif_a(i) + + ENDDO ! END main level loop + + + ! compute reflectivity to direct and diffuse radiation for layers + ! below by adding succesive layers starting from the underlying + ! ground and working upwards: + ! + ! layers interface + ! + ! --------------------- i + ! i + ! --------------------- i+1 + ! i+1 + ! --------------------- + + ! set the underlying ground albedo == albedo of near-IR + ! unless bnd_idx == 1, for visible + rupdir(snl_btm_itf) = albsfc(2) + rupdif(snl_btm_itf) = albsfc(2) + IF (bnd_idx == 1) THEN + rupdir(snl_btm_itf) = albsfc(1) + rupdif(snl_btm_itf) = albsfc(1) + ENDIF + + DO i=snl_btm,snl_top,-1 + ! interface scattering + refkp1 = c1/( c1 - rdif_b(i)*rupdif(i+1)) + ! dir from top layer plus exp tran ref from lower layer, interface + ! scattered and tran thru top layer from below, plus diff tran ref + ! from lower layer with interface scattering tran thru top from below + rupdir(i) = rdir(i) & + + ( trnlay(i) *rupdir(i+1) & + + (tdir(i)-trnlay(i))*rupdif(i+1))*refkp1*tdif_b(i) + ! dif from top layer from above, plus dif tran upwards reflected and + ! interface scattered which tran top from below + rupdif(i) = rdif_a(i) + tdif_a(i)*rupdif(i+1)*refkp1*tdif_b(i) + ENDDO ! i + + ! net flux (down-up) at each layer interface from the + ! snow top (i = snl_top) to bottom interface above land (i = snl_btm_itf) + ! the interface reflectivities and transmissivities required + ! to evaluate interface fluxes are returned from solution_dEdd; + ! now compute up and down fluxes for each interface, using the + ! combined layer properties at each interface: + ! + ! layers interface + ! + ! --------------------- i + ! i + ! --------------------- + + DO i = snl_top, snl_btm_itf + ! interface scattering + refk = c1/(c1 - rdndif(i)*rupdif(i)) + ! dir tran ref from below times interface scattering, plus diff + ! tran and ref from below times interface scattering + ! fdirup(i) = (trndir(i)*rupdir(i) + & + ! (trntdr(i)-trndir(i)) & + ! *rupdif(i))*refk + ! dir tran plus total diff trans times interface scattering plus + ! dir tran with up dir ref and down dif ref times interface scattering + ! fdirdn(i) = trndir(i) + (trntdr(i) & + ! - trndir(i) + trndir(i) & + ! *rupdir(i)*rdndif(i))*refk + ! diffuse tran ref from below times interface scattering + ! fdifup(i) = trndif(i)*rupdif(i)*refk + ! diffuse tran times interface scattering + ! fdifdn(i) = trndif(i)*refk + + ! netflux, down - up + ! dfdir = fdirdn - fdirup + dfdir(i) = trndir(i) & + + (trntdr(i)-trndir(i)) * (c1 - rupdif(i)) * refk & + - trndir(i)*rupdir(i) * (c1 - rdndif(i)) * refk + IF (dfdir(i) < puny) dfdir(i) = c0 + ! dfdif = fdifdn - fdifup + dfdif(i) = trndif(i) * (c1 - rupdif(i)) * refk + IF (dfdif(i) < puny) dfdif(i) = c0 + ENDDO ! k + + ! SNICAR_AD_RT is called twice for direct and diffuse incident fluxes + ! direct incident + IF (flg_slr_in == 1) THEN + albedo = rupdir(snl_top) + dftmp = dfdir + refk = c1/(c1 - rdndif(snl_top)*rupdif(snl_top)) + F_sfc_pls = (trndir(snl_top)*rupdir(snl_top) + & + (trntdr(snl_top)-trndir(snl_top)) & + *rupdif(snl_top))*refk + !diffuse incident + ELSE + albedo = rupdif(snl_top) + dftmp = dfdif + refk = c1/(c1 - rdndif(snl_top)*rupdif(snl_top)) + F_sfc_pls = trndif(snl_top)*rupdif(snl_top)*refk + ENDIF + + ! Absorbed flux in each layer + DO i=snl_top,snl_btm,1 + F_abs(i) = dftmp(i)-dftmp(i+1) + flx_abs_lcl(i,bnd_idx) = F_abs(i) + + ! ERROR check: negative absorption + IF (p_is_master) THEN + IF (flx_abs_lcl(i,bnd_idx) < -0.00001) THEN + write (iulog,"(a,e13.6,a,i6)") "SNICAR ERROR: negative absoption : ", flx_abs_lcl(i,bnd_idx) + write(iulog,*) "SNICAR_AD STATS: snw_rds(0)= ", snw_rds(0) + write(iulog,*) "SNICAR_AD STATS: L_snw(0)= ", L_snw(0) + write(iulog,*) "SNICAR_AD STATS: h2osno= ", h2osno_lcl, " snl= ", snl_lcl + write(iulog,*) "SNICAR_AD STATS: soot1(0)= ", mss_cnc_aer_lcl(0,1) + write(iulog,*) "SNICAR_AD STATS: soot2(0)= ", mss_cnc_aer_lcl(0,2) + write(iulog,*) "SNICAR_AD STATS: dust1(0)= ", mss_cnc_aer_lcl(0,3) + write(iulog,*) "SNICAR_AD STATS: dust2(0)= ", mss_cnc_aer_lcl(0,4) + write(iulog,*) "SNICAR_AD STATS: dust3(0)= ", mss_cnc_aer_lcl(0,5) + write(iulog,*) "SNICAR_AD STATS: dust4(0)= ", mss_cnc_aer_lcl(0,6) + CALL abort + ENDIF + ENDIF + ENDDO + + ! absobed flux by the underlying ground + F_btm_net = dftmp(snl_btm_itf) + + ! note here, snl_btm_itf = 1 by snow column set up in CLM + flx_abs_lcl(1,bnd_idx) = F_btm_net + + IF (flg_nosnl == 1) THEN + ! If there are no snow layers (but still snow), all absorbed energy must be in top soil layer + !flx_abs_lcl(:,bnd_idx) = 0._r8 + !flx_abs_lcl(1,bnd_idx) = F_abs(0) + F_btm_net + + ! changed on 20070408: + ! OK to put absorbed energy in the fictitous snow layer because routine SurfaceRadiation + ! handles the CASE of no snow layers. Then, IF a snow layer is addded between now and + ! SurfaceRadiation (called in CanopyHydrology), absorbed energy will be properly distributed. + flx_abs_lcl(0,bnd_idx) = F_abs(0) + flx_abs_lcl(1,bnd_idx) = F_btm_net + ENDIF + + !Underflow check (we've already tripped the error condition above) + DO i=snl_top,1,1 + IF (flx_abs_lcl(i,bnd_idx) < 0._r8) THEN + flx_abs_lcl(i,bnd_idx) = 0._r8 + ENDIF + ENDDO + + F_abs_sum = 0._r8 + DO i=snl_top,snl_btm,1 + F_abs_sum = F_abs_sum + F_abs(i) + ENDDO + + !ENDDO !ENDDO WHILE (flg_dover > 0) + + ! Energy conservation check: + ! Incident direct+diffuse radiation equals (absorbed+bulk_transmitted+bulk_reflected) + energy_sum = (mu_not*pi*flx_slrd_lcl(bnd_idx)) + flx_slri_lcl(bnd_idx) - (F_abs_sum + F_btm_net + F_sfc_pls) + IF (p_is_master) THEN + IF (abs(energy_sum) > 0.00001_r8) THEN + write (iulog,"(a,e13.6,a,i6)") "SNICAR ERROR: Energy conservation error of : ", energy_sum + write(iulog,*) "F_abs_sum: ",F_abs_sum + write(iulog,*) "F_btm_net: ",F_btm_net + write(iulog,*) "F_sfc_pls: ",F_sfc_pls + write(iulog,*) "mu_not*pi*flx_slrd_lcl(bnd_idx): ", mu_not*pi*flx_slrd_lcl(bnd_idx) + write(iulog,*) "flx_slri_lcl(bnd_idx)", flx_slri_lcl(bnd_idx) + write(iulog,*) "bnd_idx", bnd_idx + write(iulog,*) "F_abs", F_abs + write(iulog,*) "albedo", albedo + CALL abort + ENDIF + ENDIF + + albout_lcl(bnd_idx) = albedo + ! Check that albedo is less than 1 + IF (p_is_master) THEN + IF (albout_lcl(bnd_idx) > 1.0) THEN + write (iulog,*) "SNICAR ERROR: Albedo > 1.0: " + write (iulog,*) "SNICAR STATS: bnd_idx= ",bnd_idx + write (iulog,*) "SNICAR STATS: albout_lcl(bnd)= ",albout_lcl(bnd_idx), & + " albsfc_lcl(bnd_idx)= ",albsfc_lcl(bnd_idx) + write (iulog,*) "SNICAR STATS: h2osno= ", h2osno_lcl, " snl= ", snl_lcl + write (iulog,*) "SNICAR STATS: coszen= ", coszen, " flg_slr= ", flg_slr_in + + write (iulog,*) "SNICAR STATS: soot(-4)= ", mss_cnc_aer_lcl(-4,1) + write (iulog,*) "SNICAR STATS: soot(-3)= ", mss_cnc_aer_lcl(-3,1) + write (iulog,*) "SNICAR STATS: soot(-2)= ", mss_cnc_aer_lcl(-2,1) + write (iulog,*) "SNICAR STATS: soot(-1)= ", mss_cnc_aer_lcl(-1,1) + write (iulog,*) "SNICAR STATS: soot(0)= ", mss_cnc_aer_lcl(0,1) + + write (iulog,*) "SNICAR STATS: L_snw(-4)= ", L_snw(-4) + write (iulog,*) "SNICAR STATS: L_snw(-3)= ", L_snw(-3) + write (iulog,*) "SNICAR STATS: L_snw(-2)= ", L_snw(-2) + write (iulog,*) "SNICAR STATS: L_snw(-1)= ", L_snw(-1) + write (iulog,*) "SNICAR STATS: L_snw(0)= ", L_snw(0) + + write (iulog,*) "SNICAR STATS: snw_rds(-4)= ", snw_rds(-4) + write (iulog,*) "SNICAR STATS: snw_rds(-3)= ", snw_rds(-3) + write (iulog,*) "SNICAR STATS: snw_rds(-2)= ", snw_rds(-2) + write (iulog,*) "SNICAR STATS: snw_rds(-1)= ", snw_rds(-1) + write (iulog,*) "SNICAR STATS: snw_rds(0)= ", snw_rds(0) + + CALL abort ENDIF - enddo - - ! absobed flux by the underlying ground - F_btm_net = dftmp(snl_btm_itf) - - ! note here, snl_btm_itf = 1 by snow column set up in CLM - flx_abs_lcl(1,bnd_idx) = F_btm_net - - if (flg_nosnl == 1) then - ! If there are no snow layers (but still snow), all absorbed energy must be in top soil layer - !flx_abs_lcl(:,bnd_idx) = 0._r8 - !flx_abs_lcl(1,bnd_idx) = F_abs(0) + F_btm_net - - ! changed on 20070408: - ! OK to put absorbed energy in the fictitous snow layer because routine SurfaceRadiation - ! handles the case of no snow layers. Then, if a snow layer is addded between now and - ! SurfaceRadiation (called in CanopyHydrology), absorbed energy will be properly distributed. - flx_abs_lcl(0,bnd_idx) = F_abs(0) - flx_abs_lcl(1,bnd_idx) = F_btm_net - endif - - !Underflow check (we've already tripped the error condition above) - do i=snl_top,1,1 - if (flx_abs_lcl(i,bnd_idx) < 0._r8) then - flx_abs_lcl(i,bnd_idx) = 0._r8 - endif - enddo - - F_abs_sum = 0._r8 - do i=snl_top,snl_btm,1 - F_abs_sum = F_abs_sum + F_abs(i) - enddo - - !enddo !enddo while (flg_dover > 0) - - ! Energy conservation check: - ! Incident direct+diffuse radiation equals (absorbed+bulk_transmitted+bulk_reflected) - energy_sum = (mu_not*pi*flx_slrd_lcl(bnd_idx)) + flx_slri_lcl(bnd_idx) - (F_abs_sum + F_btm_net + F_sfc_pls) - IF (p_is_master) THEN - if (abs(energy_sum) > 0.00001_r8) then - write (iulog,"(a,e13.6,a,i6)") "SNICAR ERROR: Energy conservation error of : ", energy_sum - write(iulog,*) "F_abs_sum: ",F_abs_sum - write(iulog,*) "F_btm_net: ",F_btm_net - write(iulog,*) "F_sfc_pls: ",F_sfc_pls - write(iulog,*) "mu_not*pi*flx_slrd_lcl(bnd_idx): ", mu_not*pi*flx_slrd_lcl(bnd_idx) - write(iulog,*) "flx_slri_lcl(bnd_idx)", flx_slri_lcl(bnd_idx) - write(iulog,*) "bnd_idx", bnd_idx - write(iulog,*) "F_abs", F_abs - write(iulog,*) "albedo", albedo - call abort - endif - ENDIF - - albout_lcl(bnd_idx) = albedo - ! Check that albedo is less than 1 - IF (p_is_master) THEN - if (albout_lcl(bnd_idx) > 1.0) then - write (iulog,*) "SNICAR ERROR: Albedo > 1.0: " - write (iulog,*) "SNICAR STATS: bnd_idx= ",bnd_idx - write (iulog,*) "SNICAR STATS: albout_lcl(bnd)= ",albout_lcl(bnd_idx), & - " albsfc_lcl(bnd_idx)= ",albsfc_lcl(bnd_idx) - write (iulog,*) "SNICAR STATS: h2osno= ", h2osno_lcl, " snl= ", snl_lcl - write (iulog,*) "SNICAR STATS: coszen= ", coszen, " flg_slr= ", flg_slr_in - - write (iulog,*) "SNICAR STATS: soot(-4)= ", mss_cnc_aer_lcl(-4,1) - write (iulog,*) "SNICAR STATS: soot(-3)= ", mss_cnc_aer_lcl(-3,1) - write (iulog,*) "SNICAR STATS: soot(-2)= ", mss_cnc_aer_lcl(-2,1) - write (iulog,*) "SNICAR STATS: soot(-1)= ", mss_cnc_aer_lcl(-1,1) - write (iulog,*) "SNICAR STATS: soot(0)= ", mss_cnc_aer_lcl(0,1) - - write (iulog,*) "SNICAR STATS: L_snw(-4)= ", L_snw(-4) - write (iulog,*) "SNICAR STATS: L_snw(-3)= ", L_snw(-3) - write (iulog,*) "SNICAR STATS: L_snw(-2)= ", L_snw(-2) - write (iulog,*) "SNICAR STATS: L_snw(-1)= ", L_snw(-1) - write (iulog,*) "SNICAR STATS: L_snw(0)= ", L_snw(0) - - write (iulog,*) "SNICAR STATS: snw_rds(-4)= ", snw_rds(-4) - write (iulog,*) "SNICAR STATS: snw_rds(-3)= ", snw_rds(-3) - write (iulog,*) "SNICAR STATS: snw_rds(-2)= ", snw_rds(-2) - write (iulog,*) "SNICAR STATS: snw_rds(-1)= ", snw_rds(-1) - write (iulog,*) "SNICAR STATS: snw_rds(0)= ", snw_rds(0) - - call abort - endif - ENDIF - - enddo ! loop over wvl bands - - - ! Weight output NIR albedo appropriately - albout(1) = albout_lcl(1) - flx_sum = 0._r8 - do bnd_idx= nir_bnd_bgn,nir_bnd_end - flx_sum = flx_sum + flx_wgt(bnd_idx)*albout_lcl(bnd_idx) - enddo - albout(2) = flx_sum / sum(flx_wgt(nir_bnd_bgn:nir_bnd_end)) - - ! Weight output NIR absorbed layer fluxes (flx_abs) appropriately - flx_abs(:,1) = flx_abs_lcl(:,1) - do i=snl_top,1,1 - flx_sum = 0._r8 - do bnd_idx= nir_bnd_bgn,nir_bnd_end - flx_sum = flx_sum + flx_wgt(bnd_idx)*flx_abs_lcl(i,bnd_idx) - enddo - flx_abs(i,2) = flx_sum / sum(flx_wgt(nir_bnd_bgn:nir_bnd_end)) - enddo - - ! near-IR direct albedo/absorption adjustment for high solar zenith angles - ! solar zenith angle parameterization - ! calculate the scaling factor for NIR direct albedo if SZA>75 degree - if ((mu_not < mu_75) .and. (flg_slr_in == 1)) then - sza_c1 = sza_a0 + sza_a1 * mu_not + sza_a2 * mu_not**2 - sza_c0 = sza_b0 + sza_b1 * mu_not + sza_b2 * mu_not**2 - sza_factor = sza_c1 * (log10(snw_rds_lcl(snl_top) * c1) - c6) + sza_c0 - flx_sza_adjust = albout(2) * (sza_factor-c1) * sum(flx_wgt(nir_bnd_bgn:nir_bnd_end)) - albout(2) = albout(2) * sza_factor - flx_abs(snl_top,2) = flx_abs(snl_top,2) - flx_sza_adjust - endif - - ! If snow < minimum_snow, but > 0, and there is sun, set albedo to underlying surface albedo - elseif ( (coszen > 0._r8) .and. (h2osno_lcl < min_snw) .and. (h2osno_lcl > 0._r8) ) then - albout(1) = albsfc(1) - albout(2) = albsfc(2) - - ! There is either zero snow, or no sun - else - albout(1) = 0._r8 - albout(2) = 0._r8 - endif ! if column has snow and coszen > 0 - - ! end associate - - end subroutine SNICAR_AD_RT - !----------------------------------------------------------------------- - - - subroutine SnowAge_grain( dtime , snl , dz , & - qflx_snow_grnd , qflx_snwcp_ice , qflx_snofrz_lyr , & - do_capsnow , frac_sno , h2osno , & - h2osno_liq , h2osno_ice , & - t_soisno , t_grnd , & - forc_t , snw_rds ) - ! - ! !DESCRIPTION: - ! Updates the snow effective grain size (radius). - ! Contributions to grain size evolution are from: - ! 1. vapor redistribution (dry snow) - ! 2. liquid water redistribution (wet snow) - ! 3. re-freezing of liquid water - ! - ! Vapor redistribution: Method is to retrieve 3 best-bit parameters that - ! depend on snow temperature, temperature gradient, and density, - ! that are derived from the microphysical model described in: - ! Flanner and Zender (2006), Linking snowpack microphysics and albedo - ! evolution, J. Geophys. Res., 111, D12208, doi:10.1029/2005JD006834. - ! The parametric equation has the form: - ! dr/dt = drdt_0*(tau/(dr_fresh+tau))^(1/kappa), where: - ! r is the effective radius, - ! tau and kappa are best-fit parameters, - ! drdt_0 is the initial rate of change of effective radius, and - ! dr_fresh is the difference between the current and fresh snow states - ! (r_current - r_fresh). - ! - ! Liquid water redistribution: Apply the grain growth function from: - ! Brun, E. (1989), Investigation of wet-snow metamorphism in respect of - ! liquid-water content, Annals of Glaciology, 13, 22-26. - ! There are two parameters that describe the grain growth rate as - ! a function of snow liquid water content (LWC). The "LWC=0" parameter - ! is zeroed here because we are accounting for dry snowing with a - ! different representation - ! - ! Re-freezing of liquid water: Assume that re-frozen liquid water clumps - ! into an arbitrarily large effective grain size (snw_rds_refrz). - ! The phenomenon is observed (Grenfell), but so far unquantified, as far as - ! I am aware. - ! - ! !USES: - ! - ! DAI, Dec. 29, 2022 - !----------------------------------------------------------------------- - ! !ARGUMENTS: - - IMPLICIT NONE - - real(r8) , intent(in) :: dtime ! land model time step [sec] - - integer , intent(in) :: snl ! negative number of snow layers (col) [nbr] - real(r8) , intent(in) :: dz ( maxsnl+1:1 ) ! layer thickness (col,lyr) [m] - - real(r8) , intent(in) :: qflx_snow_grnd ! snow on ground after interception (col) [kg m-2 s-1] - real(r8) , intent(in) :: qflx_snwcp_ice ! excess precipitation due to snow capping [kg m-2 s-1] - real(r8) , intent(in) :: qflx_snofrz_lyr ( maxsnl+1:0 ) ! snow freezing rate (col,lyr) [kg m-2 s-1] - - logical , intent(in) :: do_capsnow ! true => do snow capping - real(r8) , intent(in) :: frac_sno ! fraction of ground covered by snow (0 to 1) - real(r8) , intent(in) :: h2osno ! snow water (col) [mm H2O] - real(r8) , intent(in) :: h2osno_liq ( maxsnl+1:0 ) ! liquid water content (col,lyr) [kg m-2] - real(r8) , intent(in) :: h2osno_ice ( maxsnl+1:0 ) ! ice content (col,lyr) [kg m-2] - - real(r8) , intent(in) :: t_soisno ( maxsnl+1:1 ) ! soil and snow temperature (col,lyr) [K] - real(r8) , intent(in) :: t_grnd ! ground temperature (col) [K] - real(r8) , intent(in) :: forc_t ! Atmospheric temperature (col) [K] - - real(r8) , intent(inout) :: snw_rds ( maxsnl+1:0 ) ! effective grain radius (col,lyr) [microns, m-6] - - ! DAI, Dec. 29, 2022 - !----------------------------------------------------------------------- - ! - ! !LOCAL VARIABLES: - integer :: snl_top ! top snow layer index [idx] - integer :: snl_btm ! bottom snow layer index [idx] - integer :: i ! layer index [idx] - ! integer :: c_idx ! column index [idx] - integer :: fc ! snow column filter index [idx] - integer :: T_idx ! snow aging lookup table temperature index [idx] - integer :: Tgrd_idx ! snow aging lookup table temperature gradient index [idx] - integer :: rhos_idx ! snow aging lookup table snow density index [idx] - real(r8) :: t_snotop ! temperature at upper layer boundary [K] - real(r8) :: t_snobtm ! temperature at lower layer boundary [K] - real(r8) :: dTdz(maxsnl:0) ! snow temperature gradient (col,lyr) [K m-1] - real(r8) :: bst_tau ! snow aging parameter retrieved from lookup table [hour] - real(r8) :: bst_kappa ! snow aging parameter retrieved from lookup table [unitless] - real(r8) :: bst_drdt0 ! snow aging parameter retrieved from lookup table [um hr-1] - real(r8) :: dr ! incremental change in snow effective radius [um] - real(r8) :: dr_wet ! incremental change in snow effective radius from wet growth [um] - real(r8) :: dr_fresh ! difference between fresh snow r_e and current r_e [um] - real(r8) :: newsnow ! fresh snowfall [kg m-2] - real(r8) :: refrzsnow ! re-frozen snow [kg m-2] - real(r8) :: frc_newsnow ! fraction of layer mass that is new snow [frc] - real(r8) :: frc_oldsnow ! fraction of layer mass that is old snow [frc] - real(r8) :: frc_refrz ! fraction of layer mass that is re-frozen snow [frc] - real(r8) :: frc_liq ! fraction of layer mass that is liquid water[frc] - real(r8) :: rhos ! snow density [kg m-3] - real(r8) :: h2osno_lyr ! liquid + solid H2O in snow layer [kg m-2] - real(r8) :: cdz(maxsnl+1:0) ! column average layer thickness [m] - real(r8) :: snw_rds_fresh ! fresh snow radius [microns] - - real(r8) :: snot_top ! temperature in top snow layer (col) [K] - real(r8) :: dTdz_top ! temperature gradient in top layer (col) [K m-1] - real(r8) :: snw_rds_top ! effective grain radius, top layer (col) [microns, m-6] - real(r8) :: sno_liq_top ! liquid water fraction (mass) in top snow layer (col) [frc] - - !--------------------------------------------------------------------------! + ENDIF + + ENDDO ! loop over wvl bands + + + ! Weight output NIR albedo appropriately + albout(1) = albout_lcl(1) + flx_sum = 0._r8 + DO bnd_idx= nir_bnd_bgn,nir_bnd_end + flx_sum = flx_sum + flx_wgt(bnd_idx)*albout_lcl(bnd_idx) + ENDDO + albout(2) = flx_sum / sum(flx_wgt(nir_bnd_bgn:nir_bnd_end)) + + ! Weight output NIR absorbed layer fluxes (flx_abs) appropriately + flx_abs(:,1) = flx_abs_lcl(:,1) + DO i=snl_top,1,1 + flx_sum = 0._r8 + DO bnd_idx= nir_bnd_bgn,nir_bnd_end + flx_sum = flx_sum + flx_wgt(bnd_idx)*flx_abs_lcl(i,bnd_idx) + ENDDO + flx_abs(i,2) = flx_sum / sum(flx_wgt(nir_bnd_bgn:nir_bnd_end)) + ENDDO + + ! near-IR direct albedo/absorption adjustment for high solar zenith angles + ! solar zenith angle parameterization + ! calculate the scaling factor for NIR direct albedo IF SZA>75 degree + IF ((mu_not < mu_75) .and. (flg_slr_in == 1)) THEN + sza_c1 = sza_a0 + sza_a1 * mu_not + sza_a2 * mu_not**2 + sza_c0 = sza_b0 + sza_b1 * mu_not + sza_b2 * mu_not**2 + sza_factor = sza_c1 * (log10(snw_rds_lcl(snl_top) * c1) - c6) + sza_c0 + flx_sza_adjust = albout(2) * (sza_factor-c1) * sum(flx_wgt(nir_bnd_bgn:nir_bnd_end)) + albout(2) = albout(2) * sza_factor + flx_abs(snl_top,2) = flx_abs(snl_top,2) - flx_sza_adjust + ENDIF + + ! If snow < minimum_snow, but > 0, and there is sun, set albedo to underlying surface albedo + elseif ( (coszen > 0._r8) .and. (h2osno_lcl < min_snw) .and. (h2osno_lcl > 0._r8) ) THEN + albout(1) = albsfc(1) + albout(2) = albsfc(2) + + ! There is either zero snow, or no sun + ELSE + albout(1) = 0._r8 + albout(2) = 0._r8 + ENDIF ! IF column has snow and coszen > 0 + + ! END associate + + END SUBROUTINE SNICAR_AD_RT + !----------------------------------------------------------------------- + + + SUBROUTINE SnowAge_grain( dtime , snl , dz , & + qflx_snow_grnd , qflx_snwcp_ice , qflx_snofrz_lyr , & + do_capsnow , frac_sno , h2osno , & + h2osno_liq , h2osno_ice , & + t_soisno , t_grnd , & + forc_t , snw_rds ) + ! + ! !DESCRIPTION: + ! Updates the snow effective grain size (radius). + ! Contributions to grain size evolution are from: + ! 1. vapor redistribution (dry snow) + ! 2. liquid water redistribution (wet snow) + ! 3. re-freezing of liquid water + ! + ! Vapor redistribution: Method is to retrieve 3 best-bit parameters that + ! depend on snow temperature, temperature gradient, and density, + ! that are derived from the microphysical model described in: + ! Flanner and Zender (2006), Linking snowpack microphysics and albedo + ! evolution, J. Geophys. Res., 111, D12208, doi:10.1029/2005JD006834. + ! The parametric equation has the form: + ! dr/dt = drdt_0*(tau/(dr_fresh+tau))^(1/kappa), WHERE: + ! r is the effective radius, + ! tau and kappa are best-fit parameters, + ! drdt_0 is the initial rate of change of effective radius, and + ! dr_fresh is the difference between the current and fresh snow states + ! (r_current - r_fresh). + ! + ! Liquid water redistribution: Apply the grain growth FUNCTION from: + ! Brun, E. (1989), Investigation of wet-snow metamorphism in respect of + ! liquid-water content, Annals of Glaciology, 13, 22-26. + ! There are two parameters that describe the grain growth rate as + ! a FUNCTION of snow liquid water content (LWC). The "LWC=0" parameter + ! is zeroed here because we are accounting for dry snowing with a + ! different representation + ! + ! Re-freezing of liquid water: Assume that re-frozen liquid water clumps + ! into an arbitrarily large effective grain size (snw_rds_refrz). + ! The phenomenon is observed (Grenfell), but so far unquantified, as far as + ! I am aware. + ! + ! !USES: + ! + ! DAI, Dec. 29, 2022 + !----------------------------------------------------------------------- + ! !ARGUMENTS: + + IMPLICIT NONE + + real(r8) , intent(in) :: dtime ! land model time step [sec] + + integer , intent(in) :: snl ! negative number of snow layers (col) [nbr] + real(r8) , intent(in) :: dz ( maxsnl+1:1 ) ! layer thickness (col,lyr) [m] + + real(r8) , intent(in) :: qflx_snow_grnd ! snow on ground after interception (col) [kg m-2 s-1] + real(r8) , intent(in) :: qflx_snwcp_ice ! excess precipitation due to snow capping [kg m-2 s-1] + real(r8) , intent(in) :: qflx_snofrz_lyr ( maxsnl+1:0 ) ! snow freezing rate (col,lyr) [kg m-2 s-1] + + logical , intent(in) :: do_capsnow ! true => DO snow capping + real(r8) , intent(in) :: frac_sno ! fraction of ground covered by snow (0 to 1) + real(r8) , intent(in) :: h2osno ! snow water (col) [mm H2O] + real(r8) , intent(in) :: h2osno_liq ( maxsnl+1:0 ) ! liquid water content (col,lyr) [kg m-2] + real(r8) , intent(in) :: h2osno_ice ( maxsnl+1:0 ) ! ice content (col,lyr) [kg m-2] + + real(r8) , intent(in) :: t_soisno ( maxsnl+1:1 ) ! soil and snow temperature (col,lyr) [K] + real(r8) , intent(in) :: t_grnd ! ground temperature (col) [K] + real(r8) , intent(in) :: forc_t ! Atmospheric temperature (col) [K] + + real(r8) , intent(inout) :: snw_rds ( maxsnl+1:0 ) ! effective grain radius (col,lyr) [microns, m-6] + + ! DAI, Dec. 29, 2022 + !----------------------------------------------------------------------- + ! + ! !LOCAL VARIABLES: + integer :: snl_top ! top snow layer index [idx] + integer :: snl_btm ! bottom snow layer index [idx] + integer :: i ! layer index [idx] + ! integer :: c_idx ! column index [idx] + integer :: fc ! snow column filter index [idx] + integer :: T_idx ! snow aging lookup table temperature index [idx] + integer :: Tgrd_idx ! snow aging lookup table temperature gradient index [idx] + integer :: rhos_idx ! snow aging lookup table snow density index [idx] + real(r8) :: t_snotop ! temperature at upper layer boundary [K] + real(r8) :: t_snobtm ! temperature at lower layer boundary [K] + real(r8) :: dTdz(maxsnl:0) ! snow temperature gradient (col,lyr) [K m-1] + real(r8) :: bst_tau ! snow aging parameter retrieved from lookup table [hour] + real(r8) :: bst_kappa ! snow aging parameter retrieved from lookup table [unitless] + real(r8) :: bst_drdt0 ! snow aging parameter retrieved from lookup table [um hr-1] + real(r8) :: dr ! incremental change in snow effective radius [um] + real(r8) :: dr_wet ! incremental change in snow effective radius from wet growth [um] + real(r8) :: dr_fresh ! difference between fresh snow r_e and current r_e [um] + real(r8) :: newsnow ! fresh snowfall [kg m-2] + real(r8) :: refrzsnow ! re-frozen snow [kg m-2] + real(r8) :: frc_newsnow ! fraction of layer mass that is new snow [frc] + real(r8) :: frc_oldsnow ! fraction of layer mass that is old snow [frc] + real(r8) :: frc_refrz ! fraction of layer mass that is re-frozen snow [frc] + real(r8) :: frc_liq ! fraction of layer mass that is liquid water[frc] + real(r8) :: rhos ! snow density [kg m-3] + real(r8) :: h2osno_lyr ! liquid + solid H2O in snow layer [kg m-2] + real(r8) :: cdz(maxsnl+1:0) ! column average layer thickness [m] + real(r8) :: snw_rds_fresh ! fresh snow radius [microns] + + real(r8) :: snot_top ! temperature in top snow layer (col) [K] + real(r8) :: dTdz_top ! temperature gradient in top layer (col) [K m-1] + real(r8) :: snw_rds_top ! effective grain radius, top layer (col) [microns, m-6] + real(r8) :: sno_liq_top ! liquid water fraction (mass) in top snow layer (col) [frc] + + !--------------------------------------------------------------------------! ! associate( & ! snl => col_pp%snl , & ! Input: [integer (:) ] negative number of snow layers (col) [nbr] @@ -2511,7 +2511,7 @@ subroutine SnowAge_grain( dtime , snl , dz , & ! qflx_snwcp_ice => col_wf%qflx_snwcp_ice , & ! Input: [real(r8) (:) ] excess precipitation due to snow capping [kg m-2 s-1] ! qflx_snofrz_lyr => col_wf%qflx_snofrz_lyr , & ! Input: [real(r8) (:,:) ] snow freezing rate (col,lyr) [kg m-2 s-1] - ! do_capsnow => col_ws%do_capsnow , & ! Input: [logical (:) ] true => do snow capping + ! do_capsnow => col_ws%do_capsnow , & ! Input: [logical (:) ] true => DO snow capping ! frac_sno => col_ws%frac_sno_eff , & ! Input: [real(r8) (:) ] fraction of ground covered by snow (0 to 1) ! h2osno => col_ws%h2osno , & ! Input: [real(r8) (:) ] snow water (col) [mm H2O] ! h2osno_liq => col_ws%h2osno_liq , & ! Input: [real(r8) (:,:) ] liquid water content (col,lyr) [kg m-2] @@ -2527,7 +2527,7 @@ subroutine SnowAge_grain( dtime , snl , dz , & ! ) - if (snl < 0 .and. h2osno > 0._r8) then + IF (snl < 0 .and. h2osno > 0._r8) THEN snl_btm = 0 snl_top = snl + 1 @@ -2535,27 +2535,27 @@ subroutine SnowAge_grain( dtime , snl , dz , & cdz(snl_top:snl_btm)=frac_sno*dz(snl_top:snl_btm) ! loop over snow layers - do i = snl_top, snl_btm, 1 + DO i = snl_top, snl_btm, 1 ! !********** 1. DRY SNOW AGING *********** ! h2osno_lyr = h2osno_liq(i) + h2osno_ice(i) ! temperature gradient - if (i == snl_top) then + IF (i == snl_top) THEN ! top layer t_snotop = t_soisno(snl_top) t_snobtm = (t_soisno(i+1)*dz(i) & + t_soisno(i)*dz(i+1)) & / (dz(i)+dz(i+1)) - else + ELSE t_snotop = (t_soisno(i-1)*dz(i) & + t_soisno(i)*dz(i-1)) & / (dz(i)+dz(i-1)) t_snobtm = (t_soisno(i+1)*dz(i) & + t_soisno(i)*dz(i+1)) & / (dz(i)+dz(i+1)) - endif + ENDIF dTdz(i) = abs((t_snotop - t_snobtm) / cdz(i)) @@ -2571,24 +2571,24 @@ subroutine SnowAge_grain( dtime , snl , dz , & rhos_idx = nint((rhos-50) / 50) + 1 ! boundary check: - if (T_idx < idx_T_min) then + IF (T_idx < idx_T_min) THEN T_idx = idx_T_min - endif - if (T_idx > idx_T_max) then + ENDIF + IF (T_idx > idx_T_max) THEN T_idx = idx_T_max - endif - if (Tgrd_idx < idx_Tgrd_min) then + ENDIF + IF (Tgrd_idx < idx_Tgrd_min) THEN Tgrd_idx = idx_Tgrd_min - endif - if (Tgrd_idx > idx_Tgrd_max) then + ENDIF + IF (Tgrd_idx > idx_Tgrd_max) THEN Tgrd_idx = idx_Tgrd_max - endif - if (rhos_idx < idx_rhos_min) then + ENDIF + IF (rhos_idx < idx_rhos_min) THEN rhos_idx = idx_rhos_min - endif - if (rhos_idx > idx_rhos_max) then + ENDIF + IF (rhos_idx > idx_rhos_max) THEN rhos_idx = idx_rhos_max - endif + ENDIF ! best-fit parameters bst_tau = snowage_tau(rhos_idx,Tgrd_idx,T_idx) @@ -2600,14 +2600,14 @@ subroutine SnowAge_grain( dtime , snl , dz , & dr_fresh = snw_rds(i)-snw_rds_min #ifdef MODAL_AER - if ( abs(dr_fresh) < 1.0e-8_r8 ) then + IF ( abs(dr_fresh) < 1.0e-8_r8 ) THEN dr_fresh = 0.0_r8 - else if ( dr_fresh < 0.0_r8 ) then + ELSE IF ( dr_fresh < 0.0_r8 ) THEN IF (p_is_master) THEN write(iulog,*) "dr_fresh = ", dr_fresh, snw_rds(i), snw_rds_min - call abort + CALL abort ENDIF - end if + END IF dr = (bst_drdt0*(bst_tau/(dr_fresh+bst_tau))**(1._r8/bst_kappa)) * (dtime/3600._r8) #else @@ -2633,9 +2633,9 @@ subroutine SnowAge_grain( dtime , snl , dz , & !********** 3. SNOWAGE SCALING (TURNED OFF BY DEFAULT) ************* ! ! Multiply rate of change of effective radius by some constant, xdrdt - if (flg_snoage_scl) then + IF (flg_snoage_scl) THEN dr = dr*xdrdt - endif + ENDIF ! !********** 4. INCREMENT EFFECTIVE RADIUS, ACCOUNTING FOR: *********** @@ -2645,11 +2645,11 @@ subroutine SnowAge_grain( dtime , snl , dz , & ! RE-FREEZING ! ! new snowfall [kg/m2] - if (do_capsnow .and. .not. use_extrasnowlayers) then + IF (do_capsnow .and. .not. use_extrasnowlayers) THEN newsnow = max(0._r8, (qflx_snwcp_ice*dtime)) - else + ELSE newsnow = max(0._r8, (qflx_snow_grnd*dtime)) - endif + ENDIF ! snow that has re-frozen [kg/m2] refrzsnow = max(0._r8, (qflx_snofrz_lyr(i)*dtime)) @@ -2658,19 +2658,19 @@ subroutine SnowAge_grain( dtime , snl , dz , & frc_refrz = refrzsnow / h2osno_lyr ! fraction of layer mass that is new snow - if (i == snl_top) then + IF (i == snl_top) THEN frc_newsnow = newsnow / h2osno_lyr - else + ELSE frc_newsnow = 0._r8 - endif + ENDIF - if ((frc_refrz + frc_newsnow) > 1._r8) then + IF ((frc_refrz + frc_newsnow) > 1._r8) THEN frc_refrz = frc_refrz / (frc_refrz + frc_newsnow) frc_newsnow = 1._r8 - frc_refrz frc_oldsnow = 0._r8 - else + ELSE frc_oldsnow = 1._r8 - frc_refrz - frc_newsnow - endif + ENDIF ! temperature dependent fresh grain size snw_rds_fresh = FreshSnowRadius (forc_t) @@ -2681,75 +2681,75 @@ subroutine SnowAge_grain( dtime , snl , dz , & !********** 5. CHECK BOUNDARIES *********** ! ! boundary check - if (snw_rds(i) < snw_rds_min) then + IF (snw_rds(i) < snw_rds_min) THEN snw_rds(i) = snw_rds_min - endif + ENDIF - if (snw_rds(i) > snw_rds_max) then + IF (snw_rds(i) > snw_rds_max) THEN snw_rds(i) = snw_rds_max - end if + END IF ! set top layer variables for history files - if (i == snl_top) then + IF (i == snl_top) THEN snot_top = t_soisno(i) dTdz_top = dTdz(i) snw_rds_top = snw_rds(i) sno_liq_top = h2osno_liq(i) / (h2osno_liq(i)+h2osno_ice(i)) - endif + ENDIF - enddo - endif ! endif (snl < 0 ) + ENDDO + ENDIF ! ENDIF (snl < 0 ) - ! Special case: snow on ground, but not enough to have defined a snow layer: + ! Special CASE: snow on ground, but not enough to have defined a snow layer: ! set snw_rds to fresh snow grain size: - if (snl >= 0 .and. h2osno > 0._r8) then + IF (snl >= 0 .and. h2osno > 0._r8) THEN snw_rds(0) = snw_rds_min - end if + END IF - ! end associate + ! END associate - end subroutine SnowAge_grain - !----------------------------------------------------------------------- + END SUBROUTINE SnowAge_grain + !----------------------------------------------------------------------- - subroutine SnowOptics_init( fsnowoptics ) + SUBROUTINE SnowOptics_init( fsnowoptics ) - USE MOD_NetCDFSerial + USE MOD_NetCDFSerial - IMPLICIT NONE + IMPLICIT NONE - character(len=256), intent(in) :: fsnowoptics ! snow optical properties file name - character(len= 32) :: subname = 'SnowOptics_init' ! subroutine name - integer :: atm_type_index ! index for atmospheric type + character(len=256), intent(in) :: fsnowoptics ! snow optical properties file name + character(len= 32) :: subname = 'SnowOptics_init' ! SUBROUTINE name + integer :: atm_type_index ! index for atmospheric type - logical :: readvar ! determine if variable was read from NetCDF file - !----------------------------------------------------------------------- + logical :: readvar ! determine IF variable was read from NetCDF file + !----------------------------------------------------------------------- readvar = .true. atm_type_index = atm_type_default ! Define atmospheric type - if (trim(snicar_atm_type) == 'default') then + IF (trim(snicar_atm_type) == 'default') THEN atm_type_index = atm_type_default - elseif (trim(snicar_atm_type) == 'mid-latitude_winter') then + elseif (trim(snicar_atm_type) == 'mid-latitude_winter') THEN atm_type_index = atm_type_mid_latitude_winter - elseif (trim(snicar_atm_type) == 'mid-latitude_summer') then + elseif (trim(snicar_atm_type) == 'mid-latitude_summer') THEN atm_type_index = atm_type_mid_latitude_summer - elseif (trim(snicar_atm_type) == 'sub-Arctic_winter') then + elseif (trim(snicar_atm_type) == 'sub-Arctic_winter') THEN atm_type_index = atm_type_sub_Arctic_winter - elseif (trim(snicar_atm_type) == 'sub-Arctic_summer') then + elseif (trim(snicar_atm_type) == 'sub-Arctic_summer') THEN atm_type_index = atm_type_sub_Arctic_summer - elseif (trim(snicar_atm_type) == 'summit_Greenland') then + elseif (trim(snicar_atm_type) == 'summit_Greenland') THEN atm_type_index = atm_type_summit_Greenland - elseif (trim(snicar_atm_type) == 'high_mountain') then + elseif (trim(snicar_atm_type) == 'high_mountain') THEN atm_type_index = atm_type_high_mountain - else + ELSE IF (p_is_master) THEN write(iulog,*) "snicar_atm_type = ", snicar_atm_type - call abort + CALL abort ENDIF - endif + ENDIF ! ! Open optics file: @@ -2776,221 +2776,219 @@ subroutine SnowOptics_init( fsnowoptics ) CALL ncio_read_bcast_serial (fsnowoptics, 'flx_wgt_dif', flx_wgt_dif) #ifdef MODAL_AER - ! size-dependent BC parameters and BC enhancement factors - IF (p_is_master) THEN - write(iulog,*) 'Attempting to read optical properties for within-ice BC (modal aerosol treatment) ...' - ENDIF - ! - ! BC species 1 Mie parameters - ! - CALL ncio_read_bcast_serial (fsnowoptics, 'ss_alb_bc_mam', ss_alb_bc1) - CALL ncio_read_bcast_serial (fsnowoptics, 'asm_prm_bc_mam', asm_prm_bc1) - CALL ncio_read_bcast_serial (fsnowoptics, 'ext_cff_mss_bc_mam', ext_cff_mss_bc1) - ! - ! BC species 2 Mie parameters (identical, before enhancement factors applied) - ! - CALL ncio_read_bcast_serial (fsnowoptics, 'ss_alb_bc_mam', ss_alb_bc2) - CALL ncio_read_bcast_serial (fsnowoptics, 'asm_prm_bc_mam', asm_prm_bc2) - CALL ncio_read_bcast_serial (fsnowoptics, 'ext_cff_mss_bc_mam', ext_cff_mss_bc2) - ! - ! size-dependent BC absorption enhancement factors for within-ice BC - CALL ncio_read_bcast_serial (fsnowoptics, 'bcint_enh_mam', bcenh) - ! + ! size-dependent BC parameters and BC enhancement factors + IF (p_is_master) THEN + write(iulog,*) 'Attempting to read optical properties for within-ice BC (modal aerosol treatment) ...' + ENDIF + ! + ! BC species 1 Mie parameters + ! + CALL ncio_read_bcast_serial (fsnowoptics, 'ss_alb_bc_mam', ss_alb_bc1) + CALL ncio_read_bcast_serial (fsnowoptics, 'asm_prm_bc_mam', asm_prm_bc1) + CALL ncio_read_bcast_serial (fsnowoptics, 'ext_cff_mss_bc_mam', ext_cff_mss_bc1) + ! + ! BC species 2 Mie parameters (identical, before enhancement factors applied) + ! + CALL ncio_read_bcast_serial (fsnowoptics, 'ss_alb_bc_mam', ss_alb_bc2) + CALL ncio_read_bcast_serial (fsnowoptics, 'asm_prm_bc_mam', asm_prm_bc2) + CALL ncio_read_bcast_serial (fsnowoptics, 'ext_cff_mss_bc_mam', ext_cff_mss_bc2) + ! + ! size-dependent BC absorption enhancement factors for within-ice BC + CALL ncio_read_bcast_serial (fsnowoptics, 'bcint_enh_mam', bcenh) + ! #else - ! bulk aerosol treatment - ! BC species 1 Mie parameters - CALL ncio_read_bcast_serial (fsnowoptics, 'ss_alb_bcphil', ss_alb_bc1) - CALL ncio_read_bcast_serial (fsnowoptics, 'asm_prm_bcphil', asm_prm_bc1) - CALL ncio_read_bcast_serial (fsnowoptics, 'ext_cff_mss_bcphil', ext_cff_mss_bc1) - - ! - ! BC species 2 Mie parameters - ! - CALL ncio_read_bcast_serial (fsnowoptics, 'ss_alb_bcphob', ss_alb_bc2) - CALL ncio_read_bcast_serial (fsnowoptics, 'asm_prm_bcphob', asm_prm_bc2) - CALL ncio_read_bcast_serial (fsnowoptics, 'ext_cff_mss_bcphob', ext_cff_mss_bc2) - ! + ! bulk aerosol treatment + ! BC species 1 Mie parameters + CALL ncio_read_bcast_serial (fsnowoptics, 'ss_alb_bcphil', ss_alb_bc1) + CALL ncio_read_bcast_serial (fsnowoptics, 'asm_prm_bcphil', asm_prm_bc1) + CALL ncio_read_bcast_serial (fsnowoptics, 'ext_cff_mss_bcphil', ext_cff_mss_bc1) + + ! + ! BC species 2 Mie parameters + ! + CALL ncio_read_bcast_serial (fsnowoptics, 'ss_alb_bcphob', ss_alb_bc2) + CALL ncio_read_bcast_serial (fsnowoptics, 'asm_prm_bcphob', asm_prm_bc2) + CALL ncio_read_bcast_serial (fsnowoptics, 'ext_cff_mss_bcphob', ext_cff_mss_bc2) + ! #endif - ! - ! OC species 1 Mie parameters - CALL ncio_read_bcast_serial (fsnowoptics, 'ss_alb_ocphil', ss_alb_oc1) - CALL ncio_read_bcast_serial (fsnowoptics, 'asm_prm_ocphil', asm_prm_oc1) - CALL ncio_read_bcast_serial (fsnowoptics, 'ext_cff_mss_ocphil', ext_cff_mss_oc1) - ! - ! OC species 2 Mie parameters - CALL ncio_read_bcast_serial (fsnowoptics, 'ss_alb_ocphob', ss_alb_oc2) - CALL ncio_read_bcast_serial (fsnowoptics, 'asm_prm_ocphob', asm_prm_oc2) - CALL ncio_read_bcast_serial (fsnowoptics, 'ext_cff_mss_ocphob', ext_cff_mss_oc2) - ! - ! dust species 1 Mie parameters - CALL ncio_read_bcast_serial (fsnowoptics, 'ss_alb_dust01', ss_alb_dst1) - CALL ncio_read_bcast_serial (fsnowoptics, 'asm_prm_dust01', asm_prm_dst1) - CALL ncio_read_bcast_serial (fsnowoptics, 'ext_cff_mss_dust01', ext_cff_mss_dst1) - ! - ! dust species 2 Mie parameters - CALL ncio_read_bcast_serial (fsnowoptics, 'ss_alb_dust02', ss_alb_dst2) - CALL ncio_read_bcast_serial (fsnowoptics, 'asm_prm_dust02', asm_prm_dst2) - CALL ncio_read_bcast_serial (fsnowoptics, 'ext_cff_mss_dust02', ext_cff_mss_dst2) - ! - ! dust species 3 Mie parameters - CALL ncio_read_bcast_serial (fsnowoptics, 'ss_alb_dust03', ss_alb_dst3) - CALL ncio_read_bcast_serial (fsnowoptics, 'asm_prm_dust03', asm_prm_dst3) - CALL ncio_read_bcast_serial (fsnowoptics, 'ext_cff_mss_dust03', ext_cff_mss_dst3) - ! - ! dust species 4 Mie parameters - CALL ncio_read_bcast_serial (fsnowoptics, 'ss_alb_dust04', ss_alb_dst4) - CALL ncio_read_bcast_serial (fsnowoptics, 'asm_prm_dust04', asm_prm_dst4) - CALL ncio_read_bcast_serial (fsnowoptics, 'ext_cff_mss_dust04', ext_cff_mss_dst4) - ! - ! - - IF (p_is_master) THEN - write(iulog,*) 'Successfully read snow optical properties' - ENDIF - - - ! print some diagnostics: - IF (p_is_master) THEN - write (iulog,*) 'SNICAR: Mie single scatter albedos for direct-beam ice, rds=100um: ', & - ss_alb_snw_drc(71,1), ss_alb_snw_drc(71,2), ss_alb_snw_drc(71,3), & - ss_alb_snw_drc(71,4), ss_alb_snw_drc(71,5) - write (iulog,*) 'SNICAR: Mie single scatter albedos for diffuse ice, rds=100um: ', & - ss_alb_snw_dfs(71,1), ss_alb_snw_dfs(71,2), ss_alb_snw_dfs(71,3), & - ss_alb_snw_dfs(71,4), ss_alb_snw_dfs(71,5) - if (DO_SNO_OC) then - write (iulog,*) 'SNICAR: Including OC aerosols from snow radiative transfer calculations' - else - write (iulog,*) 'SNICAR: Excluding OC aerosols from snow radiative transfer calculations' - endif - ENDIF - ! + ! + ! OC species 1 Mie parameters + CALL ncio_read_bcast_serial (fsnowoptics, 'ss_alb_ocphil', ss_alb_oc1) + CALL ncio_read_bcast_serial (fsnowoptics, 'asm_prm_ocphil', asm_prm_oc1) + CALL ncio_read_bcast_serial (fsnowoptics, 'ext_cff_mss_ocphil', ext_cff_mss_oc1) + ! + ! OC species 2 Mie parameters + CALL ncio_read_bcast_serial (fsnowoptics, 'ss_alb_ocphob', ss_alb_oc2) + CALL ncio_read_bcast_serial (fsnowoptics, 'asm_prm_ocphob', asm_prm_oc2) + CALL ncio_read_bcast_serial (fsnowoptics, 'ext_cff_mss_ocphob', ext_cff_mss_oc2) + ! + ! dust species 1 Mie parameters + CALL ncio_read_bcast_serial (fsnowoptics, 'ss_alb_dust01', ss_alb_dst1) + CALL ncio_read_bcast_serial (fsnowoptics, 'asm_prm_dust01', asm_prm_dst1) + CALL ncio_read_bcast_serial (fsnowoptics, 'ext_cff_mss_dust01', ext_cff_mss_dst1) + ! + ! dust species 2 Mie parameters + CALL ncio_read_bcast_serial (fsnowoptics, 'ss_alb_dust02', ss_alb_dst2) + CALL ncio_read_bcast_serial (fsnowoptics, 'asm_prm_dust02', asm_prm_dst2) + CALL ncio_read_bcast_serial (fsnowoptics, 'ext_cff_mss_dust02', ext_cff_mss_dst2) + ! + ! dust species 3 Mie parameters + CALL ncio_read_bcast_serial (fsnowoptics, 'ss_alb_dust03', ss_alb_dst3) + CALL ncio_read_bcast_serial (fsnowoptics, 'asm_prm_dust03', asm_prm_dst3) + CALL ncio_read_bcast_serial (fsnowoptics, 'ext_cff_mss_dust03', ext_cff_mss_dst3) + ! + ! dust species 4 Mie parameters + CALL ncio_read_bcast_serial (fsnowoptics, 'ss_alb_dust04', ss_alb_dst4) + CALL ncio_read_bcast_serial (fsnowoptics, 'asm_prm_dust04', asm_prm_dst4) + CALL ncio_read_bcast_serial (fsnowoptics, 'ext_cff_mss_dust04', ext_cff_mss_dst4) + ! + ! + + IF (p_is_master) THEN + write(iulog,*) 'Successfully read snow optical properties' + ENDIF + + + ! print some diagnostics: + IF (p_is_master) THEN + write (iulog,*) 'SNICAR: Mie single scatter albedos for direct-beam ice, rds=100um: ', & + ss_alb_snw_drc(71,1), ss_alb_snw_drc(71,2), ss_alb_snw_drc(71,3), & + ss_alb_snw_drc(71,4), ss_alb_snw_drc(71,5) + write (iulog,*) 'SNICAR: Mie single scatter albedos for diffuse ice, rds=100um: ', & + ss_alb_snw_dfs(71,1), ss_alb_snw_dfs(71,2), ss_alb_snw_dfs(71,3), & + ss_alb_snw_dfs(71,4), ss_alb_snw_dfs(71,5) + IF (DO_SNO_OC) THEN + write (iulog,*) 'SNICAR: Including OC aerosols from snow radiative transfer calculations' + ELSE + write (iulog,*) 'SNICAR: Excluding OC aerosols from snow radiative transfer calculations' + ENDIF + ENDIF + ! #ifdef MODAL_AER - IF (p_is_master) THEN - ! unique dimensionality for modal aerosol optical properties - write (iulog,*) 'SNICAR: Subset of Mie single scatter albedos for BC: ', & - ss_alb_bc1(1,1), ss_alb_bc1(1,2), ss_alb_bc1(2,1), ss_alb_bc1(5,1), ss_alb_bc1(1,10), ss_alb_bc2(1,10) - write (iulog,*) 'SNICAR: Subset of Mie mass extinction coefficients for BC: ', & - ext_cff_mss_bc2(1,1), ext_cff_mss_bc2(1,2), ext_cff_mss_bc2(2,1), ext_cff_mss_bc2(5,1), ext_cff_mss_bc2(1,10),& - ext_cff_mss_bc1(1,10) - write (iulog,*) 'SNICAR: Subset of Mie asymmetry parameters for BC: ', & - asm_prm_bc1(1,1), asm_prm_bc1(1,2), asm_prm_bc1(2,1), asm_prm_bc1(5,1), asm_prm_bc1(1,10), asm_prm_bc2(1,10) - write (iulog,*) 'SNICAR: Subset of BC absorption enhancement factors: ', & - bcenh(1,1,1), bcenh(1,2,1), bcenh(1,1,2), bcenh(2,1,1), bcenh(5,10,1), bcenh(5,1,8), bcenh(5,10,8) - ENDIF + IF (p_is_master) THEN + ! unique dimensionality for modal aerosol optical properties + write (iulog,*) 'SNICAR: Subset of Mie single scatter albedos for BC: ', & + ss_alb_bc1(1,1), ss_alb_bc1(1,2), ss_alb_bc1(2,1), ss_alb_bc1(5,1), ss_alb_bc1(1,10), ss_alb_bc2(1,10) + write (iulog,*) 'SNICAR: Subset of Mie mass extinction coefficients for BC: ', & + ext_cff_mss_bc2(1,1), ext_cff_mss_bc2(1,2), ext_cff_mss_bc2(2,1), ext_cff_mss_bc2(5,1), ext_cff_mss_bc2(1,10),& + ext_cff_mss_bc1(1,10) + write (iulog,*) 'SNICAR: Subset of Mie asymmetry parameters for BC: ', & + asm_prm_bc1(1,1), asm_prm_bc1(1,2), asm_prm_bc1(2,1), asm_prm_bc1(5,1), asm_prm_bc1(1,10), asm_prm_bc2(1,10) + write (iulog,*) 'SNICAR: Subset of BC absorption enhancement factors: ', & + bcenh(1,1,1), bcenh(1,2,1), bcenh(1,1,2), bcenh(2,1,1), bcenh(5,10,1), bcenh(5,1,8), bcenh(5,10,8) + ENDIF #else - IF (p_is_master) THEN - write (iulog,*) 'SNICAR: Mie single scatter albedos for hydrophillic BC: ', & - ss_alb_bc1(1), ss_alb_bc1(2), ss_alb_bc1(3), ss_alb_bc1(4), ss_alb_bc1(5) - write (iulog,*) 'SNICAR: Mie single scatter albedos for hydrophobic BC: ', & - ss_alb_bc2(1), ss_alb_bc2(2), ss_alb_bc2(3), ss_alb_bc2(4), ss_alb_bc2(5) - ENDIF + IF (p_is_master) THEN + write (iulog,*) 'SNICAR: Mie single scatter albedos for hydrophillic BC: ', & + ss_alb_bc1(1), ss_alb_bc1(2), ss_alb_bc1(3), ss_alb_bc1(4), ss_alb_bc1(5) + write (iulog,*) 'SNICAR: Mie single scatter albedos for hydrophobic BC: ', & + ss_alb_bc2(1), ss_alb_bc2(2), ss_alb_bc2(3), ss_alb_bc2(4), ss_alb_bc2(5) + ENDIF #endif - IF (p_is_master) THEN - if (DO_SNO_OC) then - write (iulog,*) 'SNICAR: Mie single scatter albedos for hydrophillic OC: ', & - ss_alb_oc1(1), ss_alb_oc1(2), ss_alb_oc1(3), ss_alb_oc1(4), ss_alb_oc1(5) - write (iulog,*) 'SNICAR: Mie single scatter albedos for hydrophobic OC: ', & - ss_alb_oc2(1), ss_alb_oc2(2), ss_alb_oc2(3), ss_alb_oc2(4), ss_alb_oc2(5) - endif - - write (iulog,*) 'SNICAR: Mie single scatter albedos for dust species 1: ', & - ss_alb_dst1(1), ss_alb_dst1(2), ss_alb_dst1(3), ss_alb_dst1(4), ss_alb_dst1(5) - write (iulog,*) 'SNICAR: Mie single scatter albedos for dust species 2: ', & - ss_alb_dst2(1), ss_alb_dst2(2), ss_alb_dst2(3), ss_alb_dst2(4), ss_alb_dst2(5) - write (iulog,*) 'SNICAR: Mie single scatter albedos for dust species 3: ', & - ss_alb_dst3(1), ss_alb_dst3(2), ss_alb_dst3(3), ss_alb_dst3(4), ss_alb_dst3(5) - write (iulog,*) 'SNICAR: Mie single scatter albedos for dust species 4: ', & - ss_alb_dst4(1), ss_alb_dst4(2), ss_alb_dst4(3), ss_alb_dst4(4), ss_alb_dst4(5) - write(iulog,*) - ENDIF - - end subroutine SnowOptics_init - !----------------------------------------------------------------------- - - - subroutine SnowAge_init( fsnowaging ) - - USE MOD_NetCDFSerial - - IMPLICIT NONE - - character(len=256), intent(in) :: fsnowaging ! snow aging parameters file name - character(len= 32) :: subname = 'SnowAge_init' ! subroutine name - ! - ! Open snow aging (effective radius evolution) file: - IF (p_is_master) THEN - write(iulog,*) 'Attempting to read snow aging parameters .....' - write(iulog,*) subname,trim(fsnowaging) - ENDIF - - ! - ! SNOW aging parameters - ! - CALL ncio_read_bcast_serial (fsnowaging, 'tau', snowage_tau) - CALL ncio_read_bcast_serial (fsnowaging, 'kappa', snowage_kappa) - CALL ncio_read_bcast_serial (fsnowaging, 'drdsdt0', snowage_drdt0) - - ! - IF (p_is_master) THEN - write(iulog,*) 'Successfully read snow aging properties' - ENDIF - ! - ! print some diagnostics: - IF (p_is_master) THEN - write (iulog,*) 'SNICAR: snowage tau for T=263K, dTdz = 100 K/m, rhos = 150 kg/m3: ', snowage_tau(3,11,9) - write (iulog,*) 'SNICAR: snowage kappa for T=263K, dTdz = 100 K/m, rhos = 150 kg/m3: ', snowage_kappa(3,11,9) - write (iulog,*) 'SNICAR: snowage dr/dt_0 for T=263K, dTdz = 100 K/m, rhos = 150 kg/m3: ', snowage_drdt0(3,11,9) - ENDIF - - - end subroutine SnowAge_init - !----------------------------------------------------------------------- - - - real(r8) function FreshSnowRadius (forc_t) - ! - ! !DESCRIPTION: - ! Returns fresh snow grain radius, which is linearly dependent on temperature. - ! This is implemented to remedy an outstanding bias that SNICAR has in initial - ! grain size. See e.g. Sandells et al, 2017 for a discussion (10.5194/tc-11-229-2017). - ! - ! Yang et al. (2017), 10.1016/j.jqsrt.2016.03.033 - ! discusses grain size observations, which suggest a temperature dependence. - ! - ! !REVISION HISTORY: - ! Author: Leo VanKampenhout - ! - ! !USES: - USE MOD_Const_Physical, only: tfrz - use MOD_Aerosol, only: fresh_snw_rds_max - - ! !ARGUMENTS: - real(r8), intent(in) :: forc_t ! atmospheric temperature (Kelvin) - ! - ! !LOCAL VARIABLES: - !----------------------------------------------------------------------- - real(r8), parameter :: tmin = tfrz - 30._r8 ! start of linear ramp - real(r8), parameter :: tmax = tfrz - 0._r8 ! end of linear ramp - real(r8), parameter :: gs_min = snw_rds_min ! minimum value - real(r8) :: gs_max ! maximum value - - if ( fresh_snw_rds_max <= snw_rds_min )then - FreshSnowRadius = snw_rds_min - else - gs_max = fresh_snw_rds_max - - if (forc_t < tmin) then - FreshSnowRadius = gs_min - else if (forc_t > tmax) then - FreshSnowRadius = gs_max - else - FreshSnowRadius = (tmax-forc_t)/(tmax-tmin)*gs_min + & - (forc_t-tmin)/(tmax-tmin)*gs_max - end if - end if - - end function FreshSnowRadius + IF (p_is_master) THEN + IF (DO_SNO_OC) THEN + write (iulog,*) 'SNICAR: Mie single scatter albedos for hydrophillic OC: ', & + ss_alb_oc1(1), ss_alb_oc1(2), ss_alb_oc1(3), ss_alb_oc1(4), ss_alb_oc1(5) + write (iulog,*) 'SNICAR: Mie single scatter albedos for hydrophobic OC: ', & + ss_alb_oc2(1), ss_alb_oc2(2), ss_alb_oc2(3), ss_alb_oc2(4), ss_alb_oc2(5) + ENDIF + + write (iulog,*) 'SNICAR: Mie single scatter albedos for dust species 1: ', & + ss_alb_dst1(1), ss_alb_dst1(2), ss_alb_dst1(3), ss_alb_dst1(4), ss_alb_dst1(5) + write (iulog,*) 'SNICAR: Mie single scatter albedos for dust species 2: ', & + ss_alb_dst2(1), ss_alb_dst2(2), ss_alb_dst2(3), ss_alb_dst2(4), ss_alb_dst2(5) + write (iulog,*) 'SNICAR: Mie single scatter albedos for dust species 3: ', & + ss_alb_dst3(1), ss_alb_dst3(2), ss_alb_dst3(3), ss_alb_dst3(4), ss_alb_dst3(5) + write (iulog,*) 'SNICAR: Mie single scatter albedos for dust species 4: ', & + ss_alb_dst4(1), ss_alb_dst4(2), ss_alb_dst4(3), ss_alb_dst4(4), ss_alb_dst4(5) + write(iulog,*) + ENDIF + + END SUBROUTINE SnowOptics_init + !----------------------------------------------------------------------- + + + SUBROUTINE SnowAge_init( fsnowaging ) + + USE MOD_NetCDFSerial + + IMPLICIT NONE + + character(len=256), intent(in) :: fsnowaging ! snow aging parameters file name + character(len= 32) :: subname = 'SnowAge_init' ! SUBROUTINE name + ! + ! Open snow aging (effective radius evolution) file: + IF (p_is_master) THEN + write(iulog,*) 'Attempting to read snow aging parameters .....' + write(iulog,*) subname,trim(fsnowaging) + ENDIF + + ! + ! SNOW aging parameters + ! + CALL ncio_read_bcast_serial (fsnowaging, 'tau', snowage_tau) + CALL ncio_read_bcast_serial (fsnowaging, 'kappa', snowage_kappa) + CALL ncio_read_bcast_serial (fsnowaging, 'drdsdt0', snowage_drdt0) + + ! + IF (p_is_master) THEN + write(iulog,*) 'Successfully read snow aging properties' + ENDIF + ! + ! print some diagnostics: + IF (p_is_master) THEN + write (iulog,*) 'SNICAR: snowage tau for T=263K, dTdz = 100 K/m, rhos = 150 kg/m3: ', snowage_tau(3,11,9) + write (iulog,*) 'SNICAR: snowage kappa for T=263K, dTdz = 100 K/m, rhos = 150 kg/m3: ', snowage_kappa(3,11,9) + write (iulog,*) 'SNICAR: snowage dr/dt_0 for T=263K, dTdz = 100 K/m, rhos = 150 kg/m3: ', snowage_drdt0(3,11,9) + ENDIF + END SUBROUTINE SnowAge_init + !----------------------------------------------------------------------- + + + real(r8) FUNCTION FreshSnowRadius (forc_t) + ! + ! !DESCRIPTION: + ! Returns fresh snow grain radius, which is linearly dependent on temperature. + ! This is implemented to remedy an outstanding bias that SNICAR has in initial + ! grain size. See e.g. Sandells et al, 2017 for a discussion (10.5194/tc-11-229-2017). + ! + ! Yang et al. (2017), 10.1016/j.jqsrt.2016.03.033 + ! discusses grain size observations, which suggest a temperature dependence. + ! + ! !REVISION HISTORY: + ! Author: Leo VanKampenhout + ! + ! !USES: + USE MOD_Const_Physical, only: tfrz + USE MOD_Aerosol, only: fresh_snw_rds_max + + ! !ARGUMENTS: + real(r8), intent(in) :: forc_t ! atmospheric temperature (Kelvin) + ! + ! !LOCAL VARIABLES: + !----------------------------------------------------------------------- + real(r8), parameter :: tmin = tfrz - 30._r8 ! start of linear ramp + real(r8), parameter :: tmax = tfrz - 0._r8 ! END of linear ramp + real(r8), parameter :: gs_min = snw_rds_min ! minimum value + real(r8) :: gs_max ! maximum value + + IF ( fresh_snw_rds_max <= snw_rds_min )THEN + FreshSnowRadius = snw_rds_min + ELSE + gs_max = fresh_snw_rds_max + + IF (forc_t < tmin) THEN + FreshSnowRadius = gs_min + ELSE IF (forc_t > tmax) THEN + FreshSnowRadius = gs_max + ELSE + FreshSnowRadius = (tmax-forc_t)/(tmax-tmin)*gs_min + & + (forc_t-tmin)/(tmax-tmin)*gs_max + END IF + END IF + + END FUNCTION FreshSnowRadius END MODULE MOD_SnowSnicar diff --git a/main/MOD_SoilSurfaceResistance.F90 b/main/MOD_SoilSurfaceResistance.F90 index c464b5c8..117dd1b2 100644 --- a/main/MOD_SoilSurfaceResistance.F90 +++ b/main/MOD_SoilSurfaceResistance.F90 @@ -1,16 +1,16 @@ #include MODULE MOD_SoilSurfaceResistance - ! ----------------------------------------------------------------------- - ! !DESCRIPTION: - ! Calculate the soil surface resistance with multiple parameterization schemes - ! - ! Created by Zhuo Liu and Hua Yuan, 06/2023 - ! - ! !REVISIONS: - ! - ! ----------------------------------------------------------------------- - ! !USE +! ----------------------------------------------------------------------- +! !DESCRIPTION: +! Calculate the soil surface resistance with multiple parameterization schemes +! +! Created by Zhuo Liu and Hua Yuan, 06/2023 +! +! !REVISIONS: +! +! ----------------------------------------------------------------------- +! !USE USE MOD_Precision IMPLICIT NONE @@ -36,27 +36,27 @@ MODULE MOD_SoilSurfaceResistance CONTAINS !----------------------------------------------------------------------- - SUBROUTINE SoilSurfaceResistance (nl_soil,forc_rhoair,hksati,porsl,psi0, & + SUBROUTINE SoilSurfaceResistance (nl_soil,forc_rhoair,hksati,porsl,psi0, & #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_soisno,t_soisno,wliq_soisno,wice_soisno,fsno,qg,rss) - - !======================================================================= - ! !DESCRIPTION: - ! Main SUBROUTINE to CALL soil resistance model - ! - Options for soil surface resistance schemes - ! 1: SL14, Swenson and Lawrence (2014) - ! 2: SZ09, Sakaguchi and Zeng (2009) - ! 3: TR13, Tang and Riley (2013) - ! 4: LP92, Lee and Pielke (1992) - ! 5: S92, Sellers et al (1992) - ! - ! NOTE: Support for both Campbell and VG soil parameters. - !======================================================================= + dz_soisno,t_soisno,wliq_soisno,wice_soisno,fsno,qg,rss) + +!======================================================================= +! !DESCRIPTION: +! Main SUBROUTINE to CALL soil resistance model +! - Options for soil surface resistance schemes +! 1: SL14, Swenson and Lawrence (2014) +! 2: SZ09, Sakaguchi and Zeng (2009) +! 3: TR13, Tang and Riley (2013) +! 4: LP92, Lee and Pielke (1992) +! 5: S92, Sellers et al (1992) +! +! NOTE: Support for both Campbell and VG soil parameters. +!======================================================================= USE MOD_Precision USE MOD_Const_Physical, only: denice, denh2o @@ -126,188 +126,188 @@ SUBROUTINE SoilSurfaceResistance (nl_soil,forc_rhoair,hksati,porsl,psi0, & !-----------------------End Variables list--------------------------- - ! calculate the top soil volumetric water content (m3/m3), soil matrix potential - ! and soil hydraulic conductivity - vol_liq = max(wliq_soisno(1),1.0e-6_r8)/(denh2o*dz_soisno(1)) - s_node = min(1., vol_liq/porsl(1)) + ! calculate the top soil volumetric water content (m3/m3), soil matrix potential + ! and soil hydraulic conductivity + vol_liq = max(wliq_soisno(1),1.0e-6_r8)/(denh2o*dz_soisno(1)) + s_node = min(1., vol_liq/porsl(1)) - ! calculate effective soil porosity - eff_porosity = max(0.01_r8,porsl(1)-min(porsl(1), wice_soisno(1)/(dz_soisno(1)*denice))) + ! calculate effective soil porosity + eff_porosity = max(0.01_r8,porsl(1)-min(porsl(1), wice_soisno(1)/(dz_soisno(1)*denice))) #ifdef Campbell_SOIL_MODEL - smp_node = (psi0(1)/1000.)*s_node**(-bsw(1)) - hk = (hksati(1)/1000.)*(vol_liq/porsl(1))**(2.*bsw(1)+3.) + smp_node = (psi0(1)/1000.)*s_node**(-bsw(1)) + hk = (hksati(1)/1000.)*(vol_liq/porsl(1))**(2.*bsw(1)+3.) - ! calculate air free pore space - aird = porsl(1)*(psi0(1)/-1.e7_r8)**(1./bsw(1)) + ! calculate air free pore space + aird = porsl(1)*(psi0(1)/-1.e7_r8)**(1./bsw(1)) #endif #ifdef vanGenuchten_Mualem_SOIL_MODEL - smp_node = soil_psi_from_vliq (s_node*(porsl(1)-theta_r(1)) + theta_r(1), & - porsl(1), theta_r(1), psi0(1), & - 5, (/alpha_vgm(1), n_vgm(1), L_vgm(1), sc_vgm(1), fc_vgm(1)/)) - hk = soil_hk_from_psi (smp_node, psi0(1), hksati(1), & - 5, (/alpha_vgm(1), n_vgm(1), L_vgm(1), sc_vgm(1), fc_vgm(1)/)) + smp_node = soil_psi_from_vliq (s_node*(porsl(1)-theta_r(1)) + theta_r(1), & + porsl(1), theta_r(1), psi0(1), & + 5, (/alpha_vgm(1), n_vgm(1), L_vgm(1), sc_vgm(1), fc_vgm(1)/)) + hk = soil_hk_from_psi (smp_node, psi0(1), hksati(1), & + 5, (/alpha_vgm(1), n_vgm(1), L_vgm(1), sc_vgm(1), fc_vgm(1)/)) - smp_node = smp_node/1000. - hk = hk/1000. + smp_node = smp_node/1000. + hk = hk/1000. - ! calculate air free pore space - aird = soil_vliq_from_psi (-1.e7_r8, porsl(1), theta_r(1), psi0(1), & + ! calculate air free pore space + aird = soil_vliq_from_psi (-1.e7_r8, porsl(1), theta_r(1), psi0(1), & 5, (/alpha_vgm(1), n_vgm(1), L_vgm(1), sc_vgm(1), fc_vgm(1)/)) #endif - ! D0 : 2.12e-5 unit: m2 s-1 - ! ref1: CLM5 Documentation formula (5.81) - ! ref2: Sakaguchi and Zeng, 2009 - ! ref3: Tang and Riley, 2013. Figure 2, 3, 4, and 5. - d0 = 2.12e-5*(t_soisno(1)/273.15)**1.75 - eps = porsl(1) - aird + ! D0 : 2.12e-5 unit: m2 s-1 + ! ref1: CLM5 Documentation formula (5.81) + ! ref2: Sakaguchi and Zeng, 2009 + ! ref3: Tang and Riley, 2013. Figure 2, 3, 4, and 5. + d0 = 2.12e-5*(t_soisno(1)/273.15)**1.75 + eps = porsl(1) - aird - SELECTCASE (soil_gas_diffusivity_scheme) + SELECTCASE (soil_gas_diffusivity_scheme) - ! 1: BBC - CASE (1) + ! 1: BBC + CASE (1) #ifdef Campbell_SOIL_MODEL - tao = eps*eps*(eps/porsl(1))**(3._r8/max(3._r8,bsw(1))) + tao = eps*eps*(eps/porsl(1))**(3._r8/max(3._r8,bsw(1))) #endif - ! 2: P_WLR - CASE (2) - tao = 0.66*eps*(eps/porsl(1)) + ! 2: P_WLR + CASE (2) + tao = 0.66*eps*(eps/porsl(1)) - ! 3: MI_WLR - CASE (3) - tao = eps**(4._r8/3._r8)*(eps/porsl(1)) + ! 3: MI_WLR + CASE (3) + tao = eps**(4._r8/3._r8)*(eps/porsl(1)) - ! 4: MA_WLR - CASE (4) - tao = eps**(3./2.)*(eps/porsl(1)) + ! 4: MA_WLR + CASE (4) + tao = eps**(3./2.)*(eps/porsl(1)) - ! 5: M_Q - CASE (5) - tao = eps**(4._r8/3._r8)*(eps/porsl(1))**(2.0_r8) + ! 5: M_Q + CASE (5) + tao = eps**(4._r8/3._r8)*(eps/porsl(1))**(2.0_r8) - ! 6: 3POE - CASE (6) + ! 6: 3POE + CASE (6) #ifdef Campbell_SOIL_MODEL - eps100 = porsl(1) - porsl(1)*(psi0(1)/-1000.)**(1./bsw(1)) + eps100 = porsl(1) - porsl(1)*(psi0(1)/-1000.)**(1./bsw(1)) #endif #ifdef vanGenuchten_Mualem_SOIL_MODEL - eps100 = porsl(1) - soil_vliq_from_psi (-1000., porsl(1), theta_r(1), psi0(1), & - 5, (/alpha_vgm(1), n_vgm(1), L_vgm(1), sc_vgm(1), fc_vgm(1)/)) + eps100 = porsl(1) - soil_vliq_from_psi (-1000., porsl(1), theta_r(1), psi0(1), & + 5, (/alpha_vgm(1), n_vgm(1), L_vgm(1), sc_vgm(1), fc_vgm(1)/)) #endif - tao = porsl(1)*porsl(1)*(eps/porsl(1))**(2.+log(eps100**0.25_r8)/log(eps100/porsl(1))) + tao = porsl(1)*porsl(1)*(eps/porsl(1))**(2.+log(eps100**0.25_r8)/log(eps100/porsl(1))) - ENDSELECT + ENDSELECT - ! calculate gas and water diffusivity (dg and dw) - dg = d0*tao + ! calculate gas and water diffusivity (dg and dw) + dg = d0*tao - !NOTE: dw is only for TR13 scheme + !NOTE: dw is only for TR13 scheme #ifdef Campbell_SOIL_MODEL - ! TR13, Eq.(A5): - dw = -hk*bsw(1)*smp_node/vol_liq + ! TR13, Eq.(A5): + dw = -hk*bsw(1)*smp_node/vol_liq #endif #ifdef vanGenuchten_Mualem_SOIL_MODEL - ! TR13, Eqs. (A2), (A7), (A8) and (A10): - ! dw = -hk*(m-1)/(k*m*(theta_s-theta_r))*S**(-1/m)*(1-S**(1/m))**(-m) - ! where k=alpha_vgm, S=(1+(-k*smp_node)**(n))**(-m), m=m_vgm=1-1/n_vgm - m_vgm = 1. - 1./n_vgm(1) - S = (1. + (- alpha_vgm(1)*smp_node)**(n_vgm(1)))**(-m_vgm) - dw = -hk*(m_vgm-1.)/(alpha_vgm(1)*m_vgm*(porsl(1)-theta_r(1))) & - * S**(-1./m_vgm)*(1.-S**(1./m_vgm))**(-m_vgm) + ! TR13, Eqs. (A2), (A7), (A8) and (A10): + ! dw = -hk*(m-1)/(k*m*(theta_s-theta_r))*S**(-1/m)*(1-S**(1/m))**(-m) + ! where k=alpha_vgm, S=(1+(-k*smp_node)**(n))**(-m), m=m_vgm=1-1/n_vgm + m_vgm = 1. - 1./n_vgm(1) + S = (1. + (- alpha_vgm(1)*smp_node)**(n_vgm(1)))**(-m_vgm) + dw = -hk*(m_vgm-1.)/(alpha_vgm(1)*m_vgm*(porsl(1)-theta_r(1))) & + * S**(-1./m_vgm)*(1.-S**(1./m_vgm))**(-m_vgm) #endif - SELECTCASE (DEF_RSS_SCHEME) - - ! calculate rss by SL14 - CASE (1) - dsl = dz_soisno(1)*max(1.e-6_r8,(0.8*eff_porosity - vol_liq)) & - /max(1.e-6_r8,(0.8*porsl(1)- aird)) - - dsl = max(dsl,0._r8) - dsl = min(dsl,0.2_r8) - - rss = dsl/dg - !fordebug only - !write(*,*) dsl, dg, aird, vol_liq/porsl(1), eff_porosity, wice_soisno(1),vol_liq, rss - - ! calculate rss by SZ09 - CASE (2) - dsl = dz_soisno(1)*(exp((1._r8 - vol_liq/porsl(1))**5) - 1._r8)/ (exp(1._r8) - 1._r8) - dsl = min(dsl,0.2_r8) - dsl = max(dsl,0._r8) - - rss = dsl/dg - - ! calculate rss by TR13 - CASE (3) - ! TR13, Eq. (11) and Eq. (12): - B = denh2o/(qg*forc_rhoair) - ! TR13, Eq. (13): - rg_1 = 2.0_r8*dg*eps/dz_soisno(1) - rw_1 = 2.0_r8*dw*B*vol_liq/dz_soisno(1) - rss_1 = rg_1 + rw_1 - rss = 1.0/rss_1 - - ! LP92 beta scheme - CASE (4) - wx = (max(wliq_soisno(1),1.e-6)/denh2o+wice_soisno(1)/denice)/dz_soisno(1) - fac = min(1._r8, wx/porsl(1)) - fac = max(fac , 0.001_r8) + SELECTCASE (DEF_RSS_SCHEME) + + ! calculate rss by SL14 + CASE (1) + dsl = dz_soisno(1)*max(1.e-6_r8,(0.8*eff_porosity - vol_liq)) & + /max(1.e-6_r8,(0.8*porsl(1)- aird)) + + dsl = max(dsl,0._r8) + dsl = min(dsl,0.2_r8) + + rss = dsl/dg + !fordebug only + !write(*,*) dsl, dg, aird, vol_liq/porsl(1), eff_porosity, wice_soisno(1),vol_liq, rss + + ! calculate rss by SZ09 + CASE (2) + dsl = dz_soisno(1)*(exp((1._r8 - vol_liq/porsl(1))**5) - 1._r8)/ (exp(1._r8) - 1._r8) + dsl = min(dsl,0.2_r8) + dsl = max(dsl,0._r8) + + rss = dsl/dg + + ! calculate rss by TR13 + CASE (3) + ! TR13, Eq. (11) and Eq. (12): + B = denh2o/(qg*forc_rhoair) + ! TR13, Eq. (13): + rg_1 = 2.0_r8*dg*eps/dz_soisno(1) + rw_1 = 2.0_r8*dw*B*vol_liq/dz_soisno(1) + rss_1 = rg_1 + rw_1 + rss = 1.0/rss_1 + + ! LP92 beta scheme + CASE (4) + wx = (max(wliq_soisno(1),1.e-6)/denh2o+wice_soisno(1)/denice)/dz_soisno(1) + fac = min(1._r8, wx/porsl(1)) + fac = max(fac , 0.001_r8) #ifdef Campbell_SOIL_MODEL - wfc = porsl(1)*(0.1/(86400.*hksati(1)))**(1./(2.*bsw(1)+3.)) - !NOTE: CoLM wfc = (-339.9/soil_psi_s_l(ipatch))**(-1.0*soil_lambda_l(ipatch)) * soil_theta_s_l(ipatch) - !wfc = porsl(1)*(-3399._r8/psi0(1))**(-1./bsw(1)) + wfc = porsl(1)*(0.1/(86400.*hksati(1)))**(1./(2.*bsw(1)+3.)) + !NOTE: CoLM wfc = (-339.9/soil_psi_s_l(ipatch))**(-1.0*soil_lambda_l(ipatch)) * soil_theta_s_l(ipatch) + !wfc = porsl(1)*(-3399._r8/psi0(1))**(-1./bsw(1)) #endif #ifdef vanGenuchten_Mualem_SOIL_MODEL - wfc = theta_r(1)+(porsl(1)-theta_r(1))*(1+(alpha_vgm(1)*339.9)**n_vgm(1))**(1.0/n_vgm(1)-1) + wfc = theta_r(1)+(porsl(1)-theta_r(1))*(1+(alpha_vgm(1)*339.9)**n_vgm(1))**(1.0/n_vgm(1)-1) #endif - !write(*,*) wfc !fordebug only - - ! Lee and Pielke 1992 beta - IF (wx < wfc ) THEN !when water content of ths top layer is less than that at F.C. - fac_fc = min(1._r8, wx/wfc) - fac_fc = max(fac_fc,0.001_r8) - rss = 0.25_r8*(1._r8 - cos(fac_fc*3.1415926))**2._r8 - ELSE !when water content of ths top layer is more than that at F.C. - rss = 1._r8 + !write(*,*) wfc !fordebug only + + ! Lee and Pielke 1992 beta + IF (wx < wfc ) THEN !when water content of ths top layer is less than that at F.C. + fac_fc = min(1._r8, wx/wfc) + fac_fc = max(fac_fc,0.001_r8) + rss = 0.25_r8*(1._r8 - cos(fac_fc*3.1415926))**2._r8 + ELSE !when water content of ths top layer is more than that at F.C. + rss = 1._r8 + ENDIF + + ! Sellers, 1992 + CASE (5) + wx = (max(wliq_soisno(1),1.e-6)/denh2o+wice_soisno(1)/denice)/dz_soisno(1) + fac = min(1._r8, wx/porsl(1)) + fac = max(fac , 0.001_r8) + !rss = exp(8.206-4.255*fac) !original Sellers (1992) + rss = exp(8.206-6.0*fac) !adjusted Sellers (1992) to decrease rss + !for wet soil according to Noah-MP v5 + ENDSELECT + + ! account for snow fractional cover for rss + IF (DEF_RSS_SCHEME .ne. 4) THEN + ! with 1/rss = fsno/rss_snow + (1-fsno)/rss_soil, + ! assuming rss_snow = 1, so rss is calibrated as: + IF (1.-fsno+fsno*rss > 0.) THEN + rss = rss / (1.-fsno+fsno*rss) + ELSE + rss = 0. + ENDIF + rss = min(1.e6_r8,rss) ENDIF - ! Sellers, 1992 - CASE (5) - wx = (max(wliq_soisno(1),1.e-6)/denh2o+wice_soisno(1)/denice)/dz_soisno(1) - fac = min(1._r8, wx/porsl(1)) - fac = max(fac , 0.001_r8) - !rss = exp(8.206-4.255*fac) !original Sellers (1992) - rss = exp(8.206-6.0*fac) !adjusted Sellers (1992) to decrease rss - !for wet soil according to Noah-MP v5 - ENDSELECT - - ! account for snow fractional cover for rss - IF (DEF_RSS_SCHEME .ne. 4) THEN - ! with 1/rss = fsno/rss_snow + (1-fsno)/rss_soil, - ! assuming rss_snow = 1, so rss is calibrated as: - IF (1.-fsno+fsno*rss > 0.) THEN - rss = rss / (1.-fsno+fsno*rss) - ELSE - rss = 0. + ! account for snow fractional cover for LP92 beta scheme + !NOTE: rss here is for soil beta value + IF (DEF_RSS_SCHEME .eq. 4) THEN + ! modify soil beta by snow cover, assuming soil beta for snow surface is 1. + rss = (1.-fsno)*rss + fsno ENDIF - rss = min(1.e6_r8,rss) - ENDIF - - ! account for snow fractional cover for LP92 beta scheme - !NOTE: rss here is for soil beta value - IF (DEF_RSS_SCHEME .eq. 4) THEN - ! modify soil beta by snow cover, assuming soil beta for snow surface is 1. - rss = (1.-fsno)*rss + fsno - ENDIF - END Subroutine SoilSurfaceResistance + END Subroutine SoilSurfaceResistance END MODULE MOD_SoilSurfaceResistance diff --git a/main/MOD_Thermal.F90 b/main/MOD_Thermal.F90 index 505d5a96..eed29f0c 100644 --- a/main/MOD_Thermal.F90 +++ b/main/MOD_Thermal.F90 @@ -3,74 +3,74 @@ MODULE MOD_Thermal !----------------------------------------------------------------------- - USE MOD_Precision - IMPLICIT NONE - SAVE + USE MOD_Precision + IMPLICIT NONE + SAVE ! PUBLIC MEMBER FUNCTIONS: - PUBLIC :: THERMAL + PUBLIC :: THERMAL !----------------------------------------------------------------------- - CONTAINS +CONTAINS !----------------------------------------------------------------------- - SUBROUTINE THERMAL (ipatch ,patchtype ,lb ,deltim ,& - trsmx0 ,zlnd ,zsno ,csoilc ,& - dewmx ,capr ,cnfac ,vf_quartz ,& - vf_gravels ,vf_om ,vf_sand ,wf_gravels ,& - wf_sand ,csol ,porsl ,psi0 ,& + SUBROUTINE THERMAL (ipatch ,patchtype ,lb ,deltim ,& + trsmx0 ,zlnd ,zsno ,csoilc ,& + dewmx ,capr ,cnfac ,vf_quartz ,& + vf_gravels ,vf_om ,vf_sand ,wf_gravels ,& + wf_sand ,csol ,porsl ,psi0 ,& #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 - k_solids ,dksatu ,dksatf ,dkdry ,& - BA_alpha ,BA_beta ,& - lai ,laisun ,laisha ,& - sai ,htop ,hbot ,sqrtdi ,& - rootfr ,rstfacsun_out,rstfacsha_out,rss ,& - gssun_out ,gssha_out ,& - assimsun_out,etrsun_out ,assimsha_out,etrsha_out ,& + k_solids ,dksatu ,dksatf ,dkdry ,& + BA_alpha ,BA_beta ,& + lai ,laisun ,laisha ,& + sai ,htop ,hbot ,sqrtdi ,& + rootfr ,rstfacsun_out,rstfacsha_out,rss ,& + gssun_out ,gssha_out ,& + assimsun_out,etrsun_out ,assimsha_out,etrsha_out ,& !photosynthesis and plant hydraulic variables - effcon ,vmax25 ,hksati ,smp ,hk,& - kmax_sun ,kmax_sha ,kmax_xyl ,kmax_root ,& - psi50_sun ,psi50_sha ,psi50_xyl ,psi50_root ,& - ck ,vegwp ,gs0sun ,gs0sha ,& + effcon ,vmax25 ,hksati ,smp ,hk,& + kmax_sun ,kmax_sha ,kmax_xyl ,kmax_root ,& + psi50_sun ,psi50_sha ,psi50_xyl ,psi50_root ,& + ck ,vegwp ,gs0sun ,gs0sha ,& !Ozone stress variables - lai_old ,o3uptakesun ,o3uptakesha ,forc_ozone, & + lai_old ,o3uptakesun ,o3uptakesha ,forc_ozone, & !end ozone stress variables - slti ,hlti ,shti ,hhti ,& - trda ,trdm ,trop ,g1 ,& - g0 ,gradm ,binter ,extkn ,& - forc_hgt_u ,forc_hgt_t ,forc_hgt_q ,forc_us ,& - forc_vs ,forc_t ,forc_q ,forc_rhoair,& - forc_psrf ,forc_pco2m ,forc_hpbl ,& - forc_po2m ,coszen ,parsun ,parsha ,& - sabvsun ,sabvsha ,sabg,sabg_soil,sabg_snow,frl,& - extkb ,extkd ,thermk ,fsno ,& - sigf ,dz_soisno ,z_soisno ,zi_soisno ,& - tleaf ,t_soisno ,wice_soisno ,wliq_soisno,& - ldew,ldew_rain,ldew_snow ,scv,snowdp ,imelt ,& - taux ,tauy ,fsena ,fevpa ,& - lfevpa ,fsenl ,fevpl ,etr ,& - fseng ,fevpg ,olrg ,fgrnd ,& - rootr ,rootflux ,& - qseva ,qsdew ,qsubl ,qfros ,& - qseva_soil ,qsdew_soil ,qsubl_soil ,qfros_soil ,& - qseva_snow ,qsdew_snow ,qsubl_snow ,qfros_snow ,& - sm ,tref ,qref ,& - trad ,rst ,assim ,respc ,& - errore ,emis ,z0m ,zol ,& - rib ,ustar ,qstar ,tstar ,& - fm ,fh ,fq ,pg_rain ,& - pg_snow ,t_precip ,qintr_rain ,qintr_snow ,& - snofrz ,sabg_snow_lyr ) + slti ,hlti ,shti ,hhti ,& + trda ,trdm ,trop ,g1 ,& + g0 ,gradm ,binter ,extkn ,& + forc_hgt_u ,forc_hgt_t ,forc_hgt_q ,forc_us ,& + forc_vs ,forc_t ,forc_q ,forc_rhoair,& + forc_psrf ,forc_pco2m ,forc_hpbl ,forc_po2m ,& + coszen ,parsun ,parsha ,sabvsun ,& + sabvsha ,sabg,sabg_soil,sabg_snow ,frl ,& + extkb ,extkd ,thermk ,fsno ,& + sigf ,dz_soisno ,z_soisno ,zi_soisno ,& + tleaf ,t_soisno ,wice_soisno ,wliq_soisno,& + ldew,ldew_rain,ldew_snow ,scv,snowdp ,imelt ,& + taux ,tauy ,fsena ,fevpa ,& + lfevpa ,fsenl ,fevpl ,etr ,& + fseng ,fevpg ,olrg ,fgrnd ,& + rootr ,rootflux ,& + qseva ,qsdew ,qsubl ,qfros ,& + qseva_soil ,qsdew_soil ,qsubl_soil ,qfros_soil ,& + qseva_snow ,qsdew_snow ,qsubl_snow ,qfros_snow ,& + sm ,tref ,qref ,& + trad ,rst ,assim ,respc ,& + errore ,emis ,z0m ,zol ,& + rib ,ustar ,qstar ,tstar ,& + fm ,fh ,fq ,pg_rain ,& + pg_snow ,t_precip ,qintr_rain ,qintr_snow ,& + snofrz ,sabg_snow_lyr ) !======================================================================= ! this is the main subroutine to execute the calculation @@ -99,46 +99,46 @@ SUBROUTINE THERMAL (ipatch ,patchtype ,lb ,deltim ,& ! with canopy and ground for PFT and Plant Community (PC) !======================================================================= - USE MOD_Precision - USE MOD_Vars_Global - USE MOD_Const_PFT - USE MOD_Const_Physical, only: denh2o,roverg,hvap,hsub,rgas,cpair,& - stefnc,denice,tfrz,vonkar,grav,cpliq,cpice - USE MOD_FrictionVelocity - USE MOD_Eroot - USE MOD_GroundFluxes - USE MOD_LeafTemperature - USE MOD_LeafTemperaturePC - USE MOD_GroundTemperature - USE MOD_Qsadv - USE MOD_SoilSurfaceResistance + USE MOD_Precision + USE MOD_Vars_Global + USE MOD_Const_PFT + USE MOD_Const_Physical, only: denh2o,roverg,hvap,hsub,rgas,cpair,& + stefnc,denice,tfrz,vonkar,grav,cpliq,cpice + USE MOD_FrictionVelocity + USE MOD_Eroot + USE MOD_GroundFluxes + USE MOD_LeafTemperature + USE MOD_LeafTemperaturePC + USE MOD_GroundTemperature + USE MOD_Qsadv + USE MOD_SoilSurfaceResistance #if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) - USE MOD_LandPFT, only: patch_pft_s, patch_pft_e - USE MOD_Vars_TimeInvariants, only: patchclass - USE MOD_Vars_PFTimeInvariants - USE MOD_Vars_PFTimeVariables - USE MOD_Vars_1DPFTFluxes + USE MOD_LandPFT, only: patch_pft_s, patch_pft_e + USE MOD_Vars_TimeInvariants, only: patchclass + USE MOD_Vars_PFTimeInvariants + USE MOD_Vars_PFTimeVariables + USE MOD_Vars_1DPFTFluxes #endif #ifdef vanGenuchten_Mualem_SOIL_MODEL - USE MOD_Hydro_SoilFunction, only: soil_psi_from_vliq + USE MOD_Hydro_SoilFunction, only: soil_psi_from_vliq #endif - USE MOD_SPMD_Task - USE MOD_Namelist, only: DEF_USE_PLANTHYDRAULICS, DEF_RSS_SCHEME, DEF_SPLIT_SOILSNOW, & + USE MOD_SPMD_Task + USE MOD_Namelist, only: DEF_USE_PLANTHYDRAULICS, DEF_RSS_SCHEME, DEF_SPLIT_SOILSNOW, & DEF_USE_LCT,DEF_USE_PFT,DEF_USE_PC - IMPLICIT NONE + IMPLICIT NONE !---------------------Argument------------------------------------------ - integer, intent(in) :: & + integer, intent(in) :: & ipatch, &! patch index lb, &! lower bound of array patchtype ! land patch type (0=soil, 1=urban or built-up, 2=wetland, ! 3=glacier/ice sheet, 4=land water bodies) - real(r8), intent(inout) :: & + real(r8), intent(inout) :: & sai ! stem area index [-] - real(r8), intent(in) :: & + real(r8), intent(in) :: & deltim, &! model time step [second] trsmx0, &! max transpiration for moist soil+100% veg. [mm/s] zlnd, &! roughness length for soil [m] @@ -248,11 +248,11 @@ SUBROUTINE THERMAL (ipatch ,patchtype ,lb ,deltim ,& z_soisno (lb:nl_soil), &! node depth [m] zi_soisno(lb-1:nl_soil) ! interface depth [m] - real(r8), intent(in) :: & + real(r8), intent(in) :: & sabg_snow_lyr(lb:1) ! snow layer aborption ! state variables (2) - real(r8), intent(inout) :: & + real(r8), intent(inout) :: & vegwp(1:nvegwcs),&! vegetation water potential gs0sun, &! working copy of sunlit stomata conductance gs0sha, &! working copy of shalit stomata conductance @@ -275,27 +275,27 @@ SUBROUTINE THERMAL (ipatch ,patchtype ,lb ,deltim ,& scv, &! snow cover, water equivalent [mm, kg/m2] snowdp ! snow depth [m] - real(r8), intent(out) :: & + real(r8), intent(out) :: & snofrz (lb:0) !snow freezing rate (col,lyr) [kg m-2 s-1] - integer, intent(out) :: & + integer, intent(out) :: & imelt(lb:nl_soil) ! flag for melting or freezing [-] - real(r8), intent(out) :: & + real(r8), intent(out) :: & laisun, &! sunlit leaf area index laisha, &! shaded leaf area index gssun_out, &! sunlit stomata conductance gssha_out, &! shaded stomata conductance rstfacsun_out,&! factor of soil water stress on sunlit leaf rstfacsha_out ! factor of soil water stress on shaded leaf - real(r8), intent(out) :: & + real(r8), intent(out) :: & assimsun_out ,&! diagnostic sunlit leaf assim value for output etrsun_out ,&! diagnostic sunlit leaf etr value for output assimsha_out ,&! diagnostic shaded leaf assim for output etrsha_out ! diagnostic shaded leaf etr for output ! Output 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] @@ -347,9 +347,9 @@ SUBROUTINE THERMAL (ipatch ,patchtype ,lb ,deltim ,& !---------------------Local Variables----------------------------------- - integer i,j + integer i,j - real(r8) :: & + real(r8) :: & fseng_soil, &! sensible heat flux from soil fraction fseng_snow, &! sensible heat flux from snow fraction fevpg_soil, &! latent heat flux from soil fraction @@ -402,48 +402,48 @@ SUBROUTINE THERMAL (ipatch ,patchtype ,lb ,deltim ,& xmf, &! total latent heat of phase change of ground water hprl ! precipitation sensible heat from canopy - real(r8) :: z0m_g,z0h_g,zol_g,obu_g,rib_g,ustar_g,qstar_g,tstar_g - real(r8) :: fm10m,fm_g,fh_g,fq_g,fh2m,fq2m,um,obu + real(r8) :: z0m_g,z0h_g,zol_g,obu_g,rib_g,ustar_g,qstar_g,tstar_g + real(r8) :: fm10m,fm_g,fh_g,fq_g,fh2m,fq2m,um,obu !Ozone stress variables - real(r8) :: o3coefv_sun, o3coefv_sha, o3coefg_sun, o3coefg_sha + real(r8) :: o3coefv_sun, o3coefv_sha, o3coefg_sun, o3coefg_sha !end ozone stress variables - integer p, ps, pe, pc + integer p, ps, pe, pc - real(r8), allocatable :: rootr_p (:,:) - real(r8), allocatable :: rootflux_p (:,:) - real(r8), allocatable :: etrc_p (:) - real(r8), allocatable :: rstfac_p (:) - real(r8), allocatable :: rstfacsun_p (:) - real(r8), allocatable :: rstfacsha_p (:) - real(r8), allocatable :: gssun_p (:) - real(r8), allocatable :: gssha_p (:) - real(r8), allocatable :: fsun_p (:) - real(r8), allocatable :: sabv_p (:) + real(r8), allocatable :: rootr_p (:,:) + real(r8), allocatable :: rootflux_p (:,:) + real(r8), allocatable :: etrc_p (:) + real(r8), allocatable :: rstfac_p (:) + real(r8), allocatable :: rstfacsun_p (:) + real(r8), allocatable :: rstfacsha_p (:) + real(r8), allocatable :: gssun_p (:) + real(r8), allocatable :: gssha_p (:) + real(r8), allocatable :: fsun_p (:) + real(r8), allocatable :: sabv_p (:) ! 03/06/2020, yuan: added - REAL(r8), allocatable :: fseng_soil_p (:) - REAL(r8), allocatable :: fseng_snow_p (:) - REAL(r8), allocatable :: fevpg_soil_p (:) - REAL(r8), allocatable :: fevpg_snow_p (:) - real(r8), allocatable :: cgrnd_p (:) - real(r8), allocatable :: cgrnds_p (:) - real(r8), allocatable :: cgrndl_p (:) - real(r8), allocatable :: dlrad_p (:) - real(r8), allocatable :: ulrad_p (:) - real(r8), allocatable :: zol_p (:) - real(r8), allocatable :: rib_p (:) - real(r8), allocatable :: ustar_p (:) - real(r8), allocatable :: qstar_p (:) - real(r8), allocatable :: tstar_p (:) - real(r8), allocatable :: fm_p (:) - real(r8), allocatable :: fh_p (:) - real(r8), allocatable :: fq_p (:) - real(r8), allocatable :: hprl_p (:) - real(r8), allocatable :: assimsun_p (:) - real(r8), allocatable :: etrsun_p (:) - real(r8), allocatable :: assimsha_p (:) - real(r8), allocatable :: etrsha_p (:) + real(r8), allocatable :: fseng_soil_p (:) + real(r8), allocatable :: fseng_snow_p (:) + real(r8), allocatable :: fevpg_soil_p (:) + real(r8), allocatable :: fevpg_snow_p (:) + real(r8), allocatable :: cgrnd_p (:) + real(r8), allocatable :: cgrnds_p (:) + real(r8), allocatable :: cgrndl_p (:) + real(r8), allocatable :: dlrad_p (:) + real(r8), allocatable :: ulrad_p (:) + real(r8), allocatable :: zol_p (:) + real(r8), allocatable :: rib_p (:) + real(r8), allocatable :: ustar_p (:) + real(r8), allocatable :: qstar_p (:) + real(r8), allocatable :: tstar_p (:) + real(r8), allocatable :: fm_p (:) + real(r8), allocatable :: fh_p (:) + real(r8), allocatable :: fq_p (:) + real(r8), allocatable :: hprl_p (:) + real(r8), allocatable :: assimsun_p (:) + real(r8), allocatable :: etrsun_p (:) + real(r8), allocatable :: assimsha_p (:) + real(r8), allocatable :: etrsha_p (:) !======================================================================= @@ -549,16 +549,16 @@ SUBROUTINE THERMAL (ipatch ,patchtype ,lb ,deltim ,& q_snow = qg ELSE - call qsadv(t_soil,forc_psrf,eg,degdT,qsatg,qsatgdT) + CALL qsadv(t_soil,forc_psrf,eg,degdT,qsatg,qsatgdT) q_soil = hr*qsatg dqgdT = (1.-fsno)*hr*qsatgdT - if(qsatg > forc_q .and. forc_q > hr*qsatg)then + IF(qsatg > forc_q .and. forc_q > hr*qsatg)THEN q_soil = forc_q; dqgdT = 0. ENDIF - call qsadv(t_snow,forc_psrf,eg,degdT,qsatg,qsatgdT) + CALL qsadv(t_snow,forc_psrf,eg,degdT,qsatg,qsatgdT) q_snow = qsatg dqgdT = dqgdT + fsno*qsatgdT @@ -679,7 +679,7 @@ SUBROUTINE THERMAL (ipatch ,patchtype ,lb ,deltim ,& ldew = 0. rstfacsun_out = 0. rstfacsha_out = 0. - if (DEF_USE_PLANTHYDRAULICS) THEN + IF (DEF_USE_PLANTHYDRAULICS) THEN vegwp = -2.5e4 ENDIF ENDIF @@ -1107,33 +1107,33 @@ SUBROUTINE THERMAL (ipatch ,patchtype ,lb ,deltim ,& fevpg = fevpg_soil; fevpg_snow = 0. ENDIF - if(fevpg_snow >= 0.)then + IF(fevpg_snow >= 0.)THEN ! not allow for sublimation in melting (melting ==> evap. ==> sublimation) qseva_snow = min(wliq_soisno(lb)/deltim, fevpg_snow) qsubl_snow = fevpg_snow - qseva_snow qseva_snow = qseva_snow*fsno qsubl_snow = qsubl_snow*fsno - else + ELSE ! snow temperature < tfrz - if(t_soisno(lb) < tfrz)then + IF(t_soisno(lb) < tfrz)THEN qfros_snow = abs(fevpg_snow*fsno) - else + ELSE qsdew_snow = abs(fevpg_snow*fsno) - endif - endif + ENDIF + ENDIF - if(fevpg_soil >= 0.)then + IF(fevpg_soil >= 0.)THEN ! not allow for sublimation in melting (melting ==> evap. ==> sublimation) qseva_soil = min(wliq_soisno(1)/deltim, fevpg_soil) qsubl_soil = fevpg_soil - qseva_soil - else + ELSE ! soil temperature < tfrz - if(t_soisno(1) < tfrz)then + IF(t_soisno(1) < tfrz)THEN qfros_soil = abs(fevpg_soil) - else + ELSE qsdew_soil = abs(fevpg_soil) - endif - endif + ENDIF + ENDIF IF (lb < 1) THEN ! snow layer exists qseva_soil = qseva_soil*(1.-fsno) diff --git a/main/MOD_Vars_1DAccFluxes.F90 b/main/MOD_Vars_1DAccFluxes.F90 index 591592ad..2ca19d06 100644 --- a/main/MOD_Vars_1DAccFluxes.F90 +++ b/main/MOD_Vars_1DAccFluxes.F90 @@ -1,8 +1,8 @@ #include -module MOD_Vars_1DAccFluxes +MODULE MOD_Vars_1DAccFluxes - use MOD_Precision + USE MOD_Precision real(r8) :: nac ! number of accumulation real(r8), allocatable :: nac_ln (:) @@ -91,30 +91,30 @@ module MOD_Vars_1DAccFluxes real(r8), allocatable :: a_snow (:) #ifdef URBAN_MODEL - REAL(r8), allocatable :: a_t_room (:) !temperature of inner building [K] - REAL(r8), allocatable :: a_tafu (:) !temperature of outer building [K] - REAL(r8), allocatable :: a_fhac (:) !sensible flux from heat or cool AC [W/m2] - REAL(r8), allocatable :: a_fwst (:) !waste heat flux from heat or cool AC [W/m2] - REAL(r8), allocatable :: a_fach (:) !flux from inner and outter air exchange [W/m2] - REAL(r8), allocatable :: a_fahe (:) !flux from metabolic and vehicle [W/m2] - REAL(r8), allocatable :: a_fhah (:) !sensible flux from heating [W/m2] - REAL(r8), allocatable :: a_vehc (:) !flux from vehicle [W/m2] - REAL(r8), allocatable :: a_meta (:) !flux from metabolic [W/m2] - - REAL(r8), allocatable :: a_senroof(:) !sensible heat flux from roof [W/m2] - REAL(r8), allocatable :: a_senwsun(:) !sensible heat flux from sunlit wall [W/m2] - REAL(r8), allocatable :: a_senwsha(:) !sensible heat flux from shaded wall [W/m2] - REAL(r8), allocatable :: a_sengimp(:) !sensible heat flux from impervious road [W/m2] - REAL(r8), allocatable :: a_sengper(:) !sensible heat flux from pervious road [W/m2] - REAL(r8), allocatable :: a_senurbl(:) !sensible heat flux from urban vegetation [W/m2] - - REAL(r8), allocatable :: a_lfevproof(:) !latent heat flux from roof [W/m2] - REAL(r8), allocatable :: a_lfevpgimp(:) !latent heat flux from impervious road [W/m2] - REAL(r8), allocatable :: a_lfevpgper(:) !latent heat flux from pervious road [W/m2] - REAL(r8), allocatable :: a_lfevpurbl(:) !latent heat flux from urban vegetation [W/m2] - - REAL(r8), allocatable :: a_troof (:) !temperature of roof [K] - REAL(r8), allocatable :: a_twall (:) !temperature of wall [K] + real(r8), allocatable :: a_t_room (:) !temperature of inner building [K] + real(r8), allocatable :: a_tafu (:) !temperature of outer building [K] + real(r8), allocatable :: a_fhac (:) !sensible flux from heat or cool AC [W/m2] + real(r8), allocatable :: a_fwst (:) !waste heat flux from heat or cool AC [W/m2] + real(r8), allocatable :: a_fach (:) !flux from inner and outter air exchange [W/m2] + real(r8), allocatable :: a_fahe (:) !flux from metabolic and vehicle [W/m2] + real(r8), allocatable :: a_fhah (:) !sensible flux from heating [W/m2] + real(r8), allocatable :: a_vehc (:) !flux from vehicle [W/m2] + real(r8), allocatable :: a_meta (:) !flux from metabolic [W/m2] + + real(r8), allocatable :: a_senroof(:) !sensible heat flux from roof [W/m2] + real(r8), allocatable :: a_senwsun(:) !sensible heat flux from sunlit wall [W/m2] + real(r8), allocatable :: a_senwsha(:) !sensible heat flux from shaded wall [W/m2] + real(r8), allocatable :: a_sengimp(:) !sensible heat flux from impervious road [W/m2] + real(r8), allocatable :: a_sengper(:) !sensible heat flux from pervious road [W/m2] + real(r8), allocatable :: a_senurbl(:) !sensible heat flux from urban vegetation [W/m2] + + real(r8), allocatable :: a_lfevproof(:) !latent heat flux from roof [W/m2] + real(r8), allocatable :: a_lfevpgimp(:) !latent heat flux from impervious road [W/m2] + real(r8), allocatable :: a_lfevpgper(:) !latent heat flux from pervious road [W/m2] + real(r8), allocatable :: a_lfevpurbl(:) !latent heat flux from urban vegetation [W/m2] + + real(r8), allocatable :: a_troof (:) !temperature of roof [K] + real(r8), allocatable :: a_twall (:) !temperature of wall [K] #endif @@ -264,7 +264,7 @@ module MOD_Vars_1DAccFluxes real(r8), allocatable :: a_OM_density (:,:) !Plant Hydraulic parameters real(r8), allocatable :: a_vegwp (:,:) -!end plant hydraulic parameters +!END plant hydraulic parameters real(r8), allocatable :: a_t_lake (:,:) real(r8), allocatable :: a_lake_icefrac(:,:) @@ -319,27 +319,27 @@ module MOD_Vars_1DAccFluxes real(r8), allocatable :: a_srndln (:) real(r8), allocatable :: a_srniln (:) - public :: allocate_acc_fluxes - public :: deallocate_acc_fluxes - public :: flush_acc_fluxes - public :: accumulate_fluxes + PUBLIC :: allocate_acc_fluxes + PUBLIC :: deallocate_acc_fluxes + PUBLIC :: flush_acc_fluxes + PUBLIC :: accumulate_fluxes -contains +CONTAINS - subroutine allocate_acc_fluxes + SUBROUTINE allocate_acc_fluxes - use MOD_SPMD_Task - USE MOD_LandElm - use MOD_LandPatch - USE MOD_LandUrban, only: numurban + USE MOD_SPMD_Task + USE MOD_LandElm + USE MOD_LandPatch + USE MOD_LandUrban, only: numurban #ifdef CROP - USE MOD_LandCrop + USE MOD_LandCrop #endif - USE MOD_Vars_Global - implicit none + USE MOD_Vars_Global + IMPLICIT NONE - if (p_is_worker) then - if (numpatch > 0) then + IF (p_is_worker) THEN + IF (numpatch > 0) THEN allocate (a_us (numpatch)) allocate (a_vs (numpatch)) @@ -659,8 +659,8 @@ subroutine allocate_acc_fluxes allocate (nac_ln (numpatch)) - end if - end if + ENDIF + ENDIF IF (p_is_worker) THEN #if (defined CROP) @@ -670,17 +670,17 @@ subroutine allocate_acc_fluxes #endif ENDIF - end subroutine allocate_acc_fluxes + END SUBROUTINE allocate_acc_fluxes - subroutine deallocate_acc_fluxes () + SUBROUTINE deallocate_acc_fluxes () - use MOD_SPMD_Task - use MOD_LandPatch, only : numpatch - USE MOD_LandUrban, only : numurban - implicit none + USE MOD_SPMD_Task + USE MOD_LandPatch, only : numpatch + USE MOD_LandUrban, only : numurban + IMPLICIT NONE - if (p_is_worker) then - if (numpatch > 0) then + IF (p_is_worker) THEN + IF (numpatch > 0) THEN deallocate (a_us ) deallocate (a_vs ) @@ -933,7 +933,7 @@ subroutine deallocate_acc_fluxes () #endif ! Ozone stress variables deallocate (a_ozone ) -! end ozone stress variables +! END ozone stress variables deallocate (a_t_soisno ) deallocate (a_wliq_soisno ) @@ -945,7 +945,7 @@ subroutine deallocate_acc_fluxes () deallocate (a_OM_density ) !Plant Hydraulic parameters deallocate (a_vegwp ) -!end plant hydraulic parameters +!END plant hydraulic parameters deallocate (a_t_lake ) deallocate (a_lake_icefrac) #ifdef BGC @@ -1001,25 +1001,25 @@ subroutine deallocate_acc_fluxes () deallocate (nac_ln ) - end if - end if + ENDIF + ENDIF - end subroutine deallocate_acc_fluxes + END SUBROUTINE deallocate_acc_fluxes !----------------------- SUBROUTINE FLUSH_acc_fluxes () - use MOD_SPMD_Task - use MOD_LandPatch, only : numpatch + USE MOD_SPMD_Task + USE MOD_LandPatch, only : numpatch USE MOD_LandUrban, only : numurban - use MOD_Vars_Global, only : spval - implicit none + USE MOD_Vars_Global, only : spval + IMPLICIT NONE - if (p_is_worker) then + IF (p_is_worker) THEN nac = 0 - if (numpatch > 0) then + IF (numpatch > 0) THEN ! flush the Fluxes for accumulation a_us (:) = spval @@ -1281,7 +1281,7 @@ SUBROUTINE FLUSH_acc_fluxes () a_OM_density (:,:) = spval !Plant Hydraulic parameters a_vegwp (:,:) = spval -!end plant hydraulic parameters +!END plant hydraulic parameters a_t_lake (:,:) = spval a_lake_icefrac (:,:) = spval #ifdef BGC @@ -1336,109 +1336,109 @@ SUBROUTINE FLUSH_acc_fluxes () nac_ln (:) = 0 - end if - end if + ENDIF + ENDIF END SUBROUTINE FLUSH_acc_fluxes SUBROUTINE accumulate_fluxes - ! ---------------------------------------------------------------------- - ! perfrom the grid average mapping: average a subgrid input 1d vector - ! of length numpatch to a output 2d array of length [ghist%xcnt,ghist%ycnt] - ! - ! Created by Yongjiu Dai, 03/2014 - !--------------------------------------------------------------------- - - use MOD_Precision - use MOD_SPMD_Task - USE mod_forcing, only: forcmask - USE MOD_Mesh, only: numelm - USE MOD_LandElm - use MOD_LandPatch, only: numpatch, elm_patch - USE MOD_LandUrban, only: numurban - use MOD_Const_Physical, only: vonkar, stefnc, cpair, rgas, grav - use MOD_Vars_TimeInvariants - use MOD_Vars_TimeVariables - use MOD_Vars_1DForcing - use MOD_Vars_1DFluxes - use MOD_FrictionVelocity - USE MOD_Namelist, only: DEF_USE_CBL_HEIGHT, DEF_USE_OZONESTRESS, DEF_USE_PLANTHYDRAULICS, DEF_USE_NITRIF - USE MOD_TurbulenceLEddy - use MOD_Vars_Global + ! ---------------------------------------------------------------------- + ! perfrom the grid average mapping: average a subgrid input 1d vector + ! of length numpatch to a output 2d array of length [ghist%xcnt,ghist%ycnt] + ! + ! Created by Yongjiu Dai, 03/2014 + !--------------------------------------------------------------------- + + USE MOD_Precision + USE MOD_SPMD_Task + USE mod_forcing, only: forcmask + USE MOD_Mesh, only: numelm + USE MOD_LandElm + USE MOD_LandPatch, only: numpatch, elm_patch + USE MOD_LandUrban, only: numurban + USE MOD_Const_Physical, only: vonkar, stefnc, cpair, rgas, grav + USE MOD_Vars_TimeInvariants + USE MOD_Vars_TimeVariables + USE MOD_Vars_1DForcing + USE MOD_Vars_1DFluxes + USE MOD_FrictionVelocity + USE MOD_Namelist, only: DEF_USE_CBL_HEIGHT, DEF_USE_OZONESTRESS, DEF_USE_PLANTHYDRAULICS, DEF_USE_NITRIF + USE MOD_TurbulenceLEddy + USE MOD_Vars_Global #ifdef LATERAL_FLOW - USE MOD_Hydro_Vars_1DFluxes - USE MOD_Hydro_Hist, only: accumulate_fluxes_basin + USE MOD_Hydro_Vars_1DFluxes + USE MOD_Hydro_Hist, only: accumulate_fluxes_basin #endif - IMPLICIT NONE + IMPLICIT NONE + + ! Local Variables + + real(r8), allocatable :: r_trad (:) + real(r8), allocatable :: r_ustar (:) + real(r8), allocatable :: r_ustar2(:) !define a temporary for estimating us10m only, output should be r_ustar. Shaofeng, 2023.05.20 + real(r8), allocatable :: r_tstar (:) + real(r8), allocatable :: r_qstar (:) + real(r8), allocatable :: r_zol (:) + real(r8), allocatable :: r_rib (:) + real(r8), allocatable :: r_fm (:) + real(r8), allocatable :: r_fh (:) + real(r8), allocatable :: r_fq (:) + + real(r8), allocatable :: r_us10m (:) + real(r8), allocatable :: r_vs10m (:) + real(r8), allocatable :: r_fm10m (:) + + logical, allocatable :: filter (:) + + !--------------------------------------------------------------------- + integer ib, jb, i, j, ielm, istt, iend + real(r8) sumwt + real(r8) rhoair,thm,th,thv,ur,displa_av,zldis,hgt_u,hgt_t,hgt_q + real(r8) hpbl ! atmospheric boundary layer height [m] + real(r8) z0m_av,z0h_av,z0q_av,us,vs,tm,qm,psrf,taux_e,tauy_e,fsena_e,fevpa_e + real(r8) r_ustar_e, r_tstar_e, r_qstar_e, r_zol_e, r_ustar2_e, r_fm10m_e + real(r8) r_fm_e, r_fh_e, r_fq_e, r_rib_e, r_us10m_e, r_vs10m_e + real(r8) obu,fh2m,fq2m + real(r8) um,thvstar,beta,zii,wc,wc2 - ! Local Variables - - real(r8), allocatable :: r_trad (:) - real(r8), allocatable :: r_ustar (:) - real(r8), allocatable :: r_ustar2(:) !define a temporary for estimating us10m only, output should be r_ustar. Shaofeng, 2023.05.20 - real(r8), allocatable :: r_tstar (:) - real(r8), allocatable :: r_qstar (:) - real(r8), allocatable :: r_zol (:) - real(r8), allocatable :: r_rib (:) - real(r8), allocatable :: r_fm (:) - real(r8), allocatable :: r_fh (:) - real(r8), allocatable :: r_fq (:) - - real(r8), allocatable :: r_us10m (:) - real(r8), allocatable :: r_vs10m (:) - real(r8), allocatable :: r_fm10m (:) - - logical, allocatable :: filter (:) - - !--------------------------------------------------------------------- - integer ib, jb, i, j, ielm, istt, iend - real(r8) sumwt - real(r8) rhoair,thm,th,thv,ur,displa_av,zldis,hgt_u,hgt_t,hgt_q - real(r8) hpbl ! atmospheric boundary layer height [m] - real(r8) z0m_av,z0h_av,z0q_av,us,vs,tm,qm,psrf,taux_e,tauy_e,fsena_e,fevpa_e - real(r8) r_ustar_e, r_tstar_e, r_qstar_e, r_zol_e, r_ustar2_e, r_fm10m_e - real(r8) r_fm_e, r_fh_e, r_fq_e, r_rib_e, r_us10m_e, r_vs10m_e - real(r8) obu,fh2m,fq2m - real(r8) um,thvstar,beta,zii,wc,wc2 - - if (p_is_worker) then - if (numpatch > 0) then + IF (p_is_worker) THEN + IF (numpatch > 0) THEN nac = nac + 1 - call acc1d (forc_us , a_us ) - call acc1d (forc_vs , a_vs ) - call acc1d (forc_t , a_t ) - call acc1d (forc_q , a_q ) - call acc1d (forc_prc , a_prc ) - call acc1d (forc_prl , a_prl ) - call acc1d (forc_pbot, a_pbot) - call acc1d (forc_frl , a_frl ) - - call acc1d (forc_sols, a_solarin) - call acc1d (forc_soll, a_solarin) - call acc1d (forc_solsd, a_solarin) - call acc1d (forc_solld, a_solarin) - if (DEF_USE_CBL_HEIGHT) then - call acc1d (forc_hpbl , a_hpbl) - endif - - call acc1d (taux , a_taux ) - call acc1d (tauy , a_tauy ) - call acc1d (fsena , a_fsena ) - call acc1d (lfevpa , a_lfevpa ) - call acc1d (fevpa , a_fevpa ) - call acc1d (fsenl , a_fsenl ) - call acc1d (fevpl , a_fevpl ) - call acc1d (etr , a_etr ) - call acc1d (fseng , a_fseng ) - call acc1d (fevpg , a_fevpg ) - call acc1d (fgrnd , a_fgrnd ) - call acc1d (sabvsun , a_sabvsun) - call acc1d (sabvsha , a_sabvsha) - call acc1d (sabg , a_sabg ) - call acc1d (olrg , a_olrg ) + CALL acc1d (forc_us , a_us ) + CALL acc1d (forc_vs , a_vs ) + CALL acc1d (forc_t , a_t ) + CALL acc1d (forc_q , a_q ) + CALL acc1d (forc_prc , a_prc ) + CALL acc1d (forc_prl , a_prl ) + CALL acc1d (forc_pbot, a_pbot) + CALL acc1d (forc_frl , a_frl ) + + CALL acc1d (forc_sols, a_solarin) + CALL acc1d (forc_soll, a_solarin) + CALL acc1d (forc_solsd, a_solarin) + CALL acc1d (forc_solld, a_solarin) + IF (DEF_USE_CBL_HEIGHT) THEN + CALL acc1d (forc_hpbl , a_hpbl) + ENDIF + + CALL acc1d (taux , a_taux ) + CALL acc1d (tauy , a_tauy ) + CALL acc1d (fsena , a_fsena ) + CALL acc1d (lfevpa , a_lfevpa ) + CALL acc1d (fevpa , a_fevpa ) + CALL acc1d (fsenl , a_fsenl ) + CALL acc1d (fevpl , a_fevpl ) + CALL acc1d (etr , a_etr ) + CALL acc1d (fseng , a_fseng ) + CALL acc1d (fevpg , a_fevpg ) + CALL acc1d (fgrnd , a_fgrnd ) + CALL acc1d (sabvsun , a_sabvsun) + CALL acc1d (sabvsha , a_sabvsha) + CALL acc1d (sabg , a_sabg ) + CALL acc1d (olrg , a_olrg ) IF (DEF_forcing%has_missing_value) THEN WHERE (forcmask) @@ -1449,86 +1449,86 @@ SUBROUTINE accumulate_fluxes rnet = sabg + sabvsun + sabvsha - olrg + forc_frl END WHERE ENDIF - call acc1d (rnet , a_rnet ) + CALL acc1d (rnet , a_rnet ) - call acc1d (xerr , a_xerr ) - call acc1d (zerr , a_zerr ) - call acc1d (rsur , a_rsur ) + CALL acc1d (xerr , a_xerr ) + CALL acc1d (zerr , a_zerr ) + CALL acc1d (rsur , a_rsur ) #ifndef LATERAL_FLOW WHERE ((rsur /= spval) .and. (rnof /= spval)) rsub = rnof - rsur ELSEWHERE rsub = spval - END WHERE + END WHERE #endif - call acc1d (rsub , a_rsub ) - call acc1d (rnof , a_rnof ) + CALL acc1d (rsub , a_rsub ) + CALL acc1d (rnof , a_rnof ) #ifdef LATERAL_FLOW CALL acc1d (xwsur , a_xwsur ) CALL acc1d (xwsub , a_xwsub ) #endif - call acc1d (qintr , a_qintr ) - call acc1d (qinfl , a_qinfl ) - call acc1d (qdrip , a_qdrip ) - - call acc1d (rstfacsun_out , a_rstfacsun ) - call acc1d (rstfacsha_out , a_rstfacsha ) - - call acc1d (gssun_out , a_gssun ) - call acc1d (gssha_out , a_gssha ) - - call acc1d (rss , a_rss ) - call acc1d (wdsrf , a_wdsrf ) - call acc1d (zwt , a_zwt ) - call acc1d (wa , a_wa ) - call acc1d (wat , a_wat ) - call acc1d (wetwat , a_wetwat ) - call acc1d (assim , a_assim ) - call acc1d (respc , a_respc ) - call acc1d (assimsun_out , a_assimsun ) - call acc1d (assimsha_out , a_assimsha ) - call acc1d (etrsun_out , a_etrsun ) - call acc1d (etrsha_out , a_etrsha ) - - call acc1d (qcharge, a_qcharge) - - call acc1d (t_grnd , a_t_grnd ) - call acc1d (tleaf , a_tleaf ) - call acc1d (ldew_rain, a_ldew_rain) - call acc1d (ldew_snow, a_ldew_snow) - call acc1d (ldew , a_ldew ) - call acc1d (scv , a_scv ) - call acc1d (snowdp , a_snowdp ) - call acc1d (fsno , a_fsno ) - call acc1d (sigf , a_sigf ) - call acc1d (green , a_green ) - call acc1d (lai , a_lai ) - call acc1d (laisun , a_laisun ) - call acc1d (laisha , a_laisha ) - call acc1d (sai , a_sai ) - - call acc3d (alb , a_alb ) - - call acc1d (emis , a_emis ) - call acc1d (z0m , a_z0m ) + CALL acc1d (qintr , a_qintr ) + CALL acc1d (qinfl , a_qinfl ) + CALL acc1d (qdrip , a_qdrip ) + + CALL acc1d (rstfacsun_out , a_rstfacsun ) + CALL acc1d (rstfacsha_out , a_rstfacsha ) + + CALL acc1d (gssun_out , a_gssun ) + CALL acc1d (gssha_out , a_gssha ) + + CALL acc1d (rss , a_rss ) + CALL acc1d (wdsrf , a_wdsrf ) + CALL acc1d (zwt , a_zwt ) + CALL acc1d (wa , a_wa ) + CALL acc1d (wat , a_wat ) + CALL acc1d (wetwat , a_wetwat ) + CALL acc1d (assim , a_assim ) + CALL acc1d (respc , a_respc ) + CALL acc1d (assimsun_out , a_assimsun ) + CALL acc1d (assimsha_out , a_assimsha ) + CALL acc1d (etrsun_out , a_etrsun ) + CALL acc1d (etrsha_out , a_etrsha ) + + CALL acc1d (qcharge, a_qcharge) + + CALL acc1d (t_grnd , a_t_grnd ) + CALL acc1d (tleaf , a_tleaf ) + CALL acc1d (ldew_rain, a_ldew_rain) + CALL acc1d (ldew_snow, a_ldew_snow) + CALL acc1d (ldew , a_ldew ) + CALL acc1d (scv , a_scv ) + CALL acc1d (snowdp , a_snowdp ) + CALL acc1d (fsno , a_fsno ) + CALL acc1d (sigf , a_sigf ) + CALL acc1d (green , a_green ) + CALL acc1d (lai , a_lai ) + CALL acc1d (laisun , a_laisun ) + CALL acc1d (laisha , a_laisha ) + CALL acc1d (sai , a_sai ) + + CALL acc3d (alb , a_alb ) + + CALL acc1d (emis , a_emis ) + CALL acc1d (z0m , a_z0m ) allocate (r_trad (numpatch)) ; r_trad(:) = spval - do i = 1, numpatch + DO i = 1, numpatch IF (DEF_forcing%has_missing_value) THEN - IF (.not. forcmask(i)) cycle + IF (.not. forcmask(i)) CYCLE ENDIF IF (.not. patchmask(i)) CYCLE r_trad(i) = (olrg(i)/stefnc)**0.25 - end do - call acc1d (r_trad , a_trad ) + ENDDO + CALL acc1d (r_trad , a_trad ) deallocate (r_trad ) - call acc1d (tref , a_tref ) - call acc1d (qref , a_qref ) + CALL acc1d (tref , a_tref ) + CALL acc1d (qref , a_qref ) - call acc1d (forc_rain, a_rain ) - call acc1d (forc_snow, a_snow ) + CALL acc1d (forc_rain, a_rain ) + CALL acc1d (forc_snow, a_snow ) #ifdef URBAN_MODEL IF (numurban > 0) THEN @@ -1560,250 +1560,250 @@ SUBROUTINE accumulate_fluxes #endif #ifdef BGC - call acc1d (leafc , a_leafc ) - call acc1d (leafc_storage , a_leafc_storage ) - call acc1d (leafc_xfer , a_leafc_xfer ) - call acc1d (frootc , a_frootc ) - call acc1d (frootc_storage , a_frootc_storage ) - call acc1d (frootc_xfer , a_frootc_xfer ) - call acc1d (livestemc , a_livestemc ) - call acc1d (livestemc_storage , a_livestemc_storage ) - call acc1d (livestemc_xfer , a_livestemc_xfer ) - call acc1d (deadstemc , a_deadstemc ) - call acc1d (deadstemc_storage , a_deadstemc_storage ) - call acc1d (deadstemc_xfer , a_deadstemc_xfer ) - call acc1d (livecrootc , a_livecrootc ) - call acc1d (livecrootc_storage , a_livecrootc_storage ) - call acc1d (livecrootc_xfer , a_livecrootc_xfer ) - call acc1d (deadcrootc , a_deadcrootc ) - call acc1d (deadcrootc_storage , a_deadcrootc_storage ) - call acc1d (deadcrootc_xfer , a_deadcrootc_xfer ) - call acc1d (grainc , a_grainc ) - call acc1d (grainc_storage , a_grainc_storage ) - call acc1d (grainc_xfer , a_grainc_xfer ) - call acc1d (leafn , a_leafn ) - call acc1d (leafn_storage , a_leafn_storage ) - call acc1d (leafn_xfer , a_leafn_xfer ) - call acc1d (frootn , a_frootn ) - call acc1d (frootn_storage , a_frootn_storage ) - call acc1d (frootn_xfer , a_frootn_xfer ) - call acc1d (livestemn , a_livestemn ) - call acc1d (livestemn_storage , a_livestemn_storage ) - call acc1d (livestemn_xfer , a_livestemn_xfer ) - call acc1d (deadstemn , a_deadstemn ) - call acc1d (deadstemn_storage , a_deadstemn_storage ) - call acc1d (deadstemn_xfer , a_deadstemn_xfer ) - call acc1d (livecrootn , a_livecrootn ) - call acc1d (livecrootn_storage , a_livecrootn_storage ) - call acc1d (livecrootn_xfer , a_livecrootn_xfer ) - call acc1d (deadcrootn , a_deadcrootn ) - call acc1d (deadcrootn_storage , a_deadcrootn_storage ) - call acc1d (deadcrootn_xfer , a_deadcrootn_xfer ) - call acc1d (grainn , a_grainn ) - call acc1d (grainn_storage , a_grainn_storage ) - call acc1d (grainn_xfer , a_grainn_xfer ) - call acc1d (retransn , a_retransn ) - call acc1d (gpp , a_gpp ) - call acc1d (downreg , a_downreg ) - call acc1d (ar , a_ar ) - call acc1d (cwdprod , a_cwdprod ) - call acc1d (cwddecomp , a_cwddecomp ) - call acc1d (decomp_hr , a_hr ) - call acc1d (fpg , a_fpg ) - call acc1d (fpi , a_fpi ) - call acc1d (gpp_enftemp , a_gpp_enftemp ) - call acc1d (gpp_enfboreal , a_gpp_enfboreal ) - call acc1d (gpp_dnfboreal , a_gpp_dnfboreal ) - call acc1d (gpp_ebftrop , a_gpp_ebftrop ) - call acc1d (gpp_ebftemp , a_gpp_ebftemp ) - call acc1d (gpp_dbftrop , a_gpp_dbftrop ) - call acc1d (gpp_dbftemp , a_gpp_dbftemp ) - call acc1d (gpp_dbfboreal , a_gpp_dbfboreal ) - call acc1d (gpp_ebstemp , a_gpp_ebstemp ) - call acc1d (gpp_dbstemp , a_gpp_dbstemp ) - call acc1d (gpp_dbsboreal , a_gpp_dbsboreal ) - call acc1d (gpp_c3arcgrass , a_gpp_c3arcgrass ) - call acc1d (gpp_c3grass , a_gpp_c3grass ) - call acc1d (gpp_c4grass , a_gpp_c4grass ) - call acc1d (leafc_enftemp , a_leafc_enftemp ) - call acc1d (leafc_enfboreal , a_leafc_enfboreal ) - call acc1d (leafc_dnfboreal , a_leafc_dnfboreal ) - call acc1d (leafc_ebftrop , a_leafc_ebftrop ) - call acc1d (leafc_ebftemp , a_leafc_ebftemp ) - call acc1d (leafc_dbftrop , a_leafc_dbftrop ) - call acc1d (leafc_dbftemp , a_leafc_dbftemp ) - call acc1d (leafc_dbfboreal , a_leafc_dbfboreal ) - call acc1d (leafc_ebstemp , a_leafc_ebstemp ) - call acc1d (leafc_dbstemp , a_leafc_dbstemp ) - call acc1d (leafc_dbsboreal , a_leafc_dbsboreal ) - call acc1d (leafc_c3arcgrass , a_leafc_c3arcgrass ) - call acc1d (leafc_c3grass , a_leafc_c3grass ) - call acc1d (leafc_c4grass , a_leafc_c4grass ) - if(DEF_USE_NITRIF)then - call acc2d (to2_decomp_depth_unsat, a_O2_DECOMP_DEPTH_UNSAT) - call acc2d (tconc_o2_unsat , a_CONC_O2_UNSAT ) - end if + CALL acc1d (leafc , a_leafc ) + CALL acc1d (leafc_storage , a_leafc_storage ) + CALL acc1d (leafc_xfer , a_leafc_xfer ) + CALL acc1d (frootc , a_frootc ) + CALL acc1d (frootc_storage , a_frootc_storage ) + CALL acc1d (frootc_xfer , a_frootc_xfer ) + CALL acc1d (livestemc , a_livestemc ) + CALL acc1d (livestemc_storage , a_livestemc_storage ) + CALL acc1d (livestemc_xfer , a_livestemc_xfer ) + CALL acc1d (deadstemc , a_deadstemc ) + CALL acc1d (deadstemc_storage , a_deadstemc_storage ) + CALL acc1d (deadstemc_xfer , a_deadstemc_xfer ) + CALL acc1d (livecrootc , a_livecrootc ) + CALL acc1d (livecrootc_storage , a_livecrootc_storage ) + CALL acc1d (livecrootc_xfer , a_livecrootc_xfer ) + CALL acc1d (deadcrootc , a_deadcrootc ) + CALL acc1d (deadcrootc_storage , a_deadcrootc_storage ) + CALL acc1d (deadcrootc_xfer , a_deadcrootc_xfer ) + CALL acc1d (grainc , a_grainc ) + CALL acc1d (grainc_storage , a_grainc_storage ) + CALL acc1d (grainc_xfer , a_grainc_xfer ) + CALL acc1d (leafn , a_leafn ) + CALL acc1d (leafn_storage , a_leafn_storage ) + CALL acc1d (leafn_xfer , a_leafn_xfer ) + CALL acc1d (frootn , a_frootn ) + CALL acc1d (frootn_storage , a_frootn_storage ) + CALL acc1d (frootn_xfer , a_frootn_xfer ) + CALL acc1d (livestemn , a_livestemn ) + CALL acc1d (livestemn_storage , a_livestemn_storage ) + CALL acc1d (livestemn_xfer , a_livestemn_xfer ) + CALL acc1d (deadstemn , a_deadstemn ) + CALL acc1d (deadstemn_storage , a_deadstemn_storage ) + CALL acc1d (deadstemn_xfer , a_deadstemn_xfer ) + CALL acc1d (livecrootn , a_livecrootn ) + CALL acc1d (livecrootn_storage , a_livecrootn_storage ) + CALL acc1d (livecrootn_xfer , a_livecrootn_xfer ) + CALL acc1d (deadcrootn , a_deadcrootn ) + CALL acc1d (deadcrootn_storage , a_deadcrootn_storage ) + CALL acc1d (deadcrootn_xfer , a_deadcrootn_xfer ) + CALL acc1d (grainn , a_grainn ) + CALL acc1d (grainn_storage , a_grainn_storage ) + CALL acc1d (grainn_xfer , a_grainn_xfer ) + CALL acc1d (retransn , a_retransn ) + CALL acc1d (gpp , a_gpp ) + CALL acc1d (downreg , a_downreg ) + CALL acc1d (ar , a_ar ) + CALL acc1d (cwdprod , a_cwdprod ) + CALL acc1d (cwddecomp , a_cwddecomp ) + CALL acc1d (decomp_hr , a_hr ) + CALL acc1d (fpg , a_fpg ) + CALL acc1d (fpi , a_fpi ) + CALL acc1d (gpp_enftemp , a_gpp_enftemp ) + CALL acc1d (gpp_enfboreal , a_gpp_enfboreal ) + CALL acc1d (gpp_dnfboreal , a_gpp_dnfboreal ) + CALL acc1d (gpp_ebftrop , a_gpp_ebftrop ) + CALL acc1d (gpp_ebftemp , a_gpp_ebftemp ) + CALL acc1d (gpp_dbftrop , a_gpp_dbftrop ) + CALL acc1d (gpp_dbftemp , a_gpp_dbftemp ) + CALL acc1d (gpp_dbfboreal , a_gpp_dbfboreal ) + CALL acc1d (gpp_ebstemp , a_gpp_ebstemp ) + CALL acc1d (gpp_dbstemp , a_gpp_dbstemp ) + CALL acc1d (gpp_dbsboreal , a_gpp_dbsboreal ) + CALL acc1d (gpp_c3arcgrass , a_gpp_c3arcgrass ) + CALL acc1d (gpp_c3grass , a_gpp_c3grass ) + CALL acc1d (gpp_c4grass , a_gpp_c4grass ) + CALL acc1d (leafc_enftemp , a_leafc_enftemp ) + CALL acc1d (leafc_enfboreal , a_leafc_enfboreal ) + CALL acc1d (leafc_dnfboreal , a_leafc_dnfboreal ) + CALL acc1d (leafc_ebftrop , a_leafc_ebftrop ) + CALL acc1d (leafc_ebftemp , a_leafc_ebftemp ) + CALL acc1d (leafc_dbftrop , a_leafc_dbftrop ) + CALL acc1d (leafc_dbftemp , a_leafc_dbftemp ) + CALL acc1d (leafc_dbfboreal , a_leafc_dbfboreal ) + CALL acc1d (leafc_ebstemp , a_leafc_ebstemp ) + CALL acc1d (leafc_dbstemp , a_leafc_dbstemp ) + CALL acc1d (leafc_dbsboreal , a_leafc_dbsboreal ) + CALL acc1d (leafc_c3arcgrass , a_leafc_c3arcgrass ) + CALL acc1d (leafc_c3grass , a_leafc_c3grass ) + CALL acc1d (leafc_c4grass , a_leafc_c4grass ) + IF(DEF_USE_NITRIF)THEN + CALL acc2d (to2_decomp_depth_unsat, a_O2_DECOMP_DEPTH_UNSAT) + CALL acc2d (tconc_o2_unsat , a_CONC_O2_UNSAT ) + ENDIF #ifdef CROP - call acc1d (pdcorn , a_pdcorn ) - call acc1d (pdswheat , a_pdswheat ) - call acc1d (pdwwheat , a_pdwwheat ) - call acc1d (pdsoybean , a_pdsoybean ) - call acc1d (pdcotton , a_pdcotton ) - call acc1d (pdrice1 , a_pdrice1 ) - call acc1d (pdrice2 , a_pdrice2 ) - call acc1d (pdsugarcane , a_pdsugarcane ) - call acc1d (plantdate , a_plantdate ) - call acc1d (fertnitro_corn , a_fertnitro_corn ) - call acc1d (fertnitro_swheat , a_fertnitro_swheat ) - call acc1d (fertnitro_wwheat , a_fertnitro_wwheat ) - call acc1d (fertnitro_soybean , a_fertnitro_soybean ) - call acc1d (fertnitro_cotton , a_fertnitro_cotton ) - call acc1d (fertnitro_rice1 , a_fertnitro_rice1 ) - call acc1d (fertnitro_rice2 , a_fertnitro_rice2 ) - call acc1d (fertnitro_sugarcane, a_fertnitro_sugarcane) - call acc1d (real(irrig_method_corn ,r8), a_irrig_method_corn ) - call acc1d (real(irrig_method_swheat ,r8), a_irrig_method_swheat ) - call acc1d (real(irrig_method_wwheat ,r8), a_irrig_method_wwheat ) - call acc1d (real(irrig_method_soybean ,r8), a_irrig_method_soybean ) - call acc1d (real(irrig_method_cotton ,r8), a_irrig_method_cotton ) - call acc1d (real(irrig_method_rice1 ,r8), a_irrig_method_rice1 ) - call acc1d (real(irrig_method_rice2 ,r8), a_irrig_method_rice2 ) - call acc1d (real(irrig_method_sugarcane,r8), a_irrig_method_sugarcane) - call acc1d (cphase , a_cphase ) - call acc1d (hui , a_hui ) - call acc1d (vf , a_vf ) - call acc1d (gddmaturity , a_gddmaturity ) - call acc1d (gddplant , a_gddplant ) - call acc1d (cropprod1c , a_cropprod1c ) - call acc1d (cropprod1c_loss , a_cropprod1c_loss ) - call acc1d (cropseedc_deficit , a_cropseedc_deficit ) - call acc1d (grainc_to_cropprodc, a_grainc_to_cropprodc) - call acc1d (grainc_to_seed , a_grainc_to_seed ) - call acc1d (fert_to_sminn , a_fert_to_sminn ) - - ! call acc1d (irrig_rate , a_irrig_rate ) - ! call acc1d (deficit_irrig , a_deficit_irrig ) - ! call acc1d (sum_irrig , a_sum_irrig ) - ! call acc1d (sum_irrig_count , a_sum_irrig_count ) - call acc1d (irrig_rate , a_irrig_rate ) - call acc1d (deficit_irrig , a_deficit_irrig ) + CALL acc1d (pdcorn , a_pdcorn ) + CALL acc1d (pdswheat , a_pdswheat ) + CALL acc1d (pdwwheat , a_pdwwheat ) + CALL acc1d (pdsoybean , a_pdsoybean ) + CALL acc1d (pdcotton , a_pdcotton ) + CALL acc1d (pdrice1 , a_pdrice1 ) + CALL acc1d (pdrice2 , a_pdrice2 ) + CALL acc1d (pdsugarcane , a_pdsugarcane ) + CALL acc1d (plantdate , a_plantdate ) + CALL acc1d (fertnitro_corn , a_fertnitro_corn ) + CALL acc1d (fertnitro_swheat , a_fertnitro_swheat ) + CALL acc1d (fertnitro_wwheat , a_fertnitro_wwheat ) + CALL acc1d (fertnitro_soybean , a_fertnitro_soybean ) + CALL acc1d (fertnitro_cotton , a_fertnitro_cotton ) + CALL acc1d (fertnitro_rice1 , a_fertnitro_rice1 ) + CALL acc1d (fertnitro_rice2 , a_fertnitro_rice2 ) + CALL acc1d (fertnitro_sugarcane, a_fertnitro_sugarcane) + CALL acc1d (real(irrig_method_corn ,r8), a_irrig_method_corn ) + CALL acc1d (real(irrig_method_swheat ,r8), a_irrig_method_swheat ) + CALL acc1d (real(irrig_method_wwheat ,r8), a_irrig_method_wwheat ) + CALL acc1d (real(irrig_method_soybean ,r8), a_irrig_method_soybean ) + CALL acc1d (real(irrig_method_cotton ,r8), a_irrig_method_cotton ) + CALL acc1d (real(irrig_method_rice1 ,r8), a_irrig_method_rice1 ) + CALL acc1d (real(irrig_method_rice2 ,r8), a_irrig_method_rice2 ) + CALL acc1d (real(irrig_method_sugarcane,r8), a_irrig_method_sugarcane) + CALL acc1d (cphase , a_cphase ) + CALL acc1d (hui , a_hui ) + CALL acc1d (vf , a_vf ) + CALL acc1d (gddmaturity , a_gddmaturity ) + CALL acc1d (gddplant , a_gddplant ) + CALL acc1d (cropprod1c , a_cropprod1c ) + CALL acc1d (cropprod1c_loss , a_cropprod1c_loss ) + CALL acc1d (cropseedc_deficit , a_cropseedc_deficit ) + CALL acc1d (grainc_to_cropprodc, a_grainc_to_cropprodc) + CALL acc1d (grainc_to_seed , a_grainc_to_seed ) + CALL acc1d (fert_to_sminn , a_fert_to_sminn ) + + ! CALL acc1d (irrig_rate , a_irrig_rate ) + ! CALL acc1d (deficit_irrig , a_deficit_irrig ) + ! CALL acc1d (sum_irrig , a_sum_irrig ) + ! CALL acc1d (sum_irrig_count , a_sum_irrig_count ) + CALL acc1d (irrig_rate , a_irrig_rate ) + CALL acc1d (deficit_irrig , a_deficit_irrig ) a_sum_irrig = sum_irrig a_sum_irrig_count = sum_irrig_count #endif - call acc1d (ndep_to_sminn , a_ndep_to_sminn ) - if(DEF_USE_FIRE)then - call acc1d (abm_lf , a_abm ) - call acc1d (gdp_lf , a_gdp ) - call acc1d (peatf_lf , a_peatf ) - call acc1d (hdm_lf , a_hdm ) - call acc1d (lnfm , a_lnfm ) - end if + CALL acc1d (ndep_to_sminn , a_ndep_to_sminn ) + IF(DEF_USE_FIRE)THEN + CALL acc1d (abm_lf , a_abm ) + CALL acc1d (gdp_lf , a_gdp ) + CALL acc1d (peatf_lf , a_peatf ) + CALL acc1d (hdm_lf , a_hdm ) + CALL acc1d (lnfm , a_lnfm ) + ENDIF #endif IF(DEF_USE_OZONESTRESS)THEN - call acc1d (forc_ozone , a_ozone ) + CALL acc1d (forc_ozone , a_ozone ) ENDIF - call acc2d (t_soisno , a_t_soisno ) - call acc2d (wliq_soisno, a_wliq_soisno ) - call acc2d (wice_soisno, a_wice_soisno ) - - call acc2d (h2osoi , a_h2osoi ) - call acc2d (rootr , a_rootr ) - call acc2d (BD_all , a_BD_all ) - call acc2d (wfc , a_wfc ) - call acc2d (OM_density , a_OM_density ) - if(DEF_USE_PLANTHYDRAULICS)then - call acc2d (vegwp , a_vegwp ) - end if - call acc2d (t_lake , a_t_lake ) - call acc2d (lake_icefrac, a_lake_icefrac ) + CALL acc2d (t_soisno , a_t_soisno ) + CALL acc2d (wliq_soisno, a_wliq_soisno ) + CALL acc2d (wice_soisno, a_wice_soisno ) + + CALL acc2d (h2osoi , a_h2osoi ) + CALL acc2d (rootr , a_rootr ) + CALL acc2d (BD_all , a_BD_all ) + CALL acc2d (wfc , a_wfc ) + CALL acc2d (OM_density , a_OM_density ) + IF(DEF_USE_PLANTHYDRAULICS)THEN + CALL acc2d (vegwp , a_vegwp ) + ENDIF + CALL acc2d (t_lake , a_t_lake ) + CALL acc2d (lake_icefrac, a_lake_icefrac ) #ifdef BGC - do i = 1, numpatch - do j = 1, nl_soil + DO i = 1, numpatch + DO j = 1, nl_soil decomp_vr_tmp(j,i) = decomp_cpools_vr(j,i_met_lit,i) - end do - end do - call acc2d (decomp_vr_tmp, a_litr1c_vr ) - do i = 1, numpatch - do j = 1, nl_soil + ENDDO + ENDDO + CALL acc2d (decomp_vr_tmp, a_litr1c_vr ) + DO i = 1, numpatch + DO j = 1, nl_soil decomp_vr_tmp(j,i) = decomp_cpools_vr(j,i_cel_lit,i) - end do - end do - call acc2d (decomp_vr_tmp, a_litr2c_vr ) - do i = 1, numpatch - do j = 1, nl_soil + ENDDO + ENDDO + CALL acc2d (decomp_vr_tmp, a_litr2c_vr ) + DO i = 1, numpatch + DO j = 1, nl_soil decomp_vr_tmp(j,i) = decomp_cpools_vr(j,i_lig_lit,i) - end do - end do - call acc2d (decomp_vr_tmp, a_litr3c_vr ) - do i = 1, numpatch - do j = 1, nl_soil + ENDDO + ENDDO + CALL acc2d (decomp_vr_tmp, a_litr3c_vr ) + DO i = 1, numpatch + DO j = 1, nl_soil decomp_vr_tmp(j,i) = decomp_cpools_vr(j,i_soil1,i) - end do - end do - call acc2d (decomp_vr_tmp, a_soil1c_vr ) - do i = 1, numpatch - do j = 1, nl_soil + ENDDO + ENDDO + CALL acc2d (decomp_vr_tmp, a_soil1c_vr ) + DO i = 1, numpatch + DO j = 1, nl_soil decomp_vr_tmp(j,i) = decomp_cpools_vr(j,i_soil2,i) - end do - end do - call acc2d (decomp_vr_tmp, a_soil2c_vr ) - do i = 1, numpatch - do j = 1, nl_soil + ENDDO + ENDDO + CALL acc2d (decomp_vr_tmp, a_soil2c_vr ) + DO i = 1, numpatch + DO j = 1, nl_soil decomp_vr_tmp(j,i) = decomp_cpools_vr(j,i_soil3,i) - end do - end do - call acc2d (decomp_vr_tmp, a_soil3c_vr ) - do i = 1, numpatch - do j = 1, nl_soil + ENDDO + ENDDO + CALL acc2d (decomp_vr_tmp, a_soil3c_vr ) + DO i = 1, numpatch + DO j = 1, nl_soil decomp_vr_tmp(j,i) = decomp_cpools_vr(j,i_cwd,i) - end do - end do - call acc2d (decomp_vr_tmp, a_cwdc_vr ) - do i = 1, numpatch - do j = 1, nl_soil + ENDDO + ENDDO + CALL acc2d (decomp_vr_tmp, a_cwdc_vr ) + DO i = 1, numpatch + DO j = 1, nl_soil decomp_vr_tmp(j,i) = decomp_npools_vr(j,i_met_lit,i) - end do - end do - call acc2d (decomp_vr_tmp, a_litr1n_vr ) - do i = 1, numpatch - do j = 1, nl_soil + ENDDO + ENDDO + CALL acc2d (decomp_vr_tmp, a_litr1n_vr ) + DO i = 1, numpatch + DO j = 1, nl_soil decomp_vr_tmp(j,i) = decomp_npools_vr(j,i_cel_lit,i) - end do - end do - call acc2d (decomp_vr_tmp, a_litr2n_vr ) - do i = 1, numpatch - do j = 1, nl_soil + ENDDO + ENDDO + CALL acc2d (decomp_vr_tmp, a_litr2n_vr ) + DO i = 1, numpatch + DO j = 1, nl_soil decomp_vr_tmp(j,i) = decomp_npools_vr(j,i_lig_lit,i) - end do - end do - call acc2d (decomp_vr_tmp, a_litr3n_vr ) - do i = 1, numpatch - do j = 1, nl_soil + ENDDO + ENDDO + CALL acc2d (decomp_vr_tmp, a_litr3n_vr ) + DO i = 1, numpatch + DO j = 1, nl_soil decomp_vr_tmp(j,i) = decomp_npools_vr(j,i_soil1,i) - end do - end do - call acc2d (decomp_vr_tmp, a_soil1n_vr ) - do i = 1, numpatch - do j = 1, nl_soil + ENDDO + ENDDO + CALL acc2d (decomp_vr_tmp, a_soil1n_vr ) + DO i = 1, numpatch + DO j = 1, nl_soil decomp_vr_tmp(j,i) = decomp_npools_vr(j,i_soil2,i) - end do - end do - call acc2d (decomp_vr_tmp, a_soil2n_vr ) - do i = 1, numpatch - do j = 1, nl_soil + ENDDO + ENDDO + CALL acc2d (decomp_vr_tmp, a_soil2n_vr ) + DO i = 1, numpatch + DO j = 1, nl_soil decomp_vr_tmp(j,i) = decomp_npools_vr(j,i_soil3,i) - end do - end do - call acc2d (decomp_vr_tmp, a_soil3n_vr ) - do i = 1, numpatch - do j = 1, nl_soil + ENDDO + ENDDO + CALL acc2d (decomp_vr_tmp, a_soil3n_vr ) + DO i = 1, numpatch + DO j = 1, nl_soil decomp_vr_tmp(j,i) = decomp_npools_vr(j,i_cwd,i) - end do - end do - call acc2d (decomp_vr_tmp, a_cwdn_vr ) - call acc2d (sminn_vr , a_sminn_vr ) + ENDDO + ENDDO + CALL acc2d (decomp_vr_tmp, a_cwdn_vr ) + CALL acc2d (sminn_vr , a_sminn_vr ) #endif allocate (r_ustar (numpatch)); r_ustar (:) = spval allocate (r_ustar2 (numpatch)); r_ustar2(:) = spval !Shaofeng, 2023.05.20 @@ -1854,7 +1854,7 @@ SUBROUTINE accumulate_fluxes tauy_e = sum(tauy (istt:iend) * elm_patch%subfrc(istt:iend), mask = filter) / sumwt fsena_e = sum(fsena (istt:iend) * elm_patch%subfrc(istt:iend), mask = filter) / sumwt fevpa_e = sum(fevpa (istt:iend) * elm_patch%subfrc(istt:iend), mask = filter) / sumwt - if (DEF_USE_CBL_HEIGHT) then !//TODO: Shaofeng, 2023.05.18 + IF (DEF_USE_CBL_HEIGHT) THEN !//TODO: Shaofeng, 2023.05.18 hpbl = sum(forc_hpbl(istt:iend) * elm_patch%subfrc(istt:iend), mask = filter) / sumwt ENDIF @@ -1882,36 +1882,36 @@ SUBROUTINE accumulate_fluxes r_zol_e = zldis*vonkar*grav * (r_tstar_e*(1.+0.61*qm)+0.61*th*r_qstar_e) & / (r_ustar_e**2*thv) - if(r_zol_e >= 0.)then !stable + IF(r_zol_e >= 0.)THEN !stable r_zol_e = min(2.,max(r_zol_e,1.e-6)) - else !unstable + ELSE !unstable r_zol_e = max(-100.,min(r_zol_e,-1.e-6)) - endif + ENDIF beta = 1. zii = 1000. thvstar=r_tstar_e*(1.+0.61*qm)+0.61*th*r_qstar_e ur = sqrt(us*us+vs*vs) - if(r_zol_e >= 0.)then + IF(r_zol_e >= 0.)THEN um = max(ur,0.1) - else - if (DEF_USE_CBL_HEIGHT) then !//TODO: Shaofeng, 2023.05.18 + ELSE + IF (DEF_USE_CBL_HEIGHT) THEN !//TODO: Shaofeng, 2023.05.18 zii = max(5.*hgt_u,hpbl) - endif !//TODO: Shaofeng, 2023.05.18 + ENDIF !//TODO: Shaofeng, 2023.05.18 wc = (-grav*r_ustar_e*thvstar*zii/thv)**(1./3.) wc2 = beta*beta*(wc*wc) um = max(0.1,sqrt(ur*ur+wc2)) - endif + ENDIF obu = zldis/r_zol_e - if (DEF_USE_CBL_HEIGHT) then - call moninobuk_leddy(hgt_u,hgt_t,hgt_q,displa_av,z0m_av,z0h_av,z0q_av,& + IF (DEF_USE_CBL_HEIGHT) THEN + CALL moninobuk_leddy(hgt_u,hgt_t,hgt_q,displa_av,z0m_av,z0h_av,z0q_av,& obu,um, hpbl, r_ustar2_e,fh2m,fq2m,r_fm10m_e,r_fm_e,r_fh_e,r_fq_e) !Shaofeng, 2023.05.20 - else - call moninobuk(hgt_u,hgt_t,hgt_q,displa_av,z0m_av,z0h_av,z0q_av,& + ELSE + CALL moninobuk(hgt_u,hgt_t,hgt_q,displa_av,z0m_av,z0h_av,z0q_av,& obu,um,r_ustar2_e,fh2m,fq2m,r_fm10m_e,r_fm_e,r_fh_e,r_fq_e) !Shaofeng, 2023.05.20 - endif + ENDIF ! bug found by chen qiying 2013/07/01 r_rib_e = r_zol_e /vonkar * r_ustar2_e**2 / (vonkar/r_fh_e*um**2) @@ -1937,21 +1937,21 @@ SUBROUTINE accumulate_fluxes deallocate(filter) - end do + ENDDO - call acc1d (r_ustar , a_ustar ) - call acc1d (r_ustar2, a_ustar2) - call acc1d (r_tstar , a_tstar ) - call acc1d (r_qstar , a_qstar ) - call acc1d (r_zol , a_zol ) - call acc1d (r_rib , a_rib ) - call acc1d (r_fm , a_fm ) - call acc1d (r_fh , a_fh ) - call acc1d (r_fq , a_fq ) + CALL acc1d (r_ustar , a_ustar ) + CALL acc1d (r_ustar2, a_ustar2) + CALL acc1d (r_tstar , a_tstar ) + CALL acc1d (r_qstar , a_qstar ) + CALL acc1d (r_zol , a_zol ) + CALL acc1d (r_rib , a_rib ) + CALL acc1d (r_fm , a_fm ) + CALL acc1d (r_fh , a_fh ) + CALL acc1d (r_fq , a_fq ) - call acc1d (r_us10m, a_us10m) - call acc1d (r_vs10m, a_vs10m) - call acc1d (r_fm10m, a_fm10m) + CALL acc1d (r_us10m, a_us10m) + CALL acc1d (r_vs10m, a_vs10m) + CALL acc1d (r_fm10m, a_fm10m) deallocate (r_ustar ) deallocate (r_ustar2) !Shaofeng, 2023.05.20 @@ -1967,32 +1967,32 @@ SUBROUTINE accumulate_fluxes deallocate (r_vs10m ) deallocate (r_fm10m ) - call acc1d (sr , a_sr ) - call acc1d (solvd , a_solvd ) - call acc1d (solvi , a_solvi ) - call acc1d (solnd , a_solnd ) - call acc1d (solni , a_solni ) - call acc1d (srvd , a_srvd ) - call acc1d (srvi , a_srvi ) - call acc1d (srnd , a_srnd ) - call acc1d (srni , a_srni ) - call acc1d (solvdln, a_solvdln) - call acc1d (solviln, a_solviln) - call acc1d (solndln, a_solndln) - call acc1d (solniln, a_solniln) - call acc1d (srvdln , a_srvdln ) - call acc1d (srviln , a_srviln ) - call acc1d (srndln , a_srndln ) - call acc1d (srniln , a_srniln ) - - do i = 1, numpatch - if (solvdln(i) /= spval) then + CALL acc1d (sr , a_sr ) + CALL acc1d (solvd , a_solvd ) + CALL acc1d (solvi , a_solvi ) + CALL acc1d (solnd , a_solnd ) + CALL acc1d (solni , a_solni ) + CALL acc1d (srvd , a_srvd ) + CALL acc1d (srvi , a_srvi ) + CALL acc1d (srnd , a_srnd ) + CALL acc1d (srni , a_srni ) + CALL acc1d (solvdln, a_solvdln) + CALL acc1d (solviln, a_solviln) + CALL acc1d (solndln, a_solndln) + CALL acc1d (solniln, a_solniln) + CALL acc1d (srvdln , a_srvdln ) + CALL acc1d (srviln , a_srviln ) + CALL acc1d (srndln , a_srndln ) + CALL acc1d (srniln , a_srniln ) + + DO i = 1, numpatch + IF (solvdln(i) /= spval) THEN nac_ln(i) = nac_ln(i) + 1 - end if - end do + ENDIF + ENDDO - end if - end if + ENDIF + ENDIF #ifdef LATERAL_FLOW CALL accumulate_fluxes_basin () @@ -2004,83 +2004,83 @@ END SUBROUTINE accumulate_fluxes !------ SUBROUTINE acc1d (var, s) - use MOD_Precision - use MOD_Vars_Global, only: spval + USE MOD_Precision + USE MOD_Vars_Global, only: spval - IMPLICIT NONE + IMPLICIT NONE - real(r8), intent(in) :: var(:) - real(r8), intent(inout) :: s (:) - ! Local variables - integer :: i + real(r8), intent(in) :: var(:) + real(r8), intent(inout) :: s (:) + ! Local variables + integer :: i - do i = lbound(var,1), ubound(var,1) - if (var(i) /= spval) then - if (s(i) /= spval) then + DO i = lbound(var,1), ubound(var,1) + IF (var(i) /= spval) THEN + IF (s(i) /= spval) THEN s(i) = s(i) + var(i) - else + ELSE s(i) = var(i) - end if - end if - end do + ENDIF + ENDIF + ENDDO END SUBROUTINE acc1d !------ SUBROUTINE acc2d (var, s) - use MOD_Precision - use MOD_Vars_Global, only: spval + USE MOD_Precision + USE MOD_Vars_Global, only: spval - IMPLICIT NONE + IMPLICIT NONE - real(r8), intent(in) :: var(:,:) - real(r8), intent(inout) :: s (:,:) - ! Local variables - integer :: i1, i2 + real(r8), intent(in) :: var(:,:) + real(r8), intent(inout) :: s (:,:) + ! Local variables + integer :: i1, i2 - do i2 = lbound(var,2), ubound(var,2) - do i1 = lbound(var,1), ubound(var,1) - if (var(i1,i2) /= spval) then - if (s(i1,i2) /= spval) then + DO i2 = lbound(var,2), ubound(var,2) + DO i1 = lbound(var,1), ubound(var,1) + IF (var(i1,i2) /= spval) THEN + IF (s(i1,i2) /= spval) THEN s(i1,i2) = s(i1,i2) + var(i1,i2) - else + ELSE s(i1,i2) = var(i1,i2) - end if - end if - end do - end do + ENDIF + ENDIF + ENDDO + ENDDO END SUBROUTINE acc2d !------ SUBROUTINE acc3d (var, s) - use MOD_Precision - use MOD_Vars_Global, only: spval + USE MOD_Precision + USE MOD_Vars_Global, only: spval - IMPLICIT NONE + IMPLICIT NONE - real(r8), intent(in) :: var(:,:,:) - real(r8), intent(inout) :: s (:,:,:) - ! Local variables - integer :: i1, i2, i3 + real(r8), intent(in) :: var(:,:,:) + real(r8), intent(inout) :: s (:,:,:) + ! Local variables + integer :: i1, i2, i3 - do i3 = lbound(var,3), ubound(var,3) - do i2 = lbound(var,2), ubound(var,2) - do i1 = lbound(var,1), ubound(var,1) - if (var(i1,i2,i3) /= spval) then - if (s(i1,i2,i3) /= spval) then + DO i3 = lbound(var,3), ubound(var,3) + DO i2 = lbound(var,2), ubound(var,2) + DO i1 = lbound(var,1), ubound(var,1) + IF (var(i1,i2,i3) /= spval) THEN + IF (s(i1,i2,i3) /= spval) THEN s(i1,i2,i3) = s(i1,i2,i3) + var(i1,i2,i3) - else + ELSE s(i1,i2,i3) = var(i1,i2,i3) - end if - end if - end do - end do - end do + ENDIF + ENDIF + ENDDO + ENDDO + ENDDO END SUBROUTINE acc3d -end module MOD_Vars_1DAccFluxes +END MODULE MOD_Vars_1DAccFluxes ! ----- EOP --------- diff --git a/main/MOD_Vars_1DFluxes.F90 b/main/MOD_Vars_1DFluxes.F90 index c146bbe1..07fbba42 100644 --- a/main/MOD_Vars_1DFluxes.F90 +++ b/main/MOD_Vars_1DFluxes.F90 @@ -5,98 +5,98 @@ MODULE MOD_Vars_1DFluxes ! Created by Yongjiu Dai, 03/2014 ! ------------------------------- - USE MOD_Precision + USE MOD_Precision #if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) - USE MOD_Vars_1DPFTFluxes + USE MOD_Vars_1DPFTFluxes #endif #ifdef BGC - USE MOD_BGC_Vars_1DFluxes + USE MOD_BGC_Vars_1DFluxes #endif #ifdef LATERAL_FLOW - USE MOD_Hydro_Vars_1DFluxes + USE MOD_Hydro_Vars_1DFluxes #endif #ifdef URBAN_MODEL - USE MOD_Urban_Vars_1DFluxes + USE MOD_Urban_Vars_1DFluxes #endif - IMPLICIT NONE - SAVE + IMPLICIT NONE + SAVE ! ----------------------------------------------------------------- ! Fluxes ! ----------------------------------------------------------------- - REAL(r8), allocatable :: taux (:) !wind stress: E-W [kg/m/s2] - REAL(r8), allocatable :: tauy (:) !wind stress: N-S [kg/m/s2] - REAL(r8), allocatable :: fsena (:) !sensible heat from canopy height to atmosphere [W/m2] - REAL(r8), allocatable :: lfevpa (:) !latent heat flux from canopy height to atmosphere [W/m2] - REAL(r8), allocatable :: fevpa (:) !evapotranspiration from canopy to atmosphere [mm/s] - REAL(r8), allocatable :: fsenl (:) !sensible heat from leaves [W/m2] - REAL(r8), allocatable :: fevpl (:) !evaporation+transpiration from leaves [mm/s] - REAL(r8), allocatable :: etr (:) !transpiration rate [mm/s] - REAL(r8), allocatable :: fseng (:) !sensible heat flux from ground [W/m2] - REAL(r8), allocatable :: fevpg (:) !evaporation heat flux from ground [mm/s] - REAL(r8), allocatable :: fgrnd (:) !ground heat flux [W/m2] - REAL(r8), allocatable :: sabvsun(:) !solar absorbed by sunlit vegetation [W/m2] - REAL(r8), allocatable :: sabvsha(:) !solar absorbed by shaded vegetation [W/m2] - REAL(r8), allocatable :: sabg (:) !solar absorbed by ground [W/m2] - REAL(r8), allocatable :: sr (:) !total reflected solar radiation (W/m2) - REAL(r8), allocatable :: solvd (:) !incident direct beam vis solar radiation (W/m2) - REAL(r8), allocatable :: solvi (:) !incident diffuse beam vis solar radiation (W/m2) - REAL(r8), allocatable :: solnd (:) !incident direct beam nir solar radiation (W/m2) - REAL(r8), allocatable :: solni (:) !incident diffuse beam nir solar radiation (W/m2) - REAL(r8), allocatable :: srvd (:) !reflected direct beam vis solar radiation (W/m2) - REAL(r8), allocatable :: srvi (:) !reflected diffuse beam vis solar radiation (W/m2) - REAL(r8), allocatable :: srnd (:) !reflected direct beam nir solar radiation (W/m2) - REAL(r8), allocatable :: srni (:) !reflected diffuse beam nir solar radiation (W/m2) - REAL(r8), allocatable :: solvdln(:) !incident direct beam vis solar radiation at local noon (W/m2) - REAL(r8), allocatable :: solviln(:) !incident diffuse beam vis solar radiation at local noon (W/m2) - REAL(r8), allocatable :: solndln(:) !incident direct beam nir solar radiation at local noon (W/m2) - REAL(r8), allocatable :: solniln(:) !incident diffuse beam nir solar radiation at local noon (W/m2) - REAL(r8), allocatable :: srvdln (:) !reflected direct beam vis solar radiation at local noon (W/m2) - REAL(r8), allocatable :: srviln (:) !reflected diffuse beam vis solar radiation at local noon (W/m2) - REAL(r8), allocatable :: srndln (:) !reflected direct beam nir solar radiation at local noon (W/m2) - REAL(r8), allocatable :: srniln (:) !reflected diffuse beam nir solar radiation at local noon (W/m2) - REAL(r8), allocatable :: olrg (:) !outgoing long-wave radiation from ground+canopy [W/m2] - REAL(r8), allocatable :: rnet (:) !net radiation by surface [W/m2] - REAL(r8), allocatable :: xerr (:) !the error of water banace [mm/s] - REAL(r8), allocatable :: zerr (:) !the error of energy balance [W/m2] - REAL(r8), allocatable :: rsur (:) !surface runoff (mm h2o/s) - REAL(r8), allocatable :: rsub (:) !subsurface runoff (mm h2o/s) - REAL(r8), allocatable :: rnof (:) !total runoff (mm h2o/s) - REAL(r8), allocatable :: qintr (:) !interception (mm h2o/s) - REAL(r8), allocatable :: qinfl (:) !inflitration (mm h2o/s) - REAL(r8), allocatable :: qdrip (:) !throughfall (mm h2o/s) - REAL(r8), allocatable :: assim (:) !canopy assimilation rate (mol m-2 s-1) - REAL(r8), allocatable :: respc (:) !canopy respiration (mol m-2 s-1) - - REAL(r8), allocatable :: qcharge(:) !groundwater recharge [mm/s] - - INTEGER, allocatable :: oroflag(:) !groundwater recharge [mm/s] + real(r8), allocatable :: taux (:) !wind stress: E-W [kg/m/s2] + real(r8), allocatable :: tauy (:) !wind stress: N-S [kg/m/s2] + real(r8), allocatable :: fsena (:) !sensible heat from canopy height to atmosphere [W/m2] + real(r8), allocatable :: lfevpa (:) !latent heat flux from canopy height to atmosphere [W/m2] + real(r8), allocatable :: fevpa (:) !evapotranspiration from canopy to atmosphere [mm/s] + real(r8), allocatable :: fsenl (:) !sensible heat from leaves [W/m2] + real(r8), allocatable :: fevpl (:) !evaporation+transpiration from leaves [mm/s] + real(r8), allocatable :: etr (:) !transpiration rate [mm/s] + real(r8), allocatable :: fseng (:) !sensible heat flux from ground [W/m2] + real(r8), allocatable :: fevpg (:) !evaporation heat flux from ground [mm/s] + real(r8), allocatable :: fgrnd (:) !ground heat flux [W/m2] + real(r8), allocatable :: sabvsun(:) !solar absorbed by sunlit vegetation [W/m2] + real(r8), allocatable :: sabvsha(:) !solar absorbed by shaded vegetation [W/m2] + real(r8), allocatable :: sabg (:) !solar absorbed by ground [W/m2] + real(r8), allocatable :: sr (:) !total reflected solar radiation (W/m2) + real(r8), allocatable :: solvd (:) !incident direct beam vis solar radiation (W/m2) + real(r8), allocatable :: solvi (:) !incident diffuse beam vis solar radiation (W/m2) + real(r8), allocatable :: solnd (:) !incident direct beam nir solar radiation (W/m2) + real(r8), allocatable :: solni (:) !incident diffuse beam nir solar radiation (W/m2) + real(r8), allocatable :: srvd (:) !reflected direct beam vis solar radiation (W/m2) + real(r8), allocatable :: srvi (:) !reflected diffuse beam vis solar radiation (W/m2) + real(r8), allocatable :: srnd (:) !reflected direct beam nir solar radiation (W/m2) + real(r8), allocatable :: srni (:) !reflected diffuse beam nir solar radiation (W/m2) + real(r8), allocatable :: solvdln(:) !incident direct beam vis solar radiation at local noon (W/m2) + real(r8), allocatable :: solviln(:) !incident diffuse beam vis solar radiation at local noon (W/m2) + real(r8), allocatable :: solndln(:) !incident direct beam nir solar radiation at local noon (W/m2) + real(r8), allocatable :: solniln(:) !incident diffuse beam nir solar radiation at local noon (W/m2) + real(r8), allocatable :: srvdln (:) !reflected direct beam vis solar radiation at local noon (W/m2) + real(r8), allocatable :: srviln (:) !reflected diffuse beam vis solar radiation at local noon (W/m2) + real(r8), allocatable :: srndln (:) !reflected direct beam nir solar radiation at local noon (W/m2) + real(r8), allocatable :: srniln (:) !reflected diffuse beam nir solar radiation at local noon (W/m2) + real(r8), allocatable :: olrg (:) !outgoing long-wave radiation from ground+canopy [W/m2] + real(r8), allocatable :: rnet (:) !net radiation by surface [W/m2] + real(r8), allocatable :: xerr (:) !the error of water banace [mm/s] + real(r8), allocatable :: zerr (:) !the error of energy balance [W/m2] + real(r8), allocatable :: rsur (:) !surface runoff (mm h2o/s) + real(r8), allocatable :: rsub (:) !subsurface runoff (mm h2o/s) + real(r8), allocatable :: rnof (:) !total runoff (mm h2o/s) + real(r8), allocatable :: qintr (:) !interception (mm h2o/s) + real(r8), allocatable :: qinfl (:) !inflitration (mm h2o/s) + real(r8), allocatable :: qdrip (:) !throughfall (mm h2o/s) + real(r8), allocatable :: assim (:) !canopy assimilation rate (mol m-2 s-1) + real(r8), allocatable :: respc (:) !canopy respiration (mol m-2 s-1) + + real(r8), allocatable :: qcharge(:) !groundwater recharge [mm/s] + + integer, allocatable :: oroflag(:) !groundwater recharge [mm/s] ! PUBLIC MEMBER FUNCTIONS: - PUBLIC :: allocate_1D_Fluxes - PUBLIC :: deallocate_1D_Fluxes + PUBLIC :: allocate_1D_Fluxes + PUBLIC :: deallocate_1D_Fluxes ! PRIVATE MEMBER FUNCTIONS: !----------------------------------------------------------------------- - CONTAINS +CONTAINS !----------------------------------------------------------------------- - SUBROUTINE allocate_1D_Fluxes - ! -------------------------------------------------------------------- - ! Allocates memory for CoLM 1d [numpatch] variables - ! -------------------------------------------------------------------- - USE MOD_Precision - USE MOD_Vars_Global - USE MOD_SPMD_Task - USE MOD_LandPatch - IMPLICIT NONE + SUBROUTINE allocate_1D_Fluxes + ! -------------------------------------------------------------------- + ! Allocates memory for CoLM 1d [numpatch] variables + ! -------------------------------------------------------------------- + USE MOD_Precision + USE MOD_Vars_Global + USE MOD_SPMD_Task + USE MOD_LandPatch + IMPLICIT NONE - if (p_is_worker) then + IF (p_is_worker) THEN - if (numpatch > 0) then + IF (numpatch > 0) THEN allocate ( taux (numpatch) ) ; taux (:) = spval ! wind stress: E-W [kg/m/s2] allocate ( tauy (numpatch) ) ; tauy (:) = spval ! wind stress: N-S [kg/m/s2] @@ -147,8 +147,8 @@ SUBROUTINE allocate_1D_Fluxes allocate ( oroflag(numpatch) ) ; oroflag(:) = spval_i4 ! - end if - end if + ENDIF + ENDIF #if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) CALL allocate_1D_PFTFluxes @@ -169,85 +169,84 @@ SUBROUTINE allocate_1D_Fluxes END SUBROUTINE allocate_1D_Fluxes SUBROUTINE deallocate_1D_Fluxes () - ! -------------------------------------------------------------------- - ! deallocates memory for CoLM 1d [numpatch] variables - ! -------------------------------------------------------------------- - USE MOD_SPMD_Task - USE MOD_LandPatch - - if (p_is_worker) then - - if (numpatch > 0) then - - deallocate ( taux ) ! wind stress: E-W [kg/m/s2] - deallocate ( tauy ) ! wind stress: N-S [kg/m/s2] - deallocate ( fsena ) ! sensible heat from canopy height to atmosphere [W/m2] - deallocate ( lfevpa ) ! latent heat flux from canopy height to atmosphere [W/m2] - deallocate ( fevpa ) ! evapotranspiration from canopy to atmosphere [mm/s] - deallocate ( fsenl ) ! sensible heat from leaves [W/m2] - deallocate ( fevpl ) ! evaporation+transpiration from leaves [mm/s] - deallocate ( etr ) ! transpiration rate [mm/s] - deallocate ( fseng ) ! sensible heat flux from ground [W/m2] - deallocate ( fevpg ) ! evaporation heat flux from ground [mm/s] - deallocate ( fgrnd ) ! ground heat flux [W/m2] - deallocate ( sabvsun ) ! solar absorbed by sunlit vegetation [W/m2] - deallocate ( sabvsha ) ! solar absorbed by shaded vegetation [W/m2] - deallocate ( sabg ) ! solar absorbed by ground [W/m2] - deallocate ( sr ) ! incident direct beam vis solar radiation (W/m2) - deallocate ( solvd ) ! incident direct beam vis solar radiation (W/m2) - deallocate ( solvi ) ! incident diffuse beam vis solar radiation (W/m2) - deallocate ( solnd ) ! incident direct beam nir solar radiation (W/m2) - deallocate ( solni ) ! incident diffuse beam nir solar radiation (W/m2) - deallocate ( srvd ) ! reflected direct beam vis solar radiation (W/m2) - deallocate ( srvi ) ! reflected diffuse beam vis solar radiation (W/m2) - deallocate ( srnd ) ! reflected direct beam nir solar radiation (W/m2) - deallocate ( srni ) ! reflected diffuse beam nir solar radiation (W/m2) - deallocate ( solvdln ) ! incident direct beam vis solar radiation at local noon(W/m2) - deallocate ( solviln ) ! incident diffuse beam vis solar radiation at local noon(W/m2) - deallocate ( solndln ) ! incident direct beam nir solar radiation at local noon(W/m2) - deallocate ( solniln ) ! incident diffuse beam nir solar radiation at local noon(W/m2) - deallocate ( srvdln ) ! reflected direct beam vis solar radiation at local noon(W/m2) - deallocate ( srviln ) ! reflected diffuse beam vis solar radiation at local noon(W/m2) - deallocate ( srndln ) ! reflected direct beam nir solar radiation at local noon(W/m2) - deallocate ( srniln ) ! reflected diffuse beam nir solar radiation at local noon(W/m2) - deallocate ( olrg ) ! outgoing long-wave radiation from ground+canopy [W/m2] - deallocate ( rnet ) ! net radiation by surface [W/m2] - deallocate ( xerr ) ! the error of water banace [mm/s] - deallocate ( zerr ) ! the error of energy balance [W/m2] - deallocate ( rsur ) ! surface runoff (mm h2o/s) - deallocate ( rsub ) ! subsurface runoff (mm h2o/s) - deallocate ( rnof ) ! total runoff (mm h2o/s) - deallocate ( qintr ) ! interception (mm h2o/s) - deallocate ( qinfl ) ! inflitration (mm h2o/s) - deallocate ( qdrip ) ! throughfall (mm h2o/s) - deallocate ( assim ) ! canopy assimilation rate (mol m-2 s-1) - deallocate ( respc ) ! canopy respiration (mol m-2 s-1) - - deallocate ( qcharge ) ! groundwater recharge [mm/s] - - deallocate ( oroflag ) ! - - end if - end if + ! -------------------------------------------------------------------- + ! deallocates memory for CoLM 1d [numpatch] variables + ! -------------------------------------------------------------------- + USE MOD_SPMD_Task + USE MOD_LandPatch + + IF (p_is_worker) THEN + + IF (numpatch > 0) THEN + + deallocate ( taux ) ! wind stress: E-W [kg/m/s2] + deallocate ( tauy ) ! wind stress: N-S [kg/m/s2] + deallocate ( fsena ) ! sensible heat from canopy height to atmosphere [W/m2] + deallocate ( lfevpa ) ! latent heat flux from canopy height to atmosphere [W/m2] + deallocate ( fevpa ) ! evapotranspiration from canopy to atmosphere [mm/s] + deallocate ( fsenl ) ! sensible heat from leaves [W/m2] + deallocate ( fevpl ) ! evaporation+transpiration from leaves [mm/s] + deallocate ( etr ) ! transpiration rate [mm/s] + deallocate ( fseng ) ! sensible heat flux from ground [W/m2] + deallocate ( fevpg ) ! evaporation heat flux from ground [mm/s] + deallocate ( fgrnd ) ! ground heat flux [W/m2] + deallocate ( sabvsun ) ! solar absorbed by sunlit vegetation [W/m2] + deallocate ( sabvsha ) ! solar absorbed by shaded vegetation [W/m2] + deallocate ( sabg ) ! solar absorbed by ground [W/m2] + deallocate ( sr ) ! incident direct beam vis solar radiation (W/m2) + deallocate ( solvd ) ! incident direct beam vis solar radiation (W/m2) + deallocate ( solvi ) ! incident diffuse beam vis solar radiation (W/m2) + deallocate ( solnd ) ! incident direct beam nir solar radiation (W/m2) + deallocate ( solni ) ! incident diffuse beam nir solar radiation (W/m2) + deallocate ( srvd ) ! reflected direct beam vis solar radiation (W/m2) + deallocate ( srvi ) ! reflected diffuse beam vis solar radiation (W/m2) + deallocate ( srnd ) ! reflected direct beam nir solar radiation (W/m2) + deallocate ( srni ) ! reflected diffuse beam nir solar radiation (W/m2) + deallocate ( solvdln ) ! incident direct beam vis solar radiation at local noon(W/m2) + deallocate ( solviln ) ! incident diffuse beam vis solar radiation at local noon(W/m2) + deallocate ( solndln ) ! incident direct beam nir solar radiation at local noon(W/m2) + deallocate ( solniln ) ! incident diffuse beam nir solar radiation at local noon(W/m2) + deallocate ( srvdln ) ! reflected direct beam vis solar radiation at local noon(W/m2) + deallocate ( srviln ) ! reflected diffuse beam vis solar radiation at local noon(W/m2) + deallocate ( srndln ) ! reflected direct beam nir solar radiation at local noon(W/m2) + deallocate ( srniln ) ! reflected diffuse beam nir solar radiation at local noon(W/m2) + deallocate ( olrg ) ! outgoing long-wave radiation from ground+canopy [W/m2] + deallocate ( rnet ) ! net radiation by surface [W/m2] + deallocate ( xerr ) ! the error of water banace [mm/s] + deallocate ( zerr ) ! the error of energy balance [W/m2] + deallocate ( rsur ) ! surface runoff (mm h2o/s) + deallocate ( rsub ) ! subsurface runoff (mm h2o/s) + deallocate ( rnof ) ! total runoff (mm h2o/s) + deallocate ( qintr ) ! interception (mm h2o/s) + deallocate ( qinfl ) ! inflitration (mm h2o/s) + deallocate ( qdrip ) ! throughfall (mm h2o/s) + deallocate ( assim ) ! canopy assimilation rate (mol m-2 s-1) + deallocate ( respc ) ! canopy respiration (mol m-2 s-1) + + deallocate ( qcharge ) ! groundwater recharge [mm/s] + + deallocate ( oroflag ) ! + + ENDIF + ENDIF #if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) - CALL deallocate_1D_PFTFluxes + CALL deallocate_1D_PFTFluxes #endif #ifdef BGC - CALL deallocate_1D_BGCFluxes + CALL deallocate_1D_BGCFluxes #endif #ifdef LATERAL_FLOW - CALL deallocate_1D_HydroFluxes + CALL deallocate_1D_HydroFluxes #endif #ifdef URBAN_MODEL - CALL deallocate_1D_UrbanFluxes + CALL deallocate_1D_UrbanFluxes #endif END SUBROUTINE deallocate_1D_Fluxes END MODULE MOD_Vars_1DFluxes ! ---------- EOP ------------ - diff --git a/main/MOD_Vars_1DForcing.F90 b/main/MOD_Vars_1DForcing.F90 index 1490899b..8f2743a4 100644 --- a/main/MOD_Vars_1DForcing.F90 +++ b/main/MOD_Vars_1DForcing.F90 @@ -7,195 +7,195 @@ MODULE MOD_Vars_1DForcing ! Created by Yongjiu Dai, 03/2014 ! ------------------------------- -USE MOD_Precision -USE MOD_Namelist -IMPLICIT NONE -SAVE + USE MOD_Precision + USE MOD_Namelist + IMPLICIT NONE + SAVE ! ----------------------------------------------------------------- - REAL(r8), allocatable :: forc_pco2m (:) ! CO2 concentration in atmos. (pascals) - REAL(r8), allocatable :: forc_po2m (:) ! O2 concentration in atmos. (pascals) - REAL(r8), allocatable :: forc_us (:) ! wind in eastward direction [m/s] - REAL(r8), allocatable :: forc_vs (:) ! wind in northward direction [m/s] - REAL(r8), allocatable :: forc_t (:) ! temperature at reference height [kelvin] - REAL(r8), allocatable :: forc_q (:) ! specific humidity at reference height [kg/kg] - REAL(r8), allocatable :: forc_prc (:) ! convective precipitation [mm/s] - REAL(r8), allocatable :: forc_prl (:) ! large scale precipitation [mm/s] - REAL(r8), allocatable :: forc_rain (:) ! rain [mm/s] - REAL(r8), allocatable :: forc_snow (:) ! snow [mm/s] - REAL(r8), allocatable :: forc_psrf (:) ! atmospheric pressure at the surface [pa] - REAL(r8), allocatable :: forc_pbot (:) ! atm bottom level pressure (or reference height) (pa) - REAL(r8), allocatable :: forc_sols (:) ! atm vis direct beam solar rad onto srf [W/m2] - REAL(r8), allocatable :: forc_soll (:) ! atm nir direct beam solar rad onto srf [W/m2] - REAL(r8), allocatable :: forc_solsd (:) ! atm vis diffuse solar rad onto srf [W/m2] - REAL(r8), allocatable :: forc_solld (:) ! atm nir diffuse solar rad onto srf [W/m2] - REAL(r8), allocatable :: forc_frl (:) ! atmospheric infrared (longwave) radiation [W/m2] - REAL(r8), allocatable :: forc_hgt_u (:) ! observational height of wind [m] - REAL(r8), allocatable :: forc_hgt_t (:) ! observational height of temperature [m] - REAL(r8), allocatable :: forc_hgt_q (:) ! observational height of humidity [m] - REAL(r8), allocatable :: forc_rhoair(:) ! air density [kg/m3] - REAL(r8), allocatable :: forc_ozone (:) ! air density [kg/m3] - - ! For Forcing_Downscaling - REAL(r8), allocatable :: forc_topo (:) ! topography [m] - REAL(r8), allocatable :: forc_th (:) ! potential temperature [K] - - REAL(r8), allocatable :: forc_topo_elm (:) ! atmospheric surface height [m] - REAL(r8), allocatable :: forc_t_elm (:) ! atmospheric temperature [Kelvin] - REAL(r8), allocatable :: forc_th_elm (:) ! atmospheric potential temperature [Kelvin] - REAL(r8), allocatable :: forc_q_elm (:) ! atmospheric specific humidity [kg/kg] - REAL(r8), allocatable :: forc_pbot_elm (:) ! atmospheric pressure [Pa] - REAL(r8), allocatable :: forc_rho_elm (:) ! atmospheric density [kg/m**3] - REAL(r8), allocatable :: forc_prc_elm (:) ! convective precipitation in grid [mm/s] - REAL(r8), allocatable :: forc_prl_elm (:) ! large-scale precipitation in grid [mm/s] - REAL(r8), allocatable :: forc_lwrad_elm (:) ! grid downward longwave [W/m**2] - REAL(r8), allocatable :: forc_hgt_elm (:) ! atmospheric reference height [m] - - REAL(r8), allocatable :: forc_hpbl (:) ! atmospheric boundary layer height [m] - real(r8), allocatable :: forc_aerdep(:,:) ! atmospheric aerosol deposition data [kg/m/s] - - ! PUBLIC MEMBER FUNCTIONS: - PUBLIC :: allocate_1D_Forcing - PUBLIC :: deallocate_1D_Forcing + real(r8), allocatable :: forc_pco2m (:) ! CO2 concentration in atmos. (pascals) + real(r8), allocatable :: forc_po2m (:) ! O2 concentration in atmos. (pascals) + real(r8), allocatable :: forc_us (:) ! wind in eastward direction [m/s] + real(r8), allocatable :: forc_vs (:) ! wind in northward direction [m/s] + real(r8), allocatable :: forc_t (:) ! temperature at reference height [kelvin] + real(r8), allocatable :: forc_q (:) ! specific humidity at reference height [kg/kg] + real(r8), allocatable :: forc_prc (:) ! convective precipitation [mm/s] + real(r8), allocatable :: forc_prl (:) ! large scale precipitation [mm/s] + real(r8), allocatable :: forc_rain (:) ! rain [mm/s] + real(r8), allocatable :: forc_snow (:) ! snow [mm/s] + real(r8), allocatable :: forc_psrf (:) ! atmospheric pressure at the surface [pa] + real(r8), allocatable :: forc_pbot (:) ! atm bottom level pressure (or reference height) (pa) + real(r8), allocatable :: forc_sols (:) ! atm vis direct beam solar rad onto srf [W/m2] + real(r8), allocatable :: forc_soll (:) ! atm nir direct beam solar rad onto srf [W/m2] + real(r8), allocatable :: forc_solsd (:) ! atm vis diffuse solar rad onto srf [W/m2] + real(r8), allocatable :: forc_solld (:) ! atm nir diffuse solar rad onto srf [W/m2] + real(r8), allocatable :: forc_frl (:) ! atmospheric infrared (longwave) radiation [W/m2] + real(r8), allocatable :: forc_hgt_u (:) ! observational height of wind [m] + real(r8), allocatable :: forc_hgt_t (:) ! observational height of temperature [m] + real(r8), allocatable :: forc_hgt_q (:) ! observational height of humidity [m] + real(r8), allocatable :: forc_rhoair(:) ! air density [kg/m3] + real(r8), allocatable :: forc_ozone (:) ! air density [kg/m3] + + ! For Forcing_Downscaling + real(r8), allocatable :: forc_topo (:) ! topography [m] + real(r8), allocatable :: forc_th (:) ! potential temperature [K] + + real(r8), allocatable :: forc_topo_elm (:) ! atmospheric surface height [m] + real(r8), allocatable :: forc_t_elm (:) ! atmospheric temperature [Kelvin] + real(r8), allocatable :: forc_th_elm (:) ! atmospheric potential temperature [Kelvin] + real(r8), allocatable :: forc_q_elm (:) ! atmospheric specific humidity [kg/kg] + real(r8), allocatable :: forc_pbot_elm (:) ! atmospheric pressure [Pa] + real(r8), allocatable :: forc_rho_elm (:) ! atmospheric density [kg/m**3] + real(r8), allocatable :: forc_prc_elm (:) ! convective precipitation in grid [mm/s] + real(r8), allocatable :: forc_prl_elm (:) ! large-scale precipitation in grid [mm/s] + real(r8), allocatable :: forc_lwrad_elm (:) ! grid downward longwave [W/m**2] + real(r8), allocatable :: forc_hgt_elm (:) ! atmospheric reference height [m] + + real(r8), allocatable :: forc_hpbl (:) ! atmospheric boundary layer height [m] + real(r8), allocatable :: forc_aerdep(:,:) ! atmospheric aerosol deposition data [kg/m/s] + + ! PUBLIC MEMBER FUNCTIONS: + PUBLIC :: allocate_1D_Forcing + PUBLIC :: deallocate_1D_Forcing ! PRIVATE MEMBER FUNCTIONS: !----------------------------------------------------------------------- - CONTAINS +CONTAINS !----------------------------------------------------------------------- - SUBROUTINE allocate_1D_Forcing + SUBROUTINE allocate_1D_Forcing ! ------------------------------------------------ ! Allocates memory for CoLM 1d [numpatch] variables ! ------------------------------------------------ - USE MOD_SPMD_Task - USE MOD_Mesh - USE MOD_LandPatch - IMPLICIT NONE - - IF (p_is_worker) THEN - - IF (numpatch > 0) THEN - - allocate (forc_pco2m (numpatch) ) ! CO2 concentration in atmos. (pascals) - allocate (forc_po2m (numpatch) ) ! O2 concentration in atmos. (pascals) - allocate (forc_us (numpatch) ) ! wind in eastward direction [m/s] - allocate (forc_vs (numpatch) ) ! wind in northward direction [m/s] - allocate (forc_t (numpatch) ) ! temperature at reference height [kelvin] - allocate (forc_q (numpatch) ) ! specific humidity at reference height [kg/kg] - allocate (forc_prc (numpatch) ) ! convective precipitation [mm/s] - allocate (forc_prl (numpatch) ) ! large scale precipitation [mm/s] - allocate (forc_rain (numpatch) ) ! rain [mm/s] - allocate (forc_snow (numpatch) ) ! snow [mm/s] - allocate (forc_psrf (numpatch) ) ! atmospheric pressure at the surface [pa] - allocate (forc_pbot (numpatch) ) ! atm bottom level pressure (or reference height) (pa) - allocate (forc_sols (numpatch) ) ! atm vis direct beam solar rad onto srf [W/m2] - allocate (forc_soll (numpatch) ) ! atm nir direct beam solar rad onto srf [W/m2] - allocate (forc_solsd (numpatch) ) ! atm vis diffuse solar rad onto srf [W/m2] - allocate (forc_solld (numpatch) ) ! atm nir diffuse solar rad onto srf [W/m2] - allocate (forc_frl (numpatch) ) ! atmospheric infrared (longwave) radiation [W/m2] - allocate (forc_hgt_u (numpatch) ) ! observational height of wind [m] - allocate (forc_hgt_t (numpatch) ) ! observational height of temperature [m] - allocate (forc_hgt_q (numpatch) ) ! observational height of humidity [m] - allocate (forc_rhoair (numpatch) ) ! air density [kg/m3] - allocate (forc_ozone (numpatch) ) ! air density [kg/m3] - - IF (DEF_USE_Forcing_Downscaling) THEN - allocate (forc_topo (numpatch) ) ! topography [m] - allocate (forc_th (numpatch) ) ! potential temperature [K] - ENDIF - - allocate (forc_hpbl (numpatch) ) ! atmospheric boundary layer height [m] - - IF (DEF_Aerosol_Readin) THEN - allocate (forc_aerdep(14,numpatch) ) ! atmospheric aerosol deposition data [kg/m/s] - ENDIF - - ENDIF - - IF (DEF_USE_Forcing_Downscaling) THEN - IF (numelm > 0) THEN - allocate ( forc_topo_elm (numelm) ) ! atmospheric surface height [m] - allocate ( forc_t_elm (numelm) ) ! atmospheric temperature [Kelvin] - allocate ( forc_th_elm (numelm) ) ! atmospheric potential temperature [Kelvin] - allocate ( forc_q_elm (numelm) ) ! atmospheric specific humidity [kg/kg] - allocate ( forc_pbot_elm (numelm) ) ! atmospheric pressure [Pa] - allocate ( forc_rho_elm (numelm) ) ! atmospheric density [kg/m**3] - allocate ( forc_prc_elm (numelm) ) ! convective precipitation in grid [mm/s] - allocate ( forc_prl_elm (numelm) ) ! large-scale precipitation in grid [mm/s] - allocate ( forc_lwrad_elm (numelm) ) ! grid downward longwave [W/m**2] - allocate ( forc_hgt_elm (numelm) ) ! atmospheric reference height [m] - ENDIF - ENDIF - ENDIF - - END SUBROUTINE allocate_1D_Forcing - - - SUBROUTINE deallocate_1D_Forcing () - - USE MOD_SPMD_Task - USE MOD_Mesh - USE MOD_LandPatch - IMPLICIT NONE - - IF (p_is_worker) THEN - - IF (numpatch > 0) THEN - - deallocate ( forc_pco2m ) ! CO2 concentration in atmos. (pascals) - deallocate ( forc_po2m ) ! O2 concentration in atmos. (pascals) - deallocate ( forc_us ) ! wind in eastward direction [m/s] - deallocate ( forc_vs ) ! wind in northward direction [m/s] - deallocate ( forc_t ) ! temperature at reference height [kelvin] - deallocate ( forc_q ) ! specific humidity at reference height [kg/kg] - deallocate ( forc_prc ) ! convective precipitation [mm/s] - deallocate ( forc_prl ) ! large scale precipitation [mm/s] - deallocate ( forc_rain ) ! rain [mm/s] - deallocate ( forc_snow ) ! snow [mm/s] - deallocate ( forc_psrf ) ! atmospheric pressure at the surface [pa] - deallocate ( forc_pbot ) ! atm bottom level pressure (or reference height) (pa) - deallocate ( forc_sols ) ! atm vis direct beam solar rad onto srf [W/m2] - deallocate ( forc_soll ) ! atm nir direct beam solar rad onto srf [W/m2] - deallocate ( forc_solsd ) ! atm vis diffuse solar rad onto srf [W/m2] - deallocate ( forc_solld ) ! atm nir diffuse solar rad onto srf [W/m2] - deallocate ( forc_frl ) ! atmospheric infrared (longwave) radiation [W/m2] - deallocate ( forc_hgt_u ) ! observational height of wind [m] - deallocate ( forc_hgt_t ) ! observational height of temperature [m] - deallocate ( forc_hgt_q ) ! observational height of humidity [m] - deallocate ( forc_rhoair ) ! air density [kg/m3] - deallocate ( forc_ozone ) ! Ozone partial pressure [mol/mol] - - IF (DEF_USE_Forcing_Downscaling) THEN - deallocate ( forc_topo ) ! topography [m] - deallocate ( forc_th ) ! potential temperature [K] - ENDIF - - deallocate ( forc_hpbl ) ! atmospheric boundary layer height [m] - - IF (DEF_Aerosol_Readin) THEN - deallocate ( forc_aerdep ) ! atmospheric aerosol deposition data [kg/m/s] - ENDIF - - ENDIF - - IF (DEF_USE_Forcing_Downscaling) THEN - IF (numelm > 0) THEN - deallocate ( forc_topo_elm ) ! atmospheric surface height [m] - deallocate ( forc_t_elm ) ! atmospheric temperature [Kelvin] - deallocate ( forc_th_elm ) ! atmospheric potential temperature [Kelvin] - deallocate ( forc_q_elm ) ! atmospheric specific humidity [kg/kg] - deallocate ( forc_pbot_elm ) ! atmospheric pressure [Pa] - deallocate ( forc_rho_elm ) ! atmospheric density [kg/m**3] - deallocate ( forc_prc_elm ) ! convective precipitation in grid [mm/s] - deallocate ( forc_prl_elm ) ! large-scale precipitation in grid [mm/s] - deallocate ( forc_lwrad_elm ) ! grid downward longwave [W/m**2] - deallocate ( forc_hgt_elm ) ! atmospheric reference height [m] - ENDIF - ENDIF - ENDIF - - END SUBROUTINE deallocate_1D_Forcing + USE MOD_SPMD_Task + USE MOD_Mesh + USE MOD_LandPatch + IMPLICIT NONE + + IF (p_is_worker) THEN + + IF (numpatch > 0) THEN + + allocate (forc_pco2m (numpatch) ) ! CO2 concentration in atmos. (pascals) + allocate (forc_po2m (numpatch) ) ! O2 concentration in atmos. (pascals) + allocate (forc_us (numpatch) ) ! wind in eastward direction [m/s] + allocate (forc_vs (numpatch) ) ! wind in northward direction [m/s] + allocate (forc_t (numpatch) ) ! temperature at reference height [kelvin] + allocate (forc_q (numpatch) ) ! specific humidity at reference height [kg/kg] + allocate (forc_prc (numpatch) ) ! convective precipitation [mm/s] + allocate (forc_prl (numpatch) ) ! large scale precipitation [mm/s] + allocate (forc_rain (numpatch) ) ! rain [mm/s] + allocate (forc_snow (numpatch) ) ! snow [mm/s] + allocate (forc_psrf (numpatch) ) ! atmospheric pressure at the surface [pa] + allocate (forc_pbot (numpatch) ) ! atm bottom level pressure (or reference height) (pa) + allocate (forc_sols (numpatch) ) ! atm vis direct beam solar rad onto srf [W/m2] + allocate (forc_soll (numpatch) ) ! atm nir direct beam solar rad onto srf [W/m2] + allocate (forc_solsd (numpatch) ) ! atm vis diffuse solar rad onto srf [W/m2] + allocate (forc_solld (numpatch) ) ! atm nir diffuse solar rad onto srf [W/m2] + allocate (forc_frl (numpatch) ) ! atmospheric infrared (longwave) radiation [W/m2] + allocate (forc_hgt_u (numpatch) ) ! observational height of wind [m] + allocate (forc_hgt_t (numpatch) ) ! observational height of temperature [m] + allocate (forc_hgt_q (numpatch) ) ! observational height of humidity [m] + allocate (forc_rhoair (numpatch) ) ! air density [kg/m3] + allocate (forc_ozone (numpatch) ) ! air density [kg/m3] + + IF (DEF_USE_Forcing_Downscaling) THEN + allocate (forc_topo (numpatch) ) ! topography [m] + allocate (forc_th (numpatch) ) ! potential temperature [K] + ENDIF + + allocate (forc_hpbl (numpatch) ) ! atmospheric boundary layer height [m] + + IF (DEF_Aerosol_Readin) THEN + allocate (forc_aerdep(14,numpatch) ) ! atmospheric aerosol deposition data [kg/m/s] + ENDIF + + ENDIF + + IF (DEF_USE_Forcing_Downscaling) THEN + IF (numelm > 0) THEN + allocate ( forc_topo_elm (numelm) ) ! atmospheric surface height [m] + allocate ( forc_t_elm (numelm) ) ! atmospheric temperature [Kelvin] + allocate ( forc_th_elm (numelm) ) ! atmospheric potential temperature [Kelvin] + allocate ( forc_q_elm (numelm) ) ! atmospheric specific humidity [kg/kg] + allocate ( forc_pbot_elm (numelm) ) ! atmospheric pressure [Pa] + allocate ( forc_rho_elm (numelm) ) ! atmospheric density [kg/m**3] + allocate ( forc_prc_elm (numelm) ) ! convective precipitation in grid [mm/s] + allocate ( forc_prl_elm (numelm) ) ! large-scale precipitation in grid [mm/s] + allocate ( forc_lwrad_elm (numelm) ) ! grid downward longwave [W/m**2] + allocate ( forc_hgt_elm (numelm) ) ! atmospheric reference height [m] + ENDIF + ENDIF + ENDIF + + END SUBROUTINE allocate_1D_Forcing + + + SUBROUTINE deallocate_1D_Forcing () + + USE MOD_SPMD_Task + USE MOD_Mesh + USE MOD_LandPatch + IMPLICIT NONE + + IF (p_is_worker) THEN + + IF (numpatch > 0) THEN + + deallocate ( forc_pco2m ) ! CO2 concentration in atmos. (pascals) + deallocate ( forc_po2m ) ! O2 concentration in atmos. (pascals) + deallocate ( forc_us ) ! wind in eastward direction [m/s] + deallocate ( forc_vs ) ! wind in northward direction [m/s] + deallocate ( forc_t ) ! temperature at reference height [kelvin] + deallocate ( forc_q ) ! specific humidity at reference height [kg/kg] + deallocate ( forc_prc ) ! convective precipitation [mm/s] + deallocate ( forc_prl ) ! large scale precipitation [mm/s] + deallocate ( forc_rain ) ! rain [mm/s] + deallocate ( forc_snow ) ! snow [mm/s] + deallocate ( forc_psrf ) ! atmospheric pressure at the surface [pa] + deallocate ( forc_pbot ) ! atm bottom level pressure (or reference height) (pa) + deallocate ( forc_sols ) ! atm vis direct beam solar rad onto srf [W/m2] + deallocate ( forc_soll ) ! atm nir direct beam solar rad onto srf [W/m2] + deallocate ( forc_solsd ) ! atm vis diffuse solar rad onto srf [W/m2] + deallocate ( forc_solld ) ! atm nir diffuse solar rad onto srf [W/m2] + deallocate ( forc_frl ) ! atmospheric infrared (longwave) radiation [W/m2] + deallocate ( forc_hgt_u ) ! observational height of wind [m] + deallocate ( forc_hgt_t ) ! observational height of temperature [m] + deallocate ( forc_hgt_q ) ! observational height of humidity [m] + deallocate ( forc_rhoair ) ! air density [kg/m3] + deallocate ( forc_ozone ) ! Ozone partial pressure [mol/mol] + + IF (DEF_USE_Forcing_Downscaling) THEN + deallocate ( forc_topo ) ! topography [m] + deallocate ( forc_th ) ! potential temperature [K] + ENDIF + + deallocate ( forc_hpbl ) ! atmospheric boundary layer height [m] + + IF (DEF_Aerosol_Readin) THEN + deallocate ( forc_aerdep ) ! atmospheric aerosol deposition data [kg/m/s] + ENDIF + + ENDIF + + IF (DEF_USE_Forcing_Downscaling) THEN + IF (numelm > 0) THEN + deallocate ( forc_topo_elm ) ! atmospheric surface height [m] + deallocate ( forc_t_elm ) ! atmospheric temperature [Kelvin] + deallocate ( forc_th_elm ) ! atmospheric potential temperature [Kelvin] + deallocate ( forc_q_elm ) ! atmospheric specific humidity [kg/kg] + deallocate ( forc_pbot_elm ) ! atmospheric pressure [Pa] + deallocate ( forc_rho_elm ) ! atmospheric density [kg/m**3] + deallocate ( forc_prc_elm ) ! convective precipitation in grid [mm/s] + deallocate ( forc_prl_elm ) ! large-scale precipitation in grid [mm/s] + deallocate ( forc_lwrad_elm ) ! grid downward longwave [W/m**2] + deallocate ( forc_hgt_elm ) ! atmospheric reference height [m] + ENDIF + ENDIF + ENDIF + + END SUBROUTINE deallocate_1D_Forcing END MODULE MOD_Vars_1DForcing ! ------ EOP -------- diff --git a/main/MOD_Vars_1DPFTFluxes.F90 b/main/MOD_Vars_1DPFTFluxes.F90 index 8103226b..a6042f3f 100644 --- a/main/MOD_Vars_1DPFTFluxes.F90 +++ b/main/MOD_Vars_1DPFTFluxes.F90 @@ -10,162 +10,162 @@ MODULE MOD_Vars_1DPFTFluxes ! Created by Hua Yuan, 08/2019 ! ----------------------------------------------------------------- - USE MOD_Precision + USE MOD_Precision #ifdef BGC - USE MOD_BGC_Vars_1DPFTFluxes + USE MOD_BGC_Vars_1DPFTFluxes #endif - IMPLICIT NONE - SAVE + IMPLICIT NONE + SAVE ! ----------------------------------------------------------------- ! Fluxes ! ----------------------------------------------------------------- - REAL(r8), allocatable :: taux_p (:) !wind stress: E-W [kg/m/s2] - REAL(r8), allocatable :: tauy_p (:) !wind stress: N-S [kg/m/s2] - REAL(r8), allocatable :: fsenl_p (:) !sensible heat from leaves [W/m2] - REAL(r8), allocatable :: fevpl_p (:) !evaporation+transpiration from leaves [mm/s] - REAL(r8), allocatable :: etr_p (:) !transpiration rate [mm/s] - REAL(r8), allocatable :: fseng_p (:) !sensible heat flux from ground [W/m2] - REAL(r8), allocatable :: fevpg_p (:) !evaporation heat flux from ground [mm/s] - REAL(r8), allocatable :: parsun_p (:) !solar absorbed by sunlit vegetation [W/m2] - REAL(r8), allocatable :: parsha_p (:) !solar absorbed by shaded vegetation [W/m2] - REAL(r8), allocatable :: sabvsun_p(:) !solar absorbed by sunlit vegetation [W/m2] - REAL(r8), allocatable :: sabvsha_p(:) !solar absorbed by shaded vegetation [W/m2] - REAL(r8), allocatable :: qintr_p (:) !interception (mm h2o/s) - REAL(r8), allocatable :: qintr_rain_p(:) !rainfall interception (mm h2o/s) - REAL(r8), allocatable :: qintr_snow_p(:) !snowfall interception (mm h2o/s) - REAL(r8), allocatable :: assim_p (:) !canopy assimilation rate (mol m-2 s-1) - REAL(r8), allocatable :: respc_p (:) !canopy respiration (mol m-2 s-1) + real(r8), allocatable :: taux_p (:) !wind stress: E-W [kg/m/s2] + real(r8), allocatable :: tauy_p (:) !wind stress: N-S [kg/m/s2] + real(r8), allocatable :: fsenl_p (:) !sensible heat from leaves [W/m2] + real(r8), allocatable :: fevpl_p (:) !evaporation+transpiration from leaves [mm/s] + real(r8), allocatable :: etr_p (:) !transpiration rate [mm/s] + real(r8), allocatable :: fseng_p (:) !sensible heat flux from ground [W/m2] + real(r8), allocatable :: fevpg_p (:) !evaporation heat flux from ground [mm/s] + real(r8), allocatable :: parsun_p (:) !solar absorbed by sunlit vegetation [W/m2] + real(r8), allocatable :: parsha_p (:) !solar absorbed by shaded vegetation [W/m2] + real(r8), allocatable :: sabvsun_p(:) !solar absorbed by sunlit vegetation [W/m2] + real(r8), allocatable :: sabvsha_p(:) !solar absorbed by shaded vegetation [W/m2] + real(r8), allocatable :: qintr_p (:) !interception (mm h2o/s) + real(r8), allocatable :: qintr_rain_p(:) !rainfall interception (mm h2o/s) + real(r8), allocatable :: qintr_snow_p(:) !snowfall interception (mm h2o/s) + real(r8), allocatable :: assim_p (:) !canopy assimilation rate (mol m-2 s-1) + real(r8), allocatable :: respc_p (:) !canopy respiration (mol m-2 s-1) ! PUBLIC MEMBER FUNCTIONS: - PUBLIC :: allocate_1D_PFTFluxes - PUBLIC :: deallocate_1D_PFTFluxes - PUBLIC :: set_1D_PFTFluxes + PUBLIC :: allocate_1D_PFTFluxes + PUBLIC :: deallocate_1D_PFTFluxes + PUBLIC :: set_1D_PFTFluxes ! PRIVATE MEMBER FUNCTIONS: !----------------------------------------------------------------------- - CONTAINS +CONTAINS !----------------------------------------------------------------------- - SUBROUTINE allocate_1D_PFTFluxes - ! -------------------------------------------------------------------- - ! Allocates memory for CoLM PFT 1d [numpft] variables - ! -------------------------------------------------------------------- - - USE MOD_Precision - USE MOD_SPMD_Task - USE MOD_LandPFT - IMPLICIT NONE - - IF (p_is_worker) THEN - IF (numpft > 0) THEN - - allocate (taux_p (numpft)) ; taux_p (:) = spval !wind stress: E-W [kg/m/s2] - allocate (tauy_p (numpft)) ; tauy_p (:) = spval !wind stress: N-S [kg/m/s2] - allocate (fsenl_p (numpft)) ; fsenl_p (:) = spval !sensible heat from leaves [W/m2] - allocate (fevpl_p (numpft)) ; fevpl_p (:) = spval !evaporation+transpiration from leaves [mm/s] - allocate (etr_p (numpft)) ; etr_p (:) = spval !transpiration rate [mm/s] - allocate (fseng_p (numpft)) ; fseng_p (:) = spval !sensible heat flux from ground [W/m2] - allocate (fevpg_p (numpft)) ; fevpg_p (:) = spval !evaporation heat flux from ground [mm/s] - allocate (parsun_p (numpft)) ; parsun_p (:) = spval !solar absorbed by sunlit vegetation [W/m2] - allocate (parsha_p (numpft)) ; parsha_p (:) = spval !solar absorbed by shaded vegetation [W/m2] - allocate (sabvsun_p (numpft)) ; sabvsun_p (:) = spval !solar absorbed by sunlit vegetation [W/m2] - allocate (sabvsha_p (numpft)) ; sabvsha_p (:) = spval !solar absorbed by shaded vegetation [W/m2] - allocate (qintr_p (numpft)) ; qintr_p (:) = spval !interception (mm h2o/s) - allocate (qintr_rain_p (numpft)) ; qintr_rain_p (:) = spval!rainfall interception (mm h2o/s) - allocate (qintr_snow_p (numpft)) ; qintr_snow_p (:) = spval!snowfall interception (mm h2o/s) - allocate (assim_p (numpft)) ; assim_p (:) = spval !canopy assimilation rate (mol m-2 s-1) - allocate (respc_p (numpft)) ; respc_p (:) = spval !canopy respiration (mol m-2 s-1) - - ENDIF - ENDIF + SUBROUTINE allocate_1D_PFTFluxes + ! -------------------------------------------------------------------- + ! Allocates memory for CoLM PFT 1d [numpft] variables + ! -------------------------------------------------------------------- + + USE MOD_Precision + USE MOD_SPMD_Task + USE MOD_LandPFT + IMPLICIT NONE + + IF (p_is_worker) THEN + IF (numpft > 0) THEN + + allocate (taux_p (numpft)) ; taux_p (:) = spval !wind stress: E-W [kg/m/s2] + allocate (tauy_p (numpft)) ; tauy_p (:) = spval !wind stress: N-S [kg/m/s2] + allocate (fsenl_p (numpft)) ; fsenl_p (:) = spval !sensible heat from leaves [W/m2] + allocate (fevpl_p (numpft)) ; fevpl_p (:) = spval !evaporation+transpiration from leaves [mm/s] + allocate (etr_p (numpft)) ; etr_p (:) = spval !transpiration rate [mm/s] + allocate (fseng_p (numpft)) ; fseng_p (:) = spval !sensible heat flux from ground [W/m2] + allocate (fevpg_p (numpft)) ; fevpg_p (:) = spval !evaporation heat flux from ground [mm/s] + allocate (parsun_p (numpft)) ; parsun_p (:) = spval !solar absorbed by sunlit vegetation [W/m2] + allocate (parsha_p (numpft)) ; parsha_p (:) = spval !solar absorbed by shaded vegetation [W/m2] + allocate (sabvsun_p (numpft)) ; sabvsun_p (:) = spval !solar absorbed by sunlit vegetation [W/m2] + allocate (sabvsha_p (numpft)) ; sabvsha_p (:) = spval !solar absorbed by shaded vegetation [W/m2] + allocate (qintr_p (numpft)) ; qintr_p (:) = spval !interception (mm h2o/s) + allocate (qintr_rain_p (numpft)) ; qintr_rain_p (:) = spval!rainfall interception (mm h2o/s) + allocate (qintr_snow_p (numpft)) ; qintr_snow_p (:) = spval!snowfall interception (mm h2o/s) + allocate (assim_p (numpft)) ; assim_p (:) = spval !canopy assimilation rate (mol m-2 s-1) + allocate (respc_p (numpft)) ; respc_p (:) = spval !canopy respiration (mol m-2 s-1) + + ENDIF + ENDIF #ifdef BGC - CALL allocate_1D_BGCPFTFluxes + CALL allocate_1D_BGCPFTFluxes #endif - END SUBROUTINE allocate_1D_PFTFluxes - - SUBROUTINE deallocate_1D_PFTFluxes - ! -------------------------------------------------------------------- - ! deallocates memory for CoLM PFT 1d [numpft] variables - ! -------------------------------------------------------------------- - USE MOD_SPMD_Task - USE MOD_LandPFT - - IF (p_is_worker) THEN - IF (numpft > 0) THEN - - deallocate (taux_p ) - deallocate (tauy_p ) - deallocate (fsenl_p ) - deallocate (fevpl_p ) - deallocate (etr_p ) - deallocate (fseng_p ) - deallocate (fevpg_p ) - deallocate (parsun_p ) - deallocate (parsha_p ) - deallocate (sabvsun_p ) - deallocate (sabvsha_p ) - deallocate (qintr_p ) - deallocate (qintr_rain_p) - deallocate (qintr_snow_p) - deallocate (assim_p ) - deallocate (respc_p ) - - ENDIF - ENDIF + END SUBROUTINE allocate_1D_PFTFluxes + + SUBROUTINE deallocate_1D_PFTFluxes + ! -------------------------------------------------------------------- + ! deallocates memory for CoLM PFT 1d [numpft] variables + ! -------------------------------------------------------------------- + USE MOD_SPMD_Task + USE MOD_LandPFT + + IF (p_is_worker) THEN + IF (numpft > 0) THEN + + deallocate (taux_p ) + deallocate (tauy_p ) + deallocate (fsenl_p ) + deallocate (fevpl_p ) + deallocate (etr_p ) + deallocate (fseng_p ) + deallocate (fevpg_p ) + deallocate (parsun_p ) + deallocate (parsha_p ) + deallocate (sabvsun_p ) + deallocate (sabvsha_p ) + deallocate (qintr_p ) + deallocate (qintr_rain_p) + deallocate (qintr_snow_p) + deallocate (assim_p ) + deallocate (respc_p ) + + ENDIF + ENDIF #ifdef BGC - CALL deallocate_1D_BGCPFTFluxes + CALL deallocate_1D_BGCPFTFluxes #endif - END SUBROUTINE deallocate_1D_PFTFluxes - - SUBROUTINE set_1D_PFTFluxes(Values, Nan) - ! -------------------------------------------------------------------- - ! Allocates memory for CoLM PFT 1d [numpft] variables - ! -------------------------------------------------------------------- - - USE MOD_Precision - USE MOD_SPMD_Task - USE MOD_LandPFT - IMPLICIT NONE - - REAL(r8),intent(in) :: Values - REAL(r8),intent(in) :: Nan - - IF (p_is_worker) THEN - IF (numpft > 0) THEN - - taux_p (:) = Values !wind stress: E-W [kg/m/s2] - tauy_p (:) = Values !wind stress: N-S [kg/m/s2] - fsenl_p (:) = Values !sensible heat from leaves [W/m2] - fevpl_p (:) = Values !evaporation+transpiration from leaves [mm/s] - etr_p (:) = Values !transpiration rate [mm/s] - fseng_p (:) = Values !sensible heat flux from ground [W/m2] - fevpg_p (:) = Values !evaporation heat flux from ground [mm/s] - parsun_p (:) = Values !solar absorbed by sunlit vegetation [W/m2] - parsha_p (:) = Values !solar absorbed by shaded vegetation [W/m2] - sabvsun_p (:) = Values !solar absorbed by sunlit vegetation [W/m2] - sabvsha_p (:) = Values !solar absorbed by shaded vegetation [W/m2] - qintr_p (:) = Values !interception (mm h2o/s) - qintr_rain_p(:) = Values !rainfall interception (mm h2o/s) - qintr_snow_p(:) = Values !snowfall interception (mm h2o/s) - assim_p (:) = Values !canopy assimilation rate (mol m-2 s-1) - respc_p (:) = Values !canopy respiration (mol m-2 s-1) - - ENDIF - ENDIF + END SUBROUTINE deallocate_1D_PFTFluxes + + SUBROUTINE set_1D_PFTFluxes(Values, Nan) + ! -------------------------------------------------------------------- + ! Allocates memory for CoLM PFT 1d [numpft] variables + ! -------------------------------------------------------------------- + + USE MOD_Precision + USE MOD_SPMD_Task + USE MOD_LandPFT + IMPLICIT NONE + + real(r8),intent(in) :: Values + real(r8),intent(in) :: Nan + + IF (p_is_worker) THEN + IF (numpft > 0) THEN + + taux_p (:) = Values !wind stress: E-W [kg/m/s2] + tauy_p (:) = Values !wind stress: N-S [kg/m/s2] + fsenl_p (:) = Values !sensible heat from leaves [W/m2] + fevpl_p (:) = Values !evaporation+transpiration from leaves [mm/s] + etr_p (:) = Values !transpiration rate [mm/s] + fseng_p (:) = Values !sensible heat flux from ground [W/m2] + fevpg_p (:) = Values !evaporation heat flux from ground [mm/s] + parsun_p (:) = Values !solar absorbed by sunlit vegetation [W/m2] + parsha_p (:) = Values !solar absorbed by shaded vegetation [W/m2] + sabvsun_p (:) = Values !solar absorbed by sunlit vegetation [W/m2] + sabvsha_p (:) = Values !solar absorbed by shaded vegetation [W/m2] + qintr_p (:) = Values !interception (mm h2o/s) + qintr_rain_p(:) = Values !rainfall interception (mm h2o/s) + qintr_snow_p(:) = Values !snowfall interception (mm h2o/s) + assim_p (:) = Values !canopy assimilation rate (mol m-2 s-1) + respc_p (:) = Values !canopy respiration (mol m-2 s-1) + + ENDIF + ENDIF #ifdef BGC - CALL set_1D_BGCPFTFluxes (Values, Nan) + CALL set_1D_BGCPFTFluxes (Values, Nan) #endif - END SUBROUTINE set_1D_PFTFluxes + END SUBROUTINE set_1D_PFTFluxes END MODULE MOD_Vars_1DPFTFluxes diff --git a/main/MOD_Vars_2DForcing.F90 b/main/MOD_Vars_2DForcing.F90 index aeeb48ff..5b29f352 100644 --- a/main/MOD_Vars_2DForcing.F90 +++ b/main/MOD_Vars_2DForcing.F90 @@ -7,7 +7,7 @@ MODULE MOD_Vars_2DForcing ! Created by Yongjiu Dai, 03/2014 ! ------------------------------- - use MOD_DataType + USE MOD_DataType IMPLICIT NONE SAVE @@ -34,46 +34,46 @@ MODULE MOD_Vars_2DForcing type(block_data_real8_2d) :: forc_xy_hpbl ! atmospheric boundary layer height [m] ! PUBLIC MEMBER FUNCTIONS: - public :: allocate_2D_Forcing + PUBLIC :: allocate_2D_Forcing CONTAINS !----------------------------------------------------------------------- SUBROUTINE allocate_2D_Forcing (grid) - ! ------------------------------------------------ - ! Allocates memory for CoLM 2d [lon_points,lat_points] variables - ! ------------------------------------------------ - use MOD_SPMD_Task - use MOD_Grid - use MOD_DataType - IMPLICIT NONE + ! ------------------------------------------------ + ! Allocates memory for CoLM 2d [lon_points,lat_points] variables + ! ------------------------------------------------ + USE MOD_SPMD_Task + USE MOD_Grid + USE MOD_DataType + IMPLICIT NONE - type(grid_type), intent(in) :: grid + type(grid_type), intent(in) :: grid - if (p_is_io) then + IF (p_is_io) THEN - call allocate_block_data (grid, forc_xy_pco2m ) ! CO2 concentration in atmos. (pascals) - call allocate_block_data (grid, forc_xy_po2m ) ! O2 concentration in atmos. (pascals) - call allocate_block_data (grid, forc_xy_us ) ! wind in eastward direction [m/s] - call allocate_block_data (grid, forc_xy_vs ) ! wind in northward direction [m/s] - call allocate_block_data (grid, forc_xy_t ) ! temperature at reference height [kelvin] - call allocate_block_data (grid, forc_xy_q ) ! specific humidity at reference height [kg/kg] - call allocate_block_data (grid, forc_xy_prc ) ! convective precipitation [mm/s] - call allocate_block_data (grid, forc_xy_prl ) ! large scale precipitation [mm/s] - call allocate_block_data (grid, forc_xy_psrf ) ! atmospheric pressure at the surface [pa] - call allocate_block_data (grid, forc_xy_pbot ) ! atm bottom level pressure (or reference height) (pa) - call allocate_block_data (grid, forc_xy_sols ) ! atm vis direct beam solar rad onto srf [W/m2] - call allocate_block_data (grid, forc_xy_soll ) ! atm nir direct beam solar rad onto srf [W/m2] - call allocate_block_data (grid, forc_xy_solsd ) ! atm vis diffuse solar rad onto srf [W/m2] - call allocate_block_data (grid, forc_xy_solld ) ! atm nir diffuse solar rad onto srf [W/m2] - call allocate_block_data (grid, forc_xy_frl ) ! atmospheric infrared (longwave) radiation [W/m2] - call allocate_block_data (grid, forc_xy_hgt_u ) ! observational height of wind [m] - call allocate_block_data (grid, forc_xy_hgt_t ) ! observational height of temperature [m] - call allocate_block_data (grid, forc_xy_hgt_q ) ! observational height of humidity [m] - call allocate_block_data (grid, forc_xy_rhoair) ! air density [kg/m3] - call allocate_block_data (grid, forc_xy_hpbl ) ! atmospheric boundary layer height [m] - end if + CALL allocate_block_data (grid, forc_xy_pco2m ) ! CO2 concentration in atmos. (pascals) + CALL allocate_block_data (grid, forc_xy_po2m ) ! O2 concentration in atmos. (pascals) + CALL allocate_block_data (grid, forc_xy_us ) ! wind in eastward direction [m/s] + CALL allocate_block_data (grid, forc_xy_vs ) ! wind in northward direction [m/s] + CALL allocate_block_data (grid, forc_xy_t ) ! temperature at reference height [kelvin] + CALL allocate_block_data (grid, forc_xy_q ) ! specific humidity at reference height [kg/kg] + CALL allocate_block_data (grid, forc_xy_prc ) ! convective precipitation [mm/s] + CALL allocate_block_data (grid, forc_xy_prl ) ! large scale precipitation [mm/s] + CALL allocate_block_data (grid, forc_xy_psrf ) ! atmospheric pressure at the surface [pa] + CALL allocate_block_data (grid, forc_xy_pbot ) ! atm bottom level pressure (or reference height) (pa) + CALL allocate_block_data (grid, forc_xy_sols ) ! atm vis direct beam solar rad onto srf [W/m2] + CALL allocate_block_data (grid, forc_xy_soll ) ! atm nir direct beam solar rad onto srf [W/m2] + CALL allocate_block_data (grid, forc_xy_solsd ) ! atm vis diffuse solar rad onto srf [W/m2] + CALL allocate_block_data (grid, forc_xy_solld ) ! atm nir diffuse solar rad onto srf [W/m2] + CALL allocate_block_data (grid, forc_xy_frl ) ! atmospheric infrared (longwave) radiation [W/m2] + CALL allocate_block_data (grid, forc_xy_hgt_u ) ! observational height of wind [m] + CALL allocate_block_data (grid, forc_xy_hgt_t ) ! observational height of temperature [m] + CALL allocate_block_data (grid, forc_xy_hgt_q ) ! observational height of humidity [m] + CALL allocate_block_data (grid, forc_xy_rhoair) ! air density [kg/m3] + CALL allocate_block_data (grid, forc_xy_hpbl ) ! atmospheric boundary layer height [m] + ENDIF END SUBROUTINE allocate_2D_Forcing diff --git a/main/MOD_Vars_Global.F90 b/main/MOD_Vars_Global.F90 index ff87a861..24a528be 100644 --- a/main/MOD_Vars_Global.F90 +++ b/main/MOD_Vars_Global.F90 @@ -115,9 +115,9 @@ MODULE MOD_Vars_Global SUBROUTINE Init_GlobalVars - IMPLICIT NONE + IMPLICIT NONE - integer :: nsl + integer :: nsl ! node depths of each soil layer DO nsl = 1, nl_soil @@ -144,7 +144,7 @@ SUBROUTINE Init_GlobalVars N_URB = 10 ENDIF -! ndecomp_pools_vr = ndecomp_pools * nl_soil + !ndecomp_pools_vr = ndecomp_pools * nl_soil END SUBROUTINE Init_GlobalVars diff --git a/main/MOD_Vars_TimeInvariants.F90 b/main/MOD_Vars_TimeInvariants.F90 index 50144041..d74c9bd5 100644 --- a/main/MOD_Vars_TimeInvariants.F90 +++ b/main/MOD_Vars_TimeInvariants.F90 @@ -13,151 +13,151 @@ MODULE MOD_Vars_PFTimeInvariants ! Added by Hua Yuan, 08/2019 ! ----------------------------------------------------------------- - USE MOD_Precision - USE MOD_Vars_Global - IMPLICIT NONE - SAVE + USE MOD_Precision + USE MOD_Vars_Global + IMPLICIT NONE + SAVE - ! for LULC_IGBP_PFT and LULC_IGBP_PC - INTEGER , allocatable :: pftclass (:) !PFT type - REAL(r8), allocatable :: pftfrac (:) !PFT fractional cover - REAL(r8), allocatable :: htop_p (:) !canopy top height [m] - REAL(r8), allocatable :: hbot_p (:) !canopy bottom height [m] + ! for LULC_IGBP_PFT and LULC_IGBP_PC + integer , allocatable :: pftclass (:) !PFT type + real(r8), allocatable :: pftfrac (:) !PFT fractional cover + real(r8), allocatable :: htop_p (:) !canopy top height [m] + real(r8), allocatable :: hbot_p (:) !canopy bottom height [m] ! PUBLIC MEMBER FUNCTIONS: - PUBLIC :: allocate_PFTimeInvariants - PUBLIC :: READ_PFTimeInvariants - PUBLIC :: WRITE_PFTimeInvariants - PUBLIC :: deallocate_PFTimeInvariants + PUBLIC :: allocate_PFTimeInvariants + PUBLIC :: READ_PFTimeInvariants + PUBLIC :: WRITE_PFTimeInvariants + PUBLIC :: deallocate_PFTimeInvariants #ifdef RangeCheck - PUBLIC :: check_PFTimeInvariants + PUBLIC :: check_PFTimeInvariants #endif ! PRIVATE MEMBER FUNCTIONS: !----------------------------------------------------------------------- - CONTAINS +CONTAINS !----------------------------------------------------------------------- - SUBROUTINE allocate_PFTimeInvariants - ! -------------------------------------------------------------------- - ! Allocates memory for CoLM PFT 1d [numpft] variables - ! -------------------------------------------------------------------- + SUBROUTINE allocate_PFTimeInvariants + ! -------------------------------------------------------------------- + ! Allocates memory for CoLM PFT 1d [numpft] variables + ! -------------------------------------------------------------------- - USE MOD_SPMD_Task - USE MOD_LandPFT, only : numpft - USE MOD_Precision - IMPLICIT NONE + USE MOD_SPMD_Task + USE MOD_LandPFT, only : numpft + USE MOD_Precision + IMPLICIT NONE - IF (p_is_worker) THEN - IF (numpft > 0) THEN - allocate (pftclass (numpft)) - allocate (pftfrac (numpft)) - allocate (htop_p (numpft)) - allocate (hbot_p (numpft)) - ENDIF - ENDIF + IF (p_is_worker) THEN + IF (numpft > 0) THEN + allocate (pftclass (numpft)) + allocate (pftfrac (numpft)) + allocate (htop_p (numpft)) + allocate (hbot_p (numpft)) + ENDIF + ENDIF - END SUBROUTINE allocate_PFTimeInvariants + END SUBROUTINE allocate_PFTimeInvariants - SUBROUTINE READ_PFTimeInvariants (file_restart) + SUBROUTINE READ_PFTimeInvariants (file_restart) - use MOD_NetCDFVector - USE MOD_LandPFT + USE MOD_NetCDFVector + USE MOD_LandPFT #ifdef CROP - USE MOD_LandCrop, only : pctshrpch - USE MOD_LandPatch, only : landpatch + USE MOD_LandCrop, only : pctshrpch + USE MOD_LandPatch, only : landpatch #endif - IMPLICIT NONE + IMPLICIT NONE - character(LEN=*), intent(in) :: file_restart + character(LEN=*), intent(in) :: file_restart - call ncio_read_vector (file_restart, 'pftclass', landpft, pftclass) ! - call ncio_read_vector (file_restart, 'pftfrac ', landpft, pftfrac ) ! - call ncio_read_vector (file_restart, 'htop_p ', landpft, htop_p ) ! - call ncio_read_vector (file_restart, 'hbot_p ', landpft, hbot_p ) ! + CALL ncio_read_vector (file_restart, 'pftclass', landpft, pftclass) ! + CALL ncio_read_vector (file_restart, 'pftfrac ', landpft, pftfrac ) ! + CALL ncio_read_vector (file_restart, 'htop_p ', landpft, htop_p ) ! + CALL ncio_read_vector (file_restart, 'hbot_p ', landpft, hbot_p ) ! #ifdef CROP - call ncio_read_vector (file_restart, 'pct_crops', landpatch, pctshrpch) ! + CALL ncio_read_vector (file_restart, 'pct_crops', landpatch, pctshrpch) ! #endif - end subroutine READ_PFTimeInvariants + END SUBROUTINE READ_PFTimeInvariants - SUBROUTINE WRITE_PFTimeInvariants (file_restart) + SUBROUTINE WRITE_PFTimeInvariants (file_restart) - use MOD_NetCDFVector - use MOD_LandPFT - USE MOD_Namelist - USE MOD_Vars_Global + USE MOD_NetCDFVector + USE MOD_LandPFT + USE MOD_Namelist + USE MOD_Vars_Global #ifdef CROP - USE MOD_LandCrop, only : pctshrpch - USE MOD_LandPatch, only : landpatch + USE MOD_LandCrop, only : pctshrpch + USE MOD_LandPatch, only : landpatch #endif - IMPLICIT NONE + IMPLICIT NONE - ! Local variables - character(len=*), intent(in) :: file_restart - integer :: compress + ! Local variables + character(len=*), intent(in) :: file_restart + integer :: compress - compress = DEF_REST_COMPRESS_LEVEL + compress = DEF_REST_COMPRESS_LEVEL - call ncio_create_file_vector (file_restart, landpft) - CALL ncio_define_dimension_vector (file_restart, landpft, 'pft') + CALL ncio_create_file_vector (file_restart, landpft) + CALL ncio_define_dimension_vector (file_restart, landpft, 'pft') - call ncio_write_vector (file_restart, 'pftclass', 'pft', landpft, pftclass, compress) ! - call ncio_write_vector (file_restart, 'pftfrac ', 'pft', landpft, pftfrac , compress) ! - call ncio_write_vector (file_restart, 'htop_p ', 'pft', landpft, htop_p , compress) ! - call ncio_write_vector (file_restart, 'hbot_p ', 'pft', landpft, hbot_p , compress) ! + CALL ncio_write_vector (file_restart, 'pftclass', 'pft', landpft, pftclass, compress) ! + CALL ncio_write_vector (file_restart, 'pftfrac ', 'pft', landpft, pftfrac , compress) ! + CALL ncio_write_vector (file_restart, 'htop_p ', 'pft', landpft, htop_p , compress) ! + CALL ncio_write_vector (file_restart, 'hbot_p ', 'pft', landpft, hbot_p , compress) ! #ifdef CROP - CALL ncio_define_dimension_vector (file_restart, landpatch, 'patch') - call ncio_write_vector (file_restart, 'pct_crops', 'patch', landpatch, pctshrpch, compress) ! + CALL ncio_define_dimension_vector (file_restart, landpatch, 'patch') + CALL ncio_write_vector (file_restart, 'pct_crops', 'patch', landpatch, pctshrpch, compress) ! #endif - end subroutine WRITE_PFTimeInvariants + END SUBROUTINE WRITE_PFTimeInvariants - SUBROUTINE deallocate_PFTimeInvariants + SUBROUTINE deallocate_PFTimeInvariants ! -------------------------------------------------- ! Deallocates memory for CoLM PFT 1d [numpft] variables ! -------------------------------------------------- - USE MOD_SPMD_Task - USE MOD_LandPFT + USE MOD_SPMD_Task + USE MOD_LandPFT #ifdef CROP - USE MOD_LandCrop, only : pctshrpch + USE MOD_LandCrop, only : pctshrpch #endif - IF (p_is_worker) THEN - IF (numpft > 0) THEN - deallocate (pftclass) - deallocate (pftfrac ) - deallocate (htop_p ) - deallocate (hbot_p ) - ENDIF + IF (p_is_worker) THEN + IF (numpft > 0) THEN + deallocate (pftclass) + deallocate (pftfrac ) + deallocate (htop_p ) + deallocate (hbot_p ) + ENDIF #ifdef CROP - IF (allocated(pctshrpch)) deallocate(pctshrpch) + IF (allocated(pctshrpch)) deallocate(pctshrpch) #endif - ENDIF + ENDIF - END SUBROUTINE deallocate_PFTimeInvariants + END SUBROUTINE deallocate_PFTimeInvariants #ifdef RangeCheck - SUBROUTINE check_PFTimeInvariants () + SUBROUTINE check_PFTimeInvariants () - use MOD_RangeCheck + USE MOD_RangeCheck #ifdef CROP - USE MOD_LandCrop, only : pctshrpch + USE MOD_LandCrop, only : pctshrpch #endif - IMPLICIT NONE + IMPLICIT NONE - call check_vector_data ('pftfrac', pftfrac) ! - call check_vector_data ('htop_p ', htop_p ) ! - call check_vector_data ('hbot_p ', hbot_p ) ! + CALL check_vector_data ('pftfrac', pftfrac) ! + CALL check_vector_data ('htop_p ', htop_p ) ! + CALL check_vector_data ('hbot_p ', hbot_p ) ! #ifdef CROP - call check_vector_data ('pct crop', pctshrpch) ! + CALL check_vector_data ('pct crop', pctshrpch) ! #endif - end subroutine check_PFTimeInvariants + END SUBROUTINE check_PFTimeInvariants #endif END MODULE MOD_Vars_PFTimeInvariants @@ -168,144 +168,144 @@ MODULE MOD_Vars_TimeInvariants ! Created by Yongjiu Dai, 03/2014 ! ------------------------------- - USE MOD_Precision + USE MOD_Precision #if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) - USE MOD_Vars_PFTimeInvariants + USE MOD_Vars_PFTimeInvariants #endif #ifdef BGC - USE MOD_BGC_Vars_TimeInvariants + USE MOD_BGC_Vars_TimeInvariants #endif #ifdef URBAN_MODEL - USE MOD_Urban_Vars_TimeInvariants + USE MOD_Urban_Vars_TimeInvariants #endif - IMPLICIT NONE - SAVE + IMPLICIT NONE + SAVE ! ----------------------------------------------------------------- ! surface classification and soil information - INTEGER, allocatable :: patchclass (:) !index of land cover type of the patches at the fraction > 0 - INTEGER, allocatable :: patchtype (:) !land patch type - LOGICAL, allocatable :: patchmask (:) !patch mask - - REAL(r8), allocatable :: patchlatr (:) !latitude in radians - REAL(r8), allocatable :: patchlonr (:) !longitude in radians - - REAL(r8), allocatable :: lakedepth (:) !lake depth - REAL(r8), allocatable :: dz_lake (:,:) !new lake scheme - - REAL(r8), allocatable :: soil_s_v_alb (:) !albedo of visible of the saturated soil - REAL(r8), allocatable :: soil_d_v_alb (:) !albedo of visible of the dry soil - REAL(r8), allocatable :: soil_s_n_alb (:) !albedo of near infrared of the saturated soil - REAL(r8), allocatable :: soil_d_n_alb (:) !albedo of near infrared of the dry soil - - REAL(r8), allocatable :: vf_quartz (:,:) !volumetric fraction of quartz within mineral soil - REAL(r8), allocatable :: vf_gravels (:,:) !volumetric fraction of gravels - REAL(r8), allocatable :: vf_om (:,:) !volumetric fraction of organic matter - REAL(r8), allocatable :: vf_sand (:,:) !volumetric fraction of sand - REAL(r8), allocatable :: wf_gravels (:,:) !gravimetric fraction of gravels - REAL(r8), allocatable :: wf_sand (:,:) !gravimetric fraction of sand - REAL(r8), allocatable :: OM_density (:,:) !OM density (kg/m3) - REAL(r8), allocatable :: BD_all (:,:) !bulk density of soil (GRAVELS + ORGANIC MATTER + Mineral Soils,kg/m3) - - REAL(r8), allocatable :: wfc (:,:) !field capacity - REAL(r8), allocatable :: porsl (:,:) !fraction of soil that is voids [-] - REAL(r8), allocatable :: psi0 (:,:) !minimum soil suction [mm] (NOTE: "-" valued) - REAL(r8), allocatable :: bsw (:,:) !clapp and hornbereger "b" parameter [-] + integer, allocatable :: patchclass (:) !index of land cover type of the patches at the fraction > 0 + integer, allocatable :: patchtype (:) !land patch type + logical, allocatable :: patchmask (:) !patch mask + + real(r8), allocatable :: patchlatr (:) !latitude in radians + real(r8), allocatable :: patchlonr (:) !longitude in radians + + real(r8), allocatable :: lakedepth (:) !lake depth + real(r8), allocatable :: dz_lake (:,:) !new lake scheme + + real(r8), allocatable :: soil_s_v_alb (:) !albedo of visible of the saturated soil + real(r8), allocatable :: soil_d_v_alb (:) !albedo of visible of the dry soil + real(r8), allocatable :: soil_s_n_alb (:) !albedo of near infrared of the saturated soil + real(r8), allocatable :: soil_d_n_alb (:) !albedo of near infrared of the dry soil + + real(r8), allocatable :: vf_quartz (:,:) !volumetric fraction of quartz within mineral soil + real(r8), allocatable :: vf_gravels (:,:) !volumetric fraction of gravels + real(r8), allocatable :: vf_om (:,:) !volumetric fraction of organic matter + real(r8), allocatable :: vf_sand (:,:) !volumetric fraction of sand + real(r8), allocatable :: wf_gravels (:,:) !gravimetric fraction of gravels + real(r8), allocatable :: wf_sand (:,:) !gravimetric fraction of sand + real(r8), allocatable :: OM_density (:,:) !OM density (kg/m3) + real(r8), allocatable :: BD_all (:,:) !bulk density of soil (GRAVELS + ORGANIC MATTER + Mineral Soils,kg/m3) + + real(r8), allocatable :: wfc (:,:) !field capacity + real(r8), allocatable :: porsl (:,:) !fraction of soil that is voids [-] + real(r8), allocatable :: psi0 (:,:) !minimum soil suction [mm] (NOTE: "-" valued) + real(r8), allocatable :: bsw (:,:) !clapp and hornbereger "b" parameter [-] #ifdef vanGenuchten_Mualem_SOIL_MODEL - REAL(r8), allocatable :: theta_r (:,:) !residual moisture content [-] - REAL(r8), allocatable :: alpha_vgm (:,:) !a parameter corresponding approximately to the inverse of the air-entry value - REAL(r8), allocatable :: L_vgm (:,:) !pore-connectivity parameter [dimensionless] - REAL(r8), allocatable :: n_vgm (:,:) !a shape parameter [dimensionless] - REAL(r8), allocatable :: sc_vgm (:,:) !saturation at the air entry value in the classical vanGenuchten model [-] - REAL(r8), allocatable :: fc_vgm (:,:) !a scaling factor by using air entry value in the Mualem model [-] -#endif - REAL(r8), allocatable :: hksati (:,:) !hydraulic conductivity at saturation [mm h2o/s] - REAL(r8), allocatable :: csol (:,:) !heat capacity of soil solids [J/(m3 K)] - REAL(r8), allocatable :: k_solids (:,:) !thermal conductivity of soil solids [W/m-K] - REAL(r8), allocatable :: dksatu (:,:) !thermal conductivity of saturated soil [W/m-K] - real(r8), allocatable :: dksatf (:,:) !thermal conductivity of saturated frozen soil [W/m-K] - REAL(r8), allocatable :: dkdry (:,:) !thermal conductivity for dry soil [W/(m-K)] - REAL(r8), allocatable :: BA_alpha (:,:) !alpha in Balland and Arp(2005) thermal conductivity scheme - REAL(r8), allocatable :: BA_beta (:,:) !beta in Balland and Arp(2005) thermal conductivity scheme - REAL(r8), allocatable :: htop (:) !canopy top height [m] - REAL(r8), allocatable :: hbot (:) !canopy bottom height [m] - - real(r8), allocatable :: dbedrock (:) !depth to bedrock - integer , allocatable :: ibedrock (:) !bedrock level - - - REAL(r8) :: zlnd !roughness length for soil [m] - REAL(r8) :: zsno !roughness length for snow [m] - REAL(r8) :: csoilc !drag coefficient for soil under canopy [-] - REAL(r8) :: dewmx !maximum dew - REAL(r8) :: wtfact !fraction of model area with high water table - REAL(r8) :: capr !tuning factor to turn first layer T into surface T - REAL(r8) :: cnfac !Crank Nicholson factor between 0 and 1 - REAL(r8) :: ssi !irreducible water saturation of snow - REAL(r8) :: wimp !water impremeable if porosity less than wimp - REAL(r8) :: pondmx !ponding depth (mm) - REAL(r8) :: smpmax !wilting point potential in mm - REAL(r8) :: smpmin !restriction for min of soil poten. (mm) - REAL(r8) :: trsmx0 !max transpiration for moist soil+100% veg. [mm/s] - REAL(r8) :: tcrit !critical temp. to determine rain or snow - REAL(r8) :: wetwatmax !maximum wetland water (mm) + real(r8), allocatable :: theta_r (:,:) !residual moisture content [-] + real(r8), allocatable :: alpha_vgm (:,:) !a parameter corresponding approximately to the inverse of the air-entry value + real(r8), allocatable :: L_vgm (:,:) !pore-connectivity parameter [dimensionless] + real(r8), allocatable :: n_vgm (:,:) !a shape parameter [dimensionless] + real(r8), allocatable :: sc_vgm (:,:) !saturation at the air entry value in the classical vanGenuchten model [-] + real(r8), allocatable :: fc_vgm (:,:) !a scaling factor by using air entry value in the Mualem model [-] +#endif + real(r8), allocatable :: hksati (:,:) !hydraulic conductivity at saturation [mm h2o/s] + real(r8), allocatable :: csol (:,:) !heat capacity of soil solids [J/(m3 K)] + real(r8), allocatable :: k_solids (:,:) !thermal conductivity of soil solids [W/m-K] + real(r8), allocatable :: dksatu (:,:) !thermal conductivity of saturated soil [W/m-K] + real(r8), allocatable :: dksatf (:,:) !thermal conductivity of saturated frozen soil [W/m-K] + real(r8), allocatable :: dkdry (:,:) !thermal conductivity for dry soil [W/(m-K)] + real(r8), allocatable :: BA_alpha (:,:) !alpha in Balland and Arp(2005) thermal conductivity scheme + real(r8), allocatable :: BA_beta (:,:) !beta in Balland and Arp(2005) thermal conductivity scheme + real(r8), allocatable :: htop (:) !canopy top height [m] + real(r8), allocatable :: hbot (:) !canopy bottom height [m] + + real(r8), allocatable :: dbedrock (:) !depth to bedrock + integer , allocatable :: ibedrock (:) !bedrock level + + + real(r8) :: zlnd !roughness length for soil [m] + real(r8) :: zsno !roughness length for snow [m] + real(r8) :: csoilc !drag coefficient for soil under canopy [-] + real(r8) :: dewmx !maximum dew + real(r8) :: wtfact !fraction of model area with high water table + real(r8) :: capr !tuning factor to turn first layer T into surface T + real(r8) :: cnfac !Crank Nicholson factor between 0 and 1 + real(r8) :: ssi !irreducible water saturation of snow + real(r8) :: wimp !water impremeable IF porosity less than wimp + real(r8) :: pondmx !ponding depth (mm) + real(r8) :: smpmax !wilting point potential in mm + real(r8) :: smpmin !restriction for min of soil poten. (mm) + real(r8) :: trsmx0 !max transpiration for moist soil+100% veg. [mm/s] + real(r8) :: tcrit !critical temp. to determine rain or snow + real(r8) :: wetwatmax !maximum wetland water (mm) ! PUBLIC MEMBER FUNCTIONS: - public :: allocate_TimeInvariants - public :: deallocate_TimeInvariants - public :: READ_TimeInvariants - public :: WRITE_TimeInvariants + PUBLIC :: allocate_TimeInvariants + PUBLIC :: deallocate_TimeInvariants + PUBLIC :: READ_TimeInvariants + PUBLIC :: WRITE_TimeInvariants ! PRIVATE MEMBER FUNCTIONS: !----------------------------------------------------------------------- - CONTAINS +CONTAINS !----------------------------------------------------------------------- - SUBROUTINE allocate_TimeInvariants () - ! -------------------------------------------------------------------- - ! Allocates memory for CoLM 1d [numpatch] variables - ! -------------------------------------------------------------------- - - use MOD_Precision - USE MOD_Vars_Global - use MOD_SPMD_Task - use MOD_LandPatch, only: numpatch - IMPLICIT NONE - - if (p_is_worker) then - - if (numpatch > 0) then - - allocate (patchclass (numpatch)) - allocate (patchtype (numpatch)) - allocate (patchmask (numpatch)) - - allocate (patchlonr (numpatch)) - allocate (patchlatr (numpatch)) - - allocate (lakedepth (numpatch)) - allocate (dz_lake (nl_lake,numpatch)) - - allocate (soil_s_v_alb (numpatch)) - allocate (soil_d_v_alb (numpatch)) - allocate (soil_s_n_alb (numpatch)) - allocate (soil_d_n_alb (numpatch)) - - allocate (vf_quartz (nl_soil,numpatch)) - allocate (vf_gravels (nl_soil,numpatch)) - allocate (vf_om (nl_soil,numpatch)) - allocate (vf_sand (nl_soil,numpatch)) - allocate (wf_gravels (nl_soil,numpatch)) - allocate (wf_sand (nl_soil,numpatch)) - allocate (OM_density (nl_soil,numpatch)) - allocate (BD_all (nl_soil,numpatch)) - allocate (wfc (nl_soil,numpatch)) - allocate (porsl (nl_soil,numpatch)) - allocate (psi0 (nl_soil,numpatch)) - allocate (bsw (nl_soil,numpatch)) + SUBROUTINE allocate_TimeInvariants () + ! -------------------------------------------------------------------- + ! Allocates memory for CoLM 1d [numpatch] variables + ! -------------------------------------------------------------------- + + USE MOD_Precision + USE MOD_Vars_Global + USE MOD_SPMD_Task + USE MOD_LandPatch, only: numpatch + IMPLICIT NONE + + IF (p_is_worker) THEN + + IF (numpatch > 0) THEN + + allocate (patchclass (numpatch)) + allocate (patchtype (numpatch)) + allocate (patchmask (numpatch)) + + allocate (patchlonr (numpatch)) + allocate (patchlatr (numpatch)) + + allocate (lakedepth (numpatch)) + allocate (dz_lake (nl_lake,numpatch)) + + allocate (soil_s_v_alb (numpatch)) + allocate (soil_d_v_alb (numpatch)) + allocate (soil_s_n_alb (numpatch)) + allocate (soil_d_n_alb (numpatch)) + + allocate (vf_quartz (nl_soil,numpatch)) + allocate (vf_gravels (nl_soil,numpatch)) + allocate (vf_om (nl_soil,numpatch)) + allocate (vf_sand (nl_soil,numpatch)) + allocate (wf_gravels (nl_soil,numpatch)) + allocate (wf_sand (nl_soil,numpatch)) + allocate (OM_density (nl_soil,numpatch)) + allocate (BD_all (nl_soil,numpatch)) + allocate (wfc (nl_soil,numpatch)) + allocate (porsl (nl_soil,numpatch)) + allocate (psi0 (nl_soil,numpatch)) + allocate (bsw (nl_soil,numpatch)) #ifdef vanGenuchten_Mualem_SOIL_MODEL allocate (theta_r (nl_soil,numpatch)) allocate (alpha_vgm (nl_soil,numpatch)) @@ -326,465 +326,465 @@ SUBROUTINE allocate_TimeInvariants () allocate (hbot (numpatch)) allocate (dbedrock (numpatch)) allocate (ibedrock (numpatch)) - end if + ENDIF #if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) - CALL allocate_PFTimeInvariants + CALL allocate_PFTimeInvariants #endif #ifdef BGC - CALL allocate_BGCTimeInvariants + CALL allocate_BGCTimeInvariants #endif #ifdef URBAN_MODEL - CALL allocate_UrbanTimeInvariants + CALL allocate_UrbanTimeInvariants #endif - end if + ENDIF - END SUBROUTINE allocate_TimeInvariants + END SUBROUTINE allocate_TimeInvariants - !--------------------------------------- - SUBROUTINE READ_TimeInvariants (lc_year, casename, dir_restart) + !--------------------------------------- + SUBROUTINE READ_TimeInvariants (lc_year, casename, dir_restart) - !======================================================================= - ! Original version: Yongjiu Dai, September 15, 1999, 03/2014 - !======================================================================= + !======================================================================= + ! Original version: Yongjiu Dai, September 15, 1999, 03/2014 + !======================================================================= - use MOD_Namelist - use MOD_SPMD_Task - use MOD_NetCDFVector - use MOD_NetCDFSerial + USE MOD_Namelist + USE MOD_SPMD_Task + USE MOD_NetCDFVector + USE MOD_NetCDFSerial #ifdef RangeCheck - USE MOD_RangeCheck -#endif - USE MOD_LandPatch - USE MOD_Vars_Global - - IMPLICIT NONE - - INTEGER , intent(in) :: lc_year - character(LEN=*), intent(in) :: casename - character(LEN=*), intent(in) :: dir_restart - - ! Local variables - character(LEN=256) :: file_restart, cyear - - write(cyear,'(i4.4)') lc_year - file_restart = trim(dir_restart) // '/const/' // trim(casename) //'_restart_const' // '_lc' // trim(cyear) // '.nc' - - call ncio_read_vector (file_restart, 'patchclass', landpatch, patchclass) ! - call ncio_read_vector (file_restart, 'patchtype' , landpatch, patchtype ) ! - call ncio_read_vector (file_restart, 'patchmask' , landpatch, patchmask ) ! - - call ncio_read_vector (file_restart, 'patchlonr' , landpatch, patchlonr ) ! - call ncio_read_vector (file_restart, 'patchlatr' , landpatch, patchlatr ) ! - - call ncio_read_vector (file_restart, 'lakedepth', landpatch, lakedepth) ! - call ncio_read_vector (file_restart, 'dz_lake' , nl_lake, landpatch, dz_lake) ! - - call ncio_read_vector (file_restart, 'soil_s_v_alb', landpatch, soil_s_v_alb) ! albedo of visible of the saturated soil - call ncio_read_vector (file_restart, 'soil_d_v_alb', landpatch, soil_d_v_alb) ! albedo of visible of the dry soil - call ncio_read_vector (file_restart, 'soil_s_n_alb', landpatch, soil_s_n_alb) ! albedo of near infrared of the saturated soil - call ncio_read_vector (file_restart, 'soil_d_n_alb', landpatch, soil_d_n_alb) ! albedo of near infrared of the dry soil - - call ncio_read_vector (file_restart, 'vf_quartz ', nl_soil, landpatch, vf_quartz ) ! volumetric fraction of quartz within mineral soil - call ncio_read_vector (file_restart, 'vf_gravels', nl_soil, landpatch, vf_gravels) ! volumetric fraction of gravels - call ncio_read_vector (file_restart, 'vf_om ', nl_soil, landpatch, vf_om ) ! volumetric fraction of organic matter - call ncio_read_vector (file_restart, 'vf_sand ', nl_soil, landpatch, vf_sand ) ! volumetric fraction of sand - call ncio_read_vector (file_restart, 'wf_gravels', nl_soil, landpatch, wf_gravels) ! gravimetric fraction of gravels - call ncio_read_vector (file_restart, 'wf_sand ', nl_soil, landpatch, wf_sand ) ! gravimetric fraction of sand - call ncio_read_vector (file_restart, 'OM_density', nl_soil, landpatch, OM_density) ! OM density - call ncio_read_vector (file_restart, 'BD_all ', nl_soil, landpatch, BD_all ) ! bulk density of soil - call ncio_read_vector (file_restart, 'wfc ', nl_soil, landpatch, wfc ) ! field capacity - call ncio_read_vector (file_restart, 'porsl ' , nl_soil, landpatch, porsl ) ! fraction of soil that is voids [-] - call ncio_read_vector (file_restart, 'psi0 ' , nl_soil, landpatch, psi0 ) ! minimum soil suction [mm] (NOTE: "-" valued) - call ncio_read_vector (file_restart, 'bsw ' , nl_soil, landpatch, bsw ) ! clapp and hornbereger "b" parameter [-] + USE MOD_RangeCheck +#endif + USE MOD_LandPatch + USE MOD_Vars_Global + + IMPLICIT NONE + + integer , intent(in) :: lc_year + character(LEN=*), intent(in) :: casename + character(LEN=*), intent(in) :: dir_restart + + ! Local variables + character(LEN=256) :: file_restart, cyear + + write(cyear,'(i4.4)') lc_year + file_restart = trim(dir_restart) // '/const/' // trim(casename) //'_restart_const' // '_lc' // trim(cyear) // '.nc' + + CALL ncio_read_vector (file_restart, 'patchclass', landpatch, patchclass) ! + CALL ncio_read_vector (file_restart, 'patchtype' , landpatch, patchtype ) ! + CALL ncio_read_vector (file_restart, 'patchmask' , landpatch, patchmask ) ! + + CALL ncio_read_vector (file_restart, 'patchlonr' , landpatch, patchlonr ) ! + CALL ncio_read_vector (file_restart, 'patchlatr' , landpatch, patchlatr ) ! + + CALL ncio_read_vector (file_restart, 'lakedepth', landpatch, lakedepth) ! + CALL ncio_read_vector (file_restart, 'dz_lake' , nl_lake, landpatch, dz_lake) ! + + CALL ncio_read_vector (file_restart, 'soil_s_v_alb', landpatch, soil_s_v_alb) ! albedo of visible of the saturated soil + CALL ncio_read_vector (file_restart, 'soil_d_v_alb', landpatch, soil_d_v_alb) ! albedo of visible of the dry soil + CALL ncio_read_vector (file_restart, 'soil_s_n_alb', landpatch, soil_s_n_alb) ! albedo of near infrared of the saturated soil + CALL ncio_read_vector (file_restart, 'soil_d_n_alb', landpatch, soil_d_n_alb) ! albedo of near infrared of the dry soil + + CALL ncio_read_vector (file_restart, 'vf_quartz ', nl_soil, landpatch, vf_quartz ) ! volumetric fraction of quartz within mineral soil + CALL ncio_read_vector (file_restart, 'vf_gravels', nl_soil, landpatch, vf_gravels) ! volumetric fraction of gravels + CALL ncio_read_vector (file_restart, 'vf_om ', nl_soil, landpatch, vf_om ) ! volumetric fraction of organic matter + CALL ncio_read_vector (file_restart, 'vf_sand ', nl_soil, landpatch, vf_sand ) ! volumetric fraction of sand + CALL ncio_read_vector (file_restart, 'wf_gravels', nl_soil, landpatch, wf_gravels) ! gravimetric fraction of gravels + CALL ncio_read_vector (file_restart, 'wf_sand ', nl_soil, landpatch, wf_sand ) ! gravimetric fraction of sand + CALL ncio_read_vector (file_restart, 'OM_density', nl_soil, landpatch, OM_density) ! OM density + CALL ncio_read_vector (file_restart, 'BD_all ', nl_soil, landpatch, BD_all ) ! bulk density of soil + CALL ncio_read_vector (file_restart, 'wfc ', nl_soil, landpatch, wfc ) ! field capacity + CALL ncio_read_vector (file_restart, 'porsl ' , nl_soil, landpatch, porsl ) ! fraction of soil that is voids [-] + CALL ncio_read_vector (file_restart, 'psi0 ' , nl_soil, landpatch, psi0 ) ! minimum soil suction [mm] (NOTE: "-" valued) + CALL ncio_read_vector (file_restart, 'bsw ' , nl_soil, landpatch, bsw ) ! clapp and hornbereger "b" parameter [-] #ifdef vanGenuchten_Mualem_SOIL_MODEL - call ncio_read_vector (file_restart, 'theta_r ' , nl_soil, landpatch, theta_r ) ! residual moisture content [-] - call ncio_read_vector (file_restart, 'alpha_vgm' , nl_soil, landpatch, alpha_vgm ) ! a parameter corresponding approximately to the inverse of the air-entry value - call ncio_read_vector (file_restart, 'L_vgm ' , nl_soil, landpatch, L_vgm ) ! pore-connectivity parameter [dimensionless] - call ncio_read_vector (file_restart, 'n_vgm ' , nl_soil, landpatch, n_vgm ) ! a shape parameter [dimensionless] - call ncio_read_vector (file_restart, 'sc_vgm ' , nl_soil, landpatch, sc_vgm ) ! saturation at the air entry value in the classical vanGenuchten model [-] - call ncio_read_vector (file_restart, 'fc_vgm ' , nl_soil, landpatch, fc_vgm ) ! a scaling factor by using air entry value in the Mualem model [-] -#endif - call ncio_read_vector (file_restart, 'hksati ' , nl_soil, landpatch, hksati ) ! hydraulic conductivity at saturation [mm h2o/s] - call ncio_read_vector (file_restart, 'csol ' , nl_soil, landpatch, csol ) ! heat capacity of soil solids [J/(m3 K)] - call ncio_read_vector (file_restart, 'k_solids', nl_soil, landpatch, k_solids) ! thermal conductivity of soil solids [W/m-K] - call ncio_read_vector (file_restart, 'dksatu ' , nl_soil, landpatch, dksatu ) ! thermal conductivity of unfrozen saturated soil [W/m-K] - call ncio_read_vector (file_restart, 'dksatf ' , nl_soil, landpatch, dksatf ) ! thermal conductivity of frozen saturated soil [W/m-K] - call ncio_read_vector (file_restart, 'dkdry ' , nl_soil, landpatch, dkdry ) ! thermal conductivity for dry soil [W/(m-K)] - call ncio_read_vector (file_restart, 'BA_alpha', nl_soil, landpatch, BA_alpha) ! alpha in Balland and Arp(2005) thermal conductivity scheme - call ncio_read_vector (file_restart, 'BA_beta' , nl_soil, landpatch, BA_beta ) ! beta in Balland and Arp(2005) thermal conductivity scheme - call ncio_read_vector (file_restart, 'htop' , landpatch, htop) ! - call ncio_read_vector (file_restart, 'hbot' , landpatch, hbot) ! - - IF(DEF_USE_BEDROCK)THEN - call ncio_read_vector (file_restart, 'debdrock' , landpatch, dbedrock) ! - call ncio_read_vector (file_restart, 'ibedrock' , landpatch, ibedrock) ! - ENDIF - - call ncio_read_bcast_serial (file_restart, 'zlnd ', zlnd ) ! roughness length for soil [m] - call ncio_read_bcast_serial (file_restart, 'zsno ', zsno ) ! roughness length for snow [m] - call ncio_read_bcast_serial (file_restart, 'csoilc', csoilc) ! drag coefficient for soil under canopy [-] - call ncio_read_bcast_serial (file_restart, 'dewmx ', dewmx ) ! maximum dew - call ncio_read_bcast_serial (file_restart, 'wtfact', wtfact) ! fraction of model area with high water table - call ncio_read_bcast_serial (file_restart, 'capr ', capr ) ! tuning factor to turn first layer T into surface T - call ncio_read_bcast_serial (file_restart, 'cnfac ', cnfac ) ! Crank Nicholson factor between 0 and 1 - call ncio_read_bcast_serial (file_restart, 'ssi ', ssi ) ! irreducible water saturation of snow - call ncio_read_bcast_serial (file_restart, 'wimp ', wimp ) ! water impremeable if porosity less than wimp - call ncio_read_bcast_serial (file_restart, 'pondmx', pondmx) ! ponding depth (mm) - call ncio_read_bcast_serial (file_restart, 'smpmax', smpmax) ! wilting point potential in mm - call ncio_read_bcast_serial (file_restart, 'smpmin', smpmin) ! restriction for min of soil poten. (mm) - call ncio_read_bcast_serial (file_restart, 'trsmx0', trsmx0) ! max transpiration for moist soil+100% veg. [mm/s] - call ncio_read_bcast_serial (file_restart, 'tcrit ', tcrit ) ! critical temp. to determine rain or snow - call ncio_read_bcast_serial (file_restart, 'wetwatmax', wetwatmax) ! maximum wetland water (mm) + CALL ncio_read_vector (file_restart, 'theta_r ' , nl_soil, landpatch, theta_r ) ! residual moisture content [-] + CALL ncio_read_vector (file_restart, 'alpha_vgm' , nl_soil, landpatch, alpha_vgm ) ! a parameter corresponding approximately to the inverse of the air-entry value + CALL ncio_read_vector (file_restart, 'L_vgm ' , nl_soil, landpatch, L_vgm ) ! pore-connectivity parameter [dimensionless] + CALL ncio_read_vector (file_restart, 'n_vgm ' , nl_soil, landpatch, n_vgm ) ! a shape parameter [dimensionless] + CALL ncio_read_vector (file_restart, 'sc_vgm ' , nl_soil, landpatch, sc_vgm ) ! saturation at the air entry value in the classical vanGenuchten model [-] + CALL ncio_read_vector (file_restart, 'fc_vgm ' , nl_soil, landpatch, fc_vgm ) ! a scaling factor by using air entry value in the Mualem model [-] +#endif + CALL ncio_read_vector (file_restart, 'hksati ' , nl_soil, landpatch, hksati ) ! hydraulic conductivity at saturation [mm h2o/s] + CALL ncio_read_vector (file_restart, 'csol ' , nl_soil, landpatch, csol ) ! heat capacity of soil solids [J/(m3 K)] + CALL ncio_read_vector (file_restart, 'k_solids', nl_soil, landpatch, k_solids) ! thermal conductivity of soil solids [W/m-K] + CALL ncio_read_vector (file_restart, 'dksatu ' , nl_soil, landpatch, dksatu ) ! thermal conductivity of unfrozen saturated soil [W/m-K] + CALL ncio_read_vector (file_restart, 'dksatf ' , nl_soil, landpatch, dksatf ) ! thermal conductivity of frozen saturated soil [W/m-K] + CALL ncio_read_vector (file_restart, 'dkdry ' , nl_soil, landpatch, dkdry ) ! thermal conductivity for dry soil [W/(m-K)] + CALL ncio_read_vector (file_restart, 'BA_alpha', nl_soil, landpatch, BA_alpha) ! alpha in Balland and Arp(2005) thermal conductivity scheme + CALL ncio_read_vector (file_restart, 'BA_beta' , nl_soil, landpatch, BA_beta ) ! beta in Balland and Arp(2005) thermal conductivity scheme + CALL ncio_read_vector (file_restart, 'htop' , landpatch, htop) ! + CALL ncio_read_vector (file_restart, 'hbot' , landpatch, hbot) ! + + IF(DEF_USE_BEDROCK)THEN + CALL ncio_read_vector (file_restart, 'debdrock' , landpatch, dbedrock) ! + CALL ncio_read_vector (file_restart, 'ibedrock' , landpatch, ibedrock) ! + ENDIF + + CALL ncio_read_bcast_serial (file_restart, 'zlnd ', zlnd ) ! roughness length for soil [m] + CALL ncio_read_bcast_serial (file_restart, 'zsno ', zsno ) ! roughness length for snow [m] + CALL ncio_read_bcast_serial (file_restart, 'csoilc', csoilc) ! drag coefficient for soil under canopy [-] + CALL ncio_read_bcast_serial (file_restart, 'dewmx ', dewmx ) ! maximum dew + CALL ncio_read_bcast_serial (file_restart, 'wtfact', wtfact) ! fraction of model area with high water table + CALL ncio_read_bcast_serial (file_restart, 'capr ', capr ) ! tuning factor to turn first layer T into surface T + CALL ncio_read_bcast_serial (file_restart, 'cnfac ', cnfac ) ! Crank Nicholson factor between 0 and 1 + CALL ncio_read_bcast_serial (file_restart, 'ssi ', ssi ) ! irreducible water saturation of snow + CALL ncio_read_bcast_serial (file_restart, 'wimp ', wimp ) ! water impremeable IF porosity less than wimp + CALL ncio_read_bcast_serial (file_restart, 'pondmx', pondmx) ! ponding depth (mm) + CALL ncio_read_bcast_serial (file_restart, 'smpmax', smpmax) ! wilting point potential in mm + CALL ncio_read_bcast_serial (file_restart, 'smpmin', smpmin) ! restriction for min of soil poten. (mm) + CALL ncio_read_bcast_serial (file_restart, 'trsmx0', trsmx0) ! max transpiration for moist soil+100% veg. [mm/s] + CALL ncio_read_bcast_serial (file_restart, 'tcrit ', tcrit ) ! critical temp. to determine rain or snow + CALL ncio_read_bcast_serial (file_restart, 'wetwatmax', wetwatmax) ! maximum wetland water (mm) #if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) - file_restart = trim(dir_restart) // '/const/' // trim(casename) //'_restart_pft_const' // '_lc' // trim(cyear) // '.nc' - CALL READ_PFTimeInvariants (file_restart) + file_restart = trim(dir_restart) // '/const/' // trim(casename) //'_restart_pft_const' // '_lc' // trim(cyear) // '.nc' + CALL READ_PFTimeInvariants (file_restart) #endif #if (defined BGC) - file_restart = trim(dir_restart) // '/const/' // trim(casename) //'_restart_bgc_const' // '_lc' // trim(cyear) // '.nc' - CALL READ_BGCTimeInvariants (file_restart) + file_restart = trim(dir_restart) // '/const/' // trim(casename) //'_restart_bgc_const' // '_lc' // trim(cyear) // '.nc' + CALL READ_BGCTimeInvariants (file_restart) #endif #if (defined URBAN_MODEL) - file_restart = trim(dir_restart) // '/const/' // trim(casename) //'_restart_urb_const' // '_lc' // trim(cyear) // '.nc' - CALL READ_UrbanTimeInvariants (file_restart) + file_restart = trim(dir_restart) // '/const/' // trim(casename) //'_restart_urb_const' // '_lc' // trim(cyear) // '.nc' + CALL READ_UrbanTimeInvariants (file_restart) #endif #ifdef RangeCheck - call check_TimeInvariants () + CALL check_TimeInvariants () #endif #ifdef USEMPI - call mpi_barrier (p_comm_glb, p_err) + CALL mpi_barrier (p_comm_glb, p_err) #endif - if (p_is_master) then - write(*,'(A29)') 'Loading Time Invariants done.' - end if + IF (p_is_master) THEN + write(*,'(A29)') 'Loading Time Invariants done.' + ENDIF - end subroutine READ_TimeInvariants + END SUBROUTINE READ_TimeInvariants - !--------------------------------------- - SUBROUTINE WRITE_TimeInvariants (lc_year, casename, dir_restart) + !--------------------------------------- + SUBROUTINE WRITE_TimeInvariants (lc_year, casename, dir_restart) - !======================================================================= - ! Original version: Yongjiu Dai, September 15, 1999, 03/2014 - !======================================================================= + !======================================================================= + ! Original version: Yongjiu Dai, September 15, 1999, 03/2014 + !======================================================================= - use MOD_Namelist, only : DEF_REST_COMPRESS_LEVEL, DEF_USE_BEDROCK - use MOD_SPMD_Task - use MOD_NetCDFSerial - use MOD_NetCDFVector - use MOD_LandPatch - USE MOD_Vars_Global + USE MOD_Namelist, only : DEF_REST_COMPRESS_LEVEL, DEF_USE_BEDROCK + USE MOD_SPMD_Task + USE MOD_NetCDFSerial + USE MOD_NetCDFVector + USE MOD_LandPatch + USE MOD_Vars_Global - IMPLICIT NONE + IMPLICIT NONE - INTEGER , intent(in) :: lc_year - character(len=*), intent(in) :: casename - character(len=*), intent(in) :: dir_restart + integer , intent(in) :: lc_year + character(len=*), intent(in) :: casename + character(len=*), intent(in) :: dir_restart - ! Local Variables - character(len=256) :: file_restart, cyear - integer :: compress + ! Local Variables + character(len=256) :: file_restart, cyear + integer :: compress - compress = DEF_REST_COMPRESS_LEVEL + compress = DEF_REST_COMPRESS_LEVEL - write(cyear,'(i4.4)') lc_year + write(cyear,'(i4.4)') lc_year - IF (p_is_master) THEN - CALL system('mkdir -p ' // trim(dir_restart)//'/const') - ENDIF + IF (p_is_master) THEN + CALL system('mkdir -p ' // trim(dir_restart)//'/const') + ENDIF #ifdef USEMPI - call mpi_barrier (p_comm_glb, p_err) -#endif - - file_restart = trim(dir_restart) // '/const/' // trim(casename) //'_restart_const' //'_lc'// trim(cyear) // '.nc' - - call ncio_create_file_vector (file_restart, landpatch) - - CALL ncio_define_dimension_vector (file_restart, landpatch, 'patch') - CALL ncio_define_dimension_vector (file_restart, landpatch, 'soil', nl_soil) - CALL ncio_define_dimension_vector (file_restart, landpatch, 'lake', nl_lake) - CALL ncio_define_dimension_vector (file_restart, landpatch, 'band', 2) - CALL ncio_define_dimension_vector (file_restart, landpatch, 'rtyp', 2) - CALL ncio_define_dimension_vector (file_restart, landpatch, 'snow', -maxsnl ) - CALL ncio_define_dimension_vector (file_restart, landpatch, 'snowp1', -maxsnl+1 ) - CALL ncio_define_dimension_vector (file_restart, landpatch, 'soilsnow', nl_soil-maxsnl) - CALL ncio_define_dimension_vector (file_restart, landpatch, 'soil', nl_soil) - CALL ncio_define_dimension_vector (file_restart, landpatch, 'lake', nl_lake) - - call ncio_write_vector (file_restart, 'patchclass', 'patch', landpatch, patchclass) ! - call ncio_write_vector (file_restart, 'patchtype' , 'patch', landpatch, patchtype ) ! - call ncio_write_vector (file_restart, 'patchmask' , 'patch', landpatch, patchmask ) ! - - call ncio_write_vector (file_restart, 'patchlonr' , 'patch', landpatch, patchlonr ) ! - call ncio_write_vector (file_restart, 'patchlatr' , 'patch', landpatch, patchlatr ) ! - - call ncio_write_vector (file_restart, 'lakedepth' , 'patch', landpatch, lakedepth , compress) ! - call ncio_write_vector (file_restart, 'dz_lake' , 'lake', nl_lake, 'patch', landpatch, dz_lake, compress) ! - - call ncio_write_vector (file_restart, 'soil_s_v_alb', 'patch', landpatch, soil_s_v_alb, compress) ! albedo of visible of the saturated soil - call ncio_write_vector (file_restart, 'soil_d_v_alb', 'patch', landpatch, soil_d_v_alb, compress) ! albedo of visible of the dry soil - call ncio_write_vector (file_restart, 'soil_s_n_alb', 'patch', landpatch, soil_s_n_alb, compress) ! albedo of near infrared of the saturated soil - call ncio_write_vector (file_restart, 'soil_d_n_alb', 'patch', landpatch, soil_d_n_alb, compress) ! albedo of near infrared of the dry soil - - call ncio_write_vector (file_restart, 'vf_quartz ', 'soil', nl_soil, 'patch', landpatch, vf_quartz , compress) ! volumetric fraction of quartz within mineral soil - call ncio_write_vector (file_restart, 'vf_gravels', 'soil', nl_soil, 'patch', landpatch, vf_gravels, compress) ! volumetric fraction of gravels - call ncio_write_vector (file_restart, 'vf_om ', 'soil', nl_soil, 'patch', landpatch, vf_om , compress) ! volumetric fraction of organic matter - call ncio_write_vector (file_restart, 'vf_sand ', 'soil', nl_soil, 'patch', landpatch, vf_sand , compress) ! volumetric fraction of sand - call ncio_write_vector (file_restart, 'wf_gravels', 'soil', nl_soil, 'patch', landpatch, wf_gravels, compress) ! gravimetric fraction of gravels - call ncio_write_vector (file_restart, 'wf_sand ', 'soil', nl_soil, 'patch', landpatch, wf_sand , compress) ! gravimetric fraction of sand - call ncio_write_vector (file_restart, 'OM_density', 'soil', nl_soil, 'patch', landpatch, OM_density, compress) ! OM_density - call ncio_write_vector (file_restart, 'BD_all ', 'soil', nl_soil, 'patch', landpatch, BD_all , compress) ! bulk density of soil - call ncio_write_vector (file_restart, 'wfc ', 'soil', nl_soil, 'patch', landpatch, wfc , compress) ! field capacity - call ncio_write_vector (file_restart, 'porsl ', 'soil', nl_soil, 'patch', landpatch, porsl , compress) ! fraction of soil that is voids [-] - call ncio_write_vector (file_restart, 'psi0 ', 'soil', nl_soil, 'patch', landpatch, psi0 , compress) ! minimum soil suction [mm] (NOTE: "-" valued) - call ncio_write_vector (file_restart, 'bsw ', 'soil', nl_soil, 'patch', landpatch, bsw , compress) ! clapp and hornbereger "b" parameter [-] + CALL mpi_barrier (p_comm_glb, p_err) +#endif + + file_restart = trim(dir_restart) // '/const/' // trim(casename) //'_restart_const' //'_lc'// trim(cyear) // '.nc' + + CALL ncio_create_file_vector (file_restart, landpatch) + + CALL ncio_define_dimension_vector (file_restart, landpatch, 'patch') + CALL ncio_define_dimension_vector (file_restart, landpatch, 'soil', nl_soil) + CALL ncio_define_dimension_vector (file_restart, landpatch, 'lake', nl_lake) + CALL ncio_define_dimension_vector (file_restart, landpatch, 'band', 2) + CALL ncio_define_dimension_vector (file_restart, landpatch, 'rtyp', 2) + CALL ncio_define_dimension_vector (file_restart, landpatch, 'snow', -maxsnl ) + CALL ncio_define_dimension_vector (file_restart, landpatch, 'snowp1', -maxsnl+1 ) + CALL ncio_define_dimension_vector (file_restart, landpatch, 'soilsnow', nl_soil-maxsnl) + CALL ncio_define_dimension_vector (file_restart, landpatch, 'soil', nl_soil) + CALL ncio_define_dimension_vector (file_restart, landpatch, 'lake', nl_lake) + + CALL ncio_write_vector (file_restart, 'patchclass', 'patch', landpatch, patchclass) ! + CALL ncio_write_vector (file_restart, 'patchtype' , 'patch', landpatch, patchtype ) ! + CALL ncio_write_vector (file_restart, 'patchmask' , 'patch', landpatch, patchmask ) ! + + CALL ncio_write_vector (file_restart, 'patchlonr' , 'patch', landpatch, patchlonr ) ! + CALL ncio_write_vector (file_restart, 'patchlatr' , 'patch', landpatch, patchlatr ) ! + + CALL ncio_write_vector (file_restart, 'lakedepth' , 'patch', landpatch, lakedepth , compress) ! + CALL ncio_write_vector (file_restart, 'dz_lake' , 'lake', nl_lake, 'patch', landpatch, dz_lake, compress) ! + + CALL ncio_write_vector (file_restart, 'soil_s_v_alb', 'patch', landpatch, soil_s_v_alb, compress) ! albedo of visible of the saturated soil + CALL ncio_write_vector (file_restart, 'soil_d_v_alb', 'patch', landpatch, soil_d_v_alb, compress) ! albedo of visible of the dry soil + CALL ncio_write_vector (file_restart, 'soil_s_n_alb', 'patch', landpatch, soil_s_n_alb, compress) ! albedo of near infrared of the saturated soil + CALL ncio_write_vector (file_restart, 'soil_d_n_alb', 'patch', landpatch, soil_d_n_alb, compress) ! albedo of near infrared of the dry soil + + CALL ncio_write_vector (file_restart, 'vf_quartz ', 'soil', nl_soil, 'patch', landpatch, vf_quartz , compress) ! volumetric fraction of quartz within mineral soil + CALL ncio_write_vector (file_restart, 'vf_gravels', 'soil', nl_soil, 'patch', landpatch, vf_gravels, compress) ! volumetric fraction of gravels + CALL ncio_write_vector (file_restart, 'vf_om ', 'soil', nl_soil, 'patch', landpatch, vf_om , compress) ! volumetric fraction of organic matter + CALL ncio_write_vector (file_restart, 'vf_sand ', 'soil', nl_soil, 'patch', landpatch, vf_sand , compress) ! volumetric fraction of sand + CALL ncio_write_vector (file_restart, 'wf_gravels', 'soil', nl_soil, 'patch', landpatch, wf_gravels, compress) ! gravimetric fraction of gravels + CALL ncio_write_vector (file_restart, 'wf_sand ', 'soil', nl_soil, 'patch', landpatch, wf_sand , compress) ! gravimetric fraction of sand + CALL ncio_write_vector (file_restart, 'OM_density', 'soil', nl_soil, 'patch', landpatch, OM_density, compress) ! OM_density + CALL ncio_write_vector (file_restart, 'BD_all ', 'soil', nl_soil, 'patch', landpatch, BD_all , compress) ! bulk density of soil + CALL ncio_write_vector (file_restart, 'wfc ', 'soil', nl_soil, 'patch', landpatch, wfc , compress) ! field capacity + CALL ncio_write_vector (file_restart, 'porsl ', 'soil', nl_soil, 'patch', landpatch, porsl , compress) ! fraction of soil that is voids [-] + CALL ncio_write_vector (file_restart, 'psi0 ', 'soil', nl_soil, 'patch', landpatch, psi0 , compress) ! minimum soil suction [mm] (NOTE: "-" valued) + CALL ncio_write_vector (file_restart, 'bsw ', 'soil', nl_soil, 'patch', landpatch, bsw , compress) ! clapp and hornbereger "b" parameter [-] #ifdef vanGenuchten_Mualem_SOIL_MODEL - call ncio_write_vector (file_restart, 'theta_r ' , 'soil', nl_soil, 'patch', landpatch, theta_r , compress) ! residual moisture content [-] - call ncio_write_vector (file_restart, 'alpha_vgm' , 'soil', nl_soil, 'patch', landpatch, alpha_vgm , compress) ! a parameter corresponding approximately to the inverse of the air-entry value - call ncio_write_vector (file_restart, 'L_vgm ' , 'soil', nl_soil, 'patch', landpatch, L_vgm , compress) ! pore-connectivity parameter [dimensionless] - call ncio_write_vector (file_restart, 'n_vgm ' , 'soil', nl_soil, 'patch', landpatch, n_vgm , compress) ! a shape parameter [dimensionless] - call ncio_write_vector (file_restart, 'sc_vgm ' , 'soil', nl_soil, 'patch', landpatch, sc_vgm , compress) ! saturation at the air entry value in the classical vanGenuchten model [-] - call ncio_write_vector (file_restart, 'fc_vgm ' , 'soil', nl_soil, 'patch', landpatch, fc_vgm , compress) ! a scaling factor by using air entry value in the Mualem model [-] -#endif - call ncio_write_vector (file_restart, 'hksati ' , 'soil', nl_soil, 'patch', landpatch, hksati , compress) ! hydraulic conductivity at saturation [mm h2o/s] - call ncio_write_vector (file_restart, 'csol ' , 'soil', nl_soil, 'patch', landpatch, csol , compress) ! heat capacity of soil solids [J/(m3 K)] - call ncio_write_vector (file_restart, 'k_solids ' , 'soil', nl_soil, 'patch', landpatch, k_solids , compress) ! thermal conductivity of soil solids [W/m-K] - call ncio_write_vector (file_restart, 'dksatu ' , 'soil', nl_soil, 'patch', landpatch, dksatu , compress) ! thermal conductivity of saturated soil [W/m-K] - call ncio_write_vector (file_restart, 'dksatf ' , 'soil', nl_soil, 'patch', landpatch, dksatf , compress) ! thermal conductivity of saturated soil [W/m-K] - call ncio_write_vector (file_restart, 'dkdry ' , 'soil', nl_soil, 'patch', landpatch, dkdry , compress) ! thermal conductivity for dry soil [W/(m-K)] - call ncio_write_vector (file_restart, 'BA_alpha ' , 'soil', nl_soil, 'patch', landpatch, BA_alpha , compress) ! alpha in Balland and Arp(2005) thermal conductivity scheme - call ncio_write_vector (file_restart, 'BA_beta ' , 'soil', nl_soil, 'patch', landpatch, BA_beta , compress) ! beta in Balland and Arp(2005) thermal conductivity scheme - - call ncio_write_vector (file_restart, 'htop' , 'patch', landpatch, htop) ! - call ncio_write_vector (file_restart, 'hbot' , 'patch', landpatch, hbot) ! - - IF(DEF_USE_BEDROCK)THEN - call ncio_write_vector (file_restart, 'debdrock' , 'patch', landpatch, dbedrock) ! - call ncio_write_vector (file_restart, 'ibedrock' , 'patch', landpatch, ibedrock) ! - ENDIF - - if (p_is_master) then - - call ncio_create_file (file_restart) - - call ncio_write_serial (file_restart, 'zlnd ', zlnd ) ! roughness length for soil [m] - call ncio_write_serial (file_restart, 'zsno ', zsno ) ! roughness length for snow [m] - call ncio_write_serial (file_restart, 'csoilc', csoilc) ! drag coefficient for soil under canopy [-] - call ncio_write_serial (file_restart, 'dewmx ', dewmx ) ! maximum dew - call ncio_write_serial (file_restart, 'wtfact', wtfact) ! fraction of model area with high water table - call ncio_write_serial (file_restart, 'capr ', capr ) ! tuning factor to turn first layer T into surface T - call ncio_write_serial (file_restart, 'cnfac ', cnfac ) ! Crank Nicholson factor between 0 and 1 - call ncio_write_serial (file_restart, 'ssi ', ssi ) ! irreducible water saturation of snow - call ncio_write_serial (file_restart, 'wimp ', wimp ) ! water impremeable if porosity less than wimp - call ncio_write_serial (file_restart, 'pondmx', pondmx) ! ponding depth (mm) - call ncio_write_serial (file_restart, 'smpmax', smpmax) ! wilting point potential in mm - call ncio_write_serial (file_restart, 'smpmin', smpmin) ! restriction for min of soil poten. (mm) - call ncio_write_serial (file_restart, 'trsmx0', trsmx0) ! max transpiration for moist soil+100% veg. [mm/s] - call ncio_write_serial (file_restart, 'tcrit ', tcrit ) ! critical temp. to determine rain or snow - call ncio_write_serial (file_restart, 'wetwatmax', wetwatmax) ! maximum wetland water (mm) - - end if + CALL ncio_write_vector (file_restart, 'theta_r ' , 'soil', nl_soil, 'patch', landpatch, theta_r , compress) ! residual moisture content [-] + CALL ncio_write_vector (file_restart, 'alpha_vgm' , 'soil', nl_soil, 'patch', landpatch, alpha_vgm , compress) ! a parameter corresponding approximately to the inverse of the air-entry value + CALL ncio_write_vector (file_restart, 'L_vgm ' , 'soil', nl_soil, 'patch', landpatch, L_vgm , compress) ! pore-connectivity parameter [dimensionless] + CALL ncio_write_vector (file_restart, 'n_vgm ' , 'soil', nl_soil, 'patch', landpatch, n_vgm , compress) ! a shape parameter [dimensionless] + CALL ncio_write_vector (file_restart, 'sc_vgm ' , 'soil', nl_soil, 'patch', landpatch, sc_vgm , compress) ! saturation at the air entry value in the classical vanGenuchten model [-] + CALL ncio_write_vector (file_restart, 'fc_vgm ' , 'soil', nl_soil, 'patch', landpatch, fc_vgm , compress) ! a scaling factor by using air entry value in the Mualem model [-] +#endif + CALL ncio_write_vector (file_restart, 'hksati ' , 'soil', nl_soil, 'patch', landpatch, hksati , compress) ! hydraulic conductivity at saturation [mm h2o/s] + CALL ncio_write_vector (file_restart, 'csol ' , 'soil', nl_soil, 'patch', landpatch, csol , compress) ! heat capacity of soil solids [J/(m3 K)] + CALL ncio_write_vector (file_restart, 'k_solids ' , 'soil', nl_soil, 'patch', landpatch, k_solids , compress) ! thermal conductivity of soil solids [W/m-K] + CALL ncio_write_vector (file_restart, 'dksatu ' , 'soil', nl_soil, 'patch', landpatch, dksatu , compress) ! thermal conductivity of saturated soil [W/m-K] + CALL ncio_write_vector (file_restart, 'dksatf ' , 'soil', nl_soil, 'patch', landpatch, dksatf , compress) ! thermal conductivity of saturated soil [W/m-K] + CALL ncio_write_vector (file_restart, 'dkdry ' , 'soil', nl_soil, 'patch', landpatch, dkdry , compress) ! thermal conductivity for dry soil [W/(m-K)] + CALL ncio_write_vector (file_restart, 'BA_alpha ' , 'soil', nl_soil, 'patch', landpatch, BA_alpha , compress) ! alpha in Balland and Arp(2005) thermal conductivity scheme + CALL ncio_write_vector (file_restart, 'BA_beta ' , 'soil', nl_soil, 'patch', landpatch, BA_beta , compress) ! beta in Balland and Arp(2005) thermal conductivity scheme + + CALL ncio_write_vector (file_restart, 'htop' , 'patch', landpatch, htop) ! + CALL ncio_write_vector (file_restart, 'hbot' , 'patch', landpatch, hbot) ! + + IF(DEF_USE_BEDROCK)THEN + CALL ncio_write_vector (file_restart, 'debdrock' , 'patch', landpatch, dbedrock) ! + CALL ncio_write_vector (file_restart, 'ibedrock' , 'patch', landpatch, ibedrock) ! + ENDIF + + IF (p_is_master) THEN + + CALL ncio_create_file (file_restart) + + CALL ncio_write_serial (file_restart, 'zlnd ', zlnd ) ! roughness length for soil [m] + CALL ncio_write_serial (file_restart, 'zsno ', zsno ) ! roughness length for snow [m] + CALL ncio_write_serial (file_restart, 'csoilc', csoilc) ! drag coefficient for soil under canopy [-] + CALL ncio_write_serial (file_restart, 'dewmx ', dewmx ) ! maximum dew + CALL ncio_write_serial (file_restart, 'wtfact', wtfact) ! fraction of model area with high water table + CALL ncio_write_serial (file_restart, 'capr ', capr ) ! tuning factor to turn first layer T into surface T + CALL ncio_write_serial (file_restart, 'cnfac ', cnfac ) ! Crank Nicholson factor between 0 and 1 + CALL ncio_write_serial (file_restart, 'ssi ', ssi ) ! irreducible water saturation of snow + CALL ncio_write_serial (file_restart, 'wimp ', wimp ) ! water impremeable IF porosity less than wimp + CALL ncio_write_serial (file_restart, 'pondmx', pondmx) ! ponding depth (mm) + CALL ncio_write_serial (file_restart, 'smpmax', smpmax) ! wilting point potential in mm + CALL ncio_write_serial (file_restart, 'smpmin', smpmin) ! restriction for min of soil poten. (mm) + CALL ncio_write_serial (file_restart, 'trsmx0', trsmx0) ! max transpiration for moist soil+100% veg. [mm/s] + CALL ncio_write_serial (file_restart, 'tcrit ', tcrit ) ! critical temp. to determine rain or snow + CALL ncio_write_serial (file_restart, 'wetwatmax', wetwatmax) ! maximum wetland water (mm) + + ENDIF #if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) - file_restart = trim(dir_restart) // '/const/' // trim(casename) //'_restart_pft_const' //'_lc'// trim(cyear) // '.nc' - CALL WRITE_PFTimeInvariants (file_restart) + file_restart = trim(dir_restart) // '/const/' // trim(casename) //'_restart_pft_const' //'_lc'// trim(cyear) // '.nc' + CALL WRITE_PFTimeInvariants (file_restart) #endif #if (defined BGC) - file_restart = trim(dir_restart) // '/const/' // trim(casename) //'_restart_bgc_const' //'_lc'// trim(cyear) // '.nc' - CALL WRITE_BGCTimeInvariants (file_restart) + file_restart = trim(dir_restart) // '/const/' // trim(casename) //'_restart_bgc_const' //'_lc'// trim(cyear) // '.nc' + CALL WRITE_BGCTimeInvariants (file_restart) #endif #if (defined URBAN_MODEL) - file_restart = trim(dir_restart) // '/const/' // trim(casename) //'_restart_urb_const' //'_lc'// trim(cyear) // '.nc' - CALL WRITE_UrbanTimeInvariants (file_restart) + file_restart = trim(dir_restart) // '/const/' // trim(casename) //'_restart_urb_const' //'_lc'// trim(cyear) // '.nc' + CALL WRITE_UrbanTimeInvariants (file_restart) #endif - end subroutine WRITE_TimeInvariants + END SUBROUTINE WRITE_TimeInvariants - SUBROUTINE deallocate_TimeInvariants () + SUBROUTINE deallocate_TimeInvariants () - use MOD_SPMD_Task - use MOD_LandPatch, only: numpatch + USE MOD_SPMD_Task + USE MOD_LandPatch, only: numpatch - implicit none + IMPLICIT NONE - ! -------------------------------------------------- - ! Deallocates memory for CoLM 1d [numpatch] variables - ! -------------------------------------------------- + ! -------------------------------------------------- + ! Deallocates memory for CoLM 1d [numpatch] variables + ! -------------------------------------------------- - if (p_is_worker) then + IF (p_is_worker) THEN - if (numpatch > 0) then + IF (numpatch > 0) THEN - deallocate (patchclass ) - deallocate (patchtype ) - deallocate (patchmask ) + deallocate (patchclass ) + deallocate (patchtype ) + deallocate (patchmask ) - deallocate (patchlonr ) - deallocate (patchlatr ) + deallocate (patchlonr ) + deallocate (patchlatr ) - deallocate (lakedepth ) - deallocate (dz_lake ) + deallocate (lakedepth ) + deallocate (dz_lake ) - deallocate (soil_s_v_alb ) - deallocate (soil_d_v_alb ) - deallocate (soil_s_n_alb ) - deallocate (soil_d_n_alb ) + deallocate (soil_s_v_alb ) + deallocate (soil_d_v_alb ) + deallocate (soil_s_n_alb ) + deallocate (soil_d_n_alb ) - deallocate (vf_quartz ) - deallocate (vf_gravels ) - deallocate (vf_om ) - deallocate (vf_sand ) - deallocate (wf_gravels ) - deallocate (wf_sand ) - deallocate (OM_density ) - deallocate (BD_all ) - deallocate (wfc ) - deallocate (porsl ) - deallocate (psi0 ) - deallocate (bsw ) + deallocate (vf_quartz ) + deallocate (vf_gravels ) + deallocate (vf_om ) + deallocate (vf_sand ) + deallocate (wf_gravels ) + deallocate (wf_sand ) + deallocate (OM_density ) + deallocate (BD_all ) + deallocate (wfc ) + deallocate (porsl ) + deallocate (psi0 ) + deallocate (bsw ) #ifdef vanGenuchten_Mualem_SOIL_MODEL - deallocate (theta_r ) - deallocate (alpha_vgm ) - deallocate (L_vgm ) - deallocate (n_vgm ) - deallocate (sc_vgm ) - deallocate (fc_vgm ) -#endif - deallocate (hksati ) - deallocate (csol ) - deallocate (k_solids ) - deallocate (dksatu ) - deallocate (dksatf ) - deallocate (dkdry ) - deallocate (BA_alpha ) - deallocate (BA_beta ) - - deallocate (htop ) - deallocate (hbot ) - - deallocate (dbedrock ) - deallocate (ibedrock ) - - end if - end if + deallocate (theta_r ) + deallocate (alpha_vgm ) + deallocate (L_vgm ) + deallocate (n_vgm ) + deallocate (sc_vgm ) + deallocate (fc_vgm ) +#endif + deallocate (hksati ) + deallocate (csol ) + deallocate (k_solids ) + deallocate (dksatu ) + deallocate (dksatf ) + deallocate (dkdry ) + deallocate (BA_alpha ) + deallocate (BA_beta ) + + deallocate (htop ) + deallocate (hbot ) + + deallocate (dbedrock ) + deallocate (ibedrock ) + + ENDIF + ENDIF #if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) - CALL deallocate_PFTimeInvariants + CALL deallocate_PFTimeInvariants #endif #ifdef BGC - CALL deallocate_BGCTimeInvariants + CALL deallocate_BGCTimeInvariants #endif #ifdef URBAN_MODEL - CALL deallocate_UrbanTimeInvariants + CALL deallocate_UrbanTimeInvariants #endif - END SUBROUTINE deallocate_TimeInvariants + END SUBROUTINE deallocate_TimeInvariants #ifdef RangeCheck !--------------------------------------- SUBROUTINE check_TimeInvariants () - use MOD_SPMD_Task - use MOD_RangeCheck - use MOD_Namelist, only : DEF_USE_BEDROCK + USE MOD_SPMD_Task + USE MOD_RangeCheck + USE MOD_Namelist, only : DEF_USE_BEDROCK - IMPLICIT NONE + IMPLICIT NONE - if (p_is_master) then + IF (p_is_master) THEN write(*,'(/,A29)') 'Checking Time Invariants ...' - end if + ENDIF #ifdef USEMPI - call mpi_barrier (p_comm_glb, p_err) -#endif - - call check_vector_data ('lakedepth [m] ', lakedepth ) ! - call check_vector_data ('dz_lake [m] ', dz_lake ) ! new lake scheme - - call check_vector_data ('soil_s_v_alb [-] ', soil_s_v_alb) ! albedo of visible of the saturated soil - call check_vector_data ('soil_d_v_alb [-] ', soil_d_v_alb) ! albedo of visible of the dry soil - call check_vector_data ('soil_s_n_alb [-] ', soil_s_n_alb) ! albedo of near infrared of the saturated soil - call check_vector_data ('soil_d_n_alb [-] ', soil_d_n_alb) ! albedo of near infrared of the dry soil - call check_vector_data ('vf_quartz [m3/m3] ', vf_quartz ) ! volumetric fraction of quartz within mineral soil - call check_vector_data ('vf_gravels [m3/m3] ', vf_gravels ) ! volumetric fraction of gravels - call check_vector_data ('vf_om [m3/m3] ', vf_om ) ! volumetric fraction of organic matter - call check_vector_data ('vf_sand [m3/m3] ', vf_sand ) ! volumetric fraction of sand - call check_vector_data ('wf_gravels [kg/kg] ', wf_gravels ) ! gravimetric fraction of gravels - call check_vector_data ('wf_sand [kg/kg] ', wf_sand ) ! gravimetric fraction of sand - call check_vector_data ('OM_density [kg/m3] ', OM_density ) ! OM density - call check_vector_data ('BD_all [kg/m3] ', BD_all ) ! bulk density of soils - call check_vector_data ('wfc [m3/m3] ', wfc ) ! field capacity - call check_vector_data ('porsl [m3/m3] ', porsl ) ! fraction of soil that is voids [-] - call check_vector_data ('psi0 [mm] ', psi0 ) ! minimum soil suction [mm] (NOTE: "-" valued) - call check_vector_data ('bsw [-] ', bsw ) ! clapp and hornbereger "b" parameter [-] + CALL mpi_barrier (p_comm_glb, p_err) +#endif + + CALL check_vector_data ('lakedepth [m] ', lakedepth ) ! + CALL check_vector_data ('dz_lake [m] ', dz_lake ) ! new lake scheme + + CALL check_vector_data ('soil_s_v_alb [-] ', soil_s_v_alb) ! albedo of visible of the saturated soil + CALL check_vector_data ('soil_d_v_alb [-] ', soil_d_v_alb) ! albedo of visible of the dry soil + CALL check_vector_data ('soil_s_n_alb [-] ', soil_s_n_alb) ! albedo of near infrared of the saturated soil + CALL check_vector_data ('soil_d_n_alb [-] ', soil_d_n_alb) ! albedo of near infrared of the dry soil + CALL check_vector_data ('vf_quartz [m3/m3] ', vf_quartz ) ! volumetric fraction of quartz within mineral soil + CALL check_vector_data ('vf_gravels [m3/m3] ', vf_gravels ) ! volumetric fraction of gravels + CALL check_vector_data ('vf_om [m3/m3] ', vf_om ) ! volumetric fraction of organic matter + CALL check_vector_data ('vf_sand [m3/m3] ', vf_sand ) ! volumetric fraction of sand + CALL check_vector_data ('wf_gravels [kg/kg] ', wf_gravels ) ! gravimetric fraction of gravels + CALL check_vector_data ('wf_sand [kg/kg] ', wf_sand ) ! gravimetric fraction of sand + CALL check_vector_data ('OM_density [kg/m3] ', OM_density ) ! OM density + CALL check_vector_data ('BD_all [kg/m3] ', BD_all ) ! bulk density of soils + CALL check_vector_data ('wfc [m3/m3] ', wfc ) ! field capacity + CALL check_vector_data ('porsl [m3/m3] ', porsl ) ! fraction of soil that is voids [-] + CALL check_vector_data ('psi0 [mm] ', psi0 ) ! minimum soil suction [mm] (NOTE: "-" valued) + CALL check_vector_data ('bsw [-] ', bsw ) ! clapp and hornbereger "b" parameter [-] #ifdef vanGenuchten_Mualem_SOIL_MODEL - call check_vector_data ('theta_r [m3/m3] ', theta_r ) ! residual moisture content [-] - call check_vector_data ('alpha_vgm [-] ', alpha_vgm ) ! a parameter corresponding approximately to the inverse of the air-entry value - call check_vector_data ('L_vgm [-] ', L_vgm ) ! pore-connectivity parameter [dimensionless] - call check_vector_data ('n_vgm [-] ', n_vgm ) ! a shape parameter [dimensionless] - call check_vector_data ('sc_vgm [-] ', sc_vgm ) ! saturation at the air entry value in the classical vanGenuchten model [-] - call check_vector_data ('fc_vgm [-] ', fc_vgm ) ! a scaling factor by using air entry value in the Mualem model [-] -#endif - call check_vector_data ('hksati [mm/s] ', hksati ) ! hydraulic conductivity at saturation [mm h2o/s] - call check_vector_data ('csol [J/m3/K]', csol ) ! heat capacity of soil solids [J/(m3 K)] - call check_vector_data ('k_solids [W/m/K] ', k_solids ) ! thermal conductivity of soil solids [W/m-K] - call check_vector_data ('dksatu [W/m/K] ', dksatu ) ! thermal conductivity of unfrozen saturated soil [W/m-K] - call check_vector_data ('dksatf [W/m/K] ', dksatf ) ! thermal conductivity of frozen saturated soil [W/m-K] - call check_vector_data ('dkdry [W/m/K] ', dkdry ) ! thermal conductivity for dry soil [W/(m-K)] - call check_vector_data ('BA_alpha [-] ', BA_alpha ) ! alpha in Balland and Arp(2005) thermal conductivity scheme - call check_vector_data ('BA_beta [-] ', BA_beta ) ! beta in Balland and Arp(2005) thermal conductivity scheme - - call check_vector_data ('htop [m] ', htop ) - call check_vector_data ('hbot [m] ', hbot ) - - IF(DEF_USE_BEDROCK)THEN - call check_vector_data ('dbedrock [m] ', dbedrock ) ! - ENDIF + CALL check_vector_data ('theta_r [m3/m3] ', theta_r ) ! residual moisture content [-] + CALL check_vector_data ('alpha_vgm [-] ', alpha_vgm ) ! a parameter corresponding approximately to the inverse of the air-entry value + CALL check_vector_data ('L_vgm [-] ', L_vgm ) ! pore-connectivity parameter [dimensionless] + CALL check_vector_data ('n_vgm [-] ', n_vgm ) ! a shape parameter [dimensionless] + CALL check_vector_data ('sc_vgm [-] ', sc_vgm ) ! saturation at the air entry value in the classical vanGenuchten model [-] + CALL check_vector_data ('fc_vgm [-] ', fc_vgm ) ! a scaling factor by using air entry value in the Mualem model [-] +#endif + CALL check_vector_data ('hksati [mm/s] ', hksati ) ! hydraulic conductivity at saturation [mm h2o/s] + CALL check_vector_data ('csol [J/m3/K]', csol ) ! heat capacity of soil solids [J/(m3 K)] + CALL check_vector_data ('k_solids [W/m/K] ', k_solids ) ! thermal conductivity of soil solids [W/m-K] + CALL check_vector_data ('dksatu [W/m/K] ', dksatu ) ! thermal conductivity of unfrozen saturated soil [W/m-K] + CALL check_vector_data ('dksatf [W/m/K] ', dksatf ) ! thermal conductivity of frozen saturated soil [W/m-K] + CALL check_vector_data ('dkdry [W/m/K] ', dkdry ) ! thermal conductivity for dry soil [W/(m-K)] + CALL check_vector_data ('BA_alpha [-] ', BA_alpha ) ! alpha in Balland and Arp(2005) thermal conductivity scheme + CALL check_vector_data ('BA_beta [-] ', BA_beta ) ! beta in Balland and Arp(2005) thermal conductivity scheme + + CALL check_vector_data ('htop [m] ', htop ) + CALL check_vector_data ('hbot [m] ', hbot ) + + IF(DEF_USE_BEDROCK)THEN + CALL check_vector_data ('dbedrock [m] ', dbedrock ) ! + ENDIF #ifdef USEMPI - call mpi_barrier (p_comm_glb, p_err) -#endif - - if (p_is_master) then - write(*,'(/,A)') 'Checking Constants ...' - write(*,'(A,E20.10)') 'zlnd [m] ', zlnd ! roughness length for soil [m] - write(*,'(A,E20.10)') 'zsno [m] ', zsno ! roughness length for snow [m] - write(*,'(A,E20.10)') 'csoilc [-] ', csoilc ! drag coefficient for soil under canopy [-] - write(*,'(A,E20.10)') 'dewmx [mm] ', dewmx ! maximum dew - write(*,'(A,E20.10)') 'wtfact [-] ', wtfact ! fraction of model area with high water table - write(*,'(A,E20.10)') 'capr [-] ', capr ! tuning factor to turn first layer T into surface T - write(*,'(A,E20.10)') 'cnfac [-] ', cnfac ! Crank Nicholson factor between 0 and 1 - write(*,'(A,E20.10)') 'ssi [-] ', ssi ! irreducible water saturation of snow - write(*,'(A,E20.10)') 'wimp [m3/m3]', wimp ! water impremeable if porosity less than wimp - write(*,'(A,E20.10)') 'pondmx [mm] ', pondmx ! ponding depth (mm) - write(*,'(A,E20.10)') 'smpmax [mm] ', smpmax ! wilting point potential in mm - write(*,'(A,E20.10)') 'smpmin [mm] ', smpmin ! restriction for min of soil poten. (mm) - write(*,'(A,E20.10)') 'trsmx0 [mm/s] ', trsmx0 ! max transpiration for moist soil+100% veg. [mm/s] - write(*,'(A,E20.10)') 'tcrit [K] ', tcrit ! critical temp. to determine rain or snow - write(*,'(A,E20.10)') 'wetwatmax [mm]', wetwatmax ! maximum wetland water (mm) - end if + CALL mpi_barrier (p_comm_glb, p_err) +#endif + + IF (p_is_master) THEN + write(*,'(/,A)') 'Checking Constants ...' + write(*,'(A,E20.10)') 'zlnd [m] ', zlnd ! roughness length for soil [m] + write(*,'(A,E20.10)') 'zsno [m] ', zsno ! roughness length for snow [m] + write(*,'(A,E20.10)') 'csoilc [-] ', csoilc ! drag coefficient for soil under canopy [-] + write(*,'(A,E20.10)') 'dewmx [mm] ', dewmx ! maximum dew + write(*,'(A,E20.10)') 'wtfact [-] ', wtfact ! fraction of model area with high water table + write(*,'(A,E20.10)') 'capr [-] ', capr ! tuning factor to turn first layer T into surface T + write(*,'(A,E20.10)') 'cnfac [-] ', cnfac ! Crank Nicholson factor between 0 and 1 + write(*,'(A,E20.10)') 'ssi [-] ', ssi ! irreducible water saturation of snow + write(*,'(A,E20.10)') 'wimp [m3/m3]', wimp ! water impremeable IF porosity less than wimp + write(*,'(A,E20.10)') 'pondmx [mm] ', pondmx ! ponding depth (mm) + write(*,'(A,E20.10)') 'smpmax [mm] ', smpmax ! wilting point potential in mm + write(*,'(A,E20.10)') 'smpmin [mm] ', smpmin ! restriction for min of soil poten. (mm) + write(*,'(A,E20.10)') 'trsmx0 [mm/s] ', trsmx0 ! max transpiration for moist soil+100% veg. [mm/s] + write(*,'(A,E20.10)') 'tcrit [K] ', tcrit ! critical temp. to determine rain or snow + write(*,'(A,E20.10)') 'wetwatmax [mm]', wetwatmax ! maximum wetland water (mm) + ENDIF #if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) - CALL check_PFTimeInvariants + CALL check_PFTimeInvariants #endif #ifdef BGC - CALL check_BGCTimeInvariants + CALL check_BGCTimeInvariants #endif - end subroutine check_TimeInvariants + END SUBROUTINE check_TimeInvariants #endif END MODULE MOD_Vars_TimeInvariants diff --git a/main/MOD_Vars_TimeVariables.F90 b/main/MOD_Vars_TimeVariables.F90 index 406a7b61..3be27e9e 100644 --- a/main/MOD_Vars_TimeVariables.F90 +++ b/main/MOD_Vars_TimeVariables.F90 @@ -13,65 +13,65 @@ MODULE MOD_Vars_PFTimeVariables ! Added by Hua Yuan, 08/2019 ! ----------------------------------------------------------------- - USE MOD_Precision - USE MOD_TimeManager + USE MOD_Precision + USE MOD_TimeManager #ifdef BGC - USE MOD_BGC_Vars_PFTimeVariables + USE MOD_BGC_Vars_PFTimeVariables #endif - IMPLICIT NONE - SAVE + IMPLICIT NONE + SAVE ! ----------------------------------------------------------------- ! Time-varying state variables which reaquired by restart run - ! for LULC_IGBP_PFT or LULC_IGBP_PC - real(r8), allocatable :: tleaf_p (:) !shaded leaf temperature [K] - real(r8), allocatable :: ldew_p (:) !depth of water on foliage [mm] - 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 :: sigf_p (:) !fraction of veg cover, excluding snow-covered veg [-] - real(r8), allocatable :: tlai_p (:) !leaf area index - real(r8), allocatable :: lai_p (:) !leaf area index - real(r8), allocatable :: laisun_p (:) !sunlit leaf area index - real(r8), allocatable :: laisha_p (:) !shaded leaf area index - real(r8), allocatable :: tsai_p (:) !stem area index - real(r8), allocatable :: sai_p (:) !stem area index - real(r8), allocatable :: ssun_p (:,:,:) !sunlit canopy absorption for solar radiation (0-1) - real(r8), allocatable :: ssha_p (:,:,:) !shaded canopy absorption for solar radiation (0-1) - real(r8), allocatable :: thermk_p (:) !canopy gap fraction for tir radiation - real(r8), allocatable :: fshade_p (:) !canopy shade fraction for tir radiation - real(r8), allocatable :: extkb_p (:) !(k, g(mu)/mu) direct solar extinction coefficient - real(r8), allocatable :: extkd_p (:) !diffuse and scattered diffuse PAR extinction coefficient - !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] + ! for LULC_IGBP_PFT or LULC_IGBP_PC + real(r8), allocatable :: tleaf_p (:) !shaded leaf temperature [K] + real(r8), allocatable :: ldew_p (:) !depth of water on foliage [mm] + 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 :: sigf_p (:) !fraction of veg cover, excluding snow-covered veg [-] + real(r8), allocatable :: tlai_p (:) !leaf area index + real(r8), allocatable :: lai_p (:) !leaf area index + real(r8), allocatable :: laisun_p (:) !sunlit leaf area index + real(r8), allocatable :: laisha_p (:) !shaded leaf area index + real(r8), allocatable :: tsai_p (:) !stem area index + real(r8), allocatable :: sai_p (:) !stem area index + real(r8), allocatable :: ssun_p (:,:,:) !sunlit canopy absorption for solar radiation (0-1) + real(r8), allocatable :: ssha_p (:,:,:) !shaded canopy absorption for solar radiation (0-1) + real(r8), allocatable :: thermk_p (:) !canopy gap fraction for tir radiation + real(r8), allocatable :: fshade_p (:) !canopy shade fraction for tir radiation + real(r8), allocatable :: extkb_p (:) !(k, g(mu)/mu) direct solar extinction coefficient + real(r8), allocatable :: extkd_p (:) !diffuse and scattered diffuse PAR extinction coefficient + !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 + 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 :: o3coefv_sun_p(:) !Ozone stress factor for photosynthesis on sunlit leaf - real(r8), allocatable :: o3coefv_sha_p(:) !Ozone stress factor for photosynthesis on shaded leaf - real(r8), allocatable :: o3coefg_sun_p(:) !Ozone stress factor for stomata on sunlit leaf - real(r8), allocatable :: o3coefg_sha_p(:) !Ozone stress factor for stomata on shaded leaf - 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 + real(r8), allocatable :: o3coefv_sun_p(:) !Ozone stress factor for photosynthesis on sunlit leaf + real(r8), allocatable :: o3coefv_sha_p(:) !Ozone stress factor for photosynthesis on shaded leaf + real(r8), allocatable :: o3coefg_sun_p(:) !Ozone stress factor for stomata on sunlit leaf + real(r8), allocatable :: o3coefg_sha_p(:) !Ozone stress factor for stomata on shaded leaf + 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 ! irrigation variables - integer , allocatable :: irrig_method_p(:)!irrigation method -! end irrigation variables + integer , allocatable :: irrig_method_p(:)!irrigation method +! END irrigation variables ! PUBLIC MEMBER FUNCTIONS: - PUBLIC :: allocate_PFTimeVariables - PUBLIC :: deallocate_PFTimeVariables - PUBLIC :: READ_PFTimeVariables - PUBLIC :: WRITE_PFTimeVariables + PUBLIC :: allocate_PFTimeVariables + PUBLIC :: deallocate_PFTimeVariables + PUBLIC :: READ_PFTimeVariables + PUBLIC :: WRITE_PFTimeVariables #ifdef RangeCheck - PUBLIC :: check_PFTimeVariables + PUBLIC :: check_PFTimeVariables #endif ! PRIVATE MEMBER FUNCTIONS: @@ -86,11 +86,11 @@ SUBROUTINE allocate_PFTimeVariables () ! ------------------------------------------------------ ! Allocates memory for CoLM 1d [numpft] variables ! ------------------------------------------------------ - USE MOD_Precision - USE MOD_SPMD_Task - USE MOD_LandPFT - USE MOD_Vars_Global - IMPLICIT NONE + USE MOD_Precision + USE MOD_SPMD_Task + USE MOD_LandPFT + USE MOD_Vars_Global + IMPLICIT NONE IF (p_is_worker) THEN IF (numpft > 0) THEN @@ -119,7 +119,7 @@ SUBROUTINE allocate_PFTimeVariables () allocate (vegwp_p(1:nvegwcs,numpft)); vegwp_p (:,:) = spval allocate (gs0sun_p (numpft)); gs0sun_p (:) = spval allocate (gs0sha_p (numpft)); gs0sha_p (:) = spval -! end plant hydraulic variables +! END plant hydraulic variables ! Allocate Ozone Stress Variables allocate (o3coefv_sun_p(numpft)) ; o3coefv_sun_p(:) = spval !Ozone stress factor for photosynthesis on sunlit leaf allocate (o3coefv_sha_p(numpft)) ; o3coefv_sha_p(:) = spval !Ozone stress factor for photosynthesis on shaded leaf @@ -128,7 +128,7 @@ SUBROUTINE allocate_PFTimeVariables () allocate (lai_old_p (numpft)) ; lai_old_p (:) = spval !lai in last time step allocate (o3uptakesun_p(numpft)) ; o3uptakesun_p(:) = spval !Ozone does, sunlit leaf (mmol O3/m^2) allocate (o3uptakesha_p(numpft)) ; o3uptakesha_p(:) = spval !Ozone does, shaded leaf (mmol O3/m^2) -! End allocate Ozone Stress Variables +! END allocate Ozone Stress Variables allocate (irrig_method_p(numpft))! irrigation method ENDIF @@ -142,12 +142,12 @@ END SUBROUTINE allocate_PFTimeVariables SUBROUTINE READ_PFTimeVariables (file_restart) - USE MOD_Namelist, only: DEF_USE_PLANTHYDRAULICS, DEF_USE_OZONESTRESS, DEF_USE_IRRIGATION - USE MOD_NetCDFVector - USE MOD_LandPFT - USE MOD_Vars_Global + USE MOD_Namelist, only: DEF_USE_PLANTHYDRAULICS, DEF_USE_OZONESTRESS, DEF_USE_IRRIGATION + USE MOD_NetCDFVector + USE MOD_LandPFT + USE MOD_Vars_Global - IMPLICIT NONE + IMPLICIT NONE character(LEN=*), intent(in) :: file_restart @@ -194,17 +194,17 @@ END SUBROUTINE READ_PFTimeVariables SUBROUTINE WRITE_PFTimeVariables (file_restart) - USE MOD_Namelist, only : DEF_REST_COMPRESS_LEVEL, DEF_USE_PLANTHYDRAULICS, DEF_USE_OZONESTRESS, & - DEF_USE_IRRIGATION - USE MOD_LandPFT - USE MOD_NetCDFVector - USE MOD_Vars_Global - IMPLICIT NONE + USE MOD_Namelist, only : DEF_REST_COMPRESS_LEVEL, DEF_USE_PLANTHYDRAULICS, DEF_USE_OZONESTRESS, & + DEF_USE_IRRIGATION + USE MOD_LandPFT + 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 @@ -262,8 +262,8 @@ SUBROUTINE deallocate_PFTimeVariables ! -------------------------------------------------- ! Deallocates memory for CoLM 1d [numpft/numpc] variables ! -------------------------------------------------- - USE MOD_SPMD_Task - USE MOD_LandPFT + USE MOD_SPMD_Task + USE MOD_LandPFT IF (p_is_worker) THEN IF (numpft > 0) THEN @@ -315,10 +315,10 @@ END SUBROUTINE deallocate_PFTimeVariables #ifdef RangeCheck SUBROUTINE check_PFTimeVariables - USE MOD_RangeCheck - USE MOD_Namelist, only : DEF_USE_PLANTHYDRAULICS, DEF_USE_OZONESTRESS, DEF_USE_IRRIGATION + USE MOD_RangeCheck + USE MOD_Namelist, only : DEF_USE_PLANTHYDRAULICS, DEF_USE_OZONESTRESS, DEF_USE_IRRIGATION - IMPLICIT NONE + IMPLICIT NONE CALL check_vector_data ('tleaf_p ', tleaf_p ) ! CALL check_vector_data ('ldew_p ', ldew_p ) ! @@ -375,985 +375,985 @@ MODULE MOD_Vars_TimeVariables ! Created by Yongjiu Dai, 03/2014 ! ------------------------------- - USE MOD_Precision - USE MOD_TimeManager + USE MOD_Precision + USE MOD_TimeManager #if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) - USE MOD_Vars_PFTimeVariables + USE MOD_Vars_PFTimeVariables #endif #ifdef BGC - USE MOD_BGC_Vars_TimeVariables + USE MOD_BGC_Vars_TimeVariables #endif #ifdef LATERAL_FLOW - USE MOD_Hydro_Vars_TimeVariables + USE MOD_Hydro_Vars_TimeVariables #endif #ifdef URBAN_MODEL - USE MOD_Urban_Vars_TimeVariables + USE MOD_Urban_Vars_TimeVariables #endif - IMPLICIT NONE - SAVE + IMPLICIT NONE + SAVE ! ----------------------------------------------------------------- ! Time-varying state variables which reaquired by restart run - 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 :: h2osoi (:,:) ! volumetric soil water in layers [m3/m3] - real(r8), allocatable :: smp (:,:) ! soil matrix potential [mm] - real(r8), allocatable :: hk (:,:) ! hydraulic conductivity [mm h2o/s] - real(r8), allocatable :: rootr (:,:) ! transpiration contribution fraction from different layers - real(r8), allocatable :: rootflux (:,:) ! water exchange between soil and root. Positive: soil->root [?] + 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 :: h2osoi (:,:) ! volumetric soil water in layers [m3/m3] + real(r8), allocatable :: smp (:,:) ! soil matrix potential [mm] + real(r8), allocatable :: hk (:,:) ! hydraulic conductivity [mm h2o/s] + real(r8), allocatable :: rootr (:,:) ! transpiration contribution fraction from different layers + real(r8), allocatable :: rootflux (:,:) ! water exchange between soil and root. Positive: soil->root [?] !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 + 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 :: o3coefv_sun (:) ! Ozone stress factor for photosynthesis on sunlit leaf - real(r8), allocatable :: o3coefv_sha (:) ! Ozone stress factor for photosynthesis on shaded leaf - real(r8), allocatable :: o3coefg_sun (:) ! Ozone stress factor for stomata on sunlit leaf - real(r8), allocatable :: o3coefg_sha (:) ! Ozone stress factor for stomata on shaded leaf - 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 :: rstfacsun_out (:) ! factor of soil water stress on sunlit leaf - real(r8), allocatable :: rstfacsha_out (:) ! factor of soil water stress on shaded leaf - real(r8), allocatable :: gssun_out (:) ! stomata conductance on sunlit leaf - real(r8), allocatable :: gssha_out (:) ! stomata conductance on shaded leaf - real(r8), allocatable :: t_grnd (:) ! ground surface temperature [K] - - real(r8), allocatable :: assimsun_out (:) ! diagnostic sunlit leaf assim value for output - real(r8), allocatable :: assimsha_out (:) ! diagnostic sunlit leaf etr value for output - real(r8), allocatable :: etrsun_out (:) ! diagnostic shaded leaf assim for output - real(r8), allocatable :: etrsha_out (:) ! diagnostic shaded leaf etr for output - - 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 :: fveg (:) ! fraction of vegetation cover - 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 :: green (:) ! leaf greenness - real(r8), allocatable :: tlai (:) ! leaf area index - real(r8), allocatable :: lai (:) ! leaf area index - real(r8), allocatable :: laisun (:) ! leaf area index for sunlit leaf - real(r8), allocatable :: laisha (:) ! leaf area index for shaded leaf - real(r8), allocatable :: tsai (:) ! stem area index - real(r8), allocatable :: sai (:) ! stem area index - real(r8), allocatable :: coszen (:) ! cosine of solar zenith angle - real(r8), allocatable :: alb (:,:,:) ! averaged albedo [-] - real(r8), allocatable :: ssun (:,:,:) ! sunlit canopy absorption for solar radiation (0-1) - real(r8), allocatable :: ssha (:,:,:) ! shaded canopy absorption for solar radiation (0-1) - real(r8), allocatable :: ssoi (:,:,:) ! soil absorption for solar radiation (0-1) - real(r8), allocatable :: ssno (:,:,:) ! snow absorption for solar radiation (0-1) - real(r8), allocatable :: thermk (:) ! canopy gap fraction for tir radiation - real(r8), allocatable :: extkb (:) ! (k, g(mu)/mu) direct solar extinction coefficient - real(r8), allocatable :: extkd (:) ! diffuse and scattered diffuse PAR extinction coefficient - real(r8), allocatable :: zwt (:) ! the depth to water table [m] - real(r8), allocatable :: wa (:) ! water storage in aquifer [mm] - real(r8), allocatable :: wetwat (:) ! water storage in wetland [mm] - real(r8), allocatable :: wat (:) ! total water storage [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) - - 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 [-] - - 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 :: irrig_rate (:) ! irrigation rate [mm s-1] - real(r8), allocatable :: deficit_irrig (:) ! irrigation amount [kg/m2] - real(r8), allocatable :: sum_irrig (:) ! total irrigation amount [kg/m2] - real(r8), allocatable :: sum_irrig_count (:) ! total irrigation counts [-] - integer , allocatable :: n_irrig_steps_left (:) ! left steps for once irrigation [-] - real(r8), allocatable :: tairday (:) ! daily mean temperature [degree C] - real(r8), allocatable :: usday (:) ! daily mean wind component in eastward direction [m/s] - real(r8), allocatable :: vsday (:) ! daily mean wind component in northward direction [m/s] - real(r8), allocatable :: pairday (:) ! daily mean pressure [kPa] - real(r8), allocatable :: rnetday (:) ! daily net radiation flux [MJ/m2/day] - real(r8), allocatable :: fgrndday (:) ! daily ground heat flux [MJ/m2/day] - real(r8), allocatable :: potential_evapotranspiration (:) ! daily potential evapotranspiration [mm/day] - - integer , allocatable :: irrig_method_corn (:) ! irrigation method for corn (0-3) - integer , allocatable :: irrig_method_swheat (:) ! irrigation method for spring wheat (0-3) - integer , allocatable :: irrig_method_wwheat (:) ! irrigation method for winter wheat (0-3) - integer , allocatable :: irrig_method_soybean (:) ! irrigation method for soybean (0-3) - integer , allocatable :: irrig_method_cotton (:) ! irrigation method for cotton (0-3) - integer , allocatable :: irrig_method_rice1 (:) ! irrigation method for rice1 (0-3) - integer , allocatable :: irrig_method_rice2 (:) ! irrigation method for rice2 (0-3) - integer , allocatable :: irrig_method_sugarcane (:) ! irrigation method for sugarcane (0-3) - ! PUBLIC MEMBER FUNCTIONS: - PUBLIC :: allocate_TimeVariables - PUBLIC :: deallocate_TimeVariables - PUBLIC :: READ_TimeVariables - PUBLIC :: WRITE_TimeVariables + real(r8), allocatable :: o3coefv_sun (:) ! Ozone stress factor for photosynthesis on sunlit leaf + real(r8), allocatable :: o3coefv_sha (:) ! Ozone stress factor for photosynthesis on shaded leaf + real(r8), allocatable :: o3coefg_sun (:) ! Ozone stress factor for stomata on sunlit leaf + real(r8), allocatable :: o3coefg_sha (:) ! Ozone stress factor for stomata on shaded leaf + 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 :: rstfacsun_out (:) ! factor of soil water stress on sunlit leaf + real(r8), allocatable :: rstfacsha_out (:) ! factor of soil water stress on shaded leaf + real(r8), allocatable :: gssun_out (:) ! stomata conductance on sunlit leaf + real(r8), allocatable :: gssha_out (:) ! stomata conductance on shaded leaf + real(r8), allocatable :: t_grnd (:) ! ground surface temperature [K] + + real(r8), allocatable :: assimsun_out (:) ! diagnostic sunlit leaf assim value for output + real(r8), allocatable :: assimsha_out (:) ! diagnostic sunlit leaf etr value for output + real(r8), allocatable :: etrsun_out (:) ! diagnostic shaded leaf assim for output + real(r8), allocatable :: etrsha_out (:) ! diagnostic shaded leaf etr for output + + 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 :: fveg (:) ! fraction of vegetation cover + 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 :: green (:) ! leaf greenness + real(r8), allocatable :: tlai (:) ! leaf area index + real(r8), allocatable :: lai (:) ! leaf area index + real(r8), allocatable :: laisun (:) ! leaf area index for sunlit leaf + real(r8), allocatable :: laisha (:) ! leaf area index for shaded leaf + real(r8), allocatable :: tsai (:) ! stem area index + real(r8), allocatable :: sai (:) ! stem area index + real(r8), allocatable :: coszen (:) ! cosine of solar zenith angle + real(r8), allocatable :: alb (:,:,:) ! averaged albedo [-] + real(r8), allocatable :: ssun (:,:,:) ! sunlit canopy absorption for solar radiation (0-1) + real(r8), allocatable :: ssha (:,:,:) ! shaded canopy absorption for solar radiation (0-1) + real(r8), allocatable :: ssoi (:,:,:) ! soil absorption for solar radiation (0-1) + real(r8), allocatable :: ssno (:,:,:) ! snow absorption for solar radiation (0-1) + real(r8), allocatable :: thermk (:) ! canopy gap fraction for tir radiation + real(r8), allocatable :: extkb (:) ! (k, g(mu)/mu) direct solar extinction coefficient + real(r8), allocatable :: extkd (:) ! diffuse and scattered diffuse PAR extinction coefficient + real(r8), allocatable :: zwt (:) ! the depth to water table [m] + real(r8), allocatable :: wa (:) ! water storage in aquifer [mm] + real(r8), allocatable :: wetwat (:) ! water storage in wetland [mm] + real(r8), allocatable :: wat (:) ! total water storage [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) + + 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 [-] + + 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 :: irrig_rate (:) ! irrigation rate [mm s-1] + real(r8), allocatable :: deficit_irrig (:) ! irrigation amount [kg/m2] + real(r8), allocatable :: sum_irrig (:) ! total irrigation amount [kg/m2] + real(r8), allocatable :: sum_irrig_count (:) ! total irrigation counts [-] + integer , allocatable :: n_irrig_steps_left (:) ! left steps for once irrigation [-] + real(r8), allocatable :: tairday (:) ! daily mean temperature [degree C] + real(r8), allocatable :: usday (:) ! daily mean wind component in eastward direction [m/s] + real(r8), allocatable :: vsday (:) ! daily mean wind component in northward direction [m/s] + real(r8), allocatable :: pairday (:) ! daily mean pressure [kPa] + real(r8), allocatable :: rnetday (:) ! daily net radiation flux [MJ/m2/day] + real(r8), allocatable :: fgrndday (:) ! daily ground heat flux [MJ/m2/day] + real(r8), allocatable :: potential_evapotranspiration (:) ! daily potential evapotranspiration [mm/day] + + integer , allocatable :: irrig_method_corn (:) ! irrigation method for corn (0-3) + integer , allocatable :: irrig_method_swheat (:) ! irrigation method for spring wheat (0-3) + integer , allocatable :: irrig_method_wwheat (:) ! irrigation method for winter wheat (0-3) + integer , allocatable :: irrig_method_soybean (:) ! irrigation method for soybean (0-3) + integer , allocatable :: irrig_method_cotton (:) ! irrigation method for cotton (0-3) + integer , allocatable :: irrig_method_rice1 (:) ! irrigation method for rice1 (0-3) + integer , allocatable :: irrig_method_rice2 (:) ! irrigation method for rice2 (0-3) + integer , allocatable :: irrig_method_sugarcane (:) ! irrigation method for sugarcane (0-3) + ! PUBLIC MEMBER FUNCTIONS: + PUBLIC :: allocate_TimeVariables + PUBLIC :: deallocate_TimeVariables + PUBLIC :: READ_TimeVariables + PUBLIC :: WRITE_TimeVariables #ifdef RangeCheck - PUBLIC :: check_TimeVariables + PUBLIC :: check_TimeVariables #endif !----------------------------------------------------------------------- - CONTAINS +CONTAINS !----------------------------------------------------------------------- - SUBROUTINE allocate_TimeVariables + SUBROUTINE allocate_TimeVariables ! -------------------------------------------------------------------- ! Allocates memory for CoLM 1d [numpatch] variables ! ------------------------------------------------------ - USE MOD_Precision - USE MOD_Vars_Global - USE MOD_SPMD_Task - USE MOD_LandPatch, only: numpatch - IMPLICIT NONE + USE MOD_Precision + USE MOD_Vars_Global + USE MOD_SPMD_Task + USE MOD_LandPatch, only: numpatch + IMPLICIT NONE - IF (p_is_worker) THEN - - IF (numpatch > 0) THEN + IF (p_is_worker) THEN - allocate (z_sno (maxsnl+1:0, numpatch)); z_sno (:,:) = spval - allocate (dz_sno (maxsnl+1:0, numpatch)); dz_sno (:,:) = spval - allocate (t_soisno (maxsnl+1:nl_soil,numpatch)); t_soisno (:,:) = spval - allocate (wliq_soisno(maxsnl+1:nl_soil,numpatch)); wliq_soisno (:,:) = spval - allocate (wice_soisno(maxsnl+1:nl_soil,numpatch)); wice_soisno (:,:) = spval - allocate (smp (1:nl_soil,numpatch)); smp (:,:) = spval - allocate (hk (1:nl_soil,numpatch)); hk (:,:) = spval - allocate (h2osoi (1:nl_soil,numpatch)); h2osoi (:,:) = spval - allocate (rootr (1:nl_soil,numpatch)); rootr (:,:) = spval - allocate (rootflux (1:nl_soil,numpatch)); rootflux (:,:) = spval + IF (numpatch > 0) THEN + + allocate (z_sno (maxsnl+1:0, numpatch)); z_sno (:,:) = spval + allocate (dz_sno (maxsnl+1:0, numpatch)); dz_sno (:,:) = spval + allocate (t_soisno (maxsnl+1:nl_soil,numpatch)); t_soisno (:,:) = spval + allocate (wliq_soisno(maxsnl+1:nl_soil,numpatch)); wliq_soisno (:,:) = spval + allocate (wice_soisno(maxsnl+1:nl_soil,numpatch)); wice_soisno (:,:) = spval + allocate (smp (1:nl_soil,numpatch)); smp (:,:) = spval + allocate (hk (1:nl_soil,numpatch)); hk (:,:) = spval + allocate (h2osoi (1:nl_soil,numpatch)); h2osoi (:,:) = spval + allocate (rootr (1:nl_soil,numpatch)); rootr (:,:) = spval + allocate (rootflux (1:nl_soil,numpatch)); rootflux (:,:) = spval !Plant Hydraulic variables - allocate (vegwp (1:nvegwcs,numpatch)); vegwp (:,:) = spval - allocate (gs0sun (numpatch)); gs0sun (:) = spval - allocate (gs0sha (numpatch)); gs0sha (:) = spval + allocate (vegwp (1:nvegwcs,numpatch)); vegwp (:,:) = spval + allocate (gs0sun (numpatch)); gs0sun (:) = spval + allocate (gs0sha (numpatch)); gs0sha (:) = spval !END plant hydraulic variables !Ozone Stress variables - allocate (o3coefv_sun (numpatch)); o3coefv_sun (:) = spval - allocate (o3coefv_sha (numpatch)); o3coefv_sha (:) = spval - allocate (o3coefg_sun (numpatch)); o3coefg_sun (:) = spval - allocate (o3coefg_sha (numpatch)); o3coefg_sha (:) = spval - allocate (lai_old (numpatch)); lai_old (:) = spval - allocate (o3uptakesun (numpatch)); o3uptakesun (:) = spval - allocate (o3uptakesha (numpatch)); o3uptakesha (:) = spval -!End ozone stress variables - - allocate (rstfacsun_out (numpatch)); rstfacsun_out (:) = spval - allocate (rstfacsha_out (numpatch)); rstfacsha_out (:) = spval - allocate (gssun_out (numpatch)); gssun_out (:) = spval - allocate (gssha_out (numpatch)); gssha_out (:) = spval - allocate (assimsun_out (numpatch)); assimsun_out (:) = spval - allocate (assimsha_out (numpatch)); assimsha_out (:) = spval - allocate (etrsun_out (numpatch)); etrsun_out (:) = spval - allocate (etrsha_out (numpatch)); etrsha_out (:) = spval - - allocate (t_grnd (numpatch)); t_grnd (:) = spval - allocate (tleaf (numpatch)); tleaf (:) = spval - allocate (ldew (numpatch)); ldew (:) = spval - allocate (ldew_rain (numpatch)); ldew_rain (:) = spval - allocate (ldew_snow (numpatch)); ldew_snow (:) = spval - allocate (sag (numpatch)); sag (:) = spval - allocate (scv (numpatch)); scv (:) = spval - allocate (snowdp (numpatch)); snowdp (:) = spval - allocate (fveg (numpatch)); fveg (:) = spval - allocate (fsno (numpatch)); fsno (:) = spval - allocate (sigf (numpatch)); sigf (:) = spval - allocate (green (numpatch)); green (:) = spval - allocate (tlai (numpatch)); tlai (:) = spval - allocate (lai (numpatch)); lai (:) = spval - allocate (laisun (numpatch)); laisun (:) = spval - allocate (laisha (numpatch)); laisha (:) = spval - allocate (tsai (numpatch)); tsai (:) = spval - allocate (sai (numpatch)); sai (:) = spval - allocate (coszen (numpatch)); coszen (:) = spval - allocate (alb (2,2,numpatch)); alb (:,:,:) = spval - allocate (ssun (2,2,numpatch)); ssun (:,:,:) = spval - allocate (ssha (2,2,numpatch)); ssha (:,:,:) = spval - allocate (ssoi (2,2,numpatch)); ssoi (:,:,:) = spval - allocate (ssno (2,2,numpatch)); ssno (:,:,:) = spval - allocate (thermk (numpatch)); thermk (:) = spval - allocate (extkb (numpatch)); extkb (:) = spval - allocate (extkd (numpatch)); extkd (:) = spval - allocate (zwt (numpatch)); zwt (:) = spval - allocate (wa (numpatch)); wa (:) = spval - allocate (wetwat (numpatch)); wetwat (:) = spval - allocate (wat (numpatch)); wat (:) = spval - allocate (wdsrf (numpatch)); wdsrf (:) = spval - allocate (rss (numpatch)); rss (:) = spval - allocate (t_lake (nl_lake,numpatch)); t_lake (:,:) = spval - allocate (lake_icefrac (nl_lake,numpatch)); lake_icefrac(:,:) = spval - allocate (savedtke1 (numpatch)); savedtke1 (:) = spval - - allocate (snw_rds (maxsnl+1:0,numpatch)); snw_rds (:,:) = spval - allocate (mss_bcpho (maxsnl+1:0,numpatch)); mss_bcpho (:,:) = spval - allocate (mss_bcphi (maxsnl+1:0,numpatch)); mss_bcphi (:,:) = spval - allocate (mss_ocpho (maxsnl+1:0,numpatch)); mss_ocpho (:,:) = spval - allocate (mss_ocphi (maxsnl+1:0,numpatch)); mss_ocphi (:,:) = spval - allocate (mss_dst1 (maxsnl+1:0,numpatch)); mss_dst1 (:,:) = spval - allocate (mss_dst2 (maxsnl+1:0,numpatch)); mss_dst2 (:,:) = spval - allocate (mss_dst3 (maxsnl+1:0,numpatch)); mss_dst3 (:,:) = spval - allocate (mss_dst4 (maxsnl+1:0,numpatch)); mss_dst4 (:,:) = spval - allocate (ssno_lyr (2,2,maxsnl+1:1,numpatch)); ssno_lyr(:,:,:,:) = spval - - allocate (trad (numpatch)); trad (:) = spval - allocate (tref (numpatch)); tref (:) = spval - allocate (qref (numpatch)); qref (:) = spval - allocate (rst (numpatch)); rst (:) = spval - allocate (emis (numpatch)); emis (:) = spval - allocate (z0m (numpatch)); z0m (:) = spval - allocate (displa (numpatch)); displa (:) = spval - allocate (zol (numpatch)); zol (:) = spval - allocate (rib (numpatch)); rib (:) = spval - allocate (ustar (numpatch)); ustar (:) = spval - allocate (qstar (numpatch)); qstar (:) = spval - allocate (tstar (numpatch)); tstar (:) = spval - allocate (fm (numpatch)); fm (:) = spval - allocate (fh (numpatch)); fh (:) = spval - allocate (fq (numpatch)); fq (:) = spval - - allocate ( irrig_rate (numpatch)); irrig_rate (:) = spval - allocate ( deficit_irrig (numpatch)); deficit_irrig (:) = spval - allocate ( sum_irrig (numpatch)); sum_irrig (:) = spval - allocate ( sum_irrig_count (numpatch)); sum_irrig_count (:) = spval - allocate ( n_irrig_steps_left (numpatch)); n_irrig_steps_left (:) = spval_i4 - allocate ( tairday (numpatch)); tairday (:) = spval - allocate ( usday (numpatch)); usday (:) = spval - allocate ( vsday (numpatch)); vsday (:) = spval - allocate ( pairday (numpatch)); pairday (:) = spval - allocate ( rnetday (numpatch)); rnetday (:) = spval - allocate ( fgrndday (numpatch)); fgrndday (:) = spval - allocate ( potential_evapotranspiration(numpatch)); potential_evapotranspiration(:) = spval - - allocate ( irrig_method_corn (numpatch)); irrig_method_corn (:) = spval_i4 - allocate ( irrig_method_swheat (numpatch)); irrig_method_swheat (:) = spval_i4 - allocate ( irrig_method_wwheat (numpatch)); irrig_method_wwheat (:) = spval_i4 - allocate ( irrig_method_soybean (numpatch)); irrig_method_soybean (:) = spval_i4 - allocate ( irrig_method_cotton (numpatch)); irrig_method_cotton (:) = spval_i4 - allocate ( irrig_method_rice1 (numpatch)); irrig_method_rice1 (:) = spval_i4 - allocate ( irrig_method_rice2 (numpatch)); irrig_method_rice2 (:) = spval_i4 - allocate ( irrig_method_sugarcane (numpatch)); irrig_method_sugarcane (:) = spval_i4 - - ENDIF - ENDIF + allocate (o3coefv_sun (numpatch)); o3coefv_sun (:) = spval + allocate (o3coefv_sha (numpatch)); o3coefv_sha (:) = spval + allocate (o3coefg_sun (numpatch)); o3coefg_sun (:) = spval + allocate (o3coefg_sha (numpatch)); o3coefg_sha (:) = spval + allocate (lai_old (numpatch)); lai_old (:) = spval + allocate (o3uptakesun (numpatch)); o3uptakesun (:) = spval + allocate (o3uptakesha (numpatch)); o3uptakesha (:) = spval +!END ozone stress variables + + allocate (rstfacsun_out (numpatch)); rstfacsun_out (:) = spval + allocate (rstfacsha_out (numpatch)); rstfacsha_out (:) = spval + allocate (gssun_out (numpatch)); gssun_out (:) = spval + allocate (gssha_out (numpatch)); gssha_out (:) = spval + allocate (assimsun_out (numpatch)); assimsun_out (:) = spval + allocate (assimsha_out (numpatch)); assimsha_out (:) = spval + allocate (etrsun_out (numpatch)); etrsun_out (:) = spval + allocate (etrsha_out (numpatch)); etrsha_out (:) = spval + + allocate (t_grnd (numpatch)); t_grnd (:) = spval + allocate (tleaf (numpatch)); tleaf (:) = spval + allocate (ldew (numpatch)); ldew (:) = spval + allocate (ldew_rain (numpatch)); ldew_rain (:) = spval + allocate (ldew_snow (numpatch)); ldew_snow (:) = spval + allocate (sag (numpatch)); sag (:) = spval + allocate (scv (numpatch)); scv (:) = spval + allocate (snowdp (numpatch)); snowdp (:) = spval + allocate (fveg (numpatch)); fveg (:) = spval + allocate (fsno (numpatch)); fsno (:) = spval + allocate (sigf (numpatch)); sigf (:) = spval + allocate (green (numpatch)); green (:) = spval + allocate (tlai (numpatch)); tlai (:) = spval + allocate (lai (numpatch)); lai (:) = spval + allocate (laisun (numpatch)); laisun (:) = spval + allocate (laisha (numpatch)); laisha (:) = spval + allocate (tsai (numpatch)); tsai (:) = spval + allocate (sai (numpatch)); sai (:) = spval + allocate (coszen (numpatch)); coszen (:) = spval + allocate (alb (2,2,numpatch)); alb (:,:,:) = spval + allocate (ssun (2,2,numpatch)); ssun (:,:,:) = spval + allocate (ssha (2,2,numpatch)); ssha (:,:,:) = spval + allocate (ssoi (2,2,numpatch)); ssoi (:,:,:) = spval + allocate (ssno (2,2,numpatch)); ssno (:,:,:) = spval + allocate (thermk (numpatch)); thermk (:) = spval + allocate (extkb (numpatch)); extkb (:) = spval + allocate (extkd (numpatch)); extkd (:) = spval + allocate (zwt (numpatch)); zwt (:) = spval + allocate (wa (numpatch)); wa (:) = spval + allocate (wetwat (numpatch)); wetwat (:) = spval + allocate (wat (numpatch)); wat (:) = spval + allocate (wdsrf (numpatch)); wdsrf (:) = spval + allocate (rss (numpatch)); rss (:) = spval + allocate (t_lake (nl_lake,numpatch)); t_lake (:,:) = spval + allocate (lake_icefrac (nl_lake,numpatch)); lake_icefrac(:,:) = spval + allocate (savedtke1 (numpatch)); savedtke1 (:) = spval + + allocate (snw_rds (maxsnl+1:0,numpatch)); snw_rds (:,:) = spval + allocate (mss_bcpho (maxsnl+1:0,numpatch)); mss_bcpho (:,:) = spval + allocate (mss_bcphi (maxsnl+1:0,numpatch)); mss_bcphi (:,:) = spval + allocate (mss_ocpho (maxsnl+1:0,numpatch)); mss_ocpho (:,:) = spval + allocate (mss_ocphi (maxsnl+1:0,numpatch)); mss_ocphi (:,:) = spval + allocate (mss_dst1 (maxsnl+1:0,numpatch)); mss_dst1 (:,:) = spval + allocate (mss_dst2 (maxsnl+1:0,numpatch)); mss_dst2 (:,:) = spval + allocate (mss_dst3 (maxsnl+1:0,numpatch)); mss_dst3 (:,:) = spval + allocate (mss_dst4 (maxsnl+1:0,numpatch)); mss_dst4 (:,:) = spval + allocate (ssno_lyr (2,2,maxsnl+1:1,numpatch)); ssno_lyr(:,:,:,:) = spval + + allocate (trad (numpatch)); trad (:) = spval + allocate (tref (numpatch)); tref (:) = spval + allocate (qref (numpatch)); qref (:) = spval + allocate (rst (numpatch)); rst (:) = spval + allocate (emis (numpatch)); emis (:) = spval + allocate (z0m (numpatch)); z0m (:) = spval + allocate (displa (numpatch)); displa (:) = spval + allocate (zol (numpatch)); zol (:) = spval + allocate (rib (numpatch)); rib (:) = spval + allocate (ustar (numpatch)); ustar (:) = spval + allocate (qstar (numpatch)); qstar (:) = spval + allocate (tstar (numpatch)); tstar (:) = spval + allocate (fm (numpatch)); fm (:) = spval + allocate (fh (numpatch)); fh (:) = spval + allocate (fq (numpatch)); fq (:) = spval + + allocate ( irrig_rate (numpatch)); irrig_rate (:) = spval + allocate ( deficit_irrig (numpatch)); deficit_irrig (:) = spval + allocate ( sum_irrig (numpatch)); sum_irrig (:) = spval + allocate ( sum_irrig_count (numpatch)); sum_irrig_count (:) = spval + allocate ( n_irrig_steps_left (numpatch)); n_irrig_steps_left (:) = spval_i4 + allocate ( tairday (numpatch)); tairday (:) = spval + allocate ( usday (numpatch)); usday (:) = spval + allocate ( vsday (numpatch)); vsday (:) = spval + allocate ( pairday (numpatch)); pairday (:) = spval + allocate ( rnetday (numpatch)); rnetday (:) = spval + allocate ( fgrndday (numpatch)); fgrndday (:) = spval + allocate ( potential_evapotranspiration(numpatch)); potential_evapotranspiration(:) = spval + + allocate ( irrig_method_corn (numpatch)); irrig_method_corn (:) = spval_i4 + allocate ( irrig_method_swheat (numpatch)); irrig_method_swheat (:) = spval_i4 + allocate ( irrig_method_wwheat (numpatch)); irrig_method_wwheat (:) = spval_i4 + allocate ( irrig_method_soybean (numpatch)); irrig_method_soybean (:) = spval_i4 + allocate ( irrig_method_cotton (numpatch)); irrig_method_cotton (:) = spval_i4 + allocate ( irrig_method_rice1 (numpatch)); irrig_method_rice1 (:) = spval_i4 + allocate ( irrig_method_rice2 (numpatch)); irrig_method_rice2 (:) = spval_i4 + allocate ( irrig_method_sugarcane (numpatch)); irrig_method_sugarcane (:) = spval_i4 + + ENDIF + ENDIF #if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) - CALL allocate_PFTimeVariables + CALL allocate_PFTimeVariables #endif #ifdef BGC - CALL allocate_BGCTimeVariables + CALL allocate_BGCTimeVariables #endif #ifdef LATERAL_FLOW - CALL allocate_HydroTimeVariables + CALL allocate_HydroTimeVariables #endif #ifdef URBAN_MODEL - CALL allocate_UrbanTimeVariables + CALL allocate_UrbanTimeVariables #endif - END SUBROUTINE allocate_TimeVariables - + END SUBROUTINE allocate_TimeVariables - SUBROUTINE deallocate_TimeVariables () - USE MOD_SPMD_Task - USE MOD_LandPatch, only: numpatch - IMPLICIT NONE + SUBROUTINE deallocate_TimeVariables () - ! -------------------------------------------------- - ! Deallocates memory for CoLM 1d [numpatch] variables - ! -------------------------------------------------- + USE MOD_SPMD_Task + USE MOD_LandPatch, only: numpatch + IMPLICIT NONE - IF (p_is_worker) THEN + ! -------------------------------------------------- + ! Deallocates memory for CoLM 1d [numpatch] variables + ! -------------------------------------------------- - IF (numpatch > 0) THEN + IF (p_is_worker) THEN - deallocate (z_sno ) - deallocate (dz_sno ) - deallocate (t_soisno ) - deallocate (wliq_soisno ) - deallocate (wice_soisno ) - deallocate (smp ) - deallocate (hk ) - deallocate (h2osoi ) - deallocate (rootr ) - deallocate (rootflux ) + IF (numpatch > 0) THEN + + deallocate (z_sno ) + deallocate (dz_sno ) + deallocate (t_soisno ) + deallocate (wliq_soisno ) + deallocate (wice_soisno ) + deallocate (smp ) + deallocate (hk ) + deallocate (h2osoi ) + deallocate (rootr ) + deallocate (rootflux ) !Plant Hydraulic variables - deallocate (vegwp ) - deallocate (gs0sun ) - deallocate (gs0sha ) -!End plant hydraulic variables + deallocate (vegwp ) + deallocate (gs0sun ) + deallocate (gs0sha ) +!END plant hydraulic variables !Ozone stress variables - deallocate (o3coefv_sun ) ! Ozone stress factor for photosynthesis on sunlit leaf - deallocate (o3coefv_sha ) ! Ozone stress factor for photosynthesis on shaded leaf - deallocate (o3coefg_sun ) ! Ozone stress factor for stomata on sunlit leaf - deallocate (o3coefg_sha ) ! Ozone stress factor for stomata on shaded leaf - deallocate (lai_old ) ! lai in last time step - deallocate (o3uptakesun ) ! Ozone does, sunlit leaf (mmol O3/m^2) - deallocate (o3uptakesha ) ! Ozone does, shaded leaf (mmol O3/m^2) -!End Ozone stress variables - deallocate (rstfacsun_out ) - deallocate (rstfacsha_out ) - deallocate (gssun_out ) - deallocate (gssha_out ) - deallocate (assimsun_out ) - deallocate (assimsha_out ) - deallocate (etrsun_out ) - deallocate (etrsha_out ) - - deallocate (t_grnd ) - deallocate (tleaf ) - deallocate (ldew ) - deallocate (ldew_rain ) - deallocate (ldew_snow ) - deallocate (sag ) - deallocate (scv ) - deallocate (snowdp ) - deallocate (fveg ) - deallocate (fsno ) - deallocate (sigf ) - deallocate (green ) - deallocate (tlai ) - deallocate (lai ) - deallocate (laisun ) - deallocate (laisha ) - deallocate (tsai ) - deallocate (sai ) - deallocate (coszen ) - deallocate (alb ) - deallocate (ssun ) - deallocate (ssha ) - deallocate (ssoi ) - deallocate (ssno ) - deallocate (thermk ) - deallocate (extkb ) - deallocate (extkd ) - deallocate (zwt ) - deallocate (wa ) - deallocate (wetwat ) - deallocate (wat ) - deallocate (wdsrf ) - deallocate (rss ) - - deallocate (t_lake ) ! new lake scheme - deallocate (lake_icefrac ) ! new lake scheme - deallocate (savedtke1 ) ! new lake scheme - - 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 (displa ) - deallocate (zol ) - deallocate (rib ) - deallocate (ustar ) - deallocate (qstar ) - deallocate (tstar ) - deallocate (fm ) - deallocate (fh ) - deallocate (fq ) - - deallocate (irrig_rate ) - deallocate (deficit_irrig ) - deallocate (sum_irrig ) - deallocate (sum_irrig_count ) - deallocate (n_irrig_steps_left ) - - deallocate (tairday ) - deallocate (usday ) - deallocate (vsday ) - deallocate (pairday ) - deallocate (rnetday ) - deallocate (fgrndday ) - deallocate (potential_evapotranspiration) - - deallocate ( irrig_method_corn ) - deallocate ( irrig_method_swheat ) - deallocate ( irrig_method_wwheat ) - deallocate ( irrig_method_soybean ) - deallocate ( irrig_method_cotton ) - deallocate ( irrig_method_rice1 ) - deallocate ( irrig_method_rice2 ) - deallocate ( irrig_method_sugarcane) - ENDIF - ENDIF + deallocate (o3coefv_sun ) ! Ozone stress factor for photosynthesis on sunlit leaf + deallocate (o3coefv_sha ) ! Ozone stress factor for photosynthesis on shaded leaf + deallocate (o3coefg_sun ) ! Ozone stress factor for stomata on sunlit leaf + deallocate (o3coefg_sha ) ! Ozone stress factor for stomata on shaded leaf + deallocate (lai_old ) ! lai in last time step + deallocate (o3uptakesun ) ! Ozone does, sunlit leaf (mmol O3/m^2) + deallocate (o3uptakesha ) ! Ozone does, shaded leaf (mmol O3/m^2) +!END Ozone stress variables + deallocate (rstfacsun_out ) + deallocate (rstfacsha_out ) + deallocate (gssun_out ) + deallocate (gssha_out ) + deallocate (assimsun_out ) + deallocate (assimsha_out ) + deallocate (etrsun_out ) + deallocate (etrsha_out ) + + deallocate (t_grnd ) + deallocate (tleaf ) + deallocate (ldew ) + deallocate (ldew_rain ) + deallocate (ldew_snow ) + deallocate (sag ) + deallocate (scv ) + deallocate (snowdp ) + deallocate (fveg ) + deallocate (fsno ) + deallocate (sigf ) + deallocate (green ) + deallocate (tlai ) + deallocate (lai ) + deallocate (laisun ) + deallocate (laisha ) + deallocate (tsai ) + deallocate (sai ) + deallocate (coszen ) + deallocate (alb ) + deallocate (ssun ) + deallocate (ssha ) + deallocate (ssoi ) + deallocate (ssno ) + deallocate (thermk ) + deallocate (extkb ) + deallocate (extkd ) + deallocate (zwt ) + deallocate (wa ) + deallocate (wetwat ) + deallocate (wat ) + deallocate (wdsrf ) + deallocate (rss ) + + deallocate (t_lake ) ! new lake scheme + deallocate (lake_icefrac ) ! new lake scheme + deallocate (savedtke1 ) ! new lake scheme + + 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 (displa ) + deallocate (zol ) + deallocate (rib ) + deallocate (ustar ) + deallocate (qstar ) + deallocate (tstar ) + deallocate (fm ) + deallocate (fh ) + deallocate (fq ) + + deallocate (irrig_rate ) + deallocate (deficit_irrig ) + deallocate (sum_irrig ) + deallocate (sum_irrig_count ) + deallocate (n_irrig_steps_left ) + + deallocate (tairday ) + deallocate (usday ) + deallocate (vsday ) + deallocate (pairday ) + deallocate (rnetday ) + deallocate (fgrndday ) + deallocate (potential_evapotranspiration) + + deallocate ( irrig_method_corn ) + deallocate ( irrig_method_swheat ) + deallocate ( irrig_method_wwheat ) + deallocate ( irrig_method_soybean ) + deallocate ( irrig_method_cotton ) + deallocate ( irrig_method_rice1 ) + deallocate ( irrig_method_rice2 ) + deallocate ( irrig_method_sugarcane) + ENDIF + ENDIF #if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) - CALL deallocate_PFTimeVariables + CALL deallocate_PFTimeVariables #endif #if (defined BGC) - CALL deallocate_BGCTimeVariables + CALL deallocate_BGCTimeVariables #endif #ifdef LATERAL_FLOW - CALL deallocate_HydroTimeVariables + CALL deallocate_HydroTimeVariables #endif #if (defined URBAN_MODEL) - CALL deallocate_UrbanTimeVariables + CALL deallocate_UrbanTimeVariables #endif - END SUBROUTINE deallocate_TimeVariables + END SUBROUTINE deallocate_TimeVariables - !--------------------------------------- - FUNCTION save_to_restart (idate, deltim, itstamp, ptstamp) result(rwrite) + !--------------------------------------- + FUNCTION save_to_restart (idate, deltim, itstamp, ptstamp) result(rwrite) - USE MOD_Namelist - IMPLICIT NONE + USE MOD_Namelist + IMPLICIT NONE - logical :: rwrite + logical :: rwrite - integer, intent(in) :: idate(3) - real(r8), intent(in) :: deltim - type(timestamp), intent(in) :: itstamp, ptstamp + integer, intent(in) :: idate(3) + real(r8), intent(in) :: deltim + type(timestamp), intent(in) :: itstamp, ptstamp - ! added by yuan, 08/31/2014 - SELECTCASE (trim(adjustl(DEF_WRST_FREQ))) - CASE ('TIMESTEP') - rwrite = .true. - CASE ('HOURLY') - rwrite = isendofhour (idate, deltim) - CASE ('DAILY') - rwrite = isendofday(idate, deltim) - CASE ('MONTHLY') - rwrite = isendofmonth(idate, deltim) - CASE ('YEARLY') - rwrite = isendofyear(idate, deltim) - CASE default - write(*,*) 'Warning: Please use one of TIMESTEP/HOURLY/DAILY/MONTHLY/YEARLY for restart frequency.' - ENDSELECT + ! added by yuan, 08/31/2014 + SELECTCASE (trim(adjustl(DEF_WRST_FREQ))) + CASE ('TIMESTEP') + rwrite = .true. + CASE ('HOURLY') + rwrite = isendofhour (idate, deltim) + CASE ('DAILY') + rwrite = isendofday(idate, deltim) + CASE ('MONTHLY') + rwrite = isendofmonth(idate, deltim) + CASE ('YEARLY') + rwrite = isendofyear(idate, deltim) + CASE default + write(*,*) 'Warning: Please USE one of TIMESTEP/HOURLY/DAILY/MONTHLY/YEARLY for restart frequency.' + ENDSELECT - IF (rwrite) THEN - rwrite = (ptstamp < itstamp) - ENDIF + IF (rwrite) THEN + rwrite = (ptstamp < itstamp) + ENDIF - END FUNCTION save_to_restart + END FUNCTION save_to_restart - !--------------------------------------- - SUBROUTINE WRITE_TimeVariables (idate, lc_year, site, dir_restart) - - !======================================================================= - ! Original version: Yongjiu Dai, September 15, 1999, 03/2014 - !======================================================================= - - USE MOD_SPMD_Task - USE MOD_Namelist, only : DEF_REST_COMPRESS_LEVEL, DEF_USE_PLANTHYDRAULICS, DEF_USE_OZONESTRESS, & - DEF_USE_IRRIGATION - USE MOD_LandPatch - USE MOD_NetCDFVector - USE MOD_Vars_Global - IMPLICIT NONE - - integer, intent(in) :: idate(3) - integer, intent(in) :: lc_year !year of land cover type data - character(LEN=*), intent(in) :: site - character(LEN=*), intent(in) :: dir_restart - - ! Local variables - character(LEN=256) :: file_restart - character(len=14) :: cdate - character(len=256) :: cyear !character for lc_year - integer :: compress - - compress = DEF_REST_COMPRESS_LEVEL - - ! land cover type year - write(cyear,'(i4.4)') lc_year - write(cdate,'(i4.4,"-",i3.3,"-",i5.5)') idate(1), idate(2), idate(3) - - IF (p_is_master) THEN - CALL system('mkdir -p ' // trim(dir_restart)//'/'//trim(cdate)) - ENDIF + !--------------------------------------- + SUBROUTINE WRITE_TimeVariables (idate, lc_year, site, dir_restart) + + !======================================================================= + ! Original version: Yongjiu Dai, September 15, 1999, 03/2014 + !======================================================================= + + USE MOD_SPMD_Task + USE MOD_Namelist, only : DEF_REST_COMPRESS_LEVEL, DEF_USE_PLANTHYDRAULICS, DEF_USE_OZONESTRESS, & + DEF_USE_IRRIGATION + USE MOD_LandPatch + USE MOD_NetCDFVector + USE MOD_Vars_Global + IMPLICIT NONE + + integer, intent(in) :: idate(3) + integer, intent(in) :: lc_year !year of land cover type data + character(LEN=*), intent(in) :: site + character(LEN=*), intent(in) :: dir_restart + + ! Local variables + character(LEN=256) :: file_restart + character(len=14) :: cdate + character(len=256) :: cyear !character for lc_year + integer :: compress + + compress = DEF_REST_COMPRESS_LEVEL + + ! land cover type year + write(cyear,'(i4.4)') lc_year + write(cdate,'(i4.4,"-",i3.3,"-",i5.5)') idate(1), idate(2), idate(3) + + IF (p_is_master) THEN + CALL system('mkdir -p ' // trim(dir_restart)//'/'//trim(cdate)) + ENDIF #ifdef USEMPI - call mpi_barrier (p_comm_glb, p_err) + CALL mpi_barrier (p_comm_glb, p_err) #endif - file_restart = trim(dir_restart)// '/'//trim(cdate)//'/' // trim(site) //'_restart_'//trim(cdate)//'_lc'//trim(cyear)//'.nc' + file_restart = trim(dir_restart)// '/'//trim(cdate)//'/' // trim(site) //'_restart_'//trim(cdate)//'_lc'//trim(cyear)//'.nc' - CALL ncio_create_file_vector (file_restart, landpatch) - CALL ncio_define_dimension_vector (file_restart, landpatch, 'patch') + CALL ncio_create_file_vector (file_restart, landpatch) + CALL ncio_define_dimension_vector (file_restart, landpatch, 'patch') - CALL ncio_define_dimension_vector (file_restart, landpatch, 'snow', -maxsnl ) - CALL ncio_define_dimension_vector (file_restart, landpatch, 'snowp1', -maxsnl+1 ) - CALL ncio_define_dimension_vector (file_restart, landpatch, 'soilsnow', nl_soil-maxsnl) - CALL ncio_define_dimension_vector (file_restart, landpatch, 'soil', nl_soil) - CALL ncio_define_dimension_vector (file_restart, landpatch, 'lake', nl_lake) + CALL ncio_define_dimension_vector (file_restart, landpatch, 'snow', -maxsnl ) + CALL ncio_define_dimension_vector (file_restart, landpatch, 'snowp1', -maxsnl+1 ) + CALL ncio_define_dimension_vector (file_restart, landpatch, 'soilsnow', nl_soil-maxsnl) + CALL ncio_define_dimension_vector (file_restart, landpatch, 'soil', nl_soil) + CALL ncio_define_dimension_vector (file_restart, landpatch, 'lake', nl_lake) IF(DEF_USE_PLANTHYDRAULICS)THEN - CALL ncio_define_dimension_vector (file_restart, landpatch, 'vegnodes', nvegwcs) + CALL ncio_define_dimension_vector (file_restart, landpatch, 'vegnodes', nvegwcs) ENDIF - CALL ncio_define_dimension_vector (file_restart, landpatch, 'band', 2) - CALL ncio_define_dimension_vector (file_restart, landpatch, 'rtyp', 2) - - ! Time-varying state variables which reaquired by restart run - CALL ncio_write_vector (file_restart, 'z_sno ' , 'snow', -maxsnl, 'patch', landpatch, z_sno , compress) ! node depth [m] - CALL ncio_write_vector (file_restart, 'dz_sno ' , 'snow', -maxsnl, 'patch', landpatch, dz_sno, compress) ! interface depth [m] - CALL ncio_write_vector (file_restart, 't_soisno' , 'soilsnow', nl_soil-maxsnl, 'patch', landpatch, t_soisno , compress) ! soil temperature [K] - CALL ncio_write_vector (file_restart, 'wliq_soisno', 'soilsnow', nl_soil-maxsnl, 'patch', landpatch, wliq_soisno, compress) ! liquid water in layers [kg/m2] - CALL ncio_write_vector (file_restart, 'wice_soisno', 'soilsnow', nl_soil-maxsnl, 'patch', landpatch, wice_soisno, compress) ! ice lens in layers [kg/m2] - CALL ncio_write_vector (file_restart, 'smp', 'soil', nl_soil, 'patch', landpatch, smp, compress) ! soil matrix potential [mm] - CALL ncio_write_vector (file_restart, 'hk', 'soil', nl_soil, 'patch', landpatch, hk, compress) ! hydraulic conductivity [mm h2o/s] + CALL ncio_define_dimension_vector (file_restart, landpatch, 'band', 2) + CALL ncio_define_dimension_vector (file_restart, landpatch, 'rtyp', 2) + + ! Time-varying state variables which reaquired by restart run + CALL ncio_write_vector (file_restart, 'z_sno ' , 'snow', -maxsnl, 'patch', landpatch, z_sno , compress) ! node depth [m] + CALL ncio_write_vector (file_restart, 'dz_sno ' , 'snow', -maxsnl, 'patch', landpatch, dz_sno, compress) ! interface depth [m] + CALL ncio_write_vector (file_restart, 't_soisno' , 'soilsnow', nl_soil-maxsnl, 'patch', landpatch, t_soisno , compress) ! soil temperature [K] + CALL ncio_write_vector (file_restart, 'wliq_soisno', 'soilsnow', nl_soil-maxsnl, 'patch', landpatch, wliq_soisno, compress) ! liquid water in layers [kg/m2] + CALL ncio_write_vector (file_restart, 'wice_soisno', 'soilsnow', nl_soil-maxsnl, 'patch', landpatch, wice_soisno, compress) ! ice lens in layers [kg/m2] + CALL ncio_write_vector (file_restart, 'smp', 'soil', nl_soil, 'patch', landpatch, smp, compress) ! soil matrix potential [mm] + CALL ncio_write_vector (file_restart, 'hk', 'soil', nl_soil, 'patch', landpatch, hk, compress) ! hydraulic conductivity [mm h2o/s] IF(DEF_USE_PLANTHYDRAULICS)THEN - CALL ncio_write_vector (file_restart, 'vegwp', 'vegnodes', nvegwcs, 'patch', landpatch, vegwp, compress) ! vegetation water potential [mm] - CALL ncio_write_vector (file_restart, 'gs0sun', 'patch', landpatch, gs0sun, compress) ! working copy of sunlit stomata conductance - CALL ncio_write_vector (file_restart, 'gs0sha', 'patch', landpatch, gs0sha, compress) ! working copy of shalit stomata conductance + CALL ncio_write_vector (file_restart, 'vegwp', 'vegnodes', nvegwcs, 'patch', landpatch, vegwp, compress) ! vegetation water potential [mm] + CALL ncio_write_vector (file_restart, 'gs0sun', 'patch', landpatch, gs0sun, compress) ! working copy of sunlit stomata conductance + CALL ncio_write_vector (file_restart, 'gs0sha', 'patch', landpatch, gs0sha, compress) ! working copy of shalit stomata conductance ENDIF IF(DEF_USE_OZONESTRESS)THEN - CALL ncio_write_vector (file_restart, 'lai_old ', 'patch', landpatch, lai_old , compress) - CALL ncio_write_vector (file_restart, 'o3uptakesun', 'patch', landpatch, o3uptakesun, compress) - CALL ncio_write_vector (file_restart, 'o3uptakesha', 'patch', landpatch, o3uptakesha, compress) + CALL ncio_write_vector (file_restart, 'lai_old ', 'patch', landpatch, lai_old , compress) + CALL ncio_write_vector (file_restart, 'o3uptakesun', 'patch', landpatch, o3uptakesun, compress) + CALL ncio_write_vector (file_restart, 'o3uptakesha', 'patch', landpatch, o3uptakesha, compress) ENDIF - CALL ncio_write_vector (file_restart, 't_grnd ' , 'patch', landpatch, t_grnd , compress) ! ground surface temperature [K] - CALL ncio_write_vector (file_restart, 'tleaf ' , 'patch', landpatch, tleaf , compress) ! leaf temperature [K] - CALL ncio_write_vector (file_restart, 'ldew ' , 'patch', landpatch, ldew , compress) ! depth of water on foliage [mm] - CALL ncio_write_vector (file_restart, 'ldew_rain' , 'patch', landpatch, ldew_rain , compress) ! depth of water on foliage [mm] - CALL ncio_write_vector (file_restart, 'ldew_snow' , 'patch', landpatch, ldew_snow , compress) ! depth of water on foliage [mm] - CALL ncio_write_vector (file_restart, 'sag ' , 'patch', landpatch, sag , compress) ! non dimensional snow age [-] - CALL ncio_write_vector (file_restart, 'scv ' , 'patch', landpatch, scv , compress) ! snow cover, water equivalent [mm] - CALL ncio_write_vector (file_restart, 'snowdp ' , 'patch', landpatch, snowdp , compress) ! snow depth [meter] - CALL ncio_write_vector (file_restart, 'fveg ' , 'patch', landpatch, fveg , compress) ! fraction of vegetation cover - CALL ncio_write_vector (file_restart, 'fsno ' , 'patch', landpatch, fsno , compress) ! fraction of snow cover on ground - CALL ncio_write_vector (file_restart, 'sigf ' , 'patch', landpatch, sigf , compress) ! fraction of veg cover, excluding snow-covered veg [-] - CALL ncio_write_vector (file_restart, 'green ' , 'patch', landpatch, green , compress) ! leaf greenness - CALL ncio_write_vector (file_restart, 'lai ' , 'patch', landpatch, lai , compress) ! leaf area index - CALL ncio_write_vector (file_restart, 'tlai ' , 'patch', landpatch, tlai , compress) ! leaf area index - CALL ncio_write_vector (file_restart, 'sai ' , 'patch', landpatch, sai , compress) ! stem area index - CALL ncio_write_vector (file_restart, 'tsai ' , 'patch', landpatch, tsai , compress) ! stem area index - CALL ncio_write_vector (file_restart, 'coszen ' , 'patch', landpatch, coszen , compress) ! cosine of solar zenith angle - CALL ncio_write_vector (file_restart, 'alb ' , 'band', 2, 'rtyp', 2, 'patch', landpatch, alb , compress) ! averaged albedo [-] - CALL ncio_write_vector (file_restart, 'ssun ' , 'band', 2, 'rtyp', 2, 'patch', landpatch, ssun, compress) ! sunlit canopy absorption for solar radiation (0-1) - CALL ncio_write_vector (file_restart, 'ssha ' , 'band', 2, 'rtyp', 2, 'patch', landpatch, ssha, compress) ! shaded canopy absorption for solar radiation (0-1) - CALL ncio_write_vector (file_restart, 'ssoi ' , 'band', 2, 'rtyp', 2, 'patch', landpatch, ssoi, compress) ! shaded canopy absorption for solar radiation (0-1) - CALL ncio_write_vector (file_restart, 'ssno ' , 'band', 2, 'rtyp', 2, 'patch', landpatch, ssno, compress) ! shaded canopy absorption for solar radiation (0-1) - CALL ncio_write_vector (file_restart, 'thermk ' , 'patch', landpatch, thermk , compress) ! canopy gap fraction for tir radiation - CALL ncio_write_vector (file_restart, 'extkb ' , 'patch', landpatch, extkb , compress) ! (k, g(mu)/mu) direct solar extinction coefficient - CALL ncio_write_vector (file_restart, 'extkd ' , 'patch', landpatch, extkd , compress) ! diffuse and scattered diffuse PAR extinction coefficient - CALL ncio_write_vector (file_restart, 'zwt ' , 'patch', landpatch, zwt , compress) ! the depth to water table [m] - CALL ncio_write_vector (file_restart, 'wa ' , 'patch', landpatch, wa , compress) ! water storage in aquifer [mm] - CALL ncio_write_vector (file_restart, 'wetwat ' , 'patch', landpatch, wetwat , compress) ! water storage in wetland [mm] - CALL ncio_write_vector (file_restart, 'wdsrf ' , 'patch', landpatch, wdsrf , compress) ! depth of surface water [mm] - CALL ncio_write_vector (file_restart, 'rss ' , 'patch', landpatch, rss , compress) ! soil surface resistance [s/m] - - CALL ncio_write_vector (file_restart, 't_lake ' , 'lake', nl_lake, 'patch', landpatch, t_lake , compress) ! - CALL ncio_write_vector (file_restart, 'lake_icefrc', 'lake', nl_lake, 'patch', landpatch, lake_icefrac, compress) ! - CALL ncio_write_vector (file_restart, 'savedtke1 ', 'patch', landpatch, savedtke1 , compress) ! - CALL ncio_write_vector (file_restart, 'snw_rds ', 'snow', -maxsnl, 'patch', landpatch, snw_rds , compress) - CALL ncio_write_vector (file_restart, 'mss_bcpho', 'snow', -maxsnl, 'patch', landpatch, mss_bcpho, compress) - CALL ncio_write_vector (file_restart, 'mss_bcphi', 'snow', -maxsnl, 'patch', landpatch, mss_bcphi, compress) - CALL ncio_write_vector (file_restart, 'mss_ocpho', 'snow', -maxsnl, 'patch', landpatch, mss_ocpho, compress) - CALL ncio_write_vector (file_restart, 'mss_ocphi', 'snow', -maxsnl, 'patch', landpatch, mss_ocphi, compress) - CALL ncio_write_vector (file_restart, 'mss_dst1 ', 'snow', -maxsnl, 'patch', landpatch, mss_dst1 , compress) - CALL ncio_write_vector (file_restart, 'mss_dst2 ', 'snow', -maxsnl, 'patch', landpatch, mss_dst2 , compress) - CALL ncio_write_vector (file_restart, 'mss_dst3 ', 'snow', -maxsnl, 'patch', landpatch, mss_dst3 , compress) - CALL ncio_write_vector (file_restart, 'mss_dst4 ', 'snow', -maxsnl, 'patch', landpatch, mss_dst4 , compress) - CALL ncio_write_vector (file_restart, 'ssno_lyr', 'band', 2, 'rtyp', 2, 'snowp1', -maxsnl+1, 'patch', landpatch, ssno_lyr, compress) - - ! Additional va_vectorriables required by reginal model (such as WRF ) RSM) - CALL ncio_write_vector (file_restart, 'trad ', 'patch', landpatch, trad , compress) ! radiative temperature of surface [K] - CALL ncio_write_vector (file_restart, 'tref ', 'patch', landpatch, tref , compress) ! 2 m height air temperature [kelvin] - CALL ncio_write_vector (file_restart, 'qref ', 'patch', landpatch, qref , compress) ! 2 m height air specific humidity - CALL ncio_write_vector (file_restart, 'rst ', 'patch', landpatch, rst , compress) ! canopy stomatal resistance (s/m) - CALL ncio_write_vector (file_restart, 'emis ', 'patch', landpatch, emis , compress) ! averaged bulk surface emissivity - CALL ncio_write_vector (file_restart, 'z0m ', 'patch', landpatch, z0m , compress) ! effective roughness [m] - CALL ncio_write_vector (file_restart, 'zol ', 'patch', landpatch, zol , compress) ! dimensionless height (z/L) used in Monin-Obukhov theory - CALL ncio_write_vector (file_restart, 'rib ', 'patch', landpatch, rib , compress) ! bulk Richardson number in surface layer - CALL ncio_write_vector (file_restart, 'ustar', 'patch', landpatch, ustar, compress) ! u* in similarity theory [m/s] - CALL ncio_write_vector (file_restart, 'qstar', 'patch', landpatch, qstar, compress) ! q* in similarity theory [kg/kg] - CALL ncio_write_vector (file_restart, 'tstar', 'patch', landpatch, tstar, compress) ! t* in similarity theory [K] - CALL ncio_write_vector (file_restart, 'fm ', 'patch', landpatch, fm , compress) ! integral of profile function for momentum - CALL ncio_write_vector (file_restart, 'fh ', 'patch', landpatch, fh , compress) ! integral of profile function for heat - CALL ncio_write_vector (file_restart, 'fq ', 'patch', landpatch, fq , compress) ! integral of profile function for moisture + CALL ncio_write_vector (file_restart, 't_grnd ' , 'patch', landpatch, t_grnd , compress) ! ground surface temperature [K] + CALL ncio_write_vector (file_restart, 'tleaf ' , 'patch', landpatch, tleaf , compress) ! leaf temperature [K] + CALL ncio_write_vector (file_restart, 'ldew ' , 'patch', landpatch, ldew , compress) ! depth of water on foliage [mm] + CALL ncio_write_vector (file_restart, 'ldew_rain' , 'patch', landpatch, ldew_rain , compress) ! depth of water on foliage [mm] + CALL ncio_write_vector (file_restart, 'ldew_snow' , 'patch', landpatch, ldew_snow , compress) ! depth of water on foliage [mm] + CALL ncio_write_vector (file_restart, 'sag ' , 'patch', landpatch, sag , compress) ! non dimensional snow age [-] + CALL ncio_write_vector (file_restart, 'scv ' , 'patch', landpatch, scv , compress) ! snow cover, water equivalent [mm] + CALL ncio_write_vector (file_restart, 'snowdp ' , 'patch', landpatch, snowdp , compress) ! snow depth [meter] + CALL ncio_write_vector (file_restart, 'fveg ' , 'patch', landpatch, fveg , compress) ! fraction of vegetation cover + CALL ncio_write_vector (file_restart, 'fsno ' , 'patch', landpatch, fsno , compress) ! fraction of snow cover on ground + CALL ncio_write_vector (file_restart, 'sigf ' , 'patch', landpatch, sigf , compress) ! fraction of veg cover, excluding snow-covered veg [-] + CALL ncio_write_vector (file_restart, 'green ' , 'patch', landpatch, green , compress) ! leaf greenness + CALL ncio_write_vector (file_restart, 'lai ' , 'patch', landpatch, lai , compress) ! leaf area index + CALL ncio_write_vector (file_restart, 'tlai ' , 'patch', landpatch, tlai , compress) ! leaf area index + CALL ncio_write_vector (file_restart, 'sai ' , 'patch', landpatch, sai , compress) ! stem area index + CALL ncio_write_vector (file_restart, 'tsai ' , 'patch', landpatch, tsai , compress) ! stem area index + CALL ncio_write_vector (file_restart, 'coszen ' , 'patch', landpatch, coszen , compress) ! cosine of solar zenith angle + CALL ncio_write_vector (file_restart, 'alb ' , 'band', 2, 'rtyp', 2, 'patch', landpatch, alb , compress) ! averaged albedo [-] + CALL ncio_write_vector (file_restart, 'ssun ' , 'band', 2, 'rtyp', 2, 'patch', landpatch, ssun, compress) ! sunlit canopy absorption for solar radiation (0-1) + CALL ncio_write_vector (file_restart, 'ssha ' , 'band', 2, 'rtyp', 2, 'patch', landpatch, ssha, compress) ! shaded canopy absorption for solar radiation (0-1) + CALL ncio_write_vector (file_restart, 'ssoi ' , 'band', 2, 'rtyp', 2, 'patch', landpatch, ssoi, compress) ! shaded canopy absorption for solar radiation (0-1) + CALL ncio_write_vector (file_restart, 'ssno ' , 'band', 2, 'rtyp', 2, 'patch', landpatch, ssno, compress) ! shaded canopy absorption for solar radiation (0-1) + CALL ncio_write_vector (file_restart, 'thermk ' , 'patch', landpatch, thermk , compress) ! canopy gap fraction for tir radiation + CALL ncio_write_vector (file_restart, 'extkb ' , 'patch', landpatch, extkb , compress) ! (k, g(mu)/mu) direct solar extinction coefficient + CALL ncio_write_vector (file_restart, 'extkd ' , 'patch', landpatch, extkd , compress) ! diffuse and scattered diffuse PAR extinction coefficient + CALL ncio_write_vector (file_restart, 'zwt ' , 'patch', landpatch, zwt , compress) ! the depth to water table [m] + CALL ncio_write_vector (file_restart, 'wa ' , 'patch', landpatch, wa , compress) ! water storage in aquifer [mm] + CALL ncio_write_vector (file_restart, 'wetwat ' , 'patch', landpatch, wetwat , compress) ! water storage in wetland [mm] + CALL ncio_write_vector (file_restart, 'wdsrf ' , 'patch', landpatch, wdsrf , compress) ! depth of surface water [mm] + CALL ncio_write_vector (file_restart, 'rss ' , 'patch', landpatch, rss , compress) ! soil surface resistance [s/m] + + CALL ncio_write_vector (file_restart, 't_lake ' , 'lake', nl_lake, 'patch', landpatch, t_lake , compress) ! + CALL ncio_write_vector (file_restart, 'lake_icefrc', 'lake', nl_lake, 'patch', landpatch, lake_icefrac, compress) ! + CALL ncio_write_vector (file_restart, 'savedtke1 ', 'patch', landpatch, savedtke1 , compress) ! + CALL ncio_write_vector (file_restart, 'snw_rds ', 'snow', -maxsnl, 'patch', landpatch, snw_rds , compress) + CALL ncio_write_vector (file_restart, 'mss_bcpho', 'snow', -maxsnl, 'patch', landpatch, mss_bcpho, compress) + CALL ncio_write_vector (file_restart, 'mss_bcphi', 'snow', -maxsnl, 'patch', landpatch, mss_bcphi, compress) + CALL ncio_write_vector (file_restart, 'mss_ocpho', 'snow', -maxsnl, 'patch', landpatch, mss_ocpho, compress) + CALL ncio_write_vector (file_restart, 'mss_ocphi', 'snow', -maxsnl, 'patch', landpatch, mss_ocphi, compress) + CALL ncio_write_vector (file_restart, 'mss_dst1 ', 'snow', -maxsnl, 'patch', landpatch, mss_dst1 , compress) + CALL ncio_write_vector (file_restart, 'mss_dst2 ', 'snow', -maxsnl, 'patch', landpatch, mss_dst2 , compress) + CALL ncio_write_vector (file_restart, 'mss_dst3 ', 'snow', -maxsnl, 'patch', landpatch, mss_dst3 , compress) + CALL ncio_write_vector (file_restart, 'mss_dst4 ', 'snow', -maxsnl, 'patch', landpatch, mss_dst4 , compress) + CALL ncio_write_vector (file_restart, 'ssno_lyr', 'band', 2, 'rtyp', 2, 'snowp1', -maxsnl+1, 'patch', landpatch, ssno_lyr, compress) + + ! Additional va_vectorriables required by reginal model (such as WRF ) RSM) + CALL ncio_write_vector (file_restart, 'trad ', 'patch', landpatch, trad , compress) ! radiative temperature of surface [K] + CALL ncio_write_vector (file_restart, 'tref ', 'patch', landpatch, tref , compress) ! 2 m height air temperature [kelvin] + CALL ncio_write_vector (file_restart, 'qref ', 'patch', landpatch, qref , compress) ! 2 m height air specific humidity + CALL ncio_write_vector (file_restart, 'rst ', 'patch', landpatch, rst , compress) ! canopy stomatal resistance (s/m) + CALL ncio_write_vector (file_restart, 'emis ', 'patch', landpatch, emis , compress) ! averaged bulk surface emissivity + CALL ncio_write_vector (file_restart, 'z0m ', 'patch', landpatch, z0m , compress) ! effective roughness [m] + CALL ncio_write_vector (file_restart, 'zol ', 'patch', landpatch, zol , compress) ! dimensionless height (z/L) used in Monin-Obukhov theory + CALL ncio_write_vector (file_restart, 'rib ', 'patch', landpatch, rib , compress) ! bulk Richardson number in surface layer + CALL ncio_write_vector (file_restart, 'ustar', 'patch', landpatch, ustar, compress) ! u* in similarity theory [m/s] + CALL ncio_write_vector (file_restart, 'qstar', 'patch', landpatch, qstar, compress) ! q* in similarity theory [kg/kg] + CALL ncio_write_vector (file_restart, 'tstar', 'patch', landpatch, tstar, compress) ! t* in similarity theory [K] + CALL ncio_write_vector (file_restart, 'fm ', 'patch', landpatch, fm , compress) ! integral of profile FUNCTION for momentum + CALL ncio_write_vector (file_restart, 'fh ', 'patch', landpatch, fh , compress) ! integral of profile FUNCTION for heat + CALL ncio_write_vector (file_restart, 'fq ', 'patch', landpatch, fq , compress) ! integral of profile FUNCTION for moisture IF (DEF_USE_IRRIGATION) THEN - CALL Ncio_write_vector (file_restart, 'irrig_rate ' , 'patch',landpatch,irrig_rate , compress) - CALL Ncio_write_vector (file_restart, 'deficit_irrig ' , 'patch',landpatch,deficit_irrig , compress) - CALL Ncio_write_vector (file_restart, 'sum_irrig ' , 'patch',landpatch,sum_irrig , compress) - CALL Ncio_write_vector (file_restart, 'sum_irrig_count ' , 'patch',landpatch,sum_irrig_count , compress) - CALL Ncio_write_vector (file_restart, 'n_irrig_steps_left ' , 'patch',landpatch,n_irrig_steps_left , compress) - CALL Ncio_write_vector (file_restart, 'tairday ' , 'patch',landpatch,tairday , compress) - CALL Ncio_write_vector (file_restart, 'usday ' , 'patch',landpatch,usday , compress) - CALL Ncio_write_vector (file_restart, 'vsday ' , 'patch',landpatch,vsday , compress) - CALL Ncio_write_vector (file_restart, 'pairday ' , 'patch',landpatch,pairday , compress) - CALL Ncio_write_vector (file_restart, 'rnetday ' , 'patch',landpatch,rnetday , compress) - CALL Ncio_write_vector (file_restart, 'fgrndday ' , 'patch',landpatch,fgrndday , compress) - CALL Ncio_write_vector (file_restart, 'potential_evapotranspiration', 'patch',landpatch, potential_evapotranspiration, compress) - CALL Ncio_write_vector (file_restart, 'irrig_method_corn ' , 'patch',landpatch,irrig_method_corn , compress) - CALL Ncio_write_vector (file_restart, 'irrig_method_swheat ' , 'patch',landpatch,irrig_method_swheat , compress) - CALL Ncio_write_vector (file_restart, 'irrig_method_wwheat ' , 'patch',landpatch,irrig_method_wwheat , compress) - CALL Ncio_write_vector (file_restart, 'irrig_method_soybean ' , 'patch',landpatch,irrig_method_soybean , compress) - CALL Ncio_write_vector (file_restart, 'irrig_method_cotton ' , 'patch',landpatch,irrig_method_cotton , compress) - CALL Ncio_write_vector (file_restart, 'irrig_method_rice1 ' , 'patch',landpatch,irrig_method_rice1 , compress) - CALL Ncio_write_vector (file_restart, 'irrig_method_rice2 ' , 'patch',landpatch,irrig_method_rice2 , compress) - CALL Ncio_write_vector (file_restart, 'irrig_method_sugarcane' , 'patch',landpatch,irrig_method_sugarcane, compress) + CALL Ncio_write_vector (file_restart, 'irrig_rate ' , 'patch',landpatch,irrig_rate , compress) + CALL Ncio_write_vector (file_restart, 'deficit_irrig ' , 'patch',landpatch,deficit_irrig , compress) + CALL Ncio_write_vector (file_restart, 'sum_irrig ' , 'patch',landpatch,sum_irrig , compress) + CALL Ncio_write_vector (file_restart, 'sum_irrig_count ' , 'patch',landpatch,sum_irrig_count , compress) + CALL Ncio_write_vector (file_restart, 'n_irrig_steps_left ' , 'patch',landpatch,n_irrig_steps_left , compress) + CALL Ncio_write_vector (file_restart, 'tairday ' , 'patch',landpatch,tairday , compress) + CALL Ncio_write_vector (file_restart, 'usday ' , 'patch',landpatch,usday , compress) + CALL Ncio_write_vector (file_restart, 'vsday ' , 'patch',landpatch,vsday , compress) + CALL Ncio_write_vector (file_restart, 'pairday ' , 'patch',landpatch,pairday , compress) + CALL Ncio_write_vector (file_restart, 'rnetday ' , 'patch',landpatch,rnetday , compress) + CALL Ncio_write_vector (file_restart, 'fgrndday ' , 'patch',landpatch,fgrndday , compress) + CALL Ncio_write_vector (file_restart, 'potential_evapotranspiration', 'patch',landpatch, potential_evapotranspiration, compress) + CALL Ncio_write_vector (file_restart, 'irrig_method_corn ' , 'patch',landpatch,irrig_method_corn , compress) + CALL Ncio_write_vector (file_restart, 'irrig_method_swheat ' , 'patch',landpatch,irrig_method_swheat , compress) + CALL Ncio_write_vector (file_restart, 'irrig_method_wwheat ' , 'patch',landpatch,irrig_method_wwheat , compress) + CALL Ncio_write_vector (file_restart, 'irrig_method_soybean ' , 'patch',landpatch,irrig_method_soybean , compress) + CALL Ncio_write_vector (file_restart, 'irrig_method_cotton ' , 'patch',landpatch,irrig_method_cotton , compress) + CALL Ncio_write_vector (file_restart, 'irrig_method_rice1 ' , 'patch',landpatch,irrig_method_rice1 , compress) + CALL Ncio_write_vector (file_restart, 'irrig_method_rice2 ' , 'patch',landpatch,irrig_method_rice2 , compress) + CALL Ncio_write_vector (file_restart, 'irrig_method_sugarcane' , 'patch',landpatch,irrig_method_sugarcane, compress) ENDIF #if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) - file_restart = trim(dir_restart)// '/'//trim(cdate)//'/' // trim(site) //'_restart_pft_'//trim(cdate)//'_lc'//trim(cyear)//'.nc' - CALL WRITE_PFTimeVariables (file_restart) + file_restart = trim(dir_restart)// '/'//trim(cdate)//'/' // trim(site) //'_restart_pft_'//trim(cdate)//'_lc'//trim(cyear)//'.nc' + CALL WRITE_PFTimeVariables (file_restart) #endif #if (defined BGC) - file_restart = trim(dir_restart)// '/'//trim(cdate)//'/' // trim(site) //'_restart_bgc_'//trim(cdate)//'_lc'//trim(cyear)//'.nc' - CALL WRITE_BGCTimeVariables (file_restart) + file_restart = trim(dir_restart)// '/'//trim(cdate)//'/' // trim(site) //'_restart_bgc_'//trim(cdate)//'_lc'//trim(cyear)//'.nc' + CALL WRITE_BGCTimeVariables (file_restart) #endif #if (defined LATERAL_FLOW) - file_restart = trim(dir_restart)// '/'//trim(cdate)//'/' // trim(site) //'_restart_basin_'//trim(cdate)//'_lc'//trim(cyear)//'.nc' - CALL WRITE_HydroTimeVariables (file_restart) + file_restart = trim(dir_restart)// '/'//trim(cdate)//'/' // trim(site) //'_restart_basin_'//trim(cdate)//'_lc'//trim(cyear)//'.nc' + CALL WRITE_HydroTimeVariables (file_restart) #endif #if (defined URBAN_MODEL) - file_restart = trim(dir_restart)// '/'//trim(cdate)//'/' // trim(site) //'_restart_urban_'//trim(cdate)//'_lc'//trim(cyear)//'.nc' - CALL WRITE_UrbanTimeVariables (file_restart) + file_restart = trim(dir_restart)// '/'//trim(cdate)//'/' // trim(site) //'_restart_urban_'//trim(cdate)//'_lc'//trim(cyear)//'.nc' + CALL WRITE_UrbanTimeVariables (file_restart) #endif - END SUBROUTINE WRITE_TimeVariables + END SUBROUTINE WRITE_TimeVariables - !--------------------------------------- - SUBROUTINE READ_TimeVariables (idate, lc_year, site, dir_restart) + !--------------------------------------- + SUBROUTINE READ_TimeVariables (idate, lc_year, site, dir_restart) - !======================================================================= - ! Original version: Yongjiu Dai, September 15, 1999, 03/2014 - !======================================================================= + !======================================================================= + ! Original version: Yongjiu Dai, September 15, 1999, 03/2014 + !======================================================================= - USE MOD_Namelist - USE MOD_SPMD_Task - USE MOD_NetCDFVector + USE MOD_Namelist + USE MOD_SPMD_Task + USE MOD_NetCDFVector #ifdef RangeCheck - USE MOD_RangeCheck + USE MOD_RangeCheck #endif - USE MOD_LandPatch - USE MOD_Vars_Global + USE MOD_LandPatch + USE MOD_Vars_Global - IMPLICIT NONE + IMPLICIT NONE - integer, intent(in) :: idate(3) - integer, intent(in) :: lc_year !year of land cover type data - character(LEN=*), intent(in) :: site - character(LEN=*), intent(in) :: dir_restart + integer, intent(in) :: idate(3) + integer, intent(in) :: lc_year !year of land cover type data + character(LEN=*), intent(in) :: site + character(LEN=*), intent(in) :: dir_restart - ! Local variables - character(LEN=256) :: file_restart - character(len=14) :: cdate, cyear + ! Local variables + character(LEN=256) :: file_restart + character(len=14) :: cdate, cyear #ifdef USEMPI - CALL mpi_barrier (p_comm_glb, p_err) + CALL mpi_barrier (p_comm_glb, p_err) #endif - IF (p_is_master) THEN - write(*,'(/,A26)') 'Loading Time Variables ...' - ENDIF + IF (p_is_master) THEN + write(*,'(/,A26)') 'Loading Time Variables ...' + ENDIF - ! land cover type year - write(cyear,'(i4.4)') lc_year + ! land cover type year + write(cyear,'(i4.4)') lc_year - write(cdate,'(i4.4,"-",i3.3,"-",i5.5)') idate(1), idate(2), idate(3) - file_restart = trim(dir_restart)// '/'//trim(cdate)//'/' // trim(site) //'_restart_'//trim(cdate)//'_lc'//trim(cyear)//'.nc' + write(cdate,'(i4.4,"-",i3.3,"-",i5.5)') idate(1), idate(2), idate(3) + file_restart = trim(dir_restart)// '/'//trim(cdate)//'/' // trim(site) //'_restart_'//trim(cdate)//'_lc'//trim(cyear)//'.nc' - ! Time-varying state variables which reaquired by restart run - CALL ncio_read_vector (file_restart, 'z_sno ' , -maxsnl, landpatch, z_sno ) ! node depth [m] - CALL ncio_read_vector (file_restart, 'dz_sno ' , -maxsnl, landpatch, dz_sno) ! interface depth [m] - CALL ncio_read_vector (file_restart, 't_soisno' , nl_soil-maxsnl, landpatch, t_soisno ) ! soil temperature [K] - CALL ncio_read_vector (file_restart, 'wliq_soisno', nl_soil-maxsnl, landpatch, wliq_soisno) ! liquid water in layers [kg/m2] - CALL ncio_read_vector (file_restart, 'wice_soisno', nl_soil-maxsnl, landpatch, wice_soisno) ! ice lens in layers [kg/m2] - CALL ncio_read_vector (file_restart, 'smp', nl_soil, landpatch, smp ) ! soil matrix potential [mm] - CALL ncio_read_vector (file_restart, 'hk', nl_soil, landpatch, hk ) ! hydraulic conductivity [mm h2o/s] + ! Time-varying state variables which reaquired by restart run + CALL ncio_read_vector (file_restart, 'z_sno ' , -maxsnl, landpatch, z_sno ) ! node depth [m] + CALL ncio_read_vector (file_restart, 'dz_sno ' , -maxsnl, landpatch, dz_sno) ! interface depth [m] + CALL ncio_read_vector (file_restart, 't_soisno' , nl_soil-maxsnl, landpatch, t_soisno ) ! soil temperature [K] + CALL ncio_read_vector (file_restart, 'wliq_soisno', nl_soil-maxsnl, landpatch, wliq_soisno) ! liquid water in layers [kg/m2] + CALL ncio_read_vector (file_restart, 'wice_soisno', nl_soil-maxsnl, landpatch, wice_soisno) ! ice lens in layers [kg/m2] + CALL ncio_read_vector (file_restart, 'smp', nl_soil, landpatch, smp ) ! soil matrix potential [mm] + CALL ncio_read_vector (file_restart, 'hk', nl_soil, landpatch, hk ) ! hydraulic conductivity [mm h2o/s] IF(DEF_USE_PLANTHYDRAULICS)THEN - CALL ncio_read_vector (file_restart, 'vegwp', nvegwcs, landpatch, vegwp ) ! vegetation water potential [mm] - CALL ncio_read_vector (file_restart, 'gs0sun ', landpatch, gs0sun ) ! working copy of sunlit stomata conductance - CALL ncio_read_vector (file_restart, 'gs0sha ', landpatch, gs0sha ) ! working copy of shalit stomata conductance + CALL ncio_read_vector (file_restart, 'vegwp', nvegwcs, landpatch, vegwp ) ! vegetation water potential [mm] + CALL ncio_read_vector (file_restart, 'gs0sun ', landpatch, gs0sun ) ! working copy of sunlit stomata conductance + CALL ncio_read_vector (file_restart, 'gs0sha ', landpatch, gs0sha ) ! working copy of shalit stomata conductance ENDIF IF(DEF_USE_OZONESTRESS)THEN - CALL ncio_read_vector (file_restart, 'lai_old ', landpatch, lai_old ) - CALL ncio_read_vector (file_restart, 'o3uptakesun', landpatch, o3uptakesun) - CALL ncio_read_vector (file_restart, 'o3uptakesha', landpatch, o3uptakesha) + CALL ncio_read_vector (file_restart, 'lai_old ', landpatch, lai_old ) + CALL ncio_read_vector (file_restart, 'o3uptakesun', landpatch, o3uptakesun) + CALL ncio_read_vector (file_restart, 'o3uptakesha', landpatch, o3uptakesha) ENDIF - CALL ncio_read_vector (file_restart, 't_grnd ' , landpatch, t_grnd ) ! ground surface temperature [K] - CALL ncio_read_vector (file_restart, 'tleaf ' , landpatch, tleaf ) ! leaf temperature [K] - CALL ncio_read_vector (file_restart, 'ldew ' , landpatch, ldew ) ! depth of water on foliage [mm] - CALL ncio_read_vector (file_restart, 'ldew_rain' , landpatch, ldew_rain ) ! depth of rain on foliage [mm] - CALL ncio_read_vector (file_restart, 'ldew_snow' , landpatch, ldew_snow ) ! depth of snow on foliage [mm] - CALL ncio_read_vector (file_restart, 'sag ' , landpatch, sag ) ! non dimensional snow age [-] - CALL ncio_read_vector (file_restart, 'scv ' , landpatch, scv ) ! snow cover, water equivalent [mm] - CALL ncio_read_vector (file_restart, 'snowdp ' , landpatch, snowdp ) ! snow depth [meter] - CALL ncio_read_vector (file_restart, 'fveg ' , landpatch, fveg ) ! fraction of vegetation cover - CALL ncio_read_vector (file_restart, 'fsno ' , landpatch, fsno ) ! fraction of snow cover on ground - CALL ncio_read_vector (file_restart, 'sigf ' , landpatch, sigf ) ! fraction of veg cover, excluding snow-covered veg [-] - CALL ncio_read_vector (file_restart, 'green ' , landpatch, green ) ! leaf greenness - CALL ncio_read_vector (file_restart, 'lai ' , landpatch, lai ) ! leaf area index - CALL ncio_read_vector (file_restart, 'tlai ' , landpatch, tlai ) ! leaf area index - CALL ncio_read_vector (file_restart, 'sai ' , landpatch, sai ) ! stem area index - CALL ncio_read_vector (file_restart, 'tsai ' , landpatch, tsai ) ! stem area index - CALL ncio_read_vector (file_restart, 'coszen ' , landpatch, coszen ) ! cosine of solar zenith angle - CALL ncio_read_vector (file_restart, 'alb ' , 2, 2, landpatch, alb ) ! averaged albedo [-] - CALL ncio_read_vector (file_restart, 'ssun ' , 2, 2, landpatch, ssun ) ! sunlit canopy absorption for solar radiation (0-1) - CALL ncio_read_vector (file_restart, 'ssha ' , 2, 2, landpatch, ssha ) ! shaded canopy absorption for solar radiation (0-1) - CALL ncio_read_vector (file_restart, 'ssoi ' , 2, 2, landpatch, ssoi ) ! soil absorption for solar radiation (0-1) - CALL ncio_read_vector (file_restart, 'ssno ' , 2, 2, landpatch, ssno ) ! snow absorption for solar radiation (0-1) - CALL ncio_read_vector (file_restart, 'thermk ' , landpatch, thermk ) ! canopy gap fraction for tir radiation - CALL ncio_read_vector (file_restart, 'extkb ' , landpatch, extkb ) ! (k, g(mu)/mu) direct solar extinction coefficient - CALL ncio_read_vector (file_restart, 'extkd ' , landpatch, extkd ) ! diffuse and scattered diffuse PAR extinction coefficient - CALL ncio_read_vector (file_restart, 'zwt ' , landpatch, zwt ) ! the depth to water table [m] - CALL ncio_read_vector (file_restart, 'wa ' , landpatch, wa ) ! water storage in aquifer [mm] - CALL ncio_read_vector (file_restart, 'wetwat ' , landpatch, wetwat ) ! water storage in wetland [mm] - CALL ncio_read_vector (file_restart, 'wdsrf ' , landpatch, wdsrf ) ! depth of surface water [mm] - CALL ncio_read_vector (file_restart, 'rss ' , landpatch, rss ) ! soil surface resistance [s/m] - - CALL ncio_read_vector (file_restart, 't_lake ' , nl_lake, landpatch, t_lake ) ! - CALL ncio_read_vector (file_restart, 'lake_icefrc', nl_lake, landpatch, lake_icefrac) ! - CALL ncio_read_vector (file_restart, 'savedtke1', landpatch, savedtke1) ! - - CALL ncio_read_vector (file_restart, 'snw_rds ', -maxsnl, landpatch, snw_rds ) ! - CALL ncio_read_vector (file_restart, 'mss_bcpho', -maxsnl, landpatch, mss_bcpho) ! - CALL ncio_read_vector (file_restart, 'mss_bcphi', -maxsnl, landpatch, mss_bcphi) ! - CALL ncio_read_vector (file_restart, 'mss_ocpho', -maxsnl, landpatch, mss_ocpho) ! - CALL ncio_read_vector (file_restart, 'mss_ocphi', -maxsnl, landpatch, mss_ocphi) ! - CALL ncio_read_vector (file_restart, 'mss_dst1 ', -maxsnl, landpatch, mss_dst1 ) ! - CALL ncio_read_vector (file_restart, 'mss_dst2 ', -maxsnl, landpatch, mss_dst2 ) ! - CALL ncio_read_vector (file_restart, 'mss_dst3 ', -maxsnl, landpatch, mss_dst3 ) ! - CALL ncio_read_vector (file_restart, 'mss_dst4 ', -maxsnl, landpatch, mss_dst4 ) ! - CALL ncio_read_vector (file_restart, 'ssno_lyr', 2,2, -maxsnl+1, landpatch, ssno_lyr) ! - - ! Additional variables required by reginal model (such as WRF ) RSM) - CALL ncio_read_vector (file_restart, 'trad ', landpatch, trad ) ! radiative temperature of surface [K] - CALL ncio_read_vector (file_restart, 'tref ', landpatch, tref ) ! 2 m height air temperature [kelvin] - CALL ncio_read_vector (file_restart, 'qref ', landpatch, qref ) ! 2 m height air specific humidity - CALL ncio_read_vector (file_restart, 'rst ', landpatch, rst ) ! canopy stomatal resistance (s/m) - CALL ncio_read_vector (file_restart, 'emis ', landpatch, emis ) ! averaged bulk surface emissivity - CALL ncio_read_vector (file_restart, 'z0m ', landpatch, z0m ) ! effective roughness [m] - CALL ncio_read_vector (file_restart, 'zol ', landpatch, zol ) ! dimensionless height (z/L) used in Monin-Obukhov theory - CALL ncio_read_vector (file_restart, 'rib ', landpatch, rib ) ! bulk Richardson number in surface layer - CALL ncio_read_vector (file_restart, 'ustar', landpatch, ustar) ! u* in similarity theory [m/s] - CALL ncio_read_vector (file_restart, 'qstar', landpatch, qstar) ! q* in similarity theory [kg/kg] - CALL ncio_read_vector (file_restart, 'tstar', landpatch, tstar) ! t* in similarity theory [K] - CALL ncio_read_vector (file_restart, 'fm ', landpatch, fm ) ! integral of profile function for momentum - CALL ncio_read_vector (file_restart, 'fh ', landpatch, fh ) ! integral of profile function for heat - CALL ncio_read_vector (file_restart, 'fq ', landpatch, fq ) ! integral of profile function for moisture + CALL ncio_read_vector (file_restart, 't_grnd ' , landpatch, t_grnd ) ! ground surface temperature [K] + CALL ncio_read_vector (file_restart, 'tleaf ' , landpatch, tleaf ) ! leaf temperature [K] + CALL ncio_read_vector (file_restart, 'ldew ' , landpatch, ldew ) ! depth of water on foliage [mm] + CALL ncio_read_vector (file_restart, 'ldew_rain' , landpatch, ldew_rain ) ! depth of rain on foliage [mm] + CALL ncio_read_vector (file_restart, 'ldew_snow' , landpatch, ldew_snow ) ! depth of snow on foliage [mm] + CALL ncio_read_vector (file_restart, 'sag ' , landpatch, sag ) ! non dimensional snow age [-] + CALL ncio_read_vector (file_restart, 'scv ' , landpatch, scv ) ! snow cover, water equivalent [mm] + CALL ncio_read_vector (file_restart, 'snowdp ' , landpatch, snowdp ) ! snow depth [meter] + CALL ncio_read_vector (file_restart, 'fveg ' , landpatch, fveg ) ! fraction of vegetation cover + CALL ncio_read_vector (file_restart, 'fsno ' , landpatch, fsno ) ! fraction of snow cover on ground + CALL ncio_read_vector (file_restart, 'sigf ' , landpatch, sigf ) ! fraction of veg cover, excluding snow-covered veg [-] + CALL ncio_read_vector (file_restart, 'green ' , landpatch, green ) ! leaf greenness + CALL ncio_read_vector (file_restart, 'lai ' , landpatch, lai ) ! leaf area index + CALL ncio_read_vector (file_restart, 'tlai ' , landpatch, tlai ) ! leaf area index + CALL ncio_read_vector (file_restart, 'sai ' , landpatch, sai ) ! stem area index + CALL ncio_read_vector (file_restart, 'tsai ' , landpatch, tsai ) ! stem area index + CALL ncio_read_vector (file_restart, 'coszen ' , landpatch, coszen ) ! cosine of solar zenith angle + CALL ncio_read_vector (file_restart, 'alb ' , 2, 2, landpatch, alb ) ! averaged albedo [-] + CALL ncio_read_vector (file_restart, 'ssun ' , 2, 2, landpatch, ssun ) ! sunlit canopy absorption for solar radiation (0-1) + CALL ncio_read_vector (file_restart, 'ssha ' , 2, 2, landpatch, ssha ) ! shaded canopy absorption for solar radiation (0-1) + CALL ncio_read_vector (file_restart, 'ssoi ' , 2, 2, landpatch, ssoi ) ! soil absorption for solar radiation (0-1) + CALL ncio_read_vector (file_restart, 'ssno ' , 2, 2, landpatch, ssno ) ! snow absorption for solar radiation (0-1) + CALL ncio_read_vector (file_restart, 'thermk ' , landpatch, thermk ) ! canopy gap fraction for tir radiation + CALL ncio_read_vector (file_restart, 'extkb ' , landpatch, extkb ) ! (k, g(mu)/mu) direct solar extinction coefficient + CALL ncio_read_vector (file_restart, 'extkd ' , landpatch, extkd ) ! diffuse and scattered diffuse PAR extinction coefficient + CALL ncio_read_vector (file_restart, 'zwt ' , landpatch, zwt ) ! the depth to water table [m] + CALL ncio_read_vector (file_restart, 'wa ' , landpatch, wa ) ! water storage in aquifer [mm] + CALL ncio_read_vector (file_restart, 'wetwat ' , landpatch, wetwat ) ! water storage in wetland [mm] + CALL ncio_read_vector (file_restart, 'wdsrf ' , landpatch, wdsrf ) ! depth of surface water [mm] + CALL ncio_read_vector (file_restart, 'rss ' , landpatch, rss ) ! soil surface resistance [s/m] + + CALL ncio_read_vector (file_restart, 't_lake ' , nl_lake, landpatch, t_lake ) ! + CALL ncio_read_vector (file_restart, 'lake_icefrc', nl_lake, landpatch, lake_icefrac) ! + CALL ncio_read_vector (file_restart, 'savedtke1', landpatch, savedtke1) ! + + CALL ncio_read_vector (file_restart, 'snw_rds ', -maxsnl, landpatch, snw_rds ) ! + CALL ncio_read_vector (file_restart, 'mss_bcpho', -maxsnl, landpatch, mss_bcpho) ! + CALL ncio_read_vector (file_restart, 'mss_bcphi', -maxsnl, landpatch, mss_bcphi) ! + CALL ncio_read_vector (file_restart, 'mss_ocpho', -maxsnl, landpatch, mss_ocpho) ! + CALL ncio_read_vector (file_restart, 'mss_ocphi', -maxsnl, landpatch, mss_ocphi) ! + CALL ncio_read_vector (file_restart, 'mss_dst1 ', -maxsnl, landpatch, mss_dst1 ) ! + CALL ncio_read_vector (file_restart, 'mss_dst2 ', -maxsnl, landpatch, mss_dst2 ) ! + CALL ncio_read_vector (file_restart, 'mss_dst3 ', -maxsnl, landpatch, mss_dst3 ) ! + CALL ncio_read_vector (file_restart, 'mss_dst4 ', -maxsnl, landpatch, mss_dst4 ) ! + CALL ncio_read_vector (file_restart, 'ssno_lyr', 2,2, -maxsnl+1, landpatch, ssno_lyr) ! + + ! Additional variables required by reginal model (such as WRF ) RSM) + CALL ncio_read_vector (file_restart, 'trad ', landpatch, trad ) ! radiative temperature of surface [K] + CALL ncio_read_vector (file_restart, 'tref ', landpatch, tref ) ! 2 m height air temperature [kelvin] + CALL ncio_read_vector (file_restart, 'qref ', landpatch, qref ) ! 2 m height air specific humidity + CALL ncio_read_vector (file_restart, 'rst ', landpatch, rst ) ! canopy stomatal resistance (s/m) + CALL ncio_read_vector (file_restart, 'emis ', landpatch, emis ) ! averaged bulk surface emissivity + CALL ncio_read_vector (file_restart, 'z0m ', landpatch, z0m ) ! effective roughness [m] + CALL ncio_read_vector (file_restart, 'zol ', landpatch, zol ) ! dimensionless height (z/L) used in Monin-Obukhov theory + CALL ncio_read_vector (file_restart, 'rib ', landpatch, rib ) ! bulk Richardson number in surface layer + CALL ncio_read_vector (file_restart, 'ustar', landpatch, ustar) ! u* in similarity theory [m/s] + CALL ncio_read_vector (file_restart, 'qstar', landpatch, qstar) ! q* in similarity theory [kg/kg] + CALL ncio_read_vector (file_restart, 'tstar', landpatch, tstar) ! t* in similarity theory [K] + CALL ncio_read_vector (file_restart, 'fm ', landpatch, fm ) ! integral of profile FUNCTION for momentum + CALL ncio_read_vector (file_restart, 'fh ', landpatch, fh ) ! integral of profile FUNCTION for heat + CALL ncio_read_vector (file_restart, 'fq ', landpatch, fq ) ! integral of profile FUNCTION for moisture IF (DEF_USE_IRRIGATION) THEN - CALL ncio_read_vector (file_restart, 'irrig_rate ' , landpatch, irrig_rate ) - CALL ncio_read_vector (file_restart, 'deficit_irrig ' , landpatch, deficit_irrig ) - CALL ncio_read_vector (file_restart, 'sum_irrig ' , landpatch, sum_irrig ) - CALL ncio_read_vector (file_restart, 'sum_irrig_count ' , landpatch, sum_irrig_count ) - CALL ncio_read_vector (file_restart, 'n_irrig_steps_left ' , landpatch, n_irrig_steps_left ) - CALL ncio_read_vector (file_restart, 'tairday ' , landpatch, tairday ) - CALL ncio_read_vector (file_restart, 'usday ' , landpatch, usday ) - CALL ncio_read_vector (file_restart, 'vsday ' , landpatch, vsday ) - CALL ncio_read_vector (file_restart, 'pairday ' , landpatch, pairday ) - CALL ncio_read_vector (file_restart, 'rnetday ' , landpatch, rnetday ) - CALL ncio_read_vector (file_restart, 'fgrndday ' , landpatch, fgrndday ) - CALL ncio_read_vector (file_restart, 'potential_evapotranspiration' , landpatch, potential_evapotranspiration) - CALL ncio_read_vector (file_restart, 'irrig_method_corn ' , landpatch, irrig_method_corn ) - CALL ncio_read_vector (file_restart, 'irrig_method_swheat ' , landpatch, irrig_method_swheat ) - CALL ncio_read_vector (file_restart, 'irrig_method_wwheat ' , landpatch, irrig_method_wwheat ) - CALL ncio_read_vector (file_restart, 'irrig_method_soybean ' , landpatch, irrig_method_soybean ) - CALL ncio_read_vector (file_restart, 'irrig_method_cotton ' , landpatch, irrig_method_cotton ) - CALL ncio_read_vector (file_restart, 'irrig_method_rice1 ' , landpatch, irrig_method_rice1 ) - CALL ncio_read_vector (file_restart, 'irrig_method_rice2 ' , landpatch, irrig_method_rice2 ) - CALL ncio_read_vector (file_restart, 'irrig_method_sugarcane' , landpatch, irrig_method_sugarcane) + CALL ncio_read_vector (file_restart, 'irrig_rate ' , landpatch, irrig_rate ) + CALL ncio_read_vector (file_restart, 'deficit_irrig ' , landpatch, deficit_irrig ) + CALL ncio_read_vector (file_restart, 'sum_irrig ' , landpatch, sum_irrig ) + CALL ncio_read_vector (file_restart, 'sum_irrig_count ' , landpatch, sum_irrig_count ) + CALL ncio_read_vector (file_restart, 'n_irrig_steps_left ' , landpatch, n_irrig_steps_left ) + CALL ncio_read_vector (file_restart, 'tairday ' , landpatch, tairday ) + CALL ncio_read_vector (file_restart, 'usday ' , landpatch, usday ) + CALL ncio_read_vector (file_restart, 'vsday ' , landpatch, vsday ) + CALL ncio_read_vector (file_restart, 'pairday ' , landpatch, pairday ) + CALL ncio_read_vector (file_restart, 'rnetday ' , landpatch, rnetday ) + CALL ncio_read_vector (file_restart, 'fgrndday ' , landpatch, fgrndday ) + CALL ncio_read_vector (file_restart, 'potential_evapotranspiration' , landpatch, potential_evapotranspiration) + CALL ncio_read_vector (file_restart, 'irrig_method_corn ' , landpatch, irrig_method_corn ) + CALL ncio_read_vector (file_restart, 'irrig_method_swheat ' , landpatch, irrig_method_swheat ) + CALL ncio_read_vector (file_restart, 'irrig_method_wwheat ' , landpatch, irrig_method_wwheat ) + CALL ncio_read_vector (file_restart, 'irrig_method_soybean ' , landpatch, irrig_method_soybean ) + CALL ncio_read_vector (file_restart, 'irrig_method_cotton ' , landpatch, irrig_method_cotton ) + CALL ncio_read_vector (file_restart, 'irrig_method_rice1 ' , landpatch, irrig_method_rice1 ) + CALL ncio_read_vector (file_restart, 'irrig_method_rice2 ' , landpatch, irrig_method_rice2 ) + CALL ncio_read_vector (file_restart, 'irrig_method_sugarcane' , landpatch, irrig_method_sugarcane) ENDIF #if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) - file_restart = trim(dir_restart)// '/'//trim(cdate)//'/' // trim(site) //'_restart_pft_'//trim(cdate)//'_lc'//trim(cyear)//'.nc' - CALL READ_PFTimeVariables (file_restart) + file_restart = trim(dir_restart)// '/'//trim(cdate)//'/' // trim(site) //'_restart_pft_'//trim(cdate)//'_lc'//trim(cyear)//'.nc' + CALL READ_PFTimeVariables (file_restart) #endif #if (defined BGC) - file_restart = trim(dir_restart)// '/'//trim(cdate)//'/' // trim(site) //'_restart_bgc_'//trim(cdate)//'_lc'//trim(cyear)//'.nc' - CALL READ_BGCTimeVariables (file_restart) + file_restart = trim(dir_restart)// '/'//trim(cdate)//'/' // trim(site) //'_restart_bgc_'//trim(cdate)//'_lc'//trim(cyear)//'.nc' + CALL READ_BGCTimeVariables (file_restart) #endif #if (defined LATERAL_FLOW) - file_restart = trim(dir_restart)// '/'//trim(cdate)//'/' // trim(site) //'_restart_basin_'//trim(cdate)//'_lc'//trim(cyear)//'.nc' - CALL READ_HydroTimeVariables (file_restart) + file_restart = trim(dir_restart)// '/'//trim(cdate)//'/' // trim(site) //'_restart_basin_'//trim(cdate)//'_lc'//trim(cyear)//'.nc' + CALL READ_HydroTimeVariables (file_restart) #endif #if (defined URBAN_MODEL) - file_restart = trim(dir_restart)// '/'//trim(cdate)//'/' // trim(site) //'_restart_urban_'//trim(cdate)//'_lc'//trim(cyear)//'.nc' - CALL READ_UrbanTimeVariables (file_restart) + file_restart = trim(dir_restart)// '/'//trim(cdate)//'/' // trim(site) //'_restart_urban_'//trim(cdate)//'_lc'//trim(cyear)//'.nc' + CALL READ_UrbanTimeVariables (file_restart) #endif #ifdef RangeCheck - CALL check_TimeVariables + CALL check_TimeVariables #endif - IF (p_is_master) THEN - write(*,*) 'Loading Time Variables done.' - ENDIF + IF (p_is_master) THEN + write(*,*) 'Loading Time Variables done.' + ENDIF - END SUBROUTINE READ_TimeVariables + END SUBROUTINE READ_TimeVariables !--------------------------------------- #ifdef RangeCheck - SUBROUTINE check_TimeVariables () + SUBROUTINE check_TimeVariables () - USE MOD_SPMD_Task - USE MOD_RangeCheck - USE MOD_Namelist, only: DEF_USE_PLANTHYDRAULICS, DEF_USE_OZONESTRESS, DEF_USE_IRRIGATION, & - DEF_USE_SNICAR + USE MOD_SPMD_Task + USE MOD_RangeCheck + USE MOD_Namelist, only: DEF_USE_PLANTHYDRAULICS, DEF_USE_OZONESTRESS, DEF_USE_IRRIGATION, & + DEF_USE_SNICAR - IMPLICIT NONE + IMPLICIT NONE #ifdef USEMPI - CALL mpi_barrier (p_comm_glb, p_err) + CALL mpi_barrier (p_comm_glb, p_err) #endif - IF (p_is_master) THEN - write(*,'(/,A27)') 'Checking Time Variables ...' - ENDIF - - CALL check_vector_data ('t_grnd [K] ', t_grnd ) ! ground surface temperature [K] - CALL check_vector_data ('tleaf [K] ', tleaf ) ! leaf temperature [K] - CALL check_vector_data ('ldew [mm] ', ldew ) ! depth of water on foliage [mm] - CALL check_vector_data ('ldew_rain [mm] ', ldew_rain ) ! depth of rain on foliage [mm] - CALL check_vector_data ('ldew_snow [mm] ', ldew_snow ) ! depth of snow on foliage [mm] - CALL check_vector_data ('sag [-] ', sag ) ! non dimensional snow age [-] - CALL check_vector_data ('scv [mm] ', scv ) ! snow cover, water equivalent [mm] - CALL check_vector_data ('snowdp [m] ', snowdp ) ! snow depth [meter] - CALL check_vector_data ('fveg [-] ', fveg ) ! fraction of vegetation cover - CALL check_vector_data ('fsno [-] ', fsno ) ! fraction of snow cover on ground - CALL check_vector_data ('sigf [-] ', sigf ) ! fraction of veg cover, excluding snow-covered veg [-] - CALL check_vector_data ('green [-] ', green ) ! leaf greenness - CALL check_vector_data ('lai [-] ', lai ) ! leaf area index - CALL check_vector_data ('tlai [-] ', tlai ) ! leaf area index - CALL check_vector_data ('sai [-] ', sai ) ! stem area index - CALL check_vector_data ('tsai [-] ', tsai ) ! stem area index - CALL check_vector_data ('coszen [-] ', coszen ) ! cosine of solar zenith angle - CALL check_vector_data ('alb [-] ', alb ) ! averaged albedo [-] - CALL check_vector_data ('ssun [-] ', ssun ) ! sunlit canopy absorption for solar radiation (0-1) - CALL check_vector_data ('ssha [-] ', ssha ) ! shaded canopy absorption for solar radiation (0-1) - CALL check_vector_data ('ssoi [-] ', ssoi ) ! soil absorption for solar radiation (0-1) - CALL check_vector_data ('ssno [-] ', ssno ) ! snow absorption for solar radiation (0-1) - CALL check_vector_data ('thermk [-] ', thermk ) ! canopy gap fraction for tir radiation - CALL check_vector_data ('extkb [-] ', extkb ) ! (k, g(mu)/mu) direct solar extinction coefficient - CALL check_vector_data ('extkd [-] ', extkd ) ! diffuse and scattered diffuse PAR extinction coefficient - CALL check_vector_data ('zwt [m] ', zwt ) ! the depth to water table [m] - CALL check_vector_data ('wa [mm] ', wa ) ! water storage in aquifer [mm] - CALL check_vector_data ('wetwat [mm] ', wetwat ) ! water storage in wetland [mm] - CALL check_vector_data ('wdsrf [mm] ', wdsrf ) ! depth of surface water [mm] - CALL check_vector_data ('rss [s/m] ', rss ) ! soil surface resistance [s/m] - CALL check_vector_data ('t_lake [K] ', t_lake )! - CALL check_vector_data ('lake_icefrc [-] ', lake_icefrac)! - CALL check_vector_data ('savedtke1 [W/m K]', savedtke1 )! - CALL check_vector_data ('z_sno [m] ', z_sno ) ! node depth [m] - CALL check_vector_data ('dz_sno [m] ', dz_sno) ! interface depth [m] - CALL check_vector_data ('t_soisno [K] ', t_soisno ) ! soil temperature [K] - CALL check_vector_data ('wliq_soisno [kg/m2]', wliq_soisno) ! liquid water in layers [kg/m2] - CALL check_vector_data ('wice_soisno [kg/m2]', wice_soisno) ! ice lens in layers [kg/m2] - CALL check_vector_data ('smp [mm] ', smp ) ! soil matrix potential [mm] - CALL check_vector_data ('hk [mm/s] ', hk ) ! hydraulic conductivity [mm h2o/s] + IF (p_is_master) THEN + write(*,'(/,A27)') 'Checking Time Variables ...' + ENDIF + + CALL check_vector_data ('t_grnd [K] ', t_grnd ) ! ground surface temperature [K] + CALL check_vector_data ('tleaf [K] ', tleaf ) ! leaf temperature [K] + CALL check_vector_data ('ldew [mm] ', ldew ) ! depth of water on foliage [mm] + CALL check_vector_data ('ldew_rain [mm] ', ldew_rain ) ! depth of rain on foliage [mm] + CALL check_vector_data ('ldew_snow [mm] ', ldew_snow ) ! depth of snow on foliage [mm] + CALL check_vector_data ('sag [-] ', sag ) ! non dimensional snow age [-] + CALL check_vector_data ('scv [mm] ', scv ) ! snow cover, water equivalent [mm] + CALL check_vector_data ('snowdp [m] ', snowdp ) ! snow depth [meter] + CALL check_vector_data ('fveg [-] ', fveg ) ! fraction of vegetation cover + CALL check_vector_data ('fsno [-] ', fsno ) ! fraction of snow cover on ground + CALL check_vector_data ('sigf [-] ', sigf ) ! fraction of veg cover, excluding snow-covered veg [-] + CALL check_vector_data ('green [-] ', green ) ! leaf greenness + CALL check_vector_data ('lai [-] ', lai ) ! leaf area index + CALL check_vector_data ('tlai [-] ', tlai ) ! leaf area index + CALL check_vector_data ('sai [-] ', sai ) ! stem area index + CALL check_vector_data ('tsai [-] ', tsai ) ! stem area index + CALL check_vector_data ('coszen [-] ', coszen ) ! cosine of solar zenith angle + CALL check_vector_data ('alb [-] ', alb ) ! averaged albedo [-] + CALL check_vector_data ('ssun [-] ', ssun ) ! sunlit canopy absorption for solar radiation (0-1) + CALL check_vector_data ('ssha [-] ', ssha ) ! shaded canopy absorption for solar radiation (0-1) + CALL check_vector_data ('ssoi [-] ', ssoi ) ! soil absorption for solar radiation (0-1) + CALL check_vector_data ('ssno [-] ', ssno ) ! snow absorption for solar radiation (0-1) + CALL check_vector_data ('thermk [-] ', thermk ) ! canopy gap fraction for tir radiation + CALL check_vector_data ('extkb [-] ', extkb ) ! (k, g(mu)/mu) direct solar extinction coefficient + CALL check_vector_data ('extkd [-] ', extkd ) ! diffuse and scattered diffuse PAR extinction coefficient + CALL check_vector_data ('zwt [m] ', zwt ) ! the depth to water table [m] + CALL check_vector_data ('wa [mm] ', wa ) ! water storage in aquifer [mm] + CALL check_vector_data ('wetwat [mm] ', wetwat ) ! water storage in wetland [mm] + CALL check_vector_data ('wdsrf [mm] ', wdsrf ) ! depth of surface water [mm] + CALL check_vector_data ('rss [s/m] ', rss ) ! soil surface resistance [s/m] + CALL check_vector_data ('t_lake [K] ', t_lake )! + CALL check_vector_data ('lake_icefrc [-] ', lake_icefrac)! + CALL check_vector_data ('savedtke1 [W/m K]', savedtke1 )! + CALL check_vector_data ('z_sno [m] ', z_sno ) ! node depth [m] + CALL check_vector_data ('dz_sno [m] ', dz_sno) ! interface depth [m] + CALL check_vector_data ('t_soisno [K] ', t_soisno ) ! soil temperature [K] + CALL check_vector_data ('wliq_soisno [kg/m2]', wliq_soisno) ! liquid water in layers [kg/m2] + CALL check_vector_data ('wice_soisno [kg/m2]', wice_soisno) ! ice lens in layers [kg/m2] + CALL check_vector_data ('smp [mm] ', smp ) ! soil matrix potential [mm] + CALL check_vector_data ('hk [mm/s] ', hk ) ! hydraulic conductivity [mm h2o/s] IF(DEF_USE_PLANTHYDRAULICS)THEN - CALL check_vector_data ('vegwp [m] ', vegwp ) ! vegetation water potential [mm] - CALL check_vector_data ('gs0sun [] ', gs0sun ) ! working copy of sunlit stomata conductance - CALL check_vector_data ('gs0sha [] ', gs0sha ) ! working copy of shalit stomata conductance + CALL check_vector_data ('vegwp [m] ', vegwp ) ! vegetation water potential [mm] + CALL check_vector_data ('gs0sun [] ', gs0sun ) ! working copy of sunlit stomata conductance + CALL check_vector_data ('gs0sha [] ', gs0sha ) ! working copy of shalit stomata conductance ENDIF IF(DEF_USE_OZONESTRESS)THEN - CALL check_vector_data ('o3coefv_sun ', o3coefv_sun) - CALL check_vector_data ('o3coefv_sha ', o3coefv_sha) - CALL check_vector_data ('o3coefg_sun ', o3coefg_sun) - CALL check_vector_data ('o3coefg_sha ', o3coefg_sha) - CALL check_vector_data ('lai_old ', lai_old ) - CALL check_vector_data ('o3uptakesun ', o3uptakesun) - CALL check_vector_data ('o3uptakesha ', o3uptakesha) + CALL check_vector_data ('o3coefv_sun ', o3coefv_sun) + CALL check_vector_data ('o3coefv_sha ', o3coefv_sha) + CALL check_vector_data ('o3coefg_sun ', o3coefg_sun) + CALL check_vector_data ('o3coefg_sha ', o3coefg_sha) + CALL check_vector_data ('lai_old ', lai_old ) + CALL check_vector_data ('o3uptakesun ', o3uptakesun) + CALL check_vector_data ('o3uptakesha ', o3uptakesha) ENDIF IF (DEF_USE_SNICAR) THEN - CALL check_vector_data ('snw_rds [m-6] ', snw_rds ) ! - CALL check_vector_data ('mss_bcpho [Kg] ', mss_bcpho ) ! - CALL check_vector_data ('mss_bcphi [Kg] ', mss_bcphi ) ! - CALL check_vector_data ('mss_ocpho [Kg] ', mss_ocpho ) ! - CALL check_vector_data ('mss_ocphi [Kg] ', mss_ocphi ) ! - CALL check_vector_data ('mss_dst1 [Kg] ', mss_dst1 ) ! - CALL check_vector_data ('mss_dst2 [Kg] ', mss_dst2 ) ! - CALL check_vector_data ('mss_dst3 [Kg] ', mss_dst3 ) ! - CALL check_vector_data ('mss_dst4 [Kg] ', mss_dst4 ) ! - CALL check_vector_data ('ssno_lyr [-] ', ssno_lyr ) ! + CALL check_vector_data ('snw_rds [m-6] ', snw_rds ) ! + CALL check_vector_data ('mss_bcpho [Kg] ', mss_bcpho ) ! + CALL check_vector_data ('mss_bcphi [Kg] ', mss_bcphi ) ! + CALL check_vector_data ('mss_ocpho [Kg] ', mss_ocpho ) ! + CALL check_vector_data ('mss_ocphi [Kg] ', mss_ocphi ) ! + CALL check_vector_data ('mss_dst1 [Kg] ', mss_dst1 ) ! + CALL check_vector_data ('mss_dst2 [Kg] ', mss_dst2 ) ! + CALL check_vector_data ('mss_dst3 [Kg] ', mss_dst3 ) ! + CALL check_vector_data ('mss_dst4 [Kg] ', mss_dst4 ) ! + CALL check_vector_data ('ssno_lyr [-] ', ssno_lyr ) ! ENDIF IF (DEF_USE_IRRIGATION) THEN - CALL check_vector_data ('irrig_rate ' , irrig_rate ) - CALL check_vector_data ('deficit_irrig ' , deficit_irrig ) - CALL check_vector_data ('sum_irrig ' , sum_irrig ) - CALL check_vector_data ('sum_irrig_count ' , sum_irrig_count ) - CALL check_vector_data ('n_irrig_steps_left ' , n_irrig_steps_left ) - CALL check_vector_data ('tairday ' , tairday ) - CALL check_vector_data ('usday ' , usday ) - CALL check_vector_data ('vsday ' , vsday ) - CALL check_vector_data ('pairday ' , pairday ) - CALL check_vector_data ('rnetday ' , rnetday ) - CALL check_vector_data ('fgrndday ' , fgrndday ) - CALL check_vector_data ('potential_evapotranspiration' , potential_evapotranspiration) - CALL check_vector_data ('irrig_method_corn ' , irrig_method_corn ) - CALL check_vector_data ('irrig_method_swheat ' , irrig_method_swheat ) - CALL check_vector_data ('irrig_method_wwheat ' , irrig_method_wwheat ) - CALL check_vector_data ('irrig_method_soybean ' , irrig_method_soybean ) - CALL check_vector_data ('irrig_method_cotton ' , irrig_method_cotton ) - CALL check_vector_data ('irrig_method_rice1 ' , irrig_method_rice1 ) - CALL check_vector_data ('irrig_method_rice2 ' , irrig_method_rice2 ) - CALL check_vector_data ('irrig_method_sugarcane' , irrig_method_sugarcane) + CALL check_vector_data ('irrig_rate ' , irrig_rate ) + CALL check_vector_data ('deficit_irrig ' , deficit_irrig ) + CALL check_vector_data ('sum_irrig ' , sum_irrig ) + CALL check_vector_data ('sum_irrig_count ' , sum_irrig_count ) + CALL check_vector_data ('n_irrig_steps_left ' , n_irrig_steps_left ) + CALL check_vector_data ('tairday ' , tairday ) + CALL check_vector_data ('usday ' , usday ) + CALL check_vector_data ('vsday ' , vsday ) + CALL check_vector_data ('pairday ' , pairday ) + CALL check_vector_data ('rnetday ' , rnetday ) + CALL check_vector_data ('fgrndday ' , fgrndday ) + CALL check_vector_data ('potential_evapotranspiration' , potential_evapotranspiration) + CALL check_vector_data ('irrig_method_corn ' , irrig_method_corn ) + CALL check_vector_data ('irrig_method_swheat ' , irrig_method_swheat ) + CALL check_vector_data ('irrig_method_wwheat ' , irrig_method_wwheat ) + CALL check_vector_data ('irrig_method_soybean ' , irrig_method_soybean ) + CALL check_vector_data ('irrig_method_cotton ' , irrig_method_cotton ) + CALL check_vector_data ('irrig_method_rice1 ' , irrig_method_rice1 ) + CALL check_vector_data ('irrig_method_rice2 ' , irrig_method_rice2 ) + CALL check_vector_data ('irrig_method_sugarcane' , irrig_method_sugarcane) ENDIF #if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) - CALL check_PFTimeVariables + CALL check_PFTimeVariables #endif #if (defined BGC) - CALL check_BGCTimeVariables + CALL check_BGCTimeVariables #endif #ifdef USEMPI - CALL mpi_barrier (p_comm_glb, p_err) + CALL mpi_barrier (p_comm_glb, p_err) #endif END SUBROUTINE check_TimeVariables diff --git a/main/MOD_WetBulb.F90 b/main/MOD_WetBulb.F90 index 50961e98..edc56409 100644 --- a/main/MOD_WetBulb.F90 +++ b/main/MOD_WetBulb.F90 @@ -16,7 +16,7 @@ MODULE MOD_WetBulb !----------------------------------------------------------------------- - subroutine wetbulb(t,p,q,twc) + SUBROUTINE wetbulb(t,p,q,twc) !======================================================================= ! Wet-bulb temperature @@ -24,18 +24,18 @@ subroutine wetbulb(t,p,q,twc) ! Yongjiu Dai, 07/2013 !======================================================================= - use MOD_Precision - use MOD_Const_Physical, only : tfrz, hvap, cpair - USE MOD_Qsadv + USE MOD_Precision + USE MOD_Const_Physical, only : tfrz, hvap, cpair + USE MOD_Qsadv - implicit none - real(r8), intent(in) :: t ! air temperature [K] - real(r8), intent(in) :: p ! atmos pressure [pa] - real(r8), intent(in) :: q ! air specific humidity [kg/kg] - real(r8), intent(out) :: twc ! wet bulb temperature [K] + IMPLICIT NONE + real(r8), intent(in) :: t ! air temperature [K] + real(r8), intent(in) :: p ! atmos pressure [pa] + real(r8), intent(in) :: q ! air specific humidity [kg/kg] + real(r8), intent(out) :: twc ! wet bulb temperature [K] - integer i - real(r8) es, esdT, qs, qsdT, r, rws + integer i + real(r8) es, esdT, qs, qsdT, r, rws ! ---------------------------------------------------------- ! real(r8) tcair ! dry-bulb temperature in celsius @@ -50,7 +50,7 @@ subroutine wetbulb(t,p,q,twc) ! WETBULB computes wet-bulb temperatures from dry-bulb (tkair) and ! vapor pressure of air(ea). routine adapted from e. anderson, p. 188. ! ---------------------------------------------------------- -! call qsadv(t,p,es,esdT,qs,qsdT) +! CALL qsadv(t,p,es,esdT,qs,qsdT) ! rh = min(1.0,q/qs) ! bp = p/100.0 ! mb ! eas = es/100.0 ! mb @@ -62,26 +62,26 @@ subroutine wetbulb(t,p,q,twc) !* eas = 2.7489e8*exp(-4278.63/(tcair+242.792)) !* delt = eas*4278.63/((tcair+242.792)*(tcair+242.792)) ! -! do i = 1, 3 +! DO i = 1, 3 ! twc = delt*tcair+6.6e-4 *bp*tcair+7.59e-7*bp*tcair*tcair+ea-eas ! twc = twc/(delt+6.6e-4*bp+7.59e-7*bp*tcair) ! in celsius ! ! tav = 0.5*(tcair+twc)+tfrz -! call qsadv(tav,p,es,esdT,qs,qsdT) +! CALL qsadv(tav,p,es,esdT,qs,qsdT) ! eav = es/100. ! delt = esdT/100. ! !* tav = 0.5*(tcair+twc) !* eav = 2.7489e8*exp(-4278.63/(tav+242.792)) !* delt = eav*4278.63/((tav+242.792)*(tav+242.792)) -! enddo +! ENDDO ! twc = twc + tfrz ! ---------------------------------------------------------- ! ---------------------------------------------------------- ! the defining equation for the wetbulb temp Twb is ! f(Twb) = Twb-T - Lv/Cp [r-rs(Twb)] = 0, -! where +! WHERE ! T = the dry-bulb temp (K), ! Lv = the latent heat of vaporization (J/kg/K), ! Cp = the specific heat of air at constant pressure, @@ -89,15 +89,15 @@ subroutine wetbulb(t,p,q,twc) ! rs(Twb) = the saturation mixing ratio at wetbulb temp. ! http://www.asp.ucar.edu/colloquium/1992/notes/paet1/node81.html ! ---------------------------------------------------------- - call qsadv(t,p,es,esdT,qs,qsdT) + CALL qsadv(t,p,es,esdT,qs,qsdT) r = q/(1.0-q) - if (q >= qs) r = qs/(1.0-qs) + IF (q >= qs) r = qs/(1.0-qs) twc = t - do i = 1, 6 - call qsadv(twc,p,es,esdT,qs,qsdT) + DO i = 1, 6 + CALL qsadv(twc,p,es,esdT,qs,qsdT) rws= qs/(1.0-qs) twc = (twc + t + hvap/cpair*(r-rws))/2.0 - enddo + ENDDO !*---------------------------------------------------------- !*wetbulb temp as air temp and relative humidity at standard sea level pressure. @@ -105,7 +105,7 @@ subroutine wetbulb(t,p,q,twc) !*relative humidity and air temperature. J. Appl. Meteor. and Climatol., vol 50, 2267-2269. !*---------------------------------------------------------- !* tcair = t - tfrz -!* call qsadv(t,p,es,esdT,qs,qsdT) +!* CALL qsadv(t,p,es,esdT,qs,qsdT) !* rh = min(1.0,q/qs) !* twc = tcair*atan(0.151977*(rh*100.+8.313659)**0.5) & !* + atan(tcair+rh*100.)-atan(rh*100.-1.676331) & @@ -113,6 +113,6 @@ subroutine wetbulb(t,p,q,twc) !* twc = twc + tfrz !*---------------------------------------------------------- - end subroutine wetbulb + END SUBROUTINE wetbulb END MODULE MOD_WetBulb diff --git a/mksrfdata/Aggregation_LAI.F90 b/mksrfdata/Aggregation_LAI.F90 index 16913d48..999c6b79 100644 --- a/mksrfdata/Aggregation_LAI.F90 +++ b/mksrfdata/Aggregation_LAI.F90 @@ -282,8 +282,8 @@ SUBROUTINE Aggregation_LAI (gridlai, dir_rawdata, dir_model_landdata, lc_year) lastdimname = 'Itime', lastdimvalue = itime) #endif #else - ! single point cases - !TODO: parameter input for time year + ! single point cases + !TODO: parameter input for time year IF (DEF_LAI_MONTHLY) THEN SITE_LAI_monthly(itime,iy) = LAI_patches(1) ELSE @@ -459,7 +459,7 @@ SUBROUTINE Aggregation_LAI (gridlai, dir_rawdata, dir_model_landdata, lc_year) CALL aggregation_request_data (landpatch, ipatch, gridlai, zip = USE_zip_for_aggregation, area = area_one, & data_r8_3d_in1 = pftPCT, data_r8_3d_out1 = pct_pft_one, n1_r8_3d_in1 = 16, lb1_r8_3d_in1 = 0, & data_r8_3d_in2 = pftLSAI, data_r8_3d_out2 = lai_pft_one, n1_r8_3d_in2 = 16, lb1_r8_3d_in2 = 0) - + IF (allocated(lai_one)) deallocate(lai_one) allocate(lai_one(size(area_one))) From dbef3000f1cf334bed6943911b9abc070cadce8c Mon Sep 17 00:00:00 2001 From: Hua Yuan Date: Wed, 24 Jan 2024 15:31:00 +0800 Subject: [PATCH 3/4] A bug fix for Urban hydro. -fix(MOD_Urban_Hydrology.F90): a comma error for CaMa Macro. --- main/URBAN/MOD_Urban_Hydrology.F90 | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/main/URBAN/MOD_Urban_Hydrology.F90 b/main/URBAN/MOD_Urban_Hydrology.F90 index 33a5f173..c7224b35 100644 --- a/main/URBAN/MOD_Urban_Hydrology.F90 +++ b/main/URBAN/MOD_Urban_Hydrology.F90 @@ -235,12 +235,12 @@ SUBROUTINE UrbanHydrology ( & 0. ,& ! fsno, not active rsur_gper ,rnof_gper ,qinfl ,wtfact ,& pondmx ,ssi ,wimp ,smpmin ,& - zwt ,wa ,qcharge ,errw_rsub & + zwt ,wa ,qcharge ,errw_rsub ,& #if(defined CaMa_Flood) - ,flddepth ,fldfrc ,qinfl_fld ,& + flddepth ,fldfrc ,qinfl_fld ,& #endif ! SNICAR model variables - ,forc_aer ,& + forc_aer ,& mss_bcpho ,mss_bcphi ,mss_ocpho ,mss_ocphi ,& mss_dst1 ,mss_dst2 ,mss_dst3 ,mss_dst4 & ! END SNICAR model variables From 678af6e9ff25206927f9d883eba90443bc458ba4 Mon Sep 17 00:00:00 2001 From: bnuweinan <110666207+bnuweinan@users.noreply.github.com> Date: Wed, 24 Jan 2024 16:45:13 +0800 Subject: [PATCH 4/4] Update CoLM.F90 Add 3 space at Line 486 --- main/CoLM.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/main/CoLM.F90 b/main/CoLM.F90 index 93263704..fe9831fb 100644 --- a/main/CoLM.F90 +++ b/main/CoLM.F90 @@ -483,7 +483,7 @@ PROGRAM CoLM CALL WRITE_TimeVariables (jdate, lc_year, casename, dir_restart) #endif #if(defined CaMa_Flood) - IF (p_is_master) THEN + IF (p_is_master) THEN CALL colm_cama_write_restart (jdate, lc_year, casename, dir_restart) ENDIF #endif